wip

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

@@ -6,6 +6,7 @@
 module BadgeService.Service
   ( welcomeGetOpts,
     badgeService,
+    badgeService_,
     badgeServiceCLI,
   )
 where
@@ -19,11 +20,10 @@ 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.Bot (BotAddressOpts (..), defaultBotAddressOpts, 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 (..))
@@ -55,22 +55,22 @@ welcomeGetOpts = do
   pure opts
 
 badgeService :: BadgeServiceOpts -> ChatConfig -> IO ()
-badgeService opts cfg = do
+badgeService = badgeService_ (pure ())
+
+-- Runs onStarted after postStartHook completes (address exists, service_requests set); used by tests.
+badgeService_ :: IO () -> BadgeServiceOpts -> ChatConfig -> IO ()
+badgeService_ onStarted opts cfg = do
   let chatHooks =
         defaultChatHooks
           { preStartHook = Just $ badgePreStartHook opts,
-            postStartHook = Just $ badgePostStartHook opts
+            postStartHook = Just $ \cc -> badgePostStartHook opts cc >> onStarted
           }
   simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc ->
     forever $ 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
+        -- 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 ()
@@ -79,7 +79,6 @@ 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
@@ -107,26 +106,16 @@ 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.
+  -- 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
-    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
+    -- DR required for service RPC; autoAccept off because badge service ignores contact events.
+    Just _ ->
+      unless noAddress $
+        initializeBotAddress'
+          defaultBotAddressOpts {logAddress = not testing, pqRatchet = Just True, autoAccept = False}
+          cc
 
 badgePostStartHookCLI :: BadgeServiceOpts -> ServiceState -> ChatController -> IO ()
 badgePostStartHookCLI opts env cc = do

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) Nothing cc
+      unless noAddress $ initializeBotAddress' defaultBotAddressOpts {logAddress = not testing} cc
       void $ atomically $ tryPutTMVar (serviceCC env) cc
       listingsUpdated env
       let cmds = fromMaybe [] $ preferences >>= commands_

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
@@ -510,52 +556,6 @@ executable simplex-chat
     build-depends:
         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-directory-service
   if flag(client_library)
       buildable: False

src/Simplex/Chat/Badges/Service.hs

@@ -19,7 +19,6 @@ module Simplex.Chat.Badges.Service
     BadgeServiceResponse (..),
     ServicePaymentDestination (..),
     BadgeServiceErrorCode (..),
-    badgeServiceErrorCodeText,
     BadgeCatalog (..),
     BadgePrice (..),
     BadgeOffer (..),
@@ -31,16 +30,16 @@ module Simplex.Chat.Badges.Service
     StatementDebitType (..),
   ) where
 
+import Data.Aeson (FromJSON (..), ToJSON (..))
 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
 import Simplex.Chat.Badges.Store
 import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Encoding.String (TextEncoding (..), textParseJSON, textToEncoding, textToJSON)
 import Simplex.Messaging.Version (VersionScope)
 import Simplex.Messaging.Version.Internal (Version (..))
 
@@ -228,6 +227,8 @@ data StatementDebitType
   | SDUnknown {tag :: Text, json :: J.Object}
   deriving (Show)
 
+-- Wire form is snake_case per docs/protocol/badges-rpc.schema.json.
+-- Written by hand because enumJSON $ dropPrefix "BSE" would emit camelCase.
 data BadgeServiceErrorCode
   = BSEBadRequest
   | BSEUnsupportedVersion
@@ -246,52 +247,52 @@ data BadgeServiceErrorCode
   | BSEReceiptInvalid
   | BSEReceiptUsed
   | BSEInternal
+  | BSEUnknown Text -- forwards-compatible: service is deployed ahead of clients
   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 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 J.ToJSON BadgeServiceErrorCode where
-  toJSON = J.String . badgeServiceErrorCodeText
-  toEncoding = JE.text . badgeServiceErrorCodeText
+instance ToJSON BadgeServiceErrorCode where
+  toJSON = textToJSON
+  toEncoding = textToEncoding
 
-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
+instance FromJSON BadgeServiceErrorCode where
+  parseJSON = textParseJSON "BadgeServiceErrorCode"

src/Simplex/Chat/Bot.hs

@@ -46,24 +46,27 @@ chatBotRepl welcome answer _user cc = do
   where
     contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected"
 
-initializeBotAddress :: ChatController -> IO ()
-initializeBotAddress = initializeBotAddress' True Nothing
+-- `pqRatchet = Just True` (IKUsePQ) is required for service RPC; Nothing is the legacy non-DR contact address.
+data BotAddressOpts = BotAddressOpts
+  { logAddress :: Bool,
+    pqRatchet :: Maybe Bool,
+    autoAccept :: Bool
+  }
 
--- 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
+defaultBotAddressOpts :: BotAddressOpts
+defaultBotAddressOpts = BotAddressOpts {logAddress = True, pqRatchet = Nothing, autoAccept = True}
+
+initializeBotAddress :: ChatController -> IO ()
+initializeBotAddress = initializeBotAddress' defaultBotAddressOpts
+
+initializeBotAddress' :: BotAddressOpts -> ChatController -> IO ()
+initializeBotAddress' BotAddressOpts {logAddress, pqRatchet, autoAccept = 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 pqRatchet_) >>= \case
+      sendChatCmd cc (CreateMyAddress pqRatchet) >>= \case
         Right (CRUserContactLinkCreated _ ccLink) -> showBotAddress ccLink
         _ -> putStrLn "can't create bot address" >> exitFailure
     _ -> putStrLn "unexpected response" >> exitFailure
@@ -72,7 +75,8 @@ initializeBotAddress' logAddress pqRatchet_ 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

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -9,7 +10,8 @@ import BadgeService.Service
 import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Utils
-import Control.Concurrent (forkIO, killThread, threadDelay)
+import Control.Concurrent (forkIO, killThread)
+import Control.Concurrent.STM
 import Control.Exception (finally)
 import Data.List (isInfixOf)
 import Simplex.Chat.Controller (ChatConfig)
@@ -17,11 +19,11 @@ import Simplex.Chat.Options (CoreChatOpts (..))
 import Simplex.Chat.Options.DB
 import Simplex.Chat.Types (ChatPeerType (..), Profile (..))
 import System.FilePath ((</>))
+import System.Timeout (timeout)
 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
@@ -52,41 +54,32 @@ mkBadgeServiceOpts TestParams {tmpPath = ps} =
 
 withBadgeService :: HasCallStack => TestParams -> (TestCC -> String -> IO ()) -> IO ()
 withBadgeService ps test = do
-  bsLink <-
-    withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \bs -> do
-      bs ##> "/ad pq_ratchet=on"
-      (sLink, _) <- getContactLinks bs True
-      pure sLink
   let opts = mkBadgeServiceOpts ps
+  -- Create the bot database with no address.
+  withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure ()
+  -- First start: badge service takes the CreateMyAddress branch.
+  runBadgeService testCfg opts (pure ())
+  -- Reopen and read the address the service created. `rk=` in the full link is diagnostic:
+  -- if it were absent the RPC below would fail with ASENotDRAddress.
+  bsLink <- withTestChat ps serviceDbPrefix $ \bs -> do
+    bs <## "subscribed 1 connections on server localhost"
+    bs ##> "/sa"
+    (sLink, fullLink) <- getContactLinks bs False
+    bs <## "auto_accept off"
+    ("rk=" `isInfixOf` fullLink) `shouldBe` True
+    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
-
--- 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
+  ready <- newEmptyTMVarIO
+  t <- forkIO $ badgeService_ (atomically $ putTMVar ready ()) opts cfg
+  timeout 10000000 (atomically $ takeTMVar ready) >>= \case
+    Nothing -> killThread t >> fail "badge service failed to signal ready within 10s"
+    Just () -> action `finally` killThread t
 
 testBadgeServiceRedeemUnsupported :: HasCallStack => TestParams -> IO ()
 testBadgeServiceRedeemUnsupported ps =
@@ -94,10 +87,5 @@ testBadgeServiceRedeemUnsupported ps =
     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).
+    -- Exact string is deterministic under the aeson fork's ordered-keymap default (Map-backed).
     client <## "service response: {\"code\":\"unsupported_version\",\"type\":\"error\"}"