Yeah
This commit is contained in:
parent
57cf985e05
commit
21917dea3e
@ -142,7 +142,7 @@ constraints: any.Cabal ==2.4.0.1,
|
|||||||
any.syb ==0.7.1,
|
any.syb ==0.7.1,
|
||||||
any.tagged ==0.8.6,
|
any.tagged ==0.8.6,
|
||||||
tagged +deepseq +transformers,
|
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.template-haskell ==2.14.0.0,
|
||||||
any.terminfo ==0.4.1.2,
|
any.terminfo ==0.4.1.2,
|
||||||
any.text ==1.2.3.1,
|
any.text ==1.2.3.1,
|
||||||
|
12
ghcup.cabal
12
ghcup.cabal
@ -40,23 +40,26 @@ common language-bash { build-depends: language-bash >= 0.9 }
|
|||||||
common lzma { build-depends: lzma >= 0.0.0.3 }
|
common lzma { build-depends: lzma >= 0.0.0.3 }
|
||||||
common mtl { build-depends: mtl >= 2.2 }
|
common mtl { build-depends: mtl >= 2.2 }
|
||||||
common optics { build-depends: optics >= 0.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 parsec { build-depends: parsec >= 3.1 }
|
||||||
common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
|
common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
|
||||||
common streamly { build-depends: streamly >= 0.7 }
|
common streamly { build-depends: streamly >= 0.7 }
|
||||||
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
|
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
|
||||||
common strict-base { build-depends: strict-base >= 0.4 }
|
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 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 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 unix-bytestring { build-depends: unix-bytestring >= 0.3 }
|
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 utf8-string { build-depends: utf8-string >= 1.0 }
|
||||||
common vector { build-depends: vector >= 0.12 }
|
common vector { build-depends: vector >= 0.12 }
|
||||||
common versions { build-depends: versions >= 3.5 }
|
common versions { build-depends: versions >= 3.5 }
|
||||||
common waargonaut { build-depends: waargonaut >= 0.8 }
|
common waargonaut { build-depends: waargonaut >= 0.8 }
|
||||||
|
common word8 { build-depends: word8 >= 0.1.3 }
|
||||||
common zlib { build-depends: zlib >= 0.6.2.1 }
|
common zlib { build-depends: zlib >= 0.6.2.1 }
|
||||||
|
|
||||||
|
|
||||||
@ -95,11 +98,13 @@ library
|
|||||||
, lzma
|
, lzma
|
||||||
, mtl
|
, mtl
|
||||||
, optics
|
, optics
|
||||||
|
, optics-vl
|
||||||
, parsec
|
, parsec
|
||||||
, safe-exceptions
|
, safe-exceptions
|
||||||
, streamly
|
, streamly
|
||||||
, streamly-bytestring
|
, streamly-bytestring
|
||||||
, strict-base
|
, strict-base
|
||||||
|
, string-qq
|
||||||
, tar-bytestring
|
, tar-bytestring
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, text
|
, text
|
||||||
@ -107,10 +112,11 @@ library
|
|||||||
, transformers
|
, transformers
|
||||||
, unix
|
, unix
|
||||||
, unix-bytestring
|
, unix-bytestring
|
||||||
, url
|
, uri-bytestring
|
||||||
, utf8-string
|
, utf8-string
|
||||||
, vector
|
, vector
|
||||||
, versions
|
, versions
|
||||||
|
, word8
|
||||||
, zlib
|
, zlib
|
||||||
exposed-modules: GHCup
|
exposed-modules: GHCup
|
||||||
GHCup.Bash
|
GHCup.Bash
|
||||||
|
134
lib/GHCup.hs
134
lib/GHCup.hs
@ -1,11 +1,11 @@
|
|||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
-- TODO: handle SIGTERM, SIGUSR
|
-- TODO: handle SIGTERM, SIGUSR
|
||||||
module GHCup where
|
module GHCup where
|
||||||
@ -19,6 +19,7 @@ import Control.Monad.IO.Class
|
|||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
import Data.ByteString ( ByteString )
|
import Data.ByteString ( ByteString )
|
||||||
import Data.Foldable ( asum )
|
import Data.Foldable ( asum )
|
||||||
|
import Data.String.QQ
|
||||||
import Data.Text ( Text )
|
import Data.Text ( Text )
|
||||||
import Data.Versions
|
import Data.Versions
|
||||||
import GHCup.Bash
|
import GHCup.Bash
|
||||||
@ -28,7 +29,6 @@ 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 Optics
|
import Optics
|
||||||
import Prelude hiding ( abs
|
import Prelude hiding ( abs
|
||||||
, readFile
|
, readFile
|
||||||
@ -40,6 +40,7 @@ import qualified Data.Text.Encoding as E
|
|||||||
import qualified Data.Text.ICU as ICU
|
import qualified Data.Text.ICU as ICU
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
|
import Data.Word8
|
||||||
import GHC.IO.Exception
|
import GHC.IO.Exception
|
||||||
import GHC.IO.Handle
|
import GHC.IO.Handle
|
||||||
import Haskus.Utils.Variant.Excepts
|
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 Data.ByteString.UTF8 as UTF8
|
||||||
import qualified System.Posix.Process.ByteString
|
import qualified System.Posix.Process.ByteString
|
||||||
as SPPB
|
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
|
data ArchiveError = UnknownArchive ByteString
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
|
data URLException = UnsupportedURL
|
||||||
|
deriving Show
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
----------------------
|
----------------------
|
||||||
@ -107,32 +114,29 @@ data ArchiveError = UnknownArchive ByteString
|
|||||||
----------------------
|
----------------------
|
||||||
|
|
||||||
|
|
||||||
|
-- TODO: version quasiquoter
|
||||||
availableDownloads :: AvailableDownloads
|
availableDownloads :: AvailableDownloads
|
||||||
availableDownloads = Map.fromList
|
availableDownloads = Map.fromList
|
||||||
[ ( GHC
|
[ ( GHC
|
||||||
, Map.fromList
|
, Map.fromList
|
||||||
[ ( (\(Right x) -> x) $ version (fS "8.6.5")
|
[ ( (\(Right x) -> x) $ version [s|8.6.5|]
|
||||||
, Map.fromList
|
, Map.fromList
|
||||||
[ ( A_64
|
[ ( A_64
|
||||||
, Map.fromList
|
, Map.fromList
|
||||||
[ ( Linux UnknownLinux
|
[ ( Linux UnknownLinux
|
||||||
, Map.fromList
|
, Map.fromList
|
||||||
[ ( Nothing
|
[ ( Nothing
|
||||||
, mkGHCUrl
|
, [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
|
||||||
"~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz"
|
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
, ( Linux Debian
|
, ( Linux Debian
|
||||||
, Map.fromList
|
, Map.fromList
|
||||||
[ ( Nothing
|
[ ( Nothing
|
||||||
, mkGHCUrl
|
, [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
|
||||||
"~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz"
|
|
||||||
)
|
)
|
||||||
, ( Just $ (\(Right x) -> x) $ versioning (fS "8")
|
, ( Just $ (\(Right x) -> x) $ versioning [s|8|]
|
||||||
, mkGHCUrl
|
, [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
|
||||||
"~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)
|
getDownloadURL :: (MonadCatch m, MonadIO m)
|
||||||
@ -158,7 +157,7 @@ getDownloadURL :: (MonadCatch m, MonadIO m)
|
|||||||
-> Excepts
|
-> Excepts
|
||||||
'[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
|
'[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
|
||||||
m
|
m
|
||||||
URL
|
URI
|
||||||
getDownloadURL (ToolRequest t v) mpfReq urlSource = do
|
getDownloadURL (ToolRequest t v) mpfReq urlSource = do
|
||||||
(PlatformRequest arch plat ver) <- case mpfReq of
|
(PlatformRequest arch plat ver) <- case mpfReq of
|
||||||
Just x -> pure x
|
Just x -> pure x
|
||||||
@ -185,7 +184,7 @@ getDownloadURL' :: Tool
|
|||||||
-> Maybe Versioning
|
-> Maybe Versioning
|
||||||
-- ^ optional version of the platform
|
-- ^ optional version of the platform
|
||||||
-> AvailableDownloads
|
-> AvailableDownloads
|
||||||
-> Either NoDownload URL
|
-> Either NoDownload URI
|
||||||
getDownloadURL' t v a p mv dls = maybe
|
getDownloadURL' t v a p mv dls = maybe
|
||||||
(Left NoDownload)
|
(Left NoDownload)
|
||||||
Right
|
Right
|
||||||
@ -209,9 +208,9 @@ getDownloadURL' t v a p mv dls = maybe
|
|||||||
--
|
--
|
||||||
-- The file must not exist.
|
-- The file must not exist.
|
||||||
download :: Bool -- ^ https?
|
download :: Bool -- ^ https?
|
||||||
-> String -- ^ host (e.g. "www.example.com")
|
-> ByteString -- ^ host (e.g. "www.example.com")
|
||||||
-> String -- ^ path (e.g. "/my/file")
|
-> ByteString -- ^ path (e.g. "/my/file")
|
||||||
-> Maybe Integer -- ^ optional port (e.g. 3000)
|
-> Maybe Int -- ^ optional port (e.g. 3000)
|
||||||
-> Path Abs -- ^ destination directory to download into
|
-> Path Abs -- ^ destination directory to download into
|
||||||
-> Maybe (Path Rel) -- ^ optionally provided filename
|
-> Maybe (Path Rel) -- ^ optionally provided filename
|
||||||
-> IO (Path Abs)
|
-> 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.
|
-- throw an exception if the url type or host protocol is not supported.
|
||||||
--
|
--
|
||||||
-- Only Absolute HTTP/HTTPS is supported.
|
-- Only Absolute HTTP/HTTPS is supported.
|
||||||
download' :: URL
|
download' :: MonadIO m
|
||||||
|
=> URI
|
||||||
-> Path Abs -- ^ destination dir
|
-> Path Abs -- ^ destination dir
|
||||||
-> Maybe (Path Rel) -- ^ optional filename
|
-> Maybe (Path Rel) -- ^ optional filename
|
||||||
-> IO (Path Abs)
|
-> Excepts '[URLException] m (Path Abs)
|
||||||
download' url dest mfn = case url of
|
download' url dest mfn
|
||||||
URL { url_type = Absolute (Host { protocol = HTTP https, host = host, port = port }), url_path = path, url_params = [] }
|
| view (uriSchemeL' % schemeBSL') url == [s|https|] = dl True
|
||||||
-> download https host path port dest mfn
|
| view (uriSchemeL' % schemeBSL') url == [s|http|] = dl False
|
||||||
_ -> fail ("Don't know how to handle URL: " <> exportURL url)
|
| 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.
|
-- | Same as 'download', except with a file descriptor. Allows to e.g.
|
||||||
-- print to stdout.
|
-- print to stdout.
|
||||||
downloadFd :: Bool -- ^ https?
|
downloadFd :: Bool -- ^ https?
|
||||||
-> String -- ^ host (e.g. "www.example.com")
|
-> ByteString -- ^ host (e.g. "www.example.com")
|
||||||
-> String -- ^ path (e.g. "/my/file")
|
-> ByteString -- ^ path (e.g. "/my/file")
|
||||||
-> Maybe Integer -- ^ optional port (e.g. 3000)
|
-> Maybe Int -- ^ optional port (e.g. 3000)
|
||||||
-> Fd -- ^ function creating an Fd to write the body into
|
-> Fd -- ^ function creating an Fd to write the body into
|
||||||
-> IO ()
|
-> IO ()
|
||||||
downloadFd https host path port fd =
|
downloadFd https host path port fd =
|
||||||
@ -245,19 +255,19 @@ downloadFd https host path port fd =
|
|||||||
|
|
||||||
|
|
||||||
downloadInternal :: Bool
|
downloadInternal :: Bool
|
||||||
-> String
|
-> ByteString
|
||||||
-> String
|
-> ByteString
|
||||||
-> Maybe Integer
|
-> Maybe Int
|
||||||
-> Either Fd (Path Abs, Maybe (Path Rel))
|
-> Either Fd (Path Abs, Maybe (Path Rel))
|
||||||
-> IO (Maybe (Path Abs))
|
-> IO (Maybe (Path Abs))
|
||||||
downloadInternal https host path port dest = do
|
downloadInternal https host path port dest = do
|
||||||
c <- case https of
|
c <- case https of
|
||||||
True -> do
|
True -> do
|
||||||
ctx <- baselineContextSSL
|
ctx <- baselineContextSSL
|
||||||
openConnectionSSL ctx (C.pack host) (fromIntegral $ fromMaybe 443 port)
|
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
|
||||||
False -> openConnection (C.pack host) (fromIntegral $ fromMaybe 80 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
|
sendRequest c q emptyBody
|
||||||
|
|
||||||
@ -296,20 +306,12 @@ downloadInternal https host path port dest = do
|
|||||||
Just x ->
|
Just x ->
|
||||||
let fp = dest </> x
|
let fp = dest </> x
|
||||||
in fmap (, fp) $ createRegularFileFd newFilePerms fp
|
in fmap (, fp) $ createRegularFileFd newFilePerms fp
|
||||||
Nothing ->
|
Nothing -> do
|
||||||
-- ...otherwise try to infer the filename from the URL path
|
-- ...otherwise try to infer the filename from the URL path
|
||||||
case (snd . T.breakOnEnd (fS "/") . T.pack) <$> decString False path of
|
let urlBaseName = snd . B.breakEnd (== _slash) $ urlDecode False path
|
||||||
Just x -> do
|
fn' <- parseRel urlBaseName
|
||||||
fn' <- parseRel (C.pack $ T.unpack x)
|
|
||||||
let fp = dest </> fn'
|
let fp = dest </> fn'
|
||||||
fmap (, fp) $ createRegularFileFd newFilePerms fp
|
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)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -372,7 +374,7 @@ getLinuxDistro = do
|
|||||||
hasWord t matches = foldr
|
hasWord t matches = foldr
|
||||||
(\x y ->
|
(\x y ->
|
||||||
( isJust
|
( isJust
|
||||||
. ICU.find (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> x <> fS "\\b"))
|
. ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> x <> [s|\\b|]))
|
||||||
$ t
|
$ t
|
||||||
)
|
)
|
||||||
|| y
|
|| y
|
||||||
@ -401,9 +403,9 @@ getLinuxDistro = do
|
|||||||
try_lsb_release_cmd = do
|
try_lsb_release_cmd = do
|
||||||
(Just _ ) <- findExecutable lsb_release_cmd
|
(Just _ ) <- findExecutable lsb_release_cmd
|
||||||
(Just name) <- (fmap . fmap) _stdOut
|
(Just name) <- (fmap . fmap) _stdOut
|
||||||
$ executeOut lsb_release_cmd [fS "-si"] Nothing
|
$ executeOut lsb_release_cmd [[s|-si|]] Nothing
|
||||||
ver <- (fmap . fmap) _stdOut
|
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)
|
pure (E.decodeUtf8 name, fmap E.decodeUtf8 ver)
|
||||||
|
|
||||||
try_lsb_release :: IO (Text, Maybe Text)
|
try_lsb_release :: IO (Text, Maybe Text)
|
||||||
@ -419,14 +421,14 @@ getLinuxDistro = do
|
|||||||
join
|
join
|
||||||
. fmap (ICU.group 0)
|
. fmap (ICU.group 0)
|
||||||
. ICU.find
|
. ICU.find
|
||||||
(ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> fS n <> fS "\\b")
|
(ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> fS n <> [s|\\b|])
|
||||||
)
|
)
|
||||||
$ t
|
$ t
|
||||||
verRe =
|
verRe =
|
||||||
join
|
join
|
||||||
. fmap (ICU.group 0)
|
. fmap (ICU.group 0)
|
||||||
. ICU.find
|
. ICU.find
|
||||||
(ICU.regex [ICU.CaseInsensitive] (fS "\\b(\\d)+(.(\\d)+)*\\b"))
|
(ICU.regex [ICU.CaseInsensitive] [s|\\b(\\d)+(.(\\d)+)*\\b|])
|
||||||
$ t
|
$ t
|
||||||
(Just name) <- pure
|
(Just name) <- pure
|
||||||
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
|
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
|
||||||
@ -454,31 +456,31 @@ unpackToTmpDir av = do
|
|||||||
fn <- basename av
|
fn <- basename av
|
||||||
let (fnrest, ext) = splitExtension $ toFilePath fn
|
let (fnrest, ext) = splitExtension $ toFilePath fn
|
||||||
let ext2 = takeExtension fnrest
|
let ext2 = takeExtension fnrest
|
||||||
tmpdir <- getEnvDefault (fS "TMPDIR") (fS "/tmp")
|
tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|]
|
||||||
tmp <- mkdtemp $ (tmpdir FP.</> fS "ghcup-")
|
tmp <- mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
|
||||||
let untar bs = do
|
let untar bs = do
|
||||||
Tar.unpack tmp . Tar.read $ bs
|
Tar.unpack tmp . Tar.read $ bs
|
||||||
Right <$> parseAbs tmp
|
Right <$> parseAbs tmp
|
||||||
|
|
||||||
-- extract, depending on file extension
|
-- extract, depending on file extension
|
||||||
if
|
if
|
||||||
| ext == fS ".gz" && ext2 == fS ".tar"
|
| ext == [s|.gz|] && ext2 == [s|.tar|]
|
||||||
-> untar . GZip.decompress =<< readFile av
|
-> untar . GZip.decompress =<< readFile av
|
||||||
| ext == fS ".xz" && ext2 == fS ".tar"
|
| ext == [s|.xz|] && ext2 == [s|.tar|]
|
||||||
-> do
|
-> do
|
||||||
filecontents <- readFile av
|
filecontents <- readFile av
|
||||||
let decompressed = Lzma.decompress filecontents
|
let decompressed = Lzma.decompress filecontents
|
||||||
-- putStrLn $ show decompressed
|
-- putStrLn $ show decompressed
|
||||||
untar decompressed
|
untar decompressed
|
||||||
| ext == fS ".bz2" && ext2 == fS ".tar"
|
| ext == [s|.bz2|] && ext2 == [s|.tar|]
|
||||||
-> untar . BZip.decompress =<< readFile av
|
-> untar . BZip.decompress =<< readFile av
|
||||||
| ext == fS ".tar" && ext2 == fS ".tar"
|
| ext == [s|.tar|]
|
||||||
-> untar =<< readFile av
|
-> untar =<< readFile av
|
||||||
| otherwise
|
| otherwise
|
||||||
-> pure $ Left $ UnknownArchive ext
|
-> pure $ Left $ UnknownArchive ext
|
||||||
|
|
||||||
where
|
where
|
||||||
isTar ext | ext == fS ".tar" = pure ()
|
isTar ext | ext == [s|.tar|] = pure ()
|
||||||
| otherwise = throwE $ UnknownArchive ext
|
| otherwise = throwE $ UnknownArchive ext
|
||||||
|
|
||||||
|
|
||||||
@ -487,8 +489,8 @@ installGHC :: Path Abs -- ^ Path to the unpacked GHC bindist
|
|||||||
-> Path Abs -- ^ Path to install to
|
-> Path Abs -- ^ Path to install to
|
||||||
-> IO ()
|
-> IO ()
|
||||||
installGHC path inst = do
|
installGHC path inst = do
|
||||||
exe (fS "./configure") [fS "--prefix=" <> toFilePath inst] False (Just path)
|
exec [s|./configure|] [[s|--prefix=|] <> toFilePath inst] False (Just path)
|
||||||
-- sh (fS "make") [fS "install"] (Just path)
|
exec [s|make|] [[s|install|]] True (Just path)
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
|
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
|
||||||
|
@ -159,15 +159,15 @@ createRegularFileFd fm dest =
|
|||||||
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
|
FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
|
||||||
|
|
||||||
|
|
||||||
exe :: ByteString
|
exec :: ByteString -- ^ thing to execute
|
||||||
-> [ByteString]
|
-> [ByteString] -- ^ args for the thing
|
||||||
-> Bool
|
-> Bool -- ^ whether to search PATH for the thing
|
||||||
-> Maybe (Path Abs)
|
-> Maybe (Path Abs) -- ^ optionally chdir into this
|
||||||
-> IO (Either ProcessError ())
|
-> IO (Either ProcessError ())
|
||||||
exe exe' args spath chdir = do
|
exec exe args spath chdir = do
|
||||||
pid <- SPPB.forkProcess $ do
|
pid <- SPPB.forkProcess $ do
|
||||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||||
SPPB.executeFile exe' spath args Nothing
|
SPPB.executeFile exe spath args Nothing
|
||||||
|
|
||||||
fmap toProcessError $ SPPB.getProcessStatus True True pid
|
fmap toProcessError $ SPPB.getProcessStatus True True pid
|
||||||
|
|
||||||
@ -179,4 +179,3 @@ toProcessError mps = case mps of
|
|||||||
Just (Terminated _ _ ) -> Left $ PTerminated
|
Just (Terminated _ _ ) -> Left $ PTerminated
|
||||||
Just (Stopped _ ) -> Left $ PStopped
|
Just (Stopped _ ) -> Left $ PStopped
|
||||||
Nothing -> Left $ NoSuchPid
|
Nothing -> Left $ NoSuchPid
|
||||||
|
|
||||||
|
@ -3,9 +3,9 @@
|
|||||||
module GHCup.Types where
|
module GHCup.Types where
|
||||||
|
|
||||||
import Data.Map.Strict ( Map )
|
import Data.Map.Strict ( Map )
|
||||||
import Network.URL
|
|
||||||
import qualified GHC.Generics as GHC
|
import qualified GHC.Generics as GHC
|
||||||
import Data.Versions
|
import Data.Versions
|
||||||
|
import URI.ByteString
|
||||||
|
|
||||||
|
|
||||||
data Tool = GHC
|
data Tool = GHC
|
||||||
@ -55,7 +55,7 @@ data PlatformRequest = PlatformRequest {
|
|||||||
, _rVersion :: Maybe Versioning
|
, _rVersion :: Maybe Versioning
|
||||||
} deriving (Eq, Show)
|
} deriving (Eq, Show)
|
||||||
|
|
||||||
type PlatformVersionSpec = Map (Maybe Versioning) URL
|
type PlatformVersionSpec = Map (Maybe Versioning) URI
|
||||||
type PlatformSpec = Map Platform PlatformVersionSpec
|
type PlatformSpec = Map Platform PlatformVersionSpec
|
||||||
type ArchitectureSpec = Map Architecture PlatformSpec
|
type ArchitectureSpec = Map Architecture PlatformSpec
|
||||||
type ToolVersionSpec = Map Version ArchitectureSpec
|
type ToolVersionSpec = Map Version ArchitectureSpec
|
||||||
@ -63,5 +63,5 @@ type AvailableDownloads = Map Tool ToolVersionSpec
|
|||||||
|
|
||||||
|
|
||||||
data URLSource = GHCupURL
|
data URLSource = GHCupURL
|
||||||
| OwnSource URL
|
| OwnSource URI
|
||||||
| OwnSpec AvailableDownloads
|
| OwnSpec AvailableDownloads
|
||||||
|
@ -14,10 +14,13 @@ import GHCup.Types
|
|||||||
import Data.Versions
|
import Data.Versions
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Aeson.TH
|
import Data.Aeson.TH
|
||||||
import Network.URL
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
import Data.Text.Encoding ( decodeUtf8
|
||||||
|
, encodeUtf8
|
||||||
|
)
|
||||||
import Data.Aeson.Types
|
import Data.Aeson.Types
|
||||||
import Data.Text.Encoding as E
|
import Data.Text.Encoding as E
|
||||||
|
import URI.ByteString
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -32,13 +35,14 @@ deriveJSON defaultOptions ''VSep
|
|||||||
deriveJSON defaultOptions ''VUnit
|
deriveJSON defaultOptions ''VUnit
|
||||||
|
|
||||||
|
|
||||||
instance ToJSON URL where
|
instance ToJSON URI where
|
||||||
toJSON = toJSON . exportURL
|
toJSON = toJSON . decodeUtf8 . serializeURIRef'
|
||||||
|
|
||||||
instance FromJSON URL where
|
instance FromJSON URI where
|
||||||
parseJSON = withText "URL" $ \t -> case importURL (T.unpack t) of
|
parseJSON = withText "URL" $ \t ->
|
||||||
Just x -> pure x
|
case parseURI strictURIParserOptions (encodeUtf8 t) of
|
||||||
Nothing -> fail "Could not parse URL, failure in importURL"
|
Right x -> pure x
|
||||||
|
Left e -> fail . show $ e
|
||||||
|
|
||||||
instance ToJSON Versioning where
|
instance ToJSON Versioning where
|
||||||
toJSON = toJSON . prettyV
|
toJSON = toJSON . prettyV
|
||||||
@ -62,8 +66,8 @@ instance ToJSONKey (Maybe Versioning) where
|
|||||||
Nothing -> T.pack "unknown_version"
|
Nothing -> T.pack "unknown_version"
|
||||||
|
|
||||||
instance FromJSONKey (Maybe Versioning) where
|
instance FromJSONKey (Maybe Versioning) where
|
||||||
fromJSONKey = FromJSONKeyTextParser
|
fromJSONKey = FromJSONKeyTextParser $ \t ->
|
||||||
$ \t -> if t == T.pack "unknown_version" then pure Nothing else pure $ just t
|
if t == T.pack "unknown_version" then pure Nothing else pure $ just t
|
||||||
where
|
where
|
||||||
just t = case versioning t of
|
just t = case versioning t of
|
||||||
Right x -> pure x
|
Right x -> pure x
|
||||||
|
@ -2,8 +2,10 @@
|
|||||||
|
|
||||||
module GHCup.Types.Optics where
|
module GHCup.Types.Optics where
|
||||||
|
|
||||||
|
import Data.ByteString ( ByteString )
|
||||||
import GHCup.Types
|
import GHCup.Types
|
||||||
import Optics
|
import Optics
|
||||||
|
import URI.ByteString
|
||||||
|
|
||||||
makePrisms ''Tool
|
makePrisms ''Tool
|
||||||
makePrisms ''Architecture
|
makePrisms ''Architecture
|
||||||
@ -14,3 +16,26 @@ makeLenses ''PlatformResult
|
|||||||
makeLenses ''ToolRequest
|
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
|
||||||
|
Loading…
Reference in New Issue
Block a user