diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,44 @@ ## [Unreleased] +## [0.2.0.0] — 2026-07-13 + +### Added + +- Event-codec schema evolution through pinned constructor wire kinds, + default-on-missing payload decoding, and a compile-time-complete chain of + one-envelope-to-one-envelope upcasters. +- `fieldCodec`, a strict smart constructor for `FieldCodec`, plus generated + `SchemaVersion` bindings. + +### Changed + +- **Breaking for invalid schemas:** `RegFileToJSON` now rejects duplicate slot + names at compile time through keiki's canonical `DistinctNames` invariant, + preventing Value-path data loss and duplicate streaming keys. +- Encoding now documents and pins the existing fully-initialized-register + precondition. Unwritten `emptyRegFile` slots throw a slot-named `ErrorCall`; + keiro already snapshots only fully populated register files, so it needs no + source change. +- **Breaking:** snapshot shape hashes now use keiki's pinned built-in type names. + Every non-empty shape hash changes once; stores keyed by an old hash ignore that + snapshot and replay from the event log. Keiro already treats this mismatch as a + benign cache miss. +- Container slot types now require their arguments to have + `CanonicalTypeName`, not merely `Typeable`, so user-defined types may need to + derive or define that class. This makes application overrides propagate through + `Maybe`, lists, `Either`, and tuples. +- **Breaking:** `EventCodecOptions` now also carries `kindOverrides`, + `versionFieldName`, `currentVersion`, and `upcasters`. +- **Breaking:** `FieldCodec` gains the `fcOnMissing` field. Positional + construction should be replaced with `fieldCodec` and a record update when a + missing-key default is required. +- **Breaking:** generated event envelopes now contain an in-band `"v"` field; + version-absent historical objects decode as version 1. +- **Breaking:** generated `EventTypes` and `KindMap` bindings contain resolved + wire kinds, including pinned values, rather than assuming constructor names. + + ## [0.1.0.0] — 2026-06-07 Initial Hackage release. Co-released with `keiki-0.1.0.0`; this diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -90,6 +90,26 @@ (non-record-syntax) constructors, and type synonyms are rejected at splice time with a precise error message. +## Register-file wire rules + +Every register slot must be written before encoding. `emptyRegFile` is an +initialization scaffold whose unwritten slots throw an `ErrorCall` beginning with +`uninit:` when read or encoded; it is not an encodable snapshot. On the streaming +path that exception can surface after earlier bytes have already been emitted, so +snapshot only fully hydrated aggregates. + +Every register slot is present in the JSON object. A `Nothing` slot encodes as +explicit JSON `null`; omitting its key is an error, not another spelling of +`Nothing`. A nested optional value is lossy under aeson's standard instances: +`Just Nothing :: Maybe (Maybe a)` and outer `Nothing` both encode as `null` and +decode as outer `Nothing`. Avoid nested-`Maybe` slots when that distinction +matters, or wrap the inner optional value in a newtype with explicit JSON +instances. + +The Value encoder emits aeson's object-key order, while the streaming Encoding +path emits slot-list order. Their bytes may differ, but both decode to the same +register file. + ## Deriving an event codec skeleton A service that stores its events as JSON usually hand-writes a @@ -109,9 +129,10 @@ import Data.Text (Text) import Keiki.Codec.JSON.Event ( EventCodecOptions (..) - , FieldCodec (..) + , FieldCodec (fcOnMissing) , defaultEventCodecOptions , deriveEventCodecSkeleton + , fieldCodec ) newtype OrderId = OrderId Int deriving stock (Eq, Show) @@ -138,7 +159,7 @@ $(deriveEventCodecSkeleton defaultEventCodecOptions { fieldCodecOverrides = - Map.fromList [("orderId", FieldCodec 'orderIdToJSON 'orderIdFromJSON)] + Map.fromList [("orderId", fieldCodec 'orderIdToJSON 'orderIdFromJSON)] , passthroughFields = Set.fromList ["qty", "trackingNo"] } ''OrderEvent) @@ -147,15 +168,18 @@ -- orderEventFromJSON :: Aeson.Value -> Either String OrderEvent -- orderEventEventTypes :: [Text] -- orderEventKindMap :: [(Text, Text)] +-- orderEventSchemaVersion :: Int ``` Each constructor encodes to an object carrying a `"kind"` discriminator -(its constructor name) plus one entry per payload field, so +(its constructor name unless pinned) and a `"v"` schema version, plus one +entry per payload field, so `orderEventToJSON (Placed (PlacedData (OrderId 7) 3))` is -`{"kind":"Placed","orderId":"ord-7","qty":3}` — note `orderId` is the -override's output, not a generic `Int`. The `orderEventEventTypes` / -`orderEventKindMap` bindings are plain `Text` (no Keiro dependency) so a -downstream can feed them to Keiro's `Codec.eventTypes`. +`{"kind":"Placed","v":1,"orderId":"ord-7","qty":3}` — note `orderId` +is the override's output, not a generic `Int`. The +`orderEventEventTypes` / `orderEventKindMap` bindings contain the resolved +wire kinds as plain `Text` (no Keiro dependency), and +`orderEventSchemaVersion` contains the configured current version. **No silent generic fallback.** Each payload field is encoded by *name*: an override (`fieldCodecOverrides`), a passthrough using the field's own @@ -170,6 +194,73 @@ Constructors that are multi-argument, use record syntax directly, or are GADT/infix are rejected at splice time with a precise message; wrap a single record payload type instead (`Placed PlacedData`). + +### Evolving an event schema + +There are three common changes, each with a distinct codec move. + +1. **Add a payload field without bumping the version.** For an optional + field such as `note :: Maybe Text`, add `"note"` to + `passthroughFields`; a missing key decodes as `Nothing`, while an + explicit JSON `null` also follows aeson's normal `Maybe` decoder. For a + non-`Maybe` field, provide a named default constant through the override: + + ```haskell + defaultPriority :: Priority + defaultPriority = NormalPriority + + priorityCodec :: FieldCodec + priorityCodec = + (fieldCodec 'priorityToJSON 'priorityFromJSON) + { fcOnMissing = Just 'defaultPriority } + ``` + + Put `priorityCodec` in `fieldCodecOverrides`. Keep `currentVersion` + unchanged: this is an additive compatibility rule, not a structural + migration. Required fields without either form of default still fail with + `missing field: `. + +2. **Rename a Haskell constructor without changing stored bytes.** Pin the + renamed constructor to its historical discriminator: + + ```haskell + kindOverrides = Map.fromList [("OrderPlaced", "Placed")] + ``` + + Override keys are current constructor names. The splice rejects unknown + keys and duplicate resolved wire kinds, while encoding, decoding, + `EventTypes`, and `KindMap` all use the pinned wire value. + +3. **Restructure a payload.** Increment `currentVersion` and register one + whole-envelope upcaster for every historical step: + + ```haskell + upcastOrderV1 :: Aeson.Value -> Either String Aeson.Value + upcastOrderV1 = ... -- rewrite a version-1 object into version-2 shape + + currentVersion = 2 + upcasters = [(1, 'upcastOrderV1)] + ``` + + An absent `"v"` is version 1. Before constructor dispatch, the decoder + runs every rung from the stored version to the current version. For + `currentVersion = n`, the splice requires exactly the source versions + `[1 .. n - 1]`; gaps, duplicates, and out-of-range entries fail at compile + time. A rung is one-envelope-to-one-envelope. If one historical event must + split into several current events, do that in the application's event-store + adapter as described in + [`docs/research/schema-evolution.md`](../docs/research/schema-evolution.md). + +Unknown object keys are intentionally ignored by the event decoder so additive +deployments can overlap. This differs from the RegFile snapshot decoder, which +rejects extra keys because a snapshot must match one exact register shape. + +The in-band `"v"` is opt-in version ownership for applications that have no +outer event envelope. If an application already owns out-of-band metadata — for +example, a keiro-style `schemaVersion` beside the payload — keep this codec's +`currentVersion = 1` and evolve at that outer layer. Running both schemes with +different version numbers is a configuration error; neither layer detects the +disagreement for the other. ## When to use the streaming encoder diff --git a/keiki-codec-json.cabal b/keiki-codec-json.cabal --- a/keiki-codec-json.cabal +++ b/keiki-codec-json.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: keiki-codec-json -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Optional JSON codec for keiki's RegFile. description: Sibling package to keiki providing a JSON encoder, decoder, and @@ -43,8 +43,16 @@ CONTRIBUTING.md README.md -extra-source-files: bench/baseline.csv +extra-source-files: + bench/baseline.csv + test/golden/*.json + test/golden/event/*.json +source-repository head + type: git + location: https://github.com/shinzui/keiki.git + subdir: keiki-codec-json + common warnings ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates @@ -73,7 +81,8 @@ , aeson ^>=2.2 , base ^>=4.21 , containers ^>=0.7 - , keiki ^>=0.1 + , keiki ^>=0.2 + , scientific ^>=0.3 , template-haskell ^>=2.23 , text ^>=2.1 @@ -87,8 +96,8 @@ , base ^>=4.21 , bytestring ^>=0.12 , deepseq ^>=1.5 - , keiki ^>=0.1 - , keiki-codec-json ^>=0.1 + , keiki ^>=0.2 + , keiki-codec-json ^>=0.2 , tasty-bench ^>=0.4 || ^>=0.5 , text ^>=2.1 @@ -101,9 +110,11 @@ main-is: Spec.hs other-modules: Keiki.Codec.JSON.Fixtures + Keiki.Codec.JSON.GoldenFileSpec Keiki.Codec.JSON.GoldenSpec Keiki.Codec.JSON.PropSpec Keiki.Codec.JSON.SensitivitySpec + Keiki.Codec.JSON.THEventEvolutionSpec Keiki.Codec.JSON.THEventSpec Keiki.Codec.JSON.THSpec @@ -113,8 +124,8 @@ , bytestring ^>=0.12 , containers ^>=0.7 , hspec ^>=2.11 - , keiki ^>=0.1 - , keiki-codec-json ^>=0.1 + , keiki ^>=0.2 + , keiki-codec-json ^>=0.2 , QuickCheck ^>=2.15 , quickcheck-instances ^>=0.3 , text ^>=2.1 diff --git a/src/Keiki/Codec/JSON.hs b/src/Keiki/Codec/JSON.hs --- a/src/Keiki/Codec/JSON.hs +++ b/src/Keiki/Codec/JSON.hs @@ -20,6 +20,31 @@ -- snapshots (catches structural drift, EP-36 §4 cases #1–9); the -- codec serialises the eligible ones. -- +-- == Wire-format rules +-- +-- Every slot must have been written before encoding. Encoding a register file +-- seeded by @Keiki.Generics.emptyRegFile@ but not fully initialized throws an +-- 'Control.Exception.ErrorCall' whose message starts with @uninit:@. On the +-- streaming path the exception can surface after an earlier part of the object +-- has already been emitted, so snapshot only fully hydrated aggregates. +-- +-- Slot names must also be pairwise distinct. 'RegFileToJSON' applies the +-- canonical @Keiki.Internal.Slots.DistinctNames (Keiki.Internal.Slots.Names +-- rs)@ invariant at compile time. Without it, the Value path would silently +-- retain only one duplicate key, the streaming path would emit the key twice, +-- and decoding could never populate the second slot. +-- +-- A @Nothing@ slot is present as explicit JSON @null@. Omitting the key is +-- not equivalent: 'regFileFromJSON' rejects every absent slot. A nested +-- @Maybe@ is not faithfully representable by aeson's standard instances: +-- @Just Nothing@ and @Nothing@ both encode as @null@ and decode as outer +-- @Nothing@. Avoid @Maybe (Maybe a)@ slots when that distinction matters, or +-- wrap the inner optional value in a newtype with explicit JSON instances. +-- +-- The 'Aeson.Value' path serializes object keys in aeson's KeyMap order +-- (alphabetical with aeson 2.2), while 'regFileToEncoding' preserves slot-list +-- order. The byte streams may differ; both decode to the same register file. +-- -- == Slot-value size guidance (P11) -- -- keiki's per-slot dispatch overhead is microseconds at any realistic @@ -57,6 +82,7 @@ import Data.Proxy (Proxy (..)) import GHC.TypeLits (KnownSymbol, symbolVal) import Keiki.Core (RegFile (..), Slot) +import Keiki.Internal.Slots (DistinctNames, Names) -- * Internal walker ----------------------------------------------------------- @@ -134,6 +160,10 @@ class (RegFileWalk rs) => RegFileToJSON (rs :: [Slot]) where -- | Encode a slot list as a JSON object whose keys are the slot -- symbols, in slot-list order. + -- + -- Precondition: every slot must have been written. An unwritten + -- @Keiki.Generics.emptyRegFile@ slot throws an + -- 'Control.Exception.ErrorCall' whose message starts with @uninit:@. regFileToJSON :: RegFile rs -> Aeson.Value regFileToJSON = Aeson.object . regFilePairs @@ -142,6 +172,11 @@ -- 'Aeson.Value' intermediate. Recommended for RegFiles with -- multi-MB slot values; see the module header's "Slot-value size -- guidance". + -- + -- Precondition: every slot must have been written. An unwritten + -- @Keiki.Generics.emptyRegFile@ slot throws an + -- 'Control.Exception.ErrorCall' whose message starts with @uninit:@, + -- potentially after earlier bytes have been emitted downstream. regFileToEncoding :: RegFile rs -> Aeson.Encoding regFileToEncoding = Aeson.pairs . regFileSeries @@ -165,5 +200,17 @@ -- coverage is a 'RegFileToJSON'. Users do not write instances of this -- class themselves; the inductive 'RegFileWalk' instances (one for -- @'[]@, one for @\'(s, t) \': rs@) cover every slot list whose --- component types carry 'Aeson.ToJSON' and 'Aeson.FromJSON'. -instance (RegFileWalk rs) => RegFileToJSON rs +-- component types carry 'Aeson.ToJSON' and 'Aeson.FromJSON'. The +-- 'DistinctNames' constraint rejects duplicate slot symbols before either +-- encoder can lose data or emit ambiguous JSON. +-- +-- == Negative-test procedure (manual) +-- +-- With @DataKinds@ and @TypeApplications@ enabled, this definition must fail +-- to compile with @register file declares slot "x" more than once@: +-- +-- @ +-- duplicateCodec :: RegFile '[ '("x", Int), '("x", Bool)] -> Aeson.Value +-- duplicateCodec = regFileToJSON +-- @ +instance (RegFileWalk rs, DistinctNames (Names rs)) => RegFileToJSON rs diff --git a/src/Keiki/Codec/JSON/Event.hs b/src/Keiki/Codec/JSON/Event.hs --- a/src/Keiki/Codec/JSON/Event.hs +++ b/src/Keiki/Codec/JSON/Event.hs @@ -16,28 +16,59 @@ -- > | Cancelled -- > deriving stock (Eq, Show) -- --- the splice @$(deriveEventCodecSkeleton opts ''OrderEvent)@ emits four +-- the splice @$(deriveEventCodecSkeleton opts ''OrderEvent)@ emits five -- top-level bindings (prefix derived by lower-casing the first letter of the -- type name): -- -- > orderEventToJSON :: OrderEvent -> Aeson.Value -- > orderEventFromJSON :: Aeson.Value -> Either String OrderEvent --- > orderEventEventTypes :: [Data.Text.Text] -- ctor names, in order +-- > orderEventEventTypes :: [Data.Text.Text] -- wire kinds, in order -- > orderEventKindMap :: [(Data.Text.Text, Data.Text.Text)] -- (ctor, kind) +-- > orderEventSchemaVersion :: Int -- -- Each constructor encodes to a JSON object carrying a @"kind"@ --- discriminator (the constructor name) plus one entry per payload field. --- The decoder reads @"kind"@, branches, and reassembles the payload field --- by field. +-- discriminator (the pinned wire kind, or the constructor name by default) +-- and an in-band @"v"@ schema version, plus one entry per payload field. -- +-- Decoding follows a fixed pipeline: validate the stored version (an absent +-- @"v"@ means version 1), run every required whole-object upcaster in order, +-- dispatch on the migrated @"kind"@, then decode payload fields and apply any +-- missing-key defaults. Upcasters run before dispatch, so a structural change +-- may rewrite the discriminator as well as payload keys. +-- +-- == Evolving an event schema +-- +-- For an additive field, keep 'currentVersion' unchanged and either make the +-- field a syntactic @Maybe t@ passthrough or give its 'FieldCodec' an +-- 'fcOnMissing' constant. For a structural payload change, increment +-- 'currentVersion' and add the complete next rung to 'upcasters'. For a Haskell +-- constructor rename, preserve its old wire discriminator with 'kindOverrides'. +-- +-- Each upcaster maps one envelope to one envelope. Splitting one historical +-- event into several current events remains an application-boundary concern; +-- see @docs/research/schema-evolution.md@ for that wider contract. The pure +-- @keiki@ core remains version-agnostic. +-- +-- == Unknown object keys +-- +-- Event decoding intentionally ignores keys that are not current payload or +-- envelope fields. This permits old and new readers to coexist during additive +-- deployments. The snapshot-oriented @RegFileToJSON@ decoder instead rejects +-- extra keys because a register snapshot must match one exact shape; the two +-- codecs serve different compatibility contracts. +-- -- == No silent generic fallback (the anti-drift property) -- -- A payload field is encoded one of three ways, chosen by /field name/: -- -- * if its name is a key of 'fieldCodecOverrides', the author-supplied --- 'FieldCodec' functions are spliced in; +-- 'FieldCodec' functions are spliced in; an absent key uses +-- 'fcOnMissing' when supplied and otherwise remains an error; -- * else if its name is in 'passthroughFields', the field's own --- 'Aeson.ToJSON' \/ 'Aeson.FromJSON' instances are used; +-- 'Aeson.ToJSON' \/ 'Aeson.FromJSON' instances are used. A field whose +-- reified type is syntactically @Maybe t@ decodes an absent key as +-- 'Nothing'; type synonyms are not expanded, and all other passthrough +-- fields remain strict; -- * otherwise the field is /unhandled/, and 'onMissingCodec' decides: -- 'FailAtCompileTime' (the default) aborts the splice listing every -- unhandled field, while 'EmitTodoBindings' emits a clearly-named @@ -57,12 +88,13 @@ -- == Negative-test procedure (manual) -- -- See @Keiki.Codec.JSON.THEventSpec@ for the documented procedure that --- exercises the 'FailAtCompileTime' and 'EmitTodoBindings' behaviours; the --- two cases cannot live as a passing unit test because one is a compile --- failure. +-- exercises compile-time configuration failures and the 'EmitTodoBindings' +-- behaviour. Those checks cannot all live as passing unit tests because their +-- expected result is a compile failure. module Keiki.Codec.JSON.Event ( -- * Options FieldCodec (..), + fieldCodec, OnMissingCodec (..), EventCodecOptions (..), defaultEventCodecOptions, @@ -73,7 +105,10 @@ -- * Runtime helpers (referenced by generated code; not usually called directly) lookupField, + lookupFieldMaybe, lookupText, + lookupVersion, + migrateEnvelope, aesonResultToEither, ) where @@ -82,9 +117,10 @@ import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap import Data.Char (toLower) -import Data.List (intercalate) +import Data.List (group, intercalate, sort, sortOn, (\\)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Scientific qualified as Scientific import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) @@ -98,12 +134,24 @@ -- -- * 'fcEncode' names a function @fieldType -> Aeson.Value@ (e.g. @idText@); -- * 'fcDecode' names a function @Aeson.Value -> Either String fieldType@ --- (e.g. @parseIdText@). +-- (e.g. @parseIdText@); +-- * 'fcOnMissing' optionally names a top-level /constant/ of the field type, +-- used only when the JSON key is absent. data FieldCodec = FieldCodec { fcEncode :: Name, - fcDecode :: Name + fcDecode :: Name, + fcOnMissing :: Maybe Name } +-- | Construct a strict field codec with no missing-key default. +fieldCodec :: Name -> Name -> FieldCodec +fieldCodec encodeName decodeName = + FieldCodec + { fcEncode = encodeName, + fcDecode = decodeName, + fcOnMissing = Nothing + } + -- | What to do for a payload field whose name appears in neither -- 'fieldCodecOverrides' nor 'passthroughFields'. data OnMissingCodec @@ -123,11 +171,25 @@ passthroughFields :: Set String, -- | the discriminator key; default @"kind"@ kindFieldName :: String, + -- | constructor base name to stable wire kind. Constructors omitted from + -- this map use their Haskell name. Override keys and resolved wire kinds + -- are validated when the splice runs. + kindOverrides :: Map String String, + -- | the in-band schema-version key; default @"v"@ + versionFieldName :: String, + -- | current schema version stamped by the encoder; must be at least @1@ + currentVersion :: Int, + -- | one whole-envelope migration per historical from-version. A version + -- @n@ function upgrades to version @n + 1@; the splice requires exact + -- coverage of @[1 .. currentVersion - 1]@. + upcasters :: [(Int, Name)], -- | behaviour for unhandled fields; default 'FailAtCompileTime' onMissingCodec :: OnMissingCodec } --- | Empty overrides, empty passthrough, @kindFieldName = "kind"@, +-- | Empty field and kind overrides, empty passthrough, +-- @kindFieldName = "kind"@, @versionFieldName = "v"@, +-- @currentVersion = 1@, no upcasters, and -- @onMissingCodec = 'FailAtCompileTime'@. defaultEventCodecOptions :: EventCodecOptions defaultEventCodecOptions = @@ -135,6 +197,10 @@ { fieldCodecOverrides = Map.empty, passthroughFields = Set.empty, kindFieldName = "kind", + kindOverrides = Map.empty, + versionFieldName = "v", + currentVersion = 1, + upcasters = [], onMissingCodec = FailAtCompileTime } @@ -146,6 +212,10 @@ Just v -> Right v Nothing -> Left ("missing field: " <> Key.toString k) +-- | Total object lookup: 'Nothing' when the key is absent. +lookupFieldMaybe :: Key.Key -> Aeson.Object -> Maybe Aeson.Value +lookupFieldMaybe = KeyMap.lookup + -- | Look a key up and require its value to be a JSON string. lookupText :: Key.Key -> Aeson.Object -> Either String Text lookupText k o = do @@ -154,6 +224,47 @@ Aeson.String t -> Right t _ -> Left ("field " <> Key.toString k <> ": expected a string") +-- | Read an in-band schema version. An absent key means version @1@; a +-- present value must be an integral JSON number representable as an 'Int'. +lookupVersion :: Key.Key -> Aeson.Object -> Either String Int +lookupVersion k o = case KeyMap.lookup k o of + Nothing -> Right 1 + Just (Aeson.Number number) -> + maybe + (Left expectedInteger) + Right + (Scientific.toBoundedInteger number) + Just _ -> Left expectedInteger + where + expectedInteger = + "field " <> Key.toString k <> ": expected an integer schema version" + +-- | Replay a compile-time-complete chain from the stored version to the +-- current version. Rungs run in ascending source-version order; the only +-- expected runtime failure is a rung rejecting its input. +migrateEnvelope :: + Int -> + [(Int, Aeson.Value -> Either String Aeson.Value)] -> + Int -> + Aeson.Value -> + Either String Aeson.Value +migrateEnvelope targetVersion chain storedVersion = + go applicableRungs + where + applicableRungs = + [ rung + | rung@(fromVersion, _) <- sortOn fst chain, + fromVersion >= storedVersion, + fromVersion < targetVersion + ] + + go [] value = Right value + go ((fromVersion, upcast) : rest) value = + case upcast value of + Left message -> + Left ("upcaster from version " <> show fromVersion <> ": " <> message) + Right nextValue -> go rest nextValue + -- | Adapt aeson's 'Aeson.Result' to @Either String@. aesonResultToEither :: Aeson.Result a -> Either String a aesonResultToEither (Aeson.Success a) = Right a @@ -180,6 +291,10 @@ <> " has no constructors; pass an event sum type." _ -> pure () + validateWireKinds opts tyName ctors + validateVersionEnvelope opts ctors + validateUpcasters opts + -- No-silent-fallback safety net: classify each payload field; an -- unhandled field is one in neither overrides nor passthrough. let unhandled = @@ -211,6 +326,7 @@ fromJSONN = mkName (prefix <> "FromJSON") eventTypesN = mkName (prefix <> "EventTypes") kindMapN = mkName (prefix <> "KindMap") + schemaVersionN = mkName (prefix <> "SchemaVersion") tyT = conT tyName -- Encoder: one clause per constructor. @@ -221,13 +337,14 @@ vVar <- newName "v" oVar <- newName "o" kVar <- newName "kind" + versionVar <- newName "version" fromSig <- sigD fromJSONN [t|Aeson.Value -> Either String $tyT|] fromDef <- funD fromJSONN [ clause [varP vVar] - (normalB (decoderBody opts prefix vVar oVar kVar ctors)) + (normalB (decoderBody opts prefix vVar oVar kVar versionVar ctors)) [] ] @@ -240,7 +357,7 @@ [] ( normalB ( listE - [ [|T.pack $(stringE (nameBase (ecCtorName ec)))|] + [ [|T.pack $(stringE (wireKindOf opts (ecCtorName ec)))|] | ec <- ctors ] ) @@ -255,14 +372,22 @@ [] ( normalB ( listE - [ [|(T.pack $(stringE nm), T.pack $(stringE nm))|] - | ec <- ctors, - let nm = nameBase (ecCtorName ec) + [ [| + ( T.pack $(stringE (nameBase (ecCtorName ec))), + T.pack $(stringE (wireKindOf opts (ecCtorName ec))) + ) + |] + | ec <- ctors ] ) ) [] ] + svSig <- sigD schemaVersionN [t|Int|] + svDef <- + funD + schemaVersionN + [clause [] (normalB (litE (IntegerL (fromIntegral (currentVersion opts))))) []] pure $ todoBindings @@ -273,7 +398,9 @@ etSig, etDef, kmSig, - kmDef + kmDef, + svSig, + svDef ] -- * Encoder generation ------------------------------------------------------- @@ -284,11 +411,14 @@ Nothing -> clause [conP (ecCtorName ec) []] - (normalB [|Aeson.object [$(kindPair)]|]) + (normalB [|Aeson.object [$(kindPair), $(versionPair)]|]) [] Just (_pc, fields) -> do pVar <- newName "p" - let pairs = kindPair : map (fieldPair opts (ecCtorName ec) pVar) fields + let pairs = + kindPair + : versionPair + : map (fieldPair opts (ecCtorName ec) pVar) fields clause [conP (ecCtorName ec) [varP pVar]] (normalB [|Aeson.object $(listE pairs)|]) @@ -297,8 +427,13 @@ kindPair = [| $(keyE (kindFieldName opts)) - Aeson..= (T.pack $(stringE (nameBase (ecCtorName ec))) :: Text) + Aeson..= (T.pack $(stringE (wireKindOf opts (ecCtorName ec))) :: Text) |] + versionPair = + [| + $(keyE (versionFieldName opts)) + Aeson..= ($(litE (IntegerL (fromIntegral (currentVersion opts)))) :: Int) + |] -- | One @"field" .= @ pair. fieldPair :: EventCodecOptions -> Name -> Name -> (String, Name, Type) -> Q Exp @@ -318,17 +453,17 @@ -- | The full @fromJSON@ body: @case v of Object o -> ...; _ -> Left ...@. decoderBody :: - EventCodecOptions -> String -> Name -> Name -> Name -> [EvCtor] -> Q Exp -decoderBody opts prefix vVar oVar kVar ctors = + EventCodecOptions -> String -> Name -> Name -> Name -> Name -> [EvCtor] -> Q Exp +decoderBody opts prefix vVar oVar kVar versionVar ctors = caseE (varE vVar) [ match (conP 'Aeson.Object [varP oVar]) ( normalB ( infixE - (Just [|lookupText $(keyE (kindFieldName opts)) $(varE oVar)|]) + (Just [|lookupVersion $(keyE (versionFieldName opts)) $(varE oVar)|]) (varE '(>>=)) - (Just (lamE [varP kVar] (dispatch opts oVar kVar ctors))) + (Just (lamE [varP versionVar] versionGuard)) ) ) [], @@ -337,20 +472,104 @@ (normalB [|Left $(stringE (prefix <> ": expected a JSON object"))|]) [] ] + where + currentVersionE = litE (IntegerL (fromIntegral (currentVersion opts))) + dispatchMigrated migratedObjectVar = + infixE + ( Just + [| + lookupText + $(keyE (kindFieldName opts)) + $(varE migratedObjectVar) + |] + ) + (varE '(>>=)) + ( Just + ( lamE + [varP kVar] + (dispatch opts migratedObjectVar kVar ctors) + ) + ) + migratedObjectCase migratedValueVar migratedObjectVar = + caseE + (varE migratedValueVar) + [ match + (conP 'Aeson.Object [varP migratedObjectVar]) + (normalB (dispatchMigrated migratedObjectVar)) + [], + match + wildP + (normalB [|Left $(stringE (prefix <> ": expected a JSON object"))|]) + [] + ] + migrateCurrent migratedValueVar migratedObjectVar = + infixE + ( Just + [| + migrateEnvelope + ($currentVersionE :: Int) + $(upcasterChainE opts) + $(varE versionVar) + (Aeson.Object $(varE oVar)) + |] + ) + (varE '(>>=)) + ( Just + ( lamE + [varP migratedValueVar] + (migratedObjectCase migratedValueVar migratedObjectVar) + ) + ) + versionGuard = do + migratedValueVar <- newName "migratedValue" + migratedObjectVar <- newName "migratedObject" + [| + if $(varE versionVar) < 1 + then Left ("invalid event schema version: " <> show $(varE versionVar)) + else + if $(varE versionVar) > ($currentVersionE :: Int) + then + Left + ( "event schema version " + <> show $(varE versionVar) + <> " is ahead of codec version " + <> show ($currentVersionE :: Int) + ) + else $(migrateCurrent migratedValueVar migratedObjectVar) + |] +upcasterChainE :: EventCodecOptions -> Q Exp +upcasterChainE opts = + listE + [ [|($(litE (IntegerL (fromIntegral fromVersion))) :: Int, $(varE upcastName))|] + | (fromVersion, upcastName) <- sortOn fst (upcasters opts) + ] + -- | Nested @if kind == "C" then else ...@ ending in an -- unknown-kind 'Left'. dispatch :: EventCodecOptions -> Name -> Name -> [EvCtor] -> Q Exp -dispatch opts oVar kVar = +dispatch opts oVar kVar ctors = foldr ( \ec elseQ -> [| - if $(varE kVar) == T.pack $(stringE (nameBase (ecCtorName ec))) + if $(varE kVar) == T.pack $(stringE (wireKindOf opts (ecCtorName ec))) then $(buildCtorDecode opts oVar ec) else $elseQ |] ) - [|Left ("unknown event kind: " <> T.unpack $(varE kVar))|] + [| + Left + ( "unknown event kind: " + <> T.unpack $(varE kVar) + <> $(stringE expectedKinds) + ) + |] + ctors + where + expectedKinds = + " (expected one of: " + <> intercalate ", " (map (wireKindOf opts . ecCtorName) ctors) + <> ")" -- | Decode one constructor's payload: @C \<$> (PayloadCtor \<$> d1 \<*> ...)@. buildCtorDecode :: EventCodecOptions -> Name -> EvCtor -> Q Exp @@ -369,13 +588,33 @@ -- | @Either String fieldType@ decoder for one field. decodeFieldExpr :: EventCodecOptions -> Name -> Name -> (String, Name, Type) -> Q Exp -decodeFieldExpr opts oVar ctorName (fn, _sel, _ft) = +decodeFieldExpr opts oVar ctorName (fn, _sel, ft) = let getV = [|lookupField $(keyE fn) $(varE oVar)|] in case classify opts fn of - Override fc -> [|$(varE (fcDecode fc)) =<< $getV|] - Passthrough -> [|(aesonResultToEither . Aeson.fromJSON) =<< $getV|] + Override fc -> case fcOnMissing fc of + Nothing -> [|$(varE (fcDecode fc)) =<< $getV|] + Just missingDefault -> + [| + case lookupFieldMaybe $(keyE fn) $(varE oVar) of + Nothing -> Right $(varE missingDefault) + Just fieldValue -> $(varE (fcDecode fc)) fieldValue + |] + Passthrough + | isSyntacticMaybe ft -> + [| + case lookupFieldMaybe $(keyE fn) $(varE oVar) of + Nothing -> Right Nothing + Just fieldValue -> aesonResultToEither (Aeson.fromJSON fieldValue) + |] + | otherwise -> [|(aesonResultToEither . Aeson.fromJSON) =<< $getV|] Unhandled -> [|$(varE (todoName ctorName fn)) =<< $getV|] +isSyntacticMaybe :: Type -> Bool +isSyntacticMaybe (SigT ty _) = isSyntacticMaybe ty +isSyntacticMaybe (ParensT ty) = isSyntacticMaybe ty +isSyntacticMaybe (AppT (ConT maybeName) _) = maybeName == ''Maybe +isSyntacticMaybe _ = False + -- * TODO bindings ------------------------------------------------------------ -- | The placeholder binding name for an unhandled field. @@ -418,6 +657,159 @@ isUnhandled opts fn = not (fn `Map.member` fieldCodecOverrides opts) && not (fn `Set.member` passthroughFields opts) + +-- * Wire-kind validation ---------------------------------------------------- + +wireKindOf :: EventCodecOptions -> Name -> String +wireKindOf opts ctorName = + Map.findWithDefault ctorBase ctorBase (kindOverrides opts) + where + ctorBase = nameBase ctorName + +validateWireKinds :: EventCodecOptions -> Name -> [EvCtor] -> Q () +validateWireKinds opts tyName ctors = do + case unknownOverrideKeys of + [] -> pure () + unknownKeys -> + fail . intercalate "\n" $ + [ "deriveEventCodecSkeleton: kindOverrides key " + <> show key + <> " is not a constructor of " + <> nameBase tyName + <> "." + | key <- unknownKeys + ] + + case duplicateWireKinds of + [] -> pure () + duplicates -> + fail . intercalate "\n" $ + [ "deriveEventCodecSkeleton: wire kind " + <> show wireKind + <> " is claimed by more than one constructor: " + <> intercalate ", " owners + <> ". Wire kinds must be unique per event type." + | (wireKind, owners) <- duplicates + ] + + case discriminatorCollisions of + [] -> pure () + collisions -> + fail . intercalate "\n" $ + [ "deriveEventCodecSkeleton: payload field " + <> nameBase ctorName + <> "." + <> fieldName + <> " collides with kindFieldName " + <> show (kindFieldName opts) + <> "; rename the field or choose a kindFieldName no payload uses." + | (ctorName, fieldName) <- collisions + ] + where + ctorBaseNames = map (nameBase . ecCtorName) ctors + knownConstructors = Set.fromList ctorBaseNames + unknownOverrideKeys = + Set.toList (Map.keysSet (kindOverrides opts) `Set.difference` knownConstructors) + wireKindOwners = + Map.fromListWith + (flip (<>)) + [ (wireKindOf opts (ecCtorName ec), [nameBase (ecCtorName ec)]) + | ec <- ctors + ] + duplicateWireKinds = + [ (wireKind, owners) + | (wireKind, owners) <- Map.toList wireKindOwners, + length owners > 1 + ] + discriminatorCollisions = + [ (ecCtorName ec, fieldName) + | ec <- ctors, + (_, fields) <- maybe [] (: []) (ecPayload ec), + (fieldName, _, _) <- fields, + fieldName == kindFieldName opts + ] + +validateVersionEnvelope :: EventCodecOptions -> [EvCtor] -> Q () +validateVersionEnvelope opts ctors = do + if currentVersion opts < 1 + then + fail $ + "deriveEventCodecSkeleton: currentVersion must be >= 1, got " + <> show (currentVersion opts) + <> "." + else pure () + + if kindFieldName opts == versionFieldName opts + then + fail $ + "deriveEventCodecSkeleton: kindFieldName " + <> show (kindFieldName opts) + <> " collides with versionFieldName " + <> show (versionFieldName opts) + <> "; choose distinct envelope keys." + else pure () + + case versionCollisions of + [] -> pure () + collisions -> + fail . intercalate "\n" $ + [ "deriveEventCodecSkeleton: payload field " + <> nameBase ctorName + <> "." + <> fieldName + <> " collides with versionFieldName " + <> show (versionFieldName opts) + <> "; rename the field or choose a versionFieldName no payload uses." + | (ctorName, fieldName) <- collisions + ] + where + versionCollisions = + [ (ecCtorName ec, fieldName) + | ec <- ctors, + (_, fields) <- maybe [] (: []) (ecPayload ec), + (fieldName, _, _) <- fields, + fieldName == versionFieldName opts + ] + +validateUpcasters :: EventCodecOptions -> Q () +validateUpcasters opts = do + case duplicateSources of + [] -> pure () + duplicates -> + fail $ + "deriveEventCodecSkeleton: duplicate upcaster from-versions: " + <> show duplicates + + case outOfRangeSources of + [] -> pure () + invalidSources -> + fail $ + "deriveEventCodecSkeleton: upcaster from-versions must be >= 1 and < currentVersion " + <> show (currentVersion opts) + <> "; out of range: " + <> show invalidSources + + case missingSources of + [] -> pure () + missing -> + fail $ + "deriveEventCodecSkeleton: upcasters must cover from-versions [1.." + <> show (currentVersion opts - 1) + <> "] exactly; missing: " + <> show missing + where + sources = map fst (upcasters opts) + expectedSources = [1 .. currentVersion opts - 1] + duplicateSources = + [ source + | source : _ : _ <- group (sort sources) + ] + outOfRangeSources = + [ source + | source <- sort sources, + source < 1 || source >= currentVersion opts + ] + missingSources = expectedSources \\ sources -- * Reflection --------------------------------------------------------------- diff --git a/src/Keiki/Codec/JSON/TH.hs b/src/Keiki/Codec/JSON/TH.hs --- a/src/Keiki/Codec/JSON/TH.hs +++ b/src/Keiki/Codec/JSON/TH.hs @@ -1,35 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} --- \$('deriveRegFileCodec' \'\'MySnapshot) --- @ --- --- to emit three top-level functions --- --- @ --- mySnapshotToJSON :: MySnapshot -> Aeson.Value --- mySnapshotToEncoding :: MySnapshot -> Aeson.Encoding --- mySnapshotFromJSON :: Aeson.Value -> Either String MySnapshot --- @ --- --- Each function routes through the existing --- 'Keiki.Codec.JSON.RegFileToJSON' class against the slot list --- @'Keiki.Generics.RegFieldsOf' MySnapshot@. The record's field names --- become the JSON object's keys; the record's field types must each --- carry 'Aeson.ToJSON' and 'Aeson.FromJSON' or compilation fails with a --- precise per-field error. --- --- This splice lives in @keiki-codec-json@ (not in @keiki@'s --- @Keiki.Generics.TH@). The class @RegFileToJSON@ is defined here, and --- moving the splice to @keiki@ would force an @aeson@ dependency on --- @keiki@ core — violating the load-bearing --- /keiki MUST NOT gain @aeson@/ requirement (EP-36 §3 R8; MP-11 --- Decision Log 2026-05-10). The splice does reuse the structural --- machinery in @keiki@'s @Keiki.Generics@ ('Keiki.Generics.RegFieldsOf', --- 'Keiki.Generics.gToRegFile', 'Keiki.Generics.gFromRegFile') so the --- composition with the existing 'Keiki.Generics.TH' ergonomics --- (@mkInCtorVia@, @mkWireCtorVia@, @deriveAggregateCtors@, etc.) is --- preserved. - -- | -- Module : Keiki.Codec.JSON.TH -- Description : Template Haskell helpers that emit @RegFile@-routed JSON @@ -43,12 +13,34 @@ -- , correlationId :: Text -- , dispatchedAt :: UTCTime -- } --- deriving stock ('Eq', 'Show', GHC.Generics.'GHC.Generics.Generic') +-- deriving stock (Eq, Show, Generic) -- @ -- -- invokes -- -- @ +-- \$('deriveRegFileCodec' \'\'MySnapshot) +-- +-- mySnapshotToJSON :: MySnapshot -> Aeson.Value +-- mySnapshotToEncoding :: MySnapshot -> Aeson.Encoding +-- mySnapshotFromJSON :: Aeson.Value -> Either String MySnapshot +-- @ +-- +-- to emit those three top-level functions. Each function routes through the +-- existing 'Keiki.Codec.JSON.RegFileToJSON' class against the slot list +-- @'Keiki.Generics.RegFieldsOf' MySnapshot@. The record's field names become +-- the JSON object's keys; the record's field types must each carry +-- 'Aeson.ToJSON' and 'Aeson.FromJSON' or compilation fails with a precise +-- per-field error. +-- +-- This splice lives in @keiki-codec-json@ (not in @keiki@'s +-- @Keiki.Generics.TH@). The class @RegFileToJSON@ is defined here, and moving +-- the splice to @keiki@ would force an @aeson@ dependency on @keiki@ core — +-- violating the load-bearing /keiki MUST NOT gain @aeson@/ requirement (EP-36 +-- §3 R8; MP-11 Decision Log 2026-05-10). The splice does reuse the structural +-- machinery in @keiki@'s @Keiki.Generics@ ('Keiki.Generics.RegFieldsOf', +-- 'Keiki.Generics.gToRegFile', 'Keiki.Generics.gFromRegFile') so composition +-- with the existing 'Keiki.Generics.TH' ergonomics is preserved. module Keiki.Codec.JSON.TH ( deriveRegFileCodec, deriveRegFileCodecAs, diff --git a/test/Keiki/Codec/JSON/Fixtures.hs b/test/Keiki/Codec/JSON/Fixtures.hs --- a/test/Keiki/Codec/JSON/Fixtures.hs +++ b/test/Keiki/Codec/JSON/Fixtures.hs @@ -8,6 +8,10 @@ ( -- * Baseline slot list ExemplarSlots, + -- * Maybe wire-semantics slot lists + MaybeSlots, + NestedMaybeSlots, + -- * Schema-evolution mutations (EP-36 §4 cases #1–9) AddSlots, RemoveSlots, @@ -26,6 +30,9 @@ -- * Arbitrary generator ArbitraryRegFile (..), + + -- * Value equality + EqRegFile (..), ) where @@ -53,6 +60,17 @@ '("correlationId", Text) ] +-- | Optional fields whose absent values are encoded as explicit JSON @null@. +type MaybeSlots = + '[ '("lastError", Maybe Text), + '("approvedAt", Maybe UTCTime), + '("shippingAddress", Maybe Address) + ] + +-- | A deliberately lossy aeson shape: @Just Nothing@ and @Nothing@ both +-- encode as JSON @null@. +type NestedMaybeSlots = '[ '("nested", Maybe (Maybe Int))] + -- * Schema-evolution mutations (EP-36 §4) ------------------------------------ -- | §4 case #1 — Add slot. A fourth slot is appended to the baseline. @@ -186,3 +204,16 @@ ArbitraryRegFile ('(s, t) ': rs) where arbRegFile = RCons (Proxy @s) <$> arbitrary <*> arbRegFile + +-- * Value equality for 'RegFile rs' ----------------------------------------- + +-- | Inductive heterogeneous equality. Each slot value is compared with its +-- own 'Eq' instance. +class EqRegFile (rs :: [Slot]) where + eqRegFile :: RegFile rs -> RegFile rs -> Bool + +instance EqRegFile '[] where + eqRegFile _ _ = True + +instance (Eq t, EqRegFile rs) => EqRegFile ('(s, t) ': rs) where + eqRegFile (RCons _ x xs) (RCons _ y ys) = x == y && eqRegFile xs ys diff --git a/test/Keiki/Codec/JSON/GoldenFileSpec.hs b/test/Keiki/Codec/JSON/GoldenFileSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Codec/JSON/GoldenFileSpec.hs @@ -0,0 +1,266 @@ +-- | Checked-in persistence fixtures for whole register files and their shape. +-- +-- Each register fixture is checked in both directions: current code decodes +-- historical bytes to a fixed heterogeneous value, and current encoding must +-- remain byte-identical. The Value and Encoding paths have separate files +-- because their object-key orders deliberately differ. +-- +-- To regenerate only for an intentional wire-format change: +-- +-- > KEIKI_UPDATE_GOLDENS=1 cabal test keiki-codec-json:keiki-codec-json-test +-- > cabal test keiki-codec-json:keiki-codec-json-test +-- > git diff keiki-codec-json/test/golden/ +-- +-- The first command rewrites the files and fails deliberately. The second must +-- be green after the environment variable is unset and the diff reviewed. +module Keiki.Codec.JSON.GoldenFileSpec (spec) where + +import Data.Aeson qualified as Aeson +import Data.Aeson.Encoding qualified as AesonEnc +import Data.ByteString.Lazy qualified as LBS +import Data.Proxy (Proxy (..)) +import Data.Text qualified as T +import Data.Time.Clock (UTCTime) +import Keiki.Codec.JSON (RegFileToJSON, regFileFromJSON, regFileToEncoding, regFileToJSON) +import Keiki.Codec.JSON.Fixtures + ( Address (..), + EqRegFile (eqRegFile), + ExemplarSlots, + MaybeSlots, + ) +import Keiki.Codec.JSON.THEventEvolutionSpec qualified as Evolution +import Keiki.Codec.JSON.THEventSpec qualified as Event +import Keiki.Core (RegFile (..)) +import Keiki.Shape (regFileShapeCanonical, regFileShapeHash) +import System.Environment (lookupEnv) +import Test.Hspec (Spec, describe, expectationFailure, it, runIO, shouldBe) + +data EncoderPath = ValuePath | EncodingPath + +spec :: Spec +spec = do + describe "checked-in RegFile bytes" $ do + regFileGoldenSpec + "exemplar Value path" + "test/golden/exemplar-regfile.value.json" + ValuePath + exemplarRegFile + regFileGoldenSpec + "exemplar Encoding path" + "test/golden/exemplar-regfile.encoding.json" + EncodingPath + exemplarRegFile + regFileGoldenSpec + "all-Just Maybe slots, Value path" + "test/golden/maybe-regfile-just.value.json" + ValuePath + maybeJustRegFile + regFileGoldenSpec + "all-Just Maybe slots, Encoding path" + "test/golden/maybe-regfile-just.encoding.json" + EncodingPath + maybeJustRegFile + regFileGoldenSpec + "all-Nothing Maybe slots, Value path" + "test/golden/maybe-regfile-nothing.value.json" + ValuePath + maybeNothingRegFile + regFileGoldenSpec + "all-Nothing Maybe slots, Encoding path" + "test/golden/maybe-regfile-nothing.encoding.json" + EncodingPath + maybeNothingRegFile + + shapeGoldenSpec + eventGoldenSpecs + +regFileGoldenSpec :: + forall rs. + (RegFileToJSON rs, EqRegFile rs) => + String -> + FilePath -> + EncoderPath -> + RegFile rs -> + Spec +regFileGoldenSpec label path encoder expected = describe label $ do + update <- runIO (lookupEnv "KEIKI_UPDATE_GOLDENS") + case update of + Just _ -> do + runIO (LBS.writeFile path currentBytes) + it "regenerates and requires a clean review run" $ + expectationFailure regenerationMessage + Nothing -> do + historicalBytes <- runIO (LBS.readFile path) + it "decodes checked-in bytes to the fixed value" $ + case Aeson.decode historicalBytes of + Nothing -> expectationFailure "golden file is not valid JSON" + Just value -> case regFileFromJSON @rs value of + Left message -> expectationFailure ("golden decode failed: " <> message) + Right actual -> eqRegFile actual expected `shouldBe` True + it "freezes current encoder bytes" $ + currentBytes `shouldBe` historicalBytes + where + currentBytes = case encoder of + ValuePath -> Aeson.encode (regFileToJSON expected) + EncodingPath -> AesonEnc.encodingToLazyByteString (regFileToEncoding expected) + +shapeGoldenSpec :: Spec +shapeGoldenSpec = describe "checked-in ExemplarSlots shape" $ do + update <- runIO (lookupEnv "KEIKI_UPDATE_GOLDENS") + case update of + Just _ -> do + runIO (LBS.writeFile shapePath currentBytes) + it "regenerates and requires a clean review run" $ + expectationFailure regenerationMessage + Nothing -> do + historicalBytes <- runIO (LBS.readFile shapePath) + it "pins the canonical text and hash" $ + Aeson.decode historicalBytes `shouldBe` Just currentValue + it "freezes the shape fixture bytes" $ + currentBytes `shouldBe` historicalBytes + where + shapePath = "test/golden/exemplar-shape.json" + currentValue = + Aeson.object + [ "canonical" Aeson..= regFileShapeCanonical (Proxy @ExemplarSlots), + "hash" Aeson..= regFileShapeHash (Proxy @ExemplarSlots) + ] + currentBytes = Aeson.encode currentValue + +eventGoldenSpecs :: Spec +eventGoldenSpecs = describe "checked-in versioned event envelopes" $ do + eventGoldenSpec + "record payload with pinned kind and version" + "test/golden/event/order-placed.v1.json" + placedEvent + Event.orderEventToJSON + Event.orderEventFromJSON + eventGoldenSpec + "no-payload singleton with version" + "test/golden/event/order-cancelled.v1.json" + Event.Cancelled + Event.orderEventToJSON + Event.orderEventFromJSON + eventGoldenSpec + "current additive payload with explicit defaults" + "test/golden/event/item-added.v1.json" + additiveEvent + Evolution.additiveEventToJSON + Evolution.additiveEventFromJSON + historicalEventGoldenSpec + "pre-addition payload fills missing fields and absent version" + "test/golden/event/item-added.pre-defaults.json" + additiveEvent + historicalAdditiveBytes + Evolution.additiveEventFromJSON + eventGoldenSpec + "current structural payload after upcasting era" + "test/golden/event/quantity-recorded.v2.json" + structuralEvent + Evolution.structuralEventToJSON + Evolution.structuralEventFromJSON + historicalEventGoldenSpec + "version-1 payload runs the quantity upcaster" + "test/golden/event/quantity-recorded.v1.json" + structuralEvent + historicalStructuralBytes + Evolution.structuralEventFromJSON + +eventGoldenSpec :: + (Eq event, Show event) => + String -> + FilePath -> + event -> + (event -> Aeson.Value) -> + (Aeson.Value -> Either String event) -> + Spec +eventGoldenSpec label path expected encoder decoder = describe label $ do + update <- runIO (lookupEnv "KEIKI_UPDATE_GOLDENS") + case update of + Just _ -> do + runIO (LBS.writeFile path currentBytes) + it "regenerates and requires a clean review run" $ + expectationFailure regenerationMessage + Nothing -> do + historicalBytes <- runIO (LBS.readFile path) + it "decodes checked-in bytes to the fixed event" $ + case Aeson.eitherDecode historicalBytes of + Left message -> expectationFailure ("golden file is not valid JSON: " <> message) + Right value -> decoder value `shouldBe` Right expected + it "freezes current event encoder bytes" $ + currentBytes `shouldBe` historicalBytes + where + currentBytes = Aeson.encode (encoder expected) + +historicalEventGoldenSpec :: + (Eq event, Show event) => + String -> + FilePath -> + event -> + LBS.ByteString -> + (Aeson.Value -> Either String event) -> + Spec +historicalEventGoldenSpec label path expected frozenBytes decoder = describe label $ do + update <- runIO (lookupEnv "KEIKI_UPDATE_GOLDENS") + case update of + Just _ -> do + runIO (LBS.writeFile path frozenBytes) + it "regenerates and requires a clean review run" $ + expectationFailure regenerationMessage + Nothing -> do + historicalBytes <- runIO (LBS.readFile path) + it "decodes the historical document to the current event" $ + case Aeson.eitherDecode historicalBytes of + Left message -> expectationFailure ("golden file is not valid JSON: " <> message) + Right value -> decoder value `shouldBe` Right expected + it "freezes the historical document bytes" $ + historicalBytes `shouldBe` frozenBytes + +exemplarRegFile :: RegFile ExemplarSlots +exemplarRegFile = + RCons (Proxy @"retryCount") (3 :: Int) $ + RCons (Proxy @"cooldownUntil") exemplarTime $ + RCons (Proxy @"correlationId") (T.pack "order-123") RNil + +maybeJustRegFile :: RegFile MaybeSlots +maybeJustRegFile = + RCons (Proxy @"lastError") (Just (T.pack "address invalid")) $ + RCons (Proxy @"approvedAt") (Just exemplarTime) $ + RCons + (Proxy @"shippingAddress") + (Just (Address (T.pack "1 Main St") (T.pack "Portland") (T.pack "97201"))) + RNil + +maybeNothingRegFile :: RegFile MaybeSlots +maybeNothingRegFile = + RCons (Proxy @"lastError") Nothing $ + RCons (Proxy @"approvedAt") Nothing $ + RCons (Proxy @"shippingAddress") Nothing RNil + +exemplarTime :: UTCTime +exemplarTime = read "2026-01-02 03:04:05 UTC" + +placedEvent :: Event.OrderEvent +placedEvent = Event.Placed (Event.PlacedData (Event.OrderId 7) 3) + +additiveEvent :: Evolution.AdditiveEvent +additiveEvent = + Evolution.ItemAdded + Evolution.ItemAddedData + { Evolution.orderId = T.pack "ord-7", + Evolution.discount = Evolution.Discount 0, + Evolution.note = Nothing + } + +structuralEvent :: Evolution.StructuralEvent +structuralEvent = Evolution.QuantityRecorded (Evolution.QuantityRecordedData 3) + +historicalAdditiveBytes :: LBS.ByteString +historicalAdditiveBytes = "{\"kind\":\"ItemAdded\",\"orderId\":\"ord-7\"}" + +historicalStructuralBytes :: LBS.ByteString +historicalStructuralBytes = "{\"kind\":\"QuantityRecorded\",\"v\":1,\"qty\":3}" + +regenerationMessage :: String +regenerationMessage = + "golden regenerated; unset KEIKI_UPDATE_GOLDENS, re-run, and review git diff" diff --git a/test/Keiki/Codec/JSON/GoldenSpec.hs b/test/Keiki/Codec/JSON/GoldenSpec.hs --- a/test/Keiki/Codec/JSON/GoldenSpec.hs +++ b/test/Keiki/Codec/JSON/GoldenSpec.hs @@ -1,24 +1,22 @@ -- | EP-36 M3 golden hash file. -- --- Pins the shape hash of 'ExemplarSlots' for the current GHC version. --- The cross-GHC CI gate (M5) compares this value across every GHC in --- @tested-with@; a divergence is a release-blocking bug per EP-36 §8. +-- Pins the canonical shape string and hash of 'ExemplarSlots'. Built-in +-- canonical names are module-independent, so these values are shared across +-- supported GHC versions. module Keiki.Codec.JSON.GoldenSpec (spec) where import Data.Proxy (Proxy (..)) import Data.Text qualified as T import Keiki.Codec.JSON.Fixtures (ExemplarSlots) -import Keiki.Shape (regFileShapeHash) +import Keiki.Shape (regFileShapeCanonical, regFileShapeHash) import Test.Hspec (Spec, describe, it, shouldBe) spec :: Spec spec = describe "Golden hash for ExemplarSlots" $ do - -- This value is pinned for GHC 9.12.*. Drift here means either - -- GHC's `tyConModule` / `tyConName` semantics changed for one of - -- the slot types (Int / UTCTime / Text), or `renderStableTypeRep` - -- inadvertently picked up a non-stable accessor. Per EP-36 §8 the - -- release is blocked until the cause is understood; the fix may be a - -- `CanonicalTypeName` override for the affected slot type. - it "matches the pinned GHC-9.12.* value" $ + it "matches the pinned canonical string" $ + regFileShapeCanonical (Proxy @ExemplarSlots) + `shouldBe` T.pack "retryCount:Int;cooldownUntil:UTCTime;correlationId:Text;regfile:0" + + it "matches the pinned GHC-independent value" $ regFileShapeHash (Proxy @ExemplarSlots) - `shouldBe` T.pack "a37b2b77042a635f394a082765f3410ea23a0b89745b0c77242b925a03aa172b" + `shouldBe` T.pack "d920c3660d5b2a7bda082cdedb08fa493acd3f74a663434a4cead475096866f9" diff --git a/test/Keiki/Codec/JSON/PropSpec.hs b/test/Keiki/Codec/JSON/PropSpec.hs --- a/test/Keiki/Codec/JSON/PropSpec.hs +++ b/test/Keiki/Codec/JSON/PropSpec.hs @@ -11,70 +11,117 @@ import Data.Aeson qualified as Aeson import Data.Aeson.Encoding qualified as AesonEnc -import Keiki.Codec.JSON (regFileFromJSON, regFileToEncoding, regFileToJSON) -import Keiki.Codec.JSON.Fixtures (ExemplarSlots, arbRegFile) +import Data.Proxy (Proxy (..)) +import Keiki.Codec.JSON (RegFileToJSON, regFileFromJSON, regFileToEncoding, regFileToJSON) +import Keiki.Codec.JSON.Fixtures + ( ArbitraryRegFile (arbRegFile), + EqRegFile (eqRegFile), + ExemplarSlots, + MaybeSlots, + NestedMaybeSlots, + ) import Keiki.Core (RegFile) -import Test.Hspec (Spec, describe, it) +import Keiki.Core qualified as Core +import Test.Hspec (Spec, describe, it, shouldBe) import Test.QuickCheck (Property, forAllShow, (===)) -- | RegFile rs has no Show instance (the slot list is heterogeneous); -- use the JSON encoding as the renderer for QuickCheck counterexamples. -showRegFile :: RegFile ExemplarSlots -> String +showRegFile :: (RegFileToJSON rs) => RegFile rs -> String showRegFile = show . regFileToJSON spec :: Spec spec = do + describe "ExemplarSlots" (codecProps @ExemplarSlots) + describe "MaybeSlots" (codecProps @MaybeSlots) + nestedMaybeSpec + +codecProps :: + forall rs. + (RegFileToJSON rs, ArbitraryRegFile rs, EqRegFile rs) => + Spec +codecProps = do describe "Roundtrip" $ do it "Value path round-trips" $ - forAllShow arbRegFile showRegFile valueRoundTrip + forAllShow (arbRegFile @rs) showRegFile (valueRoundTrip @rs) it "Encoding path round-trips" $ - forAllShow arbRegFile showRegFile encodingRoundTrip + forAllShow (arbRegFile @rs) showRegFile (encodingRoundTrip @rs) describe "Determinism (R9 within-path)" $ do it "Value path is deterministic" $ - forAllShow arbRegFile showRegFile valueDeterministic + forAllShow (arbRegFile @rs) showRegFile valueDeterministic it "Encoding path is deterministic" $ - forAllShow arbRegFile showRegFile encodingDeterministic + forAllShow (arbRegFile @rs) showRegFile encodingDeterministic --- | @regFileFromJSON . regFileToJSON ≡ Right rf@. We use the encoded --- bytes as the canonical comparison point: re-encoding the parsed --- RegFile must yield the same bytes (proving structural equality --- without requiring a 'Eq' or 'Show' instance on 'RegFile'). -valueRoundTrip :: RegFile ExemplarSlots -> Property +-- | @regFileFromJSON . regFileToJSON ≡ Right rf@. We compare decoded +-- slot values with the inductive 'EqRegFile' walker, so a lossy decode +-- cannot hide behind identical re-encoded bytes. +valueRoundTrip :: forall rs. (RegFileToJSON rs, EqRegFile rs) => RegFile rs -> Property valueRoundTrip rf = let bytes = Aeson.encode (regFileToJSON rf) in case Aeson.decode bytes of Nothing -> False === error "Aeson.decode failed on our own encoder output" - Just v -> case regFileFromJSON @ExemplarSlots v of + Just v -> case regFileFromJSON @rs v of Left msg -> False === error ("regFileFromJSON failed: " <> msg) - Right rf' -> - Aeson.encode (regFileToJSON rf') === bytes + Right rf' -> eqRegFile rf' rf === True -- | Encoding path round-trip via -- @regFileFromJSON . fromJust . Aeson.decode . AesonEnc.encodingToLazyByteString . regFileToEncoding@. -encodingRoundTrip :: RegFile ExemplarSlots -> Property +encodingRoundTrip :: forall rs. (RegFileToJSON rs, EqRegFile rs) => RegFile rs -> Property encodingRoundTrip rf = let bytes = AesonEnc.encodingToLazyByteString (regFileToEncoding rf) in case Aeson.decode bytes of Nothing -> False === error "Aeson.decode failed on streaming-encoder output" - Just v -> case regFileFromJSON @ExemplarSlots v of + Just v -> case regFileFromJSON @rs v of Left msg -> False === error ("regFileFromJSON failed: " <> msg) - Right rf' -> - AesonEnc.encodingToLazyByteString (regFileToEncoding rf') === bytes + Right rf' -> eqRegFile rf' rf === True -- | Re-encoding the same RegFile via the Value path produces byte- -- equal output. -valueDeterministic :: RegFile ExemplarSlots -> Property +valueDeterministic :: (RegFileToJSON rs) => RegFile rs -> Property valueDeterministic rf = Aeson.encode (regFileToJSON rf) === Aeson.encode (regFileToJSON rf) -- | Re-encoding via the Encoding path produces byte-equal output. -encodingDeterministic :: RegFile ExemplarSlots -> Property +encodingDeterministic :: (RegFileToJSON rs) => RegFile rs -> Property encodingDeterministic rf = AesonEnc.encodingToLazyByteString (regFileToEncoding rf) === AesonEnc.encodingToLazyByteString (regFileToEncoding rf) + +nestedMaybeSpec :: Spec +nestedMaybeSpec = describe "Nested Maybe wire semantics" $ do + it "encodes Just Nothing as null and decodes it as outer Nothing" $ do + let rf = nestedRegFile (Just Nothing) + regFileToJSON rf + `shouldBe` Aeson.object ["nested" Aeson..= Aeson.Null] + assertNestedDecode rf Nothing + + it "round-trips Just (Just 42)" $ + assertNestedDecode (nestedRegFile (Just (Just 42))) (Just (Just 42)) + + it "round-trips Nothing" $ + assertNestedDecode (nestedRegFile Nothing) Nothing + + it "rejects an absent Maybe slot rather than treating it as Nothing" $ + case regFileFromJSON @MaybeSlots + ( Aeson.object + [ "approvedAt" Aeson..= Aeson.Null, + "shippingAddress" Aeson..= Aeson.Null + ] + ) of + Left message -> message `shouldBe` "lastError: missing slot" + Right _ -> error "expected an absent-slot failure" + +nestedRegFile :: Maybe (Maybe Int) -> RegFile NestedMaybeSlots +nestedRegFile value = Core.RCons (Proxy @"nested") value Core.RNil + +assertNestedDecode :: RegFile NestedMaybeSlots -> Maybe (Maybe Int) -> IO () +assertNestedDecode rf expected = + case regFileFromJSON @NestedMaybeSlots (regFileToJSON rf) of + Left message -> error ("nested Maybe decode failed: " <> message) + Right (Core.RCons _ actual Core.RNil) -> actual `shouldBe` expected diff --git a/test/Keiki/Codec/JSON/THEventEvolutionSpec.hs b/test/Keiki/Codec/JSON/THEventEvolutionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Keiki/Codec/JSON/THEventEvolutionSpec.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | EP-77 evolution regressions for additive event fields. +module Keiki.Codec.JSON.THEventEvolutionSpec + ( spec, + Discount (..), + ItemAddedData (..), + AdditiveEvent (..), + additiveEventToJSON, + additiveEventFromJSON, + QuantityRecordedData (..), + StructuralEvent (..), + structuralEventToJSON, + structuralEventFromJSON, + ) +where + +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Lazy (ByteString) +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Keiki.Codec.JSON.Event + ( EventCodecOptions (..), + FieldCodec (fcOnMissing), + defaultEventCodecOptions, + deriveEventCodecSkeleton, + fieldCodec, + ) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.QuickCheck + ( Gen, + Property, + chooseInt, + elements, + forAllShow, + listOf1, + oneof, + (===), + ) + +newtype Discount = Discount Int + deriving stock (Eq, Show) + +discountToJSON :: Discount -> Aeson.Value +discountToJSON (Discount amount) = Aeson.toJSON amount + +discountFromJSON :: Aeson.Value -> Either String Discount +discountFromJSON value = case Aeson.fromJSON value of + Aeson.Success amount -> Right (Discount amount) + Aeson.Error message -> Left message + +missingDiscount :: Discount +missingDiscount = Discount 0 + +data ItemAddedData = ItemAddedData + { orderId :: Text, + discount :: Discount, + note :: Maybe Text + } + deriving stock (Eq, Show) + +data AdditiveEvent = ItemAdded ItemAddedData + deriving stock (Eq, Show) + +$( deriveEventCodecSkeleton + defaultEventCodecOptions + { fieldCodecOverrides = + Map.fromList + [ ( "discount", + (fieldCodec 'discountToJSON 'discountFromJSON) + { fcOnMissing = Just 'missingDiscount + } + ) + ], + passthroughFields = Set.fromList ["orderId", "note"] + } + ''AdditiveEvent + ) + +data QuantityRecordedData = QuantityRecordedData + { quantity :: Int + } + deriving stock (Eq, Show) + +data StructuralEvent = QuantityRecorded QuantityRecordedData + deriving stock (Eq, Show) + +upcastQuantityV1 :: Aeson.Value -> Either String Aeson.Value +upcastQuantityV1 value = case value of + Aeson.Object object -> case KeyMap.lookup (Key.fromString "qty") object of + Nothing -> Left "missing qty" + Just quantityValue -> + Right + ( Aeson.Object + (KeyMap.insert (Key.fromString "quantity") quantityValue object) + ) + _ -> Left "expected an object" + +$( deriveEventCodecSkeleton + defaultEventCodecOptions + { passthroughFields = Set.fromList ["quantity"], + currentVersion = 2, + upcasters = [(1, 'upcastQuantityV1)] + } + ''StructuralEvent + ) + +-- These bytes predate the note and discount fields; do not regenerate them. +oldAdditiveBytes :: ByteString +oldAdditiveBytes = "{\"kind\":\"ItemAdded\",\"orderId\":\"ord-7\"}" + +decodeAdditiveBytes :: ByteString -> Either String AdditiveEvent +decodeAdditiveBytes bytes = do + value <- Aeson.eitherDecode bytes + additiveEventFromJSON value + +decodeStructuralBytes :: ByteString -> Either String StructuralEvent +decodeStructuralBytes bytes = do + value <- Aeson.eitherDecode bytes + structuralEventFromJSON value + +arbAdditiveEvent :: Gen AdditiveEvent +arbAdditiveEvent = do + orderNumber <- chooseInt (0, 100000) + discountAmount <- chooseInt (-1000, 1000) + generatedNote <- + oneof + [ pure Nothing, + Just . T.pack <$> listOf1 (elements ['a' .. 'z']) + ] + pure + ( ItemAdded + ItemAddedData + { orderId = T.pack ("ord-" <> show orderNumber), + discount = Discount discountAmount, + note = generatedNote + } + ) + +roundTripProperty :: AdditiveEvent -> Property +roundTripProperty event = + additiveEventFromJSON (additiveEventToJSON event) === Right event + +spec :: Spec +spec = describe "default-on-missing event fields" $ do + it "exports the additive fixture's wire metadata" $ do + additiveEventSchemaVersion `shouldBe` 1 + additiveEventEventTypes `shouldBe` [T.pack "ItemAdded"] + additiveEventKindMap + `shouldBe` [(T.pack "ItemAdded", T.pack "ItemAdded")] + + it "decodes bytes written before the additive fields existed" $ + decodeAdditiveBytes oldAdditiveBytes + `shouldBe` Right + ( ItemAdded + ItemAddedData + { orderId = T.pack "ord-7", + discount = missingDiscount, + note = Nothing + } + ) + + it "decodes a present null Maybe field as Nothing" $ + decodeAdditiveBytes + "{\"kind\":\"ItemAdded\",\"orderId\":\"ord-7\",\"discount\":12,\"note\":null}" + `shouldBe` Right + ( ItemAdded + ItemAddedData + { orderId = T.pack "ord-7", + discount = Discount 12, + note = Nothing + } + ) + + it "round-trips a fully populated value" $ + let event = + ItemAdded + ItemAddedData + { orderId = T.pack "ord-8", + discount = Discount 15, + note = Just (T.pack "priority") + } + in additiveEventFromJSON (additiveEventToJSON event) `shouldBe` Right event + + it "round-trips generated Nothing and Just values" $ + forAllShow arbAdditiveEvent show roundTripProperty + + it "keeps required fields strict" $ + decodeAdditiveBytes "{\"kind\":\"ItemAdded\"}" + `shouldBe` (Left "missing field: orderId" :: Either String AdditiveEvent) + + describe "upcaster chain" $ do + let expected = QuantityRecorded (QuantityRecordedData 3) + + it "exports the structural fixture's current wire metadata" $ do + structuralEventSchemaVersion `shouldBe` 2 + structuralEventEventTypes `shouldBe` [T.pack "QuantityRecorded"] + structuralEventKindMap + `shouldBe` [(T.pack "QuantityRecorded", T.pack "QuantityRecorded")] + + it "decodes version-1 bytes after renaming qty to quantity" $ + decodeStructuralBytes + "{\"kind\":\"QuantityRecorded\",\"v\":1,\"qty\":3}" + `shouldBe` Right expected + + it "runs the version-1 upcaster for an absent version stamp" $ + decodeStructuralBytes + "{\"kind\":\"QuantityRecorded\",\"qty\":3}" + `shouldBe` Right expected + + it "decodes current-version bytes without running an old rung" $ do + decodeStructuralBytes + "{\"kind\":\"QuantityRecorded\",\"v\":2,\"quantity\":3}" + `shouldBe` Right expected + structuralEventFromJSON (structuralEventToJSON expected) + `shouldBe` Right expected + + it "surfaces a rung failure with its source version" $ + decodeStructuralBytes + "{\"kind\":\"QuantityRecorded\",\"v\":1}" + `shouldBe` ( Left "upcaster from version 1: missing qty" :: + Either String StructuralEvent + ) diff --git a/test/Keiki/Codec/JSON/THEventSpec.hs b/test/Keiki/Codec/JSON/THEventSpec.hs --- a/test/Keiki/Codec/JSON/THEventSpec.hs +++ b/test/Keiki/Codec/JSON/THEventSpec.hs @@ -45,9 +45,52 @@ -- @_todo_Placed_discount@ in @cabal repl@ shows the binding exists. -- Revert afterwards. -- --- Both behaviours were verified by hand on 2026-06-06; the observed --- compile-fail text matched (1) verbatim. -module Keiki.Codec.JSON.THEventSpec (spec) where +-- 3. Duplicate wire kinds. Add +-- @kindOverrides = Map.fromList [("Placed", "order.event"), +-- ("Shipped", "order.event")]@, build the test target, and expect: +-- +-- @ +-- deriveEventCodecSkeleton: wire kind "order.event" is claimed by more +-- than one constructor: Placed, Shipped. Wire kinds must be unique per +-- event type. +-- @ +-- +-- Revert the override. +-- +-- 4. Discriminator collision. Add @kind :: Text@ to @PlacedData@ and list +-- @"kind"@ in 'passthroughFields', build the test target, and expect: +-- +-- @ +-- deriveEventCodecSkeleton: payload field Placed.kind collides with +-- kindFieldName "kind"; rename the field or choose a kindFieldName no +-- payload uses. +-- @ +-- +-- Revert the field and passthrough entry. +-- +-- 5. Incomplete upcaster chain. In @THEventEvolutionSpec@, set the +-- @StructuralEvent@ codec's @currentVersion = 3@ while retaining only +-- @upcasters = [(1, 'upcastQuantityV1)]@. Build the test target and expect: +-- +-- @ +-- deriveEventCodecSkeleton: upcasters must cover from-versions [1..2] +-- exactly; missing: [2] +-- @ +-- +-- Restore @currentVersion = 2@. +-- +-- Checks (1) and (2) were verified by hand on 2026-06-06; the observed +-- compile-fail text matched (1) verbatim. Checks (3), (4), and (5) were +-- verified by hand on 2026-07-12 with the messages above. +module Keiki.Codec.JSON.THEventSpec + ( spec, + OrderId (..), + PlacedData (..), + OrderEvent (..), + orderEventToJSON, + orderEventFromJSON, + ) +where import Data.Aeson qualified as Aeson import Data.Map.Strict qualified as Map @@ -56,9 +99,9 @@ import Data.Text qualified as T import Keiki.Codec.JSON.Event ( EventCodecOptions (..), - FieldCodec (..), defaultEventCodecOptions, deriveEventCodecSkeleton, + fieldCodec, ) import Test.Hspec (Spec, describe, it, shouldBe) import Text.Read (readMaybe) @@ -101,8 +144,9 @@ $( deriveEventCodecSkeleton defaultEventCodecOptions { fieldCodecOverrides = - Map.fromList [("orderId", FieldCodec 'orderIdToJSON 'orderIdFromJSON)], - passthroughFields = Set.fromList ["qty", "trackingNo"] + Map.fromList [("orderId", fieldCodec 'orderIdToJSON 'orderIdFromJSON)], + passthroughFields = Set.fromList ["qty", "trackingNo"], + kindOverrides = Map.fromList [("Placed", "order.placed")] } ''OrderEvent ) @@ -127,48 +171,100 @@ describe "kind discriminator + override usage" $ do -- orderEventToJSON (Placed (PlacedData (OrderId 7) 3)) - -- == {"kind":"Placed","orderId":"ord-7","qty":3} + -- == {"kind":"order.placed","v":1,"orderId":"ord-7","qty":3} it "Placed carries the kind key, the override output, and the passthrough field" $ orderEventToJSON placed `shouldBe` Aeson.object - [ "kind" Aeson..= (T.pack "Placed" :: Text), + [ "kind" Aeson..= (T.pack "order.placed" :: Text), + "v" Aeson..= (1 :: Int), "orderId" Aeson..= (T.pack "ord-7" :: Text), "qty" Aeson..= (3 :: Int) ] - it "the orderId override ran (string \"ord-7\", not the integer 7)" $ + it "a pinned wire kind decodes independently of the Haskell constructor name" $ -- If a generic Int codec had been silently used, this would be 7. orderEventFromJSON ( Aeson.object - [ "kind" Aeson..= (T.pack "Placed" :: Text), + [ "kind" Aeson..= (T.pack "order.placed" :: Text), "orderId" Aeson..= (T.pack "ord-7" :: Text), "qty" Aeson..= (3 :: Int) ] ) `shouldBe` Right placed - it "Cancelled encodes to just the kind object" $ + it "Cancelled encodes to just the envelope keys" $ orderEventToJSON cancelled - `shouldBe` Aeson.object ["kind" Aeson..= (T.pack "Cancelled" :: Text)] + `shouldBe` Aeson.object + [ "kind" Aeson..= (T.pack "Cancelled" :: Text), + "v" Aeson..= (1 :: Int) + ] + describe "schema version envelope" $ do + it "exports the current schema version" $ + orderEventSchemaVersion `shouldBe` 1 + + it "treats a missing version key as version 1" $ + orderEventFromJSON + ( Aeson.object + [ "kind" Aeson..= (T.pack "order.placed" :: Text), + "orderId" Aeson..= (T.pack "ord-7" :: Text), + "qty" Aeson..= (3 :: Int) + ] + ) + `shouldBe` Right placed + + it "rejects an event written by a newer codec" $ + orderEventFromJSON + ( Aeson.object + [ "kind" Aeson..= (T.pack "Cancelled" :: Text), + "v" Aeson..= (2 :: Int) + ] + ) + `shouldBe` ( Left "event schema version 2 is ahead of codec version 1" :: + Either String OrderEvent + ) + + it "rejects a schema version below 1" $ + orderEventFromJSON + ( Aeson.object + [ "kind" Aeson..= (T.pack "Cancelled" :: Text), + "v" Aeson..= (0 :: Int) + ] + ) + `shouldBe` (Left "invalid event schema version: 0" :: Either String OrderEvent) + + it "rejects a non-integral schema-version value" $ + orderEventFromJSON + ( Aeson.object + [ "kind" Aeson..= (T.pack "Cancelled" :: Text), + "v" Aeson..= (T.pack "one" :: Text) + ] + ) + `shouldBe` ( Left "field v: expected an integer schema version" :: + Either String OrderEvent + ) + describe "decoder error paths" $ do it "an unknown kind is reported" $ orderEventFromJSON (Aeson.object ["kind" Aeson..= (T.pack "Nope" :: Text)]) - `shouldBe` (Left "unknown event kind: Nope" :: Either String OrderEvent) + `shouldBe` ( Left + "unknown event kind: Nope (expected one of: order.placed, Shipped, Cancelled)" :: + Either String OrderEvent + ) it "a non-object is reported" $ orderEventFromJSON (Aeson.toJSON (5 :: Int)) `shouldBe` (Left "orderEvent: expected a JSON object" :: Either String OrderEvent) describe "Keiro-feeding surfaces" $ do - it "EventTypes lists the constructors in declaration order" $ + it "EventTypes lists resolved wire kinds in declaration order" $ orderEventEventTypes - `shouldBe` map T.pack ["Placed", "Shipped", "Cancelled"] + `shouldBe` map T.pack ["order.placed", "Shipped", "Cancelled"] it "KindMap pairs each constructor name with its kind string" $ orderEventKindMap - `shouldBe` [ (T.pack "Placed", T.pack "Placed"), + `shouldBe` [ (T.pack "Placed", T.pack "order.placed"), (T.pack "Shipped", T.pack "Shipped"), (T.pack "Cancelled", T.pack "Cancelled") ] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,28 +7,34 @@ -- on missing slot, extra slot, type mismatch. module Main (main) where +import Control.Exception (ErrorCall (..), evaluate) import Data.Aeson qualified as Aeson import Data.Aeson.Encoding qualified as AesonEnc import Data.ByteString.Lazy qualified as LBS import Data.Kind (Type) +import Data.List (isPrefixOf) import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) import Data.Text (Text) import Data.Text qualified as T import GHC.TypeLits (Symbol) import Keiki.Codec.JSON (regFileFromJSON, regFileToEncoding, regFileToJSON) +import Keiki.Codec.JSON.GoldenFileSpec qualified import Keiki.Codec.JSON.GoldenSpec qualified import Keiki.Codec.JSON.PropSpec qualified import Keiki.Codec.JSON.SensitivitySpec qualified +import Keiki.Codec.JSON.THEventEvolutionSpec qualified import Keiki.Codec.JSON.THEventSpec qualified import Keiki.Codec.JSON.THSpec qualified import Keiki.Core (RegFile (..)) +import Keiki.Generics (emptyRegFile) import Test.Hspec ( Spec, describe, hspec, it, shouldBe, + shouldThrow, ) main :: IO () @@ -37,8 +43,10 @@ describe "M3 properties" Keiki.Codec.JSON.PropSpec.spec describe "M3 sensitivity" Keiki.Codec.JSON.SensitivitySpec.spec describe "M3 golden hash" Keiki.Codec.JSON.GoldenSpec.spec + describe "EP-78 checked-in persistence goldens" Keiki.Codec.JSON.GoldenFileSpec.spec describe "EP-38 deriveRegFileCodec" Keiki.Codec.JSON.THSpec.spec describe "EP-59 deriveEventCodecSkeleton" Keiki.Codec.JSON.THEventSpec.spec + describe "EP-77 event schema evolution" Keiki.Codec.JSON.THEventEvolutionSpec.spec spec :: Spec spec = do @@ -112,6 +120,13 @@ ] ) isExtraFieldsLeft r `shouldBe` True + + it "throws a slot-named error when encoding an unwritten slot" $ do + let uninitialized = + emptyRegFile :: RegFile '[ '("retryCount", Int)] + evaluate (LBS.length (Aeson.encode (regFileToJSON uninitialized))) + `shouldThrow` \(ErrorCall message) -> + "uninit: retryCount" `isPrefixOf` message describe "Multi-slot RegFile (Int + Text)" $ do let rf :: RegFile '[ '("retryCount", Int), '("note", Text)] diff --git a/test/golden/event/item-added.pre-defaults.json b/test/golden/event/item-added.pre-defaults.json new file mode 100644 --- /dev/null +++ b/test/golden/event/item-added.pre-defaults.json @@ -0,0 +1,1 @@ +{"kind":"ItemAdded","orderId":"ord-7"} diff --git a/test/golden/event/item-added.v1.json b/test/golden/event/item-added.v1.json new file mode 100644 --- /dev/null +++ b/test/golden/event/item-added.v1.json @@ -0,0 +1,1 @@ +{"discount":0,"kind":"ItemAdded","note":null,"orderId":"ord-7","v":1} diff --git a/test/golden/event/order-cancelled.v1.json b/test/golden/event/order-cancelled.v1.json new file mode 100644 --- /dev/null +++ b/test/golden/event/order-cancelled.v1.json @@ -0,0 +1,1 @@ +{"kind":"Cancelled","v":1} diff --git a/test/golden/event/order-placed.v1.json b/test/golden/event/order-placed.v1.json new file mode 100644 --- /dev/null +++ b/test/golden/event/order-placed.v1.json @@ -0,0 +1,1 @@ +{"kind":"order.placed","orderId":"ord-7","qty":3,"v":1} diff --git a/test/golden/event/quantity-recorded.v1.json b/test/golden/event/quantity-recorded.v1.json new file mode 100644 --- /dev/null +++ b/test/golden/event/quantity-recorded.v1.json @@ -0,0 +1,1 @@ +{"kind":"QuantityRecorded","v":1,"qty":3} diff --git a/test/golden/event/quantity-recorded.v2.json b/test/golden/event/quantity-recorded.v2.json new file mode 100644 --- /dev/null +++ b/test/golden/event/quantity-recorded.v2.json @@ -0,0 +1,1 @@ +{"kind":"QuantityRecorded","quantity":3,"v":2} diff --git a/test/golden/exemplar-regfile.encoding.json b/test/golden/exemplar-regfile.encoding.json new file mode 100644 --- /dev/null +++ b/test/golden/exemplar-regfile.encoding.json @@ -0,0 +1,1 @@ +{"retryCount":3,"cooldownUntil":"2026-01-02T03:04:05Z","correlationId":"order-123"} diff --git a/test/golden/exemplar-regfile.value.json b/test/golden/exemplar-regfile.value.json new file mode 100644 --- /dev/null +++ b/test/golden/exemplar-regfile.value.json @@ -0,0 +1,1 @@ +{"cooldownUntil":"2026-01-02T03:04:05Z","correlationId":"order-123","retryCount":3} diff --git a/test/golden/exemplar-shape.json b/test/golden/exemplar-shape.json new file mode 100644 --- /dev/null +++ b/test/golden/exemplar-shape.json @@ -0,0 +1,1 @@ +{"canonical":"retryCount:Int;cooldownUntil:UTCTime;correlationId:Text;regfile:0","hash":"d920c3660d5b2a7bda082cdedb08fa493acd3f74a663434a4cead475096866f9"} diff --git a/test/golden/maybe-regfile-just.encoding.json b/test/golden/maybe-regfile-just.encoding.json new file mode 100644 --- /dev/null +++ b/test/golden/maybe-regfile-just.encoding.json @@ -0,0 +1,1 @@ +{"lastError":"address invalid","approvedAt":"2026-01-02T03:04:05Z","shippingAddress":{"city":"Portland","line":"1 Main St","postcode":"97201"}} diff --git a/test/golden/maybe-regfile-just.value.json b/test/golden/maybe-regfile-just.value.json new file mode 100644 --- /dev/null +++ b/test/golden/maybe-regfile-just.value.json @@ -0,0 +1,1 @@ +{"approvedAt":"2026-01-02T03:04:05Z","lastError":"address invalid","shippingAddress":{"city":"Portland","line":"1 Main St","postcode":"97201"}} diff --git a/test/golden/maybe-regfile-nothing.encoding.json b/test/golden/maybe-regfile-nothing.encoding.json new file mode 100644 --- /dev/null +++ b/test/golden/maybe-regfile-nothing.encoding.json @@ -0,0 +1,1 @@ +{"lastError":null,"approvedAt":null,"shippingAddress":null} diff --git a/test/golden/maybe-regfile-nothing.value.json b/test/golden/maybe-regfile-nothing.value.json new file mode 100644 --- /dev/null +++ b/test/golden/maybe-regfile-nothing.value.json @@ -0,0 +1,1 @@ +{"approvedAt":null,"lastError":null,"shippingAddress":null}