test, fix

src/Simplex/Chat/Library/Commands.hs

@@ -432,16 +432,18 @@ processChatCommand vr nm = \case
   UnhideUser viewPwd -> withUser $ \User {userId} -> processChatCommand vr nm $ APIUnhideUser userId viewPwd
   MuteUser -> withUser $ \User {userId} -> processChatCommand vr nm $ APIMuteUser userId
   UnmuteUser -> withUser $ \User {userId} -> processChatCommand vr nm $ APIUnmuteUser userId
-  SetClientService userId' name enable -> checkChatStopped $ withUser $ \currUser@User {userId} -> do
-    user@User {clientService, profile = LocalProfile {displayName}} <-
+  SetClientService userId' name enable -> checkChatStopped $ withUser' $ \currUser@User {userId} -> do
+    user@User {agentUserId = AgentUserId auId, clientService, profile = LocalProfile {displayName}} <-
       if userId == userId' then pure currUser else privateGetUser userId'
     unless (name == displayName) $ throwChatError CEUserUnknown
     if enable == isTrue clientService
       then ok user
       else do
         withStore' $ \db -> updateClientService db userId' enable
-        let user' = user' {clientService = BoolDef enable} :: User
+        withAgent $ \a -> setUserService a auId enable
+        let user' = user {clientService = BoolDef enable} :: User
         when (userId == userId') $ chatWriteVar currentUser $ Just user'
+        setStoreChanged
         ok user'
   APIDeleteUser userId' delSMPQueues viewPwd_ -> withUser $ \user -> do
     user' <- privateGetUser userId'
@@ -4325,7 +4327,7 @@ chatCommandP =
       "/unhide user " *> (UnhideUser <$> pwdP),
       "/mute user" $> MuteUser,
       "/unmute user" $> UnmuteUser,
-      "/set client service " *> (SetClientService <$> A.decimal <* A.char ':' <*> displayNameP <*> onOffP),
+      "/set client service " *> (SetClientService <$> A.decimal <* A.char ':' <*> displayNameP <* A.space <*> onOffP),
       "/_delete user " *> (APIDeleteUser <$> A.decimal <* " del_smp=" <*> onOffP <*> optional (A.space *> jsonP)),
       "/delete user " *> (DeleteUser <$> displayNameP <*> pure True <*> optional (A.space *> pwdP)),
       ("/user" <|> "/u") $> ShowActiveUser,

src/Simplex/Chat/Store/Profiles.hs

@@ -20,7 +20,6 @@ module Simplex.Chat.Store.Profiles
     UserMsgReceiptSettings (..),
     UserContactLink (..),
     GroupLinkInfo (..),
-    createUserRecord,
     createUserRecordAt,
     getUsersInfo,
     getUsers,
@@ -126,9 +125,6 @@ import Database.SQLite.Simple (Only (..), Query, (:.) (..))
 import Database.SQLite.Simple.QQ (sql)
 #endif
 
-createUserRecord :: DB.Connection -> AgentUserId -> Profile -> Bool -> ExceptT StoreError IO User
-createUserRecord db auId p activeUser = createUserRecordAt db auId False p activeUser =<< liftIO getCurrentTime
-
 createUserRecordAt :: DB.Connection -> AgentUserId -> Bool -> Profile -> Bool -> UTCTime -> ExceptT StoreError IO User
 createUserRecordAt db (AgentUserId auId) clientService Profile {displayName, fullName, shortDescr, image, peerType, preferences = userPreferences} activeUser currentTs =
   checkConstraint SEDuplicateName . liftIO $ do

src/Simplex/Chat/View.hs

@@ -455,7 +455,7 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView}
     let Connection {connId} = entityConnection acEntity
      in ttyUser u [sShow connId <> ": END"]
   CEvtSubscriptionStatus srv status conns -> [plain $ subStatusStr status <> " " <> tshow (length conns) <> " connections on server " <> showSMPServer srv]
-  CEvtServiceSubStatus srv event -> viewServiceSubEvent srv event
+  CEvtServiceSubStatus srv event -> [plain $ serviceSubEventStr srv event]
   CEvtReceivedGroupInvitation {user = u, groupInfo = g, contact = c, memberRole = r} -> ttyUser u $ viewReceivedGroupInvitation g c r
   CEvtUserJoinedGroup u g _ -> ttyUser u $ viewUserJoinedGroup g
   CEvtJoinedGroupMember u g m -> ttyUser u $ viewJoinedGroupMember g m
@@ -1472,15 +1472,15 @@ subStatusStr = \case
   SSRemoved e -> "removed: " <> T.pack e
   SSNoSub -> "no subscription"
 
-viewServiceSubEvent :: SMPServer -> ServiceSubEvent -> [StyledString]
-viewServiceSubEvent srv event = [plain $ eventStr <> " on server " <> showSMPServer srv]
+serviceSubEventStr :: SMPServer -> ServiceSubEvent -> Text
+serviceSubEventStr srv = \case
+  ServiceSubUp e_ n -> "subscribed service " <> conns n <> srvStr <> ": " <> fromMaybe "ok" e_
+  ServiceSubDown n -> "disconnected service " <> conns n <> srvStr
+  ServiceSubAll -> "received messages from service" <> srvStr -- "(" <> n <> "connections)"
+  ServiceSubEnd n -> "service subscription ended " <> conns n <> srvStr
   where
-    eventStr = case event of
-      ServiceSubUp e_ n -> "subscribed service " <> conns n <> ": " <> fromMaybe "ok" e_
-      ServiceSubDown n -> "disconnected service " <> conns n
-      ServiceSubAll -> "received messages from service" -- "(" <> n <> "connections)"
-      ServiceSubEnd n -> "service subscription ended " <> conns n
-    conns n = "(" <> tshow n <> "connections)"
+    conns n = "(" <> tshow n <> " connections)"
+    srvStr = " on server " <> showSMPServer srv
 
 viewUserServers :: UserOperatorServers -> [StyledString]
 viewUserServers (UserOperatorServers _ [] []) = []

tests/Bots/DirectoryTests.hs

@@ -104,7 +104,7 @@ mkDirectoryOpts TestParams {tmpPath = ps} superUsers ownersGroup webFolder =
       directoryLog = Just $ ps </> "directory_service.log",
       migrateDirectoryLog = Nothing,
       serviceName = "SimpleX Directory",
-      clientService = False,
+      clientService = True,
       runCLI = False,
       searchResults = 3,
       webFolder,

tests/ChatClient.hs

@@ -25,6 +25,7 @@ import Data.Functor (($>))
 import Data.List (dropWhileEnd, find)
 import Data.Maybe (isNothing)
 import qualified Data.Text as T
+import Data.Time.Clock (getCurrentTime)
 import Network.Socket
 import Simplex.Chat
 import Simplex.Chat.Controller (ChatCommand (..), ChatConfig (..), ChatController (..), ChatDatabase (..), ChatLogLevel (..), defaultSimpleNetCfg)
@@ -282,11 +283,12 @@ prevVersion (Version v) = Version (v - 1)
 nextVersion :: Version v -> Version v
 nextVersion (Version v) = Version (v + 1)
 
-createTestChat :: TestParams -> ChatConfig -> ChatOpts -> String -> Profile -> IO TestCC
-createTestChat ps cfg opts@ChatOpts {coreOptions} dbPrefix profile = do
+createTestChat :: TestParams -> ChatConfig -> ChatOpts -> String -> Bool -> Profile -> IO TestCC
+createTestChat ps cfg opts@ChatOpts {coreOptions} dbPrefix clientService profile = do
   Right db@ChatDatabase {chatStore, agentStore} <- createDatabase ps coreOptions dbPrefix
   insertUser agentStore
-  Right user <- withTransaction chatStore $ \db' -> runExceptT $ createUserRecord db' (AgentUserId 1) profile True
+  ts <- getCurrentTime
+  Right user <- withTransaction chatStore $ \db' -> runExceptT $ createUserRecordAt db' (AgentUserId 1) clientService profile True ts
   startTestChat_ ps db cfg opts user
 
 startTestChat :: TestParams -> ChatConfig -> ChatOpts -> String -> IO TestCC
@@ -352,6 +354,9 @@ stopTestChat ps TestCC {chatController = cc@ChatController {smpAgent, chatStore}
 withNewTestChat :: HasCallStack => TestParams -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
 withNewTestChat ps = withNewTestChatCfgOpts ps testCfg testOpts
 
+withNewTestChat_ :: HasCallStack => TestParams -> String -> Bool -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
+withNewTestChat_ ps = withNewTestChatCfgOpts_ ps testCfg testOpts
+
 withNewTestChatV1 :: HasCallStack => TestParams -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
 withNewTestChatV1 ps = withNewTestChatCfg ps testCfgV1
 
@@ -362,9 +367,12 @@ withNewTestChatOpts :: HasCallStack => TestParams -> ChatOpts -> String -> Profi
 withNewTestChatOpts ps = withNewTestChatCfgOpts ps testCfg
 
 withNewTestChatCfgOpts :: HasCallStack => TestParams -> ChatConfig -> ChatOpts -> String -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
-withNewTestChatCfgOpts ps cfg opts dbPrefix profile runTest =
+withNewTestChatCfgOpts ps cfg opts dbPrefix = withNewTestChatCfgOpts_ ps cfg opts dbPrefix False
+
+withNewTestChatCfgOpts_ :: HasCallStack => TestParams -> ChatConfig -> ChatOpts -> String -> Bool -> Profile -> (HasCallStack => TestCC -> IO a) -> IO a
+withNewTestChatCfgOpts_ ps cfg opts dbPrefix clientService profile runTest =
   bracket
-    (createTestChat ps cfg opts dbPrefix profile)
+    (createTestChat ps cfg opts dbPrefix clientService profile)
     (stopTestChat ps)
     (\cc -> runTest cc >>= ((cc <// 100000) $>))
 
@@ -423,7 +431,7 @@ testChatN cfg opts ps test params =
   where
     getTestCCs :: [(Profile, Int)] -> IO [TestCC]
     getTestCCs [] = pure []
-    getTestCCs ((p, db) : envs') = (:) <$> createTestChat params cfg opts (show db) p <*> getTestCCs envs'
+    getTestCCs ((p, db) : envs') = (:) <$> createTestChat params cfg opts (show db) False p <*> getTestCCs envs'
     endTests tcs = do
       mapConcurrently_ (<// 100000) tcs
       mapConcurrently_ (stopTestChat params) tcs

tests/ChatTests/Profiles.hs

@@ -112,6 +112,9 @@ chatProfileTests = do
     it "should connect via contact address" testShortLinkContactAddress
     it "should join group" testShortLinkJoinGroup
   describe "short links with attached data" shortLinkTests
+  describe "client services" $ do
+    it "should create user as a service, disable and re-enable" testClientService
+    it "should create user without a service, enable and disable" testSwitchClientService
 
 shortLinkTests :: SpecWith TestParams
 shortLinkTests = do
@@ -4187,3 +4190,81 @@ testShortLinkGroupChangeProfileReceived = testChat3 aliceProfile bobProfile cath
       [alice, cath] *<# "#club bob> 2"
       cath #> "#club 3"
       [alice, bob] *<# "#club cath> 3"
+
+testClientService :: HasCallStack => TestParams -> IO ()
+testClientService ps =
+  withNewTestChat ps "alice" aliceProfile $ \alice ->
+    withNewTestChat ps "bob" bobProfile $ \bob -> do
+      -- create user as service
+      withNewTestChat_ ps "service" True serviceProfile $ \service -> do
+        connectUsers alice service
+        alice <##> service
+        service ##> "/set client service 1:service_user off"
+        service <## "error: chat not stopped"
+      -- connect as service
+      withTestChat ps "service" $ \service -> do
+        subscribeClientService service 1
+        alice <##> service
+      setClientService ps "off"
+      -- connect without service
+      withTestChat ps "service" $ \service -> do
+        service <## "subscribed 1 connections on server localhost"
+        alice <##> service
+        connectUsers bob service
+        bob <##> service
+      setClientService ps "on"
+      -- connect as service, queue associated
+      withTestChat ps "service" $ \service -> do
+        service <## "subscribed 2 connections on server localhost"
+        alice <##> service
+        bob <##> service
+      -- connect as service
+      withTestChat ps "service" $ \service -> do
+        subscribeClientService service 2
+        alice <##> service
+        bob <##> service
+
+testSwitchClientService :: HasCallStack => TestParams -> IO ()
+testSwitchClientService ps =
+  withNewTestChat ps "user" aliceProfile $ \alice ->
+    withNewTestChat ps "bob" bobProfile $ \bob -> do
+      -- create user without service
+      withNewTestChat_ ps "service" False serviceProfile $ \service -> do
+        connectUsers alice service
+        alice <##> service
+      -- connect without service
+      withTestChat ps "service" $ \service -> do
+        service <## "subscribed 1 connections on server localhost"
+        alice <##> service
+      setClientService ps "on"
+      -- connect as service, queue associated
+      withTestChat ps "service" $ \service -> do
+        service <## "subscribed 1 connections on server localhost"
+        alice <##> service
+        connectUsers bob service
+        bob <##> service
+      -- connect as service
+      withTestChat ps "service" $ \service -> do
+        subscribeClientService service 2
+        alice <##> service
+        bob <##> service
+      -- connect without service
+      setClientService ps "off"
+      withTestChat ps "service" $ \service -> do
+        service <## "subscribed 2 connections on server localhost"
+        alice <##> service
+        bob <##> service
+
+setClientService :: TestParams -> String -> IO ()
+setClientService ps onOff =
+  withTestChatCfgOpts ps testCfg testOpts {maintenance = True} "service" $ \service -> do
+    service ##> ("/set client service 1:service_user " <> onOff)
+    service <## "ok"
+    
+subscribeClientService :: TestCC -> Int -> IO ()
+subscribeClientService service n =
+  service
+    <###
+      [ ConsoleString $ "subscribed service (" <> show n <> " connections) on server localhost: ok",
+        "received messages from service on server localhost"
+      ]

tests/ChatTests/Utils.hs

@@ -78,6 +78,9 @@ eveProfile = mkProfile "eve" "Eve" Nothing
 businessProfile :: Profile
 businessProfile = mkProfile "biz" "Biz Inc" Nothing
 
+serviceProfile :: Profile
+serviceProfile = mkProfile "service_user" "Service user" Nothing
+
 mkProfile :: T.Text -> T.Text -> Maybe ImageData -> Profile
 mkProfile displayName descr image = Profile {displayName, fullName = "", shortDescr = Just descr, image, contactLink = Nothing, peerType = Nothing, preferences = defaultPrefs}
 

tests/MobileTests.hs

@@ -22,6 +22,7 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as BS
 import Data.ByteString.Internal (create)
 import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.Time.Clock (getCurrentTime)
 import Data.Word (Word8, Word32)
 import Foreign.C
 import Foreign.Marshal.Alloc (mallocBytes)
@@ -147,7 +148,8 @@ testChatApi ps = do
       dbPrefix = tmp </> "1"
   Right ChatDatabase {chatStore, agentStore} <- createChatDatabase (ChatDbOpts dbPrefix "myKey" DB.TQOff True) (MigrationConfig MCYesUp Nothing)
   insertUser agentStore
-  Right _ <- withTransaction chatStore $ \db -> runExceptT $ createUserRecord db (AgentUserId 1) aliceProfile {preferences = Nothing} True
+  ts <- getCurrentTime
+  Right _ <- withTransaction chatStore $ \db -> runExceptT $ createUserRecordAt db (AgentUserId 1) False aliceProfile {preferences = Nothing} True ts
   Right cc <- chatMigrateInit dbPrefix "myKey" "yesUp"
   Left (DBMErrorNotADatabase _) <- chatMigrateInit dbPrefix "" "yesUp"
   Left (DBMErrorNotADatabase _) <- chatMigrateInit dbPrefix "anotherKey" "yesUp"