Chatroom members and join/leave commands

5 files changed, 190 insertions, 17 deletions

diff --git a/README.md b/README.md
index ac262d9..9535aab 100644
--- a/README.md
+++ b/README.md
@@ -121,6 +121,17 @@ are signed, so message author can not be forged.
 : Create public unmoderated chatroom. Room name can be passed as command
   argument or entered interactively.
 
+`/members`  
+: List members of the chatroom – usesers who sent any message or joined via the
+`join` command.
+
+`/join`  
+: Join chatroom without sending text message.
+
+`/leave`  
+: Leave the chatroom. User will no longer be listed as a member and erebos tool
+  will no longer collect message of this chatroom.
+
 ### Add contacts
 
 To ensure the identity of the contact and prevent man-in-the-middle attack,
diff --git a/main/Main.hs b/main/Main.hs
index e7615ed..94c0418 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -452,6 +452,11 @@ getSelectedPeer = gets csContext >>= \case
     SelectedPeer peer -> return peer
     _ -> throwError "no peer selected"
 
+getSelectedChatroom :: CommandM ChatroomState
+getSelectedChatroom = gets csContext >>= \case
+    SelectedChatroom rstate -> return rstate
+    _ -> throwError "no chatroom selected"
+
 getSelectedConversation :: CommandM Conversation
 getSelectedConversation = gets csContext >>= \case
     SelectedPeer peer -> peerIdentity peer >>= \case
@@ -496,6 +501,9 @@ commands =
     , ("ice-connect", cmdIceConnect)
     , ("ice-send", cmdIceSend)
 #endif
+    , ("join", cmdJoin)
+    , ("leave", cmdLeave)
+    , ("members", cmdMembers)
     , ("select", cmdSelectContext)
     , ("quit", cmdQuit)
     ]
@@ -548,6 +556,19 @@ showPeer pidentity paddr =
                     PeerIdentityFull pid   -> T.unpack $ displayIdentity pid
      in name ++ " [" ++ show paddr ++ "]"
 
+cmdJoin :: Command
+cmdJoin = joinChatroom =<< getSelectedChatroom
+
+cmdLeave :: Command
+cmdLeave = leaveChatroom =<< getSelectedChatroom
+
+cmdMembers :: Command
+cmdMembers = do
+    Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom
+    forM_ (chatroomMembers room) $ \x -> do
+        liftIO $ putStrLn $ maybe "<unnamed>" T.unpack $ idName x
+
+
 cmdSelectContext :: Command
 cmdSelectContext = do
     n <- read <$> asks ciLine
@@ -653,8 +674,8 @@ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do
                                 [ maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg
                                 , formatTime defaultTimeLocale " [%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg
                                 , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg
-                                , ": "
-                                , maybe "<no message>" T.unpack $ cmsgText msg
+                                , if cmsgLeave msg then " left" else ""
+                                , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg
                                 ]
                     modifyMVar_ subscribedNumVar $ return
                         . (if roomStateSubscribe rstate then (+ 1) else id)
diff --git a/main/Test.hs b/main/Test.hs
index 6e10b54..c6448b8 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -283,6 +283,9 @@ commands = map (T.pack *** id)
     , ("chatroom-set-name", cmdChatroomSetName)
     , ("chatroom-subscribe", cmdChatroomSubscribe)
     , ("chatroom-unsubscribe", cmdChatroomUnsubscribe)
+    , ("chatroom-members", cmdChatroomMembers)
+    , ("chatroom-join", cmdChatroomJoin)
+    , ("chatroom-leave", cmdChatroomLeave)
     , ("chatroom-message-send", cmdChatroomMessageSend)
     ]
 
@@ -732,6 +735,7 @@ cmdChatroomWatchLocal = do
                             , [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room ]
                             , [ "room", maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg ]
                             , [ "from", maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg ]
+                            , if cmsgLeave msg then [ "leave" ] else []
                             , maybe [] (("text":) . (:[]) . T.unpack) $ cmsgText msg
                             ]
 
@@ -754,6 +758,26 @@ cmdChatroomUnsubscribe = do
     to <- getChatroomStateData cid
     void $ chatroomSetSubscribe to False
 
+cmdChatroomMembers :: Command
+cmdChatroomMembers = do
+    [ cid ] <- asks tiParams
+    Just chatroom <- findChatroomByStateData =<< getChatroomStateData cid
+    forM_ (chatroomMembers chatroom) $ \user -> do
+        cmdOut $ unwords [ "chatroom-members-item", maybe "<unnamed>" T.unpack $ idName user ]
+    cmdOut "chatroom-members-done"
+
+cmdChatroomJoin :: Command
+cmdChatroomJoin = do
+    [ cid ] <- asks tiParams
+    joinChatroomByStateData =<< getChatroomStateData cid
+    cmdOut "chatroom-join-done"
+
+cmdChatroomLeave :: Command
+cmdChatroomLeave = do
+    [ cid ] <- asks tiParams
+    leaveChatroomByStateData =<< getChatroomStateData cid
+    cmdOut "chatroom-leave-done"
+
 cmdChatroomMessageSend :: Command
 cmdChatroomMessageSend = do
     [cid, msg] <- asks tiParams
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
index ae373b6..c8b5805 100644
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -11,6 +11,9 @@ module Erebos.Chatroom (
     findChatroomByRoomData,
     findChatroomByStateData,
     chatroomSetSubscribe,
+    chatroomMembers,
+    joinChatroom, joinChatroomByStateData,
+    leaveChatroom, leaveChatroomByStateData,
     getMessagesSinceState,
 
     ChatroomSetChange(..),
@@ -33,6 +36,8 @@ import Control.Monad.IO.Class
 
 import Data.Bool
 import Data.Either
+import Data.Foldable
+import Data.Function
 import Data.IORef
 import Data.List
 import Data.Maybe
@@ -180,23 +185,23 @@ sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStat
 sendChatroomMessageByStateData
     :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
     => Stored ChatroomStateData -> Text -> m ()
-sendChatroomMessageByStateData lookupData msg = void $ findAndUpdateChatroomState $ \cstate -> do
+sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing (Just msg) False
+
+sendRawChatroomMessageByStateData
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => Stored ChatroomStateData -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m ()
+sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do
     guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
     Just $ do
-        self <- finalOwner . localIdentity . fromStored <$> getLocalHead
-        secret <- loadKey $ idKeyMessage self
-        time <- liftIO getZonedTime
-        mdata <- mstore =<< sign secret =<< mstore ChatMessageData
-            { mdPrev = roomStateMessageData cstate
-            , mdRoom = if null (roomStateMessageData cstate)
-                          then maybe [] roomData (roomStateRoom cstate)
-                          else []
-            , mdFrom = self
-            , mdReplyTo = Nothing
-            , mdTime = time
-            , mdText = Just msg
-            , mdLeave = False
-            }
+        mdFrom <- finalOwner . localIdentity . fromStored <$> getLocalHead
+        secret <- loadKey $ idKeyMessage mdFrom
+        mdTime <- liftIO getZonedTime
+        let mdPrev = roomStateMessageData cstate
+            mdRoom = if null (roomStateMessageData cstate)
+                        then maybe [] roomData (roomStateRoom cstate)
+                        else []
+
+        mdata <- mstore =<< sign secret =<< mstore ChatMessageData {..}
         mergeSorted . (:[]) <$> mstore ChatroomStateData
             { rsdPrev = roomStateData cstate
             , rsdRoom = []
@@ -341,6 +346,36 @@ chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $
             , rsdMessages = []
             }
 
+chatroomMembers :: ChatroomState -> [ ComposedIdentity ]
+chatroomMembers ChatroomState {..} =
+    map (mdFrom . fromSigned . head) $
+    filter (any $ not . mdLeave . fromSigned) $ -- keep only users that hasn't left
+    map (filterAncestors . map snd) $ -- gather message data per each identity and filter ancestors
+    groupBy ((==) `on` fst) $ -- group on identity root
+    sortBy (comparing fst) $ -- sort by first root of identity data
+    map (\x -> ( head . filterAncestors . concatMap storedRoots . idDataF . mdFrom . fromSigned $ x, x )) $
+    toList $ ancestors $ roomStateMessageData
+
+joinChatroom
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => ChatroomState -> m ()
+joinChatroom rstate = joinChatroomByStateData (head $ roomStateData rstate)
+
+joinChatroomByStateData
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => Stored ChatroomStateData -> m ()
+joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing False
+
+leaveChatroom
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => ChatroomState -> m ()
+leaveChatroom rstate = leaveChatroomByStateData (head $ roomStateData rstate)
+
+leaveChatroomByStateData
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => Stored ChatroomStateData -> m ()
+leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing True
+
 getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage]
 getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur)
 
diff --git a/test/chatroom.test b/test/chatroom.test
index 1998290..93de1ff 100644
--- a/test/chatroom.test
+++ b/test/chatroom.test
@@ -344,3 +344,85 @@ test ParallelThreads:
 	with p2:
 		expect /chatroom-message-new $room1_p2 room first_room from Owner. text message(..)/ capture msg
 		guard (msg == "1B")
+
+
+test ChatroomMembers:
+	spawn as p1
+	spawn as p2
+	spawn as p3
+
+	send "create-identity Device1 Owner1" to p1
+	send "create-identity Device2 Owner2" to p2
+	send "create-identity Device3 Owner3" to p3
+
+	for p in [ p1, p2, p3 ]:
+		with p:
+			send "chatroom-watch-local"
+			send "start-server"
+
+	send "chatroom-create first_room" to p1
+	expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1
+
+	expect /chatroom-watched-added $room1_p1 first_room sub true/ from p1
+	expect /chatroom-watched-added ([a-z0-9#]+) first_room sub false/ from p2 capture room1_p2
+	expect /chatroom-watched-added ([a-z0-9#]+) first_room sub false/ from p3 capture room1_p3
+
+	local:
+		send "chatroom-members $room1_p1" to p1
+		expect /chatroom-members-([a-z]+)/ from p1 capture done
+		guard (done == "done")
+	local:
+		send "chatroom-members $room1_p2" to p2
+		expect /chatroom-members-([a-z]+)/ from p2 capture done
+		guard (done == "done")
+
+	send "chatroom-message-send $room1_p1 message1" to p1
+	send "chatroom-message-send $room1_p1 message2" to p1
+	send "chatroom-join $room1_p2" to p2
+	send "chatroom-message-send $room1_p2 message3" to p2
+	send "chatroom-join $room1_p3" to p3
+
+	with p1:
+		expect /chatroom-message-new $room1_p1 room first_room from Owner1 text message2/
+		expect /chatroom-message-new $room1_p1 room first_room from Owner2 text message3/
+		expect /chatroom-message-new $room1_p1 room first_room from Owner3/
+	with p2:
+		expect /chatroom-message-new $room1_p2 room first_room from Owner1 text message2/
+		expect /chatroom-message-new $room1_p2 room first_room from Owner2 text message3/
+		expect /chatroom-message-new $room1_p2 room first_room from Owner3/
+	with p3:
+		expect /chatroom-message-new $room1_p3 room first_room from Owner1 text message2/
+		expect /chatroom-message-new $room1_p3 room first_room from Owner2 text message3/
+		expect /chatroom-message-new $room1_p3 room first_room from Owner3/
+
+	local:
+		send "chatroom-members $room1_p1" to p1
+		expect /chatroom-members-item Owner1/ from p1
+		expect /chatroom-members-item Owner2/ from p1
+		expect /chatroom-members-item Owner3/ from p1
+		expect /chatroom-members-([a-z]+)/ from p1 capture done
+		guard (done == "done")
+	local:
+		send "chatroom-members $room1_p2" to p2
+		expect /chatroom-members-item Owner1/ from p2
+		expect /chatroom-members-item Owner2/ from p2
+		expect /chatroom-members-item Owner3/ from p2
+		expect /chatroom-members-([a-z]+)/ from p2 capture done
+		guard (done == "done")
+
+	send "chatroom-leave $room1_p1" to p1
+	send "chatroom-leave $room1_p3" to p3
+
+	for p in [ p1, p2, p3 ]:
+		with p:
+			expect /chatroom-message-new [a-z0-9#]+ room first_room from Owner1 leave/
+			expect /chatroom-message-new [a-z0-9#]+ room first_room from Owner3 leave/
+
+	send "chatroom-members $room1_p1" to p1
+	send "chatroom-members $room1_p2" to p2
+	send "chatroom-members $room1_p3" to p3
+	for p in [ p1, p2, p3 ]:
+		with p:
+			expect /chatroom-members-item Owner2/
+			expect /chatroom-members-([a-z]+)/ capture done
+			guard (done == "done")