First take
This commit is contained in:
parent
e414ca4b0c
commit
3fb5c612c1
90
ghcup.cabal
90
ghcup.cabal
@ -1,35 +1,97 @@
|
|||||||
cabal-version: 2.0
|
cabal-version: 2.2
|
||||||
-- Initial package description 'ghcup.cabal' generated by 'cabal init'.
|
|
||||||
-- For further documentation, see http://haskell.org/cabal/users-guide/
|
|
||||||
|
|
||||||
name: ghcup
|
name: ghcup
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
synopsis: ghc toolchain installer as an exe/library
|
synopsis: ghc toolchain installer as an exe/library
|
||||||
-- description:
|
description: A rewrite of the shell script ghcup, for providing
|
||||||
|
a more stable user experience and exposing an API.
|
||||||
homepage: https://github.com/hasufell/ghcup-hs
|
homepage: https://github.com/hasufell/ghcup-hs
|
||||||
-- bug-reports:
|
bug-reports: https://github.com/hasufell/ghcup-hs/issues
|
||||||
license: LGPL-3
|
license: LGPL-3.0-only
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Julian Ospald
|
author: Julian Ospald
|
||||||
maintainer: hasufell@posteo.de
|
maintainer: hasufell@posteo.de
|
||||||
-- copyright:
|
copyright: Julian Ospald 2020
|
||||||
category: System
|
category: System
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
extra-source-files: CHANGELOG.md
|
extra-source-files: CHANGELOG.md
|
||||||
|
|
||||||
library
|
source-repository head
|
||||||
exposed-modules: MyLib
|
type: git
|
||||||
-- other-modules:
|
location: https://github.com/hasufell/ghcup-hs
|
||||||
-- other-extensions:
|
|
||||||
build-depends: base ^>=4.12.0.0
|
common ascii-string { build-depends: ascii-string >= 1.0 }
|
||||||
hs-source-dirs: lib
|
common base { build-depends: base >= 4.12.0.0 && < 5 }
|
||||||
|
common bytestring { build-depends: bytestring >= 0.10 }
|
||||||
|
common containers { build-depends: containers >= 0.6 }
|
||||||
|
common generics-sop { build-depends: generics-sop >= 0.5 }
|
||||||
|
common hpath { build-depends: hpath >= 0.10.1 }
|
||||||
|
common hpath-filepath { build-depends: hpath-filepath >= 0.10 }
|
||||||
|
common hpath-io { build-depends: hpath-io >= 0.10.1 }
|
||||||
|
common language-bash { build-depends: language-bash >= 0.9 }
|
||||||
|
common optics { build-depends: optics >= 0.2 }
|
||||||
|
common parsec { build-depends: parsec >= 3.1 }
|
||||||
|
common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
|
||||||
|
common streamly { build-depends: streamly >= 0.7 }
|
||||||
|
common strict-base { build-depends: strict-base >= 0.4 }
|
||||||
|
common template-haskell { build-depends: template-haskell >= 2.7 }
|
||||||
|
common text { build-depends: text >= 1.2 }
|
||||||
|
common transformers { build-depends: transformers >= 0.5 }
|
||||||
|
common unix { build-depends: unix >= 2.7 }
|
||||||
|
common url { build-depends: url >= 2.1 }
|
||||||
|
common utf8-string { build-depends: utf8-string >= 1.0 }
|
||||||
|
common vector { build-depends: vector >= 0.12 }
|
||||||
|
common waargonaut { build-depends: waargonaut >= 0.8 }
|
||||||
|
|
||||||
|
|
||||||
|
common config
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
|
||||||
|
default-extensions: LambdaCase, MultiWayIf, ScopedTypeVariables, StrictData, Strict, TupleSections
|
||||||
|
|
||||||
|
library
|
||||||
|
import: config
|
||||||
|
, base
|
||||||
|
-- deps
|
||||||
|
, ascii-string
|
||||||
|
, bytestring
|
||||||
|
, containers
|
||||||
|
, generics-sop
|
||||||
|
, hpath
|
||||||
|
, hpath-filepath
|
||||||
|
, hpath-io
|
||||||
|
, language-bash
|
||||||
|
, optics
|
||||||
|
, parsec
|
||||||
|
, safe-exceptions
|
||||||
|
, streamly
|
||||||
|
, strict-base
|
||||||
|
, template-haskell
|
||||||
|
, text
|
||||||
|
, transformers
|
||||||
|
, unix
|
||||||
|
, url
|
||||||
|
, utf8-string
|
||||||
|
, vector
|
||||||
|
, waargonaut
|
||||||
|
exposed-modules: GHCup
|
||||||
|
GHCup.Bash
|
||||||
|
GHCup.File
|
||||||
|
GHCup.Prelude
|
||||||
|
GHCup.Types
|
||||||
|
GHCup.Types.JSON
|
||||||
|
GHCup.Types.Optics
|
||||||
|
other-modules: Streamly.ByteString
|
||||||
|
-- other-extensions:
|
||||||
|
hs-source-dirs: lib
|
||||||
|
|
||||||
executable ghcup
|
executable ghcup
|
||||||
|
import: config
|
||||||
|
, base
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
build-depends: base ^>=4.12.0.0, ghcup
|
build-depends: ghcup
|
||||||
hs-source-dirs: app
|
hs-source-dirs: app
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
169
lib/GHCup.hs
Normal file
169
lib/GHCup.hs
Normal file
@ -0,0 +1,169 @@
|
|||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
|
||||||
|
-- TODO: handle SIGTERM, SIGUSR
|
||||||
|
module GHCup where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Data.Strict.Maybe
|
||||||
|
import Data.Version
|
||||||
|
import GHCup.Prelude
|
||||||
|
import GHCup.Bash
|
||||||
|
import GHCup.File
|
||||||
|
import GHCup.Types
|
||||||
|
import GHCup.Types.Optics
|
||||||
|
import HPath
|
||||||
|
import HPath.IO
|
||||||
|
import Network.URL
|
||||||
|
import qualified Data.ByteString.Lazy.UTF8 as UTF8
|
||||||
|
import Optics
|
||||||
|
import Prelude hiding ( abs
|
||||||
|
, Maybe
|
||||||
|
, Just
|
||||||
|
, Nothing
|
||||||
|
)
|
||||||
|
import System.Info
|
||||||
|
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
import qualified GHC.Exts as GE
|
||||||
|
import qualified Prelude as P
|
||||||
|
import qualified System.Posix.Process.ByteString
|
||||||
|
as SPPB
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
availableDownloads :: AvailableDownloads
|
||||||
|
availableDownloads = Map.fromList
|
||||||
|
[ ( GHC
|
||||||
|
, Map.fromList
|
||||||
|
[ ( mkV [8, 6, 5]
|
||||||
|
, Map.fromList
|
||||||
|
[ ( A_64
|
||||||
|
, Map.fromList
|
||||||
|
[ ( Linux UnknownLinux
|
||||||
|
, mkGHCUrl "~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz"
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
]
|
||||||
|
)
|
||||||
|
]
|
||||||
|
where
|
||||||
|
mkV = makeVersion
|
||||||
|
mkGHCUrl path = URL
|
||||||
|
{ url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" P.Nothing
|
||||||
|
, url_path = path
|
||||||
|
, url_params = []
|
||||||
|
}
|
||||||
|
|
||||||
|
downloadURL :: Tool
|
||||||
|
-> Version
|
||||||
|
-> Architecture
|
||||||
|
-> Platform
|
||||||
|
-> AvailableDownloads
|
||||||
|
-> Maybe URL
|
||||||
|
downloadURL t v a p dls = with_distro <|> without_ver <|> without_distro
|
||||||
|
|
||||||
|
where
|
||||||
|
with_distro = distro_preview id
|
||||||
|
without_distro = distro_preview withoutDistro
|
||||||
|
without_ver = distro_preview withoutVer
|
||||||
|
|
||||||
|
distro_preview f =
|
||||||
|
toStrictMaybe $ preview (atJust t % atJust v % atJust a % atJust (f p)) dls
|
||||||
|
atJust x = at x % _Just
|
||||||
|
|
||||||
|
-- | If we can't find a version with the given distro,
|
||||||
|
-- then just try with the platform.
|
||||||
|
withoutDistro :: Platform -> Platform
|
||||||
|
withoutDistro (Linux _) = Linux UnknownLinux
|
||||||
|
withoutDistro Darwin = Darwin
|
||||||
|
withoutDistro (FreeBSD _) = FreeBSD Nothing
|
||||||
|
|
||||||
|
-- | If we can't find a match with the given distro version,
|
||||||
|
-- we gotta try without it.
|
||||||
|
withoutVer :: Platform -> Platform
|
||||||
|
withoutVer (Linux (Debian _) ) = Linux $ Debian Nothing
|
||||||
|
withoutVer (Linux (Ubuntu _) ) = Linux $ Ubuntu Nothing
|
||||||
|
withoutVer (Linux (Mint _) ) = Linux $ Mint Nothing
|
||||||
|
withoutVer (Linux (Fedora _) ) = Linux $ Fedora Nothing
|
||||||
|
withoutVer (Linux UnknownLinux) = Linux $ UnknownLinux
|
||||||
|
withoutVer Darwin = Darwin
|
||||||
|
withoutVer (FreeBSD _) = FreeBSD Nothing
|
||||||
|
|
||||||
|
|
||||||
|
getArchitecture :: IO Architecture
|
||||||
|
getArchitecture = case arch of
|
||||||
|
"x86_64" -> pure A_64
|
||||||
|
"i386" -> pure A_32
|
||||||
|
what -> fail ("Could not find compatible architecture. Was: " <> what)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
getPlatform :: IO Platform
|
||||||
|
getPlatform = case os of
|
||||||
|
"linux" -> do
|
||||||
|
distro <- getLinuxDistro
|
||||||
|
pure $ Linux distro
|
||||||
|
-- TODO: these are not verified
|
||||||
|
"darwin" -> pure $ Darwin
|
||||||
|
"freebsd" -> do
|
||||||
|
ver <- getFreeBSDVersion
|
||||||
|
pure $ FreeBSD ver
|
||||||
|
what -> fail ("Could not find compatible platform. Was: " <> what)
|
||||||
|
|
||||||
|
where
|
||||||
|
getLinuxDistro :: IO LinuxDistro
|
||||||
|
getLinuxDistro = do
|
||||||
|
let os_release = [abs|/etc/os-release|]
|
||||||
|
lsb_release = [abs|/etc/lsb-release|]
|
||||||
|
redhat_release = [abs|/etc/redhat-release|]
|
||||||
|
debian_version = [abs|/etc/debian_version|]
|
||||||
|
|
||||||
|
pure undefined
|
||||||
|
|
||||||
|
getFreeBSDVersion = pure Nothing
|
||||||
|
|
||||||
|
-- Try various methods for getting distro name and version.
|
||||||
|
-- Failure is signalled with an IO exception.
|
||||||
|
try_os_release :: IO (String, P.Maybe String)
|
||||||
|
try_os_release = do
|
||||||
|
name <- getAssignmentValueFor [abs|/etc/os-release|] "NAME" >>= \case
|
||||||
|
P.Just s -> pure $ s
|
||||||
|
P.Nothing -> fail "No value found"
|
||||||
|
version <- getAssignmentValueFor [abs|/etc/os-release|] "VERSION_ID"
|
||||||
|
pure (name, version)
|
||||||
|
|
||||||
|
try_lsb_release_cmd :: IO (String, P.Maybe String)
|
||||||
|
try_lsb_release_cmd = findExecutable ([fn|lsb_release|] :: Path Fn) >>= \case
|
||||||
|
P.Nothing -> fail "lsb_release not found"
|
||||||
|
P.Just path -> do
|
||||||
|
name <- executeOut ([fn|lsb_release|] :: Path Fn) [fS "-si"] >>= \case
|
||||||
|
P.Just (out, _) -> pure out
|
||||||
|
_ -> fail "Barfed output of lsb_release"
|
||||||
|
version <- (fmap . fmap) (UTF8.toString . fst)
|
||||||
|
$ executeOut ([fn|lsb_release|] :: Path Fn) [fS "-si"]
|
||||||
|
pure (UTF8.toString name, version)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- download :: URL -> Path Abs -> IO (Path Abs)
|
||||||
|
-- download = undefined
|
||||||
|
|
||||||
|
-- unpack :: Path Abs -> IO (Path Abs)
|
||||||
|
-- unpack = undefined
|
||||||
|
|
||||||
|
-- install :: DownloadURL -> IO (Path Abs)
|
||||||
|
-- install = undefined
|
||||||
|
|
||||||
|
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
|
||||||
|
-- parseAvailableDownloads = undefined
|
79
lib/GHCup/Bash.hs
Normal file
79
lib/GHCup/Bash.hs
Normal file
@ -0,0 +1,79 @@
|
|||||||
|
module GHCup.Bash where
|
||||||
|
|
||||||
|
import Data.ByteString
|
||||||
|
import Language.Bash.Parse.Word
|
||||||
|
import Language.Bash.Word
|
||||||
|
import Language.Bash.Syntax
|
||||||
|
import Text.Parsec
|
||||||
|
import HPath
|
||||||
|
import Data.ByteString.UTF8 ( toString )
|
||||||
|
import Streamly
|
||||||
|
import GHCup.File
|
||||||
|
import GHCup.Prelude ( internalError )
|
||||||
|
import qualified Streamly.Prelude as S
|
||||||
|
import Control.Monad
|
||||||
|
import Data.Maybe
|
||||||
|
|
||||||
|
|
||||||
|
-- | Parse a single assignment of the given line.
|
||||||
|
parseAssignment :: SourceName -- ^ file/location of the parser
|
||||||
|
-> ByteString -- ^ the line as a bytestring
|
||||||
|
-> Either ParseError Assign
|
||||||
|
parseAssignment = runParser assign ()
|
||||||
|
|
||||||
|
|
||||||
|
-- | Parse assignments in a stream.
|
||||||
|
parseAssignments :: Monad m
|
||||||
|
=> SourceName -- ^ file/location of the parser
|
||||||
|
-> SerialT m (ByteString)
|
||||||
|
-> SerialT m (Either ParseError Assign)
|
||||||
|
parseAssignments sn = fmap (parseAssignment sn)
|
||||||
|
|
||||||
|
|
||||||
|
-- | Find an assignment matching the predicate in the given file.
|
||||||
|
findAssignment :: Path b
|
||||||
|
-> (Assign -> Bool) -- ^ predicate
|
||||||
|
-> IO (Maybe Assign)
|
||||||
|
findAssignment p predicate = do
|
||||||
|
let fn' = toString . toFilePath $ p
|
||||||
|
stream <- fmap (parseAssignments fn') $ readFileLines p
|
||||||
|
res <-
|
||||||
|
S.find -- empties the stream on first match, but doesn't terminate it
|
||||||
|
(\case
|
||||||
|
Right ass -> predicate ass
|
||||||
|
Left _ -> False
|
||||||
|
)
|
||||||
|
stream
|
||||||
|
>>= \case
|
||||||
|
Just (Right x) -> pure (Just x)
|
||||||
|
Just (Left _) ->
|
||||||
|
internalError "unexpected Left in findAssignment"
|
||||||
|
Nothing -> pure Nothing
|
||||||
|
-- Closes the file handle. Because if there was a match, then
|
||||||
|
-- the stream is not terminated.
|
||||||
|
when (isJust res) $ S.drain stream
|
||||||
|
pure res
|
||||||
|
|
||||||
|
|
||||||
|
-- | Check that the assignment is of the form Foo= ignoring the
|
||||||
|
-- right hand-side.
|
||||||
|
equalsAssignmentWith :: String -> Assign -> Bool
|
||||||
|
equalsAssignmentWith n ass = case ass of
|
||||||
|
(Assign (Parameter name' Nothing) Equals _) -> n == name'
|
||||||
|
_ -> False
|
||||||
|
|
||||||
|
|
||||||
|
-- | This pretty-prints the right hand of an Equals assignment, removing
|
||||||
|
-- quotations. No evaluation is performed.
|
||||||
|
getRValue :: Assign -> Maybe String
|
||||||
|
getRValue ass = case ass of
|
||||||
|
(Assign (Parameter _ _) Equals (RValue w)) -> Just $ unquote w
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
|
|
||||||
|
-- | Given a bash assignment such as Foo="Bar" in the given file,
|
||||||
|
-- will return "Bar" (without quotations).
|
||||||
|
getAssignmentValueFor :: Path b -> String -> IO (Maybe String)
|
||||||
|
getAssignmentValueFor p n = do
|
||||||
|
mass <- findAssignment p (equalsAssignmentWith n)
|
||||||
|
pure (mass >>= getRValue)
|
133
lib/GHCup/File.hs
Normal file
133
lib/GHCup/File.hs
Normal file
@ -0,0 +1,133 @@
|
|||||||
|
module GHCup.File where
|
||||||
|
|
||||||
|
import Data.ByteString hiding (putStrLn)
|
||||||
|
import qualified Data.ByteString.Lazy as L
|
||||||
|
import Data.Char
|
||||||
|
import Data.Maybe
|
||||||
|
import HPath
|
||||||
|
import HPath.IO
|
||||||
|
import Streamly.ByteString
|
||||||
|
import Streamly
|
||||||
|
import System.Posix.FilePath hiding ( (</>) )
|
||||||
|
import Data.Foldable
|
||||||
|
import Control.Monad
|
||||||
|
import Control.Exception.Safe
|
||||||
|
import Data.Functor
|
||||||
|
import System.Posix.Files.ByteString
|
||||||
|
import System.Posix.IO.ByteString hiding (openFd)
|
||||||
|
import qualified System.Posix.Process.ByteString
|
||||||
|
as SPPB
|
||||||
|
import System.Posix.Types
|
||||||
|
|
||||||
|
import qualified Streamly.Internal.Memory.ArrayStream
|
||||||
|
as AS
|
||||||
|
import qualified Streamly.FileSystem.Handle as FH
|
||||||
|
import qualified Streamly.Internal.Data.Unfold as SU
|
||||||
|
import qualified Streamly.Prelude as S
|
||||||
|
import System.IO
|
||||||
|
import System.Exit
|
||||||
|
import qualified Streamly.Data.Fold as FL
|
||||||
|
import Data.ByteString.Builder
|
||||||
|
import Foreign.C.Error
|
||||||
|
import GHCup.Prelude
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
|
import HPath.Internal
|
||||||
|
import System.Posix.FD
|
||||||
|
(
|
||||||
|
openFd
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- |Checks whether a file is executable. Follows symlinks.
|
||||||
|
--
|
||||||
|
-- Only eACCES, eROFS, eTXTBSY, ePERM are catched (and return False).
|
||||||
|
--
|
||||||
|
-- Throws:
|
||||||
|
--
|
||||||
|
-- - `NoSuchThing` if the file does not exist
|
||||||
|
--
|
||||||
|
-- Note: calls `access`
|
||||||
|
isExecutable :: Path b -> IO Bool
|
||||||
|
isExecutable p = fileAccess (toFilePath p) False False True
|
||||||
|
|
||||||
|
|
||||||
|
readFd :: Fd -> IO L.ByteString
|
||||||
|
readFd fd = do
|
||||||
|
handle' <- fdToHandle fd
|
||||||
|
let stream =
|
||||||
|
(S.unfold (SU.finally hClose FH.readChunks) handle')
|
||||||
|
>>= arrayToByteString
|
||||||
|
toLazyByteString <$> S.fold FL.mconcat (fmap byteString stream)
|
||||||
|
|
||||||
|
|
||||||
|
-- | Read the lines of a file into a stream. The stream holds
|
||||||
|
-- a file handle as a resource and will close it once the stream
|
||||||
|
-- terminates (either through exception or because it's drained).
|
||||||
|
readFileLines :: Path b -> IO (SerialT IO ByteString)
|
||||||
|
readFileLines p = do
|
||||||
|
stream <- readFileStream' p
|
||||||
|
pure
|
||||||
|
. (>>= arrayToByteString)
|
||||||
|
. AS.splitOn (fromIntegral $ ord '\n')
|
||||||
|
. (>>= byteStringToArray)
|
||||||
|
$ stream
|
||||||
|
where
|
||||||
|
readFileStream' :: Path b
|
||||||
|
-> IO (SerialT IO ByteString)
|
||||||
|
readFileStream' (MkPath fp) = do
|
||||||
|
fd <- openFd fp ReadOnly [] Nothing
|
||||||
|
handle' <- fdToHandle fd
|
||||||
|
let stream = (S.unfold (SU.finally (\x -> putStrLn "hClose" >> hClose x) FH.readChunks) handle') >>= arrayToByteString
|
||||||
|
pure stream
|
||||||
|
|
||||||
|
|
||||||
|
-- | Find the given executable by searching all *absolute* PATH components.
|
||||||
|
-- Relative paths in PATH are ignored.
|
||||||
|
--
|
||||||
|
-- This shouldn't throw IO exceptions, unless getting the environment variable
|
||||||
|
-- PATH does.
|
||||||
|
findExecutable :: RelC r => Path r -> IO (Maybe (Path Abs))
|
||||||
|
findExecutable ex = do
|
||||||
|
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
|
||||||
|
-- We don't want exceptions to mess up our result. If we can't
|
||||||
|
-- figure out if a file exists, then treat it as a negative result.
|
||||||
|
asum $ fmap (handleIOError (\_ -> pure Nothing)) $ fmap
|
||||||
|
-- asum for short-circuiting behavior
|
||||||
|
(\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex)))
|
||||||
|
sPaths
|
||||||
|
|
||||||
|
|
||||||
|
findExecutablee :: RelC r => Path r -> IO (Maybe (Path Abs))
|
||||||
|
findExecutablee ex = do
|
||||||
|
sPaths <- mapMaybe parseAbs <$> getSearchPath
|
||||||
|
runMaybeT $ asum (MaybeT . eExists <$> sPaths)
|
||||||
|
where
|
||||||
|
eExists sp = let path = sp </> ex in handleIOError (pure $ pure Nothing) $ Just path <$ doesFileExist path
|
||||||
|
|
||||||
|
|
||||||
|
-- TODO: fd leak
|
||||||
|
-- | Execute the given command and collect the stdout and the exit code.
|
||||||
|
executeOut :: Path Fn -- ^ command as filename, e.g. 'ls'
|
||||||
|
-> [ByteString] -- ^ arguments to the command
|
||||||
|
-> IO (Maybe (L.ByteString, ExitCode)) -- ^ fst of the tuple is the stdout
|
||||||
|
executeOut path args = withFnPath path $ \fp -> do
|
||||||
|
(readE, writeE) <- createPipe
|
||||||
|
pid <- SPPB.forkProcess $ do
|
||||||
|
whileM_
|
||||||
|
(dupTo writeE stdOutput)
|
||||||
|
(\r ->
|
||||||
|
getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR
|
||||||
|
)
|
||||||
|
closeFd writeE
|
||||||
|
closeFd readE
|
||||||
|
SPPB.executeFile fp True args Nothing
|
||||||
|
|
||||||
|
closeFd writeE
|
||||||
|
|
||||||
|
-- readFd will take care of closing the fd
|
||||||
|
SPPB.getProcessStatus True True pid >>= \case
|
||||||
|
Just (SPPB.Exited es) -> do
|
||||||
|
out <- readFd readE
|
||||||
|
pure $ Just (out, es)
|
||||||
|
_ -> pure Nothing
|
66
lib/GHCup/Prelude.hs
Normal file
66
lib/GHCup/Prelude.hs
Normal file
@ -0,0 +1,66 @@
|
|||||||
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
|
module GHCup.Prelude where
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Data.Strict.Maybe
|
||||||
|
import Data.Monoid ( (<>) )
|
||||||
|
import Prelude ( Monad
|
||||||
|
, Bool
|
||||||
|
, return
|
||||||
|
, (.)
|
||||||
|
, (>>=)
|
||||||
|
)
|
||||||
|
import qualified Prelude as P
|
||||||
|
import Data.String
|
||||||
|
|
||||||
|
|
||||||
|
fS :: IsString a => P.String -> a
|
||||||
|
fS = fromString
|
||||||
|
|
||||||
|
fromStrictMaybe :: Maybe a -> P.Maybe a
|
||||||
|
fromStrictMaybe = maybe P.Nothing P.Just
|
||||||
|
|
||||||
|
toStrictMaybe :: P.Maybe a -> Maybe a
|
||||||
|
toStrictMaybe = P.maybe Nothing Just
|
||||||
|
|
||||||
|
instance Applicative Maybe where
|
||||||
|
pure = Just
|
||||||
|
|
||||||
|
Just f <*> m = P.fmap f m
|
||||||
|
Nothing <*> _m = Nothing
|
||||||
|
|
||||||
|
liftA2 f (Just x) (Just y) = Just (f x y)
|
||||||
|
liftA2 _ _ _ = Nothing
|
||||||
|
|
||||||
|
Just _m1 *> m2 = m2
|
||||||
|
Nothing *> _m2 = Nothing
|
||||||
|
|
||||||
|
instance Alternative Maybe where
|
||||||
|
empty = Nothing
|
||||||
|
Nothing <|> r = r
|
||||||
|
l <|> _ = l
|
||||||
|
|
||||||
|
|
||||||
|
internalError :: P.String -> P.IO a
|
||||||
|
internalError = P.fail . ("Internal error: " <>)
|
||||||
|
|
||||||
|
-- | Like 'when', but where the test can be monadic.
|
||||||
|
whenM :: Monad m => m Bool -> m () -> m ()
|
||||||
|
whenM ~b ~t = ifM b t (return ())
|
||||||
|
|
||||||
|
-- | Like 'unless', but where the test can be monadic.
|
||||||
|
unlessM :: Monad m => m Bool -> m () -> m ()
|
||||||
|
unlessM ~b ~f = ifM b (return ()) f
|
||||||
|
|
||||||
|
-- | Like @if@, but where the test can be monadic.
|
||||||
|
ifM :: Monad m => m Bool -> m a -> m a -> m a
|
||||||
|
ifM ~b ~t ~f = do
|
||||||
|
b' <- b
|
||||||
|
if b' then t else f
|
||||||
|
|
||||||
|
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
|
||||||
|
whileM_ action f = whenM (action >>= f) (whileM_ action f)
|
||||||
|
|
51
lib/GHCup/Types.hs
Normal file
51
lib/GHCup/Types.hs
Normal file
@ -0,0 +1,51 @@
|
|||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
|
||||||
|
module GHCup.Types where
|
||||||
|
|
||||||
|
import Data.Map.Strict (Map)
|
||||||
|
import Data.Strict.Maybe
|
||||||
|
import Data.Text
|
||||||
|
import Data.Version
|
||||||
|
import Network.URL
|
||||||
|
import Prelude hiding (
|
||||||
|
Maybe
|
||||||
|
, Just
|
||||||
|
, Nothing)
|
||||||
|
|
||||||
|
import qualified GHC.Generics as GHC
|
||||||
|
|
||||||
|
|
||||||
|
-- | Requested tool to be installed. User input.
|
||||||
|
data Tool = GHC
|
||||||
|
| Cabal
|
||||||
|
| Stack
|
||||||
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
-- | Architecture we run on.
|
||||||
|
data Architecture = A_64
|
||||||
|
| A_32
|
||||||
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
data LinuxDistro = Debian (Maybe CustomVersion)
|
||||||
|
| Ubuntu (Maybe CustomVersion)
|
||||||
|
| Mint (Maybe CustomVersion)
|
||||||
|
| Fedora (Maybe CustomVersion)
|
||||||
|
-- not known
|
||||||
|
| UnknownLinux
|
||||||
|
-- ^ must exit
|
||||||
|
deriving (Eq, GHC.Generic, Ord, Show)
|
||||||
|
|
||||||
|
|
||||||
|
data Platform = Linux LinuxDistro
|
||||||
|
-- ^ must exit
|
||||||
|
| Darwin
|
||||||
|
-- ^ must exit
|
||||||
|
| FreeBSD (Maybe CustomVersion)
|
||||||
|
deriving (Eq, GHC.Generic, Ord, Show)
|
||||||
|
|
||||||
|
type CustomVersion = Text
|
||||||
|
type PlatformSpec = Map Platform URL
|
||||||
|
type ArchitectureSpec = Map Architecture PlatformSpec
|
||||||
|
type VersionSpec = Map Version ArchitectureSpec
|
||||||
|
type AvailableDownloads = Map Tool VersionSpec
|
||||||
|
|
18
lib/GHCup/Types/Foo.hs
Normal file
18
lib/GHCup/Types/Foo.hs
Normal file
@ -0,0 +1,18 @@
|
|||||||
|
encToJsonNoSpaces
|
||||||
|
:: ( Monoid t
|
||||||
|
, Applicative f
|
||||||
|
)
|
||||||
|
=> AReview Json (b, t)
|
||||||
|
-> (a -> b)
|
||||||
|
-> Encoder f a
|
||||||
|
encToJsonNoSpaces c f =
|
||||||
|
encodeA (pure . review c . (, mempty) . f)
|
||||||
|
|
||||||
|
bytestring :: Applicative f => Encoder f ByteString
|
||||||
|
bytestring = encToJsonNoSpaces _JStr (_JStringBS #)
|
||||||
|
|
||||||
|
_JStringBS :: (Profunctor p, Applicative f)
|
||||||
|
=> p ByteString (f ByteString)
|
||||||
|
-> p JString (f JString)
|
||||||
|
_JStringBS = iso (C.pack . review _JString)
|
||||||
|
(JString' . V.fromList . fmap utf8CharToJChar . C.unpack)
|
40
lib/GHCup/Types/JSON.hs
Normal file
40
lib/GHCup/Types/JSON.hs
Normal file
@ -0,0 +1,40 @@
|
|||||||
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
|
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
|
module GHCup.Types.JSON where
|
||||||
|
|
||||||
|
import Data.Strict.Maybe
|
||||||
|
import GHCup.Types
|
||||||
|
import Generics.SOP.TH
|
||||||
|
import Prelude hiding (
|
||||||
|
Maybe
|
||||||
|
, Just
|
||||||
|
, Nothing)
|
||||||
|
import Waargonaut.Generic (
|
||||||
|
JsonEncode
|
||||||
|
, JsonDecode
|
||||||
|
, GWaarg)
|
||||||
|
|
||||||
|
|
||||||
|
deriveGeneric ''Maybe
|
||||||
|
instance JsonEncode GWaarg a => JsonEncode GWaarg (Maybe a)
|
||||||
|
instance JsonDecode GWaarg a => JsonDecode GWaarg (Maybe a)
|
||||||
|
|
||||||
|
deriveGeneric ''Tool
|
||||||
|
instance JsonEncode GWaarg Tool
|
||||||
|
instance JsonDecode GWaarg Tool
|
||||||
|
|
||||||
|
deriveGeneric ''Architecture
|
||||||
|
instance JsonEncode GWaarg Architecture
|
||||||
|
instance JsonDecode GWaarg Architecture
|
||||||
|
|
||||||
|
deriveGeneric ''LinuxDistro
|
||||||
|
instance JsonEncode GWaarg LinuxDistro
|
||||||
|
instance JsonDecode GWaarg LinuxDistro
|
||||||
|
|
5
lib/GHCup/Types/Optics.hs
Normal file
5
lib/GHCup/Types/Optics.hs
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
|
module GHCup.Types.Optics where
|
||||||
|
|
||||||
|
|
@ -1,4 +0,0 @@
|
|||||||
module MyLib (someFunc) where
|
|
||||||
|
|
||||||
someFunc :: IO ()
|
|
||||||
someFunc = putStrLn "someFunc"
|
|
57
lib/Streamly/ByteString.hs
Normal file
57
lib/Streamly/ByteString.hs
Normal file
@ -0,0 +1,57 @@
|
|||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
|
module Streamly.ByteString where
|
||||||
|
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
import Data.ByteString hiding (length)
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
import Data.ByteString.Unsafe
|
||||||
|
import Data.Word (Word8)
|
||||||
|
import Foreign.ForeignPtr
|
||||||
|
import Foreign.ForeignPtr.Unsafe
|
||||||
|
import Foreign.Ptr (castPtr, minusPtr, plusPtr)
|
||||||
|
import Prelude hiding (length)
|
||||||
|
import Streamly
|
||||||
|
import Streamly.Internal.Memory.Array.Types
|
||||||
|
import Streamly.Memory.Array
|
||||||
|
import qualified Streamly.Prelude as S
|
||||||
|
|
||||||
|
toByteString ::
|
||||||
|
forall m. (MonadIO m, MonadAsync m)
|
||||||
|
=> SerialT m (Array Word8)
|
||||||
|
-> m ByteString
|
||||||
|
toByteString stream =
|
||||||
|
let xs = S.mapM arrayToByteString stream
|
||||||
|
ys = S.foldlM' (\a b -> pure $ a <> b) mempty xs
|
||||||
|
in ys
|
||||||
|
|
||||||
|
arrayToByteString :: (MonadIO m) => Array Word8 -> m ByteString
|
||||||
|
arrayToByteString arr
|
||||||
|
| length arr == 0 = return mempty
|
||||||
|
arrayToByteString Array {..} =
|
||||||
|
liftIO $
|
||||||
|
withForeignPtr aStart $ \ptr ->
|
||||||
|
unsafePackCStringFinalizer ptr aLen (return ())
|
||||||
|
where
|
||||||
|
aLen =
|
||||||
|
let p = unsafeForeignPtrToPtr aStart
|
||||||
|
in aEnd `minusPtr` p
|
||||||
|
|
||||||
|
byteStringToArray :: (MonadIO m) => ByteString -> m (Array Word8)
|
||||||
|
byteStringToArray bs =
|
||||||
|
liftIO $
|
||||||
|
unsafeUseAsCStringLen
|
||||||
|
bs
|
||||||
|
(\(ptr, _) -> do
|
||||||
|
let endPtr pr = (castPtr pr `plusPtr` (BS.length bs))
|
||||||
|
fptr <- newForeignPtr_ (castPtr ptr)
|
||||||
|
return $ Array {aStart = fptr, aEnd = endPtr ptr, aBound = endPtr ptr})
|
||||||
|
|
||||||
|
fromByteString ::
|
||||||
|
forall m. (MonadIO m)
|
||||||
|
=> ByteString
|
||||||
|
-> m (Array Word8)
|
||||||
|
fromByteString bs = byteStringToArray bs
|
Loading…
Reference in New Issue
Block a user