From 15b39fdf54af8e98352da2369897fe1d42c326c1 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Thu, 23 Feb 2023 14:04:19 +0100 Subject: [PATCH 01/19] RawBearer API Lower-level send/receive API for Snockets, bypassing the normal Mux protocol. We need this for KES secure forgetting, as we cannot store secrets in intermediate data structures for serialization purposes; we must copy data directly between secure memory and file descriptors. --- .../20230224_094922_tdammers_raw_bearer.rst | 6 + .../ouroboros-network-framework.cabal | 10 +- .../Test/Ouroboros/Network/RawBearer.hs | 189 ++++++++++++++++++ .../src/Ouroboros/Network/RawBearer.hs | 46 +++++ .../src/Ouroboros/Network/Snocket.hs | 8 + .../src/Simulation/Network/Snocket.hs | 121 +++++++++-- ouroboros-network-framework/test/Main.hs | 30 +++ 7 files changed, 392 insertions(+), 18 deletions(-) create mode 100644 ouroboros-network-framework/changelog.d/20230224_094922_tdammers_raw_bearer.rst create mode 100644 ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs create mode 100644 ouroboros-network-framework/src/Ouroboros/Network/RawBearer.hs create mode 100644 ouroboros-network-framework/test/Main.hs diff --git a/ouroboros-network-framework/changelog.d/20230224_094922_tdammers_raw_bearer.rst b/ouroboros-network-framework/changelog.d/20230224_094922_tdammers_raw_bearer.rst new file mode 100644 index 00000000000..e2b5f727b00 --- /dev/null +++ b/ouroboros-network-framework/changelog.d/20230224_094922_tdammers_raw_bearer.rst @@ -0,0 +1,6 @@ +Added +----- + +- RawBearer API +- ToRawBearer typeclass +- ToRawBearer instances for `Socket`, `LocalSocket`, and `Simulation.Network.Snocket.FD` diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index 1bb4cdac104..1d2485f36b8 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -38,10 +38,10 @@ library Ouroboros.Network.Driver.Simple Ouroboros.Network.Driver.Stateful Ouroboros.Network.ErrorPolicy - Ouroboros.Network.IOManager Ouroboros.Network.InboundGovernor Ouroboros.Network.InboundGovernor.Event Ouroboros.Network.InboundGovernor.State + Ouroboros.Network.IOManager Ouroboros.Network.Mux Ouroboros.Network.MuxMode Ouroboros.Network.Protocol.Handshake @@ -51,11 +51,12 @@ library Ouroboros.Network.Protocol.Handshake.Type Ouroboros.Network.Protocol.Handshake.Unversioned Ouroboros.Network.Protocol.Handshake.Version + Ouroboros.Network.RawBearer Ouroboros.Network.RethrowPolicy + Ouroboros.Network.Server2 Ouroboros.Network.Server.ConnectionTable Ouroboros.Network.Server.RateLimiting Ouroboros.Network.Server.Socket - Ouroboros.Network.Server2 Ouroboros.Network.Snocket Ouroboros.Network.Socket Ouroboros.Network.Subscription @@ -173,15 +174,16 @@ test-suite sim-tests Test.Ouroboros.Network.Server2.Sim Test.Ouroboros.Network.Socket Test.Ouroboros.Network.Subscription + Test.Ouroboros.Network.RawBearer Test.Simulation.Network.Snocket build-depends: - QuickCheck, base >=4.14 && <4.21, bytestring, cborg, containers, contra-tracer, + directory, dns, io-classes, io-sim, @@ -189,11 +191,13 @@ test-suite sim-tests monoidal-synchronisation, network, network-mux, + ouroboros-network-api, ouroboros-network-framework, ouroboros-network-framework:testlib, ouroboros-network-testing, pretty-simple, psqueues, + QuickCheck, quickcheck-instances, quickcheck-monoids, quiet, diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs new file mode 100644 index 00000000000..ed58342e198 --- /dev/null +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Ouroboros.Network.RawBearer where + +import Ouroboros.Network.IOManager +import Ouroboros.Network.RawBearer +import Ouroboros.Network.Snocket +import Ouroboros.Network.Testing.Data.AbsBearerInfo + +import Control.Concurrent.Class.MonadMVar +import Control.Exception (Exception) +import Control.Monad (when) +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork (labelThisThread) +import Control.Monad.Class.MonadSay +import Control.Monad.Class.MonadST (MonadST, withLiftST) +import Control.Monad.Class.MonadThrow (MonadThrow, bracket, catchJust, + finally, throwIO) +import Control.Monad.IOSim hiding (liftST) +import Control.Monad.ST.Unsafe (unsafeIOToST) +import Control.Tracer (nullTracer) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Foreign.Marshal (copyBytes, free, mallocBytes) +import Foreign.Ptr (castPtr, plusPtr) +import qualified Network.Socket as Socket +import Simulation.Network.Snocket as SimSnocket +import System.Directory (removeFile) +import System.IO.Error (ioeGetErrorType, isDoesNotExistErrorType) + +import Test.Simulation.Network.Snocket (toBearerInfo) +import Test.Tasty +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = testGroup "Ouroboros.Network.RawBearer" + [ testProperty "raw bearer send receive simulated socket" prop_raw_bearer_send_and_receive_iosim + , testProperty "raw bearer send receive unix socket" prop_raw_bearer_send_and_receive_unix + ] + +prop_raw_bearer_send_and_receive_unix :: Message -> Property +prop_raw_bearer_send_and_receive_unix msg = + ioProperty $ withIOManager $ \iomgr -> do + let clientName = "unix_socket_client.test" + let serverName = "unix_socket_server.test" + cleanUp clientName + cleanUp serverName + let clientAddr = Socket.SockAddrUnix clientName + let serverAddr = Socket.SockAddrUnix serverName + rawBearerSendAndReceive + (socketSnocket iomgr) + clientAddr serverAddr + msg `finally` do + cleanUp clientName + cleanUp serverName + where + cleanUp name = do + catchJust (\e -> if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing) + (removeFile name) + (\_ -> return ()) + +prop_raw_bearer_send_and_receive_iosim :: Int -> Int -> Message -> Property +prop_raw_bearer_send_and_receive_iosim clientInt serverInt msg = + (clientInt /= serverInt) ==> + iosimProperty $ + SimSnocket.withSnocket + nullTracer + (toBearerInfo absNoAttenuation) + mempty $ \snocket _observe -> do + rawBearerSendAndReceive + snocket + (TestAddress clientInt) + (TestAddress serverInt) + msg + +newtype Message = Message { messageBytes :: ByteString } + deriving (Show, Eq, Ord) + +instance Arbitrary Message where + shrink = filter (not . BS.null . messageBytes) . fmap (Message . BS.pack) . shrink . BS.unpack . messageBytes + arbitrary = Message . BS.pack <$> listOf1 arbitrary + +newtype TestError = + TestError String + deriving (Show) + +instance Exception TestError where + +rawBearerSendAndReceive :: forall m fd addr + . ( MonadST m + , MonadThrow m + , MonadAsync m + -- , MonadTimer m + , MonadMVar m + , MonadSay m + , ToRawBearer m fd + ) + => Snocket m fd addr + -> addr + -> addr + -> Message + -> m Property +rawBearerSendAndReceive snocket clientAddr serverAddr msg = + withLiftST $ \liftST -> do + let io = liftST . unsafeIOToST + let size = BS.length (messageBytes msg) + retVar <- newEmptyMVar + senderDone <- newEmptyMVar + let sender = bracket (openToConnect snocket clientAddr) (close snocket) $ \s -> do + say "sender: connecting" + connect snocket s serverAddr + say "sender: connected" + bearer <- toRawBearer s + bracket (io $ mallocBytes size) (io . free) $ \srcBuf -> do + io $ BS.useAsCStringLen (messageBytes msg) + (uncurry (copyBytes srcBuf)) + let go _ 0 = do + say "sender: done" + return () + go buf n = do + say $ "sender: " ++ show n ++ " bytes left" + bytesSent <- send bearer buf n + when (bytesSent == 0) (throwIO $ TestError "sender: premature hangup") + let n' = n - bytesSent + say $ "sender: " ++ show bytesSent ++ " bytes sent, " ++ show n' ++ " remaining" + go (plusPtr buf bytesSent) n' + go (castPtr srcBuf) size + putMVar senderDone () + receiver s = do + let acceptLoop :: Accept m fd addr -> m () + acceptLoop accept0 = do + say "receiver: accepting connection" + (accepted, acceptNext) <- runAccept accept0 + case accepted :: Accepted fd addr of + AcceptFailure err -> + throwIO err + Accepted s' _ -> do + labelThisThread "accept" + say "receiver: connection accepted" + flip finally (say "receiver: closing connection" >> close snocket s' >> say "receiver: connection closed") $ do + bearer <- toRawBearer s' + retval <- bracket (io $ mallocBytes size) (io . free) $ \dstBuf -> do + let go _ 0 = do + say "receiver: done receiving" + return () + go buf n = do + say $ "receiver: " ++ show n ++ " bytes left" + bytesReceived <- recv bearer buf n + when (bytesReceived == 0) (throwIO $ TestError "receiver: premature hangup") + let n' = n - bytesReceived + say $ "receiver: " ++ show bytesReceived ++ " bytes received, " ++ show n' ++ " remaining" + go (plusPtr buf bytesReceived) n' + go (castPtr dstBuf) size + io (BS.packCStringLen (castPtr dstBuf, size)) + say $ "receiver: received " ++ show retval + written <- tryPutMVar retVar retval + say $ if written then "receiver: stored " ++ show retval else "receiver: already have result" + say "receiver: finishing connection" + acceptLoop acceptNext + accept snocket s >>= acceptLoop + + resBSEither <- bracket (open snocket (addrFamily snocket serverAddr)) (close snocket) $ \s -> do + say "receiver: starting" + bind snocket s serverAddr + listen snocket s + say "receiver: listening" + race + (sender `concurrently` receiver s) + (takeMVar retVar <* takeMVar senderDone) + return $ resBSEither === Right (messageBytes msg) + +iosimProperty :: (forall s . IOSim s Property) + -> Property +iosimProperty sim = + let tr = runSimTrace sim + in case traceResult True tr of + Left e -> counterexample + (unlines + [ "=== Say Events ===" + , unlines (selectTraceEventsSay' tr) + , "=== Trace Events ===" + , unlines (show `map` traceEvents tr) + , "=== Error ===" + , show e ++ "\n" + ]) + False + Right prop -> prop + diff --git a/ouroboros-network-framework/src/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/src/Ouroboros/Network/RawBearer.hs new file mode 100644 index 00000000000..c1eb110cf2d --- /dev/null +++ b/ouroboros-network-framework/src/Ouroboros/Network/RawBearer.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Ouroboros.Network.RawBearer where + +import Data.Word (Word8) +import Foreign.Ptr (Ptr) +import Network.Socket (Socket) +import qualified Network.Socket as Socket + +#if defined(mingw32_HOST_OS) +import Foreign.Ptr (castPtr) +import qualified System.Win32 as Win32 +#endif + +-- | Generalized API for sending and receiving raw bytes over a file +-- descriptor, socket, or similar object. +data RawBearer m = + RawBearer + { send :: Ptr Word8 -> Int -> m Int + , recv :: Ptr Word8 -> Int -> m Int + } + +class ToRawBearer m fd where + toRawBearer :: fd -> m (RawBearer m) + +instance ToRawBearer IO Socket where + toRawBearer s = + return RawBearer + { send = Socket.sendBuf s + , recv = Socket.recvBuf s + } + +#if defined(mingw32_HOST_OS) + +-- | We cannot declare an @instance ToRawBearer Win32.HANDLE@, because +-- 'Win32.Handle' is just a type alias for @Ptr ()@. So instead, we provide +-- this function, which can be used to implement 'ToRawBearer' elsewhere (e.g. +-- over a newtype). +win32HandleToRawBearer :: Win32.HANDLE -> RawBearer IO +win32HandleToRawBearer s = + RawBearer + { send = \buf size -> fromIntegral <$> Win32.win32_WriteFile s (castPtr buf) (fromIntegral size) Nothing + , recv = \buf size -> fromIntegral <$> Win32.win32_ReadFile s (castPtr buf) (fromIntegral size) Nothing + } +#endif diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs index 63ff641ac71..a67bb2da49e 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs @@ -68,6 +68,7 @@ import Network.Socket qualified as Socket import Network.Mux.Bearer import Ouroboros.Network.IOManager +import Ouroboros.Network.RawBearer -- | Named pipes and Berkeley sockets have different API when accepting @@ -393,10 +394,17 @@ data LocalSocket = LocalSocket { getLocalHandle :: !LocalHandle } deriving (Eq, Generic) deriving Show via Quiet LocalSocket + +instance ToRawBearer IO LocalSocket where + toRawBearer = return . win32HandleToRawBearer . getLocalHandle + #else newtype LocalSocket = LocalSocket { getLocalHandle :: LocalHandle } deriving (Eq, Generic) deriving Show via Quiet LocalSocket + +instance ToRawBearer IO LocalSocket where + toRawBearer = toRawBearer . getLocalHandle #endif makeLocalBearer :: MakeBearer IO LocalSocket diff --git a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs index 968b7457a36..f25175488e0 100644 --- a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs @@ -49,21 +49,28 @@ import Prelude hiding (read) import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM qualified as LazySTM import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad (when) +import Control.Monad.Class.MonadSay +import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI +import Control.Monad.Class.MonadTime.SI +import Control.Monad.ST.Unsafe (unsafeIOToST) +import Control.Monad (when) import Control.Tracer (Tracer, contramap, contramapM, traceWith) import GHC.IO.Exception import Data.Bifoldable (bitraverse_) +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString qualified as BS import Data.Foldable (traverse_) import Data.Functor (($>)) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Typeable (Typeable) import Foreign.C.Error +import Foreign.Marshal (copyBytes) +import Foreign.Ptr (castPtr) import Numeric.Natural (Natural) import Text.Printf (printf) @@ -75,6 +82,7 @@ import Network.Mux.Bearer.AttenuatedChannel import Ouroboros.Network.ConnectionId import Ouroboros.Network.ConnectionManager.Types (AddressType (..)) +import Ouroboros.Network.RawBearer import Ouroboros.Network.Snocket import Ouroboros.Network.Testing.Data.Script (Script (..), stepScriptSTM) @@ -530,8 +538,92 @@ instance Show addr => Show (FD_ m addr) where -- | File descriptor type. -- -newtype FD m peerAddr = FD { fdVar :: (StrictTVar m (FD_ m peerAddr)) } - +newtype FD m peerAddr = FD { fdVar :: StrictTVar m (FD_ m peerAddr) } + +instance ( MonadST m + , MonadThrow m + , MonadSay m + , MonadLabelledSTM m + , Show addr + ) => ToRawBearer m (FD m (TestAddress addr)) where + toRawBearer = makeRawFDBearer + +-- | Make a 'RawBearer' from an 'FD'. Since this is only used for testing, we +-- can bypass the requirement of moving raw bytes directly between file +-- descriptors and provided memory buffers, and we can instead covertly use +-- plain old 'ByteString' under the hood. This allows us to use the +-- 'AttenuatedChannel' inside the `FD_`, even though its send and receive +-- methods do not have the right format. +makeRawFDBearer :: forall addr m. + ( MonadST m + , MonadLabelledSTM m + , MonadThrow m + , MonadSay m + , Show addr + ) + => FD m (TestAddress addr) + -> m (RawBearer m) +makeRawFDBearer (FD {fdVar}) = do + (bufVar :: StrictTMVar m LBS.ByteString) <- newTMVarIO LBS.empty + return RawBearer + { send = \src srcSize -> do + labelTVarIO fdVar "sender" + say $ "Sending " ++ show srcSize ++ " bytes" + fd_ <- readTVarIO fdVar + case fd_ of + FDConnected _ conn -> do + bs <- withLiftST $ \liftST -> + liftST . unsafeIOToST $ BS.packCStringLen (castPtr src, srcSize) + let bsl = LBS.fromStrict bs + acWrite (connChannelLocal conn) bsl + say $ "Sent " ++ show srcSize ++ " bytes" + return srcSize + _ -> + throwIO (invalidError fd_) + , recv = \dst size -> do + labelTVarIO fdVar "receiver" + let size64 = fromIntegral size + say $ "Receiving " ++ show size ++ " bytes" + fd_ <- readTVarIO fdVar + case fd_ of + FDConnected _ conn -> do + say $ "Checking buffer" + bytesFromBuffer <- atomically $ takeTMVar bufVar + say $ "Buffer: " ++ show bytesFromBuffer + (lhs, rhs) <- if not (LBS.null bytesFromBuffer) then do + say $ "Reading up to " ++ show size ++ " bytes from buffer" + return (LBS.take size64 bytesFromBuffer, LBS.drop size64 bytesFromBuffer) + else do + bytesRead <- acRead (connChannelLocal conn) + say $ "Received " ++ show (LBS.length $ LBS.take size64 bytesRead) ++ " or more bytes" + return (LBS.take size64 bytesRead, LBS.drop size64 bytesRead) + say $ "Updating buffer; use: " ++ show lhs ++ " keep: " ++ show (LBS.take 10 rhs) ++ + if (LBS.length . LBS.take 11 $ rhs) == 11 then "..." else "" + atomically $ putTMVar bufVar rhs + say $ "Receive: buffer updated" + if LBS.null lhs then do + say $ "Receive: End of stream" + return 0 + else do + say $ "Receive: copying." + let bs = LBS.toStrict lhs + withLiftST $ \liftST -> + liftST . unsafeIOToST $ BS.useAsCStringLen bs $ \(src, srcSize) -> do + copyBytes dst (castPtr src) srcSize + return srcSize + _ -> + throwIO (invalidError fd_) + } + where + invalidError :: FD_ m (TestAddress addr) -> IOError + invalidError fd_ = IOError + { ioe_handle = Nothing + , ioe_type = InvalidArgument + , ioe_location = "Ouroboros.Network.Snocket.Sim.toRawBearer" + , ioe_description = printf "Invalid argument (%s)" (show fd_) + , ioe_errno = Nothing + , ioe_filename = Nothing + } makeFDBearer :: forall addr m. ( MonadMonotonicTime m @@ -555,17 +647,16 @@ makeFDBearer = MakeBearer $ \sduTimeout muxTracer FD { fdVar } -> do (connChannelLocal conn) FDClosed {} -> throwIO (invalidError fd_) - where - -- io errors - invalidError :: FD_ m (TestAddress addr) -> IOError - invalidError fd_ = IOError - { ioe_handle = Nothing - , ioe_type = InvalidArgument - , ioe_location = "Ouroboros.Network.Snocket.Sim.toBearer" - , ioe_description = printf "Invalid argument (%s)" (show fd_) - , ioe_errno = Nothing - , ioe_filename = Nothing - } + where + invalidError :: FD_ m (TestAddress addr) -> IOError + invalidError fd_ = IOError + { ioe_handle = Nothing + , ioe_type = InvalidArgument + , ioe_location = "Ouroboros.Network.Snocket.Sim.toBearer" + , ioe_description = printf "Invalid argument (%s)" (show fd_) + , ioe_errno = Nothing + , ioe_filename = Nothing + } -- -- Simulated snockets diff --git a/ouroboros-network-framework/test/Main.hs b/ouroboros-network-framework/test/Main.hs new file mode 100644 index 00000000000..56a25cee191 --- /dev/null +++ b/ouroboros-network-framework/test/Main.hs @@ -0,0 +1,30 @@ +module Main (main) where + +import Test.Tasty + +import qualified Test.Ouroboros.Network.ConnectionManager as ConnectionManager +import qualified Test.Ouroboros.Network.Driver as Driver +import qualified Test.Ouroboros.Network.RateLimiting as RateLimiting +import qualified Test.Ouroboros.Network.RawBearer as RawBearer +import qualified Test.Ouroboros.Network.Server2 as Server2 +import qualified Test.Ouroboros.Network.Socket as Socket +import qualified Test.Ouroboros.Network.Subscription as Subscription +import qualified Test.Simulation.Network.Snocket as Snocket + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup "ouroboros-network-framework" + [ ConnectionManager.tests + , Driver.tests + , Server2.tests + , Socket.tests + , Subscription.tests + , RateLimiting.tests + , Snocket.tests + , RawBearer.tests + ] + + From b3e111774ead6d8c58f80d89fac2414b354528ec Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 9 May 2023 12:40:13 +0200 Subject: [PATCH 02/19] RawBearer tests - only test supported address types --- .../Test/Ouroboros/Network/RawBearer.hs | 29 +++++++++++++++++-- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index ed58342e198..dca20c6f564 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -22,6 +22,8 @@ import Control.Monad.ST.Unsafe (unsafeIOToST) import Control.Tracer (nullTracer) import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import Data.Maybe (catMaybes) +import Data.Word (Word32) import Foreign.Marshal (copyBytes, free, mallocBytes) import Foreign.Ptr (castPtr, plusPtr) import qualified Network.Socket as Socket @@ -34,11 +36,32 @@ import Test.Tasty import Test.Tasty.QuickCheck tests :: TestTree -tests = testGroup "Ouroboros.Network.RawBearer" - [ testProperty "raw bearer send receive simulated socket" prop_raw_bearer_send_and_receive_iosim - , testProperty "raw bearer send receive unix socket" prop_raw_bearer_send_and_receive_unix +tests = testGroup "Ouroboros.Network.RawBearer" $ + catMaybes + [ Just $ testProperty "raw bearer send receive simulated socket" prop_raw_bearer_send_and_receive_iosim + , onlyIf (Socket.isSupportedSockAddr (Socket.SockAddrUnix "dummy")) $ + testProperty "raw bearer send receive unix socket" prop_raw_bearer_send_and_receive_unix + , onlyIf (Socket.isSupportedSockAddr (Socket.SockAddrInet 10000 localhost)) $ + testProperty "raw bearer send receive inet socket" prop_raw_bearer_send_and_receive_inet ] +onlyIf :: Bool -> a -> Maybe a +onlyIf False = const Nothing +onlyIf True = Just + +prop_raw_bearer_send_and_receive_inet :: Message -> Property +prop_raw_bearer_send_and_receive_inet msg = + ioProperty $ withIOManager $ \iomgr -> do + let clientAddr = Socket.SockAddrInet 10000 localhost + let serverAddr = Socket.SockAddrInet 10001 localhost + rawBearerSendAndReceive + (socketSnocket iomgr) + clientAddr serverAddr + msg + +localhost :: Word32 +localhost = Socket.tupleToHostAddress (127, 0, 0, 1) + prop_raw_bearer_send_and_receive_unix :: Message -> Property prop_raw_bearer_send_and_receive_unix msg = ioProperty $ withIOManager $ \iomgr -> do From 0128c342672597d2ce136371a61ba73f86359bd7 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 9 May 2023 14:06:50 +0200 Subject: [PATCH 03/19] Make stylish-haskell happy --- .../sim-tests/Test/Ouroboros/Network/RawBearer.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index dca20c6f564..30d936df564 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -47,7 +47,7 @@ tests = testGroup "Ouroboros.Network.RawBearer" $ onlyIf :: Bool -> a -> Maybe a onlyIf False = const Nothing -onlyIf True = Just +onlyIf True = Just prop_raw_bearer_send_and_receive_inet :: Message -> Property prop_raw_bearer_send_and_receive_inet msg = From e3bbd9afba98f78f493bbbc82c2c33df53b54c25 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Mon, 15 May 2023 09:40:08 +0200 Subject: [PATCH 04/19] Use CHANGELOG.md instead of changelog.d --- ouroboros-network-framework/CHANGELOG.md | 1 + .../changelog.d/20230224_094922_tdammers_raw_bearer.rst | 6 ------ 2 files changed, 1 insertion(+), 6 deletions(-) delete mode 100644 ouroboros-network-framework/changelog.d/20230224_094922_tdammers_raw_bearer.rst diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md index 0cd7eaeff25..1e1e7af37c4 100644 --- a/ouroboros-network-framework/CHANGELOG.md +++ b/ouroboros-network-framework/CHANGELOG.md @@ -281,6 +281,7 @@ ### Non-breaking changes * `ghc-9.4` and `ghc-9.6` compatibility. +* RawBearer API (typeclass and instances) added. ## 0.4.0.0 -- 2023-04-19 diff --git a/ouroboros-network-framework/changelog.d/20230224_094922_tdammers_raw_bearer.rst b/ouroboros-network-framework/changelog.d/20230224_094922_tdammers_raw_bearer.rst deleted file mode 100644 index e2b5f727b00..00000000000 --- a/ouroboros-network-framework/changelog.d/20230224_094922_tdammers_raw_bearer.rst +++ /dev/null @@ -1,6 +0,0 @@ -Added ------ - -- RawBearer API -- ToRawBearer typeclass -- ToRawBearer instances for `Socket`, `LocalSocket`, and `Simulation.Network.Snocket.FD` From 4521aada16417ae4c2e27b38ccefa2a2e98b5abf Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Mon, 15 May 2023 09:40:46 +0200 Subject: [PATCH 05/19] Refactoring --- .../src/Ouroboros/Network/RawBearer.hs | 7 +++++-- .../src/Ouroboros/Network/Snocket.hs | 2 +- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/src/Ouroboros/Network/RawBearer.hs index c1eb110cf2d..b697d551c83 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/RawBearer.hs @@ -25,8 +25,11 @@ class ToRawBearer m fd where toRawBearer :: fd -> m (RawBearer m) instance ToRawBearer IO Socket where - toRawBearer s = - return RawBearer + toRawBearer = return . socketToRawBearer + +socketToRawBearer :: Socket -> RawBearer IO +socketToRawBearer s = + RawBearer { send = Socket.sendBuf s , recv = Socket.recvBuf s } diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs index a67bb2da49e..00500b46026 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs @@ -404,7 +404,7 @@ newtype LocalSocket = LocalSocket { getLocalHandle :: LocalHandle } deriving Show via Quiet LocalSocket instance ToRawBearer IO LocalSocket where - toRawBearer = toRawBearer . getLocalHandle + toRawBearer = return . socketToRawBearer . getLocalHandle #endif makeLocalBearer :: MakeBearer IO LocalSocket From ee30ae497d7a8347cdebf1c24f794851bd065b3a Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Mon, 15 May 2023 09:40:57 +0200 Subject: [PATCH 06/19] Test `RawBearer` against `LocalSnocket` --- .../Test/Ouroboros/Network/RawBearer.hs | 23 +++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index 30d936df564..f4f1e5ca5b8 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -39,6 +39,7 @@ tests :: TestTree tests = testGroup "Ouroboros.Network.RawBearer" $ catMaybes [ Just $ testProperty "raw bearer send receive simulated socket" prop_raw_bearer_send_and_receive_iosim + , Just $ testProperty "raw bearer send receive local socket" prop_raw_bearer_send_and_receive_local , onlyIf (Socket.isSupportedSockAddr (Socket.SockAddrUnix "dummy")) $ testProperty "raw bearer send receive unix socket" prop_raw_bearer_send_and_receive_unix , onlyIf (Socket.isSupportedSockAddr (Socket.SockAddrInet 10000 localhost)) $ @@ -59,6 +60,28 @@ prop_raw_bearer_send_and_receive_inet msg = clientAddr serverAddr msg +prop_raw_bearer_send_and_receive_local :: Message -> Property +prop_raw_bearer_send_and_receive_local msg = + ioProperty $ withIOManager $ \iomgr -> do + let clientName = "local_socket_client.test" + let serverName = "local_socket_server.test" + cleanUp clientName + cleanUp serverName + let clientAddr = LocalAddress clientName + let serverAddr = LocalAddress serverName + rawBearerSendAndReceive + (localSnocket iomgr) + clientAddr serverAddr + msg `finally` do + cleanUp clientName + cleanUp serverName + where + cleanUp name = do + catchJust (\e -> if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing) + (removeFile name) + (\_ -> return ()) + + localhost :: Word32 localhost = Socket.tupleToHostAddress (127, 0, 0, 1) From 0183c26a27d6172b69f9d98b227a2101b9a92d7b Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Mon, 15 May 2023 10:02:47 +0200 Subject: [PATCH 07/19] Formatting --- .../sim-tests/Test/Ouroboros/Network/RawBearer.hs | 3 +-- .../src/Simulation/Network/Snocket.hs | 15 ++++++++------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index f4f1e5ca5b8..b91e4d8b77a 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -127,8 +127,7 @@ instance Arbitrary Message where shrink = filter (not . BS.null . messageBytes) . fmap (Message . BS.pack) . shrink . BS.unpack . messageBytes arbitrary = Message . BS.pack <$> listOf1 arbitrary -newtype TestError = - TestError String +newtype TestError = TestError String deriving (Show) instance Exception TestError where diff --git a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs index f25175488e0..8a93043152e 100644 --- a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs @@ -590,13 +590,14 @@ makeRawFDBearer (FD {fdVar}) = do say $ "Checking buffer" bytesFromBuffer <- atomically $ takeTMVar bufVar say $ "Buffer: " ++ show bytesFromBuffer - (lhs, rhs) <- if not (LBS.null bytesFromBuffer) then do - say $ "Reading up to " ++ show size ++ " bytes from buffer" - return (LBS.take size64 bytesFromBuffer, LBS.drop size64 bytesFromBuffer) - else do - bytesRead <- acRead (connChannelLocal conn) - say $ "Received " ++ show (LBS.length $ LBS.take size64 bytesRead) ++ " or more bytes" - return (LBS.take size64 bytesRead, LBS.drop size64 bytesRead) + (lhs, rhs) <- if not (LBS.null bytesFromBuffer) + then do + say $ "Reading up to " ++ show size ++ " bytes from buffer" + return (LBS.take size64 bytesFromBuffer, LBS.drop size64 bytesFromBuffer) + else do + bytesRead <- acRead (connChannelLocal conn) + say $ "Received " ++ show (LBS.length $ LBS.take size64 bytesRead) ++ " or more bytes" + return (LBS.take size64 bytesRead, LBS.drop size64 bytesRead) say $ "Updating buffer; use: " ++ show lhs ++ " keep: " ++ show (LBS.take 10 rhs) ++ if (LBS.length . LBS.take 11 $ rhs) == 11 then "..." else "" atomically $ putTMVar bufVar rhs From 63923f8dc5a3dbd23231b16aab5335c3a5f5f004 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 16 May 2023 16:20:39 +0200 Subject: [PATCH 08/19] Replace ToRawBearer typeclass with MakeRawBearer wrapper type --- .../Test/Ouroboros/Network/RawBearer.hs | 13 +- .../src/Ouroboros/Network/RawBearer.hs | 12 +- .../src/Ouroboros/Network/Snocket.hs | 12 +- .../src/Simulation/Network/Snocket.hs | 124 +++++++++--------- 4 files changed, 83 insertions(+), 78 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index b91e4d8b77a..aa4853f6b7e 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -57,6 +57,7 @@ prop_raw_bearer_send_and_receive_inet msg = let serverAddr = Socket.SockAddrInet 10001 localhost rawBearerSendAndReceive (socketSnocket iomgr) + makeSocketRawBearer clientAddr serverAddr msg @@ -71,6 +72,7 @@ prop_raw_bearer_send_and_receive_local msg = let serverAddr = LocalAddress serverName rawBearerSendAndReceive (localSnocket iomgr) + makeLocalRawBearer clientAddr serverAddr msg `finally` do cleanUp clientName @@ -96,6 +98,7 @@ prop_raw_bearer_send_and_receive_unix msg = let serverAddr = Socket.SockAddrUnix serverName rawBearerSendAndReceive (socketSnocket iomgr) + makeSocketRawBearer clientAddr serverAddr msg `finally` do cleanUp clientName @@ -116,6 +119,7 @@ prop_raw_bearer_send_and_receive_iosim clientInt serverInt msg = mempty $ \snocket _observe -> do rawBearerSendAndReceive snocket + (makeFDRawBearer nullTracer) (TestAddress clientInt) (TestAddress serverInt) msg @@ -136,17 +140,16 @@ rawBearerSendAndReceive :: forall m fd addr . ( MonadST m , MonadThrow m , MonadAsync m - -- , MonadTimer m , MonadMVar m , MonadSay m - , ToRawBearer m fd ) => Snocket m fd addr + -> MakeRawBearer m fd -> addr -> addr -> Message -> m Property -rawBearerSendAndReceive snocket clientAddr serverAddr msg = +rawBearerSendAndReceive snocket mkrb clientAddr serverAddr msg = withLiftST $ \liftST -> do let io = liftST . unsafeIOToST let size = BS.length (messageBytes msg) @@ -156,7 +159,7 @@ rawBearerSendAndReceive snocket clientAddr serverAddr msg = say "sender: connecting" connect snocket s serverAddr say "sender: connected" - bearer <- toRawBearer s + bearer <- getRawBearer mkrb s bracket (io $ mallocBytes size) (io . free) $ \srcBuf -> do io $ BS.useAsCStringLen (messageBytes msg) (uncurry (copyBytes srcBuf)) @@ -184,7 +187,7 @@ rawBearerSendAndReceive snocket clientAddr serverAddr msg = labelThisThread "accept" say "receiver: connection accepted" flip finally (say "receiver: closing connection" >> close snocket s' >> say "receiver: connection closed") $ do - bearer <- toRawBearer s' + bearer <- getRawBearer mkrb s' retval <- bracket (io $ mallocBytes size) (io . free) $ \dstBuf -> do let go _ 0 = do say "receiver: done receiving" diff --git a/ouroboros-network-framework/src/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/src/Ouroboros/Network/RawBearer.hs index b697d551c83..bec9f0de872 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/RawBearer.hs @@ -21,11 +21,12 @@ data RawBearer m = , recv :: Ptr Word8 -> Int -> m Int } -class ToRawBearer m fd where - toRawBearer :: fd -> m (RawBearer m) +newtype MakeRawBearer m fd = MakeRawBearer { + getRawBearer :: fd -> m (RawBearer m) +} -instance ToRawBearer IO Socket where - toRawBearer = return . socketToRawBearer +makeSocketRawBearer :: MakeRawBearer IO Socket +makeSocketRawBearer = MakeRawBearer (return . socketToRawBearer) socketToRawBearer :: Socket -> RawBearer IO socketToRawBearer s = @@ -36,6 +37,9 @@ socketToRawBearer s = #if defined(mingw32_HOST_OS) +win32MakeRawBearer :: MakeRawBearer IO Win32.HANDLE +win32MakeRawBearer = MakeRawBearer (return . win32HandleToRawBearer) + -- | We cannot declare an @instance ToRawBearer Win32.HANDLE@, because -- 'Win32.Handle' is just a type alias for @Ptr ()@. So instead, we provide -- this function, which can be used to implement 'ToRawBearer' elsewhere (e.g. diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs index 00500b46026..b6c442c55c8 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs @@ -21,6 +21,7 @@ module Ouroboros.Network.Snocket , AddressFamily (..) , Snocket (..) , makeSocketBearer + , makeLocalRawBearer -- ** Socket based Snockets , SocketSnocket , socketSnocket @@ -395,18 +396,21 @@ data LocalSocket = LocalSocket { getLocalHandle :: !LocalHandle deriving (Eq, Generic) deriving Show via Quiet LocalSocket -instance ToRawBearer IO LocalSocket where - toRawBearer = return . win32HandleToRawBearer . getLocalHandle +localSocketToRawBearer :: LocalSocket -> RawBearer IO +localSocketToRawBearer = win32HandleToRawBearer . getLocalHandle #else newtype LocalSocket = LocalSocket { getLocalHandle :: LocalHandle } deriving (Eq, Generic) deriving Show via Quiet LocalSocket -instance ToRawBearer IO LocalSocket where - toRawBearer = return . socketToRawBearer . getLocalHandle +localSocketToRawBearer :: LocalSocket -> RawBearer IO +localSocketToRawBearer = socketToRawBearer . getLocalHandle #endif +makeLocalRawBearer :: MakeRawBearer IO LocalSocket +makeLocalRawBearer = MakeRawBearer (return . localSocketToRawBearer) + makeLocalBearer :: MakeBearer IO LocalSocket #if defined(mingw32_HOST_OS) makeLocalBearer = MakeBearer $ \sduTimeout tracer LocalSocket { getLocalHandle = fd } -> diff --git a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs index 8a93043152e..b0bf68871ee 100644 --- a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs @@ -38,6 +38,7 @@ module Simulation.Network.Snocket , TimeoutDetail (..) , noAttenuation , FD + , makeFDRawBearer , makeFDBearer , GlobalAddressScheme (..) , AddressType (..) @@ -540,82 +541,75 @@ instance Show addr => Show (FD_ m addr) where -- newtype FD m peerAddr = FD { fdVar :: StrictTVar m (FD_ m peerAddr) } -instance ( MonadST m - , MonadThrow m - , MonadSay m - , MonadLabelledSTM m - , Show addr - ) => ToRawBearer m (FD m (TestAddress addr)) where - toRawBearer = makeRawFDBearer - -- | Make a 'RawBearer' from an 'FD'. Since this is only used for testing, we -- can bypass the requirement of moving raw bytes directly between file -- descriptors and provided memory buffers, and we can instead covertly use -- plain old 'ByteString' under the hood. This allows us to use the -- 'AttenuatedChannel' inside the `FD_`, even though its send and receive -- methods do not have the right format. -makeRawFDBearer :: forall addr m. +makeFDRawBearer :: forall m addr. ( MonadST m - , MonadLabelledSTM m , MonadThrow m - , MonadSay m + , MonadLabelledSTM m , Show addr ) - => FD m (TestAddress addr) - -> m (RawBearer m) -makeRawFDBearer (FD {fdVar}) = do - (bufVar :: StrictTMVar m LBS.ByteString) <- newTMVarIO LBS.empty - return RawBearer - { send = \src srcSize -> do - labelTVarIO fdVar "sender" - say $ "Sending " ++ show srcSize ++ " bytes" - fd_ <- readTVarIO fdVar - case fd_ of - FDConnected _ conn -> do - bs <- withLiftST $ \liftST -> - liftST . unsafeIOToST $ BS.packCStringLen (castPtr src, srcSize) - let bsl = LBS.fromStrict bs - acWrite (connChannelLocal conn) bsl - say $ "Sent " ++ show srcSize ++ " bytes" - return srcSize - _ -> - throwIO (invalidError fd_) - , recv = \dst size -> do - labelTVarIO fdVar "receiver" - let size64 = fromIntegral size - say $ "Receiving " ++ show size ++ " bytes" - fd_ <- readTVarIO fdVar - case fd_ of - FDConnected _ conn -> do - say $ "Checking buffer" - bytesFromBuffer <- atomically $ takeTMVar bufVar - say $ "Buffer: " ++ show bytesFromBuffer - (lhs, rhs) <- if not (LBS.null bytesFromBuffer) - then do - say $ "Reading up to " ++ show size ++ " bytes from buffer" - return (LBS.take size64 bytesFromBuffer, LBS.drop size64 bytesFromBuffer) - else do - bytesRead <- acRead (connChannelLocal conn) - say $ "Received " ++ show (LBS.length $ LBS.take size64 bytesRead) ++ " or more bytes" - return (LBS.take size64 bytesRead, LBS.drop size64 bytesRead) - say $ "Updating buffer; use: " ++ show lhs ++ " keep: " ++ show (LBS.take 10 rhs) ++ - if (LBS.length . LBS.take 11 $ rhs) == 11 then "..." else "" - atomically $ putTMVar bufVar rhs - say $ "Receive: buffer updated" - if LBS.null lhs then do - say $ "Receive: End of stream" - return 0 - else do - say $ "Receive: copying." - let bs = LBS.toStrict lhs - withLiftST $ \liftST -> - liftST . unsafeIOToST $ BS.useAsCStringLen bs $ \(src, srcSize) -> do - copyBytes dst (castPtr src) srcSize - return srcSize - _ -> - throwIO (invalidError fd_) - } + => Tracer m String + -> MakeRawBearer m (FD m (TestAddress addr)) +makeFDRawBearer tracer = MakeRawBearer go where + go (FD {fdVar}) = do + (bufVar :: StrictTMVar m LBS.ByteString) <- newTMVarIO LBS.empty + return RawBearer + { send = \src srcSize -> do + labelTVarIO fdVar "sender" + traceWith tracer $ "Sending " ++ show srcSize ++ " bytes" + fd_ <- readTVarIO fdVar + case fd_ of + FDConnected _ conn -> do + bs <- withLiftST $ \liftST -> + liftST . unsafeIOToST $ BS.packCStringLen (castPtr src, srcSize) + let bsl = LBS.fromStrict bs + acWrite (connChannelLocal conn) bsl + traceWith tracer $ "Sent " ++ show srcSize ++ " bytes" + return srcSize + _ -> + throwIO (invalidError fd_) + , recv = \dst size -> do + labelTVarIO fdVar "receiver" + let size64 = fromIntegral size + traceWith tracer $ "Receiving " ++ show size ++ " bytes" + fd_ <- readTVarIO fdVar + case fd_ of + FDConnected _ conn -> do + traceWith tracer $ "Checking buffer" + bytesFromBuffer <- atomically $ takeTMVar bufVar + traceWith tracer $ "Buffer: " ++ show bytesFromBuffer + (lhs, rhs) <- if not (LBS.null bytesFromBuffer) + then do + traceWith tracer $ "Reading up to " ++ show size ++ " bytes from buffer" + return (LBS.take size64 bytesFromBuffer, LBS.drop size64 bytesFromBuffer) + else do + bytesRead <- acRead (connChannelLocal conn) + traceWith tracer $ "Received " ++ show (LBS.length $ LBS.take size64 bytesRead) ++ " or more bytes" + return (LBS.take size64 bytesRead, LBS.drop size64 bytesRead) + traceWith tracer $ "Updating buffer; use: " ++ show lhs ++ " keep: " ++ show (LBS.take 10 rhs) ++ + if (LBS.length . LBS.take 11 $ rhs) == 11 then "..." else "" + atomically $ putTMVar bufVar rhs + traceWith tracer $ "Receive: buffer updated" + if LBS.null lhs then do + traceWith tracer $ "Receive: End of stream" + return 0 + else do + traceWith tracer $ "Receive: copying." + let bs = LBS.toStrict lhs + withLiftST $ \liftST -> + liftST . unsafeIOToST $ BS.useAsCStringLen bs $ \(src, srcSize) -> do + copyBytes dst (castPtr src) srcSize + return srcSize + _ -> + throwIO (invalidError fd_) + } + invalidError :: FD_ m (TestAddress addr) -> IOError invalidError fd_ = IOError { ioe_handle = Nothing From 73165b041dbf609cb4fde1f2fe61f321505e1dc2 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Wed, 17 May 2023 09:17:31 +0200 Subject: [PATCH 09/19] Use typed tracer in simulated RawBearer. --- .../src/Simulation/Network/Snocket.hs | 55 ++++++++++++++----- 1 file changed, 42 insertions(+), 13 deletions(-) diff --git a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs index b0bf68871ee..a9557c2b3e6 100644 --- a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs @@ -541,6 +541,31 @@ instance Show addr => Show (FD_ m addr) where -- newtype FD m peerAddr = FD { fdVar :: StrictTVar m (FD_ m peerAddr) } +data FDRawBearerSendTrace + = SendingBytes Int + | SentBytes Int + deriving (Show, Eq) + +data FDRawBearerRecvTrace + = ReceivingBytes Int + | ReceivedBytes Int + | ReadingFromBuffer Int + | ReadingFromSocket Int + | CheckingBuffer + | BufferSize Int + | UpdateBuffer + Int -- ^ take + Int -- ^ keep + | BufferUpdated + | EndOfStream + | Copying + deriving (Show, Eq) + +data FDRawBearerTrace + = TraceSend FDRawBearerSendTrace + | TraceRecv FDRawBearerRecvTrace + deriving (Show, Eq) + -- | Make a 'RawBearer' from an 'FD'. Since this is only used for testing, we -- can bypass the requirement of moving raw bytes directly between file -- descriptors and provided memory buffers, and we can instead covertly use @@ -553,16 +578,20 @@ makeFDRawBearer :: forall m addr. , MonadLabelledSTM m , Show addr ) - => Tracer m String + => Tracer m FDRawBearerTrace -> MakeRawBearer m (FD m (TestAddress addr)) makeFDRawBearer tracer = MakeRawBearer go where + traceSend = traceWith tracer . TraceSend + + traceRecv = traceWith tracer . TraceRecv + go (FD {fdVar}) = do (bufVar :: StrictTMVar m LBS.ByteString) <- newTMVarIO LBS.empty return RawBearer { send = \src srcSize -> do labelTVarIO fdVar "sender" - traceWith tracer $ "Sending " ++ show srcSize ++ " bytes" + traceSend $ SendingBytes srcSize fd_ <- readTVarIO fdVar case fd_ of FDConnected _ conn -> do @@ -570,37 +599,37 @@ makeFDRawBearer tracer = MakeRawBearer go liftST . unsafeIOToST $ BS.packCStringLen (castPtr src, srcSize) let bsl = LBS.fromStrict bs acWrite (connChannelLocal conn) bsl - traceWith tracer $ "Sent " ++ show srcSize ++ " bytes" + traceSend $ SentBytes srcSize return srcSize _ -> throwIO (invalidError fd_) , recv = \dst size -> do labelTVarIO fdVar "receiver" let size64 = fromIntegral size - traceWith tracer $ "Receiving " ++ show size ++ " bytes" + traceRecv $ ReceivingBytes size fd_ <- readTVarIO fdVar case fd_ of FDConnected _ conn -> do - traceWith tracer $ "Checking buffer" + traceRecv CheckingBuffer bytesFromBuffer <- atomically $ takeTMVar bufVar - traceWith tracer $ "Buffer: " ++ show bytesFromBuffer + traceRecv $ BufferSize (fromIntegral $ LBS.length bytesFromBuffer) (lhs, rhs) <- if not (LBS.null bytesFromBuffer) then do - traceWith tracer $ "Reading up to " ++ show size ++ " bytes from buffer" + traceRecv $ ReadingFromBuffer size return (LBS.take size64 bytesFromBuffer, LBS.drop size64 bytesFromBuffer) else do + traceRecv $ ReadingFromSocket size bytesRead <- acRead (connChannelLocal conn) - traceWith tracer $ "Received " ++ show (LBS.length $ LBS.take size64 bytesRead) ++ " or more bytes" + traceRecv $ ReceivedBytes (fromIntegral . LBS.length $ LBS.take size64 bytesRead) return (LBS.take size64 bytesRead, LBS.drop size64 bytesRead) - traceWith tracer $ "Updating buffer; use: " ++ show lhs ++ " keep: " ++ show (LBS.take 10 rhs) ++ - if (LBS.length . LBS.take 11 $ rhs) == 11 then "..." else "" + traceRecv $ UpdateBuffer (fromIntegral $ LBS.length lhs) (fromIntegral $ LBS.length rhs) atomically $ putTMVar bufVar rhs - traceWith tracer $ "Receive: buffer updated" + traceRecv $ BufferUpdated if LBS.null lhs then do - traceWith tracer $ "Receive: End of stream" + traceRecv EndOfStream return 0 else do - traceWith tracer $ "Receive: copying." + traceRecv Copying let bs = LBS.toStrict lhs withLiftST $ \liftST -> liftST . unsafeIOToST $ BS.useAsCStringLen bs $ \(src, srcSize) -> do From d3e74192ae5631dc012bae731660793f9ac532b9 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Wed, 17 May 2023 10:17:02 +0200 Subject: [PATCH 10/19] Add buffer underflow check in test suite --- .../sim-tests/Test/Ouroboros/Network/RawBearer.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index aa4853f6b7e..794a8a6b63a 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -166,6 +166,8 @@ rawBearerSendAndReceive snocket mkrb clientAddr serverAddr msg = let go _ 0 = do say "sender: done" return () + go _ n | n < 0 = do + error "sender: negative byte count" go buf n = do say $ "sender: " ++ show n ++ " bytes left" bytesSent <- send bearer buf n @@ -192,6 +194,8 @@ rawBearerSendAndReceive snocket mkrb clientAddr serverAddr msg = let go _ 0 = do say "receiver: done receiving" return () + go _ n | n < 0 = do + error "receiver: negative byte count" go buf n = do say $ "receiver: " ++ show n ++ " bytes left" bytesReceived <- recv bearer buf n From 07b7eee987926a61279dd481769093d92ceed92e Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Thu, 25 May 2023 12:06:53 +0200 Subject: [PATCH 11/19] Windows-friendly names for named pipes --- .../sim-tests/Test/Ouroboros/Network/RawBearer.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index 794a8a6b63a..0b2b562f6ae 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module Test.Ouroboros.Network.RawBearer where @@ -64,12 +65,17 @@ prop_raw_bearer_send_and_receive_inet msg = prop_raw_bearer_send_and_receive_local :: Message -> Property prop_raw_bearer_send_and_receive_local msg = ioProperty $ withIOManager $ \iomgr -> do +#if defined(mingw32_HOST_OS) + let clientName = "\\\\.\\pipe\\local_socket_client.test" + let serverName = "\\\\.\\pipe\\local_socket_server.test" +#else let clientName = "local_socket_client.test" let serverName = "local_socket_server.test" +#endif cleanUp clientName cleanUp serverName - let clientAddr = LocalAddress clientName - let serverAddr = LocalAddress serverName + let clientAddr = localAddressFromPath clientName + let serverAddr = localAddressFromPath serverName rawBearerSendAndReceive (localSnocket iomgr) makeLocalRawBearer From 876df1af09ea28c1e1b03401e898b0b23617d473 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Wed, 31 May 2023 17:04:49 +0200 Subject: [PATCH 12/19] Randomize named pipe names to avoid false negatives --- .../Test/Ouroboros/Network/RawBearer.hs | 21 +++++++++---------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index 0b2b562f6ae..1625567b1d2 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -62,15 +62,15 @@ prop_raw_bearer_send_and_receive_inet msg = clientAddr serverAddr msg -prop_raw_bearer_send_and_receive_local :: Message -> Property -prop_raw_bearer_send_and_receive_local msg = +prop_raw_bearer_send_and_receive_local :: Int -> Int -> Message -> Property +prop_raw_bearer_send_and_receive_local clientInt serverInt msg = ioProperty $ withIOManager $ \iomgr -> do #if defined(mingw32_HOST_OS) - let clientName = "\\\\.\\pipe\\local_socket_client.test" - let serverName = "\\\\.\\pipe\\local_socket_server.test" + let clientName = "\\\\.\\pipe\\local_socket_client.test" ++ show clientInt + let serverName = "\\\\.\\pipe\\local_socket_server.test" ++ show serverInt #else - let clientName = "local_socket_client.test" - let serverName = "local_socket_server.test" + let clientName = "local_socket_client.test" ++ show clientInt + let serverName = "local_socket_server.test" ++ show serverInt #endif cleanUp clientName cleanUp serverName @@ -93,11 +93,11 @@ prop_raw_bearer_send_and_receive_local msg = localhost :: Word32 localhost = Socket.tupleToHostAddress (127, 0, 0, 1) -prop_raw_bearer_send_and_receive_unix :: Message -> Property -prop_raw_bearer_send_and_receive_unix msg = +prop_raw_bearer_send_and_receive_unix :: Int -> Int -> Message -> Property +prop_raw_bearer_send_and_receive_unix clientInt serverInt msg = ioProperty $ withIOManager $ \iomgr -> do - let clientName = "unix_socket_client.test" - let serverName = "unix_socket_server.test" + let clientName = "unix_socket_client.test" ++ show clientInt + let serverName = "unix_socket_server.test"++ show serverInt cleanUp clientName cleanUp serverName let clientAddr = Socket.SockAddrUnix clientName @@ -117,7 +117,6 @@ prop_raw_bearer_send_and_receive_unix msg = prop_raw_bearer_send_and_receive_iosim :: Int -> Int -> Message -> Property prop_raw_bearer_send_and_receive_iosim clientInt serverInt msg = - (clientInt /= serverInt) ==> iosimProperty $ SimSnocket.withSnocket nullTracer From d4c7edfeca67cac8668a237443712621f40fa991 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Thu, 1 Jun 2023 10:25:39 +0200 Subject: [PATCH 13/19] No cleaning up named pipes as files on Windows --- .../Test/Ouroboros/Network/RawBearer.hs | 23 +++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index 1625567b1d2..80d9dcfdc71 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Ouroboros.Network.RawBearer where @@ -62,8 +64,17 @@ prop_raw_bearer_send_and_receive_inet msg = clientAddr serverAddr msg -prop_raw_bearer_send_and_receive_local :: Int -> Int -> Message -> Property +newtype Unshrinkable a = Unshrinkable { unUnshrinkable :: a } + deriving newtype (Show, Eq, Ord) + +instance Arbitrary a => Arbitrary (Unshrinkable a) where + shrink _ = [] + arbitrary = Unshrinkable <$> arbitrary + +prop_raw_bearer_send_and_receive_local :: Unshrinkable Int -> Unshrinkable Int -> Message -> Property prop_raw_bearer_send_and_receive_local clientInt serverInt msg = + (clientInt /= Unshrinkable 0) ==> + (serverInt /= Unshrinkable 0) ==> do ioProperty $ withIOManager $ \iomgr -> do #if defined(mingw32_HOST_OS) let clientName = "\\\\.\\pipe\\local_socket_client.test" ++ show clientInt @@ -84,10 +95,14 @@ prop_raw_bearer_send_and_receive_local clientInt serverInt msg = cleanUp clientName cleanUp serverName where +#if defined(mingw32_HOST_OS) + cleanUp _ = return () +#else cleanUp name = do catchJust (\e -> if isDoesNotExistErrorType (ioeGetErrorType e) then Just () else Nothing) (removeFile name) (\_ -> return ()) +#endif localhost :: Word32 From f2d1e28436a60353953e98da63d49b9f4e2e4308 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Fri, 9 Jun 2023 09:47:22 +0200 Subject: [PATCH 14/19] Generating client addresses is actually pointless and wrong. --- .../Test/Ouroboros/Network/RawBearer.hs | 42 +++++++------------ 1 file changed, 14 insertions(+), 28 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index 80d9dcfdc71..f112a2a8d7b 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -56,43 +56,35 @@ onlyIf True = Just prop_raw_bearer_send_and_receive_inet :: Message -> Property prop_raw_bearer_send_and_receive_inet msg = ioProperty $ withIOManager $ \iomgr -> do - let clientAddr = Socket.SockAddrInet 10000 localhost let serverAddr = Socket.SockAddrInet 10001 localhost rawBearerSendAndReceive (socketSnocket iomgr) makeSocketRawBearer - clientAddr serverAddr + serverAddr msg -newtype Unshrinkable a = Unshrinkable { unUnshrinkable :: a } +newtype ArbPosInt = ArbPosInt { unArbPosInt :: Int } deriving newtype (Show, Eq, Ord) -instance Arbitrary a => Arbitrary (Unshrinkable a) where +instance Arbitrary ArbPosInt where shrink _ = [] - arbitrary = Unshrinkable <$> arbitrary + arbitrary = ArbPosInt . getPositive <$> arbitrary -prop_raw_bearer_send_and_receive_local :: Unshrinkable Int -> Unshrinkable Int -> Message -> Property -prop_raw_bearer_send_and_receive_local clientInt serverInt msg = - (clientInt /= Unshrinkable 0) ==> - (serverInt /= Unshrinkable 0) ==> do +prop_raw_bearer_send_and_receive_local :: ArbPosInt -> Message -> Property +prop_raw_bearer_send_and_receive_local serverInt msg = ioProperty $ withIOManager $ \iomgr -> do #if defined(mingw32_HOST_OS) - let clientName = "\\\\.\\pipe\\local_socket_client.test" ++ show clientInt let serverName = "\\\\.\\pipe\\local_socket_server.test" ++ show serverInt #else - let clientName = "local_socket_client.test" ++ show clientInt let serverName = "local_socket_server.test" ++ show serverInt #endif - cleanUp clientName cleanUp serverName - let clientAddr = localAddressFromPath clientName let serverAddr = localAddressFromPath serverName rawBearerSendAndReceive (localSnocket iomgr) makeLocalRawBearer - clientAddr serverAddr + serverAddr msg `finally` do - cleanUp clientName cleanUp serverName where #if defined(mingw32_HOST_OS) @@ -108,21 +100,17 @@ prop_raw_bearer_send_and_receive_local clientInt serverInt msg = localhost :: Word32 localhost = Socket.tupleToHostAddress (127, 0, 0, 1) -prop_raw_bearer_send_and_receive_unix :: Int -> Int -> Message -> Property -prop_raw_bearer_send_and_receive_unix clientInt serverInt msg = +prop_raw_bearer_send_and_receive_unix :: Int -> Message -> Property +prop_raw_bearer_send_and_receive_unix serverInt msg = ioProperty $ withIOManager $ \iomgr -> do - let clientName = "unix_socket_client.test" ++ show clientInt let serverName = "unix_socket_server.test"++ show serverInt - cleanUp clientName cleanUp serverName - let clientAddr = Socket.SockAddrUnix clientName let serverAddr = Socket.SockAddrUnix serverName rawBearerSendAndReceive (socketSnocket iomgr) makeSocketRawBearer - clientAddr serverAddr + serverAddr msg `finally` do - cleanUp clientName cleanUp serverName where cleanUp name = do @@ -130,8 +118,8 @@ prop_raw_bearer_send_and_receive_unix clientInt serverInt msg = (removeFile name) (\_ -> return ()) -prop_raw_bearer_send_and_receive_iosim :: Int -> Int -> Message -> Property -prop_raw_bearer_send_and_receive_iosim clientInt serverInt msg = +prop_raw_bearer_send_and_receive_iosim :: Int -> Message -> Property +prop_raw_bearer_send_and_receive_iosim serverInt msg = iosimProperty $ SimSnocket.withSnocket nullTracer @@ -140,7 +128,6 @@ prop_raw_bearer_send_and_receive_iosim clientInt serverInt msg = rawBearerSendAndReceive snocket (makeFDRawBearer nullTracer) - (TestAddress clientInt) (TestAddress serverInt) msg @@ -166,16 +153,15 @@ rawBearerSendAndReceive :: forall m fd addr => Snocket m fd addr -> MakeRawBearer m fd -> addr - -> addr -> Message -> m Property -rawBearerSendAndReceive snocket mkrb clientAddr serverAddr msg = +rawBearerSendAndReceive snocket mkrb serverAddr msg = withLiftST $ \liftST -> do let io = liftST . unsafeIOToST let size = BS.length (messageBytes msg) retVar <- newEmptyMVar senderDone <- newEmptyMVar - let sender = bracket (openToConnect snocket clientAddr) (close snocket) $ \s -> do + let sender = bracket (openToConnect snocket serverAddr) (close snocket) $ \s -> do say "sender: connecting" connect snocket s serverAddr say "sender: connected" From 7ee0b1a8aa793e11cb70a3847260386ec46151b3 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Thu, 15 Jun 2023 14:51:58 +0200 Subject: [PATCH 15/19] Turns out we do need client addresses after all --- .../Test/Ouroboros/Network/RawBearer.hs | 46 +++++++++++++++---- 1 file changed, 36 insertions(+), 10 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index f112a2a8d7b..be03c7b8a6b 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -33,11 +33,14 @@ import qualified Network.Socket as Socket import Simulation.Network.Snocket as SimSnocket import System.Directory (removeFile) import System.IO.Error (ioeGetErrorType, isDoesNotExistErrorType) +import System.IO.Unsafe import Test.Simulation.Network.Snocket (toBearerInfo) import Test.Tasty import Test.Tasty.QuickCheck +import Debug.Trace + tests :: TestTree tests = testGroup "Ouroboros.Network.RawBearer" $ catMaybes @@ -53,14 +56,21 @@ onlyIf :: Bool -> a -> Maybe a onlyIf False = const Nothing onlyIf True = Just +{-# NOINLINE nextPort #-} +nextPort :: MVar IO Int +nextPort = unsafePerformIO $ newMVar 7000 + prop_raw_bearer_send_and_receive_inet :: Message -> Property prop_raw_bearer_send_and_receive_inet msg = ioProperty $ withIOManager $ \iomgr -> do - let serverAddr = Socket.SockAddrInet 10001 localhost + serverPort <- modifyMVar nextPort (\i -> return (succ i, succ i)) + let serverAddr = Socket.SockAddrInet (fromIntegral serverPort) localhost + Debug.Trace.traceM $ "Server: " ++ show serverAddr rawBearerSendAndReceive (socketSnocket iomgr) makeSocketRawBearer serverAddr + Nothing msg newtype ArbPosInt = ArbPosInt { unArbPosInt :: Int } @@ -70,20 +80,24 @@ instance Arbitrary ArbPosInt where shrink _ = [] arbitrary = ArbPosInt . getPositive <$> arbitrary -prop_raw_bearer_send_and_receive_local :: ArbPosInt -> Message -> Property -prop_raw_bearer_send_and_receive_local serverInt msg = +prop_raw_bearer_send_and_receive_local :: ArbPosInt -> ArbPosInt -> Message -> Property +prop_raw_bearer_send_and_receive_local serverInt clientInt msg = ioProperty $ withIOManager $ \iomgr -> do #if defined(mingw32_HOST_OS) let serverName = "\\\\.\\pipe\\local_socket_server.test" ++ show serverInt + let clientName = "\\\\.\\pipe\\local_socket_client.test" ++ show clientInt #else let serverName = "local_socket_server.test" ++ show serverInt + let clientName = "local_socket_client.test" ++ show clientInt #endif cleanUp serverName let serverAddr = localAddressFromPath serverName + let clientAddr = localAddressFromPath clientName rawBearerSendAndReceive (localSnocket iomgr) makeLocalRawBearer serverAddr + (Just clientAddr) msg `finally` do cleanUp serverName where @@ -100,16 +114,20 @@ prop_raw_bearer_send_and_receive_local serverInt msg = localhost :: Word32 localhost = Socket.tupleToHostAddress (127, 0, 0, 1) -prop_raw_bearer_send_and_receive_unix :: Int -> Message -> Property -prop_raw_bearer_send_and_receive_unix serverInt msg = +prop_raw_bearer_send_and_receive_unix :: Int -> Int -> Message -> Property +prop_raw_bearer_send_and_receive_unix serverInt clientInt msg = ioProperty $ withIOManager $ \iomgr -> do let serverName = "unix_socket_server.test"++ show serverInt + let clientName = "unix_socket_client.test"++ show clientInt cleanUp serverName + cleanUp clientName let serverAddr = Socket.SockAddrUnix serverName + let clientAddr = Socket.SockAddrUnix clientName rawBearerSendAndReceive (socketSnocket iomgr) makeSocketRawBearer serverAddr + (Just clientAddr) msg `finally` do cleanUp serverName where @@ -118,8 +136,8 @@ prop_raw_bearer_send_and_receive_unix serverInt msg = (removeFile name) (\_ -> return ()) -prop_raw_bearer_send_and_receive_iosim :: Int -> Message -> Property -prop_raw_bearer_send_and_receive_iosim serverInt msg = +prop_raw_bearer_send_and_receive_iosim :: Int -> Int -> Message -> Property +prop_raw_bearer_send_and_receive_iosim serverInt clientInt msg = iosimProperty $ SimSnocket.withSnocket nullTracer @@ -129,6 +147,7 @@ prop_raw_bearer_send_and_receive_iosim serverInt msg = snocket (makeFDRawBearer nullTracer) (TestAddress serverInt) + (Just $ TestAddress clientInt) msg newtype Message = Message { messageBytes :: ByteString } @@ -149,20 +168,27 @@ rawBearerSendAndReceive :: forall m fd addr , MonadAsync m , MonadMVar m , MonadSay m + , Show addr ) => Snocket m fd addr -> MakeRawBearer m fd -> addr + -> Maybe addr -> Message -> m Property -rawBearerSendAndReceive snocket mkrb serverAddr msg = +rawBearerSendAndReceive snocket mkrb serverAddr mclientAddr msg = withLiftST $ \liftST -> do let io = liftST . unsafeIOToST let size = BS.length (messageBytes msg) retVar <- newEmptyMVar senderDone <- newEmptyMVar - let sender = bracket (openToConnect snocket serverAddr) (close snocket) $ \s -> do - say "sender: connecting" + let sender = bracket (openToConnect snocket serverAddr) (\s -> say "sender: closing" >> close snocket s) $ \s -> do + case mclientAddr of + Nothing -> return () + Just clientAddr -> do + say $ "sender: binding to " ++ show clientAddr + bind snocket s clientAddr + say $ "sender: connecting to " ++ show serverAddr connect snocket s serverAddr say "sender: connected" bearer <- getRawBearer mkrb s From 56e02d313e51b4996e5d28ba9d8b8b5a4812a04b Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Wed, 21 Jun 2023 08:52:30 +0200 Subject: [PATCH 16/19] Disable local snocket tests on Windows. --- .../Test/Ouroboros/Network/RawBearer.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index be03c7b8a6b..9ceb0b1ede3 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -25,7 +25,6 @@ import Control.Monad.ST.Unsafe (unsafeIOToST) import Control.Tracer (nullTracer) import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.Maybe (catMaybes) import Data.Word (Word32) import Foreign.Marshal (copyBytes, free, mallocBytes) import Foreign.Ptr (castPtr, plusPtr) @@ -42,14 +41,13 @@ import Test.Tasty.QuickCheck import Debug.Trace tests :: TestTree -tests = testGroup "Ouroboros.Network.RawBearer" $ - catMaybes - [ Just $ testProperty "raw bearer send receive simulated socket" prop_raw_bearer_send_and_receive_iosim - , Just $ testProperty "raw bearer send receive local socket" prop_raw_bearer_send_and_receive_local - , onlyIf (Socket.isSupportedSockAddr (Socket.SockAddrUnix "dummy")) $ - testProperty "raw bearer send receive unix socket" prop_raw_bearer_send_and_receive_unix - , onlyIf (Socket.isSupportedSockAddr (Socket.SockAddrInet 10000 localhost)) $ - testProperty "raw bearer send receive inet socket" prop_raw_bearer_send_and_receive_inet +tests = testGroup "Ouroboros.Network.RawBearer" + [ testProperty "raw bearer send receive simulated socket" prop_raw_bearer_send_and_receive_iosim +#if !defined(mingw32_HOST_OS) + , testProperty "raw bearer send receive local socket" prop_raw_bearer_send_and_receive_local + , testProperty "raw bearer send receive unix socket" prop_raw_bearer_send_and_receive_unix +#endif + , testProperty "raw bearer send receive inet socket" prop_raw_bearer_send_and_receive_inet ] onlyIf :: Bool -> a -> Maybe a @@ -91,6 +89,7 @@ prop_raw_bearer_send_and_receive_local serverInt clientInt msg = let clientName = "local_socket_client.test" ++ show clientInt #endif cleanUp serverName + cleanUp clientName let serverAddr = localAddressFromPath serverName let clientAddr = localAddressFromPath clientName rawBearerSendAndReceive @@ -100,6 +99,7 @@ prop_raw_bearer_send_and_receive_local serverInt clientInt msg = (Just clientAddr) msg `finally` do cleanUp serverName + cleanUp clientName where #if defined(mingw32_HOST_OS) cleanUp _ = return () From f9f884352c9bb6cd4bfc9807ec2f6350b3d7ac37 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Wed, 21 Jun 2023 14:22:01 +0200 Subject: [PATCH 17/19] Fix CHANGELOG --- ouroboros-network-framework/CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ouroboros-network-framework/CHANGELOG.md b/ouroboros-network-framework/CHANGELOG.md index 1e1e7af37c4..52162aa9db5 100644 --- a/ouroboros-network-framework/CHANGELOG.md +++ b/ouroboros-network-framework/CHANGELOG.md @@ -33,6 +33,7 @@ * `Ouroboros.Network.ConnectionManager.Core` must be imported qualified. * `ConnectionManagerTrace` moved from `Ouroboros.Network.ConnectionManager.Types` to the `Core` module & renamed as `Trace`. +* RawBearer API (typeclass and instances) added. ### Non-breaking changes @@ -281,7 +282,6 @@ ### Non-breaking changes * `ghc-9.4` and `ghc-9.6` compatibility. -* RawBearer API (typeclass and instances) added. ## 0.4.0.0 -- 2023-04-19 From a6e4c46836254eab0505734a47bf174ac2440a91 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Thu, 22 Jun 2023 15:14:49 +0200 Subject: [PATCH 18/19] Make stylish-haskell happy --- .../sim-tests/Test/Ouroboros/Network/RawBearer.hs | 4 ++-- ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index 9ceb0b1ede3..5316fc15816 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Test.Ouroboros.Network.RawBearer where diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs index b6c442c55c8..419d89ca842 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Snocket.hs @@ -21,7 +21,7 @@ module Ouroboros.Network.Snocket , AddressFamily (..) , Snocket (..) , makeSocketBearer - , makeLocalRawBearer + , makeLocalRawBearer -- ** Socket based Snockets , SocketSnocket , socketSnocket From 9810b717bb64c58cbe331d59973c02080dd4da62 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 1 Aug 2023 11:14:52 +0200 Subject: [PATCH 19/19] Replace `say` with tracer --- .../Test/Ouroboros/Network/RawBearer.hs | 57 +++++++++++-------- 1 file changed, 32 insertions(+), 25 deletions(-) diff --git a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index 5316fc15816..40610c8b929 100644 --- a/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -22,7 +22,7 @@ import Control.Monad.Class.MonadThrow (MonadThrow, bracket, catchJust, finally, throwIO) import Control.Monad.IOSim hiding (liftST) import Control.Monad.ST.Unsafe (unsafeIOToST) -import Control.Tracer (nullTracer) +import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Word (Word32) @@ -38,8 +38,6 @@ import Test.Simulation.Network.Snocket (toBearerInfo) import Test.Tasty import Test.Tasty.QuickCheck -import Debug.Trace - tests :: TestTree tests = testGroup "Ouroboros.Network.RawBearer" [ testProperty "raw bearer send receive simulated socket" prop_raw_bearer_send_and_receive_iosim @@ -50,6 +48,12 @@ tests = testGroup "Ouroboros.Network.RawBearer" , testProperty "raw bearer send receive inet socket" prop_raw_bearer_send_and_receive_inet ] +iosimTracer :: forall s. Tracer (IOSim s) String +iosimTracer = Tracer say + +ioTracer :: Tracer IO String +ioTracer = nullTracer + onlyIf :: Bool -> a -> Maybe a onlyIf False = const Nothing onlyIf True = Just @@ -63,8 +67,8 @@ prop_raw_bearer_send_and_receive_inet msg = ioProperty $ withIOManager $ \iomgr -> do serverPort <- modifyMVar nextPort (\i -> return (succ i, succ i)) let serverAddr = Socket.SockAddrInet (fromIntegral serverPort) localhost - Debug.Trace.traceM $ "Server: " ++ show serverAddr rawBearerSendAndReceive + ioTracer (socketSnocket iomgr) makeSocketRawBearer serverAddr @@ -93,6 +97,7 @@ prop_raw_bearer_send_and_receive_local serverInt clientInt msg = let serverAddr = localAddressFromPath serverName let clientAddr = localAddressFromPath clientName rawBearerSendAndReceive + ioTracer (localSnocket iomgr) makeLocalRawBearer serverAddr @@ -124,6 +129,7 @@ prop_raw_bearer_send_and_receive_unix serverInt clientInt msg = let serverAddr = Socket.SockAddrUnix serverName let clientAddr = Socket.SockAddrUnix clientName rawBearerSendAndReceive + ioTracer (socketSnocket iomgr) makeSocketRawBearer serverAddr @@ -144,6 +150,7 @@ prop_raw_bearer_send_and_receive_iosim serverInt clientInt msg = (toBearerInfo absNoAttenuation) mempty $ \snocket _observe -> do rawBearerSendAndReceive + iosimTracer snocket (makeFDRawBearer nullTracer) (TestAddress serverInt) @@ -167,88 +174,88 @@ rawBearerSendAndReceive :: forall m fd addr , MonadThrow m , MonadAsync m , MonadMVar m - , MonadSay m , Show addr ) - => Snocket m fd addr + => Tracer m String + -> Snocket m fd addr -> MakeRawBearer m fd -> addr -> Maybe addr -> Message -> m Property -rawBearerSendAndReceive snocket mkrb serverAddr mclientAddr msg = +rawBearerSendAndReceive tracer snocket mkrb serverAddr mclientAddr msg = withLiftST $ \liftST -> do let io = liftST . unsafeIOToST let size = BS.length (messageBytes msg) retVar <- newEmptyMVar senderDone <- newEmptyMVar - let sender = bracket (openToConnect snocket serverAddr) (\s -> say "sender: closing" >> close snocket s) $ \s -> do + let sender = bracket (openToConnect snocket serverAddr) (\s -> traceWith tracer "sender: closing" >> close snocket s) $ \s -> do case mclientAddr of Nothing -> return () Just clientAddr -> do - say $ "sender: binding to " ++ show clientAddr + traceWith tracer $ "sender: binding to " ++ show clientAddr bind snocket s clientAddr - say $ "sender: connecting to " ++ show serverAddr + traceWith tracer $ "sender: connecting to " ++ show serverAddr connect snocket s serverAddr - say "sender: connected" + traceWith tracer "sender: connected" bearer <- getRawBearer mkrb s bracket (io $ mallocBytes size) (io . free) $ \srcBuf -> do io $ BS.useAsCStringLen (messageBytes msg) (uncurry (copyBytes srcBuf)) let go _ 0 = do - say "sender: done" + traceWith tracer "sender: done" return () go _ n | n < 0 = do error "sender: negative byte count" go buf n = do - say $ "sender: " ++ show n ++ " bytes left" + traceWith tracer $ "sender: " ++ show n ++ " bytes left" bytesSent <- send bearer buf n when (bytesSent == 0) (throwIO $ TestError "sender: premature hangup") let n' = n - bytesSent - say $ "sender: " ++ show bytesSent ++ " bytes sent, " ++ show n' ++ " remaining" + traceWith tracer $ "sender: " ++ show bytesSent ++ " bytes sent, " ++ show n' ++ " remaining" go (plusPtr buf bytesSent) n' go (castPtr srcBuf) size putMVar senderDone () receiver s = do let acceptLoop :: Accept m fd addr -> m () acceptLoop accept0 = do - say "receiver: accepting connection" + traceWith tracer "receiver: accepting connection" (accepted, acceptNext) <- runAccept accept0 case accepted :: Accepted fd addr of AcceptFailure err -> throwIO err Accepted s' _ -> do labelThisThread "accept" - say "receiver: connection accepted" - flip finally (say "receiver: closing connection" >> close snocket s' >> say "receiver: connection closed") $ do + traceWith tracer "receiver: connection accepted" + flip finally (traceWith tracer "receiver: closing connection" >> close snocket s' >> traceWith tracer "receiver: connection closed") $ do bearer <- getRawBearer mkrb s' retval <- bracket (io $ mallocBytes size) (io . free) $ \dstBuf -> do let go _ 0 = do - say "receiver: done receiving" + traceWith tracer "receiver: done receiving" return () go _ n | n < 0 = do error "receiver: negative byte count" go buf n = do - say $ "receiver: " ++ show n ++ " bytes left" + traceWith tracer $ "receiver: " ++ show n ++ " bytes left" bytesReceived <- recv bearer buf n when (bytesReceived == 0) (throwIO $ TestError "receiver: premature hangup") let n' = n - bytesReceived - say $ "receiver: " ++ show bytesReceived ++ " bytes received, " ++ show n' ++ " remaining" + traceWith tracer $ "receiver: " ++ show bytesReceived ++ " bytes received, " ++ show n' ++ " remaining" go (plusPtr buf bytesReceived) n' go (castPtr dstBuf) size io (BS.packCStringLen (castPtr dstBuf, size)) - say $ "receiver: received " ++ show retval + traceWith tracer $ "receiver: received " ++ show retval written <- tryPutMVar retVar retval - say $ if written then "receiver: stored " ++ show retval else "receiver: already have result" - say "receiver: finishing connection" + traceWith tracer $ if written then "receiver: stored " ++ show retval else "receiver: already have result" + traceWith tracer "receiver: finishing connection" acceptLoop acceptNext accept snocket s >>= acceptLoop resBSEither <- bracket (open snocket (addrFamily snocket serverAddr)) (close snocket) $ \s -> do - say "receiver: starting" + traceWith tracer "receiver: starting" bind snocket s serverAddr listen snocket s - say "receiver: listening" + traceWith tracer "receiver: listening" race (sender `concurrently` receiver s) (takeMVar retVar <* takeMVar senderDone)