core: client badge store, plan: tick C1

src/Simplex/Chat/Store/Badges.hs

@@ -0,0 +1,529 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | The CLIENT's badge store: the user's purchases, the payment row a code redemption writes,
+-- the issuances the worker collects and the ledger replica the service sends.
+--
+-- The tables are the ones @badgeSchema@ creates
+-- ("Simplex.Chat.Store.SQLite.Migrations.M20260731_user_badges"), unprefixed, plus the
+-- client-only columns that migration ALTERs in: @badge_purchases.user_id@\/@purchase_priv_key@,
+-- @badge_ledger.entry_type_unknown@\/@entry_type_value@ and @users.shown_badge_id@. The service
+-- has the same tables under its own prefix, so "BadgeService.Store" is the mirror of this module
+-- and the column spellings of every status and entry type are deliberately identical to its
+-- 'BadgeService.Store.encodeLedgerEntryType'\/'BadgeService.Store.decodeLedgerEntryType'; a second
+-- spelling of @credit@\/@support@\/@opening@\/@lapse@ would be a defect, not a style choice.
+--
+-- Two things this module is NOT:
+--
+-- * It is not an author of ledger entries. The service writes the ledger (docs\/protocol
+--   \/badges-rpc.md, "The ledger is written by the service alone"); the client keeps a verbatim
+--   replica, so 'insertLedgerEntries' copies what it is given and mints nothing. @entry_uuid@ in
+--   particular is the service's, never generated here.
+--
+-- * It opens no transaction. Every function takes a 'DB.Connection', as the rest of
+--   "Simplex.Chat.Store" does, so a caller composes a payment row, a purchase row, the ledger
+--   rows, an issuance and the shown-badge pointer into one @withStore@ transaction.
+module Simplex.Chat.Store.Badges
+  ( -- * Purchases and payments
+    UserBadgePurchase (..),
+    BadgeSlot (..),
+    badgeSlot,
+    createCodePayment,
+    createPurchase,
+    supersedePurchases,
+    setShownPurchase,
+    getShownPurchase,
+
+    -- * Issuances
+    NewBadgeIssuance (..),
+    createIssuance,
+
+    -- * Ledger
+    getLastBadgeLedgerEntry,
+    insertLedgerEntries,
+  )
+where
+
+import Control.Monad (forM_, unless)
+import Control.Monad.Except (ExceptT, liftEither)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Aeson as J
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as LB
+import Data.Int (Int64)
+import Data.List (isPrefixOf)
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Time.Clock (UTCTime)
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+import Simplex.Chat.Badges (BadgeCredential, BadgeMasterKey (..), BadgeType (..))
+import Simplex.Chat.Badges.Service
+  ( BadgeStatement (..),
+    StatementCreditType (..),
+    StatementDebitType (..),
+    StatementEntry (..),
+    StatementEntryType (..),
+  )
+import Simplex.Chat.Badges.Types
+  ( BadgeIssuance (..),
+    BadgeLedgerEntry (..),
+    BadgePurchaseStatus (..),
+    LedgerCreditType (..),
+    LedgerDebitType (..),
+    LedgerEntryType (..),
+  )
+import Simplex.Chat.PaymentService.Types (PaymentStatus (..))
+import Simplex.Chat.Store.Shared (StoreError (..))
+import Simplex.Messaging.Agent.Protocol (UserId)
+import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import qualified Simplex.Messaging.Crypto as C
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..))
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+#else
+import Database.SQLite.Simple (Only (..), Query, (:.) (..))
+import Database.SQLite.Simple.QQ (sql)
+#endif
+
+-- Purchases and payments ------------------------------------------------------
+
+-- | The client's own projection of a @badge_purchases@ row: exactly its columns, with the
+-- client-only @user_id@ and @purchase_priv_key@ that the service's table does not have.
+--
+-- This is deliberately NOT 'Simplex.Chat.Badges.Types.BadgePurchase'. That record declares
+-- @priceId@, @offerId@ and @credential@, none of which is a column of this table: the price and
+-- offer of a purchase live on its @badge_invoices@ rows (one per invoice, so not a function of
+-- the purchase), and the credential lives on its @badge_issuances@ rows (one per period). A row
+-- type that had to invent three fields to be constructed would report a purchase the database
+-- does not hold. 'BadgeService.Store.BadgePurchaseRow' is the same decision on the service side.
+data UserBadgePurchase = UserBadgePurchase
+  { badgePurchaseId :: Int64,
+    userId :: UserId,
+    purchaseKey :: C.PublicKeyEd25519,
+    purchasePrivKey :: C.PrivateKeyEd25519,
+    masterKey :: BadgeMasterKey,
+    initialBadgeType :: BadgeType,
+    currentBadgeType :: BadgeType,
+    paymentId :: Maybe Text,
+    status :: BadgePurchaseStatus,
+    createdAt :: UTCTime,
+    updatedAt :: UTCTime
+  }
+  deriving (Show)
+
+-- | The badge a purchase occupies on a profile (plan §3): @paid@ for @supporter@ and @legend@,
+-- @investor@ for @investor@. It is derived from @current_badge_type@; no column stores it. At
+-- most one purchase per slot is 'PSIssued' at a time, which is what 'supersedePurchases'
+-- maintains. A badge type this build does not know keeps its own slot rather than joining
+-- @paid@: superseding a purchase because of a tag we cannot interpret would remove a badge the
+-- user paid for.
+data BadgeSlot = BSPaid | BSInvestor | BSOther Text
+  deriving (Eq, Show)
+
+badgeSlot :: BadgeType -> BadgeSlot
+badgeSlot = \case
+  BTSupporter -> BSPaid
+  BTLegend -> BSPaid
+  BTInvestor -> BSInvestor
+  BTUnknown tag -> BSOther tag
+
+-- | @payments.provider@ has no column codec yet: 'Simplex.Chat.PaymentService.Types.PaymentProvider'
+-- has no 'TextEncoding' instance, and adding one is D0\/E2\/F1's, once a second provider needs
+-- writing. Until then this literal is the client twin of
+-- 'BadgeService.Store.codePaymentProviderText' and must keep the same spelling.
+codePaymentProviderText :: Text
+codePaymentProviderText = "code"
+
+-- | The @payments@ row of a code redemption: a caller-minted UUID (the column is
+-- @TEXT NOT NULL PRIMARY KEY@ with no default), @provider = 'code'@, no invoice — a code
+-- payment never has one — and @settled@, because a redeemed code is paid for by definition.
+-- Returns the id, which 'createPurchase' takes.
+--
+-- This row is the CLIENT's and is unrelated to the service's own @payments@ row for the same
+-- redemption: the two databases share only the ledger entries, and even there the client's
+-- @payment_id@ is NULL (see 'insertLedgerEntries').
+createCodePayment :: DB.Connection -> UTCTime -> IO Text
+createCodePayment db now = do
+  paymentId <- UUID.toText <$> UUID.nextRandom
+  DB.execute
+    db
+    [sql|
+      INSERT INTO payments (payment_id, invoice_id, provider, status, created_at, updated_at)
+      VALUES (?,?,?,?,?,?)
+    |]
+    (paymentId, Nothing :: Maybe Text, codePaymentProviderText, PSSettled, now, now)
+  pure paymentId
+
+-- | The purchase row of a code redemption, written on success only: a code redemption does not
+-- learn its badge type until the response arrives, and @initial_badge_type@\/@current_badge_type@
+-- are both NOT NULL with no default. Nothing is persisted before the send; a response lost in
+-- flight is recovered with @codes unredeem@, not by reusing a stored key.
+--
+-- The status is 'PSIssued' directly, not 'PSAcquiring': the credential is in hand by the time
+-- this runs.
+createPurchase :: DB.Connection -> UserId -> C.PublicKeyEd25519 -> C.PrivateKeyEd25519 -> BadgeMasterKey -> BadgeType -> Text -> UTCTime -> IO UserBadgePurchase
+createPurchase db userId purchaseKey purchasePrivKey masterKey@(BadgeMasterKey mk) badgeType paymentId now = do
+  [Only badgePurchaseId] <-
+    DB.query
+      db
+      [sql|
+        INSERT INTO badge_purchases
+          (user_id, purchase_key, purchase_priv_key, master_key, initial_badge_type, current_badge_type, payment_id, status, created_at, updated_at)
+        VALUES (?,?,?,?,?,?,?,?,?,?)
+        RETURNING badge_purchase_id
+      |]
+      ((userId, purchaseKey, purchasePrivKey, Binary mk, badgeType, badgeType, paymentId) :. (PSIssued, now, now))
+  pure
+    UserBadgePurchase
+      { badgePurchaseId,
+        userId,
+        purchaseKey,
+        purchasePrivKey,
+        masterKey,
+        initialBadgeType = badgeType,
+        currentBadgeType = badgeType,
+        paymentId = Just paymentId,
+        status = PSIssued,
+        createdAt = now,
+        updatedAt = now
+      }
+
+-- | Moves every OTHER 'PSIssued' purchase of the same slot for this user to 'PSSuperseded', so
+-- the slot has exactly one issued purchase again. The superseded row keeps its unconsumed
+-- months: purchases are unlinkable, so the service cannot move a balance between them.
+--
+-- The slot filter is applied in Haskell rather than as a SQL @IN@ over the slot's badge types:
+-- @IN ?@ with a list is postgresql-simple's 'Database.PostgreSQL.Simple.In', which
+-- sqlite-simple has no counterpart for, and a user holds at most a handful of purchases.
+supersedePurchases :: DB.Connection -> UserId -> Int64 -> BadgeType -> UTCTime -> IO ()
+supersedePurchases db userId keepPurchaseId badgeType now = do
+  rows <-
+    DB.query
+      db
+      "SELECT badge_purchase_id, current_badge_type FROM badge_purchases WHERE user_id = ? AND status = ? AND badge_purchase_id <> ?"
+      (userId, PSIssued, keepPurchaseId)
+  let slot = badgeSlot badgeType
+      superseded = [pId | (pId :: Int64, bt) <- rows, badgeSlot bt == slot]
+  forM_ superseded $ \pId ->
+    DB.execute
+      db
+      "UPDATE badge_purchases SET status = ?, updated_at = ? WHERE badge_purchase_id = ?"
+      (PSSuperseded, now, pId)
+
+-- | Points @users.shown_badge_id@ at a purchase. Separate from
+-- 'Simplex.Chat.Store.Profiles.setUserBadge', which writes the profile's badge columns: this
+-- one records WHICH purchase the profile's badge came from, which is what
+-- 'getShownPurchase' reads back to sign the next @issueBadge@.
+setShownPurchase :: DB.Connection -> UserId -> Int64 -> IO ()
+setShownPurchase db userId badgePurchaseId =
+  DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (badgePurchaseId, userId)
+
+purchaseSelectColumns :: Query
+purchaseSelectColumns =
+  "p.badge_purchase_id, p.user_id, p.purchase_key, p.purchase_priv_key, p.master_key, "
+    <> "p.initial_badge_type, p.current_badge_type, p.payment_id, p.status, p.created_at, p.updated_at"
+
+type PurchaseRow =
+  (Int64, Maybe UserId, C.PublicKeyEd25519, Maybe C.PrivateKeyEd25519, Binary ByteString)
+    :. (BadgeType, BadgeType, Maybe Text, BadgePurchaseStatus, UTCTime, UTCTime)
+
+-- | @user_id@ and @purchase_priv_key@ are nullable only because @20260731_user_badges@ adds them
+-- with @ALTER TABLE@, which cannot add a NOT NULL column without a default. 'createPurchase' is
+-- the only writer and always sets both, so a NULL is a corrupt row and is named as one rather
+-- than being turned into a purchase whose key is missing — the private key is the whole point of
+-- reading this row back.
+rowToPurchase :: PurchaseRow -> Either StoreError UserBadgePurchase
+rowToPurchase ((badgePurchaseId, userId_, purchaseKey, purchasePrivKey_, Binary mk) :. (initialBadgeType, currentBadgeType, paymentId, status, createdAt, updatedAt)) =
+  case (userId_, purchasePrivKey_) of
+    (Just userId, Just purchasePrivKey) ->
+      Right
+        UserBadgePurchase
+          { badgePurchaseId,
+            userId,
+            purchaseKey,
+            purchasePrivKey,
+            masterKey = BadgeMasterKey mk,
+            initialBadgeType,
+            currentBadgeType,
+            paymentId,
+            status,
+            createdAt,
+            updatedAt
+          }
+    _ ->
+      Left . SEInternalError $
+        "badge purchase " <> show badgePurchaseId <> " has no user_id or purchase_priv_key"
+
+-- | The purchase @users.shown_badge_id@ points at, with its keypair and badge master key —
+-- what the badge screen renders and what the worker signs @issueBadge@ with. 'Nothing' when the
+-- user has no badge, which is the ordinary case.
+getShownPurchase :: DB.Connection -> UserId -> ExceptT StoreError IO (Maybe UserBadgePurchase)
+getShownPurchase db userId = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        ( "SELECT "
+            <> purchaseSelectColumns
+            <> " FROM badge_purchases p JOIN users u ON u.shown_badge_id = p.badge_purchase_id WHERE u.user_id = ?"
+        )
+        (Only userId)
+  liftEither $ mapM rowToPurchase (listToMaybe rows)
+
+-- Issuances -------------------------------------------------------------------
+
+-- | Fields for one @badge_issuances@ row. As on the service side, the period and expiry are
+-- definite here, matching the NOT NULL columns; 'BadgeIssuance' declares them 'Maybe' only
+-- because it is also a wire shape.
+data NewBadgeIssuance = NewBadgeIssuance
+  { badgePurchaseId :: Int64,
+    badgeType :: BadgeType,
+    periodStart :: UTCTime,
+    periodEnd :: UTCTime,
+    expiry :: UTCTime,
+    -- | The @badge_ledger.entry_id@ this issuance was debited by, when the caller has it.
+    -- Named apart from 'BadgeIssuance'\'s @entryId@ (the same column) so the two do not collide
+    -- as bare selectors under @DuplicateRecordFields@.
+    ledgerEntryId :: Maybe Int64,
+    credential :: BadgeCredential
+  }
+
+-- | Writes one issuance, minting its @issuance_id@ (the column is @TEXT NOT NULL PRIMARY KEY@
+-- with no default). One row per period: the worker calls this again for each new period, so a
+-- purchase accumulates issuances rather than replacing one.
+--
+-- The credential is stored as its own JSON encoding, the same one it crosses the wire in, so
+-- there is no second, database-only codec for it to drift from.
+createIssuance :: DB.Connection -> NewBadgeIssuance -> UTCTime -> IO BadgeIssuance
+createIssuance db NewBadgeIssuance {badgePurchaseId, badgeType, periodStart, periodEnd, expiry, ledgerEntryId, credential} now = do
+  issuanceId <- UUID.toText <$> UUID.nextRandom
+  DB.execute
+    db
+    [sql|
+      INSERT INTO badge_issuances
+        (issuance_id, badge_purchase_id, entry_id, badge_type, period_start, period_end, expiry, credential, created_at)
+      VALUES (?,?,?,?,?,?,?,?,?)
+    |]
+    (issuanceId, badgePurchaseId, ledgerEntryId, badgeType, periodStart, periodEnd, expiry, Binary (LB.toStrict (J.encode credential)), now)
+  pure
+    BadgeIssuance
+      { issuanceId,
+        badgePurchaseId,
+        badgeType,
+        periodStart = Just periodStart,
+        periodEnd = Just periodEnd,
+        expiry = Just expiry,
+        entryId = ledgerEntryId,
+        credential,
+        createdAt = now
+      }
+
+-- Ledger ----------------------------------------------------------------------
+
+-- | @entry_type, entry_credit_type, entry_debit_type, payment_id, charge_id, from_purchase_id,
+-- to_purchase_id, entry_type_unknown, entry_type_value@.
+--
+-- The first seven are 'BadgeService.Store.LedgerTypeRow' exactly, spelling for spelling. The
+-- last two are the client-only fallback columns @20260731_user_badges@ adds: a service ahead of
+-- this build can send an entry type this build has no constructor for, and the client stores it
+-- as received so a later version can decode it (docs\/protocol\/badges-rpc.md: "An unknown type
+-- is stored as received and decoded after an app upgrade"). The service, authoring every entry
+-- it writes, never needs them and its table does not have them.
+type LedgerTypeRow = (Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, Maybe Int64, Maybe Int64, BoolInt, Maybe Text)
+
+type LedgerCoreRow = (Int64, Text, Int64, Int, Int, UTCTime, BadgeType, Maybe UTCTime, UTCTime, UTCTime)
+
+ledgerSelectColumns :: Query
+ledgerSelectColumns =
+  "entry_id, entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_badge_type, was_paused_since, service_created_at, created_at, "
+    <> "entry_type, entry_credit_type, entry_debit_type, payment_id, charge_id, from_purchase_id, to_purchase_id, entry_type_unknown, entry_type_value"
+
+-- | The wire entry type as the client stores it: the inverse of
+-- 'BadgeService.Service.statementEntryType'.
+--
+-- @payment@ becomes @'CTPayment' 'Nothing'@ and the wire's @invoiceId@ is DROPPED, which is not
+-- a loss of information the client can hold: @badge_ledger.payment_id@ references @payments@,
+-- and a code redemption writes no client @payments@ row for the SERVICE's payment — that row
+-- exists only in the service database, and the wire carries no id for it. Inventing one would
+-- make the column a dangling reference (plan §9, and §10's cross-database invariant, which
+-- excludes @payment_id@ for exactly this reason).
+--
+-- @charge@, @transferIn@, @upgrade@ and @transferOut@ are refused, matching
+-- 'BadgeService.Service.statementEntryType', which refuses to put any of them on the wire in the
+-- first place, so nothing can send one. @charge@'s @chargeId@ is 'Int64' against a TEXT column
+-- (an unresolved type mismatch, plan §9) and the other three carry a purchase KEY where the
+-- column holds a purchase id; both would need a coercion this plan has not decided, and
+-- subscriptions, upgrades and transfers are out of scope (§6).
+storedEntryType :: StatementEntryType -> Either StoreError LedgerEntryType
+storedEntryType = \case
+  SECredit creditType -> LECredit <$> case creditType of
+    SCPayment {} -> Right CTPayment {paymentId = Nothing}
+    SCSupport -> Right CTSupport
+    SCOpening -> Right CTOpening
+    SCUnknown {tag, json} -> Right CTUnknown {tag, json}
+    SCCharge {} -> unsupported "credit(charge)" "chargeId is Int64 against the charge_id TEXT column; subscriptions are out of scope"
+    SCTransferIn {} -> unsupported "credit(transferIn)" "carries a purchase key where from_purchase_id holds a purchase id; transfers are out of scope"
+  SEDebit debitType -> LEDebit <$> case debitType of
+    SDRefund -> Right DTRefund
+    SDSupport -> Right DTSupport
+    SDBadge -> Right DTBadge
+    SDLapse -> Right DTLapse
+    SDUnknown {tag, json} -> Right DTUnknown {tag, json}
+    SDUpgrade {} -> unsupported "debit(upgrade)" "carries a purchase key where to_purchase_id holds a purchase id; upgrades are out of scope"
+    SDTransferOut {} -> unsupported "debit(transferOut)" "carries a purchase key where to_purchase_id holds a purchase id; transfers are out of scope"
+  where
+    unsupported what why = Left . SEInternalError $ "cannot store badge ledger " <> what <> ": " <> why
+
+-- | Known tags are spelled exactly as 'BadgeService.Store.encodeLedgerEntryType' spells them —
+-- the two stores write the same columns of the same schema, and the service reads back what it
+-- wrote. An unknown tag keeps its own spelling in @entry_credit_type@\/@entry_debit_type@ and
+-- its whole object in @entry_type_value@, flagged by @entry_type_unknown@, which is what makes
+-- 'decodeLedgerEntryType' able to hand it back unchanged after an upgrade.
+encodeLedgerEntryType :: LedgerEntryType -> Either StoreError LedgerTypeRow
+encodeLedgerEntryType = \case
+  LECredit creditType -> case creditType of
+    CTPayment {paymentId} -> Right ("credit", Just "payment", Nothing, paymentId, Nothing, Nothing, Nothing, BI False, Nothing)
+    CTSupport -> Right ("credit", Just "support", Nothing, Nothing, Nothing, Nothing, Nothing, BI False, Nothing)
+    CTTransferIn {fromPurchaseId} -> Right ("credit", Just "transfer_in", Nothing, Nothing, Nothing, fromPurchaseId, Nothing, BI False, Nothing)
+    CTOpening -> Right ("credit", Just "opening", Nothing, Nothing, Nothing, Nothing, Nothing, BI False, Nothing)
+    CTUnknown {tag, json} -> Right ("credit", Just tag, Nothing, Nothing, Nothing, Nothing, Nothing, BI True, Just (encodeUnknown json))
+    CTCharge {} -> Left $ SEInternalError "cannot store badge ledger credit(charge): chargeId is Int64 against the charge_id TEXT column"
+  LEDebit debitType -> case debitType of
+    DTRefund -> Right ("debit", Nothing, Just "refund", Nothing, Nothing, Nothing, Nothing, BI False, Nothing)
+    DTUpgrade {toPurchaseId} -> Right ("debit", Nothing, Just "upgrade", Nothing, Nothing, Nothing, Just toPurchaseId, BI False, Nothing)
+    DTTransferOut {toPurchaseId} -> Right ("debit", Nothing, Just "transfer_out", Nothing, Nothing, Nothing, Just toPurchaseId, BI False, Nothing)
+    DTSupport -> Right ("debit", Nothing, Just "support", Nothing, Nothing, Nothing, Nothing, BI False, Nothing)
+    DTBadge -> Right ("debit", Nothing, Just "badge", Nothing, Nothing, Nothing, Nothing, BI False, Nothing)
+    DTLapse -> Right ("debit", Nothing, Just "lapse", Nothing, Nothing, Nothing, Nothing, BI False, Nothing)
+    DTUnknown {tag, json} -> Right ("debit", Nothing, Just tag, Nothing, Nothing, Nothing, Nothing, BI True, Just (encodeUnknown json))
+
+-- | @entry_type_value@ holds the entry type's whole JSON object, including its own @type@ key,
+-- because that object is what 'Simplex.Chat.Badges.Service.SCUnknown' re-encodes verbatim. The
+-- column is TEXT and aeson emits UTF-8, so it round-trips through 'decodeUnknown'.
+encodeUnknown :: J.Object -> Text
+encodeUnknown = decodeUtf8 . LB.toStrict . J.encode . J.Object
+
+decodeUnknown :: Text -> Maybe J.Object
+decodeUnknown = J.decodeStrict . encodeUtf8
+
+-- | Reads back what 'encodeLedgerEntryType' wrote. The unknown flag is checked FIRST: a service
+-- ahead of this build could use a tag this build later learns, and the flag records what this
+-- row actually was when it was stored.
+decodeLedgerEntryType :: LedgerTypeRow -> Either StoreError LedgerEntryType
+decodeLedgerEntryType row = case row of
+  ("credit", Just tag, _, _, _, _, _, BI True, Just v) -> unknownCredit tag v
+  ("debit", _, Just tag, _, _, _, _, BI True, Just v) -> unknownDebit tag v
+  -- payment_id is read whether or not it is there: a client-written entry always holds NULL.
+  ("credit", Just "payment", _, paymentId, _, _, _, _, _) -> Right $ LECredit CTPayment {paymentId}
+  ("credit", Just "support", _, _, _, _, _, _, _) -> Right $ LECredit CTSupport
+  ("credit", Just "transfer_in", _, _, _, fromPurchaseId, _, _, _) -> Right $ LECredit CTTransferIn {fromPurchaseId}
+  ("credit", Just "opening", _, _, _, _, _, _, _) -> Right $ LECredit CTOpening
+  ("debit", _, Just "refund", _, _, _, _, _, _) -> Right $ LEDebit DTRefund
+  ("debit", _, Just "upgrade", _, _, _, Just toPurchaseId, _, _) -> Right $ LEDebit DTUpgrade {toPurchaseId}
+  ("debit", _, Just "transfer_out", _, _, _, Just toPurchaseId, _, _) -> Right $ LEDebit DTTransferOut {toPurchaseId}
+  ("debit", _, Just "support", _, _, _, _, _, _) -> Right $ LEDebit DTSupport
+  ("debit", _, Just "badge", _, _, _, _, _, _) -> Right $ LEDebit DTBadge
+  ("debit", _, Just "lapse", _, _, _, _, _, _) -> Right $ LEDebit DTLapse
+  (entryType, creditType, debitType, _, _, _, _, BI unknown, _) ->
+    Left . SEInternalError $
+      "malformed badge ledger entry type row: " <> show (entryType, creditType, debitType, unknown)
+  where
+    unknownCredit tag v = maybe (badValue tag) (\json -> Right $ LECredit CTUnknown {tag, json}) (decodeUnknown v)
+    unknownDebit tag v = maybe (badValue tag) (\json -> Right $ LEDebit DTUnknown {tag, json}) (decodeUnknown v)
+    badValue tag = Left . SEInternalError $ "badge ledger entry_type_value is not a JSON object, tag: " <> T.unpack tag
+
+rowToLedgerEntry :: (LedgerCoreRow :. LedgerTypeRow) -> Either StoreError BadgeLedgerEntry
+rowToLedgerEntry ((entryId, entryUuid, badgePurchaseId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, serviceCreatedAt, createdAt) :. typeRow) = do
+  entryType <- decodeLedgerEntryType typeRow
+  Right BadgeLedgerEntry {entryId, entryUuid, badgePurchaseId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, serviceCreatedAt, createdAt, entryType}
+
+-- | The purchase's last entry: its @balanceMonths@ and @balanceStartTs@ are the balance the
+-- client believes it holds, which is what the worker asserts to the service and what the badge
+-- screen's paid-through date is computed from. Ordered by @entry_id@, which is the order
+-- 'insertLedgerEntries' wrote the statement in.
+getLastBadgeLedgerEntry :: DB.Connection -> Int64 -> ExceptT StoreError IO (Maybe BadgeLedgerEntry)
+getLastBadgeLedgerEntry db badgePurchaseId = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        ("SELECT " <> ledgerSelectColumns <> " FROM badge_ledger WHERE badge_purchase_id = ? ORDER BY entry_id DESC LIMIT 1")
+        (Only badgePurchaseId)
+  liftEither $ mapM rowToLedgerEntry (listToMaybe rows)
+
+-- | Copies a statement's entries into the client's replica of the service's ledger.
+--
+-- __Order is carried only by array position.__ Every entry the service writes for one command
+-- gets an identical @createdAt@, and @serviceCreatedAt@ is not on the wire at all, so
+-- @statement.entries@ is inserted in the order given and @entry_id@ (the local autoincrement) is
+-- the only thing that records it. Sorting by any timestamp would silently scramble the ledger.
+--
+-- __@previousEntryId@ decides REPLACE against APPEND.__ Present, it names an entry the client
+-- already holds and the entries attach after it; absent with entries present, the entries
+-- "attach to nothing" (docs\/protocol\/badges-rpc.md) — they are the COMPLETE ledger for this
+-- purchase, and anything the client holds that the statement does not carry is stale and is
+-- deleted. Appending on an absent @previousEntryId@ would leave a client that had healed or
+-- reset holding rows the service no longer has. A statement with no entries at all changes
+-- nothing either way: it attaches nothing and is not a claim that the ledger is empty.
+--
+-- REPLACE is expressed as "delete what the statement does not carry, then insert what it does",
+-- not as a wipe-and-rewrite, so rows the service is merely re-sending keep their local
+-- @entry_id@ — @badge_issuances.entry_id@ references them. When the surviving rows are not a
+-- prefix of the delivered entries (a ledger the service rewrote rather than extended) they are
+-- all dropped instead, so the re-inserted entries cannot end up out of order.
+--
+-- __Re-delivery is normal, not exceptional.__ @purchaseBadge@ and @getBadgeCatalog@ return the
+-- complete history every time; only @issueBadge@ honours a cursor. Insertion is therefore
+-- @ON CONFLICT (entry_uuid) DO NOTHING@ against @idx_badge_ledger_uuid@ — a second delivery of
+-- the same statement writes nothing and changes nothing, rather than merely not crashing.
+insertLedgerEntries :: DB.Connection -> Int64 -> BadgeStatement -> UTCTime -> ExceptT StoreError IO ()
+insertLedgerEntries db badgePurchaseId BadgeStatement {entries, previousEntryId} now = do
+  rows <- liftEither $ mapM entryRow entries
+  liftIO $ do
+    case previousEntryId of
+      Just _ -> pure ()
+      Nothing -> unless (null entries) $ dropStaleEntries (map statementEntryId entries)
+    forM_ rows $ \row ->
+      DB.execute
+        db
+        [sql|
+          INSERT INTO badge_ledger
+            (entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_badge_type, was_paused_since, service_created_at, created_at,
+             entry_type, entry_credit_type, entry_debit_type, payment_id, charge_id, from_purchase_id, to_purchase_id, entry_type_unknown, entry_type_value)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+          ON CONFLICT (entry_uuid) DO NOTHING
+        |]
+        row
+  where
+    statementEntryId StatementEntry {entryId} = entryId
+    -- service_created_at is the service's own clock, which the wire reports as the entry's
+    -- createdAt; created_at is this client's, i.e. when the row was replicated. Keeping them
+    -- apart is what lets the two databases be compared on the service's timestamp.
+    entryRow StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, createdAt, entryType} = do
+      typeRow <- encodeLedgerEntryType =<< storedEntryType entryType
+      Right $
+        (entryId, badgePurchaseId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, createdAt, now)
+          :. typeRow
+    dropStaleEntries uuids = do
+      held <-
+        map fromOnly
+          <$> DB.query
+            db
+            "SELECT entry_uuid FROM badge_ledger WHERE badge_purchase_id = ? ORDER BY entry_id ASC"
+            (Only badgePurchaseId)
+      let kept = filter (`elem` uuids) held
+          stale
+            | kept `isPrefixOf` uuids = filter (`notElem` uuids) held
+            | otherwise = held
+      forM_ stale $ \entryUuid ->
+        DB.execute db "DELETE FROM badge_ledger WHERE badge_purchase_id = ? AND entry_uuid = ?" (badgePurchaseId, entryUuid)