diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,7 +6,37 @@ ## [Unreleased] -_No unreleased changes._ +## 0.4.0.1 — 2026-07-28 + +### Other Changes + +- Adds PVP upper bounds to every dependency that previously carried a lower + bound only, so `cabal check` reports no packaging warnings. No API or + behaviour change from 0.4.0.0, which was tagged but never published. + + +## 0.4.0.0 — 2026-07-28 + +### Breaking Changes + +- `StateCodec` includes the control-state/fold shape discriminator used with + the register-layout hash; stale snapshot seeds are invalidated when either + executable state shape changes. +- Validated event-stream construction rejects invalid event codec schemas, + tags, and upcaster chains at assembly. `mkEventStreamUnchecked` remains the + explicit emergency-forensics bypass. +- Requires Keiki 0.4 and handles its typed projection terms and validation + findings explicitly. + +### New Features + +- Adds the stable `Keiro.Codec.Structural` integration surface for generated + structural codecs: total `StructuralBinding` values, deterministic labelled + `FixtureCases`, both binding-law helpers, and one-way JSON delegation helpers. +- Adds `Keiro.Codec.Structural.Generic.genericStructuralBinding`, an opt-in + nominal adapter that accepts only exact constructor, selector, arity, order, + and field-type correspondence and otherwise emits a compile-time direction + to the scaffolded binding module. ## 0.3.0.0 — 2026-07-14 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.3.0.0 +version: 0.4.0.1 synopsis: Core contracts for Keiro packages description: Stable stream, codec, event-stream, and integration-event contracts @@ -40,6 +40,8 @@ import: warnings, shared exposed-modules: Keiro.Codec + Keiro.Codec.Structural + Keiro.Codec.Structural.Generic Keiro.EventStream Keiro.EventStream.Validate Keiro.Integration.Event @@ -50,16 +52,16 @@ hs-source-dirs: src build-depends: - , aeson >=2.2 - , aeson-casing >=0.2 + , aeson >=2.2 && <2.3 + , aeson-casing >=0.2 && <0.3 , base >=4.21 && <5 - , bytestring >=0.11 - , deepseq >=1.5 - , generic-lens >=2.2 - , keiki >=0.2 && <0.3 + , bytestring >=0.11 && <0.13 + , deepseq >=1.5 && <1.6 + , generic-lens >=2.2 && <2.4 + , keiki >=0.4 && <0.5 , kiroku-store >=0.3 && <0.4 - , lens >=5.2 - , scientific >=0.3 - , text >=2.1 - , time >=1.12 - , uuid >=1.3 + , lens >=5.2 && <5.4 + , scientific >=0.3 && <0.4 + , text >=2.1 && <2.2 + , time >=1.12 && <1.15 + , uuid >=1.3 && <1.4 diff --git a/src/Keiro/Codec/Structural.hs b/src/Keiro/Codec/Structural.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Codec/Structural.hs @@ -0,0 +1,82 @@ +{- | 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. +-} +data StructuralBinding a shape = StructuralBinding + { bindingToShape :: !(a -> shape) + , bindingFromShape :: !(shape -> a) + } + +{- | 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) + +-- | 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 + +-- | 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. + +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. +-} +decodeViaBinding :: + StructuralBinding a shape -> + (Value -> Either Text shape) -> + Value -> + Either Text a +decodeViaBinding binding decodeShape value = + bindingFromShape binding <$> decodeShape value diff --git a/src/Keiro/Codec/Structural/Generic.hs b/src/Keiro/Codec/Structural/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Keiro/Codec/Structural/Generic.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# 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, + genericStructuralBinding, +) 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. +-} +class GNominalBinding (domain :: Type -> Type) (shape :: Type -> Type) where + 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) + +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) + +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) + +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 + +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) + +instance {-# OVERLAPPING #-} GNominalBinding (K1 domainIndex value) (K1 shapeIndex value) where + gNominalToShape (K1 value) = K1 value + gNominalFromShape (K1 value) = K1 value + +instance {-# OVERLAPPING #-} GNominalBinding U1 U1 where + gNominalToShape U1 = U1 + gNominalFromShape U1 = U1 + +instance {-# OVERLAPPING #-} GNominalBinding V1 V1 where + 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" + +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." + ) + +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." + ) + +-- | Derive a total binding when both generic representations correspond exactly. +genericStructuralBinding :: + ( Generic domain + , Generic shape + , GNominalBinding (Rep domain) (Rep shape) + ) => + StructuralBinding domain shape +genericStructuralBinding = + 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 @@ -87,21 +87,29 @@ {- | How to serialize and deserialize a stream's snapshot state. -'stateCodecVersion' and 'shapeHash' together gate snapshot reuse: a stored -snapshot is only loaded when both match the current codec, so a change to -the snapshot encoding or to the shape of the folded state invalidates older -snapshots and forces a clean rehydration from events. +'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. -* 'shapeHash' — a digest of the folded-state shape; protects against - silently loading a snapshot whose structure no longer matches. + 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) } 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 @@ -8,6 +8,10 @@ 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 @@ -52,6 +56,7 @@ defaultValidationOptions, validateTransducer, ) +import Keiro.Codec qualified as Codec import Keiro.EventStream (EventStream (..), SnapshotPolicy (..), StateCodec (..)) import System.IO.Unsafe (unsafePerformIO) @@ -82,8 +87,9 @@ {- | 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. An empty list means the stream passed every enabled check. Pure; no -solver. +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) => @@ -106,7 +112,8 @@ EventStream (HsPred rs ci) rs s ci co -> [EventStreamWarning] validateEventStreamWith opts label es = - snapshotWarnings label es + codecConfigWarnings label es + <> snapshotWarnings label es <> initialSnapshotEncodeWarnings label es <> [ EventStreamWarning{eswStreamLabel = label, eswReason = renderWarning w} | w <- validateTransducer (forceReplayContract opts) (transducer es) @@ -170,9 +177,10 @@ <> show warns {- | Wrap an 'EventStream' /without validation/. This skips every keiki and -keiro check, including the replay-contract checks that 'mkEventStream' -force-enables. A stream admitted through this function can silently lose state -changes and fail hydration. Tests and emergency forensics only; never use it +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 :: @@ -180,7 +188,45 @@ ValidatedEventStream phi rs s ci co mkEventStreamUnchecked = ValidatedEventStream -{- | Render a keiki warning to a human-readable reason. All eight constructors +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 + } + ] + +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 + 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). -} @@ -202,6 +248,57 @@ "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