ghcup-metadata/ghcup-gen/Validate.hs

296 lines
11 KiB
Haskell
Raw Normal View History

2021-10-27 13:04:49 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Validate where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
2023-01-13 04:38:23 +00:00
import GHCup.Prelude.Logger
import GHCup.Prelude.Version.QQ
2021-10-27 13:04:49 +00:00
import Codec.Archive
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class ( lift )
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.Versions
import Haskus.Utils.Variant.Excepts
import Optics
import System.FilePath
import System.Exit
import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Version as V
data ValidationError = InternalError String
deriving Show
instance Exception ValidationError
addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
addError = do
ref <- ask
liftIO $ modifyIORef ref (+ 1)
2022-03-08 21:22:36 +00:00
validate :: ( Monad m
, MonadReader env m
, HasLog env
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
, HasGHCupInfo env
)
=> m ExitCode
validate = do
GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo
2021-10-27 13:04:49 +00:00
ref <- liftIO $ newIORef 0
-- verify binary downloads --
flip runReaderT ref $ do
-- unique tags
forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
-- required platforms
forM_ (M.toList dls) $ \(t, versions) ->
forM_ (M.toList versions) $ \(v, vi) ->
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
checkHasRequiredPlatforms t v (_viTags vi) arch (M.keys pspecs)
checkGHCVerIsValid
forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
_ <- checkGHCHasBaseVersion
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
lift $ logInfo "All good"
pure ExitSuccess
where
checkHasRequiredPlatforms t v tags arch pspecs = do
let v' = prettyVer v
arch' = prettyShow arch
when (Linux UnknownLinux `notElem` pspecs) $ do
lift $ logError $
"Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
when ((Darwin `notElem` pspecs) && arch == A_64) $ do
lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
when ((FreeBSD `notElem` pspecs) && arch == A_64) $ lift $ logWarn $
"FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
when (Windows `notElem` pspecs && arch == A_64) $ do
lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
-- alpine needs to be set explicitly, because
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
-- (although it could be static)
when (Linux Alpine `notElem` pspecs) $
case t of
GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
Cabal | v > [vver|2.4.1.0|]
, arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
GHC | Latest `elem` tags || Recommended `elem` tags
, arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))
2021-10-27 13:04:49 +00:00
_ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
checkUniqueTags tool = do
2022-03-08 21:22:36 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-10-27 13:04:49 +00:00
let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
let nonUnique =
fmap fst
. filter (\(_, b) -> not b)
<$> ( mapM
(\case
[] -> throwM $ InternalError "empty inner list"
(t : ts) ->
pure $ (t, ) (not (isUniqueTag t) || null ts)
)
. group
. sort
$ allTags
)
case join nonUnique of
[] -> pure ()
xs -> do
lift $ logError $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
addError
where
isUniqueTag Latest = True
isUniqueTag Recommended = True
isUniqueTag Old = False
isUniqueTag Prerelease = False
isUniqueTag (Base _) = False
isUniqueTag (UnknownTag _) = False
checkGHCVerIsValid = do
2022-03-08 21:22:36 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-10-27 13:04:49 +00:00
let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
forM_ ghcVers $ \v ->
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
[_] -> pure ()
_ -> do
lift $ logError $ "GHC version " <> prettyVer v <> " is not valid"
addError
-- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do
2022-03-08 21:22:36 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-10-27 13:04:49 +00:00
let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
forM_ [Latest, Recommended] $ \t -> case t `elem` allTags of
False -> do
lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
addError
True -> pure ()
-- all GHC versions must have a base tag
checkGHCHasBaseVersion = do
2022-03-08 21:22:36 +00:00
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2021-10-27 13:04:49 +00:00
let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
False -> do
lift $ logError $ "Base tag missing from GHC ver " <> prettyVer ver
addError
True -> pure ()
isBase (Base _) = True
isBase _ = False
data TarballFilter = TarballFilter
{ tfTool :: Either GlobalTool (Maybe Tool)
, tfVersion :: Regex
}
validateTarballs :: ( Monad m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
, MonadMask m
, Alternative m
, MonadFail m
2022-03-08 21:22:36 +00:00
, HasGHCupInfo env
2021-10-27 13:04:49 +00:00
)
=> TarballFilter
-> m ExitCode
2022-03-08 21:22:36 +00:00
validateTarballs (TarballFilter etool versionRegex) = do
GHCupInfo { _ghcupDownloads = dls, _globalTools = gt } <- getGHCupInfo
2021-10-27 13:04:49 +00:00
ref <- liftIO $ newIORef 0
-- download/verify all tarballs
2023-01-30 10:05:47 +00:00
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool)
%> each %& indices (matchTest versionRegex . T.unpack . prettyVer)
2023-01-30 10:35:51 +00:00
% (viTestDL % _Just `summing` viSourceDL % _Just `summing` viArch % each % each % each)
2023-01-30 10:05:47 +00:00
)
etool
2021-10-27 13:04:49 +00:00
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)
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
logInfo "All good"
pure ExitSuccess
where
downloadAll :: ( MonadUnliftIO m
, MonadIO m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
, MonadCatch m
, MonadMask m
, MonadThrow m
)
=> IORef Int
-> DownloadInfo
-> m ()
downloadAll ref dli = do
r <- runResourceT
. runE @'[DigestError
, GPGError
, DownloadFailed
, UnknownArchive
, ArchiveResult
2023-01-13 04:38:23 +00:00
, ContentLengthError
2021-10-27 13:04:49 +00:00
]
$ do
case etool of
Right (Just GHCup) -> do
tmpUnpack <- lift mkGhcupTmpDir
2023-01-13 04:38:23 +00:00
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) Nothing (fromGHCupPath tmpUnpack) Nothing False
2021-10-27 13:04:49 +00:00
pure Nothing
Right _ -> do
p <- liftE $ downloadCached dli Nothing
2023-01-30 10:05:47 +00:00
fmap Just $ liftE
. getArchiveFiles
$ p
2021-10-27 13:04:49 +00:00
Left ShimGen -> do
tmpUnpack <- lift mkGhcupTmpDir
2023-01-13 04:38:23 +00:00
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) Nothing (fromGHCupPath tmpUnpack) Nothing False
2021-10-27 13:04:49 +00:00
pure Nothing
case r of
2023-01-30 10:05:47 +00:00
VRight (Just entries) -> do
2021-10-27 13:04:49 +00:00
case _dlSubdir dli of
Just (RealDir prel) -> do
logInfo
$ " verifying subdir: " <> T.pack prel
2023-01-30 10:05:47 +00:00
when (normalise prel `notElem` fmap (normalise . takeDirectory) entries) $ do
2021-10-27 13:04:49 +00:00
logError $
2023-01-30 10:05:47 +00:00
"Subdir doesn't match: expected " <> T.pack prel
2021-10-27 13:04:49 +00:00
runReaderT addError ref
Just (RegexDir regexString) -> do
logInfo $
"verifying subdir (regex): " <> T.pack regexString
let regex = makeRegexOpts
compIgnoreCase
execBlank
regexString
2023-01-30 10:05:47 +00:00
unless (or $ fmap (match regex. normalise) entries) $ do
2021-10-27 13:04:49 +00:00
logError $
2023-01-30 10:05:47 +00:00
"Subdir doesn't match: expected regex " <> T.pack regexString
2021-10-27 13:04:49 +00:00
runReaderT addError ref
Nothing -> pure ()
VRight Nothing -> pure ()
VLeft e -> do
logError $
"Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
runReaderT addError ref