keiro-dsl-0.17.0.0: test/conformance-structural-nominals/Generated/StructuralNominalLeaves/TemplateCatalog/Codec.hs
-- @generated by keiro-dsl 0.17.0.0 (language keiro-dsl 6) from aggregate TemplateCatalog; do not edit.
module Generated.StructuralNominalLeaves.TemplateCatalog.Codec (
templateCatalogCodec,
parseTemplateCatalogEvent,
encodeTemplateCatalogEvent,
encodeTemplateBookMapped,
decodeTemplateBookMapped,
encodeTemplateRefMapped,
decodeTemplateRefMapped,
encodeTemplateStateMapped,
decodeTemplateStateMapped,
) where
import Generated.StructuralNominalLeaves.TemplateCatalog.Domain
import Generated.StructuralNominalLeaves.Nominals (templateIdText)
import Generated.StructuralNominalLeaves.Nominals.Internal (unsafeTemplateIdFromLegacyText)
import Control.Monad (unless)
import Data.Aeson (Value (..), object, parseJSON, toJSON, withObject, withText, (.:), (.=))
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 (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import qualified Data.Text as T
import Data.KindID qualified as KindID
import Keiro.Codec.IdDomain (typeIdV7Domain, validateIdDomainText)
import Keiro.Codec.Nominal (nominalFromRepresentation, nominalToRepresentation)
import Keiro.Codec.Structural (bindingFromShape, bindingToShape)
import Keiro.Codec (Codec (..), EventType (..))
import Generated.StructuralNominalLeaves.Structural.NominalLeaves (encodeAccountNumberLeaf, parseAccountNumberLeaf, encodeChannelLeaf, parseChannelLeaf, encodeClaimIdLeaf, parseClaimIdLeaf, encodeTemplateIdLeaf, parseTemplateIdLeaf, encodeTemplateKindLeaf, parseTemplateKindLeaf)
import Generated.StructuralNominalLeaves.Structural.NominalLeaves (parseClaimIdLeafKey, renderClaimIdLeafKey, parseTemplateIdLeafKey, renderTemplateIdLeafKey)
import Conformance.StructuralNominals.Bindings qualified as Bindings
import Conformance.StructuralNominals.Domain (ClaimId, TemplateBook, TemplateRef, TemplateState)
import Generated.StructuralNominalLeaves.Nominal.Shape.Channel qualified as Channel
import Generated.StructuralNominalLeaves.Nominals qualified as Nominals
import Generated.StructuralNominalLeaves.Structural.Shape.TemplateBook qualified as ShapeTemplateBook
import Generated.StructuralNominalLeaves.Structural.Shape.TemplateRef qualified as ShapeTemplateRef
import Generated.StructuralNominalLeaves.Structural.Shape.TemplateState qualified as ShapeTemplateState
parseClaimIdNominal :: Text -> Parser ClaimId
parseClaimIdNominal input = case validateIdDomainText (typeIdV7Domain "claim") input of
Left reason -> fail (show reason)
Right () -> case KindID.parseText @"claim" input of
Left reason -> fail (show reason)
Right representation -> pure (nominalFromRepresentation Bindings.claimIdBinding representation)
encodeTemplateBookMapped :: TemplateBook -> Value
encodeTemplateBookMapped = encodeTemplateBookShape . bindingToShape Bindings.templateBookBinding
parseTemplateBookMapped :: Value -> Parser TemplateBook
parseTemplateBookMapped value = bindingFromShape Bindings.templateBookBinding <$> parseTemplateBookShape value
decodeTemplateBookMapped :: Value -> Either Text TemplateBook
decodeTemplateBookMapped = mapLeftText . parseEither parseTemplateBookMapped
encodeTemplateBookShape :: ShapeTemplateBook.TemplateBookShape -> Value
encodeTemplateBookShape shape =
object
[ "templates" .= toJSON (map (\item0 -> encodeTemplateStateShape (item0)) (shape.templates))
, "holders" .= toJSON (map (\item0 -> maybe Null (\item1 -> encodeClaimIdLeaf item1) (item0)) (shape.holders))
, "byKey" .= toJSON (Map.map (\item0 -> encodeTemplateIdLeaf item0) (shape.byKey))
, "by_template" .= Object (KeyMap.fromList [(Key.fromText (renderTemplateIdLeafKey key0), toJSON (item0)) | (key0, item0) <- Map.toList (shape.byTemplate)])
, "claims" .= Object (KeyMap.fromList [(Key.fromText (renderClaimIdLeafKey key0), encodeTemplateStateShape (item0)) | (key0, item0) <- Map.toList (shape.claims)])
]
parseTemplateBookShape :: Value -> Parser ShapeTemplateBook.TemplateBookShape
parseTemplateBookShape = withObject "TemplateBookShape" $ \objectValue -> do
rejectUnknownFields "TemplateBook" ["templates", "holders", "byKey", "by_template", "claims"] objectValue
ShapeTemplateBook.TemplateBook
<$> explicitParseField (\value0 -> do items0 <- (parseJSON value0 :: Parser [Value]); traverse (\(index0, item0) -> (parseTemplateStateShape) item0 <?> Index index0) (zip [0..] items0)) objectValue "templates"
<*> explicitParseField (\value0 -> do items0 <- (parseJSON value0 :: Parser [Value]); traverse (\(index0, item0) -> (\value1 -> case value1 of Null -> pure Nothing; other1 -> Just <$> (parseClaimIdLeaf) other1) item0 <?> Index index0) (zip [0..] items0)) objectValue "holders"
<*> explicitParseField (\value0 -> do items0 <- (parseJSON value0 :: Parser (Map Text Value)); Map.traverseWithKey (\key0 item0 -> (parseTemplateIdLeaf) item0 <?> Key (Key.fromText key0)) items0) objectValue "byKey"
<*> explicitParseField (\value0 -> withObject "Map[TemplateId]" (\object0 -> Map.fromList <$> traverse (\(rawKey0, item0) -> do key0 <- parseTemplateIdLeafKey (Key.toText rawKey0) <?> Key rawKey0; parsedItem0 <- (parseJSON) item0 <?> Key rawKey0; pure (key0, parsedItem0)) (KeyMap.toList object0)) value0) objectValue "by_template"
<*> parseOptionalField (pure Map.empty) (\value0 -> withObject "Map[ClaimId]" (\object0 -> Map.fromList <$> traverse (\(rawKey0, item0) -> do key0 <- parseClaimIdLeafKey (Key.toText rawKey0) <?> Key rawKey0; parsedItem0 <- (parseTemplateStateShape) item0 <?> Key rawKey0; pure (key0, parsedItem0)) (KeyMap.toList object0)) value0) objectValue "claims"
encodeTemplateRefMapped :: TemplateRef -> Value
encodeTemplateRefMapped = encodeTemplateRefShape . bindingToShape Bindings.templateRefBinding
parseTemplateRefMapped :: Value -> Parser TemplateRef
parseTemplateRefMapped value = bindingFromShape Bindings.templateRefBinding <$> parseTemplateRefShape value
decodeTemplateRefMapped :: Value -> Either Text TemplateRef
decodeTemplateRefMapped = mapLeftText . parseEither parseTemplateRefMapped
encodeTemplateRefShape :: ShapeTemplateRef.TemplateRefShape -> Value
encodeTemplateRefShape = \case
ShapeTemplateRef.ById payload ->
object
[ "tag" .= ("by_id" :: Text)
, "contents" .= encodeTemplateIdLeaf payload
]
ShapeTemplateRef.ByAccount payload ->
object
[ "tag" .= ("by_account" :: Text)
, "contents" .= encodeAccountNumberLeaf payload
]
ShapeTemplateRef.ByChannel payload ->
object
[ "tag" .= ("by_channel" :: Text)
, "contents" .= encodeChannelLeaf payload
]
ShapeTemplateRef.Unknown ->
object
[ "tag" .= ("unknown" :: Text)
]
parseTemplateRefShape :: Value -> Parser ShapeTemplateRef.TemplateRefShape
parseTemplateRefShape = withObject "TemplateRefShape" $ \objectValue -> do
tag <- explicitParseField (withText "TemplateRef tag" validateTemplateRefTag) objectValue "tag"
case tag of
"by_id" -> do
rejectUnknownFields "TemplateRef" ["tag", "contents"] objectValue
ShapeTemplateRef.ById <$> explicitParseField (parseTemplateIdLeaf) objectValue "contents"
"by_account" -> do
rejectUnknownFields "TemplateRef" ["tag", "contents"] objectValue
ShapeTemplateRef.ByAccount <$> explicitParseField (parseAccountNumberLeaf) objectValue "contents"
"by_channel" -> do
rejectUnknownFields "TemplateRef" ["tag", "contents"] objectValue
ShapeTemplateRef.ByChannel <$> explicitParseField (parseChannelLeaf) objectValue "contents"
"unknown" -> do
rejectUnknownFields "TemplateRef" ["tag"] objectValue
pure ShapeTemplateRef.Unknown
_ -> fail "validated union tag was not handled"
validateTemplateRefTag :: Text -> Parser Text
validateTemplateRefTag tag
| tag `elem` ["by_id", "by_account", "by_channel", "unknown"] = pure tag
| otherwise = fail ("unknown TemplateRef union tag " <> show tag <> "; expected one of: by_id, by_account, by_channel, unknown")
encodeTemplateStateMapped :: TemplateState -> Value
encodeTemplateStateMapped = encodeTemplateStateShape . bindingToShape Bindings.templateStateBinding
parseTemplateStateMapped :: Value -> Parser TemplateState
parseTemplateStateMapped value = bindingFromShape Bindings.templateStateBinding <$> parseTemplateStateShape value
decodeTemplateStateMapped :: Value -> Either Text TemplateState
decodeTemplateStateMapped = mapLeftText . parseEither parseTemplateStateMapped
encodeTemplateStateShape :: ShapeTemplateState.TemplateStateShape -> Value
encodeTemplateStateShape shape =
object
[ "templateId" .= encodeTemplateIdLeaf shape.templateId
, "holder" .= maybe Null (\item0 -> encodeClaimIdLeaf item0) (shape.holder)
, "account" .= encodeAccountNumberLeaf shape.account
, "channel" .= encodeChannelLeaf shape.channel
, "kind" .= encodeTemplateKindLeaf shape.kind
, "fallbackChannel" .= encodeChannelLeaf shape.fallbackChannel
]
parseTemplateStateShape :: Value -> Parser ShapeTemplateState.TemplateStateShape
parseTemplateStateShape = withObject "TemplateStateShape" $ \objectValue -> do
rejectUnknownFields "TemplateState" ["templateId", "holder", "account", "channel", "kind", "fallbackChannel"] objectValue
ShapeTemplateState.TemplateState
<$> explicitParseField (parseTemplateIdLeaf) objectValue "templateId"
<*> parseOptionalField (pure Nothing) (\value0 -> case value0 of Null -> pure Nothing; other0 -> Just <$> (parseClaimIdLeaf) other0) objectValue "holder"
<*> explicitParseField (parseAccountNumberLeaf) objectValue "account"
<*> explicitParseField (parseChannelLeaf) objectValue "channel"
<*> parseOptionalField (pure Nominals.Draft) (parseTemplateKindLeaf) objectValue "kind"
<*> parseOptionalField (pure (nominalFromRepresentation Bindings.channelBinding Channel.Email)) (parseChannelLeaf) objectValue "fallbackChannel"
templateCatalogEventTypes :: NonEmpty EventType
templateCatalogEventTypes = EventType "TemplateRecorded" :| [EventType "TemplateRouted"]
templateCatalogCodec :: Codec TemplateCatalogEvent
templateCatalogCodec =
Codec
{ eventTypes = templateCatalogEventTypes
, eventType = \case
TemplateRecorded{} -> EventType "TemplateRecorded"
TemplateRouted{} -> EventType "TemplateRouted"
, schemaVersion = 1
, encode = encodeTemplateCatalogEvent
, decode = parseTemplateCatalogEvent
, upcasters = []
}
encodeTemplateCatalogEvent :: TemplateCatalogEvent -> Value
encodeTemplateCatalogEvent = \case
TemplateRecorded payload ->
object
[ "kind" .= ("TemplateRecorded" :: Text)
, "state" .= encodeTemplateStateMapped payload.state
, "reference" .= encodeTemplateRefMapped payload.reference
, "book" .= encodeTemplateBookMapped payload.book
]
TemplateRouted payload ->
object
[ "kind" .= ("TemplateRouted" :: Text)
, "templateId" .= templateIdText payload.templateId
, "claimId" .= KindID.toText (nominalToRepresentation Bindings.claimIdBinding payload.claimId)
]
parseTemplateCatalogEvent :: EventType -> Value -> Either Text TemplateCatalogEvent
parseTemplateCatalogEvent (EventType tag) = mapLeftText . parseEither (withObject "TemplateCatalogEvent" go)
where
go o = do
case tag of
"TemplateRecorded" ->
TemplateRecorded
<$> ( TemplateRecordedData
<$> explicitParseField parseTemplateStateMapped o "state"
<*> explicitParseField parseTemplateRefMapped o "reference"
<*> explicitParseField parseTemplateBookMapped o "book"
)
"TemplateRouted" ->
TemplateRouted
<$> ( TemplateRoutedData
<$> (unsafeTemplateIdFromLegacyText <$> o .: "templateId")
<*> explicitParseField (withText "ClaimId" parseClaimIdNominal) o "claimId"
)
_ -> fail ("unknown event type " <> show tag <> "; expected one of: " <> renderExpectedEventTypes templateCatalogEventTypes)
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))