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

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