From 2278e5f103ed9c4f0e2c28bed82aae3639e7b46f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 2 Jul 2023 21:38:45 +0200
Subject: Send direct message using local head monad

---
 src/Message.hs | 51 ++++++++++++++++++++++++++-------------------------
 1 file changed, 26 insertions(+), 25 deletions(-)

(limited to 'src/Message.hs')

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
-- 
cgit v1.2.3