wip

.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/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 (useful when the address was created out of band, for example in tests).

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

@@ -1,9 +1,7 @@
 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 
 module BadgeService.Options
   ( BadgeServiceOpts (..),

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

@@ -13,21 +13,23 @@ 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 Data.Text (Text)
 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.Store.Profiles (AddressSettings (..))
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI')
 import Simplex.Chat.Types (User (..))
 import Simplex.Messaging.Agent.Protocol (AgentInvId)
-import Simplex.Messaging.Util (raceAny_)
+import Simplex.Messaging.Encoding.String (strEncode)
+import Simplex.Messaging.Util (raceAny_, safeDecodeUtf8, tshow)
 import System.Directory (getAppUserDataDirectory)
 import System.Exit (exitFailure)
 
@@ -64,6 +66,10 @@ badgeService opts cfg = do
       (_, event) <- atomically . readTBQueue $ outputQ cc
       case event of
         Right (CEvtServiceRequest u reqId _sigKey reqData) ->
+          -- TODO [badge service] the handler must enforce `_sigKey == BadgeServiceRequest.purchaseKey`
+          -- (docs/protocol/badges-rpc.md: "rejects a purchaseKey that differs from it with bad_request,
+          -- and a key it holds no record of with unknown_purchase_key"). This is the identity guarantee
+          -- of the whole protocol - do not drop this binding when the real handler lands.
           handleServiceRequest cc u reqId reqData
         _ -> pure ()
 
@@ -73,6 +79,7 @@ badgeServiceCLI opts = do
   let eventHook _cc ev = do
         case ev of
           Right (CEvtServiceRequest u reqId _sigKey reqData) ->
+            -- Same _sigKey obligation as the non-CLI branch above.
             atomically $ writeTQueue (serviceRequestQ env) (u, reqId, reqData)
           _ -> pure ()
         pure ev
@@ -100,10 +107,26 @@ badgePreStartHook opts ChatController {config, chatStore} =
 
 badgePostStartHook :: BadgeServiceOpts -> ChatController -> IO ()
 badgePostStartHook BadgeServiceOpts {noAddress, testing} cc = do
+  -- SREQ delivery depends on this flag being True (src/Simplex/Chat/Library/Subscriber.hs:1366-1372).
+  -- Core hardcodes serviceRequests=False when starting the chat (src/Simplex/Chat/Core.hs:93);
+  -- flipping the TVar here in postStartHook is the current mechanism to enable service requests
+  -- for a service bot. Any SREQ arriving between agentSubscriber starting and this write is
+  -- dropped via dropSReq. This race window is currently accepted.
   atomically $ writeTVar (processServiceRequests cc) True
   readTVarIO (currentUser cc) >>= \case
     Nothing -> putStrLn "No current user" >> exitFailure
-    Just _ -> unless noAddress $ initializeBotAddress' (not testing) cc
+    Just _ -> unless noAddress $ do
+      -- Service RPC requires a double-ratchet address (simplexmq Agent.hs:1738 rejects non-DR
+      -- with ASENotDRAddress), so pass `Just True` to CreateMyAddress when creating.
+      initializeBotAddress' (not testing) (Just True) cc
+      -- The badge service handles service requests only; it does not reply to contact requests
+      -- (see loop above, which matches only CEvtServiceRequest). Disable autoAccept explicitly
+      -- so a stray contact request is not silently accepted and then left in limbo forever.
+      let noContactSettings =
+            AddressSettings {businessAddress = False, autoAccept = Nothing, autoReply = Nothing}
+      sendChatCmd cc (SetAddressSettings Nothing noContactSettings) >>= \case
+        Right _ -> pure ()
+        Left e -> logError $ "badge service: failed to disable autoAccept: " <> tshow e
 
 badgePostStartHookCLI :: BadgeServiceOpts -> ServiceState -> ChatController -> IO ()
 badgePostStartHookCLI opts env cc = do
@@ -111,32 +134,16 @@ badgePostStartHookCLI opts env cc = do
   void $ atomically $ tryPutTMVar (serviceCC env) cc
 
 handleServiceRequest :: ChatController -> User -> AgentInvId -> J.Object -> IO ()
-handleServiceRequest cc User {userId} reqId _reqData =
-  void $ sendChatCmd cc (APISendServiceResponse userId reqId $ errorResponse BSEUnsupportedVersion)
+handleServiceRequest cc User {userId} reqId _reqData = do
+  let reqIdT = safeDecodeUtf8 (strEncode reqId)
+  logInfo $ "badge service request " <> reqIdT
+  sendChatCmd cc (APISendServiceResponse userId reqId $ errorResponse BSEUnsupportedVersion) >>= \case
+    Right _ -> pure ()
+    Left e -> logError $ "badge service response failed for " <> reqIdT <> ": " <> tshow e
 
 errorResponse :: BadgeServiceErrorCode -> J.Object
 errorResponse errCode =
   KM.fromList
     [ ("type", J.String "error"),
-      ("code", J.String $ errorCodeText errCode)
+      ("code", J.toJSON errCode)
     ]
-
-errorCodeText :: BadgeServiceErrorCode -> Text
-errorCodeText = \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"

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

@@ -1,6 +1,5 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
 module BadgeService.Store.Migrate

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 cc
       void $ atomically $ tryPutTMVar (serviceCC env) cc
       listingsUpdated env
       let cmds = fromMaybe [] $ preferences >>= commands_

simplex-chat.cabal

@@ -529,8 +529,8 @@ executable simplex-badge-service
       aeson ==2.2.*
     , base >=4.7 && <5
     , 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.*
@@ -669,12 +669,12 @@ test-suite simplex-chat-test
       API.Docs.Syntax.Types
       API.Docs.Types
       API.TypeInfo
-      Broadcast.Bot
-      Broadcast.Options
       BadgeService.Options
       BadgeService.Service
       BadgeService.Store.Migrate
       Bots.BadgeServiceTests
+      Broadcast.Bot
+      Broadcast.Options
       Directory.BlockedWords
       Directory.Captcha
       Directory.Events
@@ -699,8 +699,8 @@ test-suite simplex-chat-test
   hs-source-dirs:
       bots/src
       tests
-      apps/simplex-broadcast-bot/src
       apps/simplex-badge-service/src
+      apps/simplex-broadcast-bot/src
       apps/simplex-directory-service/src
   default-extensions:
       StrictData

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
@@ -17,6 +19,7 @@ module Simplex.Chat.Badges.Service
     BadgeServiceResponse (..),
     ServicePaymentDestination (..),
     BadgeServiceErrorCode (..),
+    badgeServiceErrorCodeText,
     BadgeCatalog (..),
     BadgePrice (..),
     BadgeOffer (..),
@@ -29,8 +32,10 @@ module Simplex.Chat.Badges.Service
   ) where
 
 import qualified Data.Aeson as J
+import qualified Data.Aeson.Encoding as JE
 import Data.Int (Int64)
 import Data.Text (Text)
+import qualified Data.Text as T
 import Data.Time.Clock (UTCTime)
 import Data.Word (Word8, Word16, Word32)
 import Simplex.Chat.Badges
@@ -242,3 +247,51 @@ data BadgeServiceErrorCode
   | BSEReceiptUsed
   | BSEInternal
   deriving (Eq, Show)
+
+-- Wire form is snake_case per docs/protocol/badges-rpc.schema.json (definition `response.error.code`).
+-- The codebase's `enumJSON $ dropPrefix "BSE"` would produce camelCase ("unsupportedVersion") and
+-- silently break the wire format under every client, so the mapping is written explicitly here.
+badgeServiceErrorCodeText :: BadgeServiceErrorCode -> Text
+badgeServiceErrorCodeText = \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"
+
+instance J.ToJSON BadgeServiceErrorCode where
+  toJSON = J.String . badgeServiceErrorCodeText
+  toEncoding = JE.text . badgeServiceErrorCodeText
+
+instance J.FromJSON BadgeServiceErrorCode where
+  parseJSON = J.withText "BadgeServiceErrorCode" $ \case
+    "bad_request" -> pure BSEBadRequest
+    "unsupported_version" -> pure BSEUnsupportedVersion
+    "unknown_purchase_key" -> pure BSEUnknownPurchaseKey
+    "unknown_offer_id" -> pure BSEUnknownOfferId
+    "offer_disabled" -> pure BSEOfferDisabled
+    "offer_mismatch" -> pure BSEOfferMismatch
+    "product_unavailable" -> pure BSEProductUnavailable
+    "payment_not_entitled" -> pure BSEPaymentNotEntitled
+    "payment_pending" -> pure BSEPaymentPending
+    "provider_unavailable" -> pure BSEProviderUnavailable
+    "rate_limited" -> pure BSERateLimited
+    "code_invalid" -> pure BSECodeInvalid
+    "code_used" -> pure BSECodeUsed
+    "code_expired" -> pure BSECodeExpired
+    "receipt_invalid" -> pure BSEReceiptInvalid
+    "receipt_used" -> pure BSEReceiptUsed
+    "internal" -> pure BSEInternal
+    t -> fail $ "unknown BadgeServiceErrorCode: " <> T.unpack t

src/Simplex/Chat/Bot.hs

@@ -47,16 +47,23 @@ chatBotRepl welcome answer _user cc = do
     contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected"
 
 initializeBotAddress :: ChatController -> IO ()
-initializeBotAddress = initializeBotAddress' True
+initializeBotAddress = initializeBotAddress' True Nothing
 
-initializeBotAddress' :: Bool -> ChatController -> IO ()
-initializeBotAddress' logAddress cc = do
+-- Second argument controls how a NEW address is created when none exists:
+--   Nothing    -> non-double-ratchet contact address (compatible with legacy
+--                 contact-request bots such as directory and broadcast).
+--   Just True  -> double-ratchet address with post-quantum keys, required for
+--                 service RPC (see docs/protocol/badges-rpc.md).
+--   Just False -> double-ratchet address with per-ratchet PQ enabled.
+-- If an address already exists, this argument is unused (ShowMyAddress path).
+initializeBotAddress' :: Bool -> Maybe Bool -> ChatController -> IO ()
+initializeBotAddress' logAddress pqRatchet_ 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

tests/Bots/BadgeServiceTests.hs

@@ -11,6 +11,7 @@ import ChatTests.DBUtils
 import ChatTests.Utils
 import Control.Concurrent (forkIO, killThread, threadDelay)
 import Control.Exception (finally)
+import Data.List (isInfixOf)
 import Simplex.Chat.Controller (ChatConfig)
 import Simplex.Chat.Options (CoreChatOpts (..))
 import Simplex.Chat.Options.DB
@@ -20,6 +21,7 @@ import Test.Hspec hiding (it)
 
 badgeServiceTests :: SpecWith TestParams
 badgeServiceTests = do
+  it "creates a DR address when none exists" testBadgeServiceCreatesDRAddress
   it "should respond with unsupported_version to redeem" testBadgeServiceRedeemUnsupported
 
 badgeProfile :: Profile
@@ -66,10 +68,36 @@ runBadgeService cfg opts action = do
   threadDelay 500000
   action `finally` killThread t
 
+-- Exercises the address-creation branch of initializeBotAddress' that withBadgeService bypasses
+-- (it pre-creates the address to keep the RPC round-trip focused). This is the only test that
+-- covers what a fresh deployment produces.
+--
+-- Assertion is on the full link's "rk=" query parameter: simplexmq
+-- Simplex/Messaging/Agent/Protocol.hs:1174 appends "rk=" only when the ratchet keys are Just,
+-- so its presence proves the address is double-ratchet. A non-DR address would still parse and
+-- look valid, but every service request to it would fail with ASENotDRAddress (Agent.hs:1739).
+testBadgeServiceCreatesDRAddress :: HasCallStack => TestParams -> IO ()
+testBadgeServiceCreatesDRAddress ps = do
+  withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_bs -> pure ()
+  let opts = mkBadgeServiceOpts ps
+  runBadgeService testCfg opts (pure ())
+  withTestChat ps serviceDbPrefix $ \bs -> do
+    bs <## "subscribed 1 connections on server localhost"
+    bs ##> "/sa"
+    (_, fullLink) <- getContactLinks bs False
+    bs <## "auto_accept off"
+    ("rk=" `isInfixOf` fullLink) `shouldBe` True
+
 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)
+    -- The exact serialized string is deterministic today: the aeson fork's KeyMap is Map-backed
+    -- with flag `ordered-keymap` defaulted to True (aeson.cabal:52; KeyMap.hs:143), so keys sort
+    -- alphabetically. If the future typed handler switches to deriveJSON/enumJSON on the
+    -- response, the encoder will emit declaration order and this assertion will need to be
+    -- updated (and BadgeServiceErrorCode's snake_case ToJSON in src/Simplex/Chat/Badges/Service.hs
+    -- - which this test transitively depends on - reviewed at the same time).
     client <## "service response: {\"code\":\"unsupported_version\",\"type\":\"error\"}"