core: webrtc calls api types (#590)

* core: webrtc calls api

* call: call state, chat items, update commands/responses

* update sequence diagram

* remove CRCallInvitationSent, add CISCallError
This commit is contained in:
Evgeny Poberezkin 2022-05-02 17:06:49 +01:00 committed by GitHub
parent f78ec3584f
commit cdb919db96
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
8 changed files with 357 additions and 4 deletions

67
docs/rfcs/webrtc.mmd Normal file
View file

@ -0,0 +1,67 @@
sequenceDiagram
participant AW as Alice's<br>web view
participant AN as Alice's<br>app native
participant AC as Alice's<br>chat core
participant BC as Bob's<br>chat core
participant BN as Bob's<br>app native
participant BW as Bob's<br>web view
note over AW, AC: Alice's app
note over BC, BW: Bob's app
note over AW, BW: 1. Establishing call
note over AN: user: start call
AN ->> AW: WCCapabilities
AW ->> AN: WRCapabilities (e2e?)
AN ->> AC: APISendCallInvitation
AC -->> BC: XCallInv
AC ->> AN: CRCmdOk
BC ->> BN: CRCallInvitation
note over BN: show: accept call?
alt user accepted?
BN ->> BC: no: APIRejectCall<br>(sender not notified)
BC ->> BN: CRCmdOk
else
BN ->> BW: yes: WCStartCall
BW ->> BN: WCallOffer
end
BN ->> BC: APISendCallOffer
BC -->> AC: XCallOffer
BC ->> BN: CRCmdOk
AC ->> AN: CRCallOffer
note over AN: show if no e2e: continue call?
AN ->> AW: WCallOffer
AW ->> AN: WCallAnswer
AN ->> AC: APISendCallAnswer
AC -->> BC: XCallAnswer
AC ->> AN: CRCmdOk
BC ->> BN: CRCallAnswer
BN ->> BW: WCallAnswer
note over AW, BW: call can be established at this point
note over AW, BW: 2. Sending additional ice candidates<br>(optional, same for another side):
BW ->> BN: WCallICE
BN ->> BC: APISendCallExtraInfo
BC -->> AC: XCallExtra
BC ->> BN: CRCmdOk
AC ->> AN: CRCallExtraInfo
AN ->> AW: WCallICE
note over AW, BW: 3. Call termination (same for another party):
note over AN: user: end call
AN ->> AW: WEndCall
AN ->> AC: APIEndCall
AC -->> BC: XCallEnd
AC ->> AN: CRCmdOk
BC ->> BN: CRCallEnded
note over BN: show: call ended
BN ->> BW: WEndCall

View file

@ -21,6 +21,7 @@ library
exposed-modules: exposed-modules:
Simplex.Chat Simplex.Chat
Simplex.Chat.Bot Simplex.Chat.Bot
Simplex.Chat.Call
Simplex.Chat.Controller Simplex.Chat.Controller
Simplex.Chat.Core Simplex.Chat.Core
Simplex.Chat.Help Simplex.Chat.Help

View file

@ -123,8 +123,9 @@ newChatController chatStore user cfg@ChatConfig {agentConfig = aCfg, tbqSize} Ch
chatLock <- newTMVarIO () chatLock <- newTMVarIO ()
sndFiles <- newTVarIO M.empty sndFiles <- newTVarIO M.empty
rcvFiles <- newTVarIO M.empty rcvFiles <- newTVarIO M.empty
currentCall <- newTVarIO Nothing
filesFolder <- newTVarIO Nothing filesFolder <- newTVarIO Nothing
pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, config, sendNotification, filesFolder} pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCall, config, sendNotification, filesFolder}
where where
resolveServers :: IO (NonEmpty SMPServer) resolveServers :: IO (NonEmpty SMPServer)
resolveServers = case user of resolveServers = case user of
@ -388,6 +389,12 @@ processChatCommand = \case
`E.finally` deleteContactRequest st userId connReqId `E.finally` deleteContactRequest st userId connReqId
withAgent $ \a -> rejectContact a connId invId withAgent $ \a -> rejectContact a connId invId
pure $ CRContactRequestRejected cReq pure $ CRContactRequestRejected cReq
APISendCallInvitation _contactId _callType -> pure $ chatCmdError "not implemented"
APIRejectCall _contactId -> pure $ chatCmdError "not implemented"
APISendCallOffer _contactId _wCallOffer -> pure $ chatCmdError "not implemented"
APISendCallAnswer _contactId _rtcSession -> pure $ chatCmdError "not implemented"
APISendCallExtraInfo _contactId _rtcExtraInfo -> pure $ chatCmdError "not implemented"
APIEndCall _contactId -> pure $ chatCmdError "not implemented"
APIUpdateProfile profile -> withUser (`updateProfile` profile) APIUpdateProfile profile -> withUser (`updateProfile` profile)
APIParseMarkdown text -> pure . CRApiParsedMarkdown $ parseMaybeMarkdownList text APIParseMarkdown text -> pure . CRApiParsedMarkdown $ parseMaybeMarkdownList text
APIRegisterToken token -> CRNtfTokenStatus <$> withUser (\_ -> withAgent (`registerNtfToken` token)) APIRegisterToken token -> CRNtfTokenStatus <$> withUser (\_ -> withAgent (`registerNtfToken` token))
@ -1881,6 +1888,12 @@ chatCommandP =
<|> "/_delete " *> (APIDeleteChat <$> chatRefP) <|> "/_delete " *> (APIDeleteChat <$> chatRefP)
<|> "/_accept " *> (APIAcceptContact <$> A.decimal) <|> "/_accept " *> (APIAcceptContact <$> A.decimal)
<|> "/_reject " *> (APIRejectContact <$> A.decimal) <|> "/_reject " *> (APIRejectContact <$> A.decimal)
<|> "/_call invite @" *> (APISendCallInvitation <$> A.decimal <* A.space <*> jsonP)
<|> "/_call reject @" *> (APIRejectCall <$> A.decimal)
<|> "/_call offer @" *> (APISendCallOffer <$> A.decimal <* A.space <*> jsonP)
<|> "/_call answer @" *> (APISendCallAnswer <$> A.decimal <* A.space <*> jsonP)
<|> "/_call extra @" *> (APISendCallExtraInfo <$> A.decimal <* A.space <*> jsonP)
<|> "/_call end @" *> (APIEndCall <$> A.decimal)
<|> "/_profile " *> (APIUpdateProfile <$> jsonP) <|> "/_profile " *> (APIUpdateProfile <$> jsonP)
<|> "/_parse " *> (APIParseMarkdown . safeDecodeUtf8 <$> A.takeByteString) <|> "/_parse " *> (APIParseMarkdown . safeDecodeUtf8 <$> A.takeByteString)
<|> "/_ntf register " *> (APIRegisterToken <$> tokenP) <|> "/_ntf register " *> (APIRegisterToken <$> tokenP)

170
src/Simplex/Chat/Call.hs Normal file
View file

@ -0,0 +1,170 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Simplex.Chat.Call where
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as J
import Data.ByteString.Char8 (ByteString)
import Data.Int (Int64)
import GHC.Generics (Generic)
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, enumJSON)
data Call = Call
{ contactId :: Int64,
callId :: CallId,
chatItemId :: Int64,
callState :: CallState
}
data CallState
= CallInvitationSent
{ localCallType :: CallType,
localDhPrivKey :: Maybe C.PrivateKeyX25519
}
| CallInvitationReceived
{ peerCallType :: CallType,
localDhPubKey :: Maybe C.PublicKeyX25519,
sharedKey :: Maybe C.Key
}
| CallOfferSent
{ localCallType :: CallType,
peerCallType :: CallType,
localCallSession :: WebRTCSession,
sharedKey :: Maybe C.Key
}
| CallOfferReceived
{ localCallType :: CallType,
peerCallType :: CallType,
peerCallSession :: WebRTCSession,
sharedKey :: Maybe C.Key
}
| CallNegotiated
{ localCallType :: CallType,
peerCallType :: CallType,
localCallSession :: WebRTCSession,
peerCallSession :: WebRTCSession,
sharedKey :: Maybe C.Key
}
newtype CallId = CallId ByteString
deriving (Eq, Show)
instance StrEncoding CallId where
strEncode (CallId m) = strEncode m
strDecode s = CallId <$> strDecode s
strP = CallId <$> strP
instance FromJSON CallId where
parseJSON = strParseJSON "CallId"
instance ToJSON CallId where
toJSON = strToJSON
toEncoding = strToJEncoding
data CallType = CallType
{ media :: CallMedia,
capabilities :: CallCapabilities
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON CallType where toEncoding = J.genericToEncoding J.defaultOptions
-- | * Types for chat protocol
data CallInvitation = CallInvitation
{ callType :: CallType,
callDhPubKey :: Maybe C.PublicKeyX25519
}
deriving (Eq, Show, Generic)
instance FromJSON CallInvitation where
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
instance ToJSON CallInvitation where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data CallMedia = CMAudio | CMVideo
deriving (Eq, Show, Generic)
instance FromJSON CallMedia where
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CM"
instance ToJSON CallMedia where
toJSON = J.genericToJSON . enumJSON $ dropPrefix "CM"
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CM"
data CallCapabilities = CallCapabilities
{ encryption :: Bool
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON CallCapabilities where
toJSON = J.genericToJSON J.defaultOptions
toEncoding = J.genericToEncoding J.defaultOptions
data CallOffer = CallOffer
{ callType :: CallType,
rtcSession :: WebRTCSession,
callDhPubKey :: Maybe C.PublicKeyX25519
}
deriving (Eq, Show, Generic)
instance FromJSON CallOffer where
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
instance ToJSON CallOffer where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
data WebRTCCallOffer = WebRTCCallOffer
{ callType :: CallType,
rtcSession :: WebRTCSession
}
deriving (Eq, Show, Generic)
instance FromJSON WebRTCCallOffer where
parseJSON = J.genericParseJSON J.defaultOptions {J.omitNothingFields = True}
data CallAnswer = CallAnswer
{ rtcSession :: WebRTCSession
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON CallAnswer where
toJSON = J.genericToJSON J.defaultOptions
toEncoding = J.genericToEncoding J.defaultOptions
data CallExtraInfo = CallExtraInfo
{ rtcExtraInfo :: WebRTCExtraInfo
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON CallExtraInfo where
toJSON = J.genericToJSON J.defaultOptions
toEncoding = J.genericToEncoding J.defaultOptions
data WebRTCSession = WebRTCSession
{ rtcSession :: J.Value,
rtcIceCandidates :: [J.Value]
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON WebRTCSession where
toJSON = J.genericToJSON J.defaultOptions
toEncoding = J.genericToEncoding J.defaultOptions
data WebRTCExtraInfo = WebRTCExtraInfo
{ rtcIceCandidates :: [J.Value]
}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON WebRTCExtraInfo where
toJSON = J.genericToJSON J.defaultOptions
toEncoding = J.genericToEncoding J.defaultOptions

View file

@ -26,6 +26,7 @@ import Data.Word (Word16)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Numeric.Natural import Numeric.Natural
import qualified Paths_simplex_chat as SC import qualified Paths_simplex_chat as SC
import Simplex.Chat.Call
import Simplex.Chat.Markdown (MarkdownList) import Simplex.Chat.Markdown (MarkdownList)
import Simplex.Chat.Messages import Simplex.Chat.Messages
import Simplex.Chat.Protocol import Simplex.Chat.Protocol
@ -80,6 +81,7 @@ data ChatController = ChatController
chatLock :: TMVar (), chatLock :: TMVar (),
sndFiles :: TVar (Map Int64 Handle), sndFiles :: TVar (Map Int64 Handle),
rcvFiles :: TVar (Map Int64 Handle), rcvFiles :: TVar (Map Int64 Handle),
currentCall :: TVar (Maybe Call),
config :: ChatConfig, config :: ChatConfig,
filesFolder :: TVar (Maybe FilePath) -- path to files folder for mobile apps filesFolder :: TVar (Maybe FilePath) -- path to files folder for mobile apps
} }
@ -108,6 +110,12 @@ data ChatCommand
| APIDeleteChat ChatRef | APIDeleteChat ChatRef
| APIAcceptContact Int64 | APIAcceptContact Int64
| APIRejectContact Int64 | APIRejectContact Int64
| APISendCallInvitation Int64 CallType
| APIRejectCall Int64
| APISendCallOffer Int64 WebRTCCallOffer
| APISendCallAnswer Int64 WebRTCSession
| APISendCallExtraInfo Int64 WebRTCExtraInfo
| APIEndCall Int64
| APIUpdateProfile Profile | APIUpdateProfile Profile
| APIParseMarkdown Text | APIParseMarkdown Text
| APIRegisterToken DeviceToken | APIRegisterToken DeviceToken
@ -240,6 +248,11 @@ data ChatResponse
| CRPendingSubSummary {pendingSubStatus :: [PendingSubStatus]} | CRPendingSubSummary {pendingSubStatus :: [PendingSubStatus]}
| CRSndFileSubError {sndFileTransfer :: SndFileTransfer, chatError :: ChatError} | CRSndFileSubError {sndFileTransfer :: SndFileTransfer, chatError :: ChatError}
| CRRcvFileSubError {rcvFileTransfer :: RcvFileTransfer, chatError :: ChatError} | CRRcvFileSubError {rcvFileTransfer :: RcvFileTransfer, chatError :: ChatError}
| CRCallInvitation {contact :: Contact, callType :: CallType, encryptionKey :: Maybe C.Key}
| CRCallOffer {contact :: Contact, callType :: CallType, offer :: WebRTCSession, encryptionKey :: Maybe C.Key, askConfirmation :: Bool}
| CRCallAnswer {contact :: Contact, answer :: WebRTCSession}
| CRCallExtraInfo {contact :: Contact, extraInfo :: WebRTCExtraInfo}
| CRCallEnded {contact :: Contact}
| CRUserContactLinkSubscribed | CRUserContactLinkSubscribed
| CRUserContactLinkSubError {chatError :: ChatError} | CRUserContactLinkSubError {chatError :: ChatError}
| CRNtfTokenStatus {status :: NtfTknStatus} | CRNtfTokenStatus {status :: NtfTknStatus}

View file

@ -20,6 +20,7 @@ import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Int (Int64) import Data.Int (Int64)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Text.Encoding (decodeLatin1, encodeUtf8)
import Data.Time.Clock (UTCTime, diffUTCTime, nominalDay) import Data.Time.Clock (UTCTime, diffUTCTime, nominalDay)
import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime) import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime)
@ -439,6 +440,8 @@ data CIContent (d :: MsgDirection) where
CIRcvMsgContent :: MsgContent -> CIContent 'MDRcv CIRcvMsgContent :: MsgContent -> CIContent 'MDRcv
CISndDeleted :: CIDeleteMode -> CIContent 'MDSnd CISndDeleted :: CIDeleteMode -> CIContent 'MDSnd
CIRcvDeleted :: CIDeleteMode -> CIContent 'MDRcv CIRcvDeleted :: CIDeleteMode -> CIContent 'MDRcv
CISndCall :: CICallStatus -> Int -> CIContent 'MDSnd
CIRcvCall :: CICallStatus -> Int -> CIContent 'MDRcv
deriving instance Show (CIContent d) deriving instance Show (CIContent d)
@ -448,6 +451,8 @@ ciContentToText = \case
CIRcvMsgContent mc -> msgContentText mc CIRcvMsgContent mc -> msgContentText mc
CISndDeleted cidm -> ciDeleteModeToText cidm CISndDeleted cidm -> ciDeleteModeToText cidm
CIRcvDeleted cidm -> ciDeleteModeToText cidm CIRcvDeleted cidm -> ciDeleteModeToText cidm
CISndCall status duration -> "outgoing call: " <> ciCallInfoText status duration
CIRcvCall status duration -> "incoming call: " <> ciCallInfoText status duration
msgDirToDeletedContent_ :: SMsgDirection d -> CIDeleteMode -> CIContent d msgDirToDeletedContent_ :: SMsgDirection d -> CIDeleteMode -> CIContent d
msgDirToDeletedContent_ msgDir mode = case msgDir of msgDirToDeletedContent_ msgDir mode = case msgDir of
@ -480,6 +485,8 @@ data JSONCIContent
| JCIRcvMsgContent {msgContent :: MsgContent} | JCIRcvMsgContent {msgContent :: MsgContent}
| JCISndDeleted {deleteMode :: CIDeleteMode} | JCISndDeleted {deleteMode :: CIDeleteMode}
| JCIRcvDeleted {deleteMode :: CIDeleteMode} | JCIRcvDeleted {deleteMode :: CIDeleteMode}
| JCISndCall {status :: CICallStatus, duration :: Int} -- duration in seconds
| JCIRcvCall {status :: CICallStatus, duration :: Int}
deriving (Generic) deriving (Generic)
instance FromJSON JSONCIContent where instance FromJSON JSONCIContent where
@ -495,6 +502,8 @@ jsonCIContent = \case
CIRcvMsgContent mc -> JCIRcvMsgContent mc CIRcvMsgContent mc -> JCIRcvMsgContent mc
CISndDeleted cidm -> JCISndDeleted cidm CISndDeleted cidm -> JCISndDeleted cidm
CIRcvDeleted cidm -> JCIRcvDeleted cidm CIRcvDeleted cidm -> JCIRcvDeleted cidm
CISndCall status duration -> JCISndCall {status, duration}
CIRcvCall status duration -> JCIRcvCall {status, duration}
aciContentJSON :: JSONCIContent -> ACIContent aciContentJSON :: JSONCIContent -> ACIContent
aciContentJSON = \case aciContentJSON = \case
@ -502,6 +511,8 @@ aciContentJSON = \case
JCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc JCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc
JCISndDeleted cidm -> ACIContent SMDSnd $ CISndDeleted cidm JCISndDeleted cidm -> ACIContent SMDSnd $ CISndDeleted cidm
JCIRcvDeleted cidm -> ACIContent SMDRcv $ CIRcvDeleted cidm JCIRcvDeleted cidm -> ACIContent SMDRcv $ CIRcvDeleted cidm
JCISndCall {status, duration} -> ACIContent SMDSnd $ CISndCall status duration
JCIRcvCall {status, duration} -> ACIContent SMDRcv $ CIRcvCall status duration
-- platform independent -- platform independent
data DBJSONCIContent data DBJSONCIContent
@ -509,6 +520,8 @@ data DBJSONCIContent
| DBJCIRcvMsgContent {msgContent :: MsgContent} | DBJCIRcvMsgContent {msgContent :: MsgContent}
| DBJCISndDeleted {deleteMode :: CIDeleteMode} | DBJCISndDeleted {deleteMode :: CIDeleteMode}
| DBJCIRcvDeleted {deleteMode :: CIDeleteMode} | DBJCIRcvDeleted {deleteMode :: CIDeleteMode}
| DBJCISndCall {status :: CICallStatus, duration :: Int}
| DBJCIRcvCall {status :: CICallStatus, duration :: Int}
deriving (Generic) deriving (Generic)
instance FromJSON DBJSONCIContent where instance FromJSON DBJSONCIContent where
@ -524,6 +537,8 @@ dbJsonCIContent = \case
CIRcvMsgContent mc -> DBJCIRcvMsgContent mc CIRcvMsgContent mc -> DBJCIRcvMsgContent mc
CISndDeleted cidm -> DBJCISndDeleted cidm CISndDeleted cidm -> DBJCISndDeleted cidm
CIRcvDeleted cidm -> DBJCIRcvDeleted cidm CIRcvDeleted cidm -> DBJCIRcvDeleted cidm
CISndCall status duration -> DBJCISndCall {status, duration}
CIRcvCall status duration -> DBJCIRcvCall {status, duration}
aciContentDBJSON :: DBJSONCIContent -> ACIContent aciContentDBJSON :: DBJSONCIContent -> ACIContent
aciContentDBJSON = \case aciContentDBJSON = \case
@ -531,6 +546,35 @@ aciContentDBJSON = \case
DBJCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc DBJCIRcvMsgContent mc -> ACIContent SMDRcv $ CIRcvMsgContent mc
DBJCISndDeleted cidm -> ACIContent SMDSnd $ CISndDeleted cidm DBJCISndDeleted cidm -> ACIContent SMDSnd $ CISndDeleted cidm
DBJCIRcvDeleted cidm -> ACIContent SMDRcv $ CIRcvDeleted cidm DBJCIRcvDeleted cidm -> ACIContent SMDRcv $ CIRcvDeleted cidm
DBJCISndCall {status, duration} -> ACIContent SMDSnd $ CISndCall status duration
DBJCIRcvCall {status, duration} -> ACIContent SMDRcv $ CIRcvCall status duration
data CICallStatus
= CISCallPending
| CISCallMissed
| CISCallRejected -- only possible for received calls, not on type level
| CISCallProgress
| CISCallEnded
| CISCallError
deriving (Show, Generic)
instance FromJSON CICallStatus where
parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "CISCall"
instance ToJSON CICallStatus where
toJSON = J.genericToJSON . enumJSON $ dropPrefix "CISCall"
toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "CISCall"
ciCallInfoText :: CICallStatus -> Int -> Text
ciCallInfoText status duration = case status of
CISCallPending -> "calling..."
CISCallMissed -> "missed"
CISCallRejected -> "rejected"
CISCallProgress -> "in progress " <> d
CISCallEnded -> "ended " <> d
CISCallError -> "error"
where
d = let (mins, secs) = duration `divMod` 60 in T.pack $ "(" <> show mins <> ":" <> show secs <> ")"
data SChatType (c :: ChatType) where data SChatType (c :: ChatType) where
SCTDirect :: SChatType 'CTDirect SCTDirect :: SChatType 'CTDirect
@ -548,11 +592,11 @@ instance TestEquality SChatType where
testEquality _ _ = Nothing testEquality _ _ = Nothing
class ChatTypeI (c :: ChatType) where class ChatTypeI (c :: ChatType) where
chatType :: SChatType c chatTypeI :: SChatType c
instance ChatTypeI 'CTDirect where chatType = SCTDirect instance ChatTypeI 'CTDirect where chatTypeI = SCTDirect
instance ChatTypeI 'CTGroup where chatType = SCTGroup instance ChatTypeI 'CTGroup where chatTypeI = SCTGroup
data NewMessage = NewMessage data NewMessage = NewMessage
{ chatMsgEvent :: ChatMsgEvent, { chatMsgEvent :: ChatMsgEvent,

View file

@ -29,6 +29,7 @@ import Data.Time.Clock (UTCTime)
import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.FromField (FromField (..))
import Database.SQLite.Simple.ToField (ToField (..)) import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Simplex.Chat.Call
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Util (eitherToMaybe, safeDecodeUtf8) import Simplex.Chat.Util (eitherToMaybe, safeDecodeUtf8)
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
@ -132,6 +133,11 @@ data ChatMsgEvent
| XInfoProbe Probe | XInfoProbe Probe
| XInfoProbeCheck ProbeHash | XInfoProbeCheck ProbeHash
| XInfoProbeOk Probe | XInfoProbeOk Probe
| XCallInv CallId CallInvitation
| XCallOffer CallId CallOffer
| XCallAnswer CallId CallAnswer
| XCallExtra CallId CallExtraInfo
| XCallEnd CallId
| XOk | XOk
| XUnknown {event :: Text, params :: J.Object} | XUnknown {event :: Text, params :: J.Object}
deriving (Eq, Show) deriving (Eq, Show)
@ -306,6 +312,11 @@ data CMEventTag
| XInfoProbe_ | XInfoProbe_
| XInfoProbeCheck_ | XInfoProbeCheck_
| XInfoProbeOk_ | XInfoProbeOk_
| XCallInv_
| XCallOffer_
| XCallAnswer_
| XCallExtra_
| XCallEnd_
| XOk_ | XOk_
| XUnknown_ Text | XUnknown_ Text
deriving (Eq, Show) deriving (Eq, Show)
@ -336,6 +347,11 @@ instance StrEncoding CMEventTag where
XInfoProbe_ -> "x.info.probe" XInfoProbe_ -> "x.info.probe"
XInfoProbeCheck_ -> "x.info.probe.check" XInfoProbeCheck_ -> "x.info.probe.check"
XInfoProbeOk_ -> "x.info.probe.ok" XInfoProbeOk_ -> "x.info.probe.ok"
XCallInv_ -> "x.call.inv"
XCallOffer_ -> "x.call.offer"
XCallAnswer_ -> "x.call.answer"
XCallExtra_ -> "x.call.extra"
XCallEnd_ -> "x.call.end"
XOk_ -> "x.ok" XOk_ -> "x.ok"
XUnknown_ t -> encodeUtf8 t XUnknown_ t -> encodeUtf8 t
strDecode = \case strDecode = \case
@ -363,6 +379,11 @@ instance StrEncoding CMEventTag where
"x.info.probe" -> Right XInfoProbe_ "x.info.probe" -> Right XInfoProbe_
"x.info.probe.check" -> Right XInfoProbeCheck_ "x.info.probe.check" -> Right XInfoProbeCheck_
"x.info.probe.ok" -> Right XInfoProbeOk_ "x.info.probe.ok" -> Right XInfoProbeOk_
"x.call.inv" -> Right XCallInv_
"x.call.offer" -> Right XCallOffer_
"x.call.answer" -> Right XCallAnswer_
"x.call.extra" -> Right XCallExtra_
"x.call.end" -> Right XCallEnd_
"x.ok" -> Right XOk_ "x.ok" -> Right XOk_
t -> Right . XUnknown_ $ safeDecodeUtf8 t t -> Right . XUnknown_ $ safeDecodeUtf8 t
strP = strDecode <$?> A.takeTill (== ' ') strP = strDecode <$?> A.takeTill (== ' ')
@ -393,6 +414,11 @@ toCMEventTag = \case
XInfoProbe _ -> XInfoProbe_ XInfoProbe _ -> XInfoProbe_
XInfoProbeCheck _ -> XInfoProbeCheck_ XInfoProbeCheck _ -> XInfoProbeCheck_
XInfoProbeOk _ -> XInfoProbeOk_ XInfoProbeOk _ -> XInfoProbeOk_
XCallInv _ _ -> XCallInv_
XCallOffer _ _ -> XCallOffer_
XCallAnswer _ _ -> XCallAnswer_
XCallExtra _ _ -> XCallExtra_
XCallEnd _ -> XCallEnd_
XOk -> XOk_ XOk -> XOk_
XUnknown t _ -> XUnknown_ t XUnknown t _ -> XUnknown_ t
@ -441,6 +467,11 @@ appToChatMessage AppMessage {msgId, event, params} = do
XInfoProbe_ -> XInfoProbe <$> p "probe" XInfoProbe_ -> XInfoProbe <$> p "probe"
XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash" XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash"
XInfoProbeOk_ -> XInfoProbeOk <$> p "probe" XInfoProbeOk_ -> XInfoProbeOk <$> p "probe"
XCallInv_ -> XCallInv <$> p "callId" <*> p "invitation"
XCallOffer_ -> XCallOffer <$> p "callId" <*> p "offer"
XCallAnswer_ -> XCallAnswer <$> p "callId" <*> p "answer"
XCallExtra_ -> XCallExtra <$> p "callId" <*> p "extra"
XCallEnd_ -> XCallEnd <$> p "callId"
XOk_ -> pure XOk XOk_ -> pure XOk
XUnknown_ t -> pure $ XUnknown t params XUnknown_ t -> pure $ XUnknown t params
@ -476,6 +507,11 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p
XInfoProbe probe -> o ["probe" .= probe] XInfoProbe probe -> o ["probe" .= probe]
XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash] XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash]
XInfoProbeOk probe -> o ["probe" .= probe] XInfoProbeOk probe -> o ["probe" .= probe]
XCallInv callId inv -> o ["callId" .= callId, "invitation" .= inv]
XCallOffer callId offer -> o ["callId" .= callId, "offer" .= offer]
XCallAnswer callId answer -> o ["callId" .= callId, "answer" .= answer]
XCallExtra callId extra -> o ["callId" .= callId, "extra" .= extra]
XCallEnd callId -> o ["callId" .= callId]
XOk -> JM.empty XOk -> JM.empty
XUnknown _ ps -> ps XUnknown _ ps -> ps

View file

@ -139,6 +139,11 @@ responseToView testView = \case
["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e] ["sent file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
CRRcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e -> CRRcvFileSubError RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}} e ->
["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e] ["received file " <> sShow fileId <> " (" <> plain fileName <> ") error: " <> sShow e]
CRCallInvitation {} -> []
CRCallOffer {} -> []
CRCallAnswer {} -> []
CRCallExtraInfo {} -> []
CRCallEnded {} -> []
CRUserContactLinkSubscribed -> ["Your address is active! To show: " <> highlight' "/sa"] CRUserContactLinkSubscribed -> ["Your address is active! To show: " <> highlight' "/sa"]
CRUserContactLinkSubError e -> ["user address error: " <> sShow e, "to delete your address: " <> highlight' "/da"] CRUserContactLinkSubError e -> ["user address error: " <> sShow e, "to delete your address: " <> highlight' "/da"]
CRNewContactConnection _ -> [] CRNewContactConnection _ -> []
@ -185,11 +190,13 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} = case cha
CIDirectSnd -> case content of CIDirectSnd -> case content of
CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc
CISndDeleted _ -> [] CISndDeleted _ -> []
CISndCall {} -> []
where where
to = ttyToContact' c to = ttyToContact' c
CIDirectRcv -> case content of CIDirectRcv -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvDeleted _ -> [] CIRcvDeleted _ -> []
CIRcvCall {} -> []
where where
from = ttyFromContact' c from = ttyFromContact' c
where where
@ -198,11 +205,13 @@ viewChatItem chat ChatItem {chatDir, meta, content, quotedItem, file} = case cha
CIGroupSnd -> case content of CIGroupSnd -> case content of
CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc CISndMsgContent mc -> withSndFile to $ sndMsg to quote mc
CISndDeleted _ -> [] CISndDeleted _ -> []
CISndCall {} -> []
where where
to = ttyToGroup g to = ttyToGroup g
CIGroupRcv m -> case content of CIGroupRcv m -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvDeleted _ -> [] CIRcvDeleted _ -> []
CIRcvCall {} -> []
where where
from = ttyFromGroup' g m from = ttyFromGroup' g m
where where