From 53ce8074f7d0839ff4130384247ef05f6b42e2a2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 3 Aug 2025 21:43:17 +0200
Subject: Create direct message state when creating conversation

---
 src/Erebos/DirectMessage.hs | 42 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 42 insertions(+)

(limited to 'src/Erebos/DirectMessage.hs')

diff --git a/src/Erebos/DirectMessage.hs b/src/Erebos/DirectMessage.hs
index 21ba5b3..7cb1829 100644
--- a/src/Erebos/DirectMessage.hs
+++ b/src/Erebos/DirectMessage.hs
@@ -1,6 +1,8 @@
 module Erebos.DirectMessage (
     DirectMessage(..),
     sendDirectMessage,
+    updateDirectMessagePeer,
+    createOrUpdateDirectMessagePeer,
 
     DirectMessageAttributes(..),
     defaultDirectMessageAttributes,
@@ -189,6 +191,46 @@ sendDirectMessage pid text = updateLocalState_ $ \ls -> do
             }
         return $ DirectMessageThreads [ next ] (dmThreadView [ next ])
 
+updateDirectMessagePeer
+    :: (Foldable f, Applicative f, MonadHead LocalState m)
+    => Identity f -> m ()
+updateDirectMessagePeer = createOrUpdateDirectMessagePeer' False
+
+createOrUpdateDirectMessagePeer
+    :: (Foldable f, Applicative f, MonadHead LocalState m)
+    => Identity f -> m ()
+createOrUpdateDirectMessagePeer = createOrUpdateDirectMessagePeer' True
+
+createOrUpdateDirectMessagePeer'
+    :: (Foldable f, Applicative f, MonadHead LocalState m)
+    => Bool -> Identity f -> m ()
+createOrUpdateDirectMessagePeer' create pid = do
+    let powner = finalOwner pid
+    updateLocalState_ $ updateSharedState_ $ \old@(DirectMessageThreads prev threads) -> do
+        let updatePeerThread = do
+                next <- mstore MessageState
+                    { msPrev = prev
+                    , msPeer = powner
+                    , msReady = []
+                    , msSent = []
+                    , msReceived = []
+                    , msSeen = []
+                    }
+                return $ DirectMessageThreads [ next ] (dmThreadView [ next ])
+        case find (sameIdentity powner . msgPeer) threads of
+            Nothing
+                | create
+                -> updatePeerThread
+
+            Just thread
+                | oldPeer <- msgPeer thread
+                , newPeer <- updateIdentity (idExtDataF powner) oldPeer
+                , oldPeer /= newPeer
+                -> updatePeerThread
+
+            _ -> return old
+
+
 syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage ()
 syncDirectMessageToPeer (DirectMessageThreads mss _) = do
     pid <- finalOwner <$> asks svcPeerIdentity
-- 
cgit v1.2.3