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

Stuff

Browse Source
This commit is contained in:
Julian Ospald
2020-02-18 09:40:01 +01:00
parent e4754f4e4e
commit d4ed158acb
7 changed files with 314 additions and 214 deletions
Download Patch File Download Diff File Expand all files Collapse all files

372
lib/GHCup.hs
View File

@@ -11,11 +11,13 @@
module GHCup where
import qualified Codec.Archive.Tar as Tar
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Control.Exception.Safe
import Data.ByteString ( ByteString )
import Data.Foldable ( asum )
import Data.Text ( Text )
import Data.Versions
@@ -39,12 +41,19 @@ import Data.Maybe
import qualified Data.Map.Strict as Map
import GHC.IO.Exception
import GHC.IO.Handle
import Haskus.Utils.Variant.Excepts
import Haskus.Utils.Variant.VEither
import Network.Http.Client hiding ( URL )
import System.IO.Streams ( InputStream
, OutputStream
, stdout
)
import qualified System.IO.Streams as Streams
import System.Posix.FilePath ( takeExtension
, splitExtension
)
import qualified System.Posix.FilePath as FP
import System.Posix.Env.ByteString ( getEnvDefault )
import System.Posix.Temp.ByteString
import "unix" System.Posix.IO.ByteString
hiding ( fdWrite )
@@ -58,6 +67,40 @@ import System.Posix.Types
import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite )
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.Lzma as Lzma
import qualified Codec.Compression.BZip as BZip
import qualified Data.ByteString.UTF8 as UTF8
---------------------------
--[ Excepts Error types ]--
---------------------------
data PlatformResultError = NoCompatiblePlatform
deriving Show
data NoDownload = NoDownload
deriving Show
data NoCompatibleArch = NoCompatibleArch String
deriving Show
data DistroNotFound = DistroNotFound
deriving Show
data ArchiveError = UnknownArchive ByteString
deriving Show
----------------------
--[ Download stuff ]--
----------------------
availableDownloads :: AvailableDownloads
@@ -103,16 +146,20 @@ availableDownloads = Map.fromList
}
getDownloadURL :: ToolRequest
getDownloadURL :: (MonadCatch m, MonadIO m)
=> ToolRequest
-> Maybe PlatformRequest
-> URLSource
-> IO (Maybe URL) -- TODO: better error handling
-> Excepts
'[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
m
URL
getDownloadURL (ToolRequest t v) mpfReq urlSource = do
(PlatformRequest arch plat ver) <- case mpfReq of
Just x -> pure x
Nothing -> do
(PlatformResult rp rv) <- getPlatform
let ar = (\(Right x) -> x) getArchitecture
(PlatformResult rp rv) <- liftE getPlatform
ar <- lE getArchitecture
pure $ PlatformRequest ar rp rv
dls <- case urlSource of
@@ -120,7 +167,7 @@ getDownloadURL (ToolRequest t v) mpfReq urlSource = do
OwnSource url -> fail "Not implemented"
OwnSpec dls -> pure dls
pure $ getDownloadURL' t v arch plat ver dls
lE $ getDownloadURL' t v arch plat ver dls
getDownloadURL' :: Tool
@@ -133,136 +180,22 @@ getDownloadURL' :: Tool
-> Maybe Versioning
-- ^ optional version of the platform
-> AvailableDownloads
-> Maybe URL
getDownloadURL' t v a p mv dls =
with_distro <|> without_distro_ver <|> without_distro
-> Either NoDownload URL
getDownloadURL' t v a p mv dls = maybe
(Left NoDownload)
Right
(with_distro <|> without_distro_ver <|> without_distro)
where
with_distro = distro_preview id id
without_distro = distro_preview (set _Linux UnknownLinux) id
without_distro_ver = distro_preview id (const Nothing)
without_distro = distro_preview (set _Linux UnknownLinux) (const Nothing)
distro_preview f g =
preview (atJust t % atJust v % atJust a % atJust (f p) % atJust (g mv)) dls
atJust x = at x % _Just
getArchitecture :: Either String Architecture
getArchitecture = case arch of
"x86_64" -> pure A_64
"i386" -> pure A_32
what -> Left ("Could not find compatible architecture. Was: " <> what)
getPlatform :: IO PlatformResult
getPlatform = case os of
"linux" -> do
(distro, ver) <- getLinuxDistro
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
-- TODO: these are not verified
"darwin" ->
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
"freebsd" -> do
ver <- getFreeBSDVersion
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
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 ["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
recreateSymlink undefined undefined Overwrite
pure (distro, parsedVer)
where
hasWord t matches = foldr
(\x y ->
( isJust
. ICU.find (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> x <> fS "\\b"))
$ t
)
|| y
)
False
(T.pack <$> matches)
os_release :: Path Abs
os_release = [abs|/etc/os-release|]
lsb_release :: Path Abs
lsb_release = [abs|/etc/lsb-release|]
lsb_release_cmd :: Path Rel
lsb_release_cmd = [rel|lsb-release|]
redhat_release :: Path Abs
redhat_release = [abs|/etc/redhat-release|]
debian_version :: Path Abs
debian_version = [abs|/etc/debian_version|]
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_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd = do
(Just _ ) <- findExecutable lsb_release_cmd
(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
(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)
-- | 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:
@@ -284,7 +217,10 @@ 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 -> Path Abs -> Maybe (Path Rel) -> IO (Path Abs)
download' :: URL
-> 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
@@ -293,7 +229,7 @@ download' url dest mfn = case url of
-- | Same as 'download', except with a file descriptor. Allows to e.g.
-- print to stdout.
downloadFd :: Bool -- ^ https?
downloadFd :: Bool -- ^ https?
-> String -- ^ host (e.g. "www.example.com")
-> String -- ^ path (e.g. "/my/file")
-> Maybe Integer -- ^ optional port (e.g. 3000)
@@ -372,11 +308,185 @@ downloadInternal https host path port dest = do
-- unpack :: Path Abs -> IO (Path Abs)
-- unpack = undefined
--------------------------
--[ Platform detection ]--
--------------------------
-- install :: DownloadURL -> IO (Path Abs)
-- install = undefined
getArchitecture :: Either NoCompatibleArch Architecture
getArchitecture = case arch of
"x86_64" -> Right A_64
"i386" -> Right A_32
what -> Left (NoCompatibleArch what)
getPlatform :: (MonadCatch m, MonadIO m)
=> Excepts
'[PlatformResultError, DistroNotFound]
m
PlatformResult
getPlatform = case os of
"linux" -> do
(distro, ver) <- liftE getLinuxDistro
pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
-- TODO: these are not verified
"darwin" ->
pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
"freebsd" -> do
ver <- getFreeBSDVersion
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
what -> throwE NoCompatiblePlatform
where getFreeBSDVersion = pure Nothing
getLinuxDistro :: (MonadCatch m, MonadIO m)
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro = do
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ 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 ["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
hasWord t matches = foldr
(\x y ->
( isJust
. ICU.find (ICU.regex [ICU.CaseInsensitive] (fS "\\b" <> x <> fS "\\b"))
$ t
)
|| y
)
False
(T.pack <$> matches)
os_release :: Path Abs
os_release = [abs|/etc/os-release|]
lsb_release :: Path Abs
lsb_release = [abs|/etc/lsb-release|]
lsb_release_cmd :: Path Rel
lsb_release_cmd = [rel|lsb-release|]
redhat_release :: Path Abs
redhat_release = [abs|/etc/redhat-release|]
debian_version :: Path Abs
debian_version = [abs|/etc/debian_version|]
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_lsb_release_cmd :: IO (Text, Maybe Text)
try_lsb_release_cmd = do
(Just _ ) <- findExecutable lsb_release_cmd
(Just name) <- (fmap . fmap) _stdOut
$ executeOut lsb_release_cmd [fS "-si"] Nothing
ver <- (fmap . fmap) _stdOut
$ executeOut lsb_release_cmd [fS "-sr"] Nothing
pure (lBS2sT name, fmap lBS2sT ver)
try_lsb_release :: IO (Text, Maybe Text)
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
ver <- readFile debian_version
pure (T.pack "debian", Just $ lBS2sT ver)
------------------------
--[ GHC installation ]--
------------------------
-- TODO: quasiquote for ascii bytestrings
-- | Unpack an archive to a temporary directory and return that path.
unpackToTmpDir :: Path Abs -- ^ archive path
-> IO (Either ArchiveError (Path Abs))
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-")
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"
-> untar . GZip.decompress =<< readFile av
| ext == fS ".xz" && ext2 == fS ".tar"
-> do
filecontents <- readFile av
let decompressed = Lzma.decompress filecontents
-- putStrLn $ show decompressed
untar decompressed
| ext == fS ".bz2" && ext2 == fS ".tar"
-> untar . BZip.decompress =<< readFile av
| ext == fS ".tar" && ext2 == fS ".tar"
-> untar =<< readFile av
| otherwise
-> pure $ Left $ UnknownArchive ext
where
isTar ext | ext == fS ".tar" = pure ()
| otherwise = throwE $ UnknownArchive ext
-- | Install an unpacked GHC distribution.
installGHC :: Path Abs -- ^ Path to the unpacked GHC bindist
-> Path Abs -- ^ Path to install to
-> IO ()
installGHC path inst = do
let c = [rel|./configure|] :: Path Rel
executeOut c [fS "--prefix=" <> toFilePath inst] (Just path)
let m = [rel|make|] :: Path Rel
executeOut m [fS "install"] (Just path)
pure ()
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
-- parseAvailableDownloads = undefined

26
lib/GHCup/File.hs
View File

@@ -9,7 +9,8 @@ import Data.Maybe
import HPath
import HPath.IO
import Optics
import Streamly.ByteString
import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy
import Streamly
import System.Posix.FilePath hiding ( (</>) )
import Data.Foldable
@@ -23,6 +24,7 @@ import "unix" System.Posix.IO.ByteString
hiding ( openFd )
import qualified System.Posix.Process.ByteString
as SPPB
import System.Posix.Directory.ByteString
import System.Posix.Types
import qualified Streamly.Internal.Memory.ArrayStream
@@ -52,10 +54,7 @@ makeLenses ''CapturedProcess
readFd :: Fd -> IO L.ByteString
readFd fd = do
handle' <- fdToHandle fd
let stream =
(S.unfold (SU.finallyIO hClose FH.readChunks) handle')
>>= arrayToByteString
toLazyByteString <$> S.fold FL.mconcat (fmap byteString stream)
fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle')
-- | Read the lines of a file into a stream. The stream holds
@@ -65,9 +64,9 @@ readFileLines :: Path b -> IO (SerialT IO ByteString)
readFileLines p = do
stream <- readFileStream p
pure
. (>>= arrayToByteString)
. (fmap fromArray)
. AS.splitOn (fromIntegral $ ord '\n')
. (>>= byteStringToArray)
. (fmap toArray)
$ stream
@@ -89,11 +88,14 @@ findExecutable ex = do
-- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess.
executeOut :: Path Rel -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command
executeOut :: Path Rel -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command
-> Maybe (Path Abs) -- ^ chdir to this path
-> IO (Maybe CapturedProcess)
executeOut path args = withRelPath path
$ \fp -> captureOutStreams $ SPPB.executeFile fp True args Nothing
executeOut path args chdir = withRelPath path
$ \fp -> captureOutStreams $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile fp True args Nothing
-- | Capture the stdout and stderr of the given action, which
@@ -101,7 +103,7 @@ executeOut path args = withRelPath path
-- 'race' this to make sure it terminates.
captureOutStreams :: IO a
-- ^ the action to execute in a subprocess
-> IO (Maybe CapturedProcess)
-> IO (Maybe CapturedProcess) -- TODO: shouldn't be maybe
captureOutStreams action =
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do

25
lib/GHCup/Prelude.hs
View File

@@ -1,11 +1,14 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.Prelude where
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Control.Exception.Safe
import qualified Data.Strict.Maybe as S
import Data.Monoid ( (<>) )
@@ -14,6 +17,7 @@ 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 Haskus.Utils.Variant.Excepts
import System.IO.Error
@@ -74,3 +78,24 @@ handleIO' :: IOErrorType -> (IOException -> IO ()) -> IO () -> IO ()
handleIO' err handler =
handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e)
(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
(??) m e = maybe (throwE e) pure m
(!?) :: forall e es a m
. (Monad m, e :< es)
=> m (Maybe a)
-> e
-> Excepts es m a
(!?) em e = lift em >>= (?? e)
lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
lE = liftE . veitherToExcepts . fromEither
lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
lEM em = lift em >>= lE
fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight

57
lib/Streamly/ByteString.hs
View File

@@ -1,57 +0,0 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Streamly.ByteString where
import Control.Monad.IO.Class
import Data.ByteString hiding (length)
import qualified Data.ByteString as BS
import Data.ByteString.Unsafe
import Data.Word (Word8)
import Foreign.ForeignPtr
import Foreign.ForeignPtr.Unsafe
import Foreign.Ptr (castPtr, minusPtr, plusPtr)
import Prelude hiding (length)
import Streamly
import Streamly.Internal.Memory.Array.Types
import Streamly.Memory.Array
import qualified Streamly.Prelude as S
toByteString ::
forall m. (MonadIO m, MonadAsync m)
=> SerialT m (Array Word8)
-> m ByteString
toByteString stream =
let xs = S.mapM arrayToByteString stream
ys = S.foldlM' (\a b -> pure $ a <> b) mempty xs
in ys
arrayToByteString :: (MonadIO m) => Array Word8 -> m ByteString
arrayToByteString arr
| length arr == 0 = return mempty
arrayToByteString Array {..} =
liftIO $
withForeignPtr aStart $ \ptr ->
unsafePackCStringFinalizer ptr aLen (return ())
where
aLen =
let p = unsafeForeignPtrToPtr aStart
in aEnd `minusPtr` p
byteStringToArray :: (MonadIO m) => ByteString -> m (Array Word8)
byteStringToArray bs =
liftIO $
unsafeUseAsCStringLen
bs
(\(ptr, _) -> do
let endPtr pr = (castPtr pr `plusPtr` (BS.length bs))
fptr <- newForeignPtr_ (castPtr ptr)
return $ Array {aStart = fptr, aEnd = endPtr ptr, aBound = endPtr ptr})
fromByteString ::
forall m. (MonadIO m)
=> ByteString
-> m (Array Word8)
fromByteString bs = byteStringToArray bs