|
|
|
@@ -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 |
|
|
|
|
Julian Ospald
4 years ago