dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-09-27 17:58:47 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: redeem badge codes and issue credentials

Browse Source
This commit is contained in:
shum
2026-08-27 10:28:26 +00:00
parent 05d4724d41
commit 89e9bf4be7
5 changed files with 598 additions and 119 deletions
Download Patch File Download Diff File Expand all files Collapse all files
apps/simplex-badge-service/src/BadgeService/Service.hs
+515 -87
View File
@@ -16,23 +16,46 @@ module BadgeService.Service
where
import BadgeService.Catalog (catalogTotals, seedCatalog)
import BadgeService.Config (BadgeServiceEnv (..), checkFailureBuckets, newBadgeServiceEnv, readBadgeServiceConfig, takeCatalogBucket)
import BadgeService.Ledger (LedgerState (..), advance)
import BadgeService.Codes (RedeemOutcome (..), classifyRedemption, codeHash, normalizeCode)
import BadgeService.Config
( BadgeServiceConfig (issuer),
BadgeServiceEnv (..),
IssuerConfig (issuerKeyIdx),
checkFailureBuckets,
debitFailureBuckets,
newBadgeServiceEnv,
readBadgeServiceConfig,
sweepSignerBucketsIO,
takeCatalogBucket,
)
import BadgeService.Credentials (issueSignedBadge)
import BadgeService.Ledger (LedgerState (..), advance, credit, initialLedgerState, issue)
import BadgeService.Options
import BadgeService.Store
( BadgePurchaseRow (..),
NewIssuance (..),
ServiceError (..),
appendLedgerEntry,
attachPurchasePayment,
createCodePayment,
createIssuance,
createPurchase,
getActiveCatalog,
getCodeByHash,
getIssuanceForPeriod,
getIssuanceForRedeemedCode,
getLastLedgerEntry,
getLedgerEntryIdByUuid,
getLedgerSince,
getPurchaseByKey,
markCodeRedeemed,
withServiceTransaction,
)
import BadgeService.Store.Migrate (runBadgeServiceMigrations)
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM
import Control.Exception (SomeException, catch, evaluate)
import Control.Monad.Except (ExceptT, throwError)
import Control.Monad.Except (ExceptT (..), runExceptT, throwError)
import Control.Monad.IO.Class (liftIO)
import Control.Logger.Simple
import Control.Monad
@@ -40,14 +63,17 @@ import qualified Data.Aeson as J
import qualified Data.Aeson.Types as JT
import qualified Data.ByteString.Lazy as LBS
import Data.Int (Int64)
import Data.Maybe (isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Data.Word (Word32)
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeRequest (..), BadgeType)
import Simplex.Chat.Badges.Service
( BadgeCatalog (..),
( BadgeBalance (..),
BadgeCatalog (..),
BadgeOffer (..),
BadgePrice (..),
BadgeServiceCommand (..),
@@ -55,18 +81,23 @@ import Simplex.Chat.Badges.Service
BadgeServiceRequest (..),
BadgeServiceResponse (..),
BadgeStatement (..),
BadgeUpgrade,
StatementCreditType (..),
StatementDebitType (..),
StatementEntry (..),
StatementEntryType (..),
-- 'StatementEntryType' and 'LedgerEntryType' import their constructors only: their fields
-- are both named 'credit'\/'debit' and would collide with each other and with
-- 'BadgeService.Ledger.credit', which this module calls.
StatementEntryType (SECredit, SEDebit),
minSupportedBadgeVersion,
)
import Simplex.Chat.Badges.Types
( BadgeLedgerEntry (..),
( BadgeIssuance (..),
BadgeLedgerEntry (..),
BadgeOfferId (..),
LedgerCreditType (..),
LedgerDebitType (..),
LedgerEntryType (..),
LedgerEntryType (LECredit, LEDebit),
)
import Simplex.Chat.Bot (initializeBotAddress')
import Simplex.Chat.Controller
@@ -114,16 +145,20 @@ badgeService opts cfg = do
{ preStartHook = Just $ badgePreStartHook opts env,
postStartHook = Just $ badgePostStartHook opts env
}
simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> do
-- preStartHook (badgePreStartHook) already ran and populated serviceEnv by the time this
-- callback starts (Core.hs runs it before postStartHook, which runs before this), so a
-- single read here is safe -- the value never changes again for the life of the process.
bsEnv <- atomically $ readTMVar $ serviceEnv env
forever $ do
(_, event) <- atomically . readTBQueue $ outputQ cc
case event of
Right (CEvtServiceRequest u reqId sigKey_ reqData) -> handleServiceRequest bsEnv cc u reqId sigKey_ reqData
_ -> pure ()
simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc ->
raceAny_ [processServiceEvents env cc, sweepSignerBucketsLoop env]
processServiceEvents :: ServiceState -> ChatController -> IO ()
processServiceEvents env cc = do
-- preStartHook (badgePreStartHook) already ran and populated serviceEnv by the time this
-- callback starts (Core.hs runs it before postStartHook, which runs before this), so a
-- single read here is safe -- the value never changes again for the life of the process.
bsEnv <- atomically $ readTMVar $ serviceEnv env
forever $ do
(_, event) <- atomically . readTBQueue $ outputQ cc
case event of
Right (CEvtServiceRequest u reqId sigKey_ reqData) -> handleServiceRequest bsEnv cc u reqId sigKey_ reqData
_ -> pure ()
badgeServiceCLI :: BadgeServiceOpts -> IO ()
badgeServiceCLI opts = do
@@ -142,7 +177,8 @@ badgeServiceCLI opts = do
}
raceAny_
[ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing,
processQueuedRequests env
processQueuedRequests env,
sweepSignerBucketsLoop env
]
processQueuedRequests :: ServiceState -> IO ()
@@ -153,6 +189,29 @@ processQueuedRequests env = do
(u, reqId, sigKey_, reqData) <- atomically $ readTQueue $ serviceRequestQ env
handleServiceRequest bsEnv cc u reqId sigKey_ reqData
-- | How often the per-signer failure-bucket map is swept. Ten minutes is short against the
-- hour a default bucket takes to refill and long against how often a bucket is created (only a
-- classified redemption failure creates one), so the sweep is close to free while keeping the
-- map's steady-state size well under the growth cap 'debitFailureBuckets' already guarantees.
signerBucketSweepIntervalSeconds :: Int
signerBucketSweepIntervalSeconds = 600
-- | Runs the per-signer bucket sweep on a timer, as a third arm of the service's 'raceAny_'
-- alongside the bot and (in the CLI path) the terminal. B5 built 'sweepSignerBucketsIO' and
-- left it unscheduled because nothing there could create a map entry; B7 is the first step
-- whose redemptions can fail, so it is the first that needs the sweep to actually run (plan
-- \'9). The interval is real time -- 'threadDelay', not 'BadgeServiceEnv.now' -- because it
-- schedules the sweep rather than deciding anything; the eviction itself reads the injectable
-- clock through 'sweepSignerBucketsIO', so a test proves eviction by calling that directly
-- rather than waiting on this loop.
sweepSignerBucketsLoop :: ServiceState -> IO ()
sweepSignerBucketsLoop env = do
bsEnv <- atomically $ readTMVar $ serviceEnv env
forever $ do
threadDelay $ signerBucketSweepIntervalSeconds * 1000000
evicted <- sweepSignerBucketsIO bsEnv
when (evicted > 0) $ logInfo $ "badge service swept " <> tshow evicted <> " recovered signer failure buckets"
-- Seeded here, after migrations and before badgePostStartHook starts the bot: every start
-- of the service must see the catalog before it can serve a request. B8's operator
-- subcommand (not yet implemented) will need to call seedCatalog the same way, so operator
@@ -233,8 +292,15 @@ responseObject resp = case J.toJSON resp of
errorResponse :: BadgeServiceErrorCode -> Maybe Text -> Maybe Word32 -> BadgeServiceResponse
errorResponse code message retryAfter = BSPError {code, message, retryAfter}
notImplemented :: BadgeServiceResponse
notImplemented = errorResponse BSEInternal (Just "not implemented") Nothing
badRequest :: BadgeServiceResponse
badRequest = errorResponse BSEBadRequest Nothing Nothing
-- | A store error is never repeated back to the client: it is logged with the command that
-- produced it and answered with 'internal', like every other unexpected failure.
storeFailed :: Text -> ServiceError -> IO BadgeServiceResponse
storeFailed what e = do
logError $ what <> " failed: " <> tshow e
pure $ errorResponse BSEInternal Nothing Nothing
-- | Decode, version gate, and the signer\/record precondition (RPC doc "Identity"), then
-- dispatch. Order matches badges-rpc.md and the B5 brief: a decode failure is 'bad_request'
@@ -286,39 +352,47 @@ requirePurchaseRecord BadgeServiceEnv {store} key =
-- | Dispatch on the command, once the signer\/record precondition already passed.
-- 'getBadgeInvoice', 'upgradeBadgeSubscription' and 'pauseBadge' are out of scope (decision 5
-- \/ §6) and always 'bad_request'; 'issueBadge' is B7's command and answers 'internal'
-- \"not implemented\" until that step lands. 'getBadgeCatalog' (B6) and, later, 'issueBadge'
-- are the two commands that use the 'Maybe' 'BadgePurchaseRow' 'checkSignerRecord' already
-- looked up; every other clause below ignores it.
-- \/ §6) and always 'bad_request'. 'getBadgeCatalog' (B6) and 'issueBadge' (B7) are the two
-- commands that use the 'Maybe' 'BadgePurchaseRow' 'checkSignerRecord' already looked up;
-- every other clause below ignores it.
dispatchCommand :: BadgeServiceEnv -> Maybe C.PublicKeyEd25519 -> Maybe BadgePurchaseRow -> BadgeServiceCommand -> IO BadgeServiceResponse
dispatchCommand _ _ _ (BSCGetBadgeInvoice {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
dispatchCommand _ _ _ (BSCUpgradeBadgeSubscription {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
dispatchCommand _ _ _ BSCPauseBadge = pure $ errorResponse BSEBadRequest Nothing Nothing
dispatchCommand _ _ _ (BSCGetBadgeInvoice {}) = pure badRequest
dispatchCommand _ _ _ (BSCUpgradeBadgeSubscription {}) = pure badRequest
dispatchCommand _ _ _ BSCPauseBadge = pure badRequest
dispatchCommand bsEnv _ purchaseRow BSCGetBadgeCatalog = handleGetBadgeCatalog bsEnv purchaseRow
dispatchCommand _ _ _ (BSCIssueBadge {}) = pure notImplemented
dispatchCommand bsEnv purchaseKey _ (BSCPurchaseBadge {payment}) = dispatchPurchase bsEnv purchaseKey payment
dispatchCommand bsEnv _ purchaseRow (BSCIssueBadge {badgeRequest, balance}) = case purchaseRow of
Just row -> handleIssueBadge bsEnv row badgeRequest balance
-- unreachable: 'checkSignerRecord' answers 'unknown_purchase_key' for an 'issueBadge' whose
-- key has no row, so the row is always 'Just' here; this clause only keeps the case total.
Nothing -> pure $ errorResponse BSEUnknownPurchaseKey Nothing Nothing
dispatchCommand bsEnv purchaseKey _ (BSCPurchaseBadge {badgeRequest, payment, upgrade}) =
dispatchPurchase bsEnv purchaseKey badgeRequest payment upgrade
-- | 'checkSignerRecord' already requires a signature for every 'purchaseBadge', so
-- 'purchaseKey' is 'Just' here in every reachable case; the 'Nothing' clause only keeps this
-- function total.
--
-- Only 'SPCode' is implemented (B7); the others verify store evidence or transfer a receipt,
-- both out of scope (§6), so they are 'bad_request' permanently, not \"not implemented\".
-- both out of scope (§6), so they are 'bad_request' permanently. So is a purchase carrying an
-- @upgrade@: the store one-time upgrade it proves eligibility for needs store evidence, and
-- tier upgrades are out of scope too (§6), so it is refused before the payment is even looked
-- at rather than silently ignored while the code is consumed.
--
-- The throttle (B5 decision 5) runs before 'SPCode' is processed: an empty per-signer or
-- global-failure bucket rejects the request with 'rate_limited' before it would otherwise
-- reach B7's (not yet implemented) code classifier. Neither bucket is debited here --
-- 'checkFailureBuckets' only peeks; only a classified failure debits, which is B7's job.
dispatchPurchase :: BadgeServiceEnv -> Maybe C.PublicKeyEd25519 -> ServicePayment -> IO BadgeServiceResponse
dispatchPurchase bsEnv (Just signerKey) (SPCode _code) =
-- global-failure bucket rejects the request with 'rate_limited' before it reaches the code
-- classifier. Neither bucket is debited here -- 'checkFailureBuckets' only peeks; only a
-- classified failure debits, which 'handlePurchaseCode' does.
dispatchPurchase :: BadgeServiceEnv -> Maybe C.PublicKeyEd25519 -> BadgeRequest -> ServicePayment -> Maybe BadgeUpgrade -> IO BadgeServiceResponse
dispatchPurchase _ _ _ _ (Just _) = pure badRequest
dispatchPurchase bsEnv (Just signerKey) badgeRequest (SPCode code) Nothing =
checkFailureBuckets bsEnv signerKey >>= \case
Left retryAfter -> pure $ errorResponse BSERateLimited Nothing (Just retryAfter)
Right () -> pure notImplemented
dispatchPurchase _ Nothing (SPCode _) = pure $ errorResponse BSEBadRequest Nothing Nothing
dispatchPurchase _ _ (SPApple {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
dispatchPurchase _ _ (SPGoogle {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
dispatchPurchase _ _ (SPInvoice {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
dispatchPurchase _ _ (SPReceipt {}) = pure $ errorResponse BSEBadRequest Nothing Nothing
Right () -> handlePurchaseCode bsEnv signerKey badgeRequest code
dispatchPurchase _ Nothing _ (SPCode _) Nothing = pure badRequest
dispatchPurchase _ _ _ (SPApple {}) Nothing = pure badRequest
dispatchPurchase _ _ _ (SPGoogle {}) Nothing = pure badRequest
dispatchPurchase _ _ _ (SPInvoice {}) Nothing = pure badRequest
dispatchPurchase _ _ _ (SPReceipt {}) Nothing = pure badRequest
-- getBadgeCatalog (B6) --------------------------------------------------------
@@ -361,7 +435,7 @@ handleGetBadgeCatalog bsEnv@BadgeServiceEnv {store, now} purchaseRow = case purc
-- (decision 8): the site, the RPC catalog and the charge all read this one result.
catalog <- catalogTotals <$> getActiveCatalog db
-- getBadgeCatalog carries no cursor, so this is always the full ledger (Nothing).
statement <- mapM (purchaseStatement now' db Nothing) row
statement <- mapM (\BadgePurchaseRow {badgePurchaseId} -> purchaseStatement now' db Nothing badgePurchaseId) row
pure (catalog, statement)
-- | An offer that is pinned to a price the catalog also returned, yet still has no total,
@@ -378,9 +452,20 @@ logUnpricedOffers BadgeCatalog {prices, offers} =
logWarn $ "catalog offer " <> oid <> " has a pinned price but no chargeable total"
_ -> pure ()
-- | A resolved statement cursor: the wire @entryId@ the client asserted, and the local
-- @entry_id@ it resolved to. The two travel together so 'previousEntryId' always echoes the
-- value the client actually sent, and is never spelled independently of the id the query runs
-- on. A cursor exists only when the assertion resolved to an entry of this very purchase
-- ('getLedgerEntryIdByUuid'); an assertion naming nothing yields no cursor, and the RPC's
-- other permitted answer -- the complete history -- is what follows.
data StatementCursor = StatementCursor
{ cursorEntryId :: Int64,
cursorEntryUuid :: Text
}
-- | Heals the purchase's ledger to @now@, then reads it back as a statement -- the whole
-- ledger when @sinceEntryId@ is 'Nothing', or only entries strictly after it otherwise
-- (matches 'getLedgerSince'\'s own semantics).
-- ledger when there is no cursor, or only entries strictly after it otherwise (matches
-- 'getLedgerSince'\'s own semantics).
--
-- @advance@ is run against the last stored entry's state and, when it yields months, ONE
-- @debit(lapse)@ row is written for them (B2's calling convention: one row, whatever @k@ is).
@@ -388,53 +473,42 @@ logUnpricedOffers BadgeCatalog {prices, offers} =
-- balance to lapse from -- so it returns an empty statement rather than inventing an opening
-- entry.
--
-- Takes the purchase row directly rather than a key: every caller has already looked it up
-- once (B6's 'handleGetBadgeCatalog' via 'checkSignerRecord'; B7's future 'issueBadge' the
-- same way), and looking it up again here would open a second transaction reading the same
-- row -- so there is no "signer has no purchase row" case to handle any more.
-- Called at the end of the same transaction that wrote the command's entries, so the balance a
-- client is told is always the balance the database holds; a command with nothing to write
-- calls it in a transaction of its own that then writes nothing (the heal above is the only
-- write it could make, and it makes none when @advance@ yields nothing).
--
-- @sinceEntryId@ is also threaded through rather than hardcoded, so a future cursor-carrying
-- caller (B7) can reuse this function instead of duplicating it. 'getBadgeCatalog' (B6)
-- always passes 'Nothing' -- it carries no cursor -- for which 'previousEntryId' being
-- 'Nothing' below is exactly correct (RPC: "absent for the full ledger"). 'previousEntryId'
-- is meant to echo the client's *asserted* (wire, 'Text') entryId, which this function is
-- never given, only the resolved 'Int64' to query on -- a real cursor caller needs to carry
-- that wire value through separately to fill it in for real; nothing today constructs one.
purchaseStatement :: UTCTime -> DB.Connection -> Maybe Int64 -> BadgePurchaseRow -> ExceptT ServiceError IO BadgeStatement
purchaseStatement now' db sinceEntryId BadgePurchaseRow {badgePurchaseId} = do
-- 'getBadgeCatalog' (B6) and 'purchaseBadge' (B7) pass no cursor -- neither command carries an
-- asserted entry -- for which 'previousEntryId' being 'Nothing' is exactly right (RPC: "absent
-- for the full ledger"). 'issueBadge' carries @balance.lastEntry@ and passes the cursor that
-- resolved from it.
purchaseStatement :: UTCTime -> DB.Connection -> Maybe StatementCursor -> Int64 -> ExceptT ServiceError IO BadgeStatement
purchaseStatement now' db cursor badgePurchaseId = do
healLedger now' db badgePurchaseId
entries <- mapM (liftEither' . toStatementEntry) =<< getLedgerSince db badgePurchaseId sinceEntryId
pure BadgeStatement {entries, previousEntryId = Nothing}
entries <- mapM (liftEither' . toStatementEntry) =<< getLedgerSince db badgePurchaseId (cursorEntryId <$> cursor)
pure BadgeStatement {entries, previousEntryId = cursorEntryUuid <$> cursor}
where
liftEither' = either throwError pure
-- | The lapse half of a plan on its own: @advance@ against the last stored entry, written
-- through the same 'writeLedgerPlan' every command uses, so the @debit(lapse)@ row a heal
-- appends is constructed in exactly one place. A purchase with no ledger has nothing to heal.
healLedger :: UTCTime -> DB.Connection -> Int64 -> ExceptT ServiceError IO ()
healLedger now' db badgePurchaseId =
getLastLedgerEntry db badgePurchaseId >>= \case
Nothing -> pure ()
Just BadgeLedgerEntry {balanceMonths, balanceStartTs, balanceBadgeType, wasPausedSince} ->
case advance now' LedgerState {balanceMonths, balanceStartTs, balanceBadgeType} of
Nothing -> pure ()
Just (k, LedgerState {balanceMonths = balanceMonths', balanceStartTs = balanceStartTs'}) -> do
entryUuid <- liftIO (UUID.toText <$> UUID.nextRandom)
void $
appendLedgerEntry
db
BadgeLedgerEntry
{ entryId = 0, -- assigned by the database
entryUuid,
badgePurchaseId,
changeMonths = negate k,
balanceMonths = balanceMonths',
-- the entry's balance_start_ts is the state advance left, NOT the time the
-- row was created; created_at/service_created_at carry that (B2)
balanceStartTs = balanceStartTs',
balanceBadgeType,
wasPausedSince,
serviceCreatedAt = now',
createdAt = now',
entryType = LEDebit DTLapse
}
Just entry@BadgeLedgerEntry {balanceBadgeType, wasPausedSince} ->
writeLedgerPlan
db
now'
badgePurchaseId
balanceBadgeType
LedgerPlan
{ lpLapse = advance now' (ledgerStateOf entry),
lpCredit = Nothing,
lpIssue = IssuedNone,
lpWasPausedSince = wasPausedSince
}
-- | The stored ledger row as the client sees it. 'entryId' on the wire is the row's
-- @entry_uuid@, not its @entry_id@: the uuid is what the service authors and the client
@@ -444,10 +518,10 @@ healLedger now' db badgePurchaseId =
-- Four entry types are refused rather than converted, and none of them can be reached by
-- anything in this milestone:
--
-- * @CTPayment@ and @CTCharge@ carry 'Int64' ids against @TEXT@ columns -- the unresolved
-- mismatch §9 records as needing a decision before C1. 'BadgeService.Store' already
-- refuses to read or write them, so a row of either type cannot exist; inventing a
-- numeric-to-text coercion here is exactly what that refusal exists to prevent.
-- * @CTCharge@ carries an 'Int64' id against a @TEXT@ column -- the unresolved mismatch §9
-- records. 'BadgeService.Store' already refuses to read or write it, so a row of that type
-- cannot exist; inventing a numeric-to-text coercion here is exactly what that refusal
-- exists to prevent. Subscriptions are out of scope (§6), so nothing writes one.
-- * @CTTransferIn@, @DTUpgrade@ and @DTTransferOut@ store a purchase *id* while the wire
-- types carry a purchase *key*. Converting needs an id-to-key lookup the store does not
-- expose, and transfers and upgrades are out of scope (§6), so nothing writes them.
@@ -476,7 +550,12 @@ statementEntryType = \case
CTSupport -> Right SCSupport
CTOpening -> Right SCOpening
CTUnknown {tag, json} -> Right SCUnknown {tag, json}
CTPayment {} -> unresolved "credit(payment)" "invoiceId is Int64 against a TEXT column (§9, open before C1)"
-- The stored id is the PAYMENT's, and the wire field is the INVOICE's. Every payment this
-- milestone writes is a code payment, which has no invoice at all (brief B7 step 4), so
-- 'Nothing' is the right and only answer today. An invoice-funded payment (D-phase) reaches
-- its invoice through @payments.invoice_id@, which is a join this pure function cannot do:
-- whichever step first credits one must resolve the invoice id before building the entry.
CTPayment {} -> Right SCPayment {invoiceId = Nothing}
CTCharge {} -> unresolved "credit(charge)" "chargeId is Int64 against a TEXT column (§9, open before C1)"
CTTransferIn {} -> unresolved "credit(transfer_in)" "stores a purchase id, the wire carries a purchase key; transfers are out of scope (§6)"
LEDebit debitType -> SEDebit <$> case debitType of
@@ -489,3 +568,352 @@ statementEntryType = \case
DTTransferOut {} -> unresolved "debit(transfer_out)" "stores a purchase id, the wire carries a purchase key; transfers are out of scope (§6)"
where
unresolved what why = Left $ SEDecodeError ("cannot put " <> what <> " in a statement: " <> why)
-- purchaseBadge{code} and issueBadge (B7) -------------------------------------
-- | One retry of the whole redemption. A code claimed by a concurrent request between the
-- classification and the write ('SECodeConflict') is re-classified from the top, and that
-- second pass reaches a terminal answer -- a replay for the same key, @code_used@ for another
-- -- because the code is now redeemed and cannot become unredeemed by itself.
redemptionAttempts :: Int
redemptionAttempts = 1
-- | What @issue@ (B2) says should happen, computed in memory before anything is signed or
-- written.
data IssuePlan
= -- | A period to issue: it is signed, then recorded as one @debit(badge)@ entry and one
-- issuance row. Carries the state @issue@ left, the period start and the period end.
IssuePeriod LedgerState UTCTime UTCTime
| -- | The current month is already issued -- a positive balance whose @balanceStartTs@ a
-- previous @issue@ moved past @now@. Its credential is fetched, not signed, and neither a
-- @debit(badge)@ entry nor an issuance row is written: that month's pair already exists and
-- B2's property 3 keeps them 1:1.
IssueCached
| -- | Nothing to issue: the balance is exhausted. Not an error -- the statement shows why.
IssueExhausted
-- | An 'IssuePlan' with its credential resolved.
data IssueResult
= IssuedPeriod LedgerState UTCTime UTCTime BadgeCredential
| IssuedCached BadgeCredential
| IssuedNone
issuedCredential :: IssueResult -> Maybe BadgeCredential
issuedCredential = \case
IssuedPeriod _ _ _ cred -> Just cred
IssuedCached cred -> Just cred
IssuedNone -> Nothing
-- | Every ledger row a command will append, computed with B2's pure functions before any IO
-- happens. Parameterised over the issue step so one value carries first the plan
-- (@LedgerPlan IssuePlan@) and then, once the credential is resolved, the write set
-- (@LedgerPlan IssueResult@) -- the two can never drift apart into separate values.
data LedgerPlan a = LedgerPlan
{ -- | @advance@'s @debit(lapse)@: the months lapsed and the state it left. ONE row, whatever
-- @k@ is (B2's calling convention). It belongs to the write set even when the command has
-- nothing else to write.
lpLapse :: Maybe (Int, LedgerState),
-- | The @credit(payment)@ a funded command records: the months, the entry type naming the
-- payment row it references, and the state after crediting. 'issueBadge' credits nothing.
lpCredit :: Maybe (Int, LedgerCreditType, LedgerState),
lpIssue :: a,
-- | Carried forward from the last stored entry onto every row this plan appends: it marks
-- the entry ending a pause, and pausing is out of scope (§6), so nothing here sets or
-- clears it.
lpWasPausedSince :: Maybe UTCTime
}
-- | Step 4, entirely pure: @advance@, then the command's credit if it has one, then @issue@ --
-- in that order and against one timestamp, which is B2's calling convention. Nothing here
-- touches the database, so the whole prospective state is known before a signature is asked
-- for and before a transaction is opened.
planLedger :: UTCTime -> Maybe (Int, LedgerCreditType) -> Maybe UTCTime -> LedgerState -> LedgerPlan IssuePlan
planLedger now' creditWith wasPaused st0 =
LedgerPlan {lpLapse = lapse, lpCredit = credited, lpIssue = issuePlan, lpWasPausedSince = wasPaused}
where
lapse = advance now' st0
st1 = maybe st0 snd lapse
-- 'credit' ignores the 'StatementCreditType' it takes (B2); it only names the transition,
-- and 'SCPayment Nothing' is right for every credit this step records -- a code payment has
-- no invoice (brief step 4).
credited = (\(n, creditType) -> (n, creditType, credit now' n (SCPayment Nothing) st1)) <$> creditWith
st2 = maybe st1 (\(_, _, st) -> st) credited
issuePlan = case issue now' st2 of
Just (st3, periodStart, periodEnd) -> IssuePeriod st3 periodStart periodEnd
Nothing -> case st2 of
LedgerState {balanceMonths = 0} -> IssueExhausted
_ -> IssueCached
-- | Step 5: the only IO between the pure plan and the write, and the only place a credential is
-- produced. A fresh period is SIGNED (B4); an already-issued month has its credential FETCHED;
-- an exhausted balance has none. A signing failure returns its error code with nothing written
-- at all, so a redeemed-nothing code stays retryable (brief step 5).
--
-- @badgePurchaseId_@ is 'Nothing' only for a purchase that does not exist yet, which cannot be
-- in the 'IssueCached' state -- that state needs a stored ledger entry, which needs a purchase.
resolveIssue :: BadgeServiceEnv -> UTCTime -> Maybe Int64 -> BadgeRequest -> IssuePlan -> IO (Either BadgeServiceErrorCode IssueResult)
resolveIssue BadgeServiceEnv {config = bsConfig, store, issuerKey} now' badgePurchaseId_ badgeRequest = \case
IssuePeriod st periodStart periodEnd ->
issueSignedBadge (issuerKeyIdx (issuer bsConfig)) issuerKey badgeRequest periodEnd >>= \case
Left code -> pure $ Left code
Right cred -> pure $ Right $ IssuedPeriod st periodStart periodEnd cred
IssueCached -> case badgePurchaseId_ of
Nothing -> do
logError "issue reported the current month as already issued for a purchase that does not exist"
pure $ Left BSEInternal
-- The already-issued month is the one containing @now@: the previous 'issue' set
-- 'balanceStartTs' to that period's END (> now), and its START is at or before the instant
-- that issue ran, which is at or before now. Probing at @now@ therefore names exactly that
-- period. Stepping a month back from 'balanceStartTs' would not: 'addMonths' is not
-- additive under clamping (31 Jan + 1 month = 28 Feb, and 28 Feb - 1 month = 28 Jan), so
-- from a clamped boundary it can fall short of the very period it came from and pick up the
-- issuance before it.
Just pid ->
withServiceTransaction store (\db -> getIssuanceForPeriod db pid now') >>= \case
Right (Just issuance) -> pure $ Right $ IssuedCached (issuanceCredential issuance)
Right Nothing -> do
logError $ "no badge issuance covers the already-issued period of purchase " <> tshow pid
pure $ Left BSEInternal
Left e -> do
logError $ "reading the cached badge issuance failed: " <> tshow e
pure $ Left BSEInternal
IssueExhausted -> pure $ Right IssuedNone
-- | Step 6's ledger writes, in the order the brief fixes: the @debit(lapse)@ @advance@ produced,
-- the @credit(payment)@, the @debit(badge)@, then the issuance carrying the signed credential
-- and pointing at that debit. A cached or exhausted issue writes neither of the last two.
--
-- Every entry this service appends is built here, including 'healLedger''s, so a column added
-- to 'BadgeLedgerEntry' cannot be filled correctly in one writer and forgotten in another.
writeLedgerPlan :: DB.Connection -> UTCTime -> Int64 -> BadgeType -> LedgerPlan IssueResult -> ExceptT ServiceError IO ()
writeLedgerPlan db now' pid badgeType LedgerPlan {lpLapse, lpCredit, lpIssue, lpWasPausedSince} = do
forM_ lpLapse $ \(k, st) -> void $ appendEntry (negate k) st (LEDebit DTLapse)
forM_ lpCredit $ \(n, creditType, st) -> void $ appendEntry n st (LECredit creditType)
case lpIssue of
IssuedPeriod st periodStart periodEnd cred -> do
BadgeLedgerEntry {entryId} <- appendEntry (-1) st (LEDebit DTBadge)
expiry <- either throwError pure (credentialExpiry cred)
issuanceId <- liftIO (UUID.toText <$> UUID.nextRandom)
void $
createIssuance
db
NewIssuance
{ issuanceId,
badgePurchaseId = pid,
badgeType,
periodStart,
periodEnd,
expiry,
ledgerEntryId = Just entryId,
credential = cred
}
now'
IssuedCached _ -> pure ()
IssuedNone -> pure ()
where
appendEntry changeMonths LedgerState {balanceMonths, balanceStartTs, balanceBadgeType} entryType = do
entryUuid <- liftIO (UUID.toText <$> UUID.nextRandom)
appendLedgerEntry
db
BadgeLedgerEntry
{ entryId = 0, -- assigned by the database
entryUuid,
badgePurchaseId = pid,
changeMonths,
balanceMonths,
-- the entry's balance_start_ts is the state the transition left, NOT the time the
-- row was created; created_at/service_created_at carry that (B2)
balanceStartTs,
balanceBadgeType,
wasPausedSince = lpWasPausedSince,
serviceCreatedAt = now',
createdAt = now',
entryType
}
-- | The issuance row's @expiry@, read back from the credential rather than recomputed with
-- 'sundayAfter', so the stored expiry can never disagree with the one actually signed.
-- 'issueSignedBadge' always sets it (B4), so 'Nothing' is unreachable and is refused rather
-- than defaulted -- an issuance whose expiry does not match its credential is a wrong record.
credentialExpiry :: BadgeCredential -> Either ServiceError UTCTime
credentialExpiry BadgeCredential {badgeInfo = BadgeInfo {badgeExpiry}} =
maybe (Left $ SEDecodeError "signed credential carries no badgeExpiry") Right badgeExpiry
ledgerStateOf :: BadgeLedgerEntry -> LedgerState
ledgerStateOf BadgeLedgerEntry {balanceMonths, balanceStartTs, balanceBadgeType} =
LedgerState {balanceMonths, balanceStartTs, balanceBadgeType}
-- Accessors for fields whose names several records in scope share, so they are spelled once
-- here instead of as an ambiguous bare selector at every use.
entryWasPausedSince :: BadgeLedgerEntry -> Maybe UTCTime
entryWasPausedSince BadgeLedgerEntry {wasPausedSince} = wasPausedSince
rowPurchaseId :: BadgePurchaseRow -> Int64
rowPurchaseId BadgePurchaseRow {badgePurchaseId} = badgePurchaseId
rowPaymentId :: BadgePurchaseRow -> Maybe Text
rowPaymentId BadgePurchaseRow {paymentId} = paymentId
issuanceCredential :: BadgeIssuance -> BadgeCredential
issuanceCredential BadgeIssuance {credential} = credential
requestedBadgeType :: BadgeRequest -> BadgeType
requestedBadgeType BadgeRequest {badgeInfo = BadgeInfo {badgeType}} = badgeType
requestMasterKey :: BadgeRequest -> BadgeMasterKey
requestMasterKey BadgeRequest {masterKey} = masterKey
assertedEntryId :: BadgeBalance -> Text
assertedEntryId BadgeBalance {lastEntry = StatementEntry {entryId}} = entryId
-- | Resolves the client's asserted @balance.lastEntry.entryId@ against this purchase's ledger.
-- An assertion naming an entry the service holds is a prefix and becomes the cursor; one naming
-- anything else -- an unknown uuid, or an entry belonging to a different purchase -- yields no
-- cursor, and the complete history follows, which is the other answer the RPC permits
-- ("Statement and balance"). Its third answer, one @opening@ credit restating the balance,
-- needs opening entries, which nothing in this milestone writes.
resolveCursor :: DB.Connection -> Int64 -> Text -> ExceptT ServiceError IO (Maybe StatementCursor)
resolveCursor db pid entryUuid =
fmap (\eid -> StatementCursor {cursorEntryId = eid, cursorEntryUuid = entryUuid}) <$> getLedgerEntryIdByUuid db pid entryUuid
-- | Redeems a code into a credential. The ordering is the contract, not a preference: the
-- classification reads, the plan is computed in memory, the credential is signed, and only then
-- is a transaction opened and written. Nothing is written before a signature succeeds or the
-- plan proves none is needed, so a failing signature leaves the code unredeemed and retryable.
--
-- Only a classified failure debits the throttle buckets (@code_invalid@, @code_used@,
-- @code_expired@, including a checksum rejection that never reached the database). A success
-- and the same-key replay debit nothing: they are not failures, and an honest client that
-- repeats a request after a timeout must not be throttled for it.
handlePurchaseCode :: BadgeServiceEnv -> C.PublicKeyEd25519 -> BadgeRequest -> Text -> IO BadgeServiceResponse
handlePurchaseCode bsEnv@BadgeServiceEnv {store, now} signerKey badgeRequest presentedCode = attempt redemptionAttempts
where
hash = codeHash (normalizeCode presentedCode)
attempt attemptsLeft = do
now' <- now
runExceptT (classifyRedemption now' signerKey lookupCode presentedCode) >>= \case
Left e -> storeFailed "purchaseBadge{code} classification" e
Right outcome -> case outcome of
-- a revoked code must read exactly like one that never existed (B3), so a guesser
-- cannot learn that a code once existed
RedeemInvalid -> failedRedemption BSECodeInvalid
RedeemRevoked -> failedRedemption BSECodeInvalid
RedeemUsedByOther -> failedRedemption BSECodeUsed
RedeemExpired -> failedRedemption BSECodeExpired
RedeemAlreadyRedeemedBySameKey pid -> replay now' pid
RedeemOk badgeType months -> redeem attemptsLeft now' badgeType months
-- Passed as an action so 'classifyRedemption' can reject a bad check character without ever
-- forcing it: 31 of every 32 random guesses cost no database round trip, and this read
-- transaction is not even opened for them (B3).
lookupCode h = ExceptT $ withServiceTransaction store (\db -> getCodeByHash db h)
failedRedemption code = do
debitFailureBuckets bsEnv signerKey
pure $ errorResponse code Nothing Nothing
-- RPC "Idempotency": the same code presented again by the same key returns the credential it
-- was already issued and records no second redemption. Healing the ledger is the only row
-- this path can append, and only when months have genuinely lapsed since -- the RPC has the
-- service heal its own ledger before answering any statement ("Statement and balance"), and
-- a statement that showed a balance the database does not hold would be worse than the row.
replay now' pid =
withServiceTransaction store (replayTxn now' pid) >>= \case
Left e -> storeFailed "purchaseBadge{code} replay" e
Right (credential, statement) -> do
when (isNothing credential) $
logWarn $ "no badge issuance found for the redemption being replayed by purchase " <> tshow pid
pure BSPBadgeCredential {credential, receipt = Nothing, statement}
replayTxn now' pid db = do
issuance <- getIssuanceForRedeemedCode db hash
statement <- purchaseStatement now' db Nothing pid
pure (issuanceCredential <$> issuance, statement)
redeem attemptsLeft now' badgeType months
-- The service signs exactly the content the client sent (RPC "Commands"), so a request
-- naming a tier the code does not fund is refused rather than silently signed as the
-- code's tier or, worse, as the tier asked for.
| requestedBadgeType badgeRequest /= badgeType = pure badRequest
| otherwise = do
-- minted before the plan, so the credit entry can name the payment row it references,
-- and before the transaction, so nothing but writes happens inside it
paymentUuid <- UUID.toText <$> UUID.nextRandom
withServiceTransaction store (planTxn now' badgeType months paymentUuid) >>= \case
Left e -> storeFailed "purchaseBadge{code} planning" e
Right (Left code) -> pure $ errorResponse code Nothing Nothing
Right (Right (row_, plan)) ->
resolveIssue bsEnv now' (rowPurchaseId <$> row_) badgeRequest (lpIssue plan) >>= \case
Left code -> pure $ errorResponse code Nothing Nothing
Right result ->
withServiceTransaction store (writeTxn now' badgeType paymentUuid row_ plan {lpIssue = result}) >>= \case
-- another request redeemed this code between the classification and this
-- write; nothing of ours committed, so re-classify and answer what the code
-- now is (a replay for this key, code_used for any other)
Left SECodeConflict | attemptsLeft > 0 -> attempt (attemptsLeft - 1)
Left e -> storeFailed "purchaseBadge{code} write" e
Right statement ->
pure BSPBadgeCredential {credential = issuedCredential result, receipt = Nothing, statement}
planTxn now' badgeType months paymentUuid db =
getPurchaseByKey db signerKey >>= \case
-- the normal case: C4 mints a fresh key per redemption, so there is no purchase row and
-- no ledger to read. Creating it is planned for the write transaction, not done here.
Nothing -> pure $ Right (Nothing, planLedger now' creditWith Nothing (initialLedgerState now' badgeType))
Just row@BadgePurchaseRow {badgePurchaseId, currentBadgeType}
-- a repeated key is only produced by a non-standard client; a code of a different tier
-- would have to convert the existing balance, and tier upgrades are out of scope (§6)
| currentBadgeType /= badgeType -> pure $ Left BSEBadRequest
| otherwise -> do
lastEntry <- getLastLedgerEntry db badgePurchaseId
let st0 = maybe (initialLedgerState now' badgeType) ledgerStateOf lastEntry
pure $ Right (Just row, planLedger now' creditWith (lastEntry >>= entryWasPausedSince) st0)
where
creditWith = Just (months, CTPayment paymentUuid)
writeTxn now' badgeType paymentUuid row_ plan db = do
row <- maybe (createPurchase db signerKey (requestMasterKey badgeRequest) badgeType now') pure row_
let pid = rowPurchaseId row
createCodePayment db paymentUuid now'
-- badge_purchases.payment_id is UNIQUE and holds at most one payment: a repeated key's
-- second code still gets its own payments row, which the credit entry references, but
-- leaves the purchase's pointer at the first one rather than repointing it
when (isNothing (rowPaymentId row)) $ attachPurchasePayment db pid paymentUuid now'
writeLedgerPlan db now' pid badgeType plan
-- last, so a code claimed in between rolls back everything above with it
markCodeRedeemed db hash pid now'
purchaseStatement now' db Nothing pid
-- | Issues the next period from an existing balance: steps 4 to 6 with no code and no credit.
-- It is the only command that re-issues, and C3's worker is its only caller.
--
-- An exhausted balance is not an error: the response carries no credential and the statement
-- shows the zero balance. A repeat inside an already-issued month returns that month's cached
-- credential and writes nothing (RPC "Idempotency").
handleIssueBadge :: BadgeServiceEnv -> BadgePurchaseRow -> BadgeRequest -> BadgeBalance -> IO BadgeServiceResponse
handleIssueBadge bsEnv@BadgeServiceEnv {store, now} row badgeRequest badgeBalance
-- as for purchaseBadge: the service signs the content it was sent, so a request naming a tier
-- other than the purchase's own is refused rather than signed
| requestedBadgeType badgeRequest /= currentType = pure badRequest
| otherwise = do
now' <- now
withServiceTransaction store (planTxn now') >>= \case
Left e -> storeFailed "issueBadge planning" e
Right (cursor, plan) ->
resolveIssue bsEnv now' (Just pid) badgeRequest (lpIssue plan) >>= \case
Left code -> pure $ errorResponse code Nothing Nothing
Right result ->
-- One transaction either way: an issued period writes its rows and reads the
-- statement back inside them, while a cached or exhausted issue writes nothing and
-- the same call is a plain read. Neither can report a balance the database does
-- not hold.
withServiceTransaction store (writeTxn now' cursor plan {lpIssue = result}) >>= \case
Left e -> storeFailed "issueBadge write" e
Right statement ->
pure BSPBadgeCredential {credential = issuedCredential result, receipt = Nothing, statement}
where
BadgePurchaseRow {badgePurchaseId = pid, currentBadgeType = currentType} = row
planTxn now' db = do
cursor <- resolveCursor db pid (assertedEntryId badgeBalance)
lastEntry <- getLastLedgerEntry db pid
-- a purchase with no ledger at all has a zero balance, which 'planLedger' turns into
-- 'IssueExhausted': no credential, and an empty statement rather than an invented entry
let st0 = maybe (initialLedgerState now' currentType) ledgerStateOf lastEntry
pure (cursor, planLedger now' Nothing (lastEntry >>= entryWasPausedSince) st0)
writeTxn now' cursor plan db = do
writeLedgerPlan db now' pid currentType plan
purchaseStatement now' db cursor pid
apps/simplex-badge-service/src/BadgeService/Store.hs
+57 -20
View File
@@ -28,11 +28,13 @@ module BadgeService.Store
getPurchaseByKey,
createPurchase,
createCodePayment,
attachPurchasePayment,
-- * Ledger
getLastLedgerEntry,
appendLedgerEntry,
getLedgerSince,
getLedgerEntryIdByUuid,
-- * Issuances
NewIssuance (..),
@@ -108,8 +110,11 @@ data ServiceError
| SECodeNotFound
| SEPriceNotFound
| SEOfferNotFound
| -- | 'createCodePayment' only: the purchase already has a payment attached.
| -- | 'attachPurchasePayment' only: the purchase already has a payment attached.
SEPaymentConflict
| -- | 'markCodeRedeemed' only: the code was redeemed by a concurrent request between the
-- caller's classification and its write. The caller re-classifies from the code row.
SECodeConflict
| SEDecodeError Text
deriving (Eq, Show)
@@ -211,14 +216,14 @@ createPurchase db purchaseKey masterKey@(BadgeMasterKey mk) badgeType now = do
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
-- | Writes the @payments@ row alone (caller-minted UUID as @payment_id@, @provider = 'code'@,
-- @invoice_id@ NULL, @status = 'settled'@ via 'PSSettled'\'s 'ToField'). Attaching it
-- to the purchase is 'attachPurchasePayment', a separate call because the two are not always
-- paired: @badge_purchases.payment_id@ is @UNIQUE@ and holds at most one payment, so a second
-- code redeemed under a purchase key that already has one still needs its @payments@ row (the
-- @credit(payment)@ ledger entry references it) but must not repoint the purchase.
createCodePayment :: DB.Connection -> Text -> UTCTime -> ExceptT ServiceError IO ()
createCodePayment db paymentId now =
liftIO $
DB.execute
db
@@ -227,6 +232,13 @@ createCodePayment db badgePurchaseId paymentId now = do
VALUES (?,?,?,?,?,?)
|]
(paymentId, Nothing :: Maybe Text, codePaymentProviderText, PSSettled, now, now)
-- | Points the purchase's @payment_id@ at an existing payment. 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').
attachPurchasePayment :: DB.Connection -> Int64 -> Text -> UTCTime -> ExceptT ServiceError IO ()
attachPurchasePayment db badgePurchaseId paymentId now = do
attached <-
liftIO $
DB.query
@@ -265,18 +277,16 @@ 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.
-- | @'CTCharge' {chargeId}@ is typed 'Int64' in "Simplex.Chat.Badges.Types", but the column it
-- would persist through (@charge_id@) is @subscription_charges@\' TEXT primary key. Both
-- directions reject that constructor explicitly rather than inventing a silent, possibly
-- wrong, numeric<->text coercion; subscriptions are out of scope (plan \'6), so nothing writes
-- one. @'CTPayment' {paymentId}@ had the same defect and is now 'Text', matching
-- @badge_ledger.payment_id TEXT REFERENCES payments@ (B7, plan \'9).
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"
CTPayment {paymentId} -> pure ("credit", Just "payment", Nothing, Just paymentId, Nothing, Nothing, Nothing)
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)
@@ -293,6 +303,7 @@ encodeLedgerEntryType = \case
decodeLedgerEntryType :: LedgerTypeRow -> Either ServiceError LedgerEntryType
decodeLedgerEntryType row = case row of
("credit", Just "payment", _, Just paymentId, _, _, _) -> Right $ LECredit (CTPayment paymentId)
("credit", Just "support", _, _, _, _, _) -> Right $ LECredit CTSupport
("credit", Just "transfer_in", _, _, _, fromPurchaseId, _) -> Right $ LECredit (CTTransferIn fromPurchaseId)
("credit", Just "opening", _, _, _, _, _) -> Right $ LECredit CTOpening
@@ -361,6 +372,21 @@ getLedgerSince db badgePurchaseId sinceEntryId = do
(badgePurchaseId, sinceId)
liftEither $ mapM rowToLedgerEntry rows
-- | Resolves the wire @entryId@ (the row's @entry_uuid@, which is what a client asserts) to the
-- local @entry_id@ 'getLedgerSince' queries on, scoped to one purchase: an entry belonging to a
-- different purchase resolves to 'Nothing', so an asserted uuid cannot be used to probe another
-- purchase's ledger. 'Nothing' also covers a uuid the service simply does not hold, which the
-- RPC treats as an assertion that names nothing and answers with the complete history.
getLedgerEntryIdByUuid :: DB.Connection -> Int64 -> Text -> ExceptT ServiceError IO (Maybe Int64)
getLedgerEntryIdByUuid db badgePurchaseId entryUuid = do
rows <-
liftIO $
DB.query
db
"SELECT entry_id FROM sx_badge_service_badge_ledger WHERE badge_purchase_id = ? AND entry_uuid = ?"
(badgePurchaseId, entryUuid)
pure $ fromOnly <$> listToMaybe rows
-- Issuances ---------------------------------------------------------------------
-- | Fields needed to create one @badge_issuances@ row. Unlike the shared 'BadgeIssuance',
@@ -525,6 +551,10 @@ getCodeByHash db codeHash = do
code <- liftEither $ rowToCode codeRow
pure $ Just (code, redeemerKey)
-- | Claims an unredeemed code for a purchase. Guarded by @redeemed_purchase_id IS NULL@ so a
-- redemption is never overwritten by a second one racing it: on no rows affected, a follow-up
-- existence check distinguishes an unknown code ('SECodeNotFound') from one another request
-- redeemed in between ('SECodeConflict'), which the caller answers by re-classifying.
markCodeRedeemed :: DB.Connection -> ByteString -> Int64 -> UTCTime -> ExceptT ServiceError IO ()
markCodeRedeemed db codeHash badgePurchaseId now = do
rows <-
@@ -534,11 +564,18 @@ markCodeRedeemed db codeHash badgePurchaseId now = do
[sql|
UPDATE sx_badge_service_codes
SET redeemed_purchase_id = ?, redeemed_at = ?
WHERE code_hash = ?
WHERE code_hash = ? AND redeemed_purchase_id IS NULL
RETURNING code_hash
|]
(badgePurchaseId, now, Binary codeHash)
when (null (rows :: [Only (Binary ByteString)])) $ throwError SECodeNotFound
when (null (rows :: [Only (Binary ByteString)])) $ do
exists <-
liftIO $
DB.query
db
"SELECT 1 FROM sx_badge_service_codes WHERE code_hash = ?"
(Only (Binary codeHash))
throwError $ if null (exists :: [Only Int]) then SECodeNotFound else SECodeConflict
-- | Clears both redemption columns and sets @unredeemed_at@, which both re-enables
-- redemption and reopens E4's disclosure window.