Fixed handshake query delay

ouroboros-network-framework/CHANGELOG.md

@@ -10,6 +10,10 @@
   * Renamed `serverControlChannel` as `serverInboundInfoChannel` of the `ServerArguments` record.
   * Moved `OurboundGovernorInfoChannel` to `ouroboros-network`.
 
+### Non-breaking changes
+
+* Fixed query shutdown timeout in the legacy (non-p2p) mode (20s).
+
 ## 0.6.0.1 -- 2023-05-15
 
 * Updated to use `ouroboros-network-api-0.5.0.0`.

ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs

@@ -380,7 +380,7 @@ makeConnectionHandler muxTracer singMuxMode
                 atomically $ writePromise (Right HandshakeConnectionQuery)
                 traceWith tracer $ TrHandshakeQuery vMap
                 -- Wait 20s for client to receive response, who should close the connection.
-                threadDelay 20
+                threadDelay handshake_QUERY_SHUTDOWN_DELAY
 
 
 

ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs

@@ -15,6 +15,7 @@ module Ouroboros.Network.Protocol.Handshake
   , HandshakeResult (..)
   , RefuseReason (..)
   , Accept (..)
+  , handshake_QUERY_SHUTDOWN_DELAY
   ) where
 
 import           Control.Monad.Class.MonadAsync
@@ -182,3 +183,9 @@ runHandshakeServer bearer
           haTimeLimits
           (fromChannel (muxBearerAsChannel bearer handshakeProtocolNum ResponderDir))
           (handshakeServerPeer haVersionDataCodec haAcceptVersion haQueryVersion versions))
+
+-- | A 20s delay after query result was send back, before we close the
+-- connection.  After that delay we close the connection.
+--
+handshake_QUERY_SHUTDOWN_DELAY :: DiffTime
+handshake_QUERY_SHUTDOWN_DELAY = 20

ouroboros-network-framework/src/Ouroboros/Network/Socket.hs

@@ -72,7 +72,6 @@ module Ouroboros.Network.Socket
   , sockAddrFamily
   ) where
 
-import           Control.Concurrent (threadDelay)
 import           Control.Concurrent.Async
 import           Control.Concurrent.Class.MonadSTM.Strict
 import           Control.Exception (SomeException (..))
@@ -82,6 +81,7 @@ import qualified Codec.CBOR.Term as CBOR
 import           Control.Monad (unless, when)
 import           Control.Monad.Class.MonadThrow
 import           Control.Monad.Class.MonadTime.SI
+import           Control.Monad.Class.MonadTimer.SI
 import qualified Control.Monad.STM as STM
 import qualified Data.ByteString.Lazy as BL
 import           Data.Hashable
@@ -504,7 +504,7 @@ beginConnection makeBearer muxTracer handshakeTracer handshakeCodec handshakeTim
              Right (HandshakeQueryResult _vMap) -> do
                  traceWith muxTracer' Mx.MuxTraceHandshakeServerEnd
                  -- Wait 20s for client to receive response, who should close the connection.
-                 threadDelay 20
+                 threadDelay handshake_QUERY_SHUTDOWN_DELAY
 
       RejectConnection st' _peerid -> pure $ Server.Reject st'