hasufell/ghcup-metadata
1
1
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fix subdir validation

Browse Source
This commit is contained in:
Julian Ospald 2023-01-30 18:05:47 +08:00
parent 7acba3cd1e
commit bcc2ced30a
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
1 changed files with 13 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
ghcup-gen/Validate.hs
View File

@ -210,7 +210,11 @@ validateTarballs (TarballFilter etool versionRegex) = do
ref <- liftIO $ newIORef 0 ref <- liftIO $ newIORef 0
-- download/verify all tarballs -- download/verify all tarballs
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool)
%> each %& indices (matchTest versionRegex . T.unpack . prettyVer)
% (viTestDL % _Just `summing` viSourceDL % _Just)
)
etool
let gdlis = nubOrd $ gt ^.. each let gdlis = nubOrd $ gt ^.. each
let allDls = either (const gdlis) (const dlis) etool let allDls = either (const gdlis) (const dlis) etool
when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref
@ -255,23 +259,22 @@ validateTarballs (TarballFilter etool versionRegex) = do
pure Nothing pure Nothing
Right _ -> do Right _ -> do
p <- liftE $ downloadCached dli Nothing p <- liftE $ downloadCached dli Nothing
fmap (Just . head . splitDirectories . head) fmap Just $ liftE
. liftE . getArchiveFiles
. getArchiveFiles $ p
$ p
Left ShimGen -> do Left ShimGen -> do
tmpUnpack <- lift mkGhcupTmpDir tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) Nothing (fromGHCupPath tmpUnpack) Nothing False _ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) Nothing (fromGHCupPath tmpUnpack) Nothing False
pure Nothing pure Nothing
case r of case r of
VRight (Just basePath) -> do VRight (Just entries) -> do
case _dlSubdir dli of case _dlSubdir dli of
Just (RealDir prel) -> do Just (RealDir prel) -> do
logInfo logInfo
$ " verifying subdir: " <> T.pack prel $ " verifying subdir: " <> T.pack prel
when (basePath /= prel) $ do when (normalise prel `notElem` fmap (normalise . takeDirectory) entries) $ do
logError $ logError $
"Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath "Subdir doesn't match: expected " <> T.pack prel
runReaderT addError ref runReaderT addError ref
Just (RegexDir regexString) -> do Just (RegexDir regexString) -> do
logInfo $ logInfo $
@ -280,9 +283,9 @@ validateTarballs (TarballFilter etool versionRegex) = do
compIgnoreCase compIgnoreCase
execBlank execBlank
regexString regexString
unless (match regex basePath) $ do unless (or $ fmap (match regex. normalise) entries) $ do
logError $ logError $
"Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath "Subdir doesn't match: expected regex " <> T.pack regexString
runReaderT addError ref runReaderT addError ref
Nothing -> pure () Nothing -> pure ()
VRight Nothing -> pure () VRight Nothing -> pure ()