core: json instances for badge protocol types

src/Simplex/Chat/Badges/Service.hs

@@ -1,8 +1,10 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.Badges.Service
   ( BadgeServiceRequest (..),
@@ -24,9 +26,11 @@ module Simplex.Chat.Badges.Service
     StatementDebitType (..),
   ) where
 
-import Data.Aeson (FromJSON (..), ToJSON (..))
+import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=))
 import qualified Data.Aeson as J
-import Data.Int (Int64)
+import qualified Data.Aeson.Encoding as JE
+import qualified Data.Aeson.TH as JQ
+import qualified Data.Aeson.Types as JT
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Data.Word (Word8, Word16, Word32)
@@ -35,6 +39,7 @@ import Simplex.Chat.Badges.Types
 import Simplex.Chat.PaymentService
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
 import Simplex.Messaging.Version (VersionScope)
 import Simplex.Messaging.Version.Internal (Version (..))
 
@@ -52,6 +57,7 @@ data BadgeServiceRequest = BadgeServiceRequest
     purchaseKey :: Maybe C.PublicKeyEd25519, -- optional for BSCGetBadgeCatalog, required for other commands
     request :: BadgeServiceCommand
   }
+  deriving (Show)
 
 data BadgeServiceCommand
   = BSCGetBadgeCatalog
@@ -77,6 +83,7 @@ data BadgeServiceCommand
         balance :: BadgeBalance
       }
   | BSCPauseBadge
+  deriving (Show)
 
 data BadgeUpgrade = BadgeUpgrade
   { fromPurchaseKey :: C.PublicKeyEd25519,
@@ -84,6 +91,7 @@ data BadgeUpgrade = BadgeUpgrade
     receiptSignature :: C.Signature 'C.Ed25519,
     balance :: BadgeBalance
   }
+  deriving (Show)
 
 data BadgeServiceResponse
   = BSPBadgeCatalog
@@ -105,6 +113,7 @@ data BadgeServiceResponse
         message :: Maybe Text,
         retryAfter :: Maybe Word32
       }
+  deriving (Show)
 
 data BadgeCatalog = BadgeCatalog
   { prices :: [BadgePrice],
@@ -128,7 +137,8 @@ data BadgeOffer = BadgeOffer
     months :: Word8,
     discount :: OfferDiscount,
     status :: BadgeItemStatus,
-    createdAt :: UTCTime
+    createdAt :: UTCTime,
+    total :: Maybe CurrencyAmount -- absent when the store layer hasn't computed totals yet (catalogTotals, A4); the service always fills it
   }
   deriving (Show)
 
@@ -160,7 +170,7 @@ data StatementEntryType = SECredit {credit :: StatementCreditType} | SEDebit {de
 
 data StatementCreditType
   = SCPayment {invoiceId :: Maybe InvoiceId} -- absent for store and code payments
-  | SCCharge {chargeId :: Int64}
+  | SCCharge {chargeId :: Text} -- subscription_charges.charge_id TEXT NOT NULL PRIMARY KEY
   | SCSupport
   | SCTransferIn {fromPurchaseKey :: C.PublicKeyEd25519}
   | SCOpening
@@ -244,3 +254,93 @@ instance ToJSON BadgeServiceErrorCode where
 
 instance FromJSON BadgeServiceErrorCode where
   parseJSON = textParseJSON "BadgeServiceErrorCode"
+
+-- JSON
+
+-- StatementCreditType/StatementDebitType are hand-written (not TH-derived) so that an unrecognised
+-- "type" decodes into SCUnknown/SDUnknown and re-encodes verbatim from the stored object, per
+-- docs/protocol/badges-rpc.md: "An unknown type is stored as received and decoded after an app upgrade."
+
+(.=?) :: ToJSON v => J.Key -> Maybe v -> [(J.Key, J.Value)] -> [(J.Key, J.Value)]
+key .=? value = maybe id ((:) . (key .=)) value
+
+instance FromJSON StatementCreditType where
+  parseJSON (J.Object v) = do
+    tag <- v .: "type" :: JT.Parser Text
+    case tag of
+      "payment" -> SCPayment <$> v .:? "invoiceId"
+      "charge" -> SCCharge <$> v .: "chargeId"
+      "support" -> pure SCSupport
+      "transferIn" -> SCTransferIn <$> v .: "fromPurchaseKey"
+      "opening" -> pure SCOpening
+      _ -> pure $ SCUnknown tag v
+  parseJSON invalid = JT.prependFailure "bad StatementCreditType, " (JT.typeMismatch "Object" invalid)
+
+instance ToJSON StatementCreditType where
+  toJSON = \case
+    SCUnknown {json} -> J.Object json
+    SCPayment {invoiceId} -> J.object $ ("invoiceId" .=? invoiceId) ["type" .= ("payment" :: Text)]
+    SCCharge {chargeId} -> J.object ["type" .= ("charge" :: Text), "chargeId" .= chargeId]
+    SCSupport -> J.object ["type" .= ("support" :: Text)]
+    SCTransferIn {fromPurchaseKey} -> J.object ["type" .= ("transferIn" :: Text), "fromPurchaseKey" .= fromPurchaseKey]
+    SCOpening -> J.object ["type" .= ("opening" :: Text)]
+  toEncoding = \case
+    SCUnknown {json} -> JE.value $ J.Object json
+    SCPayment {invoiceId} -> J.pairs $ "type" .= ("payment" :: Text) <> maybe mempty ("invoiceId" .=) invoiceId
+    SCCharge {chargeId} -> J.pairs $ "type" .= ("charge" :: Text) <> "chargeId" .= chargeId
+    SCSupport -> J.pairs $ "type" .= ("support" :: Text)
+    SCTransferIn {fromPurchaseKey} -> J.pairs $ "type" .= ("transferIn" :: Text) <> "fromPurchaseKey" .= fromPurchaseKey
+    SCOpening -> J.pairs $ "type" .= ("opening" :: Text)
+
+instance FromJSON StatementDebitType where
+  parseJSON (J.Object v) = do
+    tag <- v .: "type" :: JT.Parser Text
+    case tag of
+      "refund" -> pure SDRefund
+      "upgrade" -> SDUpgrade <$> v .: "toPurchaseKey"
+      "transferOut" -> SDTransferOut <$> v .: "toPurchaseKey"
+      "support" -> pure SDSupport
+      "badge" -> pure SDBadge
+      "lapse" -> pure SDLapse
+      _ -> pure $ SDUnknown tag v
+  parseJSON invalid = JT.prependFailure "bad StatementDebitType, " (JT.typeMismatch "Object" invalid)
+
+instance ToJSON StatementDebitType where
+  toJSON = \case
+    SDUnknown {json} -> J.Object json
+    SDRefund -> J.object ["type" .= ("refund" :: Text)]
+    SDUpgrade {toPurchaseKey} -> J.object ["type" .= ("upgrade" :: Text), "toPurchaseKey" .= toPurchaseKey]
+    SDTransferOut {toPurchaseKey} -> J.object ["type" .= ("transferOut" :: Text), "toPurchaseKey" .= toPurchaseKey]
+    SDSupport -> J.object ["type" .= ("support" :: Text)]
+    SDBadge -> J.object ["type" .= ("badge" :: Text)]
+    SDLapse -> J.object ["type" .= ("lapse" :: Text)]
+  toEncoding = \case
+    SDUnknown {json} -> JE.value $ J.Object json
+    SDRefund -> J.pairs $ "type" .= ("refund" :: Text)
+    SDUpgrade {toPurchaseKey} -> J.pairs $ "type" .= ("upgrade" :: Text) <> "toPurchaseKey" .= toPurchaseKey
+    SDTransferOut {toPurchaseKey} -> J.pairs $ "type" .= ("transferOut" :: Text) <> "toPurchaseKey" .= toPurchaseKey
+    SDSupport -> J.pairs $ "type" .= ("support" :: Text)
+    SDBadge -> J.pairs $ "type" .= ("badge" :: Text)
+    SDLapse -> J.pairs $ "type" .= ("lapse" :: Text)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SE") ''StatementEntryType)
+
+$(JQ.deriveJSON defaultJSON ''StatementEntry)
+
+$(JQ.deriveJSON defaultJSON ''BadgeBalance)
+
+$(JQ.deriveJSON defaultJSON ''BadgeStatement)
+
+$(JQ.deriveJSON defaultJSON ''BadgePrice)
+
+$(JQ.deriveJSON defaultJSON ''BadgeOffer)
+
+$(JQ.deriveJSON defaultJSON ''BadgeCatalog)
+
+$(JQ.deriveJSON defaultJSON ''BadgeUpgrade)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "BSP") ''BadgeServiceResponse)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "BSC") ''BadgeServiceCommand)
+
+$(JQ.deriveJSON defaultJSON ''BadgeServiceRequest)

src/Simplex/Chat/Badges/Types.hs

@@ -1,6 +1,10 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.Badges.Types
   ( BadgePriceId (..),
@@ -21,7 +25,9 @@ module Simplex.Chat.Badges.Types
     UserBadgeState (..),
   ) where
 
+import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
 import Data.ByteString.Char8 (ByteString)
 import Data.Int (Int64)
 import Data.Text (Text)
@@ -30,15 +36,25 @@ import Data.Word (Word8)
 import Simplex.Chat.Badges hiding (BadgePurchase (..))
 import Simplex.Chat.PaymentService.Types (InvoiceId, StoredPayment)
 import Simplex.Messaging.Agent.Protocol (UserId)
+import Simplex.Messaging.Agent.Store.DB (fromTextField_)
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (dropPrefix, enumJSON, taggedObjectJSON)
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+#else
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+#endif
 
 -- confirmed
 newtype BadgePriceId = BadgePriceId Text
-  deriving newtype (Eq, Show)
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
 
 -- confirmed
 newtype BadgeOfferId = BadgeOfferId Text
-  deriving newtype (Eq, Show)
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
 
 -- unconfirmed draft
 data BadgePlan = BPOneTime | BPMonthly | BPAnnual
@@ -97,7 +113,7 @@ data BadgePurchase = BadgePurchase
     badgeType :: BadgeType,
     priceId :: Maybe BadgePriceId,
     offerId :: Maybe BadgeOfferId,
-    paymentId :: Int64,
+    paymentId :: Maybe Text, -- payments.payment_id TEXT REFERENCES @payments (nullable)
     status :: BadgePurchaseStatus,
     credential :: Maybe BadgeCredential,
     alertAcked :: Maybe (BadgeAlertKind, Text),
@@ -124,8 +140,8 @@ data BadgeLedgerEntry = BadgeLedgerEntry
 
 -- unconfirmed draft
 data BadgeCharge = BadgeCharge
-  { chargeId :: Int64,
-    paymentId :: Int64,
+  { chargeId :: Text, -- subscription_charges.charge_id TEXT NOT NULL PRIMARY KEY
+    paymentId :: Text, -- payments.payment_id TEXT NOT NULL PRIMARY KEY
     invoiceUuid :: InvoiceId,
     providerChargeRef :: Text,
     periodStart :: UTCTime,
@@ -138,12 +154,14 @@ data BadgeCharge = BadgeCharge
 
 -- unconfirmed draft
 data BadgeIssuance = BadgeIssuance
-  { issuanceId :: Int64,
+  { issuanceId :: Text, -- badge_issuances.issuance_id TEXT NOT NULL PRIMARY KEY
     badgePurchaseId :: Int64,
+    badgeType :: BadgeType,
     periodStart :: Maybe UTCTime,
     periodEnd :: Maybe UTCTime,
     expiry :: Maybe UTCTime,
     entryId :: Maybe Int64,
+    credential :: BadgeCredential,
     createdAt :: UTCTime
   }
   deriving (Show)
@@ -168,3 +186,37 @@ data UserBadgeState = UserBadgeState
     willRenew :: Bool,
     alert :: Maybe BadgeAlert
   }
+
+-- DB column spelling for BadgePurchaseStatus: the type does not cross the wire, so this spelling
+-- is only ever read back from the badge_purchases.status column it was written to. The payment
+-- statuses of the same rows are PaymentService.Types' InvoiceStatus and PaymentStatus, which
+-- carry their own instances there.
+instance TextEncoding BadgePurchaseStatus where
+  textEncode = \case
+    PSAcquiring -> "acquiring"
+    PSIssued -> "issued"
+    PSSuperseded -> "superseded"
+    PSFailed -> "failed"
+  textDecode s = case s of
+    "acquiring" -> Just PSAcquiring
+    "issued" -> Just PSIssued
+    "superseded" -> Just PSSuperseded
+    "failed" -> Just PSFailed
+    _ -> Nothing
+
+instance ToJSON BadgePurchaseStatus where
+  toJSON = textToJSON
+  toEncoding = textToEncoding
+
+instance FromJSON BadgePurchaseStatus where
+  parseJSON = textParseJSON "BadgePurchaseStatus"
+
+instance ToField BadgePurchaseStatus where toField = toField . textEncode
+
+instance FromField BadgePurchaseStatus where fromField = fromTextField_ textDecode
+
+-- JSON
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "BIS") ''BadgeItemStatus)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "OD") ''OfferDiscount)

src/Simplex/Chat/PaymentService.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.PaymentService
   ( ServiceInvoice (..),
@@ -6,9 +7,11 @@ module Simplex.Chat.PaymentService
     module Simplex.Chat.PaymentService.Types,
   ) where
 
+import qualified Data.Aeson.TH as JQ
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Simplex.Chat.PaymentService.Types
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
 
 data ServiceInvoice = ServiceInvoice
   { invoiceId :: InvoiceId,
@@ -29,3 +32,9 @@ data ServicePayment
   | SPCode {code :: Text}
   | SPReceipt {receipt :: Text} -- transfer of unissued months
   deriving (Show)
+
+-- JSON
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SP") ''ServicePayment)
+
+$(JQ.deriveJSON defaultJSON ''ServiceInvoice)

src/Simplex/Chat/PaymentService/Types.hs

@@ -1,6 +1,10 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.PaymentService.Types
   ( CurrencyAmount (..),
@@ -19,18 +23,32 @@ module Simplex.Chat.PaymentService.Types
     PaymentStatus (..),
   ) where
 
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
 import Data.ByteString.Char8 (ByteString)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Data.Word (Word32)
+import Simplex.Messaging.Agent.Store.DB (fromTextField_)
+import Simplex.Messaging.Encoding.String
+import Simplex.Messaging.Parsers (dropPrefix, enumJSON, taggedObjectJSON)
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+#else
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+#endif
 
 -- USD etc. are in minor units, following Stripe etc. convention
 newtype CurrencyAmount = CurrencyAmount Word32
   deriving (Eq, Show)
+  deriving newtype (ToJSON, FromJSON)
 
 -- confirmed
 newtype InvoiceId = InvoiceId Text
-  deriving newtype (Eq, Show)
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
 
 -- confirmed
 newtype PaymentId = PaymentId Text
@@ -132,3 +150,63 @@ data PaymentTerm
 -- to review
 data PaymentStatus = PSPending | PSSettled | PSFailed {exception :: Text}
   deriving (Show)
+
+-- | DB column spelling for @invoices.status@. Neither this type nor 'PaymentStatus' crosses the
+-- wire -- an invoice reaches the app as 'Simplex.Chat.PaymentService.ServiceInvoice', which
+-- carries no status at all -- so the spelling below is only ever read back from the column it was
+-- written to. The column is plain @TEXT NOT NULL@ with no CHECK (@M20261001_user_badges@), so
+-- these instances are the only thing that pins it.
+instance TextEncoding InvoiceStatus where
+  textEncode = \case
+    ISOpen -> "open"
+    ISPaid -> "paid"
+    ISExpired -> "expired"
+  textDecode = \case
+    "open" -> Just ISOpen
+    "paid" -> Just ISPaid
+    "expired" -> Just ISExpired
+    _ -> Nothing
+
+instance ToField InvoiceStatus where toField = toField . textEncode
+
+instance FromField InvoiceStatus where fromField = fromTextField_ textDecode
+
+-- | DB column spelling for @payments.status@, on the same terms as 'InvoiceStatus'.
+--
+-- __'textDecode' cannot round-trip 'PSFailed'.__ The failure text is a column of its own,
+-- @payments.exception@, so @textDecode "failed"@ can only return an empty one and a reader that
+-- wants the text must select that column and fill it in. Encoding is total and lossless, which is
+-- the direction both writers use: a redeemed code writes 'PSSettled' and nothing else writes this
+-- column yet.
+instance TextEncoding PaymentStatus where
+  textEncode = \case
+    PSPending -> "pending"
+    PSSettled -> "settled"
+    PSFailed {} -> "failed"
+  textDecode = \case
+    "pending" -> Just PSPending
+    "settled" -> Just PSSettled
+    "failed" -> Just PSFailed {exception = ""}
+    _ -> Nothing
+
+instance ToField PaymentStatus where toField = toField . textEncode
+
+-- There is deliberately __no 'FromField' instance__. 'textDecode' cannot recover 'PSFailed'\'s
+-- text (above), and a 'FromField' would let a row parser turn @SELECT status@ into a
+-- 'PaymentStatus' silently, dropping it. Whoever first reads a failed payment must select
+-- @status@ and @exception@ together and build the value from both; the missing instance makes
+-- that a compile error instead of a silent loss. 'InvoiceStatus' keeps its 'FromField' because
+-- its three constructors are nullary and its decode is lossless.
+
+-- JSON
+
+-- CardProvider has a single nullary constructor; tagSingleConstructors is needed so it still
+-- encodes as a bare string tag rather than as an untagged empty-array product (see MemberCriteria
+-- in Types.hs for the same fix).
+$(JQ.deriveJSON (enumJSON $ dropPrefix "CP") {J.tagSingleConstructors = True} ''CardProvider)
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "CC") ''CryptoCurrency)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SPM") ''ServicePaymentMethod)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SPD") ''ServicePaymentDestination)