From e1fb60d3b1d0ddfb56a7452d8c2a5757b04a72b4 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 1 Mar 2020 00:07:39 +0100 Subject: [PATCH] Yo --- TODO.md | 8 +- app/ghcup-gen/AvailableDownloads.hs | 6 +- app/ghcup-gen/Main.hs | 1 - app/ghcup-gen/Validate.hs | 11 +- app/ghcup/Main.hs | 222 +++++++++++++++------------- ghcup.cabal | 3 + lib/GHCup.hs | 183 +++++++++++++---------- lib/GHCup/File.hs | 29 ++-- lib/GHCup/Logger.hs | 24 +-- lib/GHCup/Prelude.hs | 45 ++++-- lib/GHCup/Types.hs | 19 ++- 11 files changed, 298 insertions(+), 253 deletions(-) diff --git a/TODO.md b/TODO.md index d326d4a..e8ea0c5 100644 --- a/TODO.md +++ b/TODO.md @@ -5,11 +5,8 @@ * download progress * 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 -* install major ver +* maybe: changelog Show the changelog of a GHC release (online) +* maybe: print-system-reqs Print an approximation of system requirements * testing (especially distro detection -> unit tests) @@ -25,7 +22,6 @@ * check for new version on start * tarball tags as well as version tags? -* --copy-compiler-tools * installing multiple versions in parallel? * how to version and extend the format of the downloads file? Compatibility? * how to propagate updates? Automatically? Might solve the versioning problem diff --git a/app/ghcup-gen/AvailableDownloads.hs b/app/ghcup-gen/AvailableDownloads.hs index cfc44ca..2501e42 100644 --- a/app/ghcup-gen/AvailableDownloads.hs +++ b/app/ghcup-gen/AvailableDownloads.hs @@ -21,7 +21,7 @@ availableDownloads :: AvailableDownloads availableDownloads = M.fromList [ ( GHC , M.fromList - [ ( [ver|8.6.5|] + [ ( [vver|8.6.5|] , VersionInfo [Latest] $ M.fromList [ ( A_64 , M.fromList @@ -61,7 +61,7 @@ availableDownloads = M.fromList ) ] ), - ( [ver|8.4.4|] + ( [vver|8.4.4|] , VersionInfo [Latest] $ M.fromList [ ( A_64 , M.fromList @@ -105,7 +105,7 @@ availableDownloads = M.fromList ) , ( Cabal , M.fromList - [ ( [ver|3.0.0.0|] + [ ( [vver|3.0.0.0|] , VersionInfo [Recommended, Latest] $ M.fromList [ ( A_64 , M.fromList diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs index c9717e4..3ee9ec1 100644 --- a/app/ghcup-gen/Main.hs +++ b/app/ghcup-gen/Main.hs @@ -15,7 +15,6 @@ import qualified Data.ByteString.Lazy as L import Data.Semigroup ( (<>) ) import GHCup.Types.JSON ( ) import Options.Applicative hiding ( style ) -import Control.Monad.Logger import GHCup.Logger import System.Console.Pretty import System.Exit diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 099213d..7761e3c 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -4,32 +4,23 @@ module Validate where -import AvailableDownloads import GHCup import GHCup.Types -import GHCup.Types.Optics import Control.Monad import Control.Exception.Safe import Control.Monad.Reader.Class import Control.Monad.IO.Class import Control.Monad.Trans.Class ( lift ) -import Control.Monad.Trans.Reader ( ReaderT - , runReaderT - ) +import Control.Monad.Trans.Reader ( runReaderT ) import Data.List -import Data.String.QQ import Data.String.Interpolate import Data.Versions import Data.IORef -import Optics import System.Exit -import System.Console.Pretty -import System.IO import Control.Monad.Logger import qualified Data.Map.Strict as M -import qualified Data.ByteString as B -- TODO: improve logging diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index f906ea6..d2c92e3 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -10,21 +10,13 @@ module Main where import Control.Monad.Logger import Control.Monad.Reader -import Control.Monad.IO.Class import Data.Bifunctor -import Data.ByteString ( ByteString ) import qualified Data.ByteString.UTF8 as UTF8 import Data.Char -import Data.Functor ( (<&>) ) import Data.List ( intercalate ) -import qualified Data.Map as M -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 -import Data.Traversable import Data.Versions import GHCup import GHCup.Logger @@ -32,12 +24,12 @@ import GHCup.File import GHCup.Prelude import GHCup.Types import Haskus.Utils.Variant.Excepts -import HPath import Options.Applicative hiding ( style ) import System.Console.Pretty import System.Exit import URI.ByteString import Text.Layout.Table +import Data.String.Interpolate @@ -56,17 +48,22 @@ data Command | SetGHC SetGHCOptions | List ListOptions | Rm RmOptions + | DInfo + +data ToolVersion = ToolVersion Version + | ToolTag Tag + data InstallGHCOptions = InstallGHCOptions - { ghcVer :: Maybe Version + { ghcVer :: Maybe ToolVersion } data InstallCabalOptions = InstallCabalOptions - { cabalVer :: Maybe Version + { cabalVer :: Maybe ToolVersion } data SetGHCOptions = SetGHCOptions - { ghcVer :: Maybe Version + { ghcVer :: Maybe ToolVersion } data ListOptions = ListOptions @@ -100,8 +97,8 @@ opts = ) <*> com where - parseUri s = - bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s) + parseUri s' = + bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s') com :: Parser Command com = subparser @@ -140,41 +137,20 @@ com = subparser (progDesc "Remove a GHC version installed by ghcup") ) ) + <> command + "debug-info" + ((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info"))) ) 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" - ) - ) +installGHCOpts = InstallGHCOptions <$> optional toolVersionParser 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" - ) - ) +installCabalOpts = InstallCabalOptions <$> optional toolVersionParser setGHCOpts :: Parser SetGHCOptions -setGHCOpts = SetGHCOptions <$> 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 set (default: recommended)" - ) - ) +setGHCOpts = SetGHCOptions <$> optional toolVersionParser listOpts :: Parser ListOptions listOpts = @@ -183,7 +159,7 @@ listOpts = (option (eitherReader toolParser) (short 't' <> long "tool" <> metavar "" <> help - "Tool to list versions for. Default is ghc only." + "Tool to list versions for. Default is all" ) ) <*> (optional @@ -198,30 +174,55 @@ listOpts = ) rmOpts :: Parser RmOptions -rmOpts = RmOptions <$> - (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 remove" - ) - ) +rmOpts = + RmOptions + <$> (option + (eitherReader + (bimap (const "Not a valid version") id . version . T.pack) + ) + (short 'v' <> long "version" <> metavar "VERSION" <> help + "The GHC version to remove" + ) + ) +versionParser :: Parser Version +versionParser = option + (eitherReader (bimap (const "Not a valid version") id . version . T.pack)) + (short 'v' <> long "version" <> metavar "VERSION") + + +toolVersionParser :: Parser ToolVersion +toolVersionParser = verP <|> toolP + where + verP = ToolVersion <$> versionParser + toolP = + ToolTag + <$> (option + (eitherReader + (\s' -> case fmap toLower s' of + "recommended" -> Right Recommended + "latest" -> Right Latest + other -> Left ([i|Unknown tag #{other}|]) + ) + ) + (short 't' <> long "tag" <> metavar "TAG") + ) + + toolParser :: String -> Either String Tool -toolParser s | t == T.pack "ghc" = Right GHC - | t == T.pack "cabal" = Right Cabal - | otherwise = Left ("Unknown tool: " <> s) - where t = T.toLower (T.pack s) +toolParser s' | t == T.pack "ghc" = Right GHC + | t == T.pack "cabal" = Right Cabal + | otherwise = Left ("Unknown tool: " <> s') + where t = T.toLower (T.pack s') criteriaParser :: String -> Either String ListCriteria -criteriaParser s | t == T.pack "installed" = Right ListInstalled - | t == T.pack "set" = Right ListSet - | otherwise = Left ("Unknown criteria: " <> s) - where t = T.toLower (T.pack s) +criteriaParser s' | t == T.pack "installed" = Right ListInstalled + | t == T.pack "set" = Right ListSet + | otherwise = Left ("Unknown criteria: " <> s') + where t = T.toLower (T.pack s') toSettings :: Options -> Settings @@ -246,49 +247,54 @@ main = do runLogger . flip runReaderT settings . runE - @'[ FileError + @'[ AlreadyInstalled , ArchiveError - , ProcessError - , URLException - , PlatformResultError - , NoDownload - , NoCompatibleArch , DistroNotFound - , TagNotFound - , AlreadyInstalled - , NotInstalled + , FileDoesNotExistError + , FileError , JSONError + , NoCompatibleArch + , NoDownload + , NotInstalled + , PlatformResultError + , ProcessError + , TagNotFound + , URLException ] let runSetGHC = runLogger . flip runReaderT settings - . runE @'[NotInstalled , TagNotFound, URLException , JSONError] + . runE + @'[ FileDoesNotExistError + , NotInstalled + , TagNotFound + , URLException + , JSONError + , TagNotFound + ] let runListGHC = runLogger . flip runReaderT settings - . runE @'[URLException , JSONError] + . runE @'[FileDoesNotExistError , URLException , JSONError] let runRmGHC = + runLogger . flip runReaderT settings . runE @'[NotInstalled] + + let runDebugInfo = runLogger . flip runReaderT settings - . runE @'[NotInstalled] + . runE + @'[PlatformResultError , NoCompatibleArch , DistroNotFound] case optCommand of InstallGHC (InstallGHCOptions {..}) -> void $ (runInstTool $ do av <- liftE getDownloads - v <- maybe - ( getRecommended av GHC - ?? TagNotFound Recommended GHC - ) - pure - ghcVer - av <- liftE getDownloads - liftE $ installTool (ToolRequest GHC v) - Nothing + v <- liftE $ fromVersion av ghcVer GHC + liftE $ installTool (ToolRequest GHC v) Nothing ) >>= \case VRight _ -> runLogger @@ -296,20 +302,14 @@ main = do VLeft (V (AlreadyInstalled treq)) -> runLogger $ $(logWarn) (T.pack (show treq) <> [s| already installed|]) - VLeft e -> die (color Red $ show e) + VLeft e -> + runLogger ($(logError) [i|#{e}|]) >> exitFailure InstallCabal (InstallCabalOptions {..}) -> void $ (runInstTool $ do av <- liftE getDownloads - v <- maybe - ( getRecommended av Cabal - ?? TagNotFound Recommended Cabal - ) - pure - cabalVer - av <- liftE getDownloads - liftE $ installTool (ToolRequest Cabal v) - Nothing + v <- liftE $ fromVersion av cabalVer Cabal + liftE $ installTool (ToolRequest Cabal v) Nothing ) >>= \case VRight _ -> runLogger @@ -317,24 +317,21 @@ main = do VLeft (V (AlreadyInstalled treq)) -> runLogger $ $(logWarn) (T.pack (show treq) <> [s| already installed|]) - VLeft e -> die (color Red $ show e) + VLeft e -> + runLogger ($(logError) [i|#{e}|]) >> exitFailure SetGHC (SetGHCOptions {..}) -> void $ (runSetGHC $ do av <- liftE getDownloads - v <- maybe - ( getRecommended av GHC - ?? TagNotFound Recommended GHC - ) - pure - ghcVer + v <- liftE $ fromVersion av ghcVer GHC liftE $ setGHC v SetGHCOnly ) >>= \case VRight _ -> runLogger $ $(logInfo) ([s|GHC successfully set|]) - VLeft e -> die (color Red $ show e) + VLeft e -> + runLogger ($(logError) [i|#{e}|]) >> exitFailure List (ListOptions {..}) -> void @@ -343,7 +340,8 @@ main = do ) >>= \case VRight r -> liftIO $ printListResult r - VLeft e -> die (color Red $ show e) + VLeft e -> + runLogger ($(logError) [i|#{e}|]) >> exitFailure Rm (RmOptions {..}) -> void @@ -352,11 +350,35 @@ main = do ) >>= \case VRight _ -> pure () - VLeft e -> die (color Red $ show e) + VLeft e -> + runLogger ($(logError) [i|#{e}|]) >> exitFailure + DInfo -> do + void + $ (runDebugInfo $ do + liftE $ getDebugInfo + ) + >>= \case + VRight dinfo -> putStrLn $ show dinfo + VLeft e -> + runLogger ($(logError) [i|#{e}|]) >> exitFailure pure () +fromVersion :: Monad m + => AvailableDownloads + -> Maybe ToolVersion + -> Tool + -> Excepts '[TagNotFound] m Version +fromVersion av Nothing tool = + getRecommended av tool ?? TagNotFound Recommended tool +fromVersion _ (Just (ToolVersion v)) _ = pure v +fromVersion av (Just (ToolTag Latest)) tool = + getLatest av tool ?? TagNotFound Latest tool +fromVersion av (Just (ToolTag Recommended)) tool = + getRecommended av tool ?? TagNotFound Recommended tool + + printListResult :: [ListResult] -> IO () printListResult lr = do let diff --git a/ghcup.cabal b/ghcup.cabal index 0773ee7..93d83c4 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -32,6 +32,7 @@ common bzlib { build-depends: bzlib >= 0.5.0.5 } 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 haskus-utils-types { build-depends: haskus-utils-types >= 1.5 } 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 } @@ -98,6 +99,7 @@ library , containers , generics-sop , haskus-utils-variant + , haskus-utils-types , hpath , hpath-directory , hpath-filepath @@ -160,6 +162,7 @@ executable ghcup , hpath , pretty-terminal , string-qq + , string-interpolate , table-layout , uri-bytestring , utf8-string diff --git a/lib/GHCup.hs b/lib/GHCup.hs index e0680ca..1d9cd58 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -18,17 +18,14 @@ 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 import Control.Exception.Safe import Data.Aeson import Data.Attoparsec.ByteString import Data.ByteString ( ByteString ) import qualified Data.ByteString.Lazy as L import Data.ByteString.Builder -import Data.Foldable ( asum ) +import Data.Foldable import Data.String.QQ import Data.Text ( Text ) import Data.Versions @@ -37,8 +34,8 @@ import GHCup.Bash import GHCup.File import GHCup.Prelude import GHCup.Types -import GHCup.Types.JSON import GHCup.Types.Optics +import GHCup.Types.JSON ( ) import HPath import HPath.IO import Optics @@ -48,7 +45,6 @@ import Prelude hiding ( abs import Data.List import System.Info import System.IO.Error -import Data.Foldable ( foldrM ) import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Text.ICU as ICU @@ -56,33 +52,21 @@ import Data.Maybe import qualified Data.Map.Strict as Map import Data.Word8 import GHC.IO.Exception -import GHC.IO.Handle import Haskus.Utils.Variant.Excepts -import Haskus.Utils.Variant.VEither import Network.Http.Client hiding ( URL ) -import System.IO.Streams ( InputStream - , OutputStream - , stdout - ) import qualified System.IO.Streams as Streams -import System.Posix.FilePath ( takeExtension - , takeFileName - , splitExtension - ) +import System.Posix.FilePath ( takeFileName ) 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 qualified System.Posix.RawFilePath.Directory + as RD import System.Posix.RawFilePath.Directory.Errors ( hideError ) import "unix" System.Posix.IO.ByteString hiding ( fdWrite ) -import System.Posix.FD as FD -import System.Posix.Foreign ( oTrunc ) import qualified Data.ByteString as B -import OpenSSL ( withOpenSSL ) -import qualified Data.ByteString.Char8 as C -import Data.Functor ( ($>) ) import System.Posix.Types import "unix-bytestring" System.Posix.IO.ByteString ( fdWrite ) @@ -90,12 +74,6 @@ import "unix-bytestring" System.Posix.IO.ByteString import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.Lzma as Lzma import qualified Codec.Compression.BZip as BZip - -import qualified Data.ByteString.UTF8 as UTF8 -import qualified System.Posix.Process.ByteString - as SPPB -import System.Posix.Directory.ByteString - ( changeWorkingDirectory ) import URI.ByteString import URI.ByteString.QQ import Data.String.Interpolate @@ -121,7 +99,7 @@ getCache = ask <&> cache --------------------------- -data PlatformResultError = NoCompatiblePlatform +data PlatformResultError = NoCompatiblePlatform String deriving Show data NoDownload = NoDownload @@ -160,6 +138,9 @@ data JSONError = JSONDecodeError String data ParseError = ParseError String deriving Show +data FileDoesNotExistError = FileDoesNotExistError ByteString + deriving Show + instance Exception ParseError @@ -195,15 +176,19 @@ getDownloads :: ( FromJSONKey Tool , FromJSONKey Version , FromJSON VersionInfo , MonadIO m + , MonadCatch m , MonadReader Settings m ) - => Excepts '[URLException , JSONError] m AvailableDownloads + => Excepts + '[FileDoesNotExistError , URLException , JSONError] + m + AvailableDownloads getDownloads = lift getUrlSource >>= \case GHCupURL -> do bs <- liftE $ downloadBS ghcupURL lE' JSONDecodeError $ eitherDecode' bs - (OwnSource uri) -> do - bs <- liftE $ downloadBS uri + (OwnSource url) -> do + bs <- liftE $ downloadBS url lE' JSONDecodeError $ eitherDecode' bs (OwnSpec av) -> pure $ av @@ -222,12 +207,13 @@ getDownloadInfo :: ( MonadLogger m => ToolRequest -> Maybe PlatformRequest -> Excepts - '[ PlatformResultError - , NoDownload - , NoCompatibleArch - , DistroNotFound - , URLException + '[ DistroNotFound + , FileDoesNotExistError , JSONError + , NoCompatibleArch + , NoDownload + , PlatformResultError + , URLException ] m DownloadInfo @@ -235,7 +221,7 @@ getDownloadInfo (ToolRequest t v) mpfReq = do urlSource <- lift getUrlSource lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|] -- lift $ monadLoggerLog undefined undefined undefined "" - (PlatformRequest arch plat ver) <- case mpfReq of + (PlatformRequest arch' plat ver) <- case mpfReq of Just x -> pure x Nothing -> do (PlatformResult rp rv) <- liftE getPlatform @@ -244,7 +230,7 @@ getDownloadInfo (ToolRequest t v) mpfReq = do dls <- liftE $ getDownloads - lE $ getDownloadInfo' t v arch plat ver dls + lE $ getDownloadInfo' t v arch' plat ver dls getDownloadInfo' :: Tool @@ -288,8 +274,8 @@ download dli dest mfn where dl https = do - let uri = E.decodeUtf8 (serializeURIRef' (view dlUri dli)) - lift $ $(logInfo) [i|downloading: #{uri}|] + let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli)) + lift $ $(logInfo) [i|downloading: #{uri'}|] host <- preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli ?? UnsupportedURL @@ -300,20 +286,34 @@ download dli dest mfn liftIO $ download' https host path port dest mfn -downloadBS :: MonadIO m => URI -> Excepts '[URLException] m L.ByteString -downloadBS uri | view (uriSchemeL' % schemeBSL') uri == [s|https|] = dl True - | view (uriSchemeL' % schemeBSL') uri == [s|http|] = dl False - | otherwise = throwE UnsupportedURL +-- | This is used for downloading the JSON. +downloadBS :: (MonadCatch m, MonadIO m) + => URI + -> Excepts + '[FileDoesNotExistError , URLException] + m + L.ByteString +downloadBS uri' + | scheme == [s|https|] + = dl True + | scheme == [s|http|] + = dl False + | scheme == [s|file|] + = liftException doesNotExistErrorType (FileDoesNotExistError path) + $ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString) + | otherwise + = throwE UnsupportedURL where + scheme = view (uriSchemeL' % schemeBSL') uri' + path = view pathL' uri' dl https = do host <- - preview (authorityL' % _Just % authorityHostL' % hostBSL') uri + preview (authorityL' % _Just % authorityHostL' % hostBSL') uri' ?? UnsupportedURL - let path = view pathL' uri let port = preview (authorityL' % _Just % authorityPortL' % _Just % portNumberL') - uri + uri' liftIO $ downloadBS' https host path port @@ -386,13 +386,13 @@ downloadInternal https host path port consumer = do receiveResponse c - (\p i -> do + (\_ i' -> do outStream <- Streams.makeOutputStream (\case Just bs -> void $ consumer bs Nothing -> pure () ) - Streams.connect i outStream + Streams.connect i' outStream ) closeConnection c @@ -428,7 +428,7 @@ getPlatform = do "freebsd" -> do ver <- getFreeBSDVersion pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver } - what -> throwE NoCompatiblePlatform + what -> throwE $ NoCompatiblePlatform what lift $ $(logDebug) [i|Identified Platform as: #{pfr}|] pure pfr where getFreeBSDVersion = pure Nothing @@ -552,17 +552,17 @@ installTool :: ( MonadThrow m -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform -> Excepts '[ AlreadyInstalled - , FileError , ArchiveError + , DistroNotFound + , FileDoesNotExistError + , FileError + , JSONError + , NoCompatibleArch + , NoDownload + , NotInstalled + , PlatformResultError , ProcessError , URLException - , PlatformResultError - , NoDownload - , NoCompatibleArch - , DistroNotFound - , NotInstalled - , URLException - , JSONError ] m () @@ -592,7 +592,7 @@ installTool treq mpfReq = do unpacked <- liftE $ unpackToTmpDir dl -- prepare paths - ghcdir <- liftIO $ ghcupGHCDir (view toolVersion $ treq) + ghcdir <- liftIO $ ghcupGHCDir (view trVersion $ treq) bindir <- liftIO ghcupBinDir -- the subdir of the archive where we do the work @@ -607,14 +607,14 @@ installTool treq mpfReq = do -- version, create it regardless. (mj, mi) <- liftIO $ getGHCMajor ver getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor) - (ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir + (ToolRequest Cabal _) -> liftE $ installCabal archiveSubdir bindir pure () toolAlreadyInstalled :: ToolRequest -> IO Bool -toolAlreadyInstalled ToolRequest {..} = case _tool of - GHC -> ghcInstalled _toolVersion - Cabal -> cabalInstalled _toolVersion +toolAlreadyInstalled ToolRequest {..} = case _trTool of + GHC -> ghcInstalled _trVersion + Cabal -> cabalInstalled _trVersion @@ -678,15 +678,15 @@ setGHC ver sghc = do -- for ghc tools (ghc, ghci, haddock, ...) verfiles <- ghcToolFiles ver - forM verfiles $ \file -> do + forM_ verfiles $ \file -> do liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir file) targetFile <- case sghc of SetGHCOnly -> pure file SetGHCMajor -> do - major <- + major' <- (\(mj, mi) -> E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi) <$> getGHCMajor ver - parseRel (toFilePath file <> B.singleton _hyphen <> major) + parseRel (toFilePath file <> B.singleton _hyphen <> major') SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS) liftIO $ hideError doesNotExistErrorType $ deleteFile (destdir targetFile) @@ -743,10 +743,13 @@ availableToolVersions av tool = toListOf av -listVersions :: (MonadReader Settings m, MonadIO m) +listVersions :: (MonadReader Settings m, MonadIO m, MonadCatch m) => Maybe Tool -> Maybe ListCriteria - -> Excepts '[URLException , JSONError] m [ListResult] + -> Excepts + '[FileDoesNotExistError , URLException , JSONError] + m + [ListResult] listVersions lt criteria = do dls <- liftE $ getDownloads liftIO $ listVersions' dls lt criteria @@ -786,9 +789,9 @@ listVersions' av lt criteria = case lt of - ------------------ - --[ List tools ]-- - ------------------ + -------------- + --[ GHC rm ]-- + -------------- -- | This function may throw and crash in various ways. @@ -799,14 +802,13 @@ rmGHCVer ver = do isSetGHC <- fmap (maybe False (== ver)) $ ghcSet dir <- liftIO $ ghcupGHCDir ver let d' = toFilePath dir - let v' = prettyVer ver - exists <- liftIO $ doesDirectoryExist dir + exists <- liftIO $ doesDirectoryExist dir toolsFiles <- liftE $ ghcToolFiles ver if exists then do - -- this isn't atomic + -- this isn't atomic, order matters lift $ $(logInfo) [i|Removing directory recursively: #{d'}|] liftIO $ deleteDirRecursive dir @@ -818,7 +820,7 @@ rmGHCVer ver = do when isSetGHC $ liftE $ do lift $ $(logInfo) [i|Removing ghc symlinks|] - rmPlain dir toolsFiles + rmPlain toolsFiles liftIO $ ghcupBaseDir @@ -841,10 +843,9 @@ rmGHCVer ver = do -- E.g. ghc, if this version is the set one. -- This reads `ghcupGHCDir`. rmPlain :: (MonadThrow m, MonadFail m, MonadIO m) - => Path Abs - -> [Path Rel] -- ^ tools files + => [Path Rel] -- ^ tools files -> Excepts '[NotInstalled] m () - rmPlain ghcDir files = do + rmPlain files = do bindir <- liftIO $ ghcupBinDir forM_ files $ \f -> liftIO $ deleteFile (bindir f) @@ -868,6 +869,27 @@ rmGHCVer ver = do + ------------------ + --[ Debug info ]-- + ------------------ + + +getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m) + => Excepts + '[PlatformResultError , NoCompatibleArch , DistroNotFound] + m + DebugInfo +getDebugInfo = do + diBaseDir <- liftIO $ ghcupBaseDir + diBinDir <- liftIO $ ghcupBinDir + diGHCDir <- liftIO $ ghcupGHCBaseDir + diCacheDir <- liftIO $ ghcupCacheDir + diURLSource <- lift $ getUrlSource + diArch <- lE getArchitecture + diPlatform <- liftE $ getPlatform + pure $ DebugInfo { .. } + + ----------------- --[ Utilities ]-- @@ -957,7 +979,7 @@ getGHCForMajor :: (MonadIO m, MonadThrow m) => Int -- ^ major version component -> Int -- ^ minor version component -> m (Maybe Version) -getGHCForMajor major minor = do +getGHCForMajor major' minor' = do p <- liftIO $ ghcupGHCBaseDir ghcs <- liftIO $ getDirsFiles' p semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath @@ -967,7 +989,7 @@ getGHCForMajor major minor = do . sort . filter (\SemVer {..} -> - fromIntegral _svMajor == major && fromIntegral _svMinor == minor + fromIntegral _svMajor == major' && fromIntegral _svMinor == minor' ) $ semvers @@ -1016,7 +1038,6 @@ ghcToolFiles ver = do ghcdir <- liftIO $ ghcupGHCDir ver -- fail if ghc is not installed - exists <- liftIO $ doesDirectoryExist ghcdir whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir) (throwE (NotInstalled $ ToolRequest GHC ver)) diff --git a/lib/GHCup/File.hs b/lib/GHCup/File.hs index 146e77e..46798bd 100644 --- a/lib/GHCup/File.hs +++ b/lib/GHCup/File.hs @@ -19,7 +19,6 @@ import Data.Foldable import Control.Monad 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 @@ -40,12 +39,6 @@ import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.Internal.Data.Unfold as SU import qualified Streamly.Prelude as S import System.Exit -import qualified Streamly.Data.Fold as FL -import Data.ByteString.Builder -import Foreign.C.Error -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 ) @@ -61,11 +54,12 @@ data ProcessError = NonZeroExit Int ByteString [ByteString] deriving Show -data CapturedProcess = CapturedProcess { - _exitCode :: ExitCode +data CapturedProcess = CapturedProcess + { _exitCode :: ExitCode , _stdOut :: ByteString , _stdErr :: ByteString -} deriving (Eq, Show) + } + deriving (Eq, Show) makeLenses ''CapturedProcess @@ -101,7 +95,7 @@ findExecutable ex = do -- figure out if a file exists, then treat it as a negative result. asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap -- asum for short-circuiting behavior - (\s -> (isExecutable (s ex) >>= guard) $> (Just (s ex))) + (\s' -> (isExecutable (s' ex) >>= guard) $> (Just (s' ex))) sPaths @@ -111,10 +105,9 @@ executeOut :: Path b -- ^ command as filename, e.g. 'ls' -> [ByteString] -- ^ arguments to the command -> Maybe (Path Abs) -- ^ chdir to this path -> IO CapturedProcess -executeOut path args chdir = - captureOutStreams $ do - maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir - SPPB.executeFile (toFilePath path) True args Nothing +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 @@ -150,9 +143,9 @@ captureOutStreams action = stdout' <- L.toStrict <$> readFd parentStdoutRead stderr' <- L.toStrict <$> readFd parentStderrRead pure $ CapturedProcess { _exitCode = es - , _stdOut = stdout' - , _stdErr = stderr' - } + , _stdOut = stdout' + , _stdErr = stderr' + } _ -> throwIO $ userError $ ("No such PID " ++ show pid) where diff --git a/lib/GHCup/Logger.hs b/lib/GHCup/Logger.hs index 1fbcfc7..dc5bae9 100644 --- a/lib/GHCup/Logger.hs +++ b/lib/GHCup/Logger.hs @@ -1,30 +1,10 @@ module GHCup.Logger where -import GHCup -import GHCup.Types -import GHCup.Types.Optics - -import Control.Monad -import Control.Exception.Safe -import Control.Monad.Reader.Class -import Control.Monad.IO.Class -import Control.Monad.Trans.Class ( lift ) -import Control.Monad.Trans.Reader ( ReaderT - , runReaderT - ) -import Data.List -import Data.String.QQ -import Data.String.Interpolate -import Data.Versions -import Data.IORef -import Optics -import System.Exit import System.Console.Pretty import System.IO import Control.Monad.Logger -import qualified Data.Map.Strict as M import qualified Data.ByteString as B @@ -32,14 +12,14 @@ myLoggerT :: (B.ByteString -> IO ()) -> LoggingT m a -> m a myLoggerT outter loggingt = runLoggingT loggingt mylogger where mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO () - mylogger loc source level str = do + mylogger _ _ level str' = do let l = case level of LevelDebug -> toLogStr (style Bold $ color Blue "[ Debug ]") LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]") LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]") LevelError -> toLogStr (style Bold $ color Red "[ Error ]") LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]" - let out = fromLogStr (l <> toLogStr " " <> str <> toLogStr "\n") + let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n") outter out myLoggerTStdout :: LoggingT m a -> m a diff --git a/lib/GHCup/Prelude.hs b/lib/GHCup/Prelude.hs index e4266fe..5fc126c 100644 --- a/lib/GHCup/Prelude.hs +++ b/lib/GHCup/Prelude.hs @@ -15,6 +15,7 @@ module GHCup.Prelude where import Control.Applicative import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Trans.Class ( lift ) import Control.Exception.Safe import Data.Bifunctor @@ -23,8 +24,8 @@ import qualified Data.Strict.Maybe as S import Data.Monoid ( (<>) ) import Data.String -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy.Builder.Int as B +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Lazy.Builder.Int as B import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.Text.Lazy as TL import Data.Text ( Text ) @@ -32,6 +33,7 @@ import qualified Data.Text.Encoding as E import qualified Data.Text as T import Data.Versions import qualified Data.ByteString.Lazy as L +import Haskus.Utils.Types.List import Haskus.Utils.Variant.Excepts import System.IO.Error import Language.Haskell.TH @@ -99,9 +101,14 @@ lBS2sT :: L.ByteString -> Text lBS2sT = TL.toStrict . TLE.decodeUtf8 -handleIO' :: IOErrorType -> (IOException -> IO a) -> IO a -> IO a -handleIO' err handler = - handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e) + +handleIO' :: (MonadIO m, MonadCatch m) + => IOErrorType + -> (IOException -> m a) + -> m a + -> m a +handleIO' err handler = handleIO + (\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e) (??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a @@ -139,14 +146,34 @@ lEM' f em = lift em >>= lE . bimap f id fromEither :: Either a b -> VEither '[a] b fromEither = either (VLeft . V) VRight + +liftException :: ( MonadCatch m + , MonadIO m + , Monad m + , e :< es' + , LiftVariant es es' + ) + => IOErrorType + -> e + -> Excepts es m a + -> Excepts es' m a +liftException errType ex = + handleIO + (\e -> + if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e + ) + . liftE + + +-- TODO: does this work? 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 +hideExcept _ a action = + catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action throwEither :: (Exception a, MonadThrow m) => Either a b -> m b @@ -177,8 +204,8 @@ qq quoteExp' = QuasiQuoter "illegal QuasiQuote (allowed as expression only, used as a declaration)" } -ver :: QuasiQuoter -ver = qq mkV +vver :: QuasiQuoter +vver = qq mkV where mkV :: Text -> Q Exp mkV = either (fail . show) TH.lift . version diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index fd1bc12..d517665 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -9,9 +9,21 @@ import Data.Versions import URI.ByteString +data DebugInfo = DebugInfo + { diBaseDir :: Path Abs + , diBinDir :: Path Abs + , diGHCDir :: Path Abs + , diCacheDir :: Path Abs + , diURLSource :: URLSource + , diArch :: Architecture + , diPlatform :: PlatformResult + } + deriving Show + + data SetGHC = SetGHCOnly -- ^ unversioned 'ghc' | SetGHCMajor -- ^ ghc-x.y - | SetGHCMinor -- ^ ghc-x.y.z + | SetGHCMinor -- ^ ghc-x.y.z -- TODO: rename deriving Show @@ -33,11 +45,12 @@ data DownloadInfo = DownloadInfo data Tool = GHC | Cabal + | GHCUp deriving (Eq, GHC.Generic, Ord, Show) data ToolRequest = ToolRequest - { _tool :: Tool - , _toolVersion :: Version + { _trTool :: Tool + , _trVersion :: Version } deriving (Eq, Show)