diff --git a/cabal.project b/cabal.project index 6989ba322b..ce23090223 100644 --- a/cabal.project +++ b/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 diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 1f797a79b4..56bdd19d1a 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/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) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index adc353bffd..0b6491b1e9 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/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, diff --git a/src/Simplex/Chat/Library/Subscriber.hs b/src/Simplex/Chat/Library/Subscriber.hs index 9d9518b490..13ee726cb2 100644 --- a/src/Simplex/Chat/Library/Subscriber.hs +++ b/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) diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index 008502d7df..bc541b9abe 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/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 diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 084d5d9f5e..e00b015299 100644 --- a/src/Simplex/Chat/View.hs +++ b/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]