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
This commit is contained in:
Evgeny Poberezkin
committed by
GitHub
GitHub
parent
8e002eed1c
commit
1ddd17839b
@@ -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)
|
||||
|
||||
@@ -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"
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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]
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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 _ -> []
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user