summaryrefslogtreecommitdiff
path: root/src/Erebos/Message.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos/Message.hs')
-rw-r--r--src/Erebos/Message.hs68
1 files changed, 49 insertions, 19 deletions
diff --git a/src/Erebos/Message.hs b/src/Erebos/Message.hs
index 7fe25e6..50e4acb 100644
--- a/src/Erebos/Message.hs
+++ b/src/Erebos/Message.hs
@@ -85,6 +85,7 @@ instance Service DirectMessage where
next <- wrappedStore st $ MessageState
{ msPrev = prev
, msPeer = powner
+ , msReady = []
, msSent = []
, msReceived = received'
, msSeen = []
@@ -107,6 +108,7 @@ instance Service DirectMessage where
data MessageState = MessageState
{ msPrev :: [Stored MessageState]
, msPeer :: ComposedIdentity
+ , msReady :: [Stored DirectMessage]
, msSent :: [Stored DirectMessage]
, msReceived :: [Stored DirectMessage]
, msSeen :: [Stored DirectMessage]
@@ -121,19 +123,22 @@ toThreadList :: DirectMessageThreads -> [DirectMessageThread]
toThreadList (DirectMessageThreads _ threads) = threads
instance Storable MessageState where
- store' ms = storeRec $ do
- mapM_ (storeRef "PREV") $ msPrev ms
- mapM_ (storeRef "peer") $ idDataF $ msPeer ms
- mapM_ (storeRef "sent") $ msSent ms
- mapM_ (storeRef "received") $ msReceived ms
- mapM_ (storeRef "seen") $ msSeen ms
-
- load' = loadRec $ MessageState
- <$> loadRefs "PREV"
- <*> loadIdentity "peer"
- <*> loadRefs "sent"
- <*> loadRefs "received"
- <*> loadRefs "seen"
+ store' MessageState {..} = storeRec $ do
+ mapM_ (storeRef "PREV") msPrev
+ mapM_ (storeRef "peer") $ idDataF msPeer
+ mapM_ (storeRef "ready") msReady
+ mapM_ (storeRef "sent") msSent
+ mapM_ (storeRef "received") msReceived
+ mapM_ (storeRef "seen") msSeen
+
+ load' = loadRec $ do
+ msPrev <- loadRefs "PREV"
+ msPeer <- loadIdentity "peer"
+ msReady <- loadRefs "ready"
+ msSent <- loadRefs "sent"
+ msReceived <- loadRefs "received"
+ msSeen <- loadRefs "seen"
+ return MessageState {..}
instance Mergeable DirectMessageThreads where
type Component DirectMessageThreads = MessageState
@@ -156,20 +161,21 @@ sendDirectMessage pid text = updateLocalHead $ \ls -> do
let self = localIdentity $ fromStored ls
powner = finalOwner pid
flip updateSharedState ls $ \(DirectMessageThreads prev _) -> do
- let sent = findMsgProperty powner msSent prev
+ let ready = findMsgProperty powner msReady prev
received = findMsgProperty powner msReceived prev
time <- liftIO getZonedTime
smsg <- mstore DirectMessage
{ msgFrom = toComposedIdentity $ finalOwner self
- , msgPrev = filterAncestors $ sent ++ received
+ , msgPrev = filterAncestors $ ready ++ received
, msgTime = time
, msgText = text
}
next <- mstore MessageState
{ msPrev = prev
, msPeer = powner
- , msSent = [smsg]
+ , msReady = [smsg]
+ , msSent = []
, msReceived = []
, msSeen = []
}
@@ -181,10 +187,32 @@ syncDirectMessageToPeer (DirectMessageThreads mss _) = do
peer <- asks svcPeer
let thread = messageThreadFor pid mss
mapM_ (sendToPeerStored peer) $ msgHead thread
+ updateLocalHead_ $ \ls -> do
+ let powner = finalOwner pid
+ flip updateSharedState_ ls $ \unchanged@(DirectMessageThreads prev _) -> do
+ let ready = findMsgProperty powner msReady prev
+ sent = findMsgProperty powner msSent prev
+ sent' = filterAncestors (ready ++ sent)
+
+ if sent' /= sent
+ then do
+ next <- mstore MessageState
+ { msPrev = prev
+ , msPeer = powner
+ , msReady = []
+ , msSent = sent'
+ , msReceived = []
+ , msSeen = []
+ }
+ return $ DirectMessageThreads [next] (messageThreadView [next])
+ else do
+ return unchanged
+
data DirectMessageThread = DirectMessageThread
{ msgPeer :: ComposedIdentity
, msgHead :: [Stored DirectMessage]
+ , msgSent :: [Stored DirectMessage]
, msgSeen :: [Stored DirectMessage]
}
@@ -209,14 +237,16 @@ messageThreadView = helper []
messageThreadFor :: ComposedIdentity -> [Stored MessageState] -> DirectMessageThread
messageThreadFor peer mss =
- let sent = findMsgProperty peer msSent mss
+ let ready = findMsgProperty peer msReady mss
+ sent = findMsgProperty peer msSent mss
received = findMsgProperty peer msReceived mss
seen = findMsgProperty peer msSeen mss
in DirectMessageThread
{ msgPeer = peer
- , msgHead = filterAncestors $ sent ++ received
- , msgSeen = filterAncestors $ sent ++ seen
+ , msgHead = filterAncestors $ ready ++ received
+ , msgSent = filterAncestors $ sent ++ received
+ , msgSeen = filterAncestors $ ready ++ seen
}