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.hs131
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