From 1ddd17839bb5c81e8a36ce7254090c1ab7f45e6b Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Wed, 4 May 2022 13:31:00 +0100 Subject: [PATCH] core: calls api - support multiple calls, process status updates from webview, refactor, tests (#595) * core: tests for call api (WIP, test fails) * fix test * add APICallStatus, tests * update call status based on webview events, refactor --- src/Simplex/Chat.hs | 194 +++++++++++++++++++-------------- src/Simplex/Chat/Call.hs | 20 ++++ src/Simplex/Chat/Controller.hs | 16 +-- src/Simplex/Chat/Messages.hs | 14 ++- src/Simplex/Chat/Store.hs | 99 +++++++++-------- src/Simplex/Chat/Types.hs | 12 +- src/Simplex/Chat/View.hs | 10 +- tests/ChatTests.hs | 68 +++++++++++- 8 files changed, 280 insertions(+), 153 deletions(-) diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 3a7f790174..c9b5e843bf 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -27,6 +27,7 @@ import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Char (isSpace) +import Data.Fixed (div') import Data.Functor (($>)) import Data.Int (Int64) import Data.List (find) @@ -37,7 +38,7 @@ import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Text (Text) import qualified Data.Text as T -import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds) import Data.Time.LocalTime (getCurrentTimeZone, getZonedTime) import Data.Word (Word32) import Simplex.Chat.Call @@ -60,6 +61,7 @@ import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), PushProvider import Simplex.Messaging.Parsers (base64P, parseAll) import Simplex.Messaging.Protocol (ErrorType (..), MsgBody) import qualified Simplex.Messaging.Protocol as SMP +import qualified Simplex.Messaging.TMap as TM import Simplex.Messaging.Util (tryError, (<$?>)) import System.Exit (exitFailure, exitSuccess) import System.FilePath (combine, splitExtensions, takeFileName) @@ -124,9 +126,9 @@ newChatController chatStore user cfg@ChatConfig {agentConfig = aCfg, tbqSize} Ch chatLock <- newTMVarIO () sndFiles <- newTVarIO M.empty rcvFiles <- newTVarIO M.empty - currentCall <- newTVarIO Nothing + currentCalls <- atomically TM.empty filesFolder <- newTVarIO Nothing - pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCall, config, sendNotification, filesFolder} + pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, filesFolder} where resolveServers :: IO (NonEmpty SMPServer) resolveServers = case user of @@ -290,7 +292,7 @@ processChatCommand = \case case (ciContent, itemSharedMsgId) of (CISndMsgContent _, Just itemSharedMId) -> do SndMessage {msgId} <- sendDirectContactMessage ct (XMsgUpdate itemSharedMId mc) - updCi <- withStore $ \st -> updateDirectChatItem st userId contactId itemId (CISndMsgContent mc) msgId + updCi <- withStore $ \st -> updateDirectChatItem st userId contactId itemId (CISndMsgContent mc) $ Just msgId setActive $ ActiveC c pure . CRChatItemUpdated $ AChatItem SCTDirect SMDSnd (DirectChat ct) updCi _ -> throwChatError CEInvalidChatItemUpdate @@ -393,27 +395,25 @@ processChatCommand = \case 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 + calls <- asks currentCalls + withChatLock $ 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@SndMessage {msgId} <- sendDirectContactMessage ct (XCallInv callId invitation) + ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndCall CISCallPending 0) Nothing Nothing + let call' = Call {contactId, callId, chatItemId = chatItemId' ci, callState} + call_ <- atomically $ TM.lookupInsert contactId call' calls + forM_ call_ $ \call -> updateCallItemStatus userId ct call WCSDisconnected $ Just msgId + 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 + CallInvitationReceived {} -> + let aciContent = ACIContent SMDRcv $ CIRcvCall CISCallRejected 0 + in updateDirectChatItemView userId ct chatItemId aciContent Nothing $> Nothing _ -> throwChatError . CECallState $ callStateTag callState APISendCallOffer contactId WebRTCCallOffer {callType, rtcSession} -> -- party accepting call @@ -422,19 +422,19 @@ processChatCommand = \case -- TODO check that call type matches peerCallType let offer = CallOffer {callType, rtcSession, callDhPubKey = localDhPubKey} callState' = CallOfferSent {localCallType = callType, peerCallType, localCallSession = rtcSession, sharedKey} + aciContent = ACIContent SMDRcv $ CIRcvCall CISCallAccepted 0 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 + updateDirectChatItemView userId ct chatItemId aciContent $ Just msgId 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} + aciContent = ACIContent SMDSnd $ CISndCall CISCallNegotiated 0 + SndMessage {msgId} <- sendDirectContactMessage ct (XCallAnswer callId CallAnswer {rtcSession}) + updateDirectChatItemView userId ct chatItemId aciContent $ Just msgId pure $ Just call {callState = callState'} _ -> throwChatError . CECallState $ callStateTag callState APISendCallExtraInfo contactId rtcExtraInfo -> @@ -448,17 +448,13 @@ processChatCommand = \case _ -> throwChatError . CECallState $ callStateTag callState APIEndCall contactId -> -- any call party - withCurrentCall contactId $ \userId ct Call {callId, chatItemId} -> do + withCurrentCall contactId $ \userId ct call@Call {callId} -> 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 + updateCallItemStatus userId ct call WCSDisconnected $ Just msgId pure Nothing + APICallStatus contactId receivedStatus -> + withCurrentCall contactId $ \userId ct call -> + updateCallItemStatus userId ct call receivedStatus Nothing $> Just call APIUpdateProfile profile -> withUser (`updateProfile` profile) APIParseMarkdown text -> pure . CRApiParsedMarkdown $ parseMaybeMarkdownList text APIRegisterToken token -> CRNtfTokenStatus <$> withUser (\_ -> withAgent (`registerNtfToken` token)) @@ -757,20 +753,59 @@ 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 :: ContactId -> (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 + calls <- asks currentCalls withChatLock $ - readTVarIO callVar >>= \case + atomically (TM.lookup ctId calls) >>= \case Nothing -> throwChatError CENoCurrentCall Just call@Call {contactId} | ctId == contactId -> do call_ <- action userId ct call - atomically $ writeTVar callVar call_ + atomically $ case call_ of + Just call' -> TM.insert ctId call' calls + _ -> TM.delete ctId calls pure CRCmdOk | otherwise -> throwChatError $ CECallContact contactId +updateCallItemStatus :: ChatMonad m => UserId -> Contact -> Call -> WebRTCCallStatus -> Maybe MessageId -> m () +updateCallItemStatus userId ct Call {chatItemId} receivedStatus msgId_ = do + aciContent_ <- callStatusItemContent userId ct chatItemId receivedStatus + forM_ aciContent_ $ \aciContent -> updateDirectChatItemView userId ct chatItemId aciContent msgId_ + +updateDirectChatItemView :: ChatMonad m => UserId -> Contact -> ChatItemId -> ACIContent -> Maybe MessageId -> m () +updateDirectChatItemView userId ct@Contact {contactId} chatItemId (ACIContent msgDir ciContent) msgId_ = do + updCi <- withStore $ \st -> updateDirectChatItem st userId contactId chatItemId ciContent msgId_ + toView . CRChatItemUpdated $ AChatItem SCTDirect msgDir (DirectChat ct) updCi + +callStatusItemContent :: ChatMonad m => UserId -> Contact -> ChatItemId -> WebRTCCallStatus -> m (Maybe ACIContent) +callStatusItemContent userId Contact {contactId} chatItemId receivedStatus = do + CChatItem msgDir ChatItem {meta = CIMeta {updatedAt}, content} <- + withStore $ \st -> getDirectChatItem st userId contactId chatItemId + ts <- liftIO getCurrentTime + let callDuration :: Int = nominalDiffTimeToSeconds (ts `diffUTCTime` updatedAt) `div'` 1 + callStatus = case content of + CISndCall st _ -> Just st + CIRcvCall st _ -> Just st + _ -> Nothing + newState_ = case (callStatus, receivedStatus) of + (Just CISCallProgress, WCSConnected) -> Nothing -- if call in-progress received connected -> no change + (Just CISCallProgress, WCSDisconnected) -> Just (CISCallEnded, callDuration) -- calculate in-progress duration + (Just CISCallProgress, WCSFailed) -> Just (CISCallEnded, callDuration) -- whether call disconnected or failed + (Just CISCallEnded, _) -> Nothing -- if call already ended or failed -> no change + (Just CISCallError, _) -> Nothing + (Just _, WCSConnected) -> Just (CISCallProgress, 0) -- if call ended that was never connected, duration = 0 + (Just _, WCSDisconnected) -> Just (CISCallEnded, 0) + (Just _, WCSFailed) -> Just (CISCallError, 0) + (Nothing, _) -> Nothing -- some other content - we should never get here, but no exception is thrown + pure $ aciContent msgDir <$> newState_ + where + aciContent :: forall d. SMsgDirection d -> (CICallStatus, Int) -> ACIContent + aciContent msgDir (callStatus', duration) = case msgDir of + SMDSnd -> ACIContent SMDSnd $ CISndCall callStatus' duration + SMDRcv -> ACIContent SMDRcv $ CIRcvCall callStatus' duration + -- 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 -- used during file transfer for actual operations with file system @@ -1064,12 +1099,11 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage when (memberCategory m == GCPreMember) $ probeMatchingContacts ct SENT msgId -> do sentMsgDeliveryEvent conn msgId - chatItemId_ <- withStore $ \st -> getChatItemIdByAgentMsgId st connId msgId - case chatItemId_ of - Nothing -> pure () - Just chatItemId -> do - chatItem <- withStore $ \st -> updateDirectChatItemStatus st userId contactId chatItemId CISSndSent + withStore (\st -> getDirectChatItemByAgentMsgId st userId contactId connId msgId) >>= \case + Just (CChatItem SMDSnd ci) -> do + chatItem <- withStore $ \st -> updateDirectChatItemStatus st userId contactId (chatItemId' ci) CISSndSent toView $ CRChatItemStatusUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem) + _ -> pure () END -> do toView $ CRContactAnotherClient ct showToast (c <> "> ") "connected to another client" @@ -1365,9 +1399,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage 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 + SMDRcv -> updateDirectChatItemView userId ct itemId (ACIContent SMDRcv $ CIRcvMsgContent mc) $ Just msgId SMDSnd -> messageError "x.msg.update: contact attempted invalid message update" messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> m () @@ -1523,23 +1555,21 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage -- to party accepting call xCallInv :: Contact -> CallId -> CallInvitation -> RcvMessage -> MsgMeta -> m () - xCallInv ct@Contact {contactId} callId CallInvitation {callType, callDhPubKey} msg msgMeta = do + xCallInv ct@Contact {contactId} callId CallInvitation {callType, callDhPubKey} msg@RcvMessage {msgId} 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 + dhKeyPair <- if encryption then Just <$> liftIO C.generateKeyPair' else pure Nothing + ci <- saveCallItem CISCallPending + let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> (snd <$> dhKeyPair)) + callState = CallInvitationReceived {peerCallType = callType, localDhPubKey = fst <$> dhKeyPair, sharedKey} + call' = Call {contactId, callId, chatItemId = chatItemId' ci, callState} + calls <- asks currentCalls + -- theoretically, the new call invitation for the current contant can mark the in-progress call as ended + -- (and replace it in ChatController) + -- practically, this should not happen + call_ <- atomically (TM.lookupInsert contactId call' calls) + forM_ call_ $ \call -> updateCallItemStatus userId ct call WCSDisconnected $ Just msgId + toView $ CRCallInvitation ct callType sharedKey toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci where saveCallItem status = saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvCall status 0) Nothing @@ -1583,34 +1613,34 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage toView $ CRCallExtraInfo ct rtcExtraInfo pure (Just call {callState = callState'}, Nothing) _ -> do - msgCallStateError "x.call.answer" call + msgCallStateError "x.call.extra" 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) + xCallEnd ct@Contact {contactId} callId msg msgMeta = + 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 + calls <- asks currentCalls + atomically (TM.lookup ctId' calls) >>= \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 + (call_, aciContent_) <- action call + atomically $ case call_ of + Just call' -> TM.insert ctId' call' calls + _ -> TM.delete ctId' calls + forM_ aciContent_ $ \aciContent -> + updateDirectChatItemView userId ct chatItemId aciContent $ Just msgId msgCallStateError :: Text -> Call -> m () msgCallStateError eventName Call {callState} = @@ -1929,11 +1959,10 @@ saveRcvChatItem user cd msg@RcvMessage {sharedMsgId_} MsgMeta {broker = (_, brok liftIO $ mkChatItem cd ciId content ciFile quotedItem sharedMsgId_ brokerTs createdAt mkChatItem :: MsgDirectionI d => ChatDirection c d -> ChatItemId -> CIContent d -> Maybe (CIFile d) -> Maybe (CIQuote c) -> Maybe SharedMsgId -> ChatItemTs -> UTCTime -> IO (ChatItem c d) -mkChatItem cd ciId content file quotedItem sharedMsgId itemTs createdAt = do +mkChatItem cd ciId content file quotedItem sharedMsgId itemTs currentTs = do tz <- getCurrentTimeZone - currentTs <- liftIO getCurrentTime let itemText = ciContentToText content - meta = mkCIMeta ciId content itemText ciStatusNew sharedMsgId False False tz currentTs itemTs createdAt + meta = mkCIMeta ciId content itemText ciStatusNew sharedMsgId False False tz currentTs itemTs currentTs currentTs pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, file} allowAgentConnection :: ChatMonad m => Connection -> ConfirmationId -> ChatMsgEvent -> m () @@ -2067,6 +2096,7 @@ chatCommandP = <|> "/_call answer @" *> (APISendCallAnswer <$> A.decimal <* A.space <*> jsonP) <|> "/_call extra @" *> (APISendCallExtraInfo <$> A.decimal <* A.space <*> jsonP) <|> "/_call end @" *> (APIEndCall <$> A.decimal) + <|> "/_call status @" *> (APICallStatus <$> A.decimal <* A.space <*> strP) <|> "/_profile " *> (APIUpdateProfile <$> jsonP) <|> "/_parse " *> (APIParseMarkdown . safeDecodeUtf8 <$> A.takeByteString) <|> "/_ntf register " *> (APIRegisterToken <$> tokenP) diff --git a/src/Simplex/Chat/Call.hs b/src/Simplex/Chat/Call.hs index 4559cf1e6e..827953a249 100644 --- a/src/Simplex/Chat/Call.hs +++ b/src/Simplex/Chat/Call.hs @@ -9,6 +9,7 @@ module Simplex.Chat.Call where import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as J +import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) import GHC.Generics (Generic) @@ -152,6 +153,10 @@ data WebRTCCallOffer = WebRTCCallOffer instance FromJSON WebRTCCallOffer where parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True} +instance ToJSON WebRTCCallOffer where + toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} + toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} + data CallAnswer = CallAnswer { rtcSession :: WebRTCSession } @@ -188,3 +193,18 @@ data WebRTCExtraInfo = WebRTCExtraInfo instance ToJSON WebRTCExtraInfo where toJSON = J.genericToJSON J.defaultOptions toEncoding = J.genericToEncoding J.defaultOptions + +data WebRTCCallStatus = WCSConnected | WCSDisconnected | WCSFailed + deriving (Show) + +instance StrEncoding WebRTCCallStatus where + strEncode = \case + WCSConnected -> "connected" + WCSDisconnected -> "disconnected" + WCSFailed -> "failed" + strP = + A.takeTill (== ' ') >>= \case + "connected" -> pure WCSConnected + "disconnected" -> pure WCSDisconnected + "failed" -> pure WCSFailed + _ -> fail "bad WebRTCCallStatus" diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 89a2228f27..bf6e815ef8 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -40,6 +40,7 @@ import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Notifications.Protocol (DeviceToken (..), NtfTknStatus) import Simplex.Messaging.Parsers (dropPrefix, enumJSON, sumTypeJSON) import Simplex.Messaging.Protocol (CorrId) +import Simplex.Messaging.TMap (TMap) import System.IO (Handle) import UnliftIO.STM @@ -81,7 +82,7 @@ data ChatController = ChatController chatLock :: TMVar (), sndFiles :: TVar (Map Int64 Handle), rcvFiles :: TVar (Map Int64 Handle), - currentCall :: TVar (Maybe Call), + currentCalls :: TMap ContactId Call, config :: ChatConfig, filesFolder :: TVar (Maybe FilePath) -- path to files folder for mobile apps } @@ -110,12 +111,13 @@ data ChatCommand | APIDeleteChat ChatRef | APIAcceptContact Int64 | APIRejectContact Int64 - | APISendCallInvitation Int64 CallType - | APIRejectCall Int64 - | APISendCallOffer Int64 WebRTCCallOffer - | APISendCallAnswer Int64 WebRTCSession - | APISendCallExtraInfo Int64 WebRTCExtraInfo - | APIEndCall Int64 + | APISendCallInvitation ContactId CallType + | APIRejectCall ContactId + | APISendCallOffer ContactId WebRTCCallOffer + | APISendCallAnswer ContactId WebRTCSession + | APISendCallExtraInfo ContactId WebRTCExtraInfo + | APIEndCall ContactId + | APICallStatus ContactId WebRTCCallStatus | APIUpdateProfile Profile | APIParseMarkdown Text | APIRegisterToken DeviceToken diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index b46bf67f15..6a1097d065 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -224,17 +224,18 @@ data CIMeta (d :: MsgDirection) = CIMeta itemEdited :: Bool, editable :: Bool, localItemTs :: ZonedTime, - createdAt :: UTCTime + createdAt :: UTCTime, + updatedAt :: UTCTime } deriving (Show, Generic) -mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Bool -> Bool -> TimeZone -> UTCTime -> ChatItemTs -> UTCTime -> CIMeta d -mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited tz currentTs itemTs createdAt = +mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Bool -> Bool -> TimeZone -> UTCTime -> ChatItemTs -> UTCTime -> UTCTime -> CIMeta d +mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited tz currentTs itemTs createdAt updatedAt = let localItemTs = utcToZonedTime tz itemTs editable = case itemContent of CISndMsgContent _ -> diffUTCTime currentTs itemTs < nominalDay _ -> False - in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, editable, localItemTs, createdAt} + in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, editable, localItemTs, createdAt, updatedAt} instance ToJSON (CIMeta d) where toEncoding = J.genericToEncoding J.defaultOptions @@ -578,7 +579,10 @@ ciCallInfoText status duration = case status of CISCallEnded -> "ended " <> d CISCallError -> "error" where - d = let (mins, secs) = duration `divMod` 60 in T.pack $ "(" <> show mins <> ":" <> show secs <> ")" + d = let (mins, secs) = duration `divMod` 60 in T.pack $ "(" <> with0 mins <> ":" <> with0 secs <> ")" + with0 n + | n < 9 = '0' : show n + | otherwise = show n data SChatType (c :: ChatType) where SCTDirect :: SChatType 'CTDirect diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 15e04bf194..00db6f444e 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -135,6 +135,7 @@ module Simplex.Chat.Store getChatItemIdByAgentMsgId, getDirectChatItem, getDirectChatItemBySharedMsgId, + getDirectChatItemByAgentMsgId, getGroupChatItem, getGroupChatItemBySharedMsgId, getDirectChatItemIdByText, @@ -142,7 +143,6 @@ module Simplex.Chat.Store getChatItemByFileId, updateDirectChatItemStatus, updateDirectChatItem, - updateDirectChatItemNoMsg, deleteDirectChatItemInternal, deleteDirectChatItemRcvBroadcast, deleteDirectChatItemSndBroadcast, @@ -2576,7 +2576,7 @@ getDirectChatPreviews_ db User {userId} = do -- ChatStats COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, -- DirectQuote @@ -2641,7 +2641,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do -- ChatStats COALESCE(ChatStats.UnreadCount, 0), COALESCE(ChatStats.MinUnread, 0), -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, -- Maybe GroupMember - sender @@ -2794,7 +2794,7 @@ getDirectChatLast_ db User {userId} contactId count = do [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, -- DirectQuote @@ -2825,7 +2825,7 @@ getDirectChatAfter_ db User {userId} contactId afterChatItemId count = do [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, -- DirectQuote @@ -2856,7 +2856,7 @@ getDirectChatBefore_ db User {userId} contactId beforeChatItemId count = do [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, -- DirectQuote @@ -2959,7 +2959,7 @@ getGroupChatLast_ db user@User {userId, userContactId} groupId count = do [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, -- GroupMember @@ -3002,7 +3002,7 @@ getGroupChatAfter_ db user@User {userId, userContactId} groupId afterChatItemId [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, -- GroupMember @@ -3045,7 +3045,7 @@ getGroupChatBefore_ db user@User {userId, userContactId} groupId beforeChatItemI [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, -- GroupMember @@ -3150,24 +3150,27 @@ getGroupIdByName_ db User {userId} gName = getChatItemIdByAgentMsgId :: StoreMonad m => SQLiteStore -> Int64 -> AgentMsgId -> m (Maybe ChatItemId) getChatItemIdByAgentMsgId st connId msgId = - liftIO . withTransaction st $ \db -> - join . listToMaybe . map fromOnly - <$> DB.query - db - [sql| - SELECT chat_item_id - FROM chat_item_messages - WHERE message_id = ( - SELECT message_id - FROM msg_deliveries - WHERE connection_id = ? AND agent_msg_id = ? - LIMIT 1 - ) - |] - (connId, msgId) + liftIO . withTransaction st $ \db -> getChatItemIdByAgentMsgId_ db connId msgId + +getChatItemIdByAgentMsgId_ :: DB.Connection -> Int64 -> AgentMsgId -> IO (Maybe ChatItemId) +getChatItemIdByAgentMsgId_ db connId msgId = + join . listToMaybe . map fromOnly + <$> DB.query + db + [sql| + SELECT chat_item_id + FROM chat_item_messages + WHERE message_id = ( + SELECT message_id + FROM msg_deliveries + WHERE connection_id = ? AND agent_msg_id = ? + LIMIT 1 + ) + |] + (connId, msgId) updateDirectChatItemStatus :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> UserId -> Int64 -> ChatItemId -> CIStatus d -> m (ChatItem 'CTDirect d) -updateDirectChatItemStatus st userId contactId itemId itemStatus = +updateDirectChatItemStatus st userId contactId itemId itemStatus = do liftIOEither . withTransaction st $ \db -> runExceptT $ do ci <- ExceptT $ (correctDir =<<) <$> getDirectChatItem_ db userId contactId itemId currentTs <- liftIO getCurrentTime @@ -3177,20 +3180,14 @@ updateDirectChatItemStatus st userId contactId itemId itemStatus = correctDir :: CChatItem c -> Either StoreError (ChatItem c d) correctDir (CChatItem _ ci) = first SEInternalError $ checkDirection ci -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 = +updateDirectChatItem :: forall m d. (StoreMonad m, MsgDirectionI d) => SQLiteStore -> UserId -> Int64 -> ChatItemId -> CIContent d -> Maybe MessageId -> m (ChatItem 'CTDirect d) +updateDirectChatItem st 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 + when (isRight ci) . forM_ msgId_ $ \msgId -> liftIO $ insertChatItemMessage_ db itemId msgId currentTs pure ci -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 @@ -3280,16 +3277,22 @@ deleteQuote_ db itemId = |] (Only itemId) -getDirectChatItem :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> ChatItemId -> m (CChatItem 'CTDirect) +getDirectChatItem :: StoreMonad m => SQLiteStore -> UserId -> ContactId -> ChatItemId -> m (CChatItem 'CTDirect) getDirectChatItem st userId contactId itemId = liftIOEither . withTransaction st $ \db -> getDirectChatItem_ db userId contactId itemId -getDirectChatItemBySharedMsgId :: StoreMonad m => SQLiteStore -> UserId -> Int64 -> SharedMsgId -> m (CChatItem 'CTDirect) +getDirectChatItemBySharedMsgId :: StoreMonad m => SQLiteStore -> UserId -> ContactId -> SharedMsgId -> m (CChatItem 'CTDirect) getDirectChatItemBySharedMsgId st userId contactId sharedMsgId = liftIOEither . withTransaction st $ \db -> runExceptT $ do itemId <- ExceptT $ getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId liftIOEither $ getDirectChatItem_ db userId contactId itemId +getDirectChatItemByAgentMsgId :: MonadUnliftIO m => SQLiteStore -> UserId -> ContactId -> Int64 -> AgentMsgId -> m (Maybe (CChatItem 'CTDirect)) +getDirectChatItemByAgentMsgId st userId contactId connId msgId = + liftIO . withTransaction st $ \db -> do + itemId_ <- getChatItemIdByAgentMsgId_ db connId msgId + maybe (pure Nothing) (fmap eitherToMaybe . getDirectChatItem_ db userId contactId) itemId_ + getDirectChatItemIdBySharedMsgId_ :: DB.Connection -> UserId -> Int64 -> SharedMsgId -> IO (Either StoreError Int64) getDirectChatItemIdBySharedMsgId_ db userId contactId sharedMsgId = firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $ @@ -3316,7 +3319,7 @@ getDirectChatItem_ db userId contactId itemId = do [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, -- DirectQuote @@ -3446,7 +3449,7 @@ getGroupChatItem_ db User {userId, userContactId} groupId itemId = do [sql| SELECT -- ChatItem - i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, + i.chat_item_id, i.item_ts, i.item_content, i.item_text, i.item_status, i.shared_msg_id, i.item_deleted, i.item_edited, i.created_at, i.updated_at, -- CIFile f.file_id, f.file_name, f.file_size, f.file_path, f.ci_file_status, -- GroupMember @@ -3588,9 +3591,9 @@ toChatStats (unreadCount, minUnreadItemId) = ChatStats {unreadCount, minUnreadIt type MaybeCIFIleRow = (Maybe Int64, Maybe String, Maybe Integer, Maybe FilePath, Maybe ACIFileStatus) -type ChatItemRow = (Int64, ChatItemTs, ACIContent, Text, ACIStatus, Maybe SharedMsgId, Bool, Maybe Bool, UTCTime) :. MaybeCIFIleRow +type ChatItemRow = (Int64, ChatItemTs, ACIContent, Text, ACIStatus, Maybe SharedMsgId, Bool, Maybe Bool, UTCTime, UTCTime) :. MaybeCIFIleRow -type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId, Maybe Bool, Maybe Bool, Maybe UTCTime) :. MaybeCIFIleRow +type MaybeChatItemRow = (Maybe Int64, Maybe ChatItemTs, Maybe ACIContent, Maybe Text, Maybe ACIStatus, Maybe SharedMsgId, Maybe Bool, Maybe Bool, Maybe UTCTime, Maybe UTCTime) :. MaybeCIFIleRow type QuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool) @@ -3604,7 +3607,7 @@ toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent) toDirectChatItem :: TimeZone -> UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect) -toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. quoteRow) = +toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. quoteRow) = case (itemContent, itemStatus, fileStatus_) of (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, Just (AFS SMDSnd fileStatus)) -> Right $ cItem SMDSnd CIDirectSnd ciStatus ciContent (maybeCIFile fileStatus) @@ -3626,11 +3629,11 @@ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStat CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, file} badItem = Left $ SEBadChatItem itemId ciMeta :: CIContent d -> CIStatus d -> CIMeta d - ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt + ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt updatedAt toDirectChatItemList :: TimeZone -> UTCTime -> MaybeChatItemRow :. QuoteRow -> [CChatItem 'CTDirect] -toDirectChatItemList tz currentTs (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt) :. fileRow) :. quoteRow) = - either (const []) (: []) $ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt) :. fileRow) :. quoteRow) +toDirectChatItemList tz currentTs (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt) :. fileRow) :. quoteRow) = + either (const []) (: []) $ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. fileRow) :. quoteRow) toDirectChatItemList _ _ _ = [] type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow @@ -3646,7 +3649,7 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction direction _ _ = Nothing toGroupChatItem :: TimeZone -> UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow -> Either StoreError (CChatItem 'CTGroup) -toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. memberRow_ :. quoteRow :. quotedMemberRow_) = do +toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. memberRow_ :. quoteRow :. quotedMemberRow_) = do let member_ = toMaybeGroupMember userContactId memberRow_ let quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_ case (itemContent, itemStatus, member_, fileStatus_) of @@ -3670,11 +3673,11 @@ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemT CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, file} badItem = Left $ SEBadChatItem itemId ciMeta :: CIContent d -> CIStatus d -> CIMeta d - ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt + ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) tz currentTs itemTs createdAt updatedAt toGroupChatItemList :: TimeZone -> UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] -toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_) = - either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_) +toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_) = + either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_) toGroupChatItemList _ _ _ _ = [] getSMPServers :: MonadUnliftIO m => SQLiteStore -> User -> m [SMPServer] diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index fcb11f7f5f..8c200b067e 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -37,7 +37,7 @@ import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, sumTypeJSON) import Simplex.Messaging.Util ((<$?>)) class IsContact a where - contactId' :: a -> Int64 + contactId' :: a -> ContactId profile' :: a -> Profile localDisplayName' :: a -> ContactName @@ -53,7 +53,7 @@ instance IsContact Contact where data User = User { userId :: UserId, - userContactId :: Int64, + userContactId :: ContactId, localDisplayName :: ContactName, profile :: Profile, activeUser :: Bool @@ -62,10 +62,12 @@ data User = User instance ToJSON User where toEncoding = J.genericToEncoding J.defaultOptions -type UserId = Int64 +type UserId = ContactId + +type ContactId = Int64 data Contact = Contact - { contactId :: Int64, + { contactId :: ContactId, localDisplayName :: ContactName, profile :: Profile, activeConn :: Connection, @@ -85,7 +87,7 @@ contactConnId :: Contact -> ConnId contactConnId Contact {activeConn} = aConnId activeConn data ContactRef = ContactRef - { contactId :: Int64, + { contactId :: ContactId, localDisplayName :: ContactName } deriving (Eq, Show, Generic) diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 1e816ee479..7a1a3dd257 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -139,11 +139,11 @@ responseToView testView = \case ["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e] CRRcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e -> ["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e] - CRCallInvitation {} -> [] - CRCallOffer {} -> [] - CRCallAnswer {} -> [] - CRCallExtraInfo {} -> [] - CRCallEnded {} -> [] + CRCallInvitation {contact} -> ["call invitation from " <> ttyContact' contact] + CRCallOffer {contact} -> ["call offer from " <> ttyContact' contact] + CRCallAnswer {contact} -> ["call answer from " <> ttyContact' contact] + CRCallExtraInfo {contact} -> ["call extra info from " <> ttyContact' contact] + CRCallEnded {contact} -> ["call with " <> ttyContact' contact <> " ended"] CRUserContactLinkSubscribed -> ["Your address is active! To show: " <> highlight' "/sa"] CRUserContactLinkSubError e -> ["user address error: " <> sShow e, "to delete your address: " <> highlight' "/da"] CRNewContactConnection _ -> [] diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 05e0ea7b6c..fcf52e9772 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -9,9 +9,13 @@ import ChatClient import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_) import Control.Concurrent.STM -import qualified Data.ByteString as B +import Data.Aeson (ToJSON, (.=)) +import qualified Data.Aeson as J +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isDigit) import qualified Data.Text as T +import Simplex.Chat.Call import Simplex.Chat.Controller (ChatController (..)) import Simplex.Chat.Types (ConnStatus (..), ImageData (..), Profile (..), User (..)) import Simplex.Chat.Util (unlessM) @@ -82,6 +86,8 @@ chatTests = do xdescribe "async sending and receiving files" $ do it "send and receive file, fully asynchronous" testAsyncFileTransfer it "send and receive file to group, fully asynchronous" testAsyncGroupFileTransfer + describe "webrtc calls api" $ do + it "negotiate call" testNegotiateCall testAddContact :: IO () testAddContact = @@ -1762,6 +1768,66 @@ testAsyncGroupFileTransfer = withTmpFiles $ do dest2 <- B.readFile "./tests/tmp/test_1.jpg" dest2 `shouldBe` src +testCallType :: CallType +testCallType = CallType {media = CMVideo, capabilities = CallCapabilities {encryption = True}} + +testWebRTCSession :: WebRTCSession +testWebRTCSession = + WebRTCSession + { rtcSession = J.object ["test" .= (123 :: Int)], + rtcIceCandidates = [] + } + +testWebRTCCallOffer :: WebRTCCallOffer +testWebRTCCallOffer = + WebRTCCallOffer + { callType = testCallType, + rtcSession = testWebRTCSession + } + +serialize :: ToJSON a => a -> String +serialize = B.unpack . LB.toStrict . J.encode + +testNegotiateCall :: IO () +testNegotiateCall = + testChat2 aliceProfile bobProfile $ \alice bob -> do + connectUsers alice bob + -- alice invite bob to call + alice ##> ("/_call invite @2 " <> serialize testCallType) + alice <## "ok" + alice #$> ("/_get chat @2 count=100", chat, [(1, "outgoing call: calling...")]) + bob <## "call invitation from alice" + bob #$> ("/_get chat @2 count=100", chat, [(0, "incoming call: calling...")]) + -- bob accepts call by sending WebRTC offer + bob ##> ("/_call offer @2 " <> serialize testWebRTCCallOffer) + bob <## "ok" + bob #$> ("/_get chat @2 count=100", chat, [(0, "incoming call: accepted")]) + alice <## "call offer from bob" + alice <## "message updated" -- call chat item updated + alice #$> ("/_get chat @2 count=100", chat, [(1, "outgoing call: accepted")]) + -- alice confirms call by sending WebRTC answer + alice ##> ("/_call answer @2 " <> serialize testWebRTCSession) + alice <## "ok" + alice <## "message updated" + alice #$> ("/_get chat @2 count=100", chat, [(1, "outgoing call: connecting...")]) + bob <## "call answer from alice" + bob #$> ("/_get chat @2 count=100", chat, [(0, "incoming call: connecting...")]) + -- participants can update calls as connected + alice ##> "/_call status @2 connected" + alice <## "ok" + alice <## "message updated" + alice #$> ("/_get chat @2 count=100", chat, [(1, "outgoing call: in progress (00:00)")]) + bob ##> "/_call status @2 connected" + bob <## "ok" + bob #$> ("/_get chat @2 count=100", chat, [(0, "incoming call: in progress (00:00)")]) + -- either party can end the call + bob ##> "/_call end @2" + bob <## "ok" + bob #$> ("/_get chat @2 count=100", chat, [(0, "incoming call: ended (00:00)")]) + alice <## "call with bob ended" + alice <## "message updated" + alice #$> ("/_get chat @2 count=100", chat, [(1, "outgoing call: ended (00:00)")]) + withTestChatContactConnected :: String -> (TestCC -> IO a) -> IO a withTestChatContactConnected dbPrefix action = withTestChat dbPrefix $ \cc -> do