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/src/BadgeService/Options.hs b/apps/simplex-badge-service/src/BadgeService/Options.hs new file mode 100644 index 0000000000..2012b62fa1 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Options.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +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..a1f690d86c --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -0,0 +1,142 @@ +{-# 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.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.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 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 + let chatHooks = + defaultChatHooks + { preStartHook = Just $ badgePreStartHook opts, + postStartHook = Just $ badgePostStartHook opts + } + simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> + forever $ do + (_, event) <- atomically . readTBQueue $ outputQ cc + case event of + 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 $ badgePostStartHookCLI 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 -> ChatController -> IO () +badgePostStartHook BadgeServiceOpts {noAddress, testing} cc = do + atomically $ writeTVar (processServiceRequests cc) True + readTVarIO (currentUser cc) >>= \case + Nothing -> putStrLn "No current user" >> exitFailure + Just _ -> unless noAddress $ initializeBotAddress' (not testing) cc + +badgePostStartHookCLI :: BadgeServiceOpts -> ServiceState -> ChatController -> IO () +badgePostStartHookCLI opts env cc = do + badgePostStartHook opts cc + 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) + +errorResponse :: BadgeServiceErrorCode -> J.Object +errorResponse errCode = + KM.fromList + [ ("type", J.String "error"), + ("code", J.String $ errorCodeText 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 new file mode 100644 index 0000000000..a283da7f7f --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Store/Migrate.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +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/simplex-chat.cabal b/simplex-chat.cabal index c5dcf6111e..b4bc176b6d 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -510,6 +510,52 @@ 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.* + , mtl >=2.3.1 && <3.0 + , optparse-applicative >=0.15 && <0.17 + , 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 @@ -625,6 +671,10 @@ test-suite simplex-chat-test API.TypeInfo Broadcast.Bot Broadcast.Options + BadgeService.Options + BadgeService.Service + BadgeService.Store.Migrate + Bots.BadgeServiceTests Directory.BlockedWords Directory.Captcha Directory.Events @@ -650,6 +700,7 @@ test-suite simplex-chat-test bots/src tests apps/simplex-broadcast-bot/src + apps/simplex-badge-service/src apps/simplex-directory-service/src default-extensions: StrictData @@ -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/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs new file mode 100644 index 0000000000..553b1edadf --- /dev/null +++ b/tests/Bots/BadgeServiceTests.hs @@ -0,0 +1,75 @@ +{-# 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 + bsLink <- + withNewTestChatCfg ps testCfg serviceDbPrefix badgeProfile $ \bs -> do + bs ##> "/ad pq_ratchet=on" + (sLink, _) <- getContactLinks bs True + pure sLink + let opts = mkBadgeServiceOpts ps + 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