summaryrefslogtreecommitdiff
path: root/src/Message.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-07-02 21:38:45 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2023-07-02 21:52:57 +0200
commit2278e5f103ed9c4f0e2c28bed82aae3639e7b46f (patch)
tree29103482b8e8d701e7277784857852770bdf7f9c /src/Message.hs
parentedafccea465f1f9448a1a7ae555b8615e5b5ac1b (diff)
Send direct message using local head monad
Diffstat (limited to 'src/Message.hs')
-rw-r--r--src/Message.hs51
1 files changed, 26 insertions, 25 deletions
diff --git a/src/Message.hs b/src/Message.hs
index ba45518..39e13dd 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -147,33 +147,34 @@ findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do
return $ sel x
-sendDirectMessage :: (MonadIO m, MonadError String m) => Head LocalState -> Peer -> Text -> m (Stored DirectMessage)
-sendDirectMessage h peer text = do
+sendDirectMessage :: (MonadHead LocalState m, MonadError String m) => Peer -> Text -> m (Stored DirectMessage)
+sendDirectMessage peer text = do
pid <- peerIdentity peer >>= \case PeerIdentityFull pid -> return pid
_ -> throwError "incomplete peer identity"
- let st = refStorage $ headRef h
- self = headLocalIdentity h
- powner = finalOwner pid
-
- smsg <- flip runReaderT h $ updateLocalHead $ updateSharedState $ \(DirectMessageThreads prev _) -> liftIO $ do
- let sent = findMsgProperty powner msSent prev
- received = findMsgProperty powner msReceived prev
-
- time <- getZonedTime
- smsg <- wrappedStore st DirectMessage
- { msgFrom = toComposedIdentity $ finalOwner self
- , msgPrev = filterAncestors $ sent ++ received
- , msgTime = time
- , msgText = text
- }
- next <- wrappedStore st $ MessageState
- { msPrev = prev
- , msPeer = powner
- , msSent = [smsg]
- , msReceived = []
- , msSeen = []
- }
- return (DirectMessageThreads [next] (messageThreadView [next]), smsg)
+ let powner = finalOwner pid
+
+ smsg <- updateLocalHead $ \ls -> do
+ let st = storedStorage ls
+ self = localIdentity $ fromStored ls
+ flip updateSharedState ls $ \(DirectMessageThreads prev _) -> liftIO $ do
+ let sent = findMsgProperty powner msSent prev
+ received = findMsgProperty powner msReceived prev
+
+ time <- getZonedTime
+ smsg <- wrappedStore st DirectMessage
+ { msgFrom = toComposedIdentity $ finalOwner self
+ , msgPrev = filterAncestors $ sent ++ received
+ , msgTime = time
+ , msgText = text
+ }
+ next <- wrappedStore st $ MessageState
+ { msPrev = prev
+ , msPeer = powner
+ , msSent = [smsg]
+ , msReceived = []
+ , msSeen = []
+ }
+ return (DirectMessageThreads [next] (messageThreadView [next]), smsg)
sendToPeerStored peer smsg
return smsg