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/Main.hs    |  2 +-
 src/Message.hs | 51 ++++++++++++++++++++++++++-------------------------
 src/Test.hs    |  3 +--
 3 files changed, 28 insertions(+), 28 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index cdaa9ae..1aaa4f7 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -288,7 +288,7 @@ cmdSend = void $ do
     ehead <- asks ciHead
     Just peer <- gets csPeer
     text <- asks ciLine
-    smsg <- sendDirectMessage ehead peer $ T.pack text
+    smsg <- flip runReaderT ehead $ sendDirectMessage peer $ T.pack text
     tzone <- liftIO $ getCurrentTimeZone
     liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg
 
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
diff --git a/src/Test.hs b/src/Test.hs
index 84505c2..678be18 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -492,6 +492,5 @@ cmdContactSetName = do
 cmdDmSendPeer :: Command
 cmdDmSendPeer = do
     [spidx, msg] <- asks tiParams
-    h <- getHead
     peer <- getPeer spidx
-    void $ sendDirectMessage h peer msg
+    void $ sendDirectMessage peer msg
-- 
cgit v1.2.3