mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-09-17 10:15:47 +00:00
core: renew badges monthly and alert when support ends (#7448)
This commit is contained in:
spaced4ndy
@@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module BadgeService.Service
|
||||
( ServiceState (..),
|
||||
@@ -10,6 +11,8 @@ module BadgeService.Service
|
||||
checkIssuerKey,
|
||||
badgeService,
|
||||
badgeServiceCLI,
|
||||
badgeServiceResponse,
|
||||
badgeErrorRetryAfter,
|
||||
IssueCodeOpts (..),
|
||||
issueBadgeCode,
|
||||
)
|
||||
@@ -28,15 +31,16 @@ import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.Attoparsec.ByteString.Char8 as A
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Data.Char (isSpace)
|
||||
import Data.Either (fromRight)
|
||||
import Data.Functor (($>))
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Maybe (fromMaybe, maybeToList)
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar (addDays, addGregorianMonthsClip)
|
||||
import Data.Time.Calendar.WeekDate (toWeekDate)
|
||||
import Data.Time.Clock (UTCTime (..), getCurrentTime)
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
import Data.Word (Word32)
|
||||
import Simplex.Chat.Badges
|
||||
import Simplex.Chat.Badges.Code
|
||||
import Simplex.Chat.Badges.Ledger
|
||||
import Simplex.Chat.Badges.Service
|
||||
import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
|
||||
import Simplex.Chat.Bot (initializeBotAddress')
|
||||
@@ -224,7 +228,16 @@ responseObject r = case J.toJSON r of
|
||||
_ -> KM.fromList [("type", J.String "error"), ("code", J.toJSON BSEInternal)]
|
||||
|
||||
errorResponse :: BadgeServiceErrorCode -> BadgeServiceResponse
|
||||
errorResponse code = BSPError {code, message = Nothing, retryAfter = Nothing}
|
||||
errorResponse code = BSPError {code, message = Nothing, retryAfter = badgeErrorRetryAfter code}
|
||||
|
||||
-- | Seconds, for the three codes badges-rpc.md marks transient. Every other code is terminal for
|
||||
-- the command attempted - internal included, which would otherwise press a failing service.
|
||||
badgeErrorRetryAfter :: BadgeServiceErrorCode -> Maybe Word32
|
||||
badgeErrorRetryAfter = \case
|
||||
BSEPaymentPending -> Just 300
|
||||
BSEProviderUnavailable -> Just 300
|
||||
BSERateLimited -> Just 60
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
-- | The agent verified the signature, so sigKey is a key the sender holds - a purchaseKey that
|
||||
@@ -239,6 +252,9 @@ badgeServiceResponse key cc sigKey reqData = case J.fromJSON (J.Object reqData)
|
||||
BSCRedeemBadgeCode {masterKey, code} -> case purchaseKey of
|
||||
Just k -> redeemCode key cc k masterKey code
|
||||
Nothing -> pure $ errorResponse BSEBadRequest
|
||||
BSCIssueBadge {balance} -> case purchaseKey of
|
||||
Just k -> issueBadgeCmd key cc k balance
|
||||
Nothing -> pure $ errorResponse BSEBadRequest
|
||||
-- every command but redeemBadgeCode needs a key the service already knows: that one
|
||||
-- creates the purchase, so its key is unknown on a first redemption
|
||||
_ -> case purchaseKey of
|
||||
@@ -249,64 +265,115 @@ badgeServiceResponse key cc sigKey reqData = case J.fromJSON (J.Object reqData)
|
||||
Right False -> pure $ errorResponse BSEUnknownPurchaseKey
|
||||
Left _ -> pure $ errorResponse BSEInternal
|
||||
|
||||
-- | The only clock the service reads, so a test can move both sides of a request together.
|
||||
badgeNow :: ChatController -> IO UTCTime
|
||||
badgeNow ChatController {config = ChatConfig {badgeCurrentTime}} = badgeCurrentTime
|
||||
|
||||
randomId :: ChatController -> IO T.Text
|
||||
randomId cc = safeDecodeUtf8 . strEncode <$> atomically (C.randomBytes 16 (random cc))
|
||||
|
||||
-- | Neither value comes from the caller: the badge type is the entry's, the expiry is derived
|
||||
-- from the period end it carries.
|
||||
credentialForEntry :: BadgeIssuerKey -> BadgeMasterKey -> StatementEntry -> IO (Either String (StatementEntry, BadgeCredential))
|
||||
credentialForEntry BadgeIssuerKey {keyIdx, secretKey} masterKey e@StatementEntry {balanceStartTs = periodEnd, balanceBadgeType} = do
|
||||
let badgeInfo = BadgeInfo {badgeType = balanceBadgeType, badgeExpiry = endOfMondayAfter periodEnd, badgeExtra = ""}
|
||||
fmap (e,) <$> issueBadge keyIdx secretKey (VerifiedBadgeRequest BadgeRequest {masterKey, badgeInfo})
|
||||
|
||||
-- | Pairs the issued entry with the one before it, which the writer needs for the period start.
|
||||
issuanceAfter :: StatementEntry -> (StatementEntry, BadgeCredential) -> (StatementEntry, StatementEntry, BadgeCredential)
|
||||
issuanceAfter previous (issued, credential) = (previous, issued, credential)
|
||||
|
||||
credentialResponse :: Maybe BadgeCredential -> Maybe T.Text -> [StatementEntry] -> BadgeServiceResponse
|
||||
credentialResponse credential previousEntryId entries =
|
||||
BSPBadgeCredential {credential, receipt = Nothing, statement = BadgeStatement {entries, previousEntryId}}
|
||||
|
||||
-- | Nothing is written until the credential is signed, so a signing failure leaves the code
|
||||
-- unspent rather than spent with nothing behind it.
|
||||
redeemCode :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeMasterKey -> T.Text -> IO BadgeServiceResponse
|
||||
redeemCode BadgeIssuerKey {keyIdx, secretKey} cc purchaseKey masterKey codeText = case parseBadgeCode codeText of
|
||||
redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText of
|
||||
Nothing -> pure $ errorResponse BSECodeInvalid
|
||||
Just code ->
|
||||
withDB' "getBadgeCode" cc (`getBadgeCode` badgeCodeHash code) >>= \case
|
||||
withDB "getBadgeCode" cc (readCode code) >>= \case
|
||||
Left _ -> pure $ errorResponse BSEInternal
|
||||
Right Nothing -> pure $ errorResponse BSECodeInvalid
|
||||
Right (Just IssuedCode {badgeCodeId, badgeType, redemption}) -> case redeemedResponse redemption of
|
||||
Just resp -> pure resp
|
||||
Nothing -> do
|
||||
now <- getCurrentTime
|
||||
-- TODO [badges] the code's months are ignored until the ledger credits them
|
||||
let periodEnd = addMonths 1 now
|
||||
badgeInfo = BadgeInfo {badgeType, badgeExpiry = endOfSundayAfter periodEnd, badgeExtra = ""}
|
||||
issueBadge keyIdx secretKey (VerifiedBadgeRequest BadgeRequest {masterKey, badgeInfo}) >>= \case
|
||||
Right (Left resp) -> pure resp
|
||||
Right (Right IssuedCode {badgeCodeId, badgeType, months}) -> do
|
||||
now <- badgeNow cc
|
||||
(grantUuid, issueUuid) <- (,) <$> randomId cc <*> randomId cc
|
||||
-- the purchase is created here, so there is no ledger to lapse
|
||||
-- TODO [badges] a top-up grants onto an existing ledger, and must lapse before it or the
|
||||
-- months it adds are counted from a start already in the past
|
||||
let granted = grantEntry now grantUuid months SCCode $ emptyEntry now badgeType
|
||||
-- a grant of at least one month starting now always has a month to issue
|
||||
case issueEntry now issueUuid granted of
|
||||
Nothing -> pure $ errorResponse BSEInternal
|
||||
Just issued -> credentialForEntry key masterKey issued >>= \case
|
||||
Left e -> logError ("badge service signing failed: " <> T.pack e) $> errorResponse BSEInternal
|
||||
Right credential -> do
|
||||
issuanceId <- safeDecodeUtf8 . strEncode <$> atomically (C.randomBytes 16 $ random cc)
|
||||
let newRedemption =
|
||||
NewBadgeCodeRedemption
|
||||
{ badgeCodeId,
|
||||
issuanceId,
|
||||
purchaseKey,
|
||||
masterKey,
|
||||
badgeType,
|
||||
credential,
|
||||
periodStart = now,
|
||||
periodEnd,
|
||||
expiry = endOfSundayAfter periodEnd
|
||||
}
|
||||
Right signed -> do
|
||||
-- re-read: a concurrent redemption may have landed while this one was signing
|
||||
r <- withDB "writeCodeRedemption" cc $ \db ->
|
||||
liftIO (getBadgeCode db $ badgeCodeHash code) >>= \case
|
||||
Just IssuedCode {redemption = current} | Just resp <- redeemedResponse current -> pure resp
|
||||
_ -> liftIO $ credentialResponse credential <$ writeCodeRedemption db newRedemption now
|
||||
pure $ either (const $ errorResponse BSEInternal) id r
|
||||
readCode code db >>= \case
|
||||
Left resp -> pure resp
|
||||
Right _ -> liftIO $ do
|
||||
purchaseId <- createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType} now
|
||||
appendLedgerPlan db purchaseId [granted] $ Just $ issuanceAfter granted signed
|
||||
entries_ <- getLedgerEntries db purchaseId 0
|
||||
pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_
|
||||
pure $ fromRight (errorResponse BSEInternal) r
|
||||
where
|
||||
-- one definition, used before signing and again inside the write transaction
|
||||
redeemedResponse = \case
|
||||
CodeUnredeemed -> Nothing
|
||||
CodeRedeemedUnreadable -> Just $ errorResponse BSEInternal
|
||||
CodeRedeemed RedeemedCode {purchaseKey = k, credential}
|
||||
| k == purchaseKey -> Just $ credentialResponse credential
|
||||
| otherwise -> Just $ errorResponse BSECodeUsed
|
||||
-- used before signing and again inside the write transaction; every Left is a finished
|
||||
-- response, an unknown code included
|
||||
readCode code db = liftIO $
|
||||
getBadgeCode db (badgeCodeHash code) >>= \case
|
||||
Nothing -> pure $ Left $ errorResponse BSECodeInvalid
|
||||
Just c@IssuedCode {redemption} -> fmap (const c) <$> checkUnspent db redemption
|
||||
checkUnspent db = \case
|
||||
CodeUnredeemed -> pure $ Right ()
|
||||
CodeRedeemedUnreadable -> pure $ Left $ errorResponse BSEInternal
|
||||
CodeRedeemed RedeemedCode {purchaseKey = k, badgePurchaseId, credential}
|
||||
| k /= purchaseKey -> pure $ Left $ errorResponse BSECodeUsed
|
||||
-- the whole ledger, so a client that lost the first response still ends holding it
|
||||
| otherwise ->
|
||||
maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing)
|
||||
<$> getLedgerEntries db badgePurchaseId 0
|
||||
|
||||
-- TODO [badges] the statement is empty until the ledger is written
|
||||
credentialResponse :: BadgeCredential -> BadgeServiceResponse
|
||||
credentialResponse credential =
|
||||
BSPBadgeCredential {credential = Just credential, receipt = Nothing, statement = BadgeStatement {entries = [], previousEntryId = 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 Sunday is the next Monday at 00:00, so this returns a Monday and 8 is right.
|
||||
endOfSundayAfter :: UTCTime -> UTCTime
|
||||
endOfSundayAfter (UTCTime d _) =
|
||||
let (_, _, dayOfWeek) = toWeekDate d -- 1 Monday .. 7 Sunday
|
||||
in UTCTime (addDays (toInteger (8 - dayOfWeek)) d) 0
|
||||
-- | The purchase is reached through the verified signer key and no other way.
|
||||
issueBadgeCmd :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeBalance -> IO BadgeServiceResponse
|
||||
issueBadgeCmd key cc 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
|
||||
case purchase_ of
|
||||
Left _ -> pure $ errorResponse BSEInternal
|
||||
Right Nothing -> pure $ errorResponse BSEUnknownPurchaseKey
|
||||
Right (Just (ServicePurchase {badgePurchaseId, masterKey, badgeType}, tip)) -> do
|
||||
(lapseUuid, issueUuid) <- (,) <$> randomId cc <*> randomId cc
|
||||
let tipEntry = fromMaybe (emptyEntry now badgeType) tip
|
||||
lapsed = lapseEntry now lapseUuid tipEntry
|
||||
current = fromMaybe tipEntry lapsed
|
||||
case issueEntry now issueUuid current of
|
||||
Nothing -> writeIssued badgePurchaseId tip (maybeToList lapsed) now Nothing
|
||||
Just e ->
|
||||
credentialForEntry key masterKey e >>= \case
|
||||
Left err -> logError ("badge service signing failed: " <> T.pack err) $> errorResponse BSEInternal
|
||||
Right signed ->
|
||||
writeIssued badgePurchaseId tip (maybeToList lapsed) now $ Just $ issuanceAfter current signed
|
||||
where
|
||||
-- the rows were computed from a tip that another request may have moved, and an issuance was
|
||||
-- signed against it - so write only if it is still the tip
|
||||
writeIssued purchaseId tip rows t issuance_ = do
|
||||
r <- withDB "issueBadge" cc $ \db -> liftIO $ do
|
||||
tip' <- getLedgerTip db purchaseId
|
||||
when (fmap entryId tip' == fmap entryId tip) $ appendLedgerPlan db purchaseId rows issuance_
|
||||
issueResponse db purchaseId t
|
||||
pure $ fromRight (errorResponse BSEInternal) r
|
||||
-- entries after the one asserted, or the whole ledger when this purchase does not hold it.
|
||||
-- Only the asserted entry's identity is read, never the months it claims.
|
||||
issueResponse db purchaseId t = do
|
||||
let StatementEntry {entryId = assertedUuid} = lastEntry
|
||||
assertedId <- getLedgerEntryId db purchaseId assertedUuid
|
||||
-- TODO [badges] when the assertion does not resolve, heal the ledger and restate it as a
|
||||
-- single opening credit (badges-rpc.md), rather than resending the whole history
|
||||
entries_ <- getLedgerEntries db purchaseId (fromMaybe 0 assertedId)
|
||||
credential_ <- getCurrentIssuance db purchaseId t
|
||||
pure $ maybe (errorResponse BSEInternal) (credentialResponse credential_ (assertedUuid <$ assertedId)) entries_
|
||||
|
||||
@@ -9,10 +9,17 @@ module BadgeService.Store
|
||||
( IssuedCode (..),
|
||||
CodeRedemption (..),
|
||||
RedeemedCode (..),
|
||||
NewBadgeCodeRedemption (..),
|
||||
NewCodePurchase (..),
|
||||
ServicePurchase (..),
|
||||
getBadgeCode,
|
||||
purchaseKeyExists,
|
||||
writeCodeRedemption,
|
||||
getPurchaseByKey,
|
||||
getLedgerTip,
|
||||
getLedgerEntryId,
|
||||
getLedgerEntries,
|
||||
getCurrentIssuance,
|
||||
appendLedgerPlan,
|
||||
createCodePurchase,
|
||||
insertBadgeCode,
|
||||
)
|
||||
where
|
||||
@@ -24,6 +31,8 @@ import Data.Int (Int64)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Simplex.Chat.Badges (BadgeCredential, BadgeMasterKey (..), BadgeType)
|
||||
import Simplex.Chat.Badges.Ledger
|
||||
import Simplex.Chat.Badges.Service (StatementEntry (..))
|
||||
import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus, BadgePurchaseStatus (..))
|
||||
import Simplex.Chat.Store.Shared (insertedRowId)
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..))
|
||||
@@ -32,16 +41,17 @@ import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow')
|
||||
|
||||
#if defined(dbPostgres)
|
||||
import Database.PostgreSQL.Simple (Only (..))
|
||||
import Database.PostgreSQL.Simple (Only (..), (:.) (..))
|
||||
import Database.PostgreSQL.Simple.SqlQQ (sql)
|
||||
#else
|
||||
import Database.SQLite.Simple (Only (..))
|
||||
import Database.SQLite.Simple (Only (..), (:.) (..))
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
#endif
|
||||
|
||||
data IssuedCode = IssuedCode
|
||||
{ badgeCodeId :: Int64,
|
||||
badgeType :: BadgeType,
|
||||
months :: Int,
|
||||
redemption :: CodeRedemption
|
||||
}
|
||||
|
||||
@@ -53,23 +63,24 @@ data CodeRedemption
|
||||
| CodeRedeemedUnreadable
|
||||
|
||||
data RedeemedCode = RedeemedCode
|
||||
{ purchaseKey :: C.PublicKeyEd25519,
|
||||
{ badgePurchaseId :: Int64,
|
||||
purchaseKey :: C.PublicKeyEd25519,
|
||||
credential :: BadgeCredential
|
||||
}
|
||||
|
||||
-- Everything writeCodeRedemption inserts, so that the purchase, its issuance and the spent code
|
||||
-- are written in one transaction. If the code were marked redeemed and one of the other writes
|
||||
-- failed, it would be spent with no credential behind it, and nothing can reissue it.
|
||||
data NewBadgeCodeRedemption = NewBadgeCodeRedemption
|
||||
-- Its rows and issuance are appended by 'appendLedgerPlan' in the same transaction: a code marked
|
||||
-- redeemed while another write failed would be spent with no credential, and nothing reissues it.
|
||||
data NewCodePurchase = NewCodePurchase
|
||||
{ badgeCodeId :: Int64,
|
||||
issuanceId :: Text,
|
||||
purchaseKey :: C.PublicKeyEd25519,
|
||||
masterKey :: BadgeMasterKey,
|
||||
badgeType :: BadgeType,
|
||||
credential :: BadgeCredential,
|
||||
periodStart :: UTCTime,
|
||||
periodEnd :: UTCTime,
|
||||
expiry :: UTCTime
|
||||
badgeType :: BadgeType
|
||||
}
|
||||
|
||||
data ServicePurchase = ServicePurchase
|
||||
{ badgePurchaseId :: Int64,
|
||||
masterKey :: BadgeMasterKey,
|
||||
badgeType :: BadgeType
|
||||
}
|
||||
|
||||
getBadgeCode :: DB.Connection -> ByteString -> IO (Maybe IssuedCode)
|
||||
@@ -78,23 +89,23 @@ getBadgeCode db codeHash =
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT c.badge_code_id, c.badge_type, p.purchase_key, i.credential
|
||||
SELECT c.badge_code_id, c.badge_type, c.months, p.badge_purchase_id, p.purchase_key, i.credential
|
||||
FROM sx_badge_service_badge_codes c
|
||||
LEFT JOIN sx_badge_service_badge_purchases p ON p.badge_code_id = c.badge_code_id
|
||||
LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id
|
||||
WHERE c.code_hash = ?
|
||||
ORDER BY i.created_at DESC
|
||||
ORDER BY i.period_end DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(Only (Binary codeHash))
|
||||
where
|
||||
toCode (badgeCodeId, badgeType, purchaseKey_, credential_) =
|
||||
IssuedCode {badgeCodeId, badgeType, redemption = codeRedemption purchaseKey_ credential_}
|
||||
codeRedemption purchaseKey_ credential_ = case purchaseKey_ of
|
||||
Nothing -> CodeUnredeemed
|
||||
Just purchaseKey -> case decodeCredential =<< credential_ of
|
||||
Just credential -> CodeRedeemed RedeemedCode {purchaseKey, credential}
|
||||
toCode (badgeCodeId, badgeType, months, purchaseId_, purchaseKey_, credential_) =
|
||||
IssuedCode {badgeCodeId, badgeType, months, redemption = codeRedemption purchaseId_ purchaseKey_ credential_}
|
||||
codeRedemption purchaseId_ purchaseKey_ credential_ = case (purchaseId_, purchaseKey_) of
|
||||
(Just badgePurchaseId, Just purchaseKey) -> case decodeCredential =<< credential_ of
|
||||
Just credential -> CodeRedeemed RedeemedCode {badgePurchaseId, purchaseKey, credential}
|
||||
Nothing -> CodeRedeemedUnreadable
|
||||
_ -> CodeUnredeemed
|
||||
decodeCredential (Binary bs) = J.decodeStrict' bs
|
||||
|
||||
purchaseKeyExists :: DB.Connection -> C.PublicKeyEd25519 -> IO Bool
|
||||
@@ -102,9 +113,126 @@ purchaseKeyExists db key =
|
||||
maybeFirstRow' False (\(Only (_ :: Int64)) -> True) $
|
||||
DB.query db "SELECT badge_purchase_id FROM sx_badge_service_badge_purchases WHERE purchase_key = ?" (Only key)
|
||||
|
||||
-- one transaction: the caller has already signed, so no code is left spent without a credential
|
||||
writeCodeRedemption :: DB.Connection -> NewBadgeCodeRedemption -> UTCTime -> IO ()
|
||||
writeCodeRedemption db NewBadgeCodeRedemption {badgeCodeId, issuanceId, purchaseKey, masterKey = BadgeMasterKey mk, badgeType, credential, periodStart, periodEnd, expiry} now = do
|
||||
-- | The only route from a command to a purchase, so a client cannot name one it cannot sign for.
|
||||
getPurchaseByKey :: DB.Connection -> C.PublicKeyEd25519 -> IO (Maybe ServicePurchase)
|
||||
getPurchaseByKey db key =
|
||||
maybeFirstRow toPurchase $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT badge_purchase_id, master_key, current_badge_type
|
||||
FROM sx_badge_service_badge_purchases
|
||||
WHERE purchase_key = ?
|
||||
|]
|
||||
(Only key)
|
||||
where
|
||||
toPurchase (badgePurchaseId, Binary mk, badgeType) =
|
||||
ServicePurchase {badgePurchaseId, masterKey = BadgeMasterKey mk, badgeType}
|
||||
|
||||
getLedgerTip :: DB.Connection -> Int64 -> IO (Maybe StatementEntry)
|
||||
getLedgerTip db purchaseId =
|
||||
maybeFirstRow' Nothing toEntry $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type,
|
||||
entry_type, entry_credit_type, entry_debit_type, service_created_at
|
||||
FROM sx_badge_service_badge_ledger
|
||||
WHERE badge_purchase_id = ?
|
||||
ORDER BY entry_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(Only purchaseId)
|
||||
|
||||
-- | The uuid is the client's claim about its last held entry, so the lookup is scoped to its own
|
||||
-- purchase - an entry_id taken from another ledger would silently skip rows of this one.
|
||||
getLedgerEntryId :: DB.Connection -> Int64 -> Text -> IO (Maybe Int64)
|
||||
getLedgerEntryId db purchaseId entryUuid =
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
"SELECT entry_id FROM sx_badge_service_badge_ledger WHERE badge_purchase_id = ? AND entry_uuid = ?"
|
||||
(purchaseId, entryUuid)
|
||||
|
||||
-- | 0 for the whole ledger, as entry_id starts at 1. 'Nothing' when a stored row has a type this
|
||||
-- version cannot represent, rather than sending it changed into another.
|
||||
getLedgerEntries :: DB.Connection -> Int64 -> Int64 -> IO (Maybe [StatementEntry])
|
||||
getLedgerEntries db purchaseId afterEntryId =
|
||||
mapM toEntry
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type,
|
||||
entry_type, entry_credit_type, entry_debit_type, service_created_at
|
||||
FROM sx_badge_service_badge_ledger
|
||||
WHERE badge_purchase_id = ? AND entry_id > ?
|
||||
ORDER BY entry_id
|
||||
|]
|
||||
(purchaseId, afterEntryId)
|
||||
|
||||
toEntry :: (Text, Int, Int, UTCTime, UTCTime, BadgeType, Text, Maybe Text, Maybe Text, UTCTime) -> Maybe StatementEntry
|
||||
toEntry (entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, entryType_, credit_, debit_, createdAt) =
|
||||
(\entryType -> StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince = Nothing, createdAt, entryType})
|
||||
<$> entryTypeFromColumns entryType_ credit_ debit_
|
||||
|
||||
-- | Answers a repeat inside an issued month, rather than signing the same content twice.
|
||||
getCurrentIssuance :: DB.Connection -> Int64 -> UTCTime -> IO (Maybe BadgeCredential)
|
||||
getCurrentIssuance db purchaseId now = do
|
||||
rs <-
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT credential FROM sx_badge_service_badge_issuances
|
||||
WHERE badge_purchase_id = ? AND period_end > ?
|
||||
ORDER BY period_end DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(purchaseId, now)
|
||||
pure $ case rs of
|
||||
[Only (Binary bs)] -> J.decodeStrict' bs
|
||||
_ -> Nothing
|
||||
|
||||
-- | The issuance is the entry that spends the month and the one before it, which give the period.
|
||||
-- TODO [badges] also write the reference columns - payment_id, charge_id, from_purchase_id,
|
||||
-- to_purchase_id - for the entry types that carry one. Only the tag is written today, so a
|
||||
-- payment, charge, transferIn, upgrade or transferOut row would be stored without its reference.
|
||||
appendLedgerPlan :: DB.Connection -> Int64 -> [StatementEntry] -> Maybe (StatementEntry, StatementEntry, BadgeCredential) -> IO ()
|
||||
appendLedgerPlan db purchaseId rows issuance_ = do
|
||||
mapM_ appendRow rows
|
||||
case issuance_ of
|
||||
Nothing -> pure ()
|
||||
Just (previous, issued@StatementEntry {entryId, balanceStartTs = periodEnd, balanceBadgeType, createdAt}, credential) -> do
|
||||
rowId <- appendRow issued
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO sx_badge_service_badge_issuances
|
||||
(issuance_id, badge_purchase_id, entry_id, badge_type, period_start, period_end, expiry, credential, created_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
-- the issued entry's uuid is the issuance id: one issuance per such entry, and entry uuids
|
||||
-- are already unique across the ledger, so nothing has to be drawn for it
|
||||
( (entryId, purchaseId, rowId, balanceBadgeType)
|
||||
:. (balanceStartTs previous, periodEnd, endOfMondayAfter periodEnd, Binary (LB.toStrict $ J.encode credential), createdAt)
|
||||
)
|
||||
where
|
||||
appendRow StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, createdAt, entryType} = do
|
||||
let (entryTypeT, creditType, debitType) = entryTypeColumns entryType
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO sx_badge_service_badge_ledger
|
||||
(entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_anchor_ts,
|
||||
balance_badge_type, service_created_at, created_at, entry_type, entry_credit_type, entry_debit_type)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
((entryId, purchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs) :. (balanceBadgeType, createdAt, createdAt, entryTypeT, creditType, debitType))
|
||||
insertedRowId db
|
||||
|
||||
-- redeemed_at is stamped here, so this must share a transaction with the credential's rows:
|
||||
-- a code marked spent without one can never be reissued
|
||||
createCodePurchase :: DB.Connection -> NewCodePurchase -> UTCTime -> IO Int64
|
||||
createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
@@ -114,15 +242,8 @@ writeCodeRedemption db NewBadgeCodeRedemption {badgeCodeId, issuanceId, purchase
|
||||
|]
|
||||
(purchaseKey, Binary mk, badgeType, badgeType, PSIssued, badgeCodeId, now, now)
|
||||
purchaseId <- insertedRowId db
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO sx_badge_service_badge_issuances
|
||||
(issuance_id, badge_purchase_id, badge_type, period_start, period_end, expiry, credential, created_at)
|
||||
VALUES (?,?,?,?,?,?,?,?)
|
||||
|]
|
||||
(issuanceId, purchaseId, badgeType, periodStart, periodEnd, expiry, Binary (LB.toStrict $ J.encode credential), now)
|
||||
DB.execute db "UPDATE sx_badge_service_badge_codes SET redeemed_at = ? WHERE badge_code_id = ?" (now, badgeCodeId)
|
||||
pure purchaseId
|
||||
|
||||
insertBadgeCode :: DB.Connection -> ByteString -> BadgeType -> Int -> BadgeCodePaymentStatus -> UTCTime -> IO ()
|
||||
insertBadgeCode db codeHash badgeType months paymentStatus now =
|
||||
|
||||
@@ -336,6 +336,7 @@ undocumentedCommands =
|
||||
[ "APIAbortSwitchContact",
|
||||
"APIAbortSwitchGroupMember",
|
||||
"APIAcceptConditions",
|
||||
"APIAckBadgeAlert",
|
||||
"APIActivateChat",
|
||||
"APIAddGroupShortLink",
|
||||
"APIAddMyAddressShortLink",
|
||||
@@ -371,6 +372,7 @@ undocumentedCommands =
|
||||
"APIExportArchive",
|
||||
"APIForwardChatItems",
|
||||
"APIGetAppSettings",
|
||||
"APIGetBadgeState",
|
||||
"APIGetCallInvitations",
|
||||
"APIGetChat",
|
||||
"APIGetChatContentTypes",
|
||||
|
||||
@@ -172,6 +172,8 @@ undocumentedEvents =
|
||||
"CEvtAgentConnsDeleted",
|
||||
"CEvtAgentRcvQueuesDeleted",
|
||||
"CEvtAgentUserDeleted",
|
||||
"CEvtBadgeAlert",
|
||||
"CEvtBadgeChanged",
|
||||
"CEvtBusinessRequestAlreadyAccepted",
|
||||
"CEvtCallAnswer",
|
||||
"CEvtCallEnded",
|
||||
|
||||
@@ -130,6 +130,7 @@ undocumentedResponses =
|
||||
"CRArchiveExported",
|
||||
"CRArchiveImported",
|
||||
"CRBadgeRedeemed",
|
||||
"CRBadgeState",
|
||||
"CRBroadcastSent",
|
||||
"CRCallInvitations",
|
||||
"CRChatCleared",
|
||||
|
||||
@@ -27,7 +27,7 @@ A timeout hides the outcome, so the client repeats the identical signed request
|
||||
|
||||
## Commands
|
||||
|
||||
`purchaseBadge`, `upgradeBadgeSubscription`, and `issueBadge` carry `badgeRequest`, the signer's input (`BadgeRequest`, `Simplex.Chat.Badges`): the service signs exactly this content or rejects the command. The proposed `badgeExpiry` is capped by the funded coverage (`sundayAfter`, model §3) and is required — a credential always expires, and a badge that does not is expressed as a long finite term; `badgeExtra` is reserved and must be empty.
|
||||
`purchaseBadge` and `upgradeBadgeSubscription` carry `badgeRequest`, the signer's input (`BadgeRequest`, `Simplex.Chat.Badges`): the service signs exactly this content or rejects the command. The proposed `badgeExpiry` is capped by the funded coverage (`sundayAfter`, model §3) and is required — a credential always expires, and a badge that does not is expressed as a long finite term; `badgeExtra` is reserved and must be empty. `issueBadge` carries no `badgeRequest`: the tier, the master key and the expiry are all the service's own, so there is nothing for the client to state.
|
||||
|
||||
- `getBadgeCatalog` → `badgeCatalog` — the prices and offers; signed, also the purchase's `badgeStatement`. Store builds never send it: prices come from the store and SKUs from app config.
|
||||
- `getBadgeInvoice` → `badgeInvoice` — prices the purchase for `badgeInfo` and `paymentVia` (`card` — Stripe; `crypto` — btc, xmr). The response holds the generic `invoice` — `invoiceId`, `price`, `discount`, the upgrade `credit`, `amount` = price − discount − credit, `currency`, `expiresAt`, and `paymentTo` (`url` for card; `address` and `cryptoAmount` for crypto) — beside the badge part, `badgeType` and `months`. `priceId` pins the price the client displayed; `offerId` selects a discounted duration, and its absence buys one month at that price. Price and offer status is checked here only: `deprecated` is still accepted, `disabled` is rejected; a badge type with no active price yields `product_unavailable`.
|
||||
@@ -35,7 +35,7 @@ A timeout hides the outcome, so the client repeats the identical signed request
|
||||
- `purchaseBadge` → `badgeCredential` — verifies the funding (`apple` JWS offline; `google` token via the Publisher API; `invoice` against webhook-confirmed settlement, `payment_pending` until it lands; `receipt`), records the credit, and issues the first credential, in one round trip. The response `receipt` is the recovery bearer secret (model § recovery); the service stores its hash; lifetime badges receive none.
|
||||
- Funding by `receipt` is a transfer (post-MVP): the unissued months of the purchase that receipt belongs to move to the signing key, recorded as `debit(transferOut)` on the source and `credit(transferIn)` on the new purchase, and the presented receipt is retired for a fresh one. The transferred period's issuance debits a month like any other. Lifetime badges hold no receipt, so support handles them.
|
||||
- `upgradeBadgeSubscription` → `badgeCredential` — the app-led store subscription change, on the same key: verifies the store evidence of the replaced subscription and records the new plan; an immediate upgrade returns the new credential, a deferred change returns none.
|
||||
- `issueBadge` → `badgeCredential` — issues the next period from the balance, the only source of issuance. The ledger is advanced first; the credential is signed before the `debit(badge)` and issuance rows are written, in one transaction. An exhausted balance yields no `credential`; the `statement` shows why. Issuing on a paused badge resumes it (model 2.13).
|
||||
- `issueBadge` → `badgeCredential` — issues the next period from the balance, the only source of issuance. It carries `balance` alone: the credential is signed with the purchase's stored master key, for the type the balance funds, expiring at the `sundayAfter` of the period issued. The ledger is advanced first; the credential is signed before the `debit(badge)` and issuance rows are written, in one transaction. An exhausted balance yields no `credential`; the `statement` shows why. Issuing on a paused badge resumes it (model 2.13).
|
||||
- `pauseBadge` (post-MVP) → `badgeCredential` — suspends issuance and lapse (model 2.13).
|
||||
|
||||
## Upgrades
|
||||
@@ -53,9 +53,9 @@ Always a new purchase under a new key, except store subscriptions, where the sto
|
||||
|
||||
## Statement and balance
|
||||
|
||||
The ledger is written by the service alone (model §3); the client keeps a verbatim replica and computes the effective balance from its last entry and the time.
|
||||
The ledger is written by the service alone (model §3); the client keeps a verbatim replica and computes the effective balance from its last entry and the time. Month boundaries are counted from `balanceAnchorTs`, the start of the current run of months, and not from `balanceStartTs` — counting from the moving start would compound the day-of-month clipping of a short month, so a run beginning 31 January would reach 28 February and never return to the 31st. The service sets a new anchor only where a lapsed run restarts; months granted while coverage still runs extend it on its existing anchor.
|
||||
|
||||
`statement` — `entries`, and `previousEntryId` when they attach after an entry the client holds; its absence marks entries that attach to nothing. Each entry states `entryId`, the signed `changeMonths`, the resulting `balanceMonths`, `balanceStartTs`, and `balanceBadgeType`, `wasPausedSince` on the entry ending a pause, `createdAt`, and `entryType` — `credit`: `payment {invoiceId?}`, `charge {chargeId}`, `support`, `transferIn {fromPurchaseKey}`, `opening`; `debit`: `refund`, `upgrade {toPurchaseKey}`, `transferOut {toPurchaseKey}`, `support`, `badge`, `lapse`. An unknown type is stored as received and decoded after an app upgrade.
|
||||
`statement` — `entries`, and `previousEntryId` when they attach after an entry the client holds; its absence marks entries that attach to nothing. Each entry states `entryId`, the signed `changeMonths`, the resulting `balanceMonths`, `balanceStartTs`, `balanceAnchorTs`, and `balanceBadgeType`, `wasPausedSince` on the entry ending a pause, `createdAt`, and `entryType` — `credit`: `payment {invoiceId?}`, `code`, `charge {chargeId}`, `support`, `transferIn {fromPurchaseKey}`, `opening`; `debit`: `refund`, `upgrade {toPurchaseKey}`, `transferOut {toPurchaseKey}`, `support`, `badge`, `lapse`. A code grant is `code` rather than `payment` with no `invoiceId`: the invoice of a code belongs to whoever bought it, and the redeemer's ledger must never reference it. An unknown type is stored as received and decoded after an app upgrade.
|
||||
|
||||
`balance` — `lastEntry`, the client's last entry, asserting the position and the months it believes it holds.
|
||||
|
||||
|
||||
@@ -191,6 +191,10 @@
|
||||
"changeMonths": {"type": "int16"},
|
||||
"balanceMonths": {"type": "uint16"},
|
||||
"balanceStartTs": {"type": "timestamp"},
|
||||
"balanceAnchorTs": {
|
||||
"type": "timestamp",
|
||||
"metadata": {"comment": "start of the current run of months; boundaries are counted from it"}
|
||||
},
|
||||
"balanceBadgeType": {"type": "string"},
|
||||
"createdAt": {"type": "timestamp"},
|
||||
"entryType": {"ref": "ledgerEntryType"}
|
||||
@@ -217,10 +221,14 @@
|
||||
"optionalProperties": {
|
||||
"invoiceId": {
|
||||
"type": "string",
|
||||
"metadata": {"comment": "absent for store and code payments"}
|
||||
"metadata": {"comment": "absent for store payments"}
|
||||
}
|
||||
}
|
||||
},
|
||||
"code": {
|
||||
"optionalProperties": {},
|
||||
"metadata": {"comment": "a redeemed code; its invoice belongs to the buyer, not the redeemer"}
|
||||
},
|
||||
"charge": {
|
||||
"properties": {"chargeId": {"type": "string"}}
|
||||
},
|
||||
@@ -323,7 +331,6 @@
|
||||
},
|
||||
"issueBadge": {
|
||||
"properties": {
|
||||
"badgeRequest": {"ref": "badgeRequest"},
|
||||
"balance": {"ref": "balance"}
|
||||
}
|
||||
},
|
||||
|
||||
@@ -308,8 +308,9 @@ Rules:
|
||||
|
||||
- `months` — unused months.
|
||||
- `start` — the date the unused balance starts. Not changed by grants (while `months > 0`); advanced by one month per `consume` and by the lapsed count per `lapse`.
|
||||
- `anchor` — the start of the current run of months, set only where a lapsed run restarts. Every month boundary of the run is counted from it, so a run beginning 31 Jan reaches 28 Feb and then returns to 31 Mar; counting from the moving `start` would hold it at the 28th for good.
|
||||
|
||||
Coverage = `[start, addMonths months start)`. `paidThrough = addMonths months start` — read from the last row alone; not a `badges` column.
|
||||
Write `monthAfter n = addMonths (m + n) anchor`, where `m` is the whole months from `anchor` to `start`, which always sits on a boundary. Coverage = `[start, monthAfter months)`. `paidThrough = monthAfter months` — read from the last row alone; not a `badges` column.
|
||||
|
||||
**Row:**
|
||||
|
||||
@@ -319,6 +320,7 @@ Coverage = `[start, addMonths months start)`. `paidThrough = addMonths months st
|
||||
- `delta` — signed months change
|
||||
- `months` — state: unused months after this row
|
||||
- `start` — state: balance start after this row
|
||||
- `anchor` — state: the run's anchor after this row
|
||||
- ref — bot-assigned payment ref / `charge_id` (grants)
|
||||
- `created_at`
|
||||
|
||||
@@ -328,20 +330,19 @@ Append protocol: lock the badge's ledger → read the last row → compute the n
|
||||
|
||||
```
|
||||
advance t: -- time bookkeeping only: one lapse row for the fully elapsed months
|
||||
k = min months (fullMonthsBetween start t)
|
||||
-- fullMonthsBetween start t: the largest m >= 0 with addMonths m start <= t
|
||||
if k > 0: append (lapse, −k, months − k, addMonths k start) -- O11, one row
|
||||
k = the largest k in [0, months] with monthAfter k <= t
|
||||
if k > 0: append (lapse, −k, months − k, monthAfter k) -- O11, one row
|
||||
|
||||
issue t: -- run after advance t
|
||||
requires months > 0 && start <= t && no issuance for [start, addMonths 1 start)
|
||||
sign the credential, expiry sundayAfter (addMonths 1 start)
|
||||
in one transaction: append (consume, −1, months − 1, addMonths 1 start) -- O10
|
||||
+ issuance row for [start, addMonths 1 start)
|
||||
requires months > 0 && start <= t && no issuance for [start, monthAfter 1)
|
||||
sign the credential, expiry sundayAfter (monthAfter 1)
|
||||
in one transaction: append (consume, −1, months − 1, monthAfter 1) -- O10
|
||||
+ issuance row for [start, monthAfter 1)
|
||||
on signing failure: no rows; retried at the next `issue`
|
||||
|
||||
grant t n src: -- O1–O5; t = settlement time,
|
||||
months == 0 → append (grant src, +n, n, max start t) -- provider period start for O2
|
||||
months > 0 → append (grant src, +n, months + n, start)
|
||||
months == 0 && t > start → append (grant src, +n, n, t), anchor = t -- provider period start for O2
|
||||
otherwise → append (grant src, +n, months + n, start) -- same run keeps its anchor
|
||||
|
||||
debit reason: append (debit reason, −months, 0, start) -- O6–O9
|
||||
|
||||
|
||||
@@ -0,0 +1,151 @@
|
||||
# Badge renewal and alerts — code-redeemed badges
|
||||
|
||||
Continues `plans/2026-08-27-badges-mvp-streams.md` stream 1. Model `plans/2026-07-30-supporter-badges-v3-ux.md` §2.4, §2.9, §2.11, §3; engine sketch `plans/2026-07-31-badges-core-implementation.md` §6. Protocol `docs/protocol/badges-rpc.{md,schema.json}`.
|
||||
|
||||
Those two older plans predate the code. Where they disagree with what is built, what is built wins — see §7.
|
||||
|
||||
---
|
||||
|
||||
## 1. What this fixes
|
||||
|
||||
A code says how many months it is worth. Nothing reads it. `getBadgeCode` does not select `months`, and `redeemCode` hardcodes `addMonths 1 now`, so a twelve-month code buys one month and nothing renews it.
|
||||
|
||||
The ledger is the mechanism that fixes it: a redemption credits the months, each issuance debits one, and the client asks for the next one when it comes due.
|
||||
|
||||
**Scope.** Badges redeemed by code. No subscriptions, invoices, store payments, upgrades, transfers or pause — those tables and error paths stay untouched and unwritten. No app UI.
|
||||
|
||||
**Not in scope, deliberately.** Investor badges (the type stays, unused) and lifetime badges (being removed in `stable`, merged here later). Every badge in this slice has a balance and an expiry.
|
||||
|
||||
---
|
||||
|
||||
## 2. The ledger, minimally
|
||||
|
||||
Three operations, against the tables as built.
|
||||
|
||||
| op | entry_type | change | writes |
|
||||
|---|---|---|---|
|
||||
| grant, on redemption | `credit` / `payment` | +N months | one row |
|
||||
| issue a month | `debit` / `badge` | −1 | one row + one `badge_issuances` row, same transaction |
|
||||
| lapse elapsed months | `debit` / `lapse` | −k | one row |
|
||||
|
||||
Every row carries the state after it: `balance_months`, `balance_start_ts`, `balance_badge_type`. **The last row is the state** — nothing derives a balance by summing, on either side.
|
||||
|
||||
- coverage is `[balance_start_ts, addMonths balance_months balance_start_ts)`
|
||||
- `paidThrough` = `addMonths balance_months balance_start_ts`, read from the last row alone
|
||||
- credential expiry = `endOfSundayAfter (addMonths 1 balance_start_ts)` — **anchored on the balance, not on `now`**, or the schedule drifts a little further from the purchase every month
|
||||
|
||||
`advance t` runs before every grant and issue: lapse the fully elapsed unissued months in one row, if any. Issue requires `balance_months > 0`, `balance_start_ts <= t`, and no issuance already covering `[balance_start_ts, +1 month)` — that last check is what makes a repeated `issueBadge` return the stored credential and write nothing.
|
||||
|
||||
The columns this slice never writes stay NULL: `payment_id`, `charge_id`, `from_purchase_id`, `to_purchase_id`, `was_paused_since`. A code grant has no invoice, which the wire type already allows (`payment {invoiceId?}`, absent for codes) and the storage type does not — see §7.
|
||||
|
||||
`entry_uuid` is the service's identity for a row and the client's replication key. The client stores rows **verbatim** and never authors one; `entry_type_unknown` / `entry_type_value` keep a row a newer service wrote.
|
||||
|
||||
---
|
||||
|
||||
## 3. Service
|
||||
|
||||
- `getBadgeCode` selects `months` again; redemption grants that many.
|
||||
- Redemption becomes: `advance` → grant → issue, and the response's `statement` carries the rows it wrote instead of being empty.
|
||||
- `issueBadge` (`BSCIssueBadge`, already in the protocol) gets its handler: `advance`, then issue if a month is due, then reply. The `balance` the client asserts names its last held entry; the service returns the entries after it, or the whole ledger with an `opening` restatement when it names nothing the service holds.
|
||||
- A repeat within an issued period replies with the **stored** credential and writes nothing. Not a re-sign: the same period signed twice yields a different signature and churns the client's credential for nothing.
|
||||
- An exhausted balance is not an error: the reply carries no `credential` and a statement that shows why.
|
||||
- Signing stays before every write, as in redemption. A signing failure writes nothing and the month is still due.
|
||||
|
||||
---
|
||||
|
||||
## 4. Client worker
|
||||
|
||||
One worker per user, on the agent `Worker` framework already used for delivery (`getAgentWorker` / `hasWorkToDo'` / `cancelWorker`, and the `TMap _ Worker` fields on `ChatController`). Per user because badge state is per profile and one profile must not stall another.
|
||||
|
||||
The worker holds no queue. A trigger only signals it; each pass reads stored state and derives the work. Signals are therefore free to be lost or duplicated.
|
||||
|
||||
**Pass**, per badge: is a month due, or has one lapsed, or is an alert derivable? If a request is needed, take the user's badge lock, send it signed with the purchase key, apply the response, then release. Applying a response means: copy the statement's entries verbatim, verify the credential, store the issuance, update the purchase, and re-present the badge to contacts.
|
||||
|
||||
**Triggers.** Chat start, chat activate, and redemption. Network restore and profile switch belong here too and cost nothing to add, but no caller sends them in this slice. Redemption has no immediate follow-up work — the round trip returns the credential and the statement, and the redeem command already stores the rows, sets the badge and broadcasts — but scheduling is something only a pass produces, so a purchase created without a signal has no wake-up until the next start or activate. Any later path that creates a purchase signals for the same reason.
|
||||
|
||||
**Scheduling.** No timer thread and no boundary map. Each pass ends by scheduling its own next wake-up, in the shape of `rescheduleWork` (`simplexmq` `NtfSubSupervisor.hs:478`): clear `doWork`, fork a sleeper that signals it at the next boundary, then block as usual. Two boundaries only, both day-granularity — the next month falling due, and `paidThrough`.
|
||||
|
||||
Unlike its original, this sleeper is **tracked per user and replaced**, following `deleteTimedItem` (`Internal.hs:1687`): cancel the previous before forking, cancel with the worker at chat stop, and re-check `waitChatStartedAndActivated` on waking. Badge horizons are a month where NtfSubSupervisor's are minutes, so untracked sleepers would accumulate — one per activate — instead of retiring.
|
||||
|
||||
**Expiry.** When the balance is exhausted and the last period ends, the shown badge is cleared and the profile update broadcast — the removal update of UX 2.11. This is the visible half of "the badge expired".
|
||||
|
||||
**Locking.** Add a `ChatLockEntity` constructor for the badge user and use `withEntityLock`, rather than the separate `badgeLocks` map §6 sketches. Same discipline, one lock map, and the `chatLock` ordering comes for free.
|
||||
|
||||
Nothing here is load-bearing for correctness: a pass derives its work from stored state, so chat start alone gives correct behaviour. It is what lets a client left running renew without a restart, and with `badgeGraceInterval` at 7 days a renewal hours late is invisible to contacts.
|
||||
|
||||
Timeouts are retried as the identical signed envelope at the next signal, never on a poll timer.
|
||||
|
||||
---
|
||||
|
||||
## 5. Alerts
|
||||
|
||||
One alert: `BASupportEnded`, at `paidThrough` with the balance exhausted, once.
|
||||
|
||||
`BAPrepaidEnding` — the 3-days-out warning — is **not** implemented, because a user cannot act on it. Topping up before the current period ends needs the service to credit a balance without issuing a credential, which is a change to the redemption path that beta does not carry; today a prepaid badge can only be continued after it has elapsed. Record that with a `TODO [badges]` in the alert derivation, where the missing branch is. The other three `BadgeAlertKind` constructors need subscriptions and stay unemitted.
|
||||
|
||||
Derived from state at the end of each pass, not stored as pending: compare the derived alert with `alert_acked_kind` / `alert_acked_episode` on the purchase, emit if they differ. The episode is the value that makes this occurrence distinct — `paidThrough`. Acknowledging writes the pair; snoozing sets `alert_snooze_until`, after which the alert is emitted once more. All three columns already exist.
|
||||
|
||||
---
|
||||
|
||||
## 6. Command and event surface
|
||||
|
||||
None of this exists — the names in §6 of the older plan have no code behind them. The minimum that makes the slice observable and testable from the terminal:
|
||||
|
||||
- `APIGetBadgeState` → the user's badges, balance, `paidThrough`, and current alert
|
||||
- `APIAckBadgeAlert` — acknowledge or snooze
|
||||
- `CEvtBadgeChanged` — state changed, including a renewal that arrived without a command
|
||||
- `CEvtBadgeAlert` — an alert became derivable
|
||||
|
||||
Each needs its `chatCommandP` parser, `View.hs` rendering, and registration in `bots/src/API/Docs/{Commands,Responses}.hs`, which `tests/APIDocs.hs` enforces.
|
||||
|
||||
---
|
||||
|
||||
## 7. Types to correct first
|
||||
|
||||
Declared during design, never exercised — `Badges.Types`' `BadgePurchase`, `BadgeIssuance`, `CTPayment` and `CTCharge` have no users, so none of this costs a migration or a call site. (`Simplex.Chat.Badges` has a different `BadgePurchase`, the payment-proof sum, which `Badges.Types` hides; that one is in use and unaffected.)
|
||||
|
||||
- **Add a `code` credit type, on the wire and in storage.** The wire currently models a code grant as `payment` with `invoiceId` absent. Storing it as anything else would mean the client rewriting a row it is meant to replicate verbatim, so both sides gain the constructor together. It also makes the absence structural: a code's own invoice belongs to the buyer and lives in `badge_code_invoices` on the service, and the redeemer's ledger must never reference it. Cheap now, expensive once stream 2 ships.
|
||||
- `CTPayment.invoiceId` becomes `InvoiceId`, not `Int64` — `invoices.invoice_id` is `TEXT`.
|
||||
- `CTCharge.chargeId` becomes `Text`, matching `subscription_charges.charge_id` and its wire twin `SCCharge`, corrected in milestone A. Unused in this slice; changed so the twins stop disagreeing.
|
||||
- `BadgePurchase` gains a funding sum — payment or code — rather than a mandatory `Int64` `paymentId`. Exactly one is set and the schema cannot say so, so the type should.
|
||||
- `BadgeIssuance` loses its `Maybe` period, expiry and entry id. Lifetime is gone, the columns are `NOT NULL`, and every issuance is written beside exactly one `consume` row.
|
||||
- `UserBadgeState`'s subscription fields stay: `renewsAt` is `Nothing` and `willRenew` is `False` until subscriptions exist.
|
||||
|
||||
Out of scope but worth knowing: `badge_ledger.payment_id` references a **payment** while the wire's `payment` credit names an **invoice**. Both are NULL for a code grant, so this slice never has to resolve it.
|
||||
|
||||
## 8. Order of work
|
||||
|
||||
**A — ledger on the service.** The injectable clock (§9), reading `months`, the three transitions, redemption grants and issues, the `issueBadge` handler, the statement in both responses. Done when a three-month code redeems and a second `issueBadge` a month later returns a second credential, asserted against the service's own rows.
|
||||
|
||||
**B — client replica.** Store the statement verbatim, read the balance from the last row, resolve §7's types. Done when the client's rows equal the service's row for row after a redemption.
|
||||
|
||||
**C — worker and renewal.** Worker, lock, self-scheduling, the pass, re-presentation. Done when a badge whose month has elapsed renews with no command, and one whose balance is exhausted loses its shown badge and broadcasts the removal.
|
||||
|
||||
**D — alerts and surface.** The ended alert, ack and snooze, the four commands and events. Done when the terminal shows it at `paidThrough` and acknowledging silences it.
|
||||
|
||||
## 9. Testing time
|
||||
|
||||
Nothing about the badge service is mocked: the harness already runs the real one in-process, so a fake would be less faithful and no faster. What is mocked is the clock.
|
||||
|
||||
**An injectable `now`** — `IO UTCTime` in config, defaulting to `getCurrentTime`. No badge code calls the clock directly: the transitions already take `now` as a parameter, and so do their two callers, the service handler and the worker pass. In tests both sides read one source — real time plus a test-controlled offset — so a test can redeem a twelve-month code, jump the offset a month, signal the worker, and assert, twelve times over, in milliseconds and against the real service, real signing and real rows.
|
||||
|
||||
The offset tracks real time rather than freezing it, which is what keeps the sleeper honest: `rescheduleWork` computes `actionTs - now` in shifted time and still sleeps the right real duration.
|
||||
|
||||
This is preferred over making the issuance period configurable. The period is baked into the credential's signed expiry and interacts with the Sunday rounding, so shortening it to seconds means disabling the rounding too — two knobs, and production arithmetic that no test exercises. A clock offset leaves every production computation exactly as shipped and only lies about the date.
|
||||
|
||||
It also reaches what waiting cannot: eight months offline, a boundary on the 31st, a leap day. Those hold the bugs.
|
||||
|
||||
Real elapsed time is then needed for one thing only — that the sleeper wakes the worker at all. With the offset set a second short of a boundary that is a one-second test.
|
||||
|
||||
Tests land with each step, extending `tests/Bots/BadgeServiceTests.hs`.
|
||||
|
||||
## 10. Done means
|
||||
|
||||
- a twelve-month code yields twelve monthly credentials, one per month, and a thirteenth request yields none
|
||||
- a second request inside an issued month returns the credential already stored, unchanged
|
||||
- re-issue happens without a command, from the worker's own wake-up alone
|
||||
- an app offline across several months lapses exactly the elapsed ones and issues the current one
|
||||
- redeeming the same code twice still yields one badge and one set of ledger rows
|
||||
- client and service ledgers match row for row, and the client authored none of them
|
||||
- the ended alert fires once, survives a restart, and stays silent once acknowledged
|
||||
- an expired badge disappears from contacts' view without the user acting
|
||||
@@ -0,0 +1,103 @@
|
||||
# Badge ledger: one entry type
|
||||
|
||||
This branch introduced seven types to describe ledger rows. Three hold nothing the wire's own `StatementEntry` does not already carry. Two describe a plan the caller can hold directly. One pairs a balance with a row id used for a single equality test. One holds three timestamps that two consecutive entries already determine. `StatementEntry` becomes the single representation, and nothing replaces the rest.
|
||||
|
||||
| introduced | what it holds beyond `StatementEntry` |
|
||||
| --- | --- |
|
||||
| `LedgerBalance` | nothing — its four fields are `StatementEntry`'s |
|
||||
| `ServiceLedgerEntry` | nothing — `statementEntry` exists only to rename `entryUuid`, flatten the balance, and fill in a `wasPausedSince` the service never sets |
|
||||
| `LedgerRow` | nothing — a change, a balance and a type, all fields of `StatementEntry` |
|
||||
| `LedgerPlan` | the rows to write, and which is the issuance |
|
||||
| `SignedPlan` | the same, with the credential |
|
||||
| `LedgerTip` | a numeric row id beside a balance |
|
||||
| `BadgePeriod` | three timestamps, all derivable from two consecutive entries |
|
||||
|
||||
## The entry is the state
|
||||
|
||||
The ledger's central property is that the last row *is* the balance. `StatementEntry` already carries it — `balanceMonths`, `balanceStartTs`, `balanceAnchorTs`, `balanceBadgeType` — alongside the change that produced it and the type of operation that made it. So an operation is a function from the last entry to the next. The three keep the shapes they have today, with `LedgerBalance` replaced by `StatementEntry`, a uuid added, and the credit type moving in from `ledgerPlan` because a grant now writes its own entry type:
|
||||
|
||||
```haskell
|
||||
lapseEntry :: UTCTime -> Text -> StatementEntry -> Maybe StatementEntry -- was advanceBalance
|
||||
issueEntry :: UTCTime -> Text -> StatementEntry -> Maybe StatementEntry -- was issueMonth
|
||||
grantEntry :: UTCTime -> Text -> Int -> StatementCreditType -> StatementEntry -> StatementEntry -- was grantMonths
|
||||
```
|
||||
|
||||
Each sets its own `changeMonths` and `entryType` — `SEDebit SDLapse`, `SEDebit SDBadge`, the caller's credit — so the count and the type it is recorded under travel together and cannot be mismatched. `Nothing` means the operation does not apply: nothing has elapsed, or no month is due. `grantEntry` is total, because a grant always applies.
|
||||
|
||||
The arithmetic inside them does not change. `entryId` and `createdAt` are supplied and never read, and `wasPausedSince` stays `Nothing` as the service sets it today. The price is that uuid generation moves from the store to the caller — which is also what lets an entry be identified before it is written, and be the value the credential is stored against.
|
||||
|
||||
The client is already here: `getBadgeLedgerLastEntry` returns a `StatementEntry`, because that is what the wire sends and what `badge_ledger` stores. This makes the service match rather than inventing a shape of its own.
|
||||
|
||||
## No plan, just composition
|
||||
|
||||
`ledgerPlan` goes too. A request lapses first, as its own entry, and the caller chains the rest, keeping whichever came back:
|
||||
|
||||
```haskell
|
||||
let lapsed = lapseEntry now uuid1 tip
|
||||
current = fromMaybe tip lapsed
|
||||
issued = issueEntry now uuid2 current
|
||||
rows = catMaybes [lapsed, issued]
|
||||
```
|
||||
|
||||
A redemption is the same chain with a grant between the two: `lapseEntry`, `grantEntry`, `issueEntry`. It grants the months and issues the first of them at once, which is what `ledgerPlan` does today.
|
||||
|
||||
Do not skip the lapse before a grant. `grantEntry` restarts the run only when the balance is empty, so elapsed months still on the books get added to instead: three months bought on 10 January and another code redeemed on 10 June gives five months running from January, every one already spent, where lapsing first gives two running from June.
|
||||
|
||||
The caller generates one uuid per entry it might write. These two are the only callers, so a function to compose them would serve two sites that differ by one step.
|
||||
|
||||
This disposes of `LedgerPlan` and `SignedPlan` without replacing them: the rows are a list the caller already holds, and the credential belongs to `issued`, a local in scope rather than something to find by position or by type.
|
||||
|
||||
Two store functions simplify with them. `getLedgerEntries` returns `[StatementEntry]`, so `credentialResponse`'s `map statementEntry` disappears. And `appendLedgerPlan` loses both its `TVar ChaChaDRG` and its `now`, since the entries now carry their own ids and timestamps — it gains only the issuance's predecessor, which the caller has as `current`.
|
||||
|
||||
## The period is derived
|
||||
|
||||
`BadgePeriod` carried what an issuance writes to `badge_issuances`. Given the issuance entry and the one before it, all three values are already there:
|
||||
|
||||
- `periodStart` is the previous entry's `balanceStartTs`
|
||||
- `periodEnd` is the issuance entry's own `balanceStartTs`, because issuing moves the start to the period end
|
||||
- the expiry is a pure function of `periodEnd`
|
||||
|
||||
The client already derives the two bounds this way in `getIssuedPeriod`, and takes the expiry from the credential, which is the service's own computation arriving back. On the service, compute the expiry at both points it is needed — signing, then writing the issuance row — from the same entry through the same function.
|
||||
|
||||
The predecessor is not always one of the written rows — when nothing lapsed, the entry before the issue is the tip. Composing at the call site names it anyway: it is `current`, the value the issue was computed from, so the writer has it without having to look for it.
|
||||
|
||||
## The tip is just an entry
|
||||
|
||||
`LedgerTip` is the newest row's id and balance. The id has one use — checking that no row was written while the plan was being signed — and that only asks whether it is still the same row, which `StatementEntry`'s uuid answers. So `getLedgerTip` returns a `StatementEntry`.
|
||||
|
||||
Reading a row as an entry means decoding its type, which `entryTypeFromColumns` does only partially — but totally over `code`, `badge` and `lapse`, which is everything the service writes. So `Nothing` still means no rows.
|
||||
|
||||
## What stays shared
|
||||
|
||||
The client authors no entries — it stores what the service sends and reads the last one back. So `lapseEntry`, `issueEntry` and `grantEntry` are the service's alone after this change, though `Ledger.hs` stays one module and the client simply imports less of it.
|
||||
|
||||
The rest of the module changes only in its argument: `paidThrough`, `elapsedMonths`, `monthsFromAnchor` and `monthAfter` take a `StatementEntry` where they took a `LedgerBalance`. `addMonths`, the tag functions and the column helpers are untouched; the week-boundary function is shifted a day and renamed by the worker plan, not here. `elapsedMonths` need no longer be exported, since `lapseEntry` is the only caller. The client keeps `paidThrough` and gains the check below.
|
||||
|
||||
The client's remaining use, `ledgerPlan` inside `badgeWorkDue`, is removed by the worker plan.
|
||||
|
||||
## Verifying what the service sends
|
||||
|
||||
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.
|
||||
|
||||
**What.** One outcome per entry, from one of two rules:
|
||||
|
||||
- *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.
|
||||
|
||||
**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 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 tests move with the types
|
||||
|
||||
The eight ledger-transition tests in `BadgeTests.hs` and their helpers move to `StatementEntry`. Assertions on `balanceMonths`, `balanceStartTs` and `paidThrough` survive as they are. The ones on periods do not: `pass` no longer returns a `BadgePeriod`, so `testTwelveMonths` and `testLapseAfterGap` state their period bounds as consecutive `balanceStartTs` values instead.
|
||||
|
||||
## Not in scope
|
||||
|
||||
The wire format does not change: `StatementEntry` is what the service already sends and the client already stores, and every column `badge_ledger` has today is still written. The only schema change is `balance_checked`, on the client's `badge_ledger` alone — the service has nothing to check, since it is the side that computes.
|
||||
@@ -0,0 +1,168 @@
|
||||
# Badge worker: one thread, one sleep
|
||||
|
||||
Today each user has two threads: a worker, and a sleeper that outlives each pass and signals it. That is where the `Weak ThreadId`, the swap-and-kill in `scheduleBadgeWake`, and the sleeper half of `stopBadgeWorkers` come from. The next wake is the earliest of four separately-derived times — a retry after a failed request, the snooze expiry, the stall floor, and the ledger's next renewal — and behind the first sit a per-purchase `(elapsed, delay)` map and three functions to advance it.
|
||||
|
||||
This assumes one badge per user. Most of what collapses here collapses because the maps keyed by purchase have a single key, and because `updateUserBadges` and `updateBadgePurchase` become one function, `updateUserBadge`.
|
||||
|
||||
```haskell
|
||||
data BadgeWorker = BadgeWorker
|
||||
{ badgeWorkerAsync :: Async (),
|
||||
badgeWork :: TMVar ()
|
||||
}
|
||||
|
||||
badgeWorkers :: TMap UserId (SessionVar BadgeWorker)
|
||||
badgeSeq :: TVar Int
|
||||
```
|
||||
|
||||
The loop, which the rest of this fills in:
|
||||
|
||||
```haskell
|
||||
runBadgeWorker :: User -> TMVar () -> CM ()
|
||||
runBadgeWorker user badgeWork = do
|
||||
emitted <- newTVarIO Nothing
|
||||
ri <- asks $ badgeRetryInterval . config
|
||||
forever $ do
|
||||
at_ <- withRetryInterval ri $ \_ loop -> do
|
||||
now <- badgeNow
|
||||
let done = pure $ Just $ badgeStalledInterval `addUTCTime` now
|
||||
updateUserBadge user emitted now `catchAllErrors` retryBadgeError loop done
|
||||
now <- badgeNow
|
||||
liftIO $ waitBadgeWake badgeWork now at_
|
||||
```
|
||||
|
||||
The clock is read twice because a retry sequence can run for hours, so the wait needs a fresh reading rather than the one the pass started from.
|
||||
|
||||
## Waiting
|
||||
|
||||
`registerDelay` makes the deadline an STM value, so the wait is a single transaction over the timer and the signal — no second thread, and the transaction reports which of the two woke it:
|
||||
|
||||
```haskell
|
||||
waitBadgeWake :: TMVar () -> UTCTime -> Maybe UTCTime -> IO ()
|
||||
waitBadgeWake badgeWork now = \case
|
||||
Nothing -> atomically $ takeTMVar badgeWork
|
||||
Just at -> waitFor $ diffToMicroseconds $ diffUTCTime at now
|
||||
where
|
||||
waitFor time
|
||||
| time <= 0 = pure ()
|
||||
| otherwise = do
|
||||
let maxWait = min time $ fromIntegral (maxBound :: Int)
|
||||
timer <- registerDelay $ fromIntegral maxWait
|
||||
signalled <- atomically $ do
|
||||
w <- tryTakeTMVar badgeWork
|
||||
fired <- readTVar timer
|
||||
unless (isJust w || fired) retry
|
||||
pure $ isJust w
|
||||
unless signalled $ waitFor $ time - maxWait
|
||||
```
|
||||
|
||||
This is `threadDelay'` with an escape hatch, and it keeps that function's names so it reads as one. Nothing survives the wait, so there is no handle to keep and nothing to kill. `Nothing` means sleep until signalled.
|
||||
|
||||
`registerDelay` takes an `Int`, so the loop is needed for the same reason `threadDelay'` has one: `maxBound :: Int` is ~292,000 years on 64-bit and ~36 minutes on 32-bit. A month is one sleep everywhere except legacy armv7a, which re-arms — as it already does today. Counting down the remaining time rather than re-reading the clock keeps this correct when a test has shifted `badgeCurrentTime`.
|
||||
|
||||
Taking the signal and reading the timer in one transaction means a signal is never consumed and discarded.
|
||||
|
||||
## Retrying
|
||||
|
||||
`withRetryInterval` holds the backoff in its own recursion — no map, no `TVar`, nothing persisted:
|
||||
|
||||
```haskell
|
||||
retryBadgeError :: CM a -> CM a -> ChatError -> CM a
|
||||
retryBadgeError loop done e = eToView e >> if badgeErrorRetry e then loop else done
|
||||
```
|
||||
|
||||
Same shape as `retryOnError` (`FileTransfer/Agent.hs:260`), except that it classifies with `badgeErrorRetry` rather than `temporaryOrHostError`, which does not cover `AGENT (A_SERVICE ASETimeout)` — the likeliest renewal failure, and using it would leave the retry inert for the common case.
|
||||
|
||||
`updateUserBadge` returns the next wake, as `updateBadgePurchase` does today. Retry-or-stop is a property of the error rather than a return value, so no result type is needed and `BadgeRetry` collapses to `badgeErrorRetry :: ChatError -> Bool`.
|
||||
|
||||
A service error is the exception, since it is returned rather than thrown: `requestBadgeIssue` becomes `Either (Maybe UTCTime) LedgerBalance`, where `Left` means do not retry and wake then. That is where a `retryAfter` hint lands — `withRetryInterval` owns the sleeping, so a wait the service names becomes a wake time — and where a terminal code lands as the stall floor. Floor the hint at `initialInterval`, since a service answering `0` would otherwise spin the worker, but do not cap it: a service that names a long wait is denying issuance, which it can already do by refusing, and `paidThrough` remains a wake candidate regardless of what it says.
|
||||
|
||||
**The stall floor is a day.** A terminal failure is not retried, and the ledger boundary is a whole term away. The client's own state cannot change without the service, so the only thing that can make the next attempt succeed is the service being repaired — a day is slow enough not to press a service already failing, and fast enough to recover well inside the badge's 8-14 days of headroom.
|
||||
|
||||
**The loop cannot die.** Catching everything except cancellation means no exception ends it, and a failure that reaches the top returns the stall floor as its wake, so a persistent fault is one attempt a day rather than a hot loop. That replaces the `Worker`'s rate-limited restart.
|
||||
|
||||
## When renewal is due
|
||||
|
||||
Renewal is driven by the **credential's expiry**, not the ledger's period end. A badge whose period has ended but whose credential is still valid needs nothing done — the holder keeps their perks, and the service is not asked early.
|
||||
|
||||
The expiry rounding moves one day later, from the Monday after the period to the Tuesday: `endOfSundayAfter`'s `8 - dayOfWeek` becomes `9 - dayOfWeek`. Periods ending anywhere in one Monday-to-Sunday week still share a single expiry, so the anonymity set is unchanged; it now falls on a weekday in every timezone, where Monday 00:00 UTC is Sunday evening in the Americas and puts a failed renewal on a weekend for support. The function is renamed for the day it now returns, and the range in `testSundayExpiry` widens from 1-7 days to 2-8.
|
||||
|
||||
Renewal splits into two steps, normally a day apart:
|
||||
|
||||
- **Request**, on the Monday — while the held credential is still valid, so a failure has a day of slack before anything is visible.
|
||||
- **Present**, on the Tuesday — as the old credential lapses, so the profile broadcast does not correlate with the request that produced it.
|
||||
|
||||
Neither needs a marker. Both derive from the shown credential's expiry, which the profile already stores, and from whether a newer issuance exists, which `presentIssuedBadge` already compares:
|
||||
|
||||
- **Request** when the shown credential expires within a day, months remain, and the newest issuance is still the one shown — so nothing has been requested yet. A successful request moves the newest expiry a month out, and the condition stops holding by itself.
|
||||
- **Present** when the newest issuance differs from what is shown and the shown credential has expired — or when nothing is shown at all, which is the state a crash between the issuance write and the profile write leaves behind, and which `testPresentationCatchesUp` covers.
|
||||
|
||||
Ordering falls out of that: presenting cannot precede requesting, because nothing differs until the request succeeds.
|
||||
|
||||
`badgeBoundary` becomes the next of three moments: `shownExpiry - 1 day`, `shownExpiry`, and `paidThrough`. The ledger's `balanceStartTs` goes, since renewal is no longer month-aligned — but `paidThrough` stays, and for a different reason from the other two. The credential's expiry window is what covers renewal: the client renews around it to join the anonymity set, and the recipients' grace period keeps the badge honoured while that happens. `paidThrough` is when entitlement itself ends. The worker has to be there for it, to retire the badge and raise the alert that tells the user to buy again; waiting for the credential to expire would leave them wearing a badge they have stopped paying for.
|
||||
|
||||
Missing a week is safe. A worker whose first run is the Wednesday finds both conditions true and does both in one pass: that renewal loses its anonymity benefit, and nothing else changes, which is the same property every other wake here has.
|
||||
|
||||
## The pass
|
||||
|
||||
```haskell
|
||||
updateUserBadge :: User -> TVar (Maybe BadgeOccurrence) -> UTCTime -> CM (Maybe UTCTime)
|
||||
updateUserBadge user emitted now = do
|
||||
(p, balance) <- ...
|
||||
retired <- retireExpiredBadge user p now balance
|
||||
balance' <-
|
||||
if retired
|
||||
then pure balance
|
||||
else do
|
||||
b <- if requestDue p balance now then requestBadgeIssue ... else pure balance
|
||||
when (presentDue p now) $ presentIssuedBadge user p now
|
||||
pure b
|
||||
emitBadgeAlert user emitted p now balance'
|
||||
pure $ earliestTime [badgeBoundary now p balance', snoozeAt p now]
|
||||
```
|
||||
|
||||
Retiring ends the renewal half of the pass. It means `paidThrough <= now`, so every funded month has already passed and a request could only write lapse rows — it cannot issue, because `advanceBalance` consumes the balance before `issueMonth` sees it. Reconciling the ledger for a badge that is over is not worth a round trip; a later redemption reconciles it anyway by asserting the last entry.
|
||||
|
||||
The guard is on `retired` rather than on the purchase's `shown` field because `p` was read before retirement and its `shown` is stale within the pass. `presentIssuedBadge` has its own `not shown` check, which covers later passes but not this one.
|
||||
|
||||
The alert stays outside the guard: support-ended fires exactly when the balance is exhausted, which is the pass that retires.
|
||||
|
||||
Retirement comes first because it needs no service and reads only stored state, and because an unbounded retry does not return while a failure lasts — anything after the request is unreachable meanwhile. Moving it ahead of the request is behaviour-preserving: `paidThrough` is invariant under issue and lapse, only a grant moves it, and `BSCIssueBadge` never produces one, so it gives the same answer either side.
|
||||
|
||||
## Starting and stopping
|
||||
|
||||
Chat start, `/_app activate`, `APIGetBadgeState` and a redemption can each ask for the worker at the same moment. Exactly one thread must be started, and every caller must come away holding it.
|
||||
|
||||
`getAgentWorker'` manages that by doing the lookup and the create in a single STM transaction, which works only because creating a `Worker` allocates a few TVars and nothing else. Starting a thread is IO and cannot happen inside a transaction, so for us the lookup and the create come apart, and two callers can both find nothing.
|
||||
|
||||
`SessionVar` closes the gap by putting a `TMVar` in the map instead of the value — the map holds the promise of a worker rather than a worker. `getSessVar` either inserts an empty one and returns `Left`, meaning you are the creator, or finds an existing one and returns `Right`. Exactly one caller gets `Left`.
|
||||
|
||||
```haskell
|
||||
withGetSessVar' badgeSeq userId badgeWorkers now startWorker signalExisting
|
||||
where
|
||||
startWorker v = do
|
||||
badgeWork <- newTMVarIO () -- full: a new worker has work to do
|
||||
a <- async $ runBadgeWorker user badgeWork
|
||||
let w = BadgeWorker {badgeWorkerAsync = a, badgeWork}
|
||||
w <$ atomically (putTMVar (sessionVar v) w)
|
||||
signalExisting v = do
|
||||
w <- atomically $ readTMVar $ sessionVar v
|
||||
w <$ atomically (void $ tryPutTMVar (badgeWork w) ())
|
||||
```
|
||||
|
||||
`readTMVar` blocks the other callers until the creator fills the var, so they signal the one worker rather than starting a second. The hazard is the creator dying between those two steps, leaving an empty var everyone waits on forever; `withGetSessVar'` wraps the creating branch in `bracketOnError` and drops it from the map so the next caller creates a fresh one.
|
||||
|
||||
Shutdown follows `closeAgentClient`, which stops a `TMap k (SessionVar (Async ()))` the same way: swap the map out, then for each var fork a thread that waits on `readTMVar` and `uninterruptibleCancel`s what it finds. Waiting rather than skipping is what catches a worker created after the swap; the fork is so shutdown does not block on it.
|
||||
|
||||
## What goes away
|
||||
|
||||
| removed | replaced by |
|
||||
| --- | --- |
|
||||
| `Worker`, `getAgentWorker'`, `cancelWorker`, restart accounting | `Async`, `badgeWork`, `SessionVar` |
|
||||
| `scheduleBadgeWake`, `Weak ThreadId`, `killWeakThread`, sleeper cleanup | `waitBadgeWake` |
|
||||
| `BadgeAttempt`, `nextBadgeAttempt`, `badgeAttemptDelay` | `withRetryInterval`'s own recursion |
|
||||
| `BadgeMemory` and its two maps | one `TVar (Maybe BadgeOccurrence)`, once a user has one badge |
|
||||
| `BadgeRetry`'s two constructors | `badgeErrorRetry :: ChatError -> Bool` |
|
||||
|
||||
Wake candidates go from four to three. The one that goes is the retry, because `withRetryInterval` sleeps between attempts rather than returning a time; the next request or present day, the snooze expiry, and the stall floor — or a wait the service named — all remain.
|
||||
|
||||
Unchanged: everything derived from stored state so a wake early, late or missed changes only timing; the alert-occurrence memory; `badgeCurrentTime`; `RetryInterval` in config, both as the existing pattern and so a test can shorten it. Signalling `badgeWork` replaces `startBadgeWork` at the same call sites.
|
||||
@@ -41,6 +41,7 @@ library
|
||||
Simplex.Chat.Badges
|
||||
Simplex.Chat.Badges.CLI
|
||||
Simplex.Chat.Badges.Code
|
||||
Simplex.Chat.Badges.Ledger
|
||||
Simplex.Chat.Badges.Service
|
||||
Simplex.Chat.Badges.Types
|
||||
Simplex.Chat.Names
|
||||
@@ -431,6 +432,7 @@ executable simplex-badge-service
|
||||
aeson ==2.2.*
|
||||
, attoparsec ==0.14.*
|
||||
, base >=4.7 && <5
|
||||
, containers ==0.6.*
|
||||
, crypton ==0.34.*
|
||||
, directory ==1.3.*
|
||||
, mtl >=2.3.1 && <3.0
|
||||
|
||||
@@ -69,6 +69,8 @@ defaultChatConfig =
|
||||
chatVRange = supportedChatVRange,
|
||||
badgePublicKeys = M.mapKeys fromIntegral entitlementIssuerKeys,
|
||||
badgeServiceAddress = Nothing,
|
||||
badgeCurrentTime = getCurrentTime,
|
||||
badgeRetryInterval = RetryInterval {initialInterval = 30_000000, increaseAfter = 0, maxInterval = 3600_000000},
|
||||
confirmMigrations = MCConsole,
|
||||
-- this property should NOT use operator = Nothing
|
||||
-- non-operator servers can be passed via options
|
||||
@@ -189,6 +191,8 @@ newChatController
|
||||
deliveryTaskWorkers <- TM.emptyIO
|
||||
deliveryJobWorkers <- TM.emptyIO
|
||||
relayRequestWorkers <- TM.emptyIO
|
||||
badgeWorkers <- TM.emptyIO
|
||||
badgeSeq <- newTVarIO 0
|
||||
relayGroupLinkChecksAsync <- newTVarIO Nothing
|
||||
webPreviewState <- forM webPreviewConfig $ \_ -> newWebPreviewState
|
||||
chatRelayTests <- TM.emptyIO
|
||||
@@ -235,6 +239,8 @@ newChatController
|
||||
deliveryTaskWorkers,
|
||||
deliveryJobWorkers,
|
||||
relayRequestWorkers,
|
||||
badgeWorkers,
|
||||
badgeSeq,
|
||||
relayGroupLinkChecksAsync,
|
||||
webPreviewState,
|
||||
chatRelayTests,
|
||||
|
||||
@@ -3,11 +3,11 @@
|
||||
|
||||
-- | Badge redemption codes, shared by the client, the badge service and the checkout site.
|
||||
--
|
||||
-- A code is @SXB-@ and 20 Crockford base32 characters in four groups of five:
|
||||
-- A code is "SXB-" and 20 Crockford base32 characters in four groups of five:
|
||||
-- 19 payload characters and a final check character.
|
||||
--
|
||||
-- Reading folds the characters the alphabet omits so that a code copied by hand still
|
||||
-- verifies: it is case-insensitive and maps @I@ and @L@ to @1@ and @O@ to @0@.
|
||||
-- verifies: it is case-insensitive and maps 'I' and 'L' to '1' and 'O' to '0'.
|
||||
--
|
||||
-- The check character is Luhn mod N with N = 32 over the payload values, which keeps it
|
||||
-- inside the same 32-character alphabet. It detects every single-character substitution
|
||||
|
||||
@@ -0,0 +1,176 @@
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Simplex.Chat.Badges.Ledger
|
||||
( emptyEntry,
|
||||
lapseEntry,
|
||||
grantEntry,
|
||||
issueEntry,
|
||||
paidThrough,
|
||||
balanceChecked,
|
||||
addMonths,
|
||||
endOfMondayAfter,
|
||||
entryTypeColumns,
|
||||
entryTypeFromColumns,
|
||||
creditTypeTag,
|
||||
debitTypeTag,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Calendar (addDays, addGregorianMonthsClip, toGregorian)
|
||||
import Data.Time.Calendar.WeekDate (toWeekDate)
|
||||
import Data.Time.Clock (UTCTime (..))
|
||||
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
|
||||
| otherwise = max 0 (months - 1)
|
||||
where
|
||||
(ay, am, _) = toGregorian (utctDay balanceAnchorTs)
|
||||
(sy, sm, _) = toGregorian (utctDay balanceStartTs)
|
||||
months = (sy - ay) * 12 + toInteger (sm - am)
|
||||
|
||||
-- | 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)
|
||||
|
||||
elapsedMonths :: UTCTime -> StatementEntry -> Int
|
||||
elapsedMonths t e = length $ takeWhile (\m -> monthAfter e m <= t) [1 .. balanceMonths 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.
|
||||
grantEntry :: UTCTime -> Text -> Int -> StatementCreditType -> StatementEntry -> StatementEntry
|
||||
grantEntry t entryId n credit e@StatementEntry {balanceMonths, balanceStartTs}
|
||||
-- only a lapsed run 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 = 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, 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
|
||||
}
|
||||
|
||||
-- | 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))
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | Only the types a tag alone rebuilds, which is those whose constructor has no fields; the rest
|
||||
-- answer Nothing rather than a type with an invented payload. The client also stores each type's
|
||||
-- JSON and reads that first, so this is its fallback; the service has no such column.
|
||||
-- TODO [badges] take the reference columns and rebuild payment, charge, transferIn, upgrade and
|
||||
-- transferOut, without which the service cannot re-emit a statement carrying one.
|
||||
entryTypeFromColumns :: Text -> Maybe Text -> Maybe Text -> Maybe StatementEntryType
|
||||
entryTypeFromColumns entryType credit_ debit_ = case (entryType, credit_, debit_) of
|
||||
("credit", Just t, _) -> SECredit <$> creditType t
|
||||
("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
|
||||
@@ -98,8 +98,7 @@ data BadgeServiceCommand
|
||||
balance :: BadgeBalance
|
||||
}
|
||||
| BSCIssueBadge
|
||||
{ badgeRequest :: BadgeRequest,
|
||||
balance :: BadgeBalance
|
||||
{ balance :: BadgeBalance -- no badgeRequest: the service holds the key, the tier and the expiry
|
||||
}
|
||||
| BSCPauseBadge
|
||||
|
||||
@@ -173,6 +172,9 @@ data StatementEntry = StatementEntry
|
||||
changeMonths :: Int,
|
||||
balanceMonths :: Int,
|
||||
balanceStartTs :: UTCTime,
|
||||
-- the start of the current run of months; every month boundary in it is counted from here,
|
||||
-- so that the day of month survives a short month
|
||||
balanceAnchorTs :: UTCTime,
|
||||
balanceBadgeType :: BadgeType,
|
||||
wasPausedSince :: Maybe UTCTime,
|
||||
createdAt :: UTCTime,
|
||||
@@ -184,7 +186,8 @@ data StatementEntryType = SECredit {credit :: StatementCreditType} | SEDebit {de
|
||||
deriving (Show)
|
||||
|
||||
data StatementCreditType
|
||||
= SCPayment {invoiceId :: Maybe InvoiceId} -- absent for store and code payments
|
||||
= SCPayment {invoiceId :: Maybe InvoiceId} -- absent for store payments
|
||||
| SCCode -- a redeemed code; its own invoice belongs to the buyer, not to the redeemer
|
||||
| SCCharge {chargeId :: Text}
|
||||
| SCSupport
|
||||
| SCTransferIn {fromPurchaseKey :: C.PublicKeyEd25519}
|
||||
|
||||
@@ -18,12 +18,13 @@ module Simplex.Chat.Badges.Types
|
||||
LedgerCreditType (..),
|
||||
LedgerDebitType (..),
|
||||
BadgeAlertKind (..),
|
||||
BadgeFunding (..),
|
||||
BadgePurchase (..),
|
||||
BadgeLedgerEntry (..),
|
||||
BadgeCharge (..),
|
||||
BadgeIssuance (..),
|
||||
BadgeAlert (..),
|
||||
UserBadgeState (..),
|
||||
BadgeState (..),
|
||||
) where
|
||||
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
@@ -34,12 +35,12 @@ import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Word (Word8)
|
||||
import Simplex.Chat.Badges hiding (BadgePurchase (..))
|
||||
import Simplex.Chat.PaymentService.Types (InvoiceId, StoredPayment)
|
||||
import Simplex.Chat.PaymentService.Types (InvoiceId, PaymentId, StoredPayment)
|
||||
import Simplex.Messaging.Agent.Protocol (UserId)
|
||||
import Simplex.Messaging.Agent.Store.DB (fromTextField_)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, taggedObjectJSON)
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, taggedObjectJSON)
|
||||
#if defined(dbPostgres)
|
||||
import Database.PostgreSQL.Simple.FromField (FromField (..))
|
||||
import Database.PostgreSQL.Simple.ToField (ToField (..))
|
||||
@@ -84,8 +85,9 @@ data LedgerEntryType = LECredit {credit :: LedgerCreditType} | LEDebit {debit ::
|
||||
|
||||
-- confirmed
|
||||
data LedgerCreditType
|
||||
= CTPayment {invoiceId :: Int64}
|
||||
| CTCharge {chargeId :: Int64}
|
||||
= CTPayment {invoiceId :: InvoiceId}
|
||||
| CTCode
|
||||
| CTCharge {chargeId :: Text}
|
||||
| CTSupport
|
||||
| CTTransferIn {fromPurchaseId :: Maybe Int64}
|
||||
| CTOpening
|
||||
@@ -107,6 +109,31 @@ data LedgerDebitType
|
||||
data BadgeAlertKind = BARenewalApproaching | BAPaymentIssue | BASubscriptionEnded | BAPrepaidEnding | BASupportEnded
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance TextEncoding BadgeAlertKind where
|
||||
textEncode = \case
|
||||
BARenewalApproaching -> "renewal_approaching"
|
||||
BAPaymentIssue -> "payment_issue"
|
||||
BASubscriptionEnded -> "subscription_ended"
|
||||
BAPrepaidEnding -> "prepaid_ending"
|
||||
BASupportEnded -> "support_ended"
|
||||
textDecode = \case
|
||||
"renewal_approaching" -> Just BARenewalApproaching
|
||||
"payment_issue" -> Just BAPaymentIssue
|
||||
"subscription_ended" -> Just BASubscriptionEnded
|
||||
"prepaid_ending" -> Just BAPrepaidEnding
|
||||
"support_ended" -> Just BASupportEnded
|
||||
_ -> Nothing
|
||||
|
||||
instance FromField BadgeAlertKind where fromField = fromTextField_ textDecode
|
||||
|
||||
instance ToField BadgeAlertKind where toField = toField . textEncode
|
||||
|
||||
-- exactly one of these funds a purchase; the schema cannot say so, both columns being nullable
|
||||
data BadgeFunding
|
||||
= BFPayment {paymentId :: PaymentId}
|
||||
| BFCodeRedemption {redemptionId :: Int64}
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- to review
|
||||
data BadgePurchase = BadgePurchase
|
||||
{ badgePurchaseId :: Int64,
|
||||
@@ -117,7 +144,7 @@ data BadgePurchase = BadgePurchase
|
||||
badgeType :: BadgeType,
|
||||
priceId :: Maybe BadgePriceId,
|
||||
offerId :: Maybe BadgeOfferId,
|
||||
paymentId :: Int64,
|
||||
funding :: BadgeFunding,
|
||||
status :: BadgePurchaseStatus,
|
||||
credential :: Maybe BadgeCredential,
|
||||
alertAcked :: Maybe (BadgeAlertKind, Text),
|
||||
@@ -134,6 +161,7 @@ data BadgeLedgerEntry = BadgeLedgerEntry
|
||||
changeMonths :: Int,
|
||||
balanceMonths :: Int,
|
||||
balanceStartTs :: UTCTime,
|
||||
balanceAnchorTs :: UTCTime,
|
||||
balanceBadgeType :: BadgeType,
|
||||
wasPausedSince :: Maybe UTCTime,
|
||||
serviceCreatedAt :: UTCTime,
|
||||
@@ -156,14 +184,16 @@ data BadgeCharge = BadgeCharge
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- unconfirmed draft
|
||||
-- every issuance covers one month and is written beside exactly one debit(badge) row
|
||||
data BadgeIssuance = BadgeIssuance
|
||||
{ issuanceId :: Int64,
|
||||
{ issuanceId :: Text,
|
||||
badgePurchaseId :: Int64,
|
||||
periodStart :: Maybe UTCTime,
|
||||
periodEnd :: Maybe UTCTime,
|
||||
expiry :: Maybe UTCTime,
|
||||
entryId :: Maybe Int64,
|
||||
badgeType :: BadgeType,
|
||||
periodStart :: UTCTime,
|
||||
periodEnd :: UTCTime,
|
||||
expiry :: UTCTime,
|
||||
entryId :: Int64,
|
||||
credential :: BadgeCredential,
|
||||
createdAt :: UTCTime
|
||||
}
|
||||
deriving (Show)
|
||||
@@ -177,17 +207,19 @@ data BadgeAlert = BadgeAlert
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
-- unconfirmed draft
|
||||
data UserBadgeState = UserBadgeState
|
||||
{ badges :: [BadgePurchase],
|
||||
shownBadgeId :: Maybe Int64,
|
||||
payments :: [StoredPayment],
|
||||
-- | The user's badge as the badge surfaces render it. The purchase keys are deliberately absent:
|
||||
-- this travels to the UI and over remote control, and they are secrets that stay in core.
|
||||
data BadgeState = BadgeState
|
||||
{ badgePurchaseId :: Int64,
|
||||
badgeType :: BadgeType,
|
||||
monthsLeft :: Int,
|
||||
paidThrough :: Maybe UTCTime,
|
||||
paidThrough :: UTCTime,
|
||||
-- payments returns here with the payment types, which this slice neither writes nor encodes
|
||||
renewsAt :: Maybe UTCTime,
|
||||
willRenew :: Bool,
|
||||
alert :: Maybe BadgeAlert
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance TextEncoding BadgePurchaseStatus where
|
||||
textEncode = \case
|
||||
@@ -224,3 +256,14 @@ instance ToField BadgeCodePaymentStatus where toField = toField . textEncode
|
||||
$(JQ.deriveJSON (enumJSON $ dropPrefix "BIS") ''BadgeItemStatus)
|
||||
|
||||
$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "OD") ''OfferDiscount)
|
||||
|
||||
instance ToJSON BadgeAlertKind where
|
||||
toJSON = textToJSON
|
||||
toEncoding = textToEncoding
|
||||
|
||||
instance FromJSON BadgeAlertKind where
|
||||
parseJSON = textParseJSON "BadgeAlertKind"
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''BadgeAlert)
|
||||
|
||||
$(JQ.deriveJSON defaultJSON ''BadgeState)
|
||||
|
||||
@@ -84,6 +84,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Messaging.Client (HostMode (..), SMPProxyFallback (..), SMPProxyMode (..), SMPWebPortServers (..), SocksMode (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Chat.Badges (BadgeCredential, LocalBadge)
|
||||
import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeState (..))
|
||||
import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
|
||||
import Simplex.Messaging.Crypto.File (CryptoFile (..))
|
||||
import qualified Simplex.Messaging.Crypto.File as CF
|
||||
@@ -92,6 +93,7 @@ import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus)
|
||||
import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, parseAll, parseString, sumTypeJSON)
|
||||
import Simplex.Messaging.Protocol (AProtoServerWithAuth, AProtocolType (..), MsgId, NMsgMeta (..), NtfServer, ProtocolType (..), QueueId, SMPMsgMeta (..), SubscriptionMode (..), XFTPServer)
|
||||
import Simplex.Messaging.Session (SessionVar)
|
||||
import Simplex.Messaging.TMap (TMap)
|
||||
import Simplex.Messaging.Transport (TLS, TransportPeer (..), simplexMQVersion)
|
||||
import Simplex.Messaging.Transport.Client (SocksProxyWithAuth, TransportHost)
|
||||
@@ -145,6 +147,10 @@ data ChatConfig = ChatConfig
|
||||
badgePublicKeys :: Map Int BBSPublicKey,
|
||||
-- Nothing until the badge service is deployed
|
||||
badgeServiceAddress :: Maybe (ConnectTarget 'CMContact),
|
||||
-- the only clock badge code reads, so tests can shift it; production arithmetic is unchanged
|
||||
badgeCurrentTime :: IO UTCTime,
|
||||
-- how long a badge worker waits before repeating a renewal that failed for a passing reason
|
||||
badgeRetryInterval :: RetryInterval,
|
||||
confirmMigrations :: MigrationConfirmation,
|
||||
presetServers :: PresetServers,
|
||||
shortLinkPresetServers :: NonEmpty SMPServer,
|
||||
@@ -278,6 +284,12 @@ defaultInlineFilesConfig =
|
||||
|
||||
data ChatDatabase = ChatDatabase {chatStore :: DBStore, agentStore :: DBStore}
|
||||
|
||||
-- | Signalling badgeWork wakes the worker from its own wait; a full var means it has work to do.
|
||||
data BadgeWorker = BadgeWorker
|
||||
{ badgeWorkerAsync :: Async (),
|
||||
badgeWork :: TMVar ()
|
||||
}
|
||||
|
||||
data ChatController = ChatController
|
||||
{ currentUser :: TVar (Maybe User),
|
||||
randomPresetServers :: NonEmpty PresetOperator,
|
||||
@@ -310,6 +322,9 @@ data ChatController = ChatController
|
||||
deliveryTaskWorkers :: TMap DeliveryWorkerKey Worker,
|
||||
deliveryJobWorkers :: TMap DeliveryWorkerKey Worker,
|
||||
relayRequestWorkers :: TMap Int Worker, -- single global worker with key 1 is used to fit into existing worker management framework
|
||||
-- one badge worker per user: badge state is per profile, and one profile must not stall another
|
||||
badgeWorkers :: TMap UserId (SessionVar BadgeWorker),
|
||||
badgeSeq :: TVar Int,
|
||||
relayGroupLinkChecksAsync :: TVar (Maybe (Async ())),
|
||||
webPreviewState :: Maybe WebPreviewState,
|
||||
chatRelayTests :: TMap ConnId RelayTest,
|
||||
@@ -641,6 +656,10 @@ data ChatCommand
|
||||
| UpdateProfileImageFromFile FilePath -- set profile image from a .png/.jpg/.jpeg file
|
||||
| AddBadge BadgeCredential -- attach an issued badge credential (testing; credential from `simplex-chat badge sign`)
|
||||
| APIRedeemBadgeCode {userId :: UserId, code :: Text} -- redeem a badge code with the configured badge service
|
||||
| APIGetBadgeState {userId :: UserId} -- the user's badges, their balances and any current alert
|
||||
-- episode is last because it is free text: it is the value that makes one occurrence of an
|
||||
-- alert distinct from the next, and the app returns whatever it was given
|
||||
| APIAckBadgeAlert {userId :: UserId, badgePurchaseId :: Int64, alertKind :: BadgeAlertKind, snooze :: Bool, episode :: Text}
|
||||
| ShowProfileImage
|
||||
| SetUserFeature AChatFeature FeatureAllowed -- UserId (not used in UI)
|
||||
| SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed)
|
||||
@@ -846,6 +865,7 @@ data ChatResponse
|
||||
| CRServiceResponse {user :: User, responseData :: J.Object}
|
||||
| CRServiceReplyAccepted {user :: User, connectionId :: AgentConnId}
|
||||
| CRBadgeRedeemed {user :: User, redeemedBadge :: LocalBadge, newBadge :: Bool}
|
||||
| CRBadgeState {user :: User, badgeState :: Maybe BadgeState}
|
||||
| CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact}
|
||||
| CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], withMessages :: Bool, msgSigned :: Bool}
|
||||
| CRGroupsList {user :: User, groups :: [GroupInfo]}
|
||||
@@ -963,6 +983,8 @@ data ChatEvent
|
||||
| CEvtReceivedContactRequest {user :: User, contactRequest :: UserContactRequest, chat_ :: Maybe AChat}
|
||||
| CEvtServiceRequest {user :: User, requestId :: AgentInvId, signerKey :: Maybe C.PublicKeyEd25519, requestData :: J.Object}
|
||||
| CEvtServiceReplySent {connectionId :: AgentConnId}
|
||||
| CEvtBadgeChanged {user :: User, badgeState :: Maybe BadgeState} -- badge state changed, including a renewal that arrived without a command
|
||||
| CEvtBadgeAlert {user :: User, badgeAlert :: BadgeAlert}
|
||||
| CEvtContactRequestRejected {user :: User, contact :: Contact, rejectionReason :: Maybe ContactRejectionReason}
|
||||
| CEvtAcceptingContactRequest {user :: User, contact :: Contact} -- there is the same command response
|
||||
| CEvtAcceptingBusinessRequest {user :: User, groupInfo :: GroupInfo}
|
||||
|
||||
@@ -51,14 +51,19 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeLatin1, encodeUtf8)
|
||||
import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime)
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime, nominalDay)
|
||||
import Data.Word (Word32)
|
||||
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay)
|
||||
import Data.Type.Equality
|
||||
import qualified Data.UUID as UUID
|
||||
import qualified Data.UUID.V4 as V4
|
||||
import Simplex.Chat.Library.Subscriber
|
||||
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), LocalBadge (..), badgeServerCredential, maxXFTPFileSize, mkBadgeStatus, verifyCredential)
|
||||
import Crypto.Random (ChaChaDRG)
|
||||
import Simplex.Messaging.Session (SessionVar (..), withGetSessVar')
|
||||
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, 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)
|
||||
import Simplex.Chat.Badges.Service (BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), currentBadgeServiceVersion)
|
||||
import Simplex.Chat.Badges.Service (BadgeBalance (..), BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), BadgeStatement (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..), currentBadgeServiceVersion)
|
||||
import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim)
|
||||
import Simplex.Chat.Call
|
||||
import Simplex.Chat.Controller
|
||||
@@ -100,6 +105,7 @@ import Simplex.FileTransfer.Description (FileDescriptionURI (..), maxFileSizeHar
|
||||
import Simplex.Messaging.Agent
|
||||
import Simplex.Messaging.Agent.Env.SQLite (ServerCfg (..), ServerRoles (..), allRoles)
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), withRetryInterval)
|
||||
import Simplex.Messaging.Agent.Store.Entity
|
||||
import Simplex.Messaging.Agent.Store.Interface (execSQL)
|
||||
import Simplex.Messaging.Agent.Store.Shared (upMigration)
|
||||
@@ -253,6 +259,7 @@ startChatController mainApp enableSndFiles serviceRequests = do
|
||||
startDeliveryWorkers
|
||||
startRelayRequestWorker_
|
||||
startCleanupManager
|
||||
mapM_ startBadgeWork users
|
||||
void $ forkIO $ mapM_ startExpireCIs users
|
||||
startRelayChecks users
|
||||
startWebPreview users
|
||||
@@ -349,7 +356,8 @@ restoreCalls = do
|
||||
atomically $ writeTVar calls callsMap
|
||||
|
||||
stopChatController :: ChatController -> IO ()
|
||||
stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession} = do
|
||||
stopChatController ChatController {smpAgent, agentAsync = s, sndFiles, rcvFiles, expireCIFlags, remoteHostSessions, remoteCtrlSession, badgeWorkers} = do
|
||||
stopBadgeWorkers badgeWorkers
|
||||
readTVarIO remoteHostSessions >>= mapM_ (cancelRemoteHost False . snd)
|
||||
atomically (stateTVar remoteCtrlSession (,Nothing)) >>= mapM_ (cancelRemoteCtrl False . snd)
|
||||
disconnectAgentClient smpAgent
|
||||
@@ -581,6 +589,7 @@ processChatCommand cxt nm = \case
|
||||
void . forkIO $ subscribeUsers True users
|
||||
void . forkIO $ startFilesToReceive users
|
||||
setAllExpireCIFlags True
|
||||
mapM_ startBadgeWork users
|
||||
ok_
|
||||
APISuspendChat t -> do
|
||||
chatWriteVar chatActivated False
|
||||
@@ -3538,6 +3547,17 @@ processChatCommand cxt nm = \case
|
||||
ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile)
|
||||
AddBadge cred -> withUser $ \user -> addUserBadge user cred >> ok user
|
||||
APIRedeemBadgeCode userId codeText -> withUserId userId $ \user -> redeemBadgeCode nm user codeText
|
||||
APIGetBadgeState userId -> withUserId userId $ \user -> do
|
||||
-- the read also signals the worker, whose results follow as CEvtBadgeChanged
|
||||
lift $ startBadgeWork user
|
||||
CRBadgeState user <$> getUserBadgeState user
|
||||
APIAckBadgeAlert userId badgePurchaseId alertKind snooze episode -> withUserId userId $ \user -> do
|
||||
now <- badgeNow
|
||||
let snoozeUntil = if snooze then Just (addUTCTime nominalDay now) else Nothing
|
||||
withStore' $ \db -> setBadgeAlertAcked db badgePurchaseId alertKind episode snoozeUntil
|
||||
-- after the write, so the pass it signals arms a wake for the snooze rather than raising again
|
||||
lift $ startBadgeWork user
|
||||
CRBadgeState user <$> getUserBadgeState user
|
||||
SetBotCommands commands -> withUser $ \user@User {profile} -> do
|
||||
let LocalProfile {preferences} = profile
|
||||
prefs = Just (fromMaybe emptyChatPrefs preferences :: Preferences) {commands = Just commands}
|
||||
@@ -3640,6 +3660,7 @@ processChatCommand cxt nm = \case
|
||||
CLUserContact ucId -> "UserContact " <> tshow ucId
|
||||
CLContactRequest crId -> "ContactRequest " <> tshow crId
|
||||
CLFile fId -> "File " <> tshow fId
|
||||
CLBadgeUser uId -> "BadgeUser " <> tshow uId
|
||||
DebugEvent event -> toView event >> ok_
|
||||
GetAgentSubsTotal userId -> withUserId userId $ \user -> do
|
||||
users <- withStore' $ \db -> getUsers db
|
||||
@@ -5135,12 +5156,16 @@ addUserBadge user cred@(BadgeCredential _ _ _ info) =
|
||||
Just False -> throwCmdError "badge credential does not verify against configured key"
|
||||
Just True -> do
|
||||
now <- liftIO getCurrentTime
|
||||
user' <- withFastStore' $ \db -> setUserBadge db user (Just (OwnBadge cred (mkBadgeStatus now (Just True) info)))
|
||||
user' <- withFastStore $ \db -> setUserBadge db user (Just (OwnBadge cred (mkBadgeStatus now (Just True) info)))
|
||||
presentUserBadgeToContacts user'
|
||||
|
||||
presentUserBadgeToContacts :: User -> CM ()
|
||||
presentUserBadgeToContacts user'@User {profile = LocalProfile {localBadge}} = do
|
||||
asks currentUser >>= atomically . (`writeTVar` Just user')
|
||||
presentUserBadgeToContacts user'@User {userId, profile = LocalProfile {localBadge}} = do
|
||||
-- a badge worker runs for every profile, not only the active one, so this refreshes the active
|
||||
-- record where it is the same profile and must never switch to another
|
||||
chatModifyVar currentUser $ \case
|
||||
Just User {userId = activeId} | activeId == userId -> Just user'
|
||||
active_ -> active_
|
||||
lift $ withAgent' $ \a -> setUserEntitlement a (aUserId user') (badgeServerCredential localBadge)
|
||||
cxt <- asks $ mkStoreCxt . config
|
||||
contacts <- withFastStore' $ \db -> getUserContacts db cxt user'
|
||||
@@ -5157,25 +5182,34 @@ presentUserBadgeToContacts user'@User {profile = LocalProfile {localBadge}} = do
|
||||
-- stashed before the request is sent, so a retry reaches the service as the same signer.
|
||||
-- A terminal answer drops the stash; a timeout keeps it.
|
||||
redeemBadgeCode :: NetworkRequestMode -> User -> Text -> CM ChatResponse
|
||||
redeemBadgeCode nm user codeText = do
|
||||
redeemBadgeCode nm user@User {userId} codeText = do
|
||||
code <- maybe (throwCmdError "invalid badge code") pure $ parseBadgeCode codeText
|
||||
sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwCmdError "badge service not configured") pure
|
||||
g <- asks random
|
||||
now <- liftIO getCurrentTime
|
||||
let codeSent = badgeCodeText code
|
||||
redemption@BadgeCodeRedemption {purchaseKey, purchasePrivKey, masterKey} <-
|
||||
withStore' $ \db ->
|
||||
getBadgeCodeRedemption db user codeSent
|
||||
>>= maybe (createBadgeCodeRedemption db g user codeSent now) pure
|
||||
let req = BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request = BSCRedeemBadgeCode {masterKey, code = codeSent}}
|
||||
respData <- sendServiceRequestTo nm user sendTarget Nothing (Just purchasePrivKey) req
|
||||
case J.fromJSON (J.Object respData) of
|
||||
J.Error e -> throwCmdError $ "invalid badge service response, " <> show e <> ": " <> respJSON respData
|
||||
J.Success BSPError {code = errCode} -> do
|
||||
when (terminalCodeError errCode) $ withStore' $ \db -> deleteBadgeCodeRedemption db (redemptionId redemption)
|
||||
throwCmdError $ "badge service error: " <> T.unpack (badgeServiceErrorText errCode)
|
||||
J.Success BSPBadgeCredential {credential = Just cred} -> storeRedeemedBadge user redemption cred
|
||||
J.Success _ -> throwCmdError $ "unexpected badge service response: " <> respJSON respData
|
||||
-- the guard, the request and the write are one section: without it two codes redeemed at once
|
||||
-- both pass the guard and are both spent, for one badge
|
||||
(present_, redeemed) <- withEntityLock "badgeRedeem" (CLBadgeUser userId) $ do
|
||||
redemption_ <- withStore' $ \db -> getBadgeCodeRedemption db user codeSent
|
||||
-- a code already redeemed here is allowed through: re-sending it returns the badge it bought
|
||||
-- and adds nothing. Refused before its keys are stashed and before the request, so it stays unspent
|
||||
replaying <- maybe (pure False) (\r -> withStore' $ \db -> isJust <$> getCodeBadgePurchase db r) redemption_
|
||||
unless replaying $ whenM (withStore' (`userHasBadge` user)) $ throwCmdError "badge already active"
|
||||
redemption@BadgeCodeRedemption {purchaseKey, purchasePrivKey, masterKey} <-
|
||||
maybe (withStore' $ \db -> createBadgeCodeRedemption db g user codeSent now) pure redemption_
|
||||
let req = BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request = BSCRedeemBadgeCode {masterKey, code = codeSent}}
|
||||
respData <- sendServiceRequestTo nm user sendTarget Nothing (Just purchasePrivKey) req
|
||||
case J.fromJSON (J.Object respData) of
|
||||
J.Error e -> throwCmdError $ "invalid badge service response, " <> show e <> ": " <> respJSON respData
|
||||
J.Success BSPError {code = errCode} -> do
|
||||
when (terminalCodeError errCode) $ withStore' $ \db -> deleteBadgeCodeRedemption db (redemptionId redemption)
|
||||
throwCmdError $ "badge service error: " <> T.unpack (badgeServiceErrorText errCode)
|
||||
J.Success BSPBadgeCredential {credential = Just cred, statement} -> storeRedeemedBadge user redemption cred statement
|
||||
J.Success _ -> throwCmdError $ "unexpected badge service response: " <> respJSON respData
|
||||
-- outside the badge lock: the chat lock must not be taken under it
|
||||
mapM_ presentUserBadgeToContacts present_
|
||||
pure redeemed
|
||||
where
|
||||
-- re-encoded, not shown as received: JSON escapes the control characters a terminal acts on
|
||||
respJSON = LB.unpack . J.encode
|
||||
@@ -5197,10 +5231,317 @@ badgeServiceErrorText = \case
|
||||
where
|
||||
errorCodeChar c = isAsciiLower c || isDigit c || c == '_'
|
||||
|
||||
-- | Verify the credential before writing anything; the purchase, its issuance and the profile's
|
||||
-- badge go in one transaction, and contacts are told after it commits.
|
||||
storeRedeemedBadge :: User -> BadgeCodeRedemption -> BadgeCredential -> CM ChatResponse
|
||||
storeRedeemedBadge user redemption@BadgeCodeRedemption {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeExpiry}) =
|
||||
-- | The only clock badge code reads, so a test can move the client and the service together.
|
||||
badgeNow :: CM UTCTime
|
||||
badgeNow = asks (badgeCurrentTime . config) >>= liftIO
|
||||
|
||||
-- | A signal carries nothing: each pass derives its work from stored state, so a signal lost or
|
||||
-- duplicated changes no outcome.
|
||||
startBadgeWork :: User -> CM' ()
|
||||
startBadgeWork user = whenM (isJust <$> asks (badgeServiceAddress . config)) $ void $ getBadgeWorker user
|
||||
|
||||
-- | Exactly one caller starts the thread and the rest wait for it: the lookup and the create cannot
|
||||
-- be one transaction, because starting a thread is not STM.
|
||||
getBadgeWorker :: User -> CM' BadgeWorker
|
||||
getBadgeWorker User {userId} = do
|
||||
ws <- asks badgeWorkers
|
||||
seq' <- asks badgeSeq
|
||||
now <- liftIO getCurrentTime
|
||||
withGetSessVar' seq' userId ws now startWorker signalWorker
|
||||
where
|
||||
startWorker v = do
|
||||
badgeWork <- newTMVarIO ()
|
||||
badgeWorkerAsync <- async $ void $ runExceptT $ runBadgeWorker userId badgeWork
|
||||
let w = BadgeWorker {badgeWorkerAsync, badgeWork}
|
||||
w <$ atomically (putTMVar (sessionVar v) w)
|
||||
signalWorker v = do
|
||||
w <- atomically $ readTMVar $ sessionVar v
|
||||
w <$ atomically (void $ tryPutTMVar (badgeWork w) ())
|
||||
|
||||
-- | The alert last raised, so it is not repeated on every pass. The snooze is in the key because
|
||||
-- kind and episode do not change when it lapses: the alert would match and stay silent until a restart.
|
||||
type BadgeOccurrence = (BadgeAlertKind, Text, Maybe UTCTime)
|
||||
|
||||
-- | Nothing ends a pass, so a persistent fault is one attempt per stall interval rather than a hot
|
||||
-- loop: every error returns a wake, and the wait is outside the retries.
|
||||
runBadgeWorker :: UserId -> TMVar () -> CM ()
|
||||
runBadgeWorker userId badgeWork = do
|
||||
emitted <- newTVarIO Nothing
|
||||
ri <- asks $ badgeRetryInterval . config
|
||||
forever $ do
|
||||
at_ <- withRetryInterval ri $ \_ loop -> do
|
||||
lift waitChatStartedAndActivated
|
||||
now <- badgeNow
|
||||
let stalled = pure $ Just $ badgeStalledInterval `addUTCTime` now
|
||||
updateUserBadge userId emitted now `catchAllErrors` retryBadgeError loop stalled
|
||||
now <- badgeNow
|
||||
liftIO $ waitBadgeWake badgeWork now at_
|
||||
|
||||
retryBadgeError :: CM a -> CM a -> ChatError -> CM a
|
||||
retryBadgeError loop stalled e = eToView e >> if badgeErrorRetry e then loop else stalled
|
||||
|
||||
-- | The signal is taken only by the wait that reports it - the take and the timer read are one
|
||||
-- transaction. now is the badge clock, so the remaining time counts down rather than re-reading it.
|
||||
waitBadgeWake :: TMVar () -> UTCTime -> Maybe UTCTime -> IO ()
|
||||
waitBadgeWake badgeWork now = \case
|
||||
Nothing -> atomically $ takeTMVar badgeWork
|
||||
Just at -> waitFor $ diffToMicroseconds $ min badgeMaxWake $ diffUTCTime at now
|
||||
where
|
||||
waitFor time
|
||||
| time <= 0 = pure ()
|
||||
| otherwise = do
|
||||
let maxWait = min time $ fromIntegral (maxBound :: Int)
|
||||
timer <- registerDelay $ fromIntegral maxWait
|
||||
signalled <- atomically $ do
|
||||
w <- tryTakeTMVar badgeWork
|
||||
fired <- readTVar timer
|
||||
unless (isJust w || fired) retry
|
||||
pure $ isJust w
|
||||
unless signalled $ waitFor $ time - maxWait
|
||||
|
||||
-- | Bounds the wait: a paidThrough far enough out would overflow the microsecond conversion,
|
||||
-- wrap negative and spin the worker. Longer than any entitlement, so no real wake is early.
|
||||
badgeMaxWake :: NominalDiffTime
|
||||
badgeMaxWake = 100 * 365 * nominalDay
|
||||
|
||||
-- | Retire what has ended, renew what is due, then report the next wake. Waking early, late or not
|
||||
-- at all changes only timing: each run reads stored state and works out what to do.
|
||||
updateUserBadge :: UserId -> TVar (Maybe BadgeOccurrence) -> UTCTime -> CM (Maybe UTCTime)
|
||||
updateUserBadge userId emitted now = do
|
||||
user <- withStore $ \db -> getUser db userId
|
||||
withStore' (`getUserBadgePurchase` user) >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just p@UserBadgePurchase {badgePurchaseId} ->
|
||||
withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just balance -> do
|
||||
-- retirement needs no service and an unbounded retry would not return before it
|
||||
retired <- retireExpiredBadge user p now balance
|
||||
latest <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
|
||||
let requestDue = not retired && badgeRequestDue now (shownBadgeCredential user p) latest balance
|
||||
(balance', serviceAt) <-
|
||||
if requestDue
|
||||
then either ((balance,) . Just) (,Nothing) <$> requestBadgeIssue userId p now
|
||||
else pure (balance, Nothing)
|
||||
-- presenting broadcasts the record it is handed, and the request above can block for the
|
||||
-- whole service timeout, so this read belongs after it and not at the top of the pass
|
||||
user' <- withStore $ \db -> getUser db userId
|
||||
-- and the purchase, or an alert acked while the request was in flight is raised again
|
||||
p' <- fromMaybe p <$> withStore' (`getBadgePurchase` badgePurchaseId)
|
||||
let issued = balanceStartTs balance' /= balanceStartTs balance
|
||||
-- outside the badge lock: the chat lock must not be taken under it
|
||||
unless retired $ presentIssuedBadge user' p' now
|
||||
emitBadgeAlert user' emitted p' now balance'
|
||||
-- retiring and presenting both replace the badge on the record read above, so it is read again
|
||||
user'' <- withStore $ \db -> getUser db userId
|
||||
when (retired || issued) $ toView . CEvtBadgeChanged user'' =<< getUserBadgeState user''
|
||||
-- a snooze is the one wake that is not in the ledger: nothing else brings the alert back,
|
||||
-- since support having ended leaves both ledger boundaries in the past
|
||||
let UserBadgePurchase {alertSnoozeUntil} = p'
|
||||
snoozeAt = find (> now) alertSnoozeUntil
|
||||
stalledAt = if requestDue && not issued then Just $ badgeStalledInterval `addUTCTime` now else Nothing
|
||||
pure $ earliestTime [serviceAt, snoozeAt, stalledAt, badgeBoundary now (shownBadgeCredential user'' p') balance']
|
||||
|
||||
-- | Support ended is the only alert raised here: the others need subscriptions, and warning before
|
||||
-- a prepaid badge ends is not actionable while topping up cannot credit months without issuing.
|
||||
-- TODO [badges] BAPrepaidEnding belongs here, three days before paidThrough, once that exists.
|
||||
derivedBadgeAlert :: UTCTime -> StatementEntry -> Maybe BadgeAlert
|
||||
derivedBadgeAlert now b
|
||||
| balanceMonths b == 0 && endsAt <= now =
|
||||
Just BadgeAlert {kind = BASupportEnded, episode = safeDecodeUtf8 $ strEncode endsAt, date = endsAt, price = Nothing}
|
||||
| otherwise = Nothing
|
||||
where
|
||||
endsAt = L.paidThrough b
|
||||
|
||||
-- | Derived from state rather than kept pending: raised unless this occurrence is the one already
|
||||
-- answered, and raised again once a snooze that answered it lapses.
|
||||
unansweredBadgeAlert :: UTCTime -> UserBadgePurchase -> StatementEntry -> Maybe BadgeAlert
|
||||
unansweredBadgeAlert now UserBadgePurchase {alertAcked, alertSnoozeUntil} balance =
|
||||
case derivedBadgeAlert now balance of
|
||||
Just alert@BadgeAlert {kind, episode}
|
||||
| alertAcked /= Just (kind, episode) || maybe False (now >=) alertSnoozeUntil -> Just alert
|
||||
_ -> Nothing
|
||||
|
||||
emitBadgeAlert :: User -> TVar (Maybe BadgeOccurrence) -> UserBadgePurchase -> UTCTime -> StatementEntry -> CM ()
|
||||
emitBadgeAlert user emitted p@UserBadgePurchase {alertSnoozeUntil} now balance =
|
||||
forM_ (unansweredBadgeAlert now p balance) $ \alert@BadgeAlert {kind, episode} -> do
|
||||
let occurrence = Just (kind, episode, alertSnoozeUntil)
|
||||
raised <- atomically $ stateTVar emitted (,occurrence)
|
||||
when (raised /= occurrence) $ toView $ CEvtBadgeAlert user alert
|
||||
|
||||
-- | Read from stored rows alone; the worker's results follow as CEvtBadgeChanged.
|
||||
getUserBadgeState :: User -> CM (Maybe BadgeState)
|
||||
getUserBadgeState user = do
|
||||
now <- badgeNow
|
||||
withStore' (`getUserBadgePurchase` user) >>= \case
|
||||
Nothing -> pure Nothing
|
||||
Just p@UserBadgePurchase {badgePurchaseId} ->
|
||||
fmap (badgeStateOf now p) <$> withStore' (`getBadgeLedgerLastEntry` badgePurchaseId)
|
||||
where
|
||||
badgeStateOf now p@UserBadgePurchase {badgePurchaseId, badgeType} balance =
|
||||
BadgeState
|
||||
{ badgePurchaseId,
|
||||
badgeType,
|
||||
monthsLeft = balanceMonths balance,
|
||||
paidThrough = L.paidThrough balance,
|
||||
renewsAt = Nothing,
|
||||
willRenew = False,
|
||||
alert = unansweredBadgeAlert now p balance
|
||||
}
|
||||
|
||||
-- | How long a month that did not issue waits before it is tried again, whatever stopped it. Not
|
||||
-- derived from the failure, so a misclassified one cannot leave a funded badge to expire.
|
||||
badgeStalledInterval :: NominalDiffTime
|
||||
badgeStalledInterval = nominalDay
|
||||
|
||||
-- | The wait after a service refusal, floored at initialInterval so answering 0 cannot spin the
|
||||
-- worker, and uncapped above it.
|
||||
badgeRetryAfter :: RetryInterval -> Maybe Word32 -> NominalDiffTime
|
||||
badgeRetryAfter RetryInterval {initialInterval} = maybe badgeStalledInterval (max floorWait . fromIntegral)
|
||||
where
|
||||
floorWait = fromIntegral initialInterval / 1000000
|
||||
|
||||
-- | How far ahead of the shown credential's expiry the renewal is requested - a day, so a failure
|
||||
-- has that long to retry. The wake and the due check both derive from it and have to agree.
|
||||
badgeRequestLead :: NominalDiffTime
|
||||
badgeRequestLead = nominalDay
|
||||
|
||||
-- | The credential the profile is showing for this purchase. Nothing when the purchase is not the
|
||||
-- one being shown, or when a crash left the issuance written and the profile not.
|
||||
shownBadgeCredential :: User -> UserBadgePurchase -> Maybe BadgeCredential
|
||||
shownBadgeCredential User {profile = LocalProfile {localBadge}} UserBadgePurchase {shown}
|
||||
| not shown = Nothing
|
||||
| otherwise = case localBadge of
|
||||
Just (OwnBadge cred _) -> Just cred
|
||||
_ -> Nothing
|
||||
|
||||
credentialExpiry :: BadgeCredential -> UTCTime
|
||||
credentialExpiry (BadgeCredential _ _ _ BadgeInfo {badgeExpiry}) = badgeExpiry
|
||||
|
||||
-- | Timed off the shown credential, not the period end: renewing around its shared expiry is what
|
||||
-- joins the anonymity set. Latest still equal to shown means this month has not been asked for.
|
||||
badgeRequestDue :: UTCTime -> Maybe BadgeCredential -> Maybe BadgeCredential -> StatementEntry -> Bool
|
||||
badgeRequestDue now shownCred latestCred balance =
|
||||
balanceMonths balance > 0 && latestCred == shownCred && maybe False lapsingSoon shownCred
|
||||
where
|
||||
lapsingSoon cred = credentialExpiry cred <= badgeRequestLead `addUTCTime` now
|
||||
|
||||
-- | The request and the presentation, a day apart, both read off the credential the profile shows,
|
||||
-- and the end of what is paid for. The credential's expiry window is what covers renewal, so it
|
||||
-- says nothing about entitlement: paidThrough is when that ends and the badge has to come off.
|
||||
-- TODO [badges] every client whose credential shares an expiry requests at the same instant. Only
|
||||
-- the expiry has to be shared, so the request could fall anywhere in its lead without splitting
|
||||
-- the anonymity set - spreading the load, and any outage, off a single moment.
|
||||
badgeBoundary :: UTCTime -> Maybe BadgeCredential -> StatementEntry -> Maybe UTCTime
|
||||
badgeBoundary now shownCred balance = case filter (> now) moments of
|
||||
[] -> Nothing
|
||||
ts -> Just $ minimum ts
|
||||
where
|
||||
moments = L.paidThrough balance : maybe [] renewalMoments shownCred
|
||||
renewalMoments cred =
|
||||
let expiry = credentialExpiry cred
|
||||
in [negate badgeRequestLead `addUTCTime` expiry, expiry]
|
||||
|
||||
earliestTime :: [Maybe UTCTime] -> Maybe UTCTime
|
||||
earliestTime ts = case catMaybes ts of
|
||||
[] -> Nothing
|
||||
ts' -> Just $ minimum ts'
|
||||
|
||||
-- | Only a failure that can clear on its own is repeated; every other throw is terminal, and
|
||||
-- repeating it would spin. Service errors are classified by retryAfter in requestBadgeIssue.
|
||||
badgeErrorRetry :: ChatError -> Bool
|
||||
badgeErrorRetry = \case
|
||||
ChatErrorAgent {agentError} -> retryable agentError
|
||||
_ -> False
|
||||
where
|
||||
-- an unanswered request is the likeliest renewal failure and temporaryOrHostError does not
|
||||
-- cover it: that classifies reaching the server, and this timeout is the agent's own
|
||||
retryable = \case
|
||||
AGENT (A_SERVICE ASETimeout) -> True
|
||||
e -> temporaryOrHostError e
|
||||
|
||||
-- | Ask the service for the month that is due and apply the response. A timeout writes nothing, so
|
||||
-- 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
|
||||
sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwCmdError "badge service not configured") pure
|
||||
withEntityLock "badgeIssue" (CLBadgeUser userId) $ do
|
||||
user <- withStore $ \db -> getUser db userId
|
||||
lastEntry <- withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) >>= maybe (throwCmdError "badge ledger has no entry to assert") pure
|
||||
let req =
|
||||
BadgeServiceRequest
|
||||
{ version = currentBadgeServiceVersion,
|
||||
purchaseKey = Just purchaseKey,
|
||||
request = BSCIssueBadge {balance = BadgeBalance {lastEntry}}
|
||||
}
|
||||
respData <- sendServiceRequestTo NRMBackground user sendTarget Nothing (Just purchasePrivKey) req
|
||||
case J.fromJSON (J.Object respData) of
|
||||
J.Success BSPBadgeCredential {credential, statement} -> do
|
||||
cred_ <- verifyIssuedCredential masterKey credential
|
||||
-- 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
|
||||
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
|
||||
eToView $ ChatError $ CECommandError $ "badge service error: " <> T.unpack (badgeServiceErrorText code)
|
||||
ri <- asks $ badgeRetryInterval . config
|
||||
pure $ Left $ badgeRetryAfter ri retryAfter `addUTCTime` now
|
||||
_ -> throwCmdError "unexpected badge service response"
|
||||
|
||||
-- | The signature covers the master key inside the credential, so it verifies no matter which key
|
||||
-- that is - the credential is stored only when that key is also this purchase's.
|
||||
verifyIssuedCredential :: BadgeMasterKey -> Maybe BadgeCredential -> CM (Maybe BadgeCredential)
|
||||
verifyIssuedCredential _ Nothing = pure Nothing
|
||||
verifyIssuedCredential masterKey (Just cred@(BadgeCredential _ credMasterKey _ _)) =
|
||||
verifyOwnBadge cred >>= \case
|
||||
Just True | credMasterKey == masterKey -> pure $ Just cred
|
||||
Just True -> Nothing <$ eToView (ChatError $ CEInternalError "issued badge credential is for a different master key")
|
||||
_ -> Nothing <$ eToView (ChatError $ CEInternalError "issued badge credential does not verify")
|
||||
|
||||
-- | Present the newest issued credential once the one on the profile has run out. It is written in
|
||||
-- a separate transaction from the issuance, so a crash between the two is repaired at the next run.
|
||||
presentIssuedBadge :: User -> UserBadgePurchase -> UTCTime -> CM ()
|
||||
presentIssuedBadge user p@UserBadgePurchase {badgePurchaseId, shown} now
|
||||
| not shown = pure ()
|
||||
| otherwise = do
|
||||
cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
|
||||
forM_ cred_ $ \cred@(BadgeCredential _ _ _ info) ->
|
||||
when (presentDue cred) $ do
|
||||
user' <- withStore $ \db -> setUserBadge db user (Just $ OwnBadge cred (mkBadgeStatus now (Just True) info))
|
||||
presentUserBadgeToContacts user'
|
||||
where
|
||||
shownCred = shownBadgeCredential user p
|
||||
-- Held back until the shown credential lapses, so the broadcast does not correlate with the
|
||||
-- request that produced it. Nothing shown at all is the state a lost profile write leaves.
|
||||
presentDue cred = Just cred /= shownCred && maybe True ((<= now) . credentialExpiry) shownCred
|
||||
|
||||
-- | The visible half of "the badge expired".
|
||||
retireExpiredBadge :: User -> UserBadgePurchase -> UTCTime -> StatementEntry -> CM Bool
|
||||
retireExpiredBadge user UserBadgePurchase {badgePurchaseId, shown} now balance
|
||||
| not (shown && L.paidThrough balance <= now) = pure False
|
||||
| otherwise = do
|
||||
user' <- withStore $ \db -> do
|
||||
liftIO $ clearShownBadge db user badgePurchaseId
|
||||
setUserBadge db user Nothing
|
||||
True <$ presentUserBadgeToContacts user'
|
||||
|
||||
-- | Waiting on the var rather than skipping an empty one is what catches a worker whose creator
|
||||
-- had not filled it when the map was swapped out.
|
||||
stopBadgeWorkers :: TM.TMap UserId (SessionVar BadgeWorker) -> IO ()
|
||||
stopBadgeWorkers workers =
|
||||
atomically (swapTVar workers M.empty) >>= mapM_ cancelBadgeWorker
|
||||
where
|
||||
cancelBadgeWorker v =
|
||||
void $ forkIO $ atomically (badgeWorkerAsync <$> readTMVar (sessionVar v)) >>= uninterruptibleCancel
|
||||
|
||||
-- | Verify the credential before writing anything; the purchase, the statement's rows, the
|
||||
-- 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 =
|
||||
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"
|
||||
@@ -5209,16 +5550,37 @@ storeRedeemedBadge user redemption@BadgeCodeRedemption {masterKey} cred@(BadgeCr
|
||||
Just True | credMasterKey /= masterKey -> throwCmdError "redeemed badge credential is for a different master key"
|
||||
Just True -> do
|
||||
g <- asks random
|
||||
now <- liftIO getCurrentTime
|
||||
now <- badgeNow
|
||||
let badge = OwnBadge cred (mkBadgeStatus now (Just True) info)
|
||||
-- TODO [badges] copy the statement's ledger entries, and retire a previously held badge
|
||||
(user', newBadge) <- withStore' $ \db -> do
|
||||
newBadge <- createCodeBadgePurchase db g user redemption cred badgeExpiry now
|
||||
-- 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
|
||||
-- a replay must not put a superseded badge back, or tell every contact again
|
||||
user' <- if newBadge then setUserBadge db user (Just badge) else pure user
|
||||
pure (user', newBadge)
|
||||
when newBadge $ presentUserBadgeToContacts user'
|
||||
pure $ CRBadgeRedeemed user' badge newBadge
|
||||
user' <- if newBadge then setUserBadge db user (Just badge) else getUser db userId
|
||||
pure (user', newBadge, applied)
|
||||
unless applied $ eToView $ ChatError $ CEInternalError "redeemed badge credential has no ledger row to store it against"
|
||||
-- nothing is due yet, but a pass is what arms the next wake, and this is the first purchase
|
||||
lift $ startBadgeWork user'
|
||||
pure (if newBadge then Just user' else Nothing, CRBadgeRedeemed user' badge newBadge)
|
||||
|
||||
-- | 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
|
||||
tip <- getBadgeLedgerLastEntry db purchaseId
|
||||
storeBadgeStatement db purchaseId tip entries now
|
||||
case (,) <$> cred_ <*> issuedEntryId of
|
||||
Nothing -> pure True
|
||||
Just (cred, entryUuid) ->
|
||||
getBadgeLedgerEntryId db purchaseId entryUuid >>= \case
|
||||
Nothing -> pure False
|
||||
Just entryId -> storeBadgeIssuance db g purchaseId entryId cred now
|
||||
where
|
||||
-- the credential belongs to the last month the statement issued
|
||||
issuedEntryId = case [entryId | StatementEntry {entryId, entryType = SEDebit SDBadge} <- entries] of
|
||||
[] -> Nothing
|
||||
ids -> Just (last ids)
|
||||
|
||||
sendServiceRequestTo :: J.ToJSON a => NetworkRequestMode -> User -> ConnectTarget 'CMContact -> Maybe NominalDiffTime -> Maybe C.PrivateKeyEd25519 -> a -> CM J.Object
|
||||
sendServiceRequestTo nm user sendTarget requestTimeout signKey request = do
|
||||
@@ -5625,6 +5987,8 @@ chatCommandP =
|
||||
"/_reject " *> (APIRejectContact <$> A.decimal <*> (" notify=" *> onOffP <|> pure False)),
|
||||
"/_service_request " *> (APISendServiceRequest <$> A.decimal <* A.space <*> strP <*> optional (" timeout=" *> (realToFrac <$> A.double)) <*> optional (" sign_key=" *> strP) <* A.space <*> jsonP),
|
||||
"/_redeem_badge_code " *> (APIRedeemBadgeCode <$> A.decimal <* A.space <*> textP),
|
||||
"/_badge state " *> (APIGetBadgeState <$> A.decimal),
|
||||
"/_badge ack " *> (APIAckBadgeAlert <$> A.decimal <* A.space <*> A.decimal <* A.space <*> badgeAlertKindP <* A.space <*> onOffP <* A.space <*> textP),
|
||||
"/_service_response " *> (APISendServiceResponse <$> A.decimal <* A.space <*> strP <* A.space <*> jsonP),
|
||||
"/_call invite @" *> (APISendCallInvitation <$> A.decimal <* A.space <*> jsonP),
|
||||
"/call " *> char_ '@' *> (SendCallInvitation <$> displayNameP <*> pure defaultCallType),
|
||||
@@ -6044,6 +6408,9 @@ chatCommandP =
|
||||
descr <- A.takeWhile1 isSpace *> (T.dropWhileEnd isSpace <$> textP) <|> pure ""
|
||||
pure $ if T.null descr then Nothing else Just $ T.take 160 descr
|
||||
textP = safeDecodeUtf8 <$> A.takeByteString
|
||||
badgeAlertKindP = do
|
||||
t <- A.takeTill (== ' ')
|
||||
maybe (fail "bad badge alert kind") pure $ textDecode $ safeDecodeUtf8 t
|
||||
pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' '))
|
||||
verifyCodeP = safeDecodeUtf8 <$> A.takeWhile (\c -> isDigit c || c == ' ')
|
||||
msgTextP = jsonP <|> textP
|
||||
|
||||
@@ -7,10 +7,22 @@
|
||||
|
||||
module Simplex.Chat.Store.Badges
|
||||
( BadgeCodeRedemption (..),
|
||||
UserBadgePurchase (..),
|
||||
getUserBadgePurchase,
|
||||
getBadgePurchase,
|
||||
userHasBadge,
|
||||
setBadgeAlertAcked,
|
||||
clearShownBadge,
|
||||
getBadgeCodeRedemption,
|
||||
createBadgeCodeRedemption,
|
||||
deleteBadgeCodeRedemption,
|
||||
createCodeBadgePurchase,
|
||||
getCodeBadgePurchase,
|
||||
storeBadgeIssuance,
|
||||
getLatestIssuedCredential,
|
||||
storeBadgeStatement,
|
||||
getBadgeLedgerLastEntry,
|
||||
getBadgeLedgerEntryId,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -19,23 +31,26 @@ import Crypto.Random (ChaChaDRG)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Int (Int64)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Simplex.Chat.Badges
|
||||
import Simplex.Chat.Badges.Types (BadgePurchaseStatus (..))
|
||||
import Simplex.Chat.Badges.Ledger
|
||||
import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
|
||||
import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgePurchaseStatus (..))
|
||||
import Simplex.Chat.Store.Shared (insertedRowId)
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..))
|
||||
import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Encoding.String (strEncode)
|
||||
import Simplex.Messaging.Util (maybeFirstRow, safeDecodeUtf8)
|
||||
import Simplex.Messaging.Util (decodeJSON, maybeFirstRow, maybeFirstRow', safeDecodeUtf8)
|
||||
|
||||
#if defined(dbPostgres)
|
||||
import Database.PostgreSQL.Simple (Only (..))
|
||||
import Database.PostgreSQL.Simple (Only (..), (:.) (..))
|
||||
import Database.PostgreSQL.Simple.SqlQQ (sql)
|
||||
#else
|
||||
import Database.SQLite.Simple (Only (..))
|
||||
import Database.SQLite.Simple (Only (..), (:.) (..))
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
#endif
|
||||
|
||||
@@ -90,21 +105,13 @@ deleteBadgeCodeRedemption db redemptionId =
|
||||
|]
|
||||
(redemptionId, redemptionId)
|
||||
|
||||
-- | The purchase a redeemed code created, its issuance, and the profile's pointer to it.
|
||||
-- False when the code was already redeemed here: the service replays the credential it issued,
|
||||
-- and that must add no purchase and leave the shown badge alone.
|
||||
createCodeBadgePurchase :: DB.Connection -> TVar ChaChaDRG -> User -> BadgeCodeRedemption -> BadgeCredential -> UTCTime -> UTCTime -> IO Bool
|
||||
createCodeBadgePurchase db g User {userId} redemption credential expiry now =
|
||||
-- | 'False' when the code was already redeemed here: the service replays the credential it
|
||||
-- issued, and that must add no purchase and leave the shown badge alone.
|
||||
createCodeBadgePurchase :: DB.Connection -> User -> BadgeCodeRedemption -> BadgeCredential -> UTCTime -> IO (Int64, Bool)
|
||||
createCodeBadgePurchase db User {userId} redemption credential now =
|
||||
getCodeBadgePurchase db redemption >>= \case
|
||||
Just _ -> pure False
|
||||
Just purchaseId -> pure (purchaseId, False)
|
||||
Nothing -> do
|
||||
purchaseId <- insertPurchase
|
||||
DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (purchaseId, userId)
|
||||
pure True
|
||||
where
|
||||
BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk} = redemption
|
||||
BadgeCredential {badgeInfo = BadgeInfo {badgeType}} = credential
|
||||
insertPurchase = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
@@ -114,19 +121,217 @@ createCodeBadgePurchase db g User {userId} redemption credential expiry now =
|
||||
|]
|
||||
(userId, purchaseKey, purchasePrivKey, Binary mk, badgeType, badgeType, PSIssued, redemptionId, now, now)
|
||||
purchaseId <- insertedRowId db
|
||||
DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (purchaseId, userId)
|
||||
pure (purchaseId, True)
|
||||
where
|
||||
BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk} = redemption
|
||||
BadgeCredential {badgeInfo = BadgeInfo {badgeType}} = credential
|
||||
|
||||
-- | The period comes from the ledger, the expiry from the credential, which runs a week longer.
|
||||
-- 'False' means no issuance row was written, which the caller reports rather than drop in silence.
|
||||
-- A replayed statement names a month already issued, and one month has one issuance.
|
||||
storeBadgeIssuance :: DB.Connection -> TVar ChaChaDRG -> Int64 -> Int64 -> BadgeCredential -> UTCTime -> IO Bool
|
||||
storeBadgeIssuance db g badgePurchaseId entryId credential now =
|
||||
getIssuedPeriod db badgePurchaseId entryId >>= \case
|
||||
Nothing -> pure False
|
||||
Just (periodStart, periodEnd) -> do
|
||||
issuanceId <- safeDecodeUtf8 . strEncode <$> atomically (C.randomBytes 16 g)
|
||||
-- TODO [badges] the credential's expiry stands in for the period end, which is up to a
|
||||
-- week later, until the statement carries the real period
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO badge_issuances (issuance_id, badge_purchase_id, badge_type, period_start, period_end, expiry, credential, created_at)
|
||||
VALUES (?,?,?,?,?,?,?,?)
|
||||
INSERT INTO badge_issuances (issuance_id, badge_purchase_id, entry_id, badge_type, period_start, period_end, expiry, credential, created_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?)
|
||||
ON CONFLICT (badge_purchase_id, entry_id) DO NOTHING
|
||||
|]
|
||||
(issuanceId, purchaseId, badgeType, now, expiry, expiry, Binary (LB.toStrict $ J.encode credential), now)
|
||||
pure purchaseId
|
||||
((issuanceId, badgePurchaseId, entryId, badgeType) :. (periodStart, periodEnd, badgeExpiry, Binary (LB.toStrict $ J.encode credential), now))
|
||||
pure True
|
||||
where
|
||||
BadgeCredential {badgeInfo = BadgeInfo {badgeType, badgeExpiry}} = credential
|
||||
|
||||
getLatestIssuedCredential :: DB.Connection -> Int64 -> IO (Maybe BadgeCredential)
|
||||
getLatestIssuedCredential db badgePurchaseId = do
|
||||
rows <-
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT credential FROM badge_issuances
|
||||
WHERE badge_purchase_id = ?
|
||||
ORDER BY period_end DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(Only badgePurchaseId)
|
||||
pure $ case rows of
|
||||
[Only (Binary bs)] -> J.decodeStrict' bs
|
||||
_ -> Nothing
|
||||
|
||||
-- the start is read from the row before rather than by subtracting a month, which clips
|
||||
getIssuedPeriod :: DB.Connection -> Int64 -> Int64 -> IO (Maybe (UTCTime, UTCTime))
|
||||
getIssuedPeriod db badgePurchaseId entryId = do
|
||||
rows <-
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
(SELECT prev.balance_start_ts FROM badge_ledger prev
|
||||
WHERE prev.badge_purchase_id = issued.badge_purchase_id AND prev.entry_id < issued.entry_id
|
||||
ORDER BY prev.entry_id DESC LIMIT 1),
|
||||
issued.balance_start_ts
|
||||
FROM badge_ledger issued
|
||||
WHERE issued.badge_purchase_id = ? AND issued.entry_id = ?
|
||||
|]
|
||||
(badgePurchaseId, entryId)
|
||||
-- no preceding row means no credit was ever stored, so the period this row issued is unknown
|
||||
pure $ case rows of
|
||||
[(Just periodStart, periodEnd)] -> Just (periodStart, periodEnd)
|
||||
_ -> Nothing
|
||||
|
||||
getCodeBadgePurchase :: DB.Connection -> BadgeCodeRedemption -> IO (Maybe Int64)
|
||||
getCodeBadgePurchase db BadgeCodeRedemption {redemptionId} =
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query db "SELECT badge_purchase_id FROM badge_purchases WHERE badge_code_redemption_id = ?" (Only redemptionId)
|
||||
|
||||
data UserBadgePurchase = UserBadgePurchase
|
||||
{ badgePurchaseId :: Int64,
|
||||
purchaseKey :: C.PublicKeyEd25519,
|
||||
purchasePrivKey :: C.PrivateKeyEd25519,
|
||||
masterKey :: BadgeMasterKey,
|
||||
badgeType :: BadgeType,
|
||||
shown :: Bool,
|
||||
alertAcked :: Maybe (BadgeAlertKind, Text),
|
||||
alertSnoozeUntil :: Maybe UTCTime
|
||||
}
|
||||
|
||||
-- | Newest, not the one shown_badge_id points at - retirement clears that, and the support ended
|
||||
-- alert is recomputed from this purchase after the badge stops being shown.
|
||||
getUserBadgePurchase :: DB.Connection -> User -> IO (Maybe UserBadgePurchase)
|
||||
getUserBadgePurchase db User {userId} =
|
||||
maybeFirstRow fromOnly newestId >>= maybe (pure Nothing) (getBadgePurchase db)
|
||||
where
|
||||
newestId =
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT badge_purchase_id FROM badge_purchases
|
||||
WHERE user_id = ? AND purchase_priv_key IS NOT NULL
|
||||
ORDER BY badge_purchase_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(Only userId)
|
||||
|
||||
-- shown is a CASE because in Postgres a comparison is boolean, which BoolInt rejects.
|
||||
getBadgePurchase :: DB.Connection -> Int64 -> IO (Maybe UserBadgePurchase)
|
||||
getBadgePurchase db purchaseId =
|
||||
maybeFirstRow toPurchase $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT p.badge_purchase_id, p.purchase_key, p.purchase_priv_key, p.master_key, p.current_badge_type,
|
||||
(CASE WHEN u.shown_badge_id = p.badge_purchase_id THEN 1 ELSE 0 END),
|
||||
p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until
|
||||
FROM badge_purchases p
|
||||
JOIN users u ON u.user_id = p.user_id
|
||||
WHERE p.badge_purchase_id = ? AND p.purchase_priv_key IS NOT NULL
|
||||
|]
|
||||
(Only purchaseId)
|
||||
where
|
||||
toPurchase (badgePurchaseId, purchaseKey, purchasePrivKey, Binary mk, badgeType, shown_, ackedKind_, ackedEpisode_, alertSnoozeUntil) =
|
||||
UserBadgePurchase
|
||||
{ badgePurchaseId,
|
||||
purchaseKey,
|
||||
purchasePrivKey,
|
||||
masterKey = BadgeMasterKey mk,
|
||||
badgeType,
|
||||
shown = unBI shown_,
|
||||
alertAcked = (,) <$> ackedKind_ <*> ackedEpisode_,
|
||||
alertSnoozeUntil
|
||||
}
|
||||
|
||||
-- | Whether a badge is on the profile now: set when a redemption stores one, cleared when it is
|
||||
-- retired. Read as the id rather than as a comparison, which in Postgres would be a boolean.
|
||||
userHasBadge :: DB.Connection -> User -> IO Bool
|
||||
userHasBadge db User {userId} =
|
||||
maybeFirstRow' False shownBadge $
|
||||
DB.query db "SELECT shown_badge_id FROM users WHERE user_id = ?" (Only userId)
|
||||
where
|
||||
shownBadge :: Only (Maybe Int64) -> Bool
|
||||
shownBadge = isJust . fromOnly
|
||||
|
||||
-- | An ack and a snooze both record the occurrence answered; a snooze also records how long it
|
||||
-- holds, so that it silences that occurrence and not whichever one is derived next.
|
||||
setBadgeAlertAcked :: DB.Connection -> Int64 -> BadgeAlertKind -> Text -> Maybe UTCTime -> IO ()
|
||||
setBadgeAlertAcked db badgePurchaseId kind episode snoozeUntil =
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE badge_purchases SET alert_acked_kind = ?, alert_acked_episode = ?, alert_snooze_until = ? WHERE badge_purchase_id = ?"
|
||||
(kind, episode, snoozeUntil, badgePurchaseId)
|
||||
|
||||
-- | Stop showing a badge that has expired unrenewed; the profile update is broadcast by the caller.
|
||||
clearShownBadge :: DB.Connection -> User -> Int64 -> IO ()
|
||||
clearShownBadge db User {userId} badgePurchaseId =
|
||||
DB.execute db "UPDATE users SET shown_badge_id = NULL WHERE user_id = ? AND shown_badge_id = ?" (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
|
||||
where
|
||||
storeEntry (StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince, createdAt, entryType}, checked) =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
INSERT INTO badge_ledger
|
||||
(entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type,
|
||||
was_paused_since, service_created_at, created_at, entry_type, entry_credit_type, entry_debit_type,
|
||||
entry_type_unknown, entry_type_value, balance_checked)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
ON CONFLICT (entry_uuid) DO NOTHING
|
||||
|]
|
||||
( (entryId, badgePurchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince)
|
||||
:. (createdAt, now, entryTypeT, creditType, debitType, BI typeUnknown, entryTypeValue, BI <$> checked)
|
||||
)
|
||||
where
|
||||
(entryTypeT, creditType, debitType) = entryTypeColumns entryType
|
||||
-- kept for every entry, not only for a type this version cannot decode: a tag alone does
|
||||
-- not rebuild the types that name an invoice, a charge or another purchase
|
||||
entryTypeValue = safeDecodeUtf8 . LB.toStrict $ case entryType of
|
||||
SECredit c -> J.encode c
|
||||
SEDebit d -> J.encode d
|
||||
typeUnknown = case entryType of
|
||||
SECredit SCUnknown {} -> True
|
||||
SEDebit SDUnknown {} -> True
|
||||
_ -> False
|
||||
|
||||
-- | The balance is the last row; nothing derives it by summing the history.
|
||||
getBadgeLedgerLastEntry :: DB.Connection -> Int64 -> IO (Maybe StatementEntry)
|
||||
getBadgeLedgerLastEntry db badgePurchaseId =
|
||||
maybeFirstRow' Nothing toEntry $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type,
|
||||
was_paused_since, service_created_at, entry_type, entry_credit_type, entry_debit_type, entry_type_value
|
||||
FROM badge_ledger
|
||||
WHERE badge_purchase_id = ?
|
||||
ORDER BY entry_id DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(Only badgePurchaseId)
|
||||
where
|
||||
toEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType) :. (wasPausedSince, createdAt, entryType_, credit_, debit_, value_)) =
|
||||
(\entryType -> StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince, createdAt, entryType})
|
||||
<$> maybe (entryTypeFromColumns entryType_ credit_ debit_) (entryTypeFromValue entryType_) value_
|
||||
|
||||
-- | Decodes the stored JSON rather than rebuilding from the tag, so a version that has since
|
||||
-- learnt the type reads it with its fields, and one that has not still gets it back verbatim.
|
||||
entryTypeFromValue :: Text -> Text -> Maybe StatementEntryType
|
||||
entryTypeFromValue entryTypeT value_ = case entryTypeT of
|
||||
"credit" -> SECredit <$> decodeJSON value_
|
||||
"debit" -> SEDebit <$> decodeJSON value_
|
||||
_ -> Nothing
|
||||
|
||||
getBadgeLedgerEntryId :: DB.Connection -> Int64 -> Text -> IO (Maybe Int64)
|
||||
getBadgeLedgerEntryId db badgePurchaseId entryUuid =
|
||||
maybeFirstRow fromOnly $
|
||||
DB.query db "SELECT entry_id FROM badge_ledger WHERE badge_purchase_id = ? AND entry_uuid = ?" (badgePurchaseId, entryUuid)
|
||||
|
||||
@@ -143,6 +143,7 @@ CREATE TABLE @badge_ledger(
|
||||
change_months SMALLINT NOT NULL,
|
||||
balance_months SMALLINT NOT NULL,
|
||||
balance_start_ts TIMESTAMPTZ NOT NULL,
|
||||
balance_anchor_ts TIMESTAMPTZ NOT NULL,
|
||||
balance_badge_type TEXT NOT NULL,
|
||||
was_paused_since TIMESTAMPTZ,
|
||||
service_created_at TIMESTAMPTZ NOT NULL,
|
||||
@@ -183,6 +184,8 @@ CREATE TABLE @badge_issuances(
|
||||
CREATE INDEX @idx_badge_issuances_purchase ON @badge_issuances(badge_purchase_id, issuance_id);
|
||||
|
||||
CREATE INDEX @idx_badge_issuances_entry ON @badge_issuances(entry_id);
|
||||
|
||||
CREATE UNIQUE INDEX @idx_badge_issuances_purchase_entry ON @badge_issuances(badge_purchase_id, entry_id);
|
||||
|]
|
||||
|
||||
badgeSchemaTablesDown :: Text
|
||||
@@ -190,6 +193,7 @@ badgeSchemaTablesDown =
|
||||
[r|
|
||||
DROP INDEX @idx_badge_issuances_purchase;
|
||||
DROP INDEX @idx_badge_issuances_entry;
|
||||
DROP INDEX @idx_badge_issuances_purchase_entry;
|
||||
DROP TABLE @badge_issuances;
|
||||
DROP INDEX @idx_badge_ledger_uuid;
|
||||
DROP INDEX @idx_badge_ledger_purchase;
|
||||
@@ -237,6 +241,8 @@ ALTER TABLE badge_ledger ADD COLUMN entry_type_unknown SMALLINT NOT NULL DEFAULT
|
||||
|
||||
ALTER TABLE badge_ledger ADD COLUMN entry_type_value TEXT;
|
||||
|
||||
ALTER TABLE badge_ledger ADD COLUMN balance_checked SMALLINT;
|
||||
|
||||
CREATE INDEX idx_badge_purchases_user ON badge_purchases(user_id);
|
||||
|
||||
ALTER TABLE users ADD COLUMN shown_badge_id BIGINT REFERENCES badge_purchases ON DELETE SET NULL;
|
||||
|
||||
@@ -223,6 +223,7 @@ CREATE TABLE test_chat_schema.badge_ledger (
|
||||
change_months smallint NOT NULL,
|
||||
balance_months smallint NOT NULL,
|
||||
balance_start_ts timestamp with time zone NOT NULL,
|
||||
balance_anchor_ts timestamp with time zone NOT NULL,
|
||||
balance_badge_type text NOT NULL,
|
||||
was_paused_since timestamp with time zone,
|
||||
service_created_at timestamp with time zone NOT NULL,
|
||||
@@ -235,7 +236,8 @@ CREATE TABLE test_chat_schema.badge_ledger (
|
||||
from_purchase_id bigint,
|
||||
to_purchase_id bigint,
|
||||
entry_type_unknown smallint DEFAULT 0 NOT NULL,
|
||||
entry_type_value text
|
||||
entry_type_value text,
|
||||
balance_checked smallint
|
||||
);
|
||||
|
||||
|
||||
@@ -2214,6 +2216,10 @@ CREATE INDEX idx_badge_issuances_purchase ON test_chat_schema.badge_issuances US
|
||||
|
||||
|
||||
|
||||
CREATE UNIQUE INDEX idx_badge_issuances_purchase_entry ON test_chat_schema.badge_issuances USING btree (badge_purchase_id, entry_id);
|
||||
|
||||
|
||||
|
||||
CREATE INDEX idx_badge_ledger_charge ON test_chat_schema.badge_ledger USING btree (charge_id);
|
||||
|
||||
|
||||
|
||||
@@ -382,19 +382,21 @@ updateUserProfileFields_' db userId profileId Profile {displayName, fullName, sh
|
||||
|
||||
-- store the user's own badge credential; touches only the badge columns.
|
||||
-- bumps user_member_profile_updated_at so groups receive the updated profile (with the badge) on the next message.
|
||||
setUserBadge :: DB.Connection -> User -> Maybe LocalBadge -> IO User
|
||||
setUserBadge db user@User {userId, profile = p@LocalProfile {profileId}} localBadge = do
|
||||
ts <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE contact_profiles
|
||||
SET badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ?, badge_key_idx = ?, updated_at = ?
|
||||
WHERE user_id = ? AND contact_profile_id = ?
|
||||
|]
|
||||
(localBadgeToRow localBadge :. (ts, userId, profileId))
|
||||
DB.execute db "UPDATE users SET user_member_profile_updated_at = ? WHERE user_id = ?" (ts, userId)
|
||||
pure (user :: User) {profile = p {localBadge}, userMemberProfileUpdatedAt = Just ts}
|
||||
-- answers the row as stored, or a profile edit landing since the caller's read is broadcast back stale.
|
||||
setUserBadge :: DB.Connection -> User -> Maybe LocalBadge -> ExceptT StoreError IO User
|
||||
setUserBadge db User {userId, profile = LocalProfile {profileId}} localBadge = do
|
||||
liftIO $ do
|
||||
ts <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE contact_profiles
|
||||
SET badge_proof = ?, badge_pres_header = ?, badge_expiry = ?, badge_type = ?, badge_verified = ?, badge_extra = ?, badge_master_key = ?, badge_signature = ?, badge_key_idx = ?, updated_at = ?
|
||||
WHERE user_id = ? AND contact_profile_id = ?
|
||||
|]
|
||||
(localBadgeToRow localBadge :. (ts, userId, profileId))
|
||||
DB.execute db "UPDATE users SET user_member_profile_updated_at = ? WHERE user_id = ?" (ts, userId)
|
||||
getUser db userId
|
||||
|
||||
setUserSimplexDomain :: DB.Connection -> User -> Maybe SimplexDomain -> IO User
|
||||
setUserSimplexDomain db user@User {userId, profile = p@LocalProfile {profileId}} domain_ = do
|
||||
|
||||
@@ -144,6 +144,7 @@ CREATE TABLE @badge_ledger(
|
||||
change_months INTEGER NOT NULL,
|
||||
balance_months INTEGER NOT NULL,
|
||||
balance_start_ts TEXT NOT NULL,
|
||||
balance_anchor_ts TEXT NOT NULL,
|
||||
balance_badge_type TEXT NOT NULL,
|
||||
was_paused_since TEXT,
|
||||
service_created_at TEXT NOT NULL,
|
||||
@@ -184,6 +185,8 @@ CREATE TABLE @badge_issuances(
|
||||
CREATE INDEX @idx_badge_issuances_purchase ON @badge_issuances(badge_purchase_id, issuance_id);
|
||||
|
||||
CREATE INDEX @idx_badge_issuances_entry ON @badge_issuances(entry_id);
|
||||
|
||||
CREATE UNIQUE INDEX @idx_badge_issuances_purchase_entry ON @badge_issuances(badge_purchase_id, entry_id);
|
||||
|]
|
||||
|
||||
badgeSchemaTablesDown :: Query
|
||||
@@ -191,6 +194,7 @@ badgeSchemaTablesDown =
|
||||
[sql|
|
||||
DROP INDEX @idx_badge_issuances_purchase;
|
||||
DROP INDEX @idx_badge_issuances_entry;
|
||||
DROP INDEX @idx_badge_issuances_purchase_entry;
|
||||
DROP TABLE @badge_issuances;
|
||||
DROP INDEX @idx_badge_ledger_uuid;
|
||||
DROP INDEX @idx_badge_ledger_purchase;
|
||||
@@ -238,6 +242,8 @@ ALTER TABLE badge_ledger ADD COLUMN entry_type_unknown INTEGER NOT NULL DEFAULT
|
||||
|
||||
ALTER TABLE badge_ledger ADD COLUMN entry_type_value TEXT;
|
||||
|
||||
ALTER TABLE badge_ledger ADD COLUMN balance_checked INTEGER;
|
||||
|
||||
CREATE INDEX idx_badge_purchases_user ON badge_purchases(user_id);
|
||||
|
||||
ALTER TABLE users ADD COLUMN shown_badge_id INTEGER REFERENCES badge_purchases ON DELETE SET NULL;
|
||||
|
||||
@@ -1204,8 +1204,19 @@ Plan:
|
||||
SEARCH chat_item_reactions USING INDEX idx_chat_item_reactions_group (group_id=? AND shared_msg_id=?)
|
||||
|
||||
Query:
|
||||
INSERT INTO badge_issuances (issuance_id, badge_purchase_id, badge_type, period_start, period_end, expiry, credential, created_at)
|
||||
VALUES (?,?,?,?,?,?,?,?)
|
||||
INSERT INTO badge_issuances (issuance_id, badge_purchase_id, entry_id, badge_type, period_start, period_end, expiry, credential, created_at)
|
||||
VALUES (?,?,?,?,?,?,?,?,?)
|
||||
ON CONFLICT (badge_purchase_id, entry_id) DO NOTHING
|
||||
|
||||
Plan:
|
||||
|
||||
Query:
|
||||
INSERT INTO badge_ledger
|
||||
(entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type,
|
||||
was_paused_since, service_created_at, created_at, entry_type, entry_credit_type, entry_debit_type,
|
||||
entry_type_unknown, entry_type_value, balance_checked)
|
||||
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)
|
||||
ON CONFLICT (entry_uuid) DO NOTHING
|
||||
|
||||
Plan:
|
||||
|
||||
@@ -2017,6 +2028,20 @@ Query:
|
||||
|
||||
Plan:
|
||||
|
||||
Query:
|
||||
SELECT
|
||||
(SELECT prev.balance_start_ts FROM badge_ledger prev
|
||||
WHERE prev.badge_purchase_id = issued.badge_purchase_id AND prev.entry_id < issued.entry_id
|
||||
ORDER BY prev.entry_id DESC LIMIT 1),
|
||||
issued.balance_start_ts
|
||||
FROM badge_ledger issued
|
||||
WHERE issued.badge_purchase_id = ? AND issued.entry_id = ?
|
||||
|
||||
Plan:
|
||||
SEARCH issued USING INTEGER PRIMARY KEY (rowid=?)
|
||||
CORRELATED SCALAR SUBQUERY 1
|
||||
SEARCH prev USING INDEX idx_badge_ledger_purchase (badge_purchase_id=? AND entry_id<?)
|
||||
|
||||
Query:
|
||||
SELECT
|
||||
-- Contact
|
||||
@@ -3729,6 +3754,16 @@ Query:
|
||||
Plan:
|
||||
SEARCH cp USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query:
|
||||
SELECT credential FROM badge_issuances
|
||||
WHERE badge_purchase_id = ?
|
||||
ORDER BY period_end DESC
|
||||
LIMIT 1
|
||||
|
||||
Plan:
|
||||
SEARCH badge_issuances USING INDEX idx_badge_issuances_purchase_entry (badge_purchase_id=?)
|
||||
USE TEMP B-TREE FOR ORDER BY
|
||||
|
||||
Query:
|
||||
SELECT ct.contact_id
|
||||
FROM contacts ct
|
||||
@@ -3781,6 +3816,17 @@ Query:
|
||||
Plan:
|
||||
SEARCH contact_profiles USING INDEX idx_contact_profiles_user_id (user_id=?)
|
||||
|
||||
Query:
|
||||
SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type,
|
||||
was_paused_since, service_created_at, entry_type, entry_credit_type, entry_debit_type, entry_type_value
|
||||
FROM badge_ledger
|
||||
WHERE badge_purchase_id = ?
|
||||
ORDER BY entry_id DESC
|
||||
LIMIT 1
|
||||
|
||||
Plan:
|
||||
SEARCH badge_ledger USING INDEX idx_badge_ledger_purchase (badge_purchase_id=?)
|
||||
|
||||
Query:
|
||||
SELECT f.file_id
|
||||
FROM files f
|
||||
@@ -3981,6 +4027,20 @@ Plan:
|
||||
SEARCH m USING INDEX idx_group_members_user_id (user_id=?)
|
||||
SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query:
|
||||
SELECT p.badge_purchase_id, p.purchase_key, p.purchase_priv_key, p.master_key, p.current_badge_type,
|
||||
(CASE WHEN u.shown_badge_id = p.badge_purchase_id THEN 1 ELSE 0 END),
|
||||
p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until
|
||||
FROM badge_purchases p
|
||||
JOIN users u ON u.user_id = p.user_id
|
||||
WHERE p.user_id = ? AND p.purchase_priv_key IS NOT NULL
|
||||
ORDER BY p.badge_purchase_id DESC
|
||||
LIMIT 1
|
||||
|
||||
Plan:
|
||||
SEARCH u USING INTEGER PRIMARY KEY (rowid=?)
|
||||
SEARCH p USING INDEX idx_badge_purchases_user (user_id=?)
|
||||
|
||||
Query:
|
||||
SELECT pgm.message_id, m.shared_msg_id, m.msg_body, m.msg_chat_binding, m.msg_signatures
|
||||
FROM pending_group_messages pgm
|
||||
@@ -7018,6 +7078,11 @@ Plan:
|
||||
Query: INSERT INTO app_settings (app_settings) VALUES (?)
|
||||
Plan:
|
||||
|
||||
Query: INSERT INTO badge_ledger (entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type, service_created_at, created_at, entry_type, entry_credit_type, entry_type_unknown, entry_type_value) SELECT 'unknown-entry', badge_purchase_id, 0, balance_months, balance_start_ts, balance_anchor_ts, balance_badge_type, service_created_at, created_at, 'credit', 'grant', 1, '{"type":"grant"}' FROM badge_ledger ORDER BY entry_id DESC LIMIT 1
|
||||
Plan:
|
||||
SCAN badge_ledger
|
||||
SEARCH badge_issuances USING COVERING INDEX idx_badge_issuances_entry (entry_id=?)
|
||||
|
||||
Query: INSERT INTO chat_item_mentions (chat_item_id, group_id, member_id, display_name) VALUES (?, ?, ?, ?)
|
||||
Plan:
|
||||
|
||||
@@ -7205,6 +7270,10 @@ Query: SELECT agent_conn_id FROM connections WHERE user_id = ? AND conn_req_inv
|
||||
Plan:
|
||||
SEARCH connections USING INDEX idx_connections_conn_req_inv (user_id=? AND conn_req_inv=?)
|
||||
|
||||
Query: SELECT alert_acked_kind, alert_acked_episode FROM badge_purchases
|
||||
Plan:
|
||||
SCAN badge_purchases
|
||||
|
||||
Query: SELECT app_settings FROM app_settings
|
||||
Plan:
|
||||
SCAN app_settings
|
||||
@@ -7217,6 +7286,14 @@ Query: SELECT auth_err_counter FROM connections WHERE user_id = ? AND connection
|
||||
Plan:
|
||||
SEARCH connections USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: SELECT badge_expiry, contact_profile_id FROM contact_profiles WHERE badge_proof IS NOT NULL ORDER BY contact_profile_id
|
||||
Plan:
|
||||
SCAN contact_profiles
|
||||
|
||||
Query: SELECT badge_expiry, contact_profile_id FROM contact_profiles WHERE badge_signature IS NOT NULL ORDER BY contact_profile_id
|
||||
Plan:
|
||||
SCAN contact_profiles
|
||||
|
||||
Query: SELECT badge_purchase_id FROM badge_purchases WHERE badge_code_redemption_id = ?
|
||||
Plan:
|
||||
SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_code_redemption (badge_code_redemption_id=?)
|
||||
@@ -7354,6 +7431,24 @@ Query: SELECT count(1) FROM pending_group_messages
|
||||
Plan:
|
||||
SCAN pending_group_messages USING COVERING INDEX idx_pending_group_messages_group_member_id
|
||||
|
||||
Query: SELECT entry_id FROM badge_ledger WHERE badge_purchase_id = ? AND entry_uuid = ?
|
||||
Plan:
|
||||
SEARCH badge_ledger USING INDEX idx_badge_ledger_uuid (entry_uuid=?)
|
||||
|
||||
Query: SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_badge_type, COALESCE(entry_credit_type, entry_debit_type) FROM badge_ledger ORDER BY entry_id
|
||||
Plan:
|
||||
SCAN badge_ledger
|
||||
|
||||
Query: SELECT expiry, badge_purchase_id FROM badge_issuances ORDER BY period_end
|
||||
Plan:
|
||||
SCAN badge_issuances
|
||||
USE TEMP B-TREE FOR ORDER BY
|
||||
|
||||
Query: SELECT expiry, badge_purchase_id FROM badge_issuances ORDER BY period_end DESC LIMIT 1
|
||||
Plan:
|
||||
SCAN badge_issuances
|
||||
USE TEMP B-TREE FOR ORDER BY
|
||||
|
||||
Query: SELECT file_id FROM files WHERE user_id = ? AND redirect_file_id = ?
|
||||
Plan:
|
||||
SEARCH files USING INDEX idx_files_redirect_file_id (redirect_file_id=?)
|
||||
@@ -7554,6 +7649,14 @@ Query: SELECT should_sync FROM connections_sync WHERE connections_sync_id = 1
|
||||
Plan:
|
||||
SEARCH connections_sync USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: SELECT shown_badge_id FROM users WHERE user_id = ?
|
||||
Plan:
|
||||
SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: SELECT shown_badge_id, user_id FROM users WHERE user_id = 1
|
||||
Plan:
|
||||
SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: SELECT stored_roster_version FROM groups WHERE group_id = ?
|
||||
Plan:
|
||||
SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
|
||||
@@ -7582,6 +7685,10 @@ Query: SELECT xgrplinkmem_received FROM group_members WHERE group_member_id = ?
|
||||
Plan:
|
||||
SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: UPDATE badge_purchases SET alert_acked_kind = ?, alert_acked_episode = ?, alert_snooze_until = ? WHERE badge_purchase_id = ?
|
||||
Plan:
|
||||
SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: UPDATE chat_items SET item_msg_body = ?, item_chat_binding = ?, item_signatures = ?, item_signed_by_group_member_id = ? WHERE chat_item_id = ? AND include_in_history = 1
|
||||
Plan:
|
||||
SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?)
|
||||
@@ -7646,6 +7753,14 @@ Query: UPDATE connections_sync SET should_sync = 1 WHERE connections_sync_id = 1
|
||||
Plan:
|
||||
SEARCH connections_sync USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: UPDATE contact_profiles SET badge_expiry = ? WHERE badge_proof IS NOT NULL
|
||||
Plan:
|
||||
SCAN contact_profiles
|
||||
|
||||
Query: UPDATE contact_profiles SET badge_expiry = ? WHERE badge_signature IS NOT NULL
|
||||
Plan:
|
||||
SCAN contact_profiles
|
||||
|
||||
Query: UPDATE contact_profiles SET contact_domain = ?, updated_at = ? WHERE user_id = ? AND contact_profile_id = ?
|
||||
Plan:
|
||||
SEARCH contact_profiles USING INTEGER PRIMARY KEY (rowid=?)
|
||||
@@ -8034,6 +8149,10 @@ Query: UPDATE users SET shown_badge_id = ? WHERE user_id = ?
|
||||
Plan:
|
||||
SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: UPDATE users SET shown_badge_id = NULL WHERE user_id = ? AND shown_badge_id = ?
|
||||
Plan:
|
||||
SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
Query: UPDATE users SET ui_themes = ?, updated_at = ? WHERE user_id = ?
|
||||
Plan:
|
||||
SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
|
||||
|
||||
@@ -963,6 +963,7 @@ CREATE TABLE badge_ledger(
|
||||
change_months INTEGER NOT NULL,
|
||||
balance_months INTEGER NOT NULL,
|
||||
balance_start_ts TEXT NOT NULL,
|
||||
balance_anchor_ts TEXT NOT NULL,
|
||||
balance_badge_type TEXT NOT NULL,
|
||||
was_paused_since TEXT,
|
||||
service_created_at TEXT NOT NULL,
|
||||
@@ -976,7 +977,8 @@ CREATE TABLE badge_ledger(
|
||||
to_purchase_id INTEGER REFERENCES badge_purchases
|
||||
,
|
||||
entry_type_unknown INTEGER NOT NULL DEFAULT 0,
|
||||
entry_type_value TEXT
|
||||
entry_type_value TEXT,
|
||||
balance_checked INTEGER
|
||||
) STRICT;
|
||||
CREATE TABLE badge_issuances(
|
||||
issuance_id TEXT NOT NULL PRIMARY KEY,
|
||||
@@ -1556,6 +1558,10 @@ CREATE INDEX idx_badge_issuances_purchase ON badge_issuances(
|
||||
issuance_id
|
||||
);
|
||||
CREATE INDEX idx_badge_issuances_entry ON badge_issuances(entry_id);
|
||||
CREATE UNIQUE INDEX idx_badge_issuances_purchase_entry ON badge_issuances(
|
||||
badge_purchase_id,
|
||||
entry_id
|
||||
);
|
||||
CREATE INDEX idx_badge_purchases_user ON badge_purchases(user_id);
|
||||
CREATE INDEX idx_users_shown_badge ON users(shown_badge_id);
|
||||
CREATE INDEX idx_badge_code_redemptions_user ON badge_code_redemptions(
|
||||
|
||||
@@ -73,6 +73,7 @@ data ChatLockEntity
|
||||
| CLUserContact Int64
|
||||
| CLContactRequest Int64
|
||||
| CLFile Int64
|
||||
| CLBadgeUser Int64 -- one signed badge request per profile in flight
|
||||
deriving (Eq, Ord)
|
||||
|
||||
-- These error type constructors must be added to mobile apps
|
||||
|
||||
@@ -44,6 +44,7 @@ import Simplex.Chat.Help
|
||||
import Simplex.Chat.Library.Commands (maxImageSize)
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Badges (BadgeInfo (..), BadgeStatus (..), BadgeType (..), LocalBadge, localBadgeInfo, localBadgeStatus)
|
||||
import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeState (..))
|
||||
import Simplex.Chat.Messages hiding (NewChatItem (..))
|
||||
import Simplex.Chat.Messages.CIContent
|
||||
import Simplex.Chat.Operators
|
||||
@@ -190,6 +191,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
|
||||
CRServiceReplyAccepted u (AgentConnId cId) -> ttyUser u [plain $ "service reply accepted, connection id: " <> safeDecodeUtf8 (strEncode cId)]
|
||||
-- the badge is only shown when it is the one now on the profile; a replayed code's badge may not be
|
||||
CRBadgeRedeemed u badge newBadge -> ttyUser u $ if newBadge then "badge redeemed" : viewContactBadge (Just badge) else ["badge already redeemed"]
|
||||
CRBadgeState u st -> ttyUser u $ viewUserBadgeState st
|
||||
CRGroupCreated u g -> ttyUser u $ viewGroupCreated g testView
|
||||
CRPublicGroupCreated u g _groupLink _relays -> ttyUser u $ viewGroupCreated g testView
|
||||
CRPublicGroupCreationFailed u results -> ttyUser u $ viewPublicGroupCreationFailed results
|
||||
@@ -476,6 +478,8 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView}
|
||||
<> maybe [] (\k -> [plain $ "signed by " <> safeDecodeUtf8 (strEncode k)]) sigKey_
|
||||
<> ["request: " <> viewJSON req]
|
||||
CEvtServiceReplySent (AgentConnId cId) -> [plain $ "service reply sent, connection id: " <> safeDecodeUtf8 (strEncode cId)]
|
||||
CEvtBadgeChanged u st -> ttyUser u $ viewUserBadgeState st
|
||||
CEvtBadgeAlert u alert -> ttyUser u $ viewBadgeAlert alert
|
||||
CEvtContactRequestRejected u Contact {localDisplayName = c} _reason -> ttyUser u [ttyContact c <> ": contact request rejected"]
|
||||
CEvtRcvFileStart u ci -> ttyUser u $ receivingFile_' hu testView "started" ci
|
||||
CEvtRcvFileComplete u ci -> ttyUser u $ receivingFile_' hu testView "completed" ci
|
||||
@@ -1829,9 +1833,30 @@ viewContactBadge = maybe [] $ \lb ->
|
||||
BSExpiredOld -> "expired (old)"
|
||||
BSFailed -> "verification failed"
|
||||
BSUnknownKey -> "unknown key"
|
||||
expiry = "expires " <> T.pack (formatTime defaultTimeLocale "%Y-%m-%d" badgeExpiry)
|
||||
expiry = "expires " <> day badgeExpiry
|
||||
in [plain (textEncode badgeType <> " badge - " <> st), plain expiry]
|
||||
|
||||
viewUserBadgeState :: Maybe BadgeState -> [StyledString]
|
||||
viewUserBadgeState = maybe [] viewBadge
|
||||
where
|
||||
viewBadge BadgeState {badgePurchaseId, badgeType, monthsLeft, paidThrough, alert} =
|
||||
plain
|
||||
( tshow badgePurchaseId
|
||||
<> ": "
|
||||
<> textEncode badgeType
|
||||
<> ", "
|
||||
<> tshow monthsLeft
|
||||
<> " months left, paid through "
|
||||
<> day paidThrough
|
||||
)
|
||||
: maybe [] viewBadgeAlert alert
|
||||
|
||||
viewBadgeAlert :: BadgeAlert -> [StyledString]
|
||||
viewBadgeAlert BadgeAlert {kind, date} = [plain $ "badge alert: " <> textEncode kind <> " " <> day date]
|
||||
|
||||
day :: UTCTime -> Text
|
||||
day = T.pack . formatTime defaultTimeLocale "%Y-%m-%d"
|
||||
|
||||
viewContactInfo :: Contact -> Maybe ConnectionStats -> Maybe Profile -> [StyledString]
|
||||
viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink, localBadge, contactDomain, contactDomainVerified, description}, activeConn, uiThemes, customData} stats incognitoProfile =
|
||||
["contact ID: " <> sShow contactId]
|
||||
|
||||
+290
-1
@@ -9,18 +9,30 @@
|
||||
|
||||
module BadgeTests (badgeTests) where
|
||||
|
||||
import BadgeService.Service (badgeErrorRetryAfter)
|
||||
import Control.Concurrent.STM (atomically)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime, nominalDay)
|
||||
import Data.Time.Calendar (fromGregorian)
|
||||
import Data.Time.Calendar.WeekDate (toWeekDate)
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, nominalDay)
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import Data.Maybe (fromMaybe, isNothing, maybeToList)
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Chat.Badges
|
||||
import Simplex.Chat.Badges.Code
|
||||
import Simplex.Chat.Badges.Ledger
|
||||
import Simplex.Chat.Badges.Service
|
||||
import Simplex.Chat (defaultChatConfig)
|
||||
import Simplex.Chat.Controller (ChatError (..), ChatErrorType (..), badgeRetryInterval, chatErrorAgent)
|
||||
import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeRetryAfter, badgeStalledInterval)
|
||||
import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), AgentServiceError (..), SMPAgentError (..))
|
||||
import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay)
|
||||
import Simplex.Messaging.Crypto.BBS
|
||||
import Simplex.Messaging.Protocol (BrokerErrorType (..), NetworkError (..))
|
||||
import Simplex.Messaging.Version.Internal (Version (..))
|
||||
import Test.Hspec
|
||||
|
||||
@@ -39,6 +51,20 @@ badgeTests = do
|
||||
it "reads a code as typed - any case, separators, ambiguous characters" testCodeNormalisation
|
||||
it "rejects a code whose check character does not match" testCodeCheckCharacter
|
||||
it "hashes the canonical form, whatever was typed" testCodeHash
|
||||
describe "ledger transitions" $ do
|
||||
it "issues a twelve month code one month at a time, and no thirteenth" testTwelveMonths
|
||||
it "lapses only the elapsed months after a gap, leaving paidThrough unchanged" testLapseAfterGap
|
||||
it "keeps the balance non-negative and the start non-decreasing" testLedgerInvariants
|
||||
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 "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 "worker retry" $ do
|
||||
it "repeats a failure that can clear on its own, and no other" testRetryClassification
|
||||
it "backs off to the cap" testRetryBackoff
|
||||
it "floors the wait a service asks for, and honours anything above it" testServiceRetryFloor
|
||||
it "sends retryAfter with the transient service codes and no other" testServiceRetryAfter
|
||||
describe "service protocol JSON" $ do
|
||||
it "redeemBadgeCode request matches the schema" testRedeemRequestJSON
|
||||
it "badgeCredential response matches the schema" testCredentialResponseJSON
|
||||
@@ -48,6 +74,9 @@ badgeTests = do
|
||||
proofOf :: BadgeProof -> BBSProof
|
||||
proofOf (BadgeProof _ _ p _) = p
|
||||
|
||||
nonDecreasing :: Ord a => [a] -> Bool
|
||||
nonDecreasing xs = and $ zipWith (<=) xs (drop 1 xs)
|
||||
|
||||
testKeyIdx :: Int
|
||||
testKeyIdx = 1
|
||||
|
||||
@@ -204,6 +233,260 @@ testCodeHash = do
|
||||
Just typed <- pure $ parseBadgeCode $ T.toLower $ formatBadgeCode code
|
||||
badgeCodeHash typed `shouldBe` badgeCodeHash code
|
||||
|
||||
-- Ledger transitions, against plans/2026-07-30-supporter-badges-v3-ux.md §3
|
||||
|
||||
at :: Integer -> Int -> Int -> UTCTime
|
||||
at y m d = UTCTime (fromGregorian y m d) (11 * 3600)
|
||||
|
||||
newBalance :: UTCTime -> StatementEntry
|
||||
newBalance t = emptyEntry t BTSupporter
|
||||
|
||||
-- these tests never write, so the id each operation stamps on its entry is never read
|
||||
grant :: UTCTime -> Int -> StatementEntry -> StatementEntry
|
||||
grant t n = grantEntry t "" n SCCode
|
||||
|
||||
lapse :: UTCTime -> StatementEntry -> Maybe StatementEntry
|
||||
lapse t = lapseEntry t ""
|
||||
|
||||
issue :: UTCTime -> StatementEntry -> Maybe StatementEntry
|
||||
issue t = issueEntry t ""
|
||||
|
||||
-- StatementEntry and BadgeInfo carry fields of the same names, so the selectors are ambiguous here
|
||||
bMonths :: StatementEntry -> Int
|
||||
bMonths StatementEntry {balanceMonths} = balanceMonths
|
||||
|
||||
bStart :: StatementEntry -> UTCTime
|
||||
bStart StatementEntry {balanceStartTs} = balanceStartTs
|
||||
|
||||
-- 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.
|
||||
pass :: UTCTime -> StatementEntry -> [StatementEntry]
|
||||
pass t e0 = maybeToList lapsed <> maybeToList (issue t $ fromMaybe e0 lapsed)
|
||||
where
|
||||
lapsed = lapse t e0
|
||||
|
||||
finalBalance :: StatementEntry -> [StatementEntry] -> StatementEntry
|
||||
finalBalance e0 rows = last (e0 : rows)
|
||||
|
||||
-- each pass issues exactly one month, so the entries returned are the months issued, in order
|
||||
issueAll :: StatementEntry -> [StatementEntry]
|
||||
issueAll e = case pass (bStart e) e of
|
||||
[] -> []
|
||||
rows -> let e' = finalBalance e rows in e' : issueAll e'
|
||||
|
||||
testTwelveMonths :: IO ()
|
||||
testTwelveMonths = do
|
||||
let start = at 2026 3 10
|
||||
granted = grant start 12 (newBalance start)
|
||||
-- each month is issued as soon as it falls due
|
||||
issued = issueAll granted
|
||||
spent = finalBalance granted issued
|
||||
length issued `shouldBe` 12
|
||||
bMonths spent `shouldBe` 0
|
||||
-- no month was skipped or issued twice: consecutive starts, so the periods tile the whole year
|
||||
map bStart (granted : issued) `shouldBe` map (\m -> addMonths m start) [0 .. 12]
|
||||
bStart spent `shouldBe` at 2027 3 10
|
||||
-- a thirteenth request issues nothing, whenever it is made
|
||||
issue (bStart spent) spent `shouldSatisfy` isNothing
|
||||
issue (at 2030 1 1) spent `shouldSatisfy` isNothing
|
||||
lapse (at 2030 1 1) spent `shouldSatisfy` isNothing
|
||||
|
||||
-- 3 months bought 10 Mar, first issued the same day, no pass until 20 May: April lapses unissued
|
||||
testLapseAfterGap :: IO ()
|
||||
testLapseAfterGap = do
|
||||
let start = at 2026 3 10
|
||||
granted = grant start 3 (newBalance start)
|
||||
rows1 = pass start granted
|
||||
afterFirst = finalBalance granted rows1
|
||||
rows2 = pass (at 2026 5 20) afterFirst
|
||||
afterSecond = finalBalance afterFirst rows2
|
||||
map bMonths rows1 `shouldBe` [2]
|
||||
-- March is issued: from the granting entry's start to the issued entry's own
|
||||
bStart granted `shouldBe` at 2026 3 10
|
||||
map bStart rows1 `shouldBe` [at 2026 4 10]
|
||||
-- one lapse row for April, then May is issued: two rows, not one and not three. The lapse row's
|
||||
-- start is where May begins, so it is also the start of the period the issue that follows covers
|
||||
map bMonths rows2 `shouldBe` [1, 0]
|
||||
map bStart rows2 `shouldBe` [at 2026 5 10, at 2026 6 10]
|
||||
-- a lapse moves months from unused to gone; it never changes what was paid for
|
||||
map paidThrough (granted : rows1 <> rows2) `shouldBe` replicate 4 (at 2026 6 10)
|
||||
bMonths afterSecond `shouldBe` 0
|
||||
|
||||
data LedgerStep = Grant UTCTime Int | Pass UTCTime
|
||||
|
||||
testLedgerInvariants :: IO ()
|
||||
testLedgerInvariants = do
|
||||
let start = at 2026 1 15
|
||||
reopened = at 2027 9 9
|
||||
-- the April grant lands exactly where coverage ended and continues the run, the 2027 one
|
||||
-- lands past it and restarts, so both branches of grantEntry run under the invariants
|
||||
steps =
|
||||
[ Grant start 3,
|
||||
Pass start,
|
||||
Pass (at 2026 4 15),
|
||||
Grant (at 2026 4 15) 2,
|
||||
Pass (at 2026 5 1),
|
||||
Pass reopened,
|
||||
Grant reopened 1,
|
||||
Pass reopened
|
||||
]
|
||||
step (e, rows) = \case
|
||||
Grant t n -> let e' = grant t n e in (e', rows <> [e'])
|
||||
Pass t -> let rs = pass t e in (finalBalance e rs, rows <> rs)
|
||||
(_, allRows) = foldl step (newBalance start, []) steps
|
||||
map bMonths allRows `shouldSatisfy` all (>= 0)
|
||||
map bStart allRows `shouldSatisfy` nonDecreasing
|
||||
|
||||
testGrantAfterExhausted :: IO ()
|
||||
testGrantAfterExhausted = do
|
||||
-- the balance ran out on 10 Feb; the next code is redeemed on 1 Jun
|
||||
let spent = newBalance (at 2026 2 10)
|
||||
granted = grant (at 2026 6 1) 2 spent
|
||||
bStart granted `shouldBe` at 2026 6 1
|
||||
paidThrough granted `shouldBe` at 2026 8 1
|
||||
-- the four unsupported months are not backfilled, so nothing lapses immediately
|
||||
lapse (at 2026 6 1) granted `shouldSatisfy` isNothing
|
||||
|
||||
testGrantInsideIssuedPeriod :: IO ()
|
||||
testGrantInsideIssuedPeriod = do
|
||||
let start = at 2026 1 10
|
||||
granted = grant start 1 (newBalance start)
|
||||
issued = finalBalance granted $ pass start granted
|
||||
-- topped up on 20 Jan, while the month issued on 10 Jan still runs
|
||||
toppedUp = grant (at 2026 1 20) 3 issued
|
||||
-- February is where the next period starts, the top-up having been spent on neither January nor a gap
|
||||
bStart toppedUp `shouldBe` at 2026 2 10
|
||||
paidThrough toppedUp `shouldBe` at 2026 5 10
|
||||
-- the balance starts in the future, so no second credential is issued for January
|
||||
issue (at 2026 1 20) toppedUp `shouldSatisfy` isNothing
|
||||
fmap bStart (issue (at 2026 2 10) toppedUp) `shouldBe` Just (at 2026 3 10)
|
||||
|
||||
testMonthEndClipping :: IO ()
|
||||
testMonthEndClipping = do
|
||||
let start = at 2027 1 31
|
||||
granted = grant start 3 (newBalance start)
|
||||
issued = issueAll granted
|
||||
-- February clips to the 28th, and March goes back to the 31st: clipping does not accumulate.
|
||||
-- Each period runs from one start to the next, so these bounds are the three periods
|
||||
map bStart (granted : issued) `shouldBe` [at 2027 1 31, at 2027 2 28, at 2027 3 31, at 2027 4 30]
|
||||
-- the issued period start is the previous balance start, never periodEnd minus a month, which
|
||||
-- clipping would answer as 28 Jan
|
||||
addMonths (-1) (bStart (head issued)) `shouldNotBe` bStart granted
|
||||
-- across a leap day
|
||||
let leap = grant (at 2028 1 29) 2 (newBalance (at 2028 1 29))
|
||||
map bStart (issueAll leap) `shouldBe` [at 2028 2 29, at 2028 3 29]
|
||||
-- a month that ends on the leap day counts as elapsed the moment it ends, and not before
|
||||
fmap bMonths (lapse (at 2028 2 29) leap) `shouldBe` Just 1
|
||||
lapse (addUTCTime (-1) (at 2028 2 29)) leap `shouldSatisfy` isNothing
|
||||
-- buying a month at a time keeps the day of month that buying three at once keeps
|
||||
let jan = grant (at 2027 1 31) 1 (newBalance (at 2027 1 31))
|
||||
case issue (at 2027 1 31) jan of
|
||||
Just issuedJan -> do
|
||||
let feb = grant (at 2027 2 20) 1 issuedJan
|
||||
fmap bStart (issue (at 2027 2 28) feb) `shouldBe` Just (at 2027 3 31)
|
||||
Nothing -> expectationFailure "January was not issued"
|
||||
|
||||
testMondayExpiry :: IO ()
|
||||
testMondayExpiry = do
|
||||
-- the end of Monday 13 Apr is Tuesday 14 Apr 00:00
|
||||
endOfMondayAfter (at 2026 4 10) `shouldBe` UTCTime (fromGregorian 2026 4 14) 0
|
||||
endOfMondayAfter (at 2026 6 10) `shouldBe` UTCTime (fromGregorian 2026 6 16) 0
|
||||
-- a period ending on a Monday still runs to the end of the following Monday, never to zero days
|
||||
endOfMondayAfter (at 2026 4 13) `shouldBe` UTCTime (fromGregorian 2026 4 21) 0
|
||||
let periodEnds = map (\d -> at 2026 4 d) [1 .. 30]
|
||||
expiries = map endOfMondayAfter periodEnds
|
||||
-- every expiry is a Tuesday midnight more than a day after its period, and at most eight
|
||||
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)
|
||||
|
||||
-- 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 ()
|
||||
testRetryClassification = do
|
||||
let retryFor = badgeErrorRetry . chatErrorAgent
|
||||
-- an unanswered request is the likeliest renewal failure, and it is the agent's own error
|
||||
retryFor (AGENT (A_SERVICE ASETimeout)) `shouldBe` True
|
||||
retryFor (BROKER "localhost" TIMEOUT) `shouldBe` True
|
||||
retryFor (BROKER "localhost" (NETWORK NETimeoutError)) `shouldBe` True
|
||||
-- terminal: the same request would fail the same way, and repeating it would spin
|
||||
retryFor (AGENT (A_SERVICE ASEBadSignature)) `shouldBe` False
|
||||
retryFor (AGENT (A_SERVICE (ASERejected "no"))) `shouldBe` False
|
||||
badgeErrorRetry (ChatError (CECommandError "unexpected badge service response")) `shouldBe` False
|
||||
|
||||
-- A failure that never clears is repeated for as long as the balance funds a month, so the wait
|
||||
-- has to grow: at a fixed interval an annual code would ask hundreds of times a day, all year.
|
||||
testRetryBackoff :: IO ()
|
||||
testRetryBackoff = do
|
||||
let ri@RetryInterval {initialInterval, maxInterval} = badgeRetryInterval defaultChatConfig
|
||||
advance (elapsed, delay) =
|
||||
let elapsed' = elapsed + delay
|
||||
in (elapsed', nextRetryDelay elapsed' delay ri)
|
||||
delays = map snd $ take 40 $ iterate advance (0, initialInterval)
|
||||
head delays `shouldBe` initialInterval
|
||||
delays `shouldSatisfy` all (\d -> d >= initialInterval && d <= maxInterval)
|
||||
delays `shouldSatisfy` nonDecreasing
|
||||
-- it reaches the cap rather than creeping towards it, and stays there
|
||||
last delays `shouldBe` maxInterval
|
||||
|
||||
-- A service answering retryAfter 0 would put the next attempt at now, and the worker would ask
|
||||
-- again as fast as the round trip allows, for as long as the service kept answering that way.
|
||||
testServiceRetryFloor :: IO ()
|
||||
testServiceRetryFloor = do
|
||||
let ri@RetryInterval {initialInterval, maxInterval} = badgeRetryInterval defaultChatConfig
|
||||
floorWait = fromIntegral initialInterval / 1000000 :: NominalDiffTime
|
||||
aboveCap = 2 * fromIntegral maxInterval / 1000000 :: NominalDiffTime
|
||||
-- a code carrying no wait is terminal for this request, and waits what any stalled month waits
|
||||
badgeRetryAfter ri Nothing `shouldBe` badgeStalledInterval
|
||||
-- nothing the service names brings the wait below where a retry of its own would start
|
||||
badgeRetryAfter ri (Just 0) `shouldBe` floorWait
|
||||
badgeRetryAfter ri (Just 1) `shouldBe` floorWait
|
||||
badgeRetryAfter ri (Just $ round floorWait) `shouldBe` floorWait
|
||||
-- above that it is honoured as sent, and not capped: a service may know it is down for the day
|
||||
badgeRetryAfter ri (Just 600) `shouldBe` 600
|
||||
badgeRetryAfter ri (Just $ round aboveCap) `shouldBe` aboveCap
|
||||
|
||||
-- badges-rpc.md defines retryAfter as marking the transient codes, and every other code as
|
||||
-- terminal for the command attempted. The client repeats a code that carries one on the service's
|
||||
-- schedule, so the set is the protocol's and not a judgement to make per call site.
|
||||
testServiceRetryAfter :: IO ()
|
||||
testServiceRetryAfter = do
|
||||
badgeErrorRetryAfter BSEPaymentPending `shouldBe` Just 300
|
||||
badgeErrorRetryAfter BSEProviderUnavailable `shouldBe` Just 300
|
||||
badgeErrorRetryAfter BSERateLimited `shouldBe` Just 60
|
||||
-- internal is the one most likely to clear on its own, and is still terminal: repeating it on
|
||||
-- the service's cadence presses a service already failing, and the client has its own floor
|
||||
badgeErrorRetryAfter BSEInternal `shouldBe` Nothing
|
||||
mapM_
|
||||
(\code -> badgeErrorRetryAfter code `shouldBe` Nothing)
|
||||
[BSEBadRequest, BSEUnsupportedVersion, BSEUnknownPurchaseKey, BSECodeInvalid, BSECodeUsed, BSECodeExpired, BSEUnknown "future_code"]
|
||||
|
||||
-- The client replicates entry_credit_type / entry_debit_type verbatim, so a stored tag that
|
||||
-- disagreed with the wire tag would put a different row on each side.
|
||||
testEntryTypeColumns :: IO ()
|
||||
testEntryTypeColumns = do
|
||||
k <- fst <$> (C.newRandom >>= \g -> atomically (C.generateKeyPair g) :: IO (C.KeyPair 'C.Ed25519))
|
||||
let credits = [SCPayment Nothing, SCCode, SCCharge "ch1", SCSupport, SCTransferIn k, SCOpening]
|
||||
debits = [SDRefund, SDUpgrade k, SDTransferOut k, SDSupport, SDBadge, SDLapse]
|
||||
mapM_ (\c -> wireTag (J.toJSON (SECredit c)) "credit" `shouldBe` Just (creditTypeTag c)) credits
|
||||
mapM_ (\d -> wireTag (J.toJSON (SEDebit d)) "debit" `shouldBe` Just (debitTypeTag d)) debits
|
||||
-- the three types this version writes survive a round trip through the columns
|
||||
mapM_
|
||||
(\t -> uncurry3 entryTypeFromColumns (entryTypeColumns t) `shouldSatisfy` sameEntryType t)
|
||||
[SECredit SCCode, SEDebit SDBadge, SEDebit SDLapse]
|
||||
-- a type that needs a reference column is not silently read back as something else
|
||||
uncurry3 entryTypeFromColumns (entryTypeColumns (SECredit (SCCharge "ch1"))) `shouldSatisfy` isNothing
|
||||
-- which is why every type is stored as its own JSON as well, and read from that first: the
|
||||
-- columns alone would answer a row naming an invoice or a purchase as no row at all
|
||||
mapM_ roundTrips credits
|
||||
mapM_ roundTrips debits
|
||||
where
|
||||
uncurry3 f (a, b, c) = f a b c
|
||||
sameEntryType t = maybe False ((J.toJSON t ==) . J.toJSON)
|
||||
wireTag v fld = case v of
|
||||
J.Object o | Just (J.Object inner) <- KM.lookup fld o, Just (J.String t) <- KM.lookup "type" inner -> Just t
|
||||
_ -> Nothing
|
||||
|
||||
-- Service protocol JSON, against docs/protocol/badges-rpc.schema.json
|
||||
|
||||
testRedeemRequestJSON :: IO ()
|
||||
@@ -255,6 +538,7 @@ testStatementJSON = do
|
||||
changeMonths = 3,
|
||||
balanceMonths = 3,
|
||||
balanceStartTs = futureTime,
|
||||
balanceAnchorTs = futureTime,
|
||||
balanceBadgeType = BTSupporter,
|
||||
wasPausedSince = Nothing,
|
||||
createdAt = futureTime,
|
||||
@@ -267,6 +551,7 @@ testStatementJSON = do
|
||||
"changeMonths" J..= (3 :: Int),
|
||||
"balanceMonths" J..= (3 :: Int),
|
||||
"balanceStartTs" J..= futureTime,
|
||||
"balanceAnchorTs" J..= futureTime,
|
||||
"balanceBadgeType" J..= ("supporter" :: T.Text),
|
||||
"createdAt" J..= futureTime,
|
||||
"entryType" J..= entryType entry
|
||||
@@ -274,6 +559,10 @@ testStatementJSON = do
|
||||
J.toJSON entry {wasPausedSince = Just pastTime} `shouldNotBe` J.toJSON entry
|
||||
J.toJSON (entryType entry) `shouldBe` J.object ["type" J..= ("credit" :: T.Text), "credit" J..= J.object ["type" J..= ("payment" :: T.Text)]]
|
||||
J.toJSON SEDebit {debit = SDBadge} `shouldBe` J.object ["type" J..= ("debit" :: T.Text), "debit" J..= J.object ["type" J..= ("badge" :: T.Text)]]
|
||||
J.toJSON SEDebit {debit = SDLapse} `shouldBe` J.object ["type" J..= ("debit" :: T.Text), "debit" J..= J.object ["type" J..= ("lapse" :: T.Text)]]
|
||||
-- a code grant is its own credit type, not a payment whose invoiceId happens to be absent
|
||||
J.toJSON SECredit {credit = SCCode} `shouldBe` J.object ["type" J..= ("credit" :: T.Text), "credit" J..= J.object ["type" J..= ("code" :: T.Text)]]
|
||||
J.toJSON SECredit {credit = SCCode} `shouldNotBe` J.toJSON SECredit {credit = SCPayment {invoiceId = Nothing}}
|
||||
-- an entry type from a newer service is stored and re-emitted unchanged
|
||||
let futureCredit = J.object ["type" J..= ("grant" :: T.Text), "grantedBy" J..= ("operator" :: T.Text)]
|
||||
case J.fromJSON futureCredit of
|
||||
|
||||
+790
-16
@@ -1,8 +1,12 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
||||
|
||||
module Bots.BadgeServiceTests where
|
||||
|
||||
@@ -13,23 +17,42 @@ import ChatTests.DBUtils
|
||||
import ChatTests.Utils
|
||||
import Control.Concurrent (forkIO, killThread, threadDelay)
|
||||
import Control.Concurrent.STM (atomically, readTMVar)
|
||||
import Control.Monad (void, when)
|
||||
import Control.Exception (finally)
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.Char (toLower)
|
||||
import Data.Either (isLeft, isRight)
|
||||
import Data.Int (Int64)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (isJust, isNothing)
|
||||
import Data.String (fromString)
|
||||
import System.Timeout (timeout)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Badges (BadgeType (..))
|
||||
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDay)
|
||||
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType (..), generateMasterKey)
|
||||
import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeText, formatBadgeCode, parseBadgeCode, randomBadgeCode)
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatController, ChatResponse (CRCustomChatResponse))
|
||||
import Simplex.Chat.Badges.Ledger (addMonths, creditTypeTag, debitTypeTag, endOfMondayAfter)
|
||||
import Simplex.Chat.Badges.Service
|
||||
import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (CRCustomChatResponse))
|
||||
import Simplex.Chat.Core (sendChatCmdStr)
|
||||
import Simplex.Chat.Options (CoreChatOpts (..))
|
||||
import Simplex.Chat.Options.DB
|
||||
import Simplex.Messaging.Agent.Store.Common (withTransaction)
|
||||
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
||||
import Simplex.Chat.Types (ChatPeerType (..), Profile (..))
|
||||
import qualified Simplex.Messaging.Crypto as C
|
||||
import Simplex.Messaging.Crypto.BBS (BBSSecretKey, bbsKeyGen)
|
||||
import Simplex.Messaging.Encoding.String (strDecode, strEncode, textEncode)
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
import System.FilePath ((</>))
|
||||
#if defined(dbPostgres)
|
||||
import Database.PostgreSQL.Simple (Only (..))
|
||||
#else
|
||||
import Database.SQLite.Simple (Only (..))
|
||||
#endif
|
||||
import Test.Hspec hiding (it)
|
||||
|
||||
badgeServiceTests :: SpecWith TestParams
|
||||
@@ -39,10 +62,28 @@ badgeServiceTests = do
|
||||
it "should return the same badge when the same code is redeemed twice" testRedeemBadgeCodeTwice
|
||||
it "should answer code_invalid to an unknown code, indistinguishably from a malformed one" testRedeemUnknownCode
|
||||
it "should tell a second profile redeeming the same code that it is used" testRedeemSameCodeOtherProfile
|
||||
it "should redeem a second code, and not restore the first badge on replay" testRedeemSecondCode
|
||||
it "should refuse a second code while a badge is held, leaving it unspent" testRedeemSecondCode
|
||||
it "should refuse to issue a code with an unknown badge type or a nonsense month count" testIssueRejectsBadArguments
|
||||
it "should refuse a request whose purchaseKey is not the verified signer" testPurchaseKeyMismatch
|
||||
it "should refuse to start unless the issuer secret is the key trusted at its index" testIssuerKeyMustMatchConfig
|
||||
it "should credit a code's months and issue one credential per month" testCodeMonthsRenew
|
||||
it "should return the stored credential for a repeat inside an issued period" testRepeatInsideIssuedPeriod
|
||||
it "should lapse only the months that elapsed while the client was away" testLapseWhileAway
|
||||
it "should round the last month's expiry up to the end of the Monday after it" testLastMonthExpiryRounds
|
||||
it "should sign a renewal with the master key stored on the purchase" testRenewalSignsWithStoredMasterKey
|
||||
it "should leave the client holding the same ledger rows as the service" testClientReplicatesLedger
|
||||
it "should renew a badge whose credential is lapsing, with no command" testWorkerRenews
|
||||
it "should request from the wake it set a day before the credential lapses" testRequestWakeFires
|
||||
it "should present from the wake it set at the credential's expiry" testPresentWakeFires
|
||||
it "should renew a badge whose newest ledger row is of an unknown type" testRenewsAfterUnknownEntry
|
||||
it "should catch up the months that lapsed while the client was stopped" testRenewsAfterRestart
|
||||
it "should stop showing a badge whose balance ran out, and tell contacts" testWorkerRetiresExpired
|
||||
it "should retire when entitlement ends, not when the credential expires" testRetiresWhenEntitlementEnds
|
||||
it "should alert that support ended, survive a restart, and go silent once acknowledged" testEndedAlert
|
||||
it "should raise a snoozed alert once more when the snooze lapses" testSnoozedAlertReturns
|
||||
it "should renew a badge on a profile that is not active, without switching to it" testRenewalKeepsActiveProfile
|
||||
it "should broadcast the current profile when a renewal presents a badge" testRenewalKeepsProfileEdits
|
||||
it "should present the month already issued when a previous pass did not" testPresentationCatchesUp
|
||||
|
||||
badgeProfile :: Profile
|
||||
badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing}
|
||||
@@ -74,14 +115,45 @@ mkBadgeServiceOpts TestParams {tmpPath = ps} secretKey =
|
||||
testing = True
|
||||
}
|
||||
|
||||
-- | A clock the service and the client both read: real time plus an offset the test moves. It
|
||||
-- tracks real time rather than freezing it, so a sleeper still sleeps the right real duration.
|
||||
newtype TestClock = TestClock (IORef NominalDiffTime)
|
||||
|
||||
newTestClock :: IO TestClock
|
||||
newTestClock = TestClock <$> newIORef 0
|
||||
|
||||
testClockTime :: TestClock -> IO UTCTime
|
||||
testClockTime (TestClock r) = do
|
||||
offset <- readIORef r
|
||||
addUTCTime offset <$> getCurrentTime
|
||||
|
||||
-- | Move the clock so that "now" becomes exactly the given time - months are calendar months, so
|
||||
-- a test crosses a boundary by naming the date rather than adding a duration.
|
||||
setClockAt :: TestClock -> UTCTime -> IO ()
|
||||
setClockAt (TestClock r) t = getCurrentTime >>= \real -> writeIORef r (diffUTCTime t real)
|
||||
|
||||
-- | Everything a badge test may need from a running service.
|
||||
data BadgeServiceEnv = BadgeServiceEnv
|
||||
{ bsIssuerKey :: BadgeIssuerKey,
|
||||
bsClock :: TestClock,
|
||||
bsClientCfg :: ChatConfig,
|
||||
bsAddress :: String,
|
||||
bsController :: ChatController
|
||||
}
|
||||
|
||||
-- | Start the badge service on a fresh issuer key, and hand the test body what depends on it:
|
||||
-- the client config trusting that key and addressing the service, the address, and the controller.
|
||||
withBadgeService :: HasCallStack => TestParams -> (ChatConfig -> String -> ChatController -> IO ()) -> IO ()
|
||||
withBadgeService ps test = do
|
||||
withBadgeService ps test =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsAddress, bsController} -> test bsClientCfg bsAddress bsController
|
||||
|
||||
withBadgeServiceEnv :: HasCallStack => TestParams -> (BadgeServiceEnv -> IO ()) -> IO ()
|
||||
withBadgeServiceEnv ps test = do
|
||||
Right (pk, sk) <- bbsKeyGen
|
||||
clock <- newTestClock
|
||||
let opts = mkBadgeServiceOpts ps sk
|
||||
-- the service refuses to start unless its secret is the key trusted at its index
|
||||
svcCfg = testCfg {badgePublicKeys = M.singleton testIssuerKeyIdx pk}
|
||||
svcCfg = testCfg {badgePublicKeys = M.singleton testIssuerKeyIdx pk, badgeCurrentTime = testClockTime clock}
|
||||
withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure ()
|
||||
-- First start: badge service takes the CreateMyAddress branch.
|
||||
runBadgeService svcCfg opts $ \_ -> pure ()
|
||||
@@ -97,7 +169,7 @@ withBadgeService ps test = do
|
||||
-- Second start: badge service takes the ShowMyAddress branch, then serves the test body.
|
||||
runBadgeService svcCfg opts $ \env -> do
|
||||
cc <- atomically $ readTMVar $ serviceCC env
|
||||
test clientCfg bsLink cc
|
||||
test BadgeServiceEnv {bsIssuerKey = BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey = sk}, bsClock = clock, bsClientCfg = clientCfg, bsAddress = bsLink, bsController = cc}
|
||||
|
||||
-- through the operator command the service actually exposes, not the function behind it
|
||||
issueCode :: HasCallStack => ChatController -> BadgeType -> Int -> IO BadgeCode
|
||||
@@ -108,11 +180,15 @@ issueCode cc badgeType months =
|
||||
_ -> error $ "unexpected issue response: " <> T.unpack response
|
||||
r -> error $ "issue failed: " <> show (() <$ r)
|
||||
|
||||
-- | The post-start hook fills serviceCC once the address exists, so waiting on it is the service
|
||||
-- being ready. A fixed delay here raced with startup and left the address output of one start
|
||||
-- arriving during the next test.
|
||||
runBadgeService :: ChatConfig -> BadgeServiceOpts -> (ServiceState -> IO ()) -> IO ()
|
||||
runBadgeService cfg opts action = do
|
||||
env <- newServiceState
|
||||
t <- forkIO $ badgeService opts cfg env
|
||||
threadDelay 500000
|
||||
ready <- timeout 30000000 $ atomically $ readTMVar $ serviceCC env
|
||||
when (isNothing ready) $ killThread t >> error "badge service did not start"
|
||||
action env `finally` killThread t
|
||||
|
||||
codeArg :: BadgeCode -> String
|
||||
@@ -225,8 +301,8 @@ issueRaw cc args =
|
||||
Right CRCustomChatResponse {} -> pure $ Right ()
|
||||
_ -> pure $ Left ()
|
||||
|
||||
-- Both purchases fund no payment, so both leave payment_id NULL under UNIQUE(payment_id).
|
||||
-- The first purchase stays as it is: retiring a superseded badge is not implemented.
|
||||
-- The guard is the badge on the profile, so it refuses whatever the code is and whichever type it
|
||||
-- funds; nothing is sent, so the refused code is still redeemable.
|
||||
testRedeemSecondCode :: HasCallStack => TestParams -> IO ()
|
||||
testRedeemSecondCode ps =
|
||||
withBadgeService ps $ \clientCfg _ cc ->
|
||||
@@ -238,16 +314,15 @@ testRedeemSecondCode ps =
|
||||
alice <## "supporter badge - active"
|
||||
alice <##. "expires "
|
||||
alice ##> ("/_redeem_badge_code 1 " <> codeArg legend)
|
||||
alice <## "bad chat command: badge already active"
|
||||
alice ##> "/p"
|
||||
showActiveUser alice "alice (Alice, * supporter)"
|
||||
alice ##> "/create user alisa"
|
||||
showActiveUser alice "alisa"
|
||||
alice ##> ("/_redeem_badge_code 2 " <> codeArg legend)
|
||||
alice <## "badge redeemed"
|
||||
alice <## "legend badge - active"
|
||||
alice <##. "expires "
|
||||
alice ##> "/p"
|
||||
showActiveUser alice "alice (Alice, * legend)"
|
||||
-- replaying the first code must not put supporter back
|
||||
alice ##> ("/_redeem_badge_code 1 " <> codeArg supporter)
|
||||
alice <## "badge already redeemed"
|
||||
alice ##> "/p"
|
||||
showActiveUser alice "alice (Alice, * legend)"
|
||||
|
||||
-- Each profile stashes its own keys, so the second reaches the service as a different signer -
|
||||
-- rather than being handed the first profile's badge, or colliding in badge_code_redemptions.
|
||||
@@ -269,6 +344,705 @@ testRedeemSameCodeOtherProfile ps =
|
||||
alice ##> "/user alice"
|
||||
showActiveUser alice "alice (Alice, * supporter)"
|
||||
|
||||
-- Ledger behaviour, driven against the real service - real signing, real rows - through the
|
||||
-- handler rather than the transport, so the typed response can be asserted. The transport and its
|
||||
-- purchaseKey guard are covered by the tests above.
|
||||
|
||||
serviceCmd :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> BadgeServiceCommand -> IO BadgeServiceResponse
|
||||
serviceCmd BadgeServiceEnv {bsIssuerKey, bsController} purchaseKey request =
|
||||
badgeServiceResponse bsIssuerKey bsController (Just purchaseKey) reqObject
|
||||
where
|
||||
reqObject = case J.toJSON BadgeServiceRequest {version = currentBadgeServiceVersion, purchaseKey = Just purchaseKey, request} of
|
||||
J.Object o -> o
|
||||
_ -> error "badge service request must encode as an object"
|
||||
|
||||
-- the fields a ledger assertion reads, without the ambiguity of the shared record names
|
||||
entryOf :: StatementEntry -> (Int, Int, UTCTime)
|
||||
entryOf StatementEntry {changeMonths, balanceMonths, balanceStartTs} = (changeMonths, balanceMonths, balanceStartTs)
|
||||
|
||||
anchorOf :: StatementEntry -> UTCTime
|
||||
anchorOf StatementEntry {balanceAnchorTs} = balanceAnchorTs
|
||||
|
||||
entryTag :: StatementEntry -> Text
|
||||
entryTag StatementEntry {entryType} = case entryType of
|
||||
SECredit c -> creditTypeTag c
|
||||
SEDebit d -> debitTypeTag d
|
||||
|
||||
statementOf :: HasCallStack => BadgeServiceResponse -> ([StatementEntry], Maybe Text)
|
||||
statementOf = \case
|
||||
BSPBadgeCredential {statement = BadgeStatement {entries, previousEntryId}} -> (entries, previousEntryId)
|
||||
r -> error $ "expected badgeCredential, got " <> show (J.toJSON r)
|
||||
|
||||
credentialOf :: HasCallStack => BadgeServiceResponse -> Maybe BadgeCredential
|
||||
credentialOf = \case
|
||||
BSPBadgeCredential {credential} -> credential
|
||||
r -> error $ "expected badgeCredential, got " <> show (J.toJSON r)
|
||||
|
||||
-- the next month falls due when the balance start reaches it, which is the last entry's start
|
||||
nextDue :: [StatementEntry] -> UTCTime
|
||||
nextDue entries = let (_, _, start) = entryOf (last entries) in start
|
||||
|
||||
newPurchaseKeys :: IO (C.PublicKeyEd25519, BadgeMasterKey)
|
||||
newPurchaseKeys = do
|
||||
g <- C.newRandom
|
||||
(purchaseKey, _) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519)
|
||||
(purchaseKey,) <$> generateMasterKey g
|
||||
|
||||
assertBalance :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> StatementEntry -> IO BadgeServiceResponse
|
||||
assertBalance env purchaseKey lastEntry =
|
||||
serviceCmd env purchaseKey BSCIssueBadge {balance = BadgeBalance {lastEntry}}
|
||||
|
||||
expiryOf :: HasCallStack => BadgeServiceResponse -> Maybe UTCTime
|
||||
expiryOf r = (\(BadgeCredential _ _ _ BadgeInfo {badgeExpiry}) -> badgeExpiry) <$> credentialOf r
|
||||
|
||||
masterKeyOf :: HasCallStack => BadgeServiceResponse -> Maybe BadgeMasterKey
|
||||
masterKeyOf r = (\(BadgeCredential _ mk _ _) -> mk) <$> credentialOf r
|
||||
|
||||
-- A three month code credits three months and issues the first; a month later the second is
|
||||
-- issued, and only then. Asserted against the service's own rows.
|
||||
testCodeMonthsRenew :: HasCallStack => TestParams -> IO ()
|
||||
testCodeMonthsRenew ps =
|
||||
withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do
|
||||
code <- issueCode cc BTSupporter 3
|
||||
(purchaseKey, masterKey) <- newPurchaseKeys
|
||||
redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
|
||||
let (entries, previousEntryId) = statementOf redeemed
|
||||
previousEntryId `shouldBe` Nothing
|
||||
map entryTag entries `shouldBe` ["code", "badge"]
|
||||
map (\e -> let (c, m, _) = entryOf e in (c, m)) entries `shouldBe` [(3, 3), (-1, 2)]
|
||||
credentialOf redeemed `shouldSatisfy` isJust
|
||||
let firstDue = nextDue entries
|
||||
-- still inside the first month: nothing new is written
|
||||
r2 <- assertBalance env purchaseKey (last entries)
|
||||
map entryTag (fst $ statementOf r2) `shouldBe` []
|
||||
-- the second month falls due
|
||||
setClockAt bsClock firstDue
|
||||
r3 <- assertBalance env purchaseKey (last entries)
|
||||
let (entries3, prev3) = statementOf r3
|
||||
prev3 `shouldBe` Just (entryIdOf $ last entries)
|
||||
map entryTag entries3 `shouldBe` ["badge"]
|
||||
map (\e -> let (c, m, _) = entryOf e in (c, m)) entries3 `shouldBe` [(-1, 1)]
|
||||
credentialOf r3 `shouldSatisfy` isJust
|
||||
-- a different credential for a different month, not the same signature returned twice
|
||||
credentialOf r3 `shouldNotBe` credentialOf redeemed
|
||||
where
|
||||
entryIdOf StatementEntry {entryId} = entryId
|
||||
|
||||
-- A repeat inside an issued month returns the credential already stored, and writes no row:
|
||||
-- re-signing the same period would churn the client's credential for nothing.
|
||||
testRepeatInsideIssuedPeriod :: HasCallStack => TestParams -> IO ()
|
||||
testRepeatInsideIssuedPeriod ps =
|
||||
withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do
|
||||
code <- issueCode cc BTSupporter 2
|
||||
(purchaseKey, masterKey) <- newPurchaseKeys
|
||||
redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
|
||||
let (entries, _) = statementOf redeemed
|
||||
repeated <- assertBalance env purchaseKey (last entries)
|
||||
map entryTag (fst $ statementOf repeated) `shouldBe` []
|
||||
credentialOf repeated `shouldBe` credentialOf redeemed
|
||||
|
||||
-- Months that passed unissued are lapsed in one row, and the month now current is issued.
|
||||
testLapseWhileAway :: HasCallStack => TestParams -> IO ()
|
||||
testLapseWhileAway ps =
|
||||
withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do
|
||||
code <- issueCode cc BTSupporter 6
|
||||
(purchaseKey, masterKey) <- newPurchaseKeys
|
||||
redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
|
||||
let (entries, _) = statementOf redeemed
|
||||
-- away past the fourth boundary of the run: three months lapse, the fourth is due. Counted
|
||||
-- from the anchor - adding months to an already clipped due date would miss the boundary.
|
||||
setClockAt bsClock (addMonths 4 (anchorOf (last entries)))
|
||||
away <- assertBalance env purchaseKey (last entries)
|
||||
let (entries', _) = statementOf away
|
||||
map entryTag entries' `shouldBe` ["lapse", "badge"]
|
||||
map (\e -> let (c, m, _) = entryOf e in (c, m)) entries' `shouldBe` [(-3, 2), (-1, 1)]
|
||||
credentialOf away `shouldSatisfy` isJust
|
||||
|
||||
-- Every badge issued in a week expires at the same moment, so the expiry says nothing about when
|
||||
-- it was bought. On the last month of a balance paidThrough is the period end exactly, so a
|
||||
-- client-proposed expiry capped the rounding away and put the expiry back on the anniversary.
|
||||
testLastMonthExpiryRounds :: HasCallStack => TestParams -> IO ()
|
||||
testLastMonthExpiryRounds ps =
|
||||
withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do
|
||||
code <- issueCode cc BTSupporter 2
|
||||
(purchaseKey, masterKey) <- newPurchaseKeys
|
||||
redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
|
||||
let (entries, _) = statementOf redeemed
|
||||
setClockAt bsClock (nextDue entries)
|
||||
renewed <- assertBalance env purchaseKey (last entries)
|
||||
let (entries', _) = statementOf renewed
|
||||
map entryTag entries' `shouldBe` ["badge"]
|
||||
-- the last month the balance funds: nothing is left to issue after it
|
||||
map (\e -> let (c, m, _) = entryOf e in (c, m)) entries' `shouldBe` [(-1, 0)]
|
||||
expiryOf renewed `shouldBe` Just (endOfMondayAfter (nextDue entries'))
|
||||
|
||||
-- A renewal states nothing, so the credential carries the master key stored with the purchase.
|
||||
-- The service used to sign whatever key the request supplied, checking only the badge type.
|
||||
testRenewalSignsWithStoredMasterKey :: HasCallStack => TestParams -> IO ()
|
||||
testRenewalSignsWithStoredMasterKey ps =
|
||||
withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do
|
||||
code <- issueCode cc BTSupporter 2
|
||||
(purchaseKey, masterKey) <- newPurchaseKeys
|
||||
redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code}
|
||||
masterKeyOf redeemed `shouldBe` Just masterKey
|
||||
let (entries, _) = statementOf redeemed
|
||||
setClockAt bsClock (nextDue entries)
|
||||
renewed <- assertBalance env purchaseKey (last entries)
|
||||
masterKeyOf renewed `shouldBe` Just masterKey
|
||||
|
||||
-- The replicated columns of a ledger, in order. service_created_at and created_at are left out:
|
||||
-- the client records when it stored a row, which is not when the service wrote it.
|
||||
type ReplicatedRow = (Text, Int, Int, UTCTime, Text, Maybe Text)
|
||||
|
||||
ledgerRows :: ChatController -> String -> IO [ReplicatedRow]
|
||||
ledgerRows ChatController {chatStore} table =
|
||||
withTransaction chatStore $ \db ->
|
||||
DB.query_ db . fromString $
|
||||
"SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_badge_type, "
|
||||
<> "COALESCE(entry_credit_type, entry_debit_type) FROM "
|
||||
<> table
|
||||
<> " 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 ()
|
||||
testClientReplicatesLedger ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} ->
|
||||
withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
|
||||
code <- issueCode cc BTSupporter 3
|
||||
alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
|
||||
alice <## "badge redeemed"
|
||||
alice <## "supporter badge - active"
|
||||
alice <##. "expires "
|
||||
serviceLedger <- ledgerRows cc "sx_badge_service_badge_ledger"
|
||||
clientLedger <- ledgerRows (chatController alice) "badge_ledger"
|
||||
-- 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
|
||||
-- redeeming again replays the statement, and must not duplicate a single row
|
||||
alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
|
||||
alice <## "badge already redeemed"
|
||||
clientLedger' <- ledgerRows (chatController alice) "badge_ledger"
|
||||
clientLedger' `shouldBe` serviceLedger
|
||||
-- nor a second issuance for the one month issued: the replay names a month already stored
|
||||
expiries <- issuedExpiries (chatController alice)
|
||||
length expiries `shouldBe` 1
|
||||
|
||||
-- the balance start of the last row, which is when the next month falls due
|
||||
dueAtOf :: [ReplicatedRow] -> UTCTime
|
||||
dueAtOf rows = let (_, _, _, start, _, _) = last rows in start
|
||||
|
||||
-- | The two clock positions a renewal needs: the request, a day before the shown credential
|
||||
-- lapses, and the presentation, as it lapses.
|
||||
renewalMoments :: [ReplicatedRow] -> (UTCTime, UTCTime)
|
||||
renewalMoments rows =
|
||||
let expiry = endOfMondayAfter $ dueAtOf rows
|
||||
in (addUTCTime (-nominalDay) expiry, expiry)
|
||||
|
||||
-- | Real seconds between arming a wake and it firing. Long enough for the arming pass to finish
|
||||
-- first, since one that overruns does the work itself and the test passes without a wake at all.
|
||||
badgeWakeMargin :: NominalDiffTime
|
||||
badgeWakeMargin = 3
|
||||
|
||||
-- | Stand the clock just short of t and signal once. A sleeping worker cannot see the clock move,
|
||||
-- so the signal is what makes it re-derive - and, standing short, it arms the wake at t rather
|
||||
-- than doing the work. Whatever follows is produced by that wake.
|
||||
armWakeAt :: HasCallStack => TestCC -> TestClock -> UTCTime -> IO ()
|
||||
armWakeAt cc clock t = do
|
||||
setClockAt clock $ addUTCTime (negate badgeWakeMargin) t
|
||||
cc ##> "/_app activate"
|
||||
cc <## "ok"
|
||||
|
||||
issuedExpiries :: ChatController -> IO [UTCTime]
|
||||
issuedExpiries ChatController {chatStore} = do
|
||||
rows :: [(UTCTime, Int64)] <-
|
||||
withTransaction chatStore $ \db ->
|
||||
DB.query_ db "SELECT expiry, badge_purchase_id FROM badge_issuances ORDER BY period_end"
|
||||
pure $ map fst rows
|
||||
|
||||
peerBadgeExpiry :: ChatController -> IO (Maybe UTCTime)
|
||||
peerBadgeExpiry ChatController {chatStore} = do
|
||||
rows :: [(Maybe UTCTime, Int64)] <-
|
||||
withTransaction chatStore $ \db ->
|
||||
DB.query_ db "SELECT badge_expiry, contact_profile_id FROM contact_profiles WHERE badge_proof IS NOT NULL ORDER BY contact_profile_id"
|
||||
pure $ case rows of
|
||||
((t, _) : _) -> t
|
||||
[] -> Nothing
|
||||
|
||||
setBadgeExpiry :: ChatController -> String -> UTCTime -> IO ()
|
||||
setBadgeExpiry ChatController {chatStore} whichBadge t =
|
||||
withTransaction chatStore $ \db ->
|
||||
DB.execute db (fromString $ "UPDATE contact_profiles SET badge_expiry = ? WHERE " <> whichBadge <> " IS NOT NULL") (Only t)
|
||||
|
||||
-- | Copy the newest ledger row as an entry of a type this version does not know: the service is
|
||||
-- deployed ahead of app releases, so a new type first arrives at clients that predate it.
|
||||
insertUnknownLedgerEntry :: ChatController -> IO ()
|
||||
insertUnknownLedgerEntry ChatController {chatStore} =
|
||||
withTransaction chatStore $ \db ->
|
||||
DB.execute_ db . fromString $
|
||||
"INSERT INTO badge_ledger"
|
||||
<> " (entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_anchor_ts,"
|
||||
<> " balance_badge_type, service_created_at, created_at, entry_type, entry_credit_type,"
|
||||
<> " entry_type_unknown, entry_type_value)"
|
||||
<> " SELECT 'unknown-entry', badge_purchase_id, 0, balance_months, balance_start_ts, balance_anchor_ts,"
|
||||
<> " balance_badge_type, service_created_at, created_at, 'credit', 'grant', 1, '{\"type\":\"grant\"}'"
|
||||
<> " FROM badge_ledger ORDER BY entry_id DESC LIMIT 1"
|
||||
|
||||
-- | The month the profile is showing, and the month last issued. They must agree: a profile left
|
||||
-- on an earlier month shows contacts a badge the ledger has already replaced.
|
||||
shownAndIssuedExpiry :: ChatController -> IO (Maybe UTCTime, Maybe UTCTime)
|
||||
shownAndIssuedExpiry ChatController {chatStore} = withTransaction chatStore $ \db -> do
|
||||
shown :: [(Maybe UTCTime, Int64)] <-
|
||||
DB.query_ db "SELECT badge_expiry, contact_profile_id FROM contact_profiles WHERE badge_signature IS NOT NULL ORDER BY contact_profile_id"
|
||||
issued :: [(Maybe UTCTime, Int64)] <-
|
||||
DB.query_ db "SELECT expiry, badge_purchase_id FROM badge_issuances ORDER BY period_end DESC LIMIT 1"
|
||||
pure (firstOf shown, firstOf issued)
|
||||
where
|
||||
firstOf = \case
|
||||
((t, _) : _) -> t
|
||||
[] -> Nothing
|
||||
|
||||
waitShownIssued :: HasCallStack => ChatController -> IO ()
|
||||
waitShownIssued cc = loop (100 :: Int)
|
||||
where
|
||||
-- both absent would compare equal, so the presence of a badge is asserted separately
|
||||
loop 0 = shownAndIssuedExpiry cc >>= \(shown, issued) -> do
|
||||
shown `shouldSatisfy` isJust
|
||||
shown `shouldBe` issued
|
||||
loop i =
|
||||
shownAndIssuedExpiry cc >>= \(shown, issued) ->
|
||||
if isJust shown && shown == issued then pure () else threadDelay 50000 >> loop (i - 1)
|
||||
|
||||
-- The worker acts on its own schedule, so the test waits for the rows rather than for a response.
|
||||
waitLedgerRows :: HasCallStack => ChatController -> Int -> IO [ReplicatedRow]
|
||||
waitLedgerRows cc n = loop (100 :: Int)
|
||||
where
|
||||
loop 0 = ledgerRows cc "badge_ledger" >>= \rows -> error $ "expected " <> show n <> " ledger rows, got " <> show (length rows)
|
||||
loop i = do
|
||||
rows <- ledgerRows cc "badge_ledger"
|
||||
if length rows >= n then pure rows else threadDelay 50000 >> loop (i - 1)
|
||||
|
||||
-- the badge the profile shows, which the worker clears when the balance has run out
|
||||
shownBadgeId :: HasCallStack => ChatController -> IO (Maybe Int64)
|
||||
shownBadgeId ChatController {chatStore} = do
|
||||
-- two columns rather than one, so the row type needs no backend-specific Only
|
||||
rows :: [(Maybe Int64, Int64)] <-
|
||||
withTransaction chatStore $ \db ->
|
||||
DB.query_ db "SELECT shown_badge_id, user_id FROM users WHERE user_id = 1"
|
||||
-- not Nothing on an unexpected shape: waiting for Nothing would then pass without reading it
|
||||
pure $ case rows of
|
||||
[(i, _)] -> i
|
||||
_ -> error $ "expected one users row, got " <> show rows
|
||||
|
||||
-- the occurrence the user answered, which silences that alert and no other
|
||||
ackedEpisode :: HasCallStack => ChatController -> IO (Maybe Text, Maybe Text)
|
||||
ackedEpisode ChatController {chatStore} = do
|
||||
rows :: [(Maybe Text, Maybe Text)] <-
|
||||
withTransaction chatStore $ \db ->
|
||||
DB.query_ db "SELECT alert_acked_kind, alert_acked_episode FROM badge_purchases"
|
||||
pure $ case rows of
|
||||
[r] -> r
|
||||
_ -> error $ "expected one badge purchase, got " <> show rows
|
||||
|
||||
waitShownBadge :: HasCallStack => ChatController -> Maybe Int64 -> IO ()
|
||||
waitShownBadge cc expected = loop (100 :: Int)
|
||||
where
|
||||
loop 0 = shownBadgeId cc >>= \actual -> actual `shouldBe` expected
|
||||
loop i =
|
||||
shownBadgeId cc >>= \actual ->
|
||||
if actual == expected then pure () else threadDelay 50000 >> loop (i - 1)
|
||||
|
||||
redeemFirstBadge :: HasCallStack => TestCC -> BadgeCode -> IO ()
|
||||
redeemFirstBadge alice code = do
|
||||
alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
|
||||
alice <## "badge redeemed"
|
||||
alice <## "supporter badge - active"
|
||||
alice <##. "expires "
|
||||
|
||||
-- A credential nears its expiry and the badge renews from the worker's own pass, with no command
|
||||
-- sent by the app: chat activate only signals it, and the work is derived from stored state.
|
||||
-- The request and the presentation are a day apart, so each renewal takes two passes.
|
||||
testWorkerRenews :: HasCallStack => TestParams -> IO ()
|
||||
testWorkerRenews ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
|
||||
withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
|
||||
code <- issueCode cc BTSupporter 3
|
||||
redeemFirstBadge alice code
|
||||
redeemed <- ledgerRows (chatController alice) "badge_ledger"
|
||||
map (\(_, ch, m, _, _, t) -> (ch, m, t)) redeemed `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge")]
|
||||
-- the credential the profile shows is a day from lapsing, while the app is running
|
||||
let (requestAt, presentAt) = renewalMoments redeemed
|
||||
setClockAt bsClock requestAt
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
renewed <- waitLedgerRows (chatController alice) 3
|
||||
-- the renewal reports itself, no command having asked for it
|
||||
alice <##. "1: supporter"
|
||||
map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")]
|
||||
-- the month is issued but not yet worn: the profile still carries the one it had
|
||||
(shownEarly, issuedEarly) <- shownAndIssuedExpiry (chatController alice)
|
||||
shownEarly `shouldNotBe` issuedEarly
|
||||
-- a day later the held credential lapses and the new month is presented
|
||||
setClockAt bsClock presentAt
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
waitShownIssued (chatController alice)
|
||||
-- the third month too: the state a renewal leaves must support the next one
|
||||
let (requestAt2, presentAt2) = renewalMoments renewed
|
||||
setClockAt bsClock requestAt2
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
alice <##. "1: supporter"
|
||||
renewed2 <- waitLedgerRows (chatController alice) 4
|
||||
map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed2
|
||||
`shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge"), (-1, 0, Just "badge")]
|
||||
-- the client authored none of them: the service holds exactly the same rows
|
||||
serviceLedger <- ledgerRows cc "sx_badge_service_badge_ledger"
|
||||
renewed2 `shouldBe` serviceLedger
|
||||
-- and the profile shows the month last issued, not an earlier one
|
||||
setClockAt bsClock presentAt2
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
waitShownIssued (chatController alice)
|
||||
|
||||
-- The request is made by the wake the worker set for itself a day before the credential lapses.
|
||||
testRequestWakeFires :: HasCallStack => TestParams -> IO ()
|
||||
testRequestWakeFires ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
|
||||
withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
|
||||
code <- issueCode cc BTSupporter 3
|
||||
redeemFirstBadge alice code
|
||||
redeemed <- ledgerRows (chatController alice) "badge_ledger"
|
||||
armWakeAt alice bsClock $ fst $ renewalMoments redeemed
|
||||
-- the arming pass asked for nothing, so what follows cannot be its doing
|
||||
ledgerRows (chatController alice) "badge_ledger" >>= (`shouldBe` redeemed)
|
||||
renewed <- waitLedgerRows (chatController alice) 3
|
||||
alice <##. "1: supporter"
|
||||
map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed
|
||||
`shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")]
|
||||
|
||||
-- The presentation is made by the wake at the expiry itself, a day after the request that issued
|
||||
-- the month it presents.
|
||||
testPresentWakeFires :: HasCallStack => TestParams -> IO ()
|
||||
testPresentWakeFires ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
|
||||
withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
|
||||
code <- issueCode cc BTSupporter 3
|
||||
redeemFirstBadge alice code
|
||||
redeemed <- ledgerRows (chatController alice) "badge_ledger"
|
||||
let (requestAt, presentAt) = renewalMoments redeemed
|
||||
setClockAt bsClock requestAt
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
void $ waitLedgerRows (chatController alice) 3
|
||||
alice <##. "1: supporter"
|
||||
armWakeAt alice bsClock presentAt
|
||||
-- the arming pass presented nothing: the profile still carries the credential it had
|
||||
shownAndIssuedExpiry (chatController alice) >>= \(shown, issued) -> shown `shouldNotBe` issued
|
||||
waitShownIssued (chatController alice)
|
||||
|
||||
-- The newest row being of an unknown type must not stop the renewal: it is stored verbatim and
|
||||
-- read back to be asserted, rather than leaving the client with no entry to assert at all.
|
||||
testRenewsAfterUnknownEntry :: HasCallStack => TestParams -> IO ()
|
||||
testRenewsAfterUnknownEntry ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
|
||||
withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
|
||||
code <- issueCode cc BTSupporter 3
|
||||
redeemFirstBadge alice code
|
||||
rows <- ledgerRows (chatController alice) "badge_ledger"
|
||||
insertUnknownLedgerEntry (chatController alice)
|
||||
setClockAt bsClock $ fst $ renewalMoments rows
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
renewed <- waitLedgerRows (chatController alice) 4
|
||||
alice <##. "1: supporter"
|
||||
-- the unknown row is asserted, so the service answers with what it does not hold: the whole
|
||||
-- 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 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.
|
||||
testRenewsAfterRestart :: HasCallStack => TestParams -> IO ()
|
||||
testRenewsAfterRestart ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> do
|
||||
rows <- withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
|
||||
code <- issueCode cc BTSupporter 6
|
||||
redeemFirstBadge alice code
|
||||
ledgerRows (chatController alice) "badge_ledger"
|
||||
-- the credit row's start is the anchor: a grant on a run that has never lapsed moves neither
|
||||
let (_, _, _, anchor, _, _) = head rows
|
||||
-- stopped until past the fourth boundary of the run: three months lapse, the fourth is issued
|
||||
setClockAt bsClock $ addMonths 4 anchor
|
||||
withTestChatCfg ps bsClientCfg "alice" $ \alice -> do
|
||||
renewed <- waitLedgerRows (chatController alice) 4
|
||||
alice <##. "1: supporter"
|
||||
map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed
|
||||
`shouldBe` [(6, 6, Just "code"), (-1, 5, Just "badge"), (-3, 2, Just "lapse"), (-1, 1, Just "badge")]
|
||||
-- the lapse row was replicated rather than authored here
|
||||
serviceLedger <- ledgerRows cc "sx_badge_service_badge_ledger"
|
||||
renewed `shouldBe` serviceLedger
|
||||
-- a week missed costs only the day between the two steps: one pass does both
|
||||
waitShownIssued (chatController alice)
|
||||
|
||||
-- When the balance is spent and the last period ends, the badge stops being shown and the profile
|
||||
-- update reaches contacts - the visible half of "the badge expired".
|
||||
testWorkerRetiresExpired :: HasCallStack => TestParams -> IO ()
|
||||
testWorkerRetiresExpired ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
|
||||
withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice ->
|
||||
withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do
|
||||
connectUsers alice bob
|
||||
code <- issueCode cc BTSupporter 1
|
||||
redeemFirstBadge alice code
|
||||
alice #> "@bob hi"
|
||||
bob <# "alice *> hi"
|
||||
-- bob sees it before it expires
|
||||
bob ##> "/i alice"
|
||||
bob <## "contact ID: 2"
|
||||
bob <## "supporter badge - active"
|
||||
bob <##. "expires "
|
||||
bob <## "receiving messages via: localhost"
|
||||
bob <## "sending messages via: localhost"
|
||||
bob <## "you've shared main profile with this contact"
|
||||
bob <## "connection not verified, use /code command to see security code"
|
||||
bob <## "quantum resistant end-to-end encryption"
|
||||
bob <## currentChatVRangeInfo
|
||||
rows <- ledgerRows (chatController alice) "badge_ledger"
|
||||
-- the one month it bought has ended and nothing is left to issue
|
||||
setClockAt bsClock $ dueAtOf rows
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
-- support ended, and the state it changed by retiring the badge carries the same alert
|
||||
alice <##. "badge alert: support_ended "
|
||||
alice <##. "1: supporter"
|
||||
alice <##. "badge alert: support_ended "
|
||||
-- the profile stops showing it locally
|
||||
waitShownBadge (chatController alice) Nothing
|
||||
alice ##> "/p"
|
||||
alice <## "user profile: alice (Alice)"
|
||||
alice <## "use /p <name> [<bio>] to change it"
|
||||
-- The removal travels as a profile update, which prints nothing when only the badge
|
||||
-- changed (viewContactUpdated compares names and links). The next message shows it
|
||||
-- arrived: bob's prefix loses the badge marker it carried above.
|
||||
alice #> "@bob after"
|
||||
bob <# "alice> after"
|
||||
-- and the badge is gone from the contact's stored profile, not merely from the prefix
|
||||
bob ##> "/i alice"
|
||||
bob <## "contact ID: 2"
|
||||
bob <## "receiving messages via: localhost"
|
||||
bob <## "sending messages via: localhost"
|
||||
bob <## "you've shared main profile with this contact"
|
||||
bob <## "connection not verified, use /code command to see security code"
|
||||
bob <## "quantum resistant end-to-end encryption"
|
||||
bob <## currentChatVRangeInfo
|
||||
|
||||
-- The credential outlives the balance by up to eight days, because its expiry covers renewal and
|
||||
-- not entitlement. A worker scheduled only on that expiry would leave the badge worn, and the user
|
||||
-- unasked to buy again, for the whole of that week - so paidThrough is a wake of its own.
|
||||
testRetiresWhenEntitlementEnds :: HasCallStack => TestParams -> IO ()
|
||||
testRetiresWhenEntitlementEnds ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
|
||||
withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
|
||||
code <- issueCode cc BTSupporter 1
|
||||
redeemFirstBadge alice code
|
||||
rows <- ledgerRows (chatController alice) "badge_ledger"
|
||||
armWakeAt alice bsClock $ dueAtOf rows
|
||||
-- that pass retired nothing and printed nothing: the badge is still worn and /p says so
|
||||
alice ##> "/p"
|
||||
alice <## "user profile: alice (Alice, * supporter)"
|
||||
alice <## "use /p <name> [<bio>] to change it"
|
||||
-- nothing signals the worker from here, and the credential has days left, so the wake that
|
||||
-- produces these is the one the worker set for itself at paidThrough
|
||||
alice <##. "badge alert: support_ended "
|
||||
alice <##. "1: supporter"
|
||||
alice <##. "badge alert: support_ended "
|
||||
waitShownBadge (chatController alice) Nothing
|
||||
|
||||
-- The alert is derived from stored state rather than kept pending, so it is still there after a
|
||||
-- restart; acknowledging records the occurrence it answered, and the same one is not raised again.
|
||||
testEndedAlert :: HasCallStack => TestParams -> IO ()
|
||||
testEndedAlert ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> do
|
||||
endsAt <- withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
|
||||
code <- issueCode cc BTSupporter 1
|
||||
redeemFirstBadge alice code
|
||||
rows <- ledgerRows (chatController alice) "badge_ledger"
|
||||
let endsAt = dueAtOf rows
|
||||
setClockAt bsClock endsAt
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
-- the pass raises the alert, and reports the state it changed by retiring the badge - which
|
||||
-- carries the same alert, the alert being part of the state
|
||||
alice <##. "badge alert: support_ended "
|
||||
alice <##. "1: supporter"
|
||||
alice <##. "badge alert: support_ended "
|
||||
pure endsAt
|
||||
-- nothing was stored as pending, and the alert is derived again on the next start
|
||||
withTestChatCfg ps bsClientCfg "alice" $ \alice -> do
|
||||
alice <##. "badge alert: support_ended "
|
||||
alice ##> ("/_badge ack 1 1 support_ended off " <> T.unpack (safeDecodeUtf8 $ strEncode endsAt))
|
||||
alice <##. "1: supporter"
|
||||
ackedEpisode (chatController alice) `shouldReturn` (Just "support_ended", Just (safeDecodeUtf8 $ strEncode endsAt))
|
||||
-- acknowledged: the state no longer carries the alert, and no event raises it again
|
||||
alice ##> "/_badge state 1"
|
||||
alice <##. "1: supporter"
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
alice ##> "/p"
|
||||
alice <## "user profile: alice (Alice)"
|
||||
alice <## "use /p <name> [<bio>] to change it"
|
||||
|
||||
-- A worker runs for every profile, not only the one in use, so presenting a renewed badge must not
|
||||
-- make its profile active - the next message would then be sent from the wrong identity.
|
||||
testRenewalKeepsActiveProfile :: HasCallStack => TestParams -> IO ()
|
||||
testRenewalKeepsActiveProfile ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
|
||||
withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
|
||||
code <- issueCode cc BTSupporter 3
|
||||
redeemFirstBadge alice code
|
||||
rows <- ledgerRows (chatController alice) "badge_ledger"
|
||||
alice ##> "/create user alisa"
|
||||
showActiveUser alice "alisa"
|
||||
-- alice's credential is a day from lapsing while alisa is the profile in use
|
||||
let (requestAt, presentAt) = renewalMoments rows
|
||||
setClockAt bsClock requestAt
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
renewed <- waitLedgerRows (chatController alice) 3
|
||||
map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed
|
||||
`shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")]
|
||||
-- the renewal is reported for alice, and the prefix is there because alice is not active
|
||||
alice <##. "[user: alice] 1: supporter"
|
||||
-- presenting is the pass that writes alice's profile, and it is the one that could switch
|
||||
setClockAt bsClock presentAt
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
waitShownIssued (chatController alice)
|
||||
alice ##> "/p"
|
||||
showActiveUser alice "alisa"
|
||||
|
||||
-- A snooze silences the alert until it lapses, and then it is raised once more, without a restart.
|
||||
-- A snooze changes nothing else on the purchase, so the occurrence already raised has to count it.
|
||||
testSnoozedAlertReturns :: HasCallStack => TestParams -> IO ()
|
||||
testSnoozedAlertReturns ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
|
||||
withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
|
||||
code <- issueCode cc BTSupporter 1
|
||||
redeemFirstBadge alice code
|
||||
rows <- ledgerRows (chatController alice) "badge_ledger"
|
||||
let endsAt = dueAtOf rows
|
||||
setClockAt bsClock endsAt
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
alice <##. "badge alert: support_ended "
|
||||
alice <##. "1: supporter"
|
||||
alice <##. "badge alert: support_ended "
|
||||
alice ##> ("/_badge ack 1 1 support_ended on " <> T.unpack (safeDecodeUtf8 $ strEncode endsAt))
|
||||
alice <##. "1: supporter"
|
||||
-- the ack signalled the worker, and the pass it ran was silent: /p prints only its own output
|
||||
alice ##> "/p"
|
||||
alice <## "user profile: alice (Alice)"
|
||||
alice <## "use /p <name> [<bio>] to change it"
|
||||
-- the snooze lapses: nothing else about the badge changed, so only the alert is reported
|
||||
setClockAt bsClock $ addUTCTime (nominalDay + 60) endsAt
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
alice <##. "badge alert: support_ended "
|
||||
|
||||
-- The worker re-reads the profile each pass. Presenting a renewed badge from a copy captured when
|
||||
-- the worker started would revert any edit made since and broadcast the profile in its old form.
|
||||
testRenewalKeepsProfileEdits :: HasCallStack => TestParams -> IO ()
|
||||
testRenewalKeepsProfileEdits ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
|
||||
withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice ->
|
||||
withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do
|
||||
connectUsers alice bob
|
||||
code <- issueCode cc BTSupporter 3
|
||||
redeemFirstBadge alice code
|
||||
-- the profile is edited after the worker started
|
||||
alice ##> "/p alice Alice Jones"
|
||||
concurrentlyN_
|
||||
[ alice <## "user bio changed to Alice Jones (your 1 contacts are notified)",
|
||||
bob <## "contact alice updated bio: Alice Jones"
|
||||
]
|
||||
rows <- ledgerRows (chatController alice) "badge_ledger"
|
||||
let (requestAt, presentAt) = renewalMoments rows
|
||||
setClockAt bsClock requestAt
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
alice <##. "1: supporter"
|
||||
renewed <- waitLedgerRows (chatController alice) 3
|
||||
map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed
|
||||
`shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")]
|
||||
-- presenting a day later is the pass that broadcasts the profile
|
||||
setClockAt bsClock presentAt
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
waitShownIssued (chatController alice)
|
||||
-- The renewal's profile update carries the edited bio. Had it carried the profile the
|
||||
-- worker started with, bob would print a bio change back to "Alice" here, before the
|
||||
-- message - so the message arriving next is the assertion.
|
||||
alice #> "@bob after renewal"
|
||||
bob <# "alice *> after renewal"
|
||||
bob ##> "/i alice"
|
||||
bob <## "contact ID: 2"
|
||||
bob <## "supporter badge - active"
|
||||
bob <##. "expires "
|
||||
bob <## "receiving messages via: localhost"
|
||||
bob <## "sending messages via: localhost"
|
||||
bob <## "you've shared main profile with this contact"
|
||||
bob <## "connection not verified, use /code command to see security code"
|
||||
bob <## "quantum resistant end-to-end encryption"
|
||||
bob <## currentChatVRangeInfo
|
||||
|
||||
-- Forces the state a crash between the issuance write and the profile write leaves behind: the
|
||||
-- month is issued, unpresented, and no later pass finds it due.
|
||||
testPresentationCatchesUp :: HasCallStack => TestParams -> IO ()
|
||||
testPresentationCatchesUp ps =
|
||||
withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} ->
|
||||
withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice ->
|
||||
withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do
|
||||
connectUsers alice bob
|
||||
code <- issueCode cc BTSupporter 3
|
||||
redeemFirstBadge alice code
|
||||
alice #> "@bob hi"
|
||||
bob <# "alice *> hi"
|
||||
rows <- ledgerRows (chatController alice) "badge_ledger"
|
||||
let (requestAt, presentAt) = renewalMoments rows
|
||||
setClockAt bsClock requestAt
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
alice <##. "1: supporter"
|
||||
void $ waitLedgerRows (chatController alice) 3
|
||||
setClockAt bsClock presentAt
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
waitShownIssued (chatController alice)
|
||||
expiries <- issuedExpiries (chatController alice)
|
||||
length expiries `shouldBe` 2
|
||||
let firstMonth = head expiries
|
||||
latestMonth = last expiries
|
||||
-- the renewal's rows are kept; only its presentation is undone, on both sides
|
||||
setBadgeExpiry (chatController alice) "badge_signature" firstMonth
|
||||
setBadgeExpiry (chatController bob) "badge_proof" firstMonth
|
||||
alice ##> "/_app activate"
|
||||
alice <## "ok"
|
||||
waitPeerBadgeExpiry (chatController bob) latestMonth
|
||||
(shown, issued) <- shownAndIssuedExpiry (chatController alice)
|
||||
shown `shouldBe` Just latestMonth
|
||||
issued `shouldBe` Just latestMonth
|
||||
alice #> "@bob after repair"
|
||||
bob <# "alice *> after repair"
|
||||
|
||||
waitPeerBadgeExpiry :: HasCallStack => ChatController -> UTCTime -> IO ()
|
||||
waitPeerBadgeExpiry cc expected = loop (100 :: Int)
|
||||
where
|
||||
loop 0 = peerBadgeExpiry cc >>= \actual -> actual `shouldBe` Just expected
|
||||
loop i =
|
||||
peerBadgeExpiry cc >>= \actual ->
|
||||
if actual == Just expected then pure () else threadDelay 50000 >> loop (i - 1)
|
||||
|
||||
testPurchaseKeyMismatch :: HasCallStack => TestParams -> IO ()
|
||||
testPurchaseKeyMismatch ps =
|
||||
withBadgeService ps $ \clientCfg bsLink _ ->
|
||||
|
||||
Reference in New Issue
Block a user