diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs new file mode 100644 index 0000000000..84dfdb636a --- /dev/null +++ b/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 diff --git a/plans/2026-08-21-badges-web-checkout.md b/plans/2026-08-21-badges-web-checkout.md index 86e9b27a38..ee245fb32c 100644 --- a/plans/2026-08-21-badges-web-checkout.md +++ b/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 | ☐ | diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 78bdb58ac9..8a01eef3a2 100644 --- a/simplex-chat.cabal +++ b/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 diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index c84e4fbad0..4b1774e7fb 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/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