96 lines
2.8 KiB
Haskell
96 lines
2.8 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
|
|
module Validate where
|
|
|
|
import GHCup
|
|
import GHCup.Types
|
|
|
|
import Control.Monad
|
|
import Control.Exception.Safe
|
|
import Control.Monad.Reader.Class
|
|
import Control.Monad.IO.Class
|
|
import Control.Monad.Trans.Class ( lift )
|
|
import Control.Monad.Trans.Reader ( runReaderT )
|
|
import Data.List
|
|
import Data.String.Interpolate
|
|
import Data.Versions
|
|
import Data.IORef
|
|
import System.Exit
|
|
import Control.Monad.Logger
|
|
|
|
import qualified Data.Map.Strict as M
|
|
|
|
|
|
-- TODO: improve logging
|
|
|
|
|
|
data ValidationError = InternalError String
|
|
deriving Show
|
|
|
|
instance Exception ValidationError
|
|
|
|
|
|
-- TODO: test that GHC is in semver
|
|
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
|
|
=> AvailableDownloads
|
|
-> m ExitCode
|
|
validate av = do
|
|
ref <- liftIO $ newIORef 0
|
|
flip runReaderT ref $ do
|
|
-- unique tags
|
|
forM_ (M.toList av) $ \(t, _) -> checkUniqueTags t
|
|
|
|
-- required platforms
|
|
forM_ (M.toList av) $ \(t, versions) ->
|
|
forM_ (M.toList versions) $ \(v, vi) ->
|
|
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
|
|
checkHasRequiredPlatforms t v arch (M.keys pspecs)
|
|
|
|
-- exit
|
|
e <- liftIO $ readIORef ref
|
|
if e > 0 then pure $ ExitFailure e else pure ExitSuccess
|
|
where
|
|
checkHasRequiredPlatforms t v arch pspecs = do
|
|
let v' = prettyVer v
|
|
when (not $ any (== Linux UnknownLinux) pspecs) $ do
|
|
lift $ $(logError)
|
|
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
|
|
addError
|
|
when (not $ any (== Darwin) pspecs) $ do
|
|
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
|
|
addError
|
|
when (not $ any (== FreeBSD) pspecs) $ lift $ $(logWarn)
|
|
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
|
|
|
|
checkUniqueTags tool = do
|
|
let allTags = join $ fmap snd $ availableToolVersions av tool
|
|
let nonUnique =
|
|
fmap fst
|
|
. filter (\(_, b) -> not b)
|
|
<$> ( mapM
|
|
(\case
|
|
[] -> throwM $ InternalError "empty inner list"
|
|
(t : ts) ->
|
|
pure $ (t, ) $ if isUniqueTag t then ts == [] else True
|
|
)
|
|
. group
|
|
. sort
|
|
$ allTags
|
|
)
|
|
case join nonUnique of
|
|
[] -> pure ()
|
|
xs -> do
|
|
lift $ $(logError) [i|Tags not unique: #{xs}|]
|
|
addError
|
|
where
|
|
isUniqueTag Latest = True
|
|
isUniqueTag Recommended = True
|
|
|
|
|
|
addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
|
|
addError = do
|
|
ref <- ask
|
|
liftIO $ modifyIORef ref (+ 1)
|