Env.hs

-- |
-- Module: Settei.Env
-- Description: Explicit, pure environment-variable sources for Settei.
module Settei.Env
  ( Bindings,
    EnvName (..),
    EnvSnapshot (..),
    EnvBinding,
    EnvError (..),
    annotateBinding,
    binding,
    bindingAnnotations,
    bindingKey,
    bindingName,
    bindings,
    bindingsList,
    envSnapshot,
    envSource,
    environmentSource,
    fromKubernetesObject,
    mergeBindings,
    prefixedBindings,
    readEnvSource,
    readEnvironmentSource,
    renderEnvErrorText,
    renderEnvErrorsText,
  )
where

import Data.Char (isAsciiLower, isAsciiUpper, isDigit)
import Data.Generics.Labels ()
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict qualified as Map
import Data.Text qualified as Text
import Settei
import Settei.Prelude
import System.Environment qualified as Environment

-- | An environment-variable name. 'bindings' validates its portable spelling.
newtype EnvName = EnvName Text
  deriving stock (Generic, Eq, Ord, Show)

-- | A complete injectable view of the process environment.
newtype EnvSnapshot = EnvSnapshot (Map EnvName Text)
  deriving stock (Generic, Eq)

-- | One explicit mapping from an environment variable to a structural Settei key.
data EnvBinding = EnvBinding
  { name :: !EnvName,
    key :: !Key,
    annotations :: !(Map Text Text)
  }
  deriving stock (Generic, Eq)

-- | Why a set of environment bindings cannot form one hierarchical source.
data EnvError
  = InvalidEnvironmentName !EnvName
  | DuplicateEnvironmentName !EnvName
  | DuplicateTargetKey !Key
  | ConflictingTargetKeys !Key !Key
  | PrefixedNameCollision !EnvName !(NonEmpty Key)
  deriving stock (Generic, Eq, Show)

-- | A collection of bindings proven valid at construction.
--
-- The constructor is private: 'bindings' and 'prefixedBindings' are the only ways to
-- obtain a value, so every 'Bindings' is free of invalid names, duplicate names,
-- duplicate target keys, and prefix-overlapping target keys. Binding lists are static
-- program data; resolve 'bindings' once at startup (or force it in a unit test) so an
-- invalid list is a fail-fast programming-error report, not a runtime branch.
newtype Bindings = Bindings [EnvBinding]
  deriving stock (Eq)

-- | Construct one explicit binding with no caller annotations.
binding :: EnvName -> Key -> EnvBinding
binding name key = EnvBinding {name, key, annotations = Map.empty}

-- | Add trusted descriptive metadata to a binding.
--
-- Adapter-owned metadata such as @environment.variable@ still takes precedence.
annotateBinding :: Map Text Text -> EnvBinding -> EnvBinding
annotateBinding annotations bindingValue =
  bindingValue & #annotations %~ (annotations <>)

-- | Return the variable name used by a binding.
bindingName :: EnvBinding -> EnvName
bindingName value = value ^. #name

-- | Return the structural key targeted by a binding.
bindingKey :: EnvBinding -> Key
bindingKey value = value ^. #key

-- | Return trusted annotations supplied by the caller.
bindingAnnotations :: EnvBinding -> Map Text Text
bindingAnnotations value = value ^. #annotations

-- | Validate a static binding list once, yielding a collection usable with the total
-- source builders.
bindings :: [EnvBinding] -> Either (NonEmpty EnvError) Bindings
bindings values =
  case NonEmpty.nonEmpty (bindingErrors values) of
    Just errors -> Left errors
    Nothing -> Right (Bindings values)

-- | Inspect the validated bindings, for example to count or display them.
bindingsList :: Bindings -> [EnvBinding]
bindingsList (Bindings values) = values

-- | Merge validated collections into one, re-validating cross-collection conflicts.
--
-- Two individually valid collections can still collide with each other (a variable
-- name bound in both, or target keys that overlap across them), so merging returns
-- the same 'EnvError' vocabulary as 'bindings'. The empty list yields the valid empty
-- collection. Order is preserved: earlier collections contribute earlier bindings.
mergeBindings :: [Bindings] -> Either (NonEmpty EnvError) Bindings
mergeBindings = bindings . concatMap bindingsList

-- | Render one binding-validation failure as a single operator-readable sentence.
--
-- Only variable names and structural keys appear; environment values are never
-- retained by 'EnvError' and therefore cannot leak.
renderEnvErrorText :: EnvError -> Text
renderEnvErrorText = \case
  InvalidEnvironmentName name ->
    "environment binding " <> renderEnvName name <> ": invalid variable name"
  DuplicateEnvironmentName name ->
    "environment binding " <> renderEnvName name <> ": variable bound more than once"
  DuplicateTargetKey key ->
    "bindings target the same key " <> renderKey key <> " twice"
  ConflictingTargetKeys lower higher ->
    "bindings target overlapping keys " <> renderKey lower <> " and " <> renderKey higher
  PrefixedNameCollision name keys ->
    "environment binding "
      <> renderEnvName name
      <> ": normalized name collides for keys "
      <> Text.intercalate ", " (fmap renderKey (NonEmpty.toList keys))

-- | Render every binding-validation failure, one line per problem, matching
-- 'Settei.Render.renderErrorsText' in shape and trailing newline.
renderEnvErrorsText :: NonEmpty EnvError -> Text
renderEnvErrorsText = Text.unlines . fmap renderEnvErrorText . NonEmpty.toList

-- | Build an injectable snapshot from textual name/value pairs.
--
-- Repeated names use the final supplied value, matching the behavior of a map snapshot.
envSnapshot :: [(Text, Text)] -> EnvSnapshot
envSnapshot values =
  EnvSnapshot
    (Map.fromList [(EnvName name, value) | (name, value) <- values])

-- | Translate explicitly bound variables from one snapshot into a Settei source.
--
-- Total: a 'Bindings' value is valid by construction, so no error branch exists.
-- Missing variables are absent leaves. Values remain 'RawText'; target decoding and
-- sensitivity handling stay in the core declaration and resolver.
envSource :: Text -> Bindings -> EnvSnapshot -> Source
envSource sourceLabel (Bindings values) (EnvSnapshot snapshot) =
  annotateSourceAt annotationsFor (source sourceLabel EnvironmentSource root)
  where
    presentBindings =
      [ (bindingValue, rawValue)
      | bindingValue <- values,
        Just value <- [Map.lookup (bindingValue ^. #name) snapshot],
        let rawValue = RawText value
      ]
    root =
      foldl
        (\tree (bindingValue, rawValue) -> insertRawValue (bindingValue ^. #key) rawValue tree)
        (RawObject Map.empty)
        presentBindings
    perKeyAnnotations =
      Map.fromList
        [ ( bindingValue ^. #key,
            Map.singleton "environment.variable" (renderEnvName (bindingValue ^. #name))
              <> bindingValue ^. #annotations
          )
        | (bindingValue, _) <- presentBindings
        ]
    annotationsFor key = Map.findWithDefault Map.empty key perKeyAnnotations

-- | 'envSource' with the conventional source label @"environment"@.
environmentSource :: Bindings -> EnvSnapshot -> Source
environmentSource = envSource "environment"

-- | Snapshot the process environment once and pass it through the pure translator.
readEnvSource :: Text -> Bindings -> IO Source
readEnvSource sourceLabel validated = do
  boundValues <- Environment.getEnvironment
  pure
    ( envSource
        sourceLabel
        validated
        (envSnapshot [(Text.pack name, Text.pack value) | (name, value) <- boundValues])
    )

-- | 'readEnvSource' with the conventional source label @"environment"@.
readEnvironmentSource :: Bindings -> IO Source
readEnvironmentSource = readEnvSource "environment"

-- | Derive explicit bindings using @PREFIX_KEY_SEGMENTS@ names.
--
-- Non-alphanumeric characters become underscores and letters become uppercase. Any
-- collision introduced by that normalization is returned instead of being guessed away.
-- The successful result is already validated: pass it straight to 'envSource'.
prefixedBindings :: Text -> [Key] -> Either (NonEmpty EnvError) Bindings
prefixedBindings prefix keys =
  case NonEmpty.nonEmpty errors of
    Just found -> Left found
    Nothing -> Right (Bindings generated)
  where
    generated = fmap (\key -> binding (prefixedName prefix key) key) keys
    groupedByName =
      Map.fromListWith
        (<>)
        [ (bindingValue ^. #name, bindingValue ^. #key :| [])
        | bindingValue <- generated
        ]
    collisionErrors =
      [ PrefixedNameCollision name targetKeys
      | (name, targetKeys) <- Map.toAscList groupedByName,
        NonEmpty.length targetKeys > 1
      ]
    sharedErrors = filter (not . isDuplicateNameError) (bindingErrors generated)
    errors = sharedErrors <> collisionErrors

isDuplicateNameError :: EnvError -> Bool
isDuplicateNameError (DuplicateEnvironmentName _) = True
isDuplicateNameError _ = False

-- | Attach a trusted Kubernetes object reference without querying a cluster.
fromKubernetesObject :: KubernetesRef -> EnvBinding -> EnvBinding
fromKubernetesObject reference bindingValue =
  annotateBinding (kubernetesAnnotations reference) bindingValue

bindingErrors :: [EnvBinding] -> [EnvError]
bindingErrors values =
  [ InvalidEnvironmentName name
  | bindingValue <- values,
    let name = bindingValue ^. #name,
    not (validEnvName name)
  ]
    <> fmap DuplicateEnvironmentName (duplicates (fmap (^. #name) values))
    <> fmap DuplicateTargetKey (duplicates (fmap (^. #key) values))
    <> overlapErrors (fmap (^. #key) values)

overlapErrors :: [Key] -> [EnvError]
overlapErrors keys =
  [ ConflictingTargetKeys lower higher
  | (positionIndex, lower) <- zip [0 :: Int ..] keys,
    higher <- drop (positionIndex + 1) keys,
    lower /= higher,
    isPrefixKey lower higher || isPrefixKey higher lower
  ]

duplicates :: (Ord a) => [a] -> [a]
duplicates values =
  Map.keys (Map.filter (> (1 :: Int)) (Map.fromListWith (+) [(value, 1) | value <- values]))

validEnvName :: EnvName -> Bool
validEnvName (EnvName value) =
  case Text.uncons value of
    Nothing -> False
    Just (firstCharacter, rest) ->
      validInitial firstCharacter && Text.all validContinuation rest
  where
    validInitial character = asciiLetter character || character == '_'
    validContinuation character = validInitial character || isDigit character

asciiLetter :: Char -> Bool
asciiLetter character = isAsciiLower character || isAsciiUpper character

prefixedName :: Text -> Key -> EnvName
prefixedName prefix key =
  EnvName
    ( Text.intercalate
        "_"
        (normalizeNamePart prefix : fmap normalizeNamePart (NonEmpty.toList (keySegments key)))
    )

normalizeNamePart :: Text -> Text
normalizeNamePart =
  Text.toUpper
    . Text.map
      (\character -> if asciiLetter character || isDigit character || character == '_' then character else '_')

renderEnvName :: EnvName -> Text
renderEnvName (EnvName value) = value

isPrefixKey :: Key -> Key -> Bool
isPrefixKey prefix candidateKey =
  NonEmpty.toList (keySegments prefix)
    `isListPrefixOf` NonEmpty.toList (keySegments candidateKey)

isListPrefixOf :: (Eq a) => [a] -> [a] -> Bool
isListPrefixOf [] _ = True
isListPrefixOf _ [] = False
isListPrefixOf (left : leftRest) (right : rightRest) =
  left == right && isListPrefixOf leftRest rightRest

insertRawValue :: Key -> RawValue -> RawValue -> RawValue
insertRawValue key value = go (NonEmpty.toList (keySegments key))
  where
    go [] _ = value
    go (segment : rest) (RawObject object) =
      RawObject
        ( object
            & at segment
            %~ Just
            . go rest
            . maybe (RawObject Map.empty) id
        )
    -- 'Bindings' construction rejects prefix-overlapping target keys, so by the time this
    -- fold runs, no path can descend through a previously written leaf. This branch is
    -- unreachable by construction and exists only to satisfy exhaustiveness honestly.
    go _ _ = error "validated environment keys cannot overlap"