From b3eac9bf54a6b7cb554f9f2ae4fba5d33e84ddac Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 24 Feb 2020 14:56:13 +0100 Subject: [PATCH] More --- TODO.md | 17 ++- app/Main.hs | 98 ++++++++++-------- cabal.project | 3 + ghcup.cabal | 3 + lib/GHCup.hs | 240 ++++++++++++++++++++++++++++++++++--------- lib/GHCup/File.hs | 20 ++-- lib/GHCup/Prelude.hs | 69 ++++++++----- lib/GHCup/Types.hs | 43 +++++--- 8 files changed, 350 insertions(+), 143 deletions(-) diff --git a/TODO.md b/TODO.md index 8ee11e4..96345f8 100644 --- a/TODO.md +++ b/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? diff --git a/app/Main.hs b/app/Main.hs index 6e5c067..a199f99 100644 --- a/app/Main.hs +++ b/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 <- - 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 - ] + -- logger interpreter + let runLogger = runStderrLoggingT - 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 {..}) -> - 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 - + void + $ (runInstTool $ do + v <- maybe + ( getRecommended availableDownloads GHC + ?? TagNotFound Recommended GHC + ) + pure + ghcVer + liftE $ installTool (ToolRequest GHC 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) + 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) diff --git a/cabal.project b/cabal.project index 621237e..446efab 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/ghcup.cabal b/ghcup.cabal index 2aecf3b..1146581 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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: diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 418551c..e8c0044 100644 --- a/lib/GHCup.hs +++ b/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 @@ -99,29 +107,34 @@ data Settings = Settings { data PlatformResultError = NoCompatiblePlatform - deriving Show + deriving Show data NoDownload = NoDownload - deriving Show + deriving Show data NoCompatibleArch = NoCompatibleArch String - deriving Show + deriving Show data DistroNotFound = DistroNotFound - deriving Show + deriving Show data ArchiveError = UnknownArchive ByteString - deriving Show + deriving Show data URLException = UnsupportedURL - deriving Show + deriving Show -data FileError = CopyError - deriving Show +data FileError = CopyError String + deriving Show 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 , 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,17 +558,31 @@ 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) - dlinfo <- liftE $ getDownloadInfo treq mpfReq urlSource - dl <- case cache of + 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 cachedir <- liftIO $ ghcupCacheDir fn <- urlBaseName $ view (dlUri % pathL') dlinfo @@ -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) - bindir <- liftIO ghcupBinDir + + -- 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) - (inst cabalFile) - Overwrite + 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//bin/ghc- +-- * SetGHCMajor: ~/.ghcup/bin/ghc-X.Y -> ~/.ghcup/ghc//bin/ghc- +-- * SetGHCMinor: ~/.ghcup/bin/ghc- -> ~/.ghcup/ghc//bin/ghc- +-- +-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc//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//bin/* while ignoring *- 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 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 diff --git a/lib/GHCup/File.hs b/lib/GHCup/File.hs index 6792bdb..146e77e 100644 --- a/lib/GHCup/File.hs +++ b/lib/GHCup/File.hs @@ -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 - maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir - SPPB.executeFile fp True args Nothing + -> IO CapturedProcess +executeOut path args chdir = + captureOutStreams $ do + maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir + 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 = diff --git a/lib/GHCup/Prelude.hs b/lib/GHCup/Prelude.hs index bc80a92..662f482 100644 --- a/lib/GHCup/Prelude.hs +++ b/lib/GHCup/Prelude.hs @@ -6,6 +6,10 @@ {-# LANGUAGE DeriveLift #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} module GHCup.Prelude where @@ -13,23 +17,25 @@ 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 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 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 +import Language.Haskell.TH.Syntax ( Exp(..) + , Lift + ) +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 (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,44 +142,42 @@ 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)" + 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)" + 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 + 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 + 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 + 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 + 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 - + where + mkV :: Text -> Q Exp + mkV = either (fail . show) TH.lift . pvp diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index accd550..344827b 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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) + , _rVersion :: Maybe Versioning + } + deriving (Eq, Show) type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo type PlatformSpec = Map Platform PlatformVersionSpec