core: simplex-badge-service scaffolding

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

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
+    }

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"

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

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;
+  |]

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;
+  |]

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.*

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\"}"

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