Skip to content
Snippets Groups Projects
Verified Commit 7bb67dd4 authored by Julian Ospald's avatar Julian Ospald :tea:
Browse files

Merge branch 'ghcup-gen'

parents 0ae42dd7 72c4ea70
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
.gitlab/script/ghcup_version.sh
+ 0
− 3
View file @ 7bb67dd4
......@@ -85,7 +85,6 @@ else
ext=''
fi
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup${ext}
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" "$CI_PROJECT_DIR"/.local/bin/ghcup-gen${ext}
### cleanup
......@@ -94,8 +93,6 @@ rm -rf "${GHCUP_DIR}"
### manual cli based testing
ghcup-gen check -f data/metadata/ghcup-${JSON_VERSION}.yaml
eghcup --numeric-version
eghcup install ghc ${GHC_VERSION}
......
app/ghcup-gen/Main.hs deleted 100644 → 0
+ 0
− 155
View file @ 0ae42dd7
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import GHCup.Types
import GHCup.Errors
import GHCup.Platform
import GHCup.Utils.Dirs
import GHCup.Utils.Logger
import GHCup.Types.JSON ( )
import Control.Exception ( displayException )
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.IO.Class
import Data.Char ( toLower )
import Data.Maybe
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) )
#endif
import Options.Applicative hiding ( style )
import Haskus.Utils.Variant.Excepts
import System.Console.Pretty
import System.Environment
import System.Exit
import System.IO ( stderr )
import Text.Regex.Posix
import Validate
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text.IO as T
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.Yaml.Aeson as Y
data Options = Options
{ optCommand :: Command
}
data Command = ValidateYAML ValidateYAMLOpts
| ValidateTarballs ValidateYAMLOpts TarballFilter
data Input
= FileInput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
| StdInput
fileInput :: Parser Input
fileInput =
FileInput
<$> strOption
(long "file" <> short 'f' <> metavar "FILENAME" <> help
"Input file to validate"
)
stdInput :: Parser Input
stdInput = flag'
StdInput
(short 'i' <> long "stdin" <> help "Validate from stdin (default)")
inputP :: Parser Input
inputP = fileInput <|> stdInput
data ValidateYAMLOpts = ValidateYAMLOpts
{ vInput :: Maybe Input
}
validateYAMLOpts :: Parser ValidateYAMLOpts
validateYAMLOpts = ValidateYAMLOpts <$> optional inputP
tarballFilterP :: Parser TarballFilter
tarballFilterP = option readm $
long "tarball-filter" <> short 'u' <> metavar "<tool>-<version>" <> value def
<> help "Only check certain tarballs (format: <tool>-<version>)"
where
def = TarballFilter (Right Nothing) (makeRegex ("" :: String))
readm = do
s <- str
case span (/= '-') s of
(_, []) -> fail "invalid format, missing '-' after the tool name"
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
pure (TarballFilter $ Right $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
pure (TarballFilter $ Left tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
_ -> fail "invalid tool"
low = fmap toLower
opts :: Parser Options
opts = Options <$> com
com :: Parser Command
com = subparser
( command
"check"
( ValidateYAML
<$> info (validateYAMLOpts <**> helper)
(progDesc "Validate the YAML")
)
<> command
"check-tarballs"
(info
((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
(progDesc "Validate all tarballs (download and checksum)")
)
)
main :: IO ()
main = do
no_color <- isJust <$> lookupEnv "NO_COLOR"
let loggerConfig = LoggerConfig { lcPrintDebug = True
, consoleOutter = T.hPutStr stderr
, fileOutter = \_ -> pure ()
, fancyColors = not no_color
}
dirs <- liftIO getAllDirs
let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings loggerConfig
pfreq <- (
flip runReaderT leanAppstate . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of
ValidateYAML vopts -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validate dl m)
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validateTarballs tarballFilter dl m)
pure ()
where
withValidateYamlOpts vopts f = case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit f
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit f
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit f
valAndExit f contents = do
(GHCupInfo _ av gt) <- case Y.decodeEither' contents of
Right r -> pure r
Left e -> die (color Red $ displayException e)
f av gt
>>= exitWith
app/ghcup-gen/Validate.hs deleted 100644 → 0
+ 0
− 280
View file @ 0ae42dd7
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Validate where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
import Codec.Archive
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.Trans.Resource ( runResourceT
, MonadUnliftIO
)
import Data.Containers.ListUtils ( nubOrd )
import Data.IORef
import Data.List
import Data.Versions
import Haskus.Utils.Variant.Excepts
import Optics
import System.FilePath
import System.Exit
import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Version as V
data ValidationError = InternalError String
deriving Show
instance Exception ValidationError
addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
addError = do
ref <- ask
liftIO $ modifyIORef ref (+ 1)
validate :: (Monad m, MonadReader env m, HasLog env, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> m ExitCode
validate dls _ = do
ref <- liftIO $ newIORef 0
-- verify binary downloads --
flip runReaderT ref $ do
-- unique tags
forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
-- required platforms
forM_ (M.toList dls) $ \(t, versions) ->
forM_ (M.toList versions) $ \(v, vi) ->
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
checkHasRequiredPlatforms t v (_viTags vi) arch (M.keys pspecs)
checkGHCVerIsValid
forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
_ <- checkGHCHasBaseVersion
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
lift $ logInfo "All good"
pure ExitSuccess
where
checkHasRequiredPlatforms t v tags arch pspecs = do
let v' = prettyVer v
arch' = prettyShow arch
when (Linux UnknownLinux `notElem` pspecs) $ do
lift $ logError $
"Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
when ((Darwin `notElem` pspecs) && arch == A_64) $ do
lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
when ((FreeBSD `notElem` pspecs) && arch == A_64) $ lift $ logWarn $
"FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
when (Windows `notElem` pspecs && arch == A_64) $ do
lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
-- alpine needs to be set explicitly, because
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
-- (although it could be static)
when (Linux Alpine `notElem` pspecs) $
case t of
GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
Cabal | v > [vver|2.4.1.0|]
, arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
GHC | Latest `elem` tags || Recommended `elem` tags
, arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))
_ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
checkUniqueTags tool = do
let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
let nonUnique =
fmap fst
. filter (\(_, b) -> not b)
<$> ( mapM
(\case
[] -> throwM $ InternalError "empty inner list"
(t : ts) ->
pure $ (t, ) (not (isUniqueTag t) || null ts)
)
. group
. sort
$ allTags
)
case join nonUnique of
[] -> pure ()
xs -> do
lift $ logError $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
addError
where
isUniqueTag Latest = True
isUniqueTag Recommended = True
isUniqueTag Old = False
isUniqueTag Prerelease = False
isUniqueTag (Base _) = False
isUniqueTag (UnknownTag _) = False
checkGHCVerIsValid = do
let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
forM_ ghcVers $ \v ->
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
[_] -> pure ()
_ -> do
lift $ logError $ "GHC version " <> prettyVer v <> " is not valid"
addError
-- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do
let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
forM_ [Latest, Recommended] $ \t -> case t `elem` allTags of
False -> do
lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
addError
True -> pure ()
-- all GHC versions must have a base tag
checkGHCHasBaseVersion = do
let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
False -> do
lift $ logError $ "Base tag missing from GHC ver " <> prettyVer ver
addError
True -> pure ()
isBase (Base _) = True
isBase _ = False
data TarballFilter = TarballFilter
{ tfTool :: Either GlobalTool (Maybe Tool)
, tfVersion :: Regex
}
validateTarballs :: ( Monad m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
, MonadMask m
, Alternative m
, MonadFail m
)
=> TarballFilter
-> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> m ExitCode
validateTarballs (TarballFilter etool versionRegex) dls gt = do
ref <- liftIO $ newIORef 0
-- download/verify all tarballs
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
let gdlis = nubOrd $ gt ^.. each
let allDls = either (const gdlis) (const dlis) etool
when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref
forM_ allDls (downloadAll ref)
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
logInfo "All good"
pure ExitSuccess
where
downloadAll :: ( MonadUnliftIO m
, MonadIO m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
, MonadCatch m
, MonadMask m
, MonadThrow m
)
=> IORef Int
-> DownloadInfo
-> m ()
downloadAll ref dli = do
r <- runResourceT
. runE @'[DigestError
, GPGError
, DownloadFailed
, UnknownArchive
, ArchiveResult
]
$ do
case etool of
Right (Just GHCup) -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False
pure Nothing
Right _ -> do
p <- liftE $ downloadCached dli Nothing
fmap (Just . head . splitDirectories . head)
. liftE
. getArchiveFiles
$ p
Left ShimGen -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False
pure Nothing
case r of
VRight (Just basePath) -> do
case _dlSubdir dli of
Just (RealDir prel) -> do
logInfo
$ " verifying subdir: " <> T.pack prel
when (basePath /= prel) $ do
logError $
"Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
runReaderT addError ref
Just (RegexDir regexString) -> do
logInfo $
"verifying subdir (regex): " <> T.pack regexString
let regex = makeRegexOpts
compIgnoreCase
execBlank
regexString
unless (match regex basePath) $ do
logError $
"Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
runReaderT addError ref
Nothing -> pure ()
VRight Nothing -> pure ()
VLeft e -> do
logError $
"Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
runReaderT addError ref
docs/dev.md
+ 7
− 9
View file @ 7bb67dd4
......@@ -95,21 +95,19 @@ Every subcommand now lives in its own module under [GHCup.OptParse.MyCommand](ht
3. Add ChangeLog entry
4. Add/fix downloads in `ghcup-<ver>.yaml` ([ghcup-metadata repo](https://github.com/haskell/ghcup-metadata)), then verify with `ghcup-gen check -f ghcup-<ver>.yaml` and possibly (example only) `ghcup-gen check-tarballs -f ghcup-<ver>.yaml -u 'ghc-8.10.7'`. Generally, new GHC/cabal/stack/hls versions are only added to the latest yaml file. New GHCup versions are added to all (great care must be taken here to not break the parser... e.g. ARM platforms don't parse in all older formats).
4. Commit and git push with tag. Wait for tests to succeed and release artifacts to build.
5. Commit and git push with tag. Wait for tests to succeed and release artifacts to build.
5. Download release artifacts and upload them `downloads.haskell.org/~ghcup` along with checksum files (`sha256sum --tag * > SHA256SUMS && gpg --detach-sign -u <your-email> SHA256SUMS`)
6. Download release artifacts and upload them `downloads.haskell.org/~ghcup` along with checksum files (`sha256sum --tag * > SHA256SUMS && gpg --detach-sign -u <your-email> SHA256SUMS`)
6. Add ghcup release artifacts to ALL yaml files, see [ghcup-metadata repo](https://github.com/haskell/ghcup-metadata)
7. Add ghcup release artifacts to ALL yaml files (see point 4.)
7. Upload the final `ghcup-<ver>.yaml` (and a detached GPG sig of it) to `webhost.haskell.org/ghcup/data/` (for yaml versions <= 0.0.6) as well as [https://github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata) (for all versions).
8. Upload the final `ghcup-<ver>.yaml` (and a detached GPG sig of it) to `webhost.haskell.org/ghcup/data/` (for yaml versions <= 0.0.6) as well as [https://github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata) (for all versions).
8. Upload `bootstrap-haskell` and `bootstrap-haskell.ps1` to `webhost.haskell.org/ghcup/sh/`
9. Upload `bootstrap-haskell` and `bootstrap-haskell.ps1` to `webhost.haskell.org/ghcup/sh/`
9. Update the top-level ghcup symlinks at `downloads.haskell.org/~ghcup`
10. Update the top-level ghcup symlinks at `downloads.haskell.org/~ghcup`
11. Post on reddit/discourse/etc. and collect rewards
10. Post on reddit/discourse/etc. and collect rewards
# Documentation
......
ghcup.cabal
+ 7
− 45
View file @ 7bb67dd4
......@@ -43,6 +43,11 @@ flag internal-downloader
default: False
manual: True
flag no-exe
description: Don't build any executables
default: False
manual: True
library
exposed-modules:
GHCup
......@@ -252,51 +257,8 @@ executable ghcup
if os(windows)
cpp-options: -DIS_WINDOWS
executable ghcup-gen
main-is: Main.hs
hs-source-dirs: app/ghcup-gen
other-modules: Validate
default-language: Haskell2010
default-extensions:
DeriveGeneric
LambdaCase
MultiWayIf
NamedFieldPuns
PackageImports
QuasiQuotes
RecordWildCards
ScopedTypeVariables
StrictData
TupleSections
TypeApplications
TypeFamilies
ViewPatterns
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates -threaded
build-depends:
, base >=4.13 && <5
, bytestring ^>=0.10
, containers ^>=0.6
, filepath ^>=1.4.2.1
, ghcup
, haskus-utils-variant >=3.0 && <3.2
, libarchive ^>=3.0.3.0
, mtl ^>=2.2
, optics ^>=0.4
, optparse-applicative >=0.15.1.0 && <0.17
, pretty ^>=1.1.3.1
, pretty-terminal ^>=0.1.0.0
, regex-posix ^>=0.96
, resourcet ^>=1.2.2
, safe-exceptions ^>=0.1
, text ^>=1.2.4.0
, transformers ^>=0.5
, versions >=4.0.1 && <5.1
, yaml-streamly ^>=0.12.0
if flag(no-exe)
buildable: False
test-suite ghcup-test
type: exitcode-stdio-1.0
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment