Codec.hs

{- | The default JSON encoding for aggregate snapshots.

'defaultStateCodecWithFold' builds the recommended 'StateCodec' for a
hand-written service's @(state, registers)@ pair, serializing it as a JSON
object @{ "state": …, "registers": … }@ and composing a hand-owned
'FoldVersion' into the snapshot discriminator. Change the fold version in the
same edit that changes the service's event-folding behavior.

'defaultStateCodec' builds the underlying codec for the @(state, registers)@ pair
of a keiki machine, serializing it as a JSON object @{ "state": …,
"registers": … }@. The state half uses its 'ToJSON' \/ 'FromJSON'
instances; the register half uses keiki's register-file JSON encoding. The
codec derives separate hashes for the control-state shape and register-file
layout, so structural changes transparently invalidate older snapshots (see
"Keiro.Snapshot").

Generated services use 'withFoldFingerprint' directly with a fingerprint
derived from their spec. Hand-written guard and update function bodies are not
structurally inspectable, so hand-written services should use
'defaultStateCodecWithFold' and maintain its explicit 'FoldVersion'.
-}
module Keiro.Snapshot.Codec (
    FoldVersion (..),
    defaultStateCodec,
    defaultStateCodecWithFold,
    withFoldFingerprint,
)
where

import Data.Aeson (Result (..), object, withObject, (.:))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types (parseEither)
import Data.Text qualified as Text
import Keiki.Codec.JSON (RegFileToJSON, regFileFromJSON, regFileToJSON)
import Keiki.Core (RegFile)
import Keiki.Shape (CanonicalStateShape, KnownRegFileShape, regFileShapeHash)
import Keiki.Shape qualified as Shape
import Keiro.EventStream (StateCodec (..))
import Keiro.Prelude

{- | A 'StateCodec' that serializes a @(state, registers)@ pair to a JSON
object, tagging it with the supplied codec version and hashes derived from the
control-state datatype and register-file layout.

This function does not identify changes to hand-written guards, register
updates, emitted outputs, targets, or helper functions used by the fold. Prefer
'defaultStateCodecWithFold' for hand-written services. Generated services use
'withFoldFingerprint' with a fingerprint derived from their spec.
-}
defaultStateCodec ::
    forall rs s.
    (CanonicalStateShape s, FromJSON s, KnownRegFileShape rs, RegFileToJSON rs, ToJSON s) =>
    Int ->
    StateCodec (s, RegFile rs)
defaultStateCodec version =
    StateCodec
        { stateCodecVersion = version
        , shapeHash = regFileShapeHash (Proxy @rs)
        , stateShapeHash = Shape.stateShapeHash (Proxy @s)
        , encode = \(state, registers) ->
            object
                [ "state" Aeson..= state
                , "registers" Aeson..= regFileToJSON registers
                ]
        , decode = decodeSnapshotValue
        }

{- | A hand-owned identity for a hand-written service's event fold.

The DSL derives a fold fingerprint from the spec automatically; a hand-written
service has no spec, so its fold identity must be owned by hand. Treat the
token as a change detector, not an encoding version: keep it stable while fold
semantics are stable, and change it in the same edit that changes any guard,
register update, emitted output, or target state, including logic in helper
functions the fold calls. A convention such as @"orders-fold-v3"@ keeps the
token greppable and reviewable. Forgetting to bump it recreates the silent
stale-snapshot hazard this type exists to prevent; see
'defaultStateCodecWithFold'.
-}
newtype FoldVersion = FoldVersion Text
    deriving stock (Eq, Show)

{- | The default snapshot codec for hand-written services: 'defaultStateCodec'
with a hand-owned 'FoldVersion' composed into the control-state discriminator
via 'withFoldFingerprint'.

Prefer this over bare 'defaultStateCodec' whenever the service's fold is
hand-written. A changed token changes the stored discriminator, so an old
snapshot is simply not found and hydration falls back to a full replay of the
event log: a performance cost, never wrong state. The rendered discriminator
stays operator-readable as @<state-shape-hash>;fold=<token>@.
-}
defaultStateCodecWithFold ::
    forall rs s.
    (CanonicalStateShape s, FromJSON s, KnownRegFileShape rs, RegFileToJSON rs, ToJSON s) =>
    FoldVersion ->
    Int ->
    StateCodec (s, RegFile rs)
defaultStateCodecWithFold (FoldVersion token) version =
    withFoldFingerprint token (defaultStateCodec version)

{- | Compose a caller-supplied fold identity into the control-state
discriminator.

The fingerprint is a change detector, not an encoding version. Keep it stable
when fold semantics are stable and change it whenever guards, updates, targets,
or other event-folding behavior changes. The rendered form remains
operator-readable as @<state-shape-hash>;fold=<fingerprint>@.
-}
withFoldFingerprint :: Text -> StateCodec state -> StateCodec state
withFoldFingerprint fingerprint codec =
    codec
        { stateShapeHash =
            codec ^. #stateShapeHash <> ";fold=" <> fingerprint
        }

decodeSnapshotValue ::
    forall rs s.
    (FromJSON s, RegFileToJSON rs) =>
    Value ->
    Either Text (s, RegFile rs)
decodeSnapshotValue value =
    case parseEither parser value of
        Left message -> Left (Text.pack message)
        Right pair -> Right pair
  where
    parser = withObject "Keiro snapshot" $ \objectValue -> do
        stateValue <- objectValue .: "state"
        registerValue <- objectValue .: "registers"
        state <- case Aeson.fromJSON stateValue of
            Error message -> fail ("state: " <> message)
            Success decoded -> pure decoded
        registers <- case regFileFromJSON @rs registerValue of
            Left message -> fail ("registers: " <> message)
            Right decoded -> pure decoded
        pure (state, registers)