Storage: guard changes on watched heads

2 files changed, 20 insertions, 8 deletions

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)