summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2024-04-06 19:07:27 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2024-04-17 20:59:41 +0200
commit943cd6e754453f70deae6ad89c6045b42c59e9c9 (patch)
treef7ff52bfbfacacc6af7e2793c3d60651a10c71dc /src
parentd684bc2b012e23e3cc0dfa1195a74abac661b926 (diff)
Chatroom service
Diffstat (limited to 'src')
-rw-r--r--src/Erebos/Chatroom.hs136
-rw-r--r--src/Erebos/Set.hs8
-rw-r--r--src/Erebos/State.hs2
3 files changed, 146 insertions, 0 deletions
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)