diff options
Diffstat (limited to 'src/Erebos/Chatroom.hs')
| -rw-r--r-- | src/Erebos/Chatroom.hs | 131 |
1 files changed, 125 insertions, 6 deletions
diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index d9e8837..3a2628d 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -10,10 +10,15 @@ module Erebos.Chatroom ( listChatrooms, findChatroomByRoomData, findChatroomByStateData, + getMessagesSinceState, ChatroomSetChange(..), watchChatrooms, + ChatMessage, cmsgFrom, cmsgReplyTo, cmsgTime, cmsgText, cmsgLeave, + ChatMessageData(..), + chatroomMessageByStateData, + ChatroomService(..), ) where @@ -27,8 +32,11 @@ import Data.List import Data.Maybe import Data.Monoid import Data.Ord +import Data.Set qualified as S import Data.Text (Text) +import Data.Time +import Erebos.Identity import Erebos.PubKey import Erebos.Service import Erebos.Set @@ -87,34 +95,129 @@ validateChatroom roomData = do in All $ all (fromStored sdata `isSignedBy`) required +data ChatMessageData = ChatMessageData + { mdPrev :: [Stored (Signed ChatMessageData)] + , mdRoom :: [Stored (Signed ChatroomData)] + , mdFrom :: ComposedIdentity + , mdReplyTo :: Maybe (Stored (Signed ChatMessageData)) + , mdTime :: ZonedTime + , mdText :: Maybe Text + , mdLeave :: Bool + } + +data ChatMessage = ChatMessage + { cmsgData :: Stored (Signed ChatMessageData) + } + +cmsgFrom :: ChatMessage -> ComposedIdentity +cmsgFrom = mdFrom . fromSigned . cmsgData + +cmsgReplyTo :: ChatMessage -> Maybe ChatMessage +cmsgReplyTo = fmap ChatMessage . mdReplyTo . fromSigned . cmsgData + +cmsgTime :: ChatMessage -> ZonedTime +cmsgTime = mdTime . fromSigned . cmsgData + +cmsgText :: ChatMessage -> Maybe Text +cmsgText = mdText . fromSigned . cmsgData + +cmsgLeave :: ChatMessage -> Bool +cmsgLeave = mdLeave . fromSigned . cmsgData + +instance Storable ChatMessageData where + store' ChatMessageData {..} = storeRec $ do + mapM_ (storeRef "SPREV") mdPrev + mapM_ (storeRef "room") mdRoom + mapM_ (storeRef "from") $ idExtDataF mdFrom + storeMbRef "reply-to" mdReplyTo + storeDate "time" mdTime + storeMbText "text" mdText + when mdLeave $ storeEmpty "leave" + + load' = loadRec $ do + mdPrev <- loadRefs "SPREV" + mdRoom <- loadRefs "room" + mdFrom <- loadIdentity "from" + mdReplyTo <- loadMbRef "reply-to" + mdTime <- loadDate "time" + mdText <- loadMbText "text" + mdLeave <- isJust <$> loadMbEmpty "leave" + return ChatMessageData {..} + +threadToList :: [Stored (Signed ChatMessageData)] -> [ChatMessage] +threadToList thread = helper S.empty $ thread + where + helper :: S.Set (Stored (Signed ChatMessageData)) -> [Stored (Signed ChatMessageData)] -> [ChatMessage] + helper seen msgs + | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs = + messageFromData msg : helper (S.insert msg seen) (msgs' ++ mdPrev (fromSigned msg)) + | otherwise = [] + cmpView msg = (zonedTimeToUTC $ mdTime $ fromSigned msg, msg) + + messageFromData :: Stored (Signed ChatMessageData) -> ChatMessage + messageFromData sdata = ChatMessage { cmsgData = sdata } + +chatroomMessageByStateData + :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + => Stored ChatroomStateData -> Text -> m () +chatroomMessageByStateData lookupData msg = void $ findAndUpdateChatroomState $ \cstate -> do + guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate + Just $ do + self <- finalOwner . localIdentity . fromStored <$> getLocalHead + secret <- loadKey $ idKeyMessage self + time <- liftIO getZonedTime + mdata <- mstore =<< sign secret =<< mstore ChatMessageData + { mdPrev = roomStateMessageData cstate + , mdRoom = [] + , mdFrom = self + , mdReplyTo = Nothing + , mdTime = time + , mdText = Just msg + , mdLeave = False + } + mergeSorted . (:[]) <$> mstore ChatroomStateData + { rsdPrev = roomStateData cstate + , rsdRoom = [] + , rsdMessages = [ mdata ] + } + + data ChatroomStateData = ChatroomStateData { rsdPrev :: [Stored ChatroomStateData] , rsdRoom :: [Stored (Signed ChatroomData)] + , rsdMessages :: [Stored (Signed ChatMessageData)] } data ChatroomState = ChatroomState { roomStateData :: [Stored ChatroomStateData] , roomStateRoom :: Maybe Chatroom + , roomStateMessageData :: [Stored (Signed ChatMessageData)] + , roomStateMessages :: [ChatMessage] } instance Storable ChatroomStateData where store' ChatroomStateData {..} = storeRec $ do forM_ rsdPrev $ storeRef "PREV" forM_ rsdRoom $ storeRef "room" + forM_ rsdMessages $ storeRef "msg" load' = loadRec $ do rsdPrev <- loadRefs "PREV" rsdRoom <- loadRefs "room" + rsdMessages <- loadRefs "msg" return ChatroomStateData {..} instance Mergeable ChatroomState where type Component ChatroomState = ChatroomStateData - mergeSorted cdata = ChatroomState - { roomStateData = cdata - , roomStateRoom = either (const Nothing) Just $ runExcept $ - validateChatroom $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . rsdRoom) cdata - } + mergeSorted roomStateData = + let roomStateRoom = either (const Nothing) Just $ runExcept $ + validateChatroom $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . rsdRoom) roomStateData + roomStateMessageData = filterAncestors $ concat $ flip findProperty roomStateData $ \case + ChatroomStateData {..} | null rsdMessages -> Nothing + | otherwise -> Just rsdMessages + roomStateMessages = threadToList $ concatMap (rsdMessages . fromStored) roomStateData + in ChatroomState {..} toComponents = roomStateData @@ -129,6 +232,7 @@ createChatroom rdName rdDescription = do cstate <- mergeSorted . (:[]) <$> mstore ChatroomStateData { rsdPrev = [] , rsdRoom = [ rdata ] + , rsdMessages = [] } updateLocalHead $ updateSharedState $ \rooms -> do @@ -174,6 +278,7 @@ updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomStat mergeSorted . (:[]) <$> mstore ChatroomStateData { rsdPrev = roomStateData cstate , rsdRoom = [ rdata ] + , rsdMessages = [] } @@ -193,6 +298,12 @@ findChatroomByRoomData cdata = findChatroom $ findChatroomByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> m (Maybe ChatroomState) findChatroomByStateData cdata = findChatroom $ any (cdata `precedesOrEquals`) . roomStateData +getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage] +getMessagesSinceState cur old = takeWhile notOld (roomStateMessages cur) + where + notOld msg = cmsgData msg `notElem` roomStateMessageData old + -- TODO: parallel message threads + data ChatroomSetChange = AddedChatroom ChatroomState | RemovedChatroom ChatroomState @@ -231,22 +342,26 @@ makeChatroomDiff [] ys = map (AddedChatroom . snd) ys data ChatroomService = ChatroomService { chatRoomQuery :: Bool , chatRoomInfo :: [Stored (Signed ChatroomData)] + , chatRoomMessage :: [Stored (Signed ChatMessageData)] } emptyPacket :: ChatroomService emptyPacket = ChatroomService { chatRoomQuery = False , chatRoomInfo = [] + , chatRoomMessage = [] } instance Storable ChatroomService where store' ChatroomService {..} = storeRec $ do when chatRoomQuery $ storeEmpty "room-query" forM_ chatRoomInfo $ storeRef "room-info" + forM_ chatRoomMessage $ storeRef "room-message" load' = loadRec $ do chatRoomQuery <- isJust <$> loadMbEmpty "room-query" chatRoomInfo <- loadRefs "room-info" + chatRoomMessage <- loadRefs "room-message" return ChatroomService {..} data PeerState = PeerState @@ -288,7 +403,11 @@ 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 { rsdPrev = prev, rsdRoom = room } + sdata <- mstore ChatroomStateData + { rsdPrev = prev + , rsdRoom = room + , rsdMessages = [] + } storeSetAddComponent sdata set else return set foldM upd roomSet chatRoomInfo |