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_