core: badge service store layer

apps/simplex-badge-service/src/BadgeService/Store.hs

@@ -0,0 +1,727 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | Queries over the badge service's own tables: purchases, payments, the ledger, issuances,
+-- redemption codes and the price catalog. Structured after
+-- "Directory.Store"\/"Directory.Store.Migrate": every function here takes a 'DB.Connection'
+-- and opens no transaction of its own; 'withServiceTransaction' is the only place a
+-- transaction is opened, which is what lets a later step compose a purchase row, a payment
+-- row, several ledger entries, an issuance and a code redemption into one atomic transaction.
+--
+-- The order, invoice and provider-event functions belong to D0. This module owns everything
+-- the RPC path needs on top of that: purchases and payments, the ledger, issuances, codes
+-- and the catalog. There is no store function that resolves an order to a code or a purchase
+-- -- that join does not exist in the schema (docs/protocol/badges-web.md §3 Linkage); a
+-- caller that needs it derives the code from the order id and looks it up by hash with
+-- 'getCodeByHash'.
+module BadgeService.Store
+  ( ServiceError (..),
+    withServiceTransaction,
+
+    -- * Purchases and payments
+    BadgePurchaseRow (..),
+    getPurchaseByKey,
+    createPurchase,
+    createCodePayment,
+
+    -- * Ledger
+    getLastLedgerEntry,
+    appendLedgerEntry,
+    getLedgerSince,
+
+    -- * Issuances
+    NewIssuance (..),
+    getIssuanceForPeriod,
+    getIssuanceForRedeemedCode,
+    createIssuance,
+
+    -- * Codes
+    BadgeCode (..),
+    NewBadgeCode (..),
+    getCodeByHash,
+    markCodeRedeemed,
+    unredeemCode,
+    insertCodes,
+    revokeCode,
+    revokeBatch,
+
+    -- * Catalog
+    getActiveCatalog,
+    getPriceById,
+    getOfferById,
+    setPriceStatus,
+    setOfferStatus,
+  )
+where
+
+import qualified Control.Exception as E
+import Control.Monad (when)
+import Control.Monad.Except (ExceptT, liftEither, runExceptT, throwError)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Aeson as J
+import qualified Data.ByteString.Lazy as BL
+import Data.ByteString (ByteString)
+import Data.Int (Int64)
+import Data.Maybe (listToMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime)
+import Data.Word (Word32, Word8)
+import Simplex.Chat.Badges (BadgeCredential (..), BadgeMasterKey (..), BadgeType (..))
+import Simplex.Chat.Badges.Service (BadgeCatalog (..), BadgeOffer (..), BadgePrice (..))
+import Simplex.Chat.Badges.Types
+  ( BadgeIssuance (..),
+    BadgeItemStatus (..),
+    BadgeLedgerEntry (..),
+    BadgeOfferId (..),
+    BadgePriceId (..),
+    BadgePurchaseStatus (..),
+    LedgerCreditType (..),
+    LedgerDebitType (..),
+    LedgerEntryType (..),
+    OfferDiscount (..),
+  )
+import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), PaymentStatus (..))
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
+import Simplex.Messaging.Agent.Store.DB (Binary (..))
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Util (tshow)
+#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
+
+-- | The error type of every store function: not-found (a lookup targeted by a mutation
+-- doesn't exist), conflict (a write would clobber state a caller didn't expect to overwrite)
+-- and decode failures (a row can't be reconstructed into its Haskell shape).
+data ServiceError
+  = SEPurchaseNotFound
+  | SECodeNotFound
+  | SEPriceNotFound
+  | SEOfferNotFound
+  | -- | 'createCodePayment' only: the purchase already has a payment attached.
+    SEPaymentConflict
+  | SEDecodeError Text
+  deriving (Eq, Show)
+
+-- | Thrown internally to force a real rollback out of 'withTransaction': postgresql-simple\/
+-- sqlite-simple commit on a normal return and only roll back on an exception, so a plain
+-- @'Left' e@ returned from the wrapped action would otherwise be committed along with
+-- whatever it already wrote. Never leaves this module.
+newtype ServiceRollback = ServiceRollback ServiceError
+
+instance Show ServiceRollback where
+  show (ServiceRollback e) = "ServiceRollback " <> show e
+
+instance E.Exception ServiceRollback
+
+-- | The only place a transaction is opened. Every store function above takes a
+-- 'DB.Connection' and opens none of its own, so a command handler can sequence several of
+-- them here and get one transaction: a 'Left' rolls back everything the action already wrote.
+withServiceTransaction :: DBStore -> (DB.Connection -> ExceptT ServiceError IO a) -> IO (Either ServiceError a)
+withServiceTransaction st action =
+  (Right <$> withTransaction st runInTransaction) `E.catch` \(ServiceRollback e) -> pure (Left e)
+  where
+    runInTransaction db =
+      runExceptT (action db) >>= \case
+        Left e -> E.throwIO (ServiceRollback e)
+        Right a -> pure a
+
+-- Purchases and payments -----------------------------------------------------
+
+-- | The service's own projection of a @badge_purchases@ row. The shared 'Types.BadgePurchase'
+-- carries client-only columns (@user_id@, @purchase_priv_key@, alert bookkeeping) that only
+-- exist on the client's own table (added by the client-only @20260731_user_badges@
+-- migration); the service's table has just the columns 'badgeSchema' creates.
+data BadgePurchaseRow = BadgePurchaseRow
+  { badgePurchaseId :: Int64,
+    purchaseKey :: C.PublicKeyEd25519,
+    masterKey :: BadgeMasterKey,
+    initialBadgeType :: BadgeType,
+    currentBadgeType :: BadgeType,
+    paymentId :: Maybe Text,
+    status :: BadgePurchaseStatus,
+    createdAt :: UTCTime,
+    updatedAt :: UTCTime
+  }
+  deriving (Show)
+
+type PurchaseRow = (Int64, C.PublicKeyEd25519, Binary ByteString, BadgeType, BadgeType, Maybe Text, BadgePurchaseStatus, UTCTime, UTCTime)
+
+rowToPurchase :: PurchaseRow -> BadgePurchaseRow
+rowToPurchase (badgePurchaseId, purchaseKey, Binary mk, initialBadgeType, currentBadgeType, paymentId, status, createdAt, updatedAt) =
+  BadgePurchaseRow {badgePurchaseId, purchaseKey, masterKey = BadgeMasterKey mk, initialBadgeType, currentBadgeType, paymentId, status, createdAt, updatedAt}
+
+purchaseSelectColumns :: Query
+purchaseSelectColumns =
+  "badge_purchase_id, purchase_key, master_key, initial_badge_type, current_badge_type, payment_id, status, created_at, updated_at"
+
+getPurchaseByKey :: DB.Connection -> C.PublicKeyEd25519 -> ExceptT ServiceError IO (Maybe BadgePurchaseRow)
+getPurchaseByKey db purchaseKey = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        ("SELECT " <> purchaseSelectColumns <> " FROM sx_badge_service_badge_purchases WHERE purchase_key = ?")
+        (Only purchaseKey)
+  pure $ rowToPurchase <$> listToMaybe rows
+
+-- | Writes the row with status 'PSIssued' and both badge-type columns set to the same value:
+-- the service has no pre-response row, so this is the first and only write that establishes
+-- a purchase for a given key. @payment_id@ starts NULL; 'createCodePayment' attaches one
+-- later.
+createPurchase :: DB.Connection -> C.PublicKeyEd25519 -> BadgeMasterKey -> BadgeType -> UTCTime -> ExceptT ServiceError IO BadgePurchaseRow
+createPurchase db purchaseKey masterKey@(BadgeMasterKey mk) badgeType now = do
+  [Only badgePurchaseId] <-
+    liftIO $
+      DB.query
+        db
+        [sql|
+          INSERT INTO sx_badge_service_badge_purchases
+            (purchase_key, master_key, initial_badge_type, current_badge_type, status, created_at, updated_at)
+          VALUES (?,?,?,?,?,?,?)
+          RETURNING badge_purchase_id
+        |]
+        (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, now, now)
+  pure
+    BadgePurchaseRow
+      { badgePurchaseId,
+        purchaseKey,
+        masterKey,
+        initialBadgeType = badgeType,
+        currentBadgeType = badgeType,
+        paymentId = Nothing,
+        status = PSIssued,
+        createdAt = now,
+        updatedAt = now
+      }
+
+-- | The service's DB has no 'Simplex.Chat.PaymentService.Types.PaymentProvider' column codec
+-- yet (no step has needed to persist more than this one literal); D0\/E2\/F1 should add a
+-- proper 'TextEncoding' instance once a second provider needs writing from the service side.
+codePaymentProviderText :: Text
+codePaymentProviderText = "code"
+
+-- | Writes the @payments@ row (caller-minted UUID as @payment_id@, @provider = 'code'@,
+-- @invoice_id@ NULL, @status = 'settled'@ via 'PSSettled'\'s 'ToField'), then points
+-- the purchase's @payment_id@ at it. The second write is guarded by @payment_id IS NULL@ so a
+-- purchase that already has a payment is never silently repointed; on no rows affected, a
+-- follow-up existence check distinguishes an unknown purchase ('SEPurchaseNotFound') from one
+-- that already has a payment ('SEPaymentConflict').
+createCodePayment :: DB.Connection -> Int64 -> Text -> UTCTime -> ExceptT ServiceError IO ()
+createCodePayment db badgePurchaseId paymentId now = do
+  liftIO $
+    DB.execute
+      db
+      [sql|
+        INSERT INTO sx_badge_service_payments (payment_id, invoice_id, provider, status, created_at, updated_at)
+        VALUES (?,?,?,?,?,?)
+      |]
+      (paymentId, Nothing :: Maybe Text, codePaymentProviderText, PSSettled, now, now)
+  attached <-
+    liftIO $
+      DB.query
+        db
+        [sql|
+          UPDATE sx_badge_service_badge_purchases
+          SET payment_id = ?, updated_at = ?
+          WHERE badge_purchase_id = ? AND payment_id IS NULL
+          RETURNING badge_purchase_id
+        |]
+        (paymentId, now, badgePurchaseId)
+  when (null (attached :: [Only Int64])) $ do
+    exists <-
+      liftIO $
+        DB.query
+          db
+          "SELECT 1 FROM sx_badge_service_badge_purchases WHERE badge_purchase_id = ?"
+          (Only badgePurchaseId)
+    throwError $ if null (exists :: [Only Int]) then SEPurchaseNotFound else SEPaymentConflict
+
+-- Ledger ----------------------------------------------------------------------
+
+-- The service's own @badge_ledger@ table has just the columns 'badgeSchema' creates: the
+-- @entry_type_unknown@\/@entry_type_value@ fallback columns that would let 'CTUnknown'\/
+-- 'DTUnknown' round-trip only exist on the client's table (again added by the client-only
+-- @20260731_user_badges@ ALTERs). Those variants exist for a client decoding an entry type
+-- from a service ahead of it; the service, originating every entry it writes, never needs to
+-- persist one, so 'encodeLedgerEntryType' rejects them.
+
+type LedgerCoreRow = (Int64, Text, Int64, Int, Int, UTCTime, BadgeType, Maybe UTCTime, UTCTime, UTCTime)
+
+type LedgerTypeRow = (Text, Maybe Text, Maybe Text, Maybe Text, Maybe Text, Maybe Int64, Maybe Int64)
+
+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"
+
+-- | @'CTPayment' {invoiceId}@ and @'CTCharge' {chargeId}@ are typed 'Int64' in
+-- "Simplex.Chat.Badges.Types", but the columns they would persist through (@payment_id@,
+-- @charge_id@) are the referenced tables' TEXT primary keys. This is not this step's
+-- decision to paper over: it is already recorded as an open finding awaiting a human ruling
+-- (SDD progress log, Phase A: "LedgerCreditType CTPayment.invoiceId/CTCharge.chargeId left
+-- alone -- wrong against TEXT columns but marked confirmed... needs a human decision"). Both
+-- directions reject the two constructors explicitly rather than inventing a silent, possibly
+-- wrong, numeric<->text coercion.
+encodeLedgerEntryType :: LedgerEntryType -> ExceptT ServiceError IO LedgerTypeRow
+encodeLedgerEntryType = \case
+  LECredit creditType -> case creditType of
+    CTPayment {} -> throwError $ SEDecodeError "CTPayment.invoiceId (Int64) does not fit the payment_id TEXT column; unresolved type mismatch, see SDD progress log"
+    CTCharge {} -> throwError $ SEDecodeError "CTCharge.chargeId (Int64) does not fit the charge_id TEXT column; unresolved type mismatch, see SDD progress log"
+    CTSupport -> pure ("credit", Just "support", Nothing, Nothing, Nothing, Nothing, Nothing)
+    CTTransferIn {fromPurchaseId} -> pure ("credit", Just "transfer_in", Nothing, Nothing, Nothing, fromPurchaseId, Nothing)
+    CTOpening -> pure ("credit", Just "opening", Nothing, Nothing, Nothing, Nothing, Nothing)
+    CTUnknown {tag} -> throwError $ SEDecodeError ("cannot persist unknown ledger credit type: " <> tag)
+  LEDebit debitType -> case debitType of
+    DTRefund -> pure ("debit", Nothing, Just "refund", Nothing, Nothing, Nothing, Nothing)
+    DTUpgrade {toPurchaseId} -> pure ("debit", Nothing, Just "upgrade", Nothing, Nothing, Nothing, Just toPurchaseId)
+    DTTransferOut {toPurchaseId} -> pure ("debit", Nothing, Just "transfer_out", Nothing, Nothing, Nothing, Just toPurchaseId)
+    DTSupport -> pure ("debit", Nothing, Just "support", Nothing, Nothing, Nothing, Nothing)
+    DTBadge -> pure ("debit", Nothing, Just "badge", Nothing, Nothing, Nothing, Nothing)
+    DTLapse -> pure ("debit", Nothing, Just "lapse", Nothing, Nothing, Nothing, Nothing)
+    DTUnknown {tag} -> throwError $ SEDecodeError ("cannot persist unknown ledger debit type: " <> tag)
+
+decodeLedgerEntryType :: LedgerTypeRow -> Either ServiceError LedgerEntryType
+decodeLedgerEntryType row = case row of
+  ("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
+  _ -> Left $ SEDecodeError ("malformed or unsupported ledger entry type row: " <> tshow row)
+
+rowToLedgerEntry :: (LedgerCoreRow :. LedgerTypeRow) -> Either ServiceError 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}
+
+-- | Ignores the input's 'entryId' (DB-assigned via IDENTITY) and returns the entry with the
+-- assigned id filled in.
+appendLedgerEntry :: DB.Connection -> BadgeLedgerEntry -> ExceptT ServiceError IO BadgeLedgerEntry
+appendLedgerEntry db entry = do
+  let BadgeLedgerEntry {entryUuid, badgePurchaseId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, serviceCreatedAt, createdAt, entryType} = entry
+  typeRow <- encodeLedgerEntryType entryType
+  [Only newEntryId] <-
+    liftIO $
+      DB.query
+        db
+        [sql|
+          INSERT INTO sx_badge_service_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)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
+          RETURNING entry_id
+        |]
+        ((entryUuid, badgePurchaseId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, serviceCreatedAt, createdAt) :. typeRow)
+  pure BadgeLedgerEntry {entryId = newEntryId, entryUuid, badgePurchaseId, changeMonths, balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince, serviceCreatedAt, createdAt, entryType}
+
+getLastLedgerEntry :: DB.Connection -> Int64 -> ExceptT ServiceError IO (Maybe BadgeLedgerEntry)
+getLastLedgerEntry db badgePurchaseId = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        ("SELECT " <> ledgerSelectColumns <> " FROM sx_badge_service_badge_ledger WHERE badge_purchase_id = ? ORDER BY entry_id DESC LIMIT 1")
+        (Only badgePurchaseId)
+  case rows of
+    [] -> pure Nothing
+    (row : _) -> Just <$> liftEither (rowToLedgerEntry row)
+
+-- | Entries for a purchase, oldest first. @Nothing@ returns the full ledger; @Just entryId@
+-- returns only entries strictly after it, matching 'BadgeStatement.previousEntryId'\'s
+-- semantics (absent for the full ledger).
+getLedgerSince :: DB.Connection -> Int64 -> Maybe Int64 -> ExceptT ServiceError IO [BadgeLedgerEntry]
+getLedgerSince db badgePurchaseId sinceEntryId = do
+  rows <- case sinceEntryId of
+    Nothing ->
+      liftIO $
+        DB.query
+          db
+          ("SELECT " <> ledgerSelectColumns <> " FROM sx_badge_service_badge_ledger WHERE badge_purchase_id = ? ORDER BY entry_id ASC")
+          (Only badgePurchaseId)
+    Just sinceId ->
+      liftIO $
+        DB.query
+          db
+          ("SELECT " <> ledgerSelectColumns <> " FROM sx_badge_service_badge_ledger WHERE badge_purchase_id = ? AND entry_id > ? ORDER BY entry_id ASC")
+          (badgePurchaseId, sinceId)
+  liftEither $ mapM rowToLedgerEntry rows
+
+-- Issuances ---------------------------------------------------------------------
+
+-- | Fields needed to create one @badge_issuances@ row. Unlike the shared 'BadgeIssuance',
+-- @period_start@\/@period_end@\/@expiry@ are definite here, matching the NOT NULL columns;
+-- 'BadgeIssuance' declares them 'Maybe' only because that record is also the wire shape,
+-- which has no reason to require them from a client.
+data NewIssuance = NewIssuance
+  { issuanceId :: Text,
+    badgePurchaseId :: Int64,
+    badgeType :: BadgeType,
+    periodStart :: UTCTime,
+    periodEnd :: UTCTime,
+    expiry :: UTCTime,
+    -- | Named apart from 'BadgeIssuance'\'s 'entryId' (the same @entry_id@ column) so the two
+    -- don't collide as a bare selector under 'DuplicateRecordFields' at call sites that have
+    -- both types in scope.
+    ledgerEntryId :: Maybe Int64,
+    credential :: BadgeCredential
+  }
+
+type IssuanceRow = (Text, Int64, Maybe Int64, BadgeType, UTCTime, UTCTime, UTCTime, Binary ByteString, UTCTime)
+
+issuanceSelectColumns :: Query
+issuanceSelectColumns = "issuance_id, badge_purchase_id, entry_id, badge_type, period_start, period_end, expiry, credential, created_at"
+
+-- | 'BadgeCredential' already has 'J.ToJSON'\/'J.FromJSON' (it crosses the wire in
+-- 'BSPBadgeCredential'); the @credential@ BYTEA\/BLOB column stores that same JSON encoding,
+-- so a malformed row is a genuine 'SEDecodeError' rather than a second, DB-only codec.
+rowToIssuance :: IssuanceRow -> Either ServiceError BadgeIssuance
+rowToIssuance (issuanceId, badgePurchaseId, entryId, badgeType, periodStart, periodEnd, expiry, Binary credBytes, createdAt) =
+  case J.eitherDecodeStrict credBytes of
+    Left err -> Left $ SEDecodeError ("issuance " <> issuanceId <> " credential: " <> T.pack err)
+    Right credential ->
+      Right
+        BadgeIssuance
+          { issuanceId,
+            badgePurchaseId,
+            badgeType,
+            periodStart = Just periodStart,
+            periodEnd = Just periodEnd,
+            expiry = Just expiry,
+            entryId,
+            credential,
+            createdAt
+          }
+
+createIssuance :: DB.Connection -> NewIssuance -> UTCTime -> ExceptT ServiceError IO BadgeIssuance
+createIssuance db NewIssuance {issuanceId, badgePurchaseId, badgeType, periodStart, periodEnd, expiry, ledgerEntryId, credential} now = do
+  liftIO $
+    DB.execute
+      db
+      [sql|
+        INSERT INTO sx_badge_service_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 (BL.toStrict (J.encode credential)), now)
+  pure
+    BadgeIssuance
+      { issuanceId,
+        badgePurchaseId,
+        badgeType,
+        periodStart = Just periodStart,
+        periodEnd = Just periodEnd,
+        expiry = Just expiry,
+        entryId = ledgerEntryId,
+        credential,
+        createdAt = now
+      }
+
+-- | The issuance for a purchase whose period covers a given instant (half-open:
+-- @period_start <= t < period_end@).
+getIssuanceForPeriod :: DB.Connection -> Int64 -> UTCTime -> ExceptT ServiceError IO (Maybe BadgeIssuance)
+getIssuanceForPeriod db badgePurchaseId asOf = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        ("SELECT " <> issuanceSelectColumns <> " FROM sx_badge_service_badge_issuances WHERE badge_purchase_id = ? AND period_start <= ? AND period_end > ?")
+        (badgePurchaseId, asOf, asOf)
+  case rows of
+    [] -> pure Nothing
+    (row : _) -> Just <$> liftEither (rowToIssuance row)
+
+-- | code hash -> @redeemed_purchase_id@ -> the issuance whose period contains @redeemed_at@.
+-- A purchase may have several issuances by the time B7's replay path runs this, so the
+-- redemption time (not just the purchase) picks out exactly one.
+getIssuanceForRedeemedCode :: DB.Connection -> ByteString -> ExceptT ServiceError IO (Maybe BadgeIssuance)
+getIssuanceForRedeemedCode db codeHash = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        [sql|
+          SELECT i.issuance_id, i.badge_purchase_id, i.entry_id, i.badge_type, i.period_start, i.period_end, i.expiry, i.credential, i.created_at
+          FROM sx_badge_service_codes c
+          JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = c.redeemed_purchase_id
+          WHERE c.code_hash = ? AND c.redeemed_at IS NOT NULL AND i.period_start <= c.redeemed_at AND i.period_end > c.redeemed_at
+        |]
+        (Only (Binary codeHash))
+  case rows of
+    [] -> pure Nothing
+    (row : _) -> Just <$> liftEither (rowToIssuance row)
+
+-- Codes -----------------------------------------------------------------------
+
+data BadgeCode = BadgeCode
+  { codeHash :: ByteString,
+    badgeType :: BadgeType,
+    months :: Word8,
+    batch :: Text,
+    expiresAt :: UTCTime,
+    redeemedPurchaseId :: Maybe Int64,
+    redeemedAt :: Maybe UTCTime,
+    unredeemedAt :: Maybe UTCTime,
+    revokedAt :: Maybe UTCTime,
+    createdAt :: UTCTime
+  }
+  deriving (Show)
+
+-- | Fields needed to create a new, unredeemed code; 'insertCodes' is the only writer of a
+-- fresh code, so there is no representable state where a new row starts out redeemed,
+-- unredeemed-again or revoked.
+data NewBadgeCode = NewBadgeCode
+  { codeHash :: ByteString,
+    badgeType :: BadgeType,
+    months :: Word8,
+    batch :: Text,
+    expiresAt :: UTCTime
+  }
+
+type CodeRow = (Binary ByteString, BadgeType, Int, Text, UTCTime, Maybe Int64, Maybe UTCTime, Maybe UTCTime, Maybe UTCTime, UTCTime)
+
+-- | @months@ is read as a signed 'Int' and converted: see 'word8FromInt'.
+rowToCode :: CodeRow -> Either ServiceError BadgeCode
+rowToCode (Binary codeHash, badgeType, monthsInt, batch, expiresAt, redeemedPurchaseId, redeemedAt, unredeemedAt, revokedAt, createdAt) = do
+  months <- word8FromInt "code months" monthsInt
+  Right BadgeCode {codeHash, badgeType, months, batch, expiresAt, redeemedPurchaseId, redeemedAt, unredeemedAt, revokedAt, createdAt}
+
+-- | Joined to @badge_purchases@ so the caller sees the @purchase_key@ behind
+-- @redeemed_purchase_id@: a redeeming request whose own key matches is a replay of its own
+-- redemption, one whose key differs is another key trying to use an already-used code -- the
+-- two get different responses later. @Nothing@ purchase key means the code has never been
+-- redeemed.
+getCodeByHash :: DB.Connection -> ByteString -> ExceptT ServiceError IO (Maybe (BadgeCode, Maybe C.PublicKeyEd25519))
+getCodeByHash db codeHash = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        [sql|
+          SELECT c.code_hash, c.badge_type, c.months, c.batch, c.expires_at, c.redeemed_purchase_id, c.redeemed_at, c.unredeemed_at, c.revoked_at, c.created_at,
+                 p.purchase_key
+          FROM sx_badge_service_codes c
+          LEFT JOIN sx_badge_service_badge_purchases p ON p.badge_purchase_id = c.redeemed_purchase_id
+          WHERE c.code_hash = ?
+        |]
+        (Only (Binary codeHash))
+  case rows of
+    [] -> pure Nothing
+    ((codeRow :. Only redeemerKey) : _) -> do
+      code <- liftEither $ rowToCode codeRow
+      pure $ Just (code, redeemerKey)
+
+markCodeRedeemed :: DB.Connection -> ByteString -> Int64 -> UTCTime -> ExceptT ServiceError IO ()
+markCodeRedeemed db codeHash badgePurchaseId now = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        [sql|
+          UPDATE sx_badge_service_codes
+          SET redeemed_purchase_id = ?, redeemed_at = ?
+          WHERE code_hash = ?
+          RETURNING code_hash
+        |]
+        (badgePurchaseId, now, Binary codeHash)
+  when (null (rows :: [Only (Binary ByteString)])) $ throwError SECodeNotFound
+
+-- | Clears both redemption columns and sets @unredeemed_at@, which both re-enables
+-- redemption and reopens E4's disclosure window.
+unredeemCode :: DB.Connection -> ByteString -> UTCTime -> ExceptT ServiceError IO ()
+unredeemCode db codeHash now = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        [sql|
+          UPDATE sx_badge_service_codes
+          SET redeemed_purchase_id = NULL, redeemed_at = NULL, unredeemed_at = ?
+          WHERE code_hash = ?
+          RETURNING code_hash
+        |]
+        (now, Binary codeHash)
+  when (null (rows :: [Only (Binary ByteString)])) $ throwError SECodeNotFound
+
+insertCodes :: DB.Connection -> [NewBadgeCode] -> UTCTime -> ExceptT ServiceError IO ()
+insertCodes db codes now =
+  liftIO $
+    DB.executeMany
+      db
+      [sql|
+        INSERT INTO sx_badge_service_codes (code_hash, badge_type, months, batch, expires_at, created_at)
+        VALUES (?,?,?,?,?,?)
+      |]
+      (map toRow codes)
+  where
+    toRow NewBadgeCode {codeHash, badgeType, months, batch, expiresAt} = (Binary codeHash, badgeType, months, batch, expiresAt, now)
+
+revokeCode :: DB.Connection -> ByteString -> UTCTime -> ExceptT ServiceError IO ()
+revokeCode db codeHash now = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        [sql|
+          UPDATE sx_badge_service_codes
+          SET revoked_at = ?
+          WHERE code_hash = ? AND revoked_at IS NULL
+          RETURNING code_hash
+        |]
+        (now, Binary codeHash)
+  when (null (rows :: [Only (Binary ByteString)])) $ throwError SECodeNotFound
+
+-- | Sets @revoked_at@ on every unrevoked code of a batch through @idx_codes_batch@, which is
+-- what B8's @codes revoke --batch@ calls. Returns the number of codes revoked; a batch name
+-- that matches nothing (typo, already fully revoked) is not an error, just zero.
+revokeBatch :: DB.Connection -> Text -> UTCTime -> ExceptT ServiceError IO Int
+revokeBatch db batch now = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        [sql|
+          UPDATE sx_badge_service_codes
+          SET revoked_at = ?
+          WHERE batch = ? AND revoked_at IS NULL
+          RETURNING code_hash
+        |]
+        (now, batch)
+  pure $ length (rows :: [Only (Binary ByteString)])
+
+-- Catalog -----------------------------------------------------------------------
+
+-- | postgresql-simple has no 'DB.FromField' instance for any @Word*@ type (Postgres has no
+-- unsigned integer type); sqlite-simple does. Every @Word8@\/@Word32@ column here is read as
+-- a signed integer and converted, so both backends decode the same way; the range check turns
+-- a corrupt or out-of-range value into a named 'SEDecodeError' rather than a silent
+-- 'fromIntegral' wrap (the same hazard 'BadgeService.Catalog.chargeableMonths' guards against).
+word8FromInt :: Text -> Int -> Either ServiceError Word8
+word8FromInt label n
+  | n >= 0 && n <= fromIntegral (maxBound :: Word8) = Right (fromIntegral n)
+  | otherwise = Left $ SEDecodeError (label <> ": " <> tshow n <> " does not fit a Word8")
+
+word32FromInt64 :: Text -> Int64 -> Either ServiceError Word32
+word32FromInt64 label n
+  | n >= 0 && n <= fromIntegral (maxBound :: Word32) = Right (fromIntegral n)
+  | otherwise = Left $ SEDecodeError (label <> ": " <> tshow n <> " does not fit a Word32")
+
+type PriceRow = (Text, BadgeType, Int64, Text, BadgeItemStatus, UTCTime)
+
+rowToPrice :: PriceRow -> Either ServiceError BadgePrice
+rowToPrice (priceId, badgeType, monthPriceMinor, currency, status, createdAt) = do
+  monthPriceAmount <- word32FromInt64 ("price " <> priceId <> " month_price") monthPriceMinor
+  Right BadgePrice {priceId = BadgePriceId priceId, badgeType, monthPrice = CurrencyAmount monthPriceAmount, currency, status, createdAt}
+
+type OfferRow = (Text, Maybe Text, Int, Maybe Int, Maybe Int, BadgeItemStatus, UTCTime)
+
+decodeDiscount :: Text -> Maybe Word8 -> Maybe Word8 -> Either ServiceError OfferDiscount
+decodeDiscount _ (Just freeMonths) Nothing = Right (ODFreeMonths freeMonths)
+decodeDiscount _ Nothing (Just discount) = Right (ODDiscount discount)
+decodeDiscount offerId freeMonths discount =
+  Left $ SEDecodeError ("offer " <> offerId <> ": invalid free_months/discount combination: " <> tshow (freeMonths, discount))
+
+rowToOffer :: OfferRow -> Either ServiceError BadgeOffer
+rowToOffer (offerId, priceId, monthsInt, freeMonthsInt, discountPercentInt, status, createdAt) = do
+  months <- word8FromInt ("offer " <> offerId <> " months") monthsInt
+  freeMonths <- mapM (word8FromInt ("offer " <> offerId <> " free_months")) freeMonthsInt
+  discountPercent <- mapM (word8FromInt ("offer " <> offerId <> " discount")) discountPercentInt
+  discount <- decodeDiscount offerId freeMonths discountPercent
+  Right BadgeOffer {offerId = BadgeOfferId offerId, priceId = BadgePriceId <$> priceId, months, discount, status, createdAt, total = Nothing}
+
+priceSelectColumns :: Query
+priceSelectColumns = "price_id, badge_type, month_price, currency, status, created_at"
+
+offerSelectColumns :: Query
+offerSelectColumns = "offer_id, price_id, months, free_months, discount, status, created_at"
+
+-- | Prices and offers with status 'BISActive' or 'BISDeprecated'. The offers query joins to
+-- prices under the same status filter, which is what makes both guarantees hold at once: an
+-- offer with a NULL @price_id@ has nothing to join to and is dropped, and an offer pinned to
+-- a price that isn't itself active\/deprecated fails the join too. Every offer this returns
+-- therefore has a resolvable price in the same result, which is the invariant
+-- 'BadgeService.Catalog.catalogTotals' relies on to stay a total function.
+getActiveCatalog :: DB.Connection -> ExceptT ServiceError IO BadgeCatalog
+getActiveCatalog db = do
+  priceRows <-
+    liftIO $
+      DB.query
+        db
+        ("SELECT " <> priceSelectColumns <> " FROM sx_badge_service_badge_prices WHERE status IN (?,?)")
+        (BISActive, BISDeprecated)
+  offerRows <-
+    liftIO $
+      DB.query
+        db
+        [sql|
+          SELECT o.offer_id, o.price_id, o.months, o.free_months, o.discount, o.status, o.created_at
+          FROM sx_badge_service_badge_offers o
+          JOIN sx_badge_service_badge_prices p ON o.price_id = p.price_id
+          WHERE o.status IN (?,?) AND p.status IN (?,?)
+        |]
+        (BISActive, BISDeprecated, BISActive, BISDeprecated)
+  offers <- liftEither $ mapM rowToOffer offerRows
+  prices <- liftEither $ mapM rowToPrice priceRows
+  pure BadgeCatalog {prices, offers}
+
+-- | Reachable regardless of status (including 'BISDisabled'), unlike 'getActiveCatalog'.
+getPriceById :: DB.Connection -> BadgePriceId -> ExceptT ServiceError IO (Maybe BadgePrice)
+getPriceById db (BadgePriceId priceId) = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        ("SELECT " <> priceSelectColumns <> " FROM sx_badge_service_badge_prices WHERE price_id = ?")
+        (Only priceId)
+  case rows of
+    [] -> pure Nothing
+    (row : _) -> Just <$> liftEither (rowToPrice row)
+
+-- | Reachable regardless of status, same as 'getPriceById'.
+getOfferById :: DB.Connection -> BadgeOfferId -> ExceptT ServiceError IO (Maybe BadgeOffer)
+getOfferById db (BadgeOfferId offerId) = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        ("SELECT " <> offerSelectColumns <> " FROM sx_badge_service_badge_offers WHERE offer_id = ?")
+        (Only offerId)
+  case rows of
+    [] -> pure Nothing
+    (row : _) -> Just <$> liftEither (rowToOffer row)
+
+-- | One of the only two production writers of a catalog status (with 'setOfferStatus'):
+-- operators use it to deprecate a price on repricing.
+setPriceStatus :: DB.Connection -> BadgePriceId -> BadgeItemStatus -> ExceptT ServiceError IO ()
+setPriceStatus db (BadgePriceId priceId) status = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        "UPDATE sx_badge_service_badge_prices SET status = ? WHERE price_id = ? RETURNING price_id"
+        (status, priceId)
+  when (null (rows :: [Only Text])) $ throwError SEPriceNotFound
+
+setOfferStatus :: DB.Connection -> BadgeOfferId -> BadgeItemStatus -> ExceptT ServiceError IO ()
+setOfferStatus db (BadgeOfferId offerId) status = do
+  rows <-
+    liftIO $
+      DB.query
+        db
+        "UPDATE sx_badge_service_badge_offers SET status = ? WHERE offer_id = ? RETURNING offer_id"
+        (status, offerId)
+  when (null (rows :: [Only Text])) $ throwError SEOfferNotFound

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

@@ -133,7 +133,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat
 | A4 | `Catalog.hs`: internal pricing, totals, seeding | A2, A5 | ☑ |
 | A5 | Cabal dependencies for the service | — | ☑ |
 | A6 | `badge_service.ini`: configuration file | A3, A4, A5 | ☑ |
-| B1 | Store layer: purchases, ledger, issuances, codes, catalog | A2, A3, A4, A5 | ☐ |
+| B1 | Store layer: purchases, ledger, issuances, codes, catalog | A2, A3, A4, A5 | ☑ |
 | B2 | `Ledger.hs`: pure transitions and property tests | A5 | ☐ |
 | B3 | `Codes.hs`: derive, encode, hash, classify | A5, A6, B1 | ☐ |
 | B4 | Issuer key loading and credential signing | A5, A6, B2 | ☐ |

simplex-chat.cabal

@@ -420,6 +420,7 @@ executable simplex-badge-service
       BadgeService.Config
       BadgeService.Options
       BadgeService.Service
+      BadgeService.Store
       BadgeService.Store.Migrate
       Paths_simplex_chat
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -Werror=name-shadowing -threaded -rtsopts
@@ -438,6 +439,7 @@ executable simplex-badge-service
     , http-types ==0.12.*
     , ini ==0.4.1
     , memory ==0.18.*
+    , mtl >=2.3.1 && <3.0
     , optparse-applicative >=0.15 && <0.17
     , simple-logger ==0.1.*
     , simplex-chat
@@ -698,6 +700,7 @@ test-suite simplex-chat-test
       BadgeService.Config
       BadgeService.Options
       BadgeService.Service
+      BadgeService.Store
       BadgeService.Store.Migrate
       Bots.BadgeServiceTests
       Broadcast.Bot

tests/Bots/BadgeServiceTests.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Bots.BadgeServiceTests where
 
@@ -9,10 +11,12 @@ import BadgeService.Catalog (catalogTotals, defaultCatalog, offerTotal, seedCata
 import BadgeService.Config (BadgeServiceConfig (..), readBadgeServiceConfig)
 import BadgeService.Options
 import BadgeService.Service
+import BadgeService.Store
 import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Utils
 import Control.Concurrent (forkIO, killThread, threadDelay)
+import Control.Concurrent.STM (atomically)
 import Control.Exception (SomeException, evaluate, finally, try)
 import Crypto.Random (getRandomBytes)
 import qualified Data.Aeson as J
@@ -22,11 +26,20 @@ import Data.List (find, isInfixOf)
 import Data.Maybe (fromJust, isJust)
 import Data.String (fromString)
 import Data.Text (Text)
-import Data.Time.Clock (getCurrentTime)
+import Data.Time.Clock (addUTCTime, diffUTCTime, getCurrentTime, nominalDay)
 import Data.Word (Word32)
-import Simplex.Chat.Badges (BadgeType (..))
+import Simplex.Chat.Badges (BadgeMasterKey (..), BadgeType (..))
 import Simplex.Chat.Badges.Service (BadgeCatalog (..), BadgeOffer (..), BadgePrice (..))
-import Simplex.Chat.Badges.Types (BadgeItemStatus (..), BadgeOfferId (..), OfferDiscount (..))
+import Simplex.Chat.Badges.Types
+  ( BadgeItemStatus (..),
+    BadgeLedgerEntry (..),
+    BadgeOfferId (..),
+    BadgePurchaseStatus (..),
+    LedgerCreditType (..),
+    LedgerDebitType (..),
+    LedgerEntryType (..),
+    OfferDiscount (..),
+  )
 import Simplex.Chat.Controller (ChatConfig)
 import Simplex.Chat.Options (CoreChatOpts (..))
 import Simplex.Chat.Options.DB
@@ -36,6 +49,7 @@ import Simplex.Messaging.Agent.Store.Common (DBStore, withConnection)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Messaging.Agent.Store.Interface (closeDBStore, createDBStore)
 import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.BBS (BBSPublicKey (..), BBSSecretKey (..), bbsKeyGen)
 import Simplex.Messaging.Encoding.String (strEncode)
 import System.FilePath ((</>))
@@ -69,6 +83,10 @@ badgeServiceTests = do
   it "should fail to start when a provider is configured without [web]" testBadgeServiceConfigProviderRequiresWeb
   it "should start with just [issuer] and [codes], no provider section" testBadgeServiceConfigMinimalStarts
   it "should start the service from a complete config with web and both providers" testBadgeServiceCompleteConfigStarts
+  it "should create a purchase and append ledger entries readable back in order" testBadgeStorePurchaseAndLedger
+  it "should disable a price out of the active catalog while both stay reachable by id" testBadgeStoreSetPriceStatusDisabled
+  it "should return the redeeming purchase key from getCodeByHash" testBadgeStoreGetCodeByHashRedeemer
+  it "should clear both redemption columns and set unredeemed_at" testBadgeStoreUnredeemCode
 
 badgeProfile :: Profile
 badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing}
@@ -460,6 +478,150 @@ testBadgeServiceCompleteConfigStarts ps@TestParams {tmpPath} =
                  "webhook_secret_file = " <> stripeWebhookFile
                ]
 
+-- B1 store layer -------------------------------------------------------------
+
+-- A fresh, migrated badge-service database, independent of any running bot: these tests
+-- exercise BadgeService.Store directly against BadgeServiceTests' own store, the same way
+-- testBadgeServiceCatalogSeeding does.
+withFreshBadgeStore :: TestParams -> (DBStore -> IO a) -> IO a
+withFreshBadgeStore ps test = do
+  let dbOpts = toDBOpts (dbOptions $ coreOptions $ mkBadgeServiceOpts ps) chatSuffix False chatDBFunctions
+  Right st <- createDBStore dbOpts badgeServiceSchemaMigrations (MigrationConfig MCError Nothing)
+  test st `finally` closeDBStore st
+
+mkTestKeyPair :: IO (C.PublicKeyEd25519, C.PrivateKeyEd25519)
+mkTestKeyPair = do
+  drg <- C.newRandom
+  (pub, priv :: C.PrivateKeyEd25519) <- atomically $ C.generateKeyPair drg
+  pure (pub, priv)
+
+expectRight :: HasCallStack => IO (Either ServiceError a) -> IO a
+expectRight action =
+  action >>= \case
+    Right a -> pure a
+    Left e -> expectationFailure ("expected Right, got: " <> show e) >> error "unreachable"
+
+-- Creates a purchase, appends three ledger entries (an opening credit and two badge debits)
+-- and asserts getLedgerSince returns all three in ascending entry_id order with the expected
+-- changeMonths, and getLastLedgerEntry returns exactly the last one appended.
+testBadgeStorePurchaseAndLedger :: HasCallStack => TestParams -> IO ()
+testBadgeStorePurchaseAndLedger ps =
+  withFreshBadgeStore ps $ \st -> do
+    (purchaseKey, _) <- mkTestKeyPair
+    masterKey <- BadgeMasterKey <$> getRandomBytes 32
+    now <- getCurrentTime
+    BadgePurchaseRow {badgePurchaseId, status} <-
+      expectRight $ withServiceTransaction st $ \db -> createPurchase db purchaseKey masterKey BTSupporter now
+    status `shouldBe` PSIssued
+    let mkEntry changeMonths entryType balanceMonths =
+          BadgeLedgerEntry
+            { entryId = 0,
+              entryUuid = "test-entry-" <> tshow' (badgePurchaseId, changeMonths, balanceMonths),
+              badgePurchaseId,
+              changeMonths,
+              balanceMonths,
+              balanceStartTs = now,
+              balanceBadgeType = BTSupporter,
+              wasPausedSince = Nothing,
+              serviceCreatedAt = now,
+              createdAt = now,
+              entryType
+            }
+        tshow' = fromString . show
+    entry1 <- expectRight $ withServiceTransaction st $ \db -> appendLedgerEntry db (mkEntry 3 (LECredit CTOpening) 3)
+    entry2 <- expectRight $ withServiceTransaction st $ \db -> appendLedgerEntry db (mkEntry (-1) (LEDebit DTBadge) 2)
+    entry3 <- expectRight $ withServiceTransaction st $ \db -> appendLedgerEntry db (mkEntry (-1) (LEDebit DTBadge) 1)
+    entryId entry1 < entryId entry2 && entryId entry2 < entryId entry3 `shouldBe` True
+    allEntries <- expectRight $ withServiceTransaction st $ \db -> getLedgerSince db badgePurchaseId Nothing
+    map entryId allEntries `shouldBe` [entryId entry1, entryId entry2, entryId entry3]
+    map changeMonths allEntries `shouldBe` [3, -1, -1]
+    lastEntry <- expectRight $ withServiceTransaction st $ \db -> getLastLedgerEntry db badgePurchaseId
+    (entryId <$> lastEntry) `shouldBe` Just (entryId entry3)
+    sinceFirst <- expectRight $ withServiceTransaction st $ \db -> getLedgerSince db badgePurchaseId (Just (entryId entry1))
+    map entryId sinceFirst `shouldBe` [entryId entry2, entryId entry3]
+
+-- setPriceStatus BISDisabled removes the price and every offer pinned to it from
+-- getActiveCatalog, while getPriceById and getOfferById still resolve both.
+testBadgeStoreSetPriceStatusDisabled :: HasCallStack => TestParams -> IO ()
+testBadgeStoreSetPriceStatusDisabled ps =
+  withFreshBadgeStore ps $ \st -> do
+    seedCatalog st
+    BadgeCatalog {prices = seededPrices} <- expectRight $ withServiceTransaction st getActiveCatalog
+    let BadgePrice {priceId = targetPriceId} = head seededPrices
+    pinnedOfferIds <- expectRight $ withServiceTransaction st $ \db -> do
+      BadgeCatalog {offers} <- getActiveCatalog db
+      pure [offerId | BadgeOffer {offerId, priceId = Just pid} <- offers, pid == targetPriceId]
+    length pinnedOfferIds > 0 `shouldBe` True
+    _ <- expectRight $ withServiceTransaction st $ \db -> setPriceStatus db targetPriceId BISDisabled
+    BadgeCatalog {prices = pricesAfter, offers = offersAfter} <- expectRight $ withServiceTransaction st getActiveCatalog
+    any (\BadgePrice {priceId} -> priceId == targetPriceId) pricesAfter `shouldBe` False
+    any (\BadgeOffer {priceId} -> priceId == Just targetPriceId) offersAfter `shouldBe` False
+    priceStillById <- expectRight $ withServiceTransaction st $ \db -> getPriceById db targetPriceId
+    case priceStillById of
+      Just BadgePrice {status} -> status `shouldBe` BISDisabled
+      Nothing -> expectationFailure "disabled price should still resolve by id"
+    mapM_
+      ( \oid -> do
+          offerStillById <- expectRight $ withServiceTransaction st $ \db -> getOfferById db oid
+          isJust offerStillById `shouldBe` True
+      )
+      pinnedOfferIds
+
+-- Inserts a code, marks it redeemed by one purchase's key, and asserts getCodeByHash returns
+-- that same purchase key alongside the code row.
+testBadgeStoreGetCodeByHashRedeemer :: HasCallStack => TestParams -> IO ()
+testBadgeStoreGetCodeByHashRedeemer ps =
+  withFreshBadgeStore ps $ \st -> do
+    (purchaseKey, _) <- mkTestKeyPair
+    masterKey <- BadgeMasterKey <$> getRandomBytes 32
+    now <- getCurrentTime
+    BadgePurchaseRow {badgePurchaseId} <-
+      expectRight $ withServiceTransaction st $ \db -> createPurchase db purchaseKey masterKey BTSupporter now
+    codeHash <- getRandomBytes 32
+    let expiresAt = addUTCTime (30 * nominalDay) now
+        newCode = NewBadgeCode {codeHash, badgeType = BTSupporter, months = 3, batch = "test-batch", expiresAt}
+    _ <- expectRight $ withServiceTransaction st $ \db -> insertCodes db [newCode] now
+    beforeRedeem <- expectRight $ withServiceTransaction st $ \db -> getCodeByHash db codeHash
+    case beforeRedeem of
+      Just (_, redeemer) -> redeemer `shouldBe` Nothing
+      Nothing -> expectationFailure "code should exist before redemption"
+    _ <- expectRight $ withServiceTransaction st $ \db -> markCodeRedeemed db codeHash badgePurchaseId now
+    afterRedeem <- expectRight $ withServiceTransaction st $ \db -> getCodeByHash db codeHash
+    case afterRedeem of
+      Just (BadgeCode {redeemedPurchaseId}, redeemer) -> do
+        redeemedPurchaseId `shouldBe` Just badgePurchaseId
+        redeemer `shouldBe` Just purchaseKey
+      Nothing -> expectationFailure "code should exist after redemption"
+
+-- unredeemCode clears redeemed_purchase_id and redeemed_at and sets unredeemed_at, re-opening
+-- the code for another redemption.
+testBadgeStoreUnredeemCode :: HasCallStack => TestParams -> IO ()
+testBadgeStoreUnredeemCode ps =
+  withFreshBadgeStore ps $ \st -> do
+    (purchaseKey, _) <- mkTestKeyPair
+    masterKey <- BadgeMasterKey <$> getRandomBytes 32
+    now <- getCurrentTime
+    BadgePurchaseRow {badgePurchaseId} <-
+      expectRight $ withServiceTransaction st $ \db -> createPurchase db purchaseKey masterKey BTSupporter now
+    codeHash <- getRandomBytes 32
+    let expiresAt = addUTCTime (30 * nominalDay) now
+        newCode = NewBadgeCode {codeHash, badgeType = BTSupporter, months = 3, batch = "test-batch", expiresAt}
+    _ <- expectRight $ withServiceTransaction st $ \db -> insertCodes db [newCode] now
+    _ <- expectRight $ withServiceTransaction st $ \db -> markCodeRedeemed db codeHash badgePurchaseId now
+    unredeemAt <- getCurrentTime
+    _ <- expectRight $ withServiceTransaction st $ \db -> unredeemCode db codeHash unredeemAt
+    Just (BadgeCode {redeemedPurchaseId, redeemedAt, unredeemedAt}, redeemer) <-
+      expectRight $ withServiceTransaction st $ \db -> getCodeByHash db codeHash
+    redeemedPurchaseId `shouldBe` Nothing
+    redeemedAt `shouldBe` Nothing
+    -- Postgres TIMESTAMPTZ truncates to microseconds, so an exact Haskell UTCTime round-trip
+    -- isn't guaranteed on that backend; comparing within a second confirms the column was
+    -- actually set to the given time without depending on sub-microsecond precision surviving.
+    case unredeemedAt of
+      Just storedUnredeemedAt -> abs (diffUTCTime storedUnredeemedAt unredeemAt) < 1 `shouldBe` True
+      Nothing -> expectationFailure "unredeemed_at should be set after unredeemCode"
+    redeemer `shouldBe` Nothing
+
 #if defined(dbPostgres)
 runMigrationsToRun :: DBStore -> MigrationsToRun -> IO ()
 runMigrationsToRun st = Migrations.run st Nothing