Fixed handshake query delay

After handshake query the responder side is supposed to close the connection after 20s. We used wrong `threadDelay` function, and it waited only 20μs instead.
IntersectMBO · Jun 20, 2023 · 26f4824 · 26f4824
1 parent 10ea6f1
commit 26f4824
Show file tree

Hide file tree

Showing 3 changed files with 10 additions and 3 deletions.
diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs b/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
 
 
 

diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs b/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
diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs b/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'