core: verify the badge ledger sent by the service (#7480)

plans/2026-09-07-badge-ledger-types.md

@@ -79,20 +79,17 @@ The client's remaining use, `ledgerPlan` inside `badgeWorkDue`, is removed by th
 
 The client authors nothing, so it takes the service's arithmetic on trust — while holding everything needed to check it.
 
-**Where.** In `applyBadgeStatement`, as the rows are stored. That is the one place holding both the arriving entries and the stored tip they follow, and it already runs in one transaction.
+**Where.** In `applyBadgeStatement`, as the rows are stored — the one place holding both the arriving entries and the stored tip, in one transaction. The tip is always read, and `previousEntryId` selects nothing: it is the predecessor of the statement's first entry alone, and a replayed first entry is not rewritten, so its verdict is discarded either way. A statement that resets the ledger legitimately does so with an `opening` credit, which is checked without a predecessor.
 
-**What.** One outcome per entry, from one of two rules:
+**What.** Re-run the operation the entry claims and compare, rather than restate its arithmetic as rules. Each operation is a total function of a predecessor and a timestamp, and the entry carries the timestamp it was computed with. The predecessor is the previous entry as received, the tip for the first, or `emptyEntry` when there is no tip — what `redeemCode` grants onto, so a ledger's first credit is not a rule of its own. An `opening` credit is the exception: it resets the ledger to the amount it states with no relation to the entry before it (badges-rpc.md), so it is checked against nothing but itself — the months it credits, and the purchase's badge type.
 
-- *Against its predecessor* — the previous entry in the statement, or the stored tip for the first one, whatever `previousEntryId` claims. `balanceMonths` equals the predecessor's plus `changeMonths`; a debit moves `balanceStartTs` forward by exactly the months it consumed, counted from the anchor; a credit either leaves the start alone or restarts the run with `balanceStartTs` and `balanceAnchorTs` equal.
-- *Opening*, when there is no predecessor at all: a credit whose `balanceMonths` equals its `changeMonths`, with start and anchor equal.
-
-Checking the first entry against what the client actually holds is also what catches a statement that follows some other ledger — it fails its arithmetic — so `previousEntryId` needs no separate outcome.
+Re-running is what catches over-lapsing: writing off three months when one elapsed adds up against its predecessor, and it empties `balanceMonths` while leaving `paidThrough` untouched, so the badge stops renewing while the ledger still reads as paid up. Two values cannot be re-derived and are bounded instead — a credit's months, of which only the sign is checkable, and `createdAt`, which every recompute is anchored on. A `createdAt` before its predecessor's is the service against its own clock and is marked bad; one beyond the client's clock is two clocks disagreeing, so the row goes unjudged rather than accused.
 
 **What happens when it fails: store the row and mark it.** Not refuse. Perks do not depend on the ledger — the credential is signed independently and a receiver verifies that signature — so rejecting a statement would strand a badge the service considers paid while proving nothing. The ledger is the user's record of what was spent, and the useful response to arithmetic that does not add up is to keep it and be able to point at the line.
 
-**The column.** `balance_checked`, per entry — `1` when the entry follows from its predecessor, `0` when it does not, and null when nobody has looked. Nullable, because "can be checked" and "has been checked" are different things: every row has a predecessor to check against, and none has been checked while the check is a stub. Not `verified`, which already means signature verification on profiles and would read as the same thing.
+**The column.** `balance_checked`, per entry — `1` when re-running reproduced the row, `0` when something contradicted it, and null when nothing was re-run: an unknown tag, a debit declared but unimplemented, or a timestamp this client's clock cannot corroborate. Marking an unrebuildable type `0` would report a newer service's correct row as broken, so those are held only to what is true of any operation — the months add up, the balance is not negative, coverage does not move backwards. Not `verified`, which already means signature verification on profiles and would read as the same thing.
 
-The check belongs in `Ledger.hs`, beside the arithmetic it verifies — `monthsFromAnchor` is internal there and would otherwise have to be exported to check a debit's start. Stub it to null until it exists; adding the column now is what keeps it out of a migration of its own.
+The check belongs in `Ledger.hs`, beside the arithmetic it verifies — `monthsFromAnchor` is internal there and would otherwise have to be exported. The column ships with the rest of the ledger schema, keeping it out of a migration of its own.
 
 ## The tests move with the types
 

src/Simplex/Chat/Badges/Ledger.hs

@@ -19,23 +19,26 @@ module Simplex.Chat.Badges.Ledger
   )
 where
 
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import Data.Time.Calendar (addDays, addGregorianMonthsClip, toGregorian)
 import Data.Time.Calendar.WeekDate (toWeekDate)
-import Data.Time.Clock (UTCTime (..))
+import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime)
 import Simplex.Chat.Badges (BadgeType)
 import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
 
--- | balanceStartTs is always a whole number of months from the anchor; this is that number.
 -- The calendar difference overshoots by at most one month, so one comparison settles it.
-monthsFromAnchor :: StatementEntry -> Integer
-monthsFromAnchor StatementEntry {balanceStartTs, balanceAnchorTs}
-  | addMonths months balanceAnchorTs <= balanceStartTs = max 0 months
+monthsBetween :: UTCTime -> UTCTime -> Integer
+monthsBetween from to
+  | addMonths months from <= to = max 0 months
   | otherwise = max 0 (months - 1)
   where
-    (ay, am, _) = toGregorian (utctDay balanceAnchorTs)
-    (sy, sm, _) = toGregorian (utctDay balanceStartTs)
-    months = (sy - ay) * 12 + toInteger (sm - am)
+    (fy, fm, _) = toGregorian (utctDay from)
+    (ty, tm, _) = toGregorian (utctDay to)
+    months = (ty - fy) * 12 + toInteger (tm - fm)
+
+monthsFromAnchor :: StatementEntry -> Integer
+monthsFromAnchor e = monthsBetween (balanceAnchorTs e) (balanceStartTs e)
 
 -- | The start of the month that follows n more months of this run.
 monthAfter :: StatementEntry -> Int -> UTCTime
@@ -44,8 +47,12 @@ monthAfter e n = addMonths (monthsFromAnchor e + toInteger n) (balanceAnchorTs e
 paidThrough :: StatementEntry -> UTCTime
 paidThrough e = monthAfter e (balanceMonths e)
 
+-- Counted from the anchor: 31 Jan plus a month clips to 28 Feb, and counting on from there would
+-- retire the next month three days early.
 elapsedMonths :: UTCTime -> StatementEntry -> Int
-elapsedMonths t e = length $ takeWhile (\m -> monthAfter e m <= t) [1 .. balanceMonths e]
+elapsedMonths t e = fromInteger $ max 0 $ min (toInteger $ balanceMonths e) elapsed
+  where
+    elapsed = monthsBetween (balanceAnchorTs e) t - monthsFromAnchor e
 
 -- | The seed for a purchase with no ledger yet: no months, and a run starting now.
 emptyEntry :: UTCTime -> BadgeType -> StatementEntry
@@ -107,11 +114,68 @@ issueEntry t entryId e@StatementEntry {balanceMonths, balanceStartTs}
             entryType = SEDebit SDBadge
           }
 
--- | Pairs each arriving entry with whether its balance follows from the one before it, the stored
--- tip standing in for the first one's predecessor. 'Nothing' is "not checked".
--- TODO [badges] do the arithmetic.
-balanceChecked :: Maybe StatementEntry -> [StatementEntry] -> [(StatementEntry, Maybe Bool)]
-balanceChecked _tip = map (\e -> (e, Nothing))
+-- Generous because postdating only writes off a month by crossing a month boundary, which takes
+-- days, while a device clock a few minutes slow would otherwise leave every row unverified.
+maxCreatedAtSkew :: NominalDiffTime
+maxCreatedAtSkew = 60 * 60
+
+-- | Each entry is checked by re-running the operation it claims: checking only that its numbers
+-- follow from the previous entry would pass a lapse of three months where one elapsed. So 'True'
+-- means the service ran these functions, not that it ran the right one. 'Nothing' is "not re-run":
+-- no operation rebuilds that type, or its timestamp is not credible.
+balanceChecked :: UTCTime -> BadgeType -> Maybe StatementEntry -> [StatementEntry] -> [(StatementEntry, Maybe Bool)]
+balanceChecked _ _ _ [] = []
+balanceChecked now badgeType tip entries@(first : _) = zipWith withVerdict (opening : entries) entries
+  where
+    -- the purchase's own type, not the statement's: on the seed path nothing else contradicts it
+    opening = fromMaybe (emptyEntry (createdAt first) badgeType) tip
+    withVerdict prev e = (e, entryChecked now badgeType prev e)
+
+entryChecked :: UTCTime -> BadgeType -> StatementEntry -> StatementEntry -> Maybe Bool
+entryChecked now badgeType prev e
+  -- the recompute runs on createdAt, so a stamp our own clock contradicts makes every verdict
+  -- below meaningless - which is not the same as the row being wrong, and is not marked as it
+  | postdated = Nothing
+  | backdated = Just False
+  | otherwise = case entryType e of
+      SEDebit SDLapse -> maybe (Just False) matches $ lapseEntry t "" prev
+      SEDebit SDBadge -> maybe (Just False) matches $ issueEntry t "" prev
+      SEDebit SDRefund -> uncontradicted
+      SEDebit SDUpgrade {} -> uncontradicted
+      SEDebit SDTransferOut {} -> uncontradicted
+      SEDebit SDSupport -> uncontradicted
+      SEDebit SDUnknown {} -> uncontradicted
+      -- an opening credit resets the ledger to the amount it states, with no relation to the entry
+      -- before it (badges-rpc.md), so it is checked against nothing but itself
+      SECredit SCOpening -> Just restated
+      SECredit SCUnknown {} -> uncontradicted
+      SECredit c
+        -- grantEntry is given the row's month count, so the check agrees with whatever it claims -
+        -- including a negative count, which shortens what the user paid for.
+        -- TODO [badges] a purchase made in the app knows the months it bought; check them here.
+        | changeMonths e < 0 -> Just False
+        | otherwise -> matches $ grantEntry t "" (changeMonths e) c prev
+  where
+    t = createdAt e
+    postdated = t > addUTCTime maxCreatedAtSkew now
+    -- two of the service's own stamps, so no allowance and no doubt about whose clock is wrong.
+    -- Equal is not behind: a service pass writes its lapse and its issue with one clock reading
+    backdated = t < createdAt prev
+    matches = Just . sameBalance e
+    restated = balanceMonths e == changeMonths e && balanceMonths e >= 0 && balanceBadgeType e == badgeType
+    uncontradicted
+      | balanceMonths e /= balanceMonths prev + changeMonths e = Just False
+      | balanceMonths e < 0 = Just False
+      | balanceStartTs e < balanceStartTs prev = Just False
+      | otherwise = Nothing
+
+sameBalance :: StatementEntry -> StatementEntry -> Bool
+sameBalance a b =
+  balanceMonths a == balanceMonths b
+    && balanceStartTs a == balanceStartTs b
+    && balanceAnchorTs a == balanceAnchorTs b
+    && balanceBadgeType a == balanceBadgeType b
+    && changeMonths a == changeMonths b
 
 -- | The tag stored is the string the service sent, so a type this version does not know is kept
 -- as received and can be read once it does.

src/Simplex/Chat/Library/Commands.hs

@@ -59,7 +59,7 @@ import qualified Data.UUID.V4 as V4
 import Simplex.Chat.Library.Subscriber
 import Crypto.Random (ChaChaDRG)
 import Simplex.Messaging.Session (SessionVar (..), withGetSessVar')
-import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, LocalBadge (..), badgeServerCredential, maxXFTPFileSize, mkBadgeStatus, verifyCredential)
+import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType, LocalBadge (..), badgeServerCredential, maxXFTPFileSize, mkBadgeStatus, verifyCredential)
 import qualified Simplex.Chat.Badges.Ledger as L
 import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeState (..))
 import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode)
@@ -5464,7 +5464,7 @@ badgeErrorRetry = \case
 -- the same request is sent again on the next pass. 'Left' is a service error, already reported, and
 -- carries when to try again, since a service error is answered rather than thrown.
 requestBadgeIssue :: UserId -> UserBadgePurchase -> UTCTime -> CM (Either UTCTime StatementEntry)
-requestBadgeIssue userId UserBadgePurchase {badgePurchaseId, purchaseKey, purchasePrivKey, masterKey} now = do
+requestBadgeIssue userId UserBadgePurchase {badgePurchaseId, badgeType, purchaseKey, purchasePrivKey, masterKey} now = do
   sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwCmdError "badge service not configured") pure
   withEntityLock "badgeIssue" (CLBadgeUser userId) $ do
     user <- withStore $ \db -> getUser db userId
@@ -5482,7 +5482,10 @@ requestBadgeIssue userId UserBadgePurchase {badgePurchaseId, purchaseKey, purcha
         -- TODO [badges] the statement is applied either way, so a failed verification spends the
         -- month with nothing to show for it; that needs an alert, not only a line in the log
         g <- asks random
-        applied <- withStore' $ \db -> applyBadgeStatement db g badgePurchaseId statement cred_ now
+        -- read again: now was taken before a lock wait and an untimed request, and the check reads
+        -- it as the client's clock against the timestamps the service put on the rows
+        storedAt <- badgeNow
+        applied <- withStore' $ \db -> applyBadgeStatement db g badgePurchaseId badgeType statement cred_ storedAt
         unless applied $ eToView $ ChatError $ CEInternalError "issued badge credential has no ledger row to store it against"
         Right <$> (withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) >>= maybe (throwCmdError "badge ledger has no balance") pure)
       J.Success BSPError {code, retryAfter} -> do
@@ -5541,7 +5544,7 @@ stopBadgeWorkers workers =
 -- issuance and the profile's badge go in one transaction. Answers the user to tell contacts about,
 -- which the caller does once the badge lock is released.
 storeRedeemedBadge :: User -> BadgeCodeRedemption -> BadgeCredential -> BadgeStatement -> CM (Maybe User, ChatResponse)
-storeRedeemedBadge user@User {userId} redemption@BadgeCodeRedemption {masterKey} cred@(BadgeCredential _ credMasterKey _ info) statement =
+storeRedeemedBadge user@User {userId} redemption@BadgeCodeRedemption {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeType}) statement =
   verifyOwnBadge cred >>= \case
     Nothing -> throwCmdError "redeemed badge credential names an unknown badge key index"
     Just False -> throwCmdError "redeemed badge credential does not verify against configured key"
@@ -5555,7 +5558,7 @@ storeRedeemedBadge user@User {userId} redemption@BadgeCodeRedemption {masterKey}
       -- TODO [badges] retire a previously held badge
       (user', newBadge, applied) <- withStore $ \db -> do
         (purchaseId, newBadge) <- liftIO $ createCodeBadgePurchase db user redemption cred now
-        applied <- liftIO $ applyBadgeStatement db g purchaseId statement (Just cred) now
+        applied <- liftIO $ applyBadgeStatement db g purchaseId badgeType statement (Just cred) now
         -- a replay must not put a superseded badge back, or tell every contact again
         user' <- if newBadge then setUserBadge db user (Just badge) else getUser db userId
         pure (user', newBadge, applied)
@@ -5566,10 +5569,13 @@ storeRedeemedBadge user@User {userId} redemption@BadgeCodeRedemption {masterKey}
 
 -- | Store the statement's rows, then the credential against the badge debit row among them.
 -- 'False' when that row cannot be found, which the caller reports rather than drop in silence.
-applyBadgeStatement :: DB.Connection -> TVar ChaChaDRG -> Int64 -> BadgeStatement -> Maybe BadgeCredential -> UTCTime -> IO Bool
-applyBadgeStatement db g purchaseId BadgeStatement {entries} cred_ now = do
+applyBadgeStatement :: DB.Connection -> TVar ChaChaDRG -> Int64 -> BadgeType -> BadgeStatement -> Maybe BadgeCredential -> UTCTime -> IO Bool
+applyBadgeStatement db g purchaseId badgeType BadgeStatement {entries} cred_ now = do
+  -- TODO [badges] a service that no longer holds the asserted row re-sends its whole history, which
+  -- joins onto the tip without following it, and every row of it verifies. The service is to heal
+  -- and restate as one opening credit instead (badges-rpc.md), which is checked without a tip.
   tip <- getBadgeLedgerLastEntry db purchaseId
-  storeBadgeStatement db purchaseId tip entries now
+  storeBadgeStatement db purchaseId badgeType tip entries now
   case (,) <$> cred_ <*> issuedEntryId of
     Nothing -> pure True
     Just (cred, entryUuid) ->

src/Simplex/Chat/Store/Badges.hs

@@ -273,9 +273,9 @@ clearShownBadge db User {userId} badgePurchaseId =
 -- | Verbatim, entry_uuid and type included: the client authors no row, or the two sides stop
 -- holding the same ledger. DO NOTHING makes a re-applied statement a no-op rather than a throw.
 -- An entry whose balance does not follow from the one before it is stored and marked, not refused.
-storeBadgeStatement :: DB.Connection -> Int64 -> Maybe StatementEntry -> [StatementEntry] -> UTCTime -> IO ()
-storeBadgeStatement db badgePurchaseId tip entries now =
-  mapM_ storeEntry $ balanceChecked tip entries
+storeBadgeStatement :: DB.Connection -> Int64 -> BadgeType -> Maybe StatementEntry -> [StatementEntry] -> UTCTime -> IO ()
+storeBadgeStatement db badgePurchaseId badgeType tip entries now =
+  mapM_ storeEntry $ balanceChecked now badgeType tip entries
   where
     storeEntry (StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince, createdAt, entryType}, checked) =
       DB.execute

tests/BadgeTests.hs

@@ -58,8 +58,22 @@ badgeTests = do
     it "credits an exhausted balance from the grant, not from the date it ran out" testGrantAfterExhausted
     it "does not issue months topped up inside an issued period" testGrantInsideIssuedPeriod
     it "clips month ends without losing the issued period start" testMonthEndClipping
+    it "counts the elapsed months of an absurd run in one step" testElapsedFarAnchor
     it "expires at the end of the Monday after the period" testMondayExpiry
     it "stores the wire tag of every entry type, and rebuilds each from its stored JSON" testEntryTypeColumns
+  describe "checking a statement" $ do
+    it "accepts a chain of entries, each against the one before it" testChecksChain
+    it "checks the second entry against the first, not against the tip" testChecksAgainstStatement
+    it "accepts an opening credit with no predecessor, and rejects anything else" testChecksOpening
+    it "rejects an opening credit naming a badge type the purchase is not for" testChecksOpeningBadgeType
+    it "accepts an opening credit restating the balance over a tip it does not follow" testChecksOpeningRestatement
+    it "rejects a lapse writing off months that had not elapsed" testChecksOverLapse
+    it "rejects a debit whose start or anchor moved" testChecksMovedStart
+    it "rejects a grant restarting a run the predecessor still funds" testChecksGrantRestart
+    it "rejects a credit of negative months" testChecksNegativeCredit
+    it "leaves an entry ahead of the clock unjudged, and rejects one behind the entry it follows" testChecksTimestamps
+    it "leaves an entry type it cannot derive unchecked, its months still checked" testChecksUnknownType
+    it "rejects an entry it cannot rebuild whose coverage or months contradict the ledger" testChecksUncheckedInvariants
   describe "worker retry" $ do
     it "repeats a failure that can clear on its own, and no other" testRetryClassification
     it "backs off to the cap" testRetryBackoff
@@ -258,6 +272,10 @@ bMonths StatementEntry {balanceMonths} = balanceMonths
 bStart :: StatementEntry -> UTCTime
 bStart StatementEntry {balanceStartTs} = balanceStartTs
 
+-- the moment the service claims it wrote the row, which is what the check reads it against
+stampedAt :: UTCTime -> StatementEntry -> StatementEntry
+stampedAt t e = e {createdAt = t}
+
 -- one service pass: lapse what elapsed, then issue if a month is due, as the service chains them.
 -- The period an issue covers is the previous entry's balance start to its own, so a run of starts
 -- is what the period assertions read.
@@ -387,6 +405,21 @@ testMonthEndClipping = do
       fmap bStart (issue (at 2027 2 28) feb) `shouldBe` Just (at 2027 3 31)
     Nothing -> expectationFailure "January was not issued"
 
+-- The anchor and the month count are the service's, and a run claiming to have started a thousand
+-- years ago with maxBound months is answered the same way as any other.
+testElapsedFarAnchor :: IO ()
+testElapsedFarAnchor = do
+  let far = at 1000 1 10
+      now = at 2026 1 10
+      elapsed = (2026 - 1000) * 12
+      huge = (newBalance far) {balanceMonths = maxBound}
+      three = (newBalance far) {balanceMonths = 3}
+  fmap bMonths (lapse now huge) `shouldBe` Just (maxBound - elapsed)
+  fmap bStart (lapse now huge) `shouldBe` Just now
+  -- and never writes off more months than the balance holds, however long ago it started
+  fmap bMonths (lapse now three) `shouldBe` Just 0
+  fmap bStart (lapse now three) `shouldBe` Just (at 1000 4 10)
+
 testMondayExpiry :: IO ()
 testMondayExpiry = do
   -- the end of Monday 13 Apr is Tuesday 14 Apr 00:00
@@ -400,6 +433,156 @@ testMondayExpiry = do
   expiries `shouldSatisfy` all (\(UTCTime d t) -> t == 0 && (\(_, _, wd) -> wd == 2) (toWeekDate d))
   zipWith diffUTCTime expiries periodEnds `shouldSatisfy` all (\d -> d > nominalDay && d <= 8 * nominalDay)
 
+verdicts :: UTCTime -> Maybe StatementEntry -> [StatementEntry] -> [Maybe Bool]
+verdicts now tip = map snd . balanceChecked now BTSupporter tip
+
+testChecksChain :: IO ()
+testChecksChain = do
+  let opened = newBalance (at 2026 1 10)
+      oneMonth = grant (at 2026 1 10) 1 opened
+  Just spent <- pure $ issue (at 2026 1 10) oneMonth
+  let granted = grant (at 2026 3 10) 3 spent
+      rows1 = pass (at 2026 3 10) granted
+      afterFirst = finalBalance granted rows1
+      rows2 = pass (at 2026 5 20) afterFirst
+      statement = granted : rows1 <> rows2
+  -- grant, issue, lapse, issue - the first checked against the stored tip
+  verdicts (at 2026 5 20) (Just spent) statement `shouldBe` replicate 4 (Just True)
+
+-- The client stores what it received, and the next row is what the service computed from the row it
+-- sent - never from the tip, which that row has already superseded.
+testChecksAgainstStatement :: IO ()
+testChecksAgainstStatement = do
+  let start = at 2026 3 10
+      granted = grant start 3 (newBalance start)
+  Just firstRow <- pure $ issue start granted
+  Just secondRow <- pure $ issue (at 2026 4 10) firstRow
+  verdicts (at 2026 4 10) (Just granted) [firstRow, secondRow] `shouldBe` [Just True, Just True]
+  -- against the tip it followed, the second entry does not add up
+  verdicts (at 2026 4 10) (Just granted) [secondRow] `shouldBe` [Just False]
+
+-- The seed is what redeemCode grants onto, so the row it authors is the one that verifies here.
+testChecksOpening :: IO ()
+testChecksOpening = do
+  let t = at 2026 3 10
+      opening = grant t 12 (newBalance t)
+  verdicts t Nothing [opening] `shouldBe` [Just True]
+  Just issued <- pure $ issue t opening
+  verdicts t Nothing [issued] `shouldBe` [Just False]
+
+-- The seed takes the purchase's badge type, not the statement's, so an opening row cannot assert a
+-- badge the purchase was never for - the one field on that path with something to check it against.
+testChecksOpeningBadgeType :: IO ()
+testChecksOpeningBadgeType = do
+  let t = at 2026 3 10
+      opening = grant t 12 (newBalance t)
+  verdicts t Nothing [opening] `shouldBe` [Just True]
+  verdicts t Nothing [opening {balanceBadgeType = BTLegend}] `shouldBe` [Just False]
+
+-- An opening credit resets the ledger to the amount it states, so it is the one entry whose
+-- balance owes nothing to the row before it - a new device, or history discarded into a balance
+-- brought forward. It still cannot state a balance other than the months it credits.
+testChecksOpeningRestatement :: IO ()
+testChecksOpeningRestatement = do
+  let start = at 2026 3 10
+      granted = grant start 3 (newBalance start)
+      restated = granted {entryType = SECredit SCOpening, changeMonths = 3, balanceMonths = 3}
+  -- the tip funds two months from April; the opening restates three from March and still holds
+  Just spent <- pure $ issue start granted
+  verdicts start (Just spent) [restated] `shouldBe` [Just True]
+  verdicts start (Just spent) [restated {balanceMonths = 9}] `shouldBe` [Just False]
+  verdicts start (Just spent) [restated {balanceBadgeType = BTLegend}] `shouldBe` [Just False]
+
+-- Over-lapsing empties the balance while paidThrough stays where it was: the badge stops renewing
+-- and the ledger still reads as paid up. The row is self-consistent with the one before it, so only
+-- re-running the lapse against its own timestamp catches it.
+testChecksOverLapse :: IO ()
+testChecksOverLapse = do
+  let start = at 2026 3 10
+      granted = grant start 3 (newBalance start)
+  Just issued <- pure $ issue start granted
+  Just lapsed <- pure $ lapse (at 2026 5 20) issued
+  Just overLapsed <- pure $ lapse (at 2026 8 20) issued
+  verdicts (at 2026 5 20) (Just issued) [lapsed] `shouldBe` [Just True]
+  verdicts (at 2026 5 20) (Just issued) [stampedAt (at 2026 5 20) overLapsed] `shouldBe` [Just False]
+  bMonths overLapsed `shouldBe` bMonths lapsed - 1
+  paidThrough overLapsed `shouldBe` paidThrough lapsed
+  -- and a lapse claiming a month before any had elapsed: lapseEntry declines it altogether
+  verdicts start (Just issued) [stampedAt start lapsed] `shouldBe` [Just False]
+
+testChecksMovedStart :: IO ()
+testChecksMovedStart = do
+  let start = at 2026 3 10
+      granted = grant start 3 (newBalance start)
+  Just issued <- pure $ issue start granted
+  verdicts start (Just granted) [issued] `shouldBe` [Just True]
+  verdicts start (Just granted) [issued {balanceStartTs = addMonths 1 (bStart issued)}] `shouldBe` [Just False]
+  verdicts start (Just granted) [issued {balanceAnchorTs = addMonths 1 start}] `shouldBe` [Just False]
+
+testChecksGrantRestart :: IO ()
+testChecksGrantRestart = do
+  let t = at 2026 2 10
+      opened = newBalance t
+      oneMonth = grant t 1 opened
+      funded = grant t 2 opened
+  Just spent <- pure $ issue t oneMonth
+  let restarted = grant (at 2026 6 1) 2 spent
+  verdicts (at 2026 6 1) (Just spent) [restarted] `shouldBe` [Just True]
+  -- the same entry after a predecessor with months left is a run moved to a later start
+  verdicts (at 2026 6 1) (Just funded) [restarted] `shouldBe` [Just False]
+
+testChecksNegativeCredit :: IO ()
+testChecksNegativeCredit = do
+  let t = at 2026 2 10
+      funded = grant t 2 (newBalance t)
+      negativeCredit = grant (at 2026 6 1) (-2) funded
+  verdicts (at 2026 6 1) (Just funded) [negativeCredit] `shouldBe` [Just False]
+  -- the sign is what rejects it: the row itself adds up, and the recompute would confirm it
+  bMonths negativeCredit `shouldBe` bMonths funded - 2
+
+testChecksTimestamps :: IO ()
+testChecksTimestamps = do
+  let start = at 2026 3 10
+      granted = grant start 3 (newBalance start)
+  Just issued <- pure $ issue start granted
+  -- the two clocks are not the same clock, so a row from just ahead of this one is not evidence
+  verdicts start (Just granted) [stampedAt (addUTCTime (30 * 60) start) issued] `shouldBe` [Just True]
+  -- further ahead than that, we cannot tell their clock from ours, so the row is left unjudged
+  verdicts start (Just granted) [stampedAt (addUTCTime (2 * 3600) start) issued] `shouldBe` [Nothing]
+  -- behind the row it follows is the service against itself, with no clock of ours in it
+  verdicts start (Just granted) [stampedAt (at 2026 3 1) issued] `shouldBe` [Just False]
+
+-- Marking a row this version has no operation for as broken would report a newer service as
+-- tampering, which is the opposite of the forward compatibility the rest of this code keeps.
+testChecksUnknownType :: IO ()
+testChecksUnknownType = do
+  let start = at 2026 3 10
+      granted = grant start 3 (newBalance start)
+  Just issued <- pure $ issue start granted
+  let unknown = issued {entryType = SEDebit SDUnknown {tag = "future", json = KM.empty}}
+  verdicts start (Just granted) [unknown] `shouldBe` [Nothing]
+  verdicts start (Just granted) [issued {entryType = SEDebit SDRefund}] `shouldBe` [Nothing]
+  verdicts start (Just granted) [unknown {balanceMonths = 5}] `shouldBe` [Just False]
+  verdicts start (Just granted) [stampedAt (at 2026 3 1) unknown] `shouldBe` [Just False]
+  -- an unknown credit takes the same path: fall through to grantEntry and its negative count,
+  -- which issued carries, would be rejected instead
+  let unknownCredit = issued {entryType = SECredit SCUnknown {tag = "future", json = KM.empty}}
+  verdicts start (Just granted) [unknownCredit] `shouldBe` [Nothing]
+
+-- A tag with no operation behind it escapes the recompute, leaving only the months identity - which
+-- holds while coverage moves back, or while the balance goes into debt.
+testChecksUncheckedInvariants :: IO ()
+testChecksUncheckedInvariants = do
+  let start = at 2026 3 10
+      granted = grant start 3 (newBalance start)
+  Just issued <- pure $ issue start granted
+  let shortened = issued {entryType = SEDebit SDRefund, changeMonths = 0, balanceStartTs = addMonths (-1) (bStart issued)}
+      owing = issued {entryType = SEDebit SDRefund, changeMonths = -3, balanceMonths = -1}
+  verdicts start (Just issued) [shortened] `shouldBe` [Just False]
+  paidThrough shortened `shouldBe` addMonths (-1) (paidThrough issued)
+  verdicts start (Just issued) [owing] `shouldBe` [Just False]
+  bMonths owing `shouldBe` bMonths issued - 3
+
 -- A failed renewal is otherwise left until the next chat start or activate, which on a desktop
 -- left running can be days - long enough for a funded badge to lapse.
 testRetryClassification :: IO ()

tests/Bots/BadgeServiceTests.hs

@@ -41,6 +41,7 @@ import Simplex.Chat.Core (sendChatCmdStr)
 import Simplex.Chat.Options (CoreChatOpts (..))
 import Simplex.Chat.Options.DB
 import Simplex.Messaging.Agent.Store.Common (withTransaction)
+import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import Simplex.Chat.Types (ChatPeerType (..), Profile (..))
 import qualified Simplex.Messaging.Crypto as C
@@ -503,6 +504,14 @@ ledgerRows ChatController {chatStore} table =
         <> table
         <> " ORDER BY entry_id"
 
+-- | The client's verdict on each row, in ledger order. The service has no such column: it computes
+-- the rows rather than checking what someone else computed.
+balanceChecks :: ChatController -> IO [Maybe Bool]
+balanceChecks ChatController {chatStore} =
+  withTransaction chatStore $ \db ->
+    map (fmap unBI . fromOnly)
+      <$> DB.query_ db "SELECT balance_checked FROM badge_ledger ORDER BY entry_id"
+
 -- The client copies the statement verbatim and authors nothing, so after a redemption both sides
 -- hold the same rows under the same entry ids.
 testClientReplicatesLedger :: HasCallStack => TestParams -> IO ()
@@ -519,6 +528,9 @@ testClientReplicatesLedger ps =
       -- the code credit and the first month, on both sides
       map (\(_, ch, m, _, _, t) -> (ch, m, t)) serviceLedger `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge")]
       clientLedger `shouldBe` serviceLedger
+      -- and re-ran both operations against them: the credit from the seed, the issue from the credit
+      checks <- balanceChecks (chatController alice)
+      checks `shouldBe` [Just True, Just True]
       -- redeeming again replays the statement, and must not duplicate a single row
       alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
       alice <## "badge already redeemed"
@@ -760,6 +772,10 @@ testRenewsAfterUnknownEntry ps =
       -- ledger, which re-stores the two rows already held and adds the month it issued
       map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed
         `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (0, 2, Just "grant"), (-1, 1, Just "badge")]
+      -- the issued row follows the badge row in the statement but the unknown one in the ledger,
+      -- and verifies all the same - the client cannot see that the service dropped a row
+      checks <- balanceChecks (chatController alice)
+      checks `shouldBe` [Just True, Just True, Nothing, Just True]
 
 -- The worker driven by chat start rather than by activate, and the only test where the client is
 -- given a lapse row to store: the months that passed while the app was stopped.
@@ -782,6 +798,9 @@ testRenewsAfterRestart ps =
       -- the lapse row was replicated rather than authored here
       serviceLedger <- ledgerRows cc "sx_badge_service_badge_ledger"
       renewed `shouldBe` serviceLedger
+      -- and re-run: the renewal's two rows against the tip the client held, not against a seed
+      checks <- balanceChecks (chatController alice)
+      checks `shouldBe` replicate 4 (Just True)
       -- a week missed costs only the day between the two steps: one pass does both
       waitShownIssued (chatController alice)