QBLF regression fixed

Multi-client unix socket failure

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
 

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
 

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)

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

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
 

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