diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 998c825e51..abf01ceee7 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -128,6 +128,7 @@ processChatCommand user@User {userId, profile} = \case APIGetChat cType cId -> case cType of CTDirect -> CRApiChat . AChat SCTDirect <$> withStore (\st -> getDirectChat st userId cId) CTGroup -> CRApiChat . AChat SCTGroup <$> withStore (\st -> getGroupChat st user cId) + CTContactRequest -> pure $ CRChatError ChatErrorNotImplemented APIGetChatItems _count -> pure $ CRChatError ChatErrorNotImplemented APISendMessage cType chatId mc -> case cType of CTDirect -> do @@ -141,18 +142,35 @@ processChatCommand user@User {userId, profile} = \case ci <- sendGroupChatItem userId group (XMsgNew mc) (CISndMsgContent mc) setActive $ ActiveG gName pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci - APIDeleteContact contactId -> do - ct@Contact {localDisplayName} <- withStore $ \st -> getContact st userId contactId - withStore (\st -> getContactGroupNames st userId ct) >>= \case - [] -> do - conns <- withStore $ \st -> getContactConnections st userId ct - procCmd $ do - withAgent $ \a -> forM_ conns $ \conn -> - deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure () - withStore $ \st -> deleteContact st userId ct - unsetActive $ ActiveC localDisplayName - pure $ CRContactDeleted ct - gs -> throwChatError $ CEContactGroups ct gs + CTContactRequest -> pure $ CRChatError ChatErrorNotImplemented + APIDeleteChat cType chatId -> case cType of + CTDirect -> do + ct@Contact {localDisplayName} <- withStore $ \st -> getContact st userId chatId + withStore (\st -> getContactGroupNames st userId ct) >>= \case + [] -> do + conns <- withStore $ \st -> getContactConnections st userId ct + procCmd $ do + withAgent $ \a -> forM_ conns $ \conn -> + deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure () + withStore $ \st -> deleteContact st userId ct + unsetActive $ ActiveC localDisplayName + pure $ CRContactDeleted ct + gs -> throwChatError $ CEContactGroups ct gs + CTGroup -> pure $ CRChatCmdError ChatErrorNotImplemented + CTContactRequest -> do + cReq@UserContactRequest {agentContactConnId = AgentConnId connId, agentInvitationId = AgentInvId invId} <- + withStore $ \st -> + getContactRequest st userId chatId + `E.finally` deleteContactRequest st userId chatId + withAgent $ \a -> rejectContact a connId invId + pure $ CRContactRequestRejected cReq + APIAcceptContact contactRequestId -> do + ctReq@UserContactRequest {agentInvitationId = AgentInvId invId, localDisplayName = cName, profileId} <- withStore $ \st -> + getContactRequest st userId contactRequestId + procCmd $ do + connId <- withAgent $ \a -> acceptContact a invId . directMessage $ XInfo profile + withStore $ \st -> createAcceptedContact st userId connId cName profileId + pure $ CRAcceptingContactRequest ctReq ChatHelp section -> pure $ CRChatHelp section Welcome -> pure $ CRWelcome user AddContact -> procCmd $ do @@ -171,7 +189,7 @@ processChatCommand user@User {userId, profile} = \case pure CRSentInvitation DeleteContact cName -> do contactId <- withStore $ \st -> getContactIdByName st userId cName - processChatCommand user $ APIDeleteContact contactId + processChatCommand user $ APIDeleteChat CTDirect contactId ListContacts -> CRContactsList <$> withStore (`getUserContacts` user) CreateMyAddress -> procCmd $ do (connId, cReq) <- withAgent (`createConnection` SCMContact) @@ -186,18 +204,11 @@ processChatCommand user@User {userId, profile} = \case pure CRUserContactLinkDeleted ShowMyAddress -> CRUserContactLink <$> withStore (`getUserContactLink` userId) AcceptContact cName -> do - UserContactRequest {agentInvitationId, profileId} <- withStore $ \st -> - getContactRequest st userId cName - procCmd $ do - connId <- withAgent $ \a -> acceptContact a agentInvitationId . directMessage $ XInfo profile - withStore $ \st -> createAcceptedContact st userId connId cName profileId - pure $ CRAcceptingContactRequest cName + contactRequestId <- withStore $ \st -> getContactRequestIdByName st userId cName + processChatCommand user $ APIAcceptContact contactRequestId RejectContact cName -> do - UserContactRequest {agentContactConnId, agentInvitationId} <- withStore $ \st -> - getContactRequest st userId cName - `E.finally` deleteContactRequest st userId cName - withAgent $ \a -> rejectContact a agentContactConnId agentInvitationId - pure $ CRContactRequestRejected cName + contactRequestId <- withStore $ \st -> getContactRequestIdByName st userId cName + processChatCommand user $ APIDeleteChat CTContactRequest contactRequestId SendMessage cName msg -> do contactId <- withStore $ \st -> getContactIdByName st userId cName let mc = MCText $ safeDecodeUtf8 msg @@ -768,9 +779,9 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do where profileContactRequest :: InvitationId -> Profile -> m () profileContactRequest invId p = do - cName <- withStore $ \st -> createContactRequest st userId userContactLinkId invId p - toView $ CRReceivedContactRequest cName p - showToast (cName <> "> ") "wants to connect to you" + cReq@UserContactRequest {localDisplayName} <- withStore $ \st -> createContactRequest st userId userContactLinkId invId p + toView $ CRReceivedContactRequest cReq + showToast (localDisplayName <> "> ") "wants to connect to you" withAckMessage :: ConnId -> MsgMeta -> m () -> m () withAckMessage cId MsgMeta {recipient = (msgId, _)} action = @@ -1311,7 +1322,8 @@ chatCommandP = <|> "/get chat " *> (APIGetChat <$> chatTypeP <*> A.decimal) <|> "/get chatItems count=" *> (APIGetChatItems <$> A.decimal) <|> "/send msg " *> (APISendMessage <$> chatTypeP <*> A.decimal <* A.space <*> msgContentP) - <|> "/_del @" *> (APIDeleteContact <$> A.decimal) + <|> "/_del " *> (APIDeleteChat <$> chatTypeP <*> A.decimal) + <|> "/_ac " *> (APIAcceptContact <$> A.decimal) <|> ("/help files" <|> "/help file" <|> "/hf") $> ChatHelp HSFiles <|> ("/help groups" <|> "/help group" <|> "/hg") $> ChatHelp HSGroups <|> ("/help address" <|> "/ha") $> ChatHelp HSMyAddress @@ -1348,7 +1360,7 @@ chatCommandP = <|> ("/quit" <|> "/q" <|> "/exit") $> QuitChat <|> ("/version" <|> "/v") $> ShowVersion where - chatTypeP = "@" $> CTDirect <|> "#" $> CTGroup + chatTypeP = A.char '@' $> CTDirect <|> A.char '#' $> CTGroup <|> "<@" $> CTContactRequest msgContentP = "text " *> (MCText . safeDecodeUtf8 <$> A.takeByteString) displayName = safeDecodeUtf8 <$> (B.cons <$> A.satisfy refChar <*> A.takeTill (== ' ')) refChar c = c > ' ' && c /= '#' && c /= '@' diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index e413ab0a09..849c5f2883 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -82,7 +82,8 @@ data ChatCommand | APIGetChat ChatType Int64 | APIGetChatItems Int | APISendMessage ChatType Int64 MsgContent - | APIDeleteContact Int64 + | APIDeleteChat ChatType Int64 + | APIAcceptContact Int64 | ChatHelp HelpSection | Welcome | AddContact @@ -128,7 +129,7 @@ data ChatResponse | CRGroupMembers {group :: Group} | CRContactsList {contacts :: [Contact]} | CRUserContactLink {connReqContact :: ConnReqContact} - | CRContactRequestRejected {contactName :: ContactName} -- TODO + | CRContactRequestRejected {contactRequest :: UserContactRequest} | CRUserAcceptedGroupSent {groupInfo :: GroupInfo} | CRUserDeletedMember {groupInfo :: GroupInfo, member :: GroupMember} | CRGroupsList {groups :: [GroupInfo]} @@ -145,8 +146,8 @@ data ChatResponse | CRContactDeleted {contact :: Contact} | CRUserContactLinkCreated {connReqContact :: ConnReqContact} | CRUserContactLinkDeleted - | CRReceivedContactRequest {contactName :: ContactName, profile :: Profile} -- TODO what is the entity here? - | CRAcceptingContactRequest {contactName :: ContactName} -- TODO + | CRReceivedContactRequest {contactRequest :: UserContactRequest} + | CRAcceptingContactRequest {contactRequest :: UserContactRequest} | CRLeftMemberUser {groupInfo :: GroupInfo} | CRGroupDeletedUser {groupInfo :: GroupInfo} | CRRcvFileAccepted {fileTransfer :: RcvFileTransfer, filePath :: FilePath} diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index c4780ea34e..58f8ddf77a 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -36,7 +36,7 @@ import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (dropPrefix, enumJSON, sumTypeJSON) import Simplex.Messaging.Protocol (MsgBody) -data ChatType = CTDirect | CTGroup +data ChatType = CTDirect | CTGroup | CTContactRequest deriving (Show, Generic) instance ToJSON ChatType where @@ -46,12 +46,14 @@ instance ToJSON ChatType where data ChatInfo (c :: ChatType) where DirectChat :: Contact -> ChatInfo 'CTDirect GroupChat :: GroupInfo -> ChatInfo 'CTGroup + ContactRequest :: UserContactRequest -> ChatInfo 'CTContactRequest deriving instance Show (ChatInfo c) data JSONChatInfo = JCInfoDirect {contact :: Contact} | JCInfoGroup {groupInfo :: GroupInfo} + | JCIInfoContactRequest {contactRequest :: UserContactRequest} deriving (Generic) instance ToJSON JSONChatInfo where @@ -66,6 +68,7 @@ jsonChatInfo :: ChatInfo c -> JSONChatInfo jsonChatInfo = \case DirectChat c -> JCInfoDirect c GroupChat g -> JCInfoGroup g + ContactRequest g -> JCIInfoContactRequest g data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem { chatDir :: CIDirection c d, @@ -250,6 +253,7 @@ aciContentJSON = \case data SChatType (c :: ChatType) where SCTDirect :: SChatType 'CTDirect SCTGroup :: SChatType 'CTGroup + SCTContactRequest :: SChatType 'CTContactRequest deriving instance Show (SChatType c) diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 206a81ff1f..3d10982fa4 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -39,6 +39,7 @@ module Simplex.Chat.Store getUserContactLink, createContactRequest, getContactRequest, + getContactRequestIdByName, deleteContactRequest, createAcceptedContact, getLiveSndFileTransfers, @@ -468,10 +469,12 @@ getUserContactLink st userId = connReq [Only cReq] = Right cReq connReq _ = Left SEUserContactLinkNotFound -createContactRequest :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> InvitationId -> Profile -> m ContactName +createContactRequest :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> InvitationId -> Profile -> m UserContactRequest createContactRequest st userId userContactId invId Profile {displayName, fullName} = liftIOEither . withTransaction st $ \db -> - withLocalDisplayName db userId displayName $ \ldn -> do + join <$> withLocalDisplayName db userId displayName (createContactRequest' db) + where + createContactRequest' db ldn = do DB.execute db "INSERT INTO contact_profiles (display_name, full_name) VALUES (?, ?)" (displayName, fullName) profileId <- insertedRowId db DB.execute @@ -481,33 +484,58 @@ createContactRequest st userId userContactId invId Profile {displayName, fullNam (user_contact_link_id, agent_invitation_id, contact_profile_id, local_display_name, user_id) VALUES (?,?,?,?,?) |] (userContactId, invId, profileId, ldn, userId) - pure ldn + contactRequestId <- insertedRowId db + getContactRequest_ db userId contactRequestId -getContactRequest :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m UserContactRequest -getContactRequest st userId localDisplayName = +getContactRequest :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> m UserContactRequest +getContactRequest st userId contactRequestId = 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 + runExceptT $ + ExceptT $ getContactRequest_ db userId contactRequestId -deleteContactRequest :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactName -> m () -deleteContactRequest st userId localDisplayName = +getContactRequest_ :: DB.Connection -> UserId -> Int64 -> IO (Either StoreError UserContactRequest) +getContactRequest_ db userId contactRequestId = + contactReq + <$> DB.query + db + [sql| + SELECT + cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id, + c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name + FROM contact_requests cr + JOIN connections c USING (user_contact_link_id) + JOIN contact_profiles p USING (contact_profile_id) + WHERE cr.user_id = ? + AND cr.contact_request_id = ? + |] + (userId, contactRequestId) + where + contactReq :: [(ContactName, AgentInvId, Int64, AgentConnId, Int64, ContactName, Text)] -> Either StoreError UserContactRequest + contactReq [(localDisplayName, agentInvitationId, userContactLinkId, agentContactConnId, profileId, displayName, fullName)] = do + let profile = Profile {displayName, fullName} + Right UserContactRequest {contactRequestId, agentInvitationId, userContactLinkId, agentContactConnId, localDisplayName, profileId, profile} + contactReq _ = Left $ SEContactRequestNotFound contactRequestId + +getContactRequestIdByName :: StoreMonad m => SQLiteStore -> UserId -> ContactName -> m Int64 +getContactRequestIdByName st userId cName = + liftIOEither . withTransaction st $ \db -> + firstRow fromOnly (SEContactRequestNotFoundByName cName) $ + DB.query db "SELECT contact_request_id FROM contact_requests WHERE user_id = ? AND local_display_name = ?" (userId, cName) + +deleteContactRequest :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> m () +deleteContactRequest st userId contactRequestId = 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) + DB.execute + db + [sql| + DELETE FROM display_names + WHERE user_id = ? AND local_display_name = ( + SELECT local_display_name FROM contact_requests + WHERE user_id = ? AND contact_request_id = ? + ) + |] + (userId, userId, contactRequestId) + DB.execute db "DELETE FROM contact_requests WHERE user_id = ? AND contact_request_id = ?" (userId, contactRequestId) createAcceptedContact :: MonadUnliftIO m => SQLiteStore -> UserId -> ConnId -> ContactName -> Int64 -> m () createAcceptedContact st userId agentConnId localDisplayName profileId = @@ -2131,7 +2159,8 @@ data StoreError | SEContactNotReady {contactName :: ContactName} | SEDuplicateContactLink | SEUserContactLinkNotFound - | SEContactRequestNotFound {contactName :: ContactName} + | SEContactRequestNotFound {contactRequestId :: Int64} + | SEContactRequestNotFoundByName {contactName :: ContactName} | SEGroupNotFound {groupId :: Int64} | SEGroupNotFoundByName {groupName :: GroupName} | SEGroupWithoutUser diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index d6ab2a2399..fe80668468 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -93,13 +93,17 @@ data UserContact = UserContact data UserContactRequest = UserContactRequest { contactRequestId :: Int64, - agentInvitationId :: InvitationId, + agentInvitationId :: AgentInvId, userContactLinkId :: Int64, - agentContactConnId :: ConnId, + agentContactConnId :: AgentConnId, -- connection id of user contact localDisplayName :: ContactName, - profileId :: Int64 + profileId :: Int64, + profile :: Profile } - deriving (Eq, Show) + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON UserContactRequest where + toEncoding = J.genericToEncoding J.defaultOptions type ContactName = Text @@ -517,6 +521,25 @@ instance FromField AgentConnId where fromField f = AgentConnId <$> fromField f instance ToField AgentConnId where toField (AgentConnId m) = toField m +newtype AgentInvId = AgentInvId InvitationId + deriving (Eq, Show) + +instance StrEncoding AgentInvId where + strEncode (AgentInvId connId) = strEncode connId + strDecode s = AgentInvId <$> strDecode s + strP = AgentInvId <$> strP + +instance FromJSON AgentInvId where + parseJSON = strParseJSON "AgentInvId" + +instance ToJSON AgentInvId where + toJSON = strToJSON + toEncoding = strToJEncoding + +instance FromField AgentInvId where fromField f = AgentInvId <$> fromField f + +instance ToField AgentInvId where toField (AgentInvId m) = toField m + data FileTransfer = FTSnd {sndFileTransfers :: [SndFileTransfer]} | FTRcv RcvFileTransfer deriving (Show, Generic) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 43df867b31..230253a44c 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -47,7 +47,7 @@ responseToView cmd = \case CRWelcome user -> r $ chatWelcome user CRContactsList cs -> r $ viewContactsList cs CRUserContactLink cReq -> r $ connReqContact_ "Your chat address:" cReq - CRContactRequestRejected c -> r [ttyContact c <> ": contact request rejected"] + CRContactRequestRejected UserContactRequest {localDisplayName = c} -> r [ttyContact c <> ": contact request rejected"] CRGroupCreated g -> r $ viewGroupCreated g CRGroupMembers g -> r $ viewGroupMembers g CRGroupsList gs -> r $ viewGroupsList gs @@ -61,7 +61,7 @@ responseToView cmd = \case CRSentConfirmation -> r' ["confirmation sent!"] CRSentInvitation -> r' ["connection request sent!"] CRContactDeleted Contact {localDisplayName} -> r' [ttyContact localDisplayName <> ": contact is deleted"] - CRAcceptingContactRequest c -> r' [ttyContact c <> ": accepting contact request..."] + CRAcceptingContactRequest UserContactRequest {localDisplayName = c} -> r' [ttyContact c <> ": accepting contact request..."] CRUserContactLinkCreated cReq -> r' $ connReqContact_ "Your new chat address is created!" cReq CRUserContactLinkDeleted -> r' viewUserContactLinkDeleted CRUserAcceptedGroupSent _g -> r' [] -- [ttyGroup' g <> ": joining the group..."] @@ -76,7 +76,7 @@ responseToView cmd = \case CRUserProfileUpdated p p' -> r' $ viewUserProfileUpdated p p' CRContactUpdated c c' -> viewContactUpdated c c' CRContactsMerged intoCt mergedCt -> viewContactsMerged intoCt mergedCt - CRReceivedContactRequest c p -> viewReceivedContactRequest c p + CRReceivedContactRequest UserContactRequest {localDisplayName = c, profile} -> viewReceivedContactRequest c profile CRRcvFileStart ft -> receivingFile_ "started" ft CRRcvFileComplete ft -> receivingFile_ "completed" ft CRRcvFileSndCancelled ft -> viewRcvFileSndCancelled ft @@ -479,7 +479,7 @@ viewChatError = \case 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] + SEContactRequestNotFoundByName c -> ["no contact request from " <> ttyContact c] e -> ["chat db error: " <> sShow e] ChatErrorAgent err -> case err of SMP SMP.AUTH -> ["error: this connection is deleted"]