ghcup-hs/app/ghcup-gen/Validate.hs

279 lines
9.2 KiB
Haskell
Raw Normal View History

2021-04-02 14:54:27 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
2021-04-02 14:54:27 +00:00
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
2020-01-11 20:15:05 +00:00
module Validate where
import GHCup
import GHCup.Download
2021-04-02 14:54:27 +00:00
import GHCup.Errors
2020-01-11 20:15:05 +00:00
import GHCup.Types
import GHCup.Types.Optics
2021-04-02 14:54:27 +00:00
import GHCup.Utils
2020-01-11 20:15:05 +00:00
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
2020-01-11 20:15:05 +00:00
2021-04-02 14:54:27 +00:00
#if defined(TAR)
import qualified Codec.Archive.Tar as Tar
#else
import Codec.Archive
#endif
2020-01-11 20:15:05 +00:00
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
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 )
2020-01-11 20:15:05 +00:00
import Data.IORef
import Data.List
import Data.String.Interpolate
import Data.Versions
import HPath ( toFilePath, rel )
2020-01-11 20:15:05 +00:00
import Haskus.Utils.Variant.Excepts
import Optics
import System.Exit
import System.IO
2021-04-02 14:54:27 +00:00
import System.Posix.FilePath
2020-04-25 10:06:41 +00:00
import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow )
2021-01-02 04:05:05 +00:00
import Text.Regex.Posix
2020-01-11 20:15:05 +00:00
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
2020-04-25 10:06:41 +00:00
import qualified Data.Text as T
import qualified Data.Version as V
2020-01-11 20:15:05 +00:00
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)
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads
-> m ExitCode
validate dls = do
ref <- liftIO $ newIORef 0
2020-09-15 15:44:30 +00:00
-- verify binary downloads --
2020-01-11 20:15:05 +00:00
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)
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
checkGHCVerIsValid
2020-01-11 20:15:05 +00:00
forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
_ <- checkGHCHasBaseVersion
2020-01-11 20:15:05 +00:00
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) [i|All good|]
pure ExitSuccess
where
checkHasRequiredPlatforms t v tags arch pspecs = do
2020-01-11 20:15:05 +00:00
let v' = prettyVer v
arch' = prettyShow arch
2021-03-11 16:03:51 +00:00
when (notElem (Linux UnknownLinux) pspecs) $ do
2020-01-11 20:15:05 +00:00
lift $ $(logError)
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch'}|]
2020-01-11 20:15:05 +00:00
addError
2021-03-11 16:03:51 +00:00
when ((notElem Darwin pspecs) && arch == A_64) $ do
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch'}|]
2020-01-11 20:15:05 +00:00
addError
2021-03-11 16:03:51 +00:00
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn)
[i|FreeBSD missing for #{t} #{v'} #{arch'}|]
2020-01-11 20:15:05 +00:00
-- alpine needs to be set explicitly, because
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
-- (although it could be static)
2021-03-11 16:03:51 +00:00
when (notElem (Linux Alpine) pspecs) $
case t of
2021-03-11 16:03:51 +00:00
GHCup | arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch}|]) >> addError
2021-02-24 14:19:29 +00:00
Cabal | v > [vver|2.4.1.0|]
2021-03-11 16:03:51 +00:00
, arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]) >> addError
2021-02-24 14:19:29 +00:00
GHC | Latest `elem` tags || Recommended `elem` tags
2021-03-11 16:03:51 +00:00
, arch `elem` [A_64, A_32] -> lift ($(logError) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|])
_ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]
2020-01-11 20:15:05 +00:00
checkUniqueTags tool = do
2020-04-21 21:37:48 +00:00
let allTags = join $ M.elems $ availableToolVersions dls tool
2020-01-11 20:15:05 +00:00
let nonUnique =
fmap fst
. filter (\(_, b) -> not b)
<$> ( mapM
(\case
[] -> throwM $ InternalError "empty inner list"
(t : ts) ->
2021-03-11 16:03:51 +00:00
pure $ (t, ) (not (isUniqueTag t) || null ts)
2020-01-11 20:15:05 +00:00
)
. group
. sort
$ allTags
)
case join nonUnique of
[] -> pure ()
xs -> do
lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|]
addError
where
isUniqueTag Latest = True
isUniqueTag Recommended = True
isUniqueTag Old = False
2020-07-28 18:55:00 +00:00
isUniqueTag Prerelease = False
isUniqueTag (Base _) = False
isUniqueTag (UnknownTag _) = False
2020-01-11 20:15:05 +00:00
2020-04-25 10:06:41 +00:00
checkGHCVerIsValid = do
2020-01-11 20:15:05 +00:00
let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
2020-04-25 10:06:41 +00:00
forM_ ghcVers $ \v ->
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
[_] -> pure ()
_ -> do
lift $ $(logError) [i|GHC version #{v} is not valid |]
addError
2020-01-11 20:15:05 +00:00
-- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do
2020-04-21 21:37:48 +00:00
let allTags = join $ M.elems $ availableToolVersions dls tool
2020-01-11 20:15:05 +00:00
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do
lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
addError
True -> pure ()
-- all GHC versions must have a base tag
checkGHCHasBaseVersion = do
let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, tags) -> case any isBase tags of
False -> do
lift $ $(logError) [i|Base tag missing from GHC ver #{ver}|]
addError
True -> pure ()
isBase (Base _) = True
isBase _ = False
2020-01-11 20:15:05 +00:00
2021-01-02 04:53:11 +00:00
data TarballFilter = TarballFilter
2021-01-02 06:58:08 +00:00
{ tfTool :: Maybe Tool
2021-01-02 04:53:11 +00:00
, tfVersion :: Regex
}
2020-01-11 20:15:05 +00:00
validateTarballs :: ( Monad m
, MonadLogger m
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
, MonadMask m
)
2021-01-02 04:53:11 +00:00
=> TarballFilter
-> GHCupDownloads
2020-01-11 20:15:05 +00:00
-> m ExitCode
2021-01-02 06:58:08 +00:00
validateTarballs (TarballFilter tool versionRegex) dls = do
2020-01-11 20:15:05 +00:00
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- download/verify all tarballs
2021-01-02 04:53:11 +00:00
let dlis = nubOrd $ dls ^.. each
2021-01-02 06:58:08 +00:00
%& indices (maybe (const True) (==) tool) %> each
2021-01-02 04:53:11 +00:00
%& indices (matchTest versionRegex . T.unpack . prettyVer)
% (viSourceDL % _Just `summing` viArch % each % each % each)
2021-01-02 07:51:57 +00:00
when (null dlis) $ $(logError) [i|no tarballs selected by filter|] *> addError
2021-03-11 16:03:51 +00:00
forM_ dlis downloadAll
2020-01-11 20:15:05 +00:00
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) [i|All good|]
pure ExitSuccess
where
2021-01-02 07:51:57 +00:00
runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
2021-03-11 16:03:51 +00:00
, rawOutter = \_ -> pure ()
2021-01-02 07:51:57 +00:00
}
2020-01-11 20:15:05 +00:00
downloadAll dli = do
dirs <- liftIO getDirs
2020-10-25 13:17:17 +00:00
let settings = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings
2020-01-11 20:15:05 +00:00
r <-
runLogger
. flip runReaderT settings
. runResourceT
2021-04-02 14:54:27 +00:00
. runE @'[DigestError
, DownloadFailed
, UnknownArchive
#if defined(TAR)
, Tar.FormatError
#else
, ArchiveResult
#endif
]
$ do
case tool of
Just GHCup -> do
let fn = [rel|ghcup|]
dir <- liftIO ghcupCacheDir
p <- liftE $ download dli dir (Just fn)
liftE $ checkDigest dli p
pure Nothing
_ -> do
p <- liftE $ downloadCached dli Nothing
fmap (Just . head . splitDirectories . head)
. liftE
. getArchiveFiles
$ p
2020-01-11 20:15:05 +00:00
case r of
VRight (Just basePath) -> do
2021-04-02 14:54:27 +00:00
case _dlSubdir dli of
Just (RealDir (toFilePath -> prel)) -> do
lift $ $(logInfo)
[i|verifying subdir: #{prel}|]
when (basePath /= prel) $ do
lift $ $(logError)
[i|Subdir doesn't match: expected "#{prel}", got "#{basePath}"|]
addError
Just (RegexDir regexString) -> do
lift $ $(logInfo)
[i|verifying subdir (regex): #{regexString}|]
let regex = makeRegexOpts
compIgnoreCase
execBlank
regexString
when (not (match regex basePath)) $ do
lift $ $(logError)
[i|Subdir doesn't match: expected regex "#{regexString}", got "#{basePath}"|]
addError
Nothing -> pure ()
VRight Nothing -> pure ()
2020-01-11 20:15:05 +00:00
VLeft e -> do
lift $ $(logError)
2021-04-24 19:51:06 +00:00
[i|Could not download (or verify hash) of #{dli}, Error was: #{prettyShow e}|]
2020-01-11 20:15:05 +00:00
addError