diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs index 7f80d11..38d89c9 100644 --- a/app/ghcup-gen/Main.hs +++ b/app/ghcup-gen/Main.hs @@ -24,6 +24,7 @@ import System.IO ( stdout ) import Validate import qualified Data.ByteString as B +import qualified Data.Text as T import qualified Data.Yaml as Y @@ -32,7 +33,7 @@ data Options = Options } data Command = ValidateYAML ValidateYAMLOpts - | ValidateTarballs ValidateYAMLOpts + | ValidateTarballs ValidateYAMLOpts (Maybe T.Text) data Input @@ -63,6 +64,11 @@ 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" + opts :: Parser Options opts = Options <$> com @@ -78,11 +84,9 @@ com = subparser ) <> (command "check-tarballs" - ( ValidateTarballs - <$> (info - (validateYAMLOpts <**> helper) - (progDesc "Validate all tarballs (download and checksum)") - ) + (info + ((ValidateTarballs <$> validateYAMLOpts <*> urlSubstrP) <**> helper) + (progDesc "Validate all tarballs (download and checksum)") ) ) ) @@ -100,13 +104,13 @@ main = do B.getContents >>= valAndExit validate ValidateYAMLOpts { vInput = Just (FileInput file) } -> B.readFile file >>= valAndExit validate - ValidateTarballs vopts -> case vopts of + ValidateTarballs vopts urlSubstr -> case vopts of ValidateYAMLOpts { vInput = Nothing } -> - B.getContents >>= valAndExit validateTarballs + B.getContents >>= valAndExit (validateTarballs urlSubstr) ValidateYAMLOpts { vInput = Just StdInput } -> - B.getContents >>= valAndExit validateTarballs + B.getContents >>= valAndExit (validateTarballs urlSubstr) ValidateYAMLOpts { vInput = Just (FileInput file) } -> - B.readFile file >>= valAndExit validateTarballs + B.readFile file >>= valAndExit (validateTarballs urlSubstr) pure () where diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 38a6e39..8f28153 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,10 +32,12 @@ import Optics import System.Exit import System.IO import Text.ParserCombinators.ReadP +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 @@ -164,23 +168,20 @@ validateTarballs :: ( Monad m , MonadUnliftIO m , MonadMask m ) - => GHCupDownloads + => Maybe T.Text + -> GHCupDownloads -> m ExitCode -validateTarballs dls = do +validateTarballs urlSubstr 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 . filter matchingUrl $ + dls ^.. each % each % (viSourceDL % _Just `summing` viArch % each % each % each) + matchingUrl dli = case urlSubstr of + Nothing -> True + Just sub -> E.encodeUtf8 sub `B.isInfixOf` serializeURIRef' (_dlUri dli) + forM_ dlis $ downloadAll -- exit e <- liftIO $ readIORef ref diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index bb4ca18..a9864c9 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -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.