Fix subdir validation
This commit is contained in:
parent
7acba3cd1e
commit
bcc2ced30a
@ -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 ()
|
||||||
|
Loading…
Reference in New Issue
Block a user