Chatroom service

5 files changed, 210 insertions, 10 deletions

diff --git a/main/Test.hs b/main/Test.hs
index 182d941..b32872a 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -267,6 +267,7 @@ commands = map (T.pack *** id)
     , ("dm-list-contact", cmdDmListContact)
     , ("chatroom-create", cmdChatroomCreate)
     , ("chatroom-list-local", cmdChatroomListLocal)
+    , ("chatroom-watch-local", cmdChatroomWatchLocal)
     ]
 
 cmdStore :: Command
@@ -346,6 +347,7 @@ cmdStartServer = do
         , someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"
         , someServiceAttr $ directMessageAttributes out
         , someService @SyncService Proxy
+        , someService @ChatroomService Proxy
         , someServiceAttr $ (defaultServiceAttributes Proxy)
             { testMessageReceived = \otype len sref ->
                 liftIO $ outLine out $ unwords ["test-message-received", otype, len, sref]
@@ -577,14 +579,27 @@ cmdChatroomCreate = do
 cmdChatroomListLocal :: Command
 cmdChatroomListLocal = do
     [] <- asks tiParams
-    h <- getHead
-    let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) . lookupSharedValue . lsShared . headObject $ h
+    rooms <- listChatrooms
     forM_ rooms $ \room -> do
-        r:_ <- return $ filterAncestors $ concatMap storedRoots $ toComponents room
-        cmdOut $ concat
-            [ "chatroom-list-item "
-            , show $ refDigest $ storedRef r
-            , " "
-            , maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom room
-            ]
+        cmdOut $ unwords $ "chatroom-list-item" : chatroomInfo room
     cmdOut "chatroom-list-done"
+
+cmdChatroomWatchLocal :: Command
+cmdChatroomWatchLocal = do
+    [] <- asks tiParams
+    h <- getHead
+    out <- asks tiOutput
+    void $ watchChatrooms h $ \_ -> \case
+        Nothing -> return ()
+        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)
+
+chatroomInfo :: ChatroomState -> [String]
+chatroomInfo room =
+    [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room
+    , maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom room
+    ]
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
index 90848dd..abd114c 100644
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -5,19 +5,31 @@ module Erebos.Chatroom (
 
     ChatroomState(..),
     createChatroom,
+    listChatrooms,
+
+    ChatroomSetChange(..),
+    watchChatrooms,
+
+    ChatroomService(..),
 ) where
 
+import Control.Arrow
 import Control.Monad
 import Control.Monad.Except
 
+import Data.IORef
+import Data.Maybe
 import Data.Monoid
+import Data.Ord
 import Data.Text (Text)
 
 import Erebos.PubKey
+import Erebos.Service
 import Erebos.Set
 import Erebos.State
 import Erebos.Storage
 import Erebos.Storage.Merge
+import Erebos.Util
 
 
 data ChatroomData = ChatroomData
@@ -118,3 +130,127 @@ createChatroom rdName rdDescription = do
             }
         storeSetAdd st (mergeSorted @ChatroomState [ sdata ]) rooms
     return room
+
+listChatrooms :: MonadHead LocalState m => m [ChatroomState]
+listChatrooms = fromSetBy (comparing $ roomName <=< roomStateRoom) .
+    lookupSharedValue . lsShared . fromStored <$> getLocalHead
+
+
+data ChatroomSetChange = AddedChatroom ChatroomState
+                       | RemovedChatroom ChatroomState
+                       | UpdatedChatroom ChatroomState ChatroomState
+
+watchChatrooms :: MonadIO m => Head LocalState -> (Set ChatroomState -> Maybe [ChatroomSetChange] -> IO ()) -> m WatchedHead
+watchChatrooms h f = liftIO $ do
+    lastVar <- newIORef Nothing
+    watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \cur -> do
+        let curList = chatroomSetToList cur
+        mbLast <- readIORef lastVar
+        writeIORef lastVar $ Just curList
+        f cur $ do
+            lastList <- mbLast
+            return $ makeChatroomDiff lastList curList
+
+chatroomSetToList :: Set ChatroomState -> [(Stored ChatroomStateData, ChatroomState)]
+chatroomSetToList = map (cmp &&& id) . fromSetBy (comparing cmp)
+  where
+    cmp :: ChatroomState -> Stored ChatroomStateData
+    cmp = head . filterAncestors . concatMap storedRoots . toComponents
+
+makeChatroomDiff
+    :: [(Stored ChatroomStateData, ChatroomState)]
+    -> [(Stored ChatroomStateData, ChatroomState)]
+    -> [ChatroomSetChange]
+makeChatroomDiff (x@(cx, vx) : xs) (y@(cy, vy) : ys)
+    | cx < cy = RemovedChatroom vx : makeChatroomDiff xs (y : ys)
+    | cx > cy = AddedChatroom vy : makeChatroomDiff (x : xs) ys
+    | roomStateData vx /= roomStateData vy = UpdatedChatroom vx vy : makeChatroomDiff xs ys
+    | otherwise = makeChatroomDiff xs ys
+makeChatroomDiff xs [] = map (RemovedChatroom . snd) xs
+makeChatroomDiff [] ys = map (AddedChatroom . snd) ys
+
+
+data ChatroomService = ChatroomService
+    { chatRoomQuery :: Bool
+    , chatRoomInfo :: [Stored (Signed ChatroomData)]
+    }
+
+emptyPacket :: ChatroomService
+emptyPacket = ChatroomService
+    { chatRoomQuery = False
+    , chatRoomInfo = []
+    }
+
+instance Storable ChatroomService where
+    store' ChatroomService {..} = storeRec $ do
+        when  chatRoomQuery $ storeEmpty "room-query"
+        forM_ chatRoomInfo $ storeRef "room-info"
+
+    load' = loadRec $ do
+        chatRoomQuery <- isJust <$> loadMbEmpty "room-query"
+        chatRoomInfo <- loadRefs "room-info"
+        return ChatroomService {..}
+
+data PeerState = PeerState
+    { psSendRoomUpdates :: Bool
+    , psLastList :: [(Stored ChatroomStateData, ChatroomState)]
+    }
+
+instance Service ChatroomService where
+    serviceID _ = mkServiceID "627657ae-3e39-468a-8381-353395ef4386"
+
+    type ServiceState ChatroomService = PeerState
+    emptyServiceState _ = PeerState
+        { psSendRoomUpdates = False
+        , psLastList = []
+        }
+
+    serviceHandler spacket = do
+        let ChatroomService {..} = fromStored spacket
+        svcModify $ \s -> s { psSendRoomUpdates = True }
+
+        when chatRoomQuery $ do
+            rooms <- listChatrooms
+            replyPacket emptyPacket
+                { chatRoomInfo = concatMap roomData $ catMaybes $ map roomStateRoom rooms
+                }
+
+        when (not $ null chatRoomInfo) $ do
+            updateLocalHead_ $ updateSharedState_ $ \roomSet -> do
+                let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet
+                    upd set (roomInfo :: Stored (Signed ChatroomData)) = do
+                        let currentRoots = storedRoots roomInfo
+                            isCurrentRoom = any ((`intersectsSorted` currentRoots) . storedRoots) .
+                                concatMap (rsdRoom . fromStored) . roomStateData
+
+                        let prev = concatMap roomStateData $ filter isCurrentRoom rooms
+                            prevRoom = concatMap (rsdRoom . fromStored) prev
+                            room = filterAncestors $ (roomInfo : ) prevRoom
+
+                        -- update local state only if we got roomInfo not present there
+                        if roomInfo `notElem` prevRoom && roomInfo `elem` room
+                          then do
+                            sdata <- mstore ChatroomStateData { rsdPrev = prev, rsdRoom = room }
+                            storeSetAddComponent sdata set
+                          else return set
+                foldM upd roomSet chatRoomInfo
+
+    serviceNewPeer = do
+        replyPacket emptyPacket { chatRoomQuery = True }
+
+    serviceStorageWatchers _ = (:[]) $
+        SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncChatroomsToPeer
+
+syncChatroomsToPeer :: Set ChatroomState -> ServiceHandler ChatroomService ()
+syncChatroomsToPeer set = do
+    ps@PeerState {..} <- svcGet
+    when psSendRoomUpdates $ do
+        let curList = chatroomSetToList set
+        updates <- fmap (concat . catMaybes) $
+            forM (makeChatroomDiff psLastList curList) $ return . \case
+                AddedChatroom room -> roomData <$> roomStateRoom room
+                RemovedChatroom {} -> Nothing
+                UpdatedChatroom _ room -> roomData <$> roomStateRoom room
+        when (not $ null updates) $ do
+            replyPacket $ emptyPacket { chatRoomInfo = updates }
+        svcSet $ ps { psLastList = curList }
diff --git a/src/Erebos/Set.hs b/src/Erebos/Set.hs
index 0abe02d..c5edd56 100644
--- a/src/Erebos/Set.hs
+++ b/src/Erebos/Set.hs
@@ -4,6 +4,7 @@ module Erebos.Set (
     emptySet,
     loadSet,
     storeSetAdd,
+    storeSetAddComponent,
 
     fromSetBy,
 ) where
@@ -23,6 +24,7 @@ import Erebos.Storage.Merge
 import Erebos.Util
 
 data Set a = Set [Stored (SetItem (Component a))]
+    deriving (Eq)
 
 data SetItem a = SetItem
     { siPrev :: [Stored (SetItem a)]
@@ -56,6 +58,12 @@ storeSetAdd st x (Set prev) = Set . (:[]) <$> wrappedStore st SetItem
     , siItem = toComponents x
     }
 
+storeSetAddComponent :: (Mergeable a, MonadStorage m, MonadIO m) => Stored (Component a) -> Set a -> m (Set a)
+storeSetAddComponent component (Set prev) = Set . (:[]) <$> mstore SetItem
+    { siPrev = prev
+    , siItem = [ component ]
+    }
+
 
 fromSetBy :: forall a. Mergeable a => (a -> a -> Ordering) -> Set a -> [a]
 fromSetBy cmp (Set heads) = sortBy cmp $ map merge $ groupRelated items
diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs
index 1f0bf7d..324127a 100644
--- a/src/Erebos/State.hs
+++ b/src/Erebos/State.hs
@@ -86,6 +86,8 @@ instance SharedType (Maybe ComposedIdentity) where
 
 class (MonadIO m, MonadStorage m) => MonadHead a m where
     updateLocalHead :: (Stored a -> m (Stored a, b)) -> m b
+    getLocalHead :: m (Stored a)
+    getLocalHead = updateLocalHead $ \x -> return (x, x)
 
 updateLocalHead_ :: MonadHead a m => (Stored a -> m (Stored a)) -> m ()
 updateLocalHead_ f = updateLocalHead (fmap (,()) . f)
diff --git a/test/chatroom.test b/test/chatroom.test
index b63b01b..89cf18a 100644
--- a/test/chatroom.test
+++ b/test/chatroom.test
@@ -1,4 +1,6 @@
-test LocalChatrooms:
+test ChatroomSetup:
+	# Local chatrooms
+
 	spawn as p1
 	with p1:
 		send "create-identity Device1 Owner1"
@@ -12,3 +14,40 @@ test LocalChatrooms:
 		local:
 			expect /chatroom-list-(.*)/ capture done
 			guard (done == "done")
+
+	# Send chatrooms to new peers
+
+	spawn as p2
+	send "create-identity Device2 Owner2" to p2
+
+	spawn as p3
+	send "create-identity Device3 Owner3" to p3
+
+	for p in [ p1, p2, p3 ]:
+		with p:
+			send "chatroom-watch-local"
+			send "start-server"
+
+	for p in [ p2, p3 ]:
+		with p:
+			expect /chatroom-watched-added [a-z0-9#]+ first/
+			expect /chatroom-watched-added [a-z0-9#]+ second/
+
+	with p2:
+		send "chatroom-list-local"
+		expect /chatroom-list-item [a-z0-9#]+ first/
+		expect /chatroom-list-item [a-z0-9#]+ second/
+		local:
+			expect /chatroom-list-(.*)/ capture done
+			guard (done == "done")
+
+	# Create and sync additional chatrooms
+
+	send "chatroom-create third" to p1
+	send "chatroom-create fourth" to p2
+	send "chatroom-create fifth" to p3
+	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/