Chatroom metadata updates

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.*/