Contract.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE TypeApplications #-}

-- @generated by keiro-dsl 0.8.0.0 (language keiro-dsl 4) from contract emergency; do not edit.
module Generated.HospitalCapacity.Emergency.Contract
  ( EmergencyPayload (..),
    IncidentTransferNeedDeclaredData (..),
    TransferReservationAcceptedData (..),
    incidentEventsTopic,
    hospitalEventsTopic,
    messageTypeOf,
    encodeEmergencyPayload,
    parseEmergencyPayload,
  )
where

import Data.Aeson (Value, object, withObject, withText, (.:), (.=))
import Data.Aeson.Types (Parser, explicitParseField, parseEither)
import Data.KindID (KindID)
import Data.KindID qualified as KindID
import Data.Text (Text)
import Data.Text qualified as T
import Keiro.Codec.IdDomain (parseKindIdV7Value)

-- topic constants
incidentEventsTopic :: Text
incidentEventsTopic = "emergency.incident.events"

hospitalEventsTopic :: Text
hospitalEventsTopic = "emergency.hospital.events"

-- the closed payload set (discriminated by "messageType")
data IncidentTransferNeedDeclaredData = IncidentTransferNeedDeclaredData {incidentId :: !(KindID "inc"), triageRecordId :: !Text, region :: !Text, redCount :: !Int}
  deriving stock (Eq, Show)

data TransferReservationAcceptedData = TransferReservationAcceptedData {incidentId :: !(KindID "inc"), reservationId :: !(KindID "rsv"), hospitalId :: !(KindID "hsp"), expirationDeadline :: !Text}
  deriving stock (Eq, Show)

data EmergencyPayload
  = IncidentTransferNeedDeclared !IncidentTransferNeedDeclaredData
  | TransferReservationAccepted !TransferReservationAcceptedData
  deriving stock (Eq, Show)

messageTypeOf :: EmergencyPayload -> Text
messageTypeOf = \case
  IncidentTransferNeedDeclared {} -> "IncidentTransferNeedDeclared"
  TransferReservationAccepted {} -> "TransferReservationAccepted"

encodeEmergencyPayload :: EmergencyPayload -> Value
encodeEmergencyPayload = \case
  IncidentTransferNeedDeclared payload ->
    object
      [ "messageType" .= ("IncidentTransferNeedDeclared" :: Text),
        "incidentId" .= KindID.toText payload.incidentId,
        "triageRecordId" .= payload.triageRecordId,
        "region" .= payload.region,
        "redCount" .= payload.redCount
      ]
  TransferReservationAccepted payload ->
    object
      [ "messageType" .= ("TransferReservationAccepted" :: Text),
        "incidentId" .= KindID.toText payload.incidentId,
        "reservationId" .= KindID.toText payload.reservationId,
        "hospitalId" .= KindID.toText payload.hospitalId,
        "expirationDeadline" .= payload.expirationDeadline
      ]

parseEmergencyPayload :: Value -> Either Text EmergencyPayload
parseEmergencyPayload = mapLeftText . parseEither (withObject "EmergencyPayload" go)
  where
    go o = do
      kind <- explicitParseField (withText "messageType" validateMessageType) o "messageType"
      case kind of
        "IncidentTransferNeedDeclared" ->
          IncidentTransferNeedDeclared
            <$> ( IncidentTransferNeedDeclaredData
                    <$> explicitParseField (parseKindIdV7Value @"inc") o "incidentId"
                    <*> o .: "triageRecordId"
                    <*> o .: "region"
                    <*> o .: "redCount"
                )
        "TransferReservationAccepted" ->
          TransferReservationAccepted
            <$> ( TransferReservationAcceptedData
                    <$> explicitParseField (parseKindIdV7Value @"inc") o "incidentId"
                    <*> explicitParseField (parseKindIdV7Value @"rsv") o "reservationId"
                    <*> explicitParseField (parseKindIdV7Value @"hsp") o "hospitalId"
                    <*> o .: "expirationDeadline"
                )
        _ -> fail "validated message type was not handled"

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

validateMessageType :: Text -> Parser Text
validateMessageType kind
  | kind `elem` ["IncidentTransferNeedDeclared", "TransferReservationAccepted"] = pure kind
  | otherwise = fail ("unknown message type " <> show kind <> "; expected one of: IncidentTransferNeedDeclared, TransferReservationAccepted")