diff options
| -rw-r--r-- | README.md | 5 | ||||
| -rw-r--r-- | main/Main.hs | 8 | ||||
| -rw-r--r-- | main/Test.hs | 11 | ||||
| -rw-r--r-- | src/Erebos/Chatroom.hs | 37 | ||||
| -rw-r--r-- | src/Erebos/Identity.hs | 8 | ||||
| -rw-r--r-- | test/chatroom.test | 48 |
6 files changed, 109 insertions, 8 deletions
@@ -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") |