Codec.hs

-- @generated by keiro-dsl 0.18.0.0 (language keiro-dsl 6) from aggregate HashStore; do not edit.
module Generated.RefinedBase16.HashStore.Codec (
    hashStoreCodec,
    parseHashStoreEvent,
    encodeHashStoreEvent,
    encodeContentHashMapped,
    decodeContentHashMapped,
    encodeHashEnvelopeMapped,
    decodeHashEnvelopeMapped,
    encodeMaybeContentHashMapped,
    decodeMaybeContentHashMapped,
) where

import Generated.RefinedBase16.HashStore.Domain
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 (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import qualified Data.Text as T
import Keiro.Codec.Base16Bytes (encodeBase16Bytes, parseBase16Bytes)
import Keiro.Codec.Structural (bindingFromShape, bindingToShape)
import Keiro.Codec (Codec (..), EventType (..))


import Conformance.RefinedBase16.Bindings qualified as Bindings
import Conformance.RefinedBase16.Domain (ContentHash, HashEnvelope, MaybeContentHash)
import Generated.RefinedBase16.Structural.Shape.ContentHash qualified as ShapeContentHash
import Generated.RefinedBase16.Structural.Shape.HashEnvelope qualified as ShapeHashEnvelope
import Generated.RefinedBase16.Structural.Shape.MaybeContentHash qualified as ShapeMaybeContentHash



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

encodeHashEnvelopeMapped :: HashEnvelope -> Value
encodeHashEnvelopeMapped = encodeHashEnvelopeShape . bindingToShape Bindings.hashEnvelopeBinding

parseHashEnvelopeMapped :: Value -> Parser HashEnvelope
parseHashEnvelopeMapped value = bindingFromShape Bindings.hashEnvelopeBinding <$> parseHashEnvelopeShape value

decodeHashEnvelopeMapped :: Value -> Either Text HashEnvelope
decodeHashEnvelopeMapped = mapLeftText . parseEither parseHashEnvelopeMapped

encodeHashEnvelopeShape :: ShapeHashEnvelope.HashEnvelopeShape -> Value
encodeHashEnvelopeShape shape =
  object
      [ "primary" .= encodeContentHashShape (shape.primary)
      , "optionalHash" .= maybe Null (\item0 -> encodeContentHashShape (item0)) (shape.optionalHash)
      , "namedOptional" .= encodeMaybeContentHashShape (shape.namedOptional)
      , "sequence" .= toJSON (map (\item0 -> encodeContentHashShape (item0)) (shape.sequence))
      , "labelled" .= toJSON (Map.map (\item0 -> encodeContentHashShape (item0)) (shape.labelled))
      ]

parseHashEnvelopeShape :: Value -> Parser ShapeHashEnvelope.HashEnvelopeShape
parseHashEnvelopeShape = withObject "HashEnvelopeShape" $ \objectValue -> do
  rejectUnknownFields "HashEnvelope" ["primary", "optionalHash", "namedOptional", "sequence", "labelled"] objectValue
  ShapeHashEnvelope.HashEnvelope
    <$> explicitParseField (parseContentHashShape) objectValue "primary"
    <*> parseOptionalField (pure Nothing) (\value0 -> case value0 of Null -> pure Nothing; other0 -> Just <$> (parseContentHashShape) other0) objectValue "optionalHash"
    <*> explicitParseField (parseMaybeContentHashShape) objectValue "namedOptional"
    <*> explicitParseField (\value0 -> do items0 <- (parseJSON value0 :: Parser [Value]); traverse (\(index0, item0) -> (parseContentHashShape) item0 <?> Index index0) (zip [0..] items0)) objectValue "sequence"
    <*> explicitParseField (\value0 -> do items0 <- (parseJSON value0 :: Parser (Map Text Value)); Map.traverseWithKey (\key0 item0 -> (parseContentHashShape) item0 <?> Key (Key.fromText key0)) items0) objectValue "labelled"

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

hashStoreEventTypes :: NonEmpty EventType
hashStoreEventTypes = EventType "HashStored" :| [EventType "HashAudited", EventType "LegacyHashImported"]

hashStoreCodec :: Codec HashStoreEvent
hashStoreCodec =
  Codec
    { eventTypes = hashStoreEventTypes
    , eventType = \case
        HashStored{} -> EventType "HashStored"
        HashAudited{} -> EventType "HashAudited"
        LegacyHashImported{} -> EventType "LegacyHashImported"
    , schemaVersion = 1
    , encode = encodeHashStoreEvent
    , decode = parseHashStoreEvent
    , upcasters = []
    }

encodeHashStoreEvent :: HashStoreEvent -> Value
encodeHashStoreEvent = \case
  HashStored payload ->
    object
      [ "kind" .= ("HashStored" :: Text)
      , "hash" .= encodeContentHashMapped payload.hash
      , "optionalHash" .= encodeMaybeContentHashMapped payload.optionalHash
      , "envelope" .= encodeHashEnvelopeMapped payload.envelope
      ]
  HashAudited payload ->
    object
      [ "kind" .= ("HashAudited" :: Text)
      , "hash" .= encodeContentHashMapped payload.hash
      , "optionalHash" .= encodeMaybeContentHashMapped payload.optionalHash
      , "envelope" .= encodeHashEnvelopeMapped payload.envelope
      ]
  LegacyHashImported payload ->
    object
      [ "kind" .= ("LegacyHashImported" :: Text)
      , "hash" .= encodeContentHashMapped payload.hash
      , "optionalHash" .= encodeMaybeContentHashMapped payload.optionalHash
      , "envelope" .= encodeHashEnvelopeMapped payload.envelope
      ]

parseHashStoreEvent :: EventType -> Value -> Either Text HashStoreEvent
parseHashStoreEvent (EventType tag) = mapLeftText . parseEither (withObject "HashStoreEvent" go)
  where
    go o = do
      case tag of
        "HashStored" ->
          HashStored
            <$> ( HashStoredData
                    <$> explicitParseField parseContentHashMapped o "hash"
                    <*> parseOptionalField (parseMaybeContentHashMapped Null) parseMaybeContentHashMapped o "optionalHash"
                    <*> explicitParseField parseHashEnvelopeMapped o "envelope"
                )
        "HashAudited" ->
          HashAudited
            <$> ( HashAuditedData
                    <$> explicitParseField parseContentHashMapped o "hash"
                    <*> parseOptionalField (parseMaybeContentHashMapped Null) parseMaybeContentHashMapped o "optionalHash"
                    <*> explicitParseField parseHashEnvelopeMapped o "envelope"
                )
        "LegacyHashImported" ->
          LegacyHashImported
            <$> ( LegacyHashImportedData
                    <$> explicitParseField parseContentHashMapped o "hash"
                    <*> parseOptionalField (parseMaybeContentHashMapped Null) parseMaybeContentHashMapped o "optionalHash"
                    <*> explicitParseField parseHashEnvelopeMapped o "envelope"
                )
        _ -> fail ("unknown event type " <> show tag <> "; expected one of: " <> renderExpectedEventTypes hashStoreEventTypes)

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