network-transport-tcp 0.3.0 → 0.3.1
raw patch · 7 files changed
+1149/−54 lines, 7 filesdep +HUnitdep +QuickCheckdep +data-accessor-transformersdep ~bytestringdep ~containersdep ~data-accessorPVP ok
version bump matches the API change (PVP)
Dependencies added: HUnit, QuickCheck, data-accessor-transformers, lockfree-queue, mtl, pretty, test-framework, test-framework-hunit, test-framework-quickcheck2, transformers
Dependency ranges changed: bytestring, containers, data-accessor, network-transport, network-transport-tcp, network-transport-tests
API changes (from Hackage documentation)
Files
- network-transport-tcp.cabal +39/−2
- src/Network/Transport/TCP.hs +65/−44
- src/Network/Transport/TCP/Internal.hs +11/−0
- src/Network/Transport/TCP/Mock/Socket.hs +359/−0
- src/Network/Transport/TCP/Mock/Socket/ByteString.hs +27/−0
- tests/TestQC.hs +628/−0
- tests/TestTCP.hs +20/−8
network-transport-tcp.cabal view
@@ -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
src/Network/Transport/TCP.hs view
@@ -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
src/Network/Transport/TCP/Internal.hs view
@@ -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_)
+ src/Network/Transport/TCP/Mock/Socket.hs view
@@ -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 = "<<socket " ++ socketDescription 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")
+ src/Network/Transport/TCP/Mock/Socket/ByteString.hs view
@@ -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)
+ tests/TestQC.hs view
@@ -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
tests/TestTCP.hs view
@@ -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)