From a9697ffdf3690c7db68a256c0a0b68941d0937b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sun, 7 Jun 2026 11:42:13 +0200 Subject: Test: log direct message history changes with removals --- main/Test.hs | 28 ++++++++++++++++++++++------ test/message.et | 25 +++++++++++++++++-------- 2 files changed, 39 insertions(+), 14 deletions(-) diff --git a/main/Test.hs b/main/Test.hs index ad4cb0b..1755031 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -95,19 +95,21 @@ initTestState = TestState data TestInput = TestInput { tiOutput :: Output , tiStorage :: Storage - , tiParams :: [Text] + , tiParams :: [ Text ] + , tiDmLogChange :: MVar Bool } runTestTool :: Storage -> IO () runTestTool st = do out <- newMVar () + changeVar <- newMVar False let testLoop = getLineMb >>= \case Just line -> do case T.words line of (cname:params) | Just (CommandM cmd) <- lookup cname commands -> do - runReaderT cmd $ TestInput out st params + runReaderT cmd $ TestInput out st params changeVar | otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'" [] -> return () testLoop @@ -247,9 +249,15 @@ inviteAttributes out = (defaultServiceAttributes Proxy) afterCommit $ outLine out $ "invite-reply " <> showInviteToken token <> " invalid" } -dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO () -dmThreadWatcher self out prev cur = do - forM_ (reverse $ dmThreadToListSinceUnread prev cur) $ \( msg, new ) -> do +dmThreadWatcher :: MVar Bool -> ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO () +dmThreadWatcher changeVar self out prev cur = do + change <- readMVar changeVar + let ( removed, added ) + | change = dmThreadToListChange prev cur + | otherwise = ( 0, dmThreadToListSinceUnread prev cur ) + when (removed > 0) $ do + outLine out $ unwords [ "dm-removed", show removed ] + forM_ (reverse added) $ \( msg, new ) -> do outLine out $ unwords [ if sameIdentity self (msgFrom msg) then "dm-sent" @@ -326,6 +334,7 @@ commands = , ( "contact-reject", cmdContactReject ) , ( "contact-list", cmdContactList ) , ( "contact-set-name", cmdContactSetName ) + , ( "dm-log-change", cmdDmLogChange ) , ( "dm-send-peer", cmdDmSendPeer ) , ( "dm-send-contact", cmdDmSendContact ) , ( "dm-send-identity", cmdDmSendIdentity ) @@ -544,7 +553,8 @@ cmdHeadUnwatch = do initTestHead :: Head LocalState -> Command initTestHead h = do let self = finalOwner $ headLocalIdentity h - _ <- liftIO . watchDirectMessageThreads h . dmThreadWatcher self =<< asks tiOutput + changeVar <- asks tiDmLogChange + _ <- liftIO . watchDirectMessageThreads h . dmThreadWatcher changeVar self =<< asks tiOutput modify $ \s -> s { tsHead = Just h } loadTestHead :: CommandM (Head LocalState) @@ -935,6 +945,12 @@ cmdContactSetName = do updateLocalState_ $ updateSharedState_ $ contactSetName contact name cmdOut "contact-set-name-done" +cmdDmLogChange :: Command +cmdDmLogChange = do + var <- asks tiDmLogChange + liftIO $ modifyMVar_ var $ return . const True + cmdOut "dm-log-change-done" + cmdDmSendPeer :: Command cmdDmSendPeer = do [spidx, msg] <- asks tiParams diff --git a/test/message.et b/test/message.et index 3609da5..f160cd8 100644 --- a/test/message.et +++ b/test/message.et @@ -324,8 +324,10 @@ test DirectMessageSeen: send "identity-info $p2id" to p2 expect /identity-info ref $p2id base ($refpat) owner ($refpat).*/ from p2 capture p2base, p2owner - send "start-server services $services" to p1 - send "start-server services $services" to p2 + for p in [ p1, p2 ]: + send "start-server services $services" to p + send "dm-log-change" to p + expect /dm-log-change-done/ from p expect from p1: /peer ([0-9]+) addr ${p2.node.ip} 29665/ capture peer1_2 @@ -335,22 +337,29 @@ test DirectMessageSeen: /peer ([0-9]+) addr ${p1.node.ip} 29665/ capture peer2_1 /peer $peer2_1 id Device1 Owner1/ - for i in [ 1 .. 2 ]: + for i in [ 1 .. 3 ]: send "dm-send-peer $peer1_2 msg_a_$i" to p1 expect /dm-sent from Owner1 new no text msg_a_$i/ from p1 expect /dm-received from Owner1 new yes text msg_a_$i/ from p2 - for i in [ 1 .. 2 ]: + send "dm-send-peer $peer2_1 msg_b_1" to p2 + expect /dm-removed 3/ from p2 + for i in [ 1 .. 3 ]: + expect /dm-received from Owner1 new no text msg_a_$i/ from p2 + expect /dm-sent from Owner2 new no text msg_b_1/ from p2 + expect /dm-received from Owner2 new yes text msg_b_1/ from p1 + + for i in [ 2 .. 3 ]: send "dm-send-peer $peer2_1 msg_b_$i" to p2 expect /dm-sent from Owner2 new no text msg_b_$i/ from p2 expect /dm-received from Owner2 new yes text msg_b_$i/ from p1 send "dm-list-identity $p2owner" to p1 send "dm-list-identity $p1owner" to p2 - for i in [ 1 .. 2 ]: + for i in [ 1 .. 3 ]: expect /dm-list-item from Owner1 new no text msg_a_$i/ from p1 expect /dm-list-item from Owner1 new no text msg_a_$i/ from p2 - for i in [ 1 .. 2 ]: + for i in [ 1 .. 3 ]: expect /dm-list-item from Owner2 new yes text msg_b_$i/ from p1 expect /dm-list-item from Owner2 new no text msg_b_$i/ from p2 for p in [ p1, p2 ]: @@ -364,10 +373,10 @@ test DirectMessageSeen: send "dm-list-identity $p2owner" to p1 send "dm-list-identity $p1owner" to p2 - for i in [1..2]: + for i in [ 1 .. 3 ]: expect /dm-list-item from Owner1 new no text msg_a_$i/ from p1 expect /dm-list-item from Owner1 new no text msg_a_$i/ from p2 - for i in [1..2]: + for i in [ 1 .. 3 ]: expect /dm-list-item from Owner2 new no text msg_b_$i/ from p1 expect /dm-list-item from Owner2 new no text msg_b_$i/ from p2 for p in [ p1, p2 ]: -- cgit v1.2.3