core, ui: badge redeem errors and fixes (#7515)

- redeem errors are typed (CEBadgeRedeemError) instead of matched by text in the apps
- service timeout (A_SERVICE) decodes in the apps and offers Retry via the existing retry alert
- unexpected redeem errors show the error itself instead of a generic message
- service error codes are a typed enum in the apps (BadgeServiceErrorCode)
- CRBadgeRedeemed returns badge state, so the apps skip a second round-trip after redeem
- setBadgeAlertAcked is scoped to user_id
- badgeChanged updates non-active profiles, so other profiles' badges don't go stale
- pitch banner is not shown to a profile that already has a badge
- one badgeTypeName per platform, used by the badge screen and the badge info alert
- BadgeAlertKind and BadgeAlertPrice decode via standard JSON, no custom decoders
- dead "Support ended" title branch removed from Your Badge view
- kotlin: users from badge responses carry remoteHostId
- kotlin: redeem code field keeps the IME's cursor and composition state
- kotlin: "Get your code" shown in all flavours
- kotlin: "Don't show again" -> "Dismiss", matching iOS
- kotlin: parseBadgeCode moved next to its FFI in platform/Core.kt
- kotlin: BadgesView no longer cross-fades on badge state updates
- kotlin: section title not uppercased
- ios: redeem code field parses once per change
- ios: A_SERVICE rejected reason is not decoded
- CLI: "cannot redeem badge code: ..." with the source of the error
- comments clarified

src/Simplex/Chat/Badges/Types.hs

@@ -24,6 +24,7 @@ module Simplex.Chat.Badges.Types
     BadgeCharge (..),
     BadgeIssuance (..),
     BadgeAlert (..),
+    BadgeAlertPrice (..),
     BadgeState (..),
   ) where
 
@@ -204,7 +205,13 @@ data BadgeAlert = BadgeAlert
   { kind :: BadgeAlertKind,
     episode :: Text,
     date :: UTCTime,
-    price :: Maybe (Int64, Text)
+    price :: Maybe BadgeAlertPrice
+  }
+  deriving (Show)
+
+data BadgeAlertPrice = BadgeAlertPrice
+  { amount :: Int64,
+    currency :: Text
   }
   deriving (Show)
 
@@ -259,12 +266,9 @@ $(JQ.deriveJSON (enumJSON $ dropPrefix "BIS") ''BadgeItemStatus)
 
 $(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "OD") ''OfferDiscount)
 
-instance ToJSON BadgeAlertKind where
-  toJSON = textToJSON
-  toEncoding = textToEncoding
+$(JQ.deriveJSON (enumJSON $ dropPrefix "BA") ''BadgeAlertKind)
 
-instance FromJSON BadgeAlertKind where
-  parseJSON = textParseJSON "BadgeAlertKind"
+$(JQ.deriveJSON defaultJSON ''BadgeAlertPrice)
 
 $(JQ.deriveJSON defaultJSON ''BadgeAlert)
 

src/Simplex/Chat/Controller.hs

@@ -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, FileSizeLimits, LocalBadge)
+import Simplex.Chat.Badges.Service (BadgeServiceErrorCode)
 import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeState (..))
 import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
@@ -866,7 +867,7 @@ data ChatResponse
   | CRContactRequestRejected {user :: User, contactRequest :: UserContactRequest, contact_ :: Maybe Contact}
   | CRServiceResponse {user :: User, responseData :: J.Object}
   | CRServiceReplyAccepted {user :: User, connectionId :: AgentConnId}
-  | CRBadgeRedeemed {user :: User, redeemedBadge :: LocalBadge, newBadge :: Bool}
+  | CRBadgeRedeemed {user :: User, redeemedBadge :: LocalBadge, newBadge :: Bool, badgeState :: Maybe BadgeState}
   | 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}
@@ -1476,6 +1477,16 @@ data SimplexDomainError
   | SDEUnknownDomain -- the resolved link's profile has no name, or a different name
   deriving (Eq, Show)
 
+data BadgeRedeemError
+  = BREInvalidCode -- format or check character
+  | BREServiceNotConfigured
+  | BREBadgeActive
+  | BREServiceError {serviceError :: BadgeServiceErrorCode}
+  | BREInvalidResponse {message :: String}
+  | BREUnknownKeyIndex
+  | BRECredentialNotVerified
+  deriving (Eq, Show)
+
 data ChatErrorType
   = CENoActiveUser
   | CENoConnectionUser {agentConnId :: AgentConnId}
@@ -1548,6 +1559,7 @@ data ChatErrorType
   | CEAgentVersion
   | CEAgentNoSubResult {agentConnId :: AgentConnId}
   | CECommandError {message :: String}
+  | CEBadgeRedeemError {badgeRedeemError :: BadgeRedeemError}
   | CEServerProtocol {serverProtocol :: AProtocolType}
   | CEAgentCommandError {message :: String}
   | CEInvalidFileDescription {message :: String}
@@ -1832,6 +1844,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "FC") ''ForwardConfirmation)
 
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "SDE") ''SimplexDomainError)
 
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "BRE") ''BadgeRedeemError)
+
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "CE") ''ChatErrorType)
 
 $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "RHE") ''RemoteHostError)

src/Simplex/Chat/Library/Commands.hs

@@ -3570,7 +3570,7 @@ processChatCommand cxt nm = \case
   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
+    withStore' $ \db -> setBadgeAlertAcked db user 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
@@ -5220,8 +5220,8 @@ presentUserBadgeToContacts user'@User {userId, profile = LocalProfile {localBadg
 -- A terminal answer drops the stash; a timeout keeps it.
 redeemBadgeCode :: NetworkRequestMode -> User -> Text -> CM ChatResponse
 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
+  code <- maybe (throwRedeemError BREInvalidCode) pure $ parseBadgeCode codeText
+  sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwRedeemError BREServiceNotConfigured) pure
   g <- asks random
   now <- liftIO getCurrentTime
   let codeSent = badgeCodeText code
@@ -5232,24 +5232,23 @@ redeemBadgeCode nm user@User {userId} codeText = do
     -- 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"
+    unless replaying $ whenM (withStore' (`userHasBadge` user)) $ throwRedeemError BREBadgeActive
     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
+    respBytes <- sendServiceRequestBytes nm user sendTarget Nothing (Just purchasePrivKey) req
+    respData <- either (const $ throwRedeemError $ BREInvalidResponse "not JSON") pure $ J.eitherDecodeStrict' respBytes
     case J.fromJSON (J.Object respData) of
-      J.Error e -> throwCmdError $ "invalid badge service response, " <> show e <> ": " <> respJSON respData
+      J.Error _ -> throwRedeemError $ BREInvalidResponse "not a badge service response"
       J.Success BSPError {code = errCode} -> do
         when (terminalCodeError errCode) $ withStore' $ \db -> deleteBadgeCodeRedemption db (redemptionId redemption)
-        throwCmdError $ "badge service error: " <> T.unpack (badgeServiceErrorText errCode)
+        throwRedeemError $ BREServiceError errCode
       J.Success BSPBadgeCredential {credential = Just cred, statement} -> storeRedeemedBadge user redemption cred statement
-      J.Success _ -> throwCmdError $ "unexpected badge service response: " <> respJSON respData
+      J.Success _ -> throwRedeemError $ BREInvalidResponse "unexpected response type"
   -- 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
     -- the code will never work, so the keys stashed for it are dead; a timeout keeps them
     terminalCodeError = \case
       BSECodeInvalid -> True
@@ -5257,6 +5256,9 @@ redeemBadgeCode nm user@User {userId} codeText = do
       BSECodeExpired -> True
       _ -> False
 
+throwRedeemError :: BadgeRedeemError -> CM a
+throwRedeemError = throwChatError . CEBadgeRedeemError
+
 -- | An unknown code is reported, since the service is deployed ahead of clients, but its text is
 -- the service's - so it is bounded and stripped before reaching a terminal that acts on controls.
 badgeServiceErrorText :: BadgeServiceErrorCode -> Text
@@ -5584,11 +5586,11 @@ stopBadgeWorkers workers =
 storeRedeemedBadge :: User -> BadgeCodeRedemption -> BadgeCredential -> BadgeStatement -> CM (Maybe User, ChatResponse)
 storeRedeemedBadge user@User {userId} redemption@BadgeCodeRedemption {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeType}) statement =
   verifyOwnBadge cred >>= \case
-    Nothing -> throwCmdError "redeemed badge credential names an unknown badge key index"
-    Just False -> throwCmdError "redeemed badge credential does not verify against configured key"
+    Nothing -> throwRedeemError BREUnknownKeyIndex
+    Just False -> throwRedeemError BRECredentialNotVerified
     -- verifyCredential checks the signature against the key inside the credential, not the one we
     -- sent - so a credential over any other master key also verifies
-    Just True | credMasterKey /= masterKey -> throwCmdError "redeemed badge credential is for a different master key"
+    Just True | credMasterKey /= masterKey -> throwRedeemError $ BREInvalidResponse "credential is for a different master key"
     Just True -> do
       g <- asks random
       now <- badgeNow
@@ -5603,7 +5605,8 @@ storeRedeemedBadge user@User {userId} redemption@BadgeCodeRedemption {masterKey}
       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)
+      badgeState <- getUserBadgeState user'
+      pure (if newBadge then Just user' else Nothing, CRBadgeRedeemed user' badge newBadge badgeState)
 
 -- | 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.
@@ -5627,10 +5630,14 @@ applyBadgeStatement db g purchaseId badgeType BadgeStatement {entries} cred_ now
       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
+sendServiceRequestTo nm user sendTarget requestTimeout signKey request =
+  sendServiceRequestBytes nm user sendTarget requestTimeout signKey request
+    >>= either (const $ throwCmdError "invalid service response") pure . J.eitherDecodeStrict'
+
+sendServiceRequestBytes :: J.ToJSON a => NetworkRequestMode -> User -> ConnectTarget 'CMContact -> Maybe NominalDiffTime -> Maybe C.PrivateKeyEd25519 -> a -> CM ByteString
+sendServiceRequestBytes nm user sendTarget requestTimeout signKey request = do
   cReq <- resolveServiceTarget sendTarget
-  respData <- withAgent $ \a -> sendServiceRequestAsync a (aUserId user) cReq requestTimeout signKey (LB.toStrict $ J.encode request)
-  either (const $ throwCmdError "invalid service response") pure $ J.eitherDecodeStrict' respData
+  withAgent $ \a -> sendServiceRequestAsync a (aUserId user) cReq requestTimeout signKey (LB.toStrict $ J.encode request)
   where
     resolveServiceTarget = \case
       CTFullContact cReq -> pure cReq

src/Simplex/Chat/Store/Badges.hs

@@ -258,12 +258,12 @@ userHasBadge db User {userId} =
 
 -- | 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 =
+setBadgeAlertAcked :: DB.Connection -> User -> Int64 -> BadgeAlertKind -> Text -> Maybe UTCTime -> IO ()
+setBadgeAlertAcked db User {userId} 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)
+    "UPDATE badge_purchases SET alert_acked_kind = ?, alert_acked_episode = ?, alert_snooze_until = ? WHERE badge_purchase_id = ? AND user_id = ?"
+    (kind, episode, snoozeUntil, badgePurchaseId, userId)
 
 -- | Stop showing a badge that has expired unrenewed; the profile update is broadcast by the caller.
 clearShownBadge :: DB.Connection -> User -> Int64 -> IO ()

src/Simplex/Chat/View.hs

@@ -41,7 +41,7 @@ import Numeric (showFFloat)
 import Simplex.Chat.Call
 import Simplex.Chat.Controller
 import Simplex.Chat.Help
-import Simplex.Chat.Library.Commands (maxImageSize)
+import Simplex.Chat.Library.Commands (badgeServiceErrorText, maxImageSize)
 import Simplex.Chat.Markdown
 import Simplex.Chat.Badges (BadgeInfo (..), BadgeStatus (..), BadgeType (..), LocalBadge, localBadgeInfo, localBadgeStatus)
 import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeState (..))
@@ -190,7 +190,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
   CRServiceResponse u resp -> ttyUser u ["service response: " <> viewJSON resp]
   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"]
+  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
@@ -2841,6 +2841,16 @@ viewChatError isCmd logLevel testView = \case
     CEAgentNoSubResult connId -> ["no subscription result for connection: " <> sShow connId]
     CEServerProtocol p -> [plain $ "Servers for protocol " <> strEncode p <> " cannot be configured by the users"]
     CECommandError e -> ["bad chat command: " <> plain e]
+    CEBadgeRedeemError e ->
+      let reason = case e of
+            BREInvalidCode -> "invalid code"
+            BREServiceNotConfigured -> "badge service not configured"
+            BREBadgeActive -> "badge already active"
+            BREServiceError code -> "badge service error: " <> T.unpack (badgeServiceErrorText code)
+            BREInvalidResponse m -> "invalid service response: " <> m
+            BREUnknownKeyIndex -> "credential names an unknown badge key index"
+            BRECredentialNotVerified -> "credential does not verify against configured key"
+       in ["cannot redeem badge code: " <> plain reason]
     CEAgentCommandError e -> ["agent command error: " <> plain e]
     CEInvalidFileDescription e -> ["invalid file description: " <> plain e]
     CEConnectionIncognitoChangeProhibited -> ["incognito mode change prohibited"]