Config.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Domain.Config
  ( Config (..),
    getRegistryBounds,
    defaultScripts,
    getScript,
  )
where

import Control.Monad.Except (MonadError (..))
import Data.Aeson (FromJSON (..), ToJSON (toJSON), genericParseJSON, genericToJSON)
import qualified Data.Map as Map
import HWM.Core.Common (Check (..), Name)
import HWM.Core.Has (Has, askEnv)
import HWM.Core.Pkg
import HWM.Core.Result (Issue)
import HWM.Core.Version (Version)
import HWM.Domain.Bounds (Bounds, versionBounds)
import HWM.Domain.Environments (Environments (..))
import HWM.Domain.Registry (Registry (..), lookupBounds)
import HWM.Domain.Release (Release)
import HWM.Domain.Workspace (PkgRegistry, Workspace)
import HWM.Runtime.Cache (Cache)
import HWM.Runtime.Files (Signature, aesonYAMLOptionsAdvanced)
import Relude

data Config = Config
  { cfgName :: Name,
    cfgVersion :: Version,
    cfgWorkspace :: Workspace,
    cfgEnvironments :: Environments,
    cfgGithub :: Maybe Text,
    cfgBounds :: Maybe Bounds,
    cfgRegistry :: Maybe Registry,
    cfgScripts :: Maybe (Map Name Text),
    cfgRelease :: Maybe Release
  }
  deriving
    ( Generic,
      Show
    )

getRegistryBounds :: (MonadReader env m, Has env Config, Has env PkgRegistry) => PkgName -> m (Maybe Bounds)
getRegistryBounds name = do
  cfg <- askEnv
  ps <- askEnv
  pure $ getRule' name ps cfg

getRule' :: PkgName -> PkgRegistry -> Config -> Maybe Bounds
getRule' depName ps Config {..}
  | Map.member depName ps = Just (fromMaybe (versionBounds cfgVersion) cfgBounds)
  | otherwise = lookupBounds depName (fromMaybe mempty cfgRegistry)

prefix :: String
prefix = "cfg"

instance FromJSON Config where
  parseJSON = genericParseJSON (aesonYAMLOptionsAdvanced prefix)

instance ToJSON Config where
  toJSON = genericToJSON (aesonYAMLOptionsAdvanced prefix)

instance
  ( MonadError Issue m,
    MonadReader env m,
    Has env Cache,
    Has env Workspace,
    Has env Environments,
    Has env Signature,
    MonadIO m
  ) =>
  Check m Config
  where
  check Config {..} = check cfgEnvironments

defaultScripts :: Map Name Text
defaultScripts =
  Map.fromList
    [("lint", "curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s .")]

getScript :: (MonadError e f, IsString e) => Name -> Config -> f Text
getScript name cfg =
  case cfgScripts cfg >>= Map.lookup name of
    Just script -> pure script
    Nothing -> throwError $ fromString $ toString $ "Script not found: " <> name