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

Yeah

Browse Source
This commit is contained in:
Julian Ospald 2020-02-19 20:54:23 +01:00
parent 57cf985e05
commit 21917dea3e
7 changed files with 132 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cabal.project.freeze
View File

@ -142,7 +142,7 @@ constraints: any.Cabal ==2.4.0.1,
any.syb ==0.7.1,
any.tagged ==0.8.6,
tagged +deepseq +transformers,
any.tar-bytestring ==0.6.1.3,
any.tar-bytestring ==0.6.2.0,
any.template-haskell ==2.14.0.0,
any.terminfo ==0.4.1.2,
any.text ==1.2.3.1,

12
ghcup.cabal
View File

@ -40,23 +40,26 @@ common language-bash { build-depends: language-bash >= 0.9 }
common lzma { build-depends: lzma >= 0.0.0.3 }
common mtl { build-depends: mtl >= 2.2 }
common optics { build-depends: optics >= 0.2 }
common optics-vl { build-depends: optics-vl >= 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 streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
common strict-base { build-depends: strict-base >= 0.4 }
common tar-bytestring { build-depends: tar-bytestring >= 0.6.1.3 }
common string-qq { build-depends: string-qq >= 0.0.4 }
common tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 }
common template-haskell { build-depends: template-haskell >= 2.7 }
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 uri-bytestring { build-depends: uri-bytestring >= 0.3.2.2 }
common utf8-string { build-depends: utf8-string >= 1.0 }
common vector { build-depends: vector >= 0.12 }
common versions { build-depends: versions >= 3.5 }
common waargonaut { build-depends: waargonaut >= 0.8 }
common word8 { build-depends: word8 >= 0.1.3 }
common zlib { build-depends: zlib >= 0.6.2.1 }
@ -95,11 +98,13 @@ library
, lzma
, mtl
, optics
, optics-vl
, parsec
, safe-exceptions
, streamly
, streamly-bytestring
, strict-base
, string-qq
, tar-bytestring
, template-haskell
, text
@ -107,10 +112,11 @@ library
, transformers
, unix
, unix-bytestring
, url
, uri-bytestring
, utf8-string
, vector
, versions
, word8
, zlib
exposed-modules: GHCup
GHCup.Bash

142
lib/GHCup.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
-- TODO: handle SIGTERM, SIGUSR
module GHCup where
@ -19,6 +19,7 @@ import Control.Monad.IO.Class
import Control.Exception.Safe
import Data.ByteString ( ByteString )
import Data.Foldable ( asum )
import Data.String.QQ
import Data.Text ( Text )
import Data.Versions
import GHCup.Bash
@ -28,7 +29,6 @@ import GHCup.Types
import GHCup.Types.Optics
import HPath
import HPath.IO
import Network.URL
import Optics
import Prelude hiding ( abs
, readFile
@ -36,10 +36,11 @@ import Prelude hiding ( abs
import System.Info
import System.IO.Error
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.Encoding as E
import qualified Data.Text.ICU as ICU
import Data.Maybe
import qualified Data.Map.Strict as Map
import Data.Word8
import GHC.IO.Exception
import GHC.IO.Handle
import Haskus.Utils.Variant.Excepts
@ -75,7 +76,10 @@ import qualified Codec.Compression.BZip as BZip
import qualified Data.ByteString.UTF8 as UTF8
import qualified System.Posix.Process.ByteString
as SPPB
import System.Posix.Directory.ByteString (changeWorkingDirectory)
import System.Posix.Directory.ByteString
( changeWorkingDirectory )
import URI.ByteString
import URI.ByteString.QQ
@ -100,6 +104,9 @@ data DistroNotFound = DistroNotFound
data ArchiveError = UnknownArchive ByteString
deriving Show
data URLException = UnsupportedURL
deriving Show
----------------------
@ -107,32 +114,29 @@ data ArchiveError = UnknownArchive ByteString
----------------------
-- TODO: version quasiquoter
availableDownloads :: AvailableDownloads
availableDownloads = Map.fromList
[ ( GHC
, Map.fromList
[ ( (\(Right x) -> x) $ version (fS "8.6.5")
[ ( (\(Right x) -> x) $ version [s|8.6.5|]
, Map.fromList
[ ( A_64
, Map.fromList
[ ( Linux UnknownLinux
, Map.fromList
[ ( Nothing
, mkGHCUrl
"~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz"
, [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
)
]
)
, ( Linux Debian
, Map.fromList
[ ( Nothing
, mkGHCUrl
"~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz"
, [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
)
, ( Just $ (\(Right x) -> x) $ versioning (fS "8")
, mkGHCUrl
"~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz"
, ( Just $ (\(Right x) -> x) $ versioning [s|8|]
, [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
)
]
)
@ -143,12 +147,7 @@ availableDownloads = Map.fromList
]
)
]
where
mkGHCUrl path = URL
{ url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" Nothing
, url_path = path
, url_params = []
}
getDownloadURL :: (MonadCatch m, MonadIO m)
@ -158,7 +157,7 @@ getDownloadURL :: (MonadCatch m, MonadIO m)
-> Excepts
'[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
m
URL
URI
getDownloadURL (ToolRequest t v) mpfReq urlSource = do
(PlatformRequest arch plat ver) <- case mpfReq of
Just x -> pure x
@ -185,7 +184,7 @@ getDownloadURL' :: Tool
-> Maybe Versioning
-- ^ optional version of the platform
-> AvailableDownloads
-> Either NoDownload URL
-> Either NoDownload URI
getDownloadURL' t v a p mv dls = maybe
(Left NoDownload)
Right
@ -209,9 +208,9 @@ getDownloadURL' t v a p mv dls = maybe
--
-- 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)
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file")
-> Maybe Int -- ^ optional port (e.g. 3000)
-> Path Abs -- ^ destination directory to download into
-> Maybe (Path Rel) -- ^ optionally provided filename
-> IO (Path Abs)
@ -222,22 +221,33 @@ download https host path port dest mfn = do
-- throw an exception if the url type or host protocol is not supported.
--
-- Only Absolute HTTP/HTTPS is supported.
download' :: URL
download' :: MonadIO m
=> URI
-> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename
-> 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)
-> Excepts '[URLException] m (Path Abs)
download' url dest mfn
| view (uriSchemeL' % schemeBSL') url == [s|https|] = dl True
| view (uriSchemeL' % schemeBSL') url == [s|http|] = dl False
| otherwise = throwE UnsupportedURL
where
dl https = do
host <-
preview (authorityL' % _Just % authorityHostL' % hostBSL') url
?? UnsupportedURL
let path = view pathL' url
let port = preview
(authorityL' % _Just % authorityPortL' % _Just % portNumberL')
url
liftIO $ download https host path port dest mfn
-- | 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)
-> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file")
-> Maybe Int -- ^ optional port (e.g. 3000)
-> Fd -- ^ function creating an Fd to write the body into
-> IO ()
downloadFd https host path port fd =
@ -245,19 +255,19 @@ downloadFd https host path port fd =
downloadInternal :: Bool
-> String
-> String
-> Maybe Integer
-> ByteString
-> ByteString
-> Maybe Int
-> Either Fd (Path Abs, Maybe (Path Rel))
-> 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)
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
let q = buildRequest1 $ http GET (C.pack "/" <> C.pack path)
let q = buildRequest1 $ http GET ([s|/|] <> path)
sendRequest c q emptyBody
@ -296,20 +306,12 @@ downloadInternal https host path port dest = do
Just x ->
let fp = dest </> x
in fmap (, fp) $ createRegularFileFd newFilePerms fp
Nothing ->
Nothing -> do
-- ...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' <- parseRel (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)
let urlBaseName = snd . B.breakEnd (== _slash) $ urlDecode False path
fn' <- parseRel urlBaseName
let fp = dest </> fn'
fmap (, fp) $ createRegularFileFd newFilePerms fp
@ -372,7 +374,7 @@ getLinuxDistro = do
hasWord t matches = foldr
(\x y ->
( isJust
. ICU.find (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> x <> fS "\\b"))
. ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> x <> [s|\\b|]))
$ t
)
|| y
@ -401,9 +403,9 @@ getLinuxDistro = do
try_lsb_release_cmd = do
(Just _ ) <- findExecutable lsb_release_cmd
(Just name) <- (fmap . fmap) _stdOut
$ executeOut lsb_release_cmd [fS "-si"] Nothing
$ executeOut lsb_release_cmd [[s|-si|]] Nothing
ver <- (fmap . fmap) _stdOut
$ executeOut lsb_release_cmd [fS "-sr"] Nothing
$ executeOut lsb_release_cmd [[s|-sr|]] Nothing
pure (E.decodeUtf8 name, fmap E.decodeUtf8 ver)
try_lsb_release :: IO (Text, Maybe Text)
@ -419,14 +421,14 @@ getLinuxDistro = do
join
. fmap (ICU.group 0)
. ICU.find
(ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> fS n <> fS "\\b")
(ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> fS n <> [s|\\b|])
)
$ t
verRe =
join
. fmap (ICU.group 0)
. ICU.find
(ICU.regex [ICU.CaseInsensitive] (fS "\\b(\\d)+(.(\\d)+)*\\b"))
(ICU.regex [ICU.CaseInsensitive] [s|\\b(\\d)+(.(\\d)+)*\\b|])
$ t
(Just name) <- pure
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
@ -454,32 +456,32 @@ unpackToTmpDir av = do
fn <- basename av
let (fnrest, ext) = splitExtension $ toFilePath fn
let ext2 = takeExtension fnrest
tmpdir <- getEnvDefault (fS "TMPDIR") (fS "/tmp")
tmp <- mkdtemp $ (tmpdir FP.</> fS "ghcup-")
tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
let untar bs = do
Tar.unpack tmp . Tar.read $ bs
Right <$> parseAbs tmp
-- extract, depending on file extension
if
| ext == fS ".gz" && ext2 == fS ".tar"
| ext == [s|.gz|] && ext2 == [s|.tar|]
-> untar . GZip.decompress =<< readFile av
| ext == fS ".xz" && ext2 == fS ".tar"
| ext == [s|.xz|] && ext2 == [s|.tar|]
-> do
filecontents <- readFile av
let decompressed = Lzma.decompress filecontents
-- putStrLn $ show decompressed
untar decompressed
| ext == fS ".bz2" && ext2 == fS ".tar"
| ext == [s|.bz2|] && ext2 == [s|.tar|]
-> untar . BZip.decompress =<< readFile av
| ext == fS ".tar" && ext2 == fS ".tar"
| ext == [s|.tar|]
-> untar =<< readFile av
| otherwise
-> pure $ Left $ UnknownArchive ext
where
isTar ext | ext == fS ".tar" = pure ()
| otherwise = throwE $ UnknownArchive ext
isTar ext | ext == [s|.tar|] = pure ()
| otherwise = throwE $ UnknownArchive ext
-- | Install an unpacked GHC distribution.
@ -487,8 +489,8 @@ installGHC :: Path Abs -- ^ Path to the unpacked GHC bindist
-> Path Abs -- ^ Path to install to
-> IO ()
installGHC path inst = do
exe (fS "./configure") [fS "--prefix=" <> toFilePath inst] False (Just path)
-- sh (fS "make") [fS "install"] (Just path)
exec [s|./configure|] [[s|--prefix=|] <> toFilePath inst] False (Just path)
exec [s|make|] [[s|install|]] True (Just path)
pure ()
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads

15
lib/GHCup/File.hs
View File

@ -159,15 +159,15 @@ createRegularFileFd fm dest =
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
exe :: ByteString
-> [ByteString]
-> Bool
-> Maybe (Path Abs)
-> IO (Either ProcessError ())
exe exe' args spath chdir = do
exec :: ByteString -- ^ thing to execute
-> [ByteString] -- ^ args for the thing
-> Bool -- ^ whether to search PATH for the thing
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> IO (Either ProcessError ())
exec exe args spath chdir = do
pid <- SPPB.forkProcess $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe' spath args Nothing
SPPB.executeFile exe spath args Nothing
fmap toProcessError $ SPPB.getProcessStatus True True pid
@ -179,4 +179,3 @@ toProcessError mps = case mps of
Just (Terminated _ _ ) -> Left $ PTerminated
Just (Stopped _ ) -> Left $ PStopped
Nothing -> Left $ NoSuchPid

6
lib/GHCup/Types.hs
View File

@ -3,9 +3,9 @@
module GHCup.Types where
import Data.Map.Strict ( Map )
import Network.URL
import qualified GHC.Generics as GHC
import Data.Versions
import URI.ByteString
data Tool = GHC
@ -55,7 +55,7 @@ data PlatformRequest = PlatformRequest {
, _rVersion :: Maybe Versioning
} deriving (Eq, Show)
type PlatformVersionSpec = Map (Maybe Versioning) URL
type PlatformVersionSpec = Map (Maybe Versioning) URI
type PlatformSpec = Map Platform PlatformVersionSpec
type ArchitectureSpec = Map Architecture PlatformSpec
type ToolVersionSpec = Map Version ArchitectureSpec
@ -63,5 +63,5 @@ type AvailableDownloads = Map Tool ToolVersionSpec
data URLSource = GHCupURL
| OwnSource URL
| OwnSource URI
| OwnSpec AvailableDownloads

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

@ -14,10 +14,13 @@ import GHCup.Types
import Data.Versions
import Data.Aeson
import Data.Aeson.TH
import Network.URL
import qualified Data.Text as T
import Data.Text.Encoding ( decodeUtf8
, encodeUtf8
)
import Data.Aeson.Types
import Data.Text.Encoding as E
import URI.ByteString
@ -32,13 +35,14 @@ deriveJSON defaultOptions ''VSep
deriveJSON defaultOptions ''VUnit
instance ToJSON URL where
toJSON = toJSON . exportURL
instance ToJSON URI where
toJSON = toJSON . decodeUtf8 . serializeURIRef'
instance FromJSON URL where
parseJSON = withText "URL" $ \t -> case importURL (T.unpack t) of
Just x -> pure x
Nothing -> fail "Could not parse URL, failure in importURL"
instance FromJSON URI where
parseJSON = withText "URL" $ \t ->
case parseURI strictURIParserOptions (encodeUtf8 t) of
Right x -> pure x
Left e -> fail . show $ e
instance ToJSON Versioning where
toJSON = toJSON . prettyV
@ -62,8 +66,8 @@ instance ToJSONKey (Maybe Versioning) where
Nothing -> T.pack "unknown_version"
instance FromJSONKey (Maybe Versioning) where
fromJSONKey = FromJSONKeyTextParser
$ \t -> if t == T.pack "unknown_version" then pure Nothing else pure $ just t
fromJSONKey = FromJSONKeyTextParser $ \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

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

@ -2,8 +2,10 @@
module GHCup.Types.Optics where
import GHCup.Types
import Optics
import Data.ByteString ( ByteString )
import GHCup.Types
import Optics
import URI.ByteString
makePrisms ''Tool
makePrisms ''Architecture
@ -14,3 +16,26 @@ makeLenses ''PlatformResult
makeLenses ''ToolRequest
uriSchemeL' :: Lens' (URIRef Absolute) Scheme
uriSchemeL' = lensVL uriSchemeL
schemeBSL' :: Lens' Scheme ByteString
schemeBSL' = lensVL schemeBSL
authorityL' :: Lens' (URIRef a) (Maybe Authority)
authorityL' = lensVL authorityL
authorityHostL' :: Lens' Authority Host
authorityHostL' = lensVL authorityHostL
authorityPortL' :: Lens' Authority (Maybe Port)
authorityPortL' = lensVL authorityPortL
portNumberL' :: Lens' Port Int
portNumberL' = lensVL portNumberL
hostBSL' :: Lens' Host ByteString
hostBSL' = lensVL hostBSL
pathL' :: Lens' (URIRef a) ByteString
pathL' = lensVL pathL