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
Download Patch File Download Diff File Expand all files Collapse all files

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.Download
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils.Logger
import Control.Exception.Safe
@@ -48,22 +47,22 @@ addError = do
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads
-> m ExitCode
validate dls@GHCupDownloads {..} = do
validate dls = do
ref <- liftIO $ newIORef 0
-- * verify binary downloads * --
flip runReaderT ref $ do
-- unique tags
forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkUniqueTags t
forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
-- required platforms
forM_ (M.toList _binaryDownloads) $ \(t, versions) ->
forM_ (M.toList dls) $ \(t, versions) ->
forM_ (M.toList versions) $ \(v, vi) ->
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
checkHasRequiredPlatforms t v arch (M.keys pspecs)
checkGHCisSemver
forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkMandatoryTags t
forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
-- exit
e <- liftIO $ readIORef ref
@@ -86,7 +85,7 @@ validate dls@GHCupDownloads {..} = do
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
checkUniqueTags tool = do
let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool
let allTags = join $ fmap snd $ availableToolVersions dls tool
let nonUnique =
fmap fst
. filter (\(_, b) -> not b)
@@ -110,7 +109,7 @@ validate dls@GHCupDownloads {..} = do
isUniqueTag Recommended = True
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
Left _ -> do
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
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
False -> do
lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
@@ -132,20 +131,25 @@ validateTarballs :: ( Monad m
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
, MonadMask m
)
=> GHCupDownloads
-> m ExitCode
validateTarballs GHCupDownloads {..} = do
validateTarballs dls = do
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- download/verify all tarballs
-- download/verify all binary tarballs
let
dlis = nub $ join $ (M.elems _binaryDownloads) <&> \versions ->
dlbis = nub $ join $ (M.elems dls) <&> \versions ->
join $ (M.elems versions) <&> \vi ->
join $ (M.elems $ _viArch vi) <&> \pspecs ->
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
e <- liftIO $ readIORef ref

181
app/ghcup/Main.hs
View File

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