Merge remote-tracking branch 'origin/merge-requests/56'

This commit is contained in:
Julian Ospald 2021-01-02 15:57:18 +08:00
commit 28b4737758
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
4 changed files with 52 additions and 30 deletions

View File

@ -14,6 +14,7 @@ import GHCup.Types
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils.Logger import GHCup.Utils.Logger
import Data.Char ( toLower )
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) ) import Data.Semigroup ( (<>) )
#endif #endif
@ -21,6 +22,7 @@ import Options.Applicative hiding ( style )
import System.Console.Pretty import System.Console.Pretty
import System.Exit import System.Exit
import System.IO ( stdout ) import System.IO ( stdout )
import Text.Regex.Posix
import Validate import Validate
import qualified Data.ByteString as B import qualified Data.ByteString as B
@ -32,7 +34,7 @@ data Options = Options
} }
data Command = ValidateYAML ValidateYAMLOpts data Command = ValidateYAML ValidateYAMLOpts
| ValidateTarballs ValidateYAMLOpts | ValidateTarballs ValidateYAMLOpts TarballFilter
data Input data Input
@ -63,6 +65,22 @@ data ValidateYAMLOpts = ValidateYAMLOpts
validateYAMLOpts :: Parser ValidateYAMLOpts validateYAMLOpts :: Parser ValidateYAMLOpts
validateYAMLOpts = ValidateYAMLOpts <$> optional inputP 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 :: Parser Options
opts = Options <$> com opts = Options <$> com
@ -78,11 +96,9 @@ com = subparser
) )
<> (command <> (command
"check-tarballs" "check-tarballs"
( ValidateTarballs (info
<$> (info ((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
(validateYAMLOpts <**> helper) (progDesc "Validate all tarballs (download and checksum)")
(progDesc "Validate all tarballs (download and checksum)")
)
) )
) )
) )
@ -100,13 +116,13 @@ main = do
B.getContents >>= valAndExit validate B.getContents >>= valAndExit validate
ValidateYAMLOpts { vInput = Just (FileInput file) } -> ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit validate B.readFile file >>= valAndExit validate
ValidateTarballs vopts -> case vopts of ValidateTarballs vopts tarballFilter -> case vopts of
ValidateYAMLOpts { vInput = Nothing } -> ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit validateTarballs B.getContents >>= valAndExit (validateTarballs tarballFilter)
ValidateYAMLOpts { vInput = Just StdInput } -> ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit validateTarballs B.getContents >>= valAndExit (validateTarballs tarballFilter)
ValidateYAMLOpts { vInput = Just (FileInput file) } -> ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit validateTarballs B.readFile file >>= valAndExit (validateTarballs tarballFilter)
pure () pure ()
where where

View File

@ -7,6 +7,7 @@ module Validate where
import GHCup import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Utils.Logger import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ import GHCup.Utils.Version.QQ
@ -21,6 +22,7 @@ import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.Trans.Resource ( runResourceT import Control.Monad.Trans.Resource ( runResourceT
, MonadUnliftIO , MonadUnliftIO
) )
import Data.Containers.ListUtils ( nubOrd )
import Data.IORef import Data.IORef
import Data.List import Data.List
import Data.String.Interpolate import Data.String.Interpolate
@ -30,6 +32,7 @@ import Optics
import System.Exit import System.Exit
import System.IO import System.IO
import Text.ParserCombinators.ReadP import Text.ParserCombinators.ReadP
import Text.Regex.Posix
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
@ -157,6 +160,11 @@ validate dls = do
isBase (Base _) = True isBase (Base _) = True
isBase _ = False isBase _ = False
data TarballFilter = TarballFilter
{ tfTool :: Maybe Tool
, tfVersion :: Regex
}
validateTarballs :: ( Monad m validateTarballs :: ( Monad m
, MonadLogger m , MonadLogger m
, MonadThrow m , MonadThrow m
@ -164,23 +172,20 @@ validateTarballs :: ( Monad m
, MonadUnliftIO m , MonadUnliftIO m
, MonadMask m , MonadMask m
) )
=> GHCupDownloads => TarballFilter
-> GHCupDownloads
-> m ExitCode -> m ExitCode
validateTarballs dls = do validateTarballs (TarballFilter tool versionRegex) dls = do
ref <- liftIO $ newIORef 0 ref <- liftIO $ newIORef 0
flip runReaderT ref $ do flip runReaderT ref $ do
-- download/verify all binary tarballs -- download/verify all tarballs
let let dlis = nubOrd $ dls ^.. each
dlbis = nub $ join $ (M.elems dls) <&> \versions -> %& indices (maybe (const True) (==) tool) %> each
join $ (M.elems versions) <&> \vi -> %& indices (matchTest versionRegex . T.unpack . prettyVer)
join $ (M.elems $ _viArch vi) <&> \pspecs -> % (viSourceDL % _Just `summing` viArch % each % each % each)
join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs) when (null dlis) $ $(logError) [i|no tarballs selected by filter|] *> addError
forM_ dlbis $ downloadAll forM_ dlis $ downloadAll
let dlsrc = nub $ join $ (M.elems dls) <&> \versions ->
join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL
forM_ dlsrc $ downloadAll
-- exit -- exit
e <- liftIO $ readIORef ref e <- liftIO $ readIORef ref
@ -191,13 +196,13 @@ validateTarballs dls = do
pure ExitSuccess pure ExitSuccess
where where
runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())
}
downloadAll dli = do downloadAll dli = do
dirs <- liftIO getDirs dirs <- liftIO getDirs
let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings 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 <- r <-
runLogger runLogger

View File

@ -431,6 +431,7 @@ executable ghcup-gen
, optics , optics
, optparse-applicative , optparse-applicative
, pretty-terminal , pretty-terminal
, regex-posix
, resourcet , resourcet
, safe-exceptions , safe-exceptions
, string-interpolate , string-interpolate

View File

@ -79,7 +79,7 @@ data Tool = GHC
| Cabal | Cabal
| GHCup | GHCup
| HLS | HLS
deriving (Eq, GHC.Generic, Ord, Show) deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
-- | All necessary information of a tool version, including -- | All necessary information of a tool version, including
@ -172,7 +172,7 @@ data DownloadInfo = DownloadInfo
, _dlSubdir :: Maybe TarDir , _dlSubdir :: Maybe TarDir
, _dlHash :: Text , _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. -- | How to descend into a tar archive.
data TarDir = RealDir (Path Rel) data TarDir = RealDir (Path Rel)
| RegexDir String -- ^ will be compiled to regex, the first match will "win" | 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. -- | Where to fetch GHCupDownloads from.