From 0d74c149bb27df471f08d9d40396f749a11dc8ed Mon Sep 17 00:00:00 2001 From: spacedandy-agents-simplex <342056592+spacedandy-agents-simplex@users.noreply.github.com> Date: Thu, 15 Oct 2026 12:45:20 +0000 Subject: [PATCH] badge-service: name the rule for when a subscription is due a store check The issue path's purchase read becomes getIssuePurchase and its "ask the store now" test becomes subscriptionCheckDue, so the request router can read the same rows by the same rule. No behaviour change. Run: 005-subscriptions-load-timing, slice 1 --- .../src/BadgeService/Service.hs | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index d8c4c1ce7f..74e21dde23 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -640,9 +640,7 @@ firstMonthResponse db purchaseId creditPaymentId_ subscription (rows, issuance@( issueBadgeCmd :: BadgeIssuerKey -> ChatController -> StoreVerifier -> C.PublicKeyEd25519 -> BadgeBalance -> IO BadgeServiceResponse issueBadgeCmd key cc verifier purchaseKey BadgeBalance {lastEntry} = do now <- badgeNow cc - purchase_ <- withDB' "getBadgePurchase" cc $ \db -> do - p_ <- getPurchaseByKey db purchaseKey - forM p_ $ \p@ServicePurchase {badgePurchaseId} -> (p,,) <$> getLedgerTip db badgePurchaseId <*> getPurchaseSubscription db badgePurchaseId + purchase_ <- withDB' "getBadgePurchase" cc (\db -> getIssuePurchase db purchaseKey) case purchase_ of Left _ -> pure $ errorResponse BSEInternal Right Nothing -> pure $ errorResponse BSEUnknownPurchaseKey @@ -672,8 +670,8 @@ issueBadgeCmd key cc verifier purchaseKey BadgeBalance {lastEntry} = do pure $ fromRight (errorResponse BSEInternal) r -- Nothing but the store's answer is written until a charge is granted: a lapse at now would be dated -- after a grant a later check may make at an earlier period start, and the client would read it as a pass that issued. - renewSubscription ServicePurchase {badgePurchaseId, masterKey, badgeType} tip PurchaseSubscription {paymentId, provider, subscriptionRef, storedState, checkedAt} now - | maybe False (\t -> diffUTCTime now t < subscriptionCheckInterval) checkedAt = answered "answerStoredSubscription" $ \db -> issueResponse db badgePurchaseId now (Just storedState) + renewSubscription ServicePurchase {badgePurchaseId, masterKey, badgeType} tip subscription@PurchaseSubscription {paymentId, provider, subscriptionRef, storedState} now + | not (subscriptionCheckDue now tip subscription) = answered "answerStoredSubscription" $ \db -> issueResponse db badgePurchaseId now (Just storedState) | otherwise = withDB' "stampSubscriptionCheck" cc (\db -> stampSubscriptionCheck db paymentId now) >>= \case Left _ -> pure $ errorResponse BSEInternal @@ -732,6 +730,15 @@ issueBadgeCmd key cc verifier purchaseKey BadgeBalance {lastEntry} = do credential_ <- getCurrentIssuance db purchaseId t pure $ maybe (errorResponse BSEInternal) (credentialResponse credential_ (assertedUuid <$ assertedId) subscription) entries_ +getIssuePurchase :: DB.Connection -> C.PublicKeyEd25519 -> IO (Maybe (ServicePurchase, Maybe StatementEntry, Maybe PurchaseSubscription)) +getIssuePurchase db purchaseKey = do + p_ <- getPurchaseByKey db purchaseKey + forM p_ $ \p@ServicePurchase {badgePurchaseId} -> (p,,) <$> getLedgerTip db badgePurchaseId <*> getPurchaseSubscription db badgePurchaseId + +subscriptionCheckDue :: UTCTime -> StatementEntry -> PurchaseSubscription -> Bool +subscriptionCheckDue now tip PurchaseSubscription {checkedAt} = + paidThrough tip <= now && maybe True (\t -> diffUTCTime now t >= subscriptionCheckInterval) checkedAt + -- | Each subscription asks its store at most this often, failed attempts included, so a client -- repeating its requests cannot spend the store quota every subscriber shares. subscriptionCheckInterval :: NominalDiffTime