From 400d12a6471c67dcbfe61bf82076669de43af345 Mon Sep 17 00:00:00 2001 From: shum Date: Sat, 22 Aug 2026 11:42:42 +0000 Subject: [PATCH] core: json instances for badge protocol types --- plans/2026-08-21-badges-web-checkout.md | 2 +- src/Simplex/Chat/Badges/Service.hs | 108 +++++++- src/Simplex/Chat/Badges/Types.hs | 64 ++++- src/Simplex/Chat/PaymentService.hs | 9 + src/Simplex/Chat/PaymentService/Types.hs | 80 +++++- tests/BadgeTests.hs | 306 ++++++++++++++++++++++- 6 files changed, 554 insertions(+), 15 deletions(-) diff --git a/plans/2026-08-21-badges-web-checkout.md b/plans/2026-08-21-badges-web-checkout.md index 058a52dbdd..4786e58e0d 100644 --- a/plans/2026-08-21-badges-web-checkout.md +++ b/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 | — | ☐ | diff --git a/src/Simplex/Chat/Badges/Service.hs b/src/Simplex/Chat/Badges/Service.hs index 6f15d0fa16..9e15f242f4 100644 --- a/src/Simplex/Chat/Badges/Service.hs +++ b/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) diff --git a/src/Simplex/Chat/Badges/Types.hs b/src/Simplex/Chat/Badges/Types.hs index 70dd4dfa8c..8a88456a69 100644 --- a/src/Simplex/Chat/Badges/Types.hs +++ b/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) diff --git a/src/Simplex/Chat/PaymentService.hs b/src/Simplex/Chat/PaymentService.hs index a4484c469c..a32a62aa3e 100644 --- a/src/Simplex/Chat/PaymentService.hs +++ b/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) diff --git a/src/Simplex/Chat/PaymentService/Types.hs b/src/Simplex/Chat/PaymentService/Types.hs index 910a5b973f..77b865633b 100644 --- a/src/Simplex/Chat/PaymentService/Types.hs +++ b/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) diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index 90e3e9ae7a..889afc7004 100644 --- a/tests/BadgeTests.hs +++ b/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