IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: chat preference for audio/video calls (#2188)

Browse Source 
* core: chat preference for audio/video calls

* correction

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>

* clean up

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin 2023-04-17 11:18:04 +02:00 committed by GitHub
parent 5b4c183466
commit b6876712f0
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
9 changed files with 140 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
src/Simplex/Chat.hs
View File

@ -800,19 +800,22 @@ processChatCommand = \case
-- party initiating call -- party initiating call
ct <- withStore $ \db -> getContact db user contactId ct <- withStore $ \db -> getContact db user contactId
assertDirectAllowed user MDSnd ct XCallInv_ assertDirectAllowed user MDSnd ct XCallInv_
calls <- asks currentCalls if featureAllowed SCFCalls forUser ct
withChatLock "sendCallInvitation" $ do then do
callId <- CallId <$> drgRandomBytes 16 calls <- asks currentCalls
dhKeyPair <- if encryptedCall callType then Just <$> liftIO C.generateKeyPair' else pure Nothing withChatLock "sendCallInvitation" $ do
let invitation = CallInvitation {callType, callDhPubKey = fst <$> dhKeyPair} callId <- CallId <$> drgRandomBytes 16
callState = CallInvitationSent {localCallType = callType, localDhPrivKey = snd <$> dhKeyPair} dhKeyPair <- if encryptedCall callType then Just <$> liftIO C.generateKeyPair' else pure Nothing
(msg, _) <- sendDirectContactMessage ct (XCallInv callId invitation) let invitation = CallInvitation {callType, callDhPubKey = fst <$> dhKeyPair}
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndCall CISCallPending 0) callState = CallInvitationSent {localCallType = callType, localDhPrivKey = snd <$> dhKeyPair}
let call' = Call {contactId, callId, chatItemId = chatItemId' ci, callState, callTs = chatItemTs' ci} (msg, _) <- sendDirectContactMessage ct (XCallInv callId invitation)
call_ <- atomically $ TM.lookupInsert contactId call' calls ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndCall CISCallPending 0)
forM_ call_ $ \call -> updateCallItemStatus user ct call WCSDisconnected Nothing let call' = Call {contactId, callId, chatItemId = chatItemId' ci, callState, callTs = chatItemTs' ci}
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci) call_ <- atomically $ TM.lookupInsert contactId call' calls
ok user forM_ call_ $ \call -> updateCallItemStatus user ct call WCSDisconnected Nothing
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
ok user
else pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (chatFeatureNameText CFCalls))
SendCallInvitation cName callType -> withUser $ \user -> do SendCallInvitation cName callType -> withUser $ \user -> do
contactId <- withStore $ \db -> getContactIdByName db user cName contactId <- withStore $ \db -> getContactIdByName db user cName
processChatCommand $ APISendCallInvitation contactId callType processChatCommand $ APISendCallInvitation contactId callType
@ -3586,24 +3589,30 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
-- to party accepting call -- to party accepting call
xCallInv :: Contact -> CallId -> CallInvitation -> RcvMessage -> MsgMeta -> m () 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 {sharedMsgId_} msgMeta = do
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
dhKeyPair <- if encryptedCall callType then Just <$> liftIO C.generateKeyPair' else pure Nothing if featureAllowed SCFCalls forContact ct
ci <- saveCallItem CISCallPending then do
let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> (snd <$> dhKeyPair)) dhKeyPair <- if encryptedCall callType then Just <$> liftIO C.generateKeyPair' else pure Nothing
callState = CallInvitationReceived {peerCallType = callType, localDhPubKey = fst <$> dhKeyPair, sharedKey} ci <- saveCallItem CISCallPending
call' = Call {contactId, callId, chatItemId = chatItemId' ci, callState, callTs = chatItemTs' ci} let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> (snd <$> dhKeyPair))
calls <- asks currentCalls callState = CallInvitationReceived {peerCallType = callType, localDhPubKey = fst <$> dhKeyPair, sharedKey}
-- theoretically, the new call invitation for the current contact can mark the in-progress call as ended call' = Call {contactId, callId, chatItemId = chatItemId' ci, callState, callTs = chatItemTs' ci}
-- (and replace it in ChatController) calls <- asks currentCalls
-- practically, this should not happen -- theoretically, the new call invitation for the current contact can mark the in-progress call as ended
withStore' $ \db -> createCall db user call' $ chatItemTs' ci -- (and replace it in ChatController)
call_ <- atomically (TM.lookupInsert contactId call' calls) -- practically, this should not happen
forM_ call_ $ \call -> updateCallItemStatus user ct call WCSDisconnected Nothing withStore' $ \db -> createCall db user call' $ chatItemTs' ci
toView $ CRCallInvitation RcvCallInvitation {user, contact = ct, callType, sharedKey, callTs = chatItemTs' ci} call_ <- atomically (TM.lookupInsert contactId call' calls)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) forM_ call_ $ \call -> updateCallItemStatus user ct call WCSDisconnected Nothing
toView $ CRCallInvitation RcvCallInvitation {user, contact = ct, callType, sharedKey, callTs = chatItemTs' ci}
toView $ CRNewChatItem user $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
else featureRejected CFCalls
where where
saveCallItem status = saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvCall status 0) saveCallItem status = saveRcvChatItem user (CDDirectRcv ct) msg msgMeta (CIRcvCall status 0)
featureRejected f = do
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta (CIRcvChatFeatureRejected f) Nothing Nothing False
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
-- to party initiating call -- to party initiating call
xCallOffer :: Contact -> CallId -> CallOffer -> RcvMessage -> MsgMeta -> m () xCallOffer :: Contact -> CallId -> CallOffer -> RcvMessage -> MsgMeta -> m ()
@ -4659,6 +4668,8 @@ chatCommandP =
"/set voice #" *> (SetGroupFeature (AGF SGFVoice) <$> displayName <*> (A.space *> strP)), "/set voice #" *> (SetGroupFeature (AGF SGFVoice) <$> displayName <*> (A.space *> strP)),
"/set voice @" *> (SetContactFeature (ACF SCFVoice) <$> displayName <*> optional (A.space *> strP)), "/set voice @" *> (SetContactFeature (ACF SCFVoice) <$> displayName <*> optional (A.space *> strP)),
"/set voice " *> (SetUserFeature (ACF SCFVoice) <$> strP), "/set voice " *> (SetUserFeature (ACF SCFVoice) <$> strP),
"/set calls @" *> (SetContactFeature (ACF SCFCalls) <$> displayName <*> optional (A.space *> strP)),
"/set calls " *> (SetUserFeature (ACF SCFCalls) <$> strP),
"/set delete #" *> (SetGroupFeature (AGF SGFFullDelete) <$> displayName <*> (A.space *> strP)), "/set delete #" *> (SetGroupFeature (AGF SGFFullDelete) <$> displayName <*> (A.space *> strP)),
"/set delete @" *> (SetContactFeature (ACF SCFFullDelete) <$> displayName <*> optional (A.space *> strP)), "/set delete @" *> (SetContactFeature (ACF SCFFullDelete) <$> displayName <*> optional (A.space *> strP)),
"/set delete " *> (SetUserFeature (ACF SCFFullDelete) <$> strP), "/set delete " *> (SetUserFeature (ACF SCFFullDelete) <$> strP),

2
src/Simplex/Chat/Call.hs
View File

@ -21,7 +21,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.Types (Contact, ContactId, decodeJSON, encodeJSON, User) import Simplex.Chat.Types (Contact, ContactId, User, decodeJSON, encodeJSON)
import qualified Simplex.Messaging.Crypto as C import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Encoding.String import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, fstToLower, singleFieldJSON) import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, fstToLower, singleFieldJSON)

49
src/Simplex/Chat/Types.hs
View File

@ -343,12 +343,14 @@ data ChatFeature
| CFFullDelete | CFFullDelete
| -- | CFReceipts | -- | CFReceipts
CFVoice CFVoice
| CFCalls
deriving (Show, Generic) deriving (Show, Generic)
data SChatFeature (f :: ChatFeature) where data SChatFeature (f :: ChatFeature) where
SCFTimedMessages :: SChatFeature 'CFTimedMessages SCFTimedMessages :: SChatFeature 'CFTimedMessages
SCFFullDelete :: SChatFeature 'CFFullDelete SCFFullDelete :: SChatFeature 'CFFullDelete
SCFVoice :: SChatFeature 'CFVoice SCFVoice :: SChatFeature 'CFVoice
SCFCalls :: SChatFeature 'CFCalls
deriving instance Show (SChatFeature f) deriving instance Show (SChatFeature f)
@ -361,6 +363,7 @@ chatFeatureNameText = \case
CFTimedMessages -> "Disappearing messages" CFTimedMessages -> "Disappearing messages"
CFFullDelete -> "Full deletion" CFFullDelete -> "Full deletion"
CFVoice -> "Voice messages" CFVoice -> "Voice messages"
CFCalls -> "Audio/video calls"
chatFeatureNameText' :: SChatFeature f -> Text chatFeatureNameText' :: SChatFeature f -> Text
chatFeatureNameText' = chatFeatureNameText . chatFeature chatFeatureNameText' = chatFeatureNameText . chatFeature
@ -382,7 +385,8 @@ allChatFeatures =
[ ACF SCFTimedMessages, [ ACF SCFTimedMessages,
ACF SCFFullDelete, ACF SCFFullDelete,
-- CFReceipts, -- CFReceipts,
ACF SCFVoice ACF SCFVoice,
ACF SCFCalls
] ]
chatPrefSel :: SChatFeature f -> Preferences -> Maybe (FeaturePreference f) chatPrefSel :: SChatFeature f -> Preferences -> Maybe (FeaturePreference f)
@ -391,12 +395,14 @@ chatPrefSel = \case
SCFFullDelete -> fullDelete SCFFullDelete -> fullDelete
-- CFReceipts -> receipts -- CFReceipts -> receipts
SCFVoice -> voice SCFVoice -> voice
SCFCalls -> calls
chatFeature :: SChatFeature f -> ChatFeature chatFeature :: SChatFeature f -> ChatFeature
chatFeature = \case chatFeature = \case
SCFTimedMessages -> CFTimedMessages SCFTimedMessages -> CFTimedMessages
SCFFullDelete -> CFFullDelete SCFFullDelete -> CFFullDelete
SCFVoice -> CFVoice SCFVoice -> CFVoice
SCFCalls -> CFCalls
class PreferenceI p where class PreferenceI p where
getPreference :: SChatFeature f -> p -> FeaturePreference f getPreference :: SChatFeature f -> p -> FeaturePreference f
@ -413,6 +419,7 @@ instance PreferenceI FullPreferences where
SCFFullDelete -> fullDelete SCFFullDelete -> fullDelete
-- CFReceipts -> receipts -- CFReceipts -> receipts
SCFVoice -> voice SCFVoice -> voice
SCFCalls -> calls
{-# INLINE getPreference #-} {-# INLINE getPreference #-}
setPreference :: forall f. FeatureI f => SChatFeature f -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences setPreference :: forall f. FeatureI f => SChatFeature f -> Maybe FeatureAllowed -> Maybe Preferences -> Preferences
@ -432,13 +439,15 @@ setPreference_ f pref_ prefs =
SCFTimedMessages -> prefs {timedMessages = pref_} SCFTimedMessages -> prefs {timedMessages = pref_}
SCFFullDelete -> prefs {fullDelete = pref_} SCFFullDelete -> prefs {fullDelete = pref_}
SCFVoice -> prefs {voice = pref_} SCFVoice -> prefs {voice = pref_}
SCFCalls -> prefs {calls = pref_}
-- collection of optional chat preferences for the user and the contact -- collection of optional chat preferences for the user and the contact
data Preferences = Preferences data Preferences = Preferences
{ timedMessages :: Maybe TimedMessagesPreference, { timedMessages :: Maybe TimedMessagesPreference,
fullDelete :: Maybe FullDeletePreference, fullDelete :: Maybe FullDeletePreference,
-- receipts :: Maybe SimplePreference, -- receipts :: Maybe SimplePreference,
voice :: Maybe VoicePreference voice :: Maybe VoicePreference,
calls :: Maybe CallsPreference
} }
deriving (Eq, Show, Generic, FromJSON) deriving (Eq, Show, Generic, FromJSON)
@ -591,7 +600,8 @@ data FullPreferences = FullPreferences
{ timedMessages :: TimedMessagesPreference, { timedMessages :: TimedMessagesPreference,
fullDelete :: FullDeletePreference, fullDelete :: FullDeletePreference,
-- receipts :: SimplePreference, -- receipts :: SimplePreference,
voice :: VoicePreference voice :: VoicePreference,
calls :: CallsPreference
} }
deriving (Eq, Show, Generic, FromJSON) deriving (Eq, Show, Generic, FromJSON)
@ -615,7 +625,8 @@ data ContactUserPreferences = ContactUserPreferences
{ timedMessages :: ContactUserPreference TimedMessagesPreference, { timedMessages :: ContactUserPreference TimedMessagesPreference,
fullDelete :: ContactUserPreference FullDeletePreference, fullDelete :: ContactUserPreference FullDeletePreference,
-- receipts :: ContactUserPreference, -- receipts :: ContactUserPreference,
voice :: ContactUserPreference VoicePreference voice :: ContactUserPreference VoicePreference,
calls :: ContactUserPreference CallsPreference
} }
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)
@ -638,12 +649,13 @@ instance ToJSON p => ToJSON (ContactUserPref p) where
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CUP" toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CUP"
toChatPrefs :: FullPreferences -> Preferences toChatPrefs :: FullPreferences -> Preferences
toChatPrefs FullPreferences {fullDelete, voice, timedMessages} = toChatPrefs FullPreferences {fullDelete, voice, timedMessages, calls} =
Preferences Preferences
{ timedMessages = Just timedMessages, { timedMessages = Just timedMessages,
fullDelete = Just fullDelete, fullDelete = Just fullDelete,
-- receipts = Just receipts, -- receipts = Just receipts,
voice = Just voice voice = Just voice,
calls = Just calls
} }
defaultChatPrefs :: FullPreferences defaultChatPrefs :: FullPreferences
@ -652,11 +664,12 @@ defaultChatPrefs =
{ timedMessages = TimedMessagesPreference {allow = FANo, ttl = Nothing}, { timedMessages = TimedMessagesPreference {allow = FANo, ttl = Nothing},
fullDelete = FullDeletePreference {allow = FANo}, fullDelete = FullDeletePreference {allow = FANo},
-- receipts = SimplePreference {allow = FANo}, -- receipts = SimplePreference {allow = FANo},
voice = VoicePreference {allow = FAYes} voice = VoicePreference {allow = FAYes},
calls = CallsPreference {allow = FAYes}
} }
emptyChatPrefs :: Preferences emptyChatPrefs :: Preferences
emptyChatPrefs = Preferences Nothing Nothing Nothing emptyChatPrefs = Preferences Nothing Nothing Nothing Nothing
defaultGroupPrefs :: FullGroupPreferences defaultGroupPrefs :: FullGroupPreferences
defaultGroupPrefs = defaultGroupPrefs =
@ -691,6 +704,11 @@ data VoicePreference = VoicePreference {allow :: FeatureAllowed}
instance ToJSON VoicePreference where toEncoding = J.genericToEncoding J.defaultOptions instance ToJSON VoicePreference where toEncoding = J.genericToEncoding J.defaultOptions
data CallsPreference = CallsPreference {allow :: FeatureAllowed}
deriving (Eq, Show, Generic, FromJSON)
instance ToJSON CallsPreference where toEncoding = J.genericToEncoding J.defaultOptions
class (Eq (FeaturePreference f), HasField "allow" (FeaturePreference f) FeatureAllowed) => FeatureI f where class (Eq (FeaturePreference f), HasField "allow" (FeaturePreference f) FeatureAllowed) => FeatureI f where
type FeaturePreference (f :: ChatFeature) = p | p -> f type FeaturePreference (f :: ChatFeature) = p | p -> f
sFeature :: SChatFeature f sFeature :: SChatFeature f
@ -705,6 +723,9 @@ instance HasField "allow" FullDeletePreference FeatureAllowed where
instance HasField "allow" VoicePreference FeatureAllowed where instance HasField "allow" VoicePreference FeatureAllowed where
hasField p = (\allow -> p {allow}, allow (p :: VoicePreference)) hasField p = (\allow -> p {allow}, allow (p :: VoicePreference))
instance HasField "allow" CallsPreference FeatureAllowed where
hasField p = (\allow -> p {allow}, allow (p :: CallsPreference))
instance FeatureI 'CFTimedMessages where instance FeatureI 'CFTimedMessages where
type FeaturePreference 'CFTimedMessages = TimedMessagesPreference type FeaturePreference 'CFTimedMessages = TimedMessagesPreference
sFeature = SCFTimedMessages sFeature = SCFTimedMessages
@ -720,6 +741,11 @@ instance FeatureI 'CFVoice where
sFeature = SCFVoice sFeature = SCFVoice
prefParam _ = Nothing prefParam _ = Nothing
instance FeatureI 'CFCalls where
type FeaturePreference 'CFCalls = CallsPreference
sFeature = SCFCalls
prefParam _ = Nothing
data GroupPreference = GroupPreference data GroupPreference = GroupPreference
{enable :: GroupFeatureEnabled} {enable :: GroupFeatureEnabled}
deriving (Eq, Show, Generic, FromJSON) deriving (Eq, Show, Generic, FromJSON)
@ -897,7 +923,8 @@ mergePreferences contactPrefs userPreferences =
{ timedMessages = pref SCFTimedMessages, { timedMessages = pref SCFTimedMessages,
fullDelete = pref SCFFullDelete, fullDelete = pref SCFFullDelete,
-- receipts = pref CFReceipts, -- receipts = pref CFReceipts,
voice = pref SCFVoice voice = pref SCFVoice,
calls = pref SCFCalls
} }
where where
pref :: SChatFeature f -> FeaturePreference f pref :: SChatFeature f -> FeaturePreference f
@ -1006,7 +1033,8 @@ contactUserPreferences user userPreferences contactPreferences connectedIncognit
{ timedMessages = pref SCFTimedMessages, { timedMessages = pref SCFTimedMessages,
fullDelete = pref SCFFullDelete, fullDelete = pref SCFFullDelete,
-- receipts = pref CFReceipts, -- receipts = pref CFReceipts,
voice = pref SCFVoice voice = pref SCFVoice,
calls = pref SCFCalls
} }
where where
pref :: FeatureI f => SChatFeature f -> ContactUserPreference (FeaturePreference f) pref :: FeatureI f => SChatFeature f -> ContactUserPreference (FeaturePreference f)
@ -1033,6 +1061,7 @@ getContactUserPreference = \case
SCFFullDelete -> fullDelete SCFFullDelete -> fullDelete
-- CFReceipts -> receipts -- CFReceipts -> receipts
SCFVoice -> voice SCFVoice -> voice
SCFCalls -> calls
data Profile = Profile data Profile = Profile
{ displayName :: ContactName, { displayName :: ContactName,

19
tests/ChatTests/Direct.hs
View File

@ -138,9 +138,9 @@ testAddContact = versionTestMatrix2 runTestAddContact
bob #$> ("/clear alice", id, "alice: all messages are removed locally ONLY") bob #$> ("/clear alice", id, "alice: all messages are removed locally ONLY")
bob #$> ("/_get chat @2 count=100", chat, []) bob #$> ("/_get chat @2 count=100", chat, [])
chatsEmpty alice bob = do chatsEmpty alice bob = do
alice @@@ [("@bob", "Voice messages: enabled")] alice @@@ [("@bob", lastChatFeature)]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures) alice #$> ("/_get chat @2 count=100", chat, chatFeatures)
bob @@@ [("@alice", "Voice messages: enabled")] bob @@@ [("@alice", lastChatFeature)]
bob #$> ("/_get chat @2 count=100", chat, chatFeatures) bob #$> ("/_get chat @2 count=100", chat, chatFeatures)
chatsOneMessage alice bob = do chatsOneMessage alice bob = do
alice @@@ [("@bob", "hello there 🙂")] alice @@@ [("@bob", "hello there 🙂")]
@ -289,7 +289,7 @@ testDirectMessageDelete =
alice #$> ("/_delete item @2 " <> itemId 1 <> " internal", id, "message deleted") alice #$> ("/_delete item @2 " <> itemId 1 <> " internal", id, "message deleted")
alice #$> ("/_delete item @2 " <> itemId 2 <> " internal", id, "message deleted") alice #$> ("/_delete item @2 " <> itemId 2 <> " internal", id, "message deleted")
alice @@@ [("@bob", "Voice messages: enabled")] alice @@@ [("@bob", lastChatFeature)]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures) alice #$> ("/_get chat @2 count=100", chat, chatFeatures)
-- alice: msg id 1 -- alice: msg id 1
@ -309,7 +309,7 @@ testDirectMessageDelete =
-- alice: deletes msg id 1 that was broadcast deleted by bob -- alice: deletes msg id 1 that was broadcast deleted by bob
alice #$> ("/_delete item @2 " <> itemId 1 <> " internal", id, "message deleted") alice #$> ("/_delete item @2 " <> itemId 1 <> " internal", id, "message deleted")
alice @@@ [("@bob", "Voice messages: enabled")] alice @@@ [("@bob", lastChatFeature)]
alice #$> ("/_get chat @2 count=100", chat, chatFeatures) alice #$> ("/_get chat @2 count=100", chat, chatFeatures)
-- alice: msg id 1, bob: msg id 3 (quoting message alice deleted locally) -- alice: msg id 1, bob: msg id 3 (quoting message alice deleted locally)
@ -349,13 +349,13 @@ testDirectLiveMessage =
connectUsers alice bob connectUsers alice bob
-- non-empty live message is sent instantly -- non-empty live message is sent instantly
alice `send` "/live @bob hello" alice `send` "/live @bob hello"
bob <# "alice> [LIVE started] use /show [on/off/4] hello" bob <# "alice> [LIVE started] use /show [on/off/5] hello"
alice ##> ("/_update item @2 " <> itemId 1 <> " text hello there") alice ##> ("/_update item @2 " <> itemId 1 <> " text hello there")
alice <# "@bob [LIVE] hello there" alice <# "@bob [LIVE] hello there"
bob <# "alice> [LIVE ended] hello there" bob <# "alice> [LIVE ended] hello there"
-- empty live message is also sent instantly -- empty live message is also sent instantly
alice `send` "/live @bob" alice `send` "/live @bob"
bob <# "alice> [LIVE started] use /show [on/off/5]" bob <# "alice> [LIVE started] use /show [on/off/6]"
alice ##> ("/_update item @2 " <> itemId 2 <> " text hello 2") alice ##> ("/_update item @2 " <> itemId 2 <> " text hello 2")
alice <# "@bob [LIVE] hello 2" alice <# "@bob [LIVE] hello 2"
bob <# "alice> [LIVE ended] hello 2" bob <# "alice> [LIVE ended] hello 2"
@ -955,7 +955,7 @@ testMultipleUserAddresses =
(bob <## "alice (Alice): contact is connected") (bob <## "alice (Alice): contact is connected")
(alice <## "bob (Bob): contact is connected") (alice <## "bob (Bob): contact is connected")
threadDelay 100000 threadDelay 100000
alice @@@ [("@bob", "Voice messages: enabled")] alice @@@ [("@bob", lastChatFeature)]
alice <##> bob alice <##> bob
alice ##> "/create user alisa" alice ##> "/create user alisa"
@ -973,7 +973,7 @@ testMultipleUserAddresses =
(bob <## "alisa: contact is connected") (bob <## "alisa: contact is connected")
(alice <## "bob (Bob): contact is connected") (alice <## "bob (Bob): contact is connected")
threadDelay 100000 threadDelay 100000
alice #$> ("/_get chats 2 pcc=on", chats, [("@bob", "Voice messages: enabled")]) alice #$> ("/_get chats 2 pcc=on", chats, [("@bob", lastChatFeature)])
alice <##> bob alice <##> bob
bob #> "@alice hey alice" bob #> "@alice hey alice"
@ -1004,7 +1004,7 @@ testMultipleUserAddresses =
(cath <## "alisa: contact is connected") (cath <## "alisa: contact is connected")
(alice <## "cath (Catherine): contact is connected") (alice <## "cath (Catherine): contact is connected")
threadDelay 100000 threadDelay 100000
alice #$> ("/_get chats 2 pcc=on", chats, [("@cath", "Voice messages: enabled"), ("@bob", "hey")]) alice #$> ("/_get chats 2 pcc=on", chats, [("@cath", lastChatFeature), ("@bob", "hey")])
alice <##> cath alice <##> cath
-- first user doesn't have cath as contact -- first user doesn't have cath as contact
@ -1585,6 +1585,7 @@ testUserPrivacy =
<##? [ "bob> Disappearing messages: off", <##? [ "bob> Disappearing messages: off",
"bob> Full deletion: off", "bob> Full deletion: off",
"bob> Voice messages: enabled", "bob> Voice messages: enabled",
"bob> Audio/video calls: enabled",
"@bob hello", "@bob hello",
"bob> hey", "bob> hey",
"bob> hello again", "bob> hello again",

52
tests/ChatTests/Groups.hs
View File

@ -329,30 +329,34 @@ testGroup2 =
<##? [ "dan> hi", <##? [ "dan> hi",
"@dan hey" "@dan hey"
] ]
alice ##> "/t 21" -- TODO this fails returning only 23 lines out of 24
alice -- alice ##> "/t 24"
<##? [ "@bob sent invitation to join group club as admin", -- alice
"@cath sent invitation to join group club as admin", -- <##? [ "@bob sent invitation to join group club as admin",
"#club bob> connected", -- "@cath sent invitation to join group club as admin",
"#club cath> connected", -- "#club bob> connected",
"#club bob> added dan (Daniel)", -- "#club cath> connected",
"#club dan> connected", -- "#club bob> added dan (Daniel)", -- either this is missing
"#club hello", -- "#club dan> connected",
"#club bob> hi there", -- "#club hello",
"#club cath> hey", -- "#club bob> hi there",
"#club dan> how is it going?", -- "#club cath> hey",
"dan> hi", -- "#club dan> how is it going?",
"@dan hey", -- "dan> hi",
"dan> Disappearing messages: off", -- "@dan hey",
"dan> Full deletion: off", -- "dan> Disappearing messages: off",
"dan> Voice messages: enabled", -- "dan> Full deletion: off",
"bob> Disappearing messages: off", -- "dan> Voice messages: enabled",
"bob> Full deletion: off", -- "dan> Audio/video calls: enabled",
"bob> Voice messages: enabled", -- "bob> Disappearing messages: off", -- or this one
"cath> Disappearing messages: off", -- "bob> Full deletion: off",
"cath> Full deletion: off", -- "bob> Voice messages: enabled",
"cath> Voice messages: enabled" -- "bob> Audio/video calls: enabled",
] -- "cath> Disappearing messages: off",
-- "cath> Full deletion: off",
-- "cath> Voice messages: enabled",
-- "cath> Audio/video calls: enabled"
-- ]
-- remove member -- remove member
cath ##> "/rm club dan" cath ##> "/rm club dan"
concurrentlyN_ concurrentlyN_

26
tests/ChatTests/Profiles.hs
View File

@ -119,7 +119,7 @@ testUserContactLink = versionTestMatrix3 $ \alice bob cath -> do
(bob <## "alice (Alice): contact is connected") (bob <## "alice (Alice): contact is connected")
(alice <## "bob (Bob): contact is connected") (alice <## "bob (Bob): contact is connected")
threadDelay 100000 threadDelay 100000
alice @@@ [("@bob", "Voice messages: enabled")] alice @@@ [("@bob", lastChatFeature)]
alice <##> bob alice <##> bob
cath ##> ("/c " <> cLink) cath ##> ("/c " <> cLink)
@ -131,7 +131,7 @@ testUserContactLink = versionTestMatrix3 $ \alice bob cath -> do
(cath <## "alice (Alice): contact is connected") (cath <## "alice (Alice): contact is connected")
(alice <## "cath (Catherine): contact is connected") (alice <## "cath (Catherine): contact is connected")
threadDelay 100000 threadDelay 100000
alice @@@ [("@cath", "Voice messages: enabled"), ("@bob", "hey")] alice @@@ [("@cath", lastChatFeature), ("@bob", "hey")]
alice <##> cath alice <##> cath
testUserContactLinkAutoAccept :: HasCallStack => FilePath -> IO () testUserContactLinkAutoAccept :: HasCallStack => FilePath -> IO ()
@ -150,7 +150,7 @@ testUserContactLinkAutoAccept =
(bob <## "alice (Alice): contact is connected") (bob <## "alice (Alice): contact is connected")
(alice <## "bob (Bob): contact is connected") (alice <## "bob (Bob): contact is connected")
threadDelay 100000 threadDelay 100000
alice @@@ [("@bob", "Voice messages: enabled")] alice @@@ [("@bob", lastChatFeature)]
alice <##> bob alice <##> bob
alice ##> "/auto_accept on" alice ##> "/auto_accept on"
@ -163,7 +163,7 @@ testUserContactLinkAutoAccept =
(cath <## "alice (Alice): contact is connected") (cath <## "alice (Alice): contact is connected")
(alice <## "cath (Catherine): contact is connected") (alice <## "cath (Catherine): contact is connected")
threadDelay 100000 threadDelay 100000
alice @@@ [("@cath", "Voice messages: enabled"), ("@bob", "hey")] alice @@@ [("@cath", lastChatFeature), ("@bob", "hey")]
alice <##> cath alice <##> cath
alice ##> "/auto_accept off" alice ##> "/auto_accept off"
@ -178,7 +178,7 @@ testUserContactLinkAutoAccept =
(dan <## "alice (Alice): contact is connected") (dan <## "alice (Alice): contact is connected")
(alice <## "dan (Daniel): contact is connected") (alice <## "dan (Daniel): contact is connected")
threadDelay 100000 threadDelay 100000
alice @@@ [("@dan", "Voice messages: enabled"), ("@cath", "hey"), ("@bob", "hey")] alice @@@ [("@dan", lastChatFeature), ("@cath", "hey"), ("@bob", "hey")]
alice <##> dan alice <##> dan
testDeduplicateContactRequests :: HasCallStack => FilePath -> IO () testDeduplicateContactRequests :: HasCallStack => FilePath -> IO ()
@ -207,8 +207,8 @@ testDeduplicateContactRequests = testChat3 aliceProfile bobProfile cathProfile $
bob ##> ("/c " <> cLink) bob ##> ("/c " <> cLink)
bob <## "alice (Alice): contact already exists" bob <## "alice (Alice): contact already exists"
alice @@@ [("@bob", "Voice messages: enabled")] alice @@@ [("@bob", lastChatFeature)]
bob @@@ [("@alice", "Voice messages: enabled"), (":2", ""), (":1", "")] bob @@@ [("@alice", lastChatFeature), (":2", ""), (":1", "")]
bob ##> "/_delete :1" bob ##> "/_delete :1"
bob <## "connection :1 deleted" bob <## "connection :1 deleted"
bob ##> "/_delete :2" bob ##> "/_delete :2"
@ -234,7 +234,7 @@ testDeduplicateContactRequests = testChat3 aliceProfile bobProfile cathProfile $
(cath <## "alice (Alice): contact is connected") (cath <## "alice (Alice): contact is connected")
(alice <## "cath (Catherine): contact is connected") (alice <## "cath (Catherine): contact is connected")
threadDelay 100000 threadDelay 100000
alice @@@ [("@cath", "Voice messages: enabled"), ("@bob", "hey")] alice @@@ [("@cath", lastChatFeature), ("@bob", "hey")]
alice <##> cath alice <##> cath
testDeduplicateContactRequestsProfileChange :: HasCallStack => FilePath -> IO () testDeduplicateContactRequestsProfileChange :: HasCallStack => FilePath -> IO ()
@ -278,8 +278,8 @@ testDeduplicateContactRequestsProfileChange = testChat3 aliceProfile bobProfile
bob ##> ("/c " <> cLink) bob ##> ("/c " <> cLink)
bob <## "alice (Alice): contact already exists" bob <## "alice (Alice): contact already exists"
alice @@@ [("@robert", "Voice messages: enabled")] alice @@@ [("@robert", lastChatFeature)]
bob @@@ [("@alice", "Voice messages: enabled"), (":3", ""), (":2", ""), (":1", "")] bob @@@ [("@alice", lastChatFeature), (":3", ""), (":2", ""), (":1", "")]
bob ##> "/_delete :1" bob ##> "/_delete :1"
bob <## "connection :1 deleted" bob <## "connection :1 deleted"
bob ##> "/_delete :2" bob ##> "/_delete :2"
@ -307,7 +307,7 @@ testDeduplicateContactRequestsProfileChange = testChat3 aliceProfile bobProfile
(cath <## "alice (Alice): contact is connected") (cath <## "alice (Alice): contact is connected")
(alice <## "cath (Catherine): contact is connected") (alice <## "cath (Catherine): contact is connected")
threadDelay 100000 threadDelay 100000
alice @@@ [("@cath", "Voice messages: enabled"), ("@robert", "hey")] alice @@@ [("@cath", lastChatFeature), ("@robert", "hey")]
alice <##> cath alice <##> cath
testRejectContactAndDeleteUserContact :: HasCallStack => FilePath -> IO () testRejectContactAndDeleteUserContact :: HasCallStack => FilePath -> IO ()
@ -954,7 +954,7 @@ testSetConnectionAlias = testChat2 aliceProfile bobProfile $
(alice <## "bob (Bob): contact is connected") (alice <## "bob (Bob): contact is connected")
(bob <## "alice (Alice): contact is connected") (bob <## "alice (Alice): contact is connected")
threadDelay 100000 threadDelay 100000
alice @@@ [("@bob", "Voice messages: enabled")] alice @@@ [("@bob", lastChatFeature)]
alice ##> "/contacts" alice ##> "/contacts"
alice <## "bob (Bob) (alias: friend)" alice <## "bob (Bob) (alias: friend)"
@ -976,7 +976,7 @@ testSetContactPrefs = testChat2 aliceProfile bobProfile $
alice ##> "/_set prefs @2 {}" alice ##> "/_set prefs @2 {}"
alice <## "your preferences for bob did not change" alice <## "your preferences for bob did not change"
(bob </) (bob </)
let startFeatures = [(0, "Disappearing messages: off"), (0, "Full deletion: off"), (0, "Voice messages: off")] let startFeatures = [(0, "Disappearing messages: off"), (0, "Full deletion: off"), (0, "Voice messages: off"), (0, "Audio/video calls: enabled")]
alice #$> ("/_get chat @2 count=100", chat, startFeatures) alice #$> ("/_get chat @2 count=100", chat, startFeatures)
bob #$> ("/_get chat @2 count=100", chat, startFeatures) bob #$> ("/_get chat @2 count=100", chat, startFeatures)
let sendVoice = "/_send @2 json {\"filePath\": \"test.txt\", \"msgContent\": {\"type\": \"voice\", \"text\": \"\", \"duration\": 10}}" let sendVoice = "/_send @2 json {\"filePath\": \"test.txt\", \"msgContent\": {\"type\": \"voice\", \"text\": \"\", \"duration\": 10}}"

5
tests/ChatTests/Utils.hs
View File

@ -183,7 +183,10 @@ chatFeaturesF :: [((Int, String), Maybe String)]
chatFeaturesF = map (\(a, _, c) -> (a, c)) chatFeatures'' chatFeaturesF = map (\(a, _, c) -> (a, c)) chatFeatures''
chatFeatures'' :: [((Int, String), Maybe (Int, String), Maybe String)] chatFeatures'' :: [((Int, String), Maybe (Int, String), Maybe String)]
chatFeatures'' = [((0, "Disappearing messages: off"), Nothing, Nothing), ((0, "Full deletion: off"), Nothing, Nothing), ((0, "Voice messages: enabled"), Nothing, Nothing)] chatFeatures'' = [((0, "Disappearing messages: off"), Nothing, Nothing), ((0, "Full deletion: off"), Nothing, Nothing), ((0, "Voice messages: enabled"), Nothing, Nothing), ((0, "Audio/video calls: enabled"), Nothing, Nothing)]
lastChatFeature :: String
lastChatFeature = snd $ last chatFeatures
groupFeatures :: [(Int, String)] groupFeatures :: [(Int, String)]
groupFeatures = map (\(a, _, _) -> a) groupFeatures'' groupFeatures = map (\(a, _, _) -> a) groupFeatures''

10
tests/MobileTests.hs
View File

@ -26,16 +26,16 @@ noActiveUser = "{\"resp\":{\"type\":\"chatCmdError\",\"chatError\":{\"type\":\"e
activeUserExists :: String activeUserExists :: String
#if defined(darwin_HOST_OS) && defined(swiftJSON) #if defined(darwin_HOST_OS) && defined(swiftJSON)
activeUserExists = "{\"resp\":{\"chatCmdError\":{\"user_\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\"},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true},\"chatError\":{\"error\":{\"errorType\":{\"userExists\":{\"contactName\":\"alice\"}}}}}}}" activeUserExists = "{\"resp\":{\"chatCmdError\":{\"user_\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\"},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"},\"calls\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true},\"chatError\":{\"error\":{\"errorType\":{\"userExists\":{\"contactName\":\"alice\"}}}}}}}"
#else #else
activeUserExists = "{\"resp\":{\"type\":\"chatCmdError\",\"user_\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\"},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true},\"chatError\":{\"type\":\"error\",\"errorType\":{\"type\":\"userExists\",\"contactName\":\"alice\"}}}}" activeUserExists = "{\"resp\":{\"type\":\"chatCmdError\",\"user_\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\"},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"},\"calls\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true},\"chatError\":{\"type\":\"error\",\"errorType\":{\"type\":\"userExists\",\"contactName\":\"alice\"}}}}"
#endif #endif
activeUser :: String activeUser :: String
#if defined(darwin_HOST_OS) && defined(swiftJSON) #if defined(darwin_HOST_OS) && defined(swiftJSON)
activeUser = "{\"resp\":{\"activeUser\":{\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\"},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true}}}}" activeUser = "{\"resp\":{\"activeUser\":{\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\"},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"},\"calls\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true}}}}"
#else #else
activeUser = "{\"resp\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\"},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true}}}" activeUser = "{\"resp\":{\"type\":\"activeUser\",\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\"},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"},\"calls\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true}}}"
#endif #endif
chatStarted :: String chatStarted :: String
@ -74,7 +74,7 @@ pendingSubSummary = "{\"resp\":{\"type\":\"pendingSubSummary\"," <> userJSON <>
#endif #endif
userJSON :: String userJSON :: String
userJSON = "\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\"},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true}" userJSON = "\"user\":{\"userId\":1,\"agentUserId\":\"1\",\"userContactId\":1,\"localDisplayName\":\"alice\",\"profile\":{\"profileId\":1,\"displayName\":\"alice\",\"fullName\":\"Alice\",\"localAlias\":\"\"},\"fullPreferences\":{\"timedMessages\":{\"allow\":\"no\"},\"fullDelete\":{\"allow\":\"no\"},\"voice\":{\"allow\":\"yes\"},\"calls\":{\"allow\":\"yes\"}},\"activeUser\":true,\"showNtfs\":true}"
parsedMarkdown :: String parsedMarkdown :: String
#if defined(darwin_HOST_OS) && defined(swiftJSON) #if defined(darwin_HOST_OS) && defined(swiftJSON)

2
tests/ProtocolTests.hs
View File

@ -86,7 +86,7 @@ s #==# msg = do
s ==# msg s ==# msg
testChatPreferences :: Maybe Preferences testChatPreferences :: Maybe Preferences
testChatPreferences = Just Preferences {voice = Just VoicePreference {allow = FAYes}, fullDelete = Nothing, timedMessages = Nothing} testChatPreferences = Just Preferences {voice = Just VoicePreference {allow = FAYes}, fullDelete = Nothing, timedMessages = Nothing, calls = Nothing}
testGroupPreferences :: Maybe GroupPreferences testGroupPreferences :: Maybe GroupPreferences
testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, voice = Just VoiceGroupPreference {enable = FEOn}, fullDelete = Nothing} testGroupPreferences = Just GroupPreferences {timedMessages = Nothing, directMessages = Nothing, voice = Just VoiceGroupPreference {enable = FEOn}, fullDelete = Nothing}