Functions to mark direct messages as seen and to list the statusHEADmaster

3 files changed, 154 insertions, 42 deletions

diff --git a/main/Test.hs b/main/Test.hs
index 17dc228..da49257 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -268,12 +268,13 @@ inviteAttributes out = (defaultServiceAttributes Proxy)
 
 dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO ()
 dmThreadWatcher self out prev cur = do
-    forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do
+    forM_ (reverse $ dmThreadToListSinceUnread prev cur) $ \( msg, new ) -> do
         outLine out $ unwords
             [ if sameIdentity self (msgFrom msg)
                  then "dm-sent"
                  else "dm-received"
             , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
+            , "new", if new then "yes" else "no"
             , "text", T.unpack $ msgText msg
             ]
 
@@ -347,6 +348,8 @@ commands =
     , ( "dm-send-identity", cmdDmSendIdentity )
     , ( "dm-list-peer", cmdDmListPeer )
     , ( "dm-list-contact", cmdDmListContact )
+    , ( "dm-list-identity", cmdDmListIdentity )
+    , ( "dm-mark-seen", cmdDmMarkSeen )
     , ( "chatroom-create", cmdChatroomCreate )
     , ( "chatroom-delete", cmdChatroomDelete )
     , ( "chatroom-list-local", cmdChatroomListLocal )
@@ -934,8 +937,9 @@ dmList peer = do
     threads <- dmThreadList . lookupSharedValue . lsShared . headObject <$> getHead
     case find (sameIdentity peer . msgPeer) threads of
         Just thread -> do
-            forM_ (reverse $ dmThreadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item"
+            forM_ (reverse $ dmThreadToListUnread thread) $ \( DirectMessage {..}, new ) -> cmdOut $ "dm-list-item"
                 <> " from " <> (maybe "<unnamed>" T.unpack $ idName msgFrom)
+                <> " new " <> (if new then "yes" else "no")
                 <> " text " <> (T.unpack msgText)
         Nothing -> return ()
     cmdOut "dm-list-done"
@@ -952,6 +956,23 @@ cmdDmListContact = do
     Just to <- contactIdentity <$> getContact cid
     dmList to
 
+cmdDmListIdentity :: Command
+cmdDmListIdentity = do
+    st <- asks tiStorage
+    [ tid ] <- asks tiParams
+    Just ref <- liftIO $ readRef st $ encodeUtf8 tid
+    Just pid <- return $ validateExtendedIdentity $ wrappedLoad ref
+    dmList pid
+
+cmdDmMarkSeen :: Command
+cmdDmMarkSeen = do
+    st <- asks tiStorage
+    [ tid ] <- asks tiParams
+    Just ref <- liftIO $ readRef st $ encodeUtf8 tid
+    Just pid <- return $ validateExtendedIdentity $ wrappedLoad ref
+    dmMarkAsSeen pid
+    cmdOut $ unwords [ "dm-mark-seen-done", T.unpack tid ]
+
 cmdChatroomCreate :: Command
 cmdChatroomCreate = do
     [name] <- asks tiParams
diff --git a/src/Erebos/DirectMessage.hs b/src/Erebos/DirectMessage.hs
index 2558abb..91cc045 100644
--- a/src/Erebos/DirectMessage.hs
+++ b/src/Erebos/DirectMessage.hs
@@ -1,6 +1,7 @@
 module Erebos.DirectMessage (
     DirectMessage(..),
     sendDirectMessage,
+    dmMarkAsSeen,
     updateDirectMessagePeer,
     createOrUpdateDirectMessagePeer,
 
@@ -11,7 +12,7 @@ module Erebos.DirectMessage (
     dmThreadList,
 
     DirectMessageThread(..),
-    dmThreadToList, dmThreadToListSince,
+    dmThreadToList, dmThreadToListSince, dmThreadToListUnread, dmThreadToListSinceUnread,
     dmThreadView,
 
     watchDirectMessageThreads,
@@ -202,6 +203,23 @@ sendDirectMessage pid text = updateLocalState_ $ \ls -> do
             }
         return $ DirectMessageThreads [ next ] (dmThreadView [ next ])
 
+dmMarkAsSeen
+    :: (Foldable f, Applicative f, MonadHead LocalState m)
+    => Identity f -> m ()
+dmMarkAsSeen pid = do
+    updateLocalState_ $ updateSharedState_ $ \(DirectMessageThreads prev _) -> do
+        let powner = finalOwner pid
+            received = findMsgProperty powner msReceived prev
+        next <- mstore MessageState
+            { msPrev = prev
+            , msPeer = powner
+            , msReady = []
+            , msSent = []
+            , msReceived = []
+            , msSeen = received
+            }
+        return $ DirectMessageThreads [ next ] (dmThreadView [ next ])
+
 updateDirectMessagePeer
     :: (Foldable f, Applicative f, MonadHead LocalState m)
     => Identity f -> m ()
@@ -285,15 +303,21 @@ data DirectMessageThread = DirectMessageThread
     }
 
 dmThreadToList :: DirectMessageThread -> [ DirectMessage ]
-dmThreadToList thread = threadToListHelper S.empty $ msgHead thread
+dmThreadToList thread = map fst $ threadToListHelper (msgSeen thread) S.empty $ msgHead thread
 
 dmThreadToListSince :: DirectMessageThread -> DirectMessageThread -> [ DirectMessage ]
-dmThreadToListSince since thread = threadToListHelper (S.fromAscList $ msgHead since) (msgHead thread)
+dmThreadToListSince since thread = map fst $ threadToListHelper (msgSeen thread) (S.fromAscList $ msgHead since) (msgHead thread)
+
+dmThreadToListUnread :: DirectMessageThread -> [ ( DirectMessage, Bool ) ]
+dmThreadToListUnread thread = threadToListHelper (msgSeen thread) S.empty $ msgHead thread
+
+dmThreadToListSinceUnread :: DirectMessageThread -> DirectMessageThread -> [ ( DirectMessage, Bool ) ]
+dmThreadToListSinceUnread since thread = threadToListHelper (msgSeen thread) (S.fromAscList $ msgHead since) (msgHead thread)
 
-threadToListHelper :: Set (Stored DirectMessage) -> [ Stored DirectMessage ] -> [ DirectMessage ]
-threadToListHelper seen msgs
-    | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs =
-        fromStored msg : threadToListHelper (S.insert msg seen) (msgs' ++ msgPrev (fromStored msg))
+threadToListHelper :: [ Stored DirectMessage ] -> Set (Stored DirectMessage) -> [ Stored DirectMessage ] -> [ ( DirectMessage, Bool ) ]
+threadToListHelper seen used msgs
+    | msg : msgs' <- filter (`S.notMember` used) $ reverse $ sortBy (comparing cmpView) msgs =
+        ( fromStored msg, not $ any (msg `precedesOrEquals`) seen ) : threadToListHelper seen (S.insert msg used) (msgs' ++ msgPrev (fromStored msg))
     | otherwise = []
   where
     cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg)
diff --git a/test/message.et b/test/message.et
index acdfc27..c4b61e3 100644
--- a/test/message.et
+++ b/test/message.et
@@ -28,21 +28,21 @@ test DirectMessage:
 
 	for i in [1..2]:
 		send "dm-send-peer $peer1_2 hello$i" to p1
-		expect /dm-sent from Owner1 text hello$i/ from p1
-		expect /dm-received from Owner1 text hello$i/ from p2
+		expect /dm-sent from Owner1 new no text hello$i/ from p1
+		expect /dm-received from Owner1 new yes text hello$i/ from p2
 
 	for i in [1..2]:
 		send "dm-send-peer $peer2_1 hi$i" to p2
-		expect /dm-sent from Owner2 text hi$i/ from p2
-		expect /dm-received from Owner2 text hi$i/ from p1
+		expect /dm-sent from Owner2 new no text hi$i/ from p2
+		expect /dm-received from Owner2 new yes text hi$i/ from p1
 
 	for i in [3..4]:
 		send "dm-send-peer $peer1_2 hello$i" to p1
-		expect /dm-sent from Owner1 text hello$i/ from p1
-		expect /dm-received from Owner1 text hello$i/ from p2
+		expect /dm-sent from Owner1 new no text hello$i/ from p1
+		expect /dm-received from Owner1 new yes text hello$i/ from p2
 		send "dm-send-peer $peer2_1 hi$i" to p2
-		expect /dm-sent from Owner2 text hi$i/ from p2
-		expect /dm-received from Owner2 text hi$i/ from p1
+		expect /dm-sent from Owner2 new no text hi$i/ from p2
+		expect /dm-received from Owner2 new yes text hi$i/ from p1
 
 	# Create contacts
 
@@ -71,32 +71,32 @@ test DirectMessage:
 
 	for i in [1..2]:
 		send "dm-send-contact $c1_2 hello_c_$i" to p1
-		expect /dm-sent from Owner1 text hello_c_$i/ from p1
-		expect /dm-received from Owner1 text hello_c_$i/ from p2
+		expect /dm-sent from Owner1 new no text hello_c_$i/ from p1
+		expect /dm-received from Owner1 new yes text hello_c_$i/ from p2
 
 	for i in [1..2]:
 		send "dm-send-contact $c2_1 hi_c_$i" to p2
-		expect /dm-sent from Owner2 text hi_c_$i/ from p2
-		expect /dm-received from Owner2 text hi_c_$i/ from p1
+		expect /dm-sent from Owner2 new no text hi_c_$i/ from p2
+		expect /dm-received from Owner2 new yes text hi_c_$i/ from p1
 
 	for i in [3..4]:
 		send "dm-send-contact $c1_2 hello_c_$i" to p1
-		expect /dm-sent from Owner1 text hello_c_$i/ from p1
-		expect /dm-received from Owner1 text hello_c_$i/ from p2
+		expect /dm-sent from Owner1 new no text hello_c_$i/ from p1
+		expect /dm-received from Owner1 new yes text hello_c_$i/ from p2
 		send "dm-send-contact $c2_1 hi_c_$i" to p2
-		expect /dm-sent from Owner2 text hi_c_$i/ from p2
-		expect /dm-received from Owner2 text hi_c_$i/ from p1
+		expect /dm-sent from Owner2 new no text hi_c_$i/ from p2
+		expect /dm-received from Owner2 new yes text hi_c_$i/ from p1
 
 	send "dm-list-contact $c1_2" to p1
 	send "dm-list-contact $c2_1" to p2
 	for p in [p1, p2]:
 		with p:
 			for i in [1..4]:
-				expect /dm-list-item from Owner1 text hello_c_$i/
-				expect /dm-list-item from Owner2 text hi_c_$i/
+				expect /dm-list-item from Owner1 new [a-z]+ text hello_c_$i/
+				expect /dm-list-item from Owner2 new [a-z]+ text hi_c_$i/
 			for i in [1..4]:
-				expect /dm-list-item from Owner1 text hello$i/
-				expect /dm-list-item from Owner2 text hi$i/
+				expect /dm-list-item from Owner1 new [a-z]+ text hello$i/
+				expect /dm-list-item from Owner2 new [a-z]+ text hi$i/
 			expect /dm-list-(.*)/ capture done
 			guard (done == "done")
 
@@ -124,11 +124,11 @@ test DirectMessage:
 	for p in [p1, p2]:
 		with p:
 			for i in [1..4]:
-				expect /dm-list-item from Owner1 text hello_c_$i/
-				expect /dm-list-item from Owner2 text hi_c_$i/
+				expect /dm-list-item from Owner1 new [a-z]+ text hello_c_$i/
+				expect /dm-list-item from Owner2 new [a-z]+ text hi_c_$i/
 			for i in [1..4]:
-				expect /dm-list-item from Owner1 text hello$i/
-				expect /dm-list-item from Owner2 text hi$i/
+				expect /dm-list-item from Owner1 new [a-z]+ text hello$i/
+				expect /dm-list-item from Owner2 new [a-z]+ text hi$i/
 			expect /dm-list-(.*)/ capture done
 			guard (done == "done")
 
@@ -143,10 +143,10 @@ test DirectMessage:
 	send "start-server services $services" to p2
 
 	send "dm-send-contact $c1_2 while_offline" to p1
-	expect /dm-sent from Owner1 text while_offline/ from p1
+	expect /dm-sent from Owner1 new no text while_offline/ from p1
 	send "start-server services $services" to p1
 
-	expect /dm-received from Owner1 text while_offline/ from p2
+	expect /dm-received from Owner1 new yes text while_offline/ from p2
 
 	for p in [p1, p2]:
 		with p:
@@ -157,10 +157,10 @@ test DirectMessage:
 	send "start-server services $services" to p1
 
 	send "dm-send-contact $c1_2 while_peer_offline" to p1
-	expect /dm-sent from Owner1 text while_peer_offline/ from p1
+	expect /dm-sent from Owner1 new no text while_peer_offline/ from p1
 	send "start-server services $services" to p2
 
-	expect /dm-received from Owner1 text while_peer_offline/ from p2
+	expect /dm-received from Owner1 new yes text while_peer_offline/ from p2
 
 
 test DirectMessageDiscovery:
@@ -221,9 +221,9 @@ test DirectMessageDiscovery:
 	for i in [ 1 .. 3 ]:
 		send "dm-send-peer $i init1" to p1
 	for p in [ p2, p3, p4 ]:
-		expect /dm-received from Owner1 text init1/ from p
+		expect /dm-received from Owner1 new yes text init1/ from p
 		send "dm-send-identity $p1_owner init2" to p
-		expect /dm-received from Owner. text init2/ from p1
+		expect /dm-received from Owner. new yes text init2/ from p1
 
 	# Restart servers to remove peers:
 	for p in [ p1, p2, p3, p4 ]:
@@ -258,16 +258,83 @@ test DirectMessageDiscovery:
 		/peer [0-9]+ addr ${p2.node.ip} 29665/
 		/peer [0-9]+ id Device2 Owner2/
 	send "dm-send-identity $p2_owner hello_to_p2" to p1
-	expect /dm-received from Owner1 text hello_to_p2/ from p2
+	expect /dm-received from Owner1 new yes text hello_to_p2/ from p2
 
 	# Send message, expect automatic discovery
 	send "dm-send-identity $p3_owner hello_to_p3" to p1
-	expect /dm-received from Owner1 text hello_to_p3/ from p3
+	expect /dm-received from Owner1 new yes text hello_to_p3/ from p3
 
 	# Verify the first message
-	expect /dm-received from Owner1 text hello_to_p4/ from p4
+	expect /dm-received from Owner1 new yes text hello_to_p4/ from p4
 
 	for p in [ p1, p2, p3, p4, pd ]:
 		send "stop-server" to p
 	for p in [ p1, p2, p3, p4, pd ]:
 		expect /stop-server-done/ from p
+
+
+test DirectMessageSeen:
+	let services = "dm,attach,sync"
+
+	spawn as p1
+	spawn as p2
+
+	send "create-identity Device1 Owner1" to p1
+	expect /create-identity-done ref ($refpat)/ from p1 capture p1id
+	send "identity-info $p1id" to p1
+	expect /identity-info ref $p1id base ($refpat) owner ($refpat).*/ from p1 capture p1base, p1owner
+
+	send "create-identity Device2 Owner2" to p2
+	expect /create-identity-done ref ($refpat)/ from p2 capture p2id
+	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
+
+	expect from p1:
+		/peer ([0-9]+) addr ${p2.node.ip} 29665/ capture peer1_2
+		/peer $peer1_2 id Device2 Owner2/
+
+	expect from p2:
+		/peer ([0-9]+) addr ${p1.node.ip} 29665/ capture peer2_1
+		/peer $peer2_1 id Device1 Owner1/
+
+	for i in [ 1 .. 2 ]:
+		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_$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 ]:
+		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 ]:
+		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 ]:
+		expect /dm-list-(.*)/ from p capture done
+		guard (done == "done")
+
+	send "dm-mark-seen $p2owner" to p1
+	expect /dm-mark-seen-done $p2owner/ from p1
+	send "dm-mark-seen $p1owner" to p2
+	expect /dm-mark-seen-done $p1owner/ from p2
+
+	send "dm-list-identity $p2owner" to p1
+	send "dm-list-identity $p1owner" to p2
+	for i in [1..2]:
+		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]:
+		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 ]:
+		expect /dm-list-(.*)/ from p capture done
+		guard (done == "done")