core: redeem badge codes (#7438)

apps/simplex-badge-service/Main.hs

@@ -11,4 +11,4 @@ main = do
   opts@BadgeServiceOpts {runCLI} <- welcomeGetOpts
   if runCLI
     then badgeServiceCLI opts
-    else badgeService opts terminalChatConfig
+    else newServiceState >>= badgeService opts terminalChatConfig

apps/simplex-badge-service/README.md

@@ -5,11 +5,12 @@ Scaffolding for the SimpleX supporter-badge RPC service. The wire protocol is sp
 At this stage the service:
 
 - creates a double-ratchet contact address on first start (service RPC requires DR, see [`docs/protocol/badges-rpc.md`](../../docs/protocol/badges-rpc.md)),
-- listens for service requests (`CEvtServiceRequest`) on that address and responds to every command with `unsupported_version`,
+- listens for service requests (`CEvtServiceRequest`) on that address, rejects a request whose `purchaseKey` is not the key the agent verified the signature against, and answers `redeemBadgeCode`,
+- issues redemption codes, storing only their `SHA-256` and printing each code once,
 - does not accept contact requests — the address is for RPC only,
-- exposes a placeholder schema migration (`sx_badge_service_test`) and its own migrations table (`sx_badge_service_migrations`).
+- owns the `sx_badge_service_`-prefixed tables and its own migrations table (`sx_badge_service_migrations`).
 
-Business logic — command dispatch, ledger writes, credential signing, provider webhooks — is left for follow-up per the plans.
+Every other command still answers `unsupported_version`. Ledger writes, invoices and provider webhooks are left for follow-up per the plans; a redemption issues one credential and reports an empty statement.
 
 ## Build
 
@@ -28,3 +29,32 @@ simplex-badge-service --help
 - default (no `--run-cli`): background service mode, no interactive terminal.
 - `--run-cli`: interactive CLI that also processes service requests (mirrors `simplex-directory-service --run-cli`).
 - `--no-address`: skip address creation on start-up (for operators who provision the address themselves).
+
+The service cannot sign credentials without an issuer key and refuses to start without one:
+
+- `--issuer-key-idx IDX` — the index the apps find the matching public key under (`badgePublicKeys` in `ChatConfig`).
+- `--issuer-secret SECRET` — the issuer secret from `simplex-chat badge keygen`.
+
+The service checks the secret against the configured public key at that index and refuses to start
+if they disagree: credentials signed with the wrong key cannot be verified by any client, and the
+codes redeemed against them would be spent for nothing.
+
+## Issuing codes
+
+Issuing a code is an operator command sent to the running service in `--run-cli` mode, not a way
+to start it — so codes are issued without a second process touching the service's database:
+
+```
+//issue <badge_type> [months] [paid|unpaid|free]
+//issue supporter 12
+```
+
+`months` defaults to 1 and must be between 1 and 255; the status defaults to `free` and records
+whether the code was sold (`paid`), is awaiting payment (`unpaid`), or was issued by an operator
+(`free`) — redemption never reads it.
+
+The code is printed once and only its `SHA-256` is stored, so a code that is not copied when it is
+shown cannot be recovered.
+
+Core parses `//...` into `CustomChatCommand` and leaves it to the service's `preCmdHook`, which is
+why issuing codes lives in the service rather than in core.

apps/simplex-badge-service/src/BadgeService/Options.hs

@@ -5,16 +5,20 @@
 
 module BadgeService.Options
   ( BadgeServiceOpts (..),
+    BadgeIssuerKey (..),
     getBadgeServiceOpts,
     badgeServiceOpts,
     mkChatOpts,
   )
 where
 
+import qualified Data.ByteString.Char8 as B
 import qualified Data.Text as T
 import Options.Applicative
 import Simplex.Chat.Controller (updateStr, versionNumber, versionString)
 import Simplex.Chat.Options (ChatCmdLog (..), ChatOpts (..), CoreChatOpts, CreateBotOpts (..), coreChatOptsP)
+import Simplex.Messaging.Crypto.BBS (BBSSecretKey)
+import Simplex.Messaging.Encoding.String (strDecode)
 
 data BadgeServiceOpts = BadgeServiceOpts
   { coreOptions :: CoreChatOpts,
@@ -22,9 +26,21 @@ data BadgeServiceOpts = BadgeServiceOpts
     clientService :: Bool,
     noAddress :: Bool,
     runCLI :: Bool,
+    -- the service refuses to start without this: it cannot sign a credential
+    issuerKey :: Maybe BadgeIssuerKey,
     testing :: Bool
   }
 
+-- | The issuer secret that signs credentials, and the index the apps find its public half under.
+data BadgeIssuerKey = BadgeIssuerKey
+  { keyIdx :: Int,
+    secretKey :: BBSSecretKey
+  }
+
+-- BBSSecretKey derives Show, so this is written out to keep the secret out of logs and errors
+instance Show BadgeIssuerKey where
+  show BadgeIssuerKey {keyIdx} = "issuer key " <> show keyIdx
+
 badgeServiceOpts :: FilePath -> FilePath -> Parser BadgeServiceOpts
 badgeServiceOpts appDir defaultDbName = do
   coreOptions <- coreChatOptsP appDir defaultDbName
@@ -50,6 +66,22 @@ badgeServiceOpts appDir defaultDbName = do
       ( long "run-cli"
           <> help "Run badge service as CLI"
       )
+  issuerKeyIdx <-
+    optional $
+      option
+        auto
+        ( long "issuer-key-idx"
+            <> metavar "KEY_IDX"
+            <> help "Index of the issuer key in the app config (required with --issuer-secret)"
+        )
+  issuerSecret <-
+    optional $
+      option
+        (eitherReader $ strDecode . B.pack)
+        ( long "issuer-secret"
+            <> metavar "ISSUER_SECRET"
+            <> help "Issuer secret from `simplex-chat badge keygen` (base64url)"
+        )
   pure
     BadgeServiceOpts
       { coreOptions,
@@ -57,6 +89,7 @@ badgeServiceOpts appDir defaultDbName = do
         clientService,
         noAddress,
         runCLI,
+        issuerKey = BadgeIssuerKey <$> issuerKeyIdx <*> issuerSecret,
         testing = False
       }
 

apps/simplex-badge-service/src/BadgeService/Service.hs

@@ -4,36 +4,60 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module BadgeService.Service
-  ( welcomeGetOpts,
+  ( ServiceState (..),
+    newServiceState,
+    welcomeGetOpts,
+    checkIssuerKey,
     badgeService,
     badgeServiceCLI,
+    IssueCodeOpts (..),
+    issueBadgeCode,
   )
 where
 
 import BadgeService.Options
+import BadgeService.Store
 import BadgeService.Store.Migrate (runBadgeServiceMigrations)
+import Control.Applicative (optional)
 import Control.Concurrent.STM
 import Control.Logger.Simple
 import Control.Monad
+import Control.Monad.IO.Class (liftIO)
 import qualified Data.Aeson as J
 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.Functor (($>))
+import Data.Maybe (fromMaybe)
+import qualified Data.Map.Strict as M
 import qualified Data.Text as T
-import Simplex.Chat.Badges.Service (BadgeServiceErrorCode (..))
+import Data.Time.Calendar (addDays, addGregorianMonthsClip)
+import Data.Time.Calendar.WeekDate (toWeekDate)
+import Data.Time.Clock (UTCTime (..), getCurrentTime)
+import Simplex.Chat.Badges
+import Simplex.Chat.Badges.Code
+import Simplex.Chat.Badges.Service
+import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
 import Simplex.Chat.Bot (initializeBotAddress')
+import Simplex.Chat.Bot.Store (withDB, withDB')
 import Simplex.Chat.Controller
 import Simplex.Chat.Core (sendChatCmd, simplexChatCore)
 import Simplex.Chat.Options (printDbOpts)
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI')
 import Simplex.Chat.Types (AgentInvId (..), User (..))
-import Simplex.Messaging.Encoding.String (strEncode)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Crypto.BBS (bbsPublicKey)
+import Simplex.Messaging.Encoding.String (TextEncoding, strEncode, textDecode)
+import Simplex.Messaging.Version (isCompatible)
 import Simplex.Messaging.Util (raceAny_, safeDecodeUtf8, tshow)
 import System.Directory (getAppUserDataDirectory)
 import System.Exit (exitFailure)
 
 data ServiceState = ServiceState
   { serviceCC :: TMVar ChatController,
-    serviceRequestQ :: TQueue (User, AgentInvId, J.Object)
+    serviceRequestQ :: TQueue (User, AgentInvId, Maybe C.PublicKeyEd25519, J.Object)
   }
 
 newServiceState :: IO ServiceState
@@ -52,48 +76,123 @@ welcomeGetOpts = do
     putStrLn $ "Service name: " ++ T.unpack serviceName
   pure opts
 
-badgeService :: BadgeServiceOpts -> ChatConfig -> IO ()
-badgeService opts cfg = do
-  env <- newServiceState
+-- | Check the secret is the key trusted at its index: otherwise every code redeemed is burned.
+checkIssuerKey :: BadgeServiceOpts -> ChatConfig -> IO (Either String BadgeIssuerKey)
+checkIssuerKey BadgeServiceOpts {issuerKey} ChatConfig {badgePublicKeys} = case issuerKey of
+  Nothing -> pure $ Left "an issuer key is required - pass both --issuer-key-idx and --issuer-secret (see `simplex-chat badge keygen`)"
+  Just k@BadgeIssuerKey {keyIdx, secretKey} ->
+    bbsPublicKey secretKey >>= \case
+      Left e -> pure $ Left $ "issuer secret is not a valid key: " <> e
+      Right pk -> pure $ case M.lookup keyIdx badgePublicKeys of
+        Just pk' | pk' == pk -> Right k
+        Just _ -> Left $ "issuer secret does not match the configured key at index " <> show keyIdx <> ", its public key is " <> T.unpack (safeDecodeUtf8 $ strEncode pk)
+        Nothing -> Left $ "no configured badge key at index " <> show keyIdx <> ", clients could not verify what this service signs"
+
+requireIssuerKey :: BadgeServiceOpts -> ChatConfig -> IO BadgeIssuerKey
+requireIssuerKey opts cfg =
+  checkIssuerKey opts cfg >>= either (\e -> putStrLn ("Error: " <> e) >> exitFailure) pure
+
+badgeService :: BadgeServiceOpts -> ChatConfig -> ServiceState -> IO ()
+badgeService opts cfg env = do
+  key <- requireIssuerKey opts cfg
   let chatHooks =
         defaultChatHooks
           { preStartHook = Just $ badgePreStartHook opts,
-            postStartHook = Just $ badgePostStartHook opts env
+            postStartHook = Just $ badgePostStartHook opts env,
+            preCmdHook = Just badgeCmdHook
           }
+  -- the reader must not block: outputQ carries every chat event
   simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc ->
-    forever $ do
-      (_, event) <- atomically . readTBQueue $ outputQ cc
-      case event of
-        -- TODO enforce _sigKey == BadgeServiceRequest.purchaseKey (docs/protocol/badges-rpc.md).
-        Right (CEvtServiceRequest u reqId _sigKey reqData) -> handleServiceRequest cc u reqId reqData
-        _ -> pure ()
+    raceAny_
+      [ forever $
+          atomically (readTBQueue $ outputQ cc) >>= \case
+            (_, Right (CEvtServiceRequest u reqId sigKey reqData)) ->
+              atomically $ writeTQueue (serviceRequestQ env) (u, reqId, sigKey, reqData)
+            _ -> pure (),
+        processQueuedRequests key env
+      ]
 
 badgeServiceCLI :: BadgeServiceOpts -> IO ()
 badgeServiceCLI opts = do
+  key <- requireIssuerKey opts terminalChatConfig
   env <- newServiceState
   let eventHook _cc ev = do
         case ev of
-          Right (CEvtServiceRequest u reqId _sigKey reqData) ->
-            atomically $ writeTQueue (serviceRequestQ env) (u, reqId, reqData)
+          Right (CEvtServiceRequest u reqId sigKey reqData) ->
+            atomically $ writeTQueue (serviceRequestQ env) (u, reqId, sigKey, reqData)
           _ -> pure ()
         pure ev
       chatHooks =
         defaultChatHooks
           { preStartHook = Just $ badgePreStartHook opts,
             postStartHook = Just $ badgePostStartHook opts env,
+            preCmdHook = Just badgeCmdHook,
             eventHook = Just eventHook
           }
   raceAny_
     [ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing,
-      processQueuedRequests env
+      processQueuedRequests key env
     ]
 
-processQueuedRequests :: ServiceState -> IO ()
-processQueuedRequests env = do
+-- | issuing codes lives here rather than in core: every user's app would otherwise ship it
+badgeCmdHook :: ChatController -> ChatCommand -> IO (Either (Either ChatError ChatResponse) ChatCommand)
+badgeCmdHook cc = \case
+  CustomChatCommand cmd -> Left <$> runBadgeCmd cc cmd
+  cmd -> pure $ Right cmd
+
+runBadgeCmd :: ChatController -> ByteString -> IO (Either ChatError ChatResponse)
+runBadgeCmd cc cmd = case A.parseOnly issueCmdP cmd of
+  Left _ -> pure $ chatCmdError "use: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free]"
+  Right issueOpts ->
+    issueBadgeCode cc issueOpts >>= \case
+      Right code -> pure $ Right CRCustomChatResponse {user_ = Nothing, response = "code " <> formatBadgeCode code}
+      Left e -> pure $ chatCmdError $ "issuing code: " <> e
+
+issueCmdP :: A.Parser IssueCodeOpts
+issueCmdP =
+  "issue " *> do
+    badgeType <- badgeTypeP
+    months_ <- optional (A.space *> A.decimal)
+    -- outside `optional`, which would otherwise backtrack past a bad count
+    months <- maybe (pure 1) checkMonths months_
+    paymentStatus <- fromMaybe CPSFree <$> optional (A.space *> textTokenP)
+    A.skipSpace
+    A.endOfInput
+    pure IssueCodeOpts {badgeType, months, paymentStatus}
+  where
+    checkMonths n
+      | n >= 1 && n <= (255 :: Int) = pure n
+      | otherwise = fail "months must be between 1 and 255"
+    -- BadgeType decodes anything to BTUnknown, so a typo would issue an unusable code
+    badgeTypeP =
+      textTokenP >>= \case
+        BTUnknown t -> fail $ "unknown badge type " <> T.unpack t
+        bt -> pure bt
+    textTokenP :: TextEncoding a => A.Parser a
+    textTokenP = do
+      t <- A.takeWhile1 (not . isSpace)
+      maybe (fail "invalid value") pure $ textDecode $ safeDecodeUtf8 t
+
+data IssueCodeOpts = IssueCodeOpts
+  { badgeType :: BadgeType,
+    months :: Int,
+    paymentStatus :: BadgeCodePaymentStatus
+  }
+
+-- | The caller sees the code once; only its hash is stored, so a lost code cannot be recovered.
+issueBadgeCode :: ChatController -> IssueCodeOpts -> IO (Either String BadgeCode)
+issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} = do
+  code <- randomBadgeCode $ random cc
+  now <- getCurrentTime
+  r <- withDB' "issueBadgeCode" cc $ \db -> insertBadgeCode db (badgeCodeHash code) badgeType months paymentStatus now
+  pure $ code <$ r
+
+processQueuedRequests :: BadgeIssuerKey -> ServiceState -> IO ()
+processQueuedRequests key env = do
   cc <- atomically $ readTMVar $ serviceCC env
   forever $ do
-    (u, reqId, reqData) <- atomically $ readTQueue $ serviceRequestQ env
-    handleServiceRequest cc u reqId reqData
+    (u, reqId, sigKey, reqData) <- atomically $ readTQueue $ serviceRequestQ env
+    handleServiceRequest key cc u reqId sigKey reqData
 
 badgePreStartHook :: BadgeServiceOpts -> ChatController -> IO ()
 badgePreStartHook opts ChatController {config, chatStore} =
@@ -110,11 +209,104 @@ badgePostStartHook BadgeServiceOpts {noAddress, testing} env cc = do
       unless noAddress $ initializeBotAddress' (not testing) (Just True) False cc
       void $ atomically $ tryPutTMVar (serviceCC env) cc
 
-handleServiceRequest :: ChatController -> User -> AgentInvId -> J.Object -> IO ()
-handleServiceRequest cc User {userId} reqId _reqData = do
+handleServiceRequest :: BadgeIssuerKey -> ChatController -> User -> AgentInvId -> Maybe C.PublicKeyEd25519 -> J.Object -> IO ()
+handleServiceRequest key cc User {userId} reqId sigKey reqData = do
   let reqIdT = safeDecodeUtf8 (strEncode reqId)
-      respObj = KM.fromList [("type", J.String "error"), ("code", J.toJSON BSEUnsupportedVersion)]
   logInfo $ "badge service request " <> reqIdT
-  sendChatCmd cc (APISendServiceResponse userId reqId respObj) >>= \case
+  resp <- badgeServiceResponse key cc sigKey reqData
+  sendChatCmd cc (APISendServiceResponse userId reqId (responseObject resp)) >>= \case
     Right _ -> pure ()
     Left e -> logError $ "badge service response failed for " <> reqIdT <> ": " <> tshow e
+
+responseObject :: BadgeServiceResponse -> J.Object
+responseObject r = case J.toJSON r of
+  J.Object o -> o
+  _ -> KM.fromList [("type", J.String "error"), ("code", J.toJSON BSEInternal)]
+
+errorResponse :: BadgeServiceErrorCode -> BadgeServiceResponse
+errorResponse code = BSPError {code, message = Nothing, retryAfter = Nothing}
+
+
+-- | The agent verified the signature, so sigKey is a key the sender holds - a purchaseKey that
+-- differs would let a client claim a purchase it cannot sign for.
+badgeServiceResponse :: BadgeIssuerKey -> ChatController -> Maybe C.PublicKeyEd25519 -> J.Object -> IO BadgeServiceResponse
+badgeServiceResponse key cc sigKey reqData = case J.fromJSON (J.Object reqData) of
+  J.Error _ -> pure $ errorResponse BSEBadRequest
+  J.Success BadgeServiceRequest {version, purchaseKey, request}
+    | not (version `isCompatible` supportedBadgeServiceVRange) -> pure $ errorResponse BSEUnsupportedVersion
+    | purchaseKey /= sigKey -> pure $ errorResponse BSEBadRequest
+    | otherwise -> case request of
+        BSCRedeemBadgeCode {masterKey, code} -> case purchaseKey of
+          Just k -> redeemCode key cc k masterKey code
+          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
+          Nothing -> pure $ errorResponse BSEUnsupportedVersion
+          Just k ->
+            withDB' "purchaseKeyExists" cc (`purchaseKeyExists` k) >>= \case
+              Right True -> pure $ errorResponse BSEUnsupportedVersion
+              Right False -> pure $ errorResponse BSEUnknownPurchaseKey
+              Left _ -> pure $ errorResponse BSEInternal
+
+-- | 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
+  Nothing -> pure $ errorResponse BSECodeInvalid
+  Just code ->
+    withDB' "getBadgeCode" cc (`getBadgeCode` badgeCodeHash 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 = Just (endOfSundayAfter periodEnd), badgeExtra = ""}
+          issueBadge keyIdx secretKey (VerifiedBadgeRequest BadgeRequest {masterKey, badgeInfo}) >>= \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
+                      }
+              -- 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
+  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
+
+-- 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

apps/simplex-badge-service/src/BadgeService/Store.hs

@@ -0,0 +1,135 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module BadgeService.Store
+  ( IssuedCode (..),
+    CodeRedemption (..),
+    RedeemedCode (..),
+    NewBadgeCodeRedemption (..),
+    getBadgeCode,
+    purchaseKeyExists,
+    writeCodeRedemption,
+    insertBadgeCode,
+  )
+where
+
+import qualified Data.Aeson as J
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Int (Int64)
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime)
+import Simplex.Chat.Badges (BadgeCredential, BadgeMasterKey (..), BadgeType)
+import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus, BadgePurchaseStatus (..))
+import Simplex.Chat.Store.Shared (insertedRowId)
+import Simplex.Messaging.Agent.Store.DB (Binary (..))
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+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.SqlQQ (sql)
+#else
+import Database.SQLite.Simple (Only (..))
+import Database.SQLite.Simple.QQ (sql)
+#endif
+
+data IssuedCode = IssuedCode
+  { badgeCodeId :: Int64,
+    badgeType :: BadgeType,
+    redemption :: CodeRedemption
+  }
+
+-- A code that has a purchase is spent, even if its credential cannot be read. Treating that as
+-- an unredeemed code would issue a second credential for it.
+data CodeRedemption
+  = CodeUnredeemed
+  | CodeRedeemed RedeemedCode
+  | CodeRedeemedUnreadable
+
+data RedeemedCode = RedeemedCode
+  { 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
+  { badgeCodeId :: Int64,
+    issuanceId :: Text,
+    purchaseKey :: C.PublicKeyEd25519,
+    masterKey :: BadgeMasterKey,
+    badgeType :: BadgeType,
+    credential :: BadgeCredential,
+    periodStart :: UTCTime,
+    periodEnd :: UTCTime,
+    expiry :: UTCTime
+  }
+
+getBadgeCode :: DB.Connection -> ByteString -> IO (Maybe IssuedCode)
+getBadgeCode db codeHash =
+  maybeFirstRow toCode $
+    DB.query
+      db
+      [sql|
+        SELECT c.badge_code_id, c.badge_type, 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
+        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}
+        Nothing -> CodeRedeemedUnreadable
+    decodeCredential (Binary bs) = J.decodeStrict' bs
+
+purchaseKeyExists :: DB.Connection -> C.PublicKeyEd25519 -> IO Bool
+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
+  DB.execute
+    db
+    [sql|
+      INSERT INTO sx_badge_service_badge_purchases
+        (purchase_key, master_key, initial_badge_type, current_badge_type, status, badge_code_id, created_at, updated_at)
+      VALUES (?,?,?,?,?,?,?,?)
+    |]
+    (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)
+
+insertBadgeCode :: DB.Connection -> ByteString -> BadgeType -> Int -> BadgeCodePaymentStatus -> UTCTime -> IO ()
+insertBadgeCode db codeHash badgeType months paymentStatus now =
+  DB.execute
+    db
+    [sql|
+      INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at)
+      VALUES (?,?,?,?,?)
+    |]
+    (Binary codeHash, badgeType, months, paymentStatus, now)

apps/simplex-directory-service/src/Directory/Service.hs

@@ -47,9 +47,9 @@ import Directory.Options
 import Directory.Search
 import Directory.Store
 import Directory.Store.Migrate
-import Directory.Util
 import Simplex.Chat.Bot
 import Simplex.Chat.Bot.KnownContacts
+import Simplex.Chat.Bot.Store
 import Simplex.Chat.Controller
 import Simplex.Chat.Core
 import Simplex.Chat.Library.Internal (setGroupLinkData)

apps/simplex-directory-service/src/Directory/Store.hs

@@ -68,7 +68,7 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime (..), getCurrentTime)
 import Directory.Search
-import Directory.Util
+import Simplex.Chat.Bot.Store
 import Simplex.Chat.Controller
 import Simplex.Chat.Names (claimDomain)
 import Simplex.Chat.Options.DB (FromField (..), ToField (..))

bots/src/API/Docs/Commands.hs

@@ -398,6 +398,7 @@ undocumentedCommands =
     "APIPlanForwardChatItems",
     "APIPrepareContact",
     "APIPrepareGroup",
+    "APIRedeemBadgeCode",
     "APIRegisterToken",
     "APIRejectCall",
     "APIReorderChatTags",

bots/src/API/Docs/Responses.hs

@@ -129,6 +129,7 @@ undocumentedResponses =
     "CRAppSettings",
     "CRArchiveExported",
     "CRArchiveImported",
+    "CRBadgeRedeemed",
     "CRBroadcastSent",
     "CRCallInvitations",
     "CRChatCleared",

simplex-chat.cabal

@@ -40,6 +40,7 @@ library
       Simplex.Chat.AppSettings
       Simplex.Chat.Badges
       Simplex.Chat.Badges.CLI
+      Simplex.Chat.Badges.Code
       Simplex.Chat.Badges.Service
       Simplex.Chat.Badges.Types
       Simplex.Chat.Names
@@ -79,6 +80,7 @@ library
       Simplex.Chat.Stats
       Simplex.Chat.Store
       Simplex.Chat.Store.AppSettings
+      Simplex.Chat.Store.Badges
       Simplex.Chat.Store.Connections
       Simplex.Chat.Store.ContactRequest
       Simplex.Chat.Store.Delivery
@@ -103,6 +105,7 @@ library
       exposed-modules:
           Simplex.Chat.Bot
           Simplex.Chat.Bot.KnownContacts
+          Simplex.Chat.Bot.Store
           Simplex.Chat.Core
           Simplex.Chat.Help
           Simplex.Chat.Terminal
@@ -418,18 +421,23 @@ executable simplex-badge-service
   other-modules:
       BadgeService.Options
       BadgeService.Service
+      BadgeService.Store
       BadgeService.Store.Migrate
       Paths_simplex_chat
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -Werror=name-shadowing -threaded -rtsopts
   build-depends:
       aeson ==2.2.*
+    , attoparsec ==0.14.*
     , base >=4.7 && <5
+    , crypton ==0.34.*
     , directory ==1.3.*
+    , mtl >=2.3.1 && <3.0
     , optparse-applicative >=0.15 && <0.17
     , simple-logger ==0.1.*
     , simplex-chat
     , simplexmq >=6.3
     , stm ==2.5.*
+    , time ==1.12.*
   default-language: Haskell2010
   if flag(client_postgres)
     other-modules:
@@ -583,7 +591,6 @@ executable simplex-directory-service
       Directory.Service
       Directory.Store
       Directory.Store.Migrate
-      Directory.Util
       Paths_simplex_chat
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -Werror=name-shadowing -threaded -rtsopts
   build-depends:
@@ -679,6 +686,7 @@ test-suite simplex-chat-test
       API.TypeInfo
       BadgeService.Options
       BadgeService.Service
+      BadgeService.Store
       BadgeService.Store.Migrate
       Bots.BadgeServiceTests
       Broadcast.Bot
@@ -692,7 +700,6 @@ test-suite simplex-chat-test
       Directory.Service
       Directory.Store
       Directory.Store.Migrate
-      Directory.Util
       Paths_simplex_chat
   if flag(client_postgres)
       other-modules:

src/Simplex/Chat.hs

@@ -77,6 +77,7 @@ defaultChatConfig =
             (7, toBBSPublicKey "rl36D5mg2N3NmmEybxE_RBeU9YZ_zeXNPfp7ZMLtUEuf2Mo4OQM_Up1v5rX_IqICD-AIJcuyptEBsELx_PJQzpmiNuG5I4cWO6HkRKtc6fVFvgZMrDJjaascPd1CIyxX"),
             (8, toBBSPublicKey "joM3Bnt7JPt5JiwQwERHGjro2iVZ0mPD_clUh4hzkhxvbjuFrWuTmfSNA8PWBqGKEGNl13aRi1pMf6yY14E27c5C71JxWm7T-rZaBrGPEUWifhD-qidWuf3PU7KJCCWd")
           ],
+      badgeServiceAddress = Nothing,
       confirmMigrations = MCConsole,
       -- this property should NOT use operator = Nothing
       -- non-operator servers can be passed via options

src/Simplex/Chat/Badges/Code.hs

@@ -0,0 +1,118 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | 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:
+-- 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@.
+--
+-- 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
+-- and every transposition of adjacent characters except '0' next to 'Z' - the values 0 and
+-- N-1, which is Luhn's one blind spot at any base.
+--
+-- 'BadgeCode' is only constructed by 'parseBadgeCode' and 'randomBadgeCode', so a code
+-- whose check character fails cannot be hashed, looked up or sent.
+module Simplex.Chat.Badges.Code
+  ( BadgeCode,
+    parseBadgeCode,
+    randomBadgeCode,
+    badgeCodeText,
+    badgeCodeHash,
+    formatBadgeCode,
+  )
+where
+
+import Control.Concurrent.STM
+import Crypto.Random (ChaChaDRG)
+import Data.ByteString.Char8 (ByteString)
+import qualified Data.ByteString.Char8 as B
+import Data.Char (isAlphaNum, toUpper)
+import Data.List (elemIndex)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8)
+import qualified Simplex.Messaging.Crypto as C
+
+-- | A code that has passed its check character, in canonical form: 'codePrefix' followed by
+-- 20 upper-case alphabet characters, without separators.
+newtype BadgeCode = BadgeCode Text
+  deriving (Eq, Show)
+
+-- Crockford base32: the digits and the upper-case letters except I, L, O and U.
+alphabet :: String
+alphabet = "0123456789ABCDEFGHJKMNPQRSTVWXYZ"
+
+base :: Int
+base = 32
+
+codeLength :: Int
+codeLength = 20
+
+groupLength :: Int
+groupLength = 5
+
+codePrefix :: Text
+codePrefix = "SXB"
+
+-- | The Crockford value of a character, folding the omitted characters onto the digits they
+-- are mistaken for.
+charValue :: Char -> Maybe Int
+charValue c = case toUpper c of
+  'I' -> Just 1
+  'L' -> Just 1
+  'O' -> Just 0
+  u -> elemIndex u alphabet
+
+valueChar :: Int -> Char
+valueChar v = alphabet !! v
+
+-- | Luhn mod N (N = 32): the value that makes the whole code sum to zero modulo the base.
+checkValue :: [Int] -> Int
+checkValue payload = (base - total `mod` base) `mod` base
+  where
+    -- doubling every second value from the right, as the check character sits to the right of the payload
+    total = fst $ foldr step (0, 2) payload
+    step v (sum', factor) =
+      let addend = factor * v
+       in (sum' + addend `div` base + addend `mod` base, if factor == 2 then 1 else 2)
+
+-- | Read a code as typed: any case, separators optional, ambiguous characters folded.
+-- 'Nothing' for anything not well-formed, a failed check character included.
+parseBadgeCode :: Text -> Maybe BadgeCode
+parseBadgeCode t = do
+  body <- T.stripPrefix codePrefix $ T.toUpper $ T.filter isAlphaNum t
+  vs <- mapM charValue $ T.unpack body
+  let (payload, checkChar) = splitAt (codeLength - 1) vs
+  if T.length body == codeLength && checkChar == [checkValue payload]
+    -- rebuilt from the values, not from body: that is what folds I/L/O into the canonical form
+    then Just $ BadgeCode $ codePrefix <> T.pack (map valueChar vs)
+    else Nothing
+
+-- | A new code from the CSPRNG. 256 is a multiple of the base, so a byte reduces without bias.
+randomBadgeCode :: TVar ChaChaDRG -> IO BadgeCode
+randomBadgeCode drg = do
+  bs <- atomically $ C.randomBytes (codeLength - 1) drg
+  let payload = map ((`mod` base) . fromEnum) $ B.unpack bs
+      vs = payload <> [checkValue payload]
+  pure $ BadgeCode $ codePrefix <> T.pack (map valueChar vs)
+
+-- | The canonical form: the only representation of a code that is hashed or sent.
+badgeCodeText :: BadgeCode -> Text
+badgeCodeText (BadgeCode t) = t
+
+-- | The only thing about a code stored service-side: SHA-256 over the ASCII bytes of the
+-- canonical form, prefix included.
+badgeCodeHash :: BadgeCode -> ByteString
+badgeCodeHash = C.sha256Hash . encodeUtf8 . badgeCodeText
+
+-- | The code as it is shown and printed, in four groups of five.
+formatBadgeCode :: BadgeCode -> Text
+formatBadgeCode (BadgeCode t) = T.intercalate "-" $ codePrefix : groups (T.drop (T.length codePrefix) t)
+  where
+    groups s
+      | T.null s = []
+      | otherwise = let (g, rest) = T.splitAt groupLength s in g : groups rest

src/Simplex/Chat/Badges/Service.hs

@@ -3,13 +3,18 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.Badges.Service
   ( BadgeServiceRequest (..),
     BadgeServiceCommand (..),
     BadgeServiceVersion,
     VersionBadgeService,
+    VersionRangeBadgeService,
     pattern VersionBadgeService,
+    initialBadgeServiceVersion,
+    currentBadgeServiceVersion,
+    supportedBadgeServiceVRange,
     BadgeUpgrade (..),
     BadgeServiceResponse (..),
     BadgeServiceErrorCode (..),
@@ -24,9 +29,12 @@ module Simplex.Chat.Badges.Service
     StatementDebitType (..),
   ) where
 
-import Data.Aeson (FromJSON (..), ToJSON (..))
+import Control.Applicative ((<|>))
+import Data.Aeson (FromJSON (..), ToJSON (..), (.:))
 import qualified Data.Aeson as J
-import Data.Int (Int64)
+import qualified Data.Aeson.Encoding as JE
+import qualified Data.Aeson.TH as JQ
+import qualified Data.Aeson.Types as JT
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Data.Word (Word8, Word16, Word32)
@@ -35,7 +43,8 @@ import Simplex.Chat.Badges.Types
 import Simplex.Chat.PaymentService
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Version (VersionScope)
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
+import Simplex.Messaging.Version (VersionRange, VersionScope, mkVersionRange)
 import Simplex.Messaging.Version.Internal (Version (..))
 
 data BadgeServiceVersion
@@ -47,6 +56,18 @@ type VersionBadgeService = Version BadgeServiceVersion
 pattern VersionBadgeService :: Word16 -> VersionBadgeService
 pattern VersionBadgeService v = Version v
 
+type VersionRangeBadgeService = VersionRange BadgeServiceVersion
+
+initialBadgeServiceVersion :: VersionBadgeService
+initialBadgeServiceVersion = VersionBadgeService 1
+
+currentBadgeServiceVersion :: VersionBadgeService
+currentBadgeServiceVersion = VersionBadgeService 1
+
+-- the service is deployed ahead of app releases, so it answers within the client's version
+supportedBadgeServiceVRange :: VersionRangeBadgeService
+supportedBadgeServiceVRange = mkVersionRange initialBadgeServiceVersion currentBadgeServiceVersion
+
 data BadgeServiceRequest = BadgeServiceRequest
   { version :: VersionBadgeService,
     purchaseKey :: Maybe C.PublicKeyEd25519, -- optional for BSCGetBadgeCatalog, required for other commands
@@ -164,7 +185,7 @@ data StatementEntryType = SECredit {credit :: StatementCreditType} | SEDebit {de
 
 data StatementCreditType
   = SCPayment {invoiceId :: Maybe InvoiceId} -- absent for store and code payments
-  | SCCharge {chargeId :: Int64}
+  | SCCharge {chargeId :: Text}
   | SCSupport
   | SCTransferIn {fromPurchaseKey :: C.PublicKeyEd25519}
   | SCOpening
@@ -248,3 +269,57 @@ instance ToJSON BadgeServiceErrorCode where
 
 instance FromJSON BadgeServiceErrorCode where
   parseJSON = textParseJSON "BadgeServiceErrorCode"
+
+$(pure [])
+
+instance FromJSON StatementCreditType where
+  parseJSON v@(J.Object j) =
+    $(JQ.mkParseJSON (taggedObjectJSON $ dropPrefix "SC") ''StatementCreditType) v
+      <|> SCUnknown <$> j .: "type" <*> pure j
+  parseJSON invalid =
+    JT.prependFailure "bad StatementCreditType, " (JT.typeMismatch "Object" invalid)
+
+instance ToJSON StatementCreditType where
+  toJSON = \case
+    SCUnknown _ j -> J.Object j
+    v -> $(JQ.mkToJSON (taggedObjectJSON $ dropPrefix "SC") ''StatementCreditType) v
+  toEncoding = \case
+    SCUnknown _ j -> JE.value $ J.Object j
+    v -> $(JQ.mkToEncoding (taggedObjectJSON $ dropPrefix "SC") ''StatementCreditType) v
+
+instance FromJSON StatementDebitType where
+  parseJSON v@(J.Object j) =
+    $(JQ.mkParseJSON (taggedObjectJSON $ dropPrefix "SD") ''StatementDebitType) v
+      <|> SDUnknown <$> j .: "type" <*> pure j
+  parseJSON invalid =
+    JT.prependFailure "bad StatementDebitType, " (JT.typeMismatch "Object" invalid)
+
+instance ToJSON StatementDebitType where
+  toJSON = \case
+    SDUnknown _ j -> J.Object j
+    v -> $(JQ.mkToJSON (taggedObjectJSON $ dropPrefix "SD") ''StatementDebitType) v
+  toEncoding = \case
+    SDUnknown _ j -> JE.value $ J.Object j
+    v -> $(JQ.mkToEncoding (taggedObjectJSON $ dropPrefix "SD") ''StatementDebitType) v
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SE") ''StatementEntryType)
+
+$(JQ.deriveJSON defaultJSON ''StatementEntry)
+
+$(JQ.deriveJSON defaultJSON ''BadgeStatement)
+
+$(JQ.deriveJSON defaultJSON ''BadgeBalance)
+
+$(JQ.deriveJSON defaultJSON ''BadgeUpgrade)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "BSC") ''BadgeServiceCommand)
+
+$(JQ.deriveJSON defaultJSON ''BadgeServiceRequest)
+
+$(JQ.deriveJSON defaultJSON ''BadgePrice)
+
+$(JQ.deriveJSON defaultJSON ''BadgeOffer)
+
+$(JQ.deriveJSON defaultJSON ''BadgeCatalog)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "BSP") ''BadgeServiceResponse)

src/Simplex/Chat/Badges/Types.hs

@@ -1,6 +1,10 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.Badges.Types
   ( BadgePriceId (..),
@@ -22,7 +26,9 @@ module Simplex.Chat.Badges.Types
     UserBadgeState (..),
   ) where
 
+import Data.Aeson (FromJSON, ToJSON)
 import qualified Data.Aeson as J
+import qualified Data.Aeson.TH as JQ
 import Data.Int (Int64)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
@@ -30,15 +36,25 @@ import Data.Word (Word8)
 import Simplex.Chat.Badges hiding (BadgePurchase (..))
 import Simplex.Chat.PaymentService.Types (InvoiceId, 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)
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple.FromField (FromField (..))
+import Database.PostgreSQL.Simple.ToField (ToField (..))
+#else
+import Database.SQLite.Simple.FromField (FromField (..))
+import Database.SQLite.Simple.ToField (ToField (..))
+#endif
 
 -- confirmed
 newtype BadgePriceId = BadgePriceId Text
-  deriving newtype (Eq, Show)
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
 
 -- confirmed
 newtype BadgeOfferId = BadgeOfferId Text
-  deriving newtype (Eq, Show)
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
 
 -- unconfirmed draft
 data BadgePlan = BPOneTime | BPMonthly | BPAnnual
@@ -172,3 +188,39 @@ data UserBadgeState = UserBadgeState
     willRenew :: Bool,
     alert :: Maybe BadgeAlert
   }
+
+instance TextEncoding BadgePurchaseStatus where
+  textEncode = \case
+    PSAcquiring -> "acquiring"
+    PSIssued -> "issued"
+    PSSuperseded -> "superseded"
+    PSFailed -> "failed"
+  textDecode = \case
+    "acquiring" -> Just PSAcquiring
+    "issued" -> Just PSIssued
+    "superseded" -> Just PSSuperseded
+    "failed" -> Just PSFailed
+    _ -> Nothing
+
+instance FromField BadgePurchaseStatus where fromField = fromTextField_ textDecode
+
+instance ToField BadgePurchaseStatus where toField = toField . textEncode
+
+instance TextEncoding BadgeCodePaymentStatus where
+  textEncode = \case
+    CPSPaid -> "paid"
+    CPSUnpaid -> "unpaid"
+    CPSFree -> "free"
+  textDecode = \case
+    "paid" -> Just CPSPaid
+    "unpaid" -> Just CPSUnpaid
+    "free" -> Just CPSFree
+    _ -> Nothing
+
+instance FromField BadgeCodePaymentStatus where fromField = fromTextField_ textDecode
+
+instance ToField BadgeCodePaymentStatus where toField = toField . textEncode
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "BIS") ''BadgeItemStatus)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "OD") ''OfferDiscount)

src/Simplex/Chat/Bot/Store.hs

@@ -3,7 +3,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Directory.Util where
+module Simplex.Chat.Bot.Store
+  ( storeCxt,
+    withDB,
+    withDB',
+  )
+where
 
 import Control.Logger.Simple
 import Control.Monad.Except

src/Simplex/Chat/Controller.hs

@@ -83,7 +83,7 @@ import Simplex.Messaging.Agent.Store.DB (SQLError)
 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)
+import Simplex.Chat.Badges (BadgeCredential, LocalBadge)
 import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import qualified Simplex.Messaging.Crypto.File as CF
@@ -143,6 +143,8 @@ data ChatConfig = ChatConfig
     chatVRange :: VersionRangeChat,
     -- issuer public keys by index: credentials and proofs name the key that signed them, for rotation
     badgePublicKeys :: Map Int BBSPublicKey,
+    -- Nothing until the badge service is deployed
+    badgeServiceAddress :: Maybe (ConnectTarget 'CMContact),
     confirmMigrations :: MigrationConfirmation,
     presetServers :: PresetServers,
     shortLinkPresetServers :: NonEmpty SMPServer,
@@ -638,6 +640,7 @@ data ChatCommand
   | UpdateProfileImage (Maybe ImageData) -- UserId (not used in UI)
   | 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
   | ShowProfileImage
   | SetUserFeature AChatFeature FeatureAllowed -- UserId (not used in UI)
   | SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed)
@@ -842,6 +845,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}
   | CRUserAcceptedGroupSent {user :: User, groupInfo :: GroupInfo, hostContact :: Maybe Contact}
   | CRUserDeletedMembers {user :: User, groupInfo :: GroupInfo, members :: [GroupMember], withMessages :: Bool, msgSigned :: Bool}
   | CRGroupsList {user :: User, groups :: [GroupInfo]}

src/Simplex/Chat/Library/Commands.hs

@@ -56,7 +56,9 @@ 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 (..), LocalBadge (..), maxXFTPFileSize, mkBadgeStatus, verifyCredential)
+import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), LocalBadge (..), maxXFTPFileSize, mkBadgeStatus, verifyCredential)
+import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode)
+import Simplex.Chat.Badges.Service (BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), currentBadgeServiceVersion)
 import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim)
 import Simplex.Chat.Call
 import Simplex.Chat.Controller
@@ -77,6 +79,7 @@ import Simplex.Chat.Library.Internal
 import Simplex.Chat.Stats
 import Simplex.Chat.Store
 import Simplex.Chat.Store.AppSettings
+import Simplex.Chat.Store.Badges
 import Simplex.Chat.Store.ContactRequest
 import Simplex.Chat.Store.Connections
 import Simplex.Chat.Store.Delivery
@@ -1464,26 +1467,8 @@ processChatCommand cxt nm = \case
             liftIO $ deleteContactRequest db user connReqId
             pure ct_
         pure $ CRContactRequestRejected user cReq ct_
-  APISendServiceRequest userId sendTarget requestTimeout signKey request -> withUserId userId $ \user -> do
-    cReq <- resolveServiceTarget user sendTarget
-    respData <- withAgent $ \a -> sendServiceRequestAsync a (aUserId user) cReq requestTimeout (C.unStored <$> signKey) (LB.toStrict $ J.encode request)
-    resp <- either (const $ throwCmdError "invalid service response") pure $ J.eitherDecodeStrict' respData
-    pure $ CRServiceResponse user resp
-    where
-      resolveServiceTarget user = \case
-        CTFullContact cReq -> pure cReq
-        CTShortContact (CTLink sLnk) -> resolveShortLink sLnk
-        CTShortContact (CTName SimplexNameInfo {nameType, nameDomain}) -> case nameType of
-          NTContact -> resolveDomain nameDomain
-          _ -> throwCmdError "service request target must be a contact"
-        CTDomain d -> resolveDomain d
-        where
-          resolveDomain d = do
-            nr <- withAgent $ \a -> resolveSimplexName a nm (aUserId user) d
-            case firstNameLink CCTContact (nrSimplexContact nr) of
-              Just sLnk -> resolveShortLink sLnk
-              Nothing -> throwChatError $ CESimplexDomainNotReady d SDENoValidLink
-          resolveShortLink sLnk = (\(_, _, cReq) -> cReq) <$> getShortLinkConnReq nm user sLnk
+  APISendServiceRequest userId sendTarget requestTimeout signKey request -> withUserId userId $ \user ->
+    CRServiceResponse user <$> sendServiceRequestTo nm user sendTarget requestTimeout (C.unStored <$> signKey) request
   APISendServiceResponse userId requestId responseData -> withUserId userId $ \user -> do
     let AgentInvId invId = requestId
     connId <- withAgent $ \a -> sendServiceReplyAsync a "" (aUserId user) invId (LB.toStrict $ J.encode responseData)
@@ -3552,6 +3537,7 @@ processChatCommand cxt nm = \case
           pure $ CRFileTransferStatus user fileStatus
   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
   SetBotCommands commands -> withUser $ \user@User {profile} -> do
     let LocalProfile {preferences} = profile
         prefs = Just (fromMaybe emptyChatPrefs preferences :: Preferences) {commands = Just commands}
@@ -5133,20 +5119,31 @@ createContactsSndFeatureItems user cts =
       CUPContact {preference} -> preference
       CUPUser {preference} -> preference
 
+-- | Verify an own credential against the configured issuer keys.
+-- Nothing means its key index is not among them, so this version cannot verify it at all.
+verifyOwnBadge :: BadgeCredential -> CM (Maybe Bool)
+verifyOwnBadge cred@(BadgeCredential keyIdx _ _ _) = do
+  keys <- asks $ badgePublicKeys . config
+  forM (M.lookup keyIdx keys) $ \key -> liftIO $ verifyCredential key cred
+
 -- attach an issued badge credential to the user's own profile and present it to all current contacts.
 -- the credential is stored once; every profile send generates a fresh single-use proof (see presentUserBadge).
 addUserBadge :: User -> BadgeCredential -> CM ()
-addUserBadge user cred@(BadgeCredential keyIdx _ _ info) = do
-  keys <- asks $ badgePublicKeys . config
-  key <- maybe (throwCmdError "unknown badge key index") pure $ M.lookup keyIdx keys
-  verified <- liftIO $ verifyCredential key cred
-  unless verified $ throwCmdError "badge credential does not verify against configured key"
-  now <- liftIO getCurrentTime
-  user' <- withFastStore' $ \db -> setUserBadge db user (Just (OwnBadge cred (mkBadgeStatus now (Just True) info)))
+addUserBadge user cred@(BadgeCredential _ _ _ info) =
+  verifyOwnBadge cred >>= \case
+    Nothing -> throwCmdError "unknown badge key index"
+    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)))
+      presentUserBadgeToContacts user'
+
+presentUserBadgeToContacts :: User -> CM ()
+presentUserBadgeToContacts user' = do
   asks currentUser >>= atomically . (`writeTVar` Just user')
   cxt <- asks $ mkStoreCxt . config
   contacts <- withFastStore' $ \db -> getUserContacts db cxt user'
-  withChatLock "addUserBadge" $ forM_ contacts $ \ct ->
+  withChatLock "presentUserBadge" $ forM_ contacts $ \ct ->
     case contactSendConn_ ct of
       Right conn
         | not (connIncognito conn) -> do
@@ -5155,6 +5152,95 @@ addUserBadge user cred@(BadgeCredential keyIdx _ _ info) = do
             void (sendDirectContactMessage user' ct' (XInfo p)) `catchAllErrors` eToView
       _ -> pure ()
 
+-- | The check character is verified before anything leaves the device, and the signing keys are
+-- 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
+  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
+  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
+      BSECodeUsed -> True
+      BSECodeExpired -> True
+      _ -> False
+
+-- | 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
+badgeServiceErrorText = \case
+  BSEUnknown t -> case T.filter errorCodeChar (T.take 32 t) of
+    "" -> "unknown"
+    t' -> t'
+  code -> textEncode code
+  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}) =
+  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"
+    -- 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 -> do
+      -- badge_issuances requires a period; a credential without an expiry has none to record
+      expiry <- maybe (throwCmdError "redeemed badge credential has no expiry") pure badgeExpiry
+      g <- asks random
+      now <- liftIO getCurrentTime
+      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 expiry 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
+
+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
+  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
+  where
+    resolveServiceTarget = \case
+      CTFullContact cReq -> pure cReq
+      CTShortContact (CTLink sLnk) -> resolveShortLink sLnk
+      CTShortContact (CTName SimplexNameInfo {nameType, nameDomain}) -> case nameType of
+        NTContact -> resolveDomain nameDomain
+        _ -> throwCmdError "service request target must be a contact"
+      CTDomain d -> resolveDomain d
+    resolveDomain d = do
+      nr <- withAgent $ \a -> resolveSimplexName a nm (aUserId user) d
+      case firstNameLink CCTContact (nrSimplexContact nr) of
+        Just sLnk -> resolveShortLink sLnk
+        Nothing -> throwChatError $ CESimplexDomainNotReady d SDENoValidLink
+    resolveShortLink sLnk = (\(_, _, cReq) -> cReq) <$> getShortLinkConnReq nm user sLnk
+
 assertDirectAllowed :: User -> MsgDirection -> Contact -> CMEventTag e -> CM ()
 assertDirectAllowed user dir ct event =
   unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $
@@ -5539,6 +5625,7 @@ chatCommandP =
       "/_accept" *> (APIAcceptContact <$> incognitoOnOffP <* A.space <*> A.decimal),
       "/_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),
       "/_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),

src/Simplex/Chat/PaymentService.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.PaymentService
   ( ServiceInvoice (..),
@@ -6,9 +7,11 @@ module Simplex.Chat.PaymentService
     module Simplex.Chat.PaymentService.Types,
   ) where
 
+import qualified Data.Aeson.TH as JQ
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Simplex.Chat.PaymentService.Types
+import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON)
 
 data ServiceInvoice = ServiceInvoice
   { invoiceId :: InvoiceId,
@@ -28,3 +31,7 @@ data ServicePayment
   | SPInvoice {invoiceId :: InvoiceId}
   | SPReceipt {receipt :: Text} -- transfer of unissued months
   deriving (Show)
+
+$(JQ.deriveJSON defaultJSON ''ServiceInvoice)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SP") ''ServicePayment)

src/Simplex/Chat/PaymentService/Types.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.PaymentService.Types
   ( CurrencyAmount (..),
@@ -19,18 +20,22 @@ module Simplex.Chat.PaymentService.Types
     PaymentStatus (..),
   ) where
 
+import Data.Aeson (FromJSON, ToJSON)
+import qualified Data.Aeson.TH as JQ
 import Data.ByteString.Char8 (ByteString)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Data.Word (Word32)
+import Simplex.Messaging.Parsers (dropPrefix, enumJSON, taggedObjectJSON)
 
 -- USD etc. are in minor units, following Stripe etc. convention
 newtype CurrencyAmount = CurrencyAmount Word32
   deriving (Eq, Show)
+  deriving newtype (ToJSON, FromJSON)
 
 -- confirmed
 newtype InvoiceId = InvoiceId Text
-  deriving newtype (Eq, Show)
+  deriving newtype (Eq, Show, ToJSON, FromJSON)
 
 -- confirmed
 newtype PaymentId = PaymentId Text
@@ -132,3 +137,11 @@ data PaymentTerm
 -- to review
 data PaymentStatus = PSPending | PSSettled | PSFailed {exception :: Text}
   deriving (Show)
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "CP") ''CardProvider)
+
+$(JQ.deriveJSON (enumJSON $ dropPrefix "CC") ''CryptoCurrency)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SPM") ''ServicePaymentMethod)
+
+$(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SPD") ''ServicePaymentDestination)

src/Simplex/Chat/Store/Badges.hs

@@ -0,0 +1,133 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Store.Badges
+  ( BadgeCodeRedemption (..),
+    getBadgeCodeRedemption,
+    createBadgeCodeRedemption,
+    deleteBadgeCodeRedemption,
+    createCodeBadgePurchase,
+  )
+where
+
+import Control.Concurrent.STM (TVar, atomically)
+import Crypto.Random (ChaChaDRG)
+import qualified Data.Aeson as J
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Int (Int64)
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime)
+import Simplex.Chat.Badges
+import Simplex.Chat.Badges.Types (BadgePurchaseStatus (..))
+import Simplex.Chat.Store.Shared (insertedRowId)
+import Simplex.Chat.Types
+import Simplex.Messaging.Agent.Store.DB (Binary (..))
+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)
+
+#if defined(dbPostgres)
+import Database.PostgreSQL.Simple (Only (..))
+import Database.PostgreSQL.Simple.SqlQQ (sql)
+#else
+import Database.SQLite.Simple (Only (..))
+import Database.SQLite.Simple.QQ (sql)
+#endif
+
+-- | The keys one redemption attempt is signed with, stashed before the request is sent so that a
+-- retry reaches the service as the same signer and is answered with the credential already issued.
+data BadgeCodeRedemption = BadgeCodeRedemption
+  { redemptionId :: Int64,
+    purchaseKey :: C.PublicKeyEd25519,
+    purchasePrivKey :: C.PrivateKeyEd25519,
+    masterKey :: BadgeMasterKey
+  }
+
+getBadgeCodeRedemption :: DB.Connection -> User -> Text -> IO (Maybe BadgeCodeRedemption)
+getBadgeCodeRedemption db User {userId} code =
+  maybeFirstRow toRedemption $
+    DB.query
+      db
+      [sql|
+        SELECT badge_code_redemption_id, purchase_key, purchase_priv_key, master_key
+        FROM badge_code_redemptions
+        WHERE user_id = ? AND code = ?
+      |]
+      (userId, code)
+  where
+    toRedemption (redemptionId, purchaseKey, purchasePrivKey, Binary mk) =
+      BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk}
+
+createBadgeCodeRedemption :: DB.Connection -> TVar ChaChaDRG -> User -> Text -> UTCTime -> IO BadgeCodeRedemption
+createBadgeCodeRedemption db g User {userId} code now = do
+  (purchaseKey, purchasePrivKey) <- atomically $ C.generateKeyPair g
+  masterKey@(BadgeMasterKey mk) <- generateMasterKey g
+  DB.execute
+    db
+    [sql|
+      INSERT INTO badge_code_redemptions (user_id, code, purchase_key, purchase_priv_key, master_key, created_at)
+      VALUES (?,?,?,?,?,?)
+    |]
+    (userId, code, purchaseKey, purchasePrivKey, Binary mk, now)
+  redemptionId <- insertedRowId db
+  pure BadgeCodeRedemption {redemptionId, purchaseKey, purchasePrivKey, masterKey}
+
+-- | Drop a stashed attempt whose code the service refused for good, unless a purchase already
+-- came from it - badge_purchases references this row.
+deleteBadgeCodeRedemption :: DB.Connection -> Int64 -> IO ()
+deleteBadgeCodeRedemption db redemptionId =
+  DB.execute
+    db
+    [sql|
+      DELETE FROM badge_code_redemptions
+      WHERE badge_code_redemption_id = ?
+        AND NOT EXISTS (SELECT 1 FROM badge_purchases WHERE badge_code_redemption_id = ?)
+    |]
+    (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. The expiry is passed in because
+-- badge_issuances requires one and the caller has already resolved it.
+createCodeBadgePurchase :: DB.Connection -> TVar ChaChaDRG -> User -> BadgeCodeRedemption -> BadgeCredential -> UTCTime -> UTCTime -> IO Bool
+createCodeBadgePurchase db g User {userId} redemption credential expiry now =
+  getCodeBadgePurchase db redemption >>= \case
+    Just _ -> pure 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|
+          INSERT INTO badge_purchases
+            (user_id, purchase_key, purchase_priv_key, master_key, initial_badge_type, current_badge_type, status, badge_code_redemption_id, created_at, updated_at)
+          VALUES (?,?,?,?,?,?,?,?,?,?)
+        |]
+        (userId, purchaseKey, purchasePrivKey, Binary mk, badgeType, badgeType, PSIssued, redemptionId, now, now)
+      purchaseId <- insertedRowId db
+      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 (?,?,?,?,?,?,?,?)
+        |]
+        (issuanceId, purchaseId, badgeType, now, expiry, expiry, Binary (LB.toStrict $ J.encode credential), now)
+      pure purchaseId
+
+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)

src/Simplex/Chat/Store/Postgres/Migrations/M20261001_user_badges.hs

@@ -251,7 +251,7 @@ CREATE TABLE badge_code_redemptions(
   purchase_priv_key BYTEA NOT NULL,
   master_key BYTEA NOT NULL,
   created_at TIMESTAMPTZ NOT NULL,
-  UNIQUE(code)
+  UNIQUE(user_id, code)
 );
 
 CREATE INDEX idx_badge_code_redemptions_user ON badge_code_redemptions(user_id);

src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql

@@ -1763,12 +1763,12 @@ ALTER TABLE test_chat_schema.xftp_file_descriptions ALTER COLUMN file_descr_id A
 
 
 ALTER TABLE ONLY test_chat_schema.badge_code_redemptions
-    ADD CONSTRAINT badge_code_redemptions_code_key UNIQUE (code);
+    ADD CONSTRAINT badge_code_redemptions_pkey PRIMARY KEY (badge_code_redemption_id);
 
 
 
 ALTER TABLE ONLY test_chat_schema.badge_code_redemptions
-    ADD CONSTRAINT badge_code_redemptions_pkey PRIMARY KEY (badge_code_redemption_id);
+    ADD CONSTRAINT badge_code_redemptions_user_id_code_key UNIQUE (user_id, code);
 
 
 

src/Simplex/Chat/Store/SQLite/Migrations/M20261001_user_badges.hs

@@ -252,7 +252,7 @@ CREATE TABLE badge_code_redemptions(
   purchase_priv_key BLOB NOT NULL,
   master_key BLOB NOT NULL,
   created_at TEXT NOT NULL,
-  UNIQUE(code)
+  UNIQUE(user_id, code)
 ) STRICT;
 
 CREATE INDEX idx_badge_code_redemptions_user ON badge_code_redemptions(user_id);

src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt

@@ -1203,6 +1203,19 @@ Query:
 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 (?,?,?,?,?,?,?,?)
+        
+Plan:
+
+Query: 
+          INSERT INTO badge_purchases
+            (user_id, purchase_key, purchase_priv_key, master_key, initial_badge_type, current_badge_type, status, badge_code_redemption_id, created_at, updated_at)
+          VALUES (?,?,?,?,?,?,?,?,?,?)
+        
+Plan:
+
 Query: 
           INSERT INTO chat_item_reactions
             (contact_id, shared_msg_id, reaction_sent, reaction, created_by_msg_id, reaction_ts)
@@ -3463,6 +3476,14 @@ Query:
 Plan:
 SEARCH connections USING INDEX idx_connections_to_subscribe (user_id=?)
 
+Query: 
+        SELECT badge_code_redemption_id, purchase_key, purchase_priv_key, master_key
+        FROM badge_code_redemptions
+        WHERE user_id = ? AND code = ?
+      
+Plan:
+SEARCH badge_code_redemptions USING INDEX sqlite_autoindex_badge_code_redemptions_1 (user_id=? AND code=?)
+
 Query: 
         SELECT c.agent_conn_id
         FROM connections c
@@ -4297,6 +4318,17 @@ SEARCH c USING INDEX idx_connections_to_subscribe (user_id=?)
 SEARCH m USING INTEGER PRIMARY KEY (rowid=?)
 SEARCH ug USING AUTOMATIC COVERING INDEX (group_id=?)
 
+Query: 
+      DELETE FROM badge_code_redemptions
+      WHERE badge_code_redemption_id = ?
+        AND NOT EXISTS (SELECT 1 FROM badge_purchases WHERE badge_code_redemption_id = ?)
+    
+Plan:
+SEARCH badge_code_redemptions USING INTEGER PRIMARY KEY (rowid=?)
+SCALAR SUBQUERY 1
+SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_code_redemption (badge_code_redemption_id=?)
+SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_code_redemption (badge_code_redemption_id=?)
+
 Query: 
       DELETE FROM chat_items
       WHERE group_scope_group_member_id = ?
@@ -4782,6 +4814,12 @@ LIST SUBQUERY 1
 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
 SEARCH groups USING COVERING INDEX idx_groups_group_profile_id (group_profile_id=?)
 
+Query: 
+      INSERT INTO badge_code_redemptions (user_id, code, purchase_key, purchase_priv_key, master_key, created_at)
+      VALUES (?,?,?,?,?,?)
+    
+Plan:
+
 Query: 
       INSERT INTO calls
         (contact_id, shared_call_id, call_uuid, chat_item_id, call_state, call_ts, user_id, created_at, updated_at)
@@ -6944,6 +6982,8 @@ SEARCH connections USING COVERING INDEX idx_connections_user_contact_link_id (us
 Query: DELETE FROM users WHERE user_id = ?
 Plan:
 SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
+SEARCH badge_code_redemptions USING COVERING INDEX idx_badge_code_redemptions_user (user_id=?)
+SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_user (user_id=?)
 SEARCH chat_relays USING COVERING INDEX idx_chat_relays_user_id (user_id=?)
 SEARCH chat_tags USING COVERING INDEX idx_chat_tags_user_id (user_id=?)
 SEARCH note_folders USING COVERING INDEX note_folders_user_id (user_id=?)
@@ -7177,6 +7217,10 @@ Query: SELECT auth_err_counter FROM connections WHERE user_id = ? AND connection
 Plan:
 SEARCH connections USING INTEGER PRIMARY KEY (rowid=?)
 
+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=?)
+
 Query: SELECT c.agent_conn_id FROM connections c JOIN group_members m ON m.group_member_id = c.group_member_id WHERE m.local_display_name = ?
 Plan:
 SCAN m USING COVERING INDEX idx_group_members_user_id_local_display_name
@@ -7982,6 +8026,10 @@ Query: UPDATE users SET send_rcpts_small_groups = ? WHERE user_id = ?
 Plan:
 SEARCH users USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: UPDATE users SET shown_badge_id = ? WHERE user_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=?)

src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql

@@ -996,7 +996,7 @@ CREATE TABLE badge_code_redemptions(
   purchase_priv_key BLOB NOT NULL,
   master_key BLOB NOT NULL,
   created_at TEXT NOT NULL,
-  UNIQUE(code)
+  UNIQUE(user_id, code)
 ) STRICT;
 CREATE INDEX contact_profiles_index ON contact_profiles(
   display_name,

src/Simplex/Chat/View.hs

@@ -188,6 +188,8 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
   CRContactRequestRejected u UserContactRequest {localDisplayName = c} _ct_ -> ttyUser u [ttyContact c <> ": contact request rejected"]
   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"]
   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

tests/BadgeTests.hs

@@ -1,19 +1,27 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module BadgeTests (badgeTests) where
 
+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.Clock.POSIX (posixSecondsToUTCTime)
 import qualified Data.Aeson as J
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Chat.Badges
+import Simplex.Chat.Badges.Code
+import Simplex.Chat.Badges.Service
 import Simplex.Messaging.Crypto.BBS
+import Simplex.Messaging.Version.Internal (Version (..))
 import Test.Hspec
 
 badgeTests :: Spec
@@ -27,6 +35,16 @@ badgeTests = do
   it "should treat lifetime badges as always active" testLifetimeBadge
   it "should accept unknown badge types" testUnknownBadgeType
   it "credential serializes to a paste-able token and back" testCredentialSerialization
+  describe "redemption codes" $ do
+    it "a generated code reads back" testCodeRoundTrip
+    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 "service protocol JSON" $ do
+    it "redeemBadgeCode request matches the schema" testRedeemRequestJSON
+    it "badgeCredential response matches the schema" testCredentialResponseJSON
+    it "error response matches the schema" testErrorResponseJSON
+    it "statement entries round-trip, unknown entry types verbatim" testStatementJSON
 
 proofOf :: BadgeProof -> BBSProof
 proofOf (BadgeProof _ _ p _) = p
@@ -140,3 +158,138 @@ issueBadgeProof bt expiry = do
   Right cred <- issueBadge testKeyIdx sk vreq
   Right badge <- generateBadgeProof pk cred (BBSPresHeader "test-nonce")
   pure (pk, badge)
+
+-- Redemption codes
+
+testCodeRoundTrip :: IO ()
+testCodeRoundTrip = do
+  drg <- C.newRandom
+  code <- randomBadgeCode drg
+  let formatted = formatBadgeCode code
+  T.length formatted `shouldBe` 27 -- SXB-XXXXX-XXXXX-XXXXX-XXXXX
+  T.take 4 formatted `shouldBe` "SXB-"
+  T.length (badgeCodeText code) `shouldBe` 23 -- the canonical form drops the separators
+  parseBadgeCode formatted `shouldBe` Just code
+  parseBadgeCode (badgeCodeText code) `shouldBe` Just code
+
+testCodeNormalisation :: IO ()
+testCodeNormalisation = do
+  drg <- C.newRandom
+  code <- randomBadgeCode drg
+  parseBadgeCode (T.toLower $ badgeCodeText code) `shouldBe` Just code
+  parseBadgeCode (T.replace "-" " " $ formatBadgeCode code) `shouldBe` Just code
+  -- a fixed code, because a random one contains no 0 or 1 about a quarter of the time and the
+  -- folding would then be asserted against nothing
+  let folded = T.map ambiguous fixedCode
+  folded `shouldNotBe` fixedCode
+  parseBadgeCode folded `shouldBe` parseBadgeCode fixedCode
+  parseBadgeCode fixedCode `shouldNotBe` Nothing
+  where
+    fixedCode = "SXB-0C0QS-XAQW1-N1VSA-R00Y3"
+    ambiguous = \case
+      '1' -> 'I'
+      '0' -> 'O'
+      c -> c
+
+testCodeCheckCharacter :: IO ()
+testCodeCheckCharacter = do
+  drg <- C.newRandom
+  code <- randomBadgeCode drg
+  let canonical = badgeCodeText code
+      -- every other value for the last character fails the check
+      wrong = T.init canonical <> T.singleton (if T.last canonical == 'Z' then 'Y' else 'Z')
+  parseBadgeCode wrong `shouldBe` Nothing
+  parseBadgeCode "" `shouldBe` Nothing
+  parseBadgeCode "SXB-00000-00000-00000-0000" `shouldBe` Nothing
+  parseBadgeCode (T.drop 3 canonical) `shouldBe` Nothing
+
+testCodeHash :: IO ()
+testCodeHash = do
+  drg <- C.newRandom
+  code <- randomBadgeCode drg
+  Just typed <- pure $ parseBadgeCode $ T.toLower $ formatBadgeCode code
+  badgeCodeHash typed `shouldBe` badgeCodeHash code
+
+-- Service protocol JSON, against docs/protocol/badges-rpc.schema.json
+
+testRedeemRequestJSON :: IO ()
+testRedeemRequestJSON = do
+  drg <- C.newRandom
+  mk <- generateMasterKey drg
+  (k, _) <- atomically $ C.generateKeyPair drg :: IO (C.KeyPair 'C.Ed25519)
+  code <- randomBadgeCode drg
+  let req = BadgeServiceRequest {version = Version 1, purchaseKey = Just k, request = BSCRedeemBadgeCode {masterKey = mk, code = badgeCodeText code}}
+  J.toJSON req
+    `shouldBe` J.object
+      [ "version" J..= (1 :: Int),
+        "purchaseKey" J..= k,
+        "request" J..= J.object ["type" J..= ("redeemBadgeCode" :: T.Text), "masterKey" J..= mk, "code" J..= badgeCodeText code]
+      ]
+  -- purchaseKey is optional in the schema, and a nullary command is a bare tagged object
+  J.toJSON BadgeServiceRequest {version = Version 1, purchaseKey = Nothing, request = BSCGetBadgeCatalog}
+    `shouldBe` J.object ["version" J..= (1 :: Int), "request" J..= J.object ["type" J..= ("getBadgeCatalog" :: T.Text)]]
+  roundTrips req
+
+testCredentialResponseJSON :: IO ()
+testCredentialResponseJSON = do
+  Right (_, sk) <- bbsKeyGen
+  drg <- C.newRandom
+  mk <- generateMasterKey drg
+  let info = BadgeInfo {badgeType = BTSupporter, badgeExpiry = Just futureTime, badgeExtra = ""}
+  Right cred <- issueBadge testKeyIdx sk (VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeInfo = info})
+  let resp = BSPBadgeCredential {credential = Just cred, receipt = Nothing, statement = BadgeStatement {entries = [], previousEntryId = Nothing}}
+  J.toJSON resp
+    `shouldBe` J.object
+      [ "type" J..= ("badgeCredential" :: T.Text),
+        "credential" J..= cred,
+        "statement" J..= J.object ["entries" J..= ([] :: [J.Value])]
+      ]
+  roundTrips resp
+
+testErrorResponseJSON :: IO ()
+testErrorResponseJSON = do
+  let resp = BSPError {code = BSECodeInvalid, message = Nothing, retryAfter = Nothing}
+  J.toJSON resp `shouldBe` J.object ["type" J..= ("error" :: T.Text), "code" J..= ("code_invalid" :: T.Text)]
+  J.toJSON BSPError {code = BSERateLimited, message = Just "slow down", retryAfter = Just 30}
+    `shouldBe` J.object ["type" J..= ("error" :: T.Text), "code" J..= ("rate_limited" :: T.Text), "message" J..= ("slow down" :: T.Text), "retryAfter" J..= (30 :: Int)]
+
+testStatementJSON :: IO ()
+testStatementJSON = do
+  let entry =
+        StatementEntry
+          { entryId = "e1",
+            changeMonths = 3,
+            balanceMonths = 3,
+            balanceStartTs = futureTime,
+            balanceBadgeType = BTSupporter,
+            wasPausedSince = Nothing,
+            createdAt = futureTime,
+            entryType = SECredit {credit = SCPayment {invoiceId = Nothing}}
+          }
+  -- the whole entry: the required fields, and wasPausedSince omitted rather than sent as null
+  J.toJSON entry
+    `shouldBe` J.object
+      [ "entryId" J..= ("e1" :: T.Text),
+        "changeMonths" J..= (3 :: Int),
+        "balanceMonths" J..= (3 :: Int),
+        "balanceStartTs" J..= futureTime,
+        "balanceBadgeType" J..= ("supporter" :: T.Text),
+        "createdAt" J..= futureTime,
+        "entryType" J..= entryType entry
+      ]
+  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)]]
+  -- 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
+    J.Success c@SCUnknown {tag} -> do
+      tag `shouldBe` "grant"
+      J.toJSON c `shouldBe` futureCredit
+    r -> expectationFailure $ "expected SCUnknown, got " <> show (fmap (const ()) r)
+
+-- decoding and re-encoding reproduces the encoding, without Eq on the protocol types
+roundTrips :: (HasCallStack, J.ToJSON a, J.FromJSON a) => a -> IO ()
+roundTrips x = case J.eitherDecode (J.encode x) of
+  Right x' -> J.toJSON (x' `asTypeOf` x) `shouldBe` J.toJSON x
+  Left e -> expectationFailure e

tests/Bots/BadgeServiceTests.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -10,17 +12,37 @@ import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Utils
 import Control.Concurrent (forkIO, killThread, threadDelay)
+import Control.Concurrent.STM (atomically, readTMVar)
 import Control.Exception (finally)
-import Simplex.Chat.Controller (ChatConfig)
+import qualified Data.ByteString.Char8 as B
+import Data.Char (toLower)
+import Data.Either (isLeft, isRight)
+import qualified Data.Map.Strict as M
+import qualified Data.Text as T
+import Simplex.Chat.Badges (BadgeType (..))
+import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeText, formatBadgeCode, parseBadgeCode, randomBadgeCode)
+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.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 System.FilePath ((</>))
 import Test.Hspec hiding (it)
 
 badgeServiceTests :: SpecWith TestParams
 badgeServiceTests = do
-  it "should respond with unsupported_version to redeem" testBadgeServiceRedeemUnsupported
+  it "should answer unsupported_version to unsupported command" testBadgeServiceUnsupported
+  it "should redeem an issued code into a badge a contact sees" testRedeemBadgeCode
+  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 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
 
 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}
@@ -28,8 +50,11 @@ badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDesc
 serviceDbPrefix :: FilePath
 serviceDbPrefix = "badge_service"
 
-mkBadgeServiceOpts :: TestParams -> BadgeServiceOpts
-mkBadgeServiceOpts TestParams {tmpPath = ps} =
+testIssuerKeyIdx :: Int
+testIssuerKeyIdx = 1
+
+mkBadgeServiceOpts :: TestParams -> BBSSecretKey -> BadgeServiceOpts
+mkBadgeServiceOpts TestParams {tmpPath = ps} secretKey =
   BadgeServiceOpts
     { coreOptions =
         testCoreOpts
@@ -45,15 +70,21 @@ mkBadgeServiceOpts TestParams {tmpPath = ps} =
       clientService = True,
       noAddress = False,
       runCLI = False,
+      issuerKey = Just BadgeIssuerKey {keyIdx = testIssuerKeyIdx, secretKey},
       testing = True
     }
 
-withBadgeService :: HasCallStack => TestParams -> (TestCC -> String -> IO ()) -> IO ()
+-- | 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
-  let opts = mkBadgeServiceOpts ps
+  Right (pk, sk) <- bbsKeyGen
+  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}
   withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure ()
   -- First start: badge service takes the CreateMyAddress branch.
-  runBadgeService testCfg opts (pure ())
+  runBadgeService svcCfg opts $ \_ -> pure ()
   -- Reopen the DB to read the link the service created.
   bsLink <- withTestChat ps serviceDbPrefix $ \bs -> do
     bs <## "subscribed 1 connections on server localhost"
@@ -61,21 +92,205 @@ withBadgeService ps test = do
     (sLink, _) <- getContactLinks bs False
     bs <## "auto_accept off"
     pure sLink
+  let clientCfg =
+        svcCfg {badgeServiceAddress = Just $ either (error . ("bad badge service address: " <>)) id $ strDecode (B.pack bsLink)}
   -- Second start: badge service takes the ShowMyAddress branch, then serves the test body.
-  runBadgeService testCfg opts $
-    withNewTestChatCfg ps testCfg "client" bobProfile $ \client ->
-      test client bsLink
+  runBadgeService svcCfg opts $ \env -> do
+    cc <- atomically $ readTMVar $ serviceCC env
+    test clientCfg bsLink cc
 
-runBadgeService :: ChatConfig -> BadgeServiceOpts -> IO () -> IO ()
+-- through the operator command the service actually exposes, not the function behind it
+issueCode :: HasCallStack => ChatController -> BadgeType -> Int -> IO BadgeCode
+issueCode cc badgeType months =
+  sendChatCmdStr cc ("//issue " <> T.unpack (textEncode badgeType) <> " " <> show months) >>= \case
+    Right (CRCustomChatResponse _ response) -> case T.stripPrefix "code " response of
+      Just c | Just code <- parseBadgeCode c -> pure code
+      _ -> error $ "unexpected issue response: " <> T.unpack response
+    r -> error $ "issue failed: " <> show (() <$ r)
+
+runBadgeService :: ChatConfig -> BadgeServiceOpts -> (ServiceState -> IO ()) -> IO ()
 runBadgeService cfg opts action = do
-  t <- forkIO $ badgeService opts cfg
+  env <- newServiceState
+  t <- forkIO $ badgeService opts cfg env
   threadDelay 500000
-  action `finally` killThread t
+  action env `finally` killThread t
 
-testBadgeServiceRedeemUnsupported :: HasCallStack => TestParams -> IO ()
-testBadgeServiceRedeemUnsupported ps =
-  withBadgeService ps $ \client bsLink -> do
-    let redeemReq =
-          "{\"version\":1,\"request\":{\"type\":\"purchaseBadge\",\"payment\":{\"type\":\"code\",\"code\":\"TEST-CODE\"}}}"
-    client ##> ("/_service_request 1 " <> bsLink <> " " <> redeemReq)
-    client <## "service response: {\"code\":\"unsupported_version\",\"type\":\"error\"}"
+codeArg :: BadgeCode -> String
+codeArg = T.unpack . formatBadgeCode
+
+testBadgeServiceUnsupported :: HasCallStack => TestParams -> IO ()
+testBadgeServiceUnsupported ps =
+  withBadgeService ps $ \clientCfg bsLink _ ->
+    withNewTestChatCfg ps clientCfg "client" bobProfile $ \client -> do
+      let req = "{\"version\":1,\"request\":{\"type\":\"pauseBadge\"}}"
+      client ##> ("/_service_request 1 " <> bsLink <> " " <> req)
+      client <## "service response: {\"code\":\"unsupported_version\",\"type\":\"error\"}"
+
+testRedeemBadgeCode :: HasCallStack => TestParams -> IO ()
+testRedeemBadgeCode ps =
+  withBadgeService ps $ \clientCfg _ cc ->
+    withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice ->
+      withNewTestChatCfg ps clientCfg "bob" bobProfile $ \bob -> do
+        connectUsers alice bob
+        code <- issueCode cc BTSupporter 1
+        -- the service has never seen this purchase key: a first redemption must still succeed
+        alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
+        alice <## "badge redeemed"
+        alice <## "supporter badge - active"
+        alice <##. "expires "
+        alice ##> "/p"
+        alice <## "user profile: alice (Alice, * supporter)"
+        alice <## "use /p <name> [<bio>] to change it"
+        alice #> "@bob hi"
+        bob <# "alice *> hi"
+        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
+
+testRedeemBadgeCodeTwice :: HasCallStack => TestParams -> IO ()
+testRedeemBadgeCodeTwice ps =
+  withBadgeService ps $ \clientCfg _ cc ->
+    withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueCode cc BTSupporter 1
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
+      alice <## "badge redeemed"
+      alice <## "supporter badge - active"
+      alice <##. "expires "
+      -- Retyped in another case and without separators, so it normalises to the same code and
+      -- finds the same stashed keys: a retry the service can recognise as the same signer.
+      alice ##> ("/_redeem_badge_code 1 " <> map toLower (T.unpack $ badgeCodeText code))
+      alice <## "badge already redeemed"
+      alice ##> "/p"
+      alice <## "user profile: alice (Alice, * supporter)"
+      alice <## "use /p <name> [<bio>] to change it"
+
+-- The service answers unknown and malformed alike; the client refuses malformed locally, which
+-- is why the two reach the user differently.
+testRedeemUnknownCode :: HasCallStack => TestParams -> IO ()
+testRedeemUnknownCode ps =
+  withBadgeService ps $ \clientCfg bsLink _ ->
+    withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do
+      g <- C.newRandom
+      unknown <- randomBadgeCode g
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg unknown)
+      alice <## "bad chat command: badge service error: code_invalid"
+      -- a failed check character is refused before anything leaves the device
+      alice ##> "/_redeem_badge_code 1 SXB-00000-00000-00000-00001"
+      alice <## "bad chat command: invalid badge code"
+      -- sent straight to the service, past the client's own check, the two are one answer
+      (_, redeemPriv) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519)
+      redeemDirect alice bsLink redeemPriv (T.unpack $ badgeCodeText unknown)
+      alice <## "service response: {\"code\":\"code_invalid\",\"type\":\"error\"}"
+      redeemDirect alice bsLink redeemPriv "SXB-00000-00000-00000-00001"
+      alice <## "service response: {\"code\":\"code_invalid\",\"type\":\"error\"}"
+
+-- a signed redeemBadgeCode sent as a raw service request, bypassing the client's own checks
+redeemDirect :: HasCallStack => TestCC -> String -> C.PrivateKeyEd25519 -> String -> IO ()
+redeemDirect cc bsLink signPriv code = do
+  let purchaseKey = B.unpack $ strEncode $ C.publicKey signPriv
+      signKey = B.unpack $ strEncode (C.StoredPrivateKey signPriv)
+      req =
+        "{\"version\":1,\"purchaseKey\":\"" <> purchaseKey
+          <> "\",\"request\":{\"type\":\"redeemBadgeCode\",\"masterKey\":\"" <> testMasterKeyB64
+          <> "\",\"code\":\"" <> code <> "\"}}"
+  cc ##> ("/_service_request 1 " <> bsLink <> " sign_key=" <> signKey <> " " <> req)
+
+-- any 32 bytes: these requests never reach signing
+testMasterKeyB64 :: String
+testMasterKeyB64 = "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA="
+
+-- BadgeType decodes anything to BTUnknown, so without a check at this boundary an operator
+-- typo would issue a code no app can show as a badge.
+testIssueRejectsBadArguments :: HasCallStack => TestParams -> IO ()
+testIssueRejectsBadArguments ps =
+  withBadgeService ps $ \_ _ cc -> do
+    let refuses arg = issueRaw cc arg >>= (`shouldSatisfy` isLeft)
+    refuses "suporter"
+    refuses "supporter 0"
+    refuses "supporter 256"
+    refuses "supporter 1 gratis"
+    refuses ""
+    issueRaw cc "supporter 255 paid" >>= (`shouldSatisfy` isRight)
+
+issueRaw :: ChatController -> String -> IO (Either () ())
+issueRaw cc args =
+  sendChatCmdStr cc ("//issue " <> args) >>= \case
+    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.
+testRedeemSecondCode :: HasCallStack => TestParams -> IO ()
+testRedeemSecondCode ps =
+  withBadgeService ps $ \clientCfg _ cc ->
+    withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do
+      supporter <- issueCode cc BTSupporter 1
+      legend <- issueCode cc BTLegend 1
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg supporter)
+      alice <## "badge redeemed"
+      alice <## "supporter badge - active"
+      alice <##. "expires "
+      alice ##> ("/_redeem_badge_code 1 " <> 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.
+testRedeemSameCodeOtherProfile :: HasCallStack => TestParams -> IO ()
+testRedeemSameCodeOtherProfile ps =
+  withBadgeService ps $ \clientCfg _ cc ->
+    withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do
+      code <- issueCode cc BTSupporter 1
+      alice ##> ("/_redeem_badge_code 1 " <> codeArg code)
+      alice <## "badge redeemed"
+      alice <## "supporter badge - active"
+      alice <##. "expires "
+      alice ##> "/create user alisa"
+      showActiveUser alice "alisa"
+      alice ##> ("/_redeem_badge_code 2 " <> codeArg code)
+      alice <## "bad chat command: badge service error: code_used"
+      alice ##> "/p"
+      showActiveUser alice "alisa"
+      alice ##> "/user alice"
+      showActiveUser alice "alice (Alice, * supporter)"
+
+testPurchaseKeyMismatch :: HasCallStack => TestParams -> IO ()
+testPurchaseKeyMismatch ps =
+  withBadgeService ps $ \clientCfg bsLink _ ->
+    withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do
+      g <- C.newRandom
+      (_, signPriv) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519)
+      (claimedPub, _) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519)
+      let signKey = B.unpack $ strEncode (C.StoredPrivateKey signPriv)
+          claimed = B.unpack $ strEncode claimedPub
+          req = "{\"version\":1,\"purchaseKey\":\"" <> claimed <> "\",\"request\":{\"type\":\"pauseBadge\"}}"
+      alice ##> ("/_service_request 1 " <> bsLink <> " sign_key=" <> signKey <> " " <> req)
+      alice <## "service response: {\"code\":\"bad_request\",\"type\":\"error\"}"
+
+-- A secret that is not the key clients trust at its index makes every credential unverifiable,
+-- and each code redeemed against it is spent for good - so the service must not start at all.
+testIssuerKeyMustMatchConfig :: HasCallStack => TestParams -> IO ()
+testIssuerKeyMustMatchConfig ps = do
+  Right (pk, sk) <- bbsKeyGen
+  Right (_, otherSk) <- bbsKeyGen
+  let optsFor sk' = mkBadgeServiceOpts ps sk'
+      cfg = testCfg {badgePublicKeys = M.singleton testIssuerKeyIdx pk}
+  checkIssuerKey (optsFor sk) cfg >>= (`shouldSatisfy` isRight)
+  checkIssuerKey (optsFor otherSk) cfg >>= (`shouldSatisfy` isLeft)
+  -- an index no client trusts is equally fatal
+  checkIssuerKey (optsFor sk) testCfg {badgePublicKeys = M.empty} >>= (`shouldSatisfy` isLeft)