diff options
Diffstat (limited to 'src/Erebos')
| -rw-r--r-- | src/Erebos/DirectMessage.hs | 4 | ||||
| -rw-r--r-- | src/Erebos/Network.hs | 12 | ||||
| -rw-r--r-- | src/Erebos/Service.hs | 2 | ||||
| -rw-r--r-- | src/Erebos/State.hs | 5 |
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 |