Harness.hs

{-# LANGUAGE OverloadedLabels #-}
-- @generated by keiro-dsl 0.18.0.0 (language keiro-dsl 6) from aggregate HashStore; do not edit.
module Generated.RefinedBase16.HashStore.Harness (harnessAssertions) where

import Generated.RefinedBase16.HashStore.Domain
import Generated.RefinedBase16.HashStore.Codec (encodeHashStoreEvent, parseHashStoreEvent, hashStoreCodec, encodeHashEnvelopeMapped, decodeHashEnvelopeMapped)
import Generated.RefinedBase16.HashStore.Transducer (hashStoreTransducer)
import Keiki.Core (applyEventsEither, defaultValidationOptions, step, validateTransducer, (!))
import Keiro.Codec (eventType)
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 Conformance.RefinedBase16.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 hashStoreTransducer))
  -- clock-free: spec samples no wall clock (verified at scaffold time)
  , ("golden round-trip: HashStored", roundTrips sampleEventHashStored)
  , ("golden round-trip: HashAudited", roundTrips sampleEventHashAudited)
  , ("golden round-trip: LegacyHashImported", roundTrips sampleEventLegacyHashImported)
  , ("accepts StoreHash from HashStoreEmpty", acceptStoreHash)
  ]
  ++ mappedConformanceAssertions
  ++ forwardReplayStoreHash

roundTrips :: HashStoreEvent -> Bool
roundTrips e = parseHashStoreEvent (eventType hashStoreCodec e) (encodeHashStoreEvent e) == Right e

sampleEventHashStored :: HashStoreEvent
sampleEventHashStored = HashStored (HashStoredData (snd (NonEmpty.head (fixtureCases Bindings.contentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeContentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures))))

sampleEventHashAudited :: HashStoreEvent
sampleEventHashAudited = HashAudited (HashAuditedData (snd (NonEmpty.head (fixtureCases Bindings.contentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeContentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures))))

sampleEventLegacyHashImported :: HashStoreEvent
sampleEventLegacyHashImported = LegacyHashImported (LegacyHashImportedData (snd (NonEmpty.head (fixtureCases Bindings.contentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeContentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures))))

acceptStoreHash :: Bool
acceptStoreHash =
  case step hashStoreTransducer (HashStoreEmpty, initialHashStoreRegs) (StoreHash (StoreHashData (snd (NonEmpty.head (fixtureCases Bindings.contentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeContentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures))))) of
    Just (v, _, _) -> v == HashStoreStored
    Nothing -> False

-- forward/replay equality (plan 147): cross the persisted codec boundary,
-- replay the emitted chain, and compare the final vertex and every register.
forwardReplayStoreHash :: [(String, Bool)]
forwardReplayStoreHash =
  case step hashStoreTransducer (HashStoreEmpty, initialHashStoreRegs) (StoreHash (StoreHashData (snd (NonEmpty.head (fixtureCases Bindings.contentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeContentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures))))) of
    Nothing -> [(prefix <> "forward step accepted", False)]
    Just (forwardVertex, forwardRegs, emitted) ->
      case mapM (\event -> parseHashStoreEvent (eventType hashStoreCodec event) (encodeHashStoreEvent event)) emitted of
        Left _ -> [(prefix <> "emitted chain decodes", False)]
        Right decodedEvents ->
          case applyEventsEither hashStoreTransducer (HashStoreEmpty, initialHashStoreRegs) decodedEvents of
            Left _ -> [(prefix <> "replay succeeds", False)]
            Right (replayVertex, replayRegs) ->
              [ (prefix <> "final vertex", replayVertex == forwardVertex)
              , (prefix <> "register current", (replayRegs ! #current) == (forwardRegs ! #current))
              ]
  where
    prefix = "forward/replay equality: StoreHash from HashStoreEmpty -- "

mappedConformanceAssertions :: [(String, Bool)]
mappedConformanceAssertions =
  concat
    [ hashStoredHashAssertions
    , hashStoredOptionalHashAssertions
    , hashStoredEnvelopeAssertions
    , hashAuditedHashAssertions
    , hashAuditedOptionalHashAssertions
    , hashAuditedEnvelopeAssertions
    , legacyHashImportedHashAssertions
    , legacyHashImportedOptionalHashAssertions
    , legacyHashImportedEnvelopeAssertions
    , structuralWirePolicyAssertions
    ]

hashStoredHashAssertions :: [(String, Bool)]
hashStoredHashAssertions =
  [ ("mapped codec round-trip: HashStored/hash/" <> T.unpack label, roundTrips (HashStored (HashStoredData mappedValue (snd (NonEmpty.head (fixtureCases Bindings.maybeContentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.contentHashFixtures)
  ]

hashStoredOptionalHashAssertions :: [(String, Bool)]
hashStoredOptionalHashAssertions =
  [ ("mapped codec round-trip: HashStored/optionalHash/" <> T.unpack label, roundTrips (HashStored (HashStoredData (snd (NonEmpty.head (fixtureCases Bindings.contentHashFixtures))) mappedValue (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.maybeContentHashFixtures)
  ]

hashStoredEnvelopeAssertions :: [(String, Bool)]
hashStoredEnvelopeAssertions =
  [ ("mapped codec round-trip: HashStored/envelope/" <> T.unpack label, roundTrips (HashStored (HashStoredData (snd (NonEmpty.head (fixtureCases Bindings.contentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeContentHashFixtures))) mappedValue)))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.hashEnvelopeFixtures)
  ]

hashAuditedHashAssertions :: [(String, Bool)]
hashAuditedHashAssertions =
  [ ("mapped codec round-trip: HashAudited/hash/" <> T.unpack label, roundTrips (HashAudited (HashAuditedData mappedValue (snd (NonEmpty.head (fixtureCases Bindings.maybeContentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.contentHashFixtures)
  ]

hashAuditedOptionalHashAssertions :: [(String, Bool)]
hashAuditedOptionalHashAssertions =
  [ ("mapped codec round-trip: HashAudited/optionalHash/" <> T.unpack label, roundTrips (HashAudited (HashAuditedData (snd (NonEmpty.head (fixtureCases Bindings.contentHashFixtures))) mappedValue (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.maybeContentHashFixtures)
  ]

hashAuditedEnvelopeAssertions :: [(String, Bool)]
hashAuditedEnvelopeAssertions =
  [ ("mapped codec round-trip: HashAudited/envelope/" <> T.unpack label, roundTrips (HashAudited (HashAuditedData (snd (NonEmpty.head (fixtureCases Bindings.contentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeContentHashFixtures))) mappedValue)))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.hashEnvelopeFixtures)
  ]

legacyHashImportedHashAssertions :: [(String, Bool)]
legacyHashImportedHashAssertions =
  [ ("mapped codec round-trip: LegacyHashImported/hash/" <> T.unpack label, roundTrips (LegacyHashImported (LegacyHashImportedData mappedValue (snd (NonEmpty.head (fixtureCases Bindings.maybeContentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.contentHashFixtures)
  ]

legacyHashImportedOptionalHashAssertions :: [(String, Bool)]
legacyHashImportedOptionalHashAssertions =
  [ ("mapped codec round-trip: LegacyHashImported/optionalHash/" <> T.unpack label, roundTrips (LegacyHashImported (LegacyHashImportedData (snd (NonEmpty.head (fixtureCases Bindings.contentHashFixtures))) mappedValue (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures))))))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.maybeContentHashFixtures)
  ]

legacyHashImportedEnvelopeAssertions :: [(String, Bool)]
legacyHashImportedEnvelopeAssertions =
  [ ("mapped codec round-trip: LegacyHashImported/envelope/" <> T.unpack label, roundTrips (LegacyHashImported (LegacyHashImportedData (snd (NonEmpty.head (fixtureCases Bindings.contentHashFixtures))) (snd (NonEmpty.head (fixtureCases Bindings.maybeContentHashFixtures))) mappedValue)))
  | (label, mappedValue) <- NonEmpty.toList (fixtureCases Bindings.hashEnvelopeFixtures)
  ]

structuralWirePolicyAssertions :: [(String, Bool)]
structuralWirePolicyAssertions =
  [ ("wire policy missing default: conformance.refined-base16.HashEnvelope.v1/optionalHash", case decodeHashEnvelopeMapped (deleteObjectField "optionalHash" (encodeHashEnvelopeMapped (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures))))) of Left _ -> False; Right decoded -> objectField "optionalHash" (encodeHashEnvelopeMapped decoded) == Just (Aeson.Null))
  , ("wire policy explicit null: conformance.refined-base16.HashEnvelope.v1/optionalHash", isRight (decodeHashEnvelopeMapped (insertObjectField "optionalHash" Aeson.Null (encodeHashEnvelopeMapped (snd (NonEmpty.head (fixtureCases Bindings.hashEnvelopeFixtures)))))))
  , ("wire policy unknown fields: conformance.refined-base16.HashEnvelope.v1", all (\(_, value) -> isLeft (decodeHashEnvelopeMapped (insertObjectField "__keiro_unknown" (Aeson.Bool True) (encodeHashEnvelopeMapped value)))) (NonEmpty.toList (fixtureCases Bindings.hashEnvelopeFixtures)))
  ]

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