diff --git a/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs b/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs index 89d6e9bb5f9..28fde4110a6 100644 --- a/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs +++ b/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs @@ -19,7 +19,6 @@ module Network.Mux.Bearer.AttenuatedChannel import Prelude hiding (read) import Control.Monad (when) -import qualified Control.Monad.Class.MonadSTM as LazySTM import Control.Monad.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime @@ -29,9 +28,7 @@ import Control.Tracer (Tracer, traceWith) import GHC.IO.Exception import qualified Data.ByteString.Lazy as BL -import Data.Functor (($>)) import Data.Int (Int64) -import Data.Maybe (isJust) import Network.Mux.Codec import Network.Mux.Time @@ -92,6 +89,8 @@ writeQueueChannel QueueChannel { qcWrite } msg = Nothing -> return False Just q -> writeTQueue q msg >> case msg of + -- Match SO_LINGER set with 0 interval + -- and close both ends without any handshake MsgClose -> writeTVar qcWrite Nothing _ -> return () >> return True @@ -213,32 +212,17 @@ newAttenuatedChannel tr Attenuation { aReadAttenuation, when (not sent) $ throwIO (resourceVanishedIOError "AttenuatedChannel.write" "") - -- closing is a 3-way handshake. + -- acClose simulates SO_LINGER TCP option with interval set to 0. + -- + -- It is assumed that the MsgClose is lost, where in this case + -- we only close the local end. When the remote end gets + -- used it will be closed. -- acClose :: m () acClose = do -- send 'MsgClose' and close the underlying channel sent <- writeQueueChannel qc MsgClose - traceWith tr (AttChannClosing sent) - - -- await for a reply, unless the read channel is already closed. - -- - -- TODO: switch to timeout once it's fixed. - d <- registerDelay 120 - res <- - atomically $ - (LazySTM.readTVar d >>= \b -> check b $> Nothing) - `orElse` - (fmap Just $ do - msg <- readTVar (qcRead qc) - >>= traverse readTQueue - case msg of - Nothing -> return () - Just MsgClose -> return () - -- some other message; let the appliction read it first. - Just _ -> retry) - - traceWith tr (AttChannClosed (isJust res)) + traceWith tr (AttChannLocalClose sent) -- | Create a pair of connected 'AttenuatedChannel's. @@ -315,8 +299,7 @@ attenuationChannelAsMuxBearer sduSize sduTimeout muxTracer chan = -- data AttenuatedChannelTrace = - AttChannClosing Bool - | AttChannClosed Bool + AttChannLocalClose Bool | AttChannRemoteClose deriving Show diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs index d339d140994..70cef57c041 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs @@ -3341,7 +3341,7 @@ multiNodeSim serverAcc dataFlow defaultBearerInfo $ attenuationMap mb <- timeout 7200 - ( withSnocket nullTracer + ( withSnocket (Tracer (say . show)) (toBearerInfo defaultBearerInfo) attenuationMap' $ \snocket _ ->