diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 485cd30e4e..d2a146cb76 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/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 diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index d13ec3ea95..39d0cfe84d 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) Nothing cc + unless noAddress $ initializeBotAddress' defaultBotAddressOpts {logAddress = not testing} 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 52065c8ea7..9f23bd9223 100644 --- a/simplex-chat.cabal +++ b/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 diff --git a/src/Simplex/Chat/Badges/Service.hs b/src/Simplex/Chat/Badges/Service.hs index 14d9d73e35..7e944d59db 100644 --- a/src/Simplex/Chat/Badges/Service.hs +++ b/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" diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index 174e5cb305..2018af4144 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/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 () diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index da287e8f7a..0559691dec 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/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\"}"