Harness.hs

{-# LANGUAGE OverloadedLabels #-}
-- @generated by keiro-dsl 0.12.0.0 (language keiro-dsl 4) from aggregate Journey; do not edit.
module Generated.BehaviorComplete.Journey.Harness (harnessAssertions) where

import Generated.BehaviorComplete.Journey.Domain
import Generated.BehaviorComplete.Journey.Codec (encodeJourneyEvent, parseJourneyEvent, journeyCodec, encodeStartPayloadMapped, decodeStartPayloadMapped)
import Generated.BehaviorComplete.Journey.Transducer (journeyTransducer)
import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!))
import Keiro.Codec (eventType)
import Generated.BehaviorComplete.Nominals (RequestId, parseRequestId)
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as AesonKey
import Data.Aeson.KeyMap qualified as AesonKeyMap
import Data.Either (isLeft, isRight)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text qualified as T
import Keiro.Codec.Structural (FixtureCases (..))
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock (UTCTime (..), picosecondsToDiffTime)
import BehaviorComplete.Bindings qualified as Bindings

-- | (label, passed). A driver runs these and exits non-zero on any False,
-- naming the failing assertion. Filling a hole wrongly turns a specific
-- entry False; the scaffold cannot.
harnessAssertions :: [(String, Bool)]
harnessAssertions =
  [ ("validateTransducer is empty", null (validateTransducer defaultValidationOptions journeyTransducer))
  -- clock-free: spec samples no wall clock (verified at scaffold time)
  , ("golden round-trip: Started", roundTrips sampleEventStarted)
  , ("golden round-trip: DecisionRecorded", roundTrips sampleEventDecisionRecorded)
  , ("golden round-trip: Retired", roundTrips sampleEventRetired)
  , ("golden round-trip: RetirementAudited", roundTrips sampleEventRetirementAudited)
  , ("golden round-trip: LegacyStarted", roundTrips sampleEventLegacyStarted)
  , ("accepts Start from JourneyEmpty", acceptStart)
  ]
  ++ mappedConformanceAssertions
  ++ forwardReplayStart

roundTrips :: JourneyEvent -> Bool
roundTrips e = parseJourneyEvent (eventType journeyCodec e) (encodeJourneyEvent e) == Right e

sampleRequestId :: RequestId
sampleRequestId =
  case parseRequestId "req_01h455vb4pex5vsknk084sn02q" of
    Right parsed -> parsed
    Left problem -> error (show problem)

sampleObservedAt :: UTCTime
sampleObservedAt = UTCTime (fromGregorian 2026 1 2) (picosecondsToDiffTime 11045123456789012)

sampleEventStarted :: JourneyEvent
sampleEventStarted = Started (StartedData sampleRequestId sampleObservedAt 0 (snd (NonEmpty.head (fixtureCases Bindings.startPayloadCases))))

sampleEventDecisionRecorded :: JourneyEvent
sampleEventDecisionRecorded = DecisionRecorded (DecisionRecordedData 0)

sampleEventRetired :: JourneyEvent
sampleEventRetired = Retired (RetiredData 0)

sampleEventRetirementAudited :: JourneyEvent
sampleEventRetirementAudited = RetirementAudited (RetirementAuditedData 0)

sampleEventLegacyStarted :: JourneyEvent
sampleEventLegacyStarted = LegacyStarted (LegacyStartedData 0)

acceptStart :: Bool
acceptStart =
  case step journeyTransducer (JourneyEmpty, initialJourneyRegs) (Start (StartData sampleRequestId sampleObservedAt 0 (snd (NonEmpty.head (fixtureCases Bindings.startPayloadCases))))) of
    Just (v, _, _) -> v == JourneyActive
    Nothing -> False

-- forward/replay equality (plan 147): cross the persisted codec boundary,
-- replay the emitted chain, and compare the final vertex and every register.
forwardReplayStart :: [(String, Bool)]
forwardReplayStart =
  case step journeyTransducer (JourneyEmpty, initialJourneyRegs) (Start (StartData sampleRequestId sampleObservedAt 0 (snd (NonEmpty.head (fixtureCases Bindings.startPayloadCases))))) of
    Nothing -> [(prefix <> "forward step accepted", False)]
    Just (forwardVertex, forwardRegs, emitted) ->
      case mapM (\event -> parseJourneyEvent (eventType journeyCodec event) (encodeJourneyEvent event)) emitted of
        Left _ -> [(prefix <> "emitted chain decodes", False)]
        Right decodedEvents ->
          case applyEventsEither journeyTransducer (JourneyEmpty, initialJourneyRegs) decodedEvents of
            Left _ -> [(prefix <> "replay succeeds", False)]
            Right (replayVertex, replayRegs) ->
              [ (prefix <> "final vertex", replayVertex == forwardVertex)
              , (prefix <> "register lastAmount", (replayRegs ! #lastAmount) == (forwardRegs ! #lastAmount))
              ]
  where
    prefix = "forward/replay equality: Start from JourneyEmpty -- "

mappedConformanceAssertions :: [(String, Bool)]
mappedConformanceAssertions =
  concat
    [ startedDetailsAssertions
    , structuralWirePolicyAssertions
    ]

startedDetailsAssertions :: [(String, Bool)]
startedDetailsAssertions =
  [ ("mapped codec round-trip: Started/details/" <> T.unpack label, roundTrips (Started (StartedData sampleRequestId sampleObservedAt 0 mappedValue)))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.startPayloadCases)
  ]

structuralWirePolicyAssertions :: [(String, Bool)]
structuralWirePolicyAssertions =
  [ ("wire policy missing default: behavior-complete.StartPayload.v1/optional_note", case decodeStartPayloadMapped (deleteObjectField "optional_note" (encodeStartPayloadMapped (snd (NonEmpty.head (fixtureCases Bindings.startPayloadCases))))) of Left _ -> False; Right decoded -> objectField "optional_note" (encodeStartPayloadMapped decoded) == Just (Aeson.Null))
  , ("wire policy explicit null: behavior-complete.StartPayload.v1/optional_note", isRight (decodeStartPayloadMapped (insertObjectField "optional_note" Aeson.Null (encodeStartPayloadMapped (snd (NonEmpty.head (fixtureCases Bindings.startPayloadCases)))))))
  , ("wire policy unknown fields: behavior-complete.StartPayload.v1", all (\(_, value) -> isLeft (decodeStartPayloadMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeStartPayloadMapped value)))) (NonEmpty.toList (fixtureCases Bindings.startPayloadCases)))
  ]

deleteObjectField :: T.Text -> Aeson.Value -> Aeson.Value
deleteObjectField key (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.delete (AesonKey.fromText key) objectValue)
deleteObjectField _ value = value

insertObjectField :: T.Text -> Aeson.Value -> Aeson.Value -> Aeson.Value
insertObjectField key inserted (Aeson.Object objectValue) = Aeson.Object (AesonKeyMap.insert (AesonKey.fromText key) inserted objectValue)
insertObjectField _ _ value = value

objectField :: T.Text -> Aeson.Value -> Maybe Aeson.Value
objectField key (Aeson.Object objectValue) = AesonKeyMap.lookup (AesonKey.fromText key) objectValue
objectField _ _ = Nothing