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

298 lines
10 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
2021-05-14 21:09:45 +00:00
import GHCup.Platform
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
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.String.Interpolate
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
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'}|]
2021-05-14 21:09:45 +00:00
when (notElem Windows pspecs && arch == A_64) $ do
lift $ $(logError)
[i|Windows missing for for #{t} #{v'} #{arch'}|]
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-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
{ 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
when (null allDls) $ $(logError) [i|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
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
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 False GHCupURL) 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
#if defined(TAR)
, Tar.FormatError
#else
, ArchiveResult
#endif
]
$ do
case etool of
Right (Just GHCup) -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing
pure Nothing
Right _ -> do
2021-05-14 21:09:45 +00:00
p <- liftE $ downloadCached (settings appstate) dirs dli Nothing
fmap (Just . head . splitDirectories . head)
. liftE
. getArchiveFiles
$ p
Left ShimGen -> do
tmpUnpack <- lift mkGhcupTmpDir
_ <- liftE $ download (settings appstate) dli tmpUnpack Nothing
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)
[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