diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs index 0ad34ca..6650f76 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 Control.Monad #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ( (<>) ) #endif @@ -33,7 +34,7 @@ data Options = Options } data Command = ValidateYAML ValidateYAMLOpts - | ValidateTarballs ValidateYAMLOpts (Maybe Regex) + | ValidateTarballs ValidateYAMLOpts TarballFilter data Input @@ -64,10 +65,18 @@ data ValidateYAMLOpts = ValidateYAMLOpts validateYAMLOpts :: Parser ValidateYAMLOpts validateYAMLOpts = ValidateYAMLOpts <$> optional inputP -urlRegexP :: Parser (Maybe Regex) -urlRegexP = optional . option (str @String >>= makeRegexM) $ - long "url-regex" <> short 'u' <> metavar "URL_REGEX" - <> help "Only validate if URL matches the regex" +tarballFilterP :: Parser TarballFilter +tarballFilterP = option readm $ + long "tarball-filter" <> short 'u' <> metavar "-" <> value def + <> help "Only check certain tarballs (format: -, where is GHC by default)" + where + def = join TarballFilter $ makeRegex ("" :: String) + readm = do + s <- str + (t, v) <- case span (/= '-') s of + (v, []) -> pure ("", v) + (t, v) -> pure (t, drop 1 v) + TarballFilter <$> makeRegexOptsM compIgnoreCase execBlank t <*> makeRegexM v opts :: Parser Options opts = Options <$> com @@ -85,7 +94,7 @@ com = subparser <> (command "check-tarballs" (info - ((ValidateTarballs <$> validateYAMLOpts <*> urlRegexP) <**> helper) + ((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper) (progDesc "Validate all tarballs (download and checksum)") ) ) @@ -104,13 +113,13 @@ main = do B.getContents >>= valAndExit validate ValidateYAMLOpts { vInput = Just (FileInput file) } -> B.readFile file >>= valAndExit validate - ValidateTarballs vopts urlRegex -> case vopts of + ValidateTarballs vopts tarballFilter -> case vopts of ValidateYAMLOpts { vInput = Nothing } -> - B.getContents >>= valAndExit (validateTarballs urlRegex) + B.getContents >>= valAndExit (validateTarballs tarballFilter) ValidateYAMLOpts { vInput = Just StdInput } -> - B.getContents >>= valAndExit (validateTarballs urlRegex) + B.getContents >>= valAndExit (validateTarballs tarballFilter) ValidateYAMLOpts { vInput = Just (FileInput file) } -> - B.readFile file >>= valAndExit (validateTarballs urlRegex) + B.readFile file >>= valAndExit (validateTarballs tarballFilter) pure () where diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 6ea8693..a6c826c 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -33,7 +33,6 @@ import System.Exit import System.IO import Text.ParserCombinators.ReadP import Text.Regex.Posix -import URI.ByteString import qualified Data.ByteString as B import qualified Data.Map.Strict as M @@ -161,6 +160,11 @@ validate dls = do isBase (Base _) = True isBase _ = False +data TarballFilter = TarballFilter + { tfTool :: Regex + , tfVersion :: Regex + } + validateTarballs :: ( Monad m , MonadLogger m , MonadThrow m @@ -168,19 +172,18 @@ validateTarballs :: ( Monad m , MonadUnliftIO m , MonadMask m ) - => Maybe Regex + => TarballFilter -> GHCupDownloads -> m ExitCode -validateTarballs urlRegex dls = do +validateTarballs (TarballFilter toolRegex versionRegex) dls = do ref <- liftIO $ newIORef 0 flip runReaderT ref $ do -- download/verify all tarballs - let dlis = nubOrd . filter matchingUrl $ - dls ^.. each % each % (viSourceDL % _Just `summing` viArch % each % each % each) - matchingUrl dli = case urlRegex of - Nothing -> True - Just r -> matchTest r $ serializeURIRef' (_dlUri dli) + let dlis = nubOrd $ dls ^.. each + %& indices (matchTest toolRegex . show) %> each + %& indices (matchTest versionRegex . T.unpack . prettyVer) + % (viSourceDL % _Just `summing` viArch % each % each % each) forM_ dlis $ downloadAll -- exit