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

Lol

Browse Source
This commit is contained in:
Julian Ospald 2020-02-22 19:21:10 +01:00
parent 21917dea3e
commit ac91cbd32b
8 changed files with 570 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

149
app/Main.hs
View File

@ -1,8 +1,151 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import qualified MyLib (someFunc)
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.IO.Class
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.Functor ( (<&>) )
import Data.Maybe
import Data.Semigroup ( (<>) )
import Data.Text ( Text )
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Traversable
import Data.Versions
import GHCup
import GHCup.File
import GHCup.Prelude
import GHCup.Types
import Haskus.Utils.Variant.Excepts
import HPath
import Options.Applicative
import System.Console.Pretty
import System.Exit
data Options = Options
{ optVerbose :: Bool
, optCache :: Bool
, optCommand :: Command
}
data Command
= InstallGHC InstallGHCOptions
| InstallCabal InstallCabalOptions
data InstallGHCOptions = InstallGHCOptions
{
ghcVer :: Maybe Version
}
data InstallCabalOptions = InstallCabalOptions
{
cabalVer :: Maybe Version
}
opts :: Parser Options
opts =
Options
<$> switch
(short 'v' <> long "verbose" <> help "Whether to enable verbosity")
<*> switch (short 'c' <> long "cache" <> help "Whether to cache downloads")
<*> com
com :: Parser Command
com = subparser
( command
"install-ghc"
( InstallGHC
<$> (info (installGHCOpts <**> helper)
(progDesc "Install a GHC version")
)
)
<> command
"install-cabal"
( InstallCabal
<$> (info (installCabalOpts <**> helper)
(progDesc "Install a cabal-install version")
)
)
)
installGHCOpts :: Parser InstallGHCOptions
installGHCOpts = InstallGHCOptions <$> optional
(option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The GHC version to install"
)
)
installCabalOpts :: Parser InstallCabalOptions
installCabalOpts = InstallCabalOptions <$> optional
(option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The Cabal version to install"
)
)
toSettings :: Options -> Settings
toSettings Options{..} =
let cache = optCache
in Settings{..}
main :: IO ()
main = do
putStrLn "Hello, Haskell!"
MyLib.someFunc
e <-
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \opt@Options {..} -> do
let settings = toSettings opt
-- wrapper to run effects with settings
let run = flip runReaderT settings . runStderrLoggingT . runE
@'[ FileError
, ArchiveError
, ProcessError
, URLException
, PlatformResultError
, NoDownload
, NoCompatibleArch
, DistroNotFound
, TagNotFound
]
case optCommand of
InstallGHC (InstallGHCOptions {..}) ->
run
$ do
d <- liftIO $ ghcupBaseDir
case ghcVer of
Just ver -> liftE $ installTool (ToolRequest GHC ver)
Nothing
(OwnSpec availableDownloads)
Nothing -> do
ver <-
getRecommended availableDownloads GHC
?? TagNotFound Recommended GHC
liftE $ installTool (ToolRequest GHC ver) Nothing (OwnSpec availableDownloads)
InstallCabal (InstallCabalOptions {..}) -> undefined
pure ()
-- print error, if any
-- case e of
-- Right () -> pure ()
-- Left t -> die (color Red $ t)

5
cabal.project
View File

@ -14,3 +14,8 @@ source-repository-package
type: git
location: https://github.com/composewell/streamly
tag: 4eb53e7f868bdc08afcc4b5210ab5916b9a4dfbc
source-repository-package
type: git
location: https://github.com/hasufell/tar-bytestring
tag: 64707be1abb534e88007e3320090598a0a9490a7

15
ghcup.cabal
View File

@ -38,10 +38,13 @@ 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 lzma { build-depends: lzma >= 0.0.0.3 }
common monad-logger { build-depends: monad-logger >= 0.3.31 }
common mtl { build-depends: mtl >= 2.2 }
common optics { build-depends: optics >= 0.2 }
common optics-vl { build-depends: optics-vl >= 0.2 }
common optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 }
common parsec { build-depends: parsec >= 3.1 }
common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 }
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 }
@ -65,7 +68,7 @@ common zlib { build-depends: zlib >= 0.6.2.1 }
common config
default-language: Haskell2010
ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates
ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded
default-extensions: LambdaCase
, MultiWayIf
, PackageImports
@ -96,6 +99,7 @@ library
, io-streams
, language-bash
, lzma
, monad-logger
, mtl
, optics
, optics-vl
@ -132,6 +136,15 @@ library
executable ghcup
import: config
, base
, bytestring
, haskus-utils-variant
, monad-logger
, mtl
, optparse-applicative
, text
, versions
, hpath
, pretty-terminal
main-is: Main.hs
-- other-modules:
-- other-extensions:

365
lib/GHCup.hs
View File

@ -14,7 +14,10 @@ module GHCup where
import qualified Codec.Archive.Tar as Tar
import Control.Applicative
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Logger
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class ( lift )
import Control.Monad.IO.Class
import Control.Exception.Safe
import Data.ByteString ( ByteString )
@ -83,6 +86,12 @@ import URI.ByteString.QQ
data Settings = Settings {
cache :: Bool
} deriving Show
---------------------------
--[ Excepts Error types ]--
@ -107,11 +116,18 @@ data ArchiveError = UnknownArchive ByteString
data URLException = UnsupportedURL
deriving Show
data FileError = CopyError
deriving Show
data TagNotFound = TagNotFound Tag Tool
deriving Show
----------------------
--[ Download stuff ]--
----------------------
--------------------------------
--[ AvailableDownloads stuff ]--
--------------------------------
-- TODO: version quasiquoter
@ -119,24 +135,60 @@ availableDownloads :: AvailableDownloads
availableDownloads = Map.fromList
[ ( GHC
, Map.fromList
[ ( (\(Right x) -> x) $ version [s|8.6.5|]
, Map.fromList
[ ( [ver|8.6.5|]
, VersionInfo [Latest] $ Map.fromList
[ ( A_64
, Map.fromList
[ ( Linux UnknownLinux
, Map.fromList
[ ( Nothing
, [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
]
)
, ( Linux Ubuntu
, Map.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
]
)
, ( Linux Debian
, Map.fromList
[ ( Nothing
, [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
, ( 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|]
, ( Just $ [vers|8|]
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
)
]
)
]
)
]
)
]
)
, ( Cabal
, Map.fromList
[ ( [ver|3.0.0.0|]
, VersionInfo [Latest] $ Map.fromList
[ ( A_64
, Map.fromList
[ ( Linux UnknownLinux
, Map.fromList
[ ( Nothing
, DownloadInfo
[uri|https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-linux.tar.xz|]
Nothing
)
]
)
@ -150,15 +202,40 @@ availableDownloads = Map.fromList
getDownloadURL :: (MonadCatch m, MonadIO m)
=> ToolRequest
-> Maybe PlatformRequest
-> URLSource
-> Excepts
'[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
m
URI
getDownloadURL (ToolRequest t v) mpfReq urlSource = do
-- | Get the tool versions that have this tag.
getTagged :: AvailableDownloads -> Tool -> Tag -> [Version]
getTagged av tool tag = toListOf
( ix tool
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
% to Map.keys
% folded
)
av
getLatest :: AvailableDownloads -> Tool -> Maybe Version
getLatest av tool = headOf folded $ getTagged av tool Latest
getRecommended :: AvailableDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended
----------------------
--[ Download stuff ]--
----------------------
getDownloadInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
=> ToolRequest
-> Maybe PlatformRequest
-> URLSource
-> Excepts
'[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
m
DownloadInfo
getDownloadInfo (ToolRequest t v) mpfReq urlSource = do
lift $ $(logDebug) ([s|Receiving download info from: |] <> showT urlSource)
-- lift $ monadLoggerLog undefined undefined undefined ""
(PlatformRequest arch plat ver) <- case mpfReq of
Just x -> pure x
Nothing -> do
@ -171,21 +248,21 @@ getDownloadURL (ToolRequest t v) mpfReq urlSource = do
OwnSource url -> fail "Not implemented"
OwnSpec dls -> pure dls
lE $ getDownloadURL' t v arch plat ver dls
lE $ getDownloadInfo' t v arch plat ver dls
getDownloadURL' :: Tool
-> Version
-- ^ tool version
-> Architecture
-- ^ user arch
-> Platform
-- ^ user platform
-> Maybe Versioning
-- ^ optional version of the platform
-> AvailableDownloads
-> Either NoDownload URI
getDownloadURL' t v a p mv dls = maybe
getDownloadInfo' :: Tool
-> Version
-- ^ tool version
-> Architecture
-- ^ user arch
-> Platform
-- ^ user platform
-> Maybe Versioning
-- ^ optional version of the platform
-> AvailableDownloads
-> Either NoDownload DownloadInfo
getDownloadInfo' t v a p mv dls = maybe
(Left NoDownload)
Right
(with_distro <|> without_distro_ver <|> without_distro)
@ -196,8 +273,7 @@ getDownloadURL' t v a p mv dls = maybe
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
preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
-- | Tries to download from the given http or https url
@ -221,25 +297,27 @@ 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' :: MonadIO m
=> URI
download' :: (MonadLogger m, MonadIO m)
=> DownloadInfo
-> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename
-> 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
download' dli dest mfn
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|https|] = dl True
| view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False
| otherwise = throwE UnsupportedURL
where
dl https = do
lift $ $(logInfo)
([s|downloading: |] <> E.decodeUtf8 (serializeURIRef' (view dlUri dli)))
host <-
preview (authorityL' % _Just % authorityHostL' % hostBSL') url
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
?? UnsupportedURL
let path = view pathL' url
let path = view (dlUri % pathL') dli
let port = preview
(authorityL' % _Just % authorityPortL' % _Just % portNumberL')
url
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
dli
liftIO $ download https host path port dest mfn
-- | Same as 'download', except with a file descriptor. Allows to e.g.
@ -308,8 +386,7 @@ downloadInternal https host path port dest = do
in fmap (, fp) $ createRegularFileFd newFilePerms fp
Nothing -> do
-- ...otherwise try to infer the filename from the URL path
let urlBaseName = snd . B.breakEnd (== _slash) $ urlDecode False path
fn' <- parseRel urlBaseName
fn' <- urlBaseName path
let fp = dest </> fn'
fmap (, fp) $ createRegularFileFd newFilePerms fp
@ -328,22 +405,25 @@ getArchitecture = case arch of
getPlatform :: (MonadCatch m, MonadIO m)
getPlatform :: (MonadLogger m, 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
getPlatform = do
pfr <- 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
lift $ $(logDebug) ([s|Identified Platform as: |] <> showT pfr)
pure pfr
where getFreeBSDVersion = pure Nothing
@ -374,7 +454,7 @@ getLinuxDistro = do
hasWord t matches = foldr
(\x y ->
( isJust
. ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> x <> [s|\\b|]))
. ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|]))
$ t
)
|| y
@ -421,14 +501,13 @@ getLinuxDistro = do
join
. fmap (ICU.group 0)
. ICU.find
(ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> fS n <> [s|\\b|])
)
(ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> fS n <> [s|\b|]))
$ t
verRe =
join
. fmap (ICU.group 0)
. ICU.find
(ICU.regex [ICU.CaseInsensitive] [s|\\b(\\d)+(.(\\d)+)*\\b|])
(ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|])
$ t
(Just name) <- pure
(nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
@ -440,58 +519,142 @@ getLinuxDistro = do
pure (T.pack "debian", Just $ lBS2sT ver)
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
-- parseAvailableDownloads = undefined
------------------------
--[ GHC installation ]--
------------------------
-- TODO: subdir to configure script in availableDownloads?
-- TODO: quasiquote for ascii bytestrings
-------------------------
--[ Tool installation ]--
-------------------------
-- | 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 [s|TMPDIR|] [s|/tmp|]
tmp <- mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
let untar bs = do
Tar.unpack tmp . Tar.read $ bs
Right <$> parseAbs tmp
installTool :: ( MonadThrow m
, MonadReader Settings m
, MonadLogger m
, MonadCatch m
, MonadIO m
)
=> ToolRequest
-> Maybe PlatformRequest
-> URLSource
-> Excepts
'[FileError, ArchiveError, ProcessError, URLException, PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
m
()
installTool treq mpfReq urlSource = do
Settings {..} <- lift ask
lift $ $(logDebug) ([s|Requested to install: |] <> showT treq)
dlinfo <- liftE $ getDownloadInfo treq mpfReq urlSource
dl <- case cache of
True -> do
cachedir <- liftIO $ ghcupCacheDir
fn <- urlBaseName $ view (dlUri % pathL') dlinfo
let cachfile = cachedir </> fn
fileExists <- liftIO $ doesFileExist cachfile
if
| fileExists -> pure $ cachfile
| otherwise -> liftE $ download' dlinfo cachedir Nothing
False -> do
tmp <- liftIO mkGhcupTmpDir
liftE $ download' dlinfo tmp Nothing
unpacked <- liftE $ unpackToTmpDir dl
ghcdir <- liftIO $ do
toolsubdir <- ghcupGHCDir
versubdir <- parseRel (E.encodeUtf8 . prettyVer . view toolVersion $ treq)
pure (toolsubdir </> versubdir)
bindir <- liftIO ghcupBinDir
-- extract, depending on file extension
if
| ext == [s|.gz|] && ext2 == [s|.tar|]
-> untar . GZip.decompress =<< readFile av
| ext == [s|.xz|] && ext2 == [s|.tar|]
-> do
filecontents <- readFile av
let decompressed = Lzma.decompress filecontents
-- putStrLn $ show decompressed
untar decompressed
| ext == [s|.bz2|] && ext2 == [s|.tar|]
-> untar . BZip.decompress =<< readFile av
| ext == [s|.tar|]
-> untar =<< readFile av
| otherwise
-> pure $ Left $ UnknownArchive ext
-- the subdir of the archive where we do the work
let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo)
where
isTar ext | ext == [s|.tar|] = pure ()
| otherwise = throwE $ UnknownArchive ext
case treq of
(ToolRequest GHC ver) -> liftE $ installGHC archiveSubdir ghcdir
(ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir
pure ()
-- | Install an unpacked GHC distribution.
installGHC :: Path Abs -- ^ Path to the unpacked GHC bindist
installGHC :: (MonadLogger m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked GHC bindist
-> Path Abs -- ^ Path to install to
-> IO ()
-> Excepts '[ProcessError] m ()
installGHC path inst = do
exec [s|./configure|] [[s|--prefix=|] <> toFilePath inst] False (Just path)
exec [s|make|] [[s|install|]] True (Just path)
lift $ $(logInfo) ([s|Installing GHC|])
lEM $ liftIO $ exec [s|./configure|]
[[s|--prefix=|] <> toFilePath inst]
False
(Just path)
lEM $ liftIO $ exec [s|make|] [[s|install|]] True (Just path)
pure ()
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
-- parseAvailableDownloads = undefined
-- | Install an unpacked cabal distribution.
installCabal :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked cabal bindist
-> Path Abs -- ^ Path to install to
-> Excepts '[FileError] m ()
installCabal path inst = do
lift $ $(logInfo) ([s|Installing cabal|])
let cabalFile = [rel|cabal|] :: Path Rel
handleIO (\_ -> throwE CopyError) $ liftIO $ copyFile (path </> cabalFile)
(inst </> cabalFile)
Overwrite
-----------------
--[ Utilities ]--
-----------------
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
home <- liftIO getHomeDirectory
pure (home </> ([rel|.ghcup|] :: Path Rel))
ghcupGHCDir :: IO (Path Abs)
ghcupGHCDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- | Unpack an archive to a temporary directory and return that path.
unpackToTmpDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ archive path
-> Excepts '[ArchiveError] m (Path Abs)
unpackToTmpDir av = do
lift $ $(logInfo) ([s|Unpacking: |] <> E.decodeUtf8 (toFilePath av))
fn <- basename av
let (fnrest, ext) = splitExtension $ toFilePath fn
let ext2 = takeExtension fnrest
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
let untar bs = do
Tar.unpack tmp . Tar.read $ bs
parseAbs tmp
-- extract, depending on file extension
if
| ext == [s|.gz|], ext2 == [s|.tar|] -> liftIO
(untar . GZip.decompress =<< readFile av)
| ext == [s|.xz|], ext2 == [s|.tar|] -> do
filecontents <- liftIO $ readFile av
let decompressed = Lzma.decompress filecontents
liftIO $ untar decompressed
| ext == [s|.bz2|], ext2 == [s|.tar|] -> liftIO
(untar . BZip.decompress =<< readFile av)
| ext == [s|.tar|] -> liftIO (untar =<< readFile av)
| otherwise -> throwE $ UnknownArchive ext

61
lib/GHCup/File.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.File where
@ -6,6 +7,7 @@ import Data.ByteString
import qualified Data.ByteString.Lazy as L
import Data.Char
import Data.Maybe
import Data.String.QQ
import HPath
import HPath.IO
import Optics
@ -19,14 +21,18 @@ import Control.Exception.Safe
import Data.Functor
import System.Posix.Files.ByteString
import System.Posix.Foreign ( oExcl )
import System.Posix.Env.ByteString
import System.IO
import qualified System.Posix.FilePath as FP
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
import qualified System.Posix.Process.ByteString
as SPPB
import System.Posix.Directory.ByteString
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Temp.ByteString
import System.Posix.Types
import qualified System.Posix.User as PU
import qualified Streamly.Internal.Memory.ArrayStream
as AS
@ -41,12 +47,17 @@ import GHCup.Prelude
import Control.Concurrent.Async
import Control.Concurrent
import System.Posix.FD as FD
import qualified Data.ByteString.UTF8 as UTF8
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding )
import GHC.Foreign ( peekCStringLen )
data ProcessError = NonZeroExit Int
| PTerminated
| PStopped
| NoSuchPid
data ProcessError = NonZeroExit Int ByteString [ByteString]
| PTerminated ByteString [ByteString]
| PStopped ByteString [ByteString]
| NoSuchPid ByteString [ByteString]
deriving Show
@ -169,13 +180,41 @@ exec exe args spath chdir = do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args Nothing
fmap toProcessError $ SPPB.getProcessStatus True True pid
fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
toProcessError :: Maybe ProcessStatus -> Either ProcessError ()
toProcessError mps = case mps of
Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i
toProcessError :: ByteString
-> [ByteString]
-> Maybe ProcessStatus
-> Either ProcessError ()
toProcessError exe args mps = case mps of
Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
Just (SPPB.Exited ExitSuccess ) -> Right ()
Just (Terminated _ _ ) -> Left $ PTerminated
Just (Stopped _ ) -> Left $ PStopped
Nothing -> Left $ NoSuchPid
Just (Terminated _ _ ) -> Left $ PTerminated exe args
Just (Stopped _ ) -> Left $ PStopped exe args
Nothing -> Left $ NoSuchPid exe args
mkGhcupTmpDir :: IO (Path Abs)
mkGhcupTmpDir = do
tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
parseAbs tmp
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
e <- getEnv [s|HOME|]
case e of
Just fp -> parseAbs fp
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess
-- | Convert the String to a ByteString with the current
-- system encoding.
unsafePathToString :: Path b -> IO FilePath
unsafePathToString (Path p) = do
enc <- getLocaleEncoding
unsafeUseAsCStringLen p (peekCStringLen enc)

69
lib/GHCup/Prelude.hs
View File

@ -3,6 +3,9 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
module GHCup.Prelude where
@ -10,15 +13,23 @@ import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Control.Exception.Safe
import Data.ByteString (ByteString)
import qualified Data.Strict.Maybe as S
import Data.Monoid ( (<>) )
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.Text as T
import Data.Versions
import qualified Data.ByteString.Lazy as L
import Haskus.Utils.Variant.Excepts
import System.IO.Error
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Exp(..), Lift)
import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import GHC.Base
@ -44,6 +55,9 @@ iE :: String -> IO a
iE = internalError
showT :: Show a => a -> Text
showT = fS . show
-- | Like 'when', but where the test can be monadic.
whenM :: Monad m => m Bool -> m () -> m ()
whenM ~b ~t = ifM b t (return ())
@ -99,3 +113,58 @@ lEM em = lift em >>= lE
fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight
deriving instance Lift Versioning
deriving instance Lift Version
deriving instance Lift SemVer
deriving instance Lift Mess
deriving instance Lift PVP
deriving instance Lift (NonEmpty Word)
deriving instance Lift VSep
deriving instance Lift VUnit
instance Lift Text
qq :: (Text -> Q Exp) -> QuasiQuoter
qq quoteExp' =
QuasiQuoter
{ quoteExp = (\s -> quoteExp' . T.pack $ s)
, quotePat = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a type)"
, quoteDec = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a declaration)"
}
ver :: QuasiQuoter
ver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . version
mver :: QuasiQuoter
mver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . mess
sver :: QuasiQuoter
sver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . semver
vers :: QuasiQuoter
vers = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . versioning
pver :: QuasiQuoter
pver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . pvp

21
lib/GHCup/Types.hs
View File

@ -2,15 +2,29 @@
module GHCup.Types where
import HPath
import Data.Map.Strict ( Map )
import qualified GHC.Generics as GHC
import Data.Versions
import URI.ByteString
data Tag = Latest
| Recommended
deriving (Eq, Show)
data VersionInfo = VersionInfo {
_viTags :: [Tag]
, _viArch :: ArchitectureSpec
} deriving (Eq, Show)
data DownloadInfo = DownloadInfo {
_dlUri :: URI
, _dlSubdir :: Maybe (Path Rel)
} deriving (Eq, Show)
data Tool = GHC
| Cabal
| Stack
deriving (Eq, GHC.Generic, Ord, Show)
data ToolRequest = ToolRequest {
@ -55,13 +69,14 @@ data PlatformRequest = PlatformRequest {
, _rVersion :: Maybe Versioning
} deriving (Eq, Show)
type PlatformVersionSpec = Map (Maybe Versioning) URI
type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
type PlatformSpec = Map Platform PlatformVersionSpec
type ArchitectureSpec = Map Architecture PlatformSpec
type ToolVersionSpec = Map Version ArchitectureSpec
type ToolVersionSpec = Map Version VersionInfo
type AvailableDownloads = Map Tool ToolVersionSpec
data URLSource = GHCupURL
| OwnSource URI
| OwnSpec AvailableDownloads
deriving Show

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

@ -11,9 +11,13 @@ makePrisms ''Tool
makePrisms ''Architecture
makePrisms ''LinuxDistro
makePrisms ''Platform
makePrisms ''Tag
makeLenses ''PlatformResult
makeLenses ''ToolRequest
makeLenses ''DownloadInfo
makeLenses ''Tag
makeLenses ''VersionInfo
uriSchemeL' :: Lens' (URIRef Absolute) Scheme