From 8944ed6e36e994286f0e8a80cd14e3df7e6db13b Mon Sep 17 00:00:00 2001 From: amesgen Date: Fri, 1 Jan 2021 05:45:58 +0100 Subject: [PATCH 1/5] allow to filter tarball validation by a URL substring also, use nubOrd for linearithmic instead of quadratic complexity --- app/ghcup-gen/Main.hs | 24 ++++++++++++++---------- app/ghcup-gen/Validate.hs | 27 ++++++++++++++------------- lib/GHCup/Types.hs | 4 ++-- 3 files changed, 30 insertions(+), 25 deletions(-) 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. From 56569a06983a061ba5e393f5950fbd9b35e6828c Mon Sep 17 00:00:00 2001 From: amesgen Date: Sat, 2 Jan 2021 05:05:05 +0100 Subject: [PATCH 2/5] use regex instead of substring --- app/ghcup-gen/Main.hs | 22 +++++++++++----------- app/ghcup-gen/Validate.hs | 10 +++++----- ghcup.cabal | 1 + 3 files changed, 17 insertions(+), 16 deletions(-) diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs index 38d89c9..0ad34ca 100644 --- a/app/ghcup-gen/Main.hs +++ b/app/ghcup-gen/Main.hs @@ -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 diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 8f28153..6ea8693 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -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 diff --git a/ghcup.cabal b/ghcup.cabal index 78772c3..ef77118 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 From 62d5d53232943e77dae033076b35c7be5c82339a Mon Sep 17 00:00:00 2001 From: amesgen Date: Sat, 2 Jan 2021 05:53:11 +0100 Subject: [PATCH 3/5] filter tool and version instead of URL --- app/ghcup-gen/Main.hs | 29 +++++++++++++++++++---------- app/ghcup-gen/Validate.hs | 19 +++++++++++-------- 2 files changed, 30 insertions(+), 18 deletions(-) diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs index 0ad34ca..6650f76 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 Control.Monad #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ( (<>) ) #endif @@ -33,7 +34,7 @@ data Options = Options } data Command = ValidateYAML ValidateYAMLOpts - | ValidateTarballs ValidateYAMLOpts (Maybe Regex) + | ValidateTarballs ValidateYAMLOpts TarballFilter data Input @@ -64,10 +65,18 @@ data ValidateYAMLOpts = ValidateYAMLOpts validateYAMLOpts :: Parser ValidateYAMLOpts validateYAMLOpts = ValidateYAMLOpts <$> optional inputP -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" +tarballFilterP :: Parser TarballFilter +tarballFilterP = option readm $ + long "tarball-filter" <> short 'u' <> metavar "-" <> value def + <> help "Only check certain tarballs (format: -, where 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 = Options <$> com @@ -85,7 +94,7 @@ com = subparser <> (command "check-tarballs" (info - ((ValidateTarballs <$> validateYAMLOpts <*> urlRegexP) <**> helper) + ((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper) (progDesc "Validate all tarballs (download and checksum)") ) ) @@ -104,13 +113,13 @@ main = do B.getContents >>= valAndExit validate ValidateYAMLOpts { vInput = Just (FileInput file) } -> B.readFile file >>= valAndExit validate - ValidateTarballs vopts urlRegex -> case vopts of + ValidateTarballs vopts tarballFilter -> case vopts of ValidateYAMLOpts { vInput = Nothing } -> - B.getContents >>= valAndExit (validateTarballs urlRegex) + B.getContents >>= valAndExit (validateTarballs tarballFilter) ValidateYAMLOpts { vInput = Just StdInput } -> - B.getContents >>= valAndExit (validateTarballs urlRegex) + B.getContents >>= valAndExit (validateTarballs tarballFilter) ValidateYAMLOpts { vInput = Just (FileInput file) } -> - B.readFile file >>= valAndExit (validateTarballs urlRegex) + B.readFile file >>= valAndExit (validateTarballs tarballFilter) pure () where diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index 6ea8693..a6c826c 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -33,7 +33,6 @@ 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 @@ -161,6 +160,11 @@ validate dls = do isBase (Base _) = True isBase _ = False +data TarballFilter = TarballFilter + { tfTool :: Regex + , tfVersion :: Regex + } + validateTarballs :: ( Monad m , MonadLogger m , MonadThrow m @@ -168,19 +172,18 @@ validateTarballs :: ( Monad m , MonadUnliftIO m , MonadMask m ) - => Maybe Regex + => TarballFilter -> GHCupDownloads -> m ExitCode -validateTarballs urlRegex dls = do +validateTarballs (TarballFilter toolRegex versionRegex) 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 urlRegex of - Nothing -> True - Just r -> matchTest r $ serializeURIRef' (_dlUri dli) + let dlis = nubOrd $ dls ^.. each + %& indices (matchTest toolRegex . show) %> each + %& indices (matchTest versionRegex . T.unpack . prettyVer) + % (viSourceDL % _Just `summing` viArch % each % each % each) forM_ dlis $ downloadAll -- exit From 53db68e39f0d484e1a4fd8b6e2b2397b0fba784a Mon Sep 17 00:00:00 2001 From: amesgen Date: Sat, 2 Jan 2021 07:58:08 +0100 Subject: [PATCH 4/5] minor tarball filter format change --- app/ghcup-gen/Main.hs | 17 ++++++++++------- app/ghcup-gen/Validate.hs | 6 +++--- lib/GHCup/Types.hs | 2 +- 3 files changed, 14 insertions(+), 11 deletions(-) diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs index 6650f76..74fbc03 100644 --- a/app/ghcup-gen/Main.hs +++ b/app/ghcup-gen/Main.hs @@ -14,7 +14,7 @@ import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Utils.Logger -import Control.Monad +import Data.Char ( toLower ) #if !MIN_VERSION_base(4,13,0) import Data.Semigroup ( (<>) ) #endif @@ -68,15 +68,18 @@ validateYAMLOpts = ValidateYAMLOpts <$> optional inputP tarballFilterP :: Parser TarballFilter tarballFilterP = option readm $ long "tarball-filter" <> short 'u' <> metavar "-" <> value def - <> help "Only check certain tarballs (format: -, where is GHC by default)" + <> help "Only check certain tarballs (format: -)" where - def = join TarballFilter $ makeRegex ("" :: String) + def = TarballFilter Nothing (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 + 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 diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index a6c826c..bdea1fe 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -161,7 +161,7 @@ validate dls = do isBase _ = False data TarballFilter = TarballFilter - { tfTool :: Regex + { tfTool :: Maybe Tool , tfVersion :: Regex } @@ -175,13 +175,13 @@ validateTarballs :: ( Monad m => TarballFilter -> GHCupDownloads -> m ExitCode -validateTarballs (TarballFilter toolRegex versionRegex) dls = do +validateTarballs (TarballFilter tool versionRegex) dls = do ref <- liftIO $ newIORef 0 flip runReaderT ref $ do -- download/verify all tarballs let dlis = nubOrd $ dls ^.. each - %& indices (matchTest toolRegex . show) %> each + %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each) forM_ dlis $ downloadAll diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index a9864c9..761ca10 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 From 5c43ff4c9ecf2a07ba9a99bf274cf99f4c89e673 Mon Sep 17 00:00:00 2001 From: amesgen Date: Sat, 2 Jan 2021 08:51:57 +0100 Subject: [PATCH 5/5] error if we check nothing --- app/ghcup-gen/Validate.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index bdea1fe..c3f689c 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -184,6 +184,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do %& 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 @@ -195,13 +196,13 @@ validateTarballs (TarballFilter tool versionRegex) 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