This commit is contained in:
Julian Ospald 2020-03-01 00:07:39 +01:00
parent 6489e8430b
commit e1fb60d3b1
11 changed files with 298 additions and 253 deletions

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 "<ghc|cabal>" <> help
"Tool to list versions for. Default is ghc only."
"Tool to list versions for. Default is all"
)
)
<*> (optional
@ -198,10 +174,11 @@ listOpts =
)
rmOpts :: Parser RmOptions
rmOpts = RmOptions <$>
(option
rmOpts =
RmOptions
<$> (option
(eitherReader
(\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
(bimap (const "Not a valid version") id . version . T.pack)
)
(short 'v' <> long "version" <> metavar "VERSION" <> help
"The GHC version to remove"
@ -210,18 +187,42 @@ rmOpts = RmOptions <$>
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
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)
| 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
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)
| 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

View File

@ -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

View File

@ -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
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))

View File

@ -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,8 +105,7 @@ 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
executeOut path args chdir = captureOutStreams $ do
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile (toFilePath path) True args Nothing

View File

@ -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

View File

@ -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
@ -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

View File

@ -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)