More
This commit is contained in:
parent
ac91cbd32b
commit
b3eac9bf54
17
TODO.md
17
TODO.md
@ -1,5 +1,21 @@
|
||||
# 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
|
||||
* add support for RC/alpha/HEAD versions
|
||||
* redo/rethink how tool tags works
|
||||
@ -10,7 +26,6 @@
|
||||
|
||||
* --copy-compiler-tools
|
||||
* 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 propagate updates? Automatically? Might solve the versioning problem
|
||||
* installing musl on demand?
|
||||
|
||||
84
app/Main.hs
84
app/Main.hs
@ -1,6 +1,8 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Main where
|
||||
|
||||
@ -12,6 +14,7 @@ import Data.ByteString ( ByteString )
|
||||
import Data.Functor ( (<&>) )
|
||||
import Data.Maybe
|
||||
import Data.Semigroup ( (<>) )
|
||||
import Data.String.QQ
|
||||
import Data.Text ( Text )
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
@ -29,6 +32,7 @@ import System.Exit
|
||||
|
||||
|
||||
|
||||
|
||||
data Options = Options
|
||||
{ optVerbose :: Bool
|
||||
, optCache :: Bool
|
||||
@ -102,50 +106,64 @@ installCabalOpts = InstallCabalOptions <$> optional
|
||||
|
||||
|
||||
toSettings :: Options -> Settings
|
||||
toSettings Options{..} =
|
||||
let cache = optCache
|
||||
in Settings{..}
|
||||
toSettings Options {..} = let cache = optCache in Settings { .. }
|
||||
|
||||
|
||||
-- TODO: something better than Show instance for errors
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
e <-
|
||||
-- logger interpreter
|
||||
let runLogger = runStderrLoggingT
|
||||
|
||||
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
|
||||
]
|
||||
let
|
||||
runInstTool =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[FileError, ArchiveError, ProcessError, URLException, PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound, TagNotFound, AlreadyInstalled]
|
||||
|
||||
case optCommand of
|
||||
InstallGHC (InstallGHCOptions {..}) ->
|
||||
run
|
||||
$ do
|
||||
d <- liftIO $ ghcupBaseDir
|
||||
case ghcVer of
|
||||
Just ver -> liftE $ installTool (ToolRequest GHC ver)
|
||||
void
|
||||
$ (runInstTool $ do
|
||||
v <- maybe
|
||||
( getRecommended availableDownloads GHC
|
||||
?? TagNotFound Recommended GHC
|
||||
)
|
||||
pure
|
||||
ghcVer
|
||||
liftE $ installTool (ToolRequest GHC v)
|
||||
Nothing
|
||||
(OwnSpec availableDownloads)
|
||||
Nothing -> do
|
||||
ver <-
|
||||
getRecommended availableDownloads GHC
|
||||
?? TagNotFound Recommended GHC
|
||||
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 ()
|
||||
|
||||
|
||||
-- print error, if any
|
||||
-- case e of
|
||||
-- Right () -> pure ()
|
||||
-- Left t -> die (color Red $ t)
|
||||
|
||||
@ -10,6 +10,9 @@ package streamly
|
||||
package ghcup
|
||||
ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
|
||||
|
||||
package tar-bytestring
|
||||
ghc-options: -O2
|
||||
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/composewell/streamly
|
||||
|
||||
@ -31,6 +31,7 @@ common containers { build-depends: containers >= 0.6 }
|
||||
common generics-sop { build-depends: generics-sop >= 0.5 }
|
||||
common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 }
|
||||
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-io { build-depends: hpath-io >= 0.13.1 }
|
||||
common hpath-posix { build-depends: hpath-posix >= 0.11.1 }
|
||||
@ -92,6 +93,7 @@ library
|
||||
, generics-sop
|
||||
, haskus-utils-variant
|
||||
, hpath
|
||||
, hpath-directory
|
||||
, hpath-filepath
|
||||
, hpath-io
|
||||
, hpath-posix
|
||||
@ -145,6 +147,7 @@ executable ghcup
|
||||
, versions
|
||||
, hpath
|
||||
, pretty-terminal
|
||||
, string-qq
|
||||
main-is: Main.hs
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
|
||||
214
lib/GHCup.hs
214
lib/GHCup.hs
@ -6,6 +6,7 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
-- TODO: handle SIGTERM, SIGUSR
|
||||
module GHCup where
|
||||
@ -14,8 +15,10 @@ module GHCup where
|
||||
import qualified Codec.Archive.Tar as Tar
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Cont
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.IO.Class
|
||||
@ -55,11 +58,15 @@ import System.IO.Streams ( InputStream
|
||||
)
|
||||
import qualified System.IO.Streams as Streams
|
||||
import System.Posix.FilePath ( takeExtension
|
||||
, takeFileName
|
||||
, splitExtension
|
||||
)
|
||||
import qualified System.Posix.FilePath as FP
|
||||
import System.Posix.Files.ByteString ( readSymbolicLink )
|
||||
import System.Posix.Env.ByteString ( getEnvDefault )
|
||||
import System.Posix.Temp.ByteString
|
||||
import System.Posix.RawFilePath.Directory.Errors
|
||||
( hideError )
|
||||
import "unix" System.Posix.IO.ByteString
|
||||
hiding ( fdWrite )
|
||||
import System.Posix.FD as FD
|
||||
@ -86,9 +93,10 @@ import URI.ByteString.QQ
|
||||
|
||||
|
||||
|
||||
data Settings = Settings {
|
||||
cache :: Bool
|
||||
} deriving Show
|
||||
data Settings = Settings
|
||||
{ cache :: Bool
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
|
||||
@ -116,12 +124,17 @@ data ArchiveError = UnknownArchive ByteString
|
||||
data URLException = UnsupportedURL
|
||||
deriving Show
|
||||
|
||||
data FileError = CopyError
|
||||
data FileError = CopyError String
|
||||
deriving Show
|
||||
|
||||
data TagNotFound = TagNotFound Tag Tool
|
||||
deriving Show
|
||||
|
||||
data AlreadyInstalled = AlreadyInstalled ToolRequest
|
||||
deriving Show
|
||||
|
||||
data NotInstalled = NotInstalled ToolRequest
|
||||
deriving Show
|
||||
|
||||
|
||||
|
||||
@ -180,7 +193,7 @@ availableDownloads = Map.fromList
|
||||
, ( Cabal
|
||||
, Map.fromList
|
||||
[ ( [ver|3.0.0.0|]
|
||||
, VersionInfo [Latest] $ Map.fromList
|
||||
, VersionInfo [Recommended, Latest] $ Map.fromList
|
||||
[ ( A_64
|
||||
, Map.fromList
|
||||
[ ( Linux UnknownLinux
|
||||
@ -230,7 +243,11 @@ getDownloadInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
-> Maybe PlatformRequest
|
||||
-> URLSource
|
||||
-> Excepts
|
||||
'[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
|
||||
'[ PlatformResultError
|
||||
, NoDownload
|
||||
, NoCompatibleArch
|
||||
, DistroNotFound
|
||||
]
|
||||
m
|
||||
DownloadInfo
|
||||
getDownloadInfo (ToolRequest t v) mpfReq urlSource = do
|
||||
@ -244,6 +261,7 @@ getDownloadInfo (ToolRequest t v) mpfReq urlSource = do
|
||||
pure $ PlatformRequest ar rp rv
|
||||
|
||||
dls <- case urlSource of
|
||||
-- TODO
|
||||
GHCupURL -> fail "Not implemented"
|
||||
OwnSource url -> fail "Not implemented"
|
||||
OwnSpec dls -> pure dls
|
||||
@ -407,7 +425,7 @@ getArchitecture = case arch of
|
||||
|
||||
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
|
||||
=> Excepts
|
||||
'[PlatformResultError, DistroNotFound]
|
||||
'[PlatformResultError , DistroNotFound]
|
||||
m
|
||||
PlatformResult
|
||||
getPlatform = do
|
||||
@ -430,6 +448,7 @@ getPlatform = do
|
||||
getLinuxDistro :: (MonadCatch m, MonadIO m)
|
||||
=> Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
|
||||
getLinuxDistro = do
|
||||
-- TODO: don't do alternative on IO, because it hides bugs
|
||||
(name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
|
||||
[ try_os_release
|
||||
, try_lsb_release_cmd
|
||||
@ -481,12 +500,10 @@ getLinuxDistro = do
|
||||
|
||||
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 [[s|-si|]] Nothing
|
||||
ver <- (fmap . fmap) _stdOut
|
||||
$ executeOut lsb_release_cmd [[s|-sr|]] Nothing
|
||||
pure (E.decodeUtf8 name, fmap E.decodeUtf8 ver)
|
||||
(Just _) <- findExecutable lsb_release_cmd
|
||||
name <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing
|
||||
ver <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
|
||||
pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)
|
||||
|
||||
try_lsb_release :: IO (Text, Maybe Text)
|
||||
try_lsb_release = do
|
||||
@ -522,14 +539,18 @@ getLinuxDistro = do
|
||||
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
|
||||
-- parseAvailableDownloads = undefined
|
||||
|
||||
-- TODO: subdir to configure script in availableDownloads?
|
||||
|
||||
|
||||
-------------------------
|
||||
--[ 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
|
||||
, MonadReader Settings m
|
||||
, MonadLogger m
|
||||
@ -537,15 +558,29 @@ installTool :: ( MonadThrow m
|
||||
, MonadIO m
|
||||
)
|
||||
=> ToolRequest
|
||||
-> Maybe PlatformRequest
|
||||
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
|
||||
-> URLSource
|
||||
-> Excepts
|
||||
'[FileError, ArchiveError, ProcessError, URLException, PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
|
||||
'[ AlreadyInstalled
|
||||
, 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)
|
||||
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq
|
||||
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
|
||||
@ -559,25 +594,34 @@ installTool treq mpfReq urlSource = do
|
||||
False -> do
|
||||
tmp <- liftIO mkGhcupTmpDir
|
||||
liftE $ download' dlinfo tmp Nothing
|
||||
|
||||
-- unpack
|
||||
unpacked <- liftE $ unpackToTmpDir dl
|
||||
ghcdir <- liftIO $ do
|
||||
toolsubdir <- ghcupGHCDir
|
||||
versubdir <- parseRel (E.encodeUtf8 . prettyVer . view toolVersion $ treq)
|
||||
pure (toolsubdir </> versubdir)
|
||||
|
||||
-- prepare paths
|
||||
ghcdir <- liftIO $ ghcupGHCDir (view toolVersion $ treq)
|
||||
bindir <- liftIO ghcupBinDir
|
||||
|
||||
-- the subdir of the archive where we do the work
|
||||
let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo)
|
||||
|
||||
-- TODO: test if tool is already installed
|
||||
case treq of
|
||||
(ToolRequest GHC ver) -> liftE $ installGHC archiveSubdir ghcdir
|
||||
(ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir
|
||||
pure ()
|
||||
|
||||
|
||||
toolAlreadyInstalled :: ToolRequest -> IO Bool
|
||||
toolAlreadyInstalled ToolRequest {..} = case _tool of
|
||||
GHC -> ghcInstalled _toolVersion
|
||||
Cabal -> cabalInstalled _toolVersion
|
||||
|
||||
|
||||
|
||||
-- | Install an unpacked GHC distribution.
|
||||
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
|
||||
-> Excepts '[ProcessError] m ()
|
||||
installGHC path inst = do
|
||||
@ -592,17 +636,93 @@ installGHC path inst = do
|
||||
|
||||
-- | Install an unpacked cabal distribution.
|
||||
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
|
||||
-> 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)
|
||||
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
|
||||
(path </> cabalFile)
|
||||
(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 ]--
|
||||
@ -614,8 +734,19 @@ ghcupBaseDir = do
|
||||
home <- liftIO getHomeDirectory
|
||||
pure (home </> ([rel|.ghcup|] :: Path Rel))
|
||||
|
||||
ghcupGHCDir :: IO (Path Abs)
|
||||
ghcupGHCDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
|
||||
ghcupGHCBaseDir :: IO (Path Abs)
|
||||
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 = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
|
||||
@ -623,6 +754,23 @@ ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
|
||||
ghcupCacheDir :: IO (Path Abs)
|
||||
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
|
||||
=> ByteString -- ^ the url path (without scheme and host)
|
||||
@ -637,9 +785,7 @@ unpackToTmpDir :: (MonadLogger m, MonadIO m, MonadThrow m)
|
||||
-> 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
|
||||
fn <- toFilePath <$> basename av
|
||||
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
|
||||
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
|
||||
let untar bs = do
|
||||
@ -648,13 +794,13 @@ unpackToTmpDir av = do
|
||||
|
||||
-- extract, depending on file extension
|
||||
if
|
||||
| ext == [s|.gz|], ext2 == [s|.tar|] -> liftIO
|
||||
| [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
|
||||
(untar . GZip.decompress =<< readFile av)
|
||||
| ext == [s|.xz|], ext2 == [s|.tar|] -> do
|
||||
| [s|.tar.xz|] `B.isSuffixOf` fn -> do
|
||||
filecontents <- liftIO $ readFile av
|
||||
let decompressed = Lzma.decompress filecontents
|
||||
liftIO $ untar decompressed
|
||||
| ext == [s|.bz2|], ext2 == [s|.tar|] -> liftIO
|
||||
| [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
|
||||
(untar . BZip.decompress =<< readFile av)
|
||||
| ext == [s|.tar|] -> liftIO (untar =<< readFile av)
|
||||
| otherwise -> throwE $ UnknownArchive ext
|
||||
| [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
|
||||
| otherwise -> throwE $ UnknownArchive fn
|
||||
|
||||
@ -107,13 +107,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'
|
||||
executeOut :: Path b -- ^ command as filename, e.g. 'ls'
|
||||
-> [ByteString] -- ^ arguments to the command
|
||||
-> Maybe (Path Abs) -- ^ chdir to this path
|
||||
-> IO (Maybe CapturedProcess)
|
||||
executeOut path args chdir = withRelPath path $ \fp -> captureOutStreams $ do
|
||||
-> IO CapturedProcess
|
||||
executeOut path args chdir =
|
||||
captureOutStreams $ do
|
||||
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
|
||||
SPPB.executeFile fp True args Nothing
|
||||
SPPB.executeFile (toFilePath path) True args Nothing
|
||||
|
||||
|
||||
-- | 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.
|
||||
captureOutStreams :: IO a
|
||||
-- ^ the action to execute in a subprocess
|
||||
-> IO (Maybe CapturedProcess) -- TODO: shouldn't be maybe
|
||||
-> IO CapturedProcess
|
||||
captureOutStreams action =
|
||||
actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
|
||||
actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
|
||||
@ -148,14 +149,11 @@ captureOutStreams action =
|
||||
Just (SPPB.Exited es) -> do
|
||||
stdout' <- L.toStrict <$> readFd parentStdoutRead
|
||||
stderr' <- L.toStrict <$> readFd parentStderrRead
|
||||
pure $ Just $ CapturedProcess { _exitCode = es
|
||||
pure $ CapturedProcess { _exitCode = es
|
||||
, _stdOut = stdout'
|
||||
, _stdErr = stderr'
|
||||
}
|
||||
_ -> do
|
||||
closeFd parentStdoutRead
|
||||
closeFd parentStderrRead
|
||||
pure $ Nothing
|
||||
_ -> throwIO $ userError $ ("No such PID " ++ show pid)
|
||||
|
||||
where
|
||||
actionWithPipes a =
|
||||
|
||||
@ -6,6 +6,10 @@
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module GHCup.Prelude where
|
||||
|
||||
@ -13,7 +17,7 @@ import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Exception.Safe
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString ( ByteString )
|
||||
import qualified Data.Strict.Maybe as S
|
||||
import Data.Monoid ( (<>) )
|
||||
import Data.String
|
||||
@ -26,9 +30,11 @@ 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 Language.Haskell.TH.Syntax ( Exp(..)
|
||||
, Lift
|
||||
)
|
||||
import qualified Language.Haskell.TH.Syntax as TH
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter(..))
|
||||
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 (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
|
||||
@ -127,15 +142,14 @@ deriving instance Lift VUnit
|
||||
instance Lift Text
|
||||
|
||||
qq :: (Text -> Q Exp) -> QuasiQuoter
|
||||
qq quoteExp' =
|
||||
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)"
|
||||
, quoteDec = \_ -> fail
|
||||
"illegal QuasiQuote (allowed as expression only, used as a declaration)"
|
||||
}
|
||||
|
||||
ver :: QuasiQuoter
|
||||
@ -167,4 +181,3 @@ pver = qq mkV
|
||||
where
|
||||
mkV :: Text -> Q Exp
|
||||
mkV = either (fail . show) TH.lift . pvp
|
||||
|
||||
|
||||
@ -9,28 +9,37 @@ import Data.Versions
|
||||
import URI.ByteString
|
||||
|
||||
|
||||
data SetGHC = SetGHCOnly -- ^ unversioned 'ghc'
|
||||
| SetGHCMajor -- ^ ghc-x.y
|
||||
| SetGHCMinor -- ^ ghc-x.y.z
|
||||
deriving Show
|
||||
|
||||
|
||||
data Tag = Latest
|
||||
| Recommended
|
||||
deriving (Eq, Show)
|
||||
|
||||
data VersionInfo = VersionInfo {
|
||||
_viTags :: [Tag]
|
||||
data VersionInfo = VersionInfo
|
||||
{ _viTags :: [Tag]
|
||||
, _viArch :: ArchitectureSpec
|
||||
} deriving (Eq, Show)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data DownloadInfo = DownloadInfo {
|
||||
_dlUri :: URI
|
||||
data DownloadInfo = DownloadInfo
|
||||
{ _dlUri :: URI
|
||||
, _dlSubdir :: Maybe (Path Rel)
|
||||
} deriving (Eq, Show)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Tool = GHC
|
||||
| Cabal
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
data ToolRequest = ToolRequest {
|
||||
_tool :: Tool
|
||||
data ToolRequest = ToolRequest
|
||||
{ _tool :: Tool
|
||||
, _toolVersion :: Version
|
||||
} deriving (Eq, Show)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Architecture = A_64
|
||||
| A_32
|
||||
@ -58,16 +67,18 @@ data Platform = Linux LinuxDistro
|
||||
| FreeBSD
|
||||
deriving (Eq, GHC.Generic, Ord, Show)
|
||||
|
||||
data PlatformResult = PlatformResult {
|
||||
_platform :: Platform
|
||||
data PlatformResult = PlatformResult
|
||||
{ _platform :: Platform
|
||||
, _distroVersion :: Maybe Versioning
|
||||
} deriving (Eq, Show)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
data PlatformRequest = PlatformRequest {
|
||||
_rArch :: Architecture
|
||||
data PlatformRequest = PlatformRequest
|
||||
{ _rArch :: Architecture
|
||||
, _rPlatform :: Platform
|
||||
, _rVersion :: Maybe Versioning
|
||||
} deriving (Eq, Show)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
|
||||
type PlatformSpec = Map Platform PlatformVersionSpec
|
||||
|
||||
Loading…
Reference in New Issue
Block a user