diff --git a/network-transport-tcp.cabal b/network-transport-tcp.cabal --- a/network-transport-tcp.cabal +++ b/network-transport-tcp.cabal @@ -1,5 +1,5 @@ Name: network-transport-tcp -Version: 0.3.0 +Version: 0.3.1 Cabal-Version: >=1.8 Build-Type: Simple License: BSD3 @@ -20,6 +20,10 @@ Location: https://github.com/haskell-distributed/distributed-process SubDir: network-transport-tcp +Flag use-mock-network + Description: Use mock network implementation (for testing) + Default: False + Library Build-Depends: base >= 4.3 && < 5, network-transport >= 0.3 && < 0.4, @@ -32,12 +36,16 @@ Extensions: CPP ghc-options: -Wall -fno-warn-unused-do-bind HS-Source-Dirs: src + If flag(use-mock-network) + CPP-Options: -DUSE_MOCK_NETWORK + Exposed-modules: Network.Transport.TCP.Mock.Socket + Network.Transport.TCP.Mock.Socket.ByteString Test-Suite TestTCP Type: exitcode-stdio-1.0 Main-Is: TestTCP.hs Build-Depends: base >= 4.3 && < 5, - network-transport-tests >= 0.1 && < 0.2, + network-transport-tests >= 0.1.0.1 && < 0.2, network >= 2.3 && < 2.5, network-transport >= 0.3 && < 0.4, network-transport-tcp >= 0.3 && < 0.4 @@ -45,3 +53,32 @@ HS-Source-Dirs: tests Extensions: CPP, OverloadedStrings + If flag(use-mock-network) + CPP-Options: -DUSE_MOCK_NETWORK + +Test-Suite TestQC + Type: exitcode-stdio-1.0 + Main-Is: TestQC.hs + Build-Depends: base >= 4.3 && < 5, + test-framework, + test-framework-quickcheck2, + test-framework-hunit, + QuickCheck, + HUnit, + network-transport, + network-transport-tcp, + containers, + bytestring, + pretty, + data-accessor, + data-accessor-transformers, + mtl, + transformers, + lockfree-queue + ghc-options: -threaded -Wall -fno-warn-orphans + HS-Source-Dirs: tests + Extensions: TypeSynonymInstances + FlexibleInstances + OverlappingInstances + OverloadedStrings + DeriveDataTypeable diff --git a/src/Network/Transport/TCP.hs b/src/Network/Transport/TCP.hs --- a/src/Network/Transport/TCP.hs +++ b/src/Network/Transport/TCP.hs @@ -55,7 +55,12 @@ , timeoutMaybe , asyncWhenCancelled ) + +#ifdef USE_MOCK_NETWORK +import qualified Network.Transport.TCP.Mock.Socket as N +#else import qualified Network.Socket as N +#endif ( HostName , ServiceName , Socket @@ -71,7 +76,13 @@ , sOMAXCONN , AddrInfo ) + +#ifdef USE_MOCK_NETWORK +import Network.Transport.TCP.Mock.Socket.ByteString (sendMany) +#else import Network.Socket.ByteString (sendMany) +#endif + import Control.Concurrent (forkIO, ThreadId, killThread, myThreadId) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Control.Concurrent.MVar @@ -255,8 +266,12 @@ | LocalEndPointClosed data ValidLocalEndPointState = ValidLocalEndPointState - { _nextConnOutId :: !LightweightConnectionId - , _nextConnInId :: !HeavyweightConnectionId + { -- Next available ID for an outgoing lightweight self-connection + -- (see also remoteNextConnOutId) + _localNextConnOutId :: !LightweightConnectionId + -- Next available ID for an incoming heavyweight connection + , _nextConnInId :: !HeavyweightConnectionId + -- Currently active outgoing heavyweight connections , _localConnections :: !(Map EndPointAddress RemoteEndPoint) } @@ -376,6 +391,7 @@ { _remoteOutgoing :: !Int , _remoteIncoming :: !(Set LightweightConnectionId) , _remoteMaxIncoming :: !LightweightConnectionId + , _remoteNextConnOutId :: !LightweightConnectionId , remoteSocket :: !N.Socket , remoteSendLock :: !(MVar ()) } @@ -616,7 +632,8 @@ RemoteEndPointValid vst -> do alive <- readIORef connAlive if alive - then schedule theirEndPoint $ sendOn vst (encodeInt32 connId : prependLength payload) + then schedule theirEndPoint $ + sendOn vst (encodeInt32 connId : prependLength payload) else throwIO $ TransportError SendClosed "Connection closed" RemoteEndPointClosing _ _ -> do alive <- readIORef connAlive @@ -738,11 +755,12 @@ else do sendLock <- newMVar () let vst = ValidRemoteEndPointState - { remoteSocket = sock - , remoteSendLock = sendLock - , _remoteOutgoing = 0 - , _remoteIncoming = Set.empty - , _remoteMaxIncoming = 0 + { remoteSocket = sock + , remoteSendLock = sendLock + , _remoteOutgoing = 0 + , _remoteIncoming = Set.empty + , _remoteMaxIncoming = 0 + , _remoteNextConnOutId = firstNonReservedLightweightConnectionId } sendMany sock [encodeInt32 ConnectionRequestAccepted] resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst) @@ -885,7 +903,6 @@ closeSocket :: N.Socket -> LightweightConnectionId -> IO Bool closeSocket sock lastReceivedId = do mAct <- modifyMVar theirState $ \st -> do - lastSentId <- getLastConnOutId ourEndPoint case st of RemoteEndPointInvalid _ -> relyViolation (ourEndPoint, theirEndPoint) @@ -907,7 +924,7 @@ -- then we sent a ConnectionCreated *AND* a ConnectionClosed -- message to the remote endpoint, *both of which* it did not yet -- receive before sending the CloseSocket request. - if vst' ^. remoteOutgoing > 0 || lastReceivedId < lastSentId + if vst' ^. remoteOutgoing > 0 || lastReceivedId < lastSentId vst then return (RemoteEndPointValid vst', Nothing) else do @@ -919,7 +936,7 @@ ] tryCloseSocket sock return (RemoteEndPointClosed, Just act) - RemoteEndPointClosing resolved vst -> + RemoteEndPointClosing resolved vst -> do -- Like above, we need to check if there is a ConnectionCreated -- message that we sent but that the remote endpoint has not yet -- received. However, since we are in 'closing' state, the only @@ -927,8 +944,8 @@ -- ConnectionClosed, and CloseSocket message, none of which have -- yet been received. We leave the endpoint in closing state in -- that case. - if lastReceivedId < lastSentId - then + if lastReceivedId < lastSentId vst + then do return (RemoteEndPointClosing resolved vst, Nothing) else do removeRemoteEndPoint (ourEndPoint, theirEndPoint) @@ -987,6 +1004,13 @@ connId :: LightweightConnectionId -> ConnectionId connId = createConnectionId (remoteId theirEndPoint) + -- The ID of the last connection _we_ created (or 0 for none) + lastSentId :: ValidRemoteEndPointState -> LightweightConnectionId + lastSentId vst = + if vst ^. remoteNextConnOutId == firstNonReservedLightweightConnectionId + then 0 + else (vst ^. remoteNextConnOutId) - 1 + -------------------------------------------------------------------------------- -- Uninterruptable auxiliary functions -- -- -- @@ -1019,12 +1043,17 @@ else do -- 'findRemoteEndPoint' will have increased 'remoteOutgoing' mapIOException connectFailed $ do - act <- withMVar (remoteState theirEndPoint) $ \st -> case st of + act <- modifyMVar (remoteState theirEndPoint) $ \st -> case st of RemoteEndPointValid vst -> do - connId <- getNextConnOutId ourEndPoint - schedule theirEndPoint $ do + let connId = vst ^. remoteNextConnOutId + act <- schedule theirEndPoint $ do sendOn vst [encodeInt32 CreatedNewConnection, encodeInt32 connId] return connId + return ( RemoteEndPointValid + $ remoteNextConnOutId ^= connId + 1 + $ vst + , act + ) -- Error cases RemoteEndPointInvalid err -> throwIO err @@ -1056,11 +1085,12 @@ Right (sock, ConnectionRequestAccepted) -> do sendLock <- newMVar () let vst = ValidRemoteEndPointState - { remoteSocket = sock - , remoteSendLock = sendLock - , _remoteOutgoing = 0 - , _remoteIncoming = Set.empty - , _remoteMaxIncoming = 0 + { remoteSocket = sock + , remoteSendLock = sendLock + , _remoteOutgoing = 0 + , _remoteIncoming = Set.empty + , _remoteMaxIncoming = 0 + , _remoteNextConnOutId = firstNonReservedLightweightConnectionId } resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst) return True @@ -1142,7 +1172,7 @@ -> IO Connection connectToSelf ourEndPoint = do connAlive <- newIORef True -- Protected by the local endpoint lock - lconnId <- mapIOException connectFailed $ getNextConnOutId ourEndPoint + lconnId <- mapIOException connectFailed $ getLocalNextConnOutId ourEndPoint let connId = createConnectionId heavyweightSelfConnectionId lconnId writeChan ourChan $ ConnectionOpened connId ReliableOrdered (localAddress ourEndPoint) @@ -1197,33 +1227,21 @@ _ -> relyViolation (ourEndPoint, theirEndPoint) "resolveInit" --- | Get the next outgoing connection ID +-- | Get the next outgoing self-connection ID -- -- Throws an IO exception when the endpoint is closed. -getNextConnOutId :: LocalEndPoint -> IO LightweightConnectionId -getNextConnOutId ourEndpoint = +getLocalNextConnOutId :: LocalEndPoint -> IO LightweightConnectionId +getLocalNextConnOutId ourEndpoint = modifyMVar (localState ourEndpoint) $ \st -> case st of LocalEndPointValid vst -> do - let connId = vst ^. nextConnOutId + let connId = vst ^. localNextConnOutId return ( LocalEndPointValid - . (nextConnOutId ^= connId + 1) + . (localNextConnOutId ^= connId + 1) $ vst , connId) LocalEndPointClosed -> throwIO $ userError "Local endpoint closed" --- | The last outgoing connection ID we created, or zero if we never created any -getLastConnOutId :: LocalEndPoint -> IO LightweightConnectionId -getLastConnOutId ourEndPoint = - withMVar (localState ourEndPoint) $ \st -> case st of - LocalEndPointValid vst -> - let nextId = vst ^. nextConnOutId in - if nextId == firstNonReservedLightweightConnectionId - then return 0 - else return (nextId - 1) - LocalEndPointClosed -> - throwIO $ userError "Local endpoint closed" - -- | Create a new local endpoint -- -- May throw a TransportError NewEndPointErrorCode exception if the transport @@ -1232,9 +1250,9 @@ createLocalEndPoint transport = do chan <- newChan state <- newMVar . LocalEndPointValid $ ValidLocalEndPointState - { _nextConnOutId = firstNonReservedLightweightConnectionId - , _nextConnInId = firstNonReservedHeavyweightConnectionId - , _localConnections = Map.empty + { _localNextConnOutId = firstNonReservedLightweightConnectionId + , _localConnections = Map.empty + , _nextConnInId = firstNonReservedHeavyweightConnectionId } modifyMVar (transportState transport) $ \st -> case st of TransportValid vst -> do @@ -1587,8 +1605,8 @@ nextEndPointId :: Accessor ValidTransportState EndPointId nextEndPointId = accessor _nextEndPointId (\eid st -> st { _nextEndPointId = eid }) -nextConnOutId :: Accessor ValidLocalEndPointState LightweightConnectionId -nextConnOutId = accessor _nextConnOutId (\cix st -> st { _nextConnOutId = cix }) +localNextConnOutId :: Accessor ValidLocalEndPointState LightweightConnectionId +localNextConnOutId = accessor _localNextConnOutId (\cix st -> st { _localNextConnOutId = cix }) localConnections :: Accessor ValidLocalEndPointState (Map EndPointAddress RemoteEndPoint) localConnections = accessor _localConnections (\es st -> st { _localConnections = es }) @@ -1604,6 +1622,9 @@ remoteMaxIncoming :: Accessor ValidRemoteEndPointState LightweightConnectionId remoteMaxIncoming = accessor _remoteMaxIncoming (\lcid st -> st { _remoteMaxIncoming = lcid }) + +remoteNextConnOutId :: Accessor ValidRemoteEndPointState LightweightConnectionId +remoteNextConnOutId = accessor _remoteNextConnOutId (\cix st -> st { _remoteNextConnOutId = cix }) localEndPointAt :: EndPointAddress -> Accessor ValidTransportState (Maybe LocalEndPoint) localEndPointAt addr = localEndPoints >>> DAC.mapMaybe addr diff --git a/src/Network/Transport/TCP/Internal.hs b/src/Network/Transport/TCP/Internal.hs --- a/src/Network/Transport/TCP/Internal.hs +++ b/src/Network/Transport/TCP/Internal.hs @@ -12,7 +12,12 @@ #endif import Network.Transport.Internal (decodeInt32, void, tryIO, forkIOWithUnmask) + +#ifdef USE_MOCK_NETWORK +import qualified Network.Transport.TCP.Mock.Socket as N +#else import qualified Network.Socket as N +#endif ( HostName , ServiceName , Socket @@ -30,7 +35,13 @@ , accept , sClose ) + +#ifdef USE_MOCK_NETWORK +import qualified Network.Transport.TCP.Mock.Socket.ByteString as NBS (recv) +#else import qualified Network.Socket.ByteString as NBS (recv) +#endif + import Control.Concurrent (ThreadId) import Control.Monad (forever, when) import Control.Exception (SomeException, catch, bracketOnError, throwIO, mask_) diff --git a/src/Network/Transport/TCP/Mock/Socket.hs b/src/Network/Transport/TCP/Mock/Socket.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transport/TCP/Mock/Socket.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE EmptyDataDecls #-} +module Network.Transport.TCP.Mock.Socket + ( -- * Types + HostName + , ServiceName + , Socket + , SocketType(..) + , SocketOption(..) + , AddrInfo(..) + , Family + , SockAddr + , ProtocolNumber + , ShutdownCmd(..) + -- * Functions + , getAddrInfo + , socket + , bindSocket + , listen + , setSocketOption + , accept + , sClose + , connect + , shutdown + -- * Constants + , defaultHints + , defaultProtocol + , sOMAXCONN + -- * Debugging API + , scheduleReadAction + -- * Internal API + , writeSocket + , readSocket + , Message(..) + ) where + +import Data.Word (Word8) +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Exception (throwIO) +import Control.Category ((>>>)) +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import System.IO.Unsafe (unsafePerformIO) +import Data.Accessor (Accessor, accessor, (^=), (^.), (^:)) +import qualified Data.Accessor.Container as DAC (mapMaybe) +import System.Timeout (timeout) + +-------------------------------------------------------------------------------- +-- Mock state -- +-------------------------------------------------------------------------------- + +data MockState = MockState { + _boundSockets :: !(Map SockAddr Socket) + , _nextSocketId :: !Int + , _validHostnames :: [HostName] + } + +initialMockState :: MockState +initialMockState = MockState { + _boundSockets = Map.empty + , _nextSocketId = 0 + , _validHostnames = ["localhost", "127.0.0.1"] + } + +mockState :: MVar MockState +{-# NOINLINE mockState #-} +mockState = unsafePerformIO $ newMVar initialMockState + +get :: Accessor MockState a -> IO a +get acc = timeoutThrow mvarThreshold $ withMVar mockState $ return . (^. acc) + +set :: Accessor MockState a -> a -> IO () +set acc val = timeoutThrow mvarThreshold $ modifyMVar_ mockState $ return . (acc ^= val) + +boundSockets :: Accessor MockState (Map SockAddr Socket) +boundSockets = accessor _boundSockets (\bs st -> st { _boundSockets = bs }) + +boundSocketAt :: SockAddr -> Accessor MockState (Maybe Socket) +boundSocketAt addr = boundSockets >>> DAC.mapMaybe addr + +nextSocketId :: Accessor MockState Int +nextSocketId = accessor _nextSocketId (\sid st -> st { _nextSocketId = sid }) + +validHostnames :: Accessor MockState [HostName] +validHostnames = accessor _validHostnames (\ns st -> st { _validHostnames = ns }) + +-------------------------------------------------------------------------------- +-- The public API (mirroring Network.Socket) -- +-------------------------------------------------------------------------------- + +type HostName = String +type ServiceName = String +type PortNumber = String +type HostAddress = String + +data SocketType = Stream +data SocketOption = ReuseAddr +data ShutdownCmd = ShutdownSend + +data Family +data ProtocolNumber + +data Socket = Socket { + socketState :: MVar SocketState + , socketDescription :: String + } + +data SocketState = + Uninit + | BoundSocket { + socketBacklog :: Chan (Socket, SockAddr, MVar Socket) + } + | Connected { + socketBuff :: Chan Message + , _socketPeer :: Maybe Socket + , _scheduledReadActions :: [(Int, IO ())] + } + | Closed + +data Message = + Payload Word8 + | CloseSocket + +data AddrInfo = AddrInfo { + addrFamily :: Family + , addrAddress :: SockAddr + } + +data SockAddr = SockAddrInet PortNumber HostAddress + deriving (Eq, Ord, Show) + +instance Show AddrInfo where + show = show . addrAddress + +instance Show Socket where + show sock = "<>" + +socketPeer :: Accessor SocketState (Maybe Socket) +socketPeer = accessor _socketPeer (\peer st -> st { _socketPeer = peer }) + +scheduledReadActions :: Accessor SocketState [(Int, IO ())] +scheduledReadActions = accessor _scheduledReadActions (\acts st -> st { _scheduledReadActions = acts }) + +getAddrInfo :: Maybe AddrInfo -> Maybe HostName -> Maybe ServiceName -> IO [AddrInfo] +getAddrInfo _ (Just host) (Just port) = do + validHosts <- get validHostnames + if host `elem` validHosts + then return . return $ AddrInfo { + addrFamily = error "Family unused" + , addrAddress = SockAddrInet port host + } + else throwSocketError $ "getAddrInfo: invalid hostname '" ++ host ++ "'" +getAddrInfo _ _ _ = error "getAddrInfo: unsupported arguments" + +defaultHints :: AddrInfo +defaultHints = error "defaultHints not implemented" + +socket :: Family -> SocketType -> ProtocolNumber -> IO Socket +socket _ Stream _ = do + state <- newMVar Uninit + sid <- get nextSocketId + set nextSocketId (sid + 1) + return Socket { + socketState = state + , socketDescription = show sid + } + +bindSocket :: Socket -> SockAddr -> IO () +bindSocket sock addr = do + timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st -> case st of + Uninit -> do + backlog <- newChan + return BoundSocket { + socketBacklog = backlog + } + _ -> + throwSocketError "bind: socket already initialized" + set (boundSocketAt addr) (Just sock) + +listen :: Socket -> Int -> IO () +listen _ _ = return () + +defaultProtocol :: ProtocolNumber +defaultProtocol = error "defaultProtocol not implemented" + +setSocketOption :: Socket -> SocketOption -> Int -> IO () +setSocketOption _ ReuseAddr 1 = return () +setSocketOption _ _ _ = error "setSocketOption: unsupported arguments" + +accept :: Socket -> IO (Socket, SockAddr) +accept serverSock = do + backlog <- timeoutThrow mvarThreshold $ withMVar (socketState serverSock) $ \st -> case st of + BoundSocket {} -> + return (socketBacklog st) + _ -> + throwSocketError "accept: socket not bound" + (theirSocket, theirAddress, reply) <- readChan backlog + ourBuff <- newChan + ourState <- newMVar Connected { + socketBuff = ourBuff + , _socketPeer = Just theirSocket + , _scheduledReadActions = [] + } + let ourSocket = Socket { + socketState = ourState + , socketDescription = "" + } + timeoutThrow mvarThreshold $ putMVar reply ourSocket + return (ourSocket, theirAddress) + +sClose :: Socket -> IO () +sClose sock = do + -- Close the peer socket + writeSocket sock CloseSocket + + -- Close our socket + timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st -> + case st of + Connected {} -> do + -- In case there is a parallel read stuck on a readChan + writeChan (socketBuff st) CloseSocket + return Closed + _ -> + return Closed + +connect :: Socket -> SockAddr -> IO () +connect us serverAddr = do + mServer <- get (boundSocketAt serverAddr) + case mServer of + Just server -> do + serverBacklog <- timeoutThrow mvarThreshold $ withMVar (socketState server) $ \st -> case st of + BoundSocket {} -> + return (socketBacklog st) + _ -> + throwSocketError "connect: server socket not bound" + reply <- newEmptyMVar + writeChan serverBacklog (us, SockAddrInet "" "", reply) + them <- timeoutThrow mvarThreshold $ readMVar reply + timeoutThrow mvarThreshold $ modifyMVar_ (socketState us) $ \st -> case st of + Uninit -> do + buff <- newChan + return Connected { + socketBuff = buff + , _socketPeer = Just them + , _scheduledReadActions = [] + } + _ -> + throwSocketError "connect: already connected" + Nothing -> throwSocketError "connect: unknown address" + +sOMAXCONN :: Int +sOMAXCONN = error "sOMAXCONN not implemented" + +shutdown :: Socket -> ShutdownCmd -> IO () +shutdown sock ShutdownSend = do + writeSocket sock CloseSocket + timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st -> case st of + Connected {} -> + return (socketPeer ^= Nothing $ st) + _ -> + return st + +-------------------------------------------------------------------------------- +-- Functions with no direct public counterpart -- +-------------------------------------------------------------------------------- + +peerBuffer :: Socket -> IO (Either String (Chan Message)) +peerBuffer sock = do + mPeer <- timeoutThrow mvarThreshold $ withMVar (socketState sock) $ \st -> case st of + Connected {} -> + return (st ^. socketPeer) + _ -> + return Nothing + case mPeer of + Just peer -> timeoutThrow mvarThreshold $ withMVar (socketState peer) $ \st -> case st of + Connected {} -> + return (Right (socketBuff st)) + _ -> + return (Left "Peer socket closed") + Nothing -> + return (Left "Socket closed") + +throwSocketError :: String -> IO a +throwSocketError = throwIO . userError + +writeSocket :: Socket -> Message -> IO () +writeSocket sock msg = do + theirBuff <- peerBuffer sock + case theirBuff of + Right buff -> writeChan buff msg + Left err -> case msg of Payload _ -> throwSocketError $ "writeSocket: " ++ err + CloseSocket -> return () + +readSocket :: Socket -> IO (Maybe Word8) +readSocket sock = do + mBuff <- timeoutThrow mvarThreshold $ modifyMVar (socketState sock) $ \st -> case st of + Connected {} -> do + let (later, now) = tick $ st ^. scheduledReadActions + return ( scheduledReadActions ^= later $ st + , Just (socketBuff st, now) + ) + _ -> + return (st, Nothing) + case mBuff of + Just (buff, actions) -> do + sequence actions + msg <- timeoutThrow readSocketThreshold $ readChan buff + case msg of + Payload w -> return (Just w) + CloseSocket -> timeoutThrow mvarThreshold $ modifyMVar (socketState sock) $ \st -> case st of + Connected {} -> + return (Closed, Nothing) + _ -> + throwSocketError "readSocket: socket in unexpected state" + Nothing -> + return Nothing + +-- | Given a list of scheduled actions, reduce all delays by 1, and return the +-- actions that should be executed now. +tick :: [(Int, IO ())] -> ([(Int, IO ())], [IO ()]) +tick = go [] [] + where + go later now [] = (reverse later, reverse now) + go later now ((n, action) : actions) + | n == 0 = go later (action : now) actions + | otherwise = go ((n - 1, action) : later) now actions + +-------------------------------------------------------------------------------- +-- Debugging API -- +-------------------------------------------------------------------------------- + +-- | Schedule an action to be executed after /n/ reads on this socket +-- +-- If /n/ is zero we execute the action immediately. +scheduleReadAction :: Socket -> Int -> IO () -> IO () +scheduleReadAction _ 0 action = action +scheduleReadAction sock n action = + modifyMVar_ (socketState sock) $ \st -> case st of + Connected {} -> + return (scheduledReadActions ^: ((n, action) :) $ st) + _ -> + throwSocketError "scheduleReadAction: socket not connected" + +-------------------------------------------------------------------------------- +-- Util -- +-------------------------------------------------------------------------------- + +mvarThreshold :: Int +mvarThreshold = 1000000 + +readSocketThreshold :: Int +readSocketThreshold = 10000000 + +timeoutThrow :: Int -> IO a -> IO a +timeoutThrow n p = do + ma <- timeout n p + case ma of + Just a -> return a + Nothing -> throwIO (userError "timeout") diff --git a/src/Network/Transport/TCP/Mock/Socket/ByteString.hs b/src/Network/Transport/TCP/Mock/Socket/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Network/Transport/TCP/Mock/Socket/ByteString.hs @@ -0,0 +1,27 @@ +module Network.Transport.TCP.Mock.Socket.ByteString + ( sendMany + , recv + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BSS (pack, foldl) +import Data.Word (Word8) +import Control.Applicative ((<$>)) +import Network.Transport.TCP.Mock.Socket + +sendMany :: Socket -> [ByteString] -> IO () +sendMany sock = mapM_ (bsMapM_ (writeSocket sock . Payload)) + where + bsMapM_ :: (Word8 -> IO ()) -> ByteString -> IO () + bsMapM_ p = BSS.foldl (\io w -> io >> p w) (return ()) + +recv :: Socket -> Int -> IO ByteString +recv sock = \n -> BSS.pack <$> go [] n + where + go :: [Word8] -> Int -> IO [Word8] + go acc 0 = return (reverse acc) + go acc n = do + mw <- readSocket sock + case mw of + Just w -> go (w : acc) (n - 1) + Nothing -> return (reverse acc) diff --git a/tests/TestQC.hs b/tests/TestQC.hs new file mode 100644 --- /dev/null +++ b/tests/TestQC.hs @@ -0,0 +1,628 @@ +module Main + ( main + -- Shush the compiler about unused definitions + , log + , logShow + , forAllShrink + , inits + ) where + +import Prelude hiding (log) +import Test.Framework (Test, TestName, defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.Framework.Providers.HUnit (testCase) +import Test.QuickCheck + ( Gen + , choose + , suchThatMaybe + , forAll + , forAllShrink + , Property + , Arbitrary(arbitrary) + ) +import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result) +import Test.HUnit (Assertion, assertFailure) +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Category ((>>>)) +import Control.Arrow (second) +import Control.Applicative ((<$>)) +import Control.Exception (Exception, throwIO, try) +import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread) +import Control.Monad (replicateM, forever, guard) +import Control.Monad.State.Lazy (StateT, execStateT) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Typeable (Typeable) +import Data.Maybe (isJust) +import Data.List (inits) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 (pack) +import Data.Accessor (Accessor, accessor, (^.)) +import Data.Accessor.Monad.Trans.State (get, modify) +import qualified Data.Accessor.Container as DAC (mapDefault) +import qualified Data.ByteString as BSS (concat) +import qualified Text.PrettyPrint as PP +import Data.Unique (Unique, newUnique, hashUnique) +import Data.Concurrent.Queue.MichaelScott (newQ, pushL, tryPopR) + +import Network.Transport +import Network.Transport.TCP + ( createTransportExposeInternals + , defaultTCPParameters + , TransportInternals + ) + +-------------------------------------------------------------------------------- +-- Script infrastructure -- +-------------------------------------------------------------------------------- + +type EndPointIx = Int +type SourceEndPointIx = Int +type TargetEndPointIx = Int +type ConnectionIx = Int + +-- | We randomly generate /scripts/ which are essentially a deep embedding of +-- the Transport API. These scripts are then executed and the results compared +-- against an abstract interpreter. +data ScriptCmd = + -- | Create a new endpoint + NewEndPoint + -- | @Connect i j@ creates a connection from endpoint @i@ to endpoint @j@, + -- where @i@ and @j@ are indices and refer to the @i@th and @j@th endpoint + -- created by NewEndPoint + | Connect SourceEndPointIx TargetEndPointIx + -- | @Close i@ closes the @i@ connection created using 'Connect'. Note that + -- closing a connection does not shift other indices; in other words, in + -- @[Connect 0 0, Close 0, Connect 0 0, Close 0]@ the second 'Close' + -- refers to the first (already closed) connection + | Close ConnectionIx + -- | @Send i bs@ sends payload @bs@ on the @i@ connection created + | Send ConnectionIx [ByteString] + -- | @BreakAfterReads n i j@ force-closes the socket between endpoints @i@ + -- and @j@ after @n@ reads by @i@ + -- + -- We should have @i /= j@ because the TCP transport does not use sockets + -- for connections from an endpoint to itself + | BreakAfterReads Int SourceEndPointIx TargetEndPointIx + deriving Show + +type Script = [ScriptCmd] + +-------------------------------------------------------------------------------- +-- Execute and verify scripts -- +-------------------------------------------------------------------------------- + +data Variable a = Value a | Variable Unique + deriving Eq + +instance Show a => Show (Variable a) where + show (Value x) = show x + show (Variable u) = "<<" ++ show (hashUnique u) ++ ">>" + +data ExpEvent = + ExpConnectionOpened (Variable ConnectionId) + | ExpConnectionClosed (Variable ConnectionId) + | ExpReceived (Variable ConnectionId) [ByteString] + deriving Show + +type TargetAddress = EndPointAddress + +data RunState = RunState { + _endPoints :: [EndPoint] + , _connections :: [(TargetAddress, Connection, Variable ConnectionId)] + , _expectedEvents :: Map EndPointAddress [ExpEvent] + , _forwardingThreads :: [ThreadId] + } + +initialRunState :: RunState +initialRunState = RunState { + _endPoints = [] + , _connections = [] + , _expectedEvents = Map.empty + , _forwardingThreads = [] + } + +verify :: (Transport, TransportInternals) -> Script -> IO (Either String ()) +verify (transport, _transportInternals) script = do + allEvents <- newQ + + let runScript :: Script -> StateT RunState IO () + runScript = mapM_ runCmd + + runCmd :: ScriptCmd -> StateT RunState IO () + runCmd NewEndPoint = do + mEndPoint <- liftIO $ newEndPoint transport + case mEndPoint of + Right endPoint -> do + modify endPoints (snoc endPoint) + tid <- liftIO $ forkIO (forward endPoint) + modify forwardingThreads (tid :) + Left err -> + liftIO $ throwIO err + runCmd (Connect i j) = do + endPointA <- get (endPointAtIx i) + endPointB <- address <$> get (endPointAtIx j) + mConn <- liftIO $ connect endPointA endPointB ReliableOrdered defaultConnectHints + case mConn of + Right conn -> do + connId <- Variable <$> liftIO newUnique + modify connections (snoc (endPointB, conn, connId)) + modify (expectedEventsAt endPointB) (snoc (ExpConnectionOpened connId)) + Left err -> + liftIO $ throwIO err + runCmd (Close i) = do + (target, conn, connId) <- get (connectionAt i) + liftIO $ close conn + modify (expectedEventsAt target) (snoc (ExpConnectionClosed connId)) + runCmd (Send i payload) = do + (target, conn, connId) <- get (connectionAt i) + mResult <- liftIO $ send conn payload + case mResult of + Right () -> return () + Left err -> liftIO $ throwIO err + modify (expectedEventsAt target) (snoc (ExpReceived connId payload)) + runCmd (BreakAfterReads _n _i _j) = + expectedFailure "BreakAfterReads not implemented" + + forward :: EndPoint -> IO () + forward endPoint = forever $ do + ev <- receive endPoint + pushL allEvents (address endPoint, ev) + + collectEvents :: RunState -> IO (Map EndPointAddress [Event]) + collectEvents st = do + threadDelay 10000 + mapM_ killThread (st ^. forwardingThreads) + evs <- go [] + return (groupByKey evs) + where + go acc = do + mEv <- tryPopR allEvents + case mEv of + Just ev -> go (ev : acc) + Nothing -> return acc + + st <- execStateT (runScript script) initialRunState + actualEvents <- collectEvents st + + let eventsMatch = and . map (uncurry match) $ + zip (Map.elems (st ^. expectedEvents)) + (Map.elems actualEvents) + + return $ if eventsMatch + then Right () + else Left ("Could not match " ++ show (st ^. expectedEvents) + ++ " and " ++ show actualEvents) + +-------------------------------------------------------------------------------- +-- Match expected and actual events -- +-------------------------------------------------------------------------------- + +-- | Match a list of expected events to a list of actual events, taking into +-- account that events may be reordered +match :: [ExpEvent] -> [Event] -> Bool +match expected actual = or (map (isJust . flip unify actual) (reorder expected)) + +-- | Match a list of expected events to a list of actual events, without doing +-- reordering +unify :: [ExpEvent] -> [Event] -> Maybe () +unify [] [] = return () +unify (ExpConnectionOpened connId : expected) (ConnectionOpened connId' _ _ : actual) = do + subst <- unifyConnectionId connId connId' + unify (apply subst expected) actual +unify (ExpConnectionClosed connId : expected) (ConnectionClosed connId' : actual) = do + subst <- unifyConnectionId connId connId' + unify (apply subst expected) actual +unify (ExpReceived connId payload : expected) (Received connId' payload' : actual) = do + guard (BSS.concat payload == BSS.concat payload') + subst <- unifyConnectionId connId connId' + unify (apply subst expected) actual +unify _ _ = fail "Cannot unify" + +type Substitution a = Map Unique a + +-- | Match two connection IDs +unifyConnectionId :: Variable ConnectionId -> ConnectionId -> Maybe (Substitution ConnectionId) +unifyConnectionId (Variable x) connId = Just $ Map.singleton x connId +unifyConnectionId (Value connId') connId | connId == connId' = Just Map.empty + | otherwise = Nothing + +-- | Apply a substitution +apply :: Substitution ConnectionId -> [ExpEvent] -> [ExpEvent] +apply subst = map applyEvent + where + applyEvent :: ExpEvent -> ExpEvent + applyEvent (ExpConnectionOpened connId) = ExpConnectionOpened (applyVar connId) + applyEvent (ExpConnectionClosed connId) = ExpConnectionClosed (applyVar connId) + applyEvent (ExpReceived connId payload) = ExpReceived (applyVar connId) payload + + applyVar :: Variable ConnectionId -> Variable ConnectionId + applyVar (Value connId) = Value connId + applyVar (Variable x) = case Map.lookup x subst of + Just connId -> Value connId + Nothing -> Variable x + +-- | Return all possible reorderings of a list of expected events +-- +-- Events from different connections can be reordered, but events from the +-- same connection cannot. +reorder :: [ExpEvent] -> [[ExpEvent]] +reorder = go + where + go :: [ExpEvent] -> [[ExpEvent]] + go [] = [[]] + go (ev : evs) = concat [insert ev evs' | evs' <- reorder evs] + + insert :: ExpEvent -> [ExpEvent] -> [[ExpEvent]] + insert ev [] = [[ev]] + insert ev (ev' : evs') + | connectionId ev == connectionId ev' = [ev : ev' : evs'] + | otherwise = (ev : ev' : evs') : [ev' : evs'' | evs'' <- insert ev evs'] + + connectionId :: ExpEvent -> Variable ConnectionId + connectionId (ExpConnectionOpened connId) = connId + connectionId (ExpConnectionClosed connId) = connId + connectionId (ExpReceived connId _) = connId + +-------------------------------------------------------------------------------- +-- Script generators -- +-------------------------------------------------------------------------------- + +script_NewEndPoint :: Int -> Gen Script +script_NewEndPoint numEndPoints = return (replicate numEndPoints NewEndPoint) + +script_Connect :: Int -> Gen Script +script_Connect numEndPoints = do + script <- go + return (replicate numEndPoints NewEndPoint ++ script) + where + go :: Gen Script + go = do + next <- choose (0, 1) :: Gen Int + case next of + 0 -> do + fr <- choose (0, numEndPoints - 1) + to <- choose (0, numEndPoints - 1) + cmds <- go + return (Connect fr to : cmds) + _ -> + return [] + +script_ConnectClose :: Int -> Gen Script +script_ConnectClose numEndPoints = do + script <- go Map.empty + return (replicate numEndPoints NewEndPoint ++ script) + where + go :: Map Int Bool -> Gen Script + go conns = do + next <- choose (0, 2) :: Gen Int + case next of + 0 -> do + fr <- choose (0, numEndPoints - 1) + to <- choose (0, numEndPoints - 1) + cmds <- go (Map.insert (Map.size conns) True conns) + return (Connect fr to : cmds) + 1 -> do + mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns + case mConn of + Nothing -> go conns + Just conn -> do + cmds <- go (Map.insert conn False conns) + return (Close conn : cmds) + _ -> + return [] + + isOpen :: Map Int Bool -> Int -> Bool + isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx + +script_ConnectSendClose :: Int -> Gen Script +script_ConnectSendClose numEndPoints = do + script <- go Map.empty + return (replicate numEndPoints NewEndPoint ++ script) + where + go :: Map Int Bool -> Gen Script + go conns = do + next <- choose (0, 3) :: Gen Int + case next of + 0 -> do + fr <- choose (0, numEndPoints - 1) + to <- choose (0, numEndPoints - 1) + cmds <- go (Map.insert (Map.size conns) True conns) + return (Connect fr to : cmds) + 1 -> do + mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns + case mConn of + Nothing -> go conns + Just conn -> do + numSegments <- choose (0, 2) + payload <- replicateM numSegments arbitrary + cmds <- go conns + return (Send conn payload : cmds) + 2 -> do + mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns + case mConn of + Nothing -> go conns + Just conn -> do + cmds <- go (Map.insert conn False conns) + return (Close conn : cmds) + _ -> + return [] + + isOpen :: Map Int Bool -> Int -> Bool + isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx + +withErrors :: Int -> Gen Script -> Gen Script +withErrors numErrors gen = gen >>= insertError numErrors + where + insertError :: Int -> Script -> Gen Script + insertError _ [] = return [] + insertError n (Connect i j : cmds) | i /= j = do + insert <- arbitrary + if insert && n > 0 + then do + numReads <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100) + swap <- arbitrary + if swap + then return $ Connect i j : BreakAfterReads numReads j i : cmds + else return $ Connect i j : BreakAfterReads numReads i j : cmds + else do + cmds' <- insertError (n - 1) cmds + return $ Connect i j : cmds' + insertError n (cmd : cmds) = do + cmds' <- insertError n cmds + return $ cmd : cmds' + +-------------------------------------------------------------------------------- +-- Individual scripts to test specific bugs -- +-------------------------------------------------------------------------------- + +-- | Bug #1 +-- +-- When process A wants to close the heavyweight connection to process B it +-- sends a CloseSocket request together with the ID of the last connection from +-- B. When B receives the CloseSocket request it can compare this ID to the last +-- connection it created; if they don't match, B knows that there are some +-- messages still on the way from B to A (in particular, a CreatedConnection +-- message) which will cancel the CloseSocket request from A. Hence, it will +-- know to ignore the CloseSocket request from A. +-- +-- The bug was that we recorded the last _created_ outgoing connection on the +-- local endpoint, but the last _received_ incoming connection on the state of +-- the heavyweight connection. So, in the script below, the following happened: +-- +-- A connects to B, records "last connection ID is 1024" +-- A closes the lightweight connection, sends [CloseConnection 1024] +-- A closes the heivyweight connection, sends [CloseSocket 0] +-- +-- (the 0 here indicates that it had not yet received any connections from B) +-- +-- B receives the [CloseSocket 0], compares it to the recorded outgoing ID (0), +-- confirms that they are equal, and confirms the CloseSocket request. +-- +-- B connects to A, records "last connection ID is 1024" +-- B closes the lightweight connection, sends [CloseConnection 1024] +-- B closes the heavyweight connection, sends [CloseSocket 0] +-- +-- (the 0 here indicates that it has not yet received any connections from A, +-- ON THIS HEAVYWEIGHT connection) +-- +-- A receives the [CloseSocket 0] request, compares it to the last recorded +-- outgoing ID (1024), sees that they are not equal, and concludes that this +-- must mean that there is still a CreatedConnection message on the way from A +-- to B. +-- +-- This of course is not the case, so B will wait forever for A to confirm +-- the CloseSocket request, and deadlock arises. (This deadlock doesn't become +-- obvious though until the next attempt from B to connect to A.) +-- +-- The solution is of course that both the recorded outgoing and recorded +-- incoming connection ID must be per heavyweight connection. +script_Bug1 :: Script +script_Bug1 = [ + NewEndPoint + , NewEndPoint + , Connect 0 1 + , Close 0 + , Connect 1 0 + , Close 1 + , Connect 1 0 + ] + +-- | Simulate broken network connection during send +script_BreakSend :: Script +script_BreakSend = [ + NewEndPoint + , NewEndPoint + , Connect 0 1 + , BreakAfterReads 1 1 0 + , Send 0 ["ping"] + ] + +-- | Simulate broken network connection during connect +script_BreakConnect :: Script +script_BreakConnect = [ + NewEndPoint + , NewEndPoint + , Connect 0 1 + , BreakAfterReads 1 1 0 + , Connect 0 1 + ] + +-------------------------------------------------------------------------------- +-- Main application driver -- +-------------------------------------------------------------------------------- + +basicTests :: (Transport, TransportInternals) -> Int -> (Gen Script -> Gen Script) -> [Test] +basicTests transport numEndPoints trans = [ + testGen "NewEndPoint" transport (trans (script_NewEndPoint numEndPoints)) + , testGen "Connect" transport (trans (script_Connect numEndPoints)) + , testGen "ConnectClose" transport (trans (script_ConnectClose numEndPoints)) + , testGen "ConnectSendClose" transport (trans (script_ConnectSendClose numEndPoints)) + ] + +tests :: (Transport, TransportInternals) -> [Test] +tests transport = [ + testGroup "Specific scripts" [ + testOne "Bug1" transport script_Bug1 + , testOne "BreakSend" transport script_BreakSend + , testOne "BreakConnect" transport script_BreakConnect + ] + , testGroup "One endpoint, with delays" (basicTests transport 1 id) + , testGroup "Two endpoints, with delays" (basicTests transport 2 id) + , testGroup "Three endpoints, with delays" (basicTests transport 3 id) + , testGroup "Four endpoints, with delay, single error" (basicTests transport 4 (withErrors 1)) + ] + where + +testOne :: TestName -> (Transport, TransportInternals) -> Script -> Test +testOne label transport script = testCase label (testScript transport script) + +testGen :: TestName -> (Transport, TransportInternals) -> Gen Script -> Test +testGen label transport script = testProperty label (testScriptGen transport script) + +main :: IO () +main = do + Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters + defaultMain (tests transport) + +-------------------------------------------------------------------------------- +-- Test infrastructure -- +-------------------------------------------------------------------------------- + +testScriptGen :: (Transport, TransportInternals) -> Gen Script -> Property +testScriptGen transport scriptGen = + forAll scriptGen $ \script -> + morallyDubiousIOProperty $ do + logShow script + mErr <- try $ verify transport script + return $ case mErr of + Left (ExpectedFailure str) -> + result { ok = Nothing + , reason = str + } + Right (Left err) -> + result { ok = Just False + , reason = '\n' : err ++ "\n" + } + Right (Right ()) -> + result { ok = Just True } + +testScript :: (Transport, TransportInternals) -> Script -> Assertion +testScript transport script = do + logShow script + mErr <- try $ verify transport script + case mErr of + Left (ExpectedFailure _str) -> + return () + Right (Left err) -> + assertFailure $ "Failed with script " ++ show script ++ ": " ++ err ++ "\n" + Right (Right ()) -> + return () + +-------------------------------------------------------------------------------- +-- Accessors -- +-------------------------------------------------------------------------------- + +endPoints :: Accessor RunState [EndPoint] +endPoints = accessor _endPoints (\es st -> st { _endPoints = es }) + +endPointAtIx :: EndPointIx -> Accessor RunState EndPoint +endPointAtIx i = endPoints >>> listAccessor i + +connections :: Accessor RunState [(TargetAddress, Connection, Variable ConnectionId)] +connections = accessor _connections (\cs st -> st { _connections = cs }) + +connectionAt :: ConnectionIx -> Accessor RunState (TargetAddress, Connection, Variable ConnectionId) +connectionAt i = connections >>> listAccessor i + +expectedEvents :: Accessor RunState (Map EndPointAddress [ExpEvent]) +expectedEvents = accessor _expectedEvents (\es st -> st { _expectedEvents = es }) + +expectedEventsAt :: EndPointAddress -> Accessor RunState [ExpEvent] +expectedEventsAt addr = expectedEvents >>> DAC.mapDefault [] addr + +forwardingThreads :: Accessor RunState [ThreadId] +forwardingThreads = accessor _forwardingThreads (\ts st -> st { _forwardingThreads = ts }) + +-------------------------------------------------------------------------------- +-- Pretty-printing -- +-------------------------------------------------------------------------------- + +verticalList :: Show a => [a] -> PP.Doc +verticalList = PP.brackets . PP.vcat . map (PP.text . show) + +instance Show Script where + show = ("\n" ++) . show . verticalList + +instance Show [Event] where + show = ("\n" ++) . show . verticalList + +instance Show [ExpEvent] where + show = ("\n" ++) . show . verticalList + +-------------------------------------------------------------------------------- +-- Draw random values from probability distributions -- +-------------------------------------------------------------------------------- + +data NormalD = NormalD { mean :: Double , stdDev :: Double } + +class Distribution d where + probabilityOf :: d -> Double -> Double + +instance Distribution NormalD where + probabilityOf d x = a * exp (-0.5 * b * b) + where + a = 1 / (stdDev d * sqrt (2 * pi)) + b = (x - mean d) / stdDev d + +-- | Choose from a distribution +chooseFrom :: Distribution d => d -> (Double, Double) -> Gen Double +chooseFrom d (lo, hi) = findCandidate + where + findCandidate :: Gen Double + findCandidate = do + candidate <- choose (lo, hi) + uniformSample <- choose (0, 1) + if uniformSample < probabilityOf d candidate + then return candidate + else findCandidate + +chooseFrom' :: Distribution d => d -> (Int, Int) -> Gen Int +chooseFrom' d (lo, hi) = + round <$> chooseFrom d (fromIntegral lo, fromIntegral hi) + +-------------------------------------------------------------------------------- +-- Auxiliary +-------------------------------------------------------------------------------- + +log :: String -> IO () +log = appendFile "log" . (++ "\n") + +logShow :: Show a => a -> IO () +logShow = log . show + +instance Arbitrary ByteString where + arbitrary = do + len <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100) + xs <- replicateM len arbitrary + return (pack xs) + +listAccessor :: Int -> Accessor [a] a +listAccessor i = accessor (!! i) (error "listAccessor.set not defined") + +snoc :: a -> [a] -> [a] +snoc x xs = xs ++ [x] + +groupByKey :: Ord a => [(a, b)] -> Map a [b] +groupByKey = Map.fromListWith (++) . map (second return) + +-------------------------------------------------------------------------------- +-- Expected failures (can't find explicit support for this in test-framework) -- +-------------------------------------------------------------------------------- + +data ExpectedFailure = ExpectedFailure String deriving (Typeable, Show) + +instance Exception ExpectedFailure + +expectedFailure :: MonadIO m => String -> m () +expectedFailure = liftIO . throwIO . ExpectedFailure diff --git a/tests/TestTCP.hs b/tests/TestTCP.hs --- a/tests/TestTCP.hs +++ b/tests/TestTCP.hs @@ -45,14 +45,26 @@ , void ) import Network.Transport.TCP.Internal (recvInt32, forkServer, recvWithLength) -import qualified Network.Socket as N ( sClose - , ServiceName - , Socket - , AddrInfo - , shutdown - , ShutdownCmd(ShutdownSend) - ) -import Network.Socket.ByteString (sendMany) + +#ifdef USE_MOCK_NETWORK +import qualified Network.Transport.TCP.Mock.Socket as N +#else +import qualified Network.Socket as N +#endif + ( sClose + , ServiceName + , Socket + , AddrInfo + , shutdown + , ShutdownCmd(ShutdownSend) + ) + +#ifdef USE_MOCK_NETWORK +import Network.Transport.TCP.Mock.Socket.ByteString (sendMany) +#else +import Network.Socket.ByteString (sendMany) +#endif + import Data.String (fromString) import GHC.IO.Exception (ioe_errno) import Foreign.C.Error (Errno(..), eADDRNOTAVAIL)