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.