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

{- | Shared outbound document assembly, paired with inbound "Ecluse.Core.Registry.WireSupport".
Ecosystem adapters own their wire shapes and reuse these name and location gates.
-}
module Ecluse.Core.Registry.ServedDocument (
    -- * The cached-document boundary
    assembleAcross,
    serialiseAcross,
    RenderRefused (..),

    -- * Replaying a merge plan
    overlaySurvivors,
    overlayObjectSurvivors,
    overlayObjectSources,

    -- * The interpolated-name gate
    safeDocumentName,

    -- * Rebasing an artifact location
    rebaseArtifactUrl,

    -- * Reading and editing a raw document
    documentObject,
    stringField,
    objectField,
    adjustField,
) where

import Data.Aeson (Encoding, Value (Object, String))
import Data.Aeson.Encoding (emptyObject_, encodingToLazyByteString)
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap (KeyMap)
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Map.Strict qualified as Map
import Data.Text qualified as T

import Ecluse.Core.Package.Entry (AdmittedEntry (..), EntryKey (..))
import Ecluse.Core.Package.Merge (MergePlan (mpArtifacts, mpSurvivors), SourceId)
import Ecluse.Core.Registry.CachedDocument (CachedDoc)
import Ecluse.Core.Snapshot (ContentDigest, Snapshot (..))
import Ecluse.Core.Text (urlFilename)

{- | Run an ecosystem's plain-'Value' assembly across its own cached-document boundary.
A source or base that another ecosystem injected contributes nothing.
-}
assembleAcross ::
    (Value -> CachedDoc, CachedDoc -> Maybe Value) ->
    (Text -> Map SourceId (Snapshot Value) -> MergePlan -> Value -> Value) ->
    Text ->
    Map SourceId (Snapshot CachedDoc) ->
    MergePlan ->
    Maybe CachedDoc ->
    CachedDoc
assembleAcross :: (Value -> CachedDoc, CachedDoc -> Maybe Value)
-> (Text
    -> Map Int (Snapshot Value) -> MergePlan -> Value -> Value)
-> Text
-> Map Int (Snapshot CachedDoc)
-> MergePlan
-> Maybe CachedDoc
-> CachedDoc
assembleAcross (Value -> CachedDoc
inject, CachedDoc -> Maybe Value
project) Text -> Map Int (Snapshot Value) -> MergePlan -> Value -> Value
assemble Text
mountBase Map Int (Snapshot CachedDoc)
bySource MergePlan
plan Maybe CachedDoc
base =
    Value -> CachedDoc
inject
        ( Text -> Map Int (Snapshot Value) -> MergePlan -> Value -> Value
assemble
            Text
mountBase
            ((Snapshot CachedDoc -> Maybe (Snapshot Value))
-> Map Int (Snapshot CachedDoc) -> Map Int (Snapshot Value)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe ((CachedDoc -> Maybe Value)
-> Snapshot CachedDoc -> Maybe (Snapshot Value)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Snapshot a -> f (Snapshot b)
traverse CachedDoc -> Maybe Value
project) Map Int (Snapshot CachedDoc)
bySource)
            MergePlan
plan
            (Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe (KeyMap Value -> Value
Object KeyMap Value
forall a. Monoid a => a
mempty) (CachedDoc -> Maybe Value
project (CachedDoc -> Maybe Value) -> Maybe CachedDoc -> Maybe Value
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe CachedDoc
base))
        )

-- | Encode a served document to its compact wire bytes, an empty object for a foreign one.
serialiseAcross :: (CachedDoc -> Maybe Encoding) -> CachedDoc -> LByteString
serialiseAcross :: (CachedDoc -> Maybe Encoding) -> CachedDoc -> LByteString
serialiseAcross CachedDoc -> Maybe Encoding
project = Encoding -> LByteString
forall a. Encoding' a -> LByteString
encodingToLazyByteString (Encoding -> LByteString)
-> (CachedDoc -> Encoding) -> CachedDoc -> LByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> Maybe Encoding -> Encoding
forall a. a -> Maybe a -> a
fromMaybe Encoding
emptyObject_ (Maybe Encoding -> Encoding)
-> (CachedDoc -> Maybe Encoding) -> CachedDoc -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CachedDoc -> Maybe Encoding
project

{- | A served document whose render refused its plan, because the plan names a table or string it
lacks or the render does not fill its buffer exactly. The pipeline answers it as a render fault.
-}
data RenderRefused = RenderRefused
    deriving stock (RenderRefused -> RenderRefused -> Bool
(RenderRefused -> RenderRefused -> Bool)
-> (RenderRefused -> RenderRefused -> Bool) -> Eq RenderRefused
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RenderRefused -> RenderRefused -> Bool
== :: RenderRefused -> RenderRefused -> Bool
$c/= :: RenderRefused -> RenderRefused -> Bool
/= :: RenderRefused -> RenderRefused -> Bool
Eq, Int -> RenderRefused -> ShowS
[RenderRefused] -> ShowS
RenderRefused -> String
(Int -> RenderRefused -> ShowS)
-> (RenderRefused -> String)
-> ([RenderRefused] -> ShowS)
-> Show RenderRefused
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RenderRefused -> ShowS
showsPrec :: Int -> RenderRefused -> ShowS
$cshow :: RenderRefused -> String
show :: RenderRefused -> String
$cshowList :: [RenderRefused] -> ShowS
showList :: [RenderRefused] -> ShowS
Show)

instance Exception RenderRefused

{- | Select exact admitted entries from the winning source snapshot, preserving each source's order.
Missing keys, ambiguous keys, and mismatched snapshots contribute nothing.
-}
overlaySurvivors :: (src -> [(EntryKey, entry)]) -> Map SourceId (Snapshot src) -> MergePlan -> [(Text, entry)]
overlaySurvivors :: forall src entry.
(src -> [(EntryKey, entry)])
-> Map Int (Snapshot src) -> MergePlan -> [(Text, entry)]
overlaySurvivors src -> [(EntryKey, entry)]
entriesOf Map Int (Snapshot src)
bySource MergePlan
plan =
    [ (Text
version, entry
entry)
    | (Int
sid, Snapshot src
source) <- Map Int (Snapshot src) -> [(Int, Snapshot src)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Int (Snapshot src)
bySource
    , let entries :: [(EntryKey, entry)]
entries = src -> [(EntryKey, entry)]
entriesOf (Snapshot src -> src
forall a. Snapshot a -> a
snapshotValue Snapshot src
source)
    , let unambiguous :: Map EntryKey entry
unambiguous = [(EntryKey, entry)] -> Map EntryKey entry
forall key value. Ord key => [(key, value)] -> Map key value
uniqueEntries [(EntryKey, entry)]
entries
    , (EntryKey
key, entry
entry) <- [(EntryKey, entry)]
entries
    , EntryKey -> Map EntryKey entry -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member EntryKey
key Map EntryKey entry
unambiguous
    , Just (Text
version, AdmittedEntry
kept) <- [(Int, ContentDigest, EntryKey)
-> Map (Int, ContentDigest, EntryKey) (Text, AdmittedEntry)
-> Maybe (Text, AdmittedEntry)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Int
sid, Snapshot src -> ContentDigest
forall a. Snapshot a -> ContentDigest
snapshotDigest Snapshot src
source, EntryKey
key) Map (Int, ContentDigest, EntryKey) (Text, AdmittedEntry)
admitted]
    , AdmittedEntry -> Bool
usableEntry AdmittedEntry
kept
    ]
  where
    admitted :: Map (Int, ContentDigest, EntryKey) (Text, AdmittedEntry)
admitted = MergePlan
-> Map (Int, ContentDigest, EntryKey) (Text, AdmittedEntry)
admittedIndex MergePlan
plan

{- | Select exact admitted entries by lookup in each winning source's key map, in source and key order.
Only object coordinates are served. Missing keys, ambiguous keys, and mismatched snapshots contribute nothing.
-}
overlayObjectSurvivors :: (src -> KeyMap entry) -> Map SourceId (Snapshot src) -> MergePlan -> [(Text, entry)]
overlayObjectSurvivors :: forall src entry.
(src -> KeyMap entry)
-> Map Int (Snapshot src) -> MergePlan -> [(Text, entry)]
overlayObjectSurvivors src -> KeyMap entry
entriesOf Map Int (Snapshot src)
bySource MergePlan
plan = [(Text
version, entry
entry) | (Text
version, Int
_, entry
entry) <- (src -> KeyMap entry)
-> Map Int (Snapshot src) -> MergePlan -> [(Text, Int, entry)]
forall src entry.
(src -> KeyMap entry)
-> Map Int (Snapshot src) -> MergePlan -> [(Text, Int, entry)]
overlayObjectSources src -> KeyMap entry
entriesOf Map Int (Snapshot src)
bySource MergePlan
plan]

-- | 'overlayObjectSurvivors' with the source each entry came from.
overlayObjectSources :: (src -> KeyMap entry) -> Map SourceId (Snapshot src) -> MergePlan -> [(Text, SourceId, entry)]
overlayObjectSources :: forall src entry.
(src -> KeyMap entry)
-> Map Int (Snapshot src) -> MergePlan -> [(Text, Int, entry)]
overlayObjectSources src -> KeyMap entry
entriesOf Map Int (Snapshot src)
bySource MergePlan
plan =
    [ (Text
version, Int
sid, entry
entry)
    | ((Int
sid, ContentDigest
digest, ObjectEntry Text
key), (Text
version, AdmittedEntry
kept)) <- Map (Int, ContentDigest, EntryKey) (Text, AdmittedEntry)
-> [((Int, ContentDigest, EntryKey), (Text, AdmittedEntry))]
forall k a. Map k a -> [(k, a)]
Map.toAscList (MergePlan
-> Map (Int, ContentDigest, EntryKey) (Text, AdmittedEntry)
admittedIndex MergePlan
plan)
    , AdmittedEntry -> Bool
usableEntry AdmittedEntry
kept
    , Just Snapshot src
source <- [Int -> Map Int (Snapshot src) -> Maybe (Snapshot src)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
sid Map Int (Snapshot src)
bySource]
    , Snapshot src -> ContentDigest
forall a. Snapshot a -> ContentDigest
snapshotDigest Snapshot src
source ContentDigest -> ContentDigest -> Bool
forall a. Eq a => a -> a -> Bool
== ContentDigest
digest
    , Just entry
entry <- [Key -> KeyMap entry -> Maybe entry
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
key) (src -> KeyMap entry
entriesOf (Snapshot src -> src
forall a. Snapshot a -> a
snapshotValue Snapshot src
source))]
    ]

admittedIndex :: MergePlan -> Map (SourceId, ContentDigest, EntryKey) (Text, AdmittedEntry)
admittedIndex :: MergePlan
-> Map (Int, ContentDigest, EntryKey) (Text, AdmittedEntry)
admittedIndex MergePlan
plan =
    [((Int, ContentDigest, EntryKey), (Text, AdmittedEntry))]
-> Map (Int, ContentDigest, EntryKey) (Text, AdmittedEntry)
forall key value. Ord key => [(key, value)] -> Map key value
uniqueEntries
        [ ((Int
sid, AdmittedEntry -> ContentDigest
admittedSnapshot AdmittedEntry
entry, AdmittedEntry -> EntryKey
admittedKey AdmittedEntry
entry), (Text
version, AdmittedEntry
entry))
        | (Text
version, NonEmpty AdmittedEntry
entries) <- Map Text (NonEmpty AdmittedEntry)
-> [(Text, NonEmpty AdmittedEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList (MergePlan -> Map Text (NonEmpty AdmittedEntry)
mpArtifacts MergePlan
plan)
        , Just Int
sid <- [Text -> Map Text Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
version (MergePlan -> Map Text Int
mpSurvivors MergePlan
plan)]
        , AdmittedEntry
entry <- NonEmpty AdmittedEntry -> [AdmittedEntry]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty AdmittedEntry
entries
        ]

usableEntry :: AdmittedEntry -> Bool
usableEntry :: AdmittedEntry -> Bool
usableEntry AdmittedEntry
entry = EntryKey -> Bool
validKey (AdmittedEntry -> EntryKey
admittedKey AdmittedEntry
entry) Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
T.null (AdmittedEntry -> Text
admittedFilename AdmittedEntry
entry))

uniqueEntries :: (Ord key) => [(key, value)] -> Map key value
uniqueEntries :: forall key value. Ord key => [(key, value)] -> Map key value
uniqueEntries = (Maybe value -> Maybe value)
-> Map key (Maybe value) -> Map key value
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Maybe value -> Maybe value
forall a. a -> a
id (Map key (Maybe value) -> Map key value)
-> ([(key, value)] -> Map key (Maybe value))
-> [(key, value)]
-> Map key value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe value -> Maybe value -> Maybe value)
-> [(key, Maybe value)] -> Map key (Maybe value)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (\Maybe value
_ Maybe value
_ -> Maybe value
forall a. Maybe a
Nothing) ([(key, Maybe value)] -> Map key (Maybe value))
-> ([(key, value)] -> [(key, Maybe value)])
-> [(key, value)]
-> Map key (Maybe value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((key, value) -> (key, Maybe value))
-> [(key, value)] -> [(key, Maybe value)]
forall a b. (a -> b) -> [a] -> [b]
map ((value -> Maybe value) -> (key, value) -> (key, Maybe value)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second value -> Maybe value
forall a. a -> Maybe a
Just)

validKey :: EntryKey -> Bool
validKey :: EntryKey -> Bool
validKey = \case
    ArrayEntry Int
position -> Int
position Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
    ObjectEntry Text
_ -> Bool
True
    EntryKey
SingletonEntry -> Bool
True

-- | Gate the document's claimed name before it enters a rewritten artifact URL.
safeDocumentName :: (Text -> Maybe a) -> KeyMap Value -> Maybe a
safeDocumentName :: forall a. (Text -> Maybe a) -> KeyMap Value -> Maybe a
safeDocumentName Text -> Maybe a
parse KeyMap Value
document = case Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"name" KeyMap Value
document of
    Just (String Text
name) -> Text -> Maybe a
parse Text
name
    Maybe Value
_ -> Maybe a
forall a. Maybe a
Nothing

{- | Rebase an artifact under this mount, checking filenames before and after URL whitespace trimming.
Idempotent while the renderer keeps the filename in the terminal path segment.
-}
rebaseArtifactUrl :: (Text -> Maybe Text) -> Text -> Maybe Text
rebaseArtifactUrl :: (Text -> Maybe Text) -> Text -> Maybe Text
rebaseArtifactUrl Text -> Maybe Text
renderMountUrl Text
url = do
    filename <- Text -> Maybe Text
urlFilename Text
url
    _ <- urlFilename (T.strip url)
    renderMountUrl filename

-- | A raw document's own object, empty for a document that is not one.
documentObject :: Value -> KeyMap Value
documentObject :: Value -> KeyMap Value
documentObject = \case
    Object KeyMap Value
o -> KeyMap Value
o
    Value
_ -> KeyMap Value
forall a. Monoid a => a
mempty

-- | The 'Text' at @key@ in a raw document object, if present and a JSON string.
stringField :: Key.Key -> KeyMap Value -> Maybe Text
stringField :: Key -> KeyMap Value -> Maybe Text
stringField Key
key KeyMap Value
o = case Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
key KeyMap Value
o of
    Just (String Text
s) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
    Maybe Value
_ -> Maybe Text
forall a. Maybe a
Nothing

-- | The object at @key@ in a raw document object, if present and a JSON object.
objectField :: Key.Key -> KeyMap Value -> Maybe (KeyMap Value)
objectField :: Key -> KeyMap Value -> Maybe (KeyMap Value)
objectField Key
key KeyMap Value
o = case Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
key KeyMap Value
o of
    Just (Object KeyMap Value
inner) -> KeyMap Value -> Maybe (KeyMap Value)
forall a. a -> Maybe a
Just KeyMap Value
inner
    Maybe Value
_ -> Maybe (KeyMap Value)
forall a. Maybe a
Nothing

-- | Edit the value an object carries at @key@. A missing field stays absent.
adjustField :: Key.Key -> (Value -> Value) -> KeyMap Value -> KeyMap Value
adjustField :: Key -> (Value -> Value) -> KeyMap Value -> KeyMap Value
adjustField Key
key Value -> Value
edit KeyMap Value
o = case Key -> KeyMap Value -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
key KeyMap Value
o of
    Just Value
v -> Key -> Value -> KeyMap Value -> KeyMap Value
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
key (Value -> Value
edit Value
v) KeyMap Value
o
    Maybe Value
Nothing -> KeyMap Value
o