diff --git a/package.yaml b/package.yaml index afc5d71148..7a5a670c5d 100644 --- a/package.yaml +++ b/package.yaml @@ -37,6 +37,7 @@ dependencies: - time == 1.9.* - unliftio == 0.2.* - unliftio-core == 0.2.* + - unordered-containers == 0.2.* library: source-dirs: src diff --git a/simplex-chat.cabal b/simplex-chat.cabal index a1e78a15ea..5f173b3da2 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -64,6 +64,7 @@ library , time ==1.9.* , unliftio ==0.2.* , unliftio-core ==0.2.* + , unordered-containers ==0.2.* default-language: Haskell2010 executable simplex-chat @@ -100,6 +101,7 @@ executable simplex-chat , time ==1.9.* , unliftio ==0.2.* , unliftio-core ==0.2.* + , unordered-containers ==0.2.* default-language: Haskell2010 test-suite simplex-chat-test @@ -144,4 +146,5 @@ test-suite simplex-chat-test , time ==1.9.* , unliftio ==0.2.* , unliftio-core ==0.2.* + , unordered-containers ==0.2.* default-language: Haskell2010 diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index cd4c910f4e..a2d8f3bb81 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -50,6 +50,7 @@ import Simplex.Messaging.Agent import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), defaultAgentConfig) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll) import Simplex.Messaging.Protocol (MsgBody) import qualified Simplex.Messaging.Protocol as SMP @@ -73,9 +74,9 @@ data ChatCommand | MarkdownHelp | Welcome | AddContact - | Connect (Maybe AConnectionRequest) - | ConnectAdmin - | SendAdminWelcome ContactName + | Connect (Maybe AConnectionRequestUri) + | -- | ConnectAdmin + SendAdminWelcome ContactName | DeleteContact ContactName | ListContacts | CreateMyAddress @@ -117,7 +118,7 @@ defaultChatConfig = }, dbPoolSize = 1, tbqSize = 16, - fileChunkSize = 7050 + fileChunkSize = 15000 } logCfg :: LogConfig @@ -153,7 +154,7 @@ runSimplexChat = runReaderT $ do whenM (asks firstTime) . printToView . chatWelcome user $ Onboarding 0 0 0 0 0 race_ runTerminalInput runChatController -runChatController :: (MonadUnliftIO m, MonadReader ChatController m) => m () +runChatController :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m () runChatController = raceAny_ [ inputSubscriber, @@ -167,7 +168,7 @@ withLock lock = (void . atomically $ takeTMVar lock) (atomically $ putTMVar lock ()) -inputSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m () +inputSubscriber :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m () inputSubscriber = do q <- asks inputQ l <- asks chatLock @@ -207,7 +208,7 @@ processChatCommand user@User {userId, profile} = \case Connect (Just (ACR SCMInvitation cReq)) -> connect cReq (XInfo profile) >> showSentConfirmation Connect (Just (ACR SCMContact cReq)) -> connect cReq (XContact profile Nothing) >> showSentInvitation Connect Nothing -> showInvalidConnReq - ConnectAdmin -> connect adminContactReq (XContact profile Nothing) >> showSentInvitation + -- ConnectAdmin -> connect adminContactReq (XContact profile Nothing) >> showSentInvitation SendAdminWelcome cName -> forM_ adminWelcomeMessages $ sendMessageCmd cName DeleteContact cName -> withStore (\st -> getContactGroupNames st userId cName) >>= \case @@ -259,7 +260,7 @@ processChatCommand user@User {userId, profile} = \case unless (memberActive membership) $ chatError CEGroupMemberNotActive let sendInvitation memberId cReq = do sendDirectMessage (contactConn contact) $ - XGrpInv $ GroupInvitation (userMemberId, userRole) (memberId, memRole) cReq groupProfile + XGrpInv $ GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile showSentGroupInvitation gName cName setActive $ ActiveG gName case contactMember contact members of @@ -276,7 +277,7 @@ processChatCommand user@User {userId, profile} = \case | otherwise -> chatError (CEGroupDuplicateMember cName) JoinGroup gName -> do ReceivedGroupInvitation {fromMember, userMember, connRequest} <- withStore $ \st -> getGroupInvitation st user gName - agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId userMember + agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId (userMember :: GroupMember) withStore $ \st -> do createMemberConnection st userId fromMember agentConnId updateGroupMemberStatus st userId fromMember GSMemAccepted @@ -286,13 +287,13 @@ processChatCommand user@User {userId, profile} = \case Group {membership, members} <- withStore $ \st -> getGroup st user gName case find ((== cName) . (localDisplayName :: GroupMember -> ContactName)) members of Nothing -> chatError $ CEGroupMemberNotFound cName - Just member -> do - let userRole = memberRole membership - when (userRole < GRAdmin || userRole < memberRole member) $ chatError CEGroupUserRole - when (memberStatus member /= GSMemInvited) . sendGroupMessage members $ XGrpMemDel (memberId member) - deleteMemberConnection member - withStore $ \st -> updateGroupMemberStatus st userId member GSMemRemoved - showDeletedMember gName Nothing (Just member) + Just m@GroupMember {memberId = mId, memberRole = mRole, memberStatus = mStatus} -> do + let userRole = memberRole (membership :: GroupMember) + when (userRole < GRAdmin || userRole < mRole) $ chatError CEGroupUserRole + when (mStatus /= GSMemInvited) . sendGroupMessage members $ XGrpMemDel mId + deleteMemberConnection m + withStore $ \st -> updateGroupMemberStatus st userId m GSMemRemoved + showDeletedMember gName Nothing (Just m) LeaveGroup gName -> do Group {membership, members} <- withStore $ \st -> getGroup st user gName sendGroupMessage members XGrpLeave @@ -303,7 +304,7 @@ processChatCommand user@User {userId, profile} = \case g@Group {membership, members} <- withStore $ \st -> getGroup st user gName let s = memberStatus membership canDelete = - memberRole membership == GROwner + memberRole (membership :: GroupMember) == GROwner || (s == GSMemRemoved || s == GSMemLeft || s == GSMemGroupDeleted || s == GSMemInvited) unless canDelete $ chatError CEGroupUserRole when (memberActive membership) $ sendGroupMessage members XGrpDel @@ -318,7 +319,7 @@ processChatCommand user@User {userId, profile} = \case -- TODO save pending message delivery for members without connections Group {members, membership} <- withStore $ \st -> getGroup st user gName unless (memberActive membership) $ chatError CEGroupMemberUserRemoved - let msgEvent = XMsgNew $ MsgContent MTText [] [MsgContentBody {contentType = SimplexContentType XCText, contentData = msg}] + let msgEvent = XMsgNew . MCText $ safeDecodeUtf8 msg sendGroupMessage members msgEvent setActive $ ActiveG gName SendFile cName f -> do @@ -376,14 +377,14 @@ processChatCommand user@User {userId, profile} = \case QuitChat -> liftIO exitSuccess ShowVersion -> printToView clientVersionInfo where - connect :: ConnectionRequest c -> ChatMsgEvent -> m () + connect :: ConnectionRequestUri c -> ChatMsgEvent -> m () connect cReq msg = do connId <- withAgent $ \a -> joinConnection a cReq $ directMessage msg withStore $ \st -> createDirectConnection st userId connId sendMessageCmd :: ContactName -> ByteString -> m () sendMessageCmd cName msg = do contact <- withStore $ \st -> getContact st userId cName - let msgEvent = XMsgNew $ MsgContent MTText [] [MsgContentBody {contentType = SimplexContentType XCText, contentData = msg}] + let msgEvent = XMsgNew . MCText $ safeDecodeUtf8 msg sendDirectMessage (contactConn contact) msgEvent setActive $ ActiveC cName contactMember :: Contact -> [GroupMember] -> Maybe GroupMember @@ -426,7 +427,7 @@ processChatCommand user@User {userId, profile} = \case f = filePath `combine` (name <> suffix <> ext) in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f) -agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m () +agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m () agentSubscriber = do q <- asks $ subQ . smpAgent l <- asks chatLock @@ -437,7 +438,7 @@ agentSubscriber = do withLock l . void . runExceptT $ processAgentMessage user connId msg `catchError` showChatError -subscribeUserConnections :: (MonadUnliftIO m, MonadReader ChatController m) => m () +subscribeUserConnections :: (MonadUnliftIO m, MonadReader ChatController m, MonadFail m) => m () subscribeUserConnections = void . runExceptT $ do user <- readTVarIO =<< asks currentUser subscribeContacts user @@ -519,7 +520,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do where isMember :: MemberId -> Group -> Bool isMember memId Group {membership, members} = - memberId membership == memId || isJust (find ((== memId) . memberId) members) + sameMemberId memId membership || isJust (find (sameMemberId memId) members) contactIsReady :: Contact -> Bool contactIsReady Contact {activeConn} = connStatus activeConn == ConnReady @@ -554,7 +555,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do chatMsgEvent <- saveRcvMSG conn meta msgBody withAckMessage agentConnId meta $ case chatMsgEvent of - XMsgNew (MsgContent MTText [] body) -> newTextMessage c meta $ find (isSimplexContentType XCText) body + XMsgNew (MCText text) -> newTextMessage c meta text XFile fInv -> processFileInvitation ct meta fInv XInfo p -> xInfo ct p XGrpInv gInv -> processGroupInvitation ct gInv @@ -617,7 +618,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do GCInviteeMember -> case chatMsgEvent of XGrpAcpt memId - | memId == memberId m -> do + | sameMemberId memId m -> do withStore $ \st -> updateGroupMemberStatus st userId m GSMemAccepted allowAgentConnection conn confId XOk | otherwise -> messageError "x.grp.acpt: memberId is different from expected" @@ -625,17 +626,17 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do _ -> case chatMsgEvent of XGrpMemInfo memId _memProfile - | memId == memberId m -> do + | sameMemberId memId m -> do -- TODO update member profile Group {membership} <- withStore $ \st -> getGroup st user gName - allowAgentConnection conn confId $ XGrpMemInfo (memberId membership) profile + allowAgentConnection conn confId $ XGrpMemInfo (memberId (membership :: GroupMember)) profile | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" _ -> messageError "CONF from member must have x.grp.mem.info" INFO connInfo -> do ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo case chatMsgEvent of XGrpMemInfo memId _memProfile - | memId == memberId m -> do + | sameMemberId memId m -> do -- TODO update member profile pure () | otherwise -> messageError "x.grp.mem.info: memberId is different from expected" @@ -678,8 +679,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do chatMsgEvent <- saveRcvMSG conn meta msgBody withAckMessage agentConnId meta $ case chatMsgEvent of - XMsgNew (MsgContent MTText [] body) -> - newGroupTextMessage gName m meta $ find (isSimplexContentType XCText) body + XMsgNew (MCText text) -> newGroupTextMessage gName m meta text XFile fInv -> processGroupFileInvitation gName m meta fInv XGrpMemNew memInfo -> xGrpMemNew gName m memInfo XGrpMemIntro memInfo -> xGrpMemIntro conn gName m memInfo @@ -808,7 +808,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do (probe, probeId) <- withStore $ \st -> createSentProbe st gVar userId ct sendDirectMessage (contactConn ct) $ XInfoProbe probe cs <- withStore (\st -> getMatchingContacts st userId ct) - let probeHash = C.sha256Hash probe + let probeHash = ProbeHash $ C.sha256Hash (unProbe probe) forM_ cs $ \c -> sendProbeHash c probeHash probeId `catchError` const (pure ()) where sendProbeHash c probeHash probeId = do @@ -821,23 +821,17 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do messageError :: Text -> m () messageError = showMessageError "error" - newTextMessage :: ContactName -> MsgMeta -> Maybe MsgContentBody -> m () - newTextMessage c meta = \case - Just MsgContentBody {contentData = bs} -> do - let text = safeDecodeUtf8 bs - showReceivedMessage c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta)) - showToast (c <> "> ") text - setActive $ ActiveC c - _ -> messageError "x.msg.new: no expected message body" + newTextMessage :: ContactName -> MsgMeta -> Text -> m () + newTextMessage c meta text = do + showReceivedMessage c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta)) + showToast (c <> "> ") text + setActive $ ActiveC c - newGroupTextMessage :: GroupName -> GroupMember -> MsgMeta -> Maybe MsgContentBody -> m () - newGroupTextMessage gName GroupMember {localDisplayName = c} meta = \case - Just MsgContentBody {contentData = bs} -> do - let text = safeDecodeUtf8 bs - showReceivedGroupMessage gName c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta)) - showToast ("#" <> gName <> " " <> c <> "> ") text - setActive $ ActiveG gName - _ -> messageError "x.msg.new: no expected message body" + newGroupTextMessage :: GroupName -> GroupMember -> MsgMeta -> Text -> m () + newGroupTextMessage gName GroupMember {localDisplayName = c} meta text = do + showReceivedGroupMessage gName c (snd $ broker meta) (msgPlain text) (integrity (meta :: MsgMeta)) + showToast ("#" <> gName <> " " <> c <> "> ") text + setActive $ ActiveG gName processFileInvitation :: Contact -> MsgMeta -> FileInvitation -> m () processFileInvitation contact@Contact {localDisplayName = c} meta fInv = do @@ -855,7 +849,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do setActive $ ActiveG gName processGroupInvitation :: Contact -> GroupInvitation -> m () - processGroupInvitation ct@Contact {localDisplayName} inv@(GroupInvitation (fromMemId, fromRole) (memId, memRole) _ _) = do + processGroupInvitation ct@Contact {localDisplayName} inv@(GroupInvitation (MemberIdRole fromMemId fromRole) (MemberIdRole memId memRole) _ _) = do when (fromRole < GRAdmin || fromRole < memRole) $ chatError (CEGroupContactRole localDisplayName) when (fromMemId == memId) $ chatError CEGroupDuplicateMemberId group <- withStore $ \st -> createGroupInvitation st user ct inv @@ -866,23 +860,23 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do c' <- withStore $ \st -> updateContactProfile st userId c p' showContactUpdated c c' - xInfoProbe :: Contact -> ByteString -> m () + xInfoProbe :: Contact -> Probe -> m () xInfoProbe c2 probe = do r <- withStore $ \st -> matchReceivedProbe st userId c2 probe forM_ r $ \c1 -> probeMatch c1 c2 probe - xInfoProbeCheck :: Contact -> ByteString -> m () + xInfoProbeCheck :: Contact -> ProbeHash -> m () xInfoProbeCheck c1 probeHash = do r <- withStore $ \st -> matchReceivedProbeHash st userId c1 probeHash forM_ r . uncurry $ probeMatch c1 - probeMatch :: Contact -> Contact -> ByteString -> m () + probeMatch :: Contact -> Contact -> Probe -> m () probeMatch c1@Contact {profile = p1} c2@Contact {profile = p2} probe = when (p1 == p2) $ do sendDirectMessage (contactConn c1) $ XInfoProbeOk probe mergeContacts c1 c2 - xInfoProbeOk :: Contact -> ByteString -> m () + xInfoProbeOk :: Contact -> Probe -> m () xInfoProbeOk c1 probe = do r <- withStore $ \st -> matchSentProbe st userId c1 probe forM_ r $ \c2 -> mergeContacts c1 c2 @@ -904,7 +898,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do xGrpMemNew :: GroupName -> GroupMember -> MemberInfo -> m () xGrpMemNew gName m memInfo@(MemberInfo memId _ _) = do group@Group {membership} <- withStore $ \st -> getGroup st user gName - when (memberId membership /= memId) $ + unless (sameMemberId memId membership) $ if isMember memId group then messageError "x.grp.mem.new error: member already exists" else do @@ -932,7 +926,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do case memberCategory m of GCInviteeMember -> do group <- withStore $ \st -> getGroup st user gName - case find ((== memId) . memberId) $ members group of + case find (sameMemberId memId) $ members group of Nothing -> messageError "x.grp.mem.inv error: referenced member does not exists" Just reMember -> do intro <- withStore $ \st -> saveIntroInvitation st reMember m introInv @@ -946,7 +940,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do xGrpMemFwd :: GroupName -> GroupMember -> MemberInfo -> IntroInvitation -> m () xGrpMemFwd gName m memInfo@(MemberInfo memId _ _) introInv@IntroInvitation {groupConnReq, directConnReq} = do group@Group {membership} <- withStore $ \st -> getGroup st user gName - toMember <- case find ((== memId) . memberId) $ members group of + toMember <- case find (sameMemberId memId) $ members group of -- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent -- the situation when member does not exist is an error -- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that. @@ -954,7 +948,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do Nothing -> withStore $ \st -> createNewGroupMember st user group memInfo GCPostMember GSMemAnnounced Just m' -> pure m' withStore $ \st -> saveMemberInvitation st toMember introInv - let msg = XGrpMemInfo (memberId membership) profile + let msg = XGrpMemInfo (memberId (membership :: GroupMember)) profile groupConnId <- withAgent $ \a -> joinConnection a groupConnReq $ directMessage msg directConnId <- withAgent $ \a -> joinConnection a directConnReq $ directMessage msg withStore $ \st -> createIntroToMemberContact st userId m toMember groupConnId directConnId @@ -962,22 +956,25 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do xGrpMemDel :: GroupName -> GroupMember -> MemberId -> m () xGrpMemDel gName m memId = do Group {membership, members} <- withStore $ \st -> getGroup st user gName - if memberId membership == memId + if memberId (membership :: GroupMember) == memId then do mapM_ deleteMemberConnection members withStore $ \st -> updateGroupMemberStatus st userId membership GSMemRemoved showDeletedMemberUser gName m - else case find ((== memId) . memberId) members of + else case find (sameMemberId memId) members of Nothing -> messageError "x.grp.mem.del with unknown member ID" Just member -> do - let mRole = memberRole m - if mRole < GRAdmin || mRole < memberRole member + let mRole = memberRole (m :: GroupMember) + if mRole < GRAdmin || mRole < memberRole (member :: GroupMember) then messageError "x.grp.mem.del with insufficient member permissions" else do deleteMemberConnection member withStore $ \st -> updateGroupMemberStatus st userId member GSMemRemoved showDeletedMember gName (Just m) (Just member) + sameMemberId :: MemberId -> GroupMember -> Bool + sameMemberId memId GroupMember {memberId} = memId == memberId + xGrpLeave :: GroupName -> GroupMember -> m () xGrpLeave gName m = do deleteMemberConnection m @@ -985,8 +982,8 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do showLeftMember gName m xGrpDel :: GroupName -> GroupMember -> m () - xGrpDel gName m = do - when (memberRole m /= GROwner) $ chatError CEGroupUserRole + xGrpDel gName m@GroupMember {memberRole} = do + when (memberRole /= GROwner) $ chatError CEGroupUserRole ms <- withStore $ \st -> do Group {members, membership} <- getGroup st user gName updateGroupMemberStatus st userId membership GSMemGroupDeleted @@ -995,7 +992,7 @@ processAgentMessage user@User {userId, profile} agentConnId agentMessage = do showGroupDeleted gName m parseChatMessage :: ByteString -> Either ChatError ChatMessage -parseChatMessage msgBody = first ChatErrorMessage (parseAll rawChatMessageP msgBody >>= toChatMessage) +parseChatMessage = first ChatErrorMessage . strDecode sendFileChunk :: ChatMonad m => SndFileTransfer -> m () sendFileChunk ft@SndFileTransfer {fileId, fileStatus, agentConnId} = @@ -1105,15 +1102,13 @@ deleteMemberConnection m@GroupMember {activeConn} = do sendDirectMessage :: ChatMonad m => Connection -> ChatMsgEvent -> m () sendDirectMessage conn chatMsgEvent = do let msgBody = directMessage chatMsgEvent - newMsg = NewMessage {direction = MDSnd, chatMsgEventType = toChatEventType chatMsgEvent, msgBody} + newMsg = NewMessage {direction = MDSnd, chatMsgEventType = toChatEventTag chatMsgEvent, msgBody} -- can be done in transaction after sendMessage, probably shouldn't msgId <- withStore $ \st -> createNewMessage st newMsg deliverMessage conn msgBody msgId directMessage :: ChatMsgEvent -> ByteString -directMessage chatMsgEvent = - serializeRawChatMessage $ - rawChatMessage ChatMessage {chatMsgId = Nothing, chatMsgEvent, chatDAG = Nothing} +directMessage chatMsgEvent = strEncode ChatMessage {chatMsgEvent} deliverMessage :: ChatMonad m => Connection -> MsgBody -> MessageId -> m () deliverMessage Connection {connId, agentConnId} msgBody msgId = do @@ -1124,7 +1119,7 @@ deliverMessage Connection {connId, agentConnId} msgBody msgId = do sendGroupMessage :: ChatMonad m => [GroupMember] -> ChatMsgEvent -> m () sendGroupMessage members chatMsgEvent = do let msgBody = directMessage chatMsgEvent - newMsg = NewMessage {direction = MDSnd, chatMsgEventType = toChatEventType chatMsgEvent, msgBody} + newMsg = NewMessage {direction = MDSnd, chatMsgEventType = toChatEventTag chatMsgEvent, msgBody} msgId <- withStore $ \st -> createNewMessage st newMsg -- TODO once scheduled delivery is implemented memberActive should be changed to memberCurrent forM_ (map memberConn $ filter memberActive members) $ @@ -1133,7 +1128,7 @@ sendGroupMessage members chatMsgEvent = do saveRcvMSG :: ChatMonad m => Connection -> MsgMeta -> MsgBody -> m ChatMsgEvent saveRcvMSG Connection {connId} agentMsgMeta msgBody = do ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage msgBody - let newMsg = NewMessage {direction = MDRcv, chatMsgEventType = toChatEventType chatMsgEvent, msgBody} + let newMsg = NewMessage {direction = MDRcv, chatMsgEventType = toChatEventTag chatMsgEvent, msgBody} agentMsgId = fst $ recipient agentMsgMeta rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} withStore $ \st -> createNewMessageAndRcvMsgDelivery st newMsg rcvMsgDelivery @@ -1241,7 +1236,7 @@ chatCommandP = <|> ("/groups" <|> "/gs") $> ListGroups <|> A.char '#' *> (SendGroupMessage <$> displayName <* A.space <*> A.takeByteString) <|> ("/contacts" <|> "/cs") $> ListContacts - <|> ("/connect " <|> "/c ") *> (Connect <$> ((Just <$> connReqP) <|> A.takeByteString $> Nothing)) + <|> ("/connect " <|> "/c ") *> (Connect <$> ((Just <$> strP) <|> A.takeByteString $> Nothing)) <|> ("/connect" <|> "/c") $> AddContact <|> ("/delete @" <|> "/delete " <|> "/d @" <|> "/d ") *> (DeleteContact <$> displayName) <|> A.char '@' *> (SendMessage <$> displayName <*> (A.space *> A.takeByteString)) @@ -1251,7 +1246,7 @@ chatCommandP = <|> ("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal) <|> ("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal) <|> "/admin_welcome " *> (SendAdminWelcome <$> displayName) - <|> "/admin" $> ConnectAdmin + -- <|> "/admin" $> ConnectAdmin <|> ("/address" <|> "/ad") $> CreateMyAddress <|> ("/delete_address" <|> "/da") $> DeleteMyAddress <|> ("/show_address" <|> "/sa") $> ShowMyAddress @@ -1284,6 +1279,6 @@ chatCommandP = <|> (" member" $> GRMember) <|> pure GRAdmin -adminContactReq :: ConnectionRequest 'CMContact -adminContactReq = - either error id $ parseAll connReqP' "https://simplex.chat/contact#/?smp=smp%3A%2F%2Fnxc7HnrnM8dOKgkMp008ub_9o9LXJlxlMrMpR-mfMQw%3D%40smp3.simplex.im%2F-TXnePw5eH5-4L7B%23&e2e=rsa%3AMIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEA6vpcsZggnYL38Qa2G5YU0W5uqnV8WAq_S3flIFU2kx4qW-aokVT8fo0CLJXv9aagdHObFfhc9SXcZPcm4T2NLnafKTgQa_HYFfj764l6cHkbSI-4JBE1gyhtaapsvrDGIdoiGDLgsF3AJVjqs8gavkuTsmw035aWMH-pkpc4qGlEWpNWp1Nn-7O4sdIIQ7yN48jsdCfeIY-BIk3kFR6s4oQOgiOcnir8e3x5tTuRMX1KWSiuzuqLHqgmcI1IqcPJPrBoTQLbXXEMGG1RsvIudxR03jejXXbQvlxXlNNrxwkniEe-P0rApGuCyv2NRMb4n0Wd3ZwewH7X-xtr16XNbQKBgDouGUHD1C55jB-w8W8VJRhFZS2xIYka9gJH1jjCFxHFzgjo69A_sObIamND1pF_JOzj_XCoA1fDICF95XbfS0rq9iS6xvX6M8Muq8QiJsfD5bRt5nh-Y3GK5rAFXS0ZtyOeh07iMLAMJ_EFxBQuKKDRu9_9KAvLL_plU0PuaMH3" +-- adminContactReq :: ConnReqContact +-- adminContactReq = +-- either error id $ parseAll connReqP' "https://simplex.chat/contact#/?smp=smp%3A%2F%2Fnxc7HnrnM8dOKgkMp008ub_9o9LXJlxlMrMpR-mfMQw%3D%40smp3.simplex.im%2F-TXnePw5eH5-4L7B%23&e2e=rsa%3AMIIBoDANBgkqhkiG9w0BAQEFAAOCAY0AMIIBiAKCAQEA6vpcsZggnYL38Qa2G5YU0W5uqnV8WAq_S3flIFU2kx4qW-aokVT8fo0CLJXv9aagdHObFfhc9SXcZPcm4T2NLnafKTgQa_HYFfj764l6cHkbSI-4JBE1gyhtaapsvrDGIdoiGDLgsF3AJVjqs8gavkuTsmw035aWMH-pkpc4qGlEWpNWp1Nn-7O4sdIIQ7yN48jsdCfeIY-BIk3kFR6s4oQOgiOcnir8e3x5tTuRMX1KWSiuzuqLHqgmcI1IqcPJPrBoTQLbXXEMGG1RsvIudxR03jejXXbQvlxXlNNrxwkniEe-P0rApGuCyv2NRMb4n0Wd3ZwewH7X-xtr16XNbQKBgDouGUHD1C55jB-w8W8VJRhFZS2xIYka9gJH1jjCFxHFzgjo69A_sObIamND1pF_JOzj_XCoA1fDICF95XbfS0rq9iS6xvX6M8Muq8QiJsfD5bRt5nh-Y3GK5rAFXS0ZtyOeh07iMLAMJ_EFxBQuKKDRu9_9KAvLL_plU0PuaMH3" diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 7d9b5d0937..b8749283b5 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -78,9 +78,10 @@ data ChatErrorType | CEFileSend Int64 AgentErrorType | CEFileRcvChunk String | CEFileInternal String + | CEAgentVersion deriving (Show, Exception) -type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m) +type ChatMonad m = (MonadUnliftIO m, MonadReader ChatController m, MonadError ChatError m, MonadFail m) setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m () setActive to = asks (activeTo . chatTerminal) >>= atomically . (`writeTVar` to) diff --git a/src/Simplex/Chat/Options.hs b/src/Simplex/Chat/Options.hs index 11eb57132c..d0ffa5b6f8 100644 --- a/src/Simplex/Chat/Options.hs +++ b/src/Simplex/Chat/Options.hs @@ -7,7 +7,8 @@ import qualified Data.ByteString.Char8 as B import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as L import Options.Applicative -import Simplex.Messaging.Agent.Protocol (SMPServer (..), smpServerP) +import Simplex.Messaging.Agent.Protocol (SMPServer (..)) +import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (parseAll) import System.FilePath (combine) @@ -37,8 +38,8 @@ chatOpts appDir = ) <> value ( L.fromList - [ "smp2.simplex.im#z5W2QLQ1Br3Yd6CoWg7bIq1bHdwK7Y8bEiEXBs/WfAg=", -- London, UK - "smp3.simplex.im#nxc7HnrnM8dOKgkMp008ub/9o9LXJlxlMrMpR+mfMQw=" -- Fremont, CA + [ "smp://z5W2QLQ1Br3Yd6CoWg7bIq1bHdwK7Y8bEiEXBs_WfAg=@smp2.simplex.im", -- London, UK + "smp://nxc7HnrnM8dOKgkMp008ub_9o9LXJlxlMrMpR-mfMQw=@smp3.simplex.im" -- Fremont, CA ] ) ) @@ -48,7 +49,7 @@ chatOpts appDir = parseSMPServer :: ReadM (NonEmpty SMPServer) parseSMPServer = eitherReader $ parseAll servers . B.pack where - servers = L.fromList <$> smpServerP `A.sepBy1` A.char ',' + servers = L.fromList <$> strP `A.sepBy1` A.char ',' getChatOpts :: FilePath -> IO ChatOpts getChatOpts appDir = execParser opts diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 5ba840a212..5942f088c1 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -1,35 +1,32 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} module Simplex.Chat.Protocol where -import Control.Applicative (optional) -import Control.Monad ((<=<), (>=>)) -import Data.Aeson (FromJSON, ToJSON) +import Control.Monad ((<=<)) +import Data.Aeson (FromJSON, ToJSON, (.:), (.=)) import qualified Data.Aeson as J -import Data.Attoparsec.ByteString.Char8 (Parser) +import qualified Data.Aeson.Types as JT import qualified Data.Attoparsec.ByteString.Char8 as A -import qualified Data.ByteString.Base64 as B64 -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, findIndex) +import qualified Data.HashMap.Strict as H import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) +import Data.Text.Encoding (decodeLatin1, encodeUtf8) +import GHC.Generics import Simplex.Chat.Types -import Simplex.Chat.Util (safeDecodeUtf8) import Simplex.Messaging.Agent.Protocol -import Simplex.Messaging.Parsers (parseAll) -import Simplex.Messaging.Util (bshow) +import Simplex.Messaging.Encoding.String +import Simplex.Messaging.Util ((<$?>)) data ChatDirection (p :: AParty) where ReceivedDirectMessage :: Connection -> Maybe Contact -> ChatDirection 'Agent @@ -52,6 +49,23 @@ fromConnection = \case RcvFileConnection conn _ -> conn UserContactConnection conn _ -> conn +-- chat message is sent as JSON with these properties +data AppMessage = AppMessage + { event :: Text, + params :: J.Object + } + deriving (Generic, FromJSON) + +instance ToJSON AppMessage where toEncoding = J.genericToEncoding J.defaultOptions + +newtype ChatMessage = ChatMessage {chatMsgEvent :: ChatMsgEvent} + deriving (Eq, Show) + +instance StrEncoding ChatMessage where + strEncode = LB.toStrict . J.encode . chatToAppMessage + strDecode = appToChatMessage <=< J.eitherDecodeStrict' + strP = strDecode <$?> A.takeByteString + data ChatMsgEvent = XMsgNew MsgContent | XFile FileInvitation @@ -70,372 +84,215 @@ data ChatMsgEvent | XGrpMemDel MemberId | XGrpLeave | XGrpDel - | XInfoProbe ByteString - | XInfoProbeCheck ByteString - | XInfoProbeOk ByteString + | XInfoProbe Probe + | XInfoProbeCheck ProbeHash + | XInfoProbeOk Probe | XOk deriving (Eq, Show) -data MessageType = MTText | MTImage deriving (Eq, Show) +data MsgContentType = MCText_ | MCUnknown_ -data MsgContent = MsgContent - { messageType :: MessageType, - files :: [(ContentType, Int)], - content :: [MsgContentBody] - } +instance StrEncoding MsgContentType where + strEncode = \case + MCText_ -> "text" + MCUnknown_ -> "text" + strDecode = \case + "text" -> Right MCText_ + _ -> Right MCUnknown_ + strP = strDecode <$?> A.takeTill (== ' ') + +instance FromJSON MsgContentType where + parseJSON = strParseJSON "MsgContentType" + +instance ToJSON MsgContentType where + toJSON = strToJSON + toEncoding = strToJEncoding + +data MsgContent = MCText Text | MCUnknown deriving (Eq, Show) -toMsgType :: ByteString -> Either String MessageType -toMsgType = \case - "c.text" -> Right MTText - "c.image" -> Right MTImage - t -> Left $ "invalid message type " <> B.unpack t +toMsgContentType :: MsgContent -> MsgContentType +toMsgContentType = \case + MCText _ -> MCText_ + MCUnknown -> MCUnknown_ -rawMsgType :: MessageType -> ByteString -rawMsgType = \case - MTText -> "c.text" - MTImage -> "c.image" +instance FromJSON MsgContent where + parseJSON (J.Object v) = do + v .: "type" >>= \case + MCText_ -> MCText <$> v .: "text" + MCUnknown_ -> pure MCUnknown + parseJSON invalid = + JT.prependFailure "bad MsgContent, " (JT.typeMismatch "Object" invalid) -data ChatMessage = ChatMessage - { chatMsgId :: Maybe Int64, - chatMsgEvent :: ChatMsgEvent, - chatDAG :: Maybe ByteString - } - deriving (Eq, Show) +unknownMsgType :: Text +unknownMsgType = "unknown message type" -toChatEventType :: ChatMsgEvent -> Text -toChatEventType = \case - XMsgNew _ -> "x.msg.new" - XFile _ -> "x.file" - XFileAcpt _ -> "x.file.acpt" - XInfo _ -> "x.info" - XContact _ _ -> "x.con" - XGrpInv _ -> "x.grp.inv" - XGrpAcpt _ -> "x.grp.acpt" - XGrpMemNew _ -> "x.grp.mem.new" - XGrpMemIntro _ -> "x.grp.mem.intro" - XGrpMemInv _ _ -> "x.grp.mem.inv" - XGrpMemFwd _ _ -> "x.grp.mem.fwd" - XGrpMemInfo _ _ -> "x.grp.mem.info" - XGrpMemCon _ -> "x.grp.mem.con" - XGrpMemConAll _ -> "x.grp.mem.con.all" - XGrpMemDel _ -> "x.grp.mem.del" - XGrpLeave -> "x.grp.leave" - XGrpDel -> "x.grp.del" - XInfoProbe _ -> "x.info.probe" - XInfoProbeCheck _ -> "x.info.probe.check" - XInfoProbeOk _ -> "x.info.probe.ok" - XOk -> "x.ok" +instance ToJSON MsgContent where + toJSON mc = + J.object $ + ("type" .= toMsgContentType mc) : case mc of + MCText t -> ["text" .= t] + MCUnknown -> ["text" .= unknownMsgType] + toEncoding mc = + J.pairs $ + ("type" .= toMsgContentType mc) <> case mc of + MCText t -> "text" .= t + MCUnknown -> "text" .= unknownMsgType -toChatMessage :: RawChatMessage -> Either String ChatMessage -toChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} = do - (chatDAG, body) <- getDAG <$> mapM toMsgBodyContent chatMsgBody - let chatMsg msg = pure ChatMessage {chatMsgId, chatMsgEvent = msg, chatDAG} - case (chatMsgEvent, chatMsgParams) of - ("x.msg.new", mt : rawFiles) -> do - t <- toMsgType mt - 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 - 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 - profile <- getJSON body - chatMsg . XGrpInv $ GroupInvitation fromMem invitedMem groupConnReq profile - ("x.grp.acpt", [memId]) -> - chatMsg . XGrpAcpt =<< B64.decode memId - ("x.grp.mem.new", [memId, role]) -> do - chatMsg . XGrpMemNew =<< toMemberInfo memId role body - ("x.grp.mem.intro", [memId, role]) -> - chatMsg . XGrpMemIntro =<< toMemberInfo memId role body - ("x.grp.mem.inv", [memId, groupConnReq, directConnReq]) -> - chatMsg =<< (XGrpMemInv <$> B64.decode memId <*> toIntroInv groupConnReq directConnReq) - ("x.grp.mem.fwd", [memId, role, groupConnReq, directConnReq]) -> do - chatMsg =<< (XGrpMemFwd <$> toMemberInfo memId role body <*> toIntroInv groupConnReq directConnReq) - ("x.grp.mem.info", [memId]) -> - chatMsg =<< (XGrpMemInfo <$> B64.decode memId <*> getJSON body) - ("x.grp.mem.con", [memId]) -> - chatMsg . XGrpMemCon =<< B64.decode memId - ("x.grp.mem.con.all", [memId]) -> - chatMsg . XGrpMemConAll =<< B64.decode memId - ("x.grp.mem.del", [memId]) -> - chatMsg . XGrpMemDel =<< B64.decode memId - ("x.grp.leave", []) -> - chatMsg XGrpLeave - ("x.grp.del", []) -> - chatMsg XGrpDel - ("x.info.probe", [probe]) -> do - chatMsg . XInfoProbe =<< B64.decode probe - ("x.info.probe.check", [probeHash]) -> do - chatMsg . XInfoProbeCheck =<< B64.decode probeHash - ("x.info.probe.ok", [probe]) -> do - chatMsg . XInfoProbeOk =<< B64.decode probe - ("x.ok", []) -> - chatMsg XOk - _ -> Left $ "bad syntax or unsupported event " <> B.unpack chatMsgEvent +data CMEventTag + = XMsgNew_ + | XFile_ + | XFileAcpt_ + | XInfo_ + | XContact_ + | XGrpInv_ + | XGrpAcpt_ + | XGrpMemNew_ + | XGrpMemIntro_ + | XGrpMemInv_ + | XGrpMemFwd_ + | XGrpMemInfo_ + | XGrpMemCon_ + | XGrpMemConAll_ + | XGrpMemDel_ + | XGrpLeave_ + | XGrpDel_ + | XInfoProbe_ + | XInfoProbeCheck_ + | XInfoProbeOk_ + | XOk_ + +instance StrEncoding CMEventTag where + strEncode = \case + XMsgNew_ -> "x.msg.new" + XFile_ -> "x.file" + XFileAcpt_ -> "x.file.acpt" + XInfo_ -> "x.info" + XContact_ -> "x.contact" + XGrpInv_ -> "x.grp.inv" + XGrpAcpt_ -> "x.grp.acpt" + XGrpMemNew_ -> "x.grp.mem.new" + XGrpMemIntro_ -> "x.grp.mem.intro" + XGrpMemInv_ -> "x.grp.mem.inv" + XGrpMemFwd_ -> "x.grp.mem.fwd" + XGrpMemInfo_ -> "x.grp.mem.info" + XGrpMemCon_ -> "x.grp.mem.con" + XGrpMemConAll_ -> "x.grp.mem.con.all" + XGrpMemDel_ -> "x.grp.mem.del" + XGrpLeave_ -> "x.grp.leave" + XGrpDel_ -> "x.grp.del" + XInfoProbe_ -> "x.info.probe" + XInfoProbeCheck_ -> "x.info.probe.check" + XInfoProbeOk_ -> "x.info.probe.ok" + XOk_ -> "x.ok" + strDecode = \case + "x.msg.new" -> Right XMsgNew_ + "x.file" -> Right XFile_ + "x.file.acpt" -> Right XFileAcpt_ + "x.info" -> Right XInfo_ + "x.contact" -> Right XContact_ + "x.grp.inv" -> Right XGrpInv_ + "x.grp.acpt" -> Right XGrpAcpt_ + "x.grp.mem.new" -> Right XGrpMemNew_ + "x.grp.mem.intro" -> Right XGrpMemIntro_ + "x.grp.mem.inv" -> Right XGrpMemInv_ + "x.grp.mem.fwd" -> Right XGrpMemFwd_ + "x.grp.mem.info" -> Right XGrpMemInfo_ + "x.grp.mem.con" -> Right XGrpMemCon_ + "x.grp.mem.con.all" -> Right XGrpMemConAll_ + "x.grp.mem.del" -> Right XGrpMemDel_ + "x.grp.leave" -> Right XGrpLeave_ + "x.grp.del" -> Right XGrpDel_ + "x.info.probe" -> Right XInfoProbe_ + "x.info.probe.check" -> Right XInfoProbeCheck_ + "x.info.probe.ok" -> Right XInfoProbeOk_ + "x.ok" -> Right XOk_ + _ -> Left "bad CMEventTag" + strP = strDecode <$?> A.takeTill (== ' ') + +toCMEventTag :: ChatMsgEvent -> CMEventTag +toCMEventTag = \case + XMsgNew _ -> XMsgNew_ + XFile _ -> XFile_ + XFileAcpt _ -> XFileAcpt_ + XInfo _ -> XInfo_ + XContact _ _ -> XContact_ + XGrpInv _ -> XGrpInv_ + XGrpAcpt _ -> XGrpAcpt_ + XGrpMemNew _ -> XGrpMemNew_ + XGrpMemIntro _ -> XGrpMemIntro_ + XGrpMemInv _ _ -> XGrpMemInv_ + XGrpMemFwd _ _ -> XGrpMemFwd_ + XGrpMemInfo _ _ -> XGrpMemInfo_ + XGrpMemCon _ -> XGrpMemCon_ + XGrpMemConAll _ -> XGrpMemConAll_ + XGrpMemDel _ -> XGrpMemDel_ + XGrpLeave -> XGrpLeave_ + XGrpDel -> XGrpDel_ + XInfoProbe _ -> XInfoProbe_ + XInfoProbeCheck _ -> XInfoProbeCheck_ + XInfoProbeOk _ -> XInfoProbeOk_ + XOk -> XOk_ + +toChatEventTag :: ChatMsgEvent -> Text +toChatEventTag = decodeLatin1 . strEncode . toCMEventTag + +appToChatMessage :: AppMessage -> Either String ChatMessage +appToChatMessage AppMessage {event, params} = do + eventTag <- strDecode $ encodeUtf8 event + chatMsgEvent <- msg eventTag + pure ChatMessage {chatMsgEvent} where - getDAG :: [MsgContentBody] -> (Maybe ByteString, [MsgContentBody]) - getDAG body = case break (isContentType SimplexDAG) body of - (b, MsgContentBody SimplexDAG dag : a) -> (Just dag, b <> a) - _ -> (Nothing, body) - 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 - 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) + p :: FromJSON a => Text -> Either String a + p key = JT.parseEither (.: key) params + msg = \case + XMsgNew_ -> XMsgNew <$> p "content" + XFile_ -> XFile <$> p "file" + XFileAcpt_ -> XFileAcpt <$> p "fileName" + XInfo_ -> XInfo <$> p "profile" + XContact_ -> XContact <$> p "profile" <*> p "content" + XGrpInv_ -> XGrpInv <$> p "groupInvitation" + XGrpAcpt_ -> XGrpAcpt <$> p "memberId" + XGrpMemNew_ -> XGrpMemNew <$> p "memberInfo" + XGrpMemIntro_ -> XGrpMemIntro <$> p "memberInfo" + XGrpMemInv_ -> XGrpMemInv <$> p "memberId" <*> p "memberIntro" + XGrpMemFwd_ -> XGrpMemFwd <$> p "memberInfo" <*> p "memberIntro" + XGrpMemInfo_ -> XGrpMemInfo <$> p "memberId" <*> p "profile" + XGrpMemCon_ -> XGrpMemCon <$> p "memberId" + XGrpMemConAll_ -> XGrpMemConAll <$> p "memberId" + XGrpMemDel_ -> XGrpMemDel <$> p "memberId" + XGrpLeave_ -> pure XGrpLeave + XGrpDel_ -> pure XGrpDel + XInfoProbe_ -> XInfoProbe <$> p "probe" + XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash" + XInfoProbeOk_ -> XInfoProbeOk <$> p "probe" + XOk_ -> pure XOk -isContentType :: ContentType -> MsgContentBody -> Bool -isContentType t MsgContentBody {contentType = t'} = t == t' - -isSimplexContentType :: XContentType -> MsgContentBody -> Bool -isSimplexContentType = isContentType . SimplexContentType - -getContentType :: ContentType -> [MsgContentBody] -> Either String ByteString -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} -> - rawMsg (rawMsgType t : toRawFiles files) content - XFile FileInvitation {fileName, fileSize, fileConnReq} -> - rawMsg [encodeUtf8 $ T.pack fileName, bshow fileSize, serializeConnReq' fileConnReq] [] - XFileAcpt fileName -> - rawMsg [encodeUtf8 $ T.pack fileName] [] - XInfo profile -> - rawMsg [] [jsonBody profile] - XContact profile Nothing -> - rawMsg [] [jsonBody profile] - XContact profile (Just MsgContent {messageType = t, files, content}) -> - rawMsg (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 - ] - in rawMsg params [jsonBody groupProfile] - XGrpAcpt memId -> - rawMsg [B64.encode memId] [] - XGrpMemNew (MemberInfo memId role profile) -> - let params = [B64.encode memId, serializeMemberRole role] - in rawMsg params [jsonBody profile] - XGrpMemIntro (MemberInfo memId role profile) -> - rawMsg [B64.encode memId, serializeMemberRole role] [jsonBody profile] - XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq} -> - let params = [B64.encode memId, serializeConnReq' groupConnReq, serializeConnReq' directConnReq] - in rawMsg params [] - XGrpMemFwd (MemberInfo memId role profile) IntroInvitation {groupConnReq, directConnReq} -> - let params = - [ B64.encode memId, - serializeMemberRole role, - serializeConnReq' groupConnReq, - serializeConnReq' directConnReq - ] - in rawMsg params [jsonBody profile] - XGrpMemInfo memId profile -> - rawMsg [B64.encode memId] [jsonBody profile] - XGrpMemCon memId -> - rawMsg [B64.encode memId] [] - XGrpMemConAll memId -> - rawMsg [B64.encode memId] [] - XGrpMemDel memId -> - rawMsg [B64.encode memId] [] - XGrpLeave -> - rawMsg [] [] - XGrpDel -> - rawMsg [] [] - XInfoProbe probe -> - rawMsg [B64.encode probe] [] - XInfoProbeCheck probeHash -> - rawMsg [B64.encode probeHash] [] - XInfoProbeOk probe -> - rawMsg [B64.encode probe] [] - XOk -> - rawMsg [] [] +chatToAppMessage :: ChatMessage -> AppMessage +chatToAppMessage ChatMessage {chatMsgEvent} = AppMessage {event, params} where - rawMsg :: [ByteString] -> [MsgContentBody] -> RawChatMessage - rawMsg chatMsgParams body = do - let event = encodeUtf8 $ toChatEventType chatMsgEvent - RawChatMessage {chatMsgId, chatMsgEvent = event, chatMsgParams, chatMsgBody = rawWithDAG body} - rawContentInfo :: (ContentType, Int) -> (RawContentType, Int) - rawContentInfo (t, size) = (rawContentType t, size) - jsonBody :: ToJSON a => a -> MsgContentBody - jsonBody x = - let json = LB.toStrict $ J.encode x - in MsgContentBody {contentType = SimplexContentType XCJson, contentData = json} - rawWithDAG :: [MsgContentBody] -> [RawMsgBodyContent] - 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 - cType <- toContentType contentType - pure MsgContentBody {contentType = cType, contentData} - -rawMsgBodyContent :: MsgContentBody -> RawMsgBodyContent -rawMsgBodyContent MsgContentBody {contentType = t, contentData} = - RawMsgBodyContent {contentType = rawContentType t, contentData} - -data MsgContentBody = MsgContentBody - { contentType :: ContentType, - contentData :: ByteString - } - deriving (Eq, Show) - -data ContentType - = SimplexContentType XContentType - | MimeContentType MContentType - | SimplexDAG - deriving (Eq, Show) - -data XContentType = XCText | XCImage | XCJson deriving (Eq, Show) - -data MContentType = MCImageJPG | MCImagePNG deriving (Eq, Show) - -toContentType :: RawContentType -> Either String ContentType -toContentType (RawContentType ns cType) = case ns of - "x" -> case cType of - "text" -> Right $ SimplexContentType XCText - "image" -> Right $ SimplexContentType XCImage - "json" -> Right $ SimplexContentType XCJson - "dag" -> Right SimplexDAG - _ -> err - "m" -> case cType of - "image/jpg" -> Right $ MimeContentType MCImageJPG - "image/png" -> Right $ MimeContentType MCImagePNG - _ -> err - _ -> err - where - err = Left . B.unpack $ "invalid content type " <> ns <> "." <> cType - -rawContentType :: ContentType -> RawContentType -rawContentType t = case t of - SimplexContentType t' -> RawContentType "x" $ case t' of - XCText -> "text" - XCImage -> "image" - XCJson -> "json" - MimeContentType t' -> RawContentType "m" $ case t' of - MCImageJPG -> "image/jpg" - MCImagePNG -> "image/png" - SimplexDAG -> RawContentType "x" "dag" - -newtype ContentMsg = NewContentMsg ContentData - -newtype ContentData = ContentText Text - -data RawChatMessage = RawChatMessage - { chatMsgId :: Maybe Int64, - chatMsgEvent :: ByteString, - chatMsgParams :: [ByteString], - chatMsgBody :: [RawMsgBodyContent] - } - deriving (Eq, Show) - -data RawMsgBodyContent = RawMsgBodyContent - { contentType :: RawContentType, - contentData :: ByteString - } - deriving (Eq, Show) - -data RawContentType = RawContentType NameSpace ByteString - deriving (Eq, Show) - -type NameSpace = ByteString - -newtype MsgData = MsgData ByteString - deriving (Eq, Show) - -class DataLength a where - dataLength :: a -> Int - -rawChatMessageP :: Parser RawChatMessage -rawChatMessageP = do - chatMsgId <- optional A.decimal <* A.space - chatMsgEvent <- B.intercalate "." <$> identifierP `A.sepBy1'` A.char '.' <* A.space - chatMsgParams <- A.takeWhile1 (not . A.inClass ", ") `A.sepBy'` A.char ',' <* A.space - chatMsgBody <- msgBodyContent =<< contentInfoP `A.sepBy'` A.char ',' <* A.space - pure RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} - where - msgBodyContent :: [(RawContentType, Int)] -> Parser [RawMsgBodyContent] - msgBodyContent [] = pure [] - msgBodyContent ((contentType, size) : ps) = do - contentData <- A.take size <* A.space - ((RawMsgBodyContent {contentType, contentData}) :) <$> msgBodyContent ps - -contentInfoP :: Parser (RawContentType, Int) -contentInfoP = do - contentType <- RawContentType <$> identifierP <* A.char '.' <*> A.takeTill (A.inClass ":, ") - size <- A.char ':' *> A.decimal - pure (contentType, size) - -identifierP :: Parser ByteString -identifierP = B.cons <$> A.letter_ascii <*> A.takeWhile (\c -> A.isAlpha_ascii c || A.isDigit c) - -serializeRawChatMessage :: RawChatMessage -> ByteString -serializeRawChatMessage RawChatMessage {chatMsgId, chatMsgEvent, chatMsgParams, chatMsgBody} = - B.unwords - [ maybe "" bshow chatMsgId, - chatMsgEvent, - B.intercalate "," chatMsgParams, - B.unwords $ map serializeBodyContentInfo chatMsgBody, - B.unwords $ map msgContentData chatMsgBody - ] - -serializeBodyContentInfo :: RawMsgBodyContent -> ByteString -serializeBodyContentInfo RawMsgBodyContent {contentType = t, contentData} = - serializeContentInfo (t, B.length contentData) - -serializeContentInfo :: (RawContentType, Int) -> ByteString -serializeContentInfo (RawContentType ns cType, size) = ns <> "." <> cType <> ":" <> bshow size - -msgContentData :: RawMsgBodyContent -> ByteString -msgContentData RawMsgBodyContent {contentData} = contentData <> " " + event = toChatEventTag chatMsgEvent + o :: [(Text, J.Value)] -> J.Object + o = H.fromList + params = case chatMsgEvent of + XMsgNew content -> o ["content" .= content] + XFile fileInv -> o ["file" .= fileInv] + XFileAcpt fileName -> o ["fileName" .= fileName] + XInfo profile -> o ["profile" .= profile] + XContact profile content -> o ["profile" .= profile, "content" .= content] + XGrpInv groupInv -> o ["groupInvitation" .= groupInv] + XGrpAcpt memId -> o ["memberId" .= memId] + XGrpMemNew memInfo -> o ["memberInfo" .= memInfo] + XGrpMemIntro memInfo -> o ["memberInfo" .= memInfo] + XGrpMemInv memId memIntro -> o ["memberId" .= memId, "memberIntro" .= memIntro] + XGrpMemFwd memInfo memIntro -> o ["memberInfo" .= memInfo, "memberIntro" .= memIntro] + XGrpMemInfo memId profile -> o ["memberId" .= memId, "profile" .= profile] + XGrpMemCon memId -> o ["memberId" .= memId] + XGrpMemConAll memId -> o ["memberId" .= memId] + XGrpMemDel memId -> o ["memberId" .= memId] + XGrpLeave -> H.empty + XGrpDel -> H.empty + XInfoProbe probe -> o ["probe" .= probe] + XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash] + XInfoProbeOk probe -> o ["probe" .= probe] + XOk -> H.empty diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index bc4a493bc9..484b6e3d61 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -667,20 +667,20 @@ getMatchingContacts st userId Contact {contactId, profile = Profile {displayName ] rights <$> mapM (runExceptT . getContact_ db userId) contactNames -createSentProbe :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> UserId -> Contact -> m (ByteString, Int64) +createSentProbe :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> UserId -> Contact -> m (Probe, Int64) createSentProbe st gVar userId _to@Contact {contactId} = liftIOEither . withTransaction st $ \db -> createWithRandomBytes 32 gVar $ \probe -> do DB.execute db "INSERT INTO sent_probes (contact_id, probe, user_id) VALUES (?,?,?)" (contactId, probe, userId) - (probe,) <$> insertedRowId db + (Probe probe,) <$> insertedRowId db createSentProbeHash :: MonadUnliftIO m => SQLiteStore -> UserId -> Int64 -> Contact -> m () createSentProbeHash st userId probeId _to@Contact {contactId} = liftIO . withTransaction st $ \db -> DB.execute db "INSERT INTO sent_probe_hashes (sent_probe_id, contact_id, user_id) VALUES (?,?,?)" (probeId, contactId, userId) -matchReceivedProbe :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> ByteString -> m (Maybe Contact) -matchReceivedProbe st userId _from@Contact {contactId} probe = +matchReceivedProbe :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> Probe -> m (Maybe Contact) +matchReceivedProbe st userId _from@Contact {contactId} (Probe probe) = liftIO . withTransaction st $ \db -> do let probeHash = C.sha256Hash probe contactNames <- @@ -701,8 +701,8 @@ matchReceivedProbe st userId _from@Contact {contactId} probe = either (const Nothing) Just <$> runExceptT (getContact_ db userId cName) -matchReceivedProbeHash :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> ByteString -> m (Maybe (Contact, ByteString)) -matchReceivedProbeHash st userId _from@Contact {contactId} probeHash = +matchReceivedProbeHash :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> ProbeHash -> m (Maybe (Contact, Probe)) +matchReceivedProbeHash st userId _from@Contact {contactId} (ProbeHash probeHash) = liftIO . withTransaction st $ \db -> do namesAndProbes <- DB.query @@ -718,11 +718,11 @@ matchReceivedProbeHash st userId _from@Contact {contactId} probeHash = case namesAndProbes of [] -> pure Nothing (cName, probe) : _ -> - either (const Nothing) (Just . (,probe)) + either (const Nothing) (Just . (,Probe probe)) <$> runExceptT (getContact_ db userId cName) -matchSentProbe :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> ByteString -> m (Maybe Contact) -matchSentProbe st userId _from@Contact {contactId} probe = +matchSentProbe :: MonadUnliftIO m => SQLiteStore -> UserId -> Contact -> Probe -> m (Maybe Contact) +matchSentProbe st userId _from@Contact {contactId} (Probe probe) = liftIO . withTransaction st $ \db -> do contactNames <- map fromOnly @@ -889,7 +889,7 @@ createNewGroup st gVar user groupProfile = DB.execute db "INSERT INTO groups (local_display_name, user_id, group_profile_id) VALUES (?, ?, ?)" (displayName, uId, profileId) groupId <- insertedRowId db memberId <- randomBytes gVar 12 - membership <- createContactMember_ db user groupId user (memberId, GROwner) GCUserMember GSMemCreator IBUser + membership <- createContactMember_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser pure $ Right Group {groupId, localDisplayName = displayName, groupProfile, members = [], membership} -- | creates a new group record for the group the current user was invited to, or returns an existing one @@ -1022,7 +1022,7 @@ getGroupInvitation st user localDisplayName = findFromContact (IBContact contactId) = find ((== Just contactId) . memberContactId) findFromContact _ = const Nothing -type GroupMemberRow = (Int64, Int64, ByteString, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Maybe Int64, ContactName, Maybe Int64, ContactName, Text) +type GroupMemberRow = (Int64, Int64, MemberId, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Maybe Int64, ContactName, Maybe Int64, ContactName, Text) toGroupMember :: Int64 -> GroupMemberRow -> GroupMember toGroupMember userContactId (groupMemberId, groupId, memberId, memberRole, memberCategory, memberStatus, invitedById, localDisplayName, memberContactId, displayName, fullName) = @@ -1035,7 +1035,7 @@ createContactMember :: StoreMonad m => SQLiteStore -> TVar ChaChaDRG -> User -> createContactMember st gVar user groupId contact memberRole agentConnId connRequest = liftIOEither . withTransaction st $ \db -> createWithRandomId gVar $ \memId -> do - member@GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact (memId, memberRole) GCInviteeMember GSMemInvited IBUser (Just connRequest) + member@GroupMember {groupMemberId} <- createContactMemberInv_ db user groupId contact (MemberIdRole (MemberId memId) memberRole) GCInviteeMember GSMemInvited IBUser (Just connRequest) void $ createMemberConnection_ db (userId user) groupMemberId agentConnId Nothing 0 pure member @@ -1269,12 +1269,12 @@ createIntroToMemberContact st userId GroupMember {memberContactId = viaContactId createMemberConnection_ :: DB.Connection -> UserId -> Int64 -> ConnId -> Maybe Int64 -> Int -> IO Connection 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 groupId userOrContact (memberId, memberRole) memberCategory memberStatus invitedBy = - createContactMemberInv_ db user groupId userOrContact (memberId, memberRole) memberCategory memberStatus invitedBy Nothing +createContactMember_ :: IsContact a => DB.Connection -> User -> Int64 -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> IO GroupMember +createContactMember_ db user groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy = + createContactMemberInv_ db user groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy Nothing -createContactMemberInv_ :: IsContact a => DB.Connection -> User -> Int64 -> a -> (MemberId, GroupMemberRole) -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe ConnReqInvitation -> IO GroupMember -createContactMemberInv_ db User {userId, userContactId} groupId userOrContact (memberId, memberRole) memberCategory memberStatus invitedBy connRequest = do +createContactMemberInv_ :: IsContact a => DB.Connection -> User -> Int64 -> a -> MemberIdRole -> GroupMemberCategory -> GroupMemberStatus -> InvitedBy -> Maybe ConnReqInvitation -> IO GroupMember +createContactMemberInv_ db User {userId, userContactId} groupId userOrContact MemberIdRole {memberId, memberRole} memberCategory memberStatus invitedBy connRequest = do insertMember_ groupMemberId <- insertedRowId db let memberProfile = profile' userOrContact diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 88343c421b..3bb540132c 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} @@ -11,8 +12,10 @@ module Simplex.Chat.Types where -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON, ToJSON, (.:), (.=)) import qualified Data.Aeson as J +import qualified Data.Aeson.Types as JT +import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B @@ -29,9 +32,11 @@ 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 (AgentMsgId, ConnId, ConnectionMode (..), ConnectionRequest, InvitationId, MsgMeta (..), serializeMsgIntegrity) +import Simplex.Messaging.Agent.Protocol (AgentMsgId, ConnId, ConnectionMode (..), ConnectionRequestUri, InvitationId, MsgMeta (..), serializeMsgIntegrity) import Simplex.Messaging.Agent.Store.SQLite (fromTextField_) +import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (MsgBody) +import Simplex.Messaging.Util ((<$?>)) class IsContact a where contactId' :: a -> Int64 @@ -106,41 +111,56 @@ data Profile = Profile { displayName :: ContactName, fullName :: Text } - deriving (Generic, Eq, Show) + deriving (Eq, Show, Generic, FromJSON) instance ToJSON Profile where toEncoding = J.genericToEncoding J.defaultOptions -instance FromJSON Profile - data GroupProfile = GroupProfile { displayName :: GroupName, fullName :: Text } - deriving (Generic, Eq, Show) + deriving (Eq, Show, Generic, FromJSON) instance ToJSON GroupProfile where toEncoding = J.genericToEncoding J.defaultOptions -instance FromJSON GroupProfile - data GroupInvitation = GroupInvitation - { fromMember :: (MemberId, GroupMemberRole), - invitedMember :: (MemberId, GroupMemberRole), + { fromMember :: MemberIdRole, + invitedMember :: MemberIdRole, connRequest :: ConnReqInvitation, groupProfile :: GroupProfile } - deriving (Eq, Show) + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON GroupInvitation where toEncoding = J.genericToEncoding J.defaultOptions + +data MemberIdRole = MemberIdRole + { memberId :: MemberId, + memberRole :: GroupMemberRole + } + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON MemberIdRole where toEncoding = J.genericToEncoding J.defaultOptions data IntroInvitation = IntroInvitation { groupConnReq :: ConnReqInvitation, directConnReq :: ConnReqInvitation } - deriving (Eq, Show) + deriving (Eq, Show, Generic, FromJSON) -data MemberInfo = MemberInfo MemberId GroupMemberRole Profile - deriving (Eq, Show) +instance ToJSON IntroInvitation where toEncoding = J.genericToEncoding J.defaultOptions + +data MemberInfo = MemberInfo + { memberId :: MemberId, + memberRole :: GroupMemberRole, + profile :: Profile + } + deriving (Eq, Show, Generic, FromJSON) + +instance ToJSON MemberInfo where toEncoding = J.genericToEncoding J.defaultOptions memberInfo :: GroupMember -> MemberInfo -memberInfo m = MemberInfo (memberId m) (memberRole m) (memberProfile m) +memberInfo GroupMember {memberId, memberRole, memberProfile} = + MemberInfo memberId memberRole memberProfile data ReceivedGroupInvitation = ReceivedGroupInvitation { fromMember :: GroupMember, @@ -183,7 +203,24 @@ data NewGroupMember = NewGroupMember memContactId :: Maybe Int64 } -type MemberId = ByteString +newtype MemberId = MemberId {unMemberId :: ByteString} + deriving (Eq, Show) + +instance FromField MemberId where fromField f = MemberId <$> fromField f + +instance ToField MemberId where toField (MemberId m) = toField m + +instance StrEncoding MemberId where + strEncode (MemberId m) = strEncode m + strDecode s = MemberId <$> strDecode s + strP = MemberId <$> strP + +instance FromJSON MemberId where + parseJSON = strParseJSON "MemberId" + +instance ToJSON MemberId where + toJSON = strToJSON + toEncoding = strToJEncoding data InvitedBy = IBContact Int64 | IBUser | IBUnknown deriving (Eq, Show) @@ -203,22 +240,28 @@ fromInvitedBy userCtId = \case data GroupMemberRole = GRMember | GRAdmin | GROwner deriving (Eq, Show, Ord) -instance FromField GroupMemberRole where fromField = fromBlobField_ toMemberRole +instance FromField GroupMemberRole where fromField = fromBlobField_ strDecode -instance ToField GroupMemberRole where toField = toField . serializeMemberRole +instance ToField GroupMemberRole where toField = toField . strEncode -toMemberRole :: ByteString -> Either String GroupMemberRole -toMemberRole = \case - "owner" -> Right GROwner - "admin" -> Right GRAdmin - "member" -> Right GRMember - r -> Left $ "invalid group member role " <> B.unpack r +instance StrEncoding GroupMemberRole where + strEncode = \case + GROwner -> "owner" + GRAdmin -> "admin" + GRMember -> "member" + strDecode = \case + "owner" -> Right GROwner + "admin" -> Right GRAdmin + "member" -> Right GRMember + r -> Left $ "bad GroupMemberRole " <> B.unpack r + strP = strDecode <$?> A.takeByteString -serializeMemberRole :: GroupMemberRole -> ByteString -serializeMemberRole = \case - GROwner -> "owner" - GRAdmin -> "admin" - GRMember -> "member" +instance FromJSON GroupMemberRole where + parseJSON = strParseJSON "GroupMemberRole" + +instance ToJSON GroupMemberRole where + toJSON = strToJSON + toEncoding = strToJEncoding fromBlobField_ :: Typeable k => (ByteString -> Either String k) -> FieldParser k fromBlobField_ p = \case @@ -228,6 +271,36 @@ fromBlobField_ p = \case Left e -> returnError ConversionFailed f ("could not parse field: " ++ e) f -> returnError ConversionFailed f "expecting SQLBlob column type" +newtype Probe = Probe {unProbe :: ByteString} + deriving (Eq, Show) + +instance StrEncoding Probe where + strEncode (Probe p) = strEncode p + strDecode s = Probe <$> strDecode s + strP = Probe <$> strP + +instance FromJSON Probe where + parseJSON = strParseJSON "Probe" + +instance ToJSON Probe where + toJSON = strToJSON + toEncoding = strToJEncoding + +newtype ProbeHash = ProbeHash {unProbeHash :: ByteString} + deriving (Eq, Show) + +instance StrEncoding ProbeHash where + strEncode (ProbeHash p) = strEncode p + strDecode s = ProbeHash <$> strDecode s + strP = ProbeHash <$> strP + +instance FromJSON ProbeHash where + parseJSON = strParseJSON "ProbeHash" + +instance ToJSON ProbeHash where + toJSON = strToJSON + toEncoding = strToJEncoding + data GroupMemberCategory = GCUserMember | GCInviteeMember -- member invited by the user @@ -350,7 +423,24 @@ data FileInvitation = FileInvitation fileSize :: Integer, fileConnReq :: ConnReqInvitation } - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +instance FromJSON FileInvitation where + parseJSON (J.Object v) = FileInvitation <$> v .: "fileName" <*> v .: "fileSize" <*> v .: "fileConnReq" + parseJSON invalid = JT.prependFailure "bad FileInvitation, " (JT.typeMismatch "Object" invalid) + +instance ToJSON FileInvitation where + toJSON (FileInvitation fileName fileSize fileConnReq) = + J.object + [ "fileName" .= fileName, + "fileSize" .= fileSize, + "fileConnReq" .= fileConnReq + ] + toEncoding (FileInvitation fileName fileSize fileConnReq) = + J.pairs $ + "fileName" .= fileName + <> "fileSize" .= fileSize + <> "fileConnReq" .= fileConnReq data RcvFileTransfer = RcvFileTransfer { fileId :: Int64, @@ -404,9 +494,9 @@ serializeFileStatus = \case data RcvChunkStatus = RcvChunkOk | RcvChunkFinal | RcvChunkDuplicate | RcvChunkError deriving (Eq, Show) -type ConnReqInvitation = ConnectionRequest 'CMInvitation +type ConnReqInvitation = ConnectionRequestUri 'CMInvitation -type ConnReqContact = ConnectionRequest 'CMContact +type ConnReqContact = ConnectionRequestUri 'CMContact data Connection = Connection { connId :: Int64, @@ -592,7 +682,7 @@ data RcvMsgDelivery = RcvMsgDelivery agentMsgMeta :: MsgMeta } -data MsgMetaJ = MsgMetaJ +data MsgMetaJSON = MsgMetaJSON { integrity :: Text, rcvId :: Int64, rcvTs :: UTCTime, @@ -600,15 +690,13 @@ data MsgMetaJ = MsgMetaJ serverTs :: UTCTime, sndId :: Int64 } - deriving (Generic, Eq, Show) + deriving (Eq, Show, FromJSON, Generic) -instance ToJSON MsgMetaJ where toEncoding = J.genericToEncoding J.defaultOptions +instance ToJSON MsgMetaJSON where toEncoding = J.genericToEncoding J.defaultOptions -instance FromJSON MsgMetaJ - -msgMetaToJson :: MsgMeta -> MsgMetaJ -msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId, serverTs), sender = (sndId, _)} = - MsgMetaJ +msgMetaToJson :: MsgMeta -> MsgMetaJSON +msgMetaToJson MsgMeta {integrity, recipient = (rcvId, rcvTs), broker = (serverId, serverTs), sndMsgId = sndId} = + MsgMetaJSON { integrity = (decodeLatin1 . serializeMsgIntegrity) integrity, rcvId, rcvTs, diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index fa2220f82f..8e5378b34d 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} @@ -102,6 +103,7 @@ import Simplex.Chat.Terminal (printToTerminal) import Simplex.Chat.Types import Simplex.Chat.Util (safeDecodeUtf8) import Simplex.Messaging.Agent.Protocol +import Simplex.Messaging.Encoding.String import qualified Simplex.Messaging.Protocol as SMP import System.Console.ANSI.Types @@ -328,7 +330,7 @@ connReqInvitation_ :: ConnReqInvitation -> [StyledString] connReqInvitation_ cReq = [ "pass this invitation link to your contact (via another channel): ", "", - (plain . serializeConnReq') cReq, + (plain . strEncode) cReq, "", "and ask them to connect: " <> highlight' "/c " ] @@ -380,7 +382,7 @@ connReqContact_ :: StyledString -> ConnReqContact -> [StyledString] connReqContact_ intro cReq = [ intro, "", - (plain . serializeConnReq') cReq, + (plain . strEncode) cReq, "", "Anybody can send you contact requests with: " <> highlight' "/c ", "to show it again: " <> highlight' "/sa", @@ -444,7 +446,7 @@ cannotResendInvitation g c = receivedGroupInvitation :: Group -> ContactName -> GroupMemberRole -> [StyledString] receivedGroupInvitation g@Group {localDisplayName} c role = - [ ttyFullGroup g <> ": " <> ttyContact c <> " invites you to join the group as " <> plain (serializeMemberRole role), + [ ttyFullGroup g <> ": " <> ttyContact c <> " invites you to join the group as " <> plain (strEncode role), "use " <> highlight ("/j " <> localDisplayName) <> " to accept" ] @@ -492,7 +494,7 @@ groupMembers Group {membership, members} = map groupMember . filter (not . remov where removedOrLeft m = let s = memberStatus m in s == GSMemRemoved || s == GSMemLeft groupMember m = ttyFullMember m <> ": " <> role m <> ", " <> category m <> status m - role = plain . serializeMemberRole . memberRole + role m = plain . strEncode $ memberRole (m :: GroupMember) category m = case memberCategory m of GCUserMember -> "you, " GCInviteeMember -> "invited, " @@ -753,6 +755,7 @@ chatError = \case CEFileSend fileId e -> ["error sending file " <> sShow fileId <> ": " <> sShow e] CEFileRcvChunk e -> ["error receiving file: " <> plain e] CEFileInternal e -> ["file error: " <> plain e] + CEAgentVersion -> ["unsupported agent version"] -- e -> ["chat error: " <> sShow e] ChatErrorStore err -> case err of SEDuplicateName -> ["this display name is already used by user, contact or group"] diff --git a/src/Simplex/Chat/protocol.md b/src/Simplex/Chat/protocol.md index 111319c593..33161a45a7 100644 --- a/src/Simplex/Chat/protocol.md +++ b/src/Simplex/Chat/protocol.md @@ -22,9 +22,6 @@ The syntax of the message inside agent MSG: ```abnf agentMessageBody = [chatMsgId] SP msgEvent SP [parameters] SP [contentParts [SP msgBodyParts]] chatMsgId = 1*DIGIT ; used to refer to previous message; - ; in the group should only be used in messages sent to all members, - ; which is the main reason not to use external agent ID - - ; some messages are sent only to one member msgEvent = protocolNamespace 1*("." msgTypeName) protocolNamespace = 1*ALPHA ; "x" for all events defined in the protocol msgTypeName = 1*ALPHA @@ -68,6 +65,219 @@ refMsgHash = 16*16(OCTET) ; SHA256 of agent message body ' x.file name,size x.text:NNN ' ``` +Chat message JTD: + +```jsonc +{ + "properties": { + "msgId": {"type": "string"}, + "minVersion": {"type": "uint16"}, // Word16 + "maxVersion": {"type": "uint16"}, // Word16 + "event": {"type": "string"}, // Text e.g. s.ok + "params": {"values": {}}, // Map Text Value + }, + "optionalProperties": { + "dag": {"type": "string"} + } +} +``` + +Events: + +```jsonc +"event": "x.msg.new" // XMsgNew +"params": // MsgContent +{ + "content": { + "msgType": "text", + // field "files" can be represented in content as contentType "file" with length prepended or as complex contentData + "text": "" + } + // "content": [ + // free form contentType for extensibility and/or complex content types? e.g. MIME + // could it be useful if contentData was free form as well? currently it is ByteString + // {"contentType": , "contentData": ""}, + // ... + // {"contentType": , "contentData": ""} + // ] +} + +"event": "x.file" // XFile; TODO rename into x.file.inv? +"params": // FileInvitation +{ + "file": { + "fileName": "", + "fileSize": , // integer + "fileConnReq": "" + } +} + +"event": "x.file.acpt" // XFileAcpt +"params": // String +{ + "fileName": "" +} + +"event": "x.info" // XInfo +"params": // Profile +{ + "profile": { + "displayName": "", + "fullName": "" + } +} + +"event": "x.contact" // XContact +"params": // Profile (Maybe MsgContent) +{ + "profile": { + "displayName": "", + "fullName": "" + }, + "content": { + "msgType": "text", + "text": "" + } // optional +} + +"event": "x.grp.inv" // XGrpInv +"params": // GroupInvitation +{ + "groupInvitation": { + "fromMember": { + "memberId": "", + "memberRole": "" + }, + "invitedMember": { + "memberId": "", + "memberRole": "" + }, + "connRequest": "", + "groupProfile": { + "displayName": "", + "fullName": "" + } + } +} + +"event": "x.grp.acpt" // XGrpAcpt +"params": // MemberId +{ + "memberId": "" +} + +"event": "x.grp.mem.new" // XGrpMemNew +"params": // MemberInfo +{ + "memberInfo": { + "memberId": "", + "memberRole": "", + "profile": { + "displayName": "", + "fullName": "" + } + } +} + +"event": "x.grp.mem.intro" // XGrpMemIntro +"params": // MemberInfo +{ + "memberInfo": { + "memberId": "", + "memberRole": "", + "profile": { + "displayName": "", + "fullName": "" + } + } +} + +"event": "x.grp.mem.inv" // XGrpMemInv +"params": // MemberId IntroInvitation +{ + "memberId": "", + "memberIntro": { + "groupConnReq": "", + "directConnReq": "" + } +} + +"event": "x.grp.mem.fwd" // XGrpMemFwd +"params": // MemberInfo IntroInvitation +{ + "memberInfo": { + "memberId": "", + "memberRole": "", + "profile": { + "displayName": "", + "fullName": "" + }, + }, + "memberIntro": { + "groupConnReq": "", + "directConnReq": "" + } +} + +"event": "x.grp.mem.info" // XGrpMemInfo +"params": // MemberId Profile +{ + "memberId": "", + "profile": { + "displayName": "", + "fullName": "" + } +} + +"event": "x.grp.mem.con" // XGrpMemCon +"params": // MemberId +{ + "memberId": "" +} + +"event": "x.grp.mem.con.all" // XGrpMemConAll +"params": // MemberId +{ + "memberId": "" +} + +"event": "x.grp.mem.del" // XGrpMemDel +"params": // MemberId +{ + "memberId": "" +} + +"event": "x.grp.leave" // XGrpLeave +"params": +{} + +"event": "x.grp.del" // XGrpDel +"params": +{} + +"event": "x.info.probe" // XInfoProbe +"params": // ByteString +{ + "probe": "" +} + +"event": "x.info.probe.check" // XInfoProbeCheck +"params": // ByteString +{ + "probeHash": "" +} + +"event": "x.info.probe.ok" // XInfoProbeOk +"params": // ByteString +{ + "probe": "" +} + +"event": "x.ok" // XOk +"params": +{} +``` + ### Group protocol #### Add group member diff --git a/stack.yaml b/stack.yaml index 36cc708824..0792aaf082 100644 --- a/stack.yaml +++ b/stack.yaml @@ -38,10 +38,15 @@ extra-deps: - cryptostore-0.2.1.0@sha256:9896e2984f36a1c8790f057fd5ce3da4cbcaf8aa73eb2d9277916886978c5b19,3881 - simple-logger-0.1.0@sha256:be8ede4bd251a9cac776533bae7fb643369ebd826eb948a9a18df1a8dd252ff8,1079 - terminal-0.2.0.0@sha256:de6770ecaae3197c66ac1f0db5a80cf5a5b1d3b64a66a05b50f442de5ad39570,2977 - - simplexmq-0.5.2@sha256:3544e479f353c1bbc6aa9405ef6976b78364f437d8af9cc45b9e0b228429e240,7884 + # - simplexmq-0.5.2@sha256:3544e479f353c1bbc6aa9405ef6976b78364f437d8af9cc45b9e0b228429e240,7884 # - ../simplexmq - # - github: simplex-chat/simplexmq - # commit: f15067cf6891bda3216c6cf6d2e3ecdba9b7269e + - github: simplex-chat/simplexmq + commit: 40d91e8fad499c9e3fb4317b6bcd93037b2bf1cd + - github: simplex-chat/hs-tls + commit: cea6d52c512716ff09adcac86ebc95bb0b3bb797 + subdirs: + - core + # # extra-deps: [] diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index c268ddbc32..19504a5e5c 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -39,7 +39,7 @@ opts :: ChatOpts opts = ChatOpts { dbFile = undefined, - smpServers = ["localhost:5001"] + smpServers = ["smp://9VjLsOY5ZvB4hoglNdBzJFAUi_vP4GkZnJFahQOXV20=@localhost:5001"] } termSettings :: VirtualTerminalSettings @@ -66,7 +66,7 @@ cfg :: ChatConfig cfg = defaultChatConfig { agentConfig = - aCfg {retryInterval = (retryInterval aCfg) {initialInterval = 50000}} + aCfg {reconnectInterval = (reconnectInterval aCfg) {initialInterval = 50000}} } virtualSimplexChat :: FilePath -> Profile -> IO TestCC @@ -143,44 +143,16 @@ concurrentlyN_ = mapConcurrently_ id serverCfg :: ServerConfig serverCfg = ServerConfig - { transports = [(serverPort, transport @TCP)], + { transports = [(serverPort, transport @TLS)], tbqSize = 1, serverTbqSize = 1, msgQueueQuota = 4, queueIdBytes = 12, msgIdBytes = 6, storeLog = Nothing, - blockSize = 4096, - serverPrivateKey = - -- full RSA private key (only for tests) - "MIIFIwIBAAKCAQEArZyrri/NAwt5buvYjwu+B/MQeJUszDBpRgVqNddlI9kNwDXu\ - \kaJ8chEhrtaUgXeSWGooWwqjXEUQE6RVbCC6QVo9VEBSP4xFwVVd9Fj7OsgfcXXh\ - \AqWxfctDcBZQ5jTUiJpdBc+Vz2ZkumVNl0W+j9kWm9nfkMLQj8c0cVSDxz4OKpZb\ - \qFuj0uzHkis7e7wsrKSKWLPg3M5ZXPZM1m9qn7SfJzDRDfJifamxWI7uz9XK2+Dp\ - \NkUQlGQgFJEv1cKN88JAwIqZ1s+TAQMQiB+4QZ2aNfSqGEzRJN7FMCKRK7pM0A9A\ - \PCnijyuImvKFxTdk8Bx1q+XNJzsY6fBrLWJZ+QKBgQCySG4tzlcEm+tOVWRcwrWh\ - \6zsczGZp9mbf9c8itRx6dlldSYuDG1qnddL70wuAZF2AgS1JZgvcRZECoZRoWP5q\ - \Kq2wvpTIYjFPpC39lxgUoA/DXKVKZZdan+gwaVPAPT54my1CS32VrOiAY4gVJ3LJ\ - \Mn1/FqZXUFQA326pau3loQKCAQEAoljmJMp88EZoy3HlHUbOjl5UEhzzVsU1TnQi\ - \QmPm+aWRe2qelhjW4aTvSVE5mAUJsN6UWTeMf4uvM69Z9I5pfw2pEm8x4+GxRibY\ - \iiwF2QNaLxxmzEHm1zQQPTgb39o8mgklhzFPill0JsnL3f6IkVwjFJofWSmpqEGs\ - \dFSMRSXUTVXh1p/o7QZrhpwO/475iWKVS7o48N/0Xp513re3aXw+DRNuVnFEaBIe\ - \TLvWM9Czn16ndAu1HYiTBuMvtRbAWnGZxU8ewzF4wlWK5tdIL5PTJDd1VhZJAKtB\ - \npDvJpwxzKmjAhcTmjx0ckMIWtdVaOVm/2gWCXDty2FEdg7koQKBgQDOUUguJ/i7\ - \q0jldWYRnVkotKnpInPdcEaodrehfOqYEHnvro9xlS6OeAS4Vz5AdH45zQ/4J3bV\ - \2cH66tNr18ebM9nL//t5G69i89R9W7szyUxCI3LmAIdi3oSEbmz5GQBaw4l6h9Wi\ - \n4FmFQaAXZrjQfO2qJcAHvWRsMp2pmqAGwKBgQDXaza0DRsKWywWznsHcmHa0cx8\ - \I4jxqGaQmLO7wBJRP1NSFrywy1QfYrVX9CTLBK4V3F0PCgZ01Qv94751CzN43TgF\ - \ebd/O9r5NjNTnOXzdWqETbCffLGd6kLgCMwPQWpM9ySVjXHWCGZsRAnF2F6M1O32\ - \43StIifvwJQFqSM3ewKBgCaW6y7sRY90Ua7283RErezd9EyT22BWlDlACrPu3FNC\ - \LtBf1j43uxBWBQrMLsHe2GtTV0xt9m0MfwZsm2gSsXcm4Xi4DJgfN+Z7rIlyy9UY\ - \PCDSdZiU1qSr+NrffDrXlfiAM1cUmCdUX7eKjp/ltkUHNaOGfSn5Pdr3MkAiD/Hf\ - \AoGBAKIdKCuOwuYlwjS9J+IRGuSSM4o+OxQdwGmcJDTCpyWb5dEk68e7xKIna3zf\ - \jc+H+QdMXv1nkRK9bZgYheXczsXaNZUSTwpxaEldzVD3hNvsXSgJRy9fqHwA4PBq\ - \vqiBHoO3RNbqg+2rmTMfDuXreME3S955ZiPZm4Z+T8Hj52mPAoGAQm5QH/gLFtY5\ - \+znqU/0G8V6BKISCQMxbbmTQVcTgGySrP2gVd+e4MWvUttaZykhWqs8rpr7mgpIY\ - \hul7Swx0SHFN3WpXu8uj+B6MLpRcCbDHO65qU4kQLs+IaXXsuuTjMvJ5LwjkZVrQ\ - \TmKzSAw7iVWwEUZR/PeiEKazqrpp9VU=" + caCertificateFile = "tests/fixtures/tls/ca.crt", + privateKeyFile = "tests/fixtures/tls/server.key", + certificateFile = "tests/fixtures/tls/server.crt" } withSmpServer :: IO a -> IO a diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 3a7b5d0902..7b95a01135 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -1,47 +1,44 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE OverloadedLists #-} +-- {-# LANGUAGE OverloadedStrings #-} module ProtocolTests where -import Data.ByteString.Char8 (ByteString) -import Simplex.Chat.Protocol -import Simplex.Messaging.Parsers (parseAll) -import Test.Hspec +-- import Data.ByteString.Char8 (ByteString) +-- import Simplex.Chat.Protocol.Legacy +-- import Simplex.Messaging.Parsers (parseAll) +-- import Test.Hspec -protocolTests :: Spec -protocolTests = do - parseChatMessageTest +-- protocolTests :: Spec +-- protocolTests = do +-- parseChatMessageTest -(#==) :: ByteString -> RawChatMessage -> Expectation -s #== msg = parseAll rawChatMessageP s `shouldBe` Right msg +-- (#==) :: ByteString -> RawChatMessage -> Expectation +-- s #== msg = parseAll rawChatMessageP s `shouldBe` Right msg -parseChatMessageTest :: Spec -parseChatMessageTest = describe "Raw chat message format" $ do - it "no parameters and content" $ - "5 x.grp.mem.leave " #== RawChatMessage (Just 5) "x.grp.mem.leave" [] [] - it "one parameter, no content" $ - "6 x.msg.del 3 " #== RawChatMessage (Just 6) "x.msg.del" ["3"] [] - it "with content that fits the message" $ - "7 x.msg.new c.text x.text:11 hello there " - #== RawChatMessage - (Just 7) - "x.msg.new" - ["c.text"] - [RawMsgBodyContent (RawContentType "x" "text") "hello there"] - it "with DAG reference and partial content" $ - "8 x.msg.new c.image x.dag:16,x.text:7,m.image/jpg:6 0123456789012345 picture abcdef " - #== RawChatMessage - (Just 8) - "x.msg.new" - ["c.image"] - [ RawMsgBodyContent (RawContentType "x" "dag") "0123456789012345", - RawMsgBodyContent (RawContentType "x" "text") "picture", - RawMsgBodyContent (RawContentType "m" "image/jpg") "abcdef" - ] - it "without message id" $ - " x.grp.mem.inv 23456,123 x.json:46 {\"contactRef\":\"john\",\"displayName\":\"John Doe\"} " - #== RawChatMessage - Nothing - "x.grp.mem.inv" - ["23456", "123"] - [RawMsgBodyContent (RawContentType "x" "json") "{\"contactRef\":\"john\",\"displayName\":\"John Doe\"}"] +-- parseChatMessageTest :: Spec +-- parseChatMessageTest = describe "Raw chat message format" $ do +-- it "no parameters and content" $ +-- "5 x.grp.mem.leave " #== RawChatMessage "x.grp.mem.leave" [] [] +-- it "one parameter, no content" $ +-- "6 x.msg.del 3 " #== RawChatMessage "x.msg.del" ["3"] [] +-- it "with content that fits the message" $ +-- "7 x.msg.new c.text x.text:11 hello there " +-- #== RawChatMessage +-- "x.msg.new" +-- ["c.text"] +-- [RawMsgBodyContent (RawContentType "x" "text") "hello there"] +-- it "with DAG reference and partial content" $ +-- "8 x.msg.new c.image x.dag:16,x.text:7,m.image/jpg:6 0123456789012345 picture abcdef " +-- #== RawChatMessage +-- "x.msg.new" +-- ["c.image"] +-- [ RawMsgBodyContent (RawContentType "x" "dag") "0123456789012345", +-- RawMsgBodyContent (RawContentType "x" "text") "picture", +-- RawMsgBodyContent (RawContentType "m" "image/jpg") "abcdef" +-- ] +-- it "without message id" $ +-- " x.grp.mem.inv 23456,123 x.json:46 {\"contactRef\":\"john\",\"displayName\":\"John Doe\"} " +-- #== RawChatMessage +-- "x.grp.mem.inv" +-- ["23456", "123"] +-- [RawMsgBodyContent (RawContentType "x" "json") "{\"contactRef\":\"john\",\"displayName\":\"John Doe\"}"] diff --git a/tests/Test.hs b/tests/Test.hs index 961475ab38..06ff523c7a 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,11 +1,11 @@ import ChatClient import ChatTests import MarkdownTests -import ProtocolTests +-- import ProtocolTests import Test.Hspec main :: IO () main = withSmpServer . hspec $ do describe "SimpleX chat markdown" markdownTests - describe "SimpleX chat protocol" protocolTests + -- describe "SimpleX chat protocol" protocolTests describe "SimpleX chat client" chatTests diff --git a/tests/fixtures/tls/.gitignore b/tests/fixtures/tls/.gitignore new file mode 100644 index 0000000000..e988acd1be --- /dev/null +++ b/tests/fixtures/tls/.gitignore @@ -0,0 +1 @@ +server.csr diff --git a/tests/fixtures/tls/README.md b/tests/fixtures/tls/README.md new file mode 100644 index 0000000000..9e12802a60 --- /dev/null +++ b/tests/fixtures/tls/README.md @@ -0,0 +1,26 @@ +To generate fixtures: + +(keep these instructions and *openssl.cnf* consistent with certificate generation on server) + +```sh +# CA certificate (identity/offline) +openssl genpkey -algorithm ED448 -out ca.key +openssl req -new -x509 -days 999999 -config openssl.cnf -extensions v3_ca -key ca.key -out ca.crt +# server certificate (online) +openssl genpkey -algorithm ED448 -out server.key +openssl req -new -config openssl.cnf -reqexts v3_req -key server.key -out server.csr +openssl x509 -req -days 999999 -extfile openssl.cnf -extensions v3_req -in server.csr -CA ca.crt -CAkey ca.key -CAcreateserial -out server.crt +# to pretty-print +openssl x509 -in ca.crt -text -noout +openssl req -in server.csr -text -noout +openssl x509 -in server.crt -text -noout +``` + +To compute fingerprint for tests: + +```haskell +stack ghci +> import Data.X509.Validation (Fingerprint (..)) +> Fingerprint fp <- loadFingerprint "tests/fixtures/ca.crt" +> strEncode fp +``` diff --git a/tests/fixtures/tls/ca.crt b/tests/fixtures/tls/ca.crt new file mode 100644 index 0000000000..290d8f32dd --- /dev/null +++ b/tests/fixtures/tls/ca.crt @@ -0,0 +1,11 @@ +-----BEGIN CERTIFICATE----- +MIIBijCCAQqgAwIBAgIUf/txCk9PXE4nY2gQ/B/HG2sNzmswBQYDK2VxMBQxEjAQ +BgNVBAMMCWxvY2FsaG9zdDAgFw0yMTEyMjMxNzEzMjNaGA80NzU5MTExOTE3MTMy +M1owFDESMBAGA1UEAwwJbG9jYWxob3N0MEMwBQYDK2VxAzoAXlJkn15EFUS21zLI +I+HSKlhvt88LSXK70KkN4JRRLrXPaTYfpSchFZWmSuLmx5m6rmSg5Ywj9d2Ao1Mw +UTAdBgNVHQ4EFgQUxJBTkCx02jIpcUKU4fJYcnce59QwHwYDVR0jBBgwFoAUxJBT +kCx02jIpcUKU4fJYcnce59QwDwYDVR0TAQH/BAUwAwEB/zAFBgMrZXEDcwDlxmpY +U7j3CIVnMKAGA1rqML5lvKrDTS6DidTiq90dkMTyoXv8AE4omdiGobMnB3HZPl+B +CpdDUYCfQfkNdi8Hqj3V9viqcgahbn5mGnjUAK1+Ix6r7KLm2zeKcfGEG008ykGW +TMUFDvkQqRIlFDdOPAA= +-----END CERTIFICATE----- diff --git a/tests/fixtures/tls/ca.key b/tests/fixtures/tls/ca.key new file mode 100644 index 0000000000..ca14015e04 --- /dev/null +++ b/tests/fixtures/tls/ca.key @@ -0,0 +1,4 @@ +-----BEGIN PRIVATE KEY----- +MEcCAQAwBQYDK2VxBDsEOZvjURTKSor4A7+45hnY721WD06L3E4UMKh9zntEY83C +CCv1Jju2fffDmtIFl6EXytF/nyEPGQfS5A== +-----END PRIVATE KEY----- diff --git a/tests/fixtures/tls/openssl.cnf b/tests/fixtures/tls/openssl.cnf new file mode 100644 index 0000000000..ab53446066 --- /dev/null +++ b/tests/fixtures/tls/openssl.cnf @@ -0,0 +1,16 @@ +[req] +distinguished_name = req_distinguished_name +prompt = no + +[req_distinguished_name] +CN = localhost + +[v3_ca] +subjectKeyIdentifier = hash +authorityKeyIdentifier = keyid:always +basicConstraints = critical,CA:true + +[v3_req] +basicConstraints = CA:FALSE +keyUsage = digitalSignature, nonRepudiation, keyAgreement +extendedKeyUsage = serverAuth diff --git a/tests/fixtures/tls/server.crt b/tests/fixtures/tls/server.crt new file mode 100644 index 0000000000..2c01c21838 --- /dev/null +++ b/tests/fixtures/tls/server.crt @@ -0,0 +1,11 @@ +-----BEGIN CERTIFICATE----- +MIIBpjCCASagAwIBAgIUZVFfBPmSQ+hPioDvatGcRuwcKhgwBQYDK2VxMBQxEjAQ +BgNVBAMMCWxvY2FsaG9zdDAgFw0yMjAxMDMxNjI1MDhaGA80NzU5MTEzMDE2MjUw +OFowFDESMBAGA1UEAwwJbG9jYWxob3N0MEMwBQYDK2VxAzoA/q7ngl2MOKDeHVgC +4aNgO4+pOQ7cfHJhgVTKz0W6CCK9Ce39B0N+cRy6/dPzGCSSOYNKyGE0rnWAo28w +bTAJBgNVHRMEAjAAMAsGA1UdDwQEAwIDyDATBgNVHSUEDDAKBggrBgEFBQcDATAd +BgNVHQ4EFgQUQP8dENbwDxWZNX2QwauT1Ple6aswHwYDVR0jBBgwFoAUxJBTkCx0 +2jIpcUKU4fJYcnce59QwBQYDK2VxA3MAyQKimFiGGPR+vHHo2PVh5hHG9QSJn+34 +b36oGP4ekP/JFA0P3ZS7Kt7mLx2Lm8WmB31Ah1xJu1SA79LpArfum4QLn9GvOIyt +K4Ox/bUdYRvnWqFF8msQAWetO2tt0ZUar7zI7ac3uHBdKAzLFDw1fjgA +-----END CERTIFICATE----- diff --git a/tests/fixtures/tls/server.key b/tests/fixtures/tls/server.key new file mode 100644 index 0000000000..579ac813c8 --- /dev/null +++ b/tests/fixtures/tls/server.key @@ -0,0 +1,4 @@ +-----BEGIN PRIVATE KEY----- +MEcCAQAwBQYDK2VxBDsEOQANqfrmSygKW1iiDCgf/G/y2AH1lp5NurM3Q73fp9Aw +nznRFYq6BvM03cMOkqtFpQd15A+DZr248A== +-----END PRIVATE KEY-----