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

{-# LANGUAGE CPP              #-}
{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes      #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns     #-}
{-# LANGUAGE OverloadedStrings #-}

module Validate where

import           GHCup
import           GHCup.Download
import           GHCup.Errors
import           GHCup.Types
import           GHCup.Types.Optics
import           GHCup.Utils
import           GHCup.Utils.Logger
import           GHCup.Utils.Version.QQ

import           Codec.Archive
import           Control.Applicative
import           Control.Exception.Safe
import           Control.Monad
import           Control.Monad.IO.Class
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 )
import           Data.IORef
import           Data.List
import           Data.Versions
import           Haskus.Utils.Variant.Excepts
import           Optics
import           System.FilePath
import           System.Exit
import           Text.ParserCombinators.ReadP
import           Text.PrettyPrint.HughesPJClass ( prettyShow )
import           Text.Regex.Posix

import qualified Data.Map.Strict               as M
import qualified Data.Text                     as T
import qualified Data.Version                  as V


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, MonadReader env m, HasLog env, MonadThrow m, MonadIO m, MonadUnliftIO m)
         => GHCupDownloads
         -> M.Map GlobalTool DownloadInfo
         -> m ExitCode
validate dls _ = do
  ref <- liftIO $ newIORef 0

  -- verify binary downloads --
  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)

    checkGHCVerIsValid
    forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
    _ <- checkGHCHasBaseVersion

    -- exit
    e <- liftIO $ readIORef ref
    if e > 0
      then pure $ ExitFailure e
      else do
        lift $ logInfo "All good"
        pure ExitSuccess
 where
  checkHasRequiredPlatforms t v tags arch pspecs = do
    let v' = prettyVer v
        arch' = prettyShow arch
    when (notElem (Linux UnknownLinux) pspecs) $ do
      lift $ logError $
        "Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
      addError
    when ((notElem Darwin pspecs) && arch == A_64) $ do
      lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
      addError
    when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ logWarn $
      "FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
    when (notElem Windows pspecs && arch == A_64) $ do
      lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
      addError

    -- alpine needs to be set explicitly, because
    -- we cannot assume that "Linux UnknownLinux" runs on Alpine
    -- (although it could be static)
    when (notElem (Linux Alpine) pspecs) $
      case t of
        GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
        Cabal | v > [vver|2.4.1.0|]
              , arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
        GHC | Latest `elem` tags || Recommended `elem` tags
            , 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)

  checkUniqueTags tool = do
    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
    let nonUnique =
          fmap fst
            .   filter (\(_, b) -> not b)
            <$> ( mapM
                    (\case
                      [] -> throwM $ InternalError "empty inner list"
                      (t : ts) ->
                        pure $ (t, ) (not (isUniqueTag t) || null ts)
                    )
                . group
                . sort
                $ allTags
                )
    case join nonUnique of
      [] -> pure ()
      xs -> do
        lift $ logError $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
        addError
   where
    isUniqueTag Latest         = True
    isUniqueTag Recommended    = True
    isUniqueTag Old            = False
    isUniqueTag Prerelease     = False
    isUniqueTag (Base       _) = False
    isUniqueTag (UnknownTag _) = False

  checkGHCVerIsValid = do
    let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
    forM_ ghcVers $ \v ->
      case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
        [_] -> pure ()
        _   -> do
          lift $ logError $ "GHC version " <> prettyVer v <> " is not valid"
          addError

  -- a tool must have at least one of each mandatory tags
  checkMandatoryTags tool = do
    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
    forM_ [Latest, Recommended] $ \t -> case elem t allTags of
      False -> do
        lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
        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
        lift $ logError $ "Base tag missing from GHC ver " <> prettyVer ver
        addError
      True -> pure ()

  isBase (Base _) = True
  isBase _        = False

data TarballFilter = TarballFilter
  { tfTool    :: Either GlobalTool (Maybe Tool)
  , tfVersion :: Regex
  }

validateTarballs :: ( Monad m
                    , MonadReader env m
                    , HasLog env
                    , HasDirs env
                    , HasSettings env
                    , MonadThrow m
                    , MonadIO m
                    , MonadUnliftIO m
                    , MonadMask m
                    , Alternative m
                    , MonadFail m
                    )
                 => TarballFilter
                 -> GHCupDownloads
                 -> M.Map GlobalTool DownloadInfo
                 -> m ExitCode
validateTarballs (TarballFilter etool versionRegex) dls gt = do
  ref <- liftIO $ newIORef 0

   -- 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
  let gdlis = nubOrd $ gt ^.. each
  let allDls = either (const gdlis) (const dlis) etool
  when (null allDls) $ logError "no tarballs selected by filter" *> (flip runReaderT ref addError)
  forM_ allDls (downloadAll ref)

  -- exit
  e <- liftIO $ readIORef ref
  if e > 0
    then pure $ ExitFailure e
    else do
      logInfo "All good"
      pure ExitSuccess

 where
  downloadAll :: ( MonadUnliftIO m
                 , MonadIO m
                 , MonadReader env m
                 , HasLog env
                 , HasDirs env
                 , HasSettings env
                 , MonadCatch m
                 , MonadMask m
                 , MonadThrow m
                 )
              => IORef Int
              -> DownloadInfo
              -> m ()
  downloadAll ref dli = do
    r <- runResourceT
      . runE @'[DigestError
               , GPGError
               , DownloadFailed
               , UnknownArchive
               , ArchiveResult
               ]
      $ do
        case etool of
          Right (Just GHCup) -> do
            tmpUnpack <- lift mkGhcupTmpDir
            _ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False
            pure Nothing
          Right _ -> do
            p <- liftE $ downloadCached dli Nothing
            fmap (Just . head . splitDirectories . head)
              . liftE
              . getArchiveFiles
              $ p
          Left ShimGen -> do
            tmpUnpack <- lift mkGhcupTmpDir
            _ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False
            pure Nothing
    case r of
      VRight (Just basePath) -> do
        case _dlSubdir dli of
          Just (RealDir prel) -> do
            logInfo
              $ " verifying subdir: " <> T.pack prel
            when (basePath /= prel) $ do
              logError $
                "Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
              (flip runReaderT ref addError)
          Just (RegexDir regexString) -> do
            logInfo $
              "verifying subdir (regex): " <> T.pack regexString
            let regex = makeRegexOpts
                  compIgnoreCase
                  execBlank
                  regexString
            when (not (match regex basePath)) $ do
              logError $
                "Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
              (flip runReaderT ref addError)
          Nothing -> pure ()
      VRight Nothing -> pure ()
      VLeft  e -> do
        logError $
          "Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
        (flip runReaderT ref addError)