dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-03-30 18:35:49 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: ratchet synchronization (#2653)

Browse Source
This commit is contained in:
spaced4ndy
2023-07-05 19:44:21 +04:00
committed by GitHub
parent c329bf4ea1
commit ae17566a94
10 changed files with 411 additions and 132 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
cabal.project
View File

@@ -7,7 +7,7 @@ constraints: zip +disable-bzip2 +disable-zstd
source-repository-package
type: git
location: https://github.com/simplex-chat/simplexmq.git
tag: fe22d9b299f106fc4a3d167e90499ddb4d3bfa26
tag: f2657f9c0b954f952aaf381bb9b55ac34ea59ed7
source-repository-package
type: git

2
scripts/nix/sha256map.nix
View File

@@ -1,5 +1,5 @@
{
"https://github.com/simplex-chat/simplexmq.git"."fe22d9b299f106fc4a3d167e90499ddb4d3bfa26" = "1hk6cb7bh5nn3cj6wb38ap2kyg16ajff6mk5xj6vpjh5dgpp8hkb";
"https://github.com/simplex-chat/simplexmq.git"."f2657f9c0b954f952aaf381bb9b55ac34ea59ed7" = "04qhadd0shs4hj5b62i78jhnq5c620b72naqavqirvjc7pymyq5g";
"https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
"https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
"https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";

120
src/Simplex/Chat.hs
View File

@@ -1134,6 +1134,19 @@ processChatCommand = \case
connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId
pure $ CRGroupMemberSwitchAborted user g m connectionStats
_ -> throwChatError CEGroupMemberNotActive
APISyncContactRatchet contactId force -> withUser $ \user -> do
ct <- withStore $ \db -> getContact db user contactId
cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a (contactConnId ct) force
createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCERatchetSync rss Nothing) Nothing
pure $ CRContactRatchetSyncStarted user ct cStats
APISyncGroupMemberRatchet gId gMemberId force -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
case memberConnId m of
Just connId -> do
cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId force
createInternalChatItem user (CDGroupSnd g) (CISndConnEvent . SCERatchetSync rss . Just $ groupMemberRef m) Nothing
pure $ CRGroupMemberRatchetSyncStarted user g m cStats
_ -> throwChatError CEGroupMemberNotActive
APIGetContactCode contactId -> withUser $ \user -> do
ct@Contact {activeConn = conn@Connection {connId}} <- withStore $ \db -> getContact db user contactId
code <- getConnectionCode (contactConnId ct)
@@ -1196,6 +1209,8 @@ processChatCommand = \case
SwitchGroupMember gName mName -> withMemberName gName mName APISwitchGroupMember
AbortSwitchContact cName -> withContactName cName APIAbortSwitchContact
AbortSwitchGroupMember gName mName -> withMemberName gName mName APIAbortSwitchGroupMember
SyncContactRatchet cName force -> withContactName cName $ \ctId -> APISyncContactRatchet ctId force
SyncGroupMemberRatchet gName mName force -> withMemberName gName mName $ \gId mId -> APISyncGroupMemberRatchet gId mId force
GetContactCode cName -> withContactName cName APIGetContactCode
GetGroupMemberCode gName mName -> withMemberName gName mName APIGetGroupMemberCode
VerifyContact cName code -> withContactName cName (`APIVerifyContact` code)
@@ -2716,7 +2731,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> Nothing
processDirectMessage :: ACommand 'Agent e -> ConnectionEntity -> Connection -> Maybe Contact -> m ()
processDirectMessage agentMsg connEntity conn@Connection {connId, viaUserContactLink, groupLinkId, customUserProfileId} = \case
processDirectMessage agentMsg connEntity conn@Connection {connId, viaUserContactLink, groupLinkId, customUserProfileId, connectionCode} = \case
Nothing -> case agentMsg of
CONF confId _ connInfo -> do
-- [incognito] send saved profile
@@ -2849,6 +2864,36 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
when (phase `elem` [SPStarted, SPCompleted]) $ case qd of
QDRcv -> createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCESwitchQueue phase Nothing) Nothing
QDSnd -> createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing
RSYNC rss cryptoErr_ cStats ->
case (rss, connectionCode, cryptoErr_) of
(RSRequired, _, Just cryptoErr) -> processErr cryptoErr
(RSAllowed, _, Just cryptoErr) -> processErr cryptoErr
(RSAgreed, Just _, _) -> do
withStore' $ \db -> setConnectionVerified db user connId Nothing
let ct' = ct {activeConn = conn {connectionCode = Nothing}} :: Contact
ratchetSyncEventItem ct'
toView $ CRContactVerificationReset user ct'
createInternalChatItem user (CDDirectRcv ct') (CIRcvConnEvent RCEVerificationCodeReset) Nothing
_ -> ratchetSyncEventItem ct
where
processErr cryptoErr = do
let e@(mde, n) = agentMsgDecryptError cryptoErr
ci_ <- withStore $ \db ->
getDirectChatItemsLast db user contactId 1 ""
>>= liftIO
. mapM (\(ci, content') -> updateDirectChatItem' db user contactId ci content' False Nothing)
. (mdeUpdatedCI e <=< headMaybe)
case ci_ of
Just ci -> toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
_ -> do
toView $ CRContactRatchetSync user ct (RatchetSyncProgress rss cStats)
createInternalChatItem user (CDDirectRcv ct) (CIRcvDecryptionError mde n) Nothing
headMaybe = \case
x : _ -> Just x
_ -> Nothing
ratchetSyncEventItem ct' = do
toView $ CRContactRatchetSync user ct' (RatchetSyncProgress rss cStats)
createInternalChatItem user (CDDirectRcv ct') (CIRcvConnEvent $ RCERatchetSync rss) Nothing
OK ->
-- [async agent commands] continuation on receiving OK
withCompletedCommand conn agentMsg $ \CommandData {cmdFunction, cmdId} ->
@@ -2863,24 +2908,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ERR err -> do
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
forM_ (agentMsgDecryptError err) $ \e@(mde, n) -> do
ci_ <- withStore $ \db ->
getDirectChatItemsLast db user contactId 1 ""
>>= liftIO
. mapM (\(ci, content') -> updateDirectChatItem' db user contactId ci content' False Nothing)
. (mdeUpdatedCI e <=< headMaybe)
case ci_ of
Just ci -> toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
_ -> createInternalChatItem user (CDDirectRcv ct) (CIRcvDecryptionError mde n) Nothing
where
headMaybe = \case
x : _ -> Just x
_ -> Nothing
-- TODO add debugging output
_ -> pure ()
processGroupMessage :: ACommand 'Agent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> m ()
processGroupMessage agentMsg connEntity conn@Connection {connId} gInfo@GroupInfo {groupId, localDisplayName = gName, groupProfile, membership, chatSettings} m = case agentMsg of
processGroupMessage agentMsg connEntity conn@Connection {connId, connectionCode} gInfo@GroupInfo {groupId, localDisplayName = gName, groupProfile, membership, chatSettings} m = case agentMsg of
INV (ACR _ cReq) ->
withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} ->
case cReq of
@@ -3028,6 +3060,33 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
when (phase `elem` [SPStarted, SPCompleted]) $ case qd of
QDRcv -> createInternalChatItem user (CDGroupSnd gInfo) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing
QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing
RSYNC rss cryptoErr_ cStats ->
case (rss, connectionCode, cryptoErr_) of
(RSRequired, _, Just cryptoErr) -> processErr cryptoErr
(RSAllowed, _, Just cryptoErr) -> processErr cryptoErr
(RSAgreed, Just _, _) -> do
withStore' $ \db -> setConnectionVerified db user connId Nothing
let m' = m {activeConn = Just (conn {connectionCode = Nothing} :: Connection)} :: GroupMember
ratchetSyncEventItem m'
toView $ CRGroupMemberVerificationReset user gInfo m'
createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent RCEVerificationCodeReset) Nothing
_ -> ratchetSyncEventItem m
where
processErr cryptoErr = do
let e@(mde, n) = agentMsgDecryptError cryptoErr
ci_ <- withStore $ \db ->
getGroupMemberChatItemLast db user groupId (groupMemberId' m)
>>= liftIO
. mapM (\(ci, content') -> updateGroupChatItem db user groupId ci content' False Nothing)
. mdeUpdatedCI e
case ci_ of
Just ci -> toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
_ -> do
toView $ CRGroupMemberRatchetSync user gInfo m (RatchetSyncProgress rss cStats)
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvDecryptionError mde n) Nothing
ratchetSyncEventItem m' = do
toView $ CRGroupMemberRatchetSync user gInfo m' (RatchetSyncProgress rss cStats)
createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent $ RCERatchetSync rss) Nothing
OK ->
-- [async agent commands] continuation on receiving OK
withCompletedCommand conn agentMsg $ \CommandData {cmdFunction, cmdId} ->
@@ -3038,35 +3097,24 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
ERR err -> do
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
forM_ (agentMsgDecryptError err) $ \e@(mde, n) -> do
ci_ <- withStore $ \db ->
getGroupMemberChatItemLast db user groupId (groupMemberId' m)
>>= liftIO
. mapM (\(ci, content') -> updateGroupChatItem db user groupId ci content' False Nothing)
. mdeUpdatedCI e
case ci_ of
Just ci -> toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
_ -> createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvDecryptionError mde n) Nothing
-- TODO add debugging output
_ -> pure ()
agentMsgDecryptError :: AgentErrorType -> Maybe (MsgDecryptError, Word32)
agentMsgDecryptError :: AgentCryptoError -> (MsgDecryptError, Word32)
agentMsgDecryptError = \case
AGENT (A_CRYPTO RATCHET_HEADER) -> Just (MDERatchetHeader, 1)
AGENT (A_CRYPTO (RATCHET_SKIPPED n)) -> Just (MDETooManySkipped, n)
-- we are not treating this as decryption error, as in many cases it happens as the result of duplicate or redundant delivery,
-- and we don't have a way to differentiate.
-- we could store the hashes of past messages in the agent, or delaying message deletion after ACK
-- A_DUPLICATE -> Nothing
-- earlier messages may be received in case of redundant delivery, and do not necessarily indicate an error
-- AGENT (A_CRYPTO (RATCHET_EARLIER n)) -> Nothing
_ -> Nothing
DECRYPT_AES -> (MDEOther, 1)
DECRYPT_CB -> (MDEOther, 1)
RATCHET_HEADER -> (MDERatchetHeader, 1)
RATCHET_EARLIER _ -> (MDERatchetEarlier, 1)
RATCHET_SKIPPED n -> (MDETooManySkipped, n)
mdeUpdatedCI :: (MsgDecryptError, Word32) -> CChatItem c -> Maybe (ChatItem c 'MDRcv, CIContent 'MDRcv)
mdeUpdatedCI (mde', n') (CChatItem _ ci@ChatItem {content = CIRcvDecryptionError mde n})
| mde == mde' = case mde of
MDERatchetHeader -> r (n + n')
MDETooManySkipped -> r n' -- the numbers are not added as sequential MDETooManySkipped will have it incremented by 1
MDERatchetEarlier -> r (n + n')
MDEOther -> r (n + n')
| otherwise = Nothing
where
r n'' = Just (ci, CIRcvDecryptionError mde n'')
@@ -4919,10 +4967,14 @@ chatCommandP =
"/_switch @" *> (APISwitchContact <$> A.decimal),
"/_abort switch #" *> (APIAbortSwitchGroupMember <$> A.decimal <* A.space <*> A.decimal),
"/_abort switch @" *> (APIAbortSwitchContact <$> A.decimal),
"/_sync #" *> (APISyncGroupMemberRatchet <$> A.decimal <* A.space <*> A.decimal <*> (" force=on" $> True <|> pure False)),
"/_sync @" *> (APISyncContactRatchet <$> A.decimal <*> (" force=on" $> True <|> pure False)),
"/switch #" *> (SwitchGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName),
"/switch " *> char_ '@' *> (SwitchContact <$> displayName),
"/abort switch #" *> (AbortSwitchGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName),
"/abort switch " *> char_ '@' *> (AbortSwitchContact <$> displayName),
"/sync #" *> (SyncGroupMemberRatchet <$> displayName <* A.space <* char_ '@' <*> displayName <*> (" force=on" $> True <|> pure False)),
"/sync " *> char_ '@' *> (SyncContactRatchet <$> displayName <*> (" force=on" $> True <|> pure False)),
"/_get code @" *> (APIGetContactCode <$> A.decimal),
"/_get code #" *> (APIGetGroupMemberCode <$> A.decimal <* A.space <*> A.decimal),
"/_verify code @" *> (APIVerifyContact <$> A.decimal <*> optional (A.space *> textP)),

18
src/Simplex/Chat/Controller.hs
View File

@@ -287,6 +287,8 @@ data ChatCommand
| APISwitchGroupMember GroupId GroupMemberId
| APIAbortSwitchContact ContactId
| APIAbortSwitchGroupMember GroupId GroupMemberId
| APISyncContactRatchet ContactId Bool
| APISyncGroupMemberRatchet GroupId GroupMemberId Bool
| APIGetContactCode ContactId
| APIGetGroupMemberCode GroupId GroupMemberId
| APIVerifyContact ContactId (Maybe Text)
@@ -300,6 +302,8 @@ data ChatCommand
| SwitchGroupMember GroupName ContactName
| AbortSwitchContact ContactName
| AbortSwitchGroupMember GroupName ContactName
| SyncContactRatchet ContactName Bool
| SyncGroupMemberRatchet GroupName ContactName Bool
| GetContactCode ContactName
| GetGroupMemberCode GroupName ContactName
| VerifyContact ContactName (Maybe Text)
@@ -415,6 +419,12 @@ data ChatResponse
| CRGroupMemberSwitchAborted {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats :: ConnectionStats}
| CRContactSwitch {user :: User, contact :: Contact, switchProgress :: SwitchProgress}
| CRGroupMemberSwitch {user :: User, groupInfo :: GroupInfo, member :: GroupMember, switchProgress :: SwitchProgress}
| CRContactRatchetSyncStarted {user :: User, contact :: Contact, connectionStats :: ConnectionStats}
| CRGroupMemberRatchetSyncStarted {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats :: ConnectionStats}
| CRContactRatchetSync {user :: User, contact :: Contact, ratchetSyncProgress :: RatchetSyncProgress}
| CRGroupMemberRatchetSync {user :: User, groupInfo :: GroupInfo, member :: GroupMember, ratchetSyncProgress :: RatchetSyncProgress}
| CRContactVerificationReset {user :: User, contact :: Contact}
| CRGroupMemberVerificationReset {user :: User, groupInfo :: GroupInfo, member :: GroupMember}
| CRContactCode {user :: User, contact :: Contact, connectionCode :: Text}
| CRGroupMemberCode {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionCode :: Text}
| CRConnectionVerified {user :: User, verified :: Bool, expectedCode :: Text}
@@ -719,6 +729,14 @@ data SwitchProgress = SwitchProgress
instance ToJSON SwitchProgress where toEncoding = J.genericToEncoding J.defaultOptions
data RatchetSyncProgress = RatchetSyncProgress
{ ratchetSyncStatus :: RatchetSyncState,
connectionStats :: ConnectionStats
}
deriving (Show, Generic)
instance ToJSON RatchetSyncProgress where toEncoding = J.genericToEncoding J.defaultOptions
data ParsedServerAddress = ParsedServerAddress
{ serverAddress :: Maybe ServerAddress,
parseError :: String

37
src/Simplex/Chat/Messages/CIContent.hs
View File

@@ -29,7 +29,7 @@ import Database.SQLite.Simple.ToField (ToField (..))
import GHC.Generics (Generic)
import Simplex.Chat.Protocol
import Simplex.Chat.Types
import Simplex.Messaging.Agent.Protocol (MsgErrorType (..), SwitchPhase (..))
import Simplex.Messaging.Agent.Protocol (MsgErrorType (..), RatchetSyncState (..), SwitchPhase (..))
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fstToLower, singleFieldJSON, sumTypeJSON)
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
@@ -157,7 +157,7 @@ ciMsgContent = \case
CIRcvMsgContent mc -> Just mc
_ -> Nothing
data MsgDecryptError = MDERatchetHeader | MDETooManySkipped
data MsgDecryptError = MDERatchetHeader | MDETooManySkipped | MDERatchetEarlier | MDEOther
deriving (Eq, Show, Generic)
instance ToJSON MsgDecryptError where
@@ -253,10 +253,15 @@ instance ToJSON DBSndGroupEvent where
toJSON (SGE v) = J.genericToJSON (singleFieldJSON $ dropPrefix "SGE") v
toEncoding (SGE v) = J.genericToEncoding (singleFieldJSON $ dropPrefix "SGE") v
data RcvConnEvent = RCESwitchQueue {phase :: SwitchPhase}
data RcvConnEvent
= RCESwitchQueue {phase :: SwitchPhase}
| RCERatchetSync {syncStatus :: RatchetSyncState}
| RCEVerificationCodeReset
deriving (Show, Generic)
data SndConnEvent = SCESwitchQueue {phase :: SwitchPhase, member :: Maybe GroupMemberRef}
data SndConnEvent
= SCESwitchQueue {phase :: SwitchPhase, member :: Maybe GroupMemberRef}
| SCERatchetSync {syncStatus :: RatchetSyncState, member :: Maybe GroupMemberRef}
deriving (Show, Generic)
instance FromJSON RcvConnEvent where
@@ -387,6 +392,16 @@ rcvConnEventToText = \case
SPConfirmed -> "confirmed changing address for you..."
SPSecured -> "secured new address for you..."
SPCompleted -> "changed address for you"
RCERatchetSync syncStatus -> ratchetSyncStatusToText syncStatus
RCEVerificationCodeReset -> "security code changed"
ratchetSyncStatusToText :: RatchetSyncState -> Text
ratchetSyncStatusToText = \case
RSOk -> "connection synchronized"
RSAllowed -> "decryption error (connection may be out of sync), synchronization allowed"
RSRequired -> "decryption error (connection out of sync), synchronization required"
RSStarted -> "connection synchronization started"
RSAgreed -> "connection synchronization agreed"
sndConnEventToText :: SndConnEvent -> Text
sndConnEventToText = \case
@@ -395,6 +410,7 @@ sndConnEventToText = \case
SPConfirmed -> "confirmed changing address" <> forMember m <> "..."
SPSecured -> "secured new address" <> forMember m <> "..."
SPCompleted -> "you changed address" <> forMember m
SCERatchetSync syncStatus m -> ratchetSyncStatusToText syncStatus <> forMember m
where
forMember member_ =
maybe "" (\GroupMemberRef {profile = Profile {displayName}} -> " for " <> displayName) member_
@@ -413,11 +429,16 @@ msgIntegrityError = \case
msgDecryptErrorText :: MsgDecryptError -> Word32 -> Text
msgDecryptErrorText err n =
"decryption error, possibly due to the device change (" <> errName <> if n == 1 then ")" else ", " <> tshow n <> " messages)"
"decryption error, possibly due to the device change"
<> maybe "" (\ed -> " (" <> ed <> ")") errDesc
where
errName = case err of
MDERatchetHeader -> "header"
MDETooManySkipped -> "too many skipped messages"
errDesc = case err of
MDERatchetHeader -> Just $ "header" <> counter
MDETooManySkipped -> Just $ "too many skipped messages" <> counter
MDERatchetEarlier -> Just $ "earlier message" <> counter
MDEOther -> counter_
counter_ = if n == 1 then Nothing else Just $ tshow n <> " messages"
counter = maybe "" (", " <>) counter_
msgDirToModeratedContent_ :: SMsgDirection d -> CIContent d
msgDirToModeratedContent_ = \case

3
src/Simplex/Chat/Store/Direct.hs
View File

@@ -627,9 +627,6 @@ getContactConnections db userId Contact {contactId} =
connections [] = throwError $ SEContactNotFound contactId
connections rows = pure $ map toConnection rows
getConnectionById :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Connection
getConnectionById db User {userId} connId = ExceptT $ do
firstRow toConnection (SEConnectionNotFoundById connId) $

34
src/Simplex/Chat/View.hs
View File

@@ -28,7 +28,6 @@ import Data.Time (LocalTime (..), TimeOfDay (..), TimeZone (..), utcToLocalTime)
import Data.Time.Calendar (addDays)
import Data.Time.Clock (UTCTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Word (Word32)
import GHC.Generics (Generic)
import qualified Network.HTTP.Types as Q
import Numeric (showFFloat)
@@ -86,6 +85,12 @@ responseToView user_ ChatConfig {logLevel, showReactions, testView} liveItems ts
CRGroupMemberSwitchAborted {} -> ["switch aborted"]
CRContactSwitch u ct progress -> ttyUser u $ viewContactSwitch ct progress
CRGroupMemberSwitch u g m progress -> ttyUser u $ viewGroupMemberSwitch g m progress
CRContactRatchetSyncStarted {} -> ["connection synchronization started"]
CRGroupMemberRatchetSyncStarted {} -> ["connection synchronization started"]
CRContactRatchetSync u ct progress -> ttyUser u $ viewContactRatchetSync ct progress
CRGroupMemberRatchetSync u g m progress -> ttyUser u $ viewGroupMemberRatchetSync g m progress
CRContactVerificationReset u ct -> ttyUser u $ viewContactVerificationReset ct
CRGroupMemberVerificationReset u g m -> ttyUser u $ viewGroupMemberVerificationReset g m
CRConnectionVerified u verified code -> ttyUser u [plain $ if verified then "connection verified" else "connection not verified, current code is " <> code]
CRContactCode u ct code -> ttyUser u $ viewContactCode ct code testView
CRGroupMemberCode u g m code -> ttyUser u $ viewGroupMemberCode g m code testView
@@ -385,7 +390,6 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta, content, quotedItem, file}
CIDirectRcv -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvDecryptionError err n -> viewRcvDecryptionError from err n ts tz meta
CIRcvGroupEvent {} -> showRcvItemProhibited from
_ -> showRcvItem from
where
@@ -402,7 +406,6 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta, content, quotedItem, file}
CIGroupRcv m -> case content of
CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc
CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta
CIRcvDecryptionError err n -> viewRcvDecryptionError from err n ts tz meta
CIRcvGroupInvitation {} -> showRcvItemProhibited from
CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False
_ -> showRcvItem from
@@ -587,9 +590,6 @@ msgPreview = msgPlain . preview . msgContentText
viewRcvIntegrityError :: StyledString -> MsgErrorType -> CurrentTime -> TimeZone -> CIMeta c 'MDRcv -> [StyledString]
viewRcvIntegrityError from msgErr ts tz meta = receivedWithTime_ ts tz from [] meta (viewMsgIntegrityError msgErr) False
viewRcvDecryptionError :: StyledString -> MsgDecryptError -> Word32 -> CurrentTime -> TimeZone -> CIMeta c 'MDRcv -> [StyledString]
viewRcvDecryptionError from err n ts tz meta = receivedWithTime_ ts tz from [] meta [ttyError $ msgDecryptErrorText err n] False
viewMsgIntegrityError :: MsgErrorType -> [StyledString]
viewMsgIntegrityError err = [ttyError $ msgIntegrityError err]
@@ -968,6 +968,28 @@ viewGroupMemberSwitch g m (SwitchProgress qd phase _) = case qd of
QDRcv -> [ttyGroup' g <> ": you " <> viewSwitchPhase phase <> " for " <> ttyMember m]
QDSnd -> [ttyGroup' g <> ": " <> ttyMember m <> " " <> viewSwitchPhase phase <> " for you"]
viewContactRatchetSync :: Contact -> RatchetSyncProgress -> [StyledString]
viewContactRatchetSync ct@Contact {localDisplayName = c} RatchetSyncProgress {ratchetSyncStatus = rss} =
[ttyContact' ct <> ": " <> (plain . ratchetSyncStatusToText) rss]
<> help
where
help = ["use " <> highlight ("/sync " <> c) <> " to synchronize" | rss `elem` [RSAllowed, RSRequired]]
viewGroupMemberRatchetSync :: GroupInfo -> GroupMember -> RatchetSyncProgress -> [StyledString]
viewGroupMemberRatchetSync g m@GroupMember {localDisplayName = n} RatchetSyncProgress {ratchetSyncStatus = rss} =
[ttyGroup' g <> " " <> ttyMember m <> ": " <> (plain . ratchetSyncStatusToText) rss]
<> help
where
help = ["use " <> highlight ("/sync #" <> groupName' g <> " " <> n) <> " to synchronize" | rss `elem` [RSAllowed, RSRequired]]
viewContactVerificationReset :: Contact -> [StyledString]
viewContactVerificationReset ct =
[ttyContact' ct <> ": security code changed"]
viewGroupMemberVerificationReset :: GroupInfo -> GroupMember -> [StyledString]
viewGroupMemberVerificationReset g m =
[ttyGroup' g <> " " <> ttyMember m <> ": security code changed"]
viewContactCode :: Contact -> Text -> Bool -> [StyledString]
viewContactCode ct@Contact {localDisplayName = c} = viewSecurityCode (ttyContact' ct) ("/verify " <> c <> " <code from your contact>")

2
stack.yaml
View File

@@ -49,7 +49,7 @@ extra-deps:
# - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
# - ../simplexmq
- github: simplex-chat/simplexmq
commit: fe22d9b299f106fc4a3d167e90499ddb4d3bfa26
commit: f2657f9c0b954f952aaf381bb9b55ac34ea59ed7
- github: kazu-yamamoto/http2
commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
# - ../direct-sqlcipher

137
tests/ChatTests/Direct.hs
View File

@@ -86,7 +86,9 @@ chatDirectTests = do
it "mark contact verified" testMarkContactVerified
it "mark group member verified" testMarkGroupMemberVerified
describe "message errors" $ do
xit "show message decryption error and update count" testMsgDecryptError
it "show message decryption error" testMsgDecryptError
it "should report ratchet de-synchronization, synchronize ratchets" testSyncRatchet
it "synchronize ratchets, reset connection code" testSyncRatchetCodeReset
describe "message reactions" $ do
it "set message reactions" testSetMessageReactions
@@ -1995,43 +1997,124 @@ testMsgDecryptError tmp =
bob <# "alice> hi"
bob #> "@alice hey"
alice <# "bob> hey"
copyDb "bob" "bob_old"
withTestChat tmp "bob" $ \bob -> do
bob <## "1 contacts connected (use /cs for the list)"
alice #> "@bob hello"
bob <# "alice> hello"
bob #> "@alice hello too"
alice <# "bob> hello too"
withTestChat tmp "bob_old" $ \bob -> do
bob <## "1 contacts connected (use /cs for the list)"
alice #> "@bob 1"
bob <# "alice> decryption error, possibly due to the device change (header)"
alice #> "@bob 2"
alice #> "@bob 3"
(bob </)
bob ##> "/tail @alice 1"
bob <# "alice> decryption error, possibly due to the device change (header, 3 messages)"
bob #> "@alice 1"
alice <# "bob> decryption error, possibly due to the device change (header)"
bob #> "@alice 2"
bob #> "@alice 3"
(alice </)
alice ##> "/tail @bob 1"
alice <# "bob> decryption error, possibly due to the device change (header, 3 messages)"
alice #> "@bob 4"
bob <# "alice> decryption error, possibly due to the device change (header)"
setupDesynchronizedRatchet tmp alice
withTestChat tmp "bob" $ \bob -> do
bob <## "1 contacts connected (use /cs for the list)"
alice #> "@bob hello again"
bob <# "alice> skipped message ID 5..8"
bob <# "alice> skipped message ID 5..7"
bob <# "alice> hello again"
bob #> "@alice received!"
alice <# "bob> received!"
setupDesynchronizedRatchet :: HasCallStack => FilePath -> TestCC -> IO ()
setupDesynchronizedRatchet tmp alice = do
copyDb "bob" "bob_old"
withTestChat tmp "bob" $ \bob -> do
bob <## "1 contacts connected (use /cs for the list)"
alice #> "@bob hello"
bob <# "alice> hello"
bob #> "@alice hello too"
alice <# "bob> hello too"
withTestChat tmp "bob_old" $ \bob -> do
bob <## "1 contacts connected (use /cs for the list)"
bob ##> "/sync alice"
bob <## "error: command is prohibited"
alice #> "@bob 1"
bob <## "alice: decryption error (connection out of sync), synchronization required"
bob <## "use /sync alice to synchronize"
alice #> "@bob 2"
alice #> "@bob 3"
(bob </)
bob ##> "/tail @alice 1"
bob <# "alice> decryption error, possibly due to the device change (header, 3 messages)"
bob ##> "@alice 1"
bob <## "error: command is prohibited"
(alice </)
where
copyDb from to = do
copyFile (chatStoreFile $ tmp </> from) (chatStoreFile $ tmp </> to)
copyFile (agentStoreFile $ tmp </> from) (agentStoreFile $ tmp </> to)
testSyncRatchet :: HasCallStack => FilePath -> IO ()
testSyncRatchet tmp =
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do
connectUsers alice bob
alice #> "@bob hi"
bob <# "alice> hi"
bob #> "@alice hey"
alice <# "bob> hey"
setupDesynchronizedRatchet tmp alice
withTestChat tmp "bob_old" $ \bob -> do
bob <## "1 contacts connected (use /cs for the list)"
bob ##> "/sync alice"
bob <## "connection synchronization started"
alice <## "bob: connection synchronization agreed"
bob <## "alice: connection synchronization agreed"
alice <## "bob: connection synchronized"
bob <## "alice: connection synchronized"
bob #$> ("/_get chat @2 count=3", chat, [(1, "connection synchronization started"), (0, "connection synchronization agreed"), (0, "connection synchronized")])
alice #$> ("/_get chat @2 count=2", chat, [(0, "connection synchronization agreed"), (0, "connection synchronized")])
alice #> "@bob hello again"
bob <# "alice> hello again"
bob #> "@alice received!"
alice <# "bob> received!"
testSyncRatchetCodeReset :: HasCallStack => FilePath -> IO ()
testSyncRatchetCodeReset tmp =
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do
connectUsers alice bob
alice #> "@bob hi"
bob <# "alice> hi"
bob #> "@alice hey"
alice <# "bob> hey"
-- connection not verified
bob ##> "/i alice"
aliceInfo bob
bob <## "connection not verified, use /code command to see security code"
-- verify connection
alice ##> "/code bob"
bCode <- getTermLine alice
bob ##> ("/verify alice " <> bCode)
bob <## "connection verified"
-- connection verified
bob ##> "/i alice"
aliceInfo bob
bob <## "connection verified"
setupDesynchronizedRatchet tmp alice
withTestChat tmp "bob_old" $ \bob -> do
bob <## "1 contacts connected (use /cs for the list)"
bob ##> "/sync alice"
bob <## "connection synchronization started"
alice <## "bob: connection synchronization agreed"
bob <## "alice: connection synchronization agreed"
bob <## "alice: security code changed"
alice <## "bob: connection synchronized"
bob <## "alice: connection synchronized"
bob #$> ("/_get chat @2 count=4", chat, [(1, "connection synchronization started"), (0, "connection synchronization agreed"), (0, "security code changed"), (0, "connection synchronized")])
alice #$> ("/_get chat @2 count=2", chat, [(0, "connection synchronization agreed"), (0, "connection synchronized")])
-- connection not verified
bob ##> "/i alice"
aliceInfo bob
bob <## "connection not verified, use /code command to see security code"
alice #> "@bob hello again"
bob <# "alice> hello again"
bob #> "@alice received!"
alice <# "bob> received!"
where
aliceInfo :: HasCallStack => TestCC -> IO ()
aliceInfo bob = do
bob <## "contact ID: 2"
bob <## "receiving messages via: localhost"
bob <## "sending messages via: localhost"
bob <## "you've shared main profile with this contact"
testSetMessageReactions :: HasCallStack => FilePath -> IO ()
testSetMessageReactions =
testChat2 aliceProfile bobProfile $

188
tests/ChatTests/Groups.hs
View File

@@ -56,7 +56,9 @@ chatGroupTests = do
it "group link member role" testGroupLinkMemberRole
it "leaving and deleting the group joined via link should NOT delete previously existing direct contacts" testGroupLinkLeaveDelete
describe "group message errors" $ do
xit "show message decryption error and update count" testGroupMsgDecryptError
it "show message decryption error" testGroupMsgDecryptError
it "should report ratchet de-synchronization, synchronize ratchets" testGroupSyncRatchet
it "synchronize ratchets, reset connection code" testGroupSyncRatchetCodeReset
describe "message reactions" $ do
it "set group message reactions" testSetGroupMessageReactions
@@ -2200,68 +2202,152 @@ testGroupMsgDecryptError tmp =
[bob, cath] *<# "#team alice> hi"
bob #> "#team hey"
[alice, cath] *<# "#team bob> hey"
copyDb "bob" "bob_old"
withTestChat tmp "bob" $ \bob -> do
bob <## "2 contacts connected (use /cs for the list)"
bob <## "#team: connected to server(s)"
alice #> "#team hello"
[bob, cath] *<# "#team alice> hello"
bob #> "#team hello too"
[alice, cath] *<# "#team bob> hello too"
withTestChat tmp "bob_old" $ \bob -> do
bob <## "2 contacts connected (use /cs for the list)"
bob <## "#team: connected to server(s)"
alice #> "#team 1"
bob <# "#team alice> decryption error, possibly due to the device change (header)"
cath <# "#team alice> 1"
alice #> "#team 2"
cath <# "#team alice> 2"
alice #> "#team 3"
cath <# "#team alice> 3"
(bob </)
bob ##> "/tail #team 1"
bob <# "#team alice> decryption error, possibly due to the device change (header, 3 messages)"
bob #> "#team 1"
alice <# "#team bob> decryption error, possibly due to the device change (header)"
-- cath <# "#team bob> 1"
bob #> "#team 2"
cath <# "#team bob> incorrect message hash"
cath <# "#team bob> 2"
bob #> "#team 3"
cath <# "#team bob> 3"
(alice </)
alice ##> "/tail #team 1"
alice <# "#team bob> decryption error, possibly due to the device change (header, 3 messages)"
alice #> "#team 4"
(bob </)
cath <# "#team alice> 4"
bob ##> "/tail #team 4"
bob
<##? [ "#team alice> decryption error, possibly due to the device change (header, 4 messages)",
"#team 1",
"#team 2",
"#team 3"
]
setupDesynchronizedRatchet tmp alice cath
withTestChat tmp "bob" $ \bob -> do
bob <## "2 contacts connected (use /cs for the list)"
bob <## "#team: connected to server(s)"
alice #> "#team hello again"
bob <# "#team alice> skipped message ID 8..11"
bob <# "#team alice> skipped message ID 8..10"
[bob, cath] *<# "#team alice> hello again"
bob #> "#team received!"
alice <# "#team bob> received!"
bob #> "#team 4"
alice <# "#team bob> 4"
bob #> "#team 5"
cath <# "#team bob> incorrect message hash"
[alice, cath] *<# "#team bob> 5"
bob #> "#team 6"
[alice, cath] *<# "#team bob> 6"
cath <# "#team bob> received!"
setupDesynchronizedRatchet :: HasCallStack => FilePath -> TestCC -> TestCC -> IO ()
setupDesynchronizedRatchet tmp alice cath = do
copyDb "bob" "bob_old"
withTestChat tmp "bob" $ \bob -> do
bob <## "2 contacts connected (use /cs for the list)"
bob <## "#team: connected to server(s)"
alice #> "#team hello"
[bob, cath] *<# "#team alice> hello"
bob #> "#team hello too"
[alice, cath] *<# "#team bob> hello too"
withTestChat tmp "bob_old" $ \bob -> do
bob <## "2 contacts connected (use /cs for the list)"
bob <## "#team: connected to server(s)"
bob ##> "/sync #team alice"
bob <## "error: command is prohibited"
alice #> "#team 1"
bob <## "#team alice: decryption error (connection out of sync), synchronization required"
bob <## "use /sync #team alice to synchronize"
cath <# "#team alice> 1"
alice #> "#team 2"
cath <# "#team alice> 2"
alice #> "#team 3"
cath <# "#team alice> 3"
(bob </)
bob ##> "/tail #team 1"
bob <# "#team alice> decryption error, possibly due to the device change (header, 3 messages)"
where
copyDb from to = do
copyFile (chatStoreFile $ tmp </> from) (chatStoreFile $ tmp </> to)
copyFile (agentStoreFile $ tmp </> from) (agentStoreFile $ tmp </> to)
testGroupSyncRatchet :: HasCallStack => FilePath -> IO ()
testGroupSyncRatchet tmp =
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do
createGroup3 "team" alice bob cath
alice #> "#team hi"
[bob, cath] *<# "#team alice> hi"
bob #> "#team hey"
[alice, cath] *<# "#team bob> hey"
setupDesynchronizedRatchet tmp alice cath
withTestChat tmp "bob_old" $ \bob -> do
bob <## "2 contacts connected (use /cs for the list)"
bob <## "#team: connected to server(s)"
-- cath and bob are not fully de-synchronized
bob `send` "#team 1"
bob <## "error: command is prohibited" -- silence?
bob <# "#team 1"
(alice </)
(cath </)
cath #> "#team 1"
[alice, bob] *<# "#team cath> 1"
bob `send` "#team 2"
bob <## "error: command is prohibited"
bob <# "#team 2"
cath <# "#team bob> incorrect message hash"
cath <# "#team bob> 2"
bob `send` "#team 3"
bob <## "error: command is prohibited"
bob <# "#team 3"
cath <# "#team bob> 3"
-- synchronize bob and alice
bob ##> "/sync #team alice"
bob <## "connection synchronization started"
alice <## "#team bob: connection synchronization agreed"
bob <## "#team alice: connection synchronization agreed"
alice <## "#team bob: connection synchronized"
bob <## "#team alice: connection synchronized"
bob #$> ("/_get chat #1 count=3", chat, [(1, "connection synchronization started for alice"), (0, "connection synchronization agreed"), (0, "connection synchronized")])
alice #$> ("/_get chat #1 count=2", chat, [(0, "connection synchronization agreed"), (0, "connection synchronized")])
alice #> "#team hello again"
[bob, cath] *<# "#team alice> hello again"
bob #> "#team received!"
alice <# "#team bob> received!"
cath <# "#team bob> received!"
testGroupSyncRatchetCodeReset :: HasCallStack => FilePath -> IO ()
testGroupSyncRatchetCodeReset tmp =
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
withNewTestChat tmp "cath" cathProfile $ \cath -> do
withNewTestChat tmp "bob" bobProfile $ \bob -> do
createGroup3 "team" alice bob cath
alice #> "#team hi"
[bob, cath] *<# "#team alice> hi"
bob #> "#team hey"
[alice, cath] *<# "#team bob> hey"
-- connection not verified
bob ##> "/i #team alice"
aliceInfo bob
bob <## "connection not verified, use /code command to see security code"
-- verify connection
alice ##> "/code #team bob"
bCode <- getTermLine alice
bob ##> ("/verify #team alice " <> bCode)
bob <## "connection verified"
-- connection verified
bob ##> "/i #team alice"
aliceInfo bob
bob <## "connection verified"
setupDesynchronizedRatchet tmp alice cath
withTestChat tmp "bob_old" $ \bob -> do
bob <## "2 contacts connected (use /cs for the list)"
bob <## "#team: connected to server(s)"
bob ##> "/sync #team alice"
bob <## "connection synchronization started"
alice <## "#team bob: connection synchronization agreed"
bob <## "#team alice: connection synchronization agreed"
bob <## "#team alice: security code changed"
alice <## "#team bob: connection synchronized"
bob <## "#team alice: connection synchronized"
bob #$> ("/_get chat #1 count=4", chat, [(1, "connection synchronization started for alice"), (0, "connection synchronization agreed"), (0, "security code changed"), (0, "connection synchronized")])
alice #$> ("/_get chat #1 count=2", chat, [(0, "connection synchronization agreed"), (0, "connection synchronized")])
-- connection not verified
bob ##> "/i #team alice"
aliceInfo bob
bob <## "connection not verified, use /code command to see security code"
alice #> "#team hello again"
[bob, cath] *<# "#team alice> hello again"
bob #> "#team received!"
alice <# "#team bob> received!"
(cath </) -- bob is partially de-synchronized with cath - see test above
where
aliceInfo :: HasCallStack => TestCC -> IO ()
aliceInfo bob = do
bob <## "group ID: 1"
bob <## "member ID: 1"
bob <## "receiving messages via: localhost"
bob <## "sending messages via: localhost"
testSetGroupMessageReactions :: HasCallStack => FilePath -> IO ()
testSetGroupMessageReactions =
testChat3 aliceProfile bobProfile cathProfile $