Chatroom-specific identity

Changelog: Chatroom-specific identity

6 files changed, 109 insertions, 8 deletions

diff --git a/README.md b/README.md
index 9535aab..75d9597 100644
--- a/README.md
+++ b/README.md
@@ -128,6 +128,11 @@ are signed, so message author can not be forged.
 `/join`  
 : Join chatroom without sending text message.
 
+`/join-as <name>`  
+: Join chatroom using a new identity with a name `<name>`. This new identity is
+  unrelated to the main one, and will be used for any future messages sent to
+  this chatroom.
+
 `/leave`  
 : Leave the chatroom. User will no longer be listed as a member and erebos tool
   will no longer collect message of this chatroom.
diff --git a/main/Main.hs b/main/Main.hs
index 32c226f..73def51 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -502,6 +502,7 @@ commands =
     , ("ice-send", cmdIceSend)
 #endif
     , ("join", cmdJoin)
+    , ("join-as", cmdJoinAs)
     , ("leave", cmdLeave)
     , ("members", cmdMembers)
     , ("select", cmdSelectContext)
@@ -570,6 +571,13 @@ showPeer pidentity paddr =
 cmdJoin :: Command
 cmdJoin = joinChatroom =<< getSelectedChatroom
 
+cmdJoinAs :: Command
+cmdJoinAs = do
+    name <- asks ciLine
+    st <- getStorage
+    identity <- liftIO $ createIdentity st (Just $ T.pack name) Nothing
+    joinChatroomAs identity =<< getSelectedChatroom
+
 cmdLeave :: Command
 cmdLeave = leaveChatroom =<< getSelectedChatroom
 
diff --git a/main/Test.hs b/main/Test.hs
index 741ffe8..1b156ae 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -290,6 +290,7 @@ commands = map (T.pack *** id)
     , ("chatroom-unsubscribe", cmdChatroomUnsubscribe)
     , ("chatroom-members", cmdChatroomMembers)
     , ("chatroom-join", cmdChatroomJoin)
+    , ("chatroom-join-as", cmdChatroomJoinAs)
     , ("chatroom-leave", cmdChatroomLeave)
     , ("chatroom-message-send", cmdChatroomMessageSend)
     ]
@@ -757,7 +758,7 @@ cmdChatroomListLocal = do
 cmdChatroomWatchLocal :: Command
 cmdChatroomWatchLocal = do
     [] <- asks tiParams
-    h <- getHead
+    h <- getOrLoadHead
     out <- asks tiOutput
     void $ watchChatrooms h $ \_ -> \case
         Nothing -> return ()
@@ -815,6 +816,14 @@ cmdChatroomJoin = do
     joinChatroomByStateData =<< getChatroomStateData cid
     cmdOut "chatroom-join-done"
 
+cmdChatroomJoinAs :: Command
+cmdChatroomJoinAs = do
+    [ cid, name ] <- asks tiParams
+    st <- asks tiStorage
+    identity <- liftIO $ createIdentity st (Just name) Nothing
+    joinChatroomAsByStateData identity =<< getChatroomStateData cid
+    cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ]
+
 cmdChatroomLeave :: Command
 cmdChatroomLeave = do
     [ cid ] <- asks tiParams
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
index 5ba137f..8833450 100644
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -13,6 +13,7 @@ module Erebos.Chatroom (
     chatroomSetSubscribe,
     chatroomMembers,
     joinChatroom, joinChatroomByStateData,
+    joinChatroomAs, joinChatroomAsByStateData,
     leaveChatroom, leaveChatroomByStateData,
     getMessagesSinceState,
 
@@ -185,15 +186,18 @@ sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStat
 sendChatroomMessageByStateData
     :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
     => Stored ChatroomStateData -> Text -> m ()
-sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing (Just msg) False
+sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing 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
+    => Stored ChatroomStateData -> Maybe UnifiedIdentity -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m ()
+sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do
     guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
     Just $ do
-        mdFrom <- finalOwner . localIdentity . fromStored <$> getLocalHead
+        mdFrom <- finalOwner <$> if
+            | Just identity <- mbIdentity -> return identity
+            | Just identity <- roomStateIdentity cstate -> return identity
+            | otherwise -> localIdentity . fromStored <$> getLocalHead
         secret <- loadKey $ idKeyMessage mdFrom
         mdTime <- liftIO getZonedTime
         let mdPrev = roomStateMessageData cstate
@@ -206,6 +210,7 @@ sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ f
             { rsdPrev = roomStateData cstate
             , rsdRoom = []
             , rsdSubscribe = Just (not mdLeave)
+            , rsdIdentity = mbIdentity
             , rsdMessages = [ mdata ]
             }
 
@@ -214,6 +219,7 @@ data ChatroomStateData = ChatroomStateData
     { rsdPrev :: [Stored ChatroomStateData]
     , rsdRoom :: [Stored (Signed ChatroomData)]
     , rsdSubscribe :: Maybe Bool
+    , rsdIdentity :: Maybe UnifiedIdentity
     , rsdMessages :: [Stored (Signed ChatMessageData)]
     }
 
@@ -222,6 +228,7 @@ data ChatroomState = ChatroomState
     , roomStateRoom :: Maybe Chatroom
     , roomStateMessageData :: [Stored (Signed ChatMessageData)]
     , roomStateSubscribe :: Bool
+    , roomStateIdentity :: Maybe UnifiedIdentity
     , roomStateMessages :: [ChatMessage]
     }
 
@@ -230,12 +237,14 @@ instance Storable ChatroomStateData where
         forM_ rsdPrev $ storeRef "PREV"
         forM_ rsdRoom $ storeRef "room"
         forM_ rsdSubscribe $ storeInt "subscribe" . bool @Int 0 1
+        forM_ rsdIdentity $ storeRef "id" . idExtData
         forM_ rsdMessages $ storeRef "msg"
 
     load' = loadRec $ do
         rsdPrev <- loadRefs "PREV"
         rsdRoom <- loadRefs "room"
         rsdSubscribe <- fmap ((/=) @Int 0) <$> loadMbInt "subscribe"
+        rsdIdentity <- loadMbUnifiedIdentity "id"
         rsdMessages <- loadRefs "msg"
         return ChatroomStateData {..}
 
@@ -249,6 +258,7 @@ instance Mergeable ChatroomState where
                 ChatroomStateData {..} | null rsdMessages -> Nothing
                                        | otherwise        -> Just rsdMessages
             roomStateSubscribe = fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData
+            roomStateIdentity = findPropertyFirst rsdIdentity roomStateData
             roomStateMessages = threadToListSince [] $ concatMap (rsdMessages . fromStored) roomStateData
          in ChatroomState {..}
 
@@ -266,6 +276,7 @@ createChatroom rdName rdDescription = do
         { rsdPrev = []
         , rsdRoom = [ rdata ]
         , rsdSubscribe = Just True
+        , rsdIdentity = Nothing
         , rsdMessages = []
         }
 
@@ -313,6 +324,7 @@ updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomStat
             { rsdPrev = roomStateData cstate
             , rsdRoom = [ rdata ]
             , rsdSubscribe = Just True
+            , rsdIdentity = Nothing
             , rsdMessages = []
             }
 
@@ -343,6 +355,7 @@ chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $
             { rsdPrev = roomStateData cstate
             , rsdRoom = []
             , rsdSubscribe = Just subscribe
+            , rsdIdentity = Nothing
             , rsdMessages = []
             }
 
@@ -364,7 +377,17 @@ 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
+joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing False
+
+joinChatroomAs
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => UnifiedIdentity -> ChatroomState -> m ()
+joinChatroomAs identity rstate = joinChatroomAsByStateData identity (head $ roomStateData rstate)
+
+joinChatroomAsByStateData
+    :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+    => UnifiedIdentity -> Stored ChatroomStateData -> m ()
+joinChatroomAsByStateData identity lookupData = sendRawChatroomMessageByStateData lookupData (Just identity) Nothing Nothing False
 
 leaveChatroom
     :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
@@ -374,7 +397,7 @@ 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
+leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing True
 
 getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage]
 getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur)
@@ -498,6 +521,7 @@ instance Service ChatroomService where
                                 { rsdPrev = prev
                                 , rsdRoom = room
                                 , rsdSubscribe = Nothing
+                                , rsdIdentity = Nothing
                                 , rsdMessages = []
                                 }
                             storeSetAddComponent sdata set
@@ -542,6 +566,7 @@ instance Service ChatroomService where
                                     { rsdPrev = prevData
                                     , rsdRoom = []
                                     , rsdSubscribe = Nothing
+                                    , rsdIdentity = Nothing
                                     , rsdMessages = messages
                                     }
                                 storeSetAddComponent sdata set
diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs
index f2094f6..577e5ac 100644
--- a/src/Erebos/Identity.hs
+++ b/src/Erebos/Identity.hs
@@ -13,7 +13,7 @@ module Erebos.Identity (
     createIdentity,
     validateIdentity, validateIdentityF, validateIdentityFE,
     validateExtendedIdentity, validateExtendedIdentityF, validateExtendedIdentityFE,
-    loadIdentity, loadUnifiedIdentity,
+    loadIdentity, loadMbIdentity, loadUnifiedIdentity, loadMbUnifiedIdentity,
 
     mergeIdentity, toUnifiedIdentity, toComposedIdentity,
     updateIdentity, updateOwners,
@@ -282,9 +282,15 @@ validateExtendedIdentityFE mdata = do
 loadIdentity :: String -> LoadRec ComposedIdentity
 loadIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name
 
+loadMbIdentity :: String -> LoadRec (Maybe ComposedIdentity)
+loadMbIdentity name = return . validateExtendedIdentityF =<< loadRefs name
+
 loadUnifiedIdentity :: String -> LoadRec UnifiedIdentity
 loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentity =<< loadRef name
 
+loadMbUnifiedIdentity :: String -> LoadRec (Maybe UnifiedIdentity)
+loadMbUnifiedIdentity name = return . (validateExtendedIdentity =<<) =<< loadMbRef name
+
 
 gatherPrevious :: Set (Stored (Signed ExtendedIdentityData)) -> [Stored (Signed ExtendedIdentityData)] -> Set (Stored (Signed ExtendedIdentityData))
 gatherPrevious res (n:ns) | n `S.member` res = gatherPrevious res ns
diff --git a/test/chatroom.test b/test/chatroom.test
index deea2cb..4dda21e 100644
--- a/test/chatroom.test
+++ b/test/chatroom.test
@@ -429,3 +429,51 @@ test ChatroomMembers:
 			expect /chatroom-members-item Owner2/
 			expect /chatroom-members-([a-z]+)/ capture done
 			guard (done == "done")
+
+
+test ChatroomIdentity:
+	spawn as p1
+	spawn as p2
+
+	send "create-identity Device1 Owner1" to p1
+	send "create-identity Device2 Owner2" to p2
+
+	for p in [ p1, p2 ]:
+		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 ([a-z0-9#]+) first_room sub false/ from p2 capture room1_p2
+
+	send "chatroom-join-as $room1_p1 Custom1" to p1
+	expect /chatroom-join-as-done $room1_p1/ from p1
+	send "chatroom-join-as $room1_p2 Custom2" to p2
+	expect /chatroom-join-as-done $room1_p2/ from p2
+
+	send "chatroom-message-send $room1_p1 message1" to p1
+	send "chatroom-message-send $room1_p2 message2" to p2
+
+	for p in [ p1, p2 ]:
+		with p:
+			expect /chatroom-message-new [a-z0-9#]+ room first_room from ([^ ]+) text message1/ capture name1
+			guard (name1 == "Custom1")
+			expect /chatroom-message-new [a-z0-9#]+ room first_room from ([^ ]+) text message2/ capture name2
+			guard (name2 == "Custom2")
+
+	spawn as p1b on p1.node
+	spawn as p2b on p2.node
+	for p in [ p1b, p2b ]:
+		with p:
+			send "chatroom-watch-local"
+
+	send "chatroom-message-send $room1_p1 message3" to p1b
+	send "chatroom-message-send $room1_p2 message4" to p2b
+
+	for p in [ p1, p2, p1b, p2b ]:
+		with p:
+			expect /chatroom-message-new [a-z0-9#]+ room first_room from ([^ ]+) text message3/ capture name1
+			guard (name1 == "Custom1")
+			expect /chatroom-message-new [a-z0-9#]+ room first_room from ([^ ]+) text message4/ capture name2
+			guard (name2 == "Custom2")