diff --git a/.gitlab/script/ghcup_version.sh b/.gitlab/script/ghcup_version.sh index 254fdf2..bf5f6c4 100755 --- a/.gitlab/script/ghcup_version.sh +++ b/.gitlab/script/ghcup_version.sh @@ -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} diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs deleted file mode 100644 index 8242d6c..0000000 --- a/app/ghcup-gen/Main.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# 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 "-" <> value def - <> help "Only check certain tarballs (format: -)" - 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 diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs deleted file mode 100644 index 91bb612..0000000 --- a/app/ghcup-gen/Validate.hs +++ /dev/null @@ -1,280 +0,0 @@ -{-# 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 diff --git a/docs/dev.md b/docs/dev.md index 00316e0..f86e0ee 100644 --- a/docs/dev.md +++ b/docs/dev.md @@ -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-.yaml` ([ghcup-metadata repo](https://github.com/haskell/ghcup-metadata)), then verify with `ghcup-gen check -f ghcup-.yaml` and possibly (example only) `ghcup-gen check-tarballs -f ghcup-.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 SHA256SUMS`) -6. Download release artifacts and upload them `downloads.haskell.org/~ghcup` along with checksum files (`sha256sum --tag * > SHA256SUMS && gpg --detach-sign -u 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-.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-.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 diff --git a/ghcup.cabal b/ghcup.cabal index 84f4d31..0cf2fb7 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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