filter tool and version instead of URL

This commit is contained in:
amesgen 2021-01-02 05:53:11 +01:00
parent 56569a0698
commit 62d5d53232
No known key found for this signature in database
GPG Key ID: 1A89EC203635A13D
2 changed files with 30 additions and 18 deletions

View File

@ -14,6 +14,7 @@ import GHCup.Types
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils.Logger import GHCup.Utils.Logger
import Control.Monad
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) ) import Data.Semigroup ( (<>) )
#endif #endif
@ -33,7 +34,7 @@ data Options = Options
} }
data Command = ValidateYAML ValidateYAMLOpts data Command = ValidateYAML ValidateYAMLOpts
| ValidateTarballs ValidateYAMLOpts (Maybe Regex) | ValidateTarballs ValidateYAMLOpts TarballFilter
data Input data Input
@ -64,10 +65,18 @@ data ValidateYAMLOpts = ValidateYAMLOpts
validateYAMLOpts :: Parser ValidateYAMLOpts validateYAMLOpts :: Parser ValidateYAMLOpts
validateYAMLOpts = ValidateYAMLOpts <$> optional inputP validateYAMLOpts = ValidateYAMLOpts <$> optional inputP
urlRegexP :: Parser (Maybe Regex) tarballFilterP :: Parser TarballFilter
urlRegexP = optional . option (str @String >>= makeRegexM) $ tarballFilterP = option readm $
long "url-regex" <> short 'u' <> metavar "URL_REGEX" long "tarball-filter" <> short 'u' <> metavar "<tool>-<version>" <> value def
<> help "Only validate if URL matches the regex" <> help "Only check certain tarballs (format: <tool>-<version>, where <tool> 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 :: Parser Options
opts = Options <$> com opts = Options <$> com
@ -85,7 +94,7 @@ com = subparser
<> (command <> (command
"check-tarballs" "check-tarballs"
(info (info
((ValidateTarballs <$> validateYAMLOpts <*> urlRegexP) <**> helper) ((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
(progDesc "Validate all tarballs (download and checksum)") (progDesc "Validate all tarballs (download and checksum)")
) )
) )
@ -104,13 +113,13 @@ main = do
B.getContents >>= valAndExit validate B.getContents >>= valAndExit validate
ValidateYAMLOpts { vInput = Just (FileInput file) } -> ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit validate B.readFile file >>= valAndExit validate
ValidateTarballs vopts urlRegex -> case vopts of ValidateTarballs vopts tarballFilter -> case vopts of
ValidateYAMLOpts { vInput = Nothing } -> ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit (validateTarballs urlRegex) B.getContents >>= valAndExit (validateTarballs tarballFilter)
ValidateYAMLOpts { vInput = Just StdInput } -> ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit (validateTarballs urlRegex) B.getContents >>= valAndExit (validateTarballs tarballFilter)
ValidateYAMLOpts { vInput = Just (FileInput file) } -> ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit (validateTarballs urlRegex) B.readFile file >>= valAndExit (validateTarballs tarballFilter)
pure () pure ()
where where

View File

@ -33,7 +33,6 @@ import System.Exit
import System.IO import System.IO
import Text.ParserCombinators.ReadP import Text.ParserCombinators.ReadP
import Text.Regex.Posix import Text.Regex.Posix
import URI.ByteString
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
@ -161,6 +160,11 @@ validate dls = do
isBase (Base _) = True isBase (Base _) = True
isBase _ = False isBase _ = False
data TarballFilter = TarballFilter
{ tfTool :: Regex
, tfVersion :: Regex
}
validateTarballs :: ( Monad m validateTarballs :: ( Monad m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
@ -168,19 +172,18 @@ validateTarballs :: ( Monad m
, MonadUnliftIO m , MonadUnliftIO m
, MonadMask m , MonadMask m
) )
=> Maybe Regex => TarballFilter
-> GHCupDownloads -> GHCupDownloads
-> m ExitCode -> m ExitCode
validateTarballs urlRegex dls = do validateTarballs (TarballFilter toolRegex versionRegex) dls = do
ref <- liftIO $ newIORef 0 ref <- liftIO $ newIORef 0
flip runReaderT ref $ do flip runReaderT ref $ do
-- download/verify all tarballs -- download/verify all tarballs
let dlis = nubOrd . filter matchingUrl $ let dlis = nubOrd $ dls ^.. each
dls ^.. each % each % (viSourceDL % _Just `summing` viArch % each % each % each) %& indices (matchTest toolRegex . show) %> each
matchingUrl dli = case urlRegex of %& indices (matchTest versionRegex . T.unpack . prettyVer)
Nothing -> True % (viSourceDL % _Just `summing` viArch % each % each % each)
Just r -> matchTest r $ serializeURIRef' (_dlUri dli)
forM_ dlis $ downloadAll forM_ dlis $ downloadAll
-- exit -- exit