TODROP: anticipate Issue 1147

IntersectMBO · Nov 10, 2019 · 0d2fa18 · 0d2fa18
1 parent 2f21e59
commit 0d2fa18
Show file tree

Hide file tree

Showing 2 changed files with 20 additions and 7 deletions.
diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE FlexibleContexts           #-}
@@ -106,7 +107,7 @@ data FetchClientStateVars m header =
 newFetchClientStateVars :: MonadSTM m => STM m (FetchClientStateVars m header)
 newFetchClientStateVars = do
     fetchClientInFlightVar <- newTVar initialPeerFetchInFlight
-    fetchClientStatusVar   <- newTVar (PeerFetchStatusReady Set.empty)
+    fetchClientStatusVar   <- newTVar (PeerFetchStatusReady Set.empty True)
     fetchClientRequestVar  <- newTFetchRequestVar
     return FetchClientStateVars {..}
 
@@ -158,7 +159,8 @@ data PeerFetchStatus header =
        -- | Communication with the peer is in a normal state, and the peer is
        -- considered ready to accept new requests.
        --
-     | PeerFetchStatusReady (Set (Point header))
+       -- blocks in flight, whether the mini protocol is in the Idle state
+     | PeerFetchStatusReady (Set (Point header)) Bool
   deriving (Eq, Show)
 
 
@@ -556,8 +558,15 @@ completeFetchBatch tracer inflightlimits range
               peerFetchReqsInFlight = peerFetchReqsInFlight inflight - 1
             }
       writeTVar fetchClientInFlightVar inflight'
-      currentStatus <- readTVar fetchClientStatusVar
-      return (inflight', currentStatus)
+      currentStatus' <- readTVar fetchClientStatusVar >>= \case
+        PeerFetchStatusReady bs False
+          | Set.null bs
+            && 0 == peerFetchReqsInFlight inflight'
+          -> let status = (PeerFetchStatusReady Set.empty True)
+             in status <$ writeTVar fetchClientStatusVar status
+        currentStatus -> pure currentStatus
+
+      return (inflight', currentStatus')
 
     traceWith tracer $
       CompletedFetchBatch
@@ -635,7 +644,9 @@ busyIfOverHighWatermark inflightlimits inflight
   | peerFetchBytesInFlight inflight >= inFlightBytesHighWatermark inflightlimits
   = PeerFetchStatusBusy
   | otherwise
-  = PeerFetchStatusReady (peerFetchBlocksInFlight inflight)
+  = PeerFetchStatusReady
+      (peerFetchBlocksInFlight inflight)
+      (0 == peerFetchReqsInFlight inflight)
 
 -- | Return 'PeerFetchStatusReady' if we're now under the low watermark.
 --
@@ -644,7 +655,9 @@ readyIfUnderLowWatermark :: PeerFetchInFlightLimits
                          -> PeerFetchStatus header
 readyIfUnderLowWatermark inflightlimits inflight
   | peerFetchBytesInFlight inflight <= inFlightBytesLowWatermark inflightlimits
-  = PeerFetchStatusReady (peerFetchBlocksInFlight inflight)
+  = PeerFetchStatusReady
+      (peerFetchBlocksInFlight inflight)
+      (0 == peerFetchReqsInFlight inflight)
   | otherwise
   = PeerFetchStatusBusy
 

diff --git a/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs
@@ -353,7 +353,7 @@ tracePropertyClientStateSanity es =
         == fromIntegral peerFetchBytesInFlight
 
      && case status of
-          PeerFetchStatusReady _ -> True
+          PeerFetchStatusReady{} -> True
           PeerFetchStatusBusy    -> True
           _                      -> False -- not used in this test