cli command to toggle service for a user

cabal.project

@@ -1,5 +1,5 @@
-packages: .
--- packages: . ../simplexmq
+-- packages: .
+packages: . ../simplexmq
 -- packages: . ../simplexmq ../direct-sqlcipher ../sqlcipher-simple
 
 index-state: 2023-12-12T00:00:00Z
@@ -9,10 +9,10 @@ package cryptostore
 
 constraints: zip +disable-bzip2 +disable-zstd
 
-source-repository-package
-    type: git
-    location: https://github.com/simplex-chat/simplexmq.git
-    tag: db4b27e88a95af5b295d393b4c4483ffd220fafb
+-- source-repository-package
+    -- type: git
+    -- location: https://github.com/simplex-chat/simplexmq.git
+    -- tag: db4b27e88a95af5b295d393b4c4483ffd220fafb
 
 source-repository-package
     type: git

src/Simplex/Chat/Controller.hs

@@ -284,6 +284,7 @@ data ChatCommand
   | UnhideUser UserPwd
   | MuteUser
   | UnmuteUser
+  | SetClientService UserId ContactName Bool
   | APIDeleteUser {userId :: UserId, delSMPQueues :: Bool, viewPwd :: Maybe UserPwd}
   | DeleteUser UserName Bool (Maybe UserPwd)
   | StartChat {mainApp :: Bool, enableSndFiles :: Bool} -- enableSndFiles has no effect when mainApp is True
@@ -827,6 +828,7 @@ data ChatEvent
   | CEvtConnectionsDiff {userIds :: DatabaseDiff AgentUserId, connIds :: DatabaseDiff AgentConnId}
   | CEvtSubscriptionEnd {user :: User, connectionEntity :: ConnectionEntity}
   | CEvtSubscriptionStatus {server :: SMPServer, subscriptionStatus :: SubscriptionStatus, connections :: [AgentConnId]}
+  | CEvtServiceSubStatus {server :: SMPServer, serviceSubEvent :: ServiceSubEvent}
   | CEvtHostConnected {protocol :: AProtocolType, transportHost :: TransportHost}
   | CEvtHostDisconnected {protocol :: AProtocolType, transportHost :: TransportHost}
   | CEvtReceivedGroupInvitation {user :: User, groupInfo :: GroupInfo, contact :: Contact, fromMemberRole :: GroupMemberRole, memberRole :: GroupMemberRole}
@@ -1215,6 +1217,13 @@ data ChatItemDeletion = ChatItemDeletion
   }
   deriving (Show)
 
+data ServiceSubEvent
+  = ServiceSubUp {serviceError :: Maybe Text, queueCount :: Int64}
+  | ServiceSubDown {queueCount :: Int64}
+  | ServiceSubAll
+  | ServiceSubEnd {queueCount :: Int64}
+  deriving (Show)
+  
 data ChatLogLevel = CLLDebug | CLLInfo | CLLWarning | CLLError | CLLImportant
   deriving (Eq, Ord, Show)
 
@@ -1248,7 +1257,6 @@ data ChatErrorType
   | CENoSndFileUser {agentSndFileId :: AgentSndFileId}
   | CENoRcvFileUser {agentRcvFileId :: AgentRcvFileId}
   | CEUserUnknown
-  | CEActiveUserExists -- TODO delete
   | CEUserExists {contactName :: ContactName}
   | CEDifferentActiveUser {commandUserId :: UserId, activeUserId :: UserId}
   | CECantDeleteActiveUser {userId :: UserId}
@@ -1627,6 +1635,8 @@ $(JQ.deriveJSON defaultJSON ''ParsedServerAddress)
 
 $(JQ.deriveJSON defaultJSON ''ChatItemDeletion)
 
+$(JQ.deriveJSON (sumTypeJSON $ dropPrefix "ServiceSub") ''ServiceSubEvent)
+
 $(JQ.deriveJSON defaultJSON ''CoreVersionInfo)
 
 #if !defined(dbPostgres)

src/Simplex/Chat/Library/Commands.hs

@@ -432,6 +432,17 @@ 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}} <-
+      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
+        when (userId == userId') $ chatWriteVar currentUser $ Just user'
+        ok user'
   APIDeleteUser userId' delSMPQueues viewPwd_ -> withUser $ \user -> do
     user' <- privateGetUser userId'
     validateUserPassword user user' viewPwd_
@@ -4314,6 +4325,7 @@ chatCommandP =
       "/unhide user " *> (UnhideUser <$> pwdP),
       "/mute user" $> MuteUser,
       "/unmute user" $> UnmuteUser,
+      "/set client service " *> (SetClientService <$> A.decimal <* A.char ':' <*> displayNameP <*> 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/Library/Subscriber.hs

@@ -82,7 +82,7 @@ import Simplex.Messaging.Crypto.File (CryptoFile (..))
 import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Protocol (ErrorType (..), MsgFlags (..))
+import Simplex.Messaging.Protocol (ErrorType (..), MsgFlags (..), ServiceSub (..), ServiceSubError (..), ServiceSubResult (..))
 import qualified Simplex.Messaging.Protocol as SMP
 import qualified Simplex.Messaging.TMap as TM
 import Simplex.Messaging.Transport (TransportError (..))
@@ -136,17 +136,23 @@ processAgentMessageNoConn = \case
   UP srv conns -> serverEvent srv SSActive conns
   SUSPENDED -> toView CEvtChatSuspended
   DEL_USER agentUserId -> toView $ CEvtAgentUserDeleted agentUserId
-  -- TODO [certs rcv] chat events
-  SERVICE_ALL _ -> pure ()
-  SERVICE_DOWN _ _ -> pure ()
-  SERVICE_UP _ _ -> pure ()
-  SERVICE_END _ _ -> pure ()
+  SERVICE_UP srv (ServiceSubResult e_ ss) -> serviceEvent srv $ ServiceSubUp (errText <$> e_) (smpQueueCount ss)
+    where
+      errText = \case
+        SSErrorServiceId {} -> "unexpected service ID"
+        SSErrorQueueCount {expectedQueueCount = n} -> "expected " <> tshow n <> " connections"
+        SSErrorQueueIdsHash {} -> "different IDs hash"
+  SERVICE_DOWN srv ss -> serviceEvent srv $ ServiceSubDown $ smpQueueCount ss
+  SERVICE_ALL srv -> serviceEvent srv ServiceSubAll
+  SERVICE_END srv ss -> serviceEvent srv $ ServiceSubEnd $ smpQueueCount ss
   ERRS cErrs -> errsEvent $ L.toList cErrs
   where
     hostEvent :: ChatEvent -> CM ()
     hostEvent = whenM (asks $ hostEvents . config) . toView
     serverEvent :: SMPServer -> SubscriptionStatus -> [ConnId] -> CM ()
     serverEvent srv nsStatus conns = toView $ CEvtSubscriptionStatus srv nsStatus $ map AgentConnId conns
+    serviceEvent :: SMPServer -> ServiceSubEvent -> CM ()
+    serviceEvent srv = toView . CEvtServiceSubStatus srv
     errsEvent :: [(ConnId, AgentErrorType)] -> CM ()
     errsEvent = toView . CEvtChatErrors . map (\(cId, e) -> ChatErrorAgent e (AgentConnId cId) Nothing)
 

src/Simplex/Chat/Store/Profiles.hs

@@ -37,6 +37,7 @@ module Simplex.Chat.Store.Profiles
     getUserFileInfo,
     deleteUserRecord,
     updateUserPrivacy,
+    updateClientService,
     updateAllContactReceipts,
     updateUserContactReceipts,
     updateUserGroupReceipts,
@@ -275,6 +276,17 @@ updateUserPrivacy db User {userId, showNtfs, viewPwdHash} =
   where
     hashSalt = L.unzip . fmap (\UserPwdHash {hash, salt} -> (hash, salt))
 
+updateClientService :: DB.Connection -> UserId -> Bool -> IO ()
+updateClientService db userId enable =
+  DB.execute
+    db
+    [sql|
+      UPDATE users
+      SET client_service = ?
+      WHERE user_id = ?
+    |]
+    (BI enable, userId)
+
 updateAllContactReceipts :: DB.Connection -> Bool -> IO ()
 updateAllContactReceipts db onOff =
   DB.execute

src/Simplex/Chat/View.hs

@@ -454,7 +454,8 @@ chatEventToView hu ChatConfig {logLevel, showReactions, showReceipts, testView}
   CEvtSubscriptionEnd u acEntity ->
     let Connection {connId} = entityConnection acEntity
      in ttyUser u [sShow connId <> ": END"]
-  CEvtSubscriptionStatus srv status conns -> [plain $ subStatusStr status <> " " <> show (length conns) <> " connections on server " <> showSMPServer srv]
+  CEvtSubscriptionStatus srv status conns -> [plain $ subStatusStr status <> " " <> tshow (length conns) <> " connections on server " <> showSMPServer srv]
+  CEvtServiceSubStatus srv event -> viewServiceSubEvent 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
@@ -597,8 +598,8 @@ viewUsersList us =
           Just CPTBot -> " (bot)"
           _ -> ""
 
-showSMPServer :: SMPServer -> String
-showSMPServer ProtocolServer {host} = B.unpack $ strEncode host
+showSMPServer :: SMPServer -> Text
+showSMPServer ProtocolServer {host} = safeDecodeUtf8 $ strEncode host
 
 viewHostEvent :: AProtocolType -> TransportHost -> String
 viewHostEvent p h = map toUpper (B.unpack $ strEncode p) <> " host " <> B.unpack (strEncode h)
@@ -1464,13 +1465,23 @@ viewConnDiffIds userDiff connDiff
       where
         showIds = plain . T.intercalate ", " . map (tshow . unwrapId)
 
-subStatusStr :: SubscriptionStatus -> String
+subStatusStr :: SubscriptionStatus -> Text
 subStatusStr = \case
   SSActive -> "subscribed"
   SSPending -> "disconnected"
-  SSRemoved e -> "removed: " <> e
+  SSRemoved e -> "removed: " <> T.pack e
   SSNoSub -> "no subscription"
 
+viewServiceSubEvent :: SMPServer -> ServiceSubEvent -> [StyledString]
+viewServiceSubEvent srv event = [plain $ eventStr <> " on server " <> showSMPServer srv]
+  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)"
+
 viewUserServers :: UserOperatorServers -> [StyledString]
 viewUserServers (UserOperatorServers _ [] []) = []
 viewUserServers UserOperatorServers {operator, smpServers, xftpServers} =
@@ -1669,7 +1680,7 @@ viewConnectionStats ConnectionStats {rcvQueuesInfo, sndQueuesInfo} =
     <> ["sending messages via: " <> viewSndQueuesInfo sndQueuesInfo | not $ null sndQueuesInfo]
 
 viewRcvQueuesInfo :: [RcvQueueInfo] -> StyledString
-viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo
+viewRcvQueuesInfo = plain . T.intercalate ", " . map showQueueInfo
   where
     showQueueInfo RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch} =
       let switchCanBeAborted = if canAbortSwitch then ", can be aborted" else ""
@@ -1682,7 +1693,7 @@ viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo
       RSReceivedMessage -> "switch secured"
 
 viewSndQueuesInfo :: [SndQueueInfo] -> StyledString
-viewSndQueuesInfo = plain . intercalate ", " . map showQueueInfo
+viewSndQueuesInfo = plain . T.intercalate ", " . map showQueueInfo
   where
     showQueueInfo SndQueueInfo {sndServer, sndSwitchStatus} =
       showSMPServer sndServer
@@ -2414,7 +2425,6 @@ viewChatError isCmd logLevel testView = \case
     CENoConnectionUser agentConnId -> ["error: message user not found, conn id: " <> sShow agentConnId | logLevel <= CLLError]
     CENoSndFileUser aFileId -> ["error: snd file user not found, file id: " <> sShow aFileId | logLevel <= CLLError]
     CENoRcvFileUser aFileId -> ["error: rcv file user not found, file id: " <> sShow aFileId | logLevel <= CLLError]
-    CEActiveUserExists -> ["error: active user already exists"]
     CEUserExists name -> ["user with the name " <> ttyContact name <> " already exists"]
     CEUserUnknown -> ["user does not exist or incorrect password"]
     CEDifferentActiveUser commandUserId activeUserId -> ["error: different active user, command user id: " <> sShow commandUserId <> ", active user id: " <> sShow activeUserId]