From 20d253ea359aff5b7382afb42bd6c5369302af2c Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Tue, 3 May 2022 10:22:35 +0100 Subject: [PATCH] core: webrtc calls API implementation (#593) * core: webrtc calls API implementation * process call messages, send events to the UI --- src/Simplex/Chat.hs | 207 ++++++++++++++++++++++++++++++--- src/Simplex/Chat/Call.hs | 20 ++++ src/Simplex/Chat/Controller.hs | 8 +- src/Simplex/Chat/Messages.hs | 6 +- src/Simplex/Chat/Store.hs | 30 +++-- src/Simplex/Chat/View.hs | 4 + 6 files changed, 246 insertions(+), 29 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 721c0f0add..3a7f790174 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -40,6 +40,7 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.LocalTime (getCurrentTimeZone, getZonedTime) import Data.Word (Word32) +import Simplex.Chat.Call import Simplex.Chat.Controller import Simplex.Chat.Markdown import Simplex.Chat.Messages @@ -389,12 +390,75 @@ processChatCommand = \case `E.finally` deleteContactRequest st userId connReqId withAgent $ \a -> rejectContact a connId invId pure $ CRContactRequestRejected cReq - APISendCallInvitation _contactId _callType -> pure $ chatCmdError "not implemented" - APIRejectCall _contactId -> pure $ chatCmdError "not implemented" - APISendCallOffer _contactId _wCallOffer -> pure $ chatCmdError "not implemented" - APISendCallAnswer _contactId _rtcSession -> pure $ chatCmdError "not implemented" - APISendCallExtraInfo _contactId _rtcExtraInfo -> pure $ chatCmdError "not implemented" - APIEndCall _contactId -> pure $ chatCmdError "not implemented" + APISendCallInvitation contactId callType@CallType {capabilities = CallCapabilities {encryption}} -> withUser $ \user@User {userId} -> do + -- party initiating call + ct <- withStore $ \st -> getContact st userId contactId + call <- asks currentCall + withChatLock $ + readTVarIO call >>= \case + Just _ -> throwChatError CEHasCurrentCall + _ -> do + callId <- CallId <$> (asks idsDrg >>= liftIO . (`randomBytes` 16)) + dhKeyPair <- if encryption then Just <$> liftIO C.generateKeyPair' else pure Nothing + let invitation = CallInvitation {callType, callDhPubKey = fst <$> dhKeyPair} + callState = CallInvitationSent {localCallType = callType, localDhPrivKey = snd <$> dhKeyPair} + msg <- sendDirectContactMessage ct (XCallInv callId invitation) + ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndCall CISCallPending 0) Nothing Nothing + atomically . writeTVar call $ Just Call {contactId, callId, chatItemId = chatItemId' ci, callState} + toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci + pure CRCmdOk + APIRejectCall contactId -> + -- party accepting call + withCurrentCall contactId $ \userId ct Call {chatItemId, callState} -> case callState of + CallInvitationReceived {} -> do + updCi <- withStore $ \st -> updateDirectChatItemNoMsg st userId contactId chatItemId (CIRcvCall CISCallRejected 0) + toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) updCi + pure Nothing + _ -> throwChatError . CECallState $ callStateTag callState + APISendCallOffer contactId WebRTCCallOffer {callType, rtcSession} -> + -- party accepting call + withCurrentCall contactId $ \userId ct call@Call {callId, chatItemId, callState} -> case callState of + CallInvitationReceived {peerCallType, localDhPubKey, sharedKey} -> do + -- TODO check that call type matches peerCallType + let offer = CallOffer {callType, rtcSession, callDhPubKey = localDhPubKey} + callState' = CallOfferSent {localCallType = callType, peerCallType, localCallSession = rtcSession, sharedKey} + SndMessage {msgId} <- sendDirectContactMessage ct (XCallOffer callId offer) + updCi <- withStore $ \st -> updateDirectChatItem st userId contactId chatItemId (CIRcvCall CISCallAccepted 0) msgId + toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) updCi + pure $ Just call {callState = callState'} + _ -> throwChatError . CECallState $ callStateTag callState + APISendCallAnswer contactId rtcSession -> + -- party initiating call + withCurrentCall contactId $ \userId ct call@Call {callId, chatItemId, callState} -> case callState of + CallOfferReceived {localCallType, peerCallType, peerCallSession, sharedKey} -> do + SndMessage {msgId} <- sendDirectContactMessage ct (XCallAnswer callId CallAnswer {rtcSession}) + updCi <- withStore $ \st -> updateDirectChatItem st userId contactId chatItemId (CISndCall CISCallNegotiated 0) msgId + toView . CRChatItemUpdated $ AChatItem SCTDirect SMDSnd (DirectChat ct) updCi + let callState' = CallNegotiated {localCallType, peerCallType, localCallSession = rtcSession, peerCallSession, sharedKey} + pure $ Just call {callState = callState'} + _ -> throwChatError . CECallState $ callStateTag callState + APISendCallExtraInfo contactId rtcExtraInfo -> + -- any call party + withCurrentCall contactId $ \_ ct call@Call {callId, callState} -> case callState of + CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} -> do + -- TODO update the list of ice servers + _ <- sendDirectContactMessage ct (XCallExtra callId CallExtraInfo {rtcExtraInfo}) + let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} + pure $ Just call {callState = callState'} + _ -> throwChatError . CECallState $ callStateTag callState + APIEndCall contactId -> + -- any call party + withCurrentCall contactId $ \userId ct Call {callId, chatItemId} -> do + SndMessage {msgId} <- sendDirectContactMessage ct (XCallEnd callId) + CChatItem msgDir _ <- withStore $ \st -> getDirectChatItem st userId contactId chatItemId + let aciContent = case msgDir of + SMDSnd -> ACIContent SMDSnd $ CISndCall CISCallEnded 0 + SMDRcv -> ACIContent SMDRcv $ CIRcvCall CISCallEnded 0 + case aciContent of + ACIContent msgDir' ciContent -> do + updCi <- withStore $ \st -> updateDirectChatItem st userId contactId chatItemId ciContent msgId + toView . CRChatItemUpdated $ AChatItem SCTDirect msgDir' (DirectChat ct) updCi + pure Nothing APIUpdateProfile profile -> withUser (`updateProfile` profile) APIParseMarkdown text -> pure . CRApiParsedMarkdown $ parseMaybeMarkdownList text APIRegisterToken token -> CRNtfTokenStatus <$> withUser (\_ -> withAgent (`registerNtfToken` token)) @@ -693,6 +757,19 @@ processChatCommand = \case withStore $ \st -> do updateFileCancelled st userId fileId updateCIFileStatus st userId fileId ciFileStatus + withCurrentCall :: Int64 -> (UserId -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse + withCurrentCall ctId action = withUser $ \User {userId} -> do + ct <- withStore $ \st -> getContact st userId ctId + callVar <- asks currentCall + withChatLock $ + readTVarIO callVar >>= \case + Nothing -> throwChatError CENoCurrentCall + Just call@Call {contactId} + | ctId == contactId -> do + call_ <- action userId ct call + atomically $ writeTVar callVar call_ + pure CRCmdOk + | otherwise -> throwChatError $ CECallContact contactId -- mobile clients use file paths relative to app directory (e.g. for the reason ios app directory changes on updates), -- so we have to differentiate between the file path stored in db and communicated with frontend, and the file path @@ -947,6 +1024,11 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage XInfoProbe probe -> xInfoProbe ct probe XInfoProbeCheck probeHash -> xInfoProbeCheck ct probeHash XInfoProbeOk probe -> xInfoProbeOk ct probe + XCallInv callId invitation -> xCallInv ct callId invitation msg msgMeta + XCallOffer callId offer -> xCallOffer ct callId offer msg msgMeta + XCallAnswer callId answer -> xCallAnswer ct callId answer msg msgMeta + XCallExtra callId extraInfo -> xCallExtra ct callId extraInfo msg msgMeta + XCallEnd callId -> xCallEnd ct callId msg msgMeta _ -> pure () ackMsgDeliveryEvent conn msgMeta CONF confId connInfo -> do @@ -1260,12 +1342,12 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> m () newContentMessage ct@Contact {localDisplayName = c} mc msg msgMeta = do + checkIntegrity msgMeta $ toView . CRMsgIntegrityError let (ExtMsgContent content fileInvitation_) = mcExtMsgContent mc ciFile_ <- processFileInvitation fileInvitation_ $ \fi chSize -> withStore $ \st -> createRcvFileTransfer st userId ct fi chSize ci@ChatItem {formattedText} <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvMsgContent content) ciFile_ toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci - checkIntegrity msgMeta $ toView . CRMsgIntegrityError showMsgToast (c <> "> ") content formattedText setActive $ ActiveC c @@ -1280,28 +1362,24 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> m () messageUpdate ct@Contact {contactId} sharedMsgId mc RcvMessage {msgId} msgMeta = do + checkIntegrity msgMeta $ toView . CRMsgIntegrityError CChatItem msgDir ChatItem {meta = CIMeta {itemId}} <- withStore $ \st -> getDirectChatItemBySharedMsgId st userId contactId sharedMsgId case msgDir of SMDRcv -> do updCi <- withStore $ \st -> updateDirectChatItem st userId contactId itemId (CIRcvMsgContent mc) msgId toView . CRChatItemUpdated $ AChatItem SCTDirect SMDRcv (DirectChat ct) updCi - checkIntegrity msgMeta $ toView . CRMsgIntegrityError - SMDSnd -> do - messageError "x.msg.update: contact attempted invalid message update" - checkIntegrity msgMeta $ toView . CRMsgIntegrityError + SMDSnd -> messageError "x.msg.update: contact attempted invalid message update" messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> m () messageDelete ct@Contact {contactId} sharedMsgId RcvMessage {msgId} msgMeta = do + checkIntegrity msgMeta $ toView . CRMsgIntegrityError CChatItem msgDir deletedItem@ChatItem {meta = CIMeta {itemId}} <- withStore $ \st -> getDirectChatItemBySharedMsgId st userId contactId sharedMsgId case msgDir of SMDRcv -> do -- TODO allow to locally delete items that were broadcast deleted by sender toCi <- withStore $ \st -> deleteDirectChatItemRcvBroadcast st userId ct itemId msgId toView $ CRChatItemDeleted (AChatItem SCTDirect SMDRcv (DirectChat ct) deletedItem) toCi - checkIntegrity msgMeta $ toView . CRMsgIntegrityError - SMDSnd -> do - messageError "x.msg.del: contact attempted invalid message delete" - checkIntegrity msgMeta $ toView . CRMsgIntegrityError + SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete" newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m () newGroupContentMessage gInfo m@GroupMember {localDisplayName = c} mc msg msgMeta = do @@ -1341,13 +1419,13 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage -- TODO remove once XFile is discontinued processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> m () processFileInvitation' ct@Contact {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg msgMeta = do + checkIntegrity msgMeta $ toView . CRMsgIntegrityError -- TODO chunk size has to be sent as part of invitation chSize <- asks $ fileChunkSize . config RcvFileTransfer {fileId} <- withStore $ \st -> createRcvFileTransfer st userId ct fInv chSize let ciFile = Just $ CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation} ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvMsgContent $ MCFile "") ciFile toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci - checkIntegrity msgMeta $ toView . CRMsgIntegrityError showToast (c <> "> ") "wants to send a file" setActive $ ActiveC c @@ -1401,8 +1479,8 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage groupMsgToView :: GroupInfo -> ChatItem 'CTGroup 'MDRcv -> MsgMeta -> m () groupMsgToView gInfo ci msgMeta = do - toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci checkIntegrity msgMeta $ toView . CRMsgIntegrityError + toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci processGroupInvitation :: Contact -> GroupInvitation -> m () processGroupInvitation ct@Contact {localDisplayName = c} inv@(GroupInvitation (MemberIdRole fromMemId fromRole) (MemberIdRole memId memRole) _ _) = do @@ -1443,6 +1521,101 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage r <- withStore $ \st -> matchSentProbe st userId c1 probe forM_ r $ \c2 -> mergeContacts c1 c2 + -- to party accepting call + xCallInv :: Contact -> CallId -> CallInvitation -> RcvMessage -> MsgMeta -> m () + xCallInv ct@Contact {contactId} callId CallInvitation {callType, callDhPubKey} msg msgMeta = do + checkIntegrity msgMeta $ toView . CRMsgIntegrityError + let CallType {capabilities = CallCapabilities {encryption}} = callType + call <- asks currentCall + ci <- + readTVarIO call >>= \case + Just _ -> saveCallItem CISCallMissed + -- showMsgToast (c <> "> ") content formattedText + -- setActive $ ActiveC c + _ -> do + ci <- saveCallItem CISCallPending + dhKeyPair <- if encryption then Just <$> liftIO C.generateKeyPair' else pure Nothing + let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> (snd <$> dhKeyPair)) + callState = CallInvitationReceived {peerCallType = callType, localDhPubKey = fst <$> dhKeyPair, sharedKey} + toView $ CRCallInvitation ct callType sharedKey + atomically . writeTVar call $ Just Call {contactId, callId, chatItemId = chatItemId' ci, callState} + pure ci + toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci + where + saveCallItem status = saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvCall status 0) Nothing + + -- to party initiating call + xCallOffer :: Contact -> CallId -> CallOffer -> RcvMessage -> MsgMeta -> m () + xCallOffer ct callId CallOffer {callType, rtcSession, callDhPubKey} msg msgMeta = do + msgCurrentCall ct callId "x.call.offer" msg msgMeta $ + \call -> case callState call of + CallInvitationSent {localCallType, localDhPrivKey} -> do + let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> localDhPrivKey) + callState' = CallOfferReceived {localCallType, peerCallType = callType, peerCallSession = rtcSession, sharedKey} + -- TODO decide if should askConfirmation + toView CRCallOffer {contact = ct, callType, offer = rtcSession, sharedKey, askConfirmation = False} + pure (Just call {callState = callState'}, Just . ACIContent SMDSnd $ CISndCall CISCallAccepted 0) + _ -> do + msgCallStateError "x.call.offer" call + pure (Just call, Nothing) + + -- to party accepting call + xCallAnswer :: Contact -> CallId -> CallAnswer -> RcvMessage -> MsgMeta -> m () + xCallAnswer ct callId CallAnswer {rtcSession} msg msgMeta = do + msgCurrentCall ct callId "x.call.answer" msg msgMeta $ + \call -> case callState call of + CallOfferSent {localCallType, peerCallType, localCallSession, sharedKey} -> do + let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession = rtcSession, sharedKey} + toView $ CRCallAnswer ct rtcSession + pure (Just call {callState = callState'}, Just . ACIContent SMDRcv $ CIRcvCall CISCallNegotiated 0) + _ -> do + msgCallStateError "x.call.answer" call + pure (Just call, Nothing) + + -- to any call party + xCallExtra :: Contact -> CallId -> CallExtraInfo -> RcvMessage -> MsgMeta -> m () + xCallExtra ct callId CallExtraInfo {rtcExtraInfo} msg msgMeta = do + msgCurrentCall ct callId "x.call.extra" msg msgMeta $ + \call -> case callState call of + CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} -> do + -- TODO update the list of ice servers + let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} + toView $ CRCallExtraInfo ct rtcExtraInfo + pure (Just call {callState = callState'}, Nothing) + _ -> do + msgCallStateError "x.call.answer" call + pure (Just call, Nothing) + + -- to any call party + xCallEnd :: Contact -> CallId -> RcvMessage -> MsgMeta -> m () + xCallEnd ct@Contact {contactId} callId msg msgMeta = do + msgCurrentCall ct callId "x.call.end" msg msgMeta $ + \Call {chatItemId} -> do + toView $ CRCallEnded ct + CChatItem msgDir _ <- withStore $ \st -> getDirectChatItem st userId contactId chatItemId + pure $ case msgDir of + SMDSnd -> (Nothing, Just . ACIContent SMDSnd $ CISndCall CISCallEnded 0) + SMDRcv -> (Nothing, Just . ACIContent SMDRcv $ CIRcvCall CISCallEnded 0) + + msgCurrentCall :: Contact -> CallId -> Text -> RcvMessage -> MsgMeta -> (Call -> m (Maybe Call, Maybe ACIContent)) -> m () + msgCurrentCall ct@Contact {contactId = ctId'} callId' eventName RcvMessage {msgId} msgMeta action = do + checkIntegrity msgMeta $ toView . CRMsgIntegrityError + callVar <- asks currentCall + readTVarIO callVar >>= \case + Nothing -> messageError $ eventName <> ": no current call" + Just call@Call {contactId, callId, chatItemId} + | contactId /= ctId' || callId /= callId' -> messageError $ eventName <> ": wrong contact or callId" + | otherwise -> do + (call', aciContent_) <- action call + atomically $ writeTVar callVar call' + forM_ aciContent_ $ \(ACIContent msgDir ciContent) -> do + updCi <- withStore $ \st -> updateDirectChatItem st userId contactId chatItemId ciContent msgId + toView . CRChatItemUpdated $ AChatItem SCTDirect msgDir (DirectChat ct) updCi + + msgCallStateError :: Text -> Call -> m () + msgCallStateError eventName Call {callState} = + messageError $ eventName <> ": wrong call state " <> T.pack (show $ callStateTag callState) + mergeContacts :: Contact -> Contact -> m () mergeContacts to from = do withStore $ \st -> mergeContactRecords st userId to from diff --git a/src/Simplex/Chat/Call.hs b/src/Simplex/Chat/Call.hs index 9461ff505f..4559cf1e6e 100644 --- a/src/Simplex/Chat/Call.hs +++ b/src/Simplex/Chat/Call.hs @@ -23,6 +23,26 @@ data Call = Call callState :: CallState } +data CallStateTag + = CSTCallInvitationSent + | CSTCallInvitationReceived + | CSTCallOfferSent + | CSTCallOfferReceived + | CSTCallNegotiated + deriving (Show, Generic) + +instance ToJSON CallStateTag where + toJSON = J.genericToJSON . enumJSON $ dropPrefix "CSTCall" + toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CSTCall" + +callStateTag :: CallState -> CallStateTag +callStateTag = \case + CallInvitationSent {} -> CSTCallInvitationSent + CallInvitationReceived {} -> CSTCallInvitationReceived + CallOfferSent {} -> CSTCallOfferSent + CallOfferReceived {} -> CSTCallOfferReceived + CallNegotiated {} -> CSTCallNegotiated + data CallState = CallInvitationSent { localCallType :: CallType, diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 1339256d1d..89a2228f27 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -248,8 +248,8 @@ data ChatResponse | CRPendingSubSummary {pendingSubStatus :: [PendingSubStatus]} | CRSndFileSubError {sndFileTransfer :: SndFileTransfer, chatError :: ChatError} | CRRcvFileSubError {rcvFileTransfer :: RcvFileTransfer, chatError :: ChatError} - | CRCallInvitation {contact :: Contact, callType :: CallType, encryptionKey :: Maybe C.Key} - | CRCallOffer {contact :: Contact, callType :: CallType, offer :: WebRTCSession, encryptionKey :: Maybe C.Key, askConfirmation :: Bool} + | CRCallInvitation {contact :: Contact, callType :: CallType, sharedKey :: Maybe C.Key} + | CRCallOffer {contact :: Contact, callType :: CallType, offer :: WebRTCSession, sharedKey :: Maybe C.Key, askConfirmation :: Bool} | CRCallAnswer {contact :: Contact, answer :: WebRTCSession} | CRCallExtraInfo {contact :: Contact, extraInfo :: WebRTCExtraInfo} | CRCallEnded {contact :: Contact} @@ -336,6 +336,10 @@ data ChatErrorType | CEInvalidQuote | CEInvalidChatItemUpdate | CEInvalidChatItemDelete + | CEHasCurrentCall + | CENoCurrentCall + | CECallContact {contactId :: Int64} + | CECallState {currentCallState :: CallStateTag} | CEAgentVersion | CECommandError {message :: String} deriving (Show, Exception, Generic) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index db8efceac3..b46bf67f15 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -468,7 +468,7 @@ instance ToJSON (CIContent d) where toJSON = J.toJSON . jsonCIContent toEncoding = J.toEncoding . jsonCIContent -data ACIContent = forall d. ACIContent (SMsgDirection d) (CIContent d) +data ACIContent = forall d. MsgDirectionI d => ACIContent (SMsgDirection d) (CIContent d) deriving instance Show ACIContent @@ -553,6 +553,8 @@ data CICallStatus = CISCallPending | CISCallMissed | CISCallRejected -- only possible for received calls, not on type level + | CISCallAccepted + | CISCallNegotiated | CISCallProgress | CISCallEnded | CISCallError @@ -570,6 +572,8 @@ ciCallInfoText status duration = case status of CISCallPending -> "calling..." CISCallMissed -> "missed" CISCallRejected -> "rejected" + CISCallAccepted -> "accepted" + CISCallNegotiated -> "connecting..." CISCallProgress -> "in progress " <> d CISCallEnded -> "ended " <> d CISCallError -> "error" diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index d1835490ed..15e04bf194 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -142,6 +142,7 @@ module Simplex.Chat.Store getChatItemByFileId, updateDirectChatItemStatus, updateDirectChatItem, + updateDirectChatItemNoMsg, deleteDirectChatItemInternal, deleteDirectChatItemRcvBroadcast, deleteDirectChatItemSndBroadcast, @@ -170,7 +171,7 @@ import qualified Data.Aeson as J import Data.Bifunctor (first) import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) -import Data.Either (rights) +import Data.Either (isRight, rights) import Data.Function (on) import Data.Functor (($>)) import Data.Int (Int64) @@ -1286,7 +1287,7 @@ createNewGroup st gVar user groupProfile = "INSERT INTO groups (local_display_name, user_id, group_profile_id, created_at, updated_at) VALUES (?,?,?,?,?)" (displayName, uId, profileId, currentTs, currentTs) groupId <- insertedRowId db - memberId <- randomBytes gVar 12 + memberId <- encodedRandomBytes gVar 12 membership <- createContactMember_ db user groupId user (MemberIdRole (MemberId memberId) GROwner) GCUserMember GSMemCreator IBUser currentTs pure $ Right GroupInfo {groupId, localDisplayName = displayName, groupProfile, membership, createdAt = currentTs} @@ -3178,12 +3179,21 @@ updateDirectChatItemStatus st userId contactId itemId itemStatus = updateDirectChatItem :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> UserId -> Int64 -> ChatItemId -> CIContent d -> MessageId -> m (ChatItem 'CTDirect d) updateDirectChatItem st userId contactId itemId newContent msgId = - liftIOEither . withTransaction st $ \db -> updateDirectChatItem_ db userId contactId itemId newContent msgId + liftIOEither . withTransaction st $ \db -> do + currentTs <- liftIO getCurrentTime + ci <- updateDirectChatItem_ db userId contactId itemId newContent currentTs + when (isRight ci) . liftIO $ insertChatItemMessage_ db itemId msgId currentTs + pure ci -updateDirectChatItem_ :: forall d. (MsgDirectionI d) => DB.Connection -> UserId -> Int64 -> ChatItemId -> CIContent d -> MessageId -> IO (Either StoreError (ChatItem 'CTDirect d)) -updateDirectChatItem_ db userId contactId itemId newContent msgId = runExceptT $ do +updateDirectChatItemNoMsg :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> UserId -> Int64 -> ChatItemId -> CIContent d -> m (ChatItem 'CTDirect d) +updateDirectChatItemNoMsg st userId contactId itemId newContent = + liftIOEither . withTransaction st $ \db -> do + currentTs <- liftIO getCurrentTime + updateDirectChatItem_ db userId contactId itemId newContent currentTs + +updateDirectChatItem_ :: forall d. (MsgDirectionI d) => DB.Connection -> UserId -> Int64 -> ChatItemId -> CIContent d -> UTCTime -> IO (Either StoreError (ChatItem 'CTDirect d)) +updateDirectChatItem_ db userId contactId itemId newContent currentTs = runExceptT $ do ci <- ExceptT $ (correctDir =<<) <$> getDirectChatItem_ db userId contactId itemId - currentTs <- liftIO getCurrentTime let newText = ciContentToText newContent liftIO $ do DB.execute @@ -3194,7 +3204,6 @@ updateDirectChatItem_ db userId contactId itemId newContent msgId = runExceptT $ WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? |] (newContent, newText, currentTs, userId, contactId, itemId) - insertChatItemMessage_ db itemId msgId currentTs pure ci {content = newContent, meta = (meta ci) {itemText = newText, itemEdited = True}, formattedText = parseMaybeMarkdownList newText} where correctDir :: CChatItem c -> Either StoreError (ChatItem c d) @@ -3747,15 +3756,18 @@ createWithRandomBytes size gVar create = tryCreate 3 tryCreate :: Int -> IO (Either StoreError a) tryCreate 0 = pure $ Left SEUniqueID tryCreate n = do - id' <- randomBytes gVar size + id' <- encodedRandomBytes gVar size E.try (create id') >>= \case Right x -> pure $ Right x Left e | DB.sqlError e == DB.ErrorConstraint -> tryCreate (n - 1) | otherwise -> pure . Left . SEInternalError $ show e +encodedRandomBytes :: TVar ChaChaDRG -> Int -> IO ByteString +encodedRandomBytes gVar = fmap B64.encode . randomBytes gVar + randomBytes :: TVar ChaChaDRG -> Int -> IO ByteString -randomBytes gVar n = B64.encode <$> (atomically . stateTVar gVar $ randomBytesGenerate n) +randomBytes gVar = atomically . stateTVar gVar . randomBytesGenerate listToEither :: e -> [a] -> Either e a listToEither _ (x : _) = Right x diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 080c25b4f5..1e816ee479 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -661,6 +661,10 @@ viewChatError = \case CEInvalidQuote -> ["cannot reply to this message"] CEInvalidChatItemUpdate -> ["cannot update this item"] CEInvalidChatItemDelete -> ["cannot delete this item"] + CEHasCurrentCall -> ["call already in progress"] + CENoCurrentCall -> ["no call in progress"] + CECallContact _ -> [] + CECallState _ -> [] CEAgentVersion -> ["unsupported agent version"] CECommandError e -> ["bad chat command: " <> plain e] -- e -> ["chat error: " <> sShow e]