hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Basic version of 'downloadURL'

Browse Source
This commit is contained in:
Julian Ospald 2020-01-16 23:27:38 +01:00
parent 3fb5c612c1
commit 92531045f8
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
12 changed files with 355 additions and 238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
README.md
View File

@ -1 +1,34 @@
# ghcup # ghcup
A rewrite of ghcup in haskell. This can be used as a library
and may be redistributed as a binary in the future.
## Motivation
ghcup has increasingly become difficult to maintain. A few reasons:
* few maintainers
* increasing LOC
* platform incompatibilities regularly causing breaking bugs:
* [Mktemp not working properly on macOS](https://gitlab.haskell.org/haskell/ghcup/issues/130)
* [ln: illegal option -- T on macOS Catalina](https://gitlab.haskell.org/haskell/ghcup/issues/123)
* [Wrong tar flag on darwin](https://gitlab.haskell.org/haskell/ghcup/issues/119))
* refactoring being difficult due to POSIX sh
More benefits of a rewrite:
* Features such as installing [release candidates](https://gitlab.haskell.org/haskell/ghcup/issues/94) or [HEAD builds](https://gitlab.haskell.org/haskell/ghcup/issues/65) can be more conveniently implemented in a rewrite
* Refactoring will be easier
* Better tool support (such as linting the downloads file)
* saner downloads file format (such as JSON)
However, the downside will be:
* building static binaries for all platforms (and possibly causing SSL/DNS problems)
* still bootstrapping those binaries via a POSIX sh script
## Goals
* Correct low-level code
* Good exception handling
* Easier user interface (possibly interactive and non-interactive ones)

12
TODO.md Normal file
View File

@ -0,0 +1,12 @@
# TODOs and Remarks
* handling of SIGTERM and SIGUSR
* add support for RC/alpha/HEAD versions
* redo/rethink how tool tags works
* installing multiple versions in parallel?
* exception handling (checked exception library? Maybe effects system all the way?)
* how to version and extend the format of the downloads file? Compatibility?
* how to propagate updates? Automatically? Might solve the versioning problem

7
cabal.project
View File

@ -1,2 +1,9 @@
packages: ./ghcup.cabal packages: ./ghcup.cabal
optimization: 2
package streamly
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
package ghcup
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16

11
ghcup.cabal
View File

@ -20,6 +20,7 @@ source-repository head
type: git type: git
location: https://github.com/hasufell/ghcup-hs location: https://github.com/hasufell/ghcup-hs
common aeson { build-depends: aeson >= 1.4 }
common ascii-string { build-depends: ascii-string >= 1.0 } common ascii-string { build-depends: ascii-string >= 1.0 }
common base { build-depends: base >= 4.12.0.0 && < 5 } common base { build-depends: base >= 4.12.0.0 && < 5 }
common bytestring { build-depends: bytestring >= 0.10 } common bytestring { build-depends: bytestring >= 0.10 }
@ -36,12 +37,16 @@ common streamly { build-depends: streamly >= 0.7 }
common strict-base { build-depends: strict-base >= 0.4 } common strict-base { build-depends: strict-base >= 0.4 }
common template-haskell { build-depends: template-haskell >= 2.7 } common template-haskell { build-depends: template-haskell >= 2.7 }
common text { build-depends: text >= 1.2 } common text { build-depends: text >= 1.2 }
common text-icu { build-depends: text-icu >= 0.7 }
common transformers { build-depends: transformers >= 0.5 } common transformers { build-depends: transformers >= 0.5 }
common unix { build-depends: unix >= 2.7 } common unix { build-depends: unix >= 2.7 }
common url { build-depends: url >= 2.1 } common url { build-depends: url >= 2.1 }
common utf8-string { build-depends: utf8-string >= 1.0 } common utf8-string { build-depends: utf8-string >= 1.0 }
common vector { build-depends: vector >= 0.12 } common vector { build-depends: vector >= 0.12 }
common waargonaut { build-depends: waargonaut >= 0.8 } common waargonaut { build-depends: waargonaut >= 0.8 }
common async { build-depends: async >= 0.8 }
common mtl { build-depends: mtl >= 2.2 }
common versions { build-depends: versions >= 3.5 }
common config common config
@ -53,7 +58,9 @@ library
import: config import: config
, base , base
-- deps -- deps
, aeson
, ascii-string , ascii-string
, async
, bytestring , bytestring
, containers , containers
, generics-sop , generics-sop
@ -61,6 +68,7 @@ library
, hpath-filepath , hpath-filepath
, hpath-io , hpath-io
, language-bash , language-bash
, mtl
, optics , optics
, parsec , parsec
, safe-exceptions , safe-exceptions
@ -68,12 +76,13 @@ library
, strict-base , strict-base
, template-haskell , template-haskell
, text , text
, text-icu
, transformers , transformers
, unix , unix
, url , url
, utf8-string , utf8-string
, vector , vector
, waargonaut , versions
exposed-modules: GHCup exposed-modules: GHCup
GHCup.Bash GHCup.Bash
GHCup.File GHCup.File

233
lib/GHCup.hs
View File

@ -10,44 +10,46 @@
-- TODO: handle SIGTERM, SIGUSR -- TODO: handle SIGTERM, SIGUSR
module GHCup where module GHCup where
import Control.Applicative import Control.Applicative
import Data.Strict.Maybe import Control.Monad
import Data.Version import Data.Foldable ( asum )
import GHCup.Prelude import Data.Text ( Text )
import Data.Versions
import GHCup.Bash import GHCup.Bash
import GHCup.File import GHCup.File
import GHCup.Prelude
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics import GHCup.Types.Optics
import HPath import HPath
import HPath.IO import HPath.IO
import Network.URL import Network.URL
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import Optics import Optics
import Prelude hiding ( abs import Prelude hiding ( abs
, Maybe , readFile
, Just
, Nothing
) )
import System.Info import System.Info
import qualified Data.Text as T
import qualified Data.Text.ICU as ICU
import Data.Maybe ( isJust )
import qualified Data.Map.Strict as Map 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 :: AvailableDownloads
availableDownloads = Map.fromList availableDownloads = Map.fromList
[ ( GHC [ ( GHC
, Map.fromList , Map.fromList
[ ( mkV [8, 6, 5] [ ( (\(Right x) -> x) $ version (fS "8.6.5")
, Map.fromList , Map.fromList
[ ( A_64 [ ( A_64
, Map.fromList , Map.fromList
[ ( Linux UnknownLinux [ ( Linux UnknownLinux
, mkGHCUrl "~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz" , Map.fromList
[ ( Nothing
, mkGHCUrl
"~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz"
)
]
) )
] ]
) )
@ -57,101 +59,170 @@ availableDownloads = Map.fromList
) )
] ]
where where
mkV = makeVersion
mkGHCUrl path = URL mkGHCUrl path = URL
{ url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" P.Nothing { url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" Nothing
, url_path = path , url_path = path
, url_params = [] , url_params = []
} }
downloadURL :: Tool
-> Version downloadURL :: ToolRequest
-> Architecture -> Maybe PlatformRequest
-> Platform -> URLSource
-> AvailableDownloads -> IO (Maybe URL) -- TODO: better error handling
-> Maybe URL downloadURL (ToolRequest t v) mpfReq urlSource = do
downloadURL t v a p dls = with_distro <|> without_ver <|> without_distro (PlatformRequest arch plat ver) <- case mpfReq of
Just x -> pure x
Nothing -> do
(PlatformResult rp rv) <- getPlatform
let ar = (\(Right x) -> x) getArchitecture
pure $ PlatformRequest ar rp rv
dls <- case urlSource of
GHCupURL -> fail "Not implemented"
OwnSource url -> fail "Not implemented"
OwnSpec dls -> pure dls
pure $ downloadURL' t v arch plat ver dls
downloadURL' :: Tool
-> Version
-- ^ tool version
-> Architecture
-- ^ user arch
-> Platform
-- ^ user platform
-> Maybe Versioning
-- ^ optional version of the platform
-> AvailableDownloads
-> Maybe URL
downloadURL' t v a p mv dls =
with_distro <|> without_distro_ver <|> without_distro
where where
with_distro = distro_preview id with_distro = distro_preview id id
without_distro = distro_preview withoutDistro without_distro = distro_preview (set _Linux UnknownLinux) id
without_ver = distro_preview withoutVer without_distro_ver = distro_preview id (const Nothing)
distro_preview f = distro_preview f g =
toStrictMaybe $ preview (atJust t % atJust v % atJust a % atJust (f p)) dls preview (atJust t % atJust v % atJust a % atJust (f p) % atJust (g mv)) dls
atJust x = at x % _Just 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, getArchitecture :: Either String Architecture
-- 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 getArchitecture = case arch of
"x86_64" -> pure A_64 "x86_64" -> pure A_64
"i386" -> pure A_32 "i386" -> pure A_32
what -> fail ("Could not find compatible architecture. Was: " <> what) what -> Left ("Could not find compatible architecture. Was: " <> what)
getPlatform :: IO Platform getPlatform :: IO PlatformResult
getPlatform = case os of getPlatform = case os of
"linux" -> do "linux" -> do
distro <- getLinuxDistro (distro, ver) <- getLinuxDistro
pure $ Linux distro pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
-- TODO: these are not verified -- TODO: these are not verified
"darwin" -> pure $ Darwin "darwin" ->
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
"freebsd" -> do "freebsd" -> do
ver <- getFreeBSDVersion ver <- getFreeBSDVersion
pure $ FreeBSD ver pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
what -> fail ("Could not find compatible platform. Was: " <> what) what -> fail ("Could not find compatible platform. Was: " <> what)
where getFreeBSDVersion = pure Nothing
getLinuxDistro :: IO (LinuxDistro, Maybe Versioning)
getLinuxDistro = do
(name, ver) <- asum
[ try_os_release
, try_lsb_release_cmd
, try_lsb_release
, try_redhat_release
, try_debian_version
]
let parsedVer = ver >>= either (const Nothing) Just . versioning
distro = if
| hasWord name (T.pack <$> ["debian"]) -> Debian
| hasWord name (T.pack <$> ["ubuntu"]) -> Ubuntu
| hasWord name (T.pack <$> ["linuxmint", "Linux Mint"]) -> Mint
| hasWord name (T.pack <$> ["fedora"]) -> Fedora
| hasWord name (T.pack <$> ["centos"]) -> CentOS
| hasWord name (T.pack <$> ["Red Hat"]) -> RedHat
| hasWord name (T.pack <$> ["alpine"]) -> Alpine
| hasWord name (T.pack <$> ["exherbo"]) -> Exherbo
| hasWord name (T.pack <$> ["gentoo"]) -> Gentoo
| otherwise -> UnknownLinux
pure (distro, parsedVer)
where where
getLinuxDistro :: IO LinuxDistro hasWord t matches = foldr
getLinuxDistro = do (\x y ->
let os_release = [abs|/etc/os-release|] ( isJust
lsb_release = [abs|/etc/lsb-release|] . ICU.find (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> x <> fS "\\b"))
redhat_release = [abs|/etc/redhat-release|] $ t
debian_version = [abs|/etc/debian_version|] )
|| y
)
False
matches
pure undefined os_release :: Path Abs
os_release = [abs|/etc/os-release|]
lsb_release :: Path Abs
lsb_release = [abs|/etc/lsb-release|]
lsb_release_cmd :: Path Fn
lsb_release_cmd = [fn|lsb-release|]
redhat_release :: Path Abs
redhat_release = [abs|/etc/redhat-release|]
debian_version :: Path Abs
debian_version = [abs|/etc/debian_version|]
getFreeBSDVersion = pure Nothing try_os_release :: IO (Text, Maybe Text)
try_os_release = do
(Just name) <- getAssignmentValueFor os_release "NAME"
ver <- getAssignmentValueFor os_release "VERSION_ID"
pure (T.pack name, fmap T.pack ver)
-- Try various methods for getting distro name and version. try_lsb_release_cmd :: IO (Text, Maybe Text)
-- Failure is signalled with an IO exception. try_lsb_release_cmd = do
try_os_release :: IO (String, P.Maybe String) (Just _ ) <- findExecutable lsb_release_cmd
try_os_release = do (Just (name, _)) <- executeOut lsb_release_cmd [fS "-si"]
name <- getAssignmentValueFor [abs|/etc/os-release|] "NAME" >>= \case ver <- executeOut lsb_release_cmd [fS "-sr"]
P.Just s -> pure $ s pure (lBS2sT name, fmap (lBS2sT . fst) ver)
P.Nothing -> fail "No value found"
version <- getAssignmentValueFor [abs|/etc/os-release|] "VERSION_ID" try_lsb_release :: IO (Text, Maybe Text)
pure (name, version) try_lsb_release = do
(Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
ver <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
pure (T.pack name, fmap T.pack ver)
try_redhat_release :: IO (Text, Maybe Text)
try_redhat_release = do
t <- fmap lBS2sT $ readFile redhat_release
let nameRe n =
join
. fmap (ICU.group 0)
. ICU.find
(ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> fS n <> fS "\\b")
)
$ t
verRe =
join
. fmap (ICU.group 0)
. ICU.find
(ICU.regex [ICU.CaseInsensitive] (fS "\\b(\\d)+(.(\\d)+)*\\b"))
$ t
(Just name) <- pure
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
pure (name, verRe)
try_debian_version :: IO (Text, Maybe Text)
try_debian_version = do
True <- doesFileExist debian_version
ver <- readFile debian_version
pure (T.pack "debian", Just $ lBS2sT ver)
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)

75
lib/GHCup/Bash.hs
View File

@ -1,58 +1,47 @@
module GHCup.Bash where module GHCup.Bash
( findAssignment
, equalsAssignmentWith
, getRValue
, getAssignmentValueFor
)
where
import Data.ByteString import Language.Bash.Parse
import Language.Bash.Parse.Word
import Language.Bash.Word import Language.Bash.Word
import Language.Bash.Syntax import Language.Bash.Syntax
import Text.Parsec
import HPath import HPath
import HPath.IO
import Data.ByteString.UTF8 ( toString ) import Data.ByteString.UTF8 ( toString )
import Streamly import Control.Monad
import GHCup.File import Data.Maybe
import GHCup.Prelude ( internalError ) import qualified Data.ByteString.Lazy.UTF8 as UTF8
import qualified Streamly.Prelude as S import Prelude hiding ( readFile )
import Control.Monad import Data.List
import Data.Maybe
-- | Parse a single assignment of the given line. extractAssignments :: List -> [Assign]
parseAssignment :: SourceName -- ^ file/location of the parser extractAssignments (List stms) = join $ fmap getAssign $ getCommands stms
-> ByteString -- ^ the line as a bytestring where
-> Either ParseError Assign getCommands :: [Statement] -> [Command]
parseAssignment = runParser assign () getCommands = join . fmap commands . catMaybes . fmap findPipes
where
findPipes (Statement (Last p@(Pipeline{})) Sequential) = Just p
findPipes _ = Nothing
getAssign :: Command -> [Assign]
-- | Parse assignments in a stream. getAssign (Command (SimpleCommand ass _) _) = ass
parseAssignments :: Monad m getAssign _ = []
=> 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. -- | Find an assignment matching the predicate in the given file.
findAssignment :: Path b findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign)
-> (Assign -> Bool) -- ^ predicate
-> IO (Maybe Assign)
findAssignment p predicate = do findAssignment p predicate = do
let fn' = toString . toFilePath $ p fileContents <- readFile p
stream <- fmap (parseAssignments fn') $ readFileLines p -- TODO: this should accept bytestring:
res <- -- https://github.com/knrafto/language-bash/issues/37
S.find -- empties the stream on first match, but doesn't terminate it case parse (toString . toFilePath $ p) (UTF8.toString fileContents) of
(\case Left e -> fail $ show e
Right ass -> predicate ass Right l -> pure $ find predicate (extractAssignments $ l)
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 -- | Check that the assignment is of the form Foo= ignoring the

56
lib/GHCup/File.hs
View File

@ -1,6 +1,6 @@
module GHCup.File where module GHCup.File where
import Data.ByteString hiding (putStrLn) import Data.ByteString
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.Char import Data.Char
import Data.Maybe import Data.Maybe
@ -14,7 +14,9 @@ import Control.Monad
import Control.Exception.Safe import Control.Exception.Safe
import Data.Functor import Data.Functor
import System.Posix.Files.ByteString import System.Posix.Files.ByteString
import System.Posix.IO.ByteString hiding (openFd) import System.IO
import System.Posix.IO.ByteString
hiding ( openFd )
import qualified System.Posix.Process.ByteString import qualified System.Posix.Process.ByteString
as SPPB as SPPB
import System.Posix.Types import System.Posix.Types
@ -24,19 +26,11 @@ import qualified Streamly.Internal.Memory.ArrayStream
import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S import qualified Streamly.Prelude as S
import System.IO
import System.Exit import System.Exit
import qualified Streamly.Data.Fold as FL import qualified Streamly.Data.Fold as FL
import Data.ByteString.Builder import Data.ByteString.Builder
import Foreign.C.Error import Foreign.C.Error
import GHCup.Prelude import GHCup.Prelude
import Control.Monad.Trans.Maybe
import HPath.Internal
import System.Posix.FD
(
openFd
)
-- |Checks whether a file is executable. Follows symlinks. -- |Checks whether a file is executable. Follows symlinks.
@ -66,20 +60,12 @@ readFd fd = do
-- terminates (either through exception or because it's drained). -- terminates (either through exception or because it's drained).
readFileLines :: Path b -> IO (SerialT IO ByteString) readFileLines :: Path b -> IO (SerialT IO ByteString)
readFileLines p = do readFileLines p = do
stream <- readFileStream' p stream <- readFileStream p
pure pure
. (>>= arrayToByteString) . (>>= arrayToByteString)
. AS.splitOn (fromIntegral $ ord '\n') . AS.splitOn (fromIntegral $ ord '\n')
. (>>= byteStringToArray) . (>>= byteStringToArray)
$ stream $ 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. -- | Find the given executable by searching all *absolute* PATH components.
@ -92,42 +78,32 @@ findExecutable ex = do
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
-- We don't want exceptions to mess up our result. If we can't -- 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. -- figure out if a file exists, then treat it as a negative result.
asum $ fmap (handleIOError (\_ -> pure Nothing)) $ fmap asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
-- asum for short-circuiting behavior -- asum for short-circuiting behavior
(\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex))) (\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex)))
sPaths 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. -- | Execute the given command and collect the stdout and the exit code.
executeOut :: Path Fn -- ^ command as filename, e.g. 'ls' executeOut :: Path Fn -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command -> [ByteString] -- ^ arguments to the command
-> IO (Maybe (L.ByteString, ExitCode)) -- ^ fst of the tuple is the stdout -> IO (Maybe (L.ByteString, ExitCode)) -- ^ fst of the tuple is the stdout
executeOut path args = withFnPath path $ \fp -> do executeOut path args = withFnPath path $ \fp -> do
(readE, writeE) <- createPipe (parentRead, childWrite) <- createPipe
pid <- SPPB.forkProcess $ do pid <- SPPB.forkProcess $ do
whileM_ whileM_
(dupTo writeE stdOutput) (dupTo childWrite stdOutput)
(\r -> (\r ->
getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR
) )
closeFd writeE closeFd childWrite
closeFd readE closeFd parentRead
closeFd stdInput
SPPB.executeFile fp True args Nothing SPPB.executeFile fp True args Nothing
closeFd writeE closeFd childWrite
-- readFd will take care of closing the fd
SPPB.getProcessStatus True True pid >>= \case SPPB.getProcessStatus True True pid >>= \case
Just (SPPB.Exited es) -> do -- readE will take care of closing the fd
out <- readFd readE Just (SPPB.Exited es) -> readFd parentRead <&> Just . (, es)
pure $ Just (out, es) _ -> closeFd parentRead $> Nothing
_ -> pure Nothing

30
lib/GHCup/Prelude.hs
View File

@ -5,16 +5,21 @@
module GHCup.Prelude where module GHCup.Prelude where
import Control.Applicative import Control.Applicative
import Control.Monad
import Data.Strict.Maybe import Data.Strict.Maybe
import Data.Monoid ( (<>) ) import Data.Monoid ( (<>) )
import Prelude ( Monad import Prelude ( Monad
, Bool , Bool
, return , return
, (.) , (.)
, (>>=)
) )
import qualified Prelude as P import qualified Prelude as P
import Data.String import Data.String
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.Lazy as TL
import Data.Text ( Text )
import qualified Data.ByteString.Lazy as L
fS :: IsString a => P.String -> a fS :: IsString a => P.String -> a
@ -23,9 +28,15 @@ fS = fromString
fromStrictMaybe :: Maybe a -> P.Maybe a fromStrictMaybe :: Maybe a -> P.Maybe a
fromStrictMaybe = maybe P.Nothing P.Just fromStrictMaybe = maybe P.Nothing P.Just
fSM :: Maybe a -> P.Maybe a
fSM = fromStrictMaybe
toStrictMaybe :: P.Maybe a -> Maybe a toStrictMaybe :: P.Maybe a -> Maybe a
toStrictMaybe = P.maybe Nothing Just toStrictMaybe = P.maybe Nothing Just
tSM :: P.Maybe a -> Maybe a
tSM = toStrictMaybe
instance Applicative Maybe where instance Applicative Maybe where
pure = Just pure = Just
@ -61,6 +72,17 @@ ifM ~b ~t ~f = do
b' <- b b' <- b
if b' then t else f if b' then t else f
whileM_ :: Monad m => m a -> (a -> m Bool) -> m () whileM :: Monad m => m a -> (a -> m Bool) -> m a
whileM_ action f = whenM (action >>= f) (whileM_ action f) whileM ~action ~f = do
a <- action
b' <- f a
if b' then whileM action f else pure a
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
whileM_ ~action = void . whileM action
guardM :: (Monad m, Alternative m) => m Bool -> m ()
guardM f = guard =<< f
lBS2sT :: L.ByteString -> Text
lBS2sT = TL.toStrict . TLE.decodeUtf8

64
lib/GHCup/Types.hs
View File

@ -2,50 +2,66 @@
module GHCup.Types where module GHCup.Types where
import Data.Map.Strict (Map) import Data.Map.Strict ( Map )
import Data.Strict.Maybe import Network.URL
import Data.Text import qualified GHC.Generics as GHC
import Data.Version import Data.Versions
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 data Tool = GHC
| Cabal | Cabal
| Stack | Stack
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
-- | Architecture we run on. data ToolRequest = ToolRequest {
_tool :: Tool
, _toolVersion :: Version
} deriving (Eq, Show)
data Architecture = A_64 data Architecture = A_64
| A_32 | A_32
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
data LinuxDistro = Debian (Maybe CustomVersion) data LinuxDistro = Debian
| Ubuntu (Maybe CustomVersion) | Ubuntu
| Mint (Maybe CustomVersion) | Mint
| Fedora (Maybe CustomVersion) | Fedora
| CentOS
| RedHat
| Alpine
-- rolling
| Gentoo
| Exherbo
-- not known -- not known
| UnknownLinux | UnknownLinux
-- ^ must exit -- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
data Platform = Linux LinuxDistro data Platform = Linux LinuxDistro
-- ^ must exit -- ^ must exit
| Darwin | Darwin
-- ^ must exit -- ^ must exit
| FreeBSD (Maybe CustomVersion) | FreeBSD
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
type CustomVersion = Text data PlatformResult = PlatformResult {
type PlatformSpec = Map Platform URL _platform :: Platform
type ArchitectureSpec = Map Architecture PlatformSpec , _distroVersion :: Maybe Versioning
type VersionSpec = Map Version ArchitectureSpec } deriving (Eq, Show)
type AvailableDownloads = Map Tool VersionSpec
data PlatformRequest = PlatformRequest {
_rArch :: Architecture
, _rPlatform :: Platform
, _rVersion :: Maybe Versioning
} deriving (Eq, Show)
type PlatformVersionSpec = Map (Maybe Versioning) URL
type PlatformSpec = Map Platform PlatformVersionSpec
type ArchitectureSpec = Map Architecture PlatformSpec
type ToolVersionSpec = Map Version ArchitectureSpec
type AvailableDownloads = Map Tool ToolVersionSpec
data URLSource = GHCupURL
| OwnSource URL
| OwnSpec AvailableDownloads

18
lib/GHCup/Types/Foo.hs
View File

@ -1,18 +0,0 @@
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)

43
lib/GHCup/Types/JSON.hs
View File

@ -9,32 +9,21 @@
module GHCup.Types.JSON where module GHCup.Types.JSON where
import Data.Strict.Maybe import Data.Strict.Maybe
import GHCup.Types import GHCup.Types
import Generics.SOP.TH import Prelude hiding ( Maybe )
import Prelude hiding ( import Data.Versions
Maybe import Data.Aeson
, Just import Data.Aeson.TH
, Nothing)
import Waargonaut.Generic (
JsonEncode
, JsonDecode
, GWaarg)
deriveGeneric ''Maybe deriveJSON defaultOptions ''Architecture
instance JsonEncode GWaarg a => JsonEncode GWaarg (Maybe a) deriveJSON defaultOptions ''LinuxDistro
instance JsonDecode GWaarg a => JsonDecode GWaarg (Maybe a) deriveJSON defaultOptions ''Maybe
deriveJSON defaultOptions ''Mess
deriveGeneric ''Tool deriveJSON defaultOptions ''SemVer
instance JsonEncode GWaarg Tool deriveJSON defaultOptions ''Tool
instance JsonDecode GWaarg Tool deriveJSON defaultOptions ''VSep
deriveJSON defaultOptions ''VUnit
deriveGeneric ''Architecture deriveJSON defaultOptions ''Version
instance JsonEncode GWaarg Architecture deriveJSON defaultOptions ''Versioning
instance JsonDecode GWaarg Architecture
deriveGeneric ''LinuxDistro
instance JsonEncode GWaarg LinuxDistro
instance JsonDecode GWaarg LinuxDistro

11
lib/GHCup/Types/Optics.hs
View File

@ -2,4 +2,15 @@
module GHCup.Types.Optics where module GHCup.Types.Optics where
import GHCup.Types
import Optics
makePrisms ''Tool
makePrisms ''Architecture
makePrisms ''LinuxDistro
makePrisms ''Platform
makeLenses ''PlatformResult
makeLenses ''ToolRequest