use regex instead of substring
This commit is contained in:
parent
8944ed6e36
commit
56569a0698
@ -21,10 +21,10 @@ 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
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Yaml as Y
|
||||
|
||||
|
||||
@ -33,7 +33,7 @@ data Options = Options
|
||||
}
|
||||
|
||||
data Command = ValidateYAML ValidateYAMLOpts
|
||||
| ValidateTarballs ValidateYAMLOpts (Maybe T.Text)
|
||||
| ValidateTarballs ValidateYAMLOpts (Maybe Regex)
|
||||
|
||||
|
||||
data Input
|
||||
@ -64,10 +64,10 @@ data ValidateYAMLOpts = ValidateYAMLOpts
|
||||
validateYAMLOpts :: Parser ValidateYAMLOpts
|
||||
validateYAMLOpts = ValidateYAMLOpts <$> optional inputP
|
||||
|
||||
urlSubstrP :: Parser (Maybe T.Text)
|
||||
urlSubstrP = optional . strOption $
|
||||
long "url-substr" <> short 'u' <> metavar "URL_SUBSTRING"
|
||||
<> help "Only validate if URL contains this substring"
|
||||
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"
|
||||
|
||||
opts :: Parser Options
|
||||
opts = Options <$> com
|
||||
@ -85,7 +85,7 @@ com = subparser
|
||||
<> (command
|
||||
"check-tarballs"
|
||||
(info
|
||||
((ValidateTarballs <$> validateYAMLOpts <*> urlSubstrP) <**> helper)
|
||||
((ValidateTarballs <$> validateYAMLOpts <*> urlRegexP) <**> helper)
|
||||
(progDesc "Validate all tarballs (download and checksum)")
|
||||
)
|
||||
)
|
||||
@ -104,13 +104,13 @@ main = do
|
||||
B.getContents >>= valAndExit validate
|
||||
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
|
||||
B.readFile file >>= valAndExit validate
|
||||
ValidateTarballs vopts urlSubstr -> case vopts of
|
||||
ValidateTarballs vopts urlRegex -> case vopts of
|
||||
ValidateYAMLOpts { vInput = Nothing } ->
|
||||
B.getContents >>= valAndExit (validateTarballs urlSubstr)
|
||||
B.getContents >>= valAndExit (validateTarballs urlRegex)
|
||||
ValidateYAMLOpts { vInput = Just StdInput } ->
|
||||
B.getContents >>= valAndExit (validateTarballs urlSubstr)
|
||||
B.getContents >>= valAndExit (validateTarballs urlRegex)
|
||||
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
|
||||
B.readFile file >>= valAndExit (validateTarballs urlSubstr)
|
||||
B.readFile file >>= valAndExit (validateTarballs urlRegex)
|
||||
pure ()
|
||||
|
||||
where
|
||||
|
@ -32,12 +32,12 @@ import Optics
|
||||
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
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as E
|
||||
import qualified Data.Version as V
|
||||
|
||||
|
||||
@ -168,19 +168,19 @@ validateTarballs :: ( Monad m
|
||||
, MonadUnliftIO m
|
||||
, MonadMask m
|
||||
)
|
||||
=> Maybe T.Text
|
||||
=> Maybe Regex
|
||||
-> GHCupDownloads
|
||||
-> m ExitCode
|
||||
validateTarballs urlSubstr dls = do
|
||||
validateTarballs urlRegex 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 urlSubstr of
|
||||
matchingUrl dli = case urlRegex of
|
||||
Nothing -> True
|
||||
Just sub -> E.encodeUtf8 sub `B.isInfixOf` serializeURIRef' (_dlUri dli)
|
||||
Just r -> matchTest r $ serializeURIRef' (_dlUri dli)
|
||||
forM_ dlis $ downloadAll
|
||||
|
||||
-- exit
|
||||
|
@ -431,6 +431,7 @@ executable ghcup-gen
|
||||
, optics
|
||||
, optparse-applicative
|
||||
, pretty-terminal
|
||||
, regex-posix
|
||||
, resourcet
|
||||
, safe-exceptions
|
||||
, string-interpolate
|
||||
|
Loading…
Reference in New Issue
Block a user