simplex-chat/src/Simplex/Chat/Badges/Ledger.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Simplex.Chat.Badges.Ledger
  ( emptyEntry,
    lapseEntry,
    grantEntry,
    issueEntry,
    debitEntry,
    chargeEntries,
    paidThrough,
    balanceChecked,
    addMonths,
    endOfMondayAfter,
    entryTypeColumns,
    EntryReferences (..),
    noEntryReferences,
    entryTypeFromColumns,
    creditTypeTag,
    debitTypeTag,
  )
where

import Data.Maybe (fromMaybe, maybeToList)
import Data.Text (Text)
import Data.Time.Calendar (addDays, addGregorianMonthsClip, toGregorian)
import Data.Time.Calendar.WeekDate (toWeekDate)
import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime)
import Simplex.Chat.Badges (BadgeType)
import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
import Simplex.Chat.PaymentService.Types (InvoiceId)
import qualified Simplex.Messaging.Crypto as C

-- The calendar difference overshoots by at most one month, so one comparison settles it.
monthsBetween :: UTCTime -> UTCTime -> Integer
monthsBetween from to
  | addMonths months from <= to = max 0 months
  | otherwise = max 0 (months - 1)
  where
    (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
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 = 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
emptyEntry t badgeType =
  StatementEntry
    { -- this entry is never stored, and every operation puts its own id on the entry it returns
      entryId = "",
      changeMonths = 0,
      balanceMonths = 0,
      balanceStartTs = t,
      balanceAnchorTs = t,
      balanceBadgeType = badgeType,
      wasPausedSince = Nothing,
      createdAt = t,
      entryType = SECredit SCOpening
    }

-- | Writes off the months that have passed.
lapseEntry :: UTCTime -> Text -> StatementEntry -> Maybe StatementEntry
lapseEntry t entryId e@StatementEntry {balanceMonths}
  | k == 0 = Nothing
  | otherwise =
      Just
        e
          { entryId,
            createdAt = t,
            changeMonths = negate k,
            balanceMonths = balanceMonths - k,
            balanceStartTs = monthAfter e k,
            entryType = SEDebit SDLapse
          }
  where
    k = elapsedMonths t e

-- | New months start where the current coverage ends, or at t if it has already lapsed - so they
-- are neither spent on the month still running nor backdated over a gap. Months of another tier
-- replace the balance, so they are granted only onto an empty one.
grantEntry :: UTCTime -> Text -> BadgeType -> Int -> StatementCreditType -> StatementEntry -> StatementEntry
grantEntry t entryId badgeType n credit e@StatementEntry {balanceMonths, balanceStartTs, balanceBadgeType}
  -- only a lapsed run, or one of another tier, restarts; topping up before coverage ends continues the
  -- run on its anchor, so buying a month at a time keeps the same day of month as buying a year at once
  | lapsed || badgeType /= balanceBadgeType = credited {balanceMonths = n, balanceStartTs = t, balanceAnchorTs = t}
  | otherwise = credited {balanceMonths = balanceMonths + n}
  where
    lapsed = balanceMonths == 0 && t > balanceStartTs
    credited = e {entryId, createdAt = t, changeMonths = n, balanceBadgeType = badgeType, entryType = SECredit credit}

-- | The period issued runs from the previous entry's balanceStartTs to this one's.
issueEntry :: UTCTime -> Text -> StatementEntry -> Maybe StatementEntry
issueEntry t entryId e@StatementEntry {balanceMonths, balanceStartTs}
  | balanceMonths <= 0 || balanceStartTs > t = Nothing
  | otherwise =
      Just
        e
          { entryId,
            createdAt = t,
            changeMonths = -1,
            balanceMonths = balanceMonths - 1,
            balanceStartTs = monthAfter e 1,
            entryType = SEDebit SDBadge
          }

-- | Takes every remaining month, even none; the balance start and anchor stay, so coverage ends where the issued months end.
debitEntry :: UTCTime -> Text -> StatementDebitType -> StatementEntry -> StatementEntry
debitEntry t entryId debit e@StatementEntry {balanceMonths} =
  e {entryId, createdAt = t, changeMonths = negate balanceMonths, balanceMonths = 0, entryType = SEDebit debit}

-- | A store charge's rows, dated to its billing period start so coverage follows the store's periods, or to
-- the tip when the period started before it was written, so createdAt never decreases: a lapse to that date,
-- the grant, and a lapse to now; the caller issues at now.
-- A charge of another tier ends the run with an upgrade debit naming ownKey before its grant restarts it.
chargeEntries :: UTCTime -> UTCTime -> BadgeType -> Int -> C.PublicKeyEd25519 -> Text -> (Text, Text, Text, Text) -> StatementEntry -> [StatementEntry]
chargeEntries periodStart now badgeType months ownKey chargeId (lapseBeforeId, debitId, grantId, lapseSinceId) tip@StatementEntry {balanceBadgeType, createdAt} =
  maybeToList lapsedBefore <> maybeToList debited <> [granted] <> maybeToList lapsedSince
  where
    otherTier = badgeType /= balanceBadgeType
    -- while the run continues on its anchor, dating the grant at the tip moves only the row's date;
    -- a run that has lapsed restarts at t
    t = max periodStart createdAt
    lapsedBefore = lapseEntry t lapseBeforeId tip
    current = fromMaybe tip lapsedBefore
    debited
      | otherTier && balanceMonths current /= 0 = Just $ debitEntry t debitId (SDUpgrade ownKey) current
      | otherwise = Nothing
    granted = grantEntry t grantId badgeType months (SCCharge chargeId) $ fromMaybe current debited
    lapsedSince = lapseEntry now lapseSinceId granted

-- 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 d@SDUpgrade {} -> matches $ debitEntry t "" d prev
      SEDebit d@SDTransferOut {} -> matches $ debitEntry t "" d prev
      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
        -- the recompute would agree, as a grant of another tier replaces the balance
        | tierSwitched -> Just False
        | otherwise -> matches $ grantEntry t "" (balanceBadgeType e) (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
    -- only a debit that emptied the old run may be followed by another tier, which the seed of a purchase with no ledger is not
    tierSwitched = balanceBadgeType e /= balanceBadgeType prev && not (emptiedByDebit prev)
    emptiedByDebit StatementEntry {balanceMonths, entryType} = case entryType of
      SEDebit _ -> balanceMonths == 0
      SECredit _ -> False
    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
      | tierSwitched = 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.
entryTypeColumns :: StatementEntryType -> (Text, Maybe Text, Maybe Text)
entryTypeColumns = \case
  SECredit c -> ("credit", Just $ creditTypeTag c, Nothing)
  SEDebit d -> ("debit", Nothing, Just $ debitTypeTag d)

creditTypeTag :: StatementCreditType -> Text
creditTypeTag = \case
  SCPayment _ -> "payment"
  SCCode -> "code"
  SCCharge _ -> "charge"
  SCSupport -> "support"
  SCTransferIn _ -> "transferIn"
  SCOpening -> "opening"
  SCUnknown {tag} -> tag

debitTypeTag :: StatementDebitType -> Text
debitTypeTag = \case
  SDRefund -> "refund"
  SDUpgrade _ -> "upgrade"
  SDTransferOut _ -> "transferOut"
  SDSupport -> "support"
  SDBadge -> "badge"
  SDLapse -> "lapse"
  SDUnknown {tag} -> tag

-- | What a ledger row's reference columns name. refPayment is Nothing when the row references no payment,
-- and Just Nothing when that payment had no invoice, as a store purchase has none.
data EntryReferences = EntryReferences
  { refPayment :: Maybe (Maybe InvoiceId),
    refChargeId :: Maybe Text,
    refFromPurchaseKey :: Maybe C.PublicKeyEd25519,
    refToPurchaseKey :: Maybe C.PublicKeyEd25519
  }

noEntryReferences :: EntryReferences
noEntryReferences = EntryReferences {refPayment = Nothing, refChargeId = Nothing, refFromPurchaseKey = Nothing, refToPurchaseKey = Nothing}

-- | Rebuilds only what the columns determine: constructors with no fields, and the types that name a
-- payment, a charge or a purchase, through the reference their row holds. The rest answer Nothing
-- rather than invent a payload.
-- The client stores each type's JSON and reads that first, so this is its fallback; the service has none.
entryTypeFromColumns :: EntryReferences -> Text -> Maybe Text -> Maybe Text -> Maybe StatementEntryType
entryTypeFromColumns EntryReferences {refPayment, refChargeId, refFromPurchaseKey, refToPurchaseKey} entryType credit_ debit_ = case (entryType, credit_, debit_) of
  ("credit", Just "payment", _) -> SECredit . SCPayment <$> refPayment
  ("credit", Just "charge", _) -> SECredit . SCCharge <$> refChargeId
  ("credit", Just "transferIn", _) -> SECredit . SCTransferIn <$> refFromPurchaseKey
  ("credit", Just t, _) -> SECredit <$> creditType t
  ("debit", _, Just "upgrade") -> SEDebit . SDUpgrade <$> refToPurchaseKey
  ("debit", _, Just "transferOut") -> SEDebit . SDTransferOut <$> refToPurchaseKey
  ("debit", _, Just t) -> SEDebit <$> debitType t
  _ -> Nothing
  where
    creditType = \case
      "code" -> Just SCCode
      "support" -> Just SCSupport
      "opening" -> Just SCOpening
      _ -> Nothing
    debitType = \case
      "badge" -> Just SDBadge
      "lapse" -> Just SDLapse
      "refund" -> Just SDRefund
      "support" -> Just SDSupport
      _ -> Nothing

addMonths :: Integer -> UTCTime -> UTCTime
addMonths n (UTCTime d t) = UTCTime (addGregorianMonthsClip n d) t

-- Every badge in a week expires together, revealing nothing about when it was bought.
-- The end of a Monday is the next Tuesday at 00:00, so this returns a Tuesday and 9 is right.
-- Returning a Monday instead would put the expiry on Sunday evening in the Americas, leaving a
-- renewal that failed there waiting for weekend support.
endOfMondayAfter :: UTCTime -> UTCTime
endOfMondayAfter (UTCTime d _) =
  let (_, _, dayOfWeek) = toWeekDate d -- 1 Monday .. 7 Sunday
   in UTCTime (addDays (toInteger (9 - dayOfWeek)) d) 0