From 95449bb4b93cf10468c47b27f20396d916c46778 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Thu, 13 Jul 2023 18:39:01 +0200
Subject: Send and receive direct messages through storage

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

(limited to 'src/Message.hs')

diff --git a/src/Message.hs b/src/Message.hs
index 39e13dd..53283a5 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -12,6 +12,7 @@ module Message (
     threadToList,
     messageThreadView,
 
+    watchReceivedMessages,
     formatMessage,
 ) where
 
@@ -54,17 +55,12 @@ instance Storable DirectMessage where
         <*> loadText "text"
 
 data DirectMessageAttributes = DirectMessageAttributes
-    { dmReceived :: Stored DirectMessage -> ServiceHandler DirectMessage ()
-    , dmOwnerMismatch :: ServiceHandler DirectMessage ()
+    { dmOwnerMismatch :: ServiceHandler DirectMessage ()
     }
 
 defaultDirectMessageAttributes :: DirectMessageAttributes
 defaultDirectMessageAttributes = DirectMessageAttributes
-    { dmReceived = \msg -> do
-        tzone <- liftIO $ getCurrentTimeZone
-        svcPrint $ formatMessage tzone $ fromStored msg
-
-    , dmOwnerMismatch = svcPrint "Owner mismatch"
+    { dmOwnerMismatch = svcPrint "Owner mismatch"
     }
 
 instance Service DirectMessage where
@@ -81,28 +77,32 @@ instance Service DirectMessage where
             DirectMessageThreads prev _ = lookupSharedValue $ lsShared $ fromStored erb
             sent = findMsgProperty powner msSent prev
             received = findMsgProperty powner msReceived prev
+            received' = filterAncestors $ smsg : received
         if powner `sameIdentity` msgFrom msg ||
                filterAncestors sent == filterAncestors (smsg : sent)
            then do
-               erb' <- liftIO $ do
+               when (received' /= received) $ do
                    next <- wrappedStore st $ MessageState
                        { msPrev = prev
                        , msPeer = powner
                        , msSent = []
-                       , msReceived = filterAncestors $ smsg : received
+                       , msReceived = received'
                        , msSeen = []
                        }
                    let threads = DirectMessageThreads [next] (messageThreadView [next])
                    shared <- makeSharedStateUpdate st threads (lsShared $ fromStored erb)
-                   wrappedStore st (fromStored erb) { lsShared = [shared] }
-               svcSetLocal erb'
+                   svcSetLocal =<< wrappedStore st (fromStored erb) { lsShared = [shared] }
+
                when (powner `sameIdentity` msgFrom msg) $ do
-                   hook <- asks $ dmReceived . svcAttributes
-                   hook smsg
                    replyStoredRef smsg
 
            else join $ asks $ dmOwnerMismatch . svcAttributes
 
+    serviceNewPeer = syncDirectMessageToPeer . lookupSharedValue . lsShared . fromStored =<< svcGetLocal
+
+    serviceStorageWatchers _ = (:[]) $
+        SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncDirectMessageToPeer
+
 
 data MessageState = MessageState
     { msPrev :: [Stored MessageState]
@@ -114,6 +114,9 @@ data MessageState = MessageState
 
 data DirectMessageThreads = DirectMessageThreads [Stored MessageState] [DirectMessageThread]
 
+instance Eq DirectMessageThreads where
+    DirectMessageThreads mss _ == DirectMessageThreads mss' _ = mss == mss'
+
 toThreadList :: DirectMessageThreads -> [DirectMessageThread]
 toThreadList (DirectMessageThreads _ threads) = threads
 
@@ -152,8 +155,7 @@ sendDirectMessage peer text = do
     pid <- peerIdentity peer >>= \case PeerIdentityFull pid -> return pid
                                        _ -> throwError "incomplete peer identity"
     let powner = finalOwner pid
-
-    smsg <- updateLocalHead $ \ls -> do
+    updateLocalHead $ \ls -> do
         let st = storedStorage ls
             self = localIdentity $ fromStored ls
         flip updateSharedState ls $ \(DirectMessageThreads prev _) -> liftIO $ do
@@ -176,9 +178,12 @@ sendDirectMessage peer text = do
                 }
             return (DirectMessageThreads [next] (messageThreadView [next]), smsg)
 
-    sendToPeerStored peer smsg
-    return smsg
-
+syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage ()
+syncDirectMessageToPeer (DirectMessageThreads mss _) = do
+    pid <- finalOwner <$> asks svcPeerIdentity
+    peer <- asks svcPeer
+    let thread = messageThreadFor pid mss
+    mapM_ (sendToPeerStored peer) $ msgHead thread
 
 data DirectMessageThread = DirectMessageThread
     { msgPeer :: ComposedIdentity
@@ -202,17 +207,28 @@ messageThreadView = helper []
                       helper used $ msPrev (fromStored sms) ++ rest
                   | otherwise ->
                       let peer = msPeer $ fromStored sms
-                          sent = findMsgProperty peer msSent mss
-                          received = findMsgProperty peer msReceived mss
-                          seen = findMsgProperty peer msSeen mss
-
-                       in DirectMessageThread
-                              { msgPeer = peer
-                              , msgHead = filterAncestors $ sent ++ received
-                              , msgSeen = filterAncestors $ sent ++ seen
-                              } : helper (peer : used) (msPrev (fromStored sms) ++ rest)
+                       in messageThreadFor peer mss : helper (peer : used) (msPrev (fromStored sms) ++ rest)
               _ -> []
 
+messageThreadFor :: ComposedIdentity -> [Stored MessageState] -> DirectMessageThread
+messageThreadFor peer mss =
+    let sent = findMsgProperty peer msSent mss
+        received = findMsgProperty peer msReceived mss
+        seen = findMsgProperty peer msSeen mss
+
+     in DirectMessageThread
+         { msgPeer = peer
+         , msgHead = filterAncestors $ sent ++ received
+         , msgSeen = filterAncestors $ sent ++ seen
+         }
+
+
+watchReceivedMessages :: Head LocalState -> (Stored DirectMessage -> IO ()) -> IO WatchedHead
+watchReceivedMessages h f = do
+    let self = finalOwner $ localIdentity $ headObject h
+    watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \(DirectMessageThreads sms _) -> do
+        forM_ (map fromStored sms) $ \ms -> do
+            mapM_ f $ filter (not . sameIdentity self . msgFrom . fromStored) $ msReceived ms
 
 formatMessage :: TimeZone -> DirectMessage -> String
 formatMessage tzone msg = concat
-- 
cgit v1.2.3