{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

{- HLINT ignore "Avoid restricted function" -}
module Ecluse.Config (
    Config (..),
    AppConfig (..),
    MountMap,
    Mount (..),
    MountRegistries (..),
    MirrorTarget (..),
    MountConfig (..),
    QueueBackend (..),
    CredentialBackend (..),
    MirrorCredentialProvider (..),
    Url (..),
    mkUrl,
    unUrl,
    RulePatch (..),
    RuleEntry (..),
    RulePolicy (..),
    PolicyError (..),
    renderPolicyError,
    emptyPolicy,
    defaultPolicy,
    ConfigError (..),
    renderConfigError,
    loadConfig,
) where

import Data.Aeson (Result (..), Value (..), fromJSON)
import Data.Aeson.Types (parseEither, withObject, (.!=), (.:?))
import Data.FileEmbed (embedFile)
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Data.Yaml (decodeEither')

import Ecluse.Config.Aeson ()
import Ecluse.Config.Resolve (buildEnvAst, deepMerge)
import Ecluse.Config.Rule
import Ecluse.Config.Types
import Ecluse.Core.Ecosystem (Ecosystem)
import Ecluse.Core.Rules.Types (PrecededRule)

{- HLINT ignore defaultPolicy "Avoid restricted function" -}
defaultPolicy :: RulePolicy
defaultPolicy :: RulePolicy
defaultPolicy =
    let defaultBytes :: ByteString
defaultBytes = $(embedFile "config/default.yaml")
     in case ByteString -> Either ParseException Value
forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' ByteString
defaultBytes of
            Right Value
ast -> case Value -> Either String RulePatch
parseRulesPatch Value
ast of
                Right RulePatch
globalRules -> ([PolicyError] -> RulePolicy)
-> (RulePolicy -> RulePolicy)
-> Either [PolicyError] RulePolicy
-> RulePolicy
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> RulePolicy
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> RulePolicy)
-> ([PolicyError] -> Text) -> [PolicyError] -> RulePolicy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PolicyError] -> Text
forall b a. (Show a, IsString b) => a -> b
show) RulePolicy -> RulePolicy
forall a. a -> a
id (RulePolicy -> RulePatch -> Either [PolicyError] RulePolicy
resolvePolicy RulePolicy
emptyPolicy RulePatch
globalRules)
                Left String
e -> Text -> RulePolicy
forall a t. (HasCallStack, IsText t) => t -> a
error (Text
"Invalid default policy JSON: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e)
            Left ParseException
e -> Text -> RulePolicy
forall a t. (HasCallStack, IsText t) => t -> a
error (Text
"Invalid default policy YAML: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseException -> Text
forall b a. (Show a, IsString b) => a -> b
show ParseException
e)

loadConfig :: [(String, String)] -> Maybe ByteString -> Either [ConfigError] Config
loadConfig :: [(String, String)]
-> Maybe ByteString -> Either [ConfigError] Config
loadConfig [(String, String)]
envVars Maybe ByteString
mBytes = do
    defaultAst <- Either [ConfigError] Value
parseDefaultAst
    docAst <- parseDocumentAst mBytes
    let overridesAst = Value -> Value -> Value
deepMerge Value
docAst ([(String, String)] -> Value
buildEnvAst [(String, String)]
envVars)
    let merged = Value -> Value -> Value
deepMerge Value
defaultAst Value
overridesAst
    appConfig <- parseAppConfig merged
    globalPolicy <- resolveGlobalPolicy overridesAst
    mounts <- resolveMounts globalPolicy appConfig
    Right (Config appConfig mounts)

parseDefaultAst :: Either [ConfigError] Value
parseDefaultAst :: Either [ConfigError] Value
parseDefaultAst = case ByteString -> Either ParseException Value
forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' $(embedFile "config/default.yaml") of
    Right Value
ast -> Value -> Either [ConfigError] Value
forall a b. b -> Either a b
Right Value
ast
    Left ParseException
err -> [ConfigError] -> Either [ConfigError] Value
forall a b. a -> Either a b
Left [Text -> ConfigError
ParseError (Text
"config/default.yaml is invalid YAML: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ParseException -> String
forall b a. (Show a, IsString b) => a -> b
show ParseException
err))]

parseDocumentAst :: Maybe ByteString -> Either [ConfigError] Value
parseDocumentAst :: Maybe ByteString -> Either [ConfigError] Value
parseDocumentAst = \case
    Maybe ByteString
Nothing -> Value -> Either [ConfigError] Value
forall a b. b -> Either a b
Right (Object -> Value
Object Object
forall a. Monoid a => a
mempty)
    Just ByteString
bytes -> case ByteString -> Either ParseException Value
forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' ByteString
bytes of
        Right Value
ast -> Value -> Either [ConfigError] Value
forall a b. b -> Either a b
Right Value
ast
        Left ParseException
err -> [ConfigError] -> Either [ConfigError] Value
forall a b. a -> Either a b
Left [Text -> ConfigError
ParseError (Text
"/etc/ecluse/config.yaml is invalid YAML: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (ParseException -> String
forall b a. (Show a, IsString b) => a -> b
show ParseException
err))]

parseAppConfig :: Value -> Either [ConfigError] AppConfig
parseAppConfig :: Value -> Either [ConfigError] AppConfig
parseAppConfig Value
merged = case Value -> Result AppConfig
forall a. FromJSON a => Value -> Result a
fromJSON Value
merged of
    Success AppConfig
appConfig -> AppConfig -> Either [ConfigError] AppConfig
forall a b. b -> Either a b
Right AppConfig
appConfig
    Error String
err -> [ConfigError] -> Either [ConfigError] AppConfig
forall a b. a -> Either a b
Left [Text -> ConfigError
ParseError (Text
"Configuration parse error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err)]

parseRulesPatch :: Value -> Either String RulePatch
parseRulesPatch :: Value -> Either String RulePatch
parseRulesPatch = (Value -> Parser RulePatch) -> Value -> Either String RulePatch
forall a b. (a -> Parser b) -> a -> Either String b
parseEither (String -> (Object -> Parser RulePatch) -> Value -> Parser RulePatch
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Config" (\Object
obj -> Object
obj Object -> Key -> Parser (Maybe RulePatch)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"rules" Parser (Maybe RulePatch) -> RulePatch -> Parser RulePatch
forall a. Parser (Maybe a) -> a -> Parser a
.!= Map Text RuleEntry -> RulePatch
RulePatch Map Text RuleEntry
forall k a. Map k a
Map.empty))

resolveGlobalPolicy :: Value -> Either [ConfigError] RulePolicy
resolveGlobalPolicy :: Value -> Either [ConfigError] RulePolicy
resolveGlobalPolicy Value
overridesAst = do
    globalRulePatch <- case Value -> Either String RulePatch
parseRulesPatch Value
overridesAst of
        Right RulePatch
r -> RulePatch -> Either [ConfigError] RulePatch
forall a b. b -> Either a b
Right RulePatch
r
        Left String
err -> [ConfigError] -> Either [ConfigError] RulePatch
forall a b. a -> Either a b
Left [Text -> ConfigError
ParseError (Text
"Rules parse error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err)]
    first (pure . PolicyErrors) (resolvePolicy defaultPolicy globalRulePatch)

resolveMounts :: RulePolicy -> AppConfig -> Either [ConfigError] MountMap
resolveMounts :: RulePolicy -> AppConfig -> Either [ConfigError] MountMap
resolveMounts RulePolicy
globalPolicy AppConfig
appConfig =
    (Ecosystem -> MountConfig -> Either [ConfigError] Mount)
-> Map Ecosystem MountConfig -> Either [ConfigError] MountMap
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey Ecosystem -> MountConfig -> Either [ConfigError] Mount
forall {f :: * -> *}.
Applicative f =>
Ecosystem -> MountConfig -> Either (f ConfigError) Mount
resolveOne (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
appConfig)
  where
    resolveOne :: Ecosystem -> MountConfig -> Either (f ConfigError) Mount
resolveOne Ecosystem
eco MountConfig
mcfg =
        ([PolicyError] -> f ConfigError)
-> Either [PolicyError] Mount -> Either (f ConfigError) Mount
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ConfigError -> f ConfigError
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfigError -> f ConfigError)
-> ([PolicyError] -> ConfigError) -> [PolicyError] -> f ConfigError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PolicyError] -> ConfigError
PolicyErrors) (RulePolicy
-> Ecosystem
-> MountConfig
-> AppConfig
-> Either [PolicyError] Mount
resolveMount RulePolicy
globalPolicy Ecosystem
eco MountConfig
mcfg AppConfig
appConfig)

{- HLINT ignore resolveMount "Avoid restricted function" -}
resolveMount :: RulePolicy -> Ecosystem -> MountConfig -> AppConfig -> Either [PolicyError] Mount
resolveMount :: RulePolicy
-> Ecosystem
-> MountConfig
-> AppConfig
-> Either [PolicyError] Mount
resolveMount RulePolicy
globalPolicy Ecosystem
eco MountConfig
mcfg AppConfig
app = do
    policy <- RulePolicy -> RulePatch -> Either [PolicyError] RulePolicy
resolvePolicy RulePolicy
globalPolicy (MountConfig -> RulePatch
mntAdditionalRules MountConfig
mcfg)
    Right $
        Mount
            { mountEcosystem = eco
            , mountRegistries =
                MountRegistries
                    { regPrivateUpstream = privateUpstream
                    , regPublicUpstream = mntPublicUpstream mcfg
                    , regMirrorTarget =
                        MirrorTarget
                            { mtUrl = fromMaybe privateUpstream (mntMirrorTarget mcfg)
                            , mtCredential = mntCredentialProvider mcfg
                            , mtQueue = cfgQueueBackend app
                            }
                    }
            , mountPolicy = rulesOf policy
            }
  where
    privateUpstream :: RegistryUrl
privateUpstream = RegistryUrl -> Maybe RegistryUrl -> RegistryUrl
forall a. a -> Maybe a -> a
fromMaybe (Text -> RegistryUrl
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"privateUpstream filtered out") (MountConfig -> Maybe RegistryUrl
mntPrivateUpstream MountConfig
mcfg)

rulesOf :: RulePolicy -> [PrecededRule]
rulesOf :: RulePolicy -> [PrecededRule]
rulesOf = Map Text PrecededRule -> [PrecededRule]
forall k a. Map k a -> [a]
Map.elems (Map Text PrecededRule -> [PrecededRule])
-> (RulePolicy -> Map Text PrecededRule)
-> RulePolicy
-> [PrecededRule]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RulePolicy -> Map Text PrecededRule
policyRules