core: json instances for badge protocol types

plans/2026-08-21-badges-web-checkout.md

@@ -128,7 +128,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat
 | Step | Title | Deps | Status |
 |---|---|---|---|
 | A1 | Register the client badge migration, add `STRICT` | — | ☑ |
-| A2 | JSON instances for badge protocol types, and the offer `total` | — | ☐ |
+| A2 | JSON instances for badge protocol types, and the offer `total` | — | ☑ |
 | A3 | Service schema: `web_orders`, `codes`, `provider_events` | — | ☐ |
 | A4 | `Catalog.hs`: internal pricing, totals, seeding | A2, A5 | ☐ |
 | A5 | Cabal dependencies for the service | — | ☐ |

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)

tests/BadgeTests.hs

@@ -1,19 +1,34 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module BadgeTests (badgeTests) where
 
+import Control.Concurrent.STM (atomically)
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson as J
+import qualified Data.Aeson.KeyMap as JM
+import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
+import Data.Text (Text)
 import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
-import qualified Data.Aeson as J
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Chat.Badges
+import qualified Simplex.Chat.Badges as CB
+import Simplex.Chat.Badges.Service
+import Simplex.Chat.Badges.Types
+-- PaymentStatus is hidden: its PSFailed collides with BadgePurchaseStatus's, and the column
+-- spellings of both are pinned below. The payment statuses are reached through PT instead.
+import Simplex.Chat.PaymentService hiding (PaymentStatus (..))
+import qualified Simplex.Chat.PaymentService.Types as PT
 import Simplex.Messaging.Crypto.BBS
+import Simplex.Messaging.Encoding.String (TextEncoding (..))
 import Test.Hspec
 
 badgeTests :: Spec
@@ -27,6 +42,21 @@ badgeTests = do
   it "should treat lifetime badges as always active" testLifetimeBadge
   it "should accept unknown badge types" testUnknownBadgeType
   it "credential serializes to a paste-able token and back" testCredentialSerialization
+  it "round-trips BadgeItemStatus JSON with the documented spellings" testBadgeItemStatusJSON
+  it "round-trips CardProvider and CryptoCurrency JSON" testCardCryptoJSON
+  it "round-trips BadgePurchaseStatus, InvoiceStatus and PaymentStatus DB column spellings" testBadgeStatusColumnSpelling
+  it "round-trips OfferDiscount and service payment method/destination JSON" testOfferDiscountAndPaymentMethodJSON
+  it "round-trips every ServicePayment constructor" testServicePaymentJSON
+  it "round-trips every known StatementCreditType constructor" testStatementCreditTypeJSON
+  it "decodes an unrecognised ledgerCredit tag into SCUnknown and re-encodes it byte-identically" testStatementCreditUnknownTag
+  it "round-trips every known StatementDebitType constructor" testStatementDebitTypeJSON
+  it "decodes an unrecognised ledgerDebit tag into SDUnknown and re-encodes it byte-identically" testStatementDebitUnknownTag
+  it "round-trips StatementEntry, BadgeBalance and BadgeStatement JSON" testStatementEntryJSON
+  it "round-trips BadgePrice, BadgeOffer and BadgeCatalog JSON" testCatalogJSON
+  it "round-trips BadgeUpgrade and ServiceInvoice JSON" testBadgeUpgradeAndInvoiceJSON
+  it "round-trips every BadgeServiceCommand constructor" testBadgeServiceCommandJSON
+  it "round-trips every BadgeServiceResponse constructor" testBadgeServiceResponseJSON
+  it "round-trips BadgeServiceRequest JSON" testBadgeServiceRequestJSON
 
 proofOf :: BadgeProof -> BBSProof
 proofOf (BadgeProof _ _ p _) = p
@@ -64,12 +94,12 @@ testFullWorkflow = do
 testTamperedType :: IO ()
 testTamperedType = do
   (pk, BadgeProof idx ph p info) <- issueBadgeProof BTSupporter (Just futureTime)
-  verifyBadge (keysFor pk) (BadgeProof idx ph p info {badgeType = BTLegend}) >>= (`shouldBe` Just False)
+  verifyBadge (keysFor pk) (BadgeProof idx ph p info {CB.badgeType = BTLegend}) >>= (`shouldBe` Just False)
 
 testTamperedExpiry :: IO ()
 testTamperedExpiry = do
   (pk, BadgeProof idx ph p info) <- issueBadgeProof BTSupporter (Just futureTime)
-  verifyBadge (keysFor pk) (BadgeProof idx ph p info {badgeExpiry = Just pastTime}) >>= (`shouldBe` Just False)
+  verifyBadge (keysFor pk) (BadgeProof idx ph p info {CB.badgeExpiry = Just pastTime}) >>= (`shouldBe` Just False)
 
 testWrongKey :: IO ()
 testWrongKey = do
@@ -123,6 +153,276 @@ testCredentialSerialization = do
     Right cred -> verifyCredential pk cred >>= (`shouldBe` True)
     Left e -> expectationFailure e
 
+-- Badge protocol JSON (A2)
+
+-- encode, decode, re-encode: checks both that FromJSON accepts what ToJSON produces and that the
+-- re-encoding is byte-identical to the original (the specific property SCUnknown/SDUnknown need)
+roundtripsBytes :: forall a. (ToJSON a, FromJSON a) => a -> Expectation
+roundtripsBytes v = case J.eitherDecode bytes :: Either String a of
+  Left e -> expectationFailure e
+  Right v' -> J.encode v' `shouldBe` bytes
+  where
+    bytes = J.encode v
+
+mkKeyPair :: IO (C.PublicKeyEd25519, C.PrivateKeyEd25519)
+mkKeyPair = do
+  drg <- C.newRandom
+  (pub, priv :: C.PrivateKeyEd25519) <- atomically $ C.generateKeyPair drg
+  pure (pub, priv)
+
+jsonBadgeInfo :: BadgeInfo
+jsonBadgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Just futureTime, badgeExtra = ""}
+
+jsonCredential :: IO BadgeCredential
+jsonCredential = do
+  Right (_, sk) <- bbsKeyGen
+  drg <- C.newRandom
+  mk <- generateMasterKey drg
+  Right cred <- issueBadge testKeyIdx sk (VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeInfo = jsonBadgeInfo})
+  pure cred
+
+sampleEntry :: IO StatementEntry
+sampleEntry = do
+  now <- getCurrentTime
+  pure
+    StatementEntry
+      { entryId = "entry-1",
+        changeMonths = 1,
+        balanceMonths = 12,
+        balanceStartTs = now,
+        balanceBadgeType = BTSupporter,
+        wasPausedSince = Nothing,
+        createdAt = now,
+        entryType = SECredit {credit = SCOpening}
+      }
+
+sampleBalance :: IO BadgeBalance
+sampleBalance = BadgeBalance <$> sampleEntry
+
+samplePaymentDestination :: ServicePaymentDestination
+samplePaymentDestination = SPDCard {provider = CPStripe, url = "https://pay.example/session"}
+
+testBadgeItemStatusJSON :: IO ()
+testBadgeItemStatusJSON = do
+  mapM_ roundtripsBytes [BISActive, BISDeprecated, BISDisabled]
+  J.eitherDecode (J.encode BISActive) `shouldBe` Right ("active" :: Text)
+  J.eitherDecode (J.encode BISDeprecated) `shouldBe` Right ("deprecated" :: Text)
+  J.eitherDecode (J.encode BISDisabled) `shouldBe` Right ("disabled" :: Text)
+
+testCardCryptoJSON :: IO ()
+testCardCryptoJSON = do
+  roundtripsBytes CPStripe
+  mapM_ roundtripsBytes [CCBtc, CCXmr]
+  J.eitherDecode (J.encode CPStripe) `shouldBe` Right ("stripe" :: Text)
+  J.eitherDecode (J.encode CCBtc) `shouldBe` Right ("btc" :: Text)
+  J.eitherDecode (J.encode CCXmr) `shouldBe` Right ("xmr" :: Text)
+
+testBadgeStatusColumnSpelling :: IO ()
+testBadgeStatusColumnSpelling = do
+  mapM_ roundtripsBytes [PSAcquiring, PSIssued, PSSuperseded, PSFailed]
+  J.eitherDecode (J.encode PSAcquiring) `shouldBe` Right ("acquiring" :: Text)
+  J.eitherDecode (J.encode PSIssued) `shouldBe` Right ("issued" :: Text)
+  J.eitherDecode (J.encode PSSuperseded) `shouldBe` Right ("superseded" :: Text)
+  J.eitherDecode (J.encode PSFailed) `shouldBe` Right ("failed" :: Text)
+  -- invoices.status and payments.status have no JSON at all: they never cross the wire, so
+  -- TextEncoding is their whole contract and it is asserted directly.
+  map textEncode [ISOpen, ISPaid, ISExpired] `shouldBe` ["open", "paid", "expired"]
+  map textDecode ["open", "paid", "expired", "settled"]
+    `shouldBe` [Just ISOpen, Just ISPaid, Just ISExpired, Nothing]
+  map textEncode [PT.PSPending, PT.PSSettled, PT.PSFailed "card declined"]
+    `shouldBe` ["pending", "settled", "failed"]
+  -- PaymentStatus has no Eq, and textDecode cannot recover the failure text -- it is
+  -- payments.exception, a column of its own -- so the spelling is what is compared back.
+  map (fmap textEncode . paymentStatus) ["pending", "settled", "failed", "new"]
+    `shouldBe` [Just "pending", Just "settled", Just "failed", Nothing]
+  where
+    paymentStatus :: Text -> Maybe PT.PaymentStatus
+    paymentStatus = textDecode
+
+testOfferDiscountAndPaymentMethodJSON :: IO ()
+testOfferDiscountAndPaymentMethodJSON = do
+  roundtripsBytes (ODFreeMonths {freeMonths = 3})
+  roundtripsBytes (ODDiscount {discount = 20})
+  roundtripsBytes (SPMCard {provider = CPStripe})
+  roundtripsBytes (SPMCrypto {currency = CCBtc})
+  roundtripsBytes samplePaymentDestination
+  roundtripsBytes (SPDCrypto {currency = CCXmr, address = "4Axxxxxxxxxxxxxxxxxxxxxxxxxxxxx", cryptoAmount = "0.5"})
+
+testServicePaymentJSON :: IO ()
+testServicePaymentJSON = do
+  roundtripsBytes (SPApple {jws = "jws-token"})
+  roundtripsBytes (SPGoogle {token = "google-token"})
+  roundtripsBytes (SPInvoice {invoiceId = InvoiceId "inv-1"})
+  roundtripsBytes (SPCode {code = "CODE123"})
+  roundtripsBytes (SPReceipt {receipt = "receipt-blob"})
+
+testStatementCreditTypeJSON :: IO ()
+testStatementCreditTypeJSON = do
+  roundtripsBytes (SCPayment {invoiceId = Just (InvoiceId "inv-1")})
+  roundtripsBytes (SCPayment {invoiceId = Nothing})
+  roundtripsBytes (SCCharge {chargeId = "charge-1"})
+  roundtripsBytes SCSupport
+  (pub, _) <- mkKeyPair
+  roundtripsBytes (SCTransferIn {fromPurchaseKey = pub})
+  roundtripsBytes SCOpening
+  -- ruling 1: chargeId must serialize as a JSON string (schema: "type": "string"), not a number
+  case J.toJSON (SCCharge {chargeId = "c1"}) of
+    J.Object o -> JM.lookup "chargeId" o `shouldBe` Just (J.String "c1")
+    v -> expectationFailure ("expected a JSON object, got " <> show v)
+
+testStatementCreditUnknownTag :: IO ()
+testStatementCreditUnknownTag = do
+  let bytes = LB.pack "{\"amount\":42,\"type\":\"futureThing\"}"
+  case J.eitherDecode bytes :: Either String StatementCreditType of
+    Left e -> expectationFailure e
+    Right v@(SCUnknown {tag}) -> do
+      tag `shouldBe` "futureThing"
+      J.encode v `shouldBe` bytes
+    Right other -> expectationFailure ("expected SCUnknown, got " <> show other)
+
+testStatementDebitTypeJSON :: IO ()
+testStatementDebitTypeJSON = do
+  roundtripsBytes SDRefund
+  (pub, _) <- mkKeyPair
+  roundtripsBytes (SDUpgrade {toPurchaseKey = pub})
+  roundtripsBytes (SDTransferOut {toPurchaseKey = pub})
+  roundtripsBytes SDSupport
+  roundtripsBytes SDBadge
+  roundtripsBytes SDLapse
+
+testStatementDebitUnknownTag :: IO ()
+testStatementDebitUnknownTag = do
+  let bytes = LB.pack "{\"amount\":7,\"type\":\"somethingNew\"}"
+  case J.eitherDecode bytes :: Either String StatementDebitType of
+    Left e -> expectationFailure e
+    Right v@(SDUnknown {tag}) -> do
+      tag `shouldBe` "somethingNew"
+      J.encode v `shouldBe` bytes
+    Right other -> expectationFailure ("expected SDUnknown, got " <> show other)
+
+testStatementEntryJSON :: IO ()
+testStatementEntryJSON = do
+  roundtripsBytes (SECredit {credit = SCOpening})
+  roundtripsBytes (SEDebit {debit = SDRefund})
+  entry <- sampleEntry
+  roundtripsBytes entry
+  roundtripsBytes (BadgeBalance {lastEntry = entry})
+  roundtripsBytes (BadgeStatement {entries = [entry], previousEntryId = Just "entry-0"})
+  roundtripsBytes (BadgeStatement {entries = [entry], previousEntryId = Nothing})
+
+testCatalogJSON :: IO ()
+testCatalogJSON = do
+  now <- getCurrentTime
+  let price =
+        BadgePrice
+          { priceId = BadgePriceId "price-1",
+            badgeType = BTSupporter,
+            monthPrice = CurrencyAmount 500,
+            currency = "usd",
+            status = BISActive,
+            createdAt = now
+          }
+      offer =
+        BadgeOffer
+          { offerId = BadgeOfferId "offer-1",
+            priceId = Just (BadgePriceId "price-1"),
+            months = 12,
+            discount = ODDiscount {discount = 10},
+            status = BISActive,
+            createdAt = now,
+            total = Just (CurrencyAmount 5400)
+          }
+  roundtripsBytes price
+  roundtripsBytes offer
+  roundtripsBytes (offer {total = Nothing}) -- absent until catalogTotals fills it in (A4)
+  roundtripsBytes (BadgeCatalog {prices = [price], offers = [offer]})
+
+testBadgeUpgradeAndInvoiceJSON :: IO ()
+testBadgeUpgradeAndInvoiceJSON = do
+  now <- getCurrentTime
+  balance <- sampleBalance
+  (pub, sk) <- mkKeyPair
+  let upgrade =
+        BadgeUpgrade
+          { fromPurchaseKey = pub,
+            receipt = "receipt-text",
+            receiptSignature = C.sign' sk "receipt-text",
+            balance
+          }
+  roundtripsBytes upgrade
+  let invoice =
+        ServiceInvoice
+          { invoiceId = InvoiceId "inv-1",
+            price = CurrencyAmount 1000,
+            discount = Just (CurrencyAmount 100),
+            credit = Nothing,
+            amount = CurrencyAmount 900,
+            currency = "usd",
+            expiresAt = now,
+            paymentTo = samplePaymentDestination
+          }
+  roundtripsBytes invoice
+
+testBadgeServiceCommandJSON :: IO ()
+testBadgeServiceCommandJSON = do
+  balance <- sampleBalance
+  drg <- C.newRandom
+  mk <- generateMasterKey drg
+  let badgeRequest = BadgeRequest {masterKey = mk, badgeInfo = jsonBadgeInfo}
+  (pub, sk) <- mkKeyPair
+  let upgrade =
+        BadgeUpgrade
+          { fromPurchaseKey = pub,
+            receipt = "r",
+            receiptSignature = C.sign' sk "r",
+            balance
+          }
+  roundtripsBytes BSCGetBadgeCatalog
+  roundtripsBytes
+    BSCGetBadgeInvoice
+      { priceId = BadgePriceId "price-1",
+        offerId = Just (BadgeOfferId "offer-1"),
+        badgeInfo = jsonBadgeInfo,
+        paymentVia = SPMCard {provider = CPStripe},
+        upgrade = Just upgrade
+      }
+  roundtripsBytes BSCPurchaseBadge {badgeRequest, payment = SPCode {code = "CODE"}, upgrade = Nothing}
+  roundtripsBytes BSCUpgradeBadgeSubscription {badgeRequest, payment = SPInvoice {invoiceId = InvoiceId "inv-1"}, balance}
+  roundtripsBytes BSCIssueBadge {badgeRequest, balance}
+  roundtripsBytes BSCPauseBadge
+
+testBadgeServiceResponseJSON :: IO ()
+testBadgeServiceResponseJSON = do
+  now <- getCurrentTime
+  entry <- sampleEntry
+  cred <- jsonCredential
+  let statement = BadgeStatement {entries = [entry], previousEntryId = Nothing}
+      catalog = BadgeCatalog {prices = [], offers = []}
+      invoice =
+        ServiceInvoice
+          { invoiceId = InvoiceId "inv-1",
+            price = CurrencyAmount 1000,
+            discount = Nothing,
+            credit = Nothing,
+            amount = CurrencyAmount 1000,
+            currency = "usd",
+            expiresAt = now,
+            paymentTo = samplePaymentDestination
+          }
+  roundtripsBytes (BSPBadgeCatalog {catalog, badgeStatement = Just statement})
+  roundtripsBytes (BSPBadgeCatalog {catalog, badgeStatement = Nothing})
+  roundtripsBytes (BSPBadgeInvoice {invoice, badgeType = BTSupporter, months = 12})
+  roundtripsBytes (BSPBadgeCredential {credential = Just cred, receipt = Just "r", statement})
+  roundtripsBytes (BSPBadgeCredential {credential = Nothing, receipt = Nothing, statement})
+  roundtripsBytes (BSPError {code = BSEBadRequest, message = Just "bad request", retryAfter = Just 30})
+  roundtripsBytes (BSPError {code = BSEUnknown "future_error", message = Nothing, retryAfter = Nothing})
+
+testBadgeServiceRequestJSON :: IO ()
+testBadgeServiceRequestJSON = do
+  (pub, _) <- mkKeyPair
+  roundtripsBytes (BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Just pub, request = BSCPauseBadge})
+  roundtripsBytes (BadgeServiceRequest {version = VersionBadgeService 1, purchaseKey = Nothing, request = BSCGetBadgeCatalog})
+
 -- Helpers
 
 futureTime :: UTCTime