core: allow messages with contact requests

2023-04-07 10:15:19 +01:00 · 2023-04-07 10:15:19 +01:00 · ccff79aa59
commit ccff79aa59
parent ccb52e0acd
5 changed files with 35 additions and 31 deletions
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@ -1070,8 +1070,9 @@ processChatCommand = \case
    pure $ CRInvitation user cReq
  AddContact -> withUser $ \User {userId} ->
    processChatCommand $ APIAddContact userId
-  APIConnect userId (Just (ACR SCMInvitation cReq)) -> withUserId userId $ \user -> withChatLock "connect" . procCmd $ do
+  APIConnect userId (Just (ACR SCMInvitation cReq)) mc_ -> withUserId userId $ \user -> withChatLock "connect" . procCmd $ do
    -- [incognito] generate profile to send
+    when (isJust mc_) $ throwChatError CEConnReqMessageProhibited
    incognito <- readTVarIO =<< asks incognitoMode
    incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
    let profileToSend = userProfileToSend user incognitoProfile Nothing
@ -1079,13 +1080,11 @@ processChatCommand = \case
    conn <- withStore' $ \db -> createDirectConnection db user connId cReq ConnJoined $ incognitoProfile $> profileToSend
    toView $ CRNewContactConnection user conn
    pure $ CRSentConfirmation user
-  APIConnect userId (Just (ACR SCMContact cReq)) -> withUserId userId (`connectViaContact` cReq)
-  APIConnect _ Nothing -> throwChatError CEInvalidConnReq
-  Connect cReqUri -> withUser $ \User {userId} ->
-    processChatCommand $ APIConnect userId cReqUri
-  ConnectSimplex -> withUser $ \user ->
-    -- [incognito] generate profile to send
-    connectViaContact user adminContactReq
+  APIConnect userId (Just (ACR SCMContact cReq)) mc_ -> withUserId userId $ \user -> connectViaContact user cReq mc_
+  APIConnect _ Nothing _ -> throwChatError CEInvalidConnReq
+  Connect cReqUri msg_ -> withUser $ \User {userId} ->
+    processChatCommand $ APIConnect userId cReqUri $ MCText <$> msg_
+  ConnectSimplex msg_ -> withUser $ \user -> connectViaContact user adminContactReq $ MCText <$> msg_
  DeleteContact cName -> withContactName cName $ APIDeleteChat . ChatRef CTDirect
  ClearContact cName -> withContactName cName $ APIClearChat . ChatRef CTDirect
  APIListContacts userId -> withUserId userId $ \user ->
@ -1536,12 +1535,14 @@ processChatCommand = \case
      CTDirect -> withStore $ \db -> getDirectChatItemIdByText db userId cId SMDSnd msg
      CTGroup -> withStore $ \db -> getGroupChatItemIdByText db user cId (Just localDisplayName) msg
      _ -> throwChatError $ CECommandError "not supported"
-    connectViaContact :: User -> ConnectionRequestUri 'CMContact -> m ChatResponse
-    connectViaContact user@User {userId} cReq@(CRContactUri ConnReqUriData {crClientData}) = withChatLock "connectViaContact" $ do
+    connectViaContact :: User -> ConnectionRequestUri 'CMContact -> Maybe MsgContent -> m ChatResponse
+    connectViaContact user@User {userId} cReq@(CRContactUri ConnReqUriData {crClientData}) mc_ = withChatLock "connectViaContact" $ do
      let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
      withStore' (\db -> getConnReqContactXContactId db user cReqHash) >>= \case
        (Just contact, _) -> pure $ CRContactAlreadyExists user contact
        (_, xContactId_) -> procCmd $ do
+          let groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli
+          when (isJust groupLinkId) $ throwChatError CEConnReqMessageProhibited
          let randomXContactId = XContactId <$> drgRandomBytes 16
          xContactId <- maybe randomXContactId pure xContactId_
          -- [incognito] generate profile to send
@ -1552,8 +1553,7 @@ processChatCommand = \case
          incognito <- readTVarIO =<< asks incognitoMode
          incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
          let profileToSend = userProfileToSend user incognitoProfile Nothing
-          connId <- withAgent $ \a -> joinConnection a (aUserId user) True cReq $ directMessage (XContact profileToSend $ Just xContactId)
-          let groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli
+          connId <- withAgent $ \a -> joinConnection a (aUserId user) True cReq $ directMessage (XContact profileToSend (Just xContactId) mc_)
          conn <- withStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId incognitoProfile groupLinkId
          toView $ CRNewContactConnection user conn
          pure $ CRSentInvitation user incognitoProfile
@ -2921,8 +2921,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
      REQ invId _ connInfo -> do
        ChatMessage {chatMsgEvent} <- parseChatMessage connInfo
        case chatMsgEvent of
-          XContact p xContactId_ -> profileContactRequest invId p xContactId_
-          XInfo p -> profileContactRequest invId p Nothing
+          XContact p xContactId_ mc_ -> profileContactRequest invId p xContactId_ mc_
+          XInfo p -> profileContactRequest invId p Nothing Nothing
          -- TODO show/log error, other events in contact request
          _ -> pure ()
      MERR _ err -> do
@ -2934,19 +2934,21 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
      -- TODO add debugging output
      _ -> pure ()
      where
-        profileContactRequest :: InvitationId -> Profile -> Maybe XContactId -> m ()
-        profileContactRequest invId p xContactId_ = do
+        profileContactRequest :: InvitationId -> Profile -> Maybe XContactId -> Maybe MsgContent -> m ()
+        profileContactRequest invId p xContactId_ _mc_ = do
          withStore (\db -> createOrUpdateContactRequest db user userContactLinkId invId p xContactId_) >>= \case
            CORContact contact -> toView $ CRContactRequestAlreadyAccepted user contact
            CORRequest cReq@UserContactRequest {localDisplayName} -> do
              withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
                Just (UserContactLink {autoAccept}, groupId_, _) ->
+                  -- TODO add chat item for contact request
                  case autoAccept of
                    Just AutoAccept {acceptIncognito} -> case groupId_ of
                      Nothing -> do
                        -- [incognito] generate profile to send, create connection with incognito profile
                        incognitoProfile <- if acceptIncognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
                        ct <- acceptContactRequestAsync user cReq incognitoProfile
+                        -- TODO move chat item to contact
                        toView $ CRAcceptingContactRequest user ct
                      Just groupId -> do
                        gInfo@GroupInfo {membership = membership@GroupMember {memberProfile}} <- withStore $ \db -> getGroupInfo db user groupId
@ -4546,9 +4548,9 @@ chatCommandP =
      (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <* char_ '@' <*> (Just <$> displayName) <* A.space <*> quotedMsg <*> msgTextP),
      "/_contacts " *> (APIListContacts <$> A.decimal),
      "/contacts" $> ListContacts,
-      "/_connect " *> (APIConnect <$> A.decimal <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
+      "/_connect " *> (APIConnect <$> A.decimal <* A.space <*> ((Just <$> strP) <|> A.takeTill (== ' ') $> Nothing) <*> optional (A.space *> msgContentP)),
      "/_connect " *> (APIAddContact <$> A.decimal),
-      ("/connect " <|> "/c ") *> (Connect <$> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
+      ("/connect " <|> "/c ") *> (Connect <$> ((Just <$> strP) <|> A.takeTill (== ' ') $> Nothing) <*> optional (A.space *> msgTextP)),
      ("/connect" <|> "/c") $> AddContact,
      SendMessage <$> chatNameP <* A.space <*> msgTextP,
      "/live " *> (SendLiveMessage <$> chatNameP <*> (A.space *> msgTextP <|> pure "")),
@ -4572,7 +4574,7 @@ chatCommandP =
      ("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> optional (" inline=" *> onOffP) <*> optional (A.space *> filePath)),
      ("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal),
      ("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal),
-      "/simplex" $> ConnectSimplex,
+      "/simplex" *> (ConnectSimplex <$> optional (A.space *> msgTextP)),
      "/_address " *> (APICreateMyAddress <$> A.decimal),
      ("/address" <|> "/ad") $> CreateMyAddress,
      "/_delete_address " *> (APIDeleteMyAddress <$> A.decimal),
--- a/src/Simplex/Chat/Controller.hs
+++ b/src/Simplex/Chat/Controller.hs
@ -298,9 +298,9 @@ data ChatCommand
  | Welcome
  | APIAddContact UserId
  | AddContact
-  | APIConnect UserId (Maybe AConnectionRequestUri)
-  | Connect (Maybe AConnectionRequestUri)
-  | ConnectSimplex -- UserId (not used in UI)
+  | APIConnect UserId (Maybe AConnectionRequestUri) (Maybe MsgContent)
+  | Connect (Maybe AConnectionRequestUri) (Maybe Text)
+  | ConnectSimplex (Maybe Text)
  | DeleteContact ContactName
  | ClearContact ContactName
  | APIListContacts UserId
@ -769,6 +769,7 @@ data ChatErrorType
  | CEChatStoreChanged
  | CEInvalidConnReq
  | CEInvalidChatMessage {message :: String}
+  | CEConnReqMessageProhibited
  | CEContactNotReady {contact :: Contact}
  | CEContactDisabled {contact :: Contact}
  | CEConnectionDisabled {connection :: Connection}
--- a/src/Simplex/Chat/Protocol.hs
+++ b/src/Simplex/Chat/Protocol.hs
@ -189,7 +189,7 @@ data ChatMsgEvent (e :: MsgEncoding) where
  XFileAcptInv :: SharedMsgId -> Maybe ConnReqInvitation -> String -> ChatMsgEvent 'Json
  XFileCancel :: SharedMsgId -> ChatMsgEvent 'Json
  XInfo :: Profile -> ChatMsgEvent 'Json
-  XContact :: Profile -> Maybe XContactId -> ChatMsgEvent 'Json
+  XContact :: Profile -> Maybe XContactId -> Maybe MsgContent -> ChatMsgEvent 'Json
  XGrpInv :: GroupInvitation -> ChatMsgEvent 'Json
  XGrpAcpt :: MemberId -> ChatMsgEvent 'Json
  XGrpMemNew :: MemberInfo -> ChatMsgEvent 'Json
@ -605,7 +605,7 @@ toCMEventTag msg = case msg of
  XFileAcptInv {} -> XFileAcptInv_
  XFileCancel _ -> XFileCancel_
  XInfo _ -> XInfo_
-  XContact _ _ -> XContact_
+  XContact {} -> XContact_
  XGrpInv _ -> XGrpInv_
  XGrpAcpt _ -> XGrpAcpt_
  XGrpMemNew _ -> XGrpMemNew_
@ -692,7 +692,7 @@ appJsonToCM AppMessageJson {msgId, event, params} = do
      XFileAcptInv_ -> XFileAcptInv <$> p "msgId" <*> opt "fileConnReq" <*> p "fileName"
      XFileCancel_ -> XFileCancel <$> p "msgId"
      XInfo_ -> XInfo <$> p "profile"
-      XContact_ -> XContact <$> p "profile" <*> opt "contactReqId"
+      XContact_ -> XContact <$> p "profile" <*> opt "contactReqId" <*> opt "content"
      XGrpInv_ -> XGrpInv <$> p "groupInvitation"
      XGrpAcpt_ -> XGrpAcpt <$> p "memberId"
      XGrpMemNew_ -> XGrpMemNew <$> p "memberInfo"
@ -747,7 +747,7 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = case encoding @e of
      XFileAcptInv sharedMsgId fileConnReq fileName -> o $ ("fileConnReq" .=? fileConnReq) ["msgId" .= sharedMsgId, "fileName" .= fileName]
      XFileCancel sharedMsgId -> o ["msgId" .= sharedMsgId]
      XInfo profile -> o ["profile" .= profile]
-      XContact profile xContactId -> o $ ("contactReqId" .=? xContactId) ["profile" .= profile]
+      XContact profile xContactId content -> o $ ("contactReqId" .=? xContactId) $ ("content" .=? content) ["profile" .= profile]
      XGrpInv groupInv -> o ["groupInvitation" .= groupInv]
      XGrpAcpt memId -> o ["memberId" .= memId]
      XGrpMemNew memInfo -> o ["memberInfo" .= memInfo]
--- a/src/Simplex/Chat/View.hs
+++ b/src/Simplex/Chat/View.hs
@ -1271,6 +1271,7 @@ viewChatError logLevel = \case
    CEChatStoreChanged -> ["error: chat store changed, please restart chat"]
    CEInvalidConnReq -> viewInvalidConnReq
    CEInvalidChatMessage e -> ["chat message error: " <> sShow e]
+    CEConnReqMessageProhibited -> ["message is not allowed with this connection link"]
    CEContactNotReady c -> [ttyContact' c <> ": not ready"]
    CEContactDisabled Contact {localDisplayName = c} -> [ttyContact c <> ": disabled, to enable: " <> highlight ("/enable " <> c) <> ", to delete: " <> highlight ("/d " <> c)]
    CEConnectionDisabled Connection {connId, connType} -> [plain $ "connection " <> textEncode connType <> " (" <> tshow connId <> ") is disabled" | logLevel <= CLLWarning]
--- a/tests/ProtocolTests.hs
+++ b/tests/ProtocolTests.hs
@ -201,16 +201,16 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
      #==# XInfo Profile {displayName = "alice", fullName = "", image = Nothing, preferences = testChatPreferences}
  it "x.contact with xContactId" $
    "{\"event\":\"x.contact\",\"params\":{\"contactReqId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"voice\":{\"allow\":\"yes\"}}}}}"
-      #==# XContact testProfile (Just $ XContactId "\1\2\3\4")
+      #==# XContact testProfile (Just $ XContactId "\1\2\3\4") Nothing
  it "x.contact without XContactId" $
    "{\"event\":\"x.contact\",\"params\":{\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"voice\":{\"allow\":\"yes\"}}}}}"
-      #==# XContact testProfile Nothing
+      #==# XContact testProfile Nothing Nothing
  it "x.contact with content null" $
    "{\"event\":\"x.contact\",\"params\":{\"content\":null,\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"voice\":{\"allow\":\"yes\"}}}}}"
-      ==# XContact testProfile Nothing
-  it "x.contact with content (ignored)" $
+      ==# XContact testProfile Nothing Nothing
+  it "x.contact with content" $
    "{\"event\":\"x.contact\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"voice\":{\"allow\":\"yes\"}}}}}"
-      ==# XContact testProfile Nothing
+      #==# XContact testProfile Nothing (Just $ MCText "hello")
  it "x.grp.inv" $
    "{\"event\":\"x.grp.inv\",\"params\":{\"groupInvitation\":{\"connRequest\":\"https://simplex.chat/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-2%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D1-2%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"invitedMember\":{\"memberRole\":\"member\",\"memberId\":\"BQYHCA==\"},\"groupProfile\":{\"fullName\":\"Team\",\"displayName\":\"team\",\"groupPreferences\":{\"voice\":{\"enable\":\"on\"}}},\"fromMember\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\"}}}}"
      #==# XGrpInv GroupInvitation {fromMember = MemberIdRole (MemberId "\1\2\3\4") GRAdmin, invitedMember = MemberIdRole (MemberId "\5\6\7\8") GRMember, connRequest = testConnReq, groupProfile = testGroupProfile, groupLinkId = Nothing}