Merge branch 'master' into remote-desktop

2026-06-05 10:12:59 +00:00 · 2023-10-16 21:38:54 +01:00
parent fc1bba8817 e4c8386f3f
commit 92eae012b3
27 changed files with 365 additions and 134 deletions
@@ -189,6 +189,7 @@ data ChatController = ChatController
    cleanupManagerAsync :: TVar (Maybe (Async ())),
    timedItemThreads :: TMap (ChatRef, ChatItemId) (TVar (Maybe (Weak ThreadId))),
    showLiveItems :: TVar Bool,
+    encryptLocalFiles :: TVar Bool,
    userXFTPFileConfig :: TVar (Maybe XFTPFileConfig),
    tempDirectory :: TVar (Maybe FilePath),
    logFilePath :: Maybe FilePath,
@@ -234,6 +235,7 @@ data ChatCommand
  | SetTempFolder FilePath
  | SetFilesFolder FilePath
  | APISetXFTPConfig (Maybe XFTPFileConfig)
+  | APISetEncryptLocalFiles Bool
  | SetContactMergeEnabled Bool
  | APIExportArchive ArchiveConfig
  | ExportArchive
@@ -406,8 +408,8 @@ data ChatCommand
  | ForwardFile ChatName FileTransferId
  | ForwardImage ChatName FileTransferId
  | SendFileDescription ChatName FilePath
-  | ReceiveFile {fileId :: FileTransferId, storeEncrypted :: Bool, fileInline :: Maybe Bool, filePath :: Maybe FilePath}
-  | SetFileToReceive {fileId :: FileTransferId, storeEncrypted :: Bool}
+  | ReceiveFile {fileId :: FileTransferId, storeEncrypted :: Maybe Bool, fileInline :: Maybe Bool, filePath :: Maybe FilePath}
+  | SetFileToReceive {fileId :: FileTransferId, storeEncrypted :: Maybe Bool}
  | CancelFile FileTransferId
  | FileStatus FileTransferId
  | ShowProfile -- UserId (not used in UI)
@@ -723,7 +725,8 @@ instance ToJSON InvitationLinkPlan where
 data ContactAddressPlan
  = CAPOk
  | CAPOwnLink
-  | CAPConnecting {contact :: Contact}
+  | CAPConnectingConfirmReconnect
+  | CAPConnectingProhibit {contact :: Contact}
  | CAPKnown {contact :: Contact}
  deriving (Show, Generic)

@@ -737,7 +740,8 @@ instance ToJSON ContactAddressPlan where
 data GroupLinkPlan
  = GLPOk
  | GLPOwnLink {groupInfo :: GroupInfo}
-  | GLPConnecting {groupInfo_ :: Maybe GroupInfo}
+  | GLPConnectingConfirmReconnect
+  | GLPConnectingProhibit {groupInfo_ :: Maybe GroupInfo}
  | GLPKnown {groupInfo :: GroupInfo}
  deriving (Show, Generic)

@@ -748,8 +752,8 @@ instance ToJSON GroupLinkPlan where
  toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "GLP"
  toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "GLP"

-connectionPlanOk :: ConnectionPlan -> Bool
-connectionPlanOk = \case
+connectionPlanProceed :: ConnectionPlan -> Bool
+connectionPlanProceed = \case
  CPInvitationLink ilp -> case ilp of
    ILPOk -> True
    ILPOwnLink -> True
@@ -757,10 +761,12 @@ connectionPlanOk = \case
  CPContactAddress cap -> case cap of
    CAPOk -> True
    CAPOwnLink -> True
+    CAPConnectingConfirmReconnect -> True
    _ -> False
  CPGroupLink glp -> case glp of
    GLPOk -> True
    GLPOwnLink _ -> True
+    GLPConnectingConfirmReconnect -> True
    _ -> False

 newtype UserPwd = UserPwd {unUserPwd :: Text}
@@ -33,7 +33,7 @@ import Simplex.Chat.Types.Util
 import Simplex.Messaging.Agent.Protocol (AConnectionRequestUri (..), ConnReqScheme (..), ConnReqUriData (..), ConnectionRequestUri (..), SMPQueue (..))
 import Simplex.Messaging.Encoding.String
 import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fstToLower, sumTypeJSON)
-import Simplex.Messaging.Protocol (ProtocolServer (..), SrvLoc (..))
+import Simplex.Messaging.Protocol (ProtocolServer (..))
 import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.Console.ANSI.Types
 import qualified Text.Email.Validate as Email
@@ -49,7 +49,7 @@ data Format
  | Secret
  | Colored {color :: FormatColor}
  | Uri
-  | SimplexLink {linkType :: SimplexLinkType, simplexUri :: Text, trustedUri :: Bool, smpHosts :: NonEmpty Text}
+  | SimplexLink {linkType :: SimplexLinkType, simplexUri :: Text, smpHosts :: NonEmpty Text}
  | Email
  | Phone
  deriving (Eq, Show, Generic)
@@ -248,15 +248,12 @@ markdownP = mconcat <$> A.many' fragmentP
    simplexUriFormat = \case
      ACR _ (CRContactUri crData) ->
        let uri = safeDecodeUtf8 . strEncode $ CRContactUri crData {crScheme = CRSSimplex}
-         in SimplexLink (linkType' crData) uri (trustedUri' crData) $ uriHosts crData
+         in SimplexLink (linkType' crData) uri $ uriHosts crData
      ACR _ (CRInvitationUri crData e2e) ->
        let uri = safeDecodeUtf8 . strEncode $ CRInvitationUri crData {crScheme = CRSSimplex} e2e
-         in SimplexLink XLInvitation uri (trustedUri' crData) $ uriHosts crData
+         in SimplexLink XLInvitation uri $ uriHosts crData
      where
        uriHosts ConnReqUriData {crSmpQueues} = L.map (safeDecodeUtf8 . strEncode) $ sconcat $ L.map (host . qServer) crSmpQueues
-        trustedUri' ConnReqUriData {crScheme} = case crScheme of
-          CRSSimplex -> True
-          CRSAppServer (SrvLoc host _) -> host == "simplex.chat"
        linkType' ConnReqUriData {crClientData} = case crClientData >>= decodeJSON of
          Just (CRDataGroup _) -> XLGroup
          Nothing -> XLContact
@@ -10,6 +10,7 @@
 module Simplex.Chat.Store.Connections
  ( getConnectionEntity,
    getConnectionEntityByConnReq,
+    getContactConnEntityByConnReqHash,
    getConnectionsToSubscribe,
    unsetConnectionToSubscribe,
  )
@@ -153,10 +154,33 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
        userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
        userContact_ _ = Left SEUserContactLinkNotFound

-getConnectionEntityByConnReq :: DB.Connection -> User -> ConnReqInvitation -> IO (Maybe ConnectionEntity)
-getConnectionEntityByConnReq db user cReq = do
+getConnectionEntityByConnReq :: DB.Connection -> User -> (ConnReqInvitation, ConnReqInvitation) -> IO (Maybe ConnectionEntity)
+getConnectionEntityByConnReq db user (cReqSchema1, cReqSchema2) = do
  connId_ <- maybeFirstRow fromOnly $
-    DB.query db "SELECT agent_conn_id FROM connections WHERE conn_req_inv = ? LIMIT 1" (Only cReq)
+    DB.query db "SELECT agent_conn_id FROM connections WHERE conn_req_inv IN (?,?) LIMIT 1" (cReqSchema1, cReqSchema2)
+  maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
+
+-- search connection for connection plan:
+-- multiple connections can have same via_contact_uri_hash if request was repeated;
+-- this function searches for latest connection with contact so that "known contact" plan would be chosen;
+-- deleted connections are filtered out to allow re-connecting via same contact address
+getContactConnEntityByConnReqHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe ConnectionEntity)
+getContactConnEntityByConnReqHash db user (cReqHash1, cReqHash2) = do
+  connId_ <- maybeFirstRow fromOnly $
+    DB.query
+      db
+      [sql|
+        SELECT agent_conn_id FROM (
+          SELECT
+            agent_conn_id,
+            (CASE WHEN contact_id IS NOT NULL THEN 1 ELSE 0 END) AS conn_ord
+          FROM connections
+          WHERE via_contact_uri_hash IN (?,?) AND conn_status != ?
+          ORDER BY conn_ord DESC, created_at DESC
+          LIMIT 1
+        )
+      |]
+      (cReqHash1, cReqHash2, ConnDeleted)
  maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_

 getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity])
@@ -1121,21 +1121,21 @@ getGroupInfo db User {userId, userContactId} groupId =
      |]
      (groupId, userId, userContactId)

-getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> ConnReqContact -> IO (Maybe GroupInfo)
-getGroupInfoByUserContactLinkConnReq db user cReq = do
+getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> (ConnReqContact, ConnReqContact) -> IO (Maybe GroupInfo)
+getGroupInfoByUserContactLinkConnReq db user (cReqSchema1, cReqSchema2) = do
  groupId_ <- maybeFirstRow fromOnly $
    DB.query
      db
      [sql|
        SELECT group_id
        FROM user_contact_links
-        WHERE conn_req_contact = ?
+        WHERE conn_req_contact IN (?,?)
      |]
-      (Only cReq)
+      (cReqSchema1, cReqSchema2)
  maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_

-getGroupInfoByGroupLinkHash :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe GroupInfo)
-getGroupInfoByGroupLinkHash db user@User {userId, userContactId} groupLinkHash = do
+getGroupInfoByGroupLinkHash :: DB.Connection -> User -> (ConnReqUriHash, ConnReqUriHash) -> IO (Maybe GroupInfo)
+getGroupInfoByGroupLinkHash db user@User {userId, userContactId} (groupLinkHash1, groupLinkHash2) = do
  groupId_ <- maybeFirstRow fromOnly $
    DB.query
      db
@@ -1143,11 +1143,11 @@ getGroupInfoByGroupLinkHash db user@User {userId, userContactId} groupLinkHash =
        SELECT g.group_id
        FROM groups g
        JOIN group_members mu ON mu.group_id = g.group_id
-        WHERE g.user_id = ? AND g.via_group_link_uri_hash = ?
+        WHERE g.user_id = ? AND g.via_group_link_uri_hash IN (?,?)
          AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?)
        LIMIT 1
      |]
-      (userId, groupLinkHash, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
+      (userId, groupLinkHash1, groupLinkHash2, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
  maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_

 getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
@@ -442,17 +442,17 @@ getUserContactLinkById db userId userContactLinkId =
      |]
      (userId, userContactLinkId)

-getUserContactLinkByConnReq :: DB.Connection -> ConnReqContact -> IO (Maybe UserContactLink)
-getUserContactLinkByConnReq db cReq =
+getUserContactLinkByConnReq :: DB.Connection -> (ConnReqContact, ConnReqContact) -> IO (Maybe UserContactLink)
+getUserContactLinkByConnReq db (cReqSchema1, cReqSchema2) =
  maybeFirstRow toUserContactLink $
    DB.query
      db
      [sql|
        SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content
        FROM user_contact_links
-        WHERE conn_req_contact = ?
+        WHERE conn_req_contact IN (?,?)
      |]
-      (Only cReq)
+      (cReqSchema1, cReqSchema2)

 updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink
 updateUserAddressAutoAccept db user@User {userId} autoAccept = do
@@ -207,6 +207,9 @@ contactReady Contact {activeConn} = connReady activeConn
 contactActive :: Contact -> Bool
 contactActive Contact {contactStatus} = contactStatus == CSActive

+contactDeleted :: Contact -> Bool
+contactDeleted Contact {contactStatus} = contactStatus == CSDeleted
+
 contactSecurityCode :: Contact -> Maybe SecurityCode
 contactSecurityCode Contact {activeConn} = connectionCode activeConn

@@ -167,7 +167,7 @@ responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showRecei
  CRRcvFileDescrReady _ _ -> []
  CRRcvFileDescrNotReady _ _ -> []
  CRRcvFileProgressXFTP {} -> []
-  CRRcvFileAccepted u ci -> ttyUser u $ savingFile' testView ci
+  CRRcvFileAccepted u ci -> ttyUser u $ savingFile' ci
  CRRcvFileAcceptedSndCancelled u ft -> ttyUser u $ viewRcvFileSndCancelled ft
  CRSndFileCancelled u _ ftm fts -> ttyUser u $ viewSndFileCancelled ftm fts
  CRRcvFileCancelled u _ ft -> ttyUser u $ receivingFile_ "cancelled" ft
@@ -179,10 +179,10 @@ responseToView (currentRH, user_) ChatConfig {logLevel, showReactions, showRecei
  CRContactUpdated {user = u, fromContact = c, toContact = c'} -> ttyUser u $ viewContactUpdated c c' <> viewContactPrefsUpdated u c c'
  CRContactsMerged u intoCt mergedCt ct' -> ttyUser u $ viewContactsMerged intoCt mergedCt ct'
  CRReceivedContactRequest u UserContactRequest {localDisplayName = c, profile} -> ttyUser u $ viewReceivedContactRequest c profile
-  CRRcvFileStart u ci -> ttyUser u $ receivingFile_' "started" ci
-  CRRcvFileComplete u ci -> ttyUser u $ receivingFile_' "completed" ci
+  CRRcvFileStart u ci -> ttyUser u $ receivingFile_' testView "started" ci
+  CRRcvFileComplete u ci -> ttyUser u $ receivingFile_' testView "completed" ci
  CRRcvFileSndCancelled u _ ft -> ttyUser u $ viewRcvFileSndCancelled ft
-  CRRcvFileError u ci e -> ttyUser u $ receivingFile_' "error" ci <> [sShow e]
+  CRRcvFileError u ci e -> ttyUser u $ receivingFile_' testView "error" ci <> [sShow e]
  CRSndFileStart u _ ft -> ttyUser u $ sendingFile_ "started" ft
  CRSndFileComplete u _ ft -> ttyUser u $ sendingFile_ "completed" ft
  CRSndFileStartXFTP {} -> []
@@ -707,11 +707,14 @@ viewConnReqInvitation :: ConnReqInvitation -> [StyledString]
 viewConnReqInvitation cReq =
  [ "pass this invitation link to your contact (via another channel): ",
    "",
-    (plain . strEncode) cReq,
+    (plain . strEncode) (simplexChatInvitation cReq),
    "",
    "and ask them to connect: " <> highlight' "/c <invitation_link_above>"
  ]

+simplexChatInvitation :: ConnReqInvitation -> ConnReqInvitation
+simplexChatInvitation (CRInvitationUri crData e2e) = CRInvitationUri crData {crScheme = simplexChat} e2e
+
 viewContactNotFound :: ContactName -> Maybe (GroupInfo, GroupMember) -> [StyledString]
 viewContactNotFound cName suspectedMember =
  ["no contact " <> ttyContact cName <> useMessageMember]
@@ -750,7 +753,7 @@ connReqContact_ :: StyledString -> ConnReqContact -> [StyledString]
 connReqContact_ intro cReq =
  [ intro,
    "",
-    (plain . strEncode) cReq,
+    (plain . strEncode) (simplexChatContact cReq),
    "",
    "Anybody can send you contact requests with: " <> highlight' "/c <contact_link_above>",
    "to show it again: " <> highlight' "/sa",
@@ -758,6 +761,9 @@ connReqContact_ intro cReq =
    "to delete it: " <> highlight' "/da" <> " (accepted contacts will remain connected)"
  ]

+simplexChatContact :: ConnReqContact -> ConnReqContact
+simplexChatContact (CRContactUri crData) = CRContactUri crData {crScheme = simplexChat}
+
 autoAcceptStatus_ :: Maybe AutoAccept -> [StyledString]
 autoAcceptStatus_ = \case
  Just AutoAccept {acceptIncognito, autoReply} ->
@@ -769,7 +775,7 @@ groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> GroupMemberRole ->
 groupLink_ intro g cReq mRole =
  [ intro,
    "",
-    (plain . strEncode) cReq,
+    (plain . strEncode) (simplexChatContact cReq),
    "",
    "Anybody can connect to you and join group as " <> showRole mRole <> " with: " <> highlight' "/c <group_link_above>",
    "to show it again: " <> highlight ("/show link #" <> viewGroupName g),
@@ -1036,7 +1042,7 @@ viewContactInfo :: Contact -> ConnectionStats -> Maybe Profile -> [StyledString]
 viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}, activeConn} stats incognitoProfile =
  ["contact ID: " <> sShow contactId]
    <> viewConnectionStats stats
-    <> maybe [] (\l -> ["contact address: " <> (plain . strEncode) l]) contactLink
+    <> maybe [] (\l -> ["contact address: " <> (plain . strEncode) (simplexChatContact l)]) contactLink
    <> maybe
      ["you've shared main profile with this contact"]
      (\p -> ["you've shared incognito profile with this contact: " <> incognitoProfile' p])
@@ -1295,7 +1301,8 @@ viewConnectionPlan = \case
  CPContactAddress cap -> case cap of
    CAPOk -> [ctAddr "ok to connect"]
    CAPOwnLink -> [ctAddr "own address"]
-    CAPConnecting ct -> [ctAddr ("connecting to contact " <> ttyContact' ct)]
+    CAPConnectingConfirmReconnect -> [ctAddr "connecting, allowed to reconnect"]
+    CAPConnectingProhibit ct -> [ctAddr ("connecting to contact " <> ttyContact' ct)]
    CAPKnown ct ->
      [ ctAddr ("known contact " <> ttyContact' ct),
        "use " <> ttyToContact' ct <> highlight' "<message>" <> " to send messages"
@@ -1305,8 +1312,9 @@ viewConnectionPlan = \case
  CPGroupLink glp -> case glp of
    GLPOk -> [grpLink "ok to connect"]
    GLPOwnLink g -> [grpLink "own link for group " <> ttyGroup' g]
-    GLPConnecting Nothing -> [grpLink "connecting"]
-    GLPConnecting (Just g) -> [grpLink ("connecting to group " <> ttyGroup' g)]
+    GLPConnectingConfirmReconnect -> [grpLink "connecting, allowed to reconnect"]
+    GLPConnectingProhibit Nothing -> [grpLink "connecting"]
+    GLPConnectingProhibit (Just g) -> [grpLink ("connecting to group " <> ttyGroup' g)]
    GLPKnown g ->
      [ grpLink ("known group " <> ttyGroup' g),
        "use " <> ttyToGroup g <> highlight' "<message>" <> " to send messages"
@@ -1463,27 +1471,28 @@ humanReadableSize size
    mB = kB * 1024
    gB = mB * 1024

-savingFile' :: Bool -> AChatItem -> [StyledString]
-savingFile' testView (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileSource = Just (CryptoFile filePath cfArgs_)}, chatDir}) =
-  let from = case (chat, chatDir) of
-        (DirectChat Contact {localDisplayName = c}, CIDirectRcv) -> " from " <> ttyContact c
-        (_, CIGroupRcv GroupMember {localDisplayName = m}) -> " from " <> ttyContact m
-        _ -> ""
-   in ["saving file " <> sShow fileId <> from <> " to " <> plain filePath] <> cfArgsStr
-  where
-    cfArgsStr = case cfArgs_ of
-      Just cfArgs@(CFArgs key nonce)
-        | testView -> [plain $ LB.unpack $ J.encode cfArgs]
-        | otherwise -> [plain $ "encryption key: " <> strEncode key <> ", nonce: " <> strEncode nonce]
-      _ -> []
-savingFile' _ _ = ["saving file"] -- shouldn't happen
+savingFile' :: AChatItem -> [StyledString]
+savingFile' (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileSource = Just (CryptoFile filePath _)}, chatDir}) =
+  ["saving file " <> sShow fileId <> fileFrom chat chatDir <> " to " <> plain filePath]
+savingFile' _ = ["saving file"] -- shouldn't happen

-receivingFile_' :: StyledString -> AChatItem -> [StyledString]
-receivingFile_' status (AChatItem _ _ (DirectChat c) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectRcv}) =
-  [status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyContact' c]
-receivingFile_' status (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupRcv m}) =
-  [status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyMember m]
-receivingFile_' status _ = [status <> " receiving file"] -- shouldn't happen
+receivingFile_' :: Bool -> String -> AChatItem -> [StyledString]
+receivingFile_' testView status (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileName, fileSource = Just (CryptoFile _ cfArgs_)}, chatDir}) =
+  [plain status <> " receiving " <> fileTransferStr fileId fileName <> fileFrom chat chatDir] <> cfArgsStr cfArgs_
+  where
+    cfArgsStr (Just cfArgs@(CFArgs key nonce)) = [plain s | status == "completed"]
+      where
+      s =
+        if testView
+          then LB.toStrict $ J.encode cfArgs
+          else "encryption key: " <> strEncode key <> ", nonce: " <> strEncode nonce
+    cfArgsStr _ = []
+receivingFile_' _ status _ = [plain status <> " receiving file"] -- shouldn't happen
+
+fileFrom :: ChatInfo c -> CIDirection c d -> StyledString
+fileFrom (DirectChat ct) CIDirectRcv = " from " <> ttyContact' ct
+fileFrom _ (CIGroupRcv m) = " from " <> ttyMember m
+fileFrom _ _ = ""

 receivingFile_ :: StyledString -> RcvFileTransfer -> [StyledString]
 receivingFile_ status ft@RcvFileTransfer {senderDisplayName = c} =