From 177c007edc09eec215b9bcb36f1748a93638b9fd Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 8 Dec 2021 13:09:51 +0000 Subject: [PATCH] Permanent user addresses (aka contact links) (#139) * update for ConectionMode parameters * update with CONF notification and different ConnectionRequest types * high level flow for contact requests, add x.con to chat protocol * store functions for user contact links and contact requests * contact links work * subscribe to user contact link connection * subscribe to user contact address: messages * send rejectContact to the agents when rejected in chat * user contact link (address) test * Update src/Simplex/Chat/View.hs * Update tests/ChatTests.hs * user address help, fix tests * delete connection requests when contact link deleted Co-authored-by: Efim Poberezkin <8711996+efim-poberezkin@users.noreply.github.com> --- migrations/20211205_user_contacts.sql | 29 +++ src/Simplex/Chat.hs | 132 ++++++++++--- src/Simplex/Chat/Help.hs | 34 +++- src/Simplex/Chat/Protocol.hs | 59 ++++-- src/Simplex/Chat/Store.hs | 270 +++++++++++++++++++++----- src/Simplex/Chat/Types.hs | 39 +++- src/Simplex/Chat/View.hs | 96 ++++++++- stack.yaml | 2 +- tests/ChatTests.hs | 94 ++++++++- 9 files changed, 631 insertions(+), 124 deletions(-) create mode 100644 migrations/20211205_user_contacts.sql diff --git a/migrations/20211205_user_contacts.sql b/migrations/20211205_user_contacts.sql new file mode 100644 index 0000000000..faca794c8e --- /dev/null +++ b/migrations/20211205_user_contacts.sql @@ -0,0 +1,29 @@ +CREATE TABLE user_contact_links ( + user_contact_link_id INTEGER PRIMARY KEY, + conn_req_contact BLOB NOT NULL, + local_display_name TEXT NOT NULL DEFAULT '', + created_at TEXT NOT NULL DEFAULT (datetime('now')), + user_id INTEGER NOT NULL REFERENCES users, + UNIQUE (user_id, local_display_name) +); + +CREATE TABLE contact_requests ( + contact_request_id INTEGER PRIMARY KEY, + user_contact_link_id INTEGER NOT NULL REFERENCES user_contact_links + ON UPDATE CASCADE ON DELETE CASCADE, + agent_invitation_id BLOB NOT NULL, + contact_profile_id INTEGER REFERENCES contact_profiles + DEFERRABLE INITIALLY DEFERRED, -- NULL if it's an incognito profile + local_display_name TEXT NOT NULL, + created_at TEXT NOT NULL DEFAULT (datetime('now')), + user_id INTEGER NOT NULL REFERENCES users, + FOREIGN KEY (user_id, local_display_name) + REFERENCES display_names (user_id, local_display_name) + ON UPDATE CASCADE + DEFERRABLE INITIALLY DEFERRED, + UNIQUE (user_id, local_display_name), + UNIQUE (user_id, contact_profile_id) +); + +ALTER TABLE connections ADD user_contact_link_id INTEGER +REFERENCES user_contact_links ON DELETE RESTRICT; diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index a61e9aeed1..d8b12da871 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -67,10 +67,16 @@ data ChatCommand = ChatHelp | FilesHelp | GroupsHelp + | MyAddressHelp | MarkdownHelp | AddContact - | Connect ConnectionRequest + | Connect AConnectionRequest | DeleteContact ContactName + | CreateMyAddress + | DeleteMyAddress + | ShowMyAddress + | AcceptContact ContactName + | RejectContact ContactName | SendMessage ContactName ByteString | NewGroup GroupProfile | AddMember GroupName ContactName GroupMemberRole @@ -176,13 +182,17 @@ processChatCommand user@User {userId, profile} = \case ChatHelp -> printToView chatHelpInfo FilesHelp -> printToView filesHelpInfo GroupsHelp -> printToView groupsHelpInfo + MyAddressHelp -> printToView myAddressHelpInfo MarkdownHelp -> printToView markdownInfo AddContact -> do - (connId, cReq) <- withAgent createConnection + (connId, cReq) <- withAgent (`createConnection` SCMInvitation) withStore $ \st -> createDirectConnection st userId connId showInvitation cReq - Connect cReq -> do - connId <- withAgent $ \a -> joinConnection a cReq . directMessage $ XInfo profile + Connect (ACR cMode cReq) -> do + let msg :: ChatMsgEvent = case cMode of + SCMInvitation -> XInfo profile + SCMContact -> XContact profile Nothing + connId <- withAgent $ \a -> joinConnection a cReq $ directMessage msg withStore $ \st -> createDirectConnection st userId connId DeleteContact cName -> withStore (\st -> getContactGroupNames st userId cName) >>= \case @@ -194,6 +204,31 @@ processChatCommand user@User {userId, profile} = \case unsetActive $ ActiveC cName showContactDeleted cName gs -> showContactGroups cName gs + CreateMyAddress -> do + (connId, cReq) <- withAgent (`createConnection` SCMContact) + withStore $ \st -> createUserContactLink st userId connId cReq + showUserContactLinkCreated cReq + DeleteMyAddress -> do + conns <- withStore $ \st -> getUserContactLinkConnections st userId + withAgent $ \a -> forM_ conns $ \Connection {agentConnId} -> + deleteConnection a agentConnId `catchError` \(_ :: AgentErrorType) -> pure () + withStore $ \st -> deleteUserContactLink st userId + showUserContactLinkDeleted + ShowMyAddress -> do + cReq <- withStore $ \st -> getUserContactLink st userId + showUserContactLink cReq + AcceptContact cName -> do + UserContactRequest {agentInvitationId, profileId} <- withStore $ \st -> + getContactRequest st userId cName + connId <- withAgent $ \a -> acceptContact a agentInvitationId . directMessage $ XInfo profile + withStore $ \st -> createAcceptedContact st userId connId cName profileId + showAcceptingContactRequest cName + RejectContact cName -> do + UserContactRequest {agentContactConnId, agentInvitationId} <- withStore $ \st -> + getContactRequest st userId cName + `E.finally` deleteContactRequest st userId cName + withAgent $ \a -> rejectContact a agentContactConnId agentInvitationId + showContactRequestRejected cName SendMessage cName msg -> do contact <- withStore $ \st -> getContact st userId cName let msgEvent = XMsgNew $ MsgContent MTText [] [MsgContentBody {contentType = SimplexContentType XCText, contentData = msg}] @@ -213,7 +248,7 @@ processChatCommand user@User {userId, profile} = \case unless (memberActive membership) $ chatError CEGroupMemberNotActive when (isJust $ contactMember contact members) $ chatError (CEGroupDuplicateMember cName) gVar <- asks idsDrg - (agentConnId, cReq) <- withAgent createConnection + (agentConnId, cReq) <- withAgent (`createConnection` SCMInvitation) GroupMember {memberId} <- withStore $ \st -> createContactGroupMember st gVar user groupId contact memRole agentConnId let msg = XGrpInv $ GroupInvitation (userMemberId, userRole) (memberId, memRole) cReq groupProfile sendDirectMessage (contactConnId contact) msg @@ -269,7 +304,7 @@ processChatCommand user@User {userId, profile} = \case SendFile cName f -> do (fileSize, chSize) <- checkSndFile f contact <- withStore $ \st -> getContact st userId cName - (agentConnId, fileConnReq) <- withAgent createConnection + (agentConnId, fileConnReq) <- withAgent (`createConnection` SCMInvitation) let fileInv = FileInvitation {fileName = takeFileName f, fileSize, fileConnReq} SndFileTransfer {fileId} <- withStore $ \st -> createSndFileTransfer st userId contact f fileInv agentConnId chSize @@ -282,7 +317,7 @@ processChatCommand user@User {userId, profile} = \case unless (memberActive membership) $ chatError CEGroupMemberUserRemoved let fileName = takeFileName f ms <- forM (filter memberActive members) $ \m -> do - (connId, fileConnReq) <- withAgent createConnection + (connId, fileConnReq) <- withAgent (`createConnection` SCMInvitation) pure (m, connId, FileInvitation {fileName, fileSize, fileConnReq}) fileId <- withStore $ \st -> createSndGroupFileTransfer st userId group ms f fileSize chSize forM_ ms $ \(m, _, fileInv) -> @@ -378,6 +413,7 @@ subscribeUserConnections = void . runExceptT $ do subscribeGroups user subscribeFiles user subscribePendingConnections user + subscribeUserContactLink user where subscribeContacts user = do contacts <- withStore (`getUserContacts` user) @@ -418,10 +454,17 @@ subscribeUserConnections = void . runExceptT $ do resume RcvFileInfo {agentConnId} = subscribe agentConnId `catchError` showRcvFileSubError ft subscribePendingConnections user = do - connections <- withStore (`getPendingConnections` user) - forM_ connections $ \Connection {agentConnId} -> - subscribe agentConnId `catchError` \_ -> pure () + cs <- withStore (`getPendingConnections` user) + subscribeConns cs `catchError` \_ -> pure () + subscribeUserContactLink User {userId} = do + cs <- withStore (`getUserContactLinkConnections` userId) + (subscribeConns cs >> showUserContactLinkSubscribed) + `catchError` showUserContactLinkSubError subscribe cId = withAgent (`subscribeConnection` cId) + subscribeConns conns = + withAgent $ \a -> + forM_ conns $ \Connection {agentConnId} -> + subscribeConnection a agentConnId processAgentMessage :: forall m. ChatMonad m => User -> ConnId -> ACommand 'Agent -> m () processAgentMessage user@User {userId, profile} agentConnId agentMessage = do @@ -437,6 +480,8 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do processRcvFileConn agentMessage conn ft SndFileConnection conn ft -> processSndFileConn agentMessage conn ft + UserContactConnection conn uc -> + processUserContactRequest agentMessage conn uc where isMember :: MemberId -> Group -> Bool isMember memId Group {membership, members} = @@ -450,7 +495,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do agentMsgConnStatus :: ACommand 'Agent -> Maybe ConnStatus agentMsgConnStatus = \case - REQ _ _ -> Just ConnRequested + CONF {} -> Just ConnRequested INFO _ -> Just ConnSndReady CON -> Just ConnReady _ -> Nothing @@ -458,9 +503,9 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do processDirectMessage :: ACommand 'Agent -> Connection -> Maybe Contact -> m () processDirectMessage agentMsg conn = \case Nothing -> case agentMsg of - REQ confId connInfo -> do + CONF confId connInfo -> do saveConnInfo conn connInfo - acceptAgentConnection conn confId $ XInfo profile + allowAgentConnection conn confId $ XInfo profile INFO connInfo -> saveConnInfo conn connInfo MSG meta _ -> @@ -478,15 +523,15 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do XInfoProbeCheck probeHash -> xInfoProbeCheck ct probeHash XInfoProbeOk probe -> xInfoProbeOk ct probe _ -> pure () - REQ confId connInfo -> do + CONF confId connInfo -> do -- confirming direct connection with a member ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo case chatMsgEvent of XGrpMemInfo _memId _memProfile -> do -- TODO check member ID -- TODO update member profile - acceptAgentConnection conn confId XOk - _ -> messageError "REQ from member must have x.grp.mem.info" + allowAgentConnection conn confId XOk + _ -> messageError "CONF from member must have x.grp.mem.info" INFO connInfo -> do ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo case chatMsgEvent of @@ -494,8 +539,11 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do -- TODO check member ID -- TODO update member profile pure () + XInfo _profile -> do + -- TODO update contact profile + pure () XOk -> pure () - _ -> messageError "INFO from member must have x.grp.mem.info or x.ok" + _ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok" CON -> withStore (\st -> getViaGroupMember st user ct) >>= \case Nothing -> do @@ -521,7 +569,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do processGroupMessage :: ACommand 'Agent -> Connection -> GroupName -> GroupMember -> m () processGroupMessage agentMsg conn gName m = case agentMsg of - REQ confId connInfo -> do + CONF confId connInfo -> do ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo case memberCategory m of GCInviteeMember -> @@ -529,18 +577,18 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do XGrpAcpt memId | memId == memberId m -> do withStore $ \st -> updateGroupMemberStatus st userId m GSMemAccepted - acceptAgentConnection conn confId XOk + allowAgentConnection conn confId XOk | otherwise -> messageError "x.grp.acpt: memberId is different from expected" - _ -> messageError "REQ from invited member must have x.grp.acpt" + _ -> messageError "CONF from invited member must have x.grp.acpt" _ -> case chatMsgEvent of XGrpMemInfo memId _memProfile | memId == memberId m -> do -- TODO update member profile Group {membership} <- withStore $ \st -> getGroup st user gName - acceptAgentConnection conn confId $ XGrpMemInfo (memberId membership) profile + allowAgentConnection conn confId $ XGrpMemInfo (memberId membership) profile | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" - _ -> messageError "REQ from member must have x.grp.mem.info" + _ -> messageError "CONF from member must have x.grp.mem.info" INFO connInfo -> do ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo case chatMsgEvent of @@ -603,15 +651,15 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do processSndFileConn :: ACommand 'Agent -> Connection -> SndFileTransfer -> m () processSndFileConn agentMsg conn ft@SndFileTransfer {fileId, fileName, fileStatus} = case agentMsg of - REQ confId connInfo -> do + CONF confId connInfo -> do ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo case chatMsgEvent of XFileAcpt name | name == fileName -> do withStore $ \st -> updateSndFileStatus st ft FSAccepted - acceptAgentConnection conn confId XOk + allowAgentConnection conn confId XOk | otherwise -> messageError "x.file.acpt: fileName is different from expected" - _ -> messageError "REQ from file connection must have x.file.acpt" + _ -> messageError "CONF from file connection must have x.file.acpt" CON -> do withStore $ \st -> updateSndFileStatus st ft FSConnected showSndFileStart ft @@ -665,6 +713,22 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo _ -> pure () + processUserContactRequest :: ACommand 'Agent -> Connection -> UserContact -> m () + processUserContactRequest agentMsg _conn UserContact {userContactLinkId} = case agentMsg of + REQ invId connInfo -> do + ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo + case chatMsgEvent of + XContact p _ -> profileContactRequest invId p + XInfo p -> profileContactRequest invId p + -- TODO show/log error, other events in contact request + _ -> pure () + _ -> pure () + where + profileContactRequest :: InvitationId -> Profile -> m () + profileContactRequest invId p = do + cName <- withStore $ \st -> createContactRequest st userId userContactLinkId invId p + showReceivedContactRequest cName p + withAckMessage :: ConnId -> MsgMeta -> m () -> m () withAckMessage cId MsgMeta {recipient = (msgId, _)} action = action `E.finally` withAgent (\a -> ackMessage a cId msgId `catchError` \_ -> pure ()) @@ -803,8 +867,8 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do if isMember memId group then messageWarning "x.grp.mem.intro ignored: member already exists" else do - (groupConnId, groupConnReq) <- withAgent createConnection - (directConnId, directConnReq) <- withAgent createConnection + (groupConnId, groupConnReq) <- withAgent (`createConnection` SCMInvitation) + (directConnId, directConnReq) <- withAgent (`createConnection` SCMInvitation) newMember <- withStore $ \st -> createIntroReMember st user group m memInfo groupConnId directConnId let msg = XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq} sendDirectMessage agentConnId msg @@ -1000,9 +1064,9 @@ sendGroupMessage members chatMsgEvent = do forM_ (filter memberActive members) $ traverse (\connId -> sendMessage a connId msg) . memberConnId -acceptAgentConnection :: ChatMonad m => Connection -> ConfirmationId -> ChatMsgEvent -> m () -acceptAgentConnection conn@Connection {agentConnId} confId msg = do - withAgent $ \a -> acceptConnection a agentConnId confId $ directMessage msg +allowAgentConnection :: ChatMonad m => Connection -> ConfirmationId -> ChatMsgEvent -> m () +allowAgentConnection conn@Connection {agentConnId} confId msg = do + withAgent $ \a -> allowConnection a agentConnId confId $ directMessage msg withStore $ \st -> updateConnectionStatus st conn ConnAccepted getCreateActiveUser :: SQLiteStore -> IO User @@ -1090,6 +1154,7 @@ chatCommandP :: Parser ChatCommand chatCommandP = ("/help files" <|> "/help file" <|> "/hf") $> FilesHelp <|> ("/help groups" <|> "/help group" <|> "/hg") $> GroupsHelp + <|> ("/help address" <|> "/ha") $> MyAddressHelp <|> ("/help" <|> "/h") $> ChatHelp <|> ("/group #" <|> "/group " <|> "/g #" <|> "/g ") *> (NewGroup <$> groupProfile) <|> ("/add #" <|> "/add " <|> "/a #" <|> "/a ") *> (AddMember <$> displayName <* A.space <*> displayName <*> memberRole) @@ -1108,10 +1173,15 @@ chatCommandP = <|> ("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> optional (A.space *> filePath)) <|> ("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal) <|> ("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal) + <|> ("/address" <|> "/ad") $> CreateMyAddress + <|> ("/delete_address" <|> "/da") $> DeleteMyAddress + <|> ("/show_address" <|> "/sa") $> ShowMyAddress + <|> ("/accept @" <|> "/accept " <|> "/ac @" <|> "/ac ") *> (AcceptContact <$> displayName) + <|> ("/reject @" <|> "/reject " <|> "/rc @" <|> "/rc ") *> (RejectContact <$> displayName) <|> ("/markdown" <|> "/m") $> MarkdownHelp <|> ("/profile " <|> "/p ") *> (UpdateProfile <$> userProfile) <|> ("/profile" <|> "/p") $> ShowProfile - <|> ("/quit" <|> "/q") $> QuitChat + <|> ("/quit" <|> "/q" <|> "/exit") $> QuitChat <|> ("/version" <|> "/v") $> ShowVersion where displayName = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' ')) diff --git a/src/Simplex/Chat/Help.hs b/src/Simplex/Chat/Help.hs index 8dd30ca0be..e25e532f27 100644 --- a/src/Simplex/Chat/Help.hs +++ b/src/Simplex/Chat/Help.hs @@ -4,6 +4,7 @@ module Simplex.Chat.Help ( chatHelpInfo, filesHelpInfo, groupsHelpInfo, + myAddressHelpInfo, markdownInfo, ) where @@ -34,7 +35,7 @@ chatHelpInfo = "Follow these steps to set up a connection:", "", green "Step 1: " <> highlight "/connect" <> " - Alice adds a contact.", - indent <> "Alice should send the invitation printed by the /add command", + indent <> "Alice should send the one-time invitation printed by the /connect command", indent <> "to her contact, Bob, out-of-band, via any trusted channel.", "", green "Step 2: " <> highlight "/connect " <> " - Bob accepts the invitation.", @@ -45,23 +46,20 @@ chatHelpInfo = indent <> highlight "@bob Hello, Bob!" <> " - Alice messages Bob (assuming Bob has display name 'bob').", indent <> highlight "@alice Hey, Alice!" <> " - Bob replies to Alice.", "", - green "To send file:", - indent <> highlight "/file bob ./photo.jpg" <> " - Alice sends file to Bob", - indent <> "File commands: " <> highlight "/help files", + green "Send file: " <> highlight "/file bob ./photo.jpg" <> " (see /help files)", "", - green "To create group:", - indent <> highlight "/group team" <> " - create group #team", - indent <> "Group commands: " <> highlight "/help groups", + green "Create group: " <> highlight "/group team" <> " (see /help groups)", + "", + green "Create your address: " <> highlight "/address" <> " (see /help address)", "", green "Other commands:", - indent <> highlight "/profile " <> " - show user profile", - indent <> highlight "/profile []" <> " - update user profile", + indent <> highlight "/profile " <> " - show / update user profile", indent <> highlight "/delete " <> " - delete contact and all messages with them", indent <> highlight "/markdown " <> " - show supported markdown syntax", indent <> highlight "/version " <> " - show SimpleX Chat version", indent <> highlight "/quit " <> " - quit chat", "", - "The commands may be abbreviated to a single letter: " <> listHighlight ["/c", "/f", "/g", "/p", "/h"] <> ", etc." + "The commands may be abbreviated: " <> listHighlight ["/c", "/f", "/g", "/p", "/ad"] <> ", etc." ] filesHelpInfo :: [StyledString] @@ -95,6 +93,22 @@ groupsHelpInfo = "The commands may be abbreviated: " <> listHighlight ["/g", "/a", "/j", "/rm", "/l", "/d", "/ms"] ] +myAddressHelpInfo :: [StyledString] +myAddressHelpInfo = + map + styleMarkdown + [ green "Your contact address commands:", + indent <> highlight "/address " <> " - create your address", + indent <> highlight "/delete_address" <> " - delete your address (accepted contacts will remain connected)", + indent <> highlight "/show_address " <> " - show your address", + indent <> highlight "/accept " <> " - accept contact request", + indent <> highlight "/reject " <> " - reject contact request", + "", + "Please note: you can receive spam contact requests, but it's safe to delete the address!", + "", + "The commands may be abbreviated: " <> listHighlight ["/ad", "/da", "/sa", "/ac", "/rc"] + ] + markdownInfo :: [StyledString] markdownInfo = map diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index d3cef7a5d8..536f22abd0 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -11,7 +11,7 @@ module Simplex.Chat.Protocol where import Control.Applicative (optional) -import Control.Monad ((<=<)) +import Control.Monad ((<=<), (>=>)) import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J import Data.Attoparsec.ByteString.Char8 (Parser) @@ -21,7 +21,7 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) -import Data.List (find) +import Data.List (find, findIndex) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -38,6 +38,7 @@ data ChatDirection (p :: AParty) where SentGroupMessage :: GroupName -> ChatDirection 'Client SndFileConnection :: Connection -> SndFileTransfer -> ChatDirection 'Agent RcvFileConnection :: Connection -> RcvFileTransfer -> ChatDirection 'Agent + UserContactConnection :: Connection -> UserContact -> ChatDirection 'Agent deriving instance Eq (ChatDirection p) @@ -49,12 +50,14 @@ fromConnection = \case ReceivedGroupMessage conn _ _ -> conn SndFileConnection conn _ -> conn RcvFileConnection conn _ -> conn + UserContactConnection conn _ -> conn data ChatMsgEvent = XMsgNew MsgContent | XFile FileInvitation | XFileAcpt String | XInfo Profile + | XContact Profile (Maybe MsgContent) | XGrpInv GroupInvitation | XGrpAcpt MemberId | XGrpMemNew MemberInfo @@ -107,22 +110,30 @@ toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBod case (chatMsgEvent, chatMsgParams) of ("x.msg.new", mt : rawFiles) -> do t <- toMsgType mt - files <- mapM (toContentInfo <=< parseAll contentInfoP) rawFiles + files <- toFiles rawFiles chatMsg . XMsgNew $ MsgContent {messageType = t, files, content = body} ("x.file", [name, size, cReq]) -> do let fileName = T.unpack $ safeDecodeUtf8 name fileSize <- parseAll A.decimal size - fileConnReq <- parseAll connReqP cReq + fileConnReq <- parseAll connReqP' cReq chatMsg . XFile $ FileInvitation {fileName, fileSize, fileConnReq} ("x.file.acpt", [name]) -> chatMsg . XFileAcpt . T.unpack $ safeDecodeUtf8 name ("x.info", []) -> do profile <- getJSON body chatMsg $ XInfo profile + ("x.con", []) -> do + profile <- getJSON body + chatMsg $ XContact profile Nothing + ("x.con", mt : rawFiles) -> do + (profile, body') <- extractJSON body + t <- toMsgType mt + files <- toFiles rawFiles + chatMsg . XContact profile $ Just MsgContent {messageType = t, files, content = body'} ("x.grp.inv", [fromMemId, fromRole, memId, role, cReq]) -> do fromMem <- (,) <$> B64.decode fromMemId <*> toMemberRole fromRole invitedMem <- (,) <$> B64.decode memId <*> toMemberRole role - groupConnReq <- parseAll connReqP cReq + groupConnReq <- parseAll connReqP' cReq profile <- getJSON body chatMsg . XGrpInv $ GroupInvitation fromMem invitedMem groupConnReq profile ("x.grp.acpt", [memId]) -> @@ -164,11 +175,18 @@ toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBod toMemberInfo :: ByteString -> ByteString -> [MsgContentBody] -> Either String MemberInfo toMemberInfo memId role body = MemberInfo <$> B64.decode memId <*> toMemberRole role <*> getJSON body toIntroInv :: ByteString -> ByteString -> Either String IntroInvitation - toIntroInv groupConnReq directConnReq = IntroInvitation <$> parseAll connReqP groupConnReq <*> parseAll connReqP directConnReq + toIntroInv groupConnReq directConnReq = IntroInvitation <$> parseAll connReqP' groupConnReq <*> parseAll connReqP' directConnReq toContentInfo :: (RawContentType, Int) -> Either String (ContentType, Int) toContentInfo (rawType, size) = (,size) <$> toContentType rawType + toFiles :: [ByteString] -> Either String [(ContentType, Int)] + toFiles = mapM $ toContentInfo <=< parseAll contentInfoP getJSON :: FromJSON a => [MsgContentBody] -> Either String a getJSON = J.eitherDecodeStrict' <=< getSimplexContentType XCJson + extractJSON :: FromJSON a => [MsgContentBody] -> Either String (a, [MsgContentBody]) + extractJSON = + extractSimplexContentType XCJson >=> \(a, bs) -> do + j <- J.eitherDecodeStrict' a + pure (j, bs) isContentType :: ContentType -> MsgContentBody -> Bool isContentType t MsgContentBody {contentType = t'} = t == t' @@ -181,28 +199,41 @@ getContentType t body = case find (isContentType t) body of Just MsgContentBody {contentData} -> Right contentData Nothing -> Left "no required content type" +extractContentType :: ContentType -> [MsgContentBody] -> Either String (ByteString, [MsgContentBody]) +extractContentType t body = case findIndex (isContentType t) body of + Just i -> case splitAt i body of + (b, el : a) -> Right (contentData (el :: MsgContentBody), b ++ a) + (_, []) -> Left "no required content type" -- this can only happen if findIndex returns incorrect result + Nothing -> Left "no required content type" + getSimplexContentType :: XContentType -> [MsgContentBody] -> Either String ByteString getSimplexContentType = getContentType . SimplexContentType +extractSimplexContentType :: XContentType -> [MsgContentBody] -> Either String (ByteString, [MsgContentBody]) +extractSimplexContentType = extractContentType . SimplexContentType + rawChatMessage :: ChatMessage -> RawChatMessage rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} = case chatMsgEvent of XMsgNew MsgContent {messageType = t, files, content} -> - let rawFiles = map (serializeContentInfo . rawContentInfo) files - in rawMsg "x.msg.new" (rawMsgType t : rawFiles) content + rawMsg "x.msg.new" (rawMsgType t : toRawFiles files) content XFile FileInvitation {fileName, fileSize, fileConnReq} -> - rawMsg "x.file" [encodeUtf8 $ T.pack fileName, bshow fileSize, serializeConnReq fileConnReq] [] + rawMsg "x.file" [encodeUtf8 $ T.pack fileName, bshow fileSize, serializeConnReq' fileConnReq] [] XFileAcpt fileName -> rawMsg "x.file.acpt" [encodeUtf8 $ T.pack fileName] [] XInfo profile -> rawMsg "x.info" [] [jsonBody profile] + XContact profile Nothing -> + rawMsg "x.con" [] [jsonBody profile] + XContact profile (Just MsgContent {messageType = t, files, content}) -> + rawMsg "x.con" (rawMsgType t : toRawFiles files) (jsonBody profile : content) XGrpInv (GroupInvitation (fromMemId, fromRole) (memId, role) cReq groupProfile) -> let params = [ B64.encode fromMemId, serializeMemberRole fromRole, B64.encode memId, serializeMemberRole role, - serializeConnReq cReq + serializeConnReq' cReq ] in rawMsg "x.grp.inv" params [jsonBody groupProfile] XGrpAcpt memId -> @@ -213,14 +244,14 @@ rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} = XGrpMemIntro (MemberInfo memId role profile) -> rawMsg "x.grp.mem.intro" [B64.encode memId, serializeMemberRole role] [jsonBody profile] XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq} -> - let params = [B64.encode memId, serializeConnReq groupConnReq, serializeConnReq directConnReq] + let params = [B64.encode memId, serializeConnReq' groupConnReq, serializeConnReq' directConnReq] in rawMsg "x.grp.mem.inv" params [] XGrpMemFwd (MemberInfo memId role profile) IntroInvitation {groupConnReq, directConnReq} -> let params = [ B64.encode memId, serializeMemberRole role, - serializeConnReq groupConnReq, - serializeConnReq directConnReq + serializeConnReq' groupConnReq, + serializeConnReq' directConnReq ] in rawMsg "x.grp.mem.fwd" params [jsonBody profile] XGrpMemInfo memId profile -> @@ -257,6 +288,8 @@ rawChatMessage ChatMessage {chatMsgId, chatMsgEvent, chatDAG} = rawWithDAG body = map rawMsgBodyContent $ case chatDAG of Nothing -> body Just dag -> MsgContentBody {contentType = SimplexDAG, contentData = dag} : body + toRawFiles :: [(ContentType, Int)] -> [ByteString] + toRawFiles = map $ serializeContentInfo . rawContentInfo toMsgBodyContent :: RawMsgBodyContent -> Either String MsgContentBody toMsgBodyContent RawMsgBodyContent {contentType, contentData} = do diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index fc47b7214b..560b1c15ad 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -28,6 +28,14 @@ module Simplex.Chat.Store updateUserProfile, updateContactProfile, getUserContacts, + createUserContactLink, + getUserContactLinkConnections, + deleteUserContactLink, + getUserContactLink, + createContactRequest, + getContactRequest, + deleteContactRequest, + createAcceptedContact, getLiveSndFileTransfers, getLiveRcvFileTransfers, getPendingSndChunks, @@ -107,7 +115,7 @@ import qualified Database.SQLite.Simple as DB import Database.SQLite.Simple.QQ (sql) import Simplex.Chat.Protocol import Simplex.Chat.Types -import Simplex.Messaging.Agent.Protocol (AParty (..), AgentMsgId, ConnId, ConnectionRequest) +import Simplex.Messaging.Agent.Protocol (AParty (..), AgentMsgId, ConnId, InvitationId) import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore (..), createSQLiteStore, withTransaction) import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) import qualified Simplex.Messaging.Crypto as C @@ -180,20 +188,45 @@ setActiveUser st userId = do createDirectConnection :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> m () createDirectConnection st userId agentConnId = liftIO . withTransaction st $ \db -> - void $ createConnection_ db userId agentConnId Nothing 0 + void $ createContactConnection_ db userId agentConnId Nothing 0 -createConnection_ :: DB.Connection -> UserId -> ConnId -> Maybe Int64 -> Int -> IO Connection -createConnection_ db userId agentConnId viaContact connLevel = do +createContactConnection_ :: DB.Connection -> UserId -> ConnId -> Maybe Int64 -> Int -> IO Connection +createContactConnection_ db userId = createConnection_ db userId ConnContact Nothing + +-- field types coincidentally match, but the first element here is user ID and not connection ID as in ConnectionRow +type InsertedConnectionRow = ConnectionRow + +createConnection_ :: DB.Connection -> UserId -> ConnType -> Maybe Int64 -> ConnId -> Maybe Int64 -> Int -> IO Connection +createConnection_ db userId connType entityId agentConnId viaContact connLevel = do createdAt <- getCurrentTime DB.execute db [sql| - INSERT INTO connections - (user_id, agent_conn_id, conn_status, conn_type, via_contact, conn_level, created_at) VALUES (?,?,?,?,?,?,?); + INSERT INTO connections ( + user_id, agent_conn_id, conn_level, via_contact, conn_status, conn_type, + contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?); |] - (userId, agentConnId, ConnNew, ConnContact, viaContact, connLevel, createdAt) + (insertConnParams createdAt) connId <- insertedRowId db - pure Connection {connId, agentConnId, connType = ConnContact, entityId = Nothing, viaContact, connLevel, connStatus = ConnNew, createdAt} + pure Connection {connId, agentConnId, connType, entityId, viaContact, connLevel, connStatus = ConnNew, createdAt} + where + insertConnParams :: UTCTime -> InsertedConnectionRow + insertConnParams createdAt = + ( userId, + agentConnId, + connLevel, + viaContact, + ConnNew, + connType, + ent ConnContact, + ent ConnMember, + ent ConnSndFile, + ent ConnRcvFile, + ent ConnUserContact, + createdAt + ) + ent ct = if connType == ct then entityId else Nothing createDirectContact :: StoreMonad m => SQLiteStore -> UserId -> Connection -> Profile -> m () createDirectContact st userId Connection {connId} profile = @@ -337,7 +370,7 @@ getContact_ db userId localDisplayName = do db [sql| SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, - c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at + c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM connections c WHERE c.user_id = :user_id AND c.contact_id == :contact_id ORDER BY c.connection_id DESC @@ -359,6 +392,142 @@ getUserContacts st User {userId} = contactNames <- map fromOnly <$> DB.query db "SELECT local_display_name FROM contacts WHERE user_id = ?" (Only userId) rights <$> mapM (runExceptT . getContact_ db userId) contactNames +createUserContactLink :: StoreMonad m => SQLiteStore -> UserId -> ConnId -> ConnReqContact -> m () +createUserContactLink st userId agentConnId cReq = + liftIOEither . checkConstraint SEDuplicateContactLink . withTransaction st $ \db -> do + DB.execute db "INSERT INTO user_contact_links (user_id, conn_req_contact) VALUES (?, ?)" (userId, cReq) + userContactLinkId <- insertedRowId db + Right () <$ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing 0 + +getUserContactLinkConnections :: StoreMonad m => SQLiteStore -> UserId -> m [Connection] +getUserContactLinkConnections st userId = + liftIOEither . withTransaction st $ \db -> + connections + <$> DB.queryNamed + db + [sql| + SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, + c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at + FROM connections c + JOIN user_contact_links uc ON c.user_contact_link_id == uc.user_contact_link_id + WHERE c.user_id = :user_id + AND uc.user_id = :user_id + AND uc.local_display_name = '' + |] + [":user_id" := userId] + where + connections [] = Left SEUserContactLinkNotFound + connections rows = Right $ map toConnection rows + +deleteUserContactLink :: MonadUnliftIO m => SQLiteStore -> UserId -> m () +deleteUserContactLink st userId = + liftIO . withTransaction st $ \db -> do + DB.execute + db + [sql| + DELETE FROM connections WHERE connection_id IN ( + SELECT connection_id + FROM connections c + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = ? AND uc.local_display_name = '' + ) + |] + (Only userId) + DB.executeNamed + db + [sql| + DELETE FROM display_names + WHERE user_id = :user_id + AND local_display_name in ( + SELECT cr.local_display_name + FROM contact_requests cr + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = :user_id + AND uc.local_display_name = '' + ) + |] + [":user_id" := userId] + DB.executeNamed + db + [sql| + DELETE FROM contact_profiles + WHERE contact_profile_id in ( + SELECT cr.contact_profile_id + FROM contact_requests cr + JOIN user_contact_links uc USING (user_contact_link_id) + WHERE uc.user_id = :user_id + AND uc.local_display_name = '' + ) + |] + [":user_id" := userId] + DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = ''" (Only userId) + +getUserContactLink :: StoreMonad m => SQLiteStore -> UserId -> m ConnReqContact +getUserContactLink st userId = + liftIOEither . withTransaction st $ \db -> + connReq + <$> DB.query + db + [sql| + SELECT conn_req_contact + FROM user_contact_links + WHERE user_id = ? + AND local_display_name = '' + |] + (Only userId) + where + connReq [Only cReq] = Right cReq + connReq _ = Left SEUserContactLinkNotFound + +createContactRequest :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> InvitationId -> Profile -> m ContactName +createContactRequest st userId userContactId invId Profile {displayName, fullName} = + liftIOEither . withTransaction st $ \db -> + withLocalDisplayName db userId displayName $ \ldn -> do + DB.execute db "INSERT INTO contact_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName) + profileId <- insertedRowId db + DB.execute + db + [sql| + INSERT INTO contact_requests + (user_contact_link_id, agent_invitation_id, contact_profile_id, local_display_name, user_id) VALUES (?,?,?,?,?) + |] + (userContactId, invId, profileId, ldn, userId) + pure ldn + +getContactRequest :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m UserContactRequest +getContactRequest st userId localDisplayName = + liftIOEither . withTransaction st $ \db -> + contactReq + <$> DB.query + db + [sql| + SELECT cr.contact_request_id, cr.agent_invitation_id, cr.user_contact_link_id, + c.agent_conn_id, cr.contact_profile_id + FROM contact_requests cr + JOIN connections c USING (user_contact_link_id) + WHERE cr.user_id = ? + AND cr.local_display_name = ? + |] + (userId, localDisplayName) + where + contactReq [(contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, profileId)] = + Right UserContactRequest {contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, profileId, localDisplayName} + contactReq _ = Left $ SEContactRequestNotFound localDisplayName + +deleteContactRequest :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactName -> m () +deleteContactRequest st userId localDisplayName = + liftIO . withTransaction st $ \db -> do + DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + +createAcceptedContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> ContactName -> Int64 -> m () +createAcceptedContact st userId agentConnId localDisplayName profileId = + liftIO . withTransaction st $ \db -> do + DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) + DB.execute db "INSERT INTO contacts (user_id, local_display_name, contact_profile_id) VALUES (?,?,?)" (userId, localDisplayName, profileId) + contactId <- insertedRowId db + void $ createConnection_ db userId ConnContact (Just contactId) agentConnId Nothing 0 + getLiveSndFileTransfers :: MonadUnliftIO m => SQLiteStore -> User -> m [SndFileTransfer] getLiveSndFileTransfers st User {userId} = liftIO . withTransaction st $ \db -> do @@ -416,7 +585,7 @@ getPendingConnections st User {userId} = db [sql| SELECT connection_id, agent_conn_id, conn_level, via_contact, - conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, created_at + conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at FROM connections WHERE user_id = :user_id AND conn_type = :conn_type @@ -432,7 +601,7 @@ getContactConnections st userId displayName = db [sql| SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, - c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at + c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM connections c JOIN contacts cs ON c.contact_id == cs.contact_id WHERE c.user_id = :user_id @@ -444,12 +613,12 @@ getContactConnections st userId displayName = connections [] = Left $ SEContactNotFound displayName connections rows = Right $ map toConnection rows -type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, UTCTime) +type ConnectionRow = (Int64, ConnId, Int, Maybe Int64, ConnStatus, ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, UTCTime) -type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe UTCTime) +type MaybeConnectionRow = (Maybe Int64, Maybe ConnId, Maybe Int, Maybe Int64, Maybe ConnStatus, Maybe ConnType, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64, Maybe UTCTime) toConnection :: ConnectionRow -> Connection -toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, sndFileId, rcvFileId, createdAt) = +toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId, createdAt) = let entityId = entityId_ connType in Connection {connId, agentConnId, connLevel, viaContact, connStatus, connType, entityId, createdAt} where @@ -458,10 +627,11 @@ toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, entityId_ ConnMember = groupMemberId entityId_ ConnRcvFile = rcvFileId entityId_ ConnSndFile = sndFileId + entityId_ ConnUserContact = userContactLinkId toMaybeConnection :: MaybeConnectionRow -> Maybe Connection -toMaybeConnection (Just connId, Just agentConnId, Just connLevel, viaContact, Just connStatus, Just connType, contactId, groupMemberId, sndFileId, rcvFileId, Just createdAt) = - Just $ toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, sndFileId, rcvFileId, createdAt) +toMaybeConnection (Just connId, Just agentConnId, Just connLevel, viaContact, Just connStatus, Just connType, contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId, Just createdAt) = + Just $ toConnection (connId, agentConnId, connLevel, viaContact, connStatus, connType, contactId, groupMemberId, sndFileId, rcvFileId, userContactLinkId, createdAt) toMaybeConnection _ = Nothing getMatchingContacts :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> m [Contact] @@ -599,6 +769,7 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId = ConnContact -> ReceivedDirectMessage c . Just <$> getContactRec_ db entId c ConnSndFile -> SndFileConnection c <$> getConnSndFileTransfer_ db entId c ConnRcvFile -> RcvFileConnection c <$> ExceptT (getRcvFileTransfer_ db userId entId) + ConnUserContact -> UserContactConnection c <$> getUserContact_ db entId where getConnection_ :: DB.Connection -> ExceptT StoreError IO Connection getConnection_ db = ExceptT $ do @@ -607,7 +778,7 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId = db [sql| SELECT connection_id, agent_conn_id, conn_level, via_contact, - conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, created_at + conn_status, conn_type, contact_id, group_member_id, snd_file_id, rcv_file_id, user_contact_link_id, created_at FROM connections WHERE user_id = ? AND agent_conn_id = ? |] @@ -674,6 +845,21 @@ getConnectionChatDirection st User {userId, userContactId} agentConnId = Just recipientDisplayName -> Right SndFileTransfer {..} Nothing -> Left $ SESndFileInvalid fileId sndFileTransfer_ fileId _ _ = Left $ SESndFileNotFound fileId + getUserContact_ :: DB.Connection -> Int64 -> ExceptT StoreError IO UserContact + getUserContact_ db userContactLinkId = ExceptT $ do + userContact_ + <$> DB.query + db + [sql| + SELECT conn_req_contact + FROM user_contact_links + WHERE user_id = ? AND user_contact_link_id = ? + |] + (userId, userContactLinkId) + where + userContact_ :: [Only ConnReqContact] -> Either StoreError UserContact + userContact_ [Only cReq] = Right UserContact {userContactLinkId, connReqContact = cReq} + userContact_ _ = Left SEUserContactLinkNotFound updateConnectionStatus :: MonadUnliftIO m => SQLiteStore -> Connection -> ConnStatus -> m () updateConnectionStatus st Connection {connId} connStatus = @@ -717,14 +903,14 @@ getGroup :: StoreMonad m => SQLiteStore -> User -> GroupName -> m Group getGroup st user localDisplayName = liftIOEither . withTransaction st $ \db -> runExceptT $ fst <$> getGroup_ db user localDisplayName -getGroup_ :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO (Group, Maybe ConnectionRequest) +getGroup_ :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO (Group, Maybe ConnReqInvitation) getGroup_ db User {userId, userContactId} localDisplayName = do (g@Group {groupId}, cReq) <- getGroupRec_ allMembers <- getMembers_ groupId (members, membership) <- liftEither $ splitUserMember_ allMembers pure (g {members, membership}, cReq) where - getGroupRec_ :: ExceptT StoreError IO (Group, Maybe ConnectionRequest) + getGroupRec_ :: ExceptT StoreError IO (Group, Maybe ConnReqInvitation) getGroupRec_ = ExceptT $ do toGroup <$> DB.query @@ -736,7 +922,7 @@ getGroup_ db User {userId, userContactId} localDisplayName = do WHERE g.local_display_name = ? AND g.user_id = ? |] (localDisplayName, userId) - toGroup :: [(Int64, GroupName, Text, Maybe ConnectionRequest)] -> Either StoreError (Group, Maybe ConnectionRequest) + toGroup :: [(Int64, GroupName, Text, Maybe ConnReqInvitation)] -> Either StoreError (Group, Maybe ConnReqInvitation) toGroup [(groupId, displayName, fullName, cReq)] = let groupProfile = GroupProfile {displayName, fullName} in Right (Group {groupId, localDisplayName, groupProfile, members = undefined, membership = undefined}, cReq) @@ -751,7 +937,7 @@ getGroup_ db User {userId, userContactId} localDisplayName = do m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, - c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at + c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM group_members m JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id LEFT JOIN connections c ON c.connection_id = ( @@ -975,7 +1161,7 @@ getIntroduction_ db reMember toMember = ExceptT $ do |] (groupMemberId reMember, groupMemberId toMember) where - toIntro :: [(Int64, Maybe ConnectionRequest, Maybe ConnectionRequest, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro + toIntro :: [(Int64, Maybe ConnReqInvitation, Maybe ConnReqInvitation, GroupMemberIntroStatus)] -> Either StoreError GroupMemberIntro toIntro [(introId, groupConnReq, directConnReq, introStatus)] = let introInvitation = IntroInvitation <$> groupConnReq <*> directConnReq in Right GroupMemberIntro {introId, reMember, toMember, introStatus, introInvitation} @@ -985,7 +1171,7 @@ createIntroReMember :: StoreMonad m => SQLiteStore -> User -> Group -> GroupMemb createIntroReMember st user@User {userId} group@Group {groupId} _host@GroupMember {memberContactId, activeConn} memInfo@(MemberInfo _ _ memberProfile) groupAgentConnId directAgentConnId = liftIOEither . withTransaction st $ \db -> runExceptT $ do let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn - Connection {connId = directConnId} <- liftIO $ createConnection_ db userId directAgentConnId memberContactId cLevel + Connection {connId = directConnId} <- liftIO $ createContactConnection_ db userId directAgentConnId memberContactId cLevel (localDisplayName, contactId, memProfileId) <- ExceptT $ createContact_ db userId directConnId memberProfile (Just groupId) liftIO $ do let newMember = @@ -1007,7 +1193,7 @@ createIntroToMemberContact st userId GroupMember {memberContactId = viaContactId liftIO . withTransaction st $ \db -> do let cLevel = 1 + maybe 0 (connLevel :: Connection -> Int) activeConn void $ createMemberConnection_ db userId groupMemberId groupAgentConnId viaContactId cLevel - Connection {connId = directConnId} <- createConnection_ db userId directAgentConnId viaContactId cLevel + Connection {connId = directConnId} <- createContactConnection_ db userId directAgentConnId viaContactId cLevel contactId <- createMemberContact_ db directConnId updateMember_ db contactId where @@ -1040,17 +1226,7 @@ createIntroToMemberContact st userId GroupMember {memberContactId = viaContactId [":contact_id" := contactId, ":group_member_id" := groupMemberId] createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> IO Connection -createMemberConnection_ db userId groupMemberId agentConnId viaContact connLevel = do - createdAt <- getCurrentTime - DB.execute - db - [sql| - INSERT INTO connections - (user_id, agent_conn_id, conn_status, conn_type, group_member_id, via_contact, conn_level, created_at) VALUES (?,?,?,?,?,?,?,?); - |] - (userId, agentConnId, ConnNew, ConnMember, groupMemberId, viaContact, connLevel, createdAt) - connId <- insertedRowId db - pure Connection {connId, agentConnId, connType = ConnMember, entityId = Just groupMemberId, viaContact, connLevel, connStatus = ConnNew, createdAt} +createMemberConnection_ db userId groupMemberId = createConnection_ db userId ConnMember (Just groupMemberId) createContactMember_ :: IsContact a => DB.Connection -> User -> Int64 -> a -> (MemberId, GroupMemberRole) -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> IO GroupMember createContactMember_ db User {userId, userContactId} groupId userOrContact (memberId, memberRole) memberCategory memberStatus invitedBy = do @@ -1098,7 +1274,7 @@ getViaGroupMember st User {userId, userContactId} Contact {contactId} = m.group_member_id, m.group_id, m.member_id, m.member_role, m.member_category, m.member_status, m.invited_by, m.local_display_name, m.contact_id, p.display_name, p.full_name, c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, - c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at + c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM group_members m JOIN contacts ct ON ct.contact_id = m.contact_id JOIN contact_profiles p ON p.contact_profile_id = m.contact_profile_id @@ -1128,7 +1304,7 @@ getViaGroupContact st User {userId} GroupMember {groupMemberId} = SELECT ct.contact_id, ct.local_display_name, p.display_name, p.full_name, ct.via_group, c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, - c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.created_at + c.conn_status, c.conn_type, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at FROM contacts ct JOIN contact_profiles p ON ct.contact_profile_id = p.contact_profile_id JOIN connections c ON c.connection_id = ( @@ -1171,19 +1347,8 @@ createSndGroupFileTransfer st userId Group {groupId} ms filePath fileSize chunkS pure fileId createSndFileConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> IO Connection -createSndFileConnection_ db userId fileId agentConnId = do - createdAt <- getCurrentTime - let connType = ConnSndFile - connStatus = ConnNew - DB.execute - db - [sql| - INSERT INTO connections - (user_id, snd_file_id, agent_conn_id, conn_status, conn_type, created_at) VALUES (?,?,?,?,?,?) - |] - (userId, fileId, agentConnId, connStatus, connType, createdAt) - connId <- insertedRowId db - pure Connection {connId, agentConnId, connType, entityId = Just fileId, viaContact = Nothing, connLevel = 0, connStatus, createdAt} +createSndFileConnection_ db userId fileId agentConnId = + createConnection_ db userId ConnSndFile (Just fileId) agentConnId Nothing 0 updateSndFileStatus :: MonadUnliftIO m => SQLiteStore -> SndFileTransfer -> FileStatus -> m () updateSndFileStatus st SndFileTransfer {fileId, connId} status = @@ -1275,7 +1440,7 @@ getRcvFileTransfer_ db userId fileId = (userId, fileId) where rcvFileTransfer :: - [(FileStatus, ConnectionRequest, String, Integer, Integer, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe ConnId)] -> + [(FileStatus, ConnReqInvitation, String, Integer, Integer, Maybe ContactName, Maybe ContactName, Maybe FilePath, Maybe Int64, Maybe ConnId)] -> Either StoreError RcvFileTransfer rcvFileTransfer [(fileStatus', fileConnReq, fileName, fileSize, chunkSize, contactName_, memberName_, filePath_, connId_, agentConnId_)] = let fileInv = FileInvitation {fileName, fileSize, fileConnReq} @@ -1473,6 +1638,9 @@ data StoreError = SEDuplicateName | SEContactNotFound ContactName | SEContactNotReady ContactName + | SEDuplicateContactLink + | SEUserContactLinkNotFound + | SEContactRequestNotFound ContactName | SEGroupNotFound GroupName | SEGroupWithoutUser | SEDuplicateGroupMember diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 8a6b9af62f..fd93ee4858 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} @@ -20,7 +21,7 @@ import Database.SQLite.Simple.Internal (Field (..)) import Database.SQLite.Simple.Ok (Ok (Ok)) import Database.SQLite.Simple.ToField (ToField (..)) import GHC.Generics -import Simplex.Messaging.Agent.Protocol (ConnId, ConnectionRequest) +import Simplex.Messaging.Agent.Protocol (ConnId, ConnectionMode (..), ConnectionRequest, InvitationId) import Simplex.Messaging.Agent.Store.SQLite (fromTextField_) class IsContact a where @@ -60,6 +61,22 @@ data Contact = Contact contactConnId :: Contact -> ConnId contactConnId Contact {activeConn = Connection {agentConnId}} = agentConnId +data UserContact = UserContact + { userContactLinkId :: Int64, + connReqContact :: ConnReqContact + } + deriving (Eq, Show) + +data UserContactRequest = UserContactRequest + { contactRequestId :: Int64, + agentInvitationId :: InvitationId, + userContactLinkId :: Int64, + agentContactConnId :: ConnId, + localDisplayName :: ContactName, + profileId :: Int64 + } + deriving (Eq, Show) + type ContactName = Text type GroupName = Text @@ -96,14 +113,14 @@ instance FromJSON GroupProfile data GroupInvitation = GroupInvitation { fromMember :: (MemberId, GroupMemberRole), invitedMember :: (MemberId, GroupMemberRole), - connRequest :: ConnectionRequest, + connRequest :: ConnReqInvitation, groupProfile :: GroupProfile } deriving (Eq, Show) data IntroInvitation = IntroInvitation - { groupConnReq :: ConnectionRequest, - directConnReq :: ConnectionRequest + { groupConnReq :: ConnReqInvitation, + directConnReq :: ConnReqInvitation } deriving (Eq, Show) @@ -116,7 +133,7 @@ memberInfo m = MemberInfo (memberId m) (memberRole m) (memberProfile m) data ReceivedGroupInvitation = ReceivedGroupInvitation { fromMember :: GroupMember, userMember :: GroupMember, - connRequest :: ConnectionRequest, + connRequest :: ConnReqInvitation, groupProfile :: GroupProfile } deriving (Eq, Show) @@ -316,7 +333,7 @@ data SndFileTransfer = SndFileTransfer data FileInvitation = FileInvitation { fileName :: String, fileSize :: Integer, - fileConnReq :: ConnectionRequest + fileConnReq :: ConnReqInvitation } deriving (Eq, Show) @@ -372,6 +389,10 @@ serializeFileStatus = \case data RcvChunkStatus = RcvChunkOk | RcvChunkFinal | RcvChunkDuplicate | RcvChunkError deriving (Eq, Show) +type ConnReqInvitation = ConnectionRequest 'CMInvitation + +type ConnReqContact = ConnectionRequest 'CMContact + data Connection = Connection { connId :: Int64, agentConnId :: ConnId, @@ -379,7 +400,7 @@ data Connection = Connection viaContact :: Maybe Int64, connType :: ConnType, connStatus :: ConnStatus, - entityId :: Maybe Int64, -- contact, group member or file ID + entityId :: Maybe Int64, -- contact, group member, file ID or user contact ID createdAt :: UTCTime } deriving (Eq, Show) @@ -426,7 +447,7 @@ serializeConnStatus = \case ConnReady -> "ready" ConnDeleted -> "deleted" -data ConnType = ConnContact | ConnMember | ConnSndFile | ConnRcvFile +data ConnType = ConnContact | ConnMember | ConnSndFile | ConnRcvFile | ConnUserContact deriving (Eq, Show) instance FromField ConnType where fromField = fromTextField_ connTypeT @@ -439,6 +460,7 @@ connTypeT = \case "member" -> Just ConnMember "snd_file" -> Just ConnSndFile "rcv_file" -> Just ConnRcvFile + "user_contact" -> Just ConnUserContact _ -> Nothing serializeConnType :: ConnType -> Text @@ -447,6 +469,7 @@ serializeConnType = \case ConnMember -> "member" ConnSndFile -> "snd_file" ConnRcvFile -> "rcv_file" + ConnUserContact -> "user_contact" data NewConnection = NewConnection { agentConnId :: ByteString, diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index eaa3794aa9..5f9358dc37 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -16,6 +16,14 @@ module Simplex.Chat.View showContactAnotherClient, showContactSubscribed, showContactSubError, + showUserContactLinkCreated, + showUserContactLinkDeleted, + showUserContactLink, + showReceivedContactRequest, + showAcceptingContactRequest, + showContactRequestRejected, + showUserContactLinkSubscribed, + showUserContactLinkSubError, showGroupSubscribed, showGroupEmpty, showGroupRemoved, @@ -87,12 +95,13 @@ import Simplex.Chat.Terminal (printToTerminal) import Simplex.Chat.Types import Simplex.Chat.Util (safeDecodeUtf8) import Simplex.Messaging.Agent.Protocol +import qualified Simplex.Messaging.Protocol as SMP import System.Console.ANSI.Types type ChatReader m = (MonadUnliftIO m, MonadReader ChatController m) -showInvitation :: ChatReader m => ConnectionRequest -> m () -showInvitation = printToView . connReq +showInvitation :: ChatReader m => ConnReqInvitation -> m () +showInvitation = printToView . connReqInvitation_ showChatError :: ChatReader m => ChatError -> m () showChatError = printToView . chatError @@ -118,6 +127,30 @@ showContactSubscribed = printToView . contactSubscribed showContactSubError :: ChatReader m => ContactName -> ChatError -> m () showContactSubError = printToView .: contactSubError +showUserContactLinkCreated :: ChatReader m => ConnReqContact -> m () +showUserContactLinkCreated = printToView . userContactLinkCreated + +showUserContactLinkDeleted :: ChatReader m => m () +showUserContactLinkDeleted = printToView userContactLinkDeleted + +showUserContactLink :: ChatReader m => ConnReqContact -> m () +showUserContactLink = printToView . userContactLink + +showReceivedContactRequest :: ChatReader m => ContactName -> Profile -> m () +showReceivedContactRequest = printToView .: receivedContactRequest + +showAcceptingContactRequest :: ChatReader m => ContactName -> m () +showAcceptingContactRequest = printToView . acceptingContactRequest + +showContactRequestRejected :: ChatReader m => ContactName -> m () +showContactRequestRejected = printToView . contactRequestRejected + +showUserContactLinkSubscribed :: ChatReader m => m () +showUserContactLinkSubscribed = printToView ["Your address is active! To show: " <> highlight' "/sa"] + +showUserContactLinkSubError :: ChatReader m => ChatError -> m () +showUserContactLinkSubError = printToView . userContactLinkSubError + showGroupSubscribed :: ChatReader m => GroupName -> m () showGroupSubscribed = printToView . groupSubscribed @@ -256,13 +289,13 @@ showContactUpdated = printToView .: contactUpdated showMessageError :: ChatReader m => Text -> Text -> m () showMessageError = printToView .: messageError -connReq :: ConnectionRequest -> [StyledString] -connReq cReq = - [ "pass this connection link to your contact (via another channel): ", +connReqInvitation_ :: ConnReqInvitation -> [StyledString] +connReqInvitation_ cReq = + [ "pass this invitation link to your contact (via another channel): ", "", - (plain . serializeConnReq) cReq, + (plain . serializeConnReq') cReq, "", - "and ask them to connect: " <> highlight' "/c " + "and ask them to connect: " <> highlight' "/c " ] contactDeleted :: ContactName -> [StyledString] @@ -291,6 +324,48 @@ contactSubscribed c = [ttyContact c <> ": connected to server"] contactSubError :: ContactName -> ChatError -> [StyledString] contactSubError c e = [ttyContact c <> ": contact error " <> sShow e] +userContactLinkCreated :: ConnReqContact -> [StyledString] +userContactLinkCreated = connReqContact_ "Your new chat address is created!" + +userContactLinkDeleted :: [StyledString] +userContactLinkDeleted = + [ "Your chat address is deleted - accepted contacts will remain connected.", + "To create a new chat address use " <> highlight' "/ad" + ] + +userContactLink :: ConnReqContact -> [StyledString] +userContactLink = connReqContact_ "Your chat address:" + +connReqContact_ :: StyledString -> ConnReqContact -> [StyledString] +connReqContact_ intro cReq = + [ intro, + "", + (plain . serializeConnReq') cReq, + "", + "Anybody can send you contact requests with: " <> highlight' "/c ", + "to show it again: " <> highlight' "/sa", + "to delete it: " <> highlight' "/da" <> " (accepted contacts will remain connected)" + ] + +receivedContactRequest :: ContactName -> Profile -> [StyledString] +receivedContactRequest c Profile {fullName} = + [ ttyFullName c fullName <> " wants to connect to you!", + "to accept: " <> highlight ("/ac " <> c), + "to reject: " <> highlight ("/rc " <> c) <> " (the sender will NOT be notified)" + ] + +acceptingContactRequest :: ContactName -> [StyledString] +acceptingContactRequest c = [ttyContact c <> ": accepting contact request..."] + +contactRequestRejected :: ContactName -> [StyledString] +contactRequestRejected c = [ttyContact c <> ": contact request rejected"] + +userContactLinkSubError :: ChatError -> [StyledString] +userContactLinkSubError e = + [ "user address error: " <> sShow e, + "to delete your address: " <> highlight' "/da" + ] + groupSubscribed :: GroupName -> [StyledString] groupSubscribed g = [ttyGroup g <> ": connected to server(s)"] @@ -625,8 +700,13 @@ chatError = \case SEFileNotFound fileId -> fileNotFound fileId SESndFileNotFound fileId -> fileNotFound fileId SERcvFileNotFound fileId -> fileNotFound fileId + SEDuplicateContactLink -> ["you already have chat address, to show: " <> highlight' "/sa"] + SEUserContactLinkNotFound -> ["no chat address, to create: " <> highlight' "/ad"] + SEContactRequestNotFound c -> ["no contact request from " <> ttyContact c] e -> ["chat db error: " <> sShow e] - ChatErrorAgent e -> ["smp agent error: " <> sShow e] + ChatErrorAgent err -> case err of + SMP SMP.AUTH -> ["error: this connection is deleted"] + e -> ["smp agent error: " <> sShow e] ChatErrorMessage e -> ["chat message error: " <> sShow e] where fileNotFound fileId = ["file " <> sShow fileId <> " not found"] diff --git a/stack.yaml b/stack.yaml index 9aa280d870..6526fb0f8d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -43,7 +43,7 @@ extra-deps: # - simplexmq-0.4.1@sha256:3a1bc40d85e4e398458e5b9b79757e0af4fe27b8ef44eb3157f7f1e07412a8e8,7640 # - ../simplexmq - github: simplex-chat/simplexmq - commit: 391a48d588b460d4fa06ecee0e93f0aca563b00b + commit: fe2d6607de44d6be468d3a3a1a8536cf85b4f237 # # extra-deps: [] diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 262a6131e6..c93d6da030 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -46,6 +46,10 @@ chatTests = do it "sender cancelled file transfer" testFileSndCancel it "recipient cancelled file transfer" testFileRcvCancel it "send and receive file to group" testGroupFileTransfer + describe "user contact link" $ do + it "should create and connect via contact link" testUserContactLink + it "should reject contact and delete contact link" testRejectContactAndDeleteUserContact + it "should delete connection requests when contact link deleted" testDeleteConnectionRequests testAddContact :: IO () testAddContact = @@ -530,6 +534,73 @@ testGroupFileTransfer = cath <## "completed receiving file 1 (test.jpg) from alice" ] +testUserContactLink :: IO () +testUserContactLink = testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + alice ##> "/ad" + cLink <- getContactLink alice True + bob ##> ("/c " <> cLink) + alice <#? bob + alice ##> "/ac bob" + alice <## "bob: accepting contact request..." + concurrently_ + (bob <## "alice (Alice): contact is connected") + (alice <## "bob (Bob): contact is connected") + alice <##> bob + + cath ##> ("/c " <> cLink) + alice <#? cath + alice ##> "/ac cath" + alice <## "cath: accepting contact request..." + concurrently_ + (cath <## "alice (Alice): contact is connected") + (alice <## "cath (Catherine): contact is connected") + alice <##> cath + +testRejectContactAndDeleteUserContact :: IO () +testRejectContactAndDeleteUserContact = testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + alice ##> "/ad" + cLink <- getContactLink alice True + bob ##> ("/c " <> cLink) + alice <#? bob + alice ##> "/rc bob" + alice <## "bob: contact request rejected" + (bob "/sa" + cLink' <- getContactLink alice False + cLink' `shouldBe` cLink + + alice ##> "/da" + alice <## "Your chat address is deleted - accepted contacts will remain connected." + alice <## "To create a new chat address use /ad" + + cath ##> ("/c " <> cLink) + cath <## "error: this connection is deleted" + +testDeleteConnectionRequests :: IO () +testDeleteConnectionRequests = testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + alice ##> "/ad" + cLink <- getContactLink alice True + bob ##> ("/c " <> cLink) + alice <#? bob + cath ##> ("/c " <> cLink) + alice <#? cath + + alice ##> "/da" + alice <## "Your chat address is deleted - accepted contacts will remain connected." + alice <## "To create a new chat address use /ad" + + alice ##> "/ad" + cLink' <- getContactLink alice True + bob ##> ("/c " <> cLink') + -- same names are used here, as they were released at /da + alice <#? bob + cath ##> ("/c " <> cLink') + alice <#? cath + startFileTransfer :: TestCC -> TestCC -> IO () startFileTransfer alice bob = do alice #> "/f @bob ./tests/fixtures/test.jpg" @@ -648,6 +719,14 @@ cc <# line = (dropTime <$> getTermLine cc) `shouldReturn` line ( Expectation ( TestCC -> Expectation +cc1 <#? cc2 = do + name <- userName cc2 + sName <- showName cc2 + cc1 <## (sName <> " wants to connect to you!") + cc1 <## ("to accept: /ac " <> name) + cc1 <## ("to reject: /rc " <> name <> " (the sender will NOT be notified)") + dropTime :: String -> String dropTime msg = case splitAt 6 msg of ([m, m', ':', s, s', ' '], text) -> @@ -659,9 +738,20 @@ getTermLine = atomically . readTQueue . termQ getInvitation :: TestCC -> IO String getInvitation cc = do - cc <## "pass this connection link to your contact (via another channel):" + cc <## "pass this invitation link to your contact (via another channel):" cc <## "" inv <- getTermLine cc cc <## "" - cc <## "and ask them to connect: /c " + cc <## "and ask them to connect: /c " pure inv + +getContactLink :: TestCC -> Bool -> IO String +getContactLink cc created = do + cc <## if created then "Your new chat address is created!" else "Your chat address:" + cc <## "" + link <- getTermLine cc + cc <## "" + cc <## "Anybody can send you contact requests with: /c " + cc <## "to show it again: /sa" + cc <## "to delete it: /da (accepted contacts will remain connected)" + pure link