From 7ce2e6583e7707de22fbdaeae74ebef1b5b34e74 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Sat, 8 Aug 2026 20:00:23 +0000 Subject: [PATCH] core: simplex-badge-service scaffolding (#7353) * core: simplex-badge-service scaffolding * wip * wip * wip * wip * wip * wip * wip * wip * wip * wip * wip * clean-up --------- Co-authored-by: Evgeny Poberezkin --- .github/workflows/build.yml | 1 + apps/simplex-badge-service/Main.hs | 14 ++ apps/simplex-badge-service/README.md | 30 +++++ .../src/BadgeService/Options.hs | 93 ++++++++++++++ .../src/BadgeService/Service.hs | 120 ++++++++++++++++++ .../src/BadgeService/Store/Migrate.hs | 40 ++++++ .../BadgeService/Store/Postgres/Migrations.hs | 37 ++++++ .../BadgeService/Store/SQLite/Migrations.hs | 34 +++++ .../src/Directory/Service.hs | 2 +- docs/protocol/badges-rpc.schema.json | 10 +- simplex-chat.cabal | 53 ++++++++ src/Simplex/Chat/Badges/Service.hs | 52 ++++++++ src/Simplex/Chat/Bot.hs | 12 +- tests/Bots/BadgeServiceTests.hs | 81 ++++++++++++ tests/Test.hs | 2 + 15 files changed, 567 insertions(+), 14 deletions(-) create mode 100644 apps/simplex-badge-service/Main.hs create mode 100644 apps/simplex-badge-service/README.md create mode 100644 apps/simplex-badge-service/src/BadgeService/Options.hs create mode 100644 apps/simplex-badge-service/src/BadgeService/Service.hs create mode 100644 apps/simplex-badge-service/src/BadgeService/Store/Migrate.hs create mode 100644 apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs create mode 100644 apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs create mode 100644 tests/Bots/BadgeServiceTests.hs 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/Main.hs b/apps/simplex-badge-service/Main.hs new file mode 100644 index 0000000000..b870ea8671 --- /dev/null +++ b/apps/simplex-badge-service/Main.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Main where + +import BadgeService.Options (BadgeServiceOpts (..)) +import BadgeService.Service +import Simplex.Chat.Terminal (terminalChatConfig) + +main :: IO () +main = do + opts@BadgeServiceOpts {runCLI} <- welcomeGetOpts + if runCLI + then badgeServiceCLI opts + else badgeService opts terminalChatConfig diff --git a/apps/simplex-badge-service/README.md b/apps/simplex-badge-service/README.md new file mode 100644 index 0000000000..2d3c2153f3 --- /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 (for operators who provision the address themselves). diff --git a/apps/simplex-badge-service/src/BadgeService/Options.hs b/apps/simplex-badge-service/src/BadgeService/Options.hs new file mode 100644 index 0000000000..82d82a454d --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Options.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module BadgeService.Options + ( BadgeServiceOpts (..), + getBadgeServiceOpts, + badgeServiceOpts, + mkChatOpts, + ) +where + +import qualified Data.Text as T +import Options.Applicative +import Simplex.Chat.Controller (updateStr, versionNumber, versionString) +import Simplex.Chat.Options (ChatCmdLog (..), ChatOpts (..), CoreChatOpts, CreateBotOpts (..), coreChatOptsP) + +data BadgeServiceOpts = BadgeServiceOpts + { coreOptions :: CoreChatOpts, + serviceName :: T.Text, + clientService :: Bool, + noAddress :: Bool, + runCLI :: Bool, + testing :: Bool + } + +badgeServiceOpts :: FilePath -> FilePath -> Parser BadgeServiceOpts +badgeServiceOpts appDir defaultDbName = do + coreOptions <- coreChatOptsP appDir defaultDbName + serviceName <- + strOption + ( long "service-name" + <> metavar "SERVICE_NAME" + <> help "The display name of the badge service bot, without *'s and spaces (SimpleX Badges)" + <> value "SimpleX Badges" + ) + clientService <- + switch + ( long "client-service" + <> help "Use client service certificate" + ) + noAddress <- + switch + ( long "no-address" + <> help "skip checking and creating service address" + ) + runCLI <- + switch + ( long "run-cli" + <> help "Run badge service as CLI" + ) + pure + BadgeServiceOpts + { coreOptions, + serviceName = T.pack serviceName, + clientService, + noAddress, + runCLI, + testing = False + } + +getBadgeServiceOpts :: FilePath -> FilePath -> IO BadgeServiceOpts +getBadgeServiceOpts appDir defaultDbName = + execParser $ + info + (helper <*> versionOption <*> badgeServiceOpts appDir defaultDbName) + (header versionStr <> fullDesc <> progDesc "Start SimpleX Badge Service with DB_FILE options") + where + versionStr = versionString versionNumber + versionOption = infoOption versionAndUpdate (long "version" <> short 'v' <> help "Show version") + versionAndUpdate = versionStr <> "\n" <> updateStr + +mkChatOpts :: BadgeServiceOpts -> ChatOpts +mkChatOpts BadgeServiceOpts {coreOptions, serviceName, clientService} = + ChatOpts + { coreOptions, + chatCmd = "", + chatCmdDelay = 3, + chatCmdLog = CCLNone, + chatServerPort = Nothing, + optFilesFolder = Nothing, + optTempDirectory = Nothing, + showReactions = False, + showFullLinks = False, + allowInstantFiles = True, + autoAcceptFileSize = 0, + muteNotifications = True, + markRead = False, + createBot = Just CreateBotOpts {botDisplayName = serviceName, allowFiles = False, clientService}, + userDisplayName = Nothing, + userImageFile = Nothing + } diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs new file mode 100644 index 0000000000..64e934872e --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module BadgeService.Service + ( welcomeGetOpts, + badgeService, + badgeServiceCLI, + ) +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 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.Terminal (terminalChatConfig) +import Simplex.Chat.Terminal.Main (simplexChatCLI') +import Simplex.Chat.Types (AgentInvId (..), User (..)) +import Simplex.Messaging.Encoding.String (strEncode) +import Simplex.Messaging.Util (raceAny_, safeDecodeUtf8, tshow) +import System.Directory (getAppUserDataDirectory) +import System.Exit (exitFailure) + +data ServiceState = ServiceState + { serviceCC :: TMVar ChatController, + serviceRequestQ :: TQueue (User, AgentInvId, J.Object) + } + +newServiceState :: IO ServiceState +newServiceState = do + serviceCC <- newEmptyTMVarIO + serviceRequestQ <- newTQueueIO + pure ServiceState {serviceCC, serviceRequestQ} + +welcomeGetOpts :: IO BadgeServiceOpts +welcomeGetOpts = do + appDir <- getAppUserDataDirectory "simplex" + opts@BadgeServiceOpts {coreOptions, testing, serviceName} <- getBadgeServiceOpts appDir "simplex_badge_service" + unless testing $ do + putStrLn $ "SimpleX Badge Service v" ++ versionNumber + printDbOpts coreOptions + putStrLn $ "Service name: " ++ T.unpack serviceName + pure opts + +badgeService :: BadgeServiceOpts -> ChatConfig -> IO () +badgeService opts cfg = do + env <- newServiceState + let chatHooks = + defaultChatHooks + { preStartHook = Just $ badgePreStartHook opts, + postStartHook = Just $ badgePostStartHook opts env + } + simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> + forever $ do + (_, event) <- atomically . readTBQueue $ outputQ cc + case event of + -- 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 () +badgeServiceCLI opts = do + env <- newServiceState + let eventHook _cc ev = do + case ev of + Right (CEvtServiceRequest u reqId _sigKey reqData) -> + atomically $ writeTQueue (serviceRequestQ env) (u, reqId, reqData) + _ -> pure () + pure ev + chatHooks = + defaultChatHooks + { preStartHook = Just $ badgePreStartHook opts, + postStartHook = Just $ badgePostStartHook opts env, + eventHook = Just eventHook + } + raceAny_ + [ simplexChatCLI' terminalChatConfig {chatHooks} (mkChatOpts opts) Nothing, + processQueuedRequests env + ] + +processQueuedRequests :: ServiceState -> IO () +processQueuedRequests env = do + cc <- atomically $ readTMVar $ serviceCC env + forever $ do + (u, reqId, reqData) <- atomically $ readTQueue $ serviceRequestQ env + handleServiceRequest cc u reqId reqData + +badgePreStartHook :: BadgeServiceOpts -> ChatController -> IO () +badgePreStartHook opts ChatController {config, chatStore} = + runBadgeServiceMigrations opts config chatStore + +badgePostStartHook :: BadgeServiceOpts -> ServiceState -> ChatController -> IO () +badgePostStartHook BadgeServiceOpts {noAddress, testing} env cc = do + -- 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 + -- DR required for service RPC; autoAccept off because badge service ignores contact events. + Just _ -> do + unless noAddress $ initializeBotAddress' (not testing) (Just True) False cc + void $ atomically $ tryPutTMVar (serviceCC env) cc + +handleServiceRequest :: ChatController -> User -> AgentInvId -> J.Object -> IO () +handleServiceRequest cc User {userId} reqId _reqData = do + let reqIdT = safeDecodeUtf8 (strEncode reqId) + respObj = KM.fromList [("type", J.String "error"), ("code", J.toJSON BSEUnsupportedVersion)] + logInfo $ "badge service request " <> reqIdT + sendChatCmd cc (APISendServiceResponse userId reqId respObj) >>= \case + Right _ -> pure () + Left e -> logError $ "badge service response failed for " <> reqIdT <> ": " <> tshow e diff --git a/apps/simplex-badge-service/src/BadgeService/Store/Migrate.hs b/apps/simplex-badge-service/src/BadgeService/Store/Migrate.hs new file mode 100644 index 0000000000..506043c262 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Store/Migrate.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module BadgeService.Store.Migrate + ( runBadgeServiceMigrations, + ) +where + +import BadgeService.Options +import Simplex.Chat.Controller (ChatConfig (..)) +import Simplex.Chat.Options (CoreChatOpts (..)) +import Simplex.Chat.Options.DB +import Simplex.Messaging.Agent.Store.Common +import Simplex.Messaging.Agent.Store.Interface (migrateDBSchema) +import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..)) +import System.Exit (exitFailure) + +#if defined(dbPostgres) +import BadgeService.Store.Postgres.Migrations +#else +import BadgeService.Store.SQLite.Migrations +#endif + +runBadgeServiceMigrations :: BadgeServiceOpts -> ChatConfig -> DBStore -> IO () +runBadgeServiceMigrations opts ChatConfig {confirmMigrations} chatStore = + migrateDBSchema + chatStore + (toDBOpts dbOptions chatSuffix False []) + (Just "sx_badge_service_migrations") + badgeServiceSchemaMigrations + MigrationConfig {confirm, backupPath = Nothing} + >>= either (exit . ("badge service migrations " <>) . show) pure + where + BadgeServiceOpts {coreOptions = CoreChatOpts {dbOptions, yesToUpMigrations}} = opts + confirm = if confirmMigrations == MCConsole && yesToUpMigrations then MCYesUp else confirmMigrations + +exit :: String -> IO a +exit err = putStrLn ("Error: " <> err) >> exitFailure diff --git a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs new file mode 100644 index 0000000000..a4bc3396bf --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuasiQuotes #-} + +module BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations) where + +import Data.List (sortOn) +import Data.Text (Text) +import qualified Data.Text as T +import Simplex.Messaging.Agent.Store.Shared (Migration (..)) +import Text.RawString.QQ (r) + +badgeServiceSchemaMigrations :: [Migration] +badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations + where + migration (name, up, down) = Migration {name, up, down} + +schemaMigrations :: [(String, Text, Maybe Text)] +schemaMigrations = + [ ("20260806_badge_service_schema", m20260806_badge_service_schema, Just down_m20260806_badge_service_schema) + ] + +m20260806_badge_service_schema :: Text +m20260806_badge_service_schema = + T.pack + [r| +CREATE TABLE sx_badge_service_test( + test_id BIGINT PRIMARY KEY GENERATED ALWAYS AS IDENTITY, + created_at TIMESTAMPTZ NOT NULL DEFAULT (now()) +); + |] + +down_m20260806_badge_service_schema :: Text +down_m20260806_badge_service_schema = + T.pack + [r| +DROP TABLE sx_badge_service_test; + |] diff --git a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs new file mode 100644 index 0000000000..8404f135db --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuasiQuotes #-} + +module BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations) where + +import Data.List (sortOn) +import Database.SQLite.Simple (Query (..)) +import Database.SQLite.Simple.QQ (sql) +import Simplex.Messaging.Agent.Store.Shared (Migration (..)) + +badgeServiceSchemaMigrations :: [Migration] +badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations + where + migration (name, up, down) = Migration {name, up = fromQuery up, down = fromQuery <$> down} + +schemaMigrations :: [(String, Query, Maybe Query)] +schemaMigrations = + [ ("20260806_badge_service_schema", m20260806_badge_service_schema, Just down_m20260806_badge_service_schema) + ] + +m20260806_badge_service_schema :: Query +m20260806_badge_service_schema = + [sql| +CREATE TABLE sx_badge_service_test( + test_id INTEGER PRIMARY KEY AUTOINCREMENT, + created_at TEXT NOT NULL DEFAULT(datetime('now')) +); + |] + +down_m20260806_badge_service_schema :: Query +down_m20260806_badge_service_schema = + [sql| +DROP TABLE sx_badge_service_test; + |] diff --git a/apps/simplex-directory-service/src/Directory/Service.hs b/apps/simplex-directory-service/src/Directory/Service.hs index 7dc165c4df..0273740cbb 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 True cc void $ atomically $ tryPutTMVar (serviceCC env) cc listingsUpdated env let cmds = fromMaybe [] $ preferences >>= commands_ diff --git a/docs/protocol/badges-rpc.schema.json b/docs/protocol/badges-rpc.schema.json index b1c3cf4a66..2caa3408e2 100644 --- a/docs/protocol/badges-rpc.schema.json +++ b/docs/protocol/badges-rpc.schema.json @@ -363,14 +363,8 @@ "error": { "properties": { "code": { - "enum": [ - "bad_request", "unsupported_version", "unknown_purchase_key", - "unknown_offer_id", "offer_disabled", "offer_mismatch", "product_unavailable", - "payment_not_entitled", "payment_pending", "provider_unavailable", "rate_limited", - "code_invalid", "code_used", "code_expired", - "receipt_invalid", "receipt_used", - "internal" - ] + "type": "string", + "metadata": {"comment": "BadgeServiceErrorCode"} } }, "optionalProperties": { diff --git a/simplex-chat.cabal b/simplex-chat.cabal index c5dcf6111e..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 @@ -623,6 +669,10 @@ test-suite simplex-chat-test API.Docs.Syntax.Types API.Docs.Types API.TypeInfo + BadgeService.Options + BadgeService.Service + BadgeService.Store.Migrate + Bots.BadgeServiceTests Broadcast.Bot Broadcast.Options Directory.BlockedWords @@ -649,6 +699,7 @@ test-suite simplex-chat-test hs-source-dirs: bots/src tests + apps/simplex-badge-service/src apps/simplex-broadcast-bot/src apps/simplex-directory-service/src default-extensions: @@ -691,6 +742,7 @@ test-suite simplex-chat-test default-language: Haskell2010 if flag(client_postgres) other-modules: + BadgeService.Store.Postgres.Migrations Directory.Store.Postgres.Migrations build-depends: postgresql-simple ==0.7.* @@ -698,6 +750,7 @@ test-suite simplex-chat-test cpp-options: -DdbPostgres else other-modules: + BadgeService.Store.SQLite.Migrations Directory.Store.SQLite.Migrations build-depends: sqlcipher-simple ==0.4.* diff --git a/src/Simplex/Chat/Badges/Service.hs b/src/Simplex/Chat/Badges/Service.hs index 70084e70dd..eb5a556503 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 @@ -28,6 +30,7 @@ module Simplex.Chat.Badges.Service StatementDebitType (..), ) where +import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson as J import Data.Int (Int64) import Data.Text (Text) @@ -36,6 +39,7 @@ 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 import Simplex.Messaging.Version (VersionScope) import Simplex.Messaging.Version.Internal (Version (..)) @@ -241,4 +245,52 @@ data BadgeServiceErrorCode | BSEReceiptInvalid | BSEReceiptUsed | BSEInternal + | BSEUnknown Text -- forwards-compatible: service is deployed ahead of clients deriving (Eq, Show) + +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 ToJSON BadgeServiceErrorCode where + toJSON = textToJSON + toEncoding = textToEncoding + +instance FromJSON BadgeServiceErrorCode where + parseJSON = textParseJSON "BadgeServiceErrorCode" diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index dfb7418f3f..3b1c4c6da0 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/src/Simplex/Chat/Bot.hs @@ -47,16 +47,17 @@ chatBotRepl welcome answer _user cc = do contactConnected Contact {localDisplayName} = putStrLn $ T.unpack localDisplayName <> " connected" initializeBotAddress :: ChatController -> IO () -initializeBotAddress = initializeBotAddress' True +initializeBotAddress = initializeBotAddress' True Nothing True -initializeBotAddress' :: Bool -> ChatController -> IO () -initializeBotAddress' logAddress cc = do +-- pqRatchet_ selects the address type when creating: Just True (IKUsePQ) is required for service RPC, Nothing is the legacy non-DR contact address. +initializeBotAddress' :: Bool -> Maybe Bool -> Bool -> ChatController -> IO () +initializeBotAddress' logAddress pqRatchet_ 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 Nothing) >>= \case + sendChatCmd cc (CreateMyAddress pqRatchet_) >>= \case Right (CRUserContactLinkCreated _ ccLink) -> showBotAddress ccLink _ -> putStrLn "can't create bot address" >> exitFailure _ -> putStrLn "unexpected response" >> exitFailure @@ -65,7 +66,8 @@ initializeBotAddress' logAddress 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 new file mode 100644 index 0000000000..896c603d7f --- /dev/null +++ b/tests/Bots/BadgeServiceTests.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Bots.BadgeServiceTests where + +import BadgeService.Options +import BadgeService.Service +import ChatClient +import ChatTests.DBUtils +import ChatTests.Utils +import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.Exception (finally) +import Simplex.Chat.Controller (ChatConfig) +import Simplex.Chat.Options (CoreChatOpts (..)) +import Simplex.Chat.Options.DB +import Simplex.Chat.Types (ChatPeerType (..), Profile (..)) +import System.FilePath (()) +import Test.Hspec hiding (it) + +badgeServiceTests :: SpecWith TestParams +badgeServiceTests = do + it "should respond with unsupported_version to redeem" testBadgeServiceRedeemUnsupported + +badgeProfile :: Profile +badgeProfile = Profile {displayName = "SimpleX Badges", fullName = "", shortDescr = Nothing, description = Nothing, image = Nothing, contactLink = Nothing, peerType = Just CPTBot, preferences = Nothing, badge = Nothing, contactDomain = Nothing} + +serviceDbPrefix :: FilePath +serviceDbPrefix = "badge_service" + +mkBadgeServiceOpts :: TestParams -> BadgeServiceOpts +mkBadgeServiceOpts TestParams {tmpPath = ps} = + BadgeServiceOpts + { coreOptions = + testCoreOpts + { dbOptions = + (dbOptions testCoreOpts) +#if defined(dbPostgres) + {dbSchemaPrefix = "client_" <> serviceDbPrefix} +#else + {dbFilePrefix = ps serviceDbPrefix} +#endif + }, + serviceName = "SimpleX Badges", + clientService = True, + noAddress = False, + runCLI = False, + testing = True + } + +withBadgeService :: HasCallStack => TestParams -> (TestCC -> String -> IO ()) -> IO () +withBadgeService ps test = do + let opts = mkBadgeServiceOpts ps + withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \_ -> pure () + -- First start: badge service takes the CreateMyAddress branch. + runBadgeService testCfg opts (pure ()) + -- Reopen the DB to read the link the service created. + bsLink <- withTestChat ps serviceDbPrefix $ \bs -> do + bs <## "subscribed 1 connections on server localhost" + bs ##> "/sa" + (sLink, _) <- getContactLinks bs False + bs <## "auto_accept off" + 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 + +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) + client <## "service response: {\"code\":\"unsupported_version\",\"type\":\"error\"}" diff --git a/tests/Test.hs b/tests/Test.hs index 84a019c21c..6d0e299273 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TupleSections #-} +import Bots.BadgeServiceTests import Bots.BroadcastTests import Bots.DirectoryTests import ChatClient @@ -88,6 +89,7 @@ main = do describe "SimpleX chat client" chatTests xdescribe'' "SimpleX Broadcast bot" broadcastBotTests xdescribe'' "SimpleX Directory service bot" directoryServiceTests + xdescribe'' "SimpleX Badge service bot" badgeServiceTests describe "Remote session" remoteTests #if !defined(dbPostgres) xdescribe'' "Save query plans" saveQueryPlans