Permalink
Browse files

Split Network.Transport. THIS BREAKS THE CH BUILD.

Starting to prepare for release. Have not yet updated the CH build to reflect
the changes.
  • Loading branch information...
1 parent bfacdc4 commit 724dcf4932488ffbda51db5a102984b22af7d44c ghc704 committed Jul 6, 2012
@@ -0,0 +1,31 @@
+Copyright Well-Typed LLP, 2011-2012
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of the owner nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
@@ -0,0 +1,64 @@
+Name: network-transport-inmemory
+Version: 0.2.0
+Cabal-Version: >=1.8
+Build-Type: Simple
+License: BSD3
+License-file: LICENSE
+Copyright: Well-Typed LLP
+Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
+Maintainer: edsko@well-typed.com, dcoutts@well-typed.com
+Stability: experimental
+Homepage: http://github.com/haskell-distributed/distributed-process
+Bug-Reports: mailto:edsko@well-typed.com
+Synopsis: In-memory instantation of Network.Transport
+Description: In-memory instantation of Network.Transport
+Tested-With: GHC==7.0.4 GHC==7.2.2 GHC==7.4.1 GHC==7.4.2
+Category: Network
+
+Library
+ Build-Depends: base >= 4.3 && < 5,
+ network-transport >= 0.2 && < 0.3,
+ data-accessor >= 0.2 && < 0.3,
+ bytestring >= 0.9 && < 0.10,
+ containers >= 0.4 && < 0.5
+ Exposed-modules: Network.Transport.Chan
+ ghc-options: -Wall -fno-warn-unused-do-bind
+ HS-Source-Dirs: src
+
+Test-Suite TestMulticastInMemory
+ Type: exitcode-stdio-1.0
+ Build-Depends: base >= 4.3 && < 5,
+ network-transport >= 0.2 && < 0.3,
+ data-accessor >= 0.2 && < 0.3,
+ bytestring >= 0.9 && < 0.10,
+ containers >= 0.4 && < 0.5,
+ random >= 1.0 && < 1.1,
+ ansi-terminal >= 0.5 && < 0.6
+ Main-Is: TestMulticastInMemory.hs
+ ghc-options: -Wall -fno-warn-unused-do-bind
+ Extensions: ExistentialQuantification,
+ FlexibleInstances,
+ DeriveDataTypeable,
+ RankNTypes,
+ OverloadedStrings
+ HS-Source-Dirs: tests src
+
+Test-Suite TestInMemory
+ Type: exitcode-stdio-1.0
+ Build-Depends: base >= 4.3 && < 5,
+ network-transport >= 0.2 && < 0.3,
+ data-accessor >= 0.2 && < 0.3,
+ bytestring >= 0.9 && < 0.10,
+ containers >= 0.4 && < 0.5,
+ random >= 1.0 && < 1.1,
+ ansi-terminal >= 0.5 && < 0.6,
+ mtl >= 2.0 && < 2.2
+ Main-Is: TestInMemory.hs
+ ghc-options: -Wall -fno-warn-unused-do-bind
+ Extensions: ExistentialQuantification,
+ FlexibleInstances,
+ DeriveDataTypeable,
+ RankNTypes,
+ OverloadedStrings,
+ OverlappingInstances
+ HS-Source-Dirs: tests src
@@ -0,0 +1,31 @@
+Copyright Well-Typed LLP, 2011-2012
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of the owner nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
@@ -0,0 +1,49 @@
+Name: network-transport-tcp
+Version: 0.2.0
+Cabal-Version: >=1.8
+Build-Type: Simple
+License: BSD3
+License-file: LICENSE
+Copyright: Well-Typed LLP
+Author: Duncan Coutts, Nicolas Wu, Edsko de Vries
+Maintainer: edsko@well-typed.com, dcoutts@well-typed.com
+Stability: experimental
+Homepage: http://github.com/haskell-distributed/distributed-process
+Bug-Reports: mailto:edsko@well-typed.com
+Synopsis: TCP instantation of Network.Transport
+Description: TCP instantation of Network.Transport
+Tested-With: GHC==7.0.4 GHC==7.2.2 GHC==7.4.1 GHC==7.4.2
+Category: Network
+
+Library
+ Build-Depends: base >= 4.3 && < 5,
+ network-transport >= 0.2 && < 0.3,
+ data-accessor >= 0.2 && < 0.3,
+ containers >= 0.4 && < 0.5,
+ bytestring >= 0.9 && < 0.10,
+ network >= 2.3 && < 2.4
+ Exposed-modules: Network.Transport.TCP,
+ Network.Transport.TCP.Internal
+ ghc-options: -Wall -fno-warn-unused-do-bind
+ HS-Source-Dirs: src
+
+Test-Suite TestTCP
+ Type: exitcode-stdio-1.0
+ Main-Is: TestTCP.hs
+ Build-Depends: base >= 4.3 && < 5,
+ network-transport >= 0.2 && < 0.3,
+ data-accessor >= 0.2 && < 0.3,
+ containers >= 0.4 && < 0.5,
+ bytestring >= 0.9 && < 0.10,
+ network >= 2.3 && < 2.4,
+ random >= 1.0 && < 1.1,
+ ansi-terminal >= 0.5 && < 0.6,
+ mtl >= 2.0 && < 2.2
+ ghc-options: -Wall -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N
+ Extensions: ExistentialQuantification,
+ FlexibleInstances,
+ DeriveDataTypeable,
+ RankNTypes,
+ OverlappingInstances,
+ OverloadedStrings
+ HS-Source-Dirs: tests src
@@ -30,7 +30,7 @@ module Network.Transport.TCP ( -- * Main API
import Prelude hiding (catch, mapM_)
import Network.Transport
-import Network.Transport.Internal.TCP ( forkServer
+import Network.Transport.TCP.Internal ( forkServer
, recvWithLength
, recvInt32
, tryCloseSocket
@@ -364,8 +364,16 @@ data ValidRemoteEndPointState = ValidRemoteEndPointState
, _nextCtrlRequestId :: !ControlRequestId
}
+-- | Local identifier for an endpoint within this transport
type EndPointId = Int32
+
+-- | Control request ID
+--
+-- Control requests are asynchronous; the request ID makes it possible to match
+-- requests and replies
type ControlRequestId = Int32
+
+-- | Pair of local and a remote endpoint (for conciseness in signatures)
type EndPointPair = (LocalEndPoint, RemoteEndPoint)
-- | Control headers
@@ -380,7 +388,7 @@ data ControlHeader =
| CloseSocket
deriving (Enum, Bounded, Show)
--- Response sent by /B/ to /A/ when /A/ tries to connect
+-- | Response sent by /B/ to /A/ when /A/ tries to connect
data ConnectionRequestResponse =
-- | /B/ accepts the connection
ConnectionRequestAccepted
@@ -390,7 +398,7 @@ data ConnectionRequestResponse =
| ConnectionRequestCrossed
deriving (Enum, Bounded, Show)
--- Parameters for setting up the TCP transport
+-- | Parameters for setting up the TCP transport
data TCPParameters = TCPParameters {
-- | Backlog for 'listen'.
-- Defaults to SOMAXCONN.
@@ -403,7 +411,7 @@ data TCPParameters = TCPParameters {
, tcpReuseClientAddr :: Bool
}
--- Internal functionality we expose for unit testing
+-- | Internal functionality we expose for unit testing
data TransportInternals = TransportInternals
{ -- | The ID of the thread that listens for new incoming connections
transportThread :: ThreadId
@@ -1,5 +1,5 @@
-- | Utility functions for TCP sockets
-module Network.Transport.Internal.TCP ( forkServer
+module Network.Transport.TCP.Internal ( forkServer
, recvWithLength
, recvExact
, recvInt32
@@ -0,0 +1,108 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module TestAuxiliary ( -- Running tests
+ runTest
+ , runTests
+ -- Writing tests
+ , forkTry
+ , trySome
+ , randomThreadDelay
+ ) where
+
+import Prelude hiding (catch)
+import Control.Concurrent (myThreadId, forkIO, ThreadId, throwTo, threadDelay)
+import Control.Concurrent.Chan (Chan)
+import Control.Monad (liftM2, unless)
+import Control.Exception (SomeException, try, catch)
+import System.Timeout (timeout)
+import System.IO (stdout, hFlush)
+import System.Console.ANSI ( SGR(SetColor, Reset)
+ , Color(Red, Green)
+ , ConsoleLayer(Foreground)
+ , ColorIntensity(Vivid)
+ , setSGR
+ )
+import System.Random (randomIO)
+import Network.Transport
+import Traced (Traceable(..), traceShow)
+
+-- | Like fork, but throw exceptions in the child thread to the parent
+forkTry :: IO () -> IO ThreadId
+forkTry p = do
+ tid <- myThreadId
+ forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
+
+-- | Like try, but specialized to SomeException
+trySome :: IO a -> IO (Either SomeException a)
+trySome = try
+
+-- | Run the given test, catching timeouts and exceptions
+runTest :: String -> IO () -> IO Bool
+runTest description test = do
+ putStr $ "Running " ++ show description ++ ": "
+ hFlush stdout
+ done <- try . timeout 60000000 $ test -- 60 seconds
+ case done of
+ Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"
+ Right Nothing -> failed $ "(timeout)"
+ Right (Just ()) -> ok
+ where
+ failed :: String -> IO Bool
+ failed err = do
+ setSGR [SetColor Foreground Vivid Red]
+ putStr "failed "
+ setSGR [Reset]
+ putStrLn err
+ return False
+
+ ok :: IO Bool
+ ok = do
+ setSGR [SetColor Foreground Vivid Green]
+ putStrLn "ok"
+ setSGR [Reset]
+ return True
+
+-- | Run a bunch of tests and throw an exception if any fails
+runTests :: [(String, IO ())] -> IO ()
+runTests tests = do
+ success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests
+ unless success $ fail "Some tests failed"
+
+-- | Random thread delay between 0 and the specified max
+randomThreadDelay :: Int -> IO ()
+randomThreadDelay maxDelay = do
+ delay <- randomIO :: IO Int
+ threadDelay (delay `mod` maxDelay)
+
+--------------------------------------------------------------------------------
+-- traceShow instances --
+--------------------------------------------------------------------------------
+
+instance Traceable EndPoint where
+ trace = const Nothing
+
+instance Traceable Transport where
+ trace = const Nothing
+
+instance Traceable Connection where
+ trace = const Nothing
+
+instance Traceable Event where
+ trace = traceShow
+
+instance Show err => Traceable (TransportError err) where
+ trace = traceShow
+
+instance Traceable EndPointAddress where
+ trace = traceShow . endPointAddressToByteString
+
+instance Traceable SomeException where
+ trace = traceShow
+
+instance Traceable ThreadId where
+ trace = const Nothing
+
+instance Traceable (Chan a) where
+ trace = const Nothing
+
+instance Traceable Float where
+ trace = traceShow
@@ -36,7 +36,7 @@ import Network.Transport.Internal ( encodeInt32
, tryIO
, void
)
-import Network.Transport.Internal.TCP (recvInt32, forkServer, recvWithLength)
+import Network.Transport.TCP.Internal (recvInt32, forkServer, recvWithLength)
import qualified Network.Socket as N ( sClose
, ServiceName
, Socket
Oops, something went wrong.

0 comments on commit 724dcf4

Please sign in to comment.