Make head caches available in service storage watchers

4 files changed, 20 insertions, 3 deletions

diff --git a/src/Erebos/DirectMessage.hs b/src/Erebos/DirectMessage.hs
index e3e5e97..6eb8a8c 100644
--- a/src/Erebos/DirectMessage.hs
+++ b/src/Erebos/DirectMessage.hs
@@ -152,8 +152,8 @@ instance Service DirectMessage where
         updateDirectMessagePeer . finalOwner =<< asks svcPeerIdentity
 
     serviceStorageWatchers _ =
-        [ SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncDirectMessageToPeer
-        , GlobalStorageWatcher (lookupSharedValue . lsShared . fromStored) findMissingPeers
+        [ SomeStorageWatcherHC lookupSharedValueHC syncDirectMessageToPeer
+        , GlobalStorageWatcherH lookupSharedValueH findMissingPeers
         ]
 
 
diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs
index c2a714e..dc24e93 100644
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -75,6 +75,7 @@ import Erebos.Service
 import Erebos.State
 import Erebos.Storable.Internal
 import Erebos.Storage
+import Erebos.Storage.Head
 import Erebos.Storage.Key
 import Erebos.Storage.Merge
 
@@ -346,10 +347,21 @@ startServer serverOptions serverOrigHead logd' serverServices = do
                                     PeerIdentityFull _ -> writeTQueue serverIOActions $ do
                                         runPeerService peer $ act . sel =<< svcGetLocal
                                     _ -> return ()
+                    SomeStorageWatcherHC sel act -> do
+                        watchHeadWith serverOrigHead (\h -> sel (headStoredObject h) (headCache h)) $ \_ -> do
+                            withMVar serverPeers $ mapM_ $ \peer -> atomically $ do
+                                readTVar (peerIdentityVar peer) >>= \case
+                                    PeerIdentityFull _ -> writeTQueue serverIOActions $ do
+                                        runPeerService peer $ act =<< (sel <$> getLocalHead <*> getLocalHeadCache @LocalState Proxy)
+                                    _ -> return ()
                     GlobalStorageWatcher sel act -> do
                         watchHeadWith serverOrigHead (sel . headStoredObject) $ \x -> do
                             atomically $ writeTQueue serverIOActions $ do
                                 act server x
+                    GlobalStorageWatcherH sel act -> do
+                        watchHeadWith serverOrigHead sel $ \x -> do
+                            atomically $ writeTQueue serverIOActions $ do
+                                act server x
 
             forkServerThread server "receiver" $ forever $ do
                 (msg, saddr) <- S.recvFrom sock 4096
diff --git a/src/Erebos/Service.hs b/src/Erebos/Service.hs
index a5b1370..75551eb 100644
--- a/src/Erebos/Service.hs
+++ b/src/Erebos/Service.hs
@@ -109,7 +109,9 @@ someServiceEmptyGlobalState (SomeService p _) = SomeServiceGlobalState p (emptyS
 
 data SomeStorageWatcher s
     = forall a. Eq a => SomeStorageWatcher (Stored LocalState -> a) (a -> ServiceHandler s ())
+    | forall a. Eq a => SomeStorageWatcherHC (Stored LocalState -> HeadCacheType LocalState -> a) (a -> ServiceHandler s ())
     | forall a. Eq a => GlobalStorageWatcher (Stored LocalState -> a) (Server -> a -> ExceptT ErebosError IO ())
+    | forall a. Eq a => GlobalStorageWatcherH (Head LocalState -> a) (Server -> a -> ExceptT ErebosError IO ())
 
 
 mkServiceID :: String -> ServiceID
diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs
index d74dddb..3774d87 100644
--- a/src/Erebos/State.hs
+++ b/src/Erebos/State.hs
@@ -11,7 +11,7 @@ module Erebos.State (
 
     updateLocalState, updateLocalState_,
     updateSharedState, updateSharedState_,
-    lookupSharedValueH, lookupSharedValueM,
+    lookupSharedValueH, lookupSharedValueHC, lookupSharedValueM,
     lookupSharedValue, makeSharedStateUpdate,
 
     localIdentity,
@@ -234,6 +234,9 @@ lookupSharedValueC = mergeSorted . filterAncestors . map wrappedLoad . concatMap
 lookupSharedValueH :: forall a. SharedType a => Head LocalState -> a
 lookupSharedValueH = lookupSharedValueC . headCache
 
+lookupSharedValueHC :: forall a. SharedType a => Stored LocalState -> HeadCacheType LocalState -> a
+lookupSharedValueHC _ = lookupSharedValueC
+
 lookupSharedValueM :: forall a m. (SharedType a, MonadHead LocalState m) => m a
 lookupSharedValueM = lookupSharedValueC <$> getLocalHeadCache @LocalState Proxy