-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | Hierarchical configuration resolution: the defaults, the operator document, and the
@ECLUSE_@ environment overlay merged into one tree, strongest last.

A variable name maps to a document path rather than to a setting, so every key is reachable from
the environment. The resolver inverts that mapping, which is how a refusal names the key an
operator actually wrote.
-}
module Ecluse.Config.Resolve (
    deepMerge,
    buildEnvAst,
    secretLeafKeys,
    secretEnvSpellings,
    mountKeyRef,
    mountDocRef,
) where

import Data.Aeson (Value (..), eitherDecodeStrict)
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Char (isUpper)

import Data.Text qualified as T

import Ecluse.Core.Ecosystem (Ecosystem, ecosystemName)

{- | Right-biased deep merge of two Aeson Values. Objects merge recursively.
The right side overwrites any other type, arrays and strings included.
-}
deepMerge :: Value -> Value -> Value
deepMerge :: Value -> Value -> Value
deepMerge (Object Object
l) (Object Object
r) = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value) -> Object -> Object -> Object
forall v. (v -> v -> v) -> KeyMap v -> KeyMap v -> KeyMap v
KeyMap.unionWith Value -> Value -> Value
deepMerge Object
l Object
r
deepMerge Value
_ Value
r = Value
r

{- | Convert @ECLUSE_@-prefixed environment variables into a nested JSON Object, prefix stripped:
@__@ descends into an object and @_@ joins a camelCase word ('mountKeyRef' inverts it).
-}
buildEnvAst :: [(String, String)] -> Value
buildEnvAst :: [(String, String)] -> Value
buildEnvAst [(String, String)]
env =
    (Value -> Value -> Value) -> Value -> [Value] -> Value
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Value -> Value -> Value
deepMerge (Object -> Value
Object Object
forall v. KeyMap v
KeyMap.empty) (((Text, String) -> Value) -> [(Text, String)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Text, String) -> Value
envVarValue [(Text, String)]
configVars)
  where
    configVars :: [(Text, String)]
configVars = [(Text
key, String
v) | (String
name, String
v) <- [(String, String)]
env, Just Text
key <- [Text -> Maybe Text
configEnvKey (String -> Text
T.pack String
name)]]

configEnvKey :: Text -> Maybe Text
configEnvKey :: Text -> Maybe Text
configEnvKey Text
name
    | Text
name Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Text]
reservedProcessKeys = Maybe Text
forall a. Maybe a
Nothing
    | Bool
otherwise = Text -> Text -> Maybe Text
T.stripPrefix Text
"ECLUSE_" Text
name

-- @ECLUSE_@-prefixed variables that address the boot process, not the config document.
-- "Ecluse.Boot" consumes them before resolution, so they never become document keys.
reservedProcessKeys :: [Text]
reservedProcessKeys :: [Text]
reservedProcessKeys = [Text
"ECLUSE_CONFIG"]

{- | The secret-typed leaf keys, in their document spelling: @token@ is the one under every store
tag. Verbatim env values, redacted provenance, and the @*_FILE@ indirection all read them here.
-}
secretLeafKeys :: [Text]
secretLeafKeys :: [Text]
secretLeafKeys = [Text
"authToken", Text
"token"]

-- | 'secretLeafKeys' in their environment spelling (@authToken@ -> @AUTH_TOKEN@).
secretEnvSpellings :: [Text]
secretEnvSpellings :: [Text]
secretEnvSpellings = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
envSpellingOf [Text]
secretLeafKeys

{- The environment spelling of a camelCase document key (@authToken@ -> @AUTH_TOKEN@).
It inverts 'buildEnvAst', so a boot error names exactly the key the resolver reads. -}
envSpellingOf :: Text -> Text
envSpellingOf :: Text -> Text
envSpellingOf = Text -> Text
T.toUpper (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
underscoreUpper
  where
    underscoreUpper :: Char -> Text
underscoreUpper Char
c
        | Char -> Bool
isUpper Char
c = Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Char -> Text
T.singleton Char
c
        | Bool
otherwise = Char -> Text
T.singleton Char
c

{- | The environment key a mount-scoped document path resolves from: @mirrorTarget.codeArtifact.url@
on npm gives @ECLUSE_MOUNTS__NPM__MIRROR_TARGET__CODE_ARTIFACT__URL@. Every refusal builds it here.
-}
mountKeyRef :: Ecosystem -> Text -> Text
mountKeyRef :: Ecosystem -> Text -> Text
mountKeyRef Ecosystem
eco Text
path =
    Text
"ECLUSE_MOUNTS__"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.toUpper (Ecosystem -> Text
ecosystemName Ecosystem
eco)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"__"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"__" ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
envSpellingOf (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
path))

-- | 'mountKeyRef' in the document spelling: @mounts.npm.mirrorTarget.codeArtifact.url@.
mountDocRef :: Ecosystem -> Text -> Text
mountDocRef :: Ecosystem -> Text -> Text
mountDocRef Ecosystem
eco Text
path = Text
"mounts." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text
ecosystemName Ecosystem
eco Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path

envVarValue :: (Text, String) -> Value
envVarValue :: (Text, String) -> Value
envVarValue (Text
key, String
value) =
    [Key] -> Value -> Value
nest [Key]
segments (Text -> Value
leafValue (String -> Text
T.pack String
value))
  where
    segments :: [Key]
segments = (Text -> Key) -> [Text] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Key
toCamelCase (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"__" Text
key)
    -- A secret is taken verbatim: JSON-parsing it would coerce a value like
    -- 12345 or true into a non-string the secret parser rightly refuses.
    leafValue :: Text -> Value
leafValue
        | Bool -> (Key -> Bool) -> Maybe Key -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Text]
secretLeafKeys) (Text -> Bool) -> (Key -> Text) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
Key.toText) ([Key] -> Maybe Key
forall a. [a] -> Maybe a
listToMaybe ([Key] -> [Key]
forall a. [a] -> [a]
reverse [Key]
segments)) = Text -> Value
String
        | Bool
otherwise = Text -> Value
parseEnvValue

toCamelCase :: Text -> Key.Key
toCamelCase :: Text -> Key
toCamelCase Text
t =
    let words' :: [Text]
words' = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"_" Text
t)
     in Text -> Key
Key.fromText (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ case [Text]
words' of
            [] -> Text
""
            (Text
w : [Text]
ws) -> Text -> Text
T.toLower Text
w Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.concat ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.toTitle [Text]
ws)

nest :: [Key.Key] -> Value -> Value
nest :: [Key] -> Value -> Value
nest [] Value
v = Value
v
nest (Key
p : [Key]
ps) Value
v = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
p ([Key] -> Value -> Value
nest [Key]
ps Value
v)

parseEnvValue :: Text -> Value
parseEnvValue :: Text -> Value
parseEnvValue Text
txt = case ByteString -> Either String Value
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
txt) of
    Right Value
v -> Value
v
    Left String
_ -> Text -> Value
String Text
txt