Codec.hs

{-# LANGUAGE OverloadedRecordDot #-}
-- @generated by keiro-dsl 0.9.0.0 (language keiro-dsl 4) from aggregate ScalarAccount; do not edit.
module Generated.AggregateScalarExpressions.ScalarAccount.Codec (
    scalarAccountCodec,
    parseScalarAccountEvent,
    encodeScalarAccountEvent,
    encodeLimitsMapped,
    decodeLimitsMapped,
) where

import Generated.AggregateScalarExpressions.ScalarAccount.Domain
import Generated.AggregateScalarExpressions.Nominals (AccountMode (..), accountModeText, RequestId, requestIdText)
import Generated.AggregateScalarExpressions.Nominals.Internal (unsafeRequestIdFromLegacyText)
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, 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 Keiro.Codec.Structural (bindingFromShape, bindingToShape)
import Keiro.Codec (Codec (..), EventType (..))


import Generated.AggregateScalarExpressions.Structural.Shape.Limits qualified as ShapeLimits
import ScalarExpressions.Bindings qualified as Bindings
import ScalarExpressions.Domain (Limits)

parseAccountMode :: Text -> Parser AccountMode
parseAccountMode = \case
  "normal" -> pure Normal
  "restricted" -> pure Restricted
  tag -> fail ("unknown AccountMode " <> show tag <> "; expected one of: normal, restricted")

encodeLimitsMapped :: Limits -> Value
encodeLimitsMapped = encodeLimitsShape . bindingToShape Bindings.limitsBinding

parseLimitsMapped :: Value -> Parser Limits
parseLimitsMapped value = bindingFromShape Bindings.limitsBinding <$> parseLimitsShape value

decodeLimitsMapped :: Value -> Either Text Limits
decodeLimitsMapped = mapLeftText . parseEither parseLimitsMapped

encodeLimitsShape :: ShapeLimits.LimitsShape -> Value
encodeLimitsShape shape =
  object
      [ "minimum" .= toJSON (ShapeLimits.minimum shape)
      , "ceiling" .= toJSON (ShapeLimits.ceiling shape)
      ]

parseLimitsShape :: Value -> Parser ShapeLimits.LimitsShape
parseLimitsShape = withObject "LimitsShape" $ \objectValue -> do
  rejectUnknownFields "Limits" ["minimum", "ceiling"] objectValue
  ShapeLimits.Limits
    <$> explicitParseField (parseJSON) objectValue "minimum"
    <*> explicitParseField (parseJSON) objectValue "ceiling"

scalarAccountEventTypes :: NonEmpty EventType
scalarAccountEventTypes = EventType "Adjusted" :| [EventType "ClosedEvent"]

scalarAccountCodec :: Codec ScalarAccountEvent
scalarAccountCodec =
  Codec
    { eventTypes = scalarAccountEventTypes
    , eventType = \case
        Adjusted{} -> EventType "Adjusted"
        ClosedEvent{} -> EventType "ClosedEvent"
    , schemaVersion = 1
    , encode = encodeScalarAccountEvent
    , decode = parseScalarAccountEvent
    , upcasters = []
    }

encodeScalarAccountEvent :: ScalarAccountEvent -> Value
encodeScalarAccountEvent = \case
  Adjusted payload ->
    object
      [ "kind" .= ("Adjusted" :: Text)
      , "balance" .= payload.balance
      , "requested" .= payload.requested
      , "machine" .= payload.machine
      , "label" .= payload.label
      , "active" .= payload.active
      , "mode" .= accountModeText payload.mode
      , "requestId" .= requestIdText payload.requestId
      , "observedAt" .= payload.observedAt
      , "limits" .= encodeLimitsMapped payload.limits
      ]
  ClosedEvent payload ->
    object
      [ "kind" .= ("ClosedEvent" :: Text)
      , "balance" .= payload.balance
      ]

parseScalarAccountEvent :: EventType -> Value -> Either Text ScalarAccountEvent
parseScalarAccountEvent (EventType tag) = mapLeftText . parseEither (withObject "ScalarAccountEvent" go)
  where
    go o = do
      case tag of
        "Adjusted" ->
          Adjusted
            <$> ( AdjustedData
                    <$> o .: "balance"
                    <*> o .: "requested"
                    <*> o .: "machine"
                    <*> o .: "label"
                    <*> o .: "active"
                    <*> explicitParseField (withText "AccountMode" parseAccountMode) o "mode"
                    <*> (unsafeRequestIdFromLegacyText <$> o .: "requestId")
                    <*> o .: "observedAt"
                    <*> explicitParseField parseLimitsMapped o "limits"
                )
        "ClosedEvent" ->
          ClosedEvent
            <$> ( ClosedEventData
                    <$> o .: "balance"
                )
        _ -> fail ("unknown event type " <> show tag <> "; expected one of: " <> _renderEventTypes scalarAccountEventTypes)

mapLeftText :: Either String b -> Either Text b
mapLeftText = either (Left . T.pack) Right

_renderEventTypes :: NonEmpty EventType -> String
_renderEventTypes =
  T.unpack
    . T.intercalate ", "
    . map (\(EventType eventTypeName) -> eventTypeName)
    . NonEmpty.toList

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))