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

More

Browse Source
This commit is contained in:
Julian Ospald 2020-02-24 14:56:13 +01:00
parent ac91cbd32b
commit b3eac9bf54
8 changed files with 350 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
TODO.md
View File

@ -1,5 +1,21 @@
# TODOs and Remarks # TODOs and Remarks
## New
* Downloads from URL
* set Set currently active GHC version
* list Show available GHCs and other tools
* upgrade Upgrade this script in-place
* rm Remove an already installed GHC
* debug-info Print debug info (e.g. detected system/distro)
* changelog Show the changelog of a GHC release (online)
* print-system-reqs Print an approximation of system requirements
* testing (especially distro detection -> unit tests)
## Old
* handling of SIGTERM and SIGUSR * handling of SIGTERM and SIGUSR
* add support for RC/alpha/HEAD versions * add support for RC/alpha/HEAD versions
* redo/rethink how tool tags works * redo/rethink how tool tags works
@ -10,7 +26,6 @@
* --copy-compiler-tools * --copy-compiler-tools
* installing multiple versions in parallel? * installing multiple versions in parallel?
* exception handling (checked exception library? Maybe effects system all the way?)
* how to version and extend the format of the downloads file? Compatibility? * how to version and extend the format of the downloads file? Compatibility?
* how to propagate updates? Automatically? Might solve the versioning problem * how to propagate updates? Automatically? Might solve the versioning problem
* installing musl on demand? * installing musl on demand?

98
app/Main.hs
View File

@ -1,6 +1,8 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
module Main where module Main where
@ -12,6 +14,7 @@ import Data.ByteString ( ByteString )
import Data.Functor ( (<&>) ) import Data.Functor ( (<&>) )
import Data.Maybe import Data.Maybe
import Data.Semigroup ( (<>) ) import Data.Semigroup ( (<>) )
import Data.String.QQ
import Data.Text ( Text ) import Data.Text ( Text )
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
@ -29,6 +32,7 @@ import System.Exit
data Options = Options data Options = Options
{ optVerbose :: Bool { optVerbose :: Bool
, optCache :: Bool , optCache :: Bool
@ -102,50 +106,64 @@ installCabalOpts = InstallCabalOptions <$> optional
toSettings :: Options -> Settings toSettings :: Options -> Settings
toSettings Options{..} = toSettings Options {..} = let cache = optCache in Settings { .. }
let cache = optCache
in Settings{..}
-- TODO: something better than Show instance for errors
main :: IO () main :: IO ()
main = do main = do
e <- -- logger interpreter
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm) let runLogger = runStderrLoggingT
>>= \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 customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \opt@Options {..} -> do
let settings = toSettings opt
-- wrapper to run effects with settings
let
runInstTool =
runLogger
. flip runReaderT settings
. runE
@'[FileError, ArchiveError, ProcessError, URLException, PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound, TagNotFound, AlreadyInstalled]
case optCommand of
InstallGHC (InstallGHCOptions {..}) -> InstallGHC (InstallGHCOptions {..}) ->
run void
$ do $ (runInstTool $ do
d <- liftIO $ ghcupBaseDir v <- maybe
case ghcVer of ( getRecommended availableDownloads GHC
Just ver -> liftE $ installTool (ToolRequest GHC ver) ?? TagNotFound Recommended GHC
Nothing )
(OwnSpec availableDownloads) pure
Nothing -> do ghcVer
ver <- liftE $ installTool (ToolRequest GHC v)
getRecommended availableDownloads GHC Nothing
?? TagNotFound Recommended GHC (OwnSpec availableDownloads)
liftE $ installTool (ToolRequest GHC ver) Nothing (OwnSpec availableDownloads) )
InstallCabal (InstallCabalOptions {..}) -> undefined >>= \case
VRight _ -> pure ()
VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|])
VLeft e -> die (color Red $ show e)
InstallCabal (InstallCabalOptions {..}) ->
void
$ (runInstTool $ do
v <- maybe
( getRecommended availableDownloads Cabal
?? TagNotFound Recommended Cabal
)
pure
cabalVer
liftE $ installTool (ToolRequest Cabal v)
Nothing
(OwnSpec availableDownloads)
)
>>= \case
VRight _ -> pure ()
VLeft (V (AlreadyInstalled treq)) ->
runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|])
VLeft e -> die (color Red $ show e)
pure () pure ()
-- print error, if any
-- case e of
-- Right () -> pure ()
-- Left t -> die (color Red $ t)

3
cabal.project
View File

@ -10,6 +10,9 @@ package streamly
package ghcup package ghcup
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
package tar-bytestring
ghc-options: -O2
source-repository-package source-repository-package
type: git type: git
location: https://github.com/composewell/streamly location: https://github.com/composewell/streamly

3
ghcup.cabal
View File

@ -31,6 +31,7 @@ common containers { build-depends: containers >= 0.6 }
common generics-sop { build-depends: generics-sop >= 0.5 } common generics-sop { build-depends: generics-sop >= 0.5 }
common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 } common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 }
common hpath { build-depends: hpath >= 0.11 } common hpath { build-depends: hpath >= 0.11 }
common hpath-directory { build-depends: hpath-directory >= 0.13.2 }
common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 } common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
common hpath-io { build-depends: hpath-io >= 0.13.1 } common hpath-io { build-depends: hpath-io >= 0.13.1 }
common hpath-posix { build-depends: hpath-posix >= 0.11.1 } common hpath-posix { build-depends: hpath-posix >= 0.11.1 }
@ -92,6 +93,7 @@ library
, generics-sop , generics-sop
, haskus-utils-variant , haskus-utils-variant
, hpath , hpath
, hpath-directory
, hpath-filepath , hpath-filepath
, hpath-io , hpath-io
, hpath-posix , hpath-posix
@ -145,6 +147,7 @@ executable ghcup
, versions , versions
, hpath , hpath
, pretty-terminal , pretty-terminal
, string-qq
main-is: Main.hs main-is: Main.hs
-- other-modules: -- other-modules:
-- other-extensions: -- other-extensions:

240
lib/GHCup.hs
View File

@ -6,6 +6,7 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
-- TODO: handle SIGTERM, SIGUSR -- TODO: handle SIGTERM, SIGUSR
module GHCup where module GHCup where
@ -14,8 +15,10 @@ module GHCup where
import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar as Tar
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
import Control.Monad.Fail ( MonadFail )
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Cont
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -55,11 +58,15 @@ import System.IO.Streams ( InputStream
) )
import qualified System.IO.Streams as Streams import qualified System.IO.Streams as Streams
import System.Posix.FilePath ( takeExtension import System.Posix.FilePath ( takeExtension
, takeFileName
, splitExtension , splitExtension
) )
import qualified System.Posix.FilePath as FP import qualified System.Posix.FilePath as FP
import System.Posix.Files.ByteString ( readSymbolicLink )
import System.Posix.Env.ByteString ( getEnvDefault ) import System.Posix.Env.ByteString ( getEnvDefault )
import System.Posix.Temp.ByteString import System.Posix.Temp.ByteString
import System.Posix.RawFilePath.Directory.Errors
( hideError )
import "unix" System.Posix.IO.ByteString import "unix" System.Posix.IO.ByteString
hiding ( fdWrite ) hiding ( fdWrite )
import System.Posix.FD as FD import System.Posix.FD as FD
@ -86,9 +93,10 @@ import URI.ByteString.QQ
data Settings = Settings { data Settings = Settings
cache :: Bool { cache :: Bool
} deriving Show }
deriving Show
@ -99,29 +107,34 @@ data Settings = Settings {
data PlatformResultError = NoCompatiblePlatform data PlatformResultError = NoCompatiblePlatform
deriving Show deriving Show
data NoDownload = NoDownload data NoDownload = NoDownload
deriving Show deriving Show
data NoCompatibleArch = NoCompatibleArch String data NoCompatibleArch = NoCompatibleArch String
deriving Show deriving Show
data DistroNotFound = DistroNotFound data DistroNotFound = DistroNotFound
deriving Show deriving Show
data ArchiveError = UnknownArchive ByteString data ArchiveError = UnknownArchive ByteString
deriving Show deriving Show
data URLException = UnsupportedURL data URLException = UnsupportedURL
deriving Show deriving Show
data FileError = CopyError data FileError = CopyError String
deriving Show deriving Show
data TagNotFound = TagNotFound Tag Tool data TagNotFound = TagNotFound Tag Tool
deriving Show deriving Show
data AlreadyInstalled = AlreadyInstalled ToolRequest
deriving Show
data NotInstalled = NotInstalled ToolRequest
deriving Show
@ -180,7 +193,7 @@ availableDownloads = Map.fromList
, ( Cabal , ( Cabal
, Map.fromList , Map.fromList
[ ( [ver|3.0.0.0|] [ ( [ver|3.0.0.0|]
, VersionInfo [Latest] $ Map.fromList , VersionInfo [Recommended, Latest] $ Map.fromList
[ ( A_64 [ ( A_64
, Map.fromList , Map.fromList
[ ( Linux UnknownLinux [ ( Linux UnknownLinux
@ -230,7 +243,11 @@ getDownloadInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
-> Maybe PlatformRequest -> Maybe PlatformRequest
-> URLSource -> URLSource
-> Excepts -> Excepts
'[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound] '[ PlatformResultError
, NoDownload
, NoCompatibleArch
, DistroNotFound
]
m m
DownloadInfo DownloadInfo
getDownloadInfo (ToolRequest t v) mpfReq urlSource = do getDownloadInfo (ToolRequest t v) mpfReq urlSource = do
@ -244,6 +261,7 @@ getDownloadInfo (ToolRequest t v) mpfReq urlSource = do
pure $ PlatformRequest ar rp rv pure $ PlatformRequest ar rp rv
dls <- case urlSource of dls <- case urlSource of
-- TODO
GHCupURL -> fail "Not implemented" GHCupURL -> fail "Not implemented"
OwnSource url -> fail "Not implemented" OwnSource url -> fail "Not implemented"
OwnSpec dls -> pure dls OwnSpec dls -> pure dls
@ -407,7 +425,7 @@ getArchitecture = case arch of
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m) getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts => Excepts
'[PlatformResultError, DistroNotFound] '[PlatformResultError , DistroNotFound]
m m
PlatformResult PlatformResult
getPlatform = do getPlatform = do
@ -430,6 +448,7 @@ getPlatform = do
getLinuxDistro :: (MonadCatch m, MonadIO m) getLinuxDistro :: (MonadCatch m, MonadIO m)
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning) => Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
getLinuxDistro = do getLinuxDistro = do
-- TODO: don't do alternative on IO, because it hides bugs
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum (name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
[ try_os_release [ try_os_release
, try_lsb_release_cmd , try_lsb_release_cmd
@ -481,12 +500,10 @@ getLinuxDistro = do
try_lsb_release_cmd :: IO (Text, Maybe Text) try_lsb_release_cmd :: IO (Text, Maybe Text)
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 name <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing
$ executeOut lsb_release_cmd [[s|-si|]] Nothing ver <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
ver <- (fmap . fmap) _stdOut pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)
$ executeOut lsb_release_cmd [[s|-sr|]] Nothing
pure (E.decodeUtf8 name, fmap E.decodeUtf8 ver)
try_lsb_release :: IO (Text, Maybe Text) try_lsb_release :: IO (Text, Maybe Text)
try_lsb_release = do try_lsb_release = do
@ -522,14 +539,18 @@ getLinuxDistro = do
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads -- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
-- parseAvailableDownloads = undefined -- parseAvailableDownloads = undefined
-- TODO: subdir to configure script in availableDownloads?
------------------------- -------------------------
--[ Tool installation ]-- --[ Tool installation ]--
------------------------- -------------------------
-- TODO: custom logger intepreter and pretty printing
-- | Install a tool, such as GHC or cabal.
--
-- This can fail in many ways. You may want to explicitly catch
-- `AlreadyInstalled` to not make it fatal.
installTool :: ( MonadThrow m installTool :: ( MonadThrow m
, MonadReader Settings m , MonadReader Settings m
, MonadLogger m , MonadLogger m
@ -537,17 +558,31 @@ installTool :: ( MonadThrow m
, MonadIO m , MonadIO m
) )
=> ToolRequest => ToolRequest
-> Maybe PlatformRequest -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> URLSource -> URLSource
-> Excepts -> Excepts
'[FileError, ArchiveError, ProcessError, URLException, PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound] '[ AlreadyInstalled
, FileError
, ArchiveError
, ProcessError
, URLException
, PlatformResultError
, NoDownload
, NoCompatibleArch
, DistroNotFound
]
m m
() ()
installTool treq mpfReq urlSource = do installTool treq mpfReq urlSource = do
Settings {..} <- lift ask
lift $ $(logDebug) ([s|Requested to install: |] <> showT treq) lift $ $(logDebug) ([s|Requested to install: |] <> showT treq)
dlinfo <- liftE $ getDownloadInfo treq mpfReq urlSource alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
dl <- case cache of when alreadyInstalled $ (throwE $ AlreadyInstalled treq)
Settings {..} <- lift ask
-- download (or use cached version)
dlinfo <- liftE $ getDownloadInfo treq mpfReq urlSource
dl <- case cache of
True -> do True -> do
cachedir <- liftIO $ ghcupCacheDir cachedir <- liftIO $ ghcupCacheDir
fn <- urlBaseName $ view (dlUri % pathL') dlinfo fn <- urlBaseName $ view (dlUri % pathL') dlinfo
@ -559,25 +594,34 @@ installTool treq mpfReq urlSource = do
False -> do False -> do
tmp <- liftIO mkGhcupTmpDir tmp <- liftIO mkGhcupTmpDir
liftE $ download' dlinfo tmp Nothing liftE $ download' dlinfo tmp Nothing
-- unpack
unpacked <- liftE $ unpackToTmpDir dl unpacked <- liftE $ unpackToTmpDir dl
ghcdir <- liftIO $ do
toolsubdir <- ghcupGHCDir -- prepare paths
versubdir <- parseRel (E.encodeUtf8 . prettyVer . view toolVersion $ treq) ghcdir <- liftIO $ ghcupGHCDir (view toolVersion $ treq)
pure (toolsubdir </> versubdir) bindir <- liftIO ghcupBinDir
bindir <- liftIO ghcupBinDir
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo) let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo)
-- TODO: test if tool is already installed
case treq of case treq of
(ToolRequest GHC ver) -> liftE $ installGHC archiveSubdir ghcdir (ToolRequest GHC ver) -> liftE $ installGHC archiveSubdir ghcdir
(ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir (ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir
pure () pure ()
toolAlreadyInstalled :: ToolRequest -> IO Bool
toolAlreadyInstalled ToolRequest {..} = case _tool of
GHC -> ghcInstalled _toolVersion
Cabal -> cabalInstalled _toolVersion
-- | Install an unpacked GHC distribution. -- | Install an unpacked GHC distribution.
installGHC :: (MonadLogger m, MonadIO m) installGHC :: (MonadLogger m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked GHC bindist => Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> Path Abs -- ^ Path to install to -> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
installGHC path inst = do installGHC path inst = do
@ -592,17 +636,93 @@ installGHC path inst = do
-- | Install an unpacked cabal distribution. -- | Install an unpacked cabal distribution.
installCabal :: (MonadLogger m, MonadCatch m, MonadIO m) installCabal :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked cabal bindist => Path Abs -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> Path Abs -- ^ Path to install to -> Path Abs -- ^ Path to install to
-> Excepts '[FileError] m () -> Excepts '[FileError] m ()
installCabal path inst = do installCabal path inst = do
lift $ $(logInfo) ([s|Installing cabal|]) lift $ $(logInfo) ([s|Installing cabal|])
let cabalFile = [rel|cabal|] :: Path Rel let cabalFile = [rel|cabal|] :: Path Rel
handleIO (\_ -> throwE CopyError) $ liftIO $ copyFile (path </> cabalFile) handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(inst </> cabalFile) (path </> cabalFile)
Overwrite (inst </> cabalFile)
Overwrite
-- | Set GHC symlinks in ~/.ghcup/bin for the requested GHC version. The behavior depends
-- on `SetGHC`:
--
-- * SetGHCOnly: ~/.ghcup/bin/ghc -> ~/.ghcup/ghc/<ver>/bin/ghc-<ver>
-- * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc/<ver>/bin/ghc-<ver>
-- * SetGHCMinor: ~/.ghcup/bin/ghc-<ver> -> ~/.ghcup/ghc/<ver>/bin/ghc-<ver>
--
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
-- for `SetGHCOnly` constructor.
setGHC :: (MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> SetGHC
-> Excepts '[NotInstalled] m ()
setGHC ver sghc = do
let verBS = E.encodeUtf8 $ prettyVer ver -- as ByteString
ghcdir <- liftIO $ ghcupGHCDir ver
-- symlink destination
destdir <- liftIO $ ghcupBinDir
-- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ghcdir
forM verfiles $ \file -> do
liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir </> file)
targetFile <- case sghc of
SetGHCOnly -> pure file
SetGHCMajor -> do
major <- E.encodeUtf8 <$> getGHCMajor ver
parseRel (toFilePath file <> B.singleton _hyphen <> major)
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
liftIO $ createSymlink
(destdir </> targetFile)
([s|../ghc/|] <> verBS <> [s|/bin/|] <> toFilePath file)
-- create symlink for share dir
liftIO $ symlinkShareDir ghcdir destdir verBS
pure ()
where
-- get tool files from ~/.ghcup/bin/ghc/<ver>/bin/* while ignoring *-<ver> symlinks
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
=> Path Abs
-> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ghcdir = do
-- fail if ghc is not installed
exists <- liftIO $ doesDirectoryExist ghcdir
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
(throwE (NotInstalled $ ToolRequest GHC ver))
files <- liftIO $ getDirsFiles' (ghcdir </> ([rel|bin|] :: Path Rel))
-- figure out the <ver> suffix, because this might not be `Version` for
-- alpha/rc releases, but x.y.a.somedate.
(Just symver) <-
(B.stripPrefix [s|ghc-|] . takeFileName)
<$> (liftIO $ readSymbolicLink $ toFilePath
(ghcdir </> ([rel|bin/ghc|] :: Path Rel))
)
when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
symlinkShareDir :: Path Abs -> Path Abs -> ByteString -> IO ()
symlinkShareDir ghcdir destdir verBS = case sghc of
SetGHCOnly -> do
let sharedir = [rel|share|] :: Path Rel
let fullsharedir = ghcdir </> sharedir
whenM (doesDirectoryExist fullsharedir) $ do
liftIO $ hideError doesNotExistErrorType $ deleteFile
(destdir </> sharedir)
createSymlink
(destdir </> sharedir)
([s|../ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir)
_ -> pure ()
----------------- -----------------
--[ Utilities ]-- --[ Utilities ]--
@ -614,8 +734,19 @@ ghcupBaseDir = do
home <- liftIO getHomeDirectory home <- liftIO getHomeDirectory
pure (home </> ([rel|.ghcup|] :: Path Rel)) pure (home </> ([rel|.ghcup|] :: Path Rel))
ghcupGHCDir :: IO (Path Abs) ghcupGHCBaseDir :: IO (Path Abs)
ghcupGHCDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel)) ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
ghcupGHCDir :: Version -> IO (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel (E.encodeUtf8 $ prettyVer ver)
pure (ghcbasedir </> verdir)
ghcInstalled :: Version -> IO Bool
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesDirectoryExist ghcdir
ghcupBinDir :: IO (Path Abs) ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel)) ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
@ -623,6 +754,23 @@ ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
ghcupCacheDir :: IO (Path Abs) ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel)) ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> ghcupBinDir
mc <- executeOut cabalbin [[s|--numeric-version|]] Nothing
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
pure (reportedVer == (E.encodeUtf8 $ prettyVer ver))
-- | We assume GHC is in semver format. I hope it is.
getGHCMajor :: MonadThrow m => Version -> m Text
getGHCMajor ver = do
semv <- case semver $ prettyVer ver of
Right v -> pure v
Left e -> throwM e
pure $ T.pack (show (_svMajor semv)) <> T.pack "." <> T.pack
(show (_svMinor semv))
urlBaseName :: MonadThrow m urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host) => ByteString -- ^ the url path (without scheme and host)
@ -637,9 +785,7 @@ unpackToTmpDir :: (MonadLogger m, MonadIO m, MonadThrow m)
-> Excepts '[ArchiveError] m (Path Abs) -> Excepts '[ArchiveError] m (Path Abs)
unpackToTmpDir av = do unpackToTmpDir av = do
lift $ $(logInfo) ([s|Unpacking: |] <> E.decodeUtf8 (toFilePath av)) lift $ $(logInfo) ([s|Unpacking: |] <> E.decodeUtf8 (toFilePath av))
fn <- basename av fn <- toFilePath <$> basename av
let (fnrest, ext) = splitExtension $ toFilePath fn
let ext2 = takeExtension fnrest
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|] tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|]) tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
let untar bs = do let untar bs = do
@ -648,13 +794,13 @@ unpackToTmpDir av = do
-- extract, depending on file extension -- extract, depending on file extension
if if
| ext == [s|.gz|], ext2 == [s|.tar|] -> liftIO | [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
(untar . GZip.decompress =<< readFile av) (untar . GZip.decompress =<< readFile av)
| ext == [s|.xz|], ext2 == [s|.tar|] -> do | [s|.tar.xz|] `B.isSuffixOf` fn -> do
filecontents <- liftIO $ readFile av filecontents <- liftIO $ readFile av
let decompressed = Lzma.decompress filecontents let decompressed = Lzma.decompress filecontents
liftIO $ untar decompressed liftIO $ untar decompressed
| ext == [s|.bz2|], ext2 == [s|.tar|] -> liftIO | [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
(untar . BZip.decompress =<< readFile av) (untar . BZip.decompress =<< readFile av)
| ext == [s|.tar|] -> liftIO (untar =<< readFile av) | [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
| otherwise -> throwE $ UnknownArchive ext | otherwise -> throwE $ UnknownArchive fn

20
lib/GHCup/File.hs
View File

@ -107,13 +107,14 @@ findExecutable ex = do
-- | Execute the given command and collect the stdout, stderr and the exit code. -- | Execute the given command and collect the stdout, stderr and the exit code.
-- The command is run in a subprocess. -- The command is run in a subprocess.
executeOut :: Path Rel -- ^ command as filename, e.g. 'ls' executeOut :: Path b -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command -> [ByteString] -- ^ arguments to the command
-> Maybe (Path Abs) -- ^ chdir to this path -> Maybe (Path Abs) -- ^ chdir to this path
-> IO (Maybe CapturedProcess) -> IO CapturedProcess
executeOut path args chdir = withRelPath path $ \fp -> captureOutStreams $ do executeOut path args chdir =
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir captureOutStreams $ do
SPPB.executeFile fp True args Nothing maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile (toFilePath path) True args Nothing
-- | Capture the stdout and stderr of the given action, which -- | Capture the stdout and stderr of the given action, which
@ -121,7 +122,7 @@ executeOut path args chdir = withRelPath path $ \fp -> captureOutStreams $ do
-- 'race' this to make sure it terminates. -- 'race' this to make sure it terminates.
captureOutStreams :: IO a captureOutStreams :: IO a
-- ^ the action to execute in a subprocess -- ^ the action to execute in a subprocess
-> IO (Maybe CapturedProcess) -- TODO: shouldn't be maybe -> IO CapturedProcess
captureOutStreams action = captureOutStreams action =
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) -> actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
@ -148,14 +149,11 @@ captureOutStreams action =
Just (SPPB.Exited es) -> do Just (SPPB.Exited es) -> do
stdout' <- L.toStrict <$> readFd parentStdoutRead stdout' <- L.toStrict <$> readFd parentStdoutRead
stderr' <- L.toStrict <$> readFd parentStderrRead stderr' <- L.toStrict <$> readFd parentStderrRead
pure $ Just $ CapturedProcess { _exitCode = es pure $ CapturedProcess { _exitCode = es
, _stdOut = stdout' , _stdOut = stdout'
, _stdErr = stderr' , _stdErr = stderr'
} }
_ -> do _ -> throwIO $ userError $ ("No such PID " ++ show pid)
closeFd parentStdoutRead
closeFd parentStderrRead
pure $ Nothing
where where
actionWithPipes a = actionWithPipes a =

69
lib/GHCup/Prelude.hs
View File

@ -6,6 +6,10 @@
{-# LANGUAGE DeriveLift #-} {-# LANGUAGE DeriveLift #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
module GHCup.Prelude where module GHCup.Prelude where
@ -13,23 +17,25 @@ import Control.Applicative
import Control.Monad import Control.Monad
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Control.Exception.Safe import Control.Exception.Safe
import Data.ByteString (ByteString) import Data.ByteString ( ByteString )
import qualified Data.Strict.Maybe as S import qualified Data.Strict.Maybe as S
import Data.Monoid ( (<>) ) import Data.Monoid ( (<>) )
import Data.String import Data.String
import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Text ( Text ) import Data.Text ( Text )
import qualified Data.Text as T import qualified Data.Text as T
import Data.Versions import Data.Versions
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import System.IO.Error import System.IO.Error
import Language.Haskell.TH import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Exp(..), Lift) import Language.Haskell.TH.Syntax ( Exp(..)
import qualified Language.Haskell.TH.Syntax as TH , Lift
import Language.Haskell.TH.Quote (QuasiQuoter(..)) )
import GHC.Base import qualified Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import GHC.Base
@ -114,6 +120,15 @@ lEM em = lift em >>= lE
fromEither :: Either a b -> VEither '[a] b fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight fromEither = either (VLeft . V) VRight
hideExcept :: forall e es es' a m
. (Monad m, e :< es, LiftVariant (Remove e es) es')
=> e
-> a
-> Excepts es m a
-> Excepts es' m a
hideExcept h a action =
catchLiftLeft ((\(x@e) -> pure a) :: (e -> Excepts es' m a)) action
deriving instance Lift Versioning deriving instance Lift Versioning
@ -127,44 +142,42 @@ deriving instance Lift VUnit
instance Lift Text instance Lift Text
qq :: (Text -> Q Exp) -> QuasiQuoter qq :: (Text -> Q Exp) -> QuasiQuoter
qq quoteExp' = qq quoteExp' = QuasiQuoter
QuasiQuoter
{ quoteExp = (\s -> quoteExp' . T.pack $ s) { quoteExp = (\s -> quoteExp' . T.pack $ s)
, quotePat = \_ -> , quotePat = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType = \_ -> , quoteType = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a type)" fail "illegal QuasiQuote (allowed as expression only, used as a type)"
, quoteDec = \_ -> , quoteDec = \_ -> fail
fail "illegal QuasiQuote (allowed as expression only, used as a declaration)" "illegal QuasiQuote (allowed as expression only, used as a declaration)"
} }
ver :: QuasiQuoter ver :: QuasiQuoter
ver = qq mkV ver = qq mkV
where where
mkV :: Text -> Q Exp mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . version mkV = either (fail . show) TH.lift . version
mver :: QuasiQuoter mver :: QuasiQuoter
mver = qq mkV mver = qq mkV
where where
mkV :: Text -> Q Exp mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . mess mkV = either (fail . show) TH.lift . mess
sver :: QuasiQuoter sver :: QuasiQuoter
sver = qq mkV sver = qq mkV
where where
mkV :: Text -> Q Exp mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . semver mkV = either (fail . show) TH.lift . semver
vers :: QuasiQuoter vers :: QuasiQuoter
vers = qq mkV vers = qq mkV
where where
mkV :: Text -> Q Exp mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . versioning mkV = either (fail . show) TH.lift . versioning
pver :: QuasiQuoter pver :: QuasiQuoter
pver = qq mkV pver = qq mkV
where where
mkV :: Text -> Q Exp mkV :: Text -> Q Exp
mkV = either (fail . show) TH.lift . pvp mkV = either (fail . show) TH.lift . pvp

43
lib/GHCup/Types.hs
View File

@ -9,28 +9,37 @@ import Data.Versions
import URI.ByteString import URI.ByteString
data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
| SetGHCMajor -- ^ ghc-x.y
| SetGHCMinor -- ^ ghc-x.y.z
deriving Show
data Tag = Latest data Tag = Latest
| Recommended | Recommended
deriving (Eq, Show) deriving (Eq, Show)
data VersionInfo = VersionInfo { data VersionInfo = VersionInfo
_viTags :: [Tag] { _viTags :: [Tag]
, _viArch :: ArchitectureSpec , _viArch :: ArchitectureSpec
} deriving (Eq, Show) }
deriving (Eq, Show)
data DownloadInfo = DownloadInfo { data DownloadInfo = DownloadInfo
_dlUri :: URI { _dlUri :: URI
, _dlSubdir :: Maybe (Path Rel) , _dlSubdir :: Maybe (Path Rel)
} deriving (Eq, Show) }
deriving (Eq, Show)
data Tool = GHC data Tool = GHC
| Cabal | Cabal
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
data ToolRequest = ToolRequest { data ToolRequest = ToolRequest
_tool :: Tool { _tool :: Tool
, _toolVersion :: Version , _toolVersion :: Version
} deriving (Eq, Show) }
deriving (Eq, Show)
data Architecture = A_64 data Architecture = A_64
| A_32 | A_32
@ -58,16 +67,18 @@ data Platform = Linux LinuxDistro
| FreeBSD | FreeBSD
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
data PlatformResult = PlatformResult { data PlatformResult = PlatformResult
_platform :: Platform { _platform :: Platform
, _distroVersion :: Maybe Versioning , _distroVersion :: Maybe Versioning
} deriving (Eq, Show) }
deriving (Eq, Show)
data PlatformRequest = PlatformRequest { data PlatformRequest = PlatformRequest
_rArch :: Architecture { _rArch :: Architecture
, _rPlatform :: Platform , _rPlatform :: Platform
, _rVersion :: Maybe Versioning , _rVersion :: Maybe Versioning
} deriving (Eq, Show) }
deriving (Eq, Show)
type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
type PlatformSpec = Map Platform PlatformVersionSpec type PlatformSpec = Map Platform PlatformVersionSpec