summaryrefslogtreecommitdiff
path: root/src/Erebos
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2024-04-13 08:29:25 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2024-04-17 20:59:41 +0200
commit2c297cb6747080cd47cdcd9bbd23c5f24a092e8f (patch)
tree17dc2a42dc3d33ac92e5dfcd95c442626c11597a /src/Erebos
parent943cd6e754453f70deae6ad89c6045b42c59e9c9 (diff)
Chatroom metadata updates
Diffstat (limited to 'src/Erebos')
-rw-r--r--src/Erebos/Chatroom.hs77
-rw-r--r--src/Erebos/Storage/Merge.hs4
2 files changed, 71 insertions, 10 deletions
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