diff --git a/examples/refchan-qblf/app/RefChanQBLFMain.hs b/examples/refchan-qblf/app/RefChanQBLFMain.hs index 47d7464b..b3dfa051 100644 --- a/examples/refchan-qblf/app/RefChanQBLFMain.hs +++ b/examples/refchan-qblf/app/RefChanQBLFMain.hs @@ -524,7 +524,7 @@ runMe conf = withLogging $ flip runReaderT conf do when here do liftIO $ removeFile sa - server <- newMessagingUnix True 1.0 sa + server <- newMessagingUnixOpts [MUNoFork] True 1.0 sa abus <- async $ runMessagingUnix server diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs b/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs index 88ed7499..c83e0a09 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs @@ -60,7 +60,7 @@ instance Hashable (Peer UNIX) where {- HLINT ignore "Use newtype instead of data" -} data MessagingUnixOpts = MUWatchdog Int - | MUFork + | MUNoFork deriving (Eq,Ord,Show,Generic,Data) -- FIXME: use-bounded-queues @@ -137,7 +137,12 @@ runMessagingUnix env = do liftIO $ bind sock $ SockAddrUnix (msgUnixSockPath env) liftIO $ listen sock 5 - let withSession = void . async . runResourceT + -- let withSession = void . async . runResourceT + + let doFork = not $ Set.member MUNoFork (msgUnixOpts env) + + let withSession | doFork = void . async . runResourceT + | otherwise = void . runResourceT watchdog <- async $ do @@ -174,7 +179,10 @@ runMessagingUnix env = do withSession do - let that = msgUnixSelf env & over fromPeerUnix (<> "#" <> show peerNum) + let that = if doFork then + msgUnixSelf env & over fromPeerUnix (<> "#" <> show peerNum) + else + msgUnixSelf env void $ allocate ( createQueues env that ) dropQueuesFor diff --git a/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs b/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs index b8676b42..9600a751 100644 --- a/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs +++ b/hbs2-core/lib/HBS2/Storage/Operations/Missed.hs @@ -7,6 +7,8 @@ import HBS2.Hash import HBS2.Merkle import HBS2.Storage +import HBS2.System.Logger.Simple + import Streaming.Prelude qualified as S import Control.Monad.Trans.Maybe import Control.Monad @@ -16,12 +18,14 @@ import Data.Maybe findMissedBlocks :: (MonadIO m) => AnyStorage -> HashRef -> m [HashRef] findMissedBlocks sto href = do + trace $ "findMissedBlocks" <+> pretty href + S.toList_ $ walkMerkle (fromHashRef href) (lift . getBlock sto) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do case hr of -- FIXME: investigate-this-wtf - Left{} -> pure () + Left hx -> S.yield (HashRef hx) Right (hrr :: [HashRef]) -> do forM_ hrr $ \hx -> runMaybeT do blk <- lift $ getBlock sto (fromHashRef hx) diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index becaa173..52f6cae6 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -1037,7 +1037,7 @@ runPeer opts = U.handle (\e -> myException e ] let rpcSa = getRpcSocketName conf - rpcmsg <- newMessagingUnixOpts [MUFork] True 1.0 rpcSa + rpcmsg <- newMessagingUnix True 1.0 rpcSa let rpcctx = RPC2Context { rpcConfig = fromPeerConfig conf , rpcMessaging = rpcmsg diff --git a/hbs2-peer/app/RefChan.hs b/hbs2-peer/app/RefChan.hs index 177fc499..b057d3fc 100644 --- a/hbs2-peer/app/RefChan.hs +++ b/hbs2-peer/app/RefChan.hs @@ -34,6 +34,7 @@ import HBS2.Net.Proto.Peer import HBS2.Net.Proto.RefChan import HBS2.Net.Proto.Sessions import HBS2.Storage +import HBS2.Storage.Operations.Missed import HBS2.System.Logger.Simple diff --git a/hbs2-tests/test/TestUNIX.hs b/hbs2-tests/test/TestUNIX.hs index 1c80baae..f5a061fd 100644 --- a/hbs2-tests/test/TestUNIX.hs +++ b/hbs2-tests/test/TestUNIX.hs @@ -151,7 +151,7 @@ main = do let soname = tmp "unix.socket" - server <- newMessagingUnixOpts [MUFork] True 1.0 soname + server <- newMessagingUnix True 1.0 soname client1 <- newMessagingUnix False 1.0 soname client2 <- newMessagingUnix False 1.0 soname