diff options
| -rw-r--r-- | main/Test.hs | 33 | ||||
| -rw-r--r-- | src/Erebos/Chatroom.hs | 136 | ||||
| -rw-r--r-- | src/Erebos/Set.hs | 8 | ||||
| -rw-r--r-- | src/Erebos/State.hs | 2 | ||||
| -rw-r--r-- | test/chatroom.test | 41 |
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/ |