summaryrefslogtreecommitdiff
path: root/src/Erebos/Chatroom.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos/Chatroom.hs')
-rw-r--r--src/Erebos/Chatroom.hs123
1 files changed, 81 insertions, 42 deletions
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs
index c8b5805..74456ff 100644
--- a/src/Erebos/Chatroom.hs
+++ b/src/Erebos/Chatroom.hs
@@ -6,6 +6,7 @@ module Erebos.Chatroom (
ChatroomState(..),
ChatroomStateData(..),
createChatroom,
+ deleteChatroomByStateData,
updateChatroomByStateData,
listChatrooms,
findChatroomByRoomData,
@@ -13,6 +14,7 @@ module Erebos.Chatroom (
chatroomSetSubscribe,
chatroomMembers,
joinChatroom, joinChatroomByStateData,
+ joinChatroomAs, joinChatroomAsByStateData,
leaveChatroom, leaveChatroomByStateData,
getMessagesSinceState,
@@ -52,7 +54,8 @@ import Erebos.PubKey
import Erebos.Service
import Erebos.Set
import Erebos.State
-import Erebos.Storage
+import Erebos.Storable
+import Erebos.Storage.Head
import Erebos.Storage.Merge
import Erebos.Util
@@ -178,22 +181,25 @@ threadToListSince since thread = helper (S.fromList since) thread
cmpView msg = (zonedTimeToUTC $ mdTime $ fromSigned msg, msg)
sendChatroomMessage
- :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+ :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
=> ChatroomState -> Text -> m ()
sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStateData rstate) msg
sendChatroomMessageByStateData
- :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+ :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
=> Stored ChatroomStateData -> Text -> m ()
-sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing (Just msg) False
+sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing Nothing (Just msg) False
sendRawChatroomMessageByStateData
- :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
- => Stored ChatroomStateData -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m ()
-sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do
+ :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+ => Stored ChatroomStateData -> Maybe UnifiedIdentity -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m ()
+sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do
guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
Just $ do
- mdFrom <- finalOwner . localIdentity . fromStored <$> getLocalHead
+ mdFrom <- finalOwner <$> if
+ | Just identity <- mbIdentity -> return identity
+ | Just identity <- roomStateIdentity cstate -> return identity
+ | otherwise -> localIdentity . fromStored <$> getLocalHead
secret <- loadKey $ idKeyMessage mdFrom
mdTime <- liftIO getZonedTime
let mdPrev = roomStateMessageData cstate
@@ -202,10 +208,10 @@ sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ f
else []
mdata <- mstore =<< sign secret =<< mstore ChatMessageData {..}
- mergeSorted . (:[]) <$> mstore ChatroomStateData
+ mergeSorted . (:[]) <$> mstore emptyChatroomStateData
{ rsdPrev = roomStateData cstate
- , rsdRoom = []
- , rsdSubscribe = Just True
+ , rsdSubscribe = Just (not mdLeave)
+ , rsdIdentity = mbIdentity
, rsdMessages = [ mdata ]
}
@@ -213,15 +219,29 @@ sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ f
data ChatroomStateData = ChatroomStateData
{ rsdPrev :: [Stored ChatroomStateData]
, rsdRoom :: [Stored (Signed ChatroomData)]
+ , rsdDelete :: Bool
, rsdSubscribe :: Maybe Bool
+ , rsdIdentity :: Maybe UnifiedIdentity
, rsdMessages :: [Stored (Signed ChatMessageData)]
}
+emptyChatroomStateData :: ChatroomStateData
+emptyChatroomStateData = ChatroomStateData
+ { rsdPrev = []
+ , rsdRoom = []
+ , rsdDelete = False
+ , rsdSubscribe = Nothing
+ , rsdIdentity = Nothing
+ , rsdMessages = []
+ }
+
data ChatroomState = ChatroomState
{ roomStateData :: [Stored ChatroomStateData]
, roomStateRoom :: Maybe Chatroom
, roomStateMessageData :: [Stored (Signed ChatMessageData)]
+ , roomStateDeleted :: Bool
, roomStateSubscribe :: Bool
+ , roomStateIdentity :: Maybe UnifiedIdentity
, roomStateMessages :: [ChatMessage]
}
@@ -229,13 +249,17 @@ instance Storable ChatroomStateData where
store' ChatroomStateData {..} = storeRec $ do
forM_ rsdPrev $ storeRef "PREV"
forM_ rsdRoom $ storeRef "room"
+ when rsdDelete $ storeEmpty "delete"
forM_ rsdSubscribe $ storeInt "subscribe" . bool @Int 0 1
+ forM_ rsdIdentity $ storeRef "id" . idExtData
forM_ rsdMessages $ storeRef "msg"
load' = loadRec $ do
rsdPrev <- loadRefs "PREV"
rsdRoom <- loadRefs "room"
+ rsdDelete <- isJust <$> loadMbEmpty "delete"
rsdSubscribe <- fmap ((/=) @Int 0) <$> loadMbInt "subscribe"
+ rsdIdentity <- loadMbUnifiedIdentity "id"
rsdMessages <- loadRefs "msg"
return ChatroomStateData {..}
@@ -248,7 +272,9 @@ instance Mergeable ChatroomState where
roomStateMessageData = filterAncestors $ concat $ flip findProperty roomStateData $ \case
ChatroomStateData {..} | null rsdMessages -> Nothing
| otherwise -> Just rsdMessages
- roomStateSubscribe = fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData
+ roomStateDeleted = any (rsdDelete . fromStored) roomStateData
+ roomStateSubscribe = not roomStateDeleted && (fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData)
+ roomStateIdentity = findPropertyFirst rsdIdentity roomStateData
roomStateMessages = threadToListSince [] $ concatMap (rsdMessages . fromStored) roomStateData
in ChatroomState {..}
@@ -257,19 +283,17 @@ 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 ChatroomState
+createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e) => Maybe Text -> Maybe Text -> m ChatroomState
createChatroom rdName rdDescription = do
(secret, rdKey) <- liftIO . generateKeys =<< getStorage
let rdPrev = []
rdata <- mstore =<< sign secret =<< mstore ChatroomData {..}
- cstate <- mergeSorted . (:[]) <$> mstore ChatroomStateData
- { rsdPrev = []
- , rsdRoom = [ rdata ]
+ cstate <- mergeSorted . (:[]) <$> mstore emptyChatroomStateData
+ { rsdRoom = [ rdata ]
, rsdSubscribe = Just True
- , rsdMessages = []
}
- updateLocalHead $ updateSharedState $ \rooms -> do
+ updateLocalState $ updateSharedState $ \rooms -> do
st <- getStorage
(, cstate) <$> storeSetAdd st cstate rooms
@@ -278,7 +302,7 @@ findAndUpdateChatroomState
=> (ChatroomState -> Maybe (m ChatroomState))
-> m (Maybe ChatroomState)
findAndUpdateChatroomState f = do
- updateLocalHead $ updateSharedState $ \roomSet -> do
+ updateLocalState $ updateSharedState $ \roomSet -> do
let roomList = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet
case catMaybes $ map (\x -> (x,) <$> f x) roomList of
((orig, act) : _) -> do
@@ -292,8 +316,19 @@ findAndUpdateChatroomState f = do
return (roomSet, Just upd)
[] -> return (roomSet, Nothing)
+deleteChatroomByStateData
+ :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+ => Stored ChatroomStateData -> m ()
+deleteChatroomByStateData lookupData = void $ findAndUpdateChatroomState $ \cstate -> do
+ guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
+ Just $ do
+ mergeSorted . (:[]) <$> mstore emptyChatroomStateData
+ { rsdPrev = roomStateData cstate
+ , rsdDelete = True
+ }
+
updateChatroomByStateData
- :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+ :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
=> Stored ChatroomStateData
-> Maybe Text
-> Maybe Text
@@ -309,16 +344,16 @@ updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomStat
, rdDescription = newDesc
, rdKey = roomKey room
}
- mergeSorted . (:[]) <$> mstore ChatroomStateData
+ mergeSorted . (:[]) <$> mstore emptyChatroomStateData
{ rsdPrev = roomStateData cstate
, rsdRoom = [ rdata ]
, rsdSubscribe = Just True
- , rsdMessages = []
}
listChatrooms :: MonadHead LocalState m => m [ChatroomState]
-listChatrooms = fromSetBy (comparing $ roomName <=< roomStateRoom) .
+listChatrooms = filter (not . roomStateDeleted) .
+ fromSetBy (comparing $ roomName <=< roomStateRoom) .
lookupSharedValue . lsShared . fromStored <$> getLocalHead
findChatroom :: MonadHead LocalState m => (ChatroomState -> Bool) -> m (Maybe ChatroomState)
@@ -334,16 +369,14 @@ findChatroomByStateData :: MonadHead LocalState m => Stored ChatroomStateData ->
findChatroomByStateData cdata = findChatroom $ any (cdata `precedesOrEquals`) . roomStateData
chatroomSetSubscribe
- :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+ :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
=> Stored ChatroomStateData -> Bool -> m ()
chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $ \cstate -> do
guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate
Just $ do
- mergeSorted . (:[]) <$> mstore ChatroomStateData
+ mergeSorted . (:[]) <$> mstore emptyChatroomStateData
{ rsdPrev = roomStateData cstate
- , rsdRoom = []
, rsdSubscribe = Just subscribe
- , rsdMessages = []
}
chatroomMembers :: ChatroomState -> [ ComposedIdentity ]
@@ -357,24 +390,34 @@ chatroomMembers ChatroomState {..} =
toList $ ancestors $ roomStateMessageData
joinChatroom
- :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+ :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
=> ChatroomState -> m ()
joinChatroom rstate = joinChatroomByStateData (head $ roomStateData rstate)
joinChatroomByStateData
- :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+ :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
=> Stored ChatroomStateData -> m ()
-joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing False
+joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing False
+
+joinChatroomAs
+ :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+ => UnifiedIdentity -> ChatroomState -> m ()
+joinChatroomAs identity rstate = joinChatroomAsByStateData identity (head $ roomStateData rstate)
+
+joinChatroomAsByStateData
+ :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
+ => UnifiedIdentity -> Stored ChatroomStateData -> m ()
+joinChatroomAsByStateData identity lookupData = sendRawChatroomMessageByStateData lookupData (Just identity) Nothing Nothing False
leaveChatroom
- :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+ :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
=> ChatroomState -> m ()
leaveChatroom rstate = leaveChatroomByStateData (head $ roomStateData rstate)
leaveChatroomByStateData
- :: (MonadStorage m, MonadHead LocalState m, MonadError String m)
+ :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e)
=> Stored ChatroomStateData -> m ()
-leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing True
+leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing True
getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage]
getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur)
@@ -396,7 +439,7 @@ watchChatrooms h f = liftIO $ do
return $ makeChatroomDiff lastList curList
chatroomSetToList :: Set ChatroomState -> [(Stored ChatroomStateData, ChatroomState)]
-chatroomSetToList = map (cmp &&& id) . fromSetBy (comparing cmp)
+chatroomSetToList = map (cmp &&& id) . filter (not . roomStateDeleted) . fromSetBy (comparing cmp)
where
cmp :: ChatroomState -> Stored ChatroomStateData
cmp = head . filterAncestors . concatMap storedRoots . toComponents
@@ -480,7 +523,7 @@ instance Service ChatroomService where
}
when (not $ null chatRoomInfo) $ do
- updateLocalHead_ $ updateSharedState_ $ \roomSet -> do
+ updateLocalState_ $ updateSharedState_ $ \roomSet -> do
let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet
upd set (roomInfo :: Stored (Signed ChatroomData)) = do
let currentRoots = storedRoots roomInfo
@@ -494,11 +537,9 @@ instance Service ChatroomService where
-- update local state only if we got roomInfo not present there
if roomInfo `notElem` prevRoom && roomInfo `elem` room
then do
- sdata <- mstore ChatroomStateData
+ sdata <- mstore emptyChatroomStateData
{ rsdPrev = prev
, rsdRoom = room
- , rsdSubscribe = Nothing
- , rsdMessages = []
}
storeSetAddComponent sdata set
else return set
@@ -521,7 +562,7 @@ instance Service ChatroomService where
svcModify $ \ps -> ps { psSubscribedTo = filter (/= leastRoot) (psSubscribedTo ps) }
when (not (null chatRoomMessage)) $ do
- updateLocalHead_ $ updateSharedState_ $ \roomSet -> do
+ updateLocalState_ $ updateSharedState_ $ \roomSet -> do
let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet
upd set (msgData :: Stored (Signed ChatMessageData))
| Just msg <- validateSingleMessage msgData = do
@@ -538,10 +579,8 @@ instance Service ChatroomService where
-- update local state only if subscribed and we got some new messages
if roomStateSubscribe prev && messages /= prevMessages
then do
- sdata <- mstore ChatroomStateData
+ sdata <- mstore emptyChatroomStateData
{ rsdPrev = prevData
- , rsdRoom = []
- , rsdSubscribe = Nothing
, rsdMessages = messages
}
storeSetAddComponent sdata set