diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs
index 7f80d1110a2bd462ea0c0563a2f1cf547cd69e37..74fbc03337eac9e01acb6aaa9dfff371d3827dfe 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 "<tool>-<version>" <> value def
+ <> help "Only check certain tarballs (format: <tool>-<version>)"
+ 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 38a6e3988a18f17fa18d96343fa7a9ca88bca61f..c3f689c41953f93dd95284b011e9b699942ba370 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 78772c36b4170717f7dbb9a47885c9da4cb7b831..ef771187e6e156281e45c09b704865e05f78e3f4 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 bb4ca1873207ad5bedc3a9891cd7562f0be24017..761ca10c70b5302430e46e2c4d9362f7e0b8ef0f 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.