From aa83cb804105594d43c2002352f2b1d9f9db3c45 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Mon, 17 Jul 2023 21:30:21 +0200
Subject: Send direct messages using identity

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

(limited to 'src/Message.hs')

diff --git a/src/Message.hs b/src/Message.hs
index 53283a5..41a88b0 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -150,33 +150,31 @@ findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do
     return $ sel x
 
 
-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 powner = finalOwner pid
-    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)
+sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m, MonadError String m)
+                  => Identity f -> Text -> m (Stored DirectMessage)
+sendDirectMessage pid text = updateLocalHead $ \ls -> do
+    let st = storedStorage ls
+        self = localIdentity $ fromStored ls
+        powner = finalOwner pid
+    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)
 
 syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage ()
 syncDirectMessageToPeer (DirectMessageThreads mss _) = do
-- 
cgit v1.2.3