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

More work

Browse Source
This commit is contained in:
Julian Ospald 2020-01-17 23:29:16 +01:00
parent 9d3631b20b
commit d3072a88b8
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
6 changed files with 296 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
ghcup.cabal
View File

@ -20,16 +20,21 @@ source-repository head
type: git
location: https://github.com/hasufell/ghcup-hs
common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 }
common aeson { build-depends: aeson >= 1.4 }
common ascii-string { build-depends: ascii-string >= 1.0 }
common base { build-depends: base >= 4.12.0.0 && < 5 }
common async { build-depends: async >= 0.8 }
common base { build-depends: base >= 4.12 && < 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 http-io-streams { build-depends: http-io-streams >= 0.1 }
common io-streams { build-depends: io-streams >= 1.5 }
common language-bash { build-depends: language-bash >= 0.9 }
common mtl { build-depends: mtl >= 2.2 }
common optics { build-depends: optics >= 0.2 }
common parsec { build-depends: parsec >= 3.1 }
common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
@ -40,24 +45,31 @@ common text { build-depends: text >= 1.2 }
common text-icu { build-depends: text-icu >= 0.7 }
common transformers { build-depends: transformers >= 0.5 }
common unix { build-depends: unix >= 2.7 }
common unix-bytestring { build-depends: unix-bytestring >= 0.3 }
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 async { build-depends: async >= 0.8 }
common mtl { build-depends: mtl >= 2.2 }
common versions { build-depends: versions >= 3.5 }
common waargonaut { build-depends: waargonaut >= 0.8 }
common config
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
default-extensions: LambdaCase
, MultiWayIf
, PackageImports
, RecordWildCards
, ScopedTypeVariables
, StrictData
, Strict
, TupleSections
library
import: config
, base
-- deps
, HsOpenSSL
, aeson
, ascii-string
, async
@ -67,6 +79,8 @@ library
, hpath
, hpath-filepath
, hpath-io
, http-io-streams
, io-streams
, language-bash
, mtl
, optics
@ -79,6 +93,7 @@ library
, text-icu
, transformers
, unix
, unix-bytestring
, url
, utf8-string
, vector

171
lib/GHCup.hs
View File

@ -13,6 +13,9 @@ module GHCup where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Control.Exception.Safe
import Data.Foldable ( asum )
import Data.Text ( Text )
import Data.Versions
@ -29,10 +32,32 @@ import Prelude hiding ( abs
, readFile
)
import System.Info
import System.IO.Error
import qualified Data.Text as T
import qualified Data.Text.ICU as ICU
import Data.Maybe ( isJust )
import Data.Maybe
import qualified Data.Map.Strict as Map
import GHC.IO.Exception
import GHC.IO.Handle
import Network.Http.Client hiding ( URL )
import System.IO.Streams ( InputStream
, OutputStream
, stdout
)
import qualified System.IO.Streams as Streams
import System.Posix.Temp.ByteString
import "unix" System.Posix.IO.ByteString
hiding ( fdWrite )
import System.Posix.FD as FD
import System.Posix.Directory.Foreign ( oTrunc )
import qualified Data.ByteString as B
import OpenSSL ( withOpenSSL )
import qualified Data.ByteString.Char8 as C
import Data.Functor ( ($>) )
import System.Posix.Types
import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite )
availableDownloads :: AvailableDownloads
@ -78,11 +103,11 @@ availableDownloads = Map.fromList
}
downloadURL :: ToolRequest
getDownloadURL :: ToolRequest
-> Maybe PlatformRequest
-> URLSource
-> IO (Maybe URL) -- TODO: better error handling
downloadURL (ToolRequest t v) mpfReq urlSource = do
getDownloadURL (ToolRequest t v) mpfReq urlSource = do
(PlatformRequest arch plat ver) <- case mpfReq of
Just x -> pure x
Nothing -> do
@ -95,10 +120,10 @@ downloadURL (ToolRequest t v) mpfReq urlSource = do
OwnSource url -> fail "Not implemented"
OwnSpec dls -> pure dls
pure $ downloadURL' t v arch plat ver dls
pure $ getDownloadURL' t v arch plat ver dls
downloadURL' :: Tool
getDownloadURL' :: Tool
-> Version
-- ^ tool version
-> Architecture
@ -109,7 +134,7 @@ downloadURL' :: Tool
-- ^ optional version of the platform
-> AvailableDownloads
-> Maybe URL
downloadURL' t v a p mv dls =
getDownloadURL' t v a p mv dls =
with_distro <|> without_distro_ver <|> without_distro
where
@ -156,15 +181,15 @@ getLinuxDistro = do
]
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
| hasWord name ["debian"] -> Debian
| hasWord name ["ubuntu"] -> Ubuntu
| hasWord name ["linuxmint", "Linux Mint"] -> Mint
| hasWord name ["fedora"] -> Fedora
| hasWord name ["centos"] -> CentOS
| hasWord name ["Red Hat"] -> RedHat
| hasWord name ["alpine"] -> Alpine
| hasWord name ["exherbo"] -> Exherbo
| hasWord name ["gentoo"] -> Gentoo
| otherwise -> UnknownLinux
pure (distro, parsedVer)
where
@ -177,7 +202,7 @@ getLinuxDistro = do
|| y
)
False
matches
(T.pack <$> matches)
os_release :: Path Abs
os_release = [abs|/etc/os-release|]
@ -199,9 +224,10 @@ getLinuxDistro = do
try_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd = do
(Just _ ) <- findExecutable lsb_release_cmd
(Just (name, _)) <- executeOut lsb_release_cmd [fS "-si"]
ver <- executeOut lsb_release_cmd [fS "-sr"]
pure (lBS2sT name, fmap (lBS2sT . fst) ver)
(Just name) <- (fmap . fmap) _stdOut
$ executeOut lsb_release_cmd [fS "-si"]
ver <- (fmap . fmap) _stdOut $ executeOut lsb_release_cmd [fS "-sr"]
pure (lBS2sT name, fmap lBS2sT ver)
try_lsb_release :: IO (Text, Maybe Text)
try_lsb_release = do
@ -236,11 +262,114 @@ getLinuxDistro = do
pure (T.pack "debian", Just $ lBS2sT ver)
-- | Tries to download from the given http or https url
-- and saves the result in continuous memory into a file.
-- If the filename is not provided, then we:
-- 1. try to guess the filename from the url path
-- 2. otherwise create a random file
--
-- The file must not exist.
download :: Bool -- ^ https?
-> String -- ^ host (e.g. "www.example.com")
-> String -- ^ path (e.g. "/my/file")
-> Maybe Integer -- ^ optional port (e.g. 3000)
-> Path Abs -- ^ destination directory to download into
-> Maybe (Path Fn) -- ^ optionally provided filename
-> IO (Path Abs)
download https host path port dest mfn = do
fromJust <$> downloadInternal https host path port (Right (dest, mfn))
-- | Same as 'download', except uses URL type. As such, this might
-- throw an exception if the url type or host protocol is not supported.
--
-- Only Absolute HTTP/HTTPS is supported.
download' :: URL -> Path Abs -> Maybe (Path Fn) -> IO (Path Abs)
download' url dest mfn = case url of
URL { url_type = Absolute (Host { protocol = HTTP https, host = host, port = port }), url_path = path, url_params = [] }
-> download https host path port dest mfn
_ -> fail ("Don't know how to handle URL: " <> exportURL url)
-- | Same as 'download', except with a file descriptor. Allows to e.g.
-- print to stdout.
downloadFd :: Bool -- ^ https?
-> String -- ^ host (e.g. "www.example.com")
-> String -- ^ path (e.g. "/my/file")
-> Maybe Integer -- ^ optional port (e.g. 3000)
-> Fd -- ^ function creating an Fd to write the body into
-> IO ()
downloadFd https host path port fd =
void $ downloadInternal https host path port (Left fd)
downloadInternal :: Bool
-> String
-> String
-> Maybe Integer
-> Either Fd (Path Abs, Maybe (Path Fn))
-> IO (Maybe (Path Abs))
downloadInternal https host path port dest = do
c <- case https of
True -> do
ctx <- baselineContextSSL
openConnectionSSL ctx (C.pack host) (fromIntegral $ fromMaybe 443 port)
False -> openConnection (C.pack host) (fromIntegral $ fromMaybe 80 port)
let q = buildRequest1 $ http GET (C.pack "/" <> C.pack path)
sendRequest c q emptyBody
(fd, mfp) <- case dest of
Right (dest, mfn) -> getFile dest mfn <&> (<&> Just)
Left fd -> pure (fd, Nothing)
-- wrapper so we can close Fds we created
let receiveResponse' c b = case dest of
Right _ -> (flip finally) (closeFd fd) $ receiveResponse c b
Left _ -> receiveResponse c b
receiveResponse'
c
(\p i -> do
outStream <- Streams.makeOutputStream
(\case
Just bs -> void $ fdWrite fd bs
Nothing -> pure ()
)
Streams.connect i outStream
)
closeConnection c
pure mfp
where
-- Manage to find a file we can write the body into.
getFile :: Path Abs -> Maybe (Path Fn) -> IO (Fd, Path Abs)
getFile dest mfn = do
-- destination dir must exist
hideError AlreadyExists $ createDirRecursive newDirPerms dest
case mfn of
-- if a filename was provided, try that
Just x ->
let fp = dest </> x
in fmap (, fp) $ createRegularFileFd newFilePerms fp
Nothing ->
-- ...otherwise try to infer the filename from the URL path
case (snd . T.breakOnEnd (fS "/") . T.pack) <$> decString False path of
Just x -> do
fn' <- parseFn (C.pack $ T.unpack x)
let fp = dest </> fn'
fmap (, fp) $ createRegularFileFd newFilePerms fp
Nothing -> do
-- ...if all fails, use a random filename!
(fp, handle) <- (mkstemp (toFilePath dest))
path <- parseAbs fp
fd <- handleToFd handle
pure (fd, path)
-- download :: URL -> Path Abs -> IO (Path Abs)
-- download = undefined
-- unpack :: Path Abs -> IO (Path Abs)
-- unpack = undefined

98
lib/GHCup/File.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
module GHCup.File where
import Data.ByteString
@ -6,6 +8,7 @@ import Data.Char
import Data.Maybe
import HPath
import HPath.IO
import Optics
import Streamly.ByteString
import Streamly
import System.Posix.FilePath hiding ( (</>) )
@ -14,8 +17,9 @@ import Control.Monad
import Control.Exception.Safe
import Data.Functor
import System.Posix.Files.ByteString
import System.Posix.Directory.Foreign ( oExcl )
import System.IO
import System.Posix.IO.ByteString
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
import qualified System.Posix.Process.ByteString
as SPPB
@ -31,6 +35,18 @@ import qualified Streamly.Data.Fold as FL
import Data.ByteString.Builder
import Foreign.C.Error
import GHCup.Prelude
import Control.Concurrent.Async
import Control.Concurrent
import System.Posix.FD as FD
data CapturedProcess = CapturedProcess {
_exitCode :: ExitCode
, _stdOut :: L.ByteString
, _stdErr :: L.ByteString
} deriving (Eq, Show)
makeLenses ''CapturedProcess
-- |Checks whether a file is executable. Follows symlinks.
@ -84,26 +100,70 @@ findExecutable ex = do
sPaths
-- | Execute the given command and collect the stdout and the exit code.
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
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
(parentRead, childWrite) <- createPipe
pid <- SPPB.forkProcess $ do
whileM_
(dupTo childWrite stdOutput)
(\r ->
getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR
)
closeFd childWrite
closeFd parentRead
closeFd stdInput
SPPB.executeFile fp True args Nothing
-> IO (Maybe CapturedProcess)
executeOut path args = withFnPath path
$ \fp -> captureOutStreams $ SPPB.executeFile fp True args Nothing
closeFd childWrite
-- | Capture the stdout and stderr of the given action, which
-- is run in a subprocess. Stdin is closed. You might want to
-- 'race' this to make sure it terminates.
captureOutStreams :: IO a
-- ^ the action to execute in a subprocess
-> IO (Maybe CapturedProcess)
captureOutStreams action =
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
pid <- SPPB.forkProcess $ do
-- don't mess up stdin from the parent
closeFd stdInput
-- dup stdout
void $ dupTo childStdoutWrite stdOutput
closeFd childStdoutWrite
closeFd parentStdoutRead
-- dup stderr
void $ dupTo childStderrWrite stdError
closeFd childStderrWrite
closeFd parentStderrRead
-- execute the action
void $ action
-- close everything we don't need
closeFd childStdoutWrite
closeFd childStderrWrite
SPPB.getProcessStatus True True pid >>= \case
-- readE will take care of closing the fd
Just (SPPB.Exited es) -> readFd parentRead <&> Just . (, es)
_ -> closeFd parentRead $> Nothing
-- readFd will take care of closing the fd
Just (SPPB.Exited es) -> do
stdout' <- readFd parentStdoutRead
stderr' <- readFd parentStderrRead
pure $ Just $ CapturedProcess { _exitCode = es
, _stdOut = stdout'
, _stdErr = stderr'
}
_ -> do
closeFd parentStdoutRead
closeFd parentStderrRead
pure $ Nothing
where
actionWithPipes a =
createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
-- | Create a new regular file in write-only mode. The file must not exist.
createRegularFileFd :: FileMode -> Path b -> IO Fd
createRegularFileFd fm dest = FD.openFd
(toFilePath dest)
WriteOnly
[oExcl]
(Just fm)

55
lib/GHCup/Prelude.hs
View File

@ -6,57 +6,39 @@ module GHCup.Prelude where
import Control.Applicative
import Control.Monad
import Data.Strict.Maybe
import Control.Exception.Safe
import qualified Data.Strict.Maybe as S
import Data.Monoid ( (<>) )
import Prelude ( Monad
, Bool
, return
, (.)
)
import qualified Prelude as P
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
import System.IO.Error
fS :: IsString a => P.String -> a
fS :: IsString a => String -> a
fS = fromString
fromStrictMaybe :: Maybe a -> P.Maybe a
fromStrictMaybe = maybe P.Nothing P.Just
fromStrictMaybe :: S.Maybe a -> Maybe a
fromStrictMaybe = S.maybe Nothing Just
fSM :: Maybe a -> P.Maybe a
fSM :: S.Maybe a -> Maybe a
fSM = fromStrictMaybe
toStrictMaybe :: P.Maybe a -> Maybe a
toStrictMaybe = P.maybe Nothing Just
toStrictMaybe :: Maybe a -> S.Maybe a
toStrictMaybe = maybe S.Nothing S.Just
tSM :: P.Maybe a -> Maybe a
tSM :: Maybe a -> S.Maybe a
tSM = toStrictMaybe
instance Applicative Maybe where
pure = Just
internalError :: String -> IO a
internalError = fail . ("Internal error: " <>)
Just f <*> m = P.fmap f m
Nothing <*> _m = Nothing
iE :: String -> IO a
iE = internalError
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 ()
@ -86,3 +68,12 @@ guardM ~f = guard =<< f
lBS2sT :: L.ByteString -> Text
lBS2sT = TL.toStrict . TLE.decodeUtf8
handleIO' :: IOErrorType -> (IOException -> IO ()) -> IO () -> IO ()
handleIO' err handler =
handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e)
hideError :: IOErrorType -> IO () -> IO ()
hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else ioError e)

9
lib/GHCup/Types.hs
View File

@ -6,7 +6,16 @@ import Data.Map.Strict ( Map )
import Network.URL
import qualified GHC.Generics as GHC
import Data.Versions
import HPath
import System.Posix.Types
data DownloadDestination = DPath {
dDestDir :: Path Abs
, dFileName :: Maybe (Path Fn)
} |
Fd {
dFd :: Fd
}
data Tool = GHC
| Cabal

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

@ -59,11 +59,11 @@ instance FromJSONKey Versioning where
instance ToJSONKey (Maybe Versioning) where
toJSONKey = toJSONKeyText $ \case
Just x -> prettyV x
Nothing -> T.pack "unknown"
Nothing -> T.pack "unknown_version"
instance FromJSONKey (Maybe Versioning) where
fromJSONKey = FromJSONKeyTextParser
$ \t -> if t == T.pack "unknown" then pure Nothing else pure $ just t
$ \t -> if t == T.pack "unknown_version" then pure Nothing else pure $ just t
where
just t = case versioning t of
Right x -> pure x