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

289 lines
11 KiB
Haskell
Raw Permalink 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 #-}
2021-08-25 16:54:58 +00:00
{-# LANGUAGE OverloadedStrings #-}
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
2021-05-14 21:09:45 +00:00
import GHCup.Platform
2021-07-18 21:29:09 +00:00
import GHCup.Types hiding ( LeanAppState (..) )
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
import Codec.Archive
2021-05-14 21:09:45 +00:00
import Control.Applicative
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.Versions
import Haskus.Utils.Variant.Excepts
import Optics
2021-05-14 21:09:45 +00:00
import System.FilePath
2020-01-11 20:15:05 +00:00
import System.Exit
import System.IO
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
2021-05-14 21:09:45 +00:00
-> M.Map GlobalTool DownloadInfo
2020-01-11 20:15:05 +00:00
-> m ExitCode
2021-05-14 21:09:45 +00:00
validate dls _ = do
2020-01-11 20:15:05 +00:00
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
2021-08-25 16:54:58 +00:00
lift $ $(logInfo) "All good"
2020-01-11 20:15:05 +00:00
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
2021-08-25 16:54:58 +00:00
lift $ $(logError) $
"Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack 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
2021-08-25 16:54:58 +00:00
lift $ $(logError) $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
2020-01-11 20:15:05 +00:00
addError
2021-08-25 16:54:58 +00:00
when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn) $
"FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
2021-05-14 21:09:45 +00:00
when (notElem Windows pspecs && arch == A_64) $ do
2021-08-25 16:54:58 +00:00
lift $ $(logError) $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
2021-05-14 21:09:45 +00:00
addError
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-08-25 16:54:58 +00:00
GHCup | arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
2021-02-24 14:19:29 +00:00
Cabal | v > [vver|2.4.1.0|]
2021-08-25 16:54:58 +00:00
, arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
2021-02-24 14:19:29 +00:00
GHC | Latest `elem` tags || Recommended `elem` tags
2021-08-25 16:54:58 +00:00
, arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))
_ -> lift $ $(logWarn) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
2020-01-11 20:15:05 +00:00
checkUniqueTags tool = do
let allTags = join $ fmap _viTags $ 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
2021-08-25 16:54:58 +00:00
lift $ $(logError) $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
2020-01-11 20:15:05 +00:00
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
2021-08-25 16:54:58 +00:00
lift $ $(logError) $ "GHC version " <> prettyVer v <> " is not valid"
2020-04-25 10:06:41 +00:00
addError
2020-01-11 20:15:05 +00:00
-- a tool must have at least one of each mandatory tags
checkMandatoryTags tool = do
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
2020-01-11 20:15:05 +00:00
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do
2021-08-25 16:54:58 +00:00
lift $ $(logError) $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
2020-01-11 20:15:05 +00:00
addError
True -> pure ()
-- all GHC versions must have a base tag
checkGHCHasBaseVersion = do
let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
False -> do
2021-08-25 16:54:58 +00:00
lift $ $(logError) $ "Base tag missing from GHC ver " <> prettyVer 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
{ tfTool :: Either GlobalTool (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-05-14 21:09:45 +00:00
, Alternative m
, MonadFail m
2020-01-11 20:15:05 +00:00
)
2021-01-02 04:53:11 +00:00
=> TarballFilter
-> GHCupDownloads
2021-05-14 21:09:45 +00:00
-> M.Map GlobalTool DownloadInfo
2020-01-11 20:15:05 +00:00
-> m ExitCode
validateTarballs (TarballFilter etool versionRegex) dls gt = do
2020-01-11 20:15:05 +00:00
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- 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
2021-05-14 21:09:45 +00:00
let gdlis = nubOrd $ gt ^.. each
2021-06-07 18:04:55 +00:00
let allDls = either (const gdlis) (const dlis) etool
2021-08-25 16:54:58 +00:00
when (null allDls) $ $(logError) "no tarballs selected by filter" *> addError
forM_ allDls downloadAll
2020-01-11 20:15:05 +00:00
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
2021-08-25 16:54:58 +00:00
lift $ $(logInfo) "All good"
2020-01-11 20:15:05 +00:00
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
2021-07-18 21:29:09 +00:00
dirs <- liftIO getAllDirs
2021-05-14 21:09:45 +00:00
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
lift $ runLogger
($(logError) $ T.pack $ prettyShow e)
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
2020-01-11 20:15:05 +00:00
r <-
runLogger
2021-05-14 21:09:45 +00:00
. flip runReaderT appstate
2020-01-11 20:15:05 +00:00
. runResourceT
2021-04-02 14:54:27 +00:00
. runE @'[DigestError
, DownloadFailed
, UnknownArchive
, ArchiveResult
]
$ do
case etool of
Right (Just GHCup) -> do
tmpUnpack <- lift mkGhcupTmpDir
2021-07-24 14:36:31 +00:00
_ <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmpUnpack Nothing False
pure Nothing
Right _ -> do
2021-07-18 21:29:09 +00:00
p <- liftE $ downloadCached dli Nothing
fmap (Just . head . splitDirectories . head)
. liftE
. getArchiveFiles
$ p
Left ShimGen -> do
tmpUnpack <- lift mkGhcupTmpDir
2021-07-24 14:36:31 +00:00
_ <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmpUnpack Nothing False
pure Nothing
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
2021-05-14 21:09:45 +00:00
Just (RealDir prel) -> do
2021-04-02 14:54:27 +00:00
lift $ $(logInfo)
2021-08-25 16:54:58 +00:00
$ " verifying subdir: " <> T.pack prel
2021-04-02 14:54:27 +00:00
when (basePath /= prel) $ do
2021-08-25 16:54:58 +00:00
lift $ $(logError) $
"Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
2021-04-02 14:54:27 +00:00
addError
Just (RegexDir regexString) -> do
2021-08-25 16:54:58 +00:00
lift $ $(logInfo) $
"verifying subdir (regex): " <> T.pack regexString
2021-04-02 14:54:27 +00:00
let regex = makeRegexOpts
compIgnoreCase
execBlank
regexString
when (not (match regex basePath)) $ do
2021-08-25 16:54:58 +00:00
lift $ $(logError) $
"Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
2021-04-02 14:54:27 +00:00
addError
Nothing -> pure ()
VRight Nothing -> pure ()
2020-01-11 20:15:05 +00:00
VLeft e -> do
2021-08-25 16:54:58 +00:00
lift $ $(logError) $
"Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
2020-01-11 20:15:05 +00:00
addError