keiro-dsl-0.18.0.0: test/conformance-checked-mapping-replay/Generated/CheckedMappingReplay/ReplayLedger/Codec.hs
-- @generated by keiro-dsl 0.18.0.0 (language keiro-dsl 6) from aggregate ReplayLedger; do not edit.
module Generated.CheckedMappingReplay.ReplayLedger.Codec (
replayLedgerCodec,
parseReplayLedgerEvent,
encodeReplayLedgerEvent,
encodeContentHashMapped,
decodeContentHashMapped,
encodeImportantDaysMapped,
decodeImportantDaysMapped,
encodeMaybeContentHashMapped,
decodeMaybeContentHashMapped,
encodeMaybeLabelMapped,
decodeMaybeLabelMapped,
encodeReplayEnvelopeMapped,
decodeReplayEnvelopeMapped,
encodeTextLabelsMapped,
decodeTextLabelsMapped,
) where
import Generated.CheckedMappingReplay.ReplayLedger.Domain
import Generated.CheckedMappingReplay.Nominals (retainedIdText)
import Generated.CheckedMappingReplay.Nominals.Internal (unsafeRetainedIdFromLegacyText)
import Control.Monad (unless)
import Data.Aeson (Value (..), object, parseJSON, toJSON, withObject, (.:), (.=))
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Aeson.Types (Parser, JSONPathElement (..), (<?>), explicitParseField, parseEither)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import qualified Data.Text as T
import Keiro.Codec.CalendarDay (encodeCalendarDay, parseCalendarDay)
import Keiro.Codec.TextSet (encodeTextSet, parseTextSet)
import Keiro.Codec.Base16Bytes (encodeBase16Bytes, parseBase16Bytes)
import Keiro.Codec.Structural (bindingFromShape, bindingToShape)
import Keiro.Codec (Codec (..), EventType (..))
import Generated.CheckedMappingReplay.Structural.NominalLeaves (encodeRetainedIdLeaf, parseRetainedIdLeaf)
import Generated.CheckedMappingReplay.Structural.NominalLeaves (parseRetainedIdLeafKey, renderRetainedIdLeafKey)
import Conformance.CheckedMappingReplay.Bindings qualified as Bindings
import Conformance.CheckedMappingReplay.Domain (ContentHash, ImportantDays, MaybeContentHash, MaybeLabel, ReplayEnvelope, TextLabels)
import Generated.CheckedMappingReplay.Structural.Shape.ContentHash qualified as ShapeContentHash
import Generated.CheckedMappingReplay.Structural.Shape.ImportantDays qualified as ShapeImportantDays
import Generated.CheckedMappingReplay.Structural.Shape.MaybeContentHash qualified as ShapeMaybeContentHash
import Generated.CheckedMappingReplay.Structural.Shape.MaybeLabel qualified as ShapeMaybeLabel
import Generated.CheckedMappingReplay.Structural.Shape.ReplayEnvelope qualified as ShapeReplayEnvelope
import Generated.CheckedMappingReplay.Structural.Shape.TextLabels qualified as ShapeTextLabels
encodeContentHashMapped :: ContentHash -> Value
encodeContentHashMapped = encodeContentHashShape . bindingToShape Bindings.contentHashBinding
parseContentHashMapped :: Value -> Parser ContentHash
parseContentHashMapped value = bindingFromShape Bindings.contentHashBinding <$> parseContentHashShape value
decodeContentHashMapped :: Value -> Either Text ContentHash
decodeContentHashMapped = mapLeftText . parseEither parseContentHashMapped
encodeContentHashShape :: ShapeContentHash.ContentHashShape -> Value
encodeContentHashShape = encodeBase16Bytes
parseContentHashShape :: Value -> Parser ShapeContentHash.ContentHashShape
parseContentHashShape = parseBase16Bytes
encodeImportantDaysMapped :: ImportantDays -> Value
encodeImportantDaysMapped = encodeImportantDaysShape . bindingToShape Bindings.importantDaysBinding
parseImportantDaysMapped :: Value -> Parser ImportantDays
parseImportantDaysMapped value = bindingFromShape Bindings.importantDaysBinding <$> parseImportantDaysShape value
decodeImportantDaysMapped :: Value -> Either Text ImportantDays
decodeImportantDaysMapped = mapLeftText . parseEither parseImportantDaysMapped
encodeImportantDaysShape :: ShapeImportantDays.ImportantDaysShape -> Value
encodeImportantDaysShape value = toJSON (map (\item0 -> encodeCalendarDay (item0)) (value))
parseImportantDaysShape :: Value -> Parser ShapeImportantDays.ImportantDaysShape
parseImportantDaysShape = \value0 -> do items0 <- (parseJSON value0 :: Parser [Value]); traverse (\(index0, item0) -> (parseCalendarDay) item0 <?> Index index0) (zip [0..] items0)
encodeMaybeContentHashMapped :: MaybeContentHash -> Value
encodeMaybeContentHashMapped = encodeMaybeContentHashShape . bindingToShape Bindings.maybeContentHashBinding
parseMaybeContentHashMapped :: Value -> Parser MaybeContentHash
parseMaybeContentHashMapped value = bindingFromShape Bindings.maybeContentHashBinding <$> parseMaybeContentHashShape value
decodeMaybeContentHashMapped :: Value -> Either Text MaybeContentHash
decodeMaybeContentHashMapped = mapLeftText . parseEither parseMaybeContentHashMapped
encodeMaybeContentHashShape :: ShapeMaybeContentHash.MaybeContentHashShape -> Value
encodeMaybeContentHashShape value = maybe Null (\item0 -> encodeContentHashShape (item0)) (value)
parseMaybeContentHashShape :: Value -> Parser ShapeMaybeContentHash.MaybeContentHashShape
parseMaybeContentHashShape = \value0 -> case value0 of Null -> pure Nothing; other0 -> Just <$> (parseContentHashShape) other0
encodeMaybeLabelMapped :: MaybeLabel -> Value
encodeMaybeLabelMapped = encodeMaybeLabelShape . bindingToShape Bindings.maybeLabelBinding
parseMaybeLabelMapped :: Value -> Parser MaybeLabel
parseMaybeLabelMapped value = bindingFromShape Bindings.maybeLabelBinding <$> parseMaybeLabelShape value
decodeMaybeLabelMapped :: Value -> Either Text MaybeLabel
decodeMaybeLabelMapped = mapLeftText . parseEither parseMaybeLabelMapped
encodeMaybeLabelShape :: ShapeMaybeLabel.MaybeLabelShape -> Value
encodeMaybeLabelShape value = maybe Null (\item0 -> toJSON (item0)) (value)
parseMaybeLabelShape :: Value -> Parser ShapeMaybeLabel.MaybeLabelShape
parseMaybeLabelShape = \value0 -> case value0 of Null -> pure Nothing; other0 -> Just <$> (parseJSON) other0
encodeReplayEnvelopeMapped :: ReplayEnvelope -> Value
encodeReplayEnvelopeMapped = encodeReplayEnvelopeShape . bindingToShape Bindings.replayEnvelopeBinding
parseReplayEnvelopeMapped :: Value -> Parser ReplayEnvelope
parseReplayEnvelopeMapped value = bindingFromShape Bindings.replayEnvelopeBinding <$> parseReplayEnvelopeShape value
decodeReplayEnvelopeMapped :: Value -> Either Text ReplayEnvelope
decodeReplayEnvelopeMapped = mapLeftText . parseEither parseReplayEnvelopeMapped
encodeReplayEnvelopeShape :: ShapeReplayEnvelope.ReplayEnvelopeShape -> Value
encodeReplayEnvelopeShape shape =
object
[ "label" .= encodeMaybeLabelShape (shape.label)
, "days" .= encodeImportantDaysShape (shape.days)
, "labels" .= encodeTextLabelsShape (shape.labels)
, "contentHash" .= encodeMaybeContentHashShape (shape.contentHash)
, "primary" .= encodeRetainedIdLeaf shape.primary
, "identities" .= Object (KeyMap.fromList [(Key.fromText (renderRetainedIdLeafKey key0), toJSON (item0)) | (key0, item0) <- Map.toList (shape.identities)])
, "optionalLabels" .= maybe Null (\item0 -> encodeTextSet (item0)) (shape.optionalLabels)
]
parseReplayEnvelopeShape :: Value -> Parser ShapeReplayEnvelope.ReplayEnvelopeShape
parseReplayEnvelopeShape = withObject "ReplayEnvelopeShape" $ \objectValue -> do
rejectUnknownFields "ReplayEnvelope" ["label", "days", "labels", "contentHash", "primary", "identities", "optionalLabels"] objectValue
ShapeReplayEnvelope.ReplayEnvelope
<$> explicitParseField (parseMaybeLabelShape) objectValue "label"
<*> explicitParseField (parseImportantDaysShape) objectValue "days"
<*> explicitParseField (parseTextLabelsShape) objectValue "labels"
<*> explicitParseField (parseMaybeContentHashShape) objectValue "contentHash"
<*> explicitParseField (parseRetainedIdLeaf) objectValue "primary"
<*> explicitParseField (\value0 -> withObject "Map[RetainedId]" (\object0 -> Map.fromList <$> traverse (\(rawKey0, item0) -> do key0 <- parseRetainedIdLeafKey (Key.toText rawKey0) <?> Key rawKey0; parsedItem0 <- (parseJSON) item0 <?> Key rawKey0; pure (key0, parsedItem0)) (KeyMap.toList object0)) value0) objectValue "identities"
<*> parseOptionalField (pure Nothing) (\value0 -> case value0 of Null -> pure Nothing; other0 -> Just <$> (parseTextSet) other0) objectValue "optionalLabels"
encodeTextLabelsMapped :: TextLabels -> Value
encodeTextLabelsMapped = encodeTextLabelsShape . bindingToShape Bindings.textLabelsBinding
parseTextLabelsMapped :: Value -> Parser TextLabels
parseTextLabelsMapped value = bindingFromShape Bindings.textLabelsBinding <$> parseTextLabelsShape value
decodeTextLabelsMapped :: Value -> Either Text TextLabels
decodeTextLabelsMapped = mapLeftText . parseEither parseTextLabelsMapped
encodeTextLabelsShape :: ShapeTextLabels.TextLabelsShape -> Value
encodeTextLabelsShape value = encodeTextSet (value)
parseTextLabelsShape :: Value -> Parser ShapeTextLabels.TextLabelsShape
parseTextLabelsShape = parseTextSet
replayLedgerEventTypes :: NonEmpty EventType
replayLedgerEventTypes = EventType "MappingRecorded" :| [EventType "MappingAudited", EventType "LegacyMappingImported"]
replayLedgerCodec :: Codec ReplayLedgerEvent
replayLedgerCodec =
Codec
{ eventTypes = replayLedgerEventTypes
, eventType = \case
MappingRecorded{} -> EventType "MappingRecorded"
MappingAudited{} -> EventType "MappingAudited"
LegacyMappingImported{} -> EventType "LegacyMappingImported"
, schemaVersion = 1
, encode = encodeReplayLedgerEvent
, decode = parseReplayLedgerEvent
, upcasters = []
}
encodeReplayLedgerEvent :: ReplayLedgerEvent -> Value
encodeReplayLedgerEvent = \case
MappingRecorded payload ->
object
[ "kind" .= ("MappingRecorded" :: Text)
, "retainedId" .= retainedIdText payload.retainedId
, "envelope" .= encodeReplayEnvelopeMapped payload.envelope
]
MappingAudited payload ->
object
[ "kind" .= ("MappingAudited" :: Text)
, "retainedId" .= retainedIdText payload.retainedId
, "envelope" .= encodeReplayEnvelopeMapped payload.envelope
]
LegacyMappingImported payload ->
object
[ "kind" .= ("LegacyMappingImported" :: Text)
, "retainedId" .= retainedIdText payload.retainedId
, "envelope" .= encodeReplayEnvelopeMapped payload.envelope
]
parseReplayLedgerEvent :: EventType -> Value -> Either Text ReplayLedgerEvent
parseReplayLedgerEvent (EventType tag) = mapLeftText . parseEither (withObject "ReplayLedgerEvent" go)
where
go o = do
case tag of
"MappingRecorded" ->
MappingRecorded
<$> ( MappingRecordedData
<$> (unsafeRetainedIdFromLegacyText <$> o .: "retainedId")
<*> explicitParseField parseReplayEnvelopeMapped o "envelope"
)
"MappingAudited" ->
MappingAudited
<$> ( MappingAuditedData
<$> (unsafeRetainedIdFromLegacyText <$> o .: "retainedId")
<*> explicitParseField parseReplayEnvelopeMapped o "envelope"
)
"LegacyMappingImported" ->
LegacyMappingImported
<$> ( LegacyMappingImportedData
<$> (unsafeRetainedIdFromLegacyText <$> o .: "retainedId")
<*> explicitParseField parseReplayEnvelopeMapped o "envelope"
)
_ -> fail ("unknown event type " <> show tag <> "; expected one of: " <> renderExpectedEventTypes replayLedgerEventTypes)
mapLeftText :: Either String b -> Either Text b
mapLeftText = either (Left . T.pack) Right
renderExpectedEventTypes :: NonEmpty EventType -> String
renderExpectedEventTypes =
T.unpack
. T.intercalate ", "
. map (\(EventType eventTypeName) -> eventTypeName)
. NonEmpty.toList
parseOptionalField :: Parser fieldValue -> (Value -> Parser fieldValue) -> KeyMap.KeyMap Value -> Key.Key -> Parser fieldValue
parseOptionalField onMissing parseItem objectValue key =
case KeyMap.lookup key objectValue of
Nothing -> onMissing
Just _ -> explicitParseField parseItem objectValue key
rejectUnknownFields :: String -> [Text] -> KeyMap.KeyMap Value -> Parser ()
rejectUnknownFields label allowed objectValue =
unless (null extras) (fail (label <> " contains unknown fields: " <> show extras))
where
extras = filter (`notElem` allowed) (map Key.toText (KeyMap.keys objectValue))