From 2c297cb6747080cd47cdcd9bbd23c5f24a092e8f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 13 Apr 2024 08:29:25 +0200 Subject: Chatroom metadata updates --- main/Test.hs | 26 ++++++++++++--- src/Erebos/Chatroom.hs | 77 +++++++++++++++++++++++++++++++++++++++------ src/Erebos/Storage/Merge.hs | 4 +++ test/chatroom.test | 24 +++++++++++++- 4 files changed, 116 insertions(+), 15 deletions(-) diff --git a/main/Test.hs b/main/Test.hs index b32872a..7aadd47 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -268,6 +268,7 @@ commands = map (T.pack *** id) , ("chatroom-create", cmdChatroomCreate) , ("chatroom-list-local", cmdChatroomListLocal) , ("chatroom-watch-local", cmdChatroomWatchLocal) + , ("chatroom-set-name", cmdChatroomSetName) ] cmdStore :: Command @@ -574,7 +575,22 @@ cmdDmListContact = do cmdChatroomCreate :: Command cmdChatroomCreate = do [name] <- asks tiParams - void $ createChatroom (Just name) Nothing + room <- createChatroom (Just name) Nothing + cmdOut $ unwords $ "chatroom-create-done" : chatroomInfo room + +getChatroomStateData :: Text -> CommandM (Stored ChatroomStateData) +getChatroomStateData tref = do + st <- asks tiStorage + Just ref <- liftIO $ readRef st (encodeUtf8 tref) + return $ wrappedLoad ref + +cmdChatroomSetName :: Command +cmdChatroomSetName = do + [cid, name] <- asks tiParams + sdata <- getChatroomStateData cid + updateChatroomByStateData sdata (Just name) Nothing >>= \case + Just room -> cmdOut $ unwords $ "chatroom-set-name-done" : chatroomInfo room + Nothing -> cmdOut "chatroom-set-name-failed" cmdChatroomListLocal :: Command cmdChatroomListLocal = do @@ -594,9 +610,11 @@ cmdChatroomWatchLocal = do Just diff -> forM_ diff $ \case AddedChatroom room -> outLine out $ unwords $ "chatroom-watched-added" : chatroomInfo room RemovedChatroom room -> outLine out $ unwords $ "chatroom-watched-removed" : chatroomInfo room - UpdatedChatroom oldroom room -> outLine out $ unwords $ "chatroom-watched-updated" : chatroomInfo room ++ - map (show . refDigest . storedRef) (roomStateData oldroom) ++ - map (show . refDigest . storedRef) (roomStateData room) + UpdatedChatroom oldroom room -> outLine out $ unwords $ concat + [ [ "chatroom-watched-updated" ], chatroomInfo room + , [ "old" ], map (show . refDigest . storedRef) (roomStateData oldroom) + , [ "new" ], map (show . refDigest . storedRef) (roomStateData room) + ] chatroomInfo :: ChatroomState -> [String] chatroomInfo room = diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index abd114c..3f117d5 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -4,8 +4,12 @@ module Erebos.Chatroom ( validateChatroom, ChatroomState(..), + ChatroomStateData(..), createChatroom, + updateChatroomByStateData, listChatrooms, + findChatroomByRoomData, + findChatroomByStateData, ChatroomSetChange(..), watchChatrooms, @@ -18,6 +22,7 @@ import Control.Monad import Control.Monad.Except import Data.IORef +import Data.List import Data.Maybe import Data.Monoid import Data.Ord @@ -115,26 +120,78 @@ instance Mergeable ChatroomState where instance SharedType (Set ChatroomState) where sharedTypeID _ = mkSharedTypeID "7bc71cbf-bc43-42b1-b413-d3a2c9a2aae0" -createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError String m) => Maybe Text -> Maybe Text -> m Chatroom +createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError String m) => Maybe Text -> Maybe Text -> m ChatroomState createChatroom rdName rdDescription = do - st <- getStorage - (secret, rdKey) <- liftIO $ generateKeys st + (secret, rdKey) <- liftIO . generateKeys =<< getStorage let rdPrev = [] - rdata <- wrappedStore st =<< sign secret =<< wrappedStore st ChatroomData {..} - room <- liftEither $ runExcept $ validateChatroom [ rdata ] + rdata <- mstore =<< sign secret =<< mstore ChatroomData {..} + cstate <- mergeSorted . (:[]) <$> mstore ChatroomStateData + { rsdPrev = [] + , rsdRoom = [ rdata ] + } - updateLocalHead_ $ updateSharedState_ $ \rooms -> do - sdata <- wrappedStore st ChatroomStateData - { rsdPrev = [] + updateLocalHead $ updateSharedState $ \rooms -> do + st <- getStorage + (, cstate) <$> storeSetAdd st cstate rooms + +findAndUpdateChatroomState + :: (MonadStorage m, MonadHead LocalState m) + => (ChatroomState -> Maybe (m ChatroomState)) + -> m (Maybe ChatroomState) +findAndUpdateChatroomState f = do + updateLocalHead $ updateSharedState $ \roomSet -> do + let roomList = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet + case catMaybes $ map (\x -> (x,) <$> f x) roomList of + ((orig, act) : _) -> do + upd <- act + if roomStateData orig /= roomStateData upd + then do + st <- getStorage + roomSet' <- storeSetAdd st upd roomSet + return (roomSet', Just upd) + else do + return (roomSet, Just upd) + [] -> return (roomSet, Nothing) + +updateChatroomByStateData + :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + => Stored ChatroomStateData + -> Maybe Text + -> Maybe Text + -> m (Maybe ChatroomState) +updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomState $ \cstate -> do + guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate + room <- roomStateRoom cstate + Just $ do + secret <- loadKey $ roomKey room + rdata <- mstore =<< sign secret =<< mstore ChatroomData + { rdPrev = roomData room + , rdName = newName + , rdDescription = newDesc + , rdKey = roomKey room + } + mergeSorted . (:[]) <$> mstore ChatroomStateData + { rsdPrev = roomStateData cstate , rsdRoom = [ rdata ] } - storeSetAdd st (mergeSorted @ChatroomState [ sdata ]) rooms - return room + listChatrooms :: MonadHead LocalState m => m [ChatroomState] listChatrooms = fromSetBy (comparing $ roomName <=< roomStateRoom) . lookupSharedValue . lsShared . fromStored <$> getLocalHead +findChatroom :: MonadHead LocalState m => (ChatroomState -> Bool) -> m (Maybe ChatroomState) +findChatroom p = do + list <- map snd . chatroomSetToList . lookupSharedValue . lsShared . fromStored <$> getLocalHead + return $ find p list + +findChatroomByRoomData :: MonadHead LocalState m => Stored (Signed ChatroomData) -> m (Maybe ChatroomState) +findChatroomByRoomData cdata = findChatroom $ + maybe False (any (cdata `precedesOrEquals`) . roomData) . roomStateRoom + +findChatroomByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> m (Maybe ChatroomState) +findChatroomByStateData cdata = findChatroom $ any (cdata `precedesOrEquals`) . roomStateData + data ChatroomSetChange = AddedChatroom ChatroomState | RemovedChatroom ChatroomState diff --git a/src/Erebos/Storage/Merge.hs b/src/Erebos/Storage/Merge.hs index 7234b87..9d9db13 100644 --- a/src/Erebos/Storage/Merge.hs +++ b/src/Erebos/Storage/Merge.hs @@ -10,6 +10,7 @@ module Erebos.Storage.Merge ( generations, ancestors, precedes, + precedesOrEquals, filterAncestors, storedRoots, walkAncestors, @@ -109,6 +110,9 @@ ancestors = last . (S.empty:) . generations precedes :: Storable a => Stored a -> Stored a -> Bool precedes x y = not $ x `elem` filterAncestors [x, y] +precedesOrEquals :: Storable a => Stored a -> Stored a -> Bool +precedesOrEquals x y = filterAncestors [ x, y ] == [ y ] + filterAncestors :: Storable a => [Stored a] -> [Stored a] filterAncestors [x] = [x] filterAncestors xs = let xs' = uniq $ sort xs diff --git a/test/chatroom.test b/test/chatroom.test index 89cf18a..ac66f38 100644 --- a/test/chatroom.test +++ b/test/chatroom.test @@ -9,12 +9,16 @@ test ChatroomSetup: send "chatroom-create second" send "chatroom-list-local" - expect /chatroom-list-item [a-z0-9#]+ first/ + + expect /chatroom-list-item ([a-z0-9#]+) first/ capture first expect /chatroom-list-item [a-z0-9#]+ second/ local: expect /chatroom-list-(.*)/ capture done guard (done == "done") + expect /chatroom-create-done ([a-z0-9#]+) first.*/ from p1 capture first + expect /chatroom-create-done ([a-z0-9#]+) second.*/ from p1 capture second + # Send chatrooms to new peers spawn as p2 @@ -46,8 +50,26 @@ test ChatroomSetup: send "chatroom-create third" to p1 send "chatroom-create fourth" to p2 send "chatroom-create fifth" to p3 + + expect /chatroom-create-done ([a-z0-9#]+) fourth.*/ from p2 capture fourth + expect /chatroom-create-done ([a-z0-9#]+) fifth.*/ from p3 capture fifth + for p in [ p1, p2, p3 ]: with p: expect /chatroom-watched-added [a-z0-9#]+ third/ expect /chatroom-watched-added [a-z0-9#]+ fourth/ expect /chatroom-watched-added [a-z0-9#]+ fifth/ + + # Update chatroom name + + send "chatroom-set-name $first first2" to p1 + for p in [ p1, p2, p3 ]: + with p: + expect /chatroom-watched-updated [a-z0-9#]+ first2.*/ + + send "chatroom-set-name $fourth fourth2" to p2 + send "chatroom-set-name $fifth fifth2" to p3 + for p in [ p1, p2, p3 ]: + with p: + expect /chatroom-watched-updated [a-z0-9#]+ fourth2.*/ + expect /chatroom-watched-updated [a-z0-9#]+ fifth2.*/ -- cgit v1.2.3