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

{-# 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
-- TODO: check there's LATEST tag for every tool
-- TODO: check all tarballs can be downloaded
--       AND their checksum
-- TODO: check gpg keys of tarballs?
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
         => GHCupDownloads
         -> m ExitCode
validate GHCupDownloads{..} = do
  ref <- liftIO $ newIORef 0

  -- * verify binary downloads * --
  flip runReaderT ref $ do
    -- unique tags
    forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkUniqueTags t

    -- required platforms
    forM_ (M.toList _binaryDownloads) $ \(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 _binaryDownloads 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)