diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs index 7f80d11..74fbc03 100644 --- a/app/ghcup-gen/Main.hs +++ b/app/ghcup-gen/Main.hs @@ -14,6 +14,7 @@ import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Utils.Logger +import Data.Char ( toLower ) #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ( (<>) ) #endif @@ -21,6 +22,7 @@ import Options.Applicative hiding ( style ) import System.Console.Pretty import System.Exit import System.IO ( stdout ) +import Text.Regex.Posix import Validate import qualified Data.ByteString as B @@ -32,7 +34,7 @@ data Options = Options } data Command = ValidateYAML ValidateYAMLOpts - | ValidateTarballs ValidateYAMLOpts + | ValidateTarballs ValidateYAMLOpts TarballFilter data Input @@ -63,6 +65,22 @@ data ValidateYAMLOpts = ValidateYAMLOpts 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 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 ] -> + TarballFilter <$> pure (Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v) + _ -> fail "invalid tool" + low = fmap toLower + + opts :: Parser Options opts = Options <$> com @@ -78,11 +96,9 @@ com = subparser ) <> (command "check-tarballs" - ( ValidateTarballs - <$> (info - (validateYAMLOpts <**> helper) - (progDesc "Validate all tarballs (download and checksum)") - ) + (info + ((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper) + (progDesc "Validate all tarballs (download and checksum)") ) ) ) @@ -100,13 +116,13 @@ main = do B.getContents >>= valAndExit validate ValidateYAMLOpts { vInput = Just (FileInput file) } -> B.readFile file >>= valAndExit validate - ValidateTarballs vopts -> case vopts of + ValidateTarballs vopts tarballFilter -> case vopts of ValidateYAMLOpts { vInput = Nothing } -> - B.getContents >>= valAndExit validateTarballs + B.getContents >>= valAndExit (validateTarballs tarballFilter) ValidateYAMLOpts { vInput = Just StdInput } -> - B.getContents >>= valAndExit validateTarballs + B.getContents >>= valAndExit (validateTarballs tarballFilter) ValidateYAMLOpts { vInput = Just (FileInput file) } -> - B.readFile file >>= valAndExit validateTarballs + B.readFile file >>= valAndExit (validateTarballs tarballFilter) pure () where diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 38a6e39..c3f689c 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -7,6 +7,7 @@ module Validate where import GHCup import GHCup.Download import GHCup.Types +import GHCup.Types.Optics import GHCup.Utils.Dirs import GHCup.Utils.Logger import GHCup.Utils.Version.QQ @@ -21,6 +22,7 @@ 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.String.Interpolate @@ -30,6 +32,7 @@ import Optics import System.Exit import System.IO import Text.ParserCombinators.ReadP +import Text.Regex.Posix import qualified Data.ByteString as B import qualified Data.Map.Strict as M @@ -157,6 +160,11 @@ validate dls = do isBase (Base _) = True isBase _ = False +data TarballFilter = TarballFilter + { tfTool :: Maybe Tool + , tfVersion :: Regex + } + validateTarballs :: ( Monad m , MonadLogger m , MonadThrow m @@ -164,23 +172,20 @@ validateTarballs :: ( Monad m , MonadUnliftIO m , MonadMask m ) - => GHCupDownloads + => TarballFilter + -> GHCupDownloads -> m ExitCode -validateTarballs dls = do +validateTarballs (TarballFilter tool versionRegex) dls = do ref <- liftIO $ newIORef 0 flip runReaderT ref $ do - -- download/verify all binary tarballs - let - 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_ dlbis $ downloadAll - - let dlsrc = nub $ join $ (M.elems dls) <&> \versions -> - join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL - forM_ dlsrc $ downloadAll + -- download/verify all tarballs + let dlis = nubOrd $ dls ^.. each + %& indices (maybe (const True) (==) tool) %> each + %& indices (matchTest versionRegex . T.unpack . prettyVer) + % (viSourceDL % _Just `summing` viArch % each % each % each) + when (null dlis) $ $(logError) [i|no tarballs selected by filter|] *> addError + forM_ dlis $ downloadAll -- exit e <- liftIO $ readIORef ref @@ -191,13 +196,13 @@ validateTarballs dls = do pure ExitSuccess where + runLogger = myLoggerT LoggerConfig { lcPrintDebug = True + , colorOutter = B.hPut stderr + , rawOutter = (\_ -> pure ()) + } downloadAll dli = do dirs <- liftIO getDirs let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings - let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True - , colorOutter = B.hPut stderr - , rawOutter = (\_ -> pure ()) - } r <- runLogger diff --git a/ghcup.cabal b/ghcup.cabal index 78772c3..ef77118 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -431,6 +431,7 @@ executable ghcup-gen , optics , optparse-applicative , pretty-terminal + , regex-posix , resourcet , safe-exceptions , string-interpolate diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index bb4ca18..761ca10 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -79,7 +79,7 @@ data Tool = GHC | Cabal | GHCup | HLS - deriving (Eq, GHC.Generic, Ord, Show) + deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded) -- | All necessary information of a tool version, including @@ -172,7 +172,7 @@ data DownloadInfo = DownloadInfo , _dlSubdir :: Maybe TarDir , _dlHash :: Text } - deriving (Eq, GHC.Generic, Show) + deriving (Eq, Ord, GHC.Generic, Show) @@ -185,7 +185,7 @@ data DownloadInfo = DownloadInfo -- | How to descend into a tar archive. data TarDir = RealDir (Path Rel) | RegexDir String -- ^ will be compiled to regex, the first match will "win" - deriving (Eq, GHC.Generic, Show) + deriving (Eq, Ord, GHC.Generic, Show) -- | Where to fetch GHCupDownloads from.