{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use newtype instead of data" #-} module Simplex.Chat.Call where import Data.Aeson (FromJSON (..), ToJSON (..)) import qualified Data.Aeson.TH as J import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) import Data.Int (Int64) import Data.Text (Text) import Data.Time.Clock (UTCTime) import Simplex.Chat.Options.DB (FromField (..), ToField (..)) import Simplex.Chat.Types (Contact, ContactId, User) import Simplex.Messaging.Agent.Store.DB (Binary (..), fromTextField_) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Encoding.String import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, enumJSON, fstToLower, singleFieldJSON) import Simplex.Messaging.Util (decodeJSON, encodeJSON) data Call = Call { contactId :: ContactId, callId :: CallId, callUUID :: Text, chatItemId :: Int64, callState :: CallState, callTs :: UTCTime } deriving (Show) isRcvInvitation :: Call -> Bool isRcvInvitation Call {callState} = case callState of CallInvitationReceived {} -> True _ -> False data CallStateTag = CSTCallInvitationSent | CSTCallInvitationReceived | CSTCallOfferSent | CSTCallOfferReceived | CSTCallNegotiated deriving (Show) callStateTag :: CallState -> CallStateTag callStateTag = \case CallInvitationSent {} -> CSTCallInvitationSent CallInvitationReceived {} -> CSTCallInvitationReceived CallOfferSent {} -> CSTCallOfferSent CallOfferReceived {} -> CSTCallOfferReceived CallNegotiated {} -> CSTCallNegotiated 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 } deriving (Show) newtype CallId = CallId ByteString deriving (Eq, Show) deriving newtype (FromField) instance ToField CallId where toField (CallId m) = toField $ Binary m 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 RcvCallInvitation = RcvCallInvitation { user :: User, contact :: Contact, callType :: CallType, sharedKey :: Maybe C.Key, callUUID :: Text, callTs :: UTCTime } deriving (Show) data CallType = CallType { media :: CallMedia, capabilities :: CallCapabilities } deriving (Eq, Show) defaultCallType :: CallType defaultCallType = CallType CMVideo $ CallCapabilities {encryption = True} encryptedCall :: CallType -> Bool encryptedCall CallType {capabilities = CallCapabilities {encryption}} = encryption -- | * Types for chat protocol data CallInvitation = CallInvitation { callType :: CallType, callDhPubKey :: Maybe C.PublicKeyX25519 } deriving (Eq, Show) data CallMedia = CMAudio | CMVideo deriving (Eq, Show) data CallCapabilities = CallCapabilities { encryption :: Bool } deriving (Eq, Show) data CallOffer = CallOffer { callType :: CallType, rtcSession :: WebRTCSession, callDhPubKey :: Maybe C.PublicKeyX25519 } deriving (Eq, Show) data WebRTCCallOffer = WebRTCCallOffer { callType :: CallType, rtcSession :: WebRTCSession } deriving (Eq, Show) data CallAnswer = CallAnswer { rtcSession :: WebRTCSession } deriving (Eq, Show) data CallExtraInfo = CallExtraInfo { rtcExtraInfo :: WebRTCExtraInfo } deriving (Eq, Show) data WebRTCSession = WebRTCSession { rtcSession :: Text, -- LZW compressed JSON encoding of offer or answer rtcIceCandidates :: Text -- LZW compressed JSON encoding of array of ICE candidates } deriving (Eq, Show) data WebRTCExtraInfo = WebRTCExtraInfo { rtcIceCandidates :: Text -- LZW compressed JSON encoding of array of ICE candidates } deriving (Eq, Show) data WebRTCCallStatus = WCSConnecting | WCSConnected | WCSDisconnected | WCSFailed deriving (Show) instance StrEncoding WebRTCCallStatus where strEncode = \case WCSConnecting -> "connecting" WCSConnected -> "connected" WCSDisconnected -> "disconnected" WCSFailed -> "failed" strP = A.takeTill (== ' ') >>= \case "connecting" -> pure WCSConnecting "connected" -> pure WCSConnected "disconnected" -> pure WCSDisconnected "failed" -> pure WCSFailed _ -> fail "bad WebRTCCallStatus" $(J.deriveJSON (enumJSON $ dropPrefix "CSTCall") ''CallStateTag) $(J.deriveJSON (enumJSON $ dropPrefix "CM") ''CallMedia) $(J.deriveJSON defaultJSON ''CallCapabilities) $(J.deriveJSON defaultJSON ''CallType) $(J.deriveJSON defaultJSON ''CallInvitation) $(J.deriveJSON defaultJSON ''WebRTCSession) $(J.deriveJSON defaultJSON ''CallOffer) $(J.deriveJSON defaultJSON ''WebRTCCallOffer) $(J.deriveJSON defaultJSON ''CallAnswer) $(J.deriveJSON defaultJSON ''WebRTCExtraInfo) $(J.deriveJSON defaultJSON ''CallExtraInfo) -- database representation $(J.deriveJSON (singleFieldJSON fstToLower) ''CallState) instance ToField CallState where toField = toField . encodeJSON instance FromField CallState where fromField = fromTextField_ decodeJSON $(J.deriveJSON defaultJSON ''RcvCallInvitation)