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 (..))

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

@@ -1,31 +0,0 @@
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module Directory.Util where
-
-import Control.Logger.Simple
-import Control.Monad.Except
-import Data.Text (Text)
-import qualified Data.Text as T
-import Simplex.Chat.Controller
-import Simplex.Chat.Types
-import Simplex.Messaging.Agent.Store.Common (withTransaction)
-import qualified Simplex.Messaging.Agent.Store.DB as DB
-import Simplex.Messaging.Util (catchAll)
-
-storeCxt :: ChatController -> StoreCxt
-storeCxt ChatController {config} = mkStoreCxt config
-{-# INLINE storeCxt #-}
-
-withDB' :: Text -> ChatController -> (DB.Connection -> IO a) -> IO (Either String a)
-withDB' cxt cc a = withDB cxt cc $ ExceptT . fmap Right . a
-
-withDB :: Text -> ChatController -> (DB.Connection -> ExceptT String IO a) -> IO (Either String a)
-withDB cxt ChatController {chatStore} action = do
-  r_ <- withTransaction chatStore (runExceptT . action) `catchAll` (pure . Left . show)
-  case r_ of
-    Left e -> logError $ "Database error: " <> cxt <> " " <> T.pack e
-    Right _ -> pure ()
-  pure r_