diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,19 @@ ## [Unreleased] +## 0.6.0.0 — 2026-07-31 + +### Breaking Changes + +- Requires the exact-`Integer` / total-`Natural` Keiki release + (`keiki >=0.6 && <0.7`), replacing the previous `>=0.4 && <0.5` bound. + +### New Features + +- Adds the public total `Keiro.Codec.Nominal` module: the binding and fixture + API that generated nominal consumer codecs (bound aggregate IDs, enums, and + nominal scalar wrappers) are checked against. + ## 0.5.0.0 — 2026-07-31 No changes this release. Released with the package set for the `keiro-dsl` diff --git a/keiro-core.cabal b/keiro-core.cabal --- a/keiro-core.cabal +++ b/keiro-core.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: keiro-core -version: 0.5.0.0 +version: 0.6.0.0 synopsis: Core contracts for Keiro packages description: Stable stream, codec, event-stream, and integration-event contracts @@ -40,6 +40,7 @@ import: warnings, shared exposed-modules: Keiro.Codec + Keiro.Codec.Nominal Keiro.Codec.Structural Keiro.Codec.Structural.Generic Keiro.EventStream @@ -58,7 +59,7 @@ , bytestring >=0.11 && <0.13 , deepseq >=1.5 && <1.6 , generic-lens >=2.2 && <2.4 - , keiki >=0.4 && <0.5 + , keiki >=0.6 && <0.7 , kiroku-store >=0.3 && <0.4 , lens >=5.2 && <5.4 , scientific >=0.3 && <0.4 diff --git a/src/Keiro/Codec.hs b/src/Keiro/Codec.hs --- a/src/Keiro/Codec.hs +++ b/src/Keiro/Codec.hs @@ -1,24 +1,23 @@ -{- | Versioned encode/decode contract between a domain event type and its -stored JSON payload. - -A 'Codec' is the single place a stream declares how its events are named, -serialized, and migrated. It pairs a current 'schemaVersion' with a chain -of 'Upcaster's so that payloads written under older versions are -transparently brought up to the current shape on read. Producers call -'encodeForAppend' (which stamps the schema version into event metadata); -consumers call 'decodeRecorded', which reads that stamp back, replays the -upcaster chain via 'migrateToCurrent', and then runs the current 'decode'. - -Encoding can fail only with a misconfigured codec ('InvalidSchemaVersion') -or an event whose type tag is not in 'eventTypes' ('UnknownEventType'). -Decoding additionally surfaces migration faults: a missing rung in the -upcaster chain ('GapInUpcasterChain'), an upcaster that rejected its input -('UpcasterError'), a stored future version ('VersionAhead'), an out-of-range -stored version ('UnknownVersion'), or a payload the current decoder rejects -('DecodeFailed'). --} -module Keiro.Codec ( - -- * Codec +-- | Versioned encode/decode contract between a domain event type and its +-- stored JSON payload. +-- +-- A 'Codec' is the single place a stream declares how its events are named, +-- serialized, and migrated. It pairs a current 'schemaVersion' with a chain +-- of 'Upcaster's so that payloads written under older versions are +-- transparently brought up to the current shape on read. Producers call +-- 'encodeForAppend' (which stamps the schema version into event metadata); +-- consumers call 'decodeRecorded', which reads that stamp back, replays the +-- upcaster chain via 'migrateToCurrent', and then runs the current 'decode'. +-- +-- Encoding can fail only with a misconfigured codec ('InvalidSchemaVersion') +-- or an event whose type tag is not in 'eventTypes' ('UnknownEventType'). +-- Decoding additionally surfaces migration faults: a missing rung in the +-- upcaster chain ('GapInUpcasterChain'), an upcaster that rejected its input +-- ('UpcasterError'), a stored future version ('VersionAhead'), an out-of-range +-- stored version ('UnknownVersion'), or a payload the current decoder rejects +-- ('DecodeFailed'). +module Keiro.Codec + ( -- * Codec Codec (..), Upcaster, EventType (..), @@ -38,7 +37,7 @@ -- * Metadata helpers extractSchemaVersion, metadataFor, -) + ) where import Data.Aeson (Value (..)) @@ -49,264 +48,251 @@ import Data.Maybe qualified as Maybe import Data.Scientific qualified as Scientific import Keiro.Prelude -import Kiroku.Store.Types ( - EventData (..), +import Kiroku.Store.Types + ( EventData (..), EventType (..), RecordedEvent (..), - ) + ) import Prelude qualified -{- | One rung of an upcaster chain: the source schema version it upgrades -/from/, paired with a pure migration that rewrites a version-@n@ payload -into the version-@(n+1)@ shape. The stored event-type tag is supplied so -multi-event codecs can migrate by the authoritative wire tag rather than a -payload discriminator. A migration may reject malformed input with a 'Left'. --} +-- | One rung of an upcaster chain: the source schema version it upgrades +-- /from/, paired with a pure migration that rewrites a version-@n@ payload +-- into the version-@(n+1)@ shape. The stored event-type tag is supplied so +-- multi-event codecs can migrate by the authoritative wire tag rather than a +-- payload discriminator. A migration may reject malformed input with a 'Left'. type Upcaster = (Int, EventType -> Value -> Either Text Value) -{- | Everything a stream needs to serialize and deserialize its events. - -* 'eventTypes' - the complete set of event-type tags this codec owns. - Encoding and decoding reject any tag outside this set, so it doubles as - the stream's event-type allow-list. -* 'eventType' - projects a domain value to its wire tag (must land in - 'eventTypes'). -* 'schemaVersion' - the current payload version; must be @>= 1@. Stamped - into event metadata on append and used as the migration target on read. -* 'encode' / 'decode' - the current-version JSON serialization. 'decode' - receives the stored event-type tag and only sees payloads already migrated - to 'schemaVersion'. -* 'upcasters' - migrations keyed by source version. To read a - version-@n@ payload the codec applies the @n@, @n+1@, ... rungs in - sequence until it reaches 'schemaVersion'; a missing rung is a - 'GapInUpcasterChain' or 'IncompleteUpcasterChain'. --} +-- | Everything a stream needs to serialize and deserialize its events. +-- +-- * 'eventTypes' - the complete set of event-type tags this codec owns. +-- Encoding and decoding reject any tag outside this set, so it doubles as +-- the stream's event-type allow-list. +-- * 'eventType' - projects a domain value to its wire tag (must land in +-- 'eventTypes'). +-- * 'schemaVersion' - the current payload version; must be @>= 1@. Stamped +-- into event metadata on append and used as the migration target on read. +-- * 'encode' / 'decode' - the current-version JSON serialization. 'decode' +-- receives the stored event-type tag and only sees payloads already migrated +-- to 'schemaVersion'. +-- * 'upcasters' - migrations keyed by source version. To read a +-- version-@n@ payload the codec applies the @n@, @n+1@, ... rungs in +-- sequence until it reaches 'schemaVersion'; a missing rung is a +-- 'GapInUpcasterChain' or 'IncompleteUpcasterChain'. data Codec e = Codec - { eventTypes :: !(NonEmpty EventType) - , eventType :: !(e -> EventType) - , schemaVersion :: !Int - , encode :: !(e -> Value) - , decode :: !(EventType -> Value -> Either Text e) - , upcasters :: ![Upcaster] - } - deriving stock (Generic) + { eventTypes :: !(NonEmpty EventType), + eventType :: !(e -> EventType), + schemaVersion :: !Int, + encode :: !(e -> Value), + decode :: !(EventType -> Value -> Either Text e), + upcasters :: ![Upcaster] + } + deriving stock (Generic) -- | Why an encode or decode could not be completed. data CodecError - = {- | The event-type tag is not one of the codec's 'eventTypes' (carries - the offending tag and the allowed set). - -} - UnknownEventType !EventType ![EventType] - | -- | The codec's 'schemaVersion' is not @>= 1@. - InvalidSchemaVersion !Int - | -- | A stored payload declared a version below @1@. - UnknownVersion !Int - | -- | A stored payload was written by a newer codec version. - VersionAhead !Int !Int - | {- | An upcaster rejected its input; carries the source version and the - migration's error message. - -} - UpcasterError !Int !Text - | -- | The current 'decode' rejected an already-migrated payload. - DecodeFailed !Text - | {- | The upcaster chain is missing a rung: migration reached version - @n@ but the next available upcaster starts at a later version. - -} - GapInUpcasterChain !Int !Int - | -- | The upcaster chain ended before reaching the codec's target version. - IncompleteUpcasterChain !Int !Int - | -- | A present schema-version stamp was malformed. - MalformedSchemaVersionStamp !Value - | -- | Caller-supplied metadata was not a JSON object. - NonObjectCallerMetadata !Value - deriving stock (Generic, Eq, Show) + = -- | The event-type tag is not one of the codec's 'eventTypes' (carries + -- the offending tag and the allowed set). + UnknownEventType !EventType ![EventType] + | -- | The codec's 'schemaVersion' is not @>= 1@. + InvalidSchemaVersion !Int + | -- | A stored payload declared a version below @1@. + UnknownVersion !Int + | -- | A stored payload was written by a newer codec version. + VersionAhead !Int !Int + | -- | An upcaster rejected its input; carries the source version and the + -- migration's error message. + UpcasterError !Int !Text + | -- | The current 'decode' rejected an already-migrated payload. + DecodeFailed !Text + | -- | The upcaster chain is missing a rung: migration reached version + -- @n@ but the next available upcaster starts at a later version. + GapInUpcasterChain !Int !Int + | -- | The upcaster chain ended before reaching the codec's target version. + IncompleteUpcasterChain !Int !Int + | -- | A present schema-version stamp was malformed. + MalformedSchemaVersionStamp !Value + | -- | Caller-supplied metadata was not a JSON object. + NonObjectCallerMetadata !Value + deriving stock (Generic, Eq, Show) -- | Why a raw 'Codec' record did not satisfy the construction invariants. data CodecConfigError - = CodecSchemaVersionInvalid !Int - | CodecDuplicateEventTypes ![EventType] - | CodecDuplicateUpcasterSources ![Int] - | CodecUpcasterSourceOutOfRange !Int !Int - | CodecUpcasterChainIncomplete ![Int] !Int - deriving stock (Generic, Eq, Show) + = CodecSchemaVersionInvalid !Int + | CodecDuplicateEventTypes ![EventType] + | CodecDuplicateUpcasterSources ![Int] + | CodecUpcasterSourceOutOfRange !Int !Int + | CodecUpcasterChainIncomplete ![Int] !Int + deriving stock (Generic, Eq, Show) schemaVersionKey :: Key.Key schemaVersionKey = "schemaVersion" -{- | Validate a raw 'Codec' record before exposing it to runtime use. - -The raw 'Codec' constructor remains exported as an escape hatch for tests and -low-level callers, but production definitions should prefer 'mkCodec' so -misconfigured schema versions and upcaster chains fail at construction time. --} +-- | Validate a raw 'Codec' record before exposing it to runtime use. +-- +-- The raw 'Codec' constructor remains exported as an escape hatch for tests and +-- low-level callers, but production definitions should prefer 'mkCodec' so +-- misconfigured schema versions and upcaster chains fail at construction time. mkCodec :: Codec e -> Either CodecConfigError (Codec e) mkCodec codec - | codec ^. #schemaVersion < 1 = - Left (CodecSchemaVersionInvalid (codec ^. #schemaVersion)) - | Prelude.not (Prelude.null duplicateTypes) = - Left (CodecDuplicateEventTypes duplicateTypes) - | Prelude.not (Prelude.null duplicateSources) = - Left (CodecDuplicateUpcasterSources duplicateSources) - | Just source <- outOfRangeSource = - Left (CodecUpcasterSourceOutOfRange source (codec ^. #schemaVersion)) - | Prelude.not (Prelude.null missingSources) = - Left (CodecUpcasterChainIncomplete missingSources (codec ^. #schemaVersion)) - | otherwise = - Right codec + | codec ^. #schemaVersion < 1 = + Left (CodecSchemaVersionInvalid (codec ^. #schemaVersion)) + | Prelude.not (Prelude.null duplicateTypes) = + Left (CodecDuplicateEventTypes duplicateTypes) + | Prelude.not (Prelude.null duplicateSources) = + Left (CodecDuplicateUpcasterSources duplicateSources) + | Just source <- outOfRangeSource = + Left (CodecUpcasterSourceOutOfRange source (codec ^. #schemaVersion)) + | Prelude.not (Prelude.null missingSources) = + Left (CodecUpcasterChainIncomplete missingSources (codec ^. #schemaVersion)) + | otherwise = + Right codec where sources = List.sort [source | (source, _) <- codec ^. #upcasters] expectedSources = [1 .. (codec ^. #schemaVersion) Prelude.- 1] duplicateTypes = duplicates (NonEmpty.toList (codec ^. #eventTypes)) duplicateSources = duplicates sources outOfRangeSource = - List.find - (\source -> source < 1 Prelude.|| source >= codec ^. #schemaVersion) - sources + List.find + (\source -> source < 1 Prelude.|| source >= codec ^. #schemaVersion) + sources missingSources = expectedSources List.\\ sources duplicates :: (Ord a) => [a] -> [a] duplicates = - Maybe.mapMaybe duplicateHead - . List.group - . List.sort + Maybe.mapMaybe duplicateHead + . List.group + . List.sort where duplicateHead (x : _ : _) = Just x duplicateHead _ = Nothing -{- | Encode a domain event into 'EventData' ready for append, stamping the -codec's 'schemaVersion' into fresh metadata. Equivalent to -'encodeForAppendWithMetadata' with no caller metadata. --} +-- | Encode a domain event into 'EventData' ready for append, stamping the +-- codec's 'schemaVersion' into fresh metadata. Equivalent to +-- 'encodeForAppendWithMetadata' with no caller metadata. encodeForAppend :: Codec e -> e -> Either CodecError EventData encodeForAppend codec value = encodeForAppendWithMetadata codec Nothing value -{- | Encode a domain event into 'EventData', merging the codec's -'schemaVersion' into the supplied metadata object (if any). - -Fails with 'InvalidSchemaVersion' when the codec's version is not @>= 1@, -'UnknownEventType' when 'eventType' produces a tag outside 'eventTypes', or -'NonObjectCallerMetadata' when the caller supplies non-object metadata. The -schema-version key always wins over any clashing key in the caller's metadata -so the stamp on disk is authoritative. --} +-- | Encode a domain event into 'EventData', merging the codec's +-- 'schemaVersion' into the supplied metadata object (if any). +-- +-- Fails with 'InvalidSchemaVersion' when the codec's version is not @>= 1@, +-- 'UnknownEventType' when 'eventType' produces a tag outside 'eventTypes', or +-- 'NonObjectCallerMetadata' when the caller supplies non-object metadata. The +-- schema-version key always wins over any clashing key in the caller's metadata +-- so the stamp on disk is authoritative. encodeForAppendWithMetadata :: Codec e -> Maybe Value -> e -> Either CodecError EventData encodeForAppendWithMetadata codec metadata value = do - unless (codec ^. #schemaVersion > 0) - $ Left (InvalidSchemaVersion (codec ^. #schemaVersion)) - let selectedType = codec ^. #eventType $ value - unless (selectedType `List.elem` NonEmpty.toList (codec ^. #eventTypes)) - $ Left (UnknownEventType selectedType (NonEmpty.toList (codec ^. #eventTypes))) - stampedMetadata <- metadataFor (codec ^. #schemaVersion) metadata - pure - EventData - { eventId = Nothing - , eventType = selectedType - , payload = codec ^. #encode $ value - , metadata = Just stampedMetadata - , causationId = Nothing - , correlationId = Nothing - } + unless (codec ^. #schemaVersion > 0) + $ Left (InvalidSchemaVersion (codec ^. #schemaVersion)) + let selectedType = codec ^. #eventType $ value + unless (selectedType `List.elem` NonEmpty.toList (codec ^. #eventTypes)) + $ Left (UnknownEventType selectedType (NonEmpty.toList (codec ^. #eventTypes))) + stampedMetadata <- metadataFor (codec ^. #schemaVersion) metadata + pure + EventData + { eventId = Nothing, + eventType = selectedType, + payload = codec ^. #encode $ value, + metadata = Just stampedMetadata, + causationId = Nothing, + correlationId = Nothing + } -{- | Build the metadata object stored alongside an event, inserting the schema -version under the @schemaVersion@ key. A non-object @existing@ value is rejected -with 'NonObjectCallerMetadata'. --} +-- | Build the metadata object stored alongside an event, inserting the schema +-- version under the @schemaVersion@ key. A non-object @existing@ value is rejected +-- with 'NonObjectCallerMetadata'. metadataFor :: Int -> Maybe Value -> Either CodecError Value metadataFor version existing = - case existing of - Just object@(Object _) -> - Right (insertVersion object) - Nothing -> - Right (insertVersion (Object KeyMap.empty)) - Just value -> - Left (NonObjectCallerMetadata value) + case existing of + Just object@(Object _) -> + Right (insertVersion object) + Nothing -> + Right (insertVersion (Object KeyMap.empty)) + Just value -> + Left (NonObjectCallerMetadata value) where insertVersion (Object object) = - Object - $ object - & KeyMap.insert schemaVersionKey (Number (Prelude.fromIntegral version)) + Object + $ object + & KeyMap.insert schemaVersionKey (Number (Prelude.fromIntegral version)) insertVersion value = value -{- | Decode a stored 'RecordedEvent' into a domain value. Reads the schema -version stamped in the event's metadata (defaulting to @1@ when absent), -migrates the payload up to the codec's current version, then runs 'decode'. -Rejects events whose type tag is not in 'eventTypes'. --} +-- | Decode a stored 'RecordedEvent' into a domain value. Reads the schema +-- version stamped in the event's metadata (defaulting to @1@ when absent), +-- migrates the payload up to the codec's current version, then runs 'decode'. +-- Rejects events whose type tag is not in 'eventTypes'. decodeRecorded :: Codec e -> RecordedEvent -> Either CodecError e decodeRecorded codec recorded = do - unless (isKnownEventType (recorded ^. #eventType) codec) - $ Left (UnknownEventType (recorded ^. #eventType) (NonEmpty.toList (codec ^. #eventTypes))) - version <- extractSchemaVersion recorded - decodeRaw codec (recorded ^. #eventType) version (recorded ^. #payload) + unless (isKnownEventType (recorded ^. #eventType) codec) + $ Left (UnknownEventType (recorded ^. #eventType) (NonEmpty.toList (codec ^. #eventTypes))) + version <- extractSchemaVersion recorded + decodeRaw codec (recorded ^. #eventType) version (recorded ^. #payload) -{- | Decode a raw JSON payload whose source schema version and event type are -already known. Migrates from @version@ to the codec's current version and runs -'decode'. Useful when the version comes from somewhere other than -recorded-event metadata (e.g. a snapshot, job envelope, or replay tool). --} +-- | Decode a raw JSON payload whose source schema version and event type are +-- already known. Migrates from @version@ to the codec's current version and runs +-- 'decode'. Useful when the version comes from somewhere other than +-- recorded-event metadata (e.g. a snapshot, job envelope, or replay tool). decodeRaw :: Codec e -> EventType -> Int -> Value -> Either CodecError e decodeRaw codec selectedType version payload = do - unless (isKnownEventType selectedType codec) - $ Left (UnknownEventType selectedType (NonEmpty.toList (codec ^. #eventTypes))) - migrated <- migrateToCurrent codec selectedType version payload - case (codec ^. #decode) selectedType migrated of - Right value -> Right value - Left message -> Left (DecodeFailed message) - -{- | Replay the upcaster chain to bring a payload from @sourceVersion@ up to -the codec's current 'schemaVersion'. + unless (isKnownEventType selectedType codec) + $ Left (UnknownEventType selectedType (NonEmpty.toList (codec ^. #eventTypes))) + migrated <- migrateToCurrent codec selectedType version payload + case (codec ^. #decode) selectedType migrated of + Right value -> Right value + Left message -> Left (DecodeFailed message) -A payload exactly at the current version is returned unchanged. A payload from a -future version fails with 'VersionAhead'. Each step looks up the upcaster keyed -by the current version and applies it; the walk stops with -'GapInUpcasterChain' if a later rung exists but an earlier rung is missing, -'IncompleteUpcasterChain' if the chain ends early, 'UpcasterError' if a -migration rejects its input, or 'UnknownVersion' for a source version below @1@. --} +-- | Replay the upcaster chain to bring a payload from @sourceVersion@ up to +-- the codec's current 'schemaVersion'. +-- +-- A payload exactly at the current version is returned unchanged. A payload from a +-- future version fails with 'VersionAhead'. Each step looks up the upcaster keyed +-- by the current version and applies it; the walk stops with +-- 'GapInUpcasterChain' if a later rung exists but an earlier rung is missing, +-- 'IncompleteUpcasterChain' if the chain ends early, 'UpcasterError' if a +-- migration rejects its input, or 'UnknownVersion' for a source version below @1@. migrateToCurrent :: Codec e -> EventType -> Int -> Value -> Either CodecError Value migrateToCurrent codec selectedType sourceVersion payload - | sourceVersion == codec ^. #schemaVersion = Right payload - | sourceVersion > codec ^. #schemaVersion = Left (VersionAhead sourceVersion (codec ^. #schemaVersion)) - | sourceVersion < 1 = Left (UnknownVersion sourceVersion) - | otherwise = go sourceVersion payload + | sourceVersion == codec ^. #schemaVersion = Right payload + | sourceVersion > codec ^. #schemaVersion = Left (VersionAhead sourceVersion (codec ^. #schemaVersion)) + | sourceVersion < 1 = Left (UnknownVersion sourceVersion) + | otherwise = go sourceVersion payload where go version current - | version >= codec ^. #schemaVersion = Right current - | otherwise = - case Prelude.lookup version (codec ^. #upcasters) of - Nothing -> - case nextChainStart version of - Just nextVersion -> Left (GapInUpcasterChain version nextVersion) - Nothing -> Left (IncompleteUpcasterChain version (codec ^. #schemaVersion)) - Just upcast -> - case upcast selectedType current of - Left message -> Left (UpcasterError version message) - Right next -> go (version Prelude.+ 1) next + | version >= codec ^. #schemaVersion = Right current + | otherwise = + case Prelude.lookup version (codec ^. #upcasters) of + Nothing -> + case nextChainStart version of + Just nextVersion -> Left (GapInUpcasterChain version nextVersion) + Nothing -> Left (IncompleteUpcasterChain version (codec ^. #schemaVersion)) + Just upcast -> + case upcast selectedType current of + Left message -> Left (UpcasterError version message) + Right next -> go (version Prelude.+ 1) next nextChainStart version = - case [next | (next, _) <- codec ^. #upcasters, next > version] of - next : _ -> Just next - [] -> Nothing + case [next | (next, _) <- codec ^. #upcasters, next > version] of + next : _ -> Just next + [] -> Nothing -{- | Read the schema version stamped into a recorded event's metadata. Defaults -to @1@ when metadata is absent or the object lacks the @schemaVersion@ key. -Present-but-malformed metadata fails with 'MalformedSchemaVersionStamp'. --} +-- | Read the schema version stamped into a recorded event's metadata. Defaults +-- to @1@ when metadata is absent or the object lacks the @schemaVersion@ key. +-- Present-but-malformed metadata fails with 'MalformedSchemaVersionStamp'. extractSchemaVersion :: RecordedEvent -> Either CodecError Int extractSchemaVersion recorded = - case recorded ^. #metadata of + case recorded ^. #metadata of + Nothing -> Right 1 + Just (Object object) -> + case KeyMap.lookup schemaVersionKey object of Nothing -> Right 1 - Just (Object object) -> - case KeyMap.lookup schemaVersionKey object of - Nothing -> Right 1 - Just stamp@(Number number) -> - maybe - (Left (MalformedSchemaVersionStamp stamp)) - Right - (Scientific.toBoundedInteger number) - Just stamp -> Left (MalformedSchemaVersionStamp stamp) - Just metadata -> Left (MalformedSchemaVersionStamp metadata) + Just stamp@(Number number) -> + maybe + (Left (MalformedSchemaVersionStamp stamp)) + Right + (Scientific.toBoundedInteger number) + Just stamp -> Left (MalformedSchemaVersionStamp stamp) + Just metadata -> Left (MalformedSchemaVersionStamp metadata) isKnownEventType :: EventType -> Codec e -> Bool isKnownEventType selectedType codec = - selectedType `List.elem` NonEmpty.toList (codec ^. #eventTypes) + selectedType `List.elem` NonEmpty.toList (codec ^. #eventTypes) diff --git a/src/Keiro/Codec/Nominal.hs b/src/Keiro/Codec/Nominal.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Codec/Nominal.hs @@ -0,0 +1,58 @@ +-- | Stable runtime contract between consumer-owned nominal domain types and +-- Keiro-owned wire representations. +-- +-- Stability: this module is a published integration point for consumer binding +-- modules and @keiro-dsl@ generated code. Its types and record field names are +-- stable within a major version. Additions are permitted; renames or semantic +-- changes require a major version bump and a coordinated @keiro-dsl@ release. +-- +-- Both directions of a 'NominalBinding' are total. The generated codec remains +-- the only authority for JSON parsing and rendering. A consumer type whose +-- constructor rejects, normalizes, or identifies values of the representation is +-- refined rather than nominal and must not use this API. +module Keiro.Codec.Nominal + ( NominalBinding (..), + NominalFixture (..), + NominalFixtureCases (..), + nominalDomainRoundTrip, + nominalRepresentationRoundTrip, + ) +where + +import Data.Aeson (Value) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) + +-- | A total isomorphism between a consumer-owned domain type and the complete +-- Keiro-owned representation used immediately inside the JSON wire boundary. +data NominalBinding domain representation = NominalBinding + { nominalToRepresentation :: !(domain -> representation), + nominalFromRepresentation :: !(representation -> domain) + } + +-- | One labelled consumer value and its expected generated-codec JSON value. +data NominalFixture domain = NominalFixture + { nominalFixtureLabel :: !Text, + nominalFixtureWire :: !Value, + nominalFixtureDomain :: !domain + } + deriving stock (Eq, Show) + +-- | A non-empty finite corpus used by generated conformance harnesses. +-- +-- The corpus supplies evidence for the total binding contract; it does not prove +-- the laws for values outside the declared cases. +newtype NominalFixtureCases domain = NominalFixtureCases + { nominalFixtureCases :: NonEmpty (NominalFixture domain) + } + deriving stock (Eq, Show) + +-- | Check that a consumer value survives conversion through its representation. +nominalDomainRoundTrip :: (Eq domain) => NominalBinding domain representation -> domain -> Bool +nominalDomainRoundTrip binding value = + nominalFromRepresentation binding (nominalToRepresentation binding value) == value + +-- | Check that a representation survives conversion through the consumer type. +nominalRepresentationRoundTrip :: (Eq representation) => NominalBinding domain representation -> representation -> Bool +nominalRepresentationRoundTrip binding representation = + nominalToRepresentation binding (nominalFromRepresentation binding representation) == representation diff --git a/src/Keiro/Codec/Structural.hs b/src/Keiro/Codec/Structural.hs --- a/src/Keiro/Codec/Structural.hs +++ b/src/Keiro/Codec/Structural.hs @@ -1,82 +1,77 @@ -{- | Stable runtime contract between consumer-owned domain types and -Keiro-generated structural wire shapes. - -Stability: this module is a published integration point for consumer binding -modules and @keiro-dsl@ generated code. Its types and record field names are -stable within a major version. Additions are permitted; renames or semantic -changes require a major version bump and a coordinated @keiro-dsl@ release. - -The generated codec is the single authority for the wire schema. A consumer -'Data.Aeson.ToJSON' or 'Data.Aeson.FromJSON' instance may delegate to that -generated codec through a binding, but Keiro never delegates structural -encoding to a consumer instance. --} -module Keiro.Codec.Structural ( - StructuralBinding (..), +-- | Stable runtime contract between consumer-owned domain types and +-- Keiro-generated structural wire shapes. +-- +-- Stability: this module is a published integration point for consumer binding +-- modules and @keiro-dsl@ generated code. Its types and record field names are +-- stable within a major version. Additions are permitted; renames or semantic +-- changes require a major version bump and a coordinated @keiro-dsl@ release. +-- +-- The generated codec is the single authority for the wire schema. A consumer +-- 'Data.Aeson.ToJSON' or 'Data.Aeson.FromJSON' instance may delegate to that +-- generated codec through a binding, but Keiro never delegates structural +-- encoding to a consumer instance. +module Keiro.Codec.Structural + ( StructuralBinding (..), FixtureCases (..), bindingDomainRoundTrip, bindingShapeRoundTrip, encodeViaBinding, decodeViaBinding, -) + ) where import Data.Aeson (Value) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) -{- | A total construction and destruction boundary between a consumer-owned -type and its declared structural shape. - -Consumer invariants must be represented by the shape. If converting a valid -shape into the consumer type can fail, the declaration is not structural and -must use Keiro's opaque mapping mode instead. --} +-- | A total construction and destruction boundary between a consumer-owned +-- type and its declared structural shape. +-- +-- Consumer invariants must be represented by the shape. If converting a valid +-- shape into the consumer type can fail, the declaration is not structural and +-- must use Keiro's opaque mapping mode instead. data StructuralBinding a shape = StructuralBinding - { bindingToShape :: !(a -> shape) - , bindingFromShape :: !(shape -> a) - } - -{- | Deterministic, labelled consumer values used by generated conformance -harnesses. + { bindingToShape :: !(a -> shape), + bindingFromShape :: !(shape -> a) + } -The generator checks these cases against every declared union and nullable -branch. Values are never invented through @Arbitrary@ or @Default@. Generated -harnesses also reject empty or duplicate labels so failures keep a stable -identity. --} +-- | Deterministic, labelled consumer values used by generated conformance +-- harnesses. +-- +-- The generator checks these cases against every declared union and nullable +-- branch. Values are never invented through @Arbitrary@ or @Default@. Generated +-- harnesses also reject empty or duplicate labels so failures keep a stable +-- identity. newtype FixtureCases a = FixtureCases - { fixtureCases :: NonEmpty (Text, a) - } - deriving stock (Eq, Show) + { fixtureCases :: NonEmpty (Text, a) + } + deriving stock (Eq, Show) -- | Check that a consumer value survives conversion through its shape. bindingDomainRoundTrip :: (Eq a) => StructuralBinding a shape -> a -> Bool bindingDomainRoundTrip binding value = - bindingFromShape binding (bindingToShape binding value) == value + bindingFromShape binding (bindingToShape binding value) == value -- | Check that every declared shape survives conversion through the consumer type. bindingShapeRoundTrip :: (Eq shape) => StructuralBinding a shape -> shape -> Bool bindingShapeRoundTrip binding shape = - bindingToShape binding (bindingFromShape binding shape) == shape - -{- | Encode a consumer value by first converting it to the generated shape. + bindingToShape binding (bindingFromShape binding shape) == shape -This is the sanctioned delegation direction for a consumer-owned JSON -instance: the generated shape encoder remains the wire authority. --} +-- | Encode a consumer value by first converting it to the generated shape. +-- +-- This is the sanctioned delegation direction for a consumer-owned JSON +-- instance: the generated shape encoder remains the wire authority. encodeViaBinding :: StructuralBinding a shape -> (shape -> Value) -> a -> Value encodeViaBinding binding encodeShape = encodeShape . bindingToShape binding -{- | Decode the generated shape and then apply the binding's total constructor. - -All failure comes from parsing JSON into the generated shape. Applying the -binding introduces no hidden semantic rejection. --} +-- | Decode the generated shape and then apply the binding's total constructor. +-- +-- All failure comes from parsing JSON into the generated shape. Applying the +-- binding introduces no hidden semantic rejection. decodeViaBinding :: - StructuralBinding a shape -> - (Value -> Either Text shape) -> - Value -> - Either Text a + StructuralBinding a shape -> + (Value -> Either Text shape) -> + Value -> + Either Text a decodeViaBinding binding decodeShape value = - bindingFromShape binding <$> decodeShape value + bindingFromShape binding <$> decodeShape value diff --git a/src/Keiro/Codec/Structural/Generic.hs b/src/Keiro/Codec/Structural/Generic.hs --- a/src/Keiro/Codec/Structural/Generic.hs +++ b/src/Keiro/Codec/Structural/Generic.hs @@ -8,112 +8,111 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{- | Exact, opt-in nominal derivation for structural bindings. - -The derivation supplies only nominal construction and destruction; wire keys, -union tags, presence, nullability, and defaults remain exclusively in the -@.keiro@ spec and the generated codec. Exact representation mismatches fail at -compile time; both binding laws and finite codec cases remain required evidence -against implementation defects and semantic mistakes. --} -module Keiro.Codec.Structural.Generic ( - GNominalBinding, +-- | Exact, opt-in nominal derivation for structural bindings. +-- +-- The derivation supplies only nominal construction and destruction; wire keys, +-- union tags, presence, nullability, and defaults remain exclusively in the +-- @.keiro@ spec and the generated codec. Exact representation mismatches fail at +-- compile time; both binding laws and finite codec cases remain required evidence +-- against implementation defects and semantic mistakes. +module Keiro.Codec.Structural.Generic + ( GNominalBinding, genericStructuralBinding, -) where + ) +where import Data.Kind (Constraint, Type) import GHC.Generics import GHC.TypeLits (ErrorMessage (..), TypeError) import Keiro.Codec.Structural (StructuralBinding (..)) -{- | Generic representations with identical constructor names, selector names, -field order, arity, and field types. There are deliberately no coercion, -prefix-stripping, or positional-only options. --} +-- | Generic representations with identical constructor names, selector names, +-- field order, arity, and field types. There are deliberately no coercion, +-- prefix-stripping, or positional-only options. class GNominalBinding (domain :: Type -> Type) (shape :: Type -> Type) where - gNominalToShape :: domain parameter -> shape parameter - gNominalFromShape :: shape parameter -> domain parameter + gNominalToShape :: domain parameter -> shape parameter + gNominalFromShape :: shape parameter -> domain parameter instance {-# OVERLAPPING #-} (GNominalBinding domain shape) => GNominalBinding (M1 D domainMeta domain) (M1 D shapeMeta shape) where - gNominalToShape (M1 value) = M1 (gNominalToShape value) - gNominalFromShape (M1 value) = M1 (gNominalFromShape value) + gNominalToShape (M1 value) = M1 (gNominalToShape value) + gNominalFromShape (M1 value) = M1 (gNominalFromShape value) instance {-# OVERLAPPING #-} (SameConstructor domainMeta shapeMeta, GNominalBinding domain shape) => GNominalBinding (M1 C domainMeta domain) (M1 C shapeMeta shape) where - gNominalToShape (M1 value) = M1 (gNominalToShape value) - gNominalFromShape (M1 value) = M1 (gNominalFromShape value) + gNominalToShape (M1 value) = M1 (gNominalToShape value) + gNominalFromShape (M1 value) = M1 (gNominalFromShape value) instance {-# OVERLAPPING #-} (SameSelector domainMeta shapeMeta, GNominalBinding domain shape) => GNominalBinding (M1 S domainMeta domain) (M1 S shapeMeta shape) where - gNominalToShape (M1 value) = M1 (gNominalToShape value) - gNominalFromShape (M1 value) = M1 (gNominalFromShape value) + gNominalToShape (M1 value) = M1 (gNominalToShape value) + gNominalFromShape (M1 value) = M1 (gNominalFromShape value) instance {-# OVERLAPPING #-} (GNominalBinding domainLeft shapeLeft, GNominalBinding domainRight shapeRight) => GNominalBinding (domainLeft :*: domainRight) (shapeLeft :*: shapeRight) where - gNominalToShape (left :*: right) = gNominalToShape left :*: gNominalToShape right - gNominalFromShape (left :*: right) = gNominalFromShape left :*: gNominalFromShape right + gNominalToShape (left :*: right) = gNominalToShape left :*: gNominalToShape right + gNominalFromShape (left :*: right) = gNominalFromShape left :*: gNominalFromShape right instance {-# OVERLAPPING #-} (GNominalBinding domainLeft shapeLeft, GNominalBinding domainRight shapeRight) => GNominalBinding (domainLeft :+: domainRight) (shapeLeft :+: shapeRight) where - gNominalToShape (L1 value) = L1 (gNominalToShape value) - gNominalToShape (R1 value) = R1 (gNominalToShape value) - gNominalFromShape (L1 value) = L1 (gNominalFromShape value) - gNominalFromShape (R1 value) = R1 (gNominalFromShape value) + gNominalToShape (L1 value) = L1 (gNominalToShape value) + gNominalToShape (R1 value) = R1 (gNominalToShape value) + gNominalFromShape (L1 value) = L1 (gNominalFromShape value) + gNominalFromShape (R1 value) = R1 (gNominalFromShape value) instance {-# OVERLAPPING #-} GNominalBinding (K1 domainIndex value) (K1 shapeIndex value) where - gNominalToShape (K1 value) = K1 value - gNominalFromShape (K1 value) = K1 value + gNominalToShape (K1 value) = K1 value + gNominalFromShape (K1 value) = K1 value instance {-# OVERLAPPING #-} GNominalBinding U1 U1 where - gNominalToShape U1 = U1 - gNominalFromShape U1 = U1 + gNominalToShape U1 = U1 + gNominalFromShape U1 = U1 instance {-# OVERLAPPING #-} GNominalBinding V1 V1 where - gNominalToShape value = case value of {} - gNominalFromShape value = case value of {} + gNominalToShape value = case value of {} + gNominalFromShape value = case value of {} instance - {-# OVERLAPPABLE #-} - ( TypeError - ( 'Text "keiro structural binding has no exact nominal correspondence between " - ':<>: 'ShowType domain - ':<>: 'Text " and " - ':<>: 'ShowType shape - ':$$: 'Text "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module." - ) - ) => - GNominalBinding domain shape - where - gNominalToShape _ = error "unreachable: TypeError prevents generic structural binding construction" - gNominalFromShape _ = error "unreachable: TypeError prevents generic structural binding construction" + {-# OVERLAPPABLE #-} + ( TypeError + ( 'Text "keiro structural binding has no exact nominal correspondence between " + ':<>: 'ShowType domain + ':<>: 'Text " and " + ':<>: 'ShowType shape + ':$$: 'Text "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module." + ) + ) => + GNominalBinding domain shape + where + gNominalToShape _ = error "unreachable: TypeError prevents generic structural binding construction" + gNominalFromShape _ = error "unreachable: TypeError prevents generic structural binding construction" type family SameConstructor (domainMeta :: Meta) (shapeMeta :: Meta) :: Constraint where - SameConstructor ('MetaCons name domainFixity domainRecord) ('MetaCons name shapeFixity shapeRecord) = () - SameConstructor ('MetaCons domainName domainFixity domainRecord) ('MetaCons shapeName shapeFixity shapeRecord) = - TypeError - ( 'Text "keiro structural binding constructor mismatch: " - ':<>: 'ShowType domainName - ':<>: 'Text " versus " - ':<>: 'ShowType shapeName - ':$$: 'Text "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module." - ) + SameConstructor ('MetaCons name domainFixity domainRecord) ('MetaCons name shapeFixity shapeRecord) = () + SameConstructor ('MetaCons domainName domainFixity domainRecord) ('MetaCons shapeName shapeFixity shapeRecord) = + TypeError + ( 'Text "keiro structural binding constructor mismatch: " + ':<>: 'ShowType domainName + ':<>: 'Text " versus " + ':<>: 'ShowType shapeName + ':$$: 'Text "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module." + ) type family SameSelector (domainMeta :: Meta) (shapeMeta :: Meta) :: Constraint where - SameSelector ('MetaSel name domainUnpack domainStrict domainDecided) ('MetaSel name shapeUnpack shapeStrict shapeDecided) = () - SameSelector ('MetaSel domainName domainUnpack domainStrict domainDecided) ('MetaSel shapeName shapeUnpack shapeStrict shapeDecided) = - TypeError - ( 'Text "keiro structural binding selector mismatch: " - ':<>: 'ShowType domainName - ':<>: 'Text " versus " - ':<>: 'ShowType shapeName - ':$$: 'Text "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module." - ) + SameSelector ('MetaSel name domainUnpack domainStrict domainDecided) ('MetaSel name shapeUnpack shapeStrict shapeDecided) = () + SameSelector ('MetaSel domainName domainUnpack domainStrict domainDecided) ('MetaSel shapeName shapeUnpack shapeStrict shapeDecided) = + TypeError + ( 'Text "keiro structural binding selector mismatch: " + ':<>: 'ShowType domainName + ':<>: 'Text " versus " + ':<>: 'ShowType shapeName + ':$$: 'Text "Run keiro-dsl scaffold and fill the binding by hand at this error location in the scaffolded module." + ) -- | Derive a total binding when both generic representations correspond exactly. genericStructuralBinding :: - ( Generic domain - , Generic shape - , GNominalBinding (Rep domain) (Rep shape) - ) => - StructuralBinding domain shape + ( Generic domain, + Generic shape, + GNominalBinding (Rep domain) (Rep shape) + ) => + StructuralBinding domain shape genericStructuralBinding = - StructuralBinding - { bindingToShape = to . gNominalToShape . from - , bindingFromShape = to . gNominalFromShape . from - } + StructuralBinding + { bindingToShape = to . gNominalToShape . from, + bindingFromShape = to . gNominalFromShape . from + } diff --git a/src/Keiro/EventStream.hs b/src/Keiro/EventStream.hs --- a/src/Keiro/EventStream.hs +++ b/src/Keiro/EventStream.hs @@ -1,32 +1,31 @@ -{- | The complete description of one persistent event stream. - -An 'EventStream' marries a pure keiki 'SymTransducer' (the decision logic -of a symbolic-register state machine) with everything keiro needs to run -it against a durable event store: where its initial state and registers -come from, how its emitted events are serialized ('Codec'), which physical -stream name to read and write, when to snapshot, and how to serialize that -snapshot. Command handling ("Keiro.Command") hydrates the machine from -stored events (optionally fast-forwarding from a snapshot), steps it with a -command, encodes the resulting events, and appends them. Public command -runners require a 'Keiro.EventStream.Validate.ValidatedEventStream', obtained -from 'Keiro.EventStream.Validate.mkEventStream' or -'Keiro.EventStream.Validate.mkEventStreamOrThrow', rather than a bare record -literal. - -The type parameters thread through from the underlying transducer: - -* @phi@ — the guard/predicate alphabet the transducer branches on. -* @rs@ — the register set ('RegFile' @rs@ holds the live values). -* @s@ — the control state. -* @ci@ — the command input the machine consumes. -* @co@ — the event output the machine emits (what 'eventCodec' serializes). --} -module Keiro.EventStream ( - EventStream (..), +-- | The complete description of one persistent event stream. +-- +-- An 'EventStream' marries a pure keiki 'SymTransducer' (the decision logic +-- of a symbolic-register state machine) with everything keiro needs to run +-- it against a durable event store: where its initial state and registers +-- come from, how its emitted events are serialized ('Codec'), which physical +-- stream name to read and write, when to snapshot, and how to serialize that +-- snapshot. Command handling ("Keiro.Command") hydrates the machine from +-- stored events (optionally fast-forwarding from a snapshot), steps it with a +-- command, encodes the resulting events, and appends them. Public command +-- runners require a 'Keiro.EventStream.Validate.ValidatedEventStream', obtained +-- from 'Keiro.EventStream.Validate.mkEventStream' or +-- 'Keiro.EventStream.Validate.mkEventStreamOrThrow', rather than a bare record +-- literal. +-- +-- The type parameters thread through from the underlying transducer: +-- +-- * @phi@ — the guard/predicate alphabet the transducer branches on. +-- * @rs@ — the register set ('RegFile' @rs@ holds the live values). +-- * @s@ — the control state. +-- * @ci@ — the command input the machine consumes. +-- * @co@ — the event output the machine emits (what 'eventCodec' serializes). +module Keiro.EventStream + ( EventStream (..), Terminality (..), SnapshotPolicy (..), StateCodec (..), -) + ) where import Keiki.Core (RegFile, SymTransducer) @@ -35,82 +34,79 @@ import Keiro.Stream (Stream) import Kiroku.Store.Types (StreamName, StreamVersion) -{- | A self-contained, persistable event stream definition. - -* 'transducer' — the pure keiki state machine that turns a command into - emitted events. -* 'initialState' \/ 'initialRegisters' — the machine's starting control - state and register file, used when hydrating an empty stream. -* 'eventCodec' — serializes and migrates the emitted events (@co@) to and - from stored payloads. -* 'resolveStreamName' — maps a typed 'Stream' handle to the physical - 'StreamName' read and appended to in the store. -* 'snapshotPolicy' — decides, per append, whether to persist a snapshot of - the @(state, registers)@ pair. -* 'stateCodec' — how to serialize that snapshot. Set 'snapshotPolicy' and - 'stateCodec' coherently; 'Keiro.EventStream.Validate.mkEventStream' rejects - a snapshotting policy without a state codec and returns the - 'Keiro.EventStream.Validate.ValidatedEventStream' that command runners accept. --} +-- | A self-contained, persistable event stream definition. +-- +-- * 'transducer' — the pure keiki state machine that turns a command into +-- emitted events. +-- * 'initialState' \/ 'initialRegisters' — the machine's starting control +-- state and register file, used when hydrating an empty stream. +-- * 'eventCodec' — serializes and migrates the emitted events (@co@) to and +-- from stored payloads. +-- * 'resolveStreamName' — maps a typed 'Stream' handle to the physical +-- 'StreamName' read and appended to in the store. +-- * 'snapshotPolicy' — decides, per append, whether to persist a snapshot of +-- the @(state, registers)@ pair. +-- * 'stateCodec' — how to serialize that snapshot. Set 'snapshotPolicy' and +-- 'stateCodec' coherently; 'Keiro.EventStream.Validate.mkEventStream' rejects +-- a snapshotting policy without a state codec and returns the +-- 'Keiro.EventStream.Validate.ValidatedEventStream' that command runners accept. data EventStream phi rs s ci co = EventStream - { transducer :: !(SymTransducer phi rs s ci co) - , initialState :: !s - , initialRegisters :: !(RegFile rs) - , eventCodec :: !(Codec co) - , resolveStreamName :: !(Stream (EventStream phi rs s ci co) -> StreamName) - , snapshotPolicy :: !(SnapshotPolicy (s, RegFile rs)) - , stateCodec :: !(Maybe (StateCodec (s, RegFile rs))) - } - deriving stock (Generic) + { transducer :: !(SymTransducer phi rs s ci co), + initialState :: !s, + initialRegisters :: !(RegFile rs), + eventCodec :: !(Codec co), + resolveStreamName :: !(Stream (EventStream phi rs s ci co) -> StreamName), + snapshotPolicy :: !(SnapshotPolicy (s, RegFile rs)), + stateCodec :: !(Maybe (StateCodec (s, RegFile rs))) + } + deriving stock (Generic) -- | Whether the append that just happened reached a terminal stream state. data Terminality = Terminal | NotTerminal - deriving stock (Eq, Show, Generic) - -{- | When to persist a snapshot of a stream's folded state. - -* 'Never' — never snapshot; always rehydrate from the full event log. -* 'Every' @n@ — snapshot whenever the stream version is a multiple of @n@ - (a non-positive interval disables snapshotting). -* 'OnTerminal' — snapshot only when the machine has reached a final state. -* 'Custom' — an arbitrary predicate over terminality, folded @state@, and - the current 'StreamVersion'. + deriving stock (Eq, Show, Generic) -See 'Keiro.Snapshot.Policy.shouldSnapshot' for the evaluation rules. --} +-- | When to persist a snapshot of a stream's folded state. +-- +-- * 'Never' — never snapshot; always rehydrate from the full event log. +-- * 'Every' @n@ — snapshot whenever the stream version is a multiple of @n@ +-- (a non-positive interval disables snapshotting). +-- * 'OnTerminal' — snapshot only when the machine has reached a final state. +-- * 'Custom' — an arbitrary predicate over terminality, folded @state@, and +-- the current 'StreamVersion'. +-- +-- See 'Keiro.Snapshot.Policy.shouldSnapshot' for the evaluation rules. data SnapshotPolicy state - = Never - | Every !Int - | OnTerminal - | Custom !(Terminality -> state -> StreamVersion -> Bool) - deriving stock (Generic) - -{- | How to serialize and deserialize a stream's snapshot state. - -'stateCodecVersion', 'shapeHash', and 'stateShapeHash' together gate snapshot -reuse: a stored snapshot is only loaded when all three match the current -codec, so incompatible encodings, register layouts, and control-state shapes -invalidate older snapshots and force a clean rehydration from events. - -* 'stateCodecVersion' — bumped when the snapshot encoding changes - incompatibly, and whenever fold logic changes in a way the structural hashes - and any composed fold fingerprint cannot see. -* 'shapeHash' — a digest of the register-file layout. -* 'stateShapeHash' — a digest of the control-state shape, optionally composed - with a fold fingerprint. -* 'encode' \/ 'decode' — the JSON serialization of the @(state, - registers)@ pair. + = Never + | Every !Int + | OnTerminal + | Custom !(Terminality -> state -> StreamVersion -> Bool) + deriving stock (Generic) -Hand-written guard and update function bodies are not structurally -inspectable. Changing them without also changing a composed fold fingerprint -MUST bump 'stateCodecVersion'; otherwise an old snapshot can still match and -be served as a stale hydration seed. --} +-- | How to serialize and deserialize a stream's snapshot state. +-- +-- 'stateCodecVersion', 'shapeHash', and 'stateShapeHash' together gate snapshot +-- reuse: a stored snapshot is only loaded when all three match the current +-- codec, so incompatible encodings, register layouts, and control-state shapes +-- invalidate older snapshots and force a clean rehydration from events. +-- +-- * 'stateCodecVersion' — bumped when the snapshot encoding changes +-- incompatibly, and whenever fold logic changes in a way the structural hashes +-- and any composed fold fingerprint cannot see. +-- * 'shapeHash' — a digest of the register-file layout. +-- * 'stateShapeHash' — a digest of the control-state shape, optionally composed +-- with a fold fingerprint. +-- * 'encode' \/ 'decode' — the JSON serialization of the @(state, +-- registers)@ pair. +-- +-- Hand-written guard and update function bodies are not structurally +-- inspectable. Changing them without also changing a composed fold fingerprint +-- MUST bump 'stateCodecVersion'; otherwise an old snapshot can still match and +-- be served as a stale hydration seed. data StateCodec state = StateCodec - { stateCodecVersion :: !Int - , shapeHash :: !Text - , stateShapeHash :: !Text - , encode :: !(state -> Value) - , decode :: !(Value -> Either Text state) - } - deriving stock (Generic) + { stateCodecVersion :: !Int, + shapeHash :: !Text, + stateShapeHash :: !Text, + encode :: !(state -> Value), + decode :: !(Value -> Either Text state) + } + deriving stock (Generic) diff --git a/src/Keiro/EventStream/Validate.hs b/src/Keiro/EventStream/Validate.hs --- a/src/Keiro/EventStream/Validate.hs +++ b/src/Keiro/EventStream/Validate.hs @@ -1,36 +1,35 @@ -{- | Replay-safety validation for keiro 'EventStream's. - -An 'EventStream' pairs a pure keiki 'SymTransducer' with the durable plumbing -needed to replay it. keiki can prove, with no SMT solver, that a transducer is -/replay-safe/ — each emitted chain is recoverable from its first event, observed -events invert to one edge, input reads are guarded by the matching command -constructor, and output-free edges do not change durable state. The umbrella -also checks guard determinism and structural reachability. This module lifts -keiki's umbrella check ('Keiki.validateTransducer') to the 'EventStream' -boundary so a service can assert all of its streams are sound before hydration. -The boundary also validates the event 'Keiro.Codec.Codec' construction -invariants, so malformed schema versions, duplicate event tags or upcaster -sources, out-of-range rungs, and incomplete chains fail before the service -touches stored streams. - -Every warning enabled by the selected 'ValidationOptions' makes construction -fail. This is intentionally stricter than a pure keiki use: events are keiro's -only durable state, so accepting an unreplayable shape would lose state or defer -the failure to production. Build custom options by updating -'defaultValidationOptions'. The replay-contract checks for head recoverability -and state-changing output-free edges are always forced on at this durable -boundary; caller-supplied options may only strengthen that contract. - -* 'validateEventStream' \/ 'validateEventStreamWith' run the pure check and - return labelled warnings (empty when the stream is sound). -* 'mkEventStream' is a fail-fast smart constructor: it returns @Left warnings@ - for an unsafe stream and @Right validatedStream@ for a sound one. The returned - 'ValidatedEventStream' is the value command runners accept; the bare - 'EventStream' record literal remains available only for construction, - validation, and low-level internals. --} -module Keiro.EventStream.Validate ( - EventStreamWarning (..), +-- | Replay-safety validation for keiro 'EventStream's. +-- +-- An 'EventStream' pairs a pure keiki 'SymTransducer' with the durable plumbing +-- needed to replay it. keiki can prove, with no SMT solver, that a transducer is +-- /replay-safe/ — each emitted chain is recoverable from its first event, observed +-- events invert to one edge, input reads are guarded by the matching command +-- constructor, and output-free edges do not change durable state. The umbrella +-- also checks guard determinism and structural reachability. This module lifts +-- keiki's umbrella check ('Keiki.validateTransducer') to the 'EventStream' +-- boundary so a service can assert all of its streams are sound before hydration. +-- The boundary also validates the event 'Keiro.Codec.Codec' construction +-- invariants, so malformed schema versions, duplicate event tags or upcaster +-- sources, out-of-range rungs, and incomplete chains fail before the service +-- touches stored streams. +-- +-- Every warning enabled by the selected 'ValidationOptions' makes construction +-- fail. This is intentionally stricter than a pure keiki use: events are keiro's +-- only durable state, so accepting an unreplayable shape would lose state or defer +-- the failure to production. Build custom options by updating +-- 'defaultValidationOptions'. The replay-contract checks for head recoverability +-- and state-changing output-free edges are always forced on at this durable +-- boundary; caller-supplied options may only strengthen that contract. +-- +-- * 'validateEventStream' \/ 'validateEventStreamWith' run the pure check and +-- return labelled warnings (empty when the stream is sound). +-- * 'mkEventStream' is a fail-fast smart constructor: it returns @Left warnings@ +-- for an unsafe stream and @Right validatedStream@ for a sound one. The returned +-- 'ValidatedEventStream' is the value command runners accept; the bare +-- 'EventStream' record literal remains available only for construction, +-- validation, and low-level internals. +module Keiro.EventStream.Validate + ( EventStreamWarning (..), ValidatedEventStream, unvalidated, validateEventStream, @@ -41,301 +40,292 @@ -- * Unchecked escape hatch (tests and emergency forensics only) mkEventStreamUnchecked, -) where + ) +where import Control.DeepSeq (force) import Control.Exception (ErrorCall, displayException, evaluate, try) import Data.Text (Text) import Data.Text qualified as Text import GHC.Stack (HasCallStack) -import Keiki.Core ( - EdgeRef (..), +import Keiki.Core + ( EdgeRef (..), HsPred, TransducerValidationWarning (..), ValidationOptions (..), defaultValidationOptions, validateTransducer, - ) + ) import Keiro.Codec qualified as Codec import Keiro.EventStream (EventStream (..), SnapshotPolicy (..), StateCodec (..)) import System.IO.Unsafe (unsafePerformIO) -{- | A validation warning about one event stream, tagged with the -caller-supplied label so a multi-aggregate service can tell which stream is at -fault. --} +-- | A validation warning about one event stream, tagged with the +-- caller-supplied label so a multi-aggregate service can tell which stream is at +-- fault. data EventStreamWarning = EventStreamWarning - { eswStreamLabel :: !Text - , eswReason :: !Text - -- ^ rendered from the keiki warning - } - deriving stock (Eq, Show) + { eswStreamLabel :: !Text, + -- | rendered from the keiki warning + eswReason :: !Text + } + deriving stock (Eq, Show) -{- | An 'EventStream' that has passed keiki validation and keiro's stream-level -checks. Command runners require this wrapper instead of a bare 'EventStream'. -The constructor is intentionally not exported; use 'mkEventStream', -'mkEventStreamWith', or 'mkEventStreamOrThrow' to obtain a validated value. -'mkEventStreamUnchecked' exists only for tests and emergency forensics. --} +-- | An 'EventStream' that has passed keiki validation and keiro's stream-level +-- checks. Command runners require this wrapper instead of a bare 'EventStream'. +-- The constructor is intentionally not exported; use 'mkEventStream', +-- 'mkEventStreamWith', or 'mkEventStreamOrThrow' to obtain a validated value. +-- 'mkEventStreamUnchecked' exists only for tests and emergency forensics. newtype ValidatedEventStream phi rs s ci co - = ValidatedEventStream (EventStream phi rs s ci co) + = ValidatedEventStream (EventStream phi rs s ci co) -- | Recover the underlying stream for internal runners and low-level helpers. unvalidated :: ValidatedEventStream phi rs s ci co -> EventStream phi rs s ci co unvalidated (ValidatedEventStream es) = es -{- | Run keiki's pure umbrella check over a stream's transducer with the default -options. This includes hidden-input, head recoverability, inversion ambiguity, -guarded input reads, state-changing epsilon edges, determinism, and dead-edge -checks, plus the event codec's schema and upcaster-chain construction -invariants. An empty list means the stream passed every enabled check. Pure; -no solver. --} +-- | Run keiki's pure umbrella check over a stream's transducer with the default +-- options. This includes hidden-input, head recoverability, inversion ambiguity, +-- guarded input reads, state-changing epsilon edges, determinism, and dead-edge +-- checks, plus the event codec's schema and upcaster-chain construction +-- invariants. An empty list means the stream passed every enabled check. Pure; +-- no solver. validateEventStream :: - (Bounded s, Enum s, Ord s, Show s) => - -- | caller-supplied stream label - Text -> - EventStream (HsPred rs ci) rs s ci co -> - [EventStreamWarning] + (Bounded s, Enum s, Ord s, Show s) => + -- | caller-supplied stream label + Text -> + EventStream (HsPred rs ci) rs s ci co -> + [EventStreamWarning] validateEventStream = validateEventStreamWith defaultValidationOptions -{- | As 'validateEventStream', but with caller-chosen 'ValidationOptions'. -The head-recoverability and state-changing-epsilon checks are always forced on: -events are keiro's only durable state, so callers may narrow only checks with a -documented benign override. --} +-- | As 'validateEventStream', but with caller-chosen 'ValidationOptions'. +-- The head-recoverability and state-changing-epsilon checks are always forced on: +-- events are keiro's only durable state, so callers may narrow only checks with a +-- documented benign override. validateEventStreamWith :: - (Bounded s, Enum s, Ord s, Show s) => - ValidationOptions -> - -- | caller-supplied stream label - Text -> - EventStream (HsPred rs ci) rs s ci co -> - [EventStreamWarning] + (Bounded s, Enum s, Ord s, Show s) => + ValidationOptions -> + -- | caller-supplied stream label + Text -> + EventStream (HsPred rs ci) rs s ci co -> + [EventStreamWarning] validateEventStreamWith opts label es = - codecConfigWarnings label es - <> snapshotWarnings label es - <> initialSnapshotEncodeWarnings label es - <> [ EventStreamWarning{eswStreamLabel = label, eswReason = renderWarning w} - | w <- validateTransducer (forceReplayContract opts) (transducer es) - ] + codecConfigWarnings label es + <> snapshotWarnings label es + <> initialSnapshotEncodeWarnings label es + <> [ EventStreamWarning {eswStreamLabel = label, eswReason = renderWarning w} + | w <- validateTransducer (forceReplayContract opts) (transducer es) + ] -- | Force the replay-contract checks required at keiro's durable boundary. forceReplayContract :: ValidationOptions -> ValidationOptions forceReplayContract opts = - opts - { checkStateChangingEpsilon = True - , checkHeadRecoverability = True - } + opts + { checkStateChangingEpsilon = True, + checkHeadRecoverability = True + } -{- | Build a validated event stream with the default validation options. -Returns the warnings (@Left@) for an unsafe stream, or a -'ValidatedEventStream' (@Right@) when it passes. --} +-- | Build a validated event stream with the default validation options. +-- Returns the warnings (@Left@) for an unsafe stream, or a +-- 'ValidatedEventStream' (@Right@) when it passes. mkEventStream :: - (Bounded s, Enum s, Ord s, Show s) => - -- | caller-supplied stream label - Text -> - EventStream (HsPred rs ci) rs s ci co -> - Either [EventStreamWarning] (ValidatedEventStream (HsPred rs ci) rs s ci co) + (Bounded s, Enum s, Ord s, Show s) => + -- | caller-supplied stream label + Text -> + EventStream (HsPred rs ci) rs s ci co -> + Either [EventStreamWarning] (ValidatedEventStream (HsPred rs ci) rs s ci co) mkEventStream = mkEventStreamWith defaultValidationOptions -{- | Build a validated event stream with caller-chosen validation options. -The replay-contract checks for head recoverability and state-changing epsilon -edges cannot be disabled here: caller options may only strengthen the durable -boundary. Only narrow other checks for a documented benign warning. --} +-- | Build a validated event stream with caller-chosen validation options. +-- The replay-contract checks for head recoverability and state-changing epsilon +-- edges cannot be disabled here: caller options may only strengthen the durable +-- boundary. Only narrow other checks for a documented benign warning. mkEventStreamWith :: - (Bounded s, Enum s, Ord s, Show s) => - ValidationOptions -> - -- | caller-supplied stream label - Text -> - EventStream (HsPred rs ci) rs s ci co -> - Either [EventStreamWarning] (ValidatedEventStream (HsPred rs ci) rs s ci co) + (Bounded s, Enum s, Ord s, Show s) => + ValidationOptions -> + -- | caller-supplied stream label + Text -> + EventStream (HsPred rs ci) rs s ci co -> + Either [EventStreamWarning] (ValidatedEventStream (HsPred rs ci) rs s ci co) mkEventStreamWith opts label es = - case validateEventStreamWith opts label es of - [] -> Right (ValidatedEventStream es) - warns -> Left warns + case validateEventStreamWith opts label es of + [] -> Right (ValidatedEventStream es) + warns -> Left warns -{- | Partial constructor for generated code and test fixtures that have a -sibling validation proof. Hand-authored application wiring should prefer -'mkEventStream' and handle @Left@ explicitly. --} +-- | Partial constructor for generated code and test fixtures that have a +-- sibling validation proof. Hand-authored application wiring should prefer +-- 'mkEventStream' and handle @Left@ explicitly. mkEventStreamOrThrow :: - (HasCallStack, Bounded s, Enum s, Ord s, Show s) => - -- | caller-supplied stream label - Text -> - EventStream (HsPred rs ci) rs s ci co -> - ValidatedEventStream (HsPred rs ci) rs s ci co + (HasCallStack, Bounded s, Enum s, Ord s, Show s) => + -- | caller-supplied stream label + Text -> + EventStream (HsPred rs ci) rs s ci co -> + ValidatedEventStream (HsPred rs ci) rs s ci co mkEventStreamOrThrow label es = - case mkEventStream label es of - Right validated -> validated - Left warns -> - error $ - "Keiro.EventStream.Validate.mkEventStreamOrThrow: " - <> Text.unpack label - <> " is not replay-safe: " - <> show warns + case mkEventStream label es of + Right validated -> validated + Left warns -> + error $ + "Keiro.EventStream.Validate.mkEventStreamOrThrow: " + <> Text.unpack label + <> " is not replay-safe: " + <> show warns -{- | Wrap an 'EventStream' /without validation/. This skips every keiki and -keiro check, including event-codec construction validation and the -replay-contract checks that 'mkEventStream' force-enables. A stream admitted -through this function can silently lose state changes, select the wrong -upcaster, or fail hydration. Tests and emergency forensics only; never use it -for production streams. Prefer 'mkEventStream'. --} +-- | Wrap an 'EventStream' /without validation/. This skips every keiki and +-- keiro check, including event-codec construction validation and the +-- replay-contract checks that 'mkEventStream' force-enables. A stream admitted +-- through this function can silently lose state changes, select the wrong +-- upcaster, or fail hydration. Tests and emergency forensics only; never use it +-- for production streams. Prefer 'mkEventStream'. mkEventStreamUnchecked :: - EventStream phi rs s ci co -> - ValidatedEventStream phi rs s ci co + EventStream phi rs s ci co -> + ValidatedEventStream phi rs s ci co mkEventStreamUnchecked = ValidatedEventStream codecConfigWarnings :: Text -> EventStream phi rs s ci co -> [EventStreamWarning] codecConfigWarnings label es = - case Codec.mkCodec (eventCodec es) of - Right _ -> [] - Left err -> - [ EventStreamWarning - { eswStreamLabel = label - , eswReason = "event codec misconfigured: " <> renderCodecConfigError err - } - ] + case Codec.mkCodec (eventCodec es) of + Right _ -> [] + Left err -> + [ EventStreamWarning + { eswStreamLabel = label, + eswReason = "event codec misconfigured: " <> renderCodecConfigError err + } + ] renderCodecConfigError :: Codec.CodecConfigError -> Text renderCodecConfigError = \case - Codec.CodecSchemaVersionInvalid version -> - "schema version must be at least 1, got " <> showT version - Codec.CodecDuplicateEventTypes eventTypes -> - "duplicate event type tag(s): " - <> Text.intercalate ", " [tag | Codec.EventType tag <- eventTypes] - Codec.CodecDuplicateUpcasterSources versions -> - "duplicate upcaster source version(s): " - <> renderVersions versions - <> "; only one rung may own each source version" - Codec.CodecUpcasterSourceOutOfRange source target -> - "upcaster source version " - <> showT source - <> " is outside the valid range 1.." - <> showT (target - 1) - <> " for target schema version " - <> showT target - Codec.CodecUpcasterChainIncomplete missing target -> - "missing upcaster source version(s): " - <> renderVersions missing - <> "; stored payloads cannot reach target schema version " - <> showT target + Codec.CodecSchemaVersionInvalid version -> + "schema version must be at least 1, got " <> showT version + Codec.CodecDuplicateEventTypes eventTypes -> + "duplicate event type tag(s): " + <> Text.intercalate ", " [tag | Codec.EventType tag <- eventTypes] + Codec.CodecDuplicateUpcasterSources versions -> + "duplicate upcaster source version(s): " + <> renderVersions versions + <> "; only one rung may own each source version" + Codec.CodecUpcasterSourceOutOfRange source target -> + "upcaster source version " + <> showT source + <> " is outside the valid range 1.." + <> showT (target - 1) + <> " for target schema version " + <> showT target + Codec.CodecUpcasterChainIncomplete missing target -> + "missing upcaster source version(s): " + <> renderVersions missing + <> "; stored payloads cannot reach target schema version " + <> showT target where showT = Text.pack . show renderVersions = Text.intercalate ", " . map showT -{- | Render a keiki warning to a human-readable reason. Every constructor -carry @tvwDetail@; the source vertex is @edgeSource . tvwEdge@ (or @tvwSource@ -for pair warnings). --} +-- | Render a keiki warning to a human-readable reason. Every constructor +-- carry @tvwDetail@; the source vertex is @edgeSource . tvwEdge@ (or @tvwSource@ +-- for pair warnings). renderWarning :: (Show s) => TransducerValidationWarning s -> Text renderWarning w = case w of - HiddenInput{tvwEdge = e, tvwDetail = d} -> - "hidden-input @" <> showT (edgeSource e) <> ": " <> Text.pack d - HeadUnrecoverable{tvwEdge = e, tvwDetail = d} -> - "head-unrecoverable @" <> showT (edgeSource e) <> ": " <> Text.pack d - InversionAmbiguity{tvwSource = s, tvwDetail = d} -> - "inversion-ambiguity @" <> showT s <> ": " <> Text.pack d - UnguardedInputRead{tvwEdge = e, tvwDetail = d} -> - "unguarded-input-read @" <> showT (edgeSource e) <> ": " <> Text.pack d - StateChangingEpsilon{tvwEdge = e, tvwDetail = d} -> - "state-changing-epsilon @" <> showT (edgeSource e) <> ": " <> Text.pack d - NondeterministicPair{tvwSource = s, tvwDetail = d} -> - "nondeterministic @" <> showT s <> ": " <> Text.pack d - PossiblyDeadEdge{tvwEdge = e, tvwDetail = d} -> - "possibly-dead @" <> showT (edgeSource e) <> ": " <> Text.pack d - OpaqueGuard{tvwEdge = e, tvwDetail = d} -> - "opaque-guard @" <> showT (edgeSource e) <> ": " <> Text.pack d - ProjectionResultUnsupported - { tvwEdge = e - , tvwProjectionPath = path - , tvwProjectionShape = shape - , tvwProjectionResultType = resultType - , tvwDetail = d - } -> - "projection-result-unsupported @" - <> showT (edgeSource e) - <> " [" - <> Text.pack path - <> ", shape " - <> Text.pack shape - <> ", result " - <> Text.pack resultType - <> "]: " - <> Text.pack d - ProjectionOrderingUnsupported - { tvwEdge = e - , tvwProjectionPath = path - , tvwProjectionShape = shape - , tvwProjectionResultType = resultType - , tvwDetail = d - } -> - "projection-ordering-unsupported @" - <> showT (edgeSource e) - <> " [" - <> Text.pack path - <> ", shape " - <> Text.pack shape - <> ", result " - <> Text.pack resultType - <> "]: " - <> Text.pack d - ProjectionOutsideGuard - { tvwEdge = e - , tvwProjectionPath = path - , tvwProjectionShape = shape - , tvwProjectionLocation = location - , tvwDetail = d - } -> - "projection-outside-guard @" - <> showT (edgeSource e) - <> " [" - <> Text.pack path - <> ", shape " - <> Text.pack shape - <> ", location " - <> Text.pack location - <> "]: " - <> Text.pack d + HiddenInput {tvwEdge = e, tvwDetail = d} -> + "hidden-input @" <> showT (edgeSource e) <> ": " <> Text.pack d + HeadUnrecoverable {tvwEdge = e, tvwDetail = d} -> + "head-unrecoverable @" <> showT (edgeSource e) <> ": " <> Text.pack d + InversionAmbiguity {tvwSource = s, tvwDetail = d} -> + "inversion-ambiguity @" <> showT s <> ": " <> Text.pack d + UnguardedInputRead {tvwEdge = e, tvwDetail = d} -> + "unguarded-input-read @" <> showT (edgeSource e) <> ": " <> Text.pack d + StateChangingEpsilon {tvwEdge = e, tvwDetail = d} -> + "state-changing-epsilon @" <> showT (edgeSource e) <> ": " <> Text.pack d + NondeterministicPair {tvwSource = s, tvwDetail = d} -> + "nondeterministic @" <> showT s <> ": " <> Text.pack d + PossiblyDeadEdge {tvwEdge = e, tvwDetail = d} -> + "possibly-dead @" <> showT (edgeSource e) <> ": " <> Text.pack d + OpaqueGuard {tvwEdge = e, tvwDetail = d} -> + "opaque-guard @" <> showT (edgeSource e) <> ": " <> Text.pack d + ProjectionResultUnsupported + { tvwEdge = e, + tvwProjectionPath = path, + tvwProjectionShape = shape, + tvwProjectionResultType = resultType, + tvwDetail = d + } -> + "projection-result-unsupported @" + <> showT (edgeSource e) + <> " [" + <> Text.pack path + <> ", shape " + <> Text.pack shape + <> ", result " + <> Text.pack resultType + <> "]: " + <> Text.pack d + ProjectionOrderingUnsupported + { tvwEdge = e, + tvwProjectionPath = path, + tvwProjectionShape = shape, + tvwProjectionResultType = resultType, + tvwDetail = d + } -> + "projection-ordering-unsupported @" + <> showT (edgeSource e) + <> " [" + <> Text.pack path + <> ", shape " + <> Text.pack shape + <> ", result " + <> Text.pack resultType + <> "]: " + <> Text.pack d + ProjectionOutsideGuard + { tvwEdge = e, + tvwProjectionPath = path, + tvwProjectionShape = shape, + tvwProjectionLocation = location, + tvwDetail = d + } -> + "projection-outside-guard @" + <> showT (edgeSource e) + <> " [" + <> Text.pack path + <> ", shape " + <> Text.pack shape + <> ", location " + <> Text.pack location + <> "]: " + <> Text.pack d where showT = Text.pack . show snapshotWarnings :: Text -> EventStream phi rs s ci co -> [EventStreamWarning] snapshotWarnings label es = - case (snapshotPolicy es, stateCodec es) of - (Never, _) -> [] - (_, Just _) -> [] - (_, Nothing) -> - [ EventStreamWarning - { eswStreamLabel = label - , eswReason = "snapshotPolicy is set but stateCodec is Nothing; snapshots would never be written" - } - ] - -{- | Force the configured codec over the initial aggregate state while the -stream is being validated. This catches the labelled @uninit: @ -'ErrorCall' thunks installed by 'Keiki.Generics.emptyRegFile' before a service -can accept commands for a snapshot-enabled stream. + case (snapshotPolicy es, stateCodec es) of + (Never, _) -> [] + (_, Just _) -> [] + (_, Nothing) -> + [ EventStreamWarning + { eswStreamLabel = label, + eswReason = "snapshotPolicy is set but stateCodec is Nothing; snapshots would never be written" + } + ] -The public validation API remains pure; this narrowly scoped exception spoon -observes only 'ErrorCall'. Any other exception remains a programmer-visible -failure instead of being converted into a warning. --} +-- | Force the configured codec over the initial aggregate state while the +-- stream is being validated. This catches the labelled @uninit: @ +-- 'ErrorCall' thunks installed by 'Keiki.Generics.emptyRegFile' before a service +-- can accept commands for a snapshot-enabled stream. +-- +-- The public validation API remains pure; this narrowly scoped exception spoon +-- observes only 'ErrorCall'. Any other exception remains a programmer-visible +-- failure instead of being converted into a warning. initialSnapshotEncodeWarnings :: Text -> EventStream phi rs s ci co -> [EventStreamWarning] initialSnapshotEncodeWarnings label es = - case stateCodec es of - Nothing -> [] - Just codec -> unsafePerformIO $ do - encoded <- try @ErrorCall (evaluate (force (encode codec (initialState es, initialRegisters es)))) - pure $ case encoded of - Right _ -> [] - Left err -> - [ EventStreamWarning - { eswStreamLabel = label - , eswReason = - "stateCodec cannot encode the initial state/registers: " - <> Text.pack (displayException err) - } - ] + case stateCodec es of + Nothing -> [] + Just codec -> unsafePerformIO $ do + encoded <- try @ErrorCall (evaluate (force (encode codec (initialState es, initialRegisters es)))) + pure $ case encoded of + Right _ -> [] + Left err -> + [ EventStreamWarning + { eswStreamLabel = label, + eswReason = + "stateCodec cannot encode the initial state/registers: " + <> Text.pack (displayException err) + } + ] diff --git a/src/Keiro/Integration/Event.hs b/src/Keiro/Integration/Event.hs --- a/src/Keiro/Integration/Event.hs +++ b/src/Keiro/Integration/Event.hs @@ -1,18 +1,17 @@ -{- | Public integration-event envelope. - -A keiro integration event is a public message that crosses from one bounded -context to another over Kafka (or another transport). It is distinct from a -private 'Kiroku.Store.Types.RecordedEvent': domain events are internal facts -of one event stream, while integration events are stable public contracts -versioned independently from the private model. - -This module owns the wire shape, identity rules, and pure encode/decode -helpers. Storage of the envelope ('Keiro.Outbox', 'Keiro.Inbox') and -Kafka-specific producer/consumer wrappers consume this contract; they do -not redefine it. --} -module Keiro.Integration.Event ( - -- * Envelope +-- | Public integration-event envelope. +-- +-- A keiro integration event is a public message that crosses from one bounded +-- context to another over Kafka (or another transport). It is distinct from a +-- private 'Kiroku.Store.Types.RecordedEvent': domain events are internal facts +-- of one event stream, while integration events are stable public contracts +-- versioned independently from the private model. +-- +-- This module owns the wire shape, identity rules, and pure encode/decode +-- helpers. Storage of the envelope ('Keiro.Outbox', 'Keiro.Inbox') and +-- Kafka-specific producer/consumer wrappers consume this contract; they do +-- not redefine it. +module Keiro.Integration.Event + ( -- * Envelope IntegrationEvent (..), IntegrationContentType (..), SchemaReference (..), @@ -47,7 +46,7 @@ headerAttributes, contentTypeText, parseContentType, -) + ) where import Data.Aeson qualified as Aeson @@ -61,153 +60,146 @@ import Keiro.Prelude import Kiroku.Store.Types (EventId (..), GlobalPosition (..)) -{- | The canonical integration-event envelope. - -The envelope is byte-oriented so future schema-registry integration (Avro, -Protobuf, JSON Schema) does not require a table or API migration. JSON -remains the v1 encoding, but the contract itself does not commit to it. - -Identity rules: - -* 'messageId' is an application-level id (UUIDv7 or equivalent - time-ordered UUID) minted by the producer subscription when it writes - the outbox row. It is stable across publish retries because it lives in - the row; Kafka topic/partition/offset are delivery metadata only and - are /not/ the canonical dedupe key. -* 'sourceEventId' and 'sourceGlobalPosition' identify the private event - that produced this integration event. A single source event can fan out - to multiple integration events with distinct 'messageId's; consumers - can opt into source-position deduplication when they want to suppress - reissued public events sharing an upstream cause. - -Routing: - -* 'source' is the producing bounded context (e.g. @\"ordering\"@). -* 'destination' is the Kafka topic, conventionally including a contract - version (@\"billing.orders.v1\"@). -* 'key' partitions per-aggregate within the destination topic. Consumers - see events for the same 'key' in producer order under EP-20's per-key - head-of-line publisher policy. --} +-- | The canonical integration-event envelope. +-- +-- The envelope is byte-oriented so future schema-registry integration (Avro, +-- Protobuf, JSON Schema) does not require a table or API migration. JSON +-- remains the v1 encoding, but the contract itself does not commit to it. +-- +-- Identity rules: +-- +-- * 'messageId' is an application-level id (UUIDv7 or equivalent +-- time-ordered UUID) minted by the producer subscription when it writes +-- the outbox row. It is stable across publish retries because it lives in +-- the row; Kafka topic/partition/offset are delivery metadata only and +-- are /not/ the canonical dedupe key. +-- * 'sourceEventId' and 'sourceGlobalPosition' identify the private event +-- that produced this integration event. A single source event can fan out +-- to multiple integration events with distinct 'messageId's; consumers +-- can opt into source-position deduplication when they want to suppress +-- reissued public events sharing an upstream cause. +-- +-- Routing: +-- +-- * 'source' is the producing bounded context (e.g. @\"ordering\"@). +-- * 'destination' is the Kafka topic, conventionally including a contract +-- version (@\"billing.orders.v1\"@). +-- * 'key' partitions per-aggregate within the destination topic. Consumers +-- see events for the same 'key' in producer order under EP-20's per-key +-- head-of-line publisher policy. data IntegrationEvent = IntegrationEvent - { messageId :: !Text - , source :: !Text - , destination :: !Text - , key :: !(Maybe Text) - , eventType :: !Text - , schemaVersion :: !Int - , contentType :: !IntegrationContentType - , schemaReference :: !(Maybe SchemaReference) - , sourceEventId :: !(Maybe EventId) - , sourceGlobalPosition :: !(Maybe GlobalPosition) - , payloadBytes :: !ByteString - , occurredAt :: !UTCTime - , causationId :: !(Maybe EventId) - , correlationId :: !(Maybe EventId) - , traceContext :: !(Maybe TraceContext) - , attributes :: !(Maybe Value) - } - deriving stock (Eq, Show, Generic) - -{- | Content type of the payload bytes. + { messageId :: !Text, + source :: !Text, + destination :: !Text, + key :: !(Maybe Text), + eventType :: !Text, + schemaVersion :: !Int, + contentType :: !IntegrationContentType, + schemaReference :: !(Maybe SchemaReference), + sourceEventId :: !(Maybe EventId), + sourceGlobalPosition :: !(Maybe GlobalPosition), + payloadBytes :: !ByteString, + occurredAt :: !UTCTime, + causationId :: !(Maybe EventId), + correlationId :: !(Maybe EventId), + traceContext :: !(Maybe TraceContext), + attributes :: !(Maybe Value) + } + deriving stock (Eq, Show, Generic) -'ApplicationJson' is the v1 default. 'OtherContentType' is the open door -for Avro, Protobuf, or any future registry-backed binary format; a future -schema-registry adapter can populate 'schemaReference' alongside. --} +-- | Content type of the payload bytes. +-- +-- 'ApplicationJson' is the v1 default. 'OtherContentType' is the open door +-- for Avro, Protobuf, or any future registry-backed binary format; a future +-- schema-registry adapter can populate 'schemaReference' alongside. data IntegrationContentType - = ApplicationJson - | OtherContentType !Text - deriving stock (Eq, Show, Generic) - -{- | Optional registry-neutral schema reference. + = ApplicationJson + | OtherContentType !Text + deriving stock (Eq, Show, Generic) -Every field is optional because v1 does not require a registry. A future -adapter may populate any combination of registry name, subject, version, -numeric schema id, or fingerprint depending on the registry vendor. The -core envelope preserves all fields verbatim through publish and consume. --} +-- | Optional registry-neutral schema reference. +-- +-- Every field is optional because v1 does not require a registry. A future +-- adapter may populate any combination of registry name, subject, version, +-- numeric schema id, or fingerprint depending on the registry vendor. The +-- core envelope preserves all fields verbatim through publish and consume. data SchemaReference = SchemaReference - { registry :: !(Maybe Text) - , subject :: !(Maybe Text) - , version :: !(Maybe Int) - , schemaId :: !(Maybe Int64) - , fingerprint :: !(Maybe Text) - } - deriving stock (Eq, Show, Generic) - -{- | W3C Trace Context propagation fields. + { registry :: !(Maybe Text), + subject :: !(Maybe Text), + version :: !(Maybe Int), + schemaId :: !(Maybe Int64), + fingerprint :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) -When a service captures @traceparent@ and (optionally) @tracestate@ from -the producing request and threads them through, both fields survive -publish and consume via Kafka headers so a consumer can continue the -same trace. --} +-- | W3C Trace Context propagation fields. +-- +-- When a service captures @traceparent@ and (optionally) @tracestate@ from +-- the producing request and threads them through, both fields survive +-- publish and consume via Kafka headers so a consumer can continue the +-- same trace. data TraceContext = TraceContext - { traceparent :: !Text - , tracestate :: !(Maybe Text) - } - deriving stock (Eq, Show, Generic) + { traceparent :: !Text, + tracestate :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) -{- | Typed decode errors. The encode side cannot fail; the decode side can -fail if payload bytes are malformed JSON, the JSON does not satisfy the -target type, or required envelope metadata is missing. --} +-- | Typed decode errors. The encode side cannot fail; the decode side can +-- fail if payload bytes are malformed JSON, the JSON does not satisfy the +-- target type, or required envelope metadata is missing. data IntegrationEventError - = MalformedPayload !Text - | DecodeFailed !Text - | MissingField !Text - | UnsupportedContentType !Text - deriving stock (Eq, Show, Generic) + = MalformedPayload !Text + | DecodeFailed !Text + | MissingField !Text + | UnsupportedContentType !Text + deriving stock (Eq, Show, Generic) -- | The payload bytes as they should be put on the wire. integrationPayload :: IntegrationEvent -> ByteString integrationPayload = (^. #payloadBytes) -{- | The set of headers a transport should attach to a published message. - -Every header value is a 'Text' for portability — Kafka header values are -arbitrary bytes, but text headers are the convention for human-readable -metadata. The publisher converts these to UTF-8 bytes; the consumer -decodes UTF-8 back to text. - -Headers are emitted only when their source field is populated, so a -service that does not capture trace context, causation, or a schema -reference does not pay a header for it. --} +-- | The set of headers a transport should attach to a published message. +-- +-- Every header value is a 'Text' for portability — Kafka header values are +-- arbitrary bytes, but text headers are the convention for human-readable +-- metadata. The publisher converts these to UTF-8 bytes; the consumer +-- decodes UTF-8 back to text. +-- +-- Headers are emitted only when their source field is populated, so a +-- service that does not capture trace context, causation, or a schema +-- reference does not pay a header for it. integrationHeaders :: IntegrationEvent -> [(Text, Text)] integrationHeaders event = - concat - [ - [ (headerMessageId, event ^. #messageId) - , (headerSource, event ^. #source) - , (headerDestination, event ^. #destination) - , (headerEventType, event ^. #eventType) - , (headerSchemaVersion, Text.pack (show (event ^. #schemaVersion))) - , (headerContentType, contentTypeText (event ^. #contentType)) - ] - , case event ^. #schemaReference of - Nothing -> [] - Just ref -> - concat - [ maybeHeader headerSchemaRegistry (ref ^. #registry) - , maybeHeader headerSchemaSubject (ref ^. #subject) - , maybeHeader headerSchemaVersionRef (fmap (Text.pack . show) (ref ^. #version)) - , maybeHeader headerSchemaId (fmap (Text.pack . show) (ref ^. #schemaId)) - , maybeHeader headerSchemaFingerprint (ref ^. #fingerprint) - ] - , maybeHeader headerSourceEventId (fmap (UUID.toText . eventIdToUuid) (event ^. #sourceEventId)) - , maybeHeader headerSourceGlobalPosition (fmap globalPositionText (event ^. #sourceGlobalPosition)) - , maybeHeader headerCausationId (fmap (UUID.toText . eventIdToUuid) (event ^. #causationId)) - , maybeHeader headerCorrelationId (fmap (UUID.toText . eventIdToUuid) (event ^. #correlationId)) - , case event ^. #traceContext of - Nothing -> [] - Just tc -> - (headerTraceParent, tc ^. #traceparent) - : maybeHeader headerTraceState (tc ^. #tracestate) - , [(headerOccurredAt, Text.pack (iso8601Show (event ^. #occurredAt)))] - , maybeHeader headerAttributes (fmap (TextEncoding.decodeUtf8 . Lazy.toStrict . Aeson.encode) (event ^. #attributes)) - ] + concat + [ [ (headerMessageId, event ^. #messageId), + (headerSource, event ^. #source), + (headerDestination, event ^. #destination), + (headerEventType, event ^. #eventType), + (headerSchemaVersion, Text.pack (show (event ^. #schemaVersion))), + (headerContentType, contentTypeText (event ^. #contentType)) + ], + case event ^. #schemaReference of + Nothing -> [] + Just ref -> + concat + [ maybeHeader headerSchemaRegistry (ref ^. #registry), + maybeHeader headerSchemaSubject (ref ^. #subject), + maybeHeader headerSchemaVersionRef (fmap (Text.pack . show) (ref ^. #version)), + maybeHeader headerSchemaId (fmap (Text.pack . show) (ref ^. #schemaId)), + maybeHeader headerSchemaFingerprint (ref ^. #fingerprint) + ], + maybeHeader headerSourceEventId (fmap (UUID.toText . eventIdToUuid) (event ^. #sourceEventId)), + maybeHeader headerSourceGlobalPosition (fmap globalPositionText (event ^. #sourceGlobalPosition)), + maybeHeader headerCausationId (fmap (UUID.toText . eventIdToUuid) (event ^. #causationId)), + maybeHeader headerCorrelationId (fmap (UUID.toText . eventIdToUuid) (event ^. #correlationId)), + case event ^. #traceContext of + Nothing -> [] + Just tc -> + (headerTraceParent, tc ^. #traceparent) + : maybeHeader headerTraceState (tc ^. #tracestate), + [(headerOccurredAt, Text.pack (iso8601Show (event ^. #occurredAt)))], + maybeHeader headerAttributes (fmap (TextEncoding.decodeUtf8 . Lazy.toStrict . Aeson.encode) (event ^. #attributes)) + ] where maybeHeader name = maybe [] (\value -> [(name, value)]) @@ -244,64 +236,61 @@ -- | The canonical wire string for a 'IntegrationContentType'. contentTypeText :: IntegrationContentType -> Text contentTypeText = \case - ApplicationJson -> "application/json" - OtherContentType raw -> raw + ApplicationJson -> "application/json" + OtherContentType raw -> raw -{- | Parse a content-type header back into an 'IntegrationContentType'. The -JSON form round-trips to 'ApplicationJson'; everything else is preserved -verbatim as 'OtherContentType'. --} +-- | Parse a content-type header back into an 'IntegrationContentType'. The +-- JSON form round-trips to 'ApplicationJson'; everything else is preserved +-- verbatim as 'OtherContentType'. parseContentType :: Text -> IntegrationContentType parseContentType raw - | normalized == "application/json" = ApplicationJson - | otherwise = OtherContentType raw + | normalized == "application/json" = ApplicationJson + | otherwise = OtherContentType raw where normalized = Text.toLower (Text.strip (Text.takeWhile (/= ';') raw)) -{- | Build an 'IntegrationEvent' from a JSON-serializable business payload. - -@encodeJsonIntegrationEvent envelope value@ replaces 'contentType' with -'ApplicationJson' and 'payloadBytes' with the UTF-8 encoding of -@value@'s JSON representation. Every other envelope field is taken from -@envelope@ verbatim, so the caller controls identity, routing, and -metadata. --} +-- | Build an 'IntegrationEvent' from a JSON-serializable business payload. +-- +-- @encodeJsonIntegrationEvent envelope value@ replaces 'contentType' with +-- 'ApplicationJson' and 'payloadBytes' with the UTF-8 encoding of +-- @value@'s JSON representation. Every other envelope field is taken from +-- @envelope@ verbatim, so the caller controls identity, routing, and +-- metadata. encodeJsonIntegrationEvent :: - (ToJSON a) => - -- | Envelope template carrying identity, routing, and metadata. - IntegrationEvent -> - -- | Business payload to encode as JSON. - a -> - IntegrationEvent + (ToJSON a) => + -- | Envelope template carrying identity, routing, and metadata. + IntegrationEvent -> + -- | Business payload to encode as JSON. + a -> + IntegrationEvent encodeJsonIntegrationEvent envelope value = - envelope - & #contentType - .~ ApplicationJson - & #payloadBytes - .~ Lazy.toStrict (Aeson.encode value) - -{- | Decode the JSON payload of an 'IntegrationEvent' into a business -type. + envelope + & #contentType + .~ ApplicationJson + & #payloadBytes + .~ Lazy.toStrict (Aeson.encode value) -Returns 'MalformedPayload' if the bytes are not valid JSON, -'DecodeFailed' if the JSON does not satisfy the target's 'FromJSON' -instance, and 'UnsupportedContentType' if the envelope's 'contentType' -is not 'ApplicationJson'. --} +-- | Decode the JSON payload of an 'IntegrationEvent' into a business +-- type. +-- +-- Returns 'MalformedPayload' if the bytes are not valid JSON, +-- 'DecodeFailed' if the JSON does not satisfy the target's 'FromJSON' +-- instance, and 'UnsupportedContentType' if the envelope's 'contentType' +-- is not 'ApplicationJson'. decodeJsonIntegrationEvent :: - (FromJSON a) => - IntegrationEvent -> - Either IntegrationEventError a + (FromJSON a) => + IntegrationEvent -> + Either IntegrationEventError a decodeJsonIntegrationEvent event = do - case event ^. #contentType of - ApplicationJson -> pure () - OtherContentType raw -> Left (UnsupportedContentType raw) - parsed <- case Aeson.eitherDecodeStrict (event ^. #payloadBytes) of - Left err -> Left (MalformedPayload (Text.pack err)) - Right value -> Right (value :: Value) - case parseEither parseJSON parsed of - Left err -> Left (DecodeFailed (Text.pack err)) - Right value -> Right value + case event ^. #contentType of + ApplicationJson -> pure () + OtherContentType raw -> Left (UnsupportedContentType raw) + parsed <- case Aeson.eitherDecodeStrict (event ^. #payloadBytes) of + Left err -> Left (MalformedPayload (Text.pack err)) + Right value -> Right (value :: Value) + case parseEither parseJSON parsed of + Left err -> Left (DecodeFailed (Text.pack err)) + Right value -> Right value eventIdToUuid :: EventId -> UUID.UUID eventIdToUuid (EventId uuid) = uuid diff --git a/src/Keiro/Prelude.hs b/src/Keiro/Prelude.hs --- a/src/Keiro/Prelude.hs +++ b/src/Keiro/Prelude.hs @@ -1,24 +1,23 @@ -{- | The curated prelude shared across the Keiro packages. - -Re-exports a deliberately small slice of @base@, @aeson@, @text@, @time@, -and the full @lens@ surface so modules can open with a single -@import Keiro.Prelude@ and get a consistent, explicit set of names. The -implicit @base@ @Prelude@ is expected to be disabled -(@NoImplicitPrelude@); only the names listed here are in scope, which -keeps event-sourcing code uniform and avoids accidental partial functions. - -The @generic-lens@ @Data.Generics.Labels@ orphan instances are imported -for their effect only, enabling the @^. #field@ overloaded-label optics -used throughout the codebase. --} -module Keiro.Prelude ( - module X, +-- | The curated prelude shared across the Keiro packages. +-- +-- Re-exports a deliberately small slice of @base@, @aeson@, @text@, @time@, +-- and the full @lens@ surface so modules can open with a single +-- @import Keiro.Prelude@ and get a consistent, explicit set of names. The +-- implicit @base@ @Prelude@ is expected to be disabled +-- (@NoImplicitPrelude@); only the names listed here are in scope, which +-- keeps event-sourcing code uniform and avoids accidental partial functions. +-- +-- The @generic-lens@ @Data.Generics.Labels@ orphan instances are imported +-- for their effect only, enabling the @^. #field@ overloaded-label optics +-- used throughout the codebase. +module Keiro.Prelude + ( module X, module Control.Lens, -) + ) where -import "aeson" Data.Aeson as X ( - FromJSON, +import "aeson" Data.Aeson as X + ( FromJSON, Options, SumEncoding (..), ToJSON, @@ -31,7 +30,7 @@ parseJSON, toEncoding, toJSON, - ) + ) import "aeson-casing" Data.Aeson.Casing as X (aesonDrop, aesonPrefix, camelCase, pascalCase, snakeCase, trainCase) import "base" Control.Applicative as X ((<|>)) import "base" Control.Monad as X (guard, unless, void, when) @@ -54,8 +53,8 @@ import "lens" Control.Lens import "text" Data.Text as X (Text) import "time" Data.Time as X (UTCTime, getCurrentTime) -import "base" Prelude as X ( - Applicative (..), +import "base" Prelude as X + ( Applicative (..), Bounded (..), Enum (..), IO, @@ -63,4 +62,4 @@ Show (..), error, pure, - ) + ) diff --git a/src/Keiro/Schema.hs b/src/Keiro/Schema.hs --- a/src/Keiro/Schema.hs +++ b/src/Keiro/Schema.hs @@ -1,13 +1,12 @@ -{- | The single source of truth for the name of the dedicated PostgreSQL schema -that owns all of Keiro's framework tables. - -A PostgreSQL /schema/ is a namespace inside one database. Keiro's framework -tables (@keiro_snapshots@, @keiro_timers@, @keiro_outbox@, …) live in the schema -named by 'keiroSchema'. The migrations in @keiro-migrations@ create them -schema-qualified (@keiro.@); runtime queries in the @keiro@ package -qualify against this same name. This is the literal string every part of the -system must agree on, so it is defined once here and imported elsewhere. --} +-- | The single source of truth for the name of the dedicated PostgreSQL schema +-- that owns all of Keiro's framework tables. +-- +-- A PostgreSQL /schema/ is a namespace inside one database. Keiro's framework +-- tables (@keiro_snapshots@, @keiro_timers@, @keiro_outbox@, …) live in the schema +-- named by 'keiroSchema'. The migrations in @keiro-migrations@ create them +-- schema-qualified (@keiro.
@); runtime queries in the @keiro@ package +-- qualify against this same name. This is the literal string every part of the +-- system must agree on, so it is defined once here and imported elsewhere. module Keiro.Schema (keiroSchema) where import Data.Text (Text) diff --git a/src/Keiro/Snapshot/Policy.hs b/src/Keiro/Snapshot/Policy.hs --- a/src/Keiro/Snapshot/Policy.hs +++ b/src/Keiro/Snapshot/Policy.hs @@ -1,14 +1,13 @@ -{- | Evaluation of a stream's 'SnapshotPolicy'. - -This is the single decision procedure command handling consults after an -append to decide whether to persist a snapshot of the folded state. It -keeps the 'SnapshotPolicy' constructors purely declarative — the meaning -of each constructor lives here. --} -module Keiro.Snapshot.Policy ( - shouldSnapshot, +-- | Evaluation of a stream's 'SnapshotPolicy'. +-- +-- This is the single decision procedure command handling consults after an +-- append to decide whether to persist a snapshot of the folded state. It +-- keeps the 'SnapshotPolicy' constructors purely declarative — the meaning +-- of each constructor lives here. +module Keiro.Snapshot.Policy + ( shouldSnapshot, shouldSnapshotSpan, -) + ) where import Keiro.EventStream (SnapshotPolicy (..), Terminality (..)) @@ -16,44 +15,42 @@ import Kiroku.Store.Types (StreamVersion (..)) import Prelude qualified -{- | Decide whether to snapshot given a policy, a terminality flag, the -folded state, and the post-append stream version. - -* 'Never' is always 'False'. -* 'Every' @n@ is 'True' when the version is a positive multiple of @n@ - (a non-positive interval never fires). -* 'OnTerminal' mirrors the @terminal@ flag — snapshot exactly when the - machine has reached a final state. -* 'Custom' defers to the caller-supplied predicate over state and version. --} +-- | Decide whether to snapshot given a policy, a terminality flag, the +-- folded state, and the post-append stream version. +-- +-- * 'Never' is always 'False'. +-- * 'Every' @n@ is 'True' when the version is a positive multiple of @n@ +-- (a non-positive interval never fires). +-- * 'OnTerminal' mirrors the @terminal@ flag — snapshot exactly when the +-- machine has reached a final state. +-- * 'Custom' defers to the caller-supplied predicate over state and version. shouldSnapshot :: SnapshotPolicy state -> Terminality -> state -> StreamVersion -> Bool shouldSnapshot Never _ _ _ = False shouldSnapshot (Every interval) _ _ (StreamVersion version) - | interval <= 0 = False - | otherwise = version > 0 Prelude.&& version `Prelude.mod` Prelude.fromIntegral interval == 0 + | interval <= 0 = False + | otherwise = version > 0 Prelude.&& version `Prelude.mod` Prelude.fromIntegral interval == 0 shouldSnapshot OnTerminal terminality _ _ = terminality == Terminal shouldSnapshot (Custom decide) terminality state version = decide terminality state version -{- | Like 'shouldSnapshot', but evaluated over the half-open stream-version -span @(preVersion, postVersion]@ that one append covered. - -For 'Every' @n@, this fires when any positive multiple of @n@ lies inside -the span, so a batch append that jumps over a boundary still snapshots at -the post-append version. The other policies ignore the span and behave like -'shouldSnapshot'. --} +-- | Like 'shouldSnapshot', but evaluated over the half-open stream-version +-- span @(preVersion, postVersion]@ that one append covered. +-- +-- For 'Every' @n@, this fires when any positive multiple of @n@ lies inside +-- the span, so a batch append that jumps over a boundary still snapshots at +-- the post-append version. The other policies ignore the span and behave like +-- 'shouldSnapshot'. shouldSnapshotSpan :: - SnapshotPolicy state -> - Terminality -> - state -> - StreamVersion -> - StreamVersion -> - Bool + SnapshotPolicy state -> + Terminality -> + state -> + StreamVersion -> + StreamVersion -> + Bool shouldSnapshotSpan Never _ _ _ _ = False shouldSnapshotSpan (Every interval) _ _ (StreamVersion preVersion) (StreamVersion postVersion) - | interval <= 0 = False - | postVersion <= 0 = False - | otherwise = postVersion `Prelude.div` n > preVersion `Prelude.div` n + | interval <= 0 = False + | postVersion <= 0 = False + | otherwise = postVersion `Prelude.div` n > preVersion `Prelude.div` n where n = Prelude.fromIntegral interval shouldSnapshotSpan OnTerminal terminality _ _ _ = terminality == Terminal diff --git a/src/Keiro/Stream.hs b/src/Keiro/Stream.hs --- a/src/Keiro/Stream.hs +++ b/src/Keiro/Stream.hs @@ -1,14 +1,13 @@ -{- | A phantom-typed handle to a single event stream. - -'Stream' wraps a 'StreamName' but carries a phantom type parameter @a@ -identifying /which/ aggregate or event stream the name belongs to. This -lets the rest of the framework demand, say, a @Stream Order@ rather than a -bare 'StreamName', so a name for one aggregate cannot be passed where -another is expected. The wrapper is otherwise transparent — use 'stream' -to construct one and 'streamName' to recover the underlying name. --} -module Keiro.Stream ( - Stream (..), +-- | A phantom-typed handle to a single event stream. +-- +-- 'Stream' wraps a 'StreamName' but carries a phantom type parameter @a@ +-- identifying /which/ aggregate or event stream the name belongs to. This +-- lets the rest of the framework demand, say, a @Stream Order@ rather than a +-- bare 'StreamName', so a name for one aggregate cannot be passed where +-- another is expected. The wrapper is otherwise transparent — use 'stream' +-- to construct one and 'streamName' to recover the underlying name. +module Keiro.Stream + ( Stream (..), stream, streamName, mapStreamName, @@ -23,7 +22,7 @@ StreamIdSegment (..), entityStream, entityStreamId, -) + ) where import Data.Char qualified as Char @@ -35,117 +34,109 @@ -- | A 'StreamName' tagged with the phantom type @a@ of the stream it names. newtype Stream a = Stream - { name :: StreamName - } - deriving stock (Generic, Eq, Ord, Show) + { name :: StreamName + } + deriving stock (Generic, Eq, Ord, Show) -- | Build a 'Stream' handle from a raw stream-name 'Text'. stream :: Text -> Stream a -stream name = Stream{name = StreamName name} +stream name = Stream {name = StreamName name} -- | Recover the underlying 'StreamName' from a 'Stream' handle. streamName :: Stream a -> StreamName streamName value = value ^. #name -{- | Transform the underlying 'StreamName' while preserving the phantom -type. Handy for namespacing or prefixing a stream name without losing the -compile-time tag. --} +-- | Transform the underlying 'StreamName' while preserving the phantom +-- type. Handy for namespacing or prefixing a stream name without losing the +-- compile-time tag. mapStreamName :: (StreamName -> StreamName) -> Stream a -> Stream a mapStreamName f value = value & #name %~ f -{- | A validated stream /category/: the prefix that precedes the first @-@ in -every stream name belonging to this family. Kiroku defines a stream's category -as the substring before its first @-@ (see 'Kiroku.Store.Types.categoryName'), -so a category must itself contain no @-@. Carries the same phantom type @a@ as -the 'Stream' handles it produces. Write a compound category in camelCase (e.g. -@"hospitalSurge"@ for a saga over hospital surges); @:@ is reserved for the -workflow stream family (@wf:\@). - -Named 'StreamCategory' (not @Category@) to avoid clashing with the -'Kiroku.Store.Subscription.Types.Category' subscription-target constructor, -which consumer code commonly imports alongside this module. --} +-- | A validated stream /category/: the prefix that precedes the first @-@ in +-- every stream name belonging to this family. Kiroku defines a stream's category +-- as the substring before its first @-@ (see 'Kiroku.Store.Types.categoryName'), +-- so a category must itself contain no @-@. Carries the same phantom type @a@ as +-- the 'Stream' handles it produces. Write a compound category in camelCase (e.g. +-- @"hospitalSurge"@ for a saga over hospital surges); @:@ is reserved for the +-- workflow stream family (@wf:\@). +-- +-- Named 'StreamCategory' (not @Category@) to avoid clashing with the +-- 'Kiroku.Store.Subscription.Types.Category' subscription-target constructor, +-- which consumer code commonly imports alongside this module. newtype StreamCategory a = StreamCategory {categoryTextOf :: Text} - deriving stock (Generic, Eq, Ord, Show) + deriving stock (Generic, Eq, Ord, Show) -- | Why a 'Text' is not a valid 'StreamCategory'. data CategoryError - = -- | the empty string - CategoryEmpty - | -- | contains the reserved @-@ category/id boundary - CategoryContainsSeparator !Text - | -- | equals a store-reserved name (@$all@) - CategoryReserved !Text - | -- | contains whitespace or a control character - CategoryContainsIllegalChar !Char !Text - deriving stock (Eq, Show, Generic) + = -- | the empty string + CategoryEmpty + | -- | contains the reserved @-@ category/id boundary + CategoryContainsSeparator !Text + | -- | equals a store-reserved name (@$all@) + CategoryReserved !Text + | -- | contains whitespace or a control character + CategoryContainsIllegalChar !Char !Text + deriving stock (Eq, Show, Generic) -{- | Validate a 'Text' as a 'Category'. Rejects the empty string, any text -containing @-@ (Kiroku's category/id boundary, which would make 'categoryName' -ambiguous), whitespace/control characters, and the reserved name @$all@. --} +-- | Validate a 'Text' as a 'Category'. Rejects the empty string, any text +-- containing @-@ (Kiroku's category/id boundary, which would make 'categoryName' +-- ambiguous), whitespace/control characters, and the reserved name @$all@. category :: Text -> Either CategoryError (StreamCategory a) category t - | Text.null t = Left CategoryEmpty - | t == "$all" = Left (CategoryReserved t) - | Text.isInfixOf "-" t = Left (CategoryContainsSeparator t) - | Just illegal <- Text.find (\c -> Char.isSpace c || Char.isControl c) t = - Left (CategoryContainsIllegalChar illegal t) - | otherwise = Right (StreamCategory t) + | Text.null t = Left CategoryEmpty + | t == "$all" = Left (CategoryReserved t) + | Text.isInfixOf "-" t = Left (CategoryContainsSeparator t) + | Just illegal <- Text.find (\c -> Char.isSpace c || Char.isControl c) t = + Left (CategoryContainsIllegalChar illegal t) + | otherwise = Right (StreamCategory t) -- | Recover the validated category text. categoryText :: StreamCategory a -> Text categoryText (StreamCategory t) = t -{- | Partial constructor for static, known-good category literals at definition -sites. Calls 'error' on an invalid category; never pass user input. Intended for -top-level @fooCategory = categoryUnsafe "foo"@. --} +-- | Partial constructor for static, known-good category literals at definition +-- sites. Calls 'error' on an invalid category; never pass user input. Intended for +-- top-level @fooCategory = categoryUnsafe "foo"@. categoryUnsafe :: (HasCallStack) => Text -> StreamCategory a categoryUnsafe t = - case category t of - Right value -> value - Left err -> error ("Keiro.Stream.categoryUnsafe: invalid category " <> show t <> ": " <> show err) + case category t of + Right value -> value + Left err -> error ("Keiro.Stream.categoryUnsafe: invalid category " <> show t <> ": " <> show err) -{- | The 'CategoryName' for category-scoped reads -('Kiroku.Store.Read.readCategory') and category subscription targets. For any -@cat@ and id segment, @categoryName cat@ equals -@Kiroku.Store.Types.categoryName (streamName (entityStream cat id))@ — the -category rule is single-sourced in kiroku. --} +-- | The 'CategoryName' for category-scoped reads +-- ('Kiroku.Store.Read.readCategory') and category subscription targets. For any +-- @cat@ and id segment, @categoryName cat@ equals +-- @Kiroku.Store.Types.categoryName (streamName (entityStream cat id))@ — the +-- category rule is single-sourced in kiroku. categoryName :: StreamCategory a -> CategoryName categoryName (StreamCategory t) = CategoryName t -{- | Render a value as the /id segment/ of a stream name (the part after the -first @-@). The id may itself contain @-@ without corrupting the leading -category, but must be non-blank to keep the stream name distinct from a bare -category read. --} +-- | Render a value as the /id segment/ of a stream name (the part after the +-- first @-@). The id may itself contain @-@ without corrupting the leading +-- category, but must be non-blank to keep the stream name distinct from a bare +-- category read. class StreamIdSegment i where - renderIdSegment :: i -> Text + renderIdSegment :: i -> Text instance StreamIdSegment Text where - renderIdSegment = id + renderIdSegment = id instance StreamIdSegment String where - renderIdSegment = Text.pack + renderIdSegment = Text.pack -{- | Build the per-entity 'Stream' handle for an aggregate instance, rendering -@\-\@. The phantom type is carried from the 'StreamCategory', so -the result is correctly tagged. The actual name mechanics are delegated to -kiroku's 'Store.streamNameInCategory', keeping the category rule single-sourced -in the store. --} +-- | Build the per-entity 'Stream' handle for an aggregate instance, rendering +-- @\-\@. The phantom type is carried from the 'StreamCategory', so +-- the result is correctly tagged. The actual name mechanics are delegated to +-- kiroku's 'Store.streamNameInCategory', keeping the category rule single-sourced +-- in the store. entityStream :: (HasCallStack) => StreamCategory a -> Text -> Stream a entityStream (StreamCategory c) idSeg = - if Text.null (Text.strip idSeg) - then error ("Keiro.Stream.entityStream: blank id segment for category " <> show c) - else Stream{name = Store.streamNameInCategory (CategoryName c) idSeg} + if Text.null (Text.strip idSeg) + then error ("Keiro.Stream.entityStream: blank id segment for category " <> show c) + else Stream {name = Store.streamNameInCategory (CategoryName c) idSeg} -{- | 'entityStream' for a typed id with a 'StreamIdSegment' instance. Domain id -types typically add @instance StreamIdSegment FooId where renderIdSegment = -Text.pack . show@. --} +-- | 'entityStream' for a typed id with a 'StreamIdSegment' instance. Domain id +-- types typically add @instance StreamIdSegment FooId where renderIdSegment = +-- Text.pack . show@. entityStreamId :: (HasCallStack, StreamIdSegment i) => StreamCategory a -> i -> Stream a entityStreamId c = entityStream c . renderIdSegment