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

Jo

Browse Source
This commit is contained in:
Julian Ospald 2020-03-08 18:30:08 +01:00
parent b2a7da29cf
commit 18f891f261
20 changed files with 2652 additions and 1995 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
TODO.md
View File

@ -2,22 +2,29 @@
## Now ## Now
* static builds and host ghcup (and fix BinaryDownloads) * print-system-reqs
* interoperability with old ghcup
* sign the JSON? (Or check gpg keys?) * set proper ghcup URL
## Cleanups
* avoid alternative for IO
* don't use Excepts?
## Maybe ## Maybe
* maybe: download progress
* maybe: changelog Show the changelog of a GHC release (online) * maybe: changelog Show the changelog of a GHC release (online)
* maybe: print-system-reqs Print an approximation of system requirements
* OS faking * OS faking
* sign the JSON? (Or check gpg keys?)
* testing (especially distro detection -> unit tests) * testing (especially distro detection -> unit tests)
* hard cleanup command?
## Later ## Later
* static builds and host ghcup
* do bootstrap-haskell with new ghcup
* add support for RC/alpha/HEAD versions * add support for RC/alpha/HEAD versions
* check for updates on start * check for updates on start
* use plucky or oops instead of Excepts * use plucky or oops instead of Excepts

1502
app/ghcup-gen/BinaryDownloads.hs
View File

File diff suppressed because it is too large Load Diff

1692
app/ghcup-gen/GHCupDownloads.hs
View File

File diff suppressed because it is too large Load Diff

26
app/ghcup-gen/SourceDownloads.hs
View File

@ -1,26 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
module SourceDownloads where
import GHCup.Types
import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import HPath
import URI.ByteString.QQ
import qualified Data.Map as M
-- TODO: source tarballs
-- TODO: reference tarballs
sourceDownloads :: SourceDownloads
sourceDownloads = M.fromList
[ ( [vver|8.6.5|]
, DownloadInfo
[uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-src.tar.xz|]
(Just ([rel|ghc-8.6.5|] :: Path Rel))
[s|b47726aaf302eb87b4970fcee924d45d|]
)
]

28
app/ghcup-gen/Validate.hs
View File

@ -7,7 +7,6 @@ module Validate where
import GHCup import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils.Logger import GHCup.Utils.Logger
import Control.Exception.Safe import Control.Exception.Safe
@ -48,22 +47,22 @@ addError = do
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m) validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads => GHCupDownloads
-> m ExitCode -> m ExitCode
validate dls@GHCupDownloads {..} = do validate dls = do
ref <- liftIO $ newIORef 0 ref <- liftIO $ newIORef 0
-- * verify binary downloads * -- -- * verify binary downloads * --
flip runReaderT ref $ do flip runReaderT ref $ do
-- unique tags -- unique tags
forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkUniqueTags t forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
-- required platforms -- required platforms
forM_ (M.toList _binaryDownloads) $ \(t, versions) -> forM_ (M.toList dls) $ \(t, versions) ->
forM_ (M.toList versions) $ \(v, vi) -> forM_ (M.toList versions) $ \(v, vi) ->
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
checkHasRequiredPlatforms t v arch (M.keys pspecs) checkHasRequiredPlatforms t v arch (M.keys pspecs)
checkGHCisSemver checkGHCisSemver
forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkMandatoryTags t forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
-- exit -- exit
e <- liftIO $ readIORef ref e <- liftIO $ readIORef ref
@ -86,7 +85,7 @@ validate dls@GHCupDownloads {..} = do
[i|FreeBSD missing for #{t} #{v'} #{arch}|] [i|FreeBSD missing for #{t} #{v'} #{arch}|]
checkUniqueTags tool = do checkUniqueTags tool = do
let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool let allTags = join $ fmap snd $ availableToolVersions dls tool
let nonUnique = let nonUnique =
fmap fst fmap fst
. filter (\(_, b) -> not b) . filter (\(_, b) -> not b)
@ -110,7 +109,7 @@ validate dls@GHCupDownloads {..} = do
isUniqueTag Recommended = True isUniqueTag Recommended = True
checkGHCisSemver = do checkGHCisSemver = do
let ghcVers = toListOf (binaryDownloads % ix GHC % to M.keys % folded) dls let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
forM_ ghcVers $ \v -> case semver (prettyVer v) of forM_ ghcVers $ \v -> case semver (prettyVer v) of
Left _ -> do Left _ -> do
lift $ $(logError) [i|GHC version #{v} is not valid semver|] lift $ $(logError) [i|GHC version #{v} is not valid semver|]
@ -119,7 +118,7 @@ validate dls@GHCupDownloads {..} = do
-- a tool must have at least one of each mandatory tags -- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do checkMandatoryTags tool = do
let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool let allTags = join $ fmap snd $ availableToolVersions dls tool
forM_ [Latest, Recommended] $ \t -> case elem t allTags of forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do False -> do
lift $ $(logError) [i|Tag #{t} missing from #{tool}|] lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
@ -132,20 +131,25 @@ validateTarballs :: ( Monad m
, MonadThrow m , MonadThrow m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
, MonadMask m
) )
=> GHCupDownloads => GHCupDownloads
-> m ExitCode -> m ExitCode
validateTarballs GHCupDownloads {..} = do validateTarballs dls = do
ref <- liftIO $ newIORef 0 ref <- liftIO $ newIORef 0
flip runReaderT ref $ do flip runReaderT ref $ do
-- download/verify all tarballs -- download/verify all binary tarballs
let let
dlis = nub $ join $ (M.elems _binaryDownloads) <&> \versions -> dlbis = nub $ join $ (M.elems dls) <&> \versions ->
join $ (M.elems versions) <&> \vi -> join $ (M.elems versions) <&> \vi ->
join $ (M.elems $ _viArch vi) <&> \pspecs -> join $ (M.elems $ _viArch vi) <&> \pspecs ->
join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs) join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs)
forM_ dlis $ downloadAll forM_ dlbis $ downloadAll
let dlsrc = nub $ join $ (M.elems dls) <&> \versions ->
join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL
forM_ dlsrc $ downloadAll
-- exit -- exit
e <- liftIO $ readIORef ref e <- liftIO $ readIORef ref

181
app/ghcup/Main.hs
View File

@ -13,10 +13,10 @@ import GHCup.Download
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger import GHCup.Utils.Logger
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ import GHCup.Utils.String.QQ
import GHCup.Version
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
@ -43,6 +43,7 @@ import URI.ByteString
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
@ -66,8 +67,9 @@ data Command
| List ListOptions | List ListOptions
| Rm RmOptions | Rm RmOptions
| DInfo | DInfo
| Compile CompileOptions | Compile CompileCommand
| Upgrade UpgradeOpts | Upgrade UpgradeOpts
| NumericVersion
data ToolVersion = ToolVersion Version data ToolVersion = ToolVersion Version
| ToolTag Tag | ToolTag Tag
@ -94,8 +96,12 @@ data RmOptions = RmOptions
} }
data CompileCommand = CompileGHC CompileOptions
| CompileCabal CompileOptions
data CompileOptions = CompileOptions data CompileOptions = CompileOptions
{ ghcVer :: Version { targetVer :: Version
, bootstrapVer :: Version , bootstrapVer :: Version
, jobs :: Maybe Int , jobs :: Maybe Int
, buildConfig :: Maybe (Path Abs) , buildConfig :: Maybe (Path Abs)
@ -122,21 +128,20 @@ opts =
(option (option
(eitherReader parseUri) (eitherReader parseUri)
(short 's' <> long "url-source" <> metavar "URL" <> help (short 's' <> long "url-source" <> metavar "URL" <> help
"Alternative ghcup download info url" "Alternative ghcup download info url" <> internal
) )
) )
) )
<*> switch <*> switch
( short 'n' (short 'n' <> long "no-verify" <> help
<> long "no-verify" "Skip tarball checksum verification (default: False)"
<> help
"Skip tarball checksum checks (default: False)"
) )
<*> com <*> com
where where
parseUri s' = parseUri s' =
bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s') bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
com :: Parser Command com :: Parser Command
com = com =
subparser subparser
@ -162,6 +167,13 @@ com =
(progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)") (progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")
) )
) )
<> command
"compile"
( Compile
<$> (info (compileP <**> helper)
(progDesc "Compile a tool from source")
)
)
<> commandGroup "Main commands:" <> commandGroup "Main commands:"
) )
<|> subparser <|> subparser
@ -180,13 +192,6 @@ com =
(progDesc "Remove a GHC version installed by ghcup") (progDesc "Remove a GHC version installed by ghcup")
) )
) )
<> command
"compile"
( Compile
<$> (info (compileOpts <**> helper)
(progDesc "Compile GHC from source")
)
)
<> commandGroup "GHC commands:" <> commandGroup "GHC commands:"
<> hidden <> hidden
) )
@ -194,6 +199,11 @@ com =
( command ( command
"debug-info" "debug-info"
((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info"))) ((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
<> command
"numeric-version"
( (\_ -> NumericVersion)
<$> (info (helper) (progDesc "Show the numeric version"))
)
<> commandGroup "Other commands:" <> commandGroup "Other commands:"
<> hidden <> hidden
) )
@ -246,6 +256,24 @@ rmOpts :: Parser RmOptions
rmOpts = RmOptions <$> versionParser rmOpts = RmOptions <$> versionParser
compileP :: Parser CompileCommand
compileP = subparser
( command
"ghc"
( CompileGHC
<$> (info (compileOpts <**> helper) (progDesc "Compile GHC from source")
)
)
<> command
"cabal"
( CompileCabal
<$> (info (compileOpts <**> helper)
(progDesc "Compile Cabal from source")
)
)
)
compileOpts :: Parser CompileOptions compileOpts :: Parser CompileOptions
compileOpts = compileOpts =
CompileOptions CompileOptions
@ -254,7 +282,7 @@ compileOpts =
(bimap (const "Not a valid version") id . version . T.pack) (bimap (const "Not a valid version") id . version . T.pack)
) )
(short 'v' <> long "version" <> metavar "VERSION" <> help (short 'v' <> long "version" <> metavar "VERSION" <> help
"The GHC version to compile" "The tool version to compile"
) )
) )
<*> (option <*> (option
@ -386,19 +414,19 @@ main = do
. runResourceT . runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
, ArchiveError , UnknownArchive
, DistroNotFound , DistroNotFound
, FileDoesNotExistError , FileDoesNotExistError
, FileError , CopyError
, JSONError , JSONError
, NoCompatibleArch , NoCompatibleArch
, NoDownload , NoDownload
, NotInstalled , NotInstalled
, PlatformResultError , NoCompatiblePlatform
, ProcessError , BuildFailed
, TagNotFound , TagNotFound
, URLException
, DigestError , DigestError
, DownloadFailed
] ]
let runSetGHC = let runSetGHC =
@ -408,15 +436,15 @@ main = do
@'[ FileDoesNotExistError @'[ FileDoesNotExistError
, NotInstalled , NotInstalled
, TagNotFound , TagNotFound
, URLException
, JSONError , JSONError
, TagNotFound , TagNotFound
, DownloadFailed
] ]
let runListGHC = let runListGHC =
runLogger runLogger
. flip runReaderT settings . flip runReaderT settings
. runE @'[FileDoesNotExistError , URLException , JSONError] . runE @'[FileDoesNotExistError , JSONError , DownloadFailed]
let runRmGHC = let runRmGHC =
runLogger . flip runReaderT settings . runE @'[NotInstalled] runLogger . flip runReaderT settings . runE @'[NotInstalled]
@ -425,7 +453,7 @@ main = do
runLogger runLogger
. flip runReaderT settings . flip runReaderT settings
. runE . runE
@'[PlatformResultError , NoCompatibleArch , DistroNotFound] @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC = let runCompileGHC =
runLogger runLogger
@ -433,31 +461,43 @@ main = do
. runResourceT . runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
, NotInstalled , BuildFailed
, GHCNotFound
, ArchiveError
, ProcessError
, URLException
, DigestError , DigestError
, BuildConfigNotFound , DownloadFailed
, FileDoesNotExistError , GHCupSetError
, URLException , NoDownload
, UnknownArchive
--
, JSONError , JSONError
] ]
let runCompileCabal =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[ JSONError
, UnknownArchive
, NoDownload
, DigestError
, DownloadFailed
, BuildFailed
]
let runUpgrade = let runUpgrade =
runLogger runLogger
. flip runReaderT settings . flip runReaderT settings
. runResourceT . runResourceT
. runE . runE
@'[ DigestError @'[ DigestError
, URLException
, DistroNotFound , DistroNotFound
, PlatformResultError , NoCompatiblePlatform
, NoCompatibleArch , NoCompatibleArch
, NoDownload , NoDownload
, FileDoesNotExistError , FileDoesNotExistError
, JSONError , JSONError
, DownloadFailed
, CopyError
] ]
@ -465,16 +505,22 @@ main = do
Install (InstallGHC InstallOptions {..}) -> Install (InstallGHC InstallOptions {..}) ->
void void
$ (runInstTool $ do $ (runInstTool $ do
dls <- _binaryDownloads <$> liftE getDownloads dls <- liftE getDownloads
v <- liftE $ fromVersion dls instVer GHC v <- liftE $ fromVersion dls instVer GHC
liftE $ installTool dls (ToolRequest GHC v) Nothing liftE $ installGHCBin dls v Nothing
) )
>>= \case >>= \case
VRight _ -> runLogger VRight _ -> runLogger
$ $(logInfo) ([s|GHC installation successful|]) $ $(logInfo) ([s|GHC installation successful|])
VLeft (V (AlreadyInstalled treq)) -> VLeft (V (AlreadyInstalled _ v)) ->
runLogger $ $(logWarn) runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|]) [i|GHC ver #{prettyVer v} already installed|]
VLeft (V (BuildFailed tmpdir e)) ->
runLogger
($(logError) [i|Build failed with #{e}
Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
)
>> exitFailure
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
$(logError) [i|#{e}|] $(logError) [i|#{e}|]
@ -483,16 +529,16 @@ main = do
Install (InstallCabal InstallOptions {..}) -> Install (InstallCabal InstallOptions {..}) ->
void void
$ (runInstTool $ do $ (runInstTool $ do
dls <- _binaryDownloads <$> liftE getDownloads dls <- liftE getDownloads
v <- liftE $ fromVersion dls instVer Cabal v <- liftE $ fromVersion dls instVer Cabal
liftE $ installTool dls (ToolRequest Cabal v) Nothing liftE $ installCabalBin dls v Nothing
) )
>>= \case >>= \case
VRight _ -> runLogger VRight _ -> runLogger
$ $(logInfo) ([s|Cabal installation successful|]) $ $(logInfo) ([s|Cabal installation successful|])
VLeft (V (AlreadyInstalled treq)) -> VLeft (V (AlreadyInstalled _ v)) ->
runLogger $ $(logWarn) runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|]) [i|Cabal ver #{prettyVer v} already installed|]
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
$(logError) [i|#{e}|] $(logError) [i|#{e}|]
@ -502,7 +548,7 @@ main = do
SetGHC (SetGHCOptions {..}) -> SetGHC (SetGHCOptions {..}) ->
void void
$ (runSetGHC $ do $ (runSetGHC $ do
dls <- _binaryDownloads <$> liftE getDownloads dls <- liftE getDownloads
v <- liftE $ fromVersion dls ghcVer GHC v <- liftE $ fromVersion dls ghcVer GHC
liftE $ setGHC v SetGHCOnly liftE $ setGHC v SetGHCOnly
) )
@ -515,7 +561,7 @@ main = do
List (ListOptions {..}) -> List (ListOptions {..}) ->
void void
$ (runListGHC $ do $ (runListGHC $ do
dls <- _binaryDownloads <$> liftE getDownloads dls <- liftE getDownloads
liftIO $ listVersions dls lTool lCriteria liftIO $ listVersions dls lTool lCriteria
) )
>>= \case >>= \case
@ -543,24 +589,52 @@ main = do
VLeft e -> VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure runLogger ($(logError) [i|#{e}|]) >> exitFailure
Compile (CompileOptions {..}) -> Compile (CompileGHC CompileOptions {..}) ->
void void
$ (runCompileGHC $ do $ (runCompileGHC $ do
dls <- _sourceDownloads <$> liftE getDownloads dls <- liftE getDownloads
liftE $ compileGHC dls ghcVer bootstrapVer jobs buildConfig liftE
$ compileGHC dls targetVer bootstrapVer jobs buildConfig
) )
>>= \case >>= \case
VRight _ -> VRight _ ->
runLogger $ $(logInfo) runLogger $ $(logInfo)
([s|GHC successfully compiled and installed|]) ([s|GHC successfully compiled and installed|])
VLeft (V (AlreadyInstalled treq)) -> VLeft (V (AlreadyInstalled _ v)) ->
runLogger $ $(logWarn) runLogger $ $(logWarn)
(T.pack (show treq) <> [s| already installed|]) [i|GHC ver #{prettyVer v} already installed|]
VLeft (V (BuildFailed tmpdir e)) ->
runLogger
($(logError) [i|Build failed with #{e}
Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
)
>> exitFailure
VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure
Compile (CompileCabal CompileOptions {..}) ->
void
$ (runCompileCabal $ do
dls <- liftE getDownloads
liftE $ compileCabal dls
targetVer
bootstrapVer
jobs
)
>>= \case
VRight _ ->
runLogger $ $(logInfo)
([s|Cabal successfully compiled and installed|])
VLeft (V (BuildFailed tmpdir e)) ->
runLogger
($(logError) [i|Build failed with #{e}
Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
)
>> exitFailure
VLeft e -> VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure runLogger ($(logError) [i|#{e}|]) >> exitFailure
Upgrade (uOpts) -> do Upgrade (uOpts) -> do
liftIO $ putStrLn $ show uOpts
target <- case uOpts of target <- case uOpts of
UpgradeInplace -> do UpgradeInplace -> do
efp <- liftIO $ getExecutablePath efp <- liftIO $ getExecutablePath
@ -573,7 +647,7 @@ main = do
void void
$ (runUpgrade $ do $ (runUpgrade $ do
dls <- _binaryDownloads <$> liftE getDownloads dls <- liftE getDownloads
liftE $ upgradeGHCup dls target liftE $ upgradeGHCup dls target
) )
>>= \case >>= \case
@ -585,11 +659,12 @@ main = do
VLeft e -> VLeft e ->
runLogger ($(logError) [i|#{e}|]) >> exitFailure runLogger ($(logError) [i|#{e}|]) >> exitFailure
NumericVersion -> T.hPutStr stdout (prettyPVP ghcUpVer)
pure () pure ()
fromVersion :: Monad m fromVersion :: Monad m
=> BinaryDownloads => GHCupDownloads
-> Maybe ToolVersion -> Maybe ToolVersion
-> Tool -> Tool
-> Excepts '[TagNotFound] m Version -> Excepts '[TagNotFound] m Version
@ -611,6 +686,7 @@ printListResult lr = do
, column expand left def def , column expand left def def
, column expand left def def , column expand left def def
, column expand left def def , column expand left def def
, column expand left def def
] ]
$ fmap $ fmap
(\ListResult {..} -> (\ListResult {..} ->
@ -621,6 +697,7 @@ printListResult lr = do
, fmap toLower . show $ lTool , fmap toLower . show $ lTool
, T.unpack . prettyVer $ lVer , T.unpack . prettyVer $ lVer
, intercalate "," $ ((fmap . fmap) toLower . fmap show $ lTag) , intercalate "," $ ((fmap . fmap) toLower . fmap show $ lTag)
, if fromSrc then (color Blue "compiled") else mempty
] ]
) )
lr lr

64
cabal.project.freeze
View File

@ -1,5 +1,4 @@
constraints: any.Cabal ==2.4.0.1, constraints: any.Cabal ==2.4.0.1,
any.HUnit ==1.6.0.0,
any.HsOpenSSL ==0.11.4.17, any.HsOpenSSL ==0.11.4.17,
HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -old-locale, HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -old-locale,
any.IfElse ==0.85, any.IfElse ==0.85,
@ -10,22 +9,28 @@ constraints: any.Cabal ==2.4.0.1,
abstract-deque -usecas, abstract-deque -usecas,
any.aeson ==1.4.6.0, any.aeson ==1.4.6.0,
aeson -bytestring-builder -cffi -developer -fast, aeson -bytestring-builder -cffi -developer -fast,
any.aeson-pretty ==0.8.8,
aeson-pretty -lib-only,
any.ansi-terminal ==0.10.3, any.ansi-terminal ==0.10.3,
ansi-terminal -example, ansi-terminal -example,
any.ansi-wl-pprint ==0.6.9,
ansi-wl-pprint -example,
any.array ==0.5.3.0, any.array ==0.5.3.0,
any.ascii-string ==1.0.1.4, any.ascii-string ==1.0.1.4,
any.assoc ==1.0.1,
any.async ==2.2.2, any.async ==2.2.2,
async -bench, async -bench,
any.atomic-primops ==0.8.3, any.atomic-primops ==0.8.3,
atomic-primops -debug, atomic-primops -debug,
any.attoparsec ==0.13.2.3, any.attoparsec ==0.13.2.3,
attoparsec -developer, attoparsec -developer,
any.auto-update ==0.1.6,
any.base ==4.12.0.0, any.base ==4.12.0.0,
any.base-compat ==0.11.1, any.base-compat ==0.11.1,
any.base-orphans ==0.8.2, any.base-orphans ==0.8.2,
any.base-prelude ==1.3, any.base-prelude ==1.3,
any.base16-bytestring ==0.1.1.6,
any.base64-bytestring ==1.0.0.3, any.base64-bytestring ==1.0.0.3,
any.basement ==0.0.11,
any.bifunctors ==5.5.7, any.bifunctors ==5.5.7,
bifunctors +semigroups +tagged, bifunctors +semigroups +tagged,
any.binary ==0.8.6.0, any.binary ==0.8.6.0,
@ -99,6 +104,7 @@ constraints: any.Cabal ==2.4.0.1,
any.io-streams ==1.5.1.0, any.io-streams ==1.5.1.0,
io-streams -nointeractivetests, io-streams -nointeractivetests,
any.language-bash ==0.9.0, any.language-bash ==0.9.0,
any.lifted-base ==0.2.3.12,
any.list-t ==1.0.4, any.list-t ==1.0.4,
any.lockfree-queue ==0.2.3.1, any.lockfree-queue ==0.2.3.1,
any.lzma ==0.0.0.3, any.lzma ==0.0.0.3,
@ -108,29 +114,42 @@ constraints: any.Cabal ==2.4.0.1,
megaparsec -dev, megaparsec -dev,
any.mmorph ==1.1.3, any.mmorph ==1.1.3,
any.monad-control ==1.0.2.3, any.monad-control ==1.0.2.3,
any.monad-logger ==0.3.32,
monad-logger +template_haskell,
any.monad-loops ==0.4.3,
monad-loops +base4,
any.mono-traversable ==1.0.15.1,
any.mtl ==2.2.2, any.mtl ==2.2.2,
any.mwc-random ==0.14.0.0, any.mwc-random ==0.14.0.0,
any.network ==3.0.1.1, any.network ==3.0.1.1,
any.network-uri ==2.6.2.0, any.network-uri ==2.6.3.0,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.openssl-streams ==1.2.2.0, any.openssl-streams ==1.2.2.0,
any.optics ==0.2, any.optics ==0.2,
any.optics-core ==0.2, any.optics-core ==0.2,
any.optics-extra ==0.2, any.optics-extra ==0.2,
any.optics-th ==0.2, any.optics-th ==0.2,
any.optics-vl ==0.2,
any.optparse-applicative ==0.15.1.0,
any.parsec ==3.1.13.0, any.parsec ==3.1.13.0,
any.parser-combinators ==1.2.1, any.parser-combinators ==1.2.1,
parser-combinators -dev, parser-combinators -dev,
any.pretty ==1.1.3.6, any.pretty ==1.1.3.6,
any.pretty-terminal ==0.1.0.0,
any.prettyprinter ==1.6.1, any.prettyprinter ==1.6.1,
prettyprinter -buildreadme, prettyprinter -buildreadme,
any.primitive ==0.7.0.0, any.primitive ==0.7.0.1,
any.primitive-extras ==0.8, any.primitive-extras ==0.8,
any.primitive-unlifted ==0.1.3.0, any.primitive-unlifted ==0.1.3.0,
any.process ==1.6.5.0, any.process ==1.6.5.0,
any.profunctors ==5.5.2, any.profunctors ==5.5.2,
any.quickcheck-io ==0.2.0,
any.random ==1.1, any.random ==1.1,
any.recursion-schemes ==5.1.3,
recursion-schemes +template-haskell,
any.resourcet ==1.2.3,
any.rts ==1.0, any.rts ==1.0,
any.safe ==0.3.18,
any.safe-exceptions ==0.1.7.0, any.safe-exceptions ==0.1.7.0,
any.scientific ==0.3.6.2, any.scientific ==0.3.6.2,
scientific -bytestring-builder -integer-simple, scientific -bytestring-builder -integer-simple,
@ -138,26 +157,41 @@ constraints: any.Cabal ==2.4.0.1,
semigroupoids +comonad +containers +contravariant +distributive +doctests +tagged +unordered-containers, semigroupoids +comonad +containers +contravariant +distributive +doctests +tagged +unordered-containers,
any.semigroups ==0.19.1, any.semigroups ==0.19.1,
semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers,
any.setenv ==0.1.1.3,
any.sop-core ==0.5.0.0, any.sop-core ==0.5.0.0,
any.splitmix ==0.0.3, any.split ==0.2.3.4,
any.splitmix ==0.0.4,
splitmix -optimised-mixer +random, splitmix -optimised-mixer +random,
any.stm ==2.5.0.0, any.stm ==2.5.0.0,
any.stm-chans ==3.0.0.4,
any.streaming-commons ==0.2.1.2,
streaming-commons -use-bytestring-builder,
any.streamly ==0.7.1,
streamly -debug -dev -examples -examples-sdl -fusion-plugin -has-llvm -inspection -no-charts -no-fusion -streamk, streamly -debug -dev -examples -examples-sdl -fusion-plugin -has-llvm -inspection -no-charts -no-fusion -streamk,
any.streamly-bytestring ==0.1.2, any.streamly-bytestring ==0.1.2,
any.streamly-posix ==0.1.0.0,
any.strict-base ==0.4.0.0, any.strict-base ==0.4.0.0,
any.string-interpolate ==0.2.0.0,
any.syb ==0.7.1, any.syb ==0.7.1,
any.table-layout ==0.8.0.5,
any.tagged ==0.8.6, any.tagged ==0.8.6,
tagged +deepseq +transformers, tagged +deepseq +transformers,
any.tar-bytestring ==0.6.2.0, any.tar-bytestring ==0.6.3.0,
any.template-haskell ==2.14.0.0, any.template-haskell ==2.14.0.0,
any.terminfo ==0.4.1.2, any.terminal-progress-bar ==0.4.1,
any.terminal-size ==0.3.2.1,
any.text ==1.2.3.1, any.text ==1.2.3.1,
any.text-conversions ==0.3.0,
any.text-icu ==0.7.0.1, any.text-icu ==0.7.0.1,
any.text-short ==0.1.3, any.text-short ==0.1.3,
text-short -asserts, text-short -asserts,
any.tf-random ==0.5,
any.th-abstraction ==0.3.2.0, any.th-abstraction ==0.3.2.0,
any.th-expand-syns ==0.4.5.0,
any.th-lift ==0.8.1,
any.th-lift-instances ==0.1.14,
any.th-orphans ==0.13.9,
any.th-reify-many ==0.1.9,
any.these ==1.0.1,
these +aeson +assoc +quickcheck +semigroupoids,
any.time ==1.8.0.2, any.time ==1.8.0.2,
any.time-compat ==1.9.2.2, any.time-compat ==1.9.2.2,
time-compat -old-locale, time-compat -old-locale,
@ -169,14 +203,20 @@ constraints: any.Cabal ==2.4.0.1,
any.typed-process ==0.2.6.0, any.typed-process ==0.2.6.0,
any.unix ==2.7.2.2, any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.3, any.unix-bytestring ==0.3.7.3,
any.unliftio-core ==0.1.2.0, any.unix-compat ==0.5.2,
unix-compat -old-time,
any.unix-time ==0.4.7,
any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.10.0, any.unordered-containers ==0.2.10.0,
unordered-containers -debug, unordered-containers -debug,
any.url ==2.1.3, any.uri-bytestring ==0.3.2.2,
uri-bytestring -lib-werror,
any.utf8-string ==1.0.1.1, any.utf8-string ==1.0.1.1,
any.uuid-types ==1.0.3, any.uuid-types ==1.0.3,
any.vector ==0.12.1.2, any.vector ==0.12.1.2,
vector +boundschecks -internalchecks -unsafechecks -wall, vector +boundschecks -internalchecks -unsafechecks -wall,
any.vector-algorithms ==0.8.0.3,
vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
any.vector-builder ==0.3.8, any.vector-builder ==0.3.8,
any.vector-th-unbox ==0.2.1.7, any.vector-th-unbox ==0.2.1.7,
any.versions ==3.5.3, any.versions ==3.5.3,

12
ghcup.cabal
View File

@ -27,6 +27,7 @@ common ascii-string { build-depends: ascii-string >= 1.0 }
common async { build-depends: async >= 0.8 } common async { build-depends: async >= 0.8 }
common attoparsec { build-depends: attoparsec >= 0.13 } common attoparsec { build-depends: attoparsec >= 0.13 }
common base { build-depends: base >= 4.12 && < 5 } common base { build-depends: base >= 4.12 && < 5 }
common binary { build-depends: binary >= 0.8.6.0 }
common bytestring { build-depends: bytestring >= 0.10 } common bytestring { build-depends: bytestring >= 0.10 }
common bzlib { build-depends: bzlib >= 0.5.0.5 } common bzlib { build-depends: bzlib >= 0.5.0.5 }
common containers { build-depends: containers >= 0.6 } common containers { build-depends: containers >= 0.6 }
@ -53,13 +54,14 @@ common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 }
common resourcet { build-depends: resourcet >= 1.2.2 } common resourcet { build-depends: resourcet >= 1.2.2 }
common safe { build-depends: safe >= 0.3.18 } common safe { build-depends: safe >= 0.3.18 }
common safe-exceptions { build-depends: safe-exceptions >= 0.1 } common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
common streamly { build-depends: streamly >= 0.7 } common streamly { build-depends: streamly >= 0.7.1 }
common streamly-posix { build-depends: streamly-posix >= 0.1.0.0 } common streamly-posix { build-depends: streamly-posix >= 0.1.0.0 }
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 } common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
common strict-base { build-depends: strict-base >= 0.4 } common strict-base { build-depends: strict-base >= 0.4 }
common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 } common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
common table-layout { build-depends: table-layout >= 0.8 } common table-layout { build-depends: table-layout >= 0.8 }
common tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 } common tar-bytestring { build-depends: tar-bytestring >= 0.6.3.0 }
common terminal-progress-bar { build-depends: terminal-progress-bar >= 0.4.1 }
common template-haskell { build-depends: template-haskell >= 2.7 } common template-haskell { build-depends: template-haskell >= 2.7 }
common text { build-depends: text >= 1.2 } common text { build-depends: text >= 1.2 }
common text-icu { build-depends: text-icu >= 0.7 } common text-icu { build-depends: text-icu >= 0.7 }
@ -96,6 +98,7 @@ library
, ascii-string , ascii-string
, async , async
, attoparsec , attoparsec
, binary
, bytestring , bytestring
, bzlib , bzlib
, containers , containers
@ -128,6 +131,7 @@ library
, string-interpolate , string-interpolate
, tar-bytestring , tar-bytestring
, template-haskell , template-haskell
, terminal-progress-bar
, text , text
, text-icu , text-icu
, transformers , transformers
@ -211,9 +215,7 @@ executable ghcup-gen
, uri-bytestring , uri-bytestring
, utf8-string , utf8-string
main-is: Main.hs main-is: Main.hs
other-modules: BinaryDownloads other-modules: GHCupDownloads
GHCupDownloads
SourceDownloads
Validate Validate
-- other-extensions: -- other-extensions:
build-depends: ghcup build-depends: ghcup

569
lib/GHCup.hs
View File

@ -23,6 +23,7 @@ import GHCup.Utils.File
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ import GHCup.Utils.Version.QQ
import GHCup.Version
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
@ -34,7 +35,6 @@ import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Foldable
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.String.Interpolate import Data.String.Interpolate
@ -50,7 +50,6 @@ import Prelude hiding ( abs
, writeFile , writeFile
) )
import System.IO.Error import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment )
import System.Posix.FilePath ( getSearchPath ) import System.Posix.FilePath ( getSearchPath )
import System.Posix.RawFilePath.Directory.Errors import System.Posix.RawFilePath.Directory.Errors
( hideError ) ( hideError )
@ -65,55 +64,116 @@ import qualified Data.Text.Encoding as E
--[ Tool installation ]-- --[ Tool installation ]--
------------------------- -------------------------
-- TODO: custom logger intepreter and pretty printing
-- | Install a tool, such as GHC or cabal. This also sets
-- the ghc-x.y.z symlinks and potentially the ghc-x.y.
--
-- 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
, MonadCatch m
, MonadIO m
, MonadFail m
, MonadResource m
) -- tmp file
=> BinaryDownloads
-> ToolRequest
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts
'[ AlreadyInstalled
, ArchiveError
, DistroNotFound
, FileDoesNotExistError
, FileError
, JSONError
, NoCompatibleArch
, NoDownload
, NotInstalled
, PlatformResultError
, ProcessError
, URLException
, DigestError
]
m
()
installTool bDls treq mpfReq = do
lift $ $(logDebug) [i|Requested to install: #{treq}|]
-- stop if GHC is already installed, other tools can be overwritten
case treq of
(ToolRequest GHC _) ->
whenM (liftIO $ toolAlreadyInstalled treq)
$ (throwE $ AlreadyInstalled treq)
(ToolRequest Cabal _) -> pure ()
installGHCBin :: ( MonadFail m
, MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
)
=> GHCupDownloads
-> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, UnknownArchive
]
m
()
installGHCBin bDls ver mpfReq = do
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (liftIO $ toolAlreadyInstalled GHC ver)
$ (throwE $ AlreadyInstalled GHC ver)
Settings {..} <- lift ask Settings {..} <- lift ask
-- download (or use cached version) -- download (or use cached version)
dlinfo <- liftE $ getDownloadInfo bDls treq mpfReq dlinfo <- liftE $ getDownloadInfo bDls GHC ver mpfReq
dl <- liftE $ downloadCached dlinfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
-- prepare paths
ghcdir <- liftIO $ ghcupGHCDir ver
-- the subdir of the archive where we do the work
let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
catchAllE
(\es ->
liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
>> throwE (BuildFailed archiveSubdir es)
)
$ installGHC' archiveSubdir ghcdir
-- only clean up dir if the build succeeded
liftIO $ deleteDirRecursive tmpUnpack
liftE $ postGHCInstall ver
where
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
installGHC' :: (MonadLogger m, MonadIO m)
=> 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
lift $ $(logInfo) [s|Installing GHC (this may take a while)|]
lEM $ liftIO $ execLogged [s|./configure|]
False
[[s|--prefix=|] <> toFilePath inst]
([rel|ghc-configure.log|] :: Path Rel)
(Just path)
Nothing
lEM $ liftIO $ execLogged [s|make|]
True
[[s|install|]]
([rel|ghc-make.log|] :: Path Rel)
(Just path)
Nothing
pure ()
installCabalBin :: ( MonadMask m
, MonadCatch m
, MonadReader Settings m
, MonadLogger m
, MonadResource m
, MonadIO m
)
=> GHCupDownloads
-> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts
'[ CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, UnknownArchive
]
m
()
installCabalBin bDls ver mpfReq = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
Settings {..} <- lift ask
-- download (or use cached version)
dlinfo <- liftE $ getDownloadInfo bDls Cabal ver mpfReq
dl <- liftE $ downloadCached dlinfo Nothing dl <- liftE $ downloadCached dlinfo Nothing
-- unpack -- unpack
@ -121,62 +181,28 @@ installTool bDls treq mpfReq = do
liftE $ unpackToDir tmpUnpack dl liftE $ unpackToDir tmpUnpack dl
-- prepare paths -- prepare paths
ghcdir <- liftIO $ ghcupGHCDir (view trVersion $ treq)
bindir <- liftIO ghcupBinDir bindir <- liftIO ghcupBinDir
-- the subdir of the archive where we do the work -- the subdir of the archive where we do the work
let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo) let archiveSubdir = maybe tmpUnpack (tmpUnpack </>) (view dlSubdir dlinfo)
case treq of liftE $ installCabal' archiveSubdir bindir
(ToolRequest GHC ver) -> do
liftE $ installGHC archiveSubdir ghcdir
liftE $ postGHCInstall ver
(ToolRequest Cabal _) -> liftE $ installCabal archiveSubdir bindir
pure () pure ()
where
toolAlreadyInstalled :: ToolRequest -> IO Bool -- | Install an unpacked cabal distribution.
toolAlreadyInstalled ToolRequest {..} = case _trTool of installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
GHC -> ghcInstalled _trVersion => Path Abs -- ^ Path to the unpacked cabal bindist (where the executable resides)
Cabal -> cabalInstalled _trVersion -> Path Abs -- ^ Path to install to
-> Excepts '[CopyError] m ()
installCabal' path inst = do
lift $ $(logInfo) [s|Installing cabal|]
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else. let cabalFile = [rel|cabal|] :: Path Rel
installGHC :: (MonadLogger m, MonadIO m) liftIO $ createDirIfMissing newDirPerms inst
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides) handleIO (throwE . CopyError . show) $ liftIO $ copyFile
-> Path Abs -- ^ Path to install to (path </> cabalFile)
-> Excepts '[ProcessError] m () (inst </> cabalFile)
installGHC path inst = do Overwrite
lift $ $(logInfo) [s|Installing GHC (this may take a while)|]
lEM $ liftIO $ execLogged [s|./configure|]
False
[[s|--prefix=|] <> toFilePath inst]
([rel|ghc-configure.log|] :: Path Rel)
(Just path)
Nothing
lEM $ liftIO $ execLogged [s|make|]
True
[[s|install|]]
([rel|ghc-make.log|] :: Path Rel)
(Just path)
Nothing
pure ()
-- | Install an unpacked cabal distribution.
installCabal :: (MonadLogger m, MonadCatch m, MonadIO m)
=> 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
liftIO $ createDirIfMissing newDirPerms inst
handleIO (throwE . CopyError . show) $ liftIO $ copyFile
(path </> cabalFile)
(inst </> cabalFile)
Overwrite
@ -195,7 +221,7 @@ installCabal path inst = do
-- --
-- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink -- Additionally creates a ~/.ghcup/share -> ~/.ghcup/ghc/<ver>/share symlink
-- for `SetGHCOnly` constructor. -- for `SetGHCOnly` constructor.
setGHC :: (MonadThrow m, MonadFail m, MonadIO m) setGHC :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version => Version
-> SetGHC -> SetGHC
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
@ -207,7 +233,12 @@ setGHC ver sghc = do
bindir <- liftIO $ ghcupBinDir bindir <- liftIO $ ghcupBinDir
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms bindir
when (sghc == SetGHCOnly) $ liftE (delOldSymlinks bindir) -- first delete the old symlinks (this fixes compatibility issues
-- with old ghcup)
case sghc of
SetGHCOnly -> liftE $ rmPlain ver
SetGHCMajor -> lift $ rmMajorSymlinks ver
SetGHCMinor -> lift $ rmMinorSymlinks ver
-- for ghc tools (ghc, ghci, haddock, ...) -- for ghc tools (ghc, ghci, haddock, ...)
verfiles <- ghcToolFiles ver verfiles <- ghcToolFiles ver
@ -221,45 +252,39 @@ setGHC ver sghc = do
<$> getGHCMajor ver <$> getGHCMajor ver
parseRel (toFilePath file <> B.singleton _hyphen <> major') parseRel (toFilePath file <> B.singleton _hyphen <> major')
SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS) SetGHCMinor -> parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
liftIO $ hideError doesNotExistErrorType $ deleteFile
(bindir </> targetFile) -- create symlink
liftIO $ createSymlink (bindir </> targetFile) let fullF = bindir </> targetFile
(ghcLinkDestination (toFilePath file) ver) let destL = ghcLinkDestination (toFilePath file) ver
lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
liftIO $ createSymlink fullF destL
-- create symlink for share dir -- create symlink for share dir
liftIO $ symlinkShareDir ghcdir verBS lift $ symlinkShareDir ghcdir verBS
pure () pure ()
where where
symlinkShareDir :: Path Abs -> ByteString -> IO () symlinkShareDir :: (MonadIO m, MonadLogger m)
=> Path Abs
-> ByteString
-> m ()
symlinkShareDir ghcdir verBS = do symlinkShareDir ghcdir verBS = do
destdir <- ghcupBaseDir destdir <- liftIO $ ghcupBaseDir
case sghc of case sghc of
SetGHCOnly -> do SetGHCOnly -> do
let sharedir = [rel|share|] :: Path Rel let sharedir = [rel|share|] :: Path Rel
let fullsharedir = ghcdir </> sharedir let fullsharedir = ghcdir </> sharedir
whenM (doesDirectoryExist fullsharedir) $ do whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
liftIO $ hideError doesNotExistErrorType $ deleteFile let fullF = destdir </> sharedir
(destdir </> sharedir) let targetF = [s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir
createSymlink $(logDebug) [i|rm -f #{fullF}|]
(destdir </> sharedir) liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
([s|./ghc/|] <> verBS <> [s|/|] <> toFilePath sharedir) $(logDebug) [i|ln -s #{targetF} #{fullF}|]
liftIO $ createSymlink fullF targetF
_ -> pure () _ -> pure ()
-- The old tool symlinks might be different (e.g. more) than the
-- requested version. Have to avoid "stray" symlinks.
delOldSymlinks :: forall m
. (MonadThrow m, MonadFail m, MonadIO m)
=> Path Abs
-> Excepts '[] m ()
delOldSymlinks bindir = catchLiftLeft (\NotInstalled{} -> pure ()) $ do
mv <- ghcSet
for_ mv $ \ver' -> do
verfiles <- ghcToolFiles ver'
for_ verfiles $ \f -> liftIO $ deleteFile (bindir </> f)
@ -278,17 +303,18 @@ data ListResult = ListResult
, lTag :: [Tag] , lTag :: [Tag]
, lInstalled :: Bool , lInstalled :: Bool
, lSet :: Bool , lSet :: Bool
, fromSrc :: Bool
} }
deriving Show deriving Show
availableToolVersions :: BinaryDownloads -> Tool -> [(Version, [Tag])] availableToolVersions :: GHCupDownloads -> Tool -> [(Version, [Tag])]
availableToolVersions av tool = toListOf availableToolVersions av tool = toListOf
(ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded) (ix tool % to (fmap (\(v, vi) -> (v, (_viTags vi))) . Map.toList) % folded)
av av
listVersions :: BinaryDownloads listVersions :: GHCupDownloads
-> Maybe Tool -> Maybe Tool
-> Maybe ListCriteria -> Maybe ListCriteria
-> IO [ListResult] -> IO [ListResult]
@ -298,7 +324,8 @@ listVersions av lt criteria = case lt of
Nothing -> do Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria ghcvers <- listVersions av (Just GHC) criteria
cabalvers <- listVersions av (Just Cabal) criteria cabalvers <- listVersions av (Just Cabal) criteria
pure (ghcvers <> cabalvers) ghcupvers <- listVersions av (Just GHCup) criteria
pure (ghcvers <> cabalvers <> ghcupvers)
where where
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
@ -306,11 +333,17 @@ listVersions av lt criteria = case lt of
GHC -> do GHC -> do
lSet <- fmap (maybe False (== v)) $ ghcSet lSet <- fmap (maybe False (== v)) $ ghcSet
lInstalled <- ghcInstalled v lInstalled <- ghcInstalled v
fromSrc <- ghcSrcInstalled v
pure ListResult { lVer = v, lTag = tags, lTool = t, .. } pure ListResult { lVer = v, lTag = tags, lTool = t, .. }
Cabal -> do Cabal -> do
lSet <- fmap (== v) $ cabalSet lSet <- fmap (== v) $ cabalSet
lInstalled <- cabalInstalled v lInstalled <- cabalInstalled v
pure ListResult { lVer = v, lTag = tags, lTool = t, .. } pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
GHCup -> do
let lSet = prettyPVP ghcUpVer == prettyVer v
let lInstalled = True
pure ListResult { lVer = v, lTag = tags, lTool = t, fromSrc = False, .. }
filter' :: [ListResult] -> [ListResult] filter' :: [ListResult] -> [ListResult]
filter' lr = case criteria of filter' lr = case criteria of
@ -320,8 +353,6 @@ listVersions av lt criteria = case lt of
-------------- --------------
--[ GHC rm ]-- --[ GHC rm ]--
-------------- --------------
@ -335,9 +366,8 @@ rmGHCVer ver = do
isSetGHC <- fmap (maybe False (== ver)) $ ghcSet isSetGHC <- fmap (maybe False (== ver)) $ ghcSet
dir <- liftIO $ ghcupGHCDir ver dir <- liftIO $ ghcupGHCDir ver
let d' = toFilePath dir let d' = toFilePath dir
exists <- liftIO $ doesDirectoryExist dir exists <- liftIO $ doesDirectoryExist dir
toolsFiles <- liftE $ ghcToolFiles ver
if exists if exists
then do then do
@ -346,59 +376,27 @@ rmGHCVer ver = do
liftIO $ deleteDirRecursive dir liftIO $ deleteDirRecursive dir
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|] lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
liftIO $ rmMinorSymlinks lift $ rmMinorSymlinks ver
lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|] lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
liftE fixMajorSymlinks -- first remove
lift $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version)
(mj, mi) <- getGHCMajor ver
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
when isSetGHC $ liftE $ do
when isSetGHC $ do
lift $ $(logInfo) [i|Removing ghc symlinks|] lift $ $(logInfo) [i|Removing ghc symlinks|]
rmPlain toolsFiles liftE $ rmPlain ver
liftIO liftIO
$ ghcupBaseDir $ ghcupBaseDir
>>= hideError doesNotExistErrorType >>= hideError doesNotExistErrorType
. deleteFile . deleteFile
. (</> ([rel|share|] :: Path Rel)) . (</> ([rel|share|] :: Path Rel))
else throwE (NotInstalled $ ToolRequest GHC ver) else throwE (NotInstalled GHC ver)
where
-- e.g. ghc-8.6.5
rmMinorSymlinks :: IO ()
rmMinorSymlinks = do
bindir <- ghcupBinDir
files <- getDirsFiles' bindir
let myfiles = filter
(\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x)
files
forM_ myfiles $ \f -> deleteFile (bindir </> f)
-- E.g. ghc, if this version is the set one.
-- This reads `ghcupGHCDir`.
rmPlain :: (MonadThrow m, MonadFail m, MonadIO m)
=> [Path Rel] -- ^ tools files
-> Excepts '[NotInstalled] m ()
rmPlain files = do
bindir <- liftIO $ ghcupBinDir
forM_ files $ \f -> liftIO $ deleteFile (bindir </> f)
-- e.g. ghc-8.6
fixMajorSymlinks :: (MonadFail m, MonadThrow m, MonadIO m)
=> Excepts '[NotInstalled] m ()
fixMajorSymlinks = do
(mj, mi) <- getGHCMajor ver
let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
bindir <- liftIO $ ghcupBinDir
-- first delete them
files <- liftIO $ getDirsFiles' bindir
let myfiles =
filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
forM_ myfiles $ \f -> liftIO $ deleteFile (bindir </> f)
-- then fix them (e.g. with an earlier version)
getGHCForMajor mj mi >>= mapM_ (\v -> liftE $ setGHC v SetGHCMajor)
@ -409,7 +407,7 @@ rmGHCVer ver = do
getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m) getDebugInfo :: (MonadLogger m, MonadCatch m, MonadReader Settings m, MonadIO m)
=> Excepts => Excepts
'[PlatformResultError , NoCompatibleArch , DistroNotFound] '[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
m m
DebugInfo DebugInfo
getDebugInfo = do getDebugInfo = do
@ -430,38 +428,37 @@ getDebugInfo = do
--------------- ---------------
compileGHC :: ( MonadReader Settings m compileGHC :: ( MonadMask m
, MonadReader Settings m
, MonadThrow m , MonadThrow m
, MonadResource m , MonadResource m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
) )
=> SourceDownloads => GHCupDownloads
-> Version -- ^ version to install -> Version -- ^ version to install
-> Version -- ^ version to bootstrap with -> Version -- ^ version to bootstrap with
-> Maybe Int -- ^ jobs -> Maybe Int -- ^ jobs
-> Maybe (Path Abs) -- ^ build config -> Maybe (Path Abs) -- ^ build config
-> Excepts -> Excepts
'[ AlreadyInstalled '[ AlreadyInstalled
, NotInstalled , BuildFailed
, GHCNotFound
, ArchiveError
, ProcessError
, URLException
, DigestError , DigestError
, BuildConfigNotFound , DownloadFailed
, GHCupSetError
, NoDownload
, UnknownArchive
] ]
m m
() ()
compileGHC dls tver bver jobs mbuildConfig = do compileGHC dls tver bver jobs mbuildConfig = do
let treq = ToolRequest GHC tver
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|] lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bver}|]
alreadyInstalled <- liftIO $ toolAlreadyInstalled treq whenM (liftIO $ toolAlreadyInstalled GHC tver)
when alreadyInstalled $ (throwE $ AlreadyInstalled treq) (throwE $ AlreadyInstalled GHC tver)
-- download source tarball -- download source tarball
dlInfo <- preview (ix tver) dls ?? GHCNotFound dlInfo <- preview (ix GHC % ix tver % viSourceDL % _Just) dls ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing dl <- liftE $ downloadCached dlInfo Nothing
-- unpack -- unpack
@ -470,43 +467,20 @@ compileGHC dls tver bver jobs mbuildConfig = do
bghc <- parseRel ([s|ghc-|] <> verToBS bver) bghc <- parseRel ([s|ghc-|] <> verToBS bver)
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
ghcdir <- liftIO $ ghcupGHCDir tver ghcdir <- liftIO $ ghcupGHCDir tver
if
| tver >= [vver|8.8.0|] -> do
cEnv <- liftIO $ getEnvironment
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
bghcPath <- (liftIO $ searchPath spaths bghc) !? GHCNotFound
let newEnv = ([s|GHC|], toFilePath bghcPath) : cEnv
lEM $ liftIO $ exec [s|./configure|]
False
[[s|--prefix=|] <> toFilePath ghcdir]
(Just workdir)
(Just newEnv)
| otherwise -> do
lEM $ liftIO $ exec
[s|./configure|]
False
[ [s|--prefix=|] <> toFilePath ghcdir
, [s|--with-ghc=|] <> toFilePath bghc
]
(Just workdir)
Nothing
let build_mk = workdir </> ([rel|mk/build.mk|] :: Path Rel) catchAllE
case mbuildConfig of (\es ->
Just bc -> liftIO $ copyFile bc build_mk Overwrite liftIO (hideError doesNotExistErrorType $ deleteDirRecursive ghcdir)
Nothing -> liftIO $ writeFile build_mk (Just newFilePerms) defaultConf >> throwE (BuildFailed workdir es)
)
$ compile bghc ghcdir workdir
markSrcBuilt ghcdir workdir
lEM $ liftIO $ exec [s|make|] -- only clean up dir if the build succeeded
True liftIO $ deleteDirRecursive tmpUnpack
(maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
(Just workdir)
Nothing
lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just workdir) Nothing reThrowAll GHCupSetError $ postGHCInstall tver
liftE $ postGHCInstall tver
pure () pure ()
where where
@ -518,28 +492,160 @@ BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = YES HADDOCK_DOCS = YES
GhcWithLlvmCodeGen = YES|] GhcWithLlvmCodeGen = YES|]
compile :: (MonadCatch m, MonadLogger m, MonadIO m)
=> Path Rel
-> Path Abs
-> Path Abs
-> Excepts
'[NoDownload , FileDoesNotExistError , ProcessError]
m
()
compile bghc ghcdir workdir = do
lift $ $(logInfo) [i|configuring build|]
if
| tver >= [vver|8.8.0|] -> do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
bghcPath <- (liftIO $ searchPath spaths bghc) !? NoDownload
newEnv <- addToCurrentEnv [([s|GHC|], toFilePath bghcPath)]
lEM $ liftIO $ execLogged [s|./configure|]
False
[[s|--prefix=|] <> toFilePath ghcdir]
([rel|ghc-configure.log|] :: Path Rel)
(Just workdir)
(Just newEnv)
| otherwise -> do
lEM $ liftIO $ execLogged
[s|./configure|]
False
[ [s|--prefix=|] <> toFilePath ghcdir
, [s|--with-ghc=|] <> toFilePath bghc
]
([rel|ghc-configure.log|] :: Path Rel)
(Just workdir)
Nothing
case mbuildConfig of
Just bc -> liftIOException
doesNotExistErrorType
(FileDoesNotExistError $ toFilePath bc)
(liftIO $ copyFile bc (build_mk workdir) Overwrite)
Nothing ->
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
lift
$ $(logInfo)
[i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/ghc-make.log' to see the progress.|]
lEM $ liftIO $ execLogged [s|make|]
True
(maybe [] (\j -> [[s|-j|] <> fS (show j)]) jobs)
([rel|ghc-make.log|] :: Path Rel)
(Just workdir)
Nothing
lift $ $(logInfo) [i|Installing...|]
lEM $ liftIO $ execLogged [s|make|]
True
[[s|install|]]
([rel|ghc-make.log|] :: Path Rel)
(Just workdir)
Nothing
markSrcBuilt ghcdir workdir = do
let dest = (ghcdir </> ghcUpSrcBuiltFile)
liftIO $ copyFile (build_mk workdir) dest Overwrite
build_mk workdir = workdir </> ([rel|mk/build.mk|] :: Path Rel)
--------------- compileCabal :: ( MonadReader Settings m
--[ Set GHC ]-- , MonadResource m
--------------- , MonadMask m
, MonadLogger m
, MonadIO m
)
=> GHCupDownloads
-> Version -- ^ version to install
-> Version -- ^ GHC version to build with
-> Maybe Int
-> Excepts
'[ BuildFailed
, DigestError
, DownloadFailed
, NoDownload
, UnknownArchive
]
m
()
compileCabal dls tver bver jobs = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bver}|]
-- download source tarball
dlInfo <- preview (ix Cabal % ix tver % viSourceDL % _Just) dls ?? NoDownload
dl <- liftE $ downloadCached dlInfo Nothing
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
reThrowAll (BuildFailed workdir) $ compile workdir
-- only clean up dir if the build succeeded
liftIO $ deleteDirRecursive tmpUnpack
pure ()
where
compile :: (MonadLogger m, MonadIO m)
=> Path Abs
-> Excepts '[ProcessError] m ()
compile workdir = do
lift
$ $(logInfo)
[i|Building (this may take a while)... Run 'tail -f ~/.ghcup/logs/cabal-bootstrap.log' to see the progress.|]
let v' = verToBS bver
cabal_bin <- liftIO $ ghcupBinDir
newEnv <- lift $ addToCurrentEnv
[ ([s|GHC|] , [s|ghc-|] <> v')
, ([s|GHC_PKG|], [s|ghc-pkg-|] <> v')
, ([s|GHC_VER|], v')
, ([s|PREFIX|] , toFilePath cabal_bin)
]
lEM $ liftIO $ execLogged [s|./bootstrap.sh|]
False
(maybe [] (\j -> [[s|-j|], fS (show j)]) jobs)
([rel|cabal-bootstrap.log|] :: Path Rel)
(Just workdir)
(Just newEnv)
upgradeGHCup :: ( MonadReader Settings m
---------------------
--[ Upgrade GHCup ]--
---------------------
upgradeGHCup :: ( MonadMask m
, MonadReader Settings m
, MonadCatch m , MonadCatch m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
) )
=> BinaryDownloads => GHCupDownloads
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into -> Maybe (Path Abs) -- ^ full file destination to write ghcup into
-> Excepts -> Excepts
'[ DigestError '[ CopyError
, URLException , DigestError
, DistroNotFound , DistroNotFound
, PlatformResultError , DownloadFailed
, NoCompatibleArch , NoCompatibleArch
, NoCompatiblePlatform
, NoDownload , NoDownload
] ]
m m
@ -547,14 +653,16 @@ upgradeGHCup :: ( MonadReader Settings m
upgradeGHCup dls mtarget = do upgradeGHCup dls mtarget = do
lift $ $(logInfo) [i|Upgrading GHCup...|] lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = head $ getTagged dls GHCup Latest let latestVer = head $ getTagged dls GHCup Latest
dli <- liftE $ getDownloadInfo dls (ToolRequest GHCup latestVer) Nothing dli <- liftE $ getDownloadInfo dls GHCup latestVer Nothing
tmp <- lift withGHCupTmpDir tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|] :: Path Rel let fn = [rel|ghcup|] :: Path Rel
p <- liftE $ download dli tmp (Just fn) p <- liftE $ download dli tmp (Just fn)
case mtarget of case mtarget of
Nothing -> do Nothing -> do
dest <- liftIO $ ghcupBinDir dest <- liftIO $ ghcupBinDir
liftIO $ copyFile p (dest </> fn) Overwrite handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
(dest </> fn)
Overwrite
Just fullDest -> liftIO $ copyFile p fullDest Overwrite Just fullDest -> liftIO $ copyFile p fullDest Overwrite
pure latestVer pure latestVer
@ -565,8 +673,9 @@ upgradeGHCup dls mtarget = do
------------- -------------
-- | Creates ghc-x.y.z and ghc-x.y symlinks. -- | Creates ghc-x.y.z and ghc-x.y symlinks. This is used for
postGHCInstall :: (MonadThrow m, MonadFail m, MonadIO m) -- both installing from source and bindist.
postGHCInstall :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version => Version
-> Excepts '[NotInstalled] m () -> Excepts '[NotInstalled] m ()
postGHCInstall ver = do postGHCInstall ver = do

242
lib/GHCup/Download.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
module GHCup.Download where module GHCup.Download where
@ -33,6 +34,7 @@ import Data.ByteString.Builder
import Data.IORef import Data.IORef
import Data.Maybe import Data.Maybe
import Data.String.Interpolate import Data.String.Interpolate
import Data.Text.Read
import Data.Versions import Data.Versions
import GHC.IO.Exception import GHC.IO.Exception
import HPath import HPath
@ -52,9 +54,12 @@ import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite ) ( fdWrite )
import System.Posix.RawFilePath.Directory.Errors import System.Posix.RawFilePath.Directory.Errors
( hideError ) ( hideError )
import System.ProgressBar
import URI.ByteString import URI.ByteString
import URI.ByteString.QQ import URI.ByteString.QQ
import qualified Data.Binary.Builder as B
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding as E
import qualified System.IO.Streams as Streams import qualified System.IO.Streams as Streams
@ -69,6 +74,11 @@ ghcupURL =
------------------
--[ High-level ]--
------------------
-- | Downloads the download information! -- | Downloads the download information!
getDownloads :: ( FromJSONKey Tool getDownloads :: ( FromJSONKey Tool
, FromJSONKey Version , FromJSONKey Version
@ -78,19 +88,16 @@ getDownloads :: ( FromJSONKey Tool
, MonadReader Settings m , MonadReader Settings m
, MonadLogger m , MonadLogger m
) )
=> Excepts => Excepts '[JSONError , DownloadFailed] m GHCupDownloads
'[FileDoesNotExistError , URLException , JSONError]
m
GHCupDownloads
getDownloads = do getDownloads = do
urlSource <- lift getUrlSource urlSource <- lift getUrlSource
lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|] lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
case urlSource of case urlSource of
GHCupURL -> do GHCupURL -> do
bs <- liftE $ downloadBS ghcupURL bs <- reThrowAll DownloadFailed $ downloadBS ghcupURL
lE' JSONDecodeError $ eitherDecode' bs lE' JSONDecodeError $ eitherDecode' bs
(OwnSource url) -> do (OwnSource url) -> do
bs <- liftE $ downloadBS url bs <- reThrowAll DownloadFailed $ downloadBS url
lE' JSONDecodeError $ eitherDecode' bs lE' JSONDecodeError $ eitherDecode' bs
(OwnSpec av) -> pure $ av (OwnSpec av) -> pure $ av
@ -101,18 +108,19 @@ getDownloadInfo :: ( MonadLogger m
, MonadIO m , MonadIO m
, MonadReader Settings m , MonadReader Settings m
) )
=> BinaryDownloads => GHCupDownloads
-> ToolRequest -> Tool
-> Version
-> Maybe PlatformRequest -> Maybe PlatformRequest
-> Excepts -> Excepts
'[ DistroNotFound '[ DistroNotFound
, PlatformResultError , NoCompatiblePlatform
, NoCompatibleArch , NoCompatibleArch
, NoDownload , NoDownload
] ]
m m
DownloadInfo DownloadInfo
getDownloadInfo bDls (ToolRequest t v) mpfReq = do getDownloadInfo bDls t v mpfReq = do
(PlatformRequest arch' plat ver) <- case mpfReq of (PlatformRequest arch' plat ver) <- case mpfReq of
Just x -> pure x Just x -> pure x
Nothing -> do Nothing -> do
@ -132,7 +140,7 @@ getDownloadInfo' :: Tool
-- ^ user platform -- ^ user platform
-> Maybe Versioning -> Maybe Versioning
-- ^ optional version of the platform -- ^ optional version of the platform
-> BinaryDownloads -> GHCupDownloads
-> Either NoDownload DownloadInfo -> Either NoDownload DownloadInfo
getDownloadInfo' t v a p mv dls = maybe getDownloadInfo' t v a p mv dls = maybe
(Left NoDownload) (Left NoDownload)
@ -155,15 +163,21 @@ getDownloadInfo' t v a p mv dls = maybe
-- 2. otherwise create a random file -- 2. otherwise create a random file
-- --
-- The file must not exist. -- The file must not exist.
download :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m) download :: ( MonadMask m
, MonadReader Settings m
, MonadThrow m
, MonadLogger m
, MonadIO m
)
=> DownloadInfo => DownloadInfo
-> Path Abs -- ^ destination dir -> Path Abs -- ^ destination dir
-> Maybe (Path Rel) -- ^ optional filename -> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , URLException] m (Path Abs) -> Excepts '[DigestError , DownloadFailed] m (Path Abs)
download dli dest mfn | scheme == [s|https|] = dl True download dli dest mfn
| scheme == [s|http|] = dl False | scheme == [s|https|] = dl
| scheme == [s|file|] = cp | scheme == [s|http|] = dl
| otherwise = throwE UnsupportedURL | scheme == [s|file|] = cp
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
where where
scheme = view (dlUri % uriSchemeL' % schemeBSL') dli scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
@ -174,16 +188,12 @@ download dli dest mfn | scheme == [s|https|] = dl True
fromFile <- parseAbs path fromFile <- parseAbs path
liftIO $ copyFile fromFile destFile Strict liftIO $ copyFile fromFile destFile Strict
pure destFile pure destFile
dl https = do dl = do
let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli)) let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
lift $ $(logInfo) [i|downloading: #{uri'}|] lift $ $(logInfo) [i|downloading: #{uri'}|]
host <- (https, host, fullPath, port) <- reThrowAll DownloadFailed
preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli $ uriToQuadruple (view dlUri dli)
?? UnsupportedURL
let port = preview
(dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
dli
-- destination dir must exist -- destination dir must exist
liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
@ -192,11 +202,9 @@ download dli dest mfn | scheme == [s|https|] = dl True
-- download -- download
fd <- liftIO $ createRegularFileFd newFilePerms destFile fd <- liftIO $ createRegularFileFd newFilePerms destFile
let stepper = fdWrite fd let stepper = fdWrite fd
liftIO $ flip finally (closeFd fd) $ downloadInternal https flip finally (liftIO $ closeFd fd)
host $ reThrowAll DownloadFailed
path $ downloadInternal True https host fullPath port stepper
port
stepper
-- TODO: verify md5 during download -- TODO: verify md5 during download
liftE $ checkDigest dli destFile liftE $ checkDigest dli destFile
@ -211,7 +219,8 @@ download dli dest mfn | scheme == [s|https|] = dl True
-- | Download into tmpdir or use cached version, if it exists. If filename -- | Download into tmpdir or use cached version, if it exists. If filename
-- is omitted, infers the filename from the url. -- is omitted, infers the filename from the url.
downloadCached :: ( MonadResource m downloadCached :: ( MonadMask m
, MonadResource m
, MonadThrow m , MonadThrow m
, MonadLogger m , MonadLogger m
, MonadIO m , MonadIO m
@ -219,7 +228,7 @@ downloadCached :: ( MonadResource m
) )
=> DownloadInfo => DownloadInfo
-> Maybe (Path Rel) -- ^ optional filename -> Maybe (Path Rel) -- ^ optional filename
-> Excepts '[DigestError , URLException] m (Path Abs) -> Excepts '[DigestError , DownloadFailed] m (Path Abs)
downloadCached dli mfn = do downloadCached dli mfn = do
cache <- lift getCache cache <- lift getCache
case cache of case cache of
@ -238,11 +247,24 @@ downloadCached dli mfn = do
liftE $ download dli tmp mfn liftE $ download dli tmp mfn
------------------
--[ Low-level ]--
------------------
-- | This is used for downloading the JSON. -- | This is used for downloading the JSON.
downloadBS :: (MonadCatch m, MonadIO m) downloadBS :: (MonadCatch m, MonadIO m)
=> URI => URI
-> Excepts -> Excepts
'[FileDoesNotExistError , URLException] '[ FileDoesNotExistError
, HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
]
m m
L.ByteString L.ByteString
downloadBS uri' downloadBS uri'
@ -251,10 +273,10 @@ downloadBS uri'
| scheme == [s|http|] | scheme == [s|http|]
= dl False = dl False
| scheme == [s|file|] | scheme == [s|file|]
= liftException doesNotExistErrorType (FileDoesNotExistError path) = liftIOException doesNotExistErrorType (FileDoesNotExistError path)
$ (liftIO $ RD.readFile path :: MonadIO m => Excepts '[] m L.ByteString) $ (liftIO $ RD.readFile path)
| otherwise | otherwise
= throwE UnsupportedURL = throwE UnsupportedScheme
where where
scheme = view (uriSchemeL' % schemeBSL') uri' scheme = view (uriSchemeL' % schemeBSL') uri'
@ -262,55 +284,144 @@ downloadBS uri'
dl https = do dl https = do
host <- host <-
preview (authorityL' % _Just % authorityHostL' % hostBSL') uri' preview (authorityL' % _Just % authorityHostL' % hostBSL') uri'
?? UnsupportedURL ?? UnsupportedScheme
let port = preview let port = preview
(authorityL' % _Just % authorityPortL' % _Just % portNumberL') (authorityL' % _Just % authorityPortL' % _Just % portNumberL')
uri' uri'
liftIO $ downloadBS' https host path port liftE $ downloadBS' https host path port
-- | Load the result of this download into memory at once. -- | Load the result of this download into memory at once.
downloadBS' :: Bool -- ^ https? downloadBS' :: MonadIO m
=> Bool -- ^ https?
-> ByteString -- ^ host (e.g. "www.example.com") -> ByteString -- ^ host (e.g. "www.example.com")
-> ByteString -- ^ path (e.g. "/my/file") -> ByteString -- ^ path (e.g. "/my/file") including query
-> Maybe Int -- ^ optional port (e.g. 3000) -> Maybe Int -- ^ optional port (e.g. 3000)
-> IO (L.ByteString) -> Excepts
'[ HTTPStatusError
, URIParseError
, UnsupportedScheme
, NoLocationHeader
, TooManyRedirs
]
m
(L.ByteString)
downloadBS' https host path port = do downloadBS' https host path port = do
bref <- newIORef (mempty :: Builder) bref <- liftIO $ newIORef (mempty :: Builder)
let stepper bs = modifyIORef bref (<> byteString bs) let stepper bs = modifyIORef bref (<> byteString bs)
downloadInternal https host path port stepper downloadInternal False https host path port stepper
readIORef bref <&> toLazyByteString liftIO (readIORef bref <&> toLazyByteString)
downloadInternal :: Bool downloadInternal :: MonadIO m
-> ByteString => Bool -- ^ whether to show a progress bar
-> ByteString -> Bool -- ^ https?
-> Maybe Int -> ByteString -- ^ host
-> (ByteString -> IO a) -- ^ the consuming step function -> ByteString -- ^ path with query
-> IO () -> Maybe Int -- ^ optional port
downloadInternal https host path port consumer = do -> (ByteString -> IO a) -- ^ the consuming step function
c <- case https of -> Excepts
True -> do '[ HTTPStatusError
ctx <- baselineContextSSL , URIParseError
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port) , UnsupportedScheme
False -> openConnection host (fromIntegral $ fromMaybe 80 port) , NoLocationHeader
, TooManyRedirs
]
m
()
downloadInternal = go (5 :: Int)
let q = buildRequest1 $ http GET path where
go redirs progressBar https host path port consumer = do
r <- liftIO $ bracket acquire release' action
veitherToExcepts r >>= \case
Just r' ->
if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
Nothing -> pure ()
where
acquire = case https of
True -> do
ctx <- baselineContextSSL
openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
False -> openConnection host (fromIntegral $ fromMaybe 80 port)
sendRequest c q emptyBody release' = closeConnection
receiveResponse action c = do
c let q = buildRequest1 $ http GET path
(\_ i' -> do
outStream <- Streams.makeOutputStream sendRequest c q emptyBody
receiveResponse
c
(\r i' -> runE $ do
let scode = getStatusCode r
if
| scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
| scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
Just r' -> pure $ Just $ r'
Nothing -> throwE NoLocationHeader
| otherwise -> throwE $ HTTPStatusError scode
)
followRedirectURL bs = case parseURI strictURIParserOptions bs of
Right uri' -> do
(https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
go (redirs - 1) progressBar https' host' fullPath' port' consumer
Left e -> throwE e
downloadStream r i' = do
let size = case getHeader r [s|Content-Length|] of
Just x' -> case decimal $ E.decodeUtf8 x' of
Left _ -> 0
Right (r', _) -> r'
Nothing -> 0
mpb <- if progressBar
then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
else pure Nothing
outStream <- liftIO $ Streams.makeOutputStream
(\case (\case
Just bs -> void $ consumer bs Just bs -> do
forM_ mpb $ \pb -> incProgress pb (BS.length bs)
void $ consumer bs
Nothing -> pure () Nothing -> pure ()
) )
Streams.connect i' outStream liftIO $ Streams.connect i' outStream
)
closeConnection c
-- | Extracts from a URI type: (https?, host, path+query, port)
uriToQuadruple :: Monad m
=> URI
-> Excepts
'[UnsupportedScheme]
m
(Bool, ByteString, ByteString, Maybe Int)
uriToQuadruple URI {..} = do
let scheme = view schemeBSL' uriScheme
host <-
preview (_Just % authorityHostL' % hostBSL') uriAuthority
?? UnsupportedScheme
https <- if
| scheme == [s|https|] -> pure True
| scheme == [s|http|] -> pure False
| otherwise -> throwE UnsupportedScheme
let
queryBS =
BS.intercalate [s|&|]
. fmap (\(x, y) -> encodeQuery x <> [s|=|] <> encodeQuery y)
$ (queryPairs uriQuery)
port =
preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
fullpath =
if BS.null queryBS then uriPath else uriPath <> [s|?|] <> queryBS
pure (https, host, fullpath, port)
where encodeQuery = L.toStrict . B.toLazyByteString . urlEncodeQuery
checkDigest :: (MonadIO m, MonadLogger m, MonadReader Settings m) checkDigest :: (MonadIO m, MonadLogger m, MonadReader Settings m)
@ -326,4 +437,3 @@ checkDigest dli file = do
let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c
eDigest = view dlHash dli eDigest = view dlHash dli
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest) when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)

103
lib/GHCup/Errors.hs
View File

@ -1,3 +1,8 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DataKinds #-}
module GHCup.Errors where module GHCup.Errors where
import GHCup.Types import GHCup.Types
@ -5,59 +10,115 @@ import GHCup.Types
import Control.Exception.Safe import Control.Exception.Safe
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions
import Haskus.Utils.Variant
import HPath import HPath
------------------------
--[ Low-level errors ]--
------------------------
-- | A compatible platform could not be found. -- | A compatible platform could not be found.
data PlatformResultError = NoCompatiblePlatform String -- the platform we got data NoCompatiblePlatform = NoCompatiblePlatform String -- the platform we got
deriving Show deriving Show
-- | Unable to find a download for the requested versio/distro.
data NoDownload = NoDownload data NoDownload = NoDownload
deriving Show deriving Show
-- | The Architecture is unknown and unsupported.
data NoCompatibleArch = NoCompatibleArch String data NoCompatibleArch = NoCompatibleArch String
deriving Show deriving Show
-- | Unable to figure out the distribution of the host.
data DistroNotFound = DistroNotFound data DistroNotFound = DistroNotFound
deriving Show deriving Show
data ArchiveError = UnknownArchive ByteString -- | The archive format is unknown. We don't know how to extract it.
data UnknownArchive = UnknownArchive ByteString
deriving Show deriving Show
data URLException = UnsupportedURL -- | The scheme is not supported (such as ftp).
data UnsupportedScheme = UnsupportedScheme
deriving Show deriving Show
data FileError = CopyError String -- | Unable to copy a file.
data CopyError = CopyError String
deriving Show deriving Show
-- | Unable to find a tag of a tool.
data TagNotFound = TagNotFound Tag Tool data TagNotFound = TagNotFound Tag Tool
deriving Show deriving Show
data AlreadyInstalled = AlreadyInstalled ToolRequest -- | The tool (such as GHC) is already installed with that version.
data AlreadyInstalled = AlreadyInstalled Tool Version
deriving Show deriving Show
data NotInstalled = NotInstalled ToolRequest -- | The tool is not installed. Some operations rely on a tool
deriving Show -- to be installed (such as setting the current GHC version).
data NotInstalled = NotInstalled Tool Version
data NotSet = NotSet Tool
deriving Show deriving Show
-- | JSON decoding failed.
data JSONError = JSONDecodeError String data JSONError = JSONDecodeError String
deriving Show deriving Show
-- | A file that is supposed to exist does not exist
-- (e.g. when we use file scheme to "download" something).
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
-- | File digest verification failed.
data DigestError = DigestError Text Text
deriving Show
-- | Unexpected HTTP status.
data HTTPStatusError = HTTPStatusError Int
deriving Show
-- | The 'Location' header was expected during a 3xx redirect, but not found.
data NoLocationHeader = NoLocationHeader
deriving Show
-- | Too many redirects.
data TooManyRedirs = TooManyRedirs
deriving Show
-------------------------
--[ High-level errors ]--
-------------------------
-- | A download failed. The underlying error is encapsulated.
data DownloadFailed = forall es . Show (V es) => DownloadFailed (V es)
deriving instance Show DownloadFailed
-- | A build failed.
data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
deriving instance Show BuildFailed
-- | Setting the current GHC version failed.
data GHCupSetError = forall es . Show (V es) => GHCupSetError (V es)
deriving instance Show GHCupSetError
---------------------------------------------
--[ True Exceptions (e.g. for MonadThrow) ]--
---------------------------------------------
-- | Parsing failed.
data ParseError = ParseError String data ParseError = ParseError String
deriving Show deriving Show
instance Exception ParseError instance Exception ParseError
data FileDoesNotExistError = FileDoesNotExistError ByteString
deriving Show
data GHCNotFound = GHCNotFound
deriving Show
data BuildConfigNotFound = BuildConfigNotFound (Path Abs)
deriving Show
data DigestError = DigestError Text Text
deriving Show

2
lib/GHCup/Platform.hs
View File

@ -54,7 +54,7 @@ getArchitecture = case arch of
getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m) getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
=> Excepts => Excepts
'[PlatformResultError , DistroNotFound] '[NoCompatiblePlatform , DistroNotFound]
m m
PlatformResult PlatformResult
getPlatform = do getPlatform = do

22
lib/GHCup/Types.hs
View File

@ -43,8 +43,9 @@ data Tag = Latest
deriving (Ord, Eq, Show) deriving (Ord, Eq, Show)
data VersionInfo = VersionInfo data VersionInfo = VersionInfo
{ _viTags :: [Tag] { _viTags :: [Tag] -- ^ version specific tag
, _viArch :: ArchitectureSpec , _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
, _viArch :: ArchitectureSpec -- ^ descend for binary downloads per arch
} }
deriving (Eq, Show) deriving (Eq, Show)
@ -56,17 +57,10 @@ data DownloadInfo = DownloadInfo
deriving (Eq, Show) deriving (Eq, Show)
data Tool = GHC data Tool = GHC
| GHCSrc
| Cabal | Cabal
| GHCup | GHCup
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
data ToolRequest = ToolRequest
{ _trTool :: Tool
, _trVersion :: Version
}
deriving (Eq, Show)
data Architecture = A_64 data Architecture = A_64
| A_32 | A_32
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show)
@ -111,17 +105,9 @@ type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
type PlatformSpec = Map Platform PlatformVersionSpec type PlatformSpec = Map Platform PlatformVersionSpec
type ArchitectureSpec = Map Architecture PlatformSpec type ArchitectureSpec = Map Architecture PlatformSpec
type ToolVersionSpec = Map Version VersionInfo type ToolVersionSpec = Map Version VersionInfo
type BinaryDownloads = Map Tool ToolVersionSpec type GHCupDownloads = Map Tool ToolVersionSpec
type SourceDownloads = Map Version DownloadInfo
data GHCupDownloads = GHCupDownloads {
_binaryDownloads :: BinaryDownloads
, _sourceDownloads :: SourceDownloads
} deriving Show
data URLSource = GHCupURL data URLSource = GHCupURL
| OwnSource URI | OwnSource URI
| OwnSpec GHCupDownloads | OwnSpec GHCupDownloads
deriving Show deriving Show

1
lib/GHCup/Types/JSON.hs
View File

@ -40,7 +40,6 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupDownloads
instance ToJSON URI where instance ToJSON URI where

5
lib/GHCup/Types/Optics.hs
View File

@ -15,11 +15,9 @@ makePrisms ''Platform
makePrisms ''Tag makePrisms ''Tag
makeLenses ''PlatformResult makeLenses ''PlatformResult
makeLenses ''ToolRequest
makeLenses ''DownloadInfo makeLenses ''DownloadInfo
makeLenses ''Tag makeLenses ''Tag
makeLenses ''VersionInfo makeLenses ''VersionInfo
makeLenses ''GHCupDownloads
uriSchemeL' :: Lens' (URIRef Absolute) Scheme uriSchemeL' :: Lens' (URIRef Absolute) Scheme
@ -45,3 +43,6 @@ hostBSL' = lensVL hostBSL
pathL' :: Lens' (URIRef a) ByteString pathL' :: Lens' (URIRef a) ByteString
pathL' = lensVL pathL pathL' = lensVL pathL
queryL' :: Lens' (URIRef a) Query
queryL' = lensVL queryL

92
lib/GHCup/Utils.hs
View File

@ -43,6 +43,7 @@ import Prelude hiding ( abs
, writeFile , writeFile
) )
import Safe import Safe
import System.IO.Error
import System.Posix.FilePath ( takeFileName ) import System.Posix.FilePath ( takeFileName )
import System.Posix.Files.ByteString ( readSymbolicLink ) import System.Posix.Files.ByteString ( readSymbolicLink )
import URI.ByteString import URI.ByteString
@ -83,6 +84,51 @@ ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
Right r -> pure r Right r -> pure r
-- e.g. ghc-8.6.5
rmMinorSymlinks :: (MonadIO m, MonadLogger m) => Version -> m ()
rmMinorSymlinks ver = do
bindir <- liftIO $ ghcupBinDir
files <- liftIO $ getDirsFiles' bindir
let myfiles =
filter (\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x) files
forM_ myfiles $ \f -> do
let fullF = (bindir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- E.g. ghc, if this version is the set one.
-- This reads `ghcupGHCDir`.
rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
=> Version
-> Excepts '[NotInstalled] m ()
rmPlain ver = do
files <- liftE $ ghcToolFiles ver
bindir <- liftIO $ ghcupBinDir
forM_ files $ \f -> do
let fullF = (bindir </> f)
lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
-- old ghcup
let hdc_file = (bindir </> [rel|haddock-ghc|])
lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
-- e.g. ghc-8.6
rmMajorSymlinks :: (MonadLogger m, MonadIO m) => Version -> m ()
rmMajorSymlinks ver = do
(mj, mi) <- liftIO $ getGHCMajor ver
let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
bindir <- liftIO ghcupBinDir
files <- liftIO $ getDirsFiles' bindir
let myfiles = filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
forM_ myfiles $ \f -> do
let fullF = (bindir </> f)
$(logDebug) [i|rm -f #{toFilePath fullF}|]
liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
----------------------------------- -----------------------------------
@ -90,12 +136,25 @@ ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
----------------------------------- -----------------------------------
toolAlreadyInstalled :: Tool -> Version -> IO Bool
toolAlreadyInstalled tool ver = case tool of
GHC -> ghcInstalled ver
Cabal -> cabalInstalled ver
GHCup -> pure True
ghcInstalled :: Version -> IO Bool ghcInstalled :: Version -> IO Bool
ghcInstalled ver = do ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver ghcdir <- ghcupGHCDir ver
doesDirectoryExist ghcdir doesDirectoryExist ghcdir
ghcSrcInstalled :: Version -> IO Bool
ghcSrcInstalled ver = do
ghcdir <- ghcupGHCDir ver
doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version) ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
ghcSet = do ghcSet = do
ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
@ -108,10 +167,8 @@ ghcSet = do
cabalInstalled :: Version -> IO Bool cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do cabalInstalled ver = do
cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> ghcupBinDir reportedVer <- cabalSet
mc <- executeOut cabalbin [[s|--numeric-version|]] Nothing pure (reportedVer == ver)
let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
pure (reportedVer == (verToBS ver))
cabalSet :: (MonadIO m, MonadThrow m) => m Version cabalSet :: (MonadIO m, MonadThrow m) => m Version
cabalSet = do cabalSet = do
@ -169,7 +226,7 @@ getGHCForMajor major' minor' = do
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m) unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ destination dir => Path Abs -- ^ destination dir
-> Path Abs -- ^ archive path -> Path Abs -- ^ archive path
-> Excepts '[ArchiveError] m () -> Excepts '[UnknownArchive] m ()
unpackToDir dest av = do unpackToDir dest av = do
let fp = E.decodeUtf8 (toFilePath av) let fp = E.decodeUtf8 (toFilePath av)
lift $ $(logInfo) [i|Unpacking: #{fp}|] lift $ $(logInfo) [i|Unpacking: #{fp}|]
@ -198,7 +255,7 @@ unpackToDir dest av = do
-- | Get the tool versions that have this tag. -- | Get the tool versions that have this tag.
getTagged :: BinaryDownloads -> Tool -> Tag -> [Version] getTagged :: GHCupDownloads -> Tool -> Tag -> [Version]
getTagged av tool tag = toListOf getTagged av tool tag = toListOf
( ix tool ( ix tool
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags)) % to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
@ -207,10 +264,10 @@ getTagged av tool tag = toListOf
) )
av av
getLatest :: BinaryDownloads -> Tool -> Maybe Version getLatest :: GHCupDownloads -> Tool -> Maybe Version
getLatest av tool = headOf folded $ getTagged av tool Latest getLatest av tool = headOf folded $ getTagged av tool Latest
getRecommended :: BinaryDownloads -> Tool -> Maybe Version getRecommended :: GHCupDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended getRecommended av tool = headOf folded $ getTagged av tool Recommended
@ -241,24 +298,33 @@ urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/* -- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
-- while ignoring *-<ver> symlinks. -- while ignoring *-<ver> symlinks.
--
-- Returns unversioned relative files, e.g.:
-- ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m) ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
=> Version => Version
-> Excepts '[NotInstalled] m [Path Rel] -> Excepts '[NotInstalled] m [Path Rel]
ghcToolFiles ver = do ghcToolFiles ver = do
ghcdir <- liftIO $ ghcupGHCDir ver ghcdir <- liftIO $ ghcupGHCDir ver
let bindir = ghcdir </> [rel|bin|]
-- fail if ghc is not installed -- fail if ghc is not installed
whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir) whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
(throwE (NotInstalled $ ToolRequest GHC ver)) (throwE (NotInstalled GHC ver))
files <- liftIO $ getDirsFiles' (ghcdir </> ([rel|bin|] :: Path Rel)) files <- liftIO $ getDirsFiles' bindir
-- figure out the <ver> suffix, because this might not be `Version` for -- figure out the <ver> suffix, because this might not be `Version` for
-- alpha/rc releases, but x.y.a.somedate. -- alpha/rc releases, but x.y.a.somedate.
(Just symver) <- (Just symver) <-
(B.stripPrefix [s|ghc-|] . takeFileName) (B.stripPrefix [s|ghc-|] . takeFileName)
<$> (liftIO $ readSymbolicLink $ toFilePath <$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> [rel|ghc|]))
(ghcdir </> ([rel|bin/ghc|] :: Path Rel))
)
when (B.null symver) when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken") (throwIO $ userError $ "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
-- | This file, when residing in ~/.ghcup/ghc/<ver>/ signals that
-- this GHC was built from source. It contains the build config.
ghcUpSrcBuiltFile :: Path Rel
ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]

1
lib/GHCup/Utils/Dirs.hs
View File

@ -76,7 +76,6 @@ withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
-------------- --------------
--[ Others ]-- --[ Others ]--
-------------- --------------

2
lib/GHCup/Utils/File.hs
View File

@ -134,7 +134,7 @@ execLogged exe spath args lfile chdir env = do
SPPB.getProcessStatus True True pid >>= \case SPPB.getProcessStatus True True pid >>= \case
i@(Just (SPPB.Exited es)) -> pure $ toProcessError exe args i i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
i -> pure $ toProcessError exe args i i -> pure $ toProcessError exe args i

9
lib/GHCup/Utils/Logger.hs
View File

@ -4,6 +4,7 @@ module GHCup.Utils.Logger where
import GHCup.Utils import GHCup.Utils
import Control.Monad
import Control.Monad.Logger import Control.Monad.Logger
import HPath import HPath
import HPath.IO import HPath.IO
@ -28,15 +29,15 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
mylogger _ _ level str' = do mylogger _ _ level str' = do
-- color output -- color output
let l = case level of let l = case level of
LevelDebug -> if lcPrintDebug LevelDebug -> toLogStr (style Bold $ color Blue "[ Debug ]")
then toLogStr (style Bold $ color Blue "[ Debug ]")
else mempty
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]") LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]") LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]") LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]" LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n") let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
colorOutter out
when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
$ colorOutter out
-- raw output -- raw output
let lr = case level of let lr = case level of

77
lib/GHCup/Utils/Prelude.hs
View File

@ -1,11 +1,12 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveLift #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module GHCup.Utils.Prelude where module GHCup.Utils.Prelude where
@ -23,6 +24,7 @@ import Data.Versions
import Haskus.Utils.Types.List import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
import System.IO.Error import System.IO.Error
import System.Posix.Env.ByteString ( getEnvironment )
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.Strict.Maybe as S import qualified Data.Strict.Maybe as S
@ -136,17 +138,17 @@ fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight fromEither = either (VLeft . V) VRight
liftException :: ( MonadCatch m liftIOException' :: ( MonadCatch m
, MonadIO m , MonadIO m
, Monad m , Monad m
, e :< es' , e :< es'
, LiftVariant es es' , LiftVariant es es'
) )
=> IOErrorType => IOErrorType
-> e -> e
-> Excepts es m a -> Excepts es m a
-> Excepts es' m a -> Excepts es' m a
liftException errType ex = liftIOException' errType ex =
handleIO handleIO
(\e -> (\e ->
if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
@ -154,6 +156,19 @@ liftException errType ex =
. liftE . liftE
liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es')
=> IOErrorType
-> e
-> m a
-> Excepts es' m a
liftIOException errType ex =
handleIO
(\e ->
if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
)
. lift
hideErrorDef :: IOErrorType -> a -> IO a -> IO a hideErrorDef :: IOErrorType -> a -> IO a -> IO a
hideErrorDef err def = hideErrorDef err def =
handleIO (\e -> if err == ioeGetErrorType e then pure def else ioError e) handleIO (\e -> if err == ioeGetErrorType e then pure def else ioError e)
@ -174,6 +189,7 @@ hideExcept :: forall e es es' a m
hideExcept _ a action = hideExcept _ a action =
catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
hideExcept' :: forall e es es' m hideExcept' :: forall e es es' m
. (Monad m, e :< es, LiftVariant (Remove e es) es') . (Monad m, e :< es, LiftVariant (Remove e es) es')
=> e => e
@ -183,6 +199,23 @@ hideExcept' _ action =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
reThrowAll :: forall e es es' a m
. (Monad m, e :< es')
=> (V es -> e)
-> Excepts es m a
-> Excepts es' m a
reThrowAll f = catchAllE (throwE . f)
reThrowAllIO :: forall e es es' a m
. (MonadCatch m, Monad m, MonadIO m, e :< es')
=> (V es -> e)
-> (IOException -> e)
-> Excepts es m a
-> Excepts es' m a
reThrowAllIO f g = handleIO (throwE . g) . catchAllE (throwE . f)
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
throwEither a = case a of throwEither a = case a of
Left e -> throwM e Left e -> throwM e
@ -200,3 +233,11 @@ intToText = TL.toStrict . B.toLazyText . B.decimal
removeLensFieldLabel :: String -> String removeLensFieldLabel :: String -> String
removeLensFieldLabel str' = removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str' maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
addToCurrentEnv :: MonadIO m
=> [(ByteString, ByteString)]
-> m [(ByteString, ByteString)]
addToCurrentEnv adds = do
cEnv <- liftIO $ getEnvironment
pure (adds ++ cEnv)