Update ghcup-gen
This commit is contained in:
parent
174ff702a5
commit
dc6d43ddba
@ -7,7 +7,7 @@ package ghcup
|
||||
source-repository-package
|
||||
type: git
|
||||
location: https://github.com/haskell/ghcup-hs.git
|
||||
tag: e27fed09f3eb4b0b72ce7825c65f16a4202a2399
|
||||
tag: b1106985ec1173a0122f2781719e9bb1a85de257
|
||||
|
||||
constraints: http-io-streams -brotli,
|
||||
any.aeson >= 2.0.1.0
|
||||
|
@ -135,15 +135,13 @@ tarballFilterP = option readm $
|
||||
long "tarball-filter" <> short 'u' <> metavar "<tool>-<version>" <> value def
|
||||
<> help "Only check certain tarballs (format: <tool>-<version>)"
|
||||
where
|
||||
def = TarballFilter (Right Nothing) (makeRegex ("" :: String))
|
||||
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 ] ->
|
||||
pure (TarballFilter $ Right $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
|
||||
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
|
||||
pure (TarballFilter $ Left tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
|
||||
pure (TarballFilter $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
|
||||
_ -> fail "invalid tool"
|
||||
low = fmap toLower
|
||||
|
||||
@ -206,7 +204,7 @@ main = do
|
||||
flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e
|
||||
liftIO $ exitWith (ExitFailure 2)
|
||||
|
||||
let appstate = AppState (Settings True 0 Lax False Never Curl True GHCupURL False GPGNone True Nothing (DM mempty)) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
|
||||
let appstate = AppState (Settings True 0 Lax False Never Curl True GHCupURL False GPGNone True Nothing (DM mempty)) dirs defaultKeyBindings (GHCupInfo mempty mempty Nothing) pfreq loggerConfig
|
||||
|
||||
let withValidateYamlOpts vopts f = case vopts of
|
||||
ValidateYAMLOpts { vInput = Nothing } ->
|
||||
|
@ -207,7 +207,7 @@ validate distroChannel = do
|
||||
isBase _ = False
|
||||
|
||||
data TarballFilter = TarballFilter
|
||||
{ tfTool :: Either GlobalTool (Maybe Tool)
|
||||
{ tfTool :: Maybe Tool
|
||||
, tfVersion :: Regex
|
||||
}
|
||||
|
||||
@ -226,20 +226,16 @@ validateTarballs :: ( Monad m
|
||||
)
|
||||
=> TarballFilter
|
||||
-> m ExitCode
|
||||
validateTarballs (TarballFilter etool versionRegex) = do
|
||||
GHCupInfo { _ghcupDownloads = dls, _globalTools = gt } <- getGHCupInfo
|
||||
validateTarballs (TarballFilter mtool versionRegex) = do
|
||||
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
|
||||
ref <- liftIO $ newIORef 0
|
||||
|
||||
-- download/verify all tarballs
|
||||
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool)
|
||||
%> each %& indices (matchTest versionRegex . T.unpack . prettyVer . _tvVersion)
|
||||
% (viTestDL % _Just `summing` viSourceDL % _Just `summing` viArch % each % each % each)
|
||||
)
|
||||
etool
|
||||
let gdlis = nubOrd $ gt ^.. each
|
||||
let allDls = either (const gdlis) (const dlis) etool
|
||||
when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref
|
||||
forM_ allDls (downloadAll ref)
|
||||
let dlis = nubOrd $ dls ^.. each %& indices (maybe (const True) (==) mtool)
|
||||
%> each %& indices (matchTest versionRegex . T.unpack . prettyVer . _tvVersion)
|
||||
% (viTestDL % _Just `summing` viSourceDL % _Just `summing` viArch % each % each % each)
|
||||
when (null dlis) $ logError "no tarballs selected by filter" *> runReaderT addError ref
|
||||
forM_ dlis (downloadAll ref)
|
||||
|
||||
-- exit
|
||||
e <- liftIO $ readIORef ref
|
||||
@ -273,20 +269,16 @@ validateTarballs (TarballFilter etool versionRegex) = do
|
||||
, ContentLengthError
|
||||
]
|
||||
$ do
|
||||
case etool of
|
||||
Right (Just GHCup) -> do
|
||||
case mtool of
|
||||
(Just GHCup) -> do
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) Nothing (fromGHCupPath tmpUnpack) Nothing False
|
||||
pure Nothing
|
||||
Right _ -> do
|
||||
_ -> do
|
||||
p <- liftE $ downloadCached dli Nothing
|
||||
fmap Just $ liftE
|
||||
. getArchiveFiles
|
||||
$ p
|
||||
Left ShimGen -> do
|
||||
tmpUnpack <- lift mkGhcupTmpDir
|
||||
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) Nothing (fromGHCupPath tmpUnpack) Nothing False
|
||||
pure Nothing
|
||||
case r of
|
||||
VRight (Just entries) -> do
|
||||
case _dlSubdir dli of
|
||||
|
@ -65,5 +65,5 @@ executable ghcup-gen
|
||||
, safe-exceptions ^>=0.1
|
||||
, text ^>=2.0
|
||||
, transformers ^>=0.5
|
||||
, versions >=4.0.1 && <5.1
|
||||
, versions >=6.0.0
|
||||
, yaml-streamly ^>=0.12.0
|
||||
|
Loading…
Reference in New Issue
Block a user