From 9e07f08c019a4951fff0a969ca3fb88c8a0d9569 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Tue, 7 Dec 2021 21:47:50 +0100
Subject: Storage: guard changes on watched heads

---
 src/Storage.hs          | 26 +++++++++++++++++++-------
 src/Storage/Internal.hs |  2 +-
 2 files changed, 20 insertions(+), 8 deletions(-)

(limited to 'src')

diff --git a/src/Storage.hs b/src/Storage.hs
index 5ef9bec..84df213 100644
--- a/src/Storage.hs
+++ b/src/Storage.hs
@@ -463,23 +463,29 @@ updateHead_ :: HeadType a => Head a -> (Stored a -> IO (Stored a)) -> IO (Maybe
 updateHead_ h = fmap fst . updateHead h . (fmap (,()) .)
 
 
-data WatchedHead = WatchedHead Storage WatchID
+data WatchedHead = forall a. WatchedHead Storage WatchID (MVar a)
 
 watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHead
 watchHead h = watchHeadWith h id
 
-watchHeadWith :: forall a b. HeadType a => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead
-watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do
+watchHeadWith :: forall a b. (HeadType a, Eq b) => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead
+watchHeadWith oh@(Head hid (Stored (Ref st _) _)) sel cb = do
+    memo <- newEmptyMVar
     let tid = headTypeID @a Proxy
-        addWatcher wl = (wl', WatchedHead st (wlNext wl))
+        addWatcher wl = (wl', WatchedHead st (wlNext wl) memo)
             where wl' = wl { wlNext = wlNext wl + 1
                            , wlList = WatchListItem
                                { wlID = wlNext wl
                                , wlHead = (tid, hid)
-                               , wlFun = cb . sel . Head hid . wrappedLoad
+                               , wlFun = \r -> do
+                                   let x = sel $ Head hid $ wrappedLoad r
+                                   modifyMVar_ memo $ \prev -> do
+                                       when (x /= prev) $ cb x
+                                       return x
                                } : wlList wl
                            }
-    case stBacking st of
+
+    watched <- case stBacking st of
          StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(ilist, wl) -> do
              ilist' <- case lookup tid ilist of
                  Just _ -> return ilist
@@ -496,8 +502,14 @@ watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do
 
          StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher
 
+    cur <- sel . maybe oh id <$> reloadHead oh
+    cb cur
+    putMVar memo cur
+
+    return watched
+
 unwatchHead :: WatchedHead -> IO ()
-unwatchHead (WatchedHead st wid) = do
+unwatchHead (WatchedHead st wid _) = do
     let delWatcher wl = wl { wlList = filter ((/=wid) . wlID) $ wlList wl }
     case stBacking st of
         StorageDir { dirWatchers = mvar } -> modifyMVar_ mvar $ return . second delWatcher
diff --git a/src/Storage/Internal.hs b/src/Storage/Internal.hs
index 7e593f8..3a05029 100644
--- a/src/Storage/Internal.hs
+++ b/src/Storage/Internal.hs
@@ -154,7 +154,7 @@ newtype Generation = Generation Int
     deriving (Eq, Show)
 
 data Head' c a = Head HeadID (Stored' c a)
-    deriving (Show)
+    deriving (Eq, Show)
 
 newtype HeadID = HeadID UUID
     deriving (Eq, Ord, Show)
-- 
cgit v1.2.3