allow to filter tarball validation by a URL substring

also, use nubOrd for linearithmic instead of quadratic complexity

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
-       <$> (info
+         ((ValidateTarballs <$> validateYAMLOpts <*> urlSubstrP) <**> helper)
-             (validateYAMLOpts <**> helper)
+         (progDesc "Validate all tarballs (download and checksum)")
-             (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

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
+     -- download/verify all tarballs
-    let
+    let dlis = nubOrd . filter matchingUrl $
-      dlbis = nub $ join $ (M.elems dls) <&> \versions ->
+          dls ^.. each % each % (viSourceDL % _Just `summing` viArch % each % each % each)
-        join $ (M.elems versions) <&> \vi ->
+        matchingUrl dli = case urlSubstr of
-          join $ (M.elems $ _viArch vi) <&> \pspecs ->
+          Nothing -> True
-            join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs)
+          Just sub -> E.encodeUtf8 sub `B.isInfixOf` serializeURIRef' (_dlUri dli)
-    forM_ dlbis $ downloadAll
+    forM_ dlis $ downloadAll
-
-    let dlsrc = nub $ join $ (M.elems dls) <&> \versions ->
-          join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL
-    forM_ dlsrc $ downloadAll
 
     -- exit
     e <- liftIO $ readIORef ref

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.