core: simplex-badge-service scaffolding (#7353)

* core: simplex-badge-service scaffolding

* wip

* wip

* wip

* wip

* wip

* wip

* wip

* wip

* wip

* wip

* wip

* clean-up

---------

Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com>

.github/workflows/build.yml

@@ -15,6 +15,7 @@ on:
       - "apps/simplex-chat/**"
       - "apps/simplex-bot/**"
       - "apps/simplex-bot-advanced/**"
+      - "apps/simplex-badge-service/**"
       - "apps/simplex-broadcast-bot/**"
       - "apps/simplex-directory-service/**"
       - "tests/**"

apps/simplex-badge-service/Main.hs

@@ -0,0 +1,14 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Main where
+
+import BadgeService.Options (BadgeServiceOpts (..))
+import BadgeService.Service
+import Simplex.Chat.Terminal (terminalChatConfig)
+
+main :: IO ()
+main = do
+  opts@BadgeServiceOpts {runCLI} <- welcomeGetOpts
+  if runCLI
+    then badgeServiceCLI opts
+    else badgeService opts terminalChatConfig

apps/simplex-badge-service/README.md

@@ -0,0 +1,30 @@
+# SimpleX badge service
+
+Scaffolding for the SimpleX supporter-badge RPC service. The wire protocol is specified in [`docs/protocol/badges-rpc.md`](../../docs/protocol/badges-rpc.md), and the implementation plans live under [`plans/`](../../plans) (`2026-07-30-supporter-badges-v3-ux.md`, `2026-07-31-badges-core-implementation.md`, `2026-08-04-badges-mvp-scope.md`).
+
+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`,
+- 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`).
+
+Business logic — command dispatch, ledger writes, credential signing, provider webhooks — is left for follow-up per the plans.
+
+## Build
+
+Build prerequisites and the general contribution flow are in [`docs/CONTRIBUTING.md`](../../docs/CONTRIBUTING.md).
+
+```
+cabal build exe:simplex-badge-service
+```
+
+## Run
+
+```
+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).

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

@@ -0,0 +1,93 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module BadgeService.Options
+  ( BadgeServiceOpts (..),
+    getBadgeServiceOpts,
+    badgeServiceOpts,
+    mkChatOpts,
+  )
+where
+
+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)
+
+data BadgeServiceOpts = BadgeServiceOpts
+  { coreOptions :: CoreChatOpts,
+    serviceName :: T.Text,
+    clientService :: Bool,
+    noAddress :: Bool,
+    runCLI :: Bool,
+    testing :: Bool
+  }
+
+badgeServiceOpts :: FilePath -> FilePath -> Parser BadgeServiceOpts
+badgeServiceOpts appDir defaultDbName = do
+  coreOptions <- coreChatOptsP appDir defaultDbName
+  serviceName <-
+    strOption
+      ( long "service-name"
+          <> metavar "SERVICE_NAME"
+          <> help "The display name of the badge service bot, without *'s and spaces (SimpleX Badges)"
+          <> value "SimpleX Badges"
+      )
+  clientService <-
+    switch
+      ( long "client-service"
+          <> help "Use client service certificate"
+      )
+  noAddress <-
+    switch
+      ( long "no-address"
+          <> help "skip checking and creating service address"
+      )
+  runCLI <-
+    switch
+      ( long "run-cli"
+          <> help "Run badge service as CLI"
+      )
+  pure
+    BadgeServiceOpts
+      { coreOptions,
+        serviceName = T.pack serviceName,
+        clientService,
+        noAddress,
+        runCLI,
+        testing = False
+      }
+
+getBadgeServiceOpts :: FilePath -> FilePath -> IO BadgeServiceOpts
+getBadgeServiceOpts appDir defaultDbName =
+  execParser $
+    info
+      (helper <*> versionOption <*> badgeServiceOpts appDir defaultDbName)
+      (header versionStr <> fullDesc <> progDesc "Start SimpleX Badge Service with DB_FILE options")
+  where
+    versionStr = versionString versionNumber
+    versionOption = infoOption versionAndUpdate (long "version" <> short 'v' <> help "Show version")
+    versionAndUpdate = versionStr <> "\n" <> updateStr
+
+mkChatOpts :: BadgeServiceOpts -> ChatOpts
+mkChatOpts BadgeServiceOpts {coreOptions, serviceName, clientService} =
+  ChatOpts
+    { coreOptions,
+      chatCmd = "",
+      chatCmdDelay = 3,
+      chatCmdLog = CCLNone,
+      chatServerPort = Nothing,
+      optFilesFolder = Nothing,
+      optTempDirectory = Nothing,
+      showReactions = False,
+      showFullLinks = False,
+      allowInstantFiles = True,
+      autoAcceptFileSize = 0,
+      muteNotifications = True,
+      markRead = False,
+      createBot = Just CreateBotOpts {botDisplayName = serviceName, allowFiles = False, clientService},
+      userDisplayName = Nothing,
+      userImageFile = Nothing
+    }

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

@@ -0,0 +1,120 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module BadgeService.Service
+  ( welcomeGetOpts,
+    badgeService,
+    badgeServiceCLI,
+  )
+where
+
+import BadgeService.Options
+import BadgeService.Store.Migrate (runBadgeServiceMigrations)
+import Control.Concurrent.STM
+import Control.Logger.Simple
+import Control.Monad
+import qualified Data.Aeson as J
+import qualified Data.Aeson.KeyMap as KM
+import qualified Data.Text as T
+import Simplex.Chat.Badges.Service (BadgeServiceErrorCode (..))
+import Simplex.Chat.Bot (initializeBotAddress')
+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 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)
+  }
+
+newServiceState :: IO ServiceState
+newServiceState = do
+  serviceCC <- newEmptyTMVarIO
+  serviceRequestQ <- newTQueueIO
+  pure ServiceState {serviceCC, serviceRequestQ}
+
+welcomeGetOpts :: IO BadgeServiceOpts
+welcomeGetOpts = do
+  appDir <- getAppUserDataDirectory "simplex"
+  opts@BadgeServiceOpts {coreOptions, testing, serviceName} <- getBadgeServiceOpts appDir "simplex_badge_service"
+  unless testing $ do
+    putStrLn $ "SimpleX Badge Service v" ++ versionNumber
+    printDbOpts coreOptions
+    putStrLn $ "Service name: " ++ T.unpack serviceName
+  pure opts
+
+badgeService :: BadgeServiceOpts -> ChatConfig -> IO ()
+badgeService opts cfg = do
+  env <- newServiceState
+  let chatHooks =
+        defaultChatHooks
+          { preStartHook = Just $ badgePreStartHook opts,
+            postStartHook = Just $ badgePostStartHook opts env
+          }
+  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 ()
+
+badgeServiceCLI :: BadgeServiceOpts -> IO ()
+badgeServiceCLI opts = do
+  env <- newServiceState
+  let eventHook _cc ev = do
+        case ev of
+          Right (CEvtServiceRequest u reqId _sigKey reqData) ->
+            atomically $ writeTQueue (serviceRequestQ env) (u, reqId, reqData)
+          _ -> pure ()
+        pure ev
+      chatHooks =
+        defaultChatHooks
+          { preStartHook = Just $ badgePreStartHook opts,
+            postStartHook = Just $ badgePostStartHook opts env,
+            eventHook = Just eventHook
+          }
+  raceAny_
+    [ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing,
+      processQueuedRequests env
+    ]
+
+processQueuedRequests :: ServiceState -> IO ()
+processQueuedRequests env = do
+  cc <- atomically $ readTMVar $ serviceCC env
+  forever $ do
+    (u, reqId, reqData) <- atomically $ readTQueue $ serviceRequestQ env
+    handleServiceRequest cc u reqId reqData
+
+badgePreStartHook :: BadgeServiceOpts -> ChatController -> IO ()
+badgePreStartHook opts ChatController {config, chatStore} =
+  runBadgeServiceMigrations opts config chatStore
+
+badgePostStartHook :: BadgeServiceOpts -> ServiceState -> ChatController -> IO ()
+badgePostStartHook BadgeServiceOpts {noAddress, testing} env cc = do
+  -- SREQ delivery gates on this flag; Core starts serviceRequests=False, so the hook must set it.
+  atomically $ writeTVar (processServiceRequests cc) True
+  readTVarIO (currentUser cc) >>= \case
+    Nothing -> putStrLn "No current user" >> exitFailure
+    -- DR required for service RPC; autoAccept off because badge service ignores contact events.
+    Just _ -> 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
+  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
+    Right _ -> pure ()
+    Left e -> logError $ "badge service response failed for " <> reqIdT <> ": " <> tshow e

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

@@ -0,0 +1,40 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module BadgeService.Store.Migrate
+  ( runBadgeServiceMigrations,
+  )
+where
+
+import BadgeService.Options
+import Simplex.Chat.Controller (ChatConfig (..))
+import Simplex.Chat.Options (CoreChatOpts (..))
+import Simplex.Chat.Options.DB
+import Simplex.Messaging.Agent.Store.Common
+import Simplex.Messaging.Agent.Store.Interface (migrateDBSchema)
+import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..))
+import System.Exit (exitFailure)
+
+#if defined(dbPostgres)
+import BadgeService.Store.Postgres.Migrations
+#else
+import BadgeService.Store.SQLite.Migrations
+#endif
+
+runBadgeServiceMigrations :: BadgeServiceOpts -> ChatConfig -> DBStore -> IO ()
+runBadgeServiceMigrations opts ChatConfig {confirmMigrations} chatStore =
+  migrateDBSchema
+    chatStore
+    (toDBOpts dbOptions chatSuffix False [])
+    (Just "sx_badge_service_migrations")
+    badgeServiceSchemaMigrations
+    MigrationConfig {confirm, backupPath = Nothing}
+    >>= either (exit . ("badge service migrations " <>) . show) pure
+  where
+    BadgeServiceOpts {coreOptions = CoreChatOpts {dbOptions, yesToUpMigrations}} = opts
+    confirm = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations
+
+exit :: String -> IO a
+exit err = putStrLn ("Error: " <> err) >> exitFailure

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

@@ -0,0 +1,37 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations) where
+
+import Data.List (sortOn)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Simplex.Messaging.Agent.Store.Shared (Migration (..))
+import Text.RawString.QQ (r)
+
+badgeServiceSchemaMigrations :: [Migration]
+badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations
+  where
+    migration (name, up, down) = Migration {name, up, down}
+
+schemaMigrations :: [(String, Text, Maybe Text)]
+schemaMigrations =
+  [ ("20260806_badge_service_schema", m20260806_badge_service_schema, Just down_m20260806_badge_service_schema)
+  ]
+
+m20260806_badge_service_schema :: Text
+m20260806_badge_service_schema =
+  T.pack
+    [r|
+CREATE TABLE sx_badge_service_test(
+  test_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY,
+  created_at TIMESTAMPTZ NOT NULL DEFAULT (now())
+);
+  |]
+
+down_m20260806_badge_service_schema :: Text
+down_m20260806_badge_service_schema =
+  T.pack
+    [r|
+DROP TABLE sx_badge_service_test;
+  |]

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

@@ -0,0 +1,34 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations) where
+
+import Data.List (sortOn)
+import Database.SQLite.Simple (Query (..))
+import Database.SQLite.Simple.QQ (sql)
+import Simplex.Messaging.Agent.Store.Shared (Migration (..))
+
+badgeServiceSchemaMigrations :: [Migration]
+badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations
+  where
+    migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down}
+
+schemaMigrations :: [(String, Query, Maybe Query)]
+schemaMigrations =
+  [ ("20260806_badge_service_schema", m20260806_badge_service_schema, Just down_m20260806_badge_service_schema)
+  ]
+
+m20260806_badge_service_schema :: Query
+m20260806_badge_service_schema =
+  [sql|
+CREATE TABLE sx_badge_service_test(
+  test_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  created_at TEXT NOT NULL DEFAULT(datetime('now'))
+);
+  |]
+
+down_m20260806_badge_service_schema :: Query
+down_m20260806_badge_service_schema =
+  [sql|
+DROP TABLE sx_badge_service_test;
+  |]

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

@@ -220,7 +220,7 @@ directoryPostStartHook opts@DirectoryOpts {noAddress, testing} env cc =
   readTVarIO (currentUser cc) >>= \case
     Nothing -> putStrLn "No current user" >> exitFailure
     Just User {userId, profile = p@LocalProfile {preferences}} -> do
-      unless noAddress $ initializeBotAddress' (not testing) cc
+      unless noAddress $ initializeBotAddress' (not testing) Nothing True cc
       void $ atomically $ tryPutTMVar (serviceCC env) cc
       listingsUpdated env
       let cmds = fromMaybe [] $ preferences >>= commands_

docs/protocol/badges-rpc.schema.json

@@ -363,14 +363,8 @@
         "error": {
           "properties": {
             "code": {
-              "enum": [
-                "bad_request", "unsupported_version", "unknown_purchase_key",
-                "unknown_offer_id", "offer_disabled", "offer_mismatch", "product_unavailable",
-                "payment_not_entitled", "payment_pending", "provider_unavailable", "rate_limited",
-                "code_invalid", "code_used", "code_expired",
-                "receipt_invalid", "receipt_used",
-                "internal"
-              ]
+              "type": "string",
+              "metadata": {"comment": "BadgeServiceErrorCode"}
             }
           },
           "optionalProperties": {

simplex-chat.cabal

@@ -398,6 +398,52 @@ library
       , template-haskell ==2.16.*
       , text >=1.2.4.0 && <1.3
 
+executable simplex-badge-service
+  if flag(client_library)
+      buildable: False
+  main-is: Main.hs
+  hs-source-dirs:
+      apps/simplex-badge-service
+      apps/simplex-badge-service/src
+  default-extensions:
+      StrictData
+  other-modules:
+      BadgeService.Options
+      BadgeService.Service
+      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.*
+    , base >=4.7 && <5
+    , directory ==1.3.*
+    , optparse-applicative >=0.15 && <0.17
+    , simple-logger ==0.1.*
+    , simplex-chat
+    , simplexmq >=6.3
+    , stm ==2.5.*
+  default-language: Haskell2010
+  if flag(client_postgres)
+    other-modules:
+        BadgeService.Store.Postgres.Migrations
+    build-depends:
+        postgresql-simple ==0.7.*
+        , raw-strings-qq ==1.1.*
+    cpp-options: -DdbPostgres
+  else
+    other-modules:
+        BadgeService.Store.SQLite.Migrations
+    build-depends:
+        sqlcipher-simple ==0.4.*
+  if impl(ghc >= 9.6.2)
+    build-depends:
+        bytestring ==0.11.*
+      , text >=2.0.1 && <2.2
+  if impl(ghc < 9.6.2)
+    build-depends:
+        bytestring ==0.10.*
+      , text >=1.2.4.0 && <1.3
+
 executable simplex-bot
   if flag(client_library)
       buildable: False
@@ -623,6 +669,10 @@ test-suite simplex-chat-test
       API.Docs.Syntax.Types
       API.Docs.Types
       API.TypeInfo
+      BadgeService.Options
+      BadgeService.Service
+      BadgeService.Store.Migrate
+      Bots.BadgeServiceTests
       Broadcast.Bot
       Broadcast.Options
       Directory.BlockedWords
@@ -649,6 +699,7 @@ test-suite simplex-chat-test
   hs-source-dirs:
       bots/src
       tests
+      apps/simplex-badge-service/src
       apps/simplex-broadcast-bot/src
       apps/simplex-directory-service/src
   default-extensions:
@@ -691,6 +742,7 @@ test-suite simplex-chat-test
   default-language: Haskell2010
   if flag(client_postgres)
     other-modules:
+        BadgeService.Store.Postgres.Migrations
         Directory.Store.Postgres.Migrations
     build-depends:
         postgresql-simple ==0.7.*
@@ -698,6 +750,7 @@ test-suite simplex-chat-test
     cpp-options: -DdbPostgres
   else
     other-modules:
+        BadgeService.Store.SQLite.Migrations
         Directory.Store.SQLite.Migrations
     build-depends:
         sqlcipher-simple ==0.4.*

src/Simplex/Chat/Badges/Service.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 
 module Simplex.Chat.Badges.Service
@@ -28,6 +30,7 @@ module Simplex.Chat.Badges.Service
     StatementDebitType (..),
   ) where
 
+import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson as J
 import Data.Int (Int64)
 import Data.Text (Text)
@@ -36,6 +39,7 @@ import Data.Word (Word8, Word16, Word32)
 import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Store
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Version (VersionScope)
 import Simplex.Messaging.Version.Internal (Version (..))
 
@@ -241,4 +245,52 @@ data BadgeServiceErrorCode
   | BSEReceiptInvalid
   | BSEReceiptUsed
   | BSEInternal
+  | BSEUnknown Text -- forwards-compatible: service is deployed ahead of clients
   deriving (Eq, Show)
+
+instance TextEncoding BadgeServiceErrorCode where
+  textEncode = \case
+    BSEBadRequest -> "bad_request"
+    BSEUnsupportedVersion -> "unsupported_version"
+    BSEUnknownPurchaseKey -> "unknown_purchase_key"
+    BSEUnknownOfferId -> "unknown_offer_id"
+    BSEOfferDisabled -> "offer_disabled"
+    BSEOfferMismatch -> "offer_mismatch"
+    BSEProductUnavailable -> "product_unavailable"
+    BSEPaymentNotEntitled -> "payment_not_entitled"
+    BSEPaymentPending -> "payment_pending"
+    BSEProviderUnavailable -> "provider_unavailable"
+    BSERateLimited -> "rate_limited"
+    BSECodeInvalid -> "code_invalid"
+    BSECodeUsed -> "code_used"
+    BSECodeExpired -> "code_expired"
+    BSEReceiptInvalid -> "receipt_invalid"
+    BSEReceiptUsed -> "receipt_used"
+    BSEInternal -> "internal"
+    BSEUnknown t -> t
+  textDecode s = Just $ case s of
+    "bad_request" -> BSEBadRequest
+    "unsupported_version" -> BSEUnsupportedVersion
+    "unknown_purchase_key" -> BSEUnknownPurchaseKey
+    "unknown_offer_id" -> BSEUnknownOfferId
+    "offer_disabled" -> BSEOfferDisabled
+    "offer_mismatch" -> BSEOfferMismatch
+    "product_unavailable" -> BSEProductUnavailable
+    "payment_not_entitled" -> BSEPaymentNotEntitled
+    "payment_pending" -> BSEPaymentPending
+    "provider_unavailable" -> BSEProviderUnavailable
+    "rate_limited" -> BSERateLimited
+    "code_invalid" -> BSECodeInvalid
+    "code_used" -> BSECodeUsed
+    "code_expired" -> BSECodeExpired
+    "receipt_invalid" -> BSEReceiptInvalid
+    "receipt_used" -> BSEReceiptUsed
+    "internal" -> BSEInternal
+    t -> BSEUnknown t
+
+instance ToJSON BadgeServiceErrorCode where
+  toJSON = textToJSON
+  toEncoding = textToEncoding
+
+instance FromJSON BadgeServiceErrorCode where
+  parseJSON = textParseJSON "BadgeServiceErrorCode"

src/Simplex/Chat/Bot.hs

@@ -47,16 +47,17 @@ chatBotRepl welcome answer _user cc = do
     contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected"
 
 initializeBotAddress :: ChatController -> IO ()
-initializeBotAddress = initializeBotAddress' True
+initializeBotAddress = initializeBotAddress' True Nothing True
 
-initializeBotAddress' :: Bool -> ChatController -> IO ()
-initializeBotAddress' logAddress cc = do
+-- pqRatchet_ selects the address type when creating: Just True (IKUsePQ) is required for service RPC, Nothing is the legacy non-DR contact address.
+initializeBotAddress' :: Bool -> Maybe Bool -> Bool -> ChatController -> IO ()
+initializeBotAddress' logAddress pqRatchet_ doAutoAccept cc = do
   sendChatCmd cc ShowMyAddress >>= \case
     Right (CRUserContactLink _ UserContactLink {connLinkContact}) -> showBotAddress connLinkContact
     Left (ChatErrorStore SEUserContactLinkNotFound) -> do
       when logAddress $ putStrLn "No bot address, creating..."
       -- TODO [short links] create short link by default
-      sendChatCmd cc (CreateMyAddress Nothing) >>= \case
+      sendChatCmd cc (CreateMyAddress pqRatchet_) >>= \case
         Right (CRUserContactLinkCreated _ ccLink) -> showBotAddress ccLink
         _ -> putStrLn "can't create bot address" >> exitFailure
     _ -> putStrLn "unexpected response" >> exitFailure
@@ -65,7 +66,8 @@ initializeBotAddress' logAddress cc = do
       when logAddress $ do
         putStrLn $ "Bot's contact address is: " <> B.unpack (maybe (strEncode uri) strEncode shortUri)
         when (isJust shortUri) $ putStrLn $ "Full contact address for old clients: " <> B.unpack (strEncode uri)
-      let settings = AddressSettings {businessAddress = False, autoAccept = Just AutoAccept {acceptIncognito = False}, autoReply = Nothing}
+      let aa = if doAutoAccept then Just AutoAccept {acceptIncognito = False} else Nothing
+          settings = AddressSettings {businessAddress = False, autoAccept = aa, autoReply = Nothing}
       void $ sendChatCmd cc $ SetAddressSettings Nothing settings
 
 sendMessage :: ChatController -> Contact -> Text -> IO ()

tests/Bots/BadgeServiceTests.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bots.BadgeServiceTests where
+
+import BadgeService.Options
+import BadgeService.Service
+import ChatClient
+import ChatTests.DBUtils
+import ChatTests.Utils
+import Control.Concurrent (forkIO, killThread, threadDelay)
+import Control.Exception (finally)
+import Simplex.Chat.Controller (ChatConfig)
+import Simplex.Chat.Options (CoreChatOpts (..))
+import Simplex.Chat.Options.DB
+import Simplex.Chat.Types (ChatPeerType (..), Profile (..))
+import System.FilePath ((</>))
+import Test.Hspec hiding (it)
+
+badgeServiceTests :: SpecWith TestParams
+badgeServiceTests = do
+  it "should respond with unsupported_version to redeem" testBadgeServiceRedeemUnsupported
+
+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}
+
+serviceDbPrefix :: FilePath
+serviceDbPrefix = "badge_service"
+
+mkBadgeServiceOpts :: TestParams -> BadgeServiceOpts
+mkBadgeServiceOpts TestParams {tmpPath = ps} =
+  BadgeServiceOpts
+    { coreOptions =
+        testCoreOpts
+          { dbOptions =
+              (dbOptions testCoreOpts)
+#if defined(dbPostgres)
+                {dbSchemaPrefix = "client_" <> serviceDbPrefix}
+#else
+                {dbFilePrefix = ps </> serviceDbPrefix}
+#endif
+          },
+      serviceName = "SimpleX Badges",
+      clientService = True,
+      noAddress = False,
+      runCLI = False,
+      testing = True
+    }
+
+withBadgeService :: HasCallStack => TestParams -> (TestCC -> String -> IO ()) -> IO ()
+withBadgeService ps test = do
+  let opts = mkBadgeServiceOpts ps
+  withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure ()
+  -- First start: badge service takes the CreateMyAddress branch.
+  runBadgeService testCfg 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"
+    bs ##> "/sa"
+    (sLink, _) <- getContactLinks bs False
+    bs <## "auto_accept off"
+    pure sLink
+  -- 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 :: ChatConfig -> BadgeServiceOpts -> IO () -> IO ()
+runBadgeService cfg opts action = do
+  t <- forkIO $ badgeService opts cfg
+  threadDelay 500000
+  action `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\"}"

tests/Test.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TupleSections #-}
 
+import Bots.BadgeServiceTests
 import Bots.BroadcastTests
 import Bots.DirectoryTests
 import ChatClient
@@ -88,6 +89,7 @@ main = do
           describe "SimpleX chat client" chatTests
           xdescribe'' "SimpleX Broadcast bot" broadcastBotTests
           xdescribe'' "SimpleX Directory service bot" directoryServiceTests
+          xdescribe'' "SimpleX Badge service bot" badgeServiceTests
           describe "Remote session" remoteTests
 #if !defined(dbPostgres)
           xdescribe'' "Save query plans" saveQueryPlans