From 23cbcc4830a2bbdd3da88bd09114f175d39b142e Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Thu, 6 Aug 2026 19:49:27 +0400 Subject: [PATCH] wip --- .github/workflows/build.yml | 1 + apps/simplex-badge-service/README.md | 30 ++++++++++ .../src/BadgeService/Options.hs | 2 - .../src/BadgeService/Service.hs | 59 +++++++++++-------- .../src/BadgeService/Store/Migrate.hs | 1 - .../src/Directory/Service.hs | 2 +- simplex-chat.cabal | 8 +-- src/Simplex/Chat/Badges/Service.hs | 53 +++++++++++++++++ src/Simplex/Chat/Bot.hs | 15 +++-- tests/Bots/BadgeServiceTests.hs | 28 +++++++++ 10 files changed, 161 insertions(+), 38 deletions(-) create mode 100644 apps/simplex-badge-service/README.md diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 4e5050fe8f..6cc939f866 100644 --- a/.github/workflows/build.yml +++ b/.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/**" diff --git a/apps/simplex-badge-service/README.md b/apps/simplex-badge-service/README.md new file mode 100644 index 0000000000..e642d4de95 --- /dev/null +++ b/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). diff --git a/apps/simplex-badge-service/src/BadgeService/Options.hs b/apps/simplex-badge-service/src/BadgeService/Options.hs index 2012b62fa1..82d82a454d 100644 --- a/apps/simplex-badge-service/src/BadgeService/Options.hs +++ b/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 (..), diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index a1f690d86c..485cd30e4e 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/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" diff --git a/apps/simplex-badge-service/src/BadgeService/Store/Migrate.hs b/apps/simplex-badge-service/src/BadgeService/Store/Migrate.hs index a283da7f7f..d76507fbb1 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/Migrate.hs +++ b/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 diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 7dc165c4df..d13ec3ea95 100644 --- a/apps/simplex-directory-service/src/Directory/Service.hs +++ b/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_ diff --git a/simplex-chat.cabal b/simplex-chat.cabal index b4bc176b6d..52065c8ea7 100644 --- a/simplex-chat.cabal +++ b/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 diff --git a/src/Simplex/Chat/Badges/Service.hs b/src/Simplex/Chat/Badges/Service.hs index 70084e70dd..14d9d73e35 100644 --- a/src/Simplex/Chat/Badges/Service.hs +++ b/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 diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index dfb7418f3f..174e5cb305 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/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 diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index 553b1edadf..da287e8f7a 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/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\"}"