courier 0.1.0.14 → 0.1.0.15

raw patch · 12 files changed

+513/−341 lines, 12 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• changes.md +14/−2
• courier.cabal +5/−3
• src/Network/RPC.hs +68/−27
• src/Network/Transport/Sockets.hs +88/−40
• src/Network/Transport/TCP.hs +110/−135
• src/Network/Transport/UDP.hs +23/−58
• tests/TestMemory.hs +39/−31
• tests/TestRPC.hs +30/−0
• tests/TestTCP.hs +21/−17
• tests/TestTransports.hs +45/−15
• tests/TestUDP.hs +17/−13
• tests/TestUtils.hs +53/−0

@@ -1,3 +1,15 @@+0.1.0.15++    * Initial implementation of IPv6 transports (TCP and UDP)+    * Small cleanup for better thread safety+    * Refactored socket transports for more code sharing+    * Added anyCall+    * Exported RequestId and mkRequestId+    * Incorporated changes from carletes for running tests in parallel by allowing+    each test to bind to their own set of ports; on machines with multiple CPUs the speedup+    has a noticeable impact on producitivity+    * Added methodSelector for applications that may want to customize RPC handling+ 0.1.0.14      * Included test source into tarball@@ -28,12 +40,12 @@     in pure methods.  By leaving the interface to use Message values, its not only     consistent with the rest of Endpoint behavior, but it clarifies the responsibility     of the calling application to manage their Message payloads on their own.-    +     * Improvements to RPC. Previously, it was not possible to differentiate correctly     between requests and responses in the same mailbox: the only check was that     deserialization succeeded, which wasn't a sufficient test, and it would be possible     to deserialize a response as a request, etc.  This lead to spurious errors.-    +     * Added functions for detecting presence of messages in an an endpoint's mailbox     (while still leaving them unconsumed): mostly added this for applications that     need to react to the presence of a particular message, but not actual consume

@@ -1,5 +1,5 @@ name:                courier-version:             0.1.0.14+version:             0.1.0.15 synopsis:           A message-passing library for simplifying network applications description:         Inspired by Erlang's simple message-passing facilities, courier provides roughly similar                       capabilities. Applications simply create one or more endpoints, @@ -22,7 +22,7 @@                      applications may approximate the style of an Erlang application, and enjoy better                       composability of message reception with multiple independent dispatch routines or                       message pumps.-                     + extra-source-files:  changes.md                      examples/HelloWorld.hs                      tests/Tests.hs@@ -32,6 +32,7 @@                      tests/TestTCP.hs                      tests/TestTransports.hs                      tests/TestUDP.hs+                     tests/TestUtils.hs  homepage:          http://github.com/hargettp/courier license:             MIT@@ -62,8 +63,8 @@    ghc-options: -Wall -fno-state-hack   other-modules:-                  Network.Transport.Sockets                   Network.Transport.Internal+                  Network.Transport.Sockets   build-depends:       base >=4.6 && <5,                        async,                        bytestring,@@ -94,6 +95,7 @@         containers,         directory,         hslogger,+        network,         stm,         -- this project's modules         courier

@@ -42,7 +42,9 @@     callWithTimeout,     gcall,     gcallWithTimeout,+    anyCall, +    methodSelector,     hear,     hearTimeout,     Reply,@@ -52,6 +54,8 @@     hangup,      Request(..),+    RequestId,+    mkRequestId,     Response(..)  ) where@@ -85,15 +89,28 @@  instance Serialize RPCMessageType -type RequestId = (Word32, Word32, Word32, Word32)+{-+A unique identifier for a 'Request'+-}+newtype RequestId = RequestId (Word32, Word32, Word32, Word32) deriving (Generic,Eq,Show) +instance Serialize (RequestId)++{-|+Create a new identifier for 'Request's+-}+mkRequestId :: IO RequestId+mkRequestId = do+    ruuid <- nextRandom+    return $ RequestId $ toWords ruuid+ data Request = Request {     requestId :: RequestId,     requestCaller :: Name,     requestMethod :: Method,     requestArgs :: Message-}-+} deriving (Eq,Show)+  instance Serialize Request where     put req = do         put Req@@ -113,7 +130,7 @@     responseId :: RequestId,     responseFrom :: Name,     responseValue :: Message-}+} deriving (Eq,Show)  instance Serialize Response where     put rsp = do@@ -145,18 +162,18 @@ {-| Call a method with the provided arguments on the recipient with the given name. -the caller will wait until a matching response is received.+The caller will wait until a matching response is received. -} call :: CallSite -> Name -> Method -> Message -> IO Message call (CallSite endpoint from) name method args = do-    ruuid <- nextRandom-    let req = Request {requestId = toWords ruuid,requestCaller = from,requestMethod = method, requestArgs = args}+    rid <- mkRequestId+    let req = Request {requestId = rid,requestCaller = from,requestMethod = method, requestArgs = args}     sendMessage_ endpoint name $ encode req     selectMessage endpoint $ \msg -> do         case decode msg of             Left _ -> Nothing-            Right (Response rid _ value) -> do-                if rid == (requestId req)+            Right (Response respId _ value) -> do+                if respId == rid                     then Just value                     else Nothing @@ -184,8 +201,8 @@ -} gcall :: CallSite -> [Name] -> Method -> Message -> IO (M.Map Name Message) gcall (CallSite endpoint from) names method args = do-    ruuid <- nextRandom-    let req = Request {requestId = toWords ruuid,requestCaller = from,requestMethod = method, requestArgs = args}+    rid <- mkRequestId+    let req = Request {requestId = rid,requestCaller = from,requestMethod = method, requestArgs = args}     sendAll req     recvAll req M.empty     where@@ -219,8 +236,8 @@ -} gcallWithTimeout :: CallSite -> [Name] -> Method -> Int -> Message -> IO (M.Map Name (Maybe Message)) gcallWithTimeout (CallSite endpoint from) names method delay args = do-    ruuid <- nextRandom-    let req = Request {requestId = toWords ruuid,requestCaller = from,requestMethod = method, requestArgs = args}+    rid <- mkRequestId+    let req = Request {requestId = rid,requestCaller = from,requestMethod = method, requestArgs = args}     sendAll req     allResults <- atomically $ newTVar M.empty     responses <- race (recvAll req allResults) (threadDelay delay)@@ -258,11 +275,47 @@         complete partial = foldl (\final name -> M.insert name (M.lookup name partial) final) M.empty names  {-|+Invoke the same method on multiple 'Name's, and wait indefinitely until+the first response from any 'Name', returning the value and the 'Name'+which responded.+-}+anyCall :: CallSite -> [Name] -> Method -> Message -> IO (Message,Name)+anyCall (CallSite endpoint from) names method args = do+    rid <- mkRequestId+    let req = Request {requestId = rid,requestCaller = from,requestMethod = method, requestArgs = args}+    sendAll req+    recvAny req+    where+        sendAll req = do+            forM_ names $ \name -> sendMessage_ endpoint name $ encode req+        recvAny req = selectMessage endpoint $ \msg -> do+                case decode msg of+                    Left _ -> Nothing+                    Right (Response rid name value) -> do+                        if (rid == (requestId req)) && (elem name names)+                            then Just (value,name)+                            else Nothing++{-| A 'Reply' is a one-shot function for sending a response to an incoming request. -} type Reply b = b -> IO ()  {-|+A simple function that, given a 'Method', returns a filter suitable for+use with 'selectMessage'. The typical use case will involve partial+application: @methodSelector method@ passed as an argument to 'selectMessage'.+-}+methodSelector :: Method -> Message -> Maybe (Name,RequestId,Message)+methodSelector method msg = do+    case decode msg of+        Left _ -> Nothing+        Right (Request rid caller rmethod args) -> do+            if rmethod == method+                then Just (caller,rid,args)+                else Nothing++{-| Wait for a single incoming request to invoke the indicated 'Method' on the specified 'Endpoint'. Return both the method arguments and a 'Reply' function useful for sending the reply.  A good pattern for using 'hear' will pattern match the result to a tuple of@@ -275,13 +328,7 @@ -} hear :: Endpoint -> Name -> Method -> IO (Message,Reply Message) hear endpoint name method = do-    (caller,rid,args) <- selectMessage endpoint $ \msg -> do-                case decode msg of-                    Left _ -> Nothing-                    Right (Request rid caller rmethod args) -> do-                        if rmethod == method-                            then Just (caller,rid,args)-                            else Nothing+    (caller,rid,args) <- selectMessage endpoint $ methodSelector method     return (args, reply caller rid)     where         reply caller rid result = do@@ -295,13 +342,7 @@ -} hearTimeout :: Endpoint -> Name -> Method -> Int -> IO (Maybe (Message,Reply Message)) hearTimeout endpoint name method timeout = do-    req <- selectMessageTimeout endpoint timeout $ \msg -> do-                case decode msg of-                    Left _ -> Nothing-                    Right (Request rid caller rmethod args) -> do-                        if rmethod == method-                            then Just (caller,rid,args)-                            else Nothing+    req <- selectMessageTimeout endpoint timeout $ methodSelector method     case req of         Just (caller,rid,args) -> return $ Just (args, reply caller rid)         Nothing -> return Nothing

@@ -26,6 +26,10 @@     closeBindings,      SocketTransport(..),+    SocketConnectionFactory,+    SocketMessengerFactory,+    SocketBindingFactory,+    newSocketTransport,      Connection(..), @@ -34,6 +38,7 @@     Messenger(..),     newMessenger,     addMessenger,+    replaceMessenger,     deliver,     closeMessenger, @@ -72,7 +77,7 @@  import GHC.Generics -import Network.Socket hiding (recv,socket)+import Network.Socket hiding (recv,socket,bind,sendTo,shutdown) import qualified Network.Socket.ByteString as NSB  import System.Log.Logger@@ -83,6 +88,34 @@ _log :: String _log = "transport.sockets" +type SocketConnectionFactory = Address -> IO Connection+type SocketMessengerFactory = Bindings -> Resolver -> Connection -> Mailbox Message -> IO Messenger+type SocketBindingFactory = SocketTransport -> SocketBindings -> Mailbox Message -> Name -> IO (Either String Binding)++newSocketTransport :: Resolver -> Scheme -> SocketBindingFactory -> SocketConnectionFactory -> SocketMessengerFactory -> IO Transport+newSocketTransport resolver socketScheme binder connectionFactory messengerFactory = do+  messengers <- atomically $ newTVar M.empty+  bindings <- atomically $ newTVar M.empty+  sockets <- newSocketBindings+  inbound <- atomically $ newMailbox+  dispatch <- async $ dispatcher bindings inbound+  let transport = SocketTransport {+        socketMessengers = messengers,+        socketBindings = bindings,+        socketConnection = connectionFactory,+        socketMessenger = messengerFactory bindings resolver,+        socketInbound = inbound,+        socketDispatchers = S.fromList [dispatch],+        socketResolver = resolver+        }+  return Transport {+      scheme = socketScheme,+      handles = socketTransportHandles transport,+      bind = binder transport sockets,+      sendTo = socketSendTo transport,+      shutdown = socketTransportShutdown transport sockets+      }+ type Bindings = TVar (M.Map Name (Mailbox Message))  data SocketBinding = SocketBinding {@@ -91,6 +124,14 @@     socketListener :: TMVar (Async ()) } +socketTransportHandles :: SocketTransport -> Name -> IO Bool+socketTransportHandles transport name = do +  resolved <- resolve (socketResolver transport) name+  return $ isJust resolved+  where+    isJust (Just _) = True+    isJust _ = False+ type SocketBindings = TVar (M.Map Address SocketBinding)  newSocketBindings :: IO SocketBindings@@ -100,7 +141,7 @@ bindAddress bindings address factory = do     (count,binding) <- atomically $ do         bmap <- readTVar bindings-        bndg <- case M.lookup address bmap of+        binding <- case M.lookup address bmap of             Nothing -> do                 count <- newTVar 1                 listener <- newEmptyTMVar@@ -115,8 +156,8 @@             Just binding -> do                 modifyTVar (socketCount binding) $ \c -> c + 1                 return binding-        count <- readTVar $ socketCount bndg-        return (count,bndg)+        count <- readTVar $ socketCount binding+        return (count,binding)     if count == 1         then do             infoM _log $ "Opening binding for " ++ (show address)@@ -130,47 +171,31 @@  unbindAddress :: SocketBindings -> Address -> IO () unbindAddress bindings address = do-    (count, maybeBinding) <- atomically $ do+    (count,maybeBinding) <- atomically $ do         bmap <- readTVar bindings         case M.lookup address bmap of             Nothing -> return (0,Nothing)-            Just b -> do-                modifyTVar (socketCount b) $ \count -> count - 1-                count <- readTVar (socketCount b)-                return (count,Just b)+            Just binding -> do+                modifyTVar (socketCount binding) $ \count -> count - 1+                count <- readTVar (socketCount binding)+                if count == 0+                    then do+                        modifyTVar bindings $ \bm -> M.delete address bm+                        sock <- takeTMVar $ socketSocket binding+                        listener <- takeTMVar $ socketListener binding+                        return (0,Just (sock,listener))+                    else return (count,Nothing)     case maybeBinding of         -- no binding to shutdown; can just return         Nothing -> do-            warningM _log $ "No binding for " ++ (show address) ++ "; count is " ++ (show count)+            infoM _log $ "No binding to shutdown for " ++ (show address) ++ "; count is " ++ (show count)             return ()         -- we're the last, so close the binding-        Just binding -> do-            if count == 0-                then do-                    (sock,listener) <- atomically $ do-                        sock <- takeTMVar $ socketSocket binding-                        listener <- takeTMVar $ socketListener binding-                        return (sock,listener)-                    infoM _log $ "Closing binding for " ++ (show address) ++ "; count is " ++ (show count)-                    cancel listener-                    sClose sock-                    infoM _log $ "Closed binding for " ++ (show address)-                    -- now we remove the binding from the map, if it is still there and 0-                    -- the expectation here is that only one thread is going to remove it-                    -- from the map-                    atomically $ do-                        bmap <- readTVar bindings-                        case M.lookup address bmap of-                            Nothing -> return ()-                            Just b -> do-                                newCount <- readTVar (socketCount b)-                                if newCount == 0-                                    then do-                                        modifyTVar bindings $ \bm -> M.delete address bm-                                        return ()-                                    else return ()-                else return ()-            return ()+        Just (sock,listener) -> do+            infoM _log $ "Closing binding for " ++ (show address) ++ "; count is " ++ (show count)+            cancel listener+            sClose sock+            infoM _log $ "Closed binding for " ++ (show address)  data SocketTransport = SocketTransport {   socketMessengers :: TVar (M.Map Address Messenger),@@ -180,7 +205,6 @@   socketInbound :: Mailbox Message,   socketDispatchers :: S.Set (Async ()),   socketResolver :: Resolver- }  {-|@@ -241,8 +265,8 @@     let (host,port) = parseSocketAddress address         hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME, AI_NUMERICSERV] }     in do-          addresses <- getAddrInfo (Just hints) (Just host) (Just port)-          return $ map addrAddress $ filter (\addrInfo -> addrFamily addrInfo == family && addrSocketType addrInfo == socketType) addresses+        addresses <- getAddrInfo (Just hints) (Just host) (Just port)+        return $ map addrAddress $ filter (\addrInfo -> addrFamily addrInfo == family && addrSocketType addrInfo == socketType) addresses  lookupAddress :: Family -> SocketType -> Address -> IO SockAddr lookupAddress family socketType address = do@@ -285,6 +309,20 @@         return msngrs   infoM _log $ "Added messenger to " ++ (show address) ++ "; messengers are " ++ (show msngrs) +replaceMessenger :: SocketTransport -> Address -> Messenger -> IO ()+replaceMessenger transport address msngr = do+    found <- atomically $ do+        msngrs <- readTVar $ socketMessengers transport+        return $ M.lookup address msngrs+    case found of+        Just _ -> do+              infoM _log $ "Already have messenger for " ++ (show address)+              closeMessenger msngr+        Nothing -> do+            addMessenger transport address msngr+++ deliver :: Messenger -> Message -> IO () deliver msngr message = atomically $ writeMailbox (messengerOut msngr) message @@ -462,3 +500,13 @@   bindings <- atomically $ readTVar sockets   mapM_ (unbindAddress sockets)  $ M.keys bindings   infoM _log $ "Closed bindings"++socketTransportShutdown :: SocketTransport -> SocketBindings -> IO ()+socketTransportShutdown transport sockets = do+  closeBindings sockets+  infoM _log $ "Closing messengers"+  msngrs <- atomically $ readTVar $ socketMessengers transport+  mapM_ closeMessenger $ M.elems msngrs+  infoM _log $ "Closing dispatcher"+  mapM_ cancel $ S.toList $ socketDispatchers transport+  mapM_ wait $ S.toList $ socketDispatchers transport

@@ -19,7 +19,12 @@ -----------------------------------------------------------------------------  module Network.Transport.TCP (-  newTCPTransport+  newTCPTransport,+  newTCPTransport6,++  lookupAddresses,+  lookupTCPAddress,+  lookupWildcardTCPAddress   ) where  -- local imports@@ -53,146 +58,127 @@ tcpScheme :: Scheme tcpScheme = "tcp" -lookupTCPAddress :: Address -> IO NS.SockAddr-lookupTCPAddress address = lookupAddress NS.AF_INET NS.Stream address+lookupTCPAddress :: Address -> NS.Family -> IO NS.SockAddr+lookupTCPAddress address family = lookupAddress family NS.Stream address -lookupWildcardTCPAddress :: Address -> IO NS.SockAddr-lookupWildcardTCPAddress address = lookupWildcardAddress NS.AF_INET NS.Stream address+lookupWildcardTCPAddress :: Address -> NS.Family -> IO NS.SockAddr+lookupWildcardTCPAddress address family = lookupWildcardAddress family NS.Stream address  {-|-Create a new 'Transport' suitable for sending messages over TCP/IP.  There can+Create a new 'Transport' suitable for sending messages over TCP/IP (IPv4).  There can be multiple instances of these 'Transport's: 'Network.Endpoints.Endpoint' using different instances will still be able to communicate, provided they use correct TCP/IP addresses (or hostnames) for communication. -} newTCPTransport :: Resolver -> IO Transport-newTCPTransport resolver = do-  messengers <- atomically $ newTVar M.empty-  bindings <- atomically $ newTVar M.empty-  sockets <- newSocketBindings-  inbound <- atomically $ newMailbox-  dispatch <- async $ dispatcher bindings inbound-  let transport = SocketTransport {-        socketMessengers = messengers,-        socketBindings = bindings,-        socketConnection = newTCPConnection,-        socketMessenger = newTCPMessenger bindings resolver,-        socketInbound = inbound,-        socketDispatchers = S.fromList [dispatch],-        socketResolver = resolver+newTCPTransport resolver = let family = NS.AF_INET in newSocketTransport resolver tcpScheme (tcpBind family) (newTCPConnection family) newTCPMessenger++{-|+Create a new 'Transport' suitable for sending messages over TCP/IP (IPv4).  There can+be multiple instances of these 'Transport's: 'Network.Endpoints.Endpoint' using+different instances will still be able to communicate, provided they use+correct TCP/IP addresses (or hostnames) for communication.+-}+newTCPTransport6 :: Resolver -> IO Transport+newTCPTransport6 resolver = let family = NS.AF_INET6 in newSocketTransport resolver tcpScheme (tcpBind family) (newTCPConnection family) newTCPMessenger++tcpBind :: NS.Family -> SocketTransport -> SocketBindings -> Mailbox Message -> Name -> IO (Either String Binding)+tcpBind family transport sockets inc name = do+    atomically $ modifyTVar (socketBindings transport) $ \ bindings ->+        M.insert name inc bindings+    Just address <- resolve (socketResolver transport) name+    bindAddress sockets address $ do+        sock <- NS.socket family NS.Stream NS.defaultProtocol+        listener <- do+            infoM _log $ "Binding to address " ++ (show address)+            tcpListen transport family address sock+        return (sock,listener)+    return $ Right Binding {+        bindingName = name,+        unbind = tcpUnbind sockets address         }-  return Transport {-      scheme = tcpScheme,-      handles = tcpHandles transport,-      bind = tcpBind transport sockets,-      sendTo = socketSendTo transport,-      shutdown = tcpShutdown transport sockets-      } -tcpHandles :: SocketTransport -> Name -> IO Bool-tcpHandles transport name = do -  resolved <- resolve (socketResolver transport) name-  return $ isJust resolved-  where-    isJust (Just _) = True-    isJust _ = False+tcpListen :: SocketTransport -> NS.Family -> Address -> NS.Socket -> IO (Async ())+tcpListen transport family address sock = do+            catchExceptions (do+                    NS.setSocketOption sock NS.NoDelay 1+                    NS.setSocketOption sock NS.ReuseAddr 1+                    sockAddr <- lookupWildcardTCPAddress address family+                    NS.bind sock sockAddr+                    NS.listen sock 2048) -- TODO think about a configurable backlog+                (\e -> do+                warningM _log $ "Listen error on port " ++ address ++ ": " ++ (show (e :: SomeException))+                NS.sClose sock)+            async $ tcpAccept transport family address sock -tcpBind :: SocketTransport -> SocketBindings -> Mailbox Message -> Name -> IO (Either String Binding)-tcpBind transport sockets inc name = do-  atomically $ modifyTVar (socketBindings transport) $ \ bindings ->-    M.insert name inc bindings-  Just address <- resolve (socketResolver transport) name-  bindAddress sockets address $ do-      sock <- NS.socket NS.AF_INET NS.Stream NS.defaultProtocol-      listener <- do-        infoM _log $ "Binding to address " ++ (show address)-        tcpListen address sock-      return (sock,listener)-  return $ Right Binding {-    bindingName = name,-    unbind = tcpUnbind address-    }-  where-    tcpListen address sock = do-                catchExceptions (do-                        NS.setSocketOption sock NS.NoDelay 1-                        NS.setSocketOption sock NS.ReuseAddr 1-                        sockAddr <- lookupWildcardTCPAddress address-                        NS.bind sock sockAddr-                        NS.listen sock 2048) -- TODO think about a configurable backlog-                    (\e -> do-                    warningM _log $ "Listen error on port " ++ address ++ ": " ++ (show (e :: SomeException))-                    NS.sClose sock)-                async $ tcpAccept address sock-    tcpAccept address sock = do-      infoM _log $ "Listening for connections on " ++ (show address) ++ ": " ++ (show sock)-      (client,clientAddress) <- NS.accept sock-      _ <- async $ tcpDispatch address client clientAddress-      tcpAccept address sock-    tcpDispatch address client socketAddress = do-      infoM _log $ "Accepted connection on " ++ (show address)-      identity <- tcpIdentify client socketAddress-      case identity of+tcpAccept :: SocketTransport -> NS.Family -> Address -> NS.Socket -> IO ()+tcpAccept transport family address sock = do+    infoM _log $ "Listening for connections on " ++ (show address) ++ ": " ++ (show sock)+    (client,clientAddress) <- NS.accept sock+    _ <- async $ tcpDispatch transport family address client clientAddress+    tcpAccept transport family address sock++tcpDispatch :: SocketTransport -> NS.Family -> Address -> NS.Socket -> NS.SockAddr -> IO ()+tcpDispatch transport family address client socketAddress = do+  infoM _log $ "Accepted connection on " ++ (show address)+  identity <- tcpIdentify client socketAddress+  case identity of         Nothing -> NS.sClose client         Just (IdentifyMessage clientAddress) -> do-          infoM _log $ "Identified " ++ (show clientAddress)-          newConn <- newTCPConnection clientAddress-          atomically $ putTMVar (connSocket newConn) client-          msngr <- newMessenger newConn (socketInbound transport)-          found <- atomically $ do-            msngrs <- readTVar $ socketMessengers transport-            return $ M.lookup clientAddress msngrs-          case found of-            Just _ -> do-              infoM _log $ "Already have messenger for " ++ (show clientAddress)-              closeMessenger msngr-            Nothing -> do-              addMessenger transport clientAddress msngr-    tcpIdentify client clientAddress = do-      infoM _log $ "Awaiting identity from " ++ (show clientAddress)-      maybeMsg <- receiveSocketMessage client-      case maybeMsg of+            infoM _log $ "Identified " ++ (show clientAddress)+            newConn <- (newTCPConnection family) clientAddress+            atomically $ putTMVar (connSocket newConn) client+            msngr <- newMessenger newConn (socketInbound transport)+            replaceMessenger transport clientAddress msngr++tcpIdentify :: NS.Socket -> NS.SockAddr -> IO (Maybe IdentifyMessage)+tcpIdentify client clientAddress = do+    infoM _log $ "Awaiting identity from " ++ (show clientAddress)+    maybeMsg <- receiveSocketMessage client+    case maybeMsg of         Nothing -> return Nothing         Just bytes -> do-          let msg = decode bytes-          case msg of-            Left _ -> return Nothing-            Right message -> return $ Just message-    tcpUnbind address = do-      infoM _log $ "Unbinding from TCP port " ++ (show address)-      unbindAddress sockets address-      infoM _log $ "Unbound from TCP port " ++ (show address)+            let msg = decode bytes+            case msg of+                Left _ -> return Nothing+                Right message -> return $ Just message -newTCPConnection :: Address -> IO Connection-newTCPConnection address = do-  sock <- atomically $ newEmptyTMVar-  return Connection {-    connAddress = address,-    connSocket = sock,-    connConnect = do-        socket <- NS.socket NS.AF_INET NS.Stream NS.defaultProtocol-        sockAddr <- lookupTCPAddress address-        NS.connect socket sockAddr-        -- NS.connect socket $ NS.addrAddress $ head ipv4Addrs-        atomically $ putTMVar sock socket-        -- infoM _log $ "Initiated socket connection to " ++ (show $ head ipv4Addrs)-        return socket,-    connSend = tcpSend address,-    connReceive = receiveSocketBytes,-    connClose = do-        infoM _log $ "Closing connection to " ++ address-        open <- atomically $ tryTakeTMVar sock-        case open of-            Just socket -> do-                infoM _log $ "Closing socket " ++ (show socket) ++ " for " ++ address-                NS.sClose socket-                infoM _log $ "Closed socket " ++ (show socket) ++ " for " ++ address-            Nothing -> do-                infoM _log $ "No socket to close for " ++ address-                return ()-        infoM _log $ "Connection to " ++ address ++ " closed"-    }+tcpUnbind :: SocketBindings -> Address -> IO ()+tcpUnbind sockets address = do+  infoM _log $ "Unbinding from TCP port " ++ (show address)+  unbindAddress sockets address+  infoM _log $ "Unbound from TCP port " ++ (show address) +newTCPConnection :: NS.Family -> Address -> IO Connection+newTCPConnection family address = do+    sock <- atomically $ newEmptyTMVar+    return Connection {+        connAddress = address,+        connSocket = sock,+        connConnect = do+            socket <- NS.socket family NS.Stream NS.defaultProtocol+            sockAddr <- lookupTCPAddress address family+            NS.connect socket sockAddr+            -- NS.connect socket $ NS.addrAddress $ head ipv4Addrs+            atomically $ putTMVar sock socket+            -- infoM _log $ "Initiated socket connection to " ++ (show $ head ipv4Addrs)+            return socket,+        connSend = tcpSend address,+        connReceive = receiveSocketBytes,+        connClose = do+            infoM _log $ "Closing connection to " ++ address+            open <- atomically $ tryTakeTMVar sock+            case open of+                Just socket -> do+                    infoM _log $ "Closing socket " ++ (show socket) ++ " for " ++ address+                    NS.sClose socket+                    infoM _log $ "Closed socket " ++ (show socket) ++ " for " ++ address+                Nothing -> do+                    infoM _log $ "No socket to close for " ++ address+                    return ()+            infoM _log $ "Connection to " ++ address ++ " closed"+        }+ newTCPMessenger :: Bindings -> Resolver -> Connection -> Mailbox Message -> IO Messenger newTCPMessenger bindings resolver conn mailbox = do     msngr <- newMessenger conn mailbox@@ -215,14 +201,3 @@     infoM _log $ "Length sent"     NSB.sendAll sock bs     infoM _log $ "Message sent to" ++ (show addr)---tcpShutdown :: SocketTransport -> SocketBindings -> IO ()-tcpShutdown transport sockets = do-  closeBindings sockets-  infoM _log $ "Closing messengers"-  msngrs <- atomically $ readTVar $ socketMessengers transport-  mapM_ closeMessenger $ M.elems msngrs-  infoM _log $ "Closing dispatcher"-  mapM_ cancel $ S.toList $ socketDispatchers transport-  mapM_ wait $ S.toList $ socketDispatchers transport

@@ -26,7 +26,12 @@ -----------------------------------------------------------------------------  module Network.Transport.UDP (-  newUDPTransport+  newUDPTransport,+  newUDPTransport6,++  lookupAddresses,+  lookupUDPAddress,+  lookupWildcardUDPAddress   ) where  -- local imports@@ -43,13 +48,11 @@  import qualified Data.ByteString as B import qualified Data.Map as M-import qualified Data.Set as S  import qualified Network.Socket as NS import Network.Socket.ByteString(sendAllTo,recvFrom)  import System.Log.Logger--- import qualified System.Random as R  -------------------------------------------------------------------------------- --------------------------------------------------------------------------------@@ -60,52 +63,26 @@ udpScheme :: Scheme udpScheme = "udp" -lookupUDPAddress :: Address -> IO NS.SockAddr-lookupUDPAddress address = lookupAddress NS.AF_INET NS.Datagram address+lookupUDPAddress :: Address -> NS.Family -> IO NS.SockAddr+lookupUDPAddress address family = lookupAddress family NS.Datagram address -lookupWildcardUDPAddress :: Address -> IO NS.SockAddr-lookupWildcardUDPAddress address = lookupWildcardAddress NS.AF_INET NS.Datagram address+lookupWildcardUDPAddress :: Address -> NS.Family -> IO NS.SockAddr+lookupWildcardUDPAddress address family = lookupWildcardAddress family NS.Datagram address  newUDPTransport :: Resolver -> IO Transport-newUDPTransport resolver = do-  messengers <- atomically $ newTVar M.empty-  bindings <- atomically $ newTVar M.empty-  sockets <- newSocketBindings-  inbound <- atomically $ newMailbox-  dispatch <- async $ dispatcher bindings inbound-  let transport = SocketTransport {-        socketMessengers = messengers,-        socketBindings = bindings,-        socketConnection = newUDPConnection,-        socketMessenger = newUDPMessenger,-        socketInbound = inbound,-        socketDispatchers = S.fromList [dispatch],-        socketResolver = resolver-        }-  return Transport {-      scheme = udpScheme,-      handles = udpHandles transport,-      bind = udpBind transport sockets,-      sendTo = socketSendTo transport,-      shutdown = udpShutdown transport sockets-      }+newUDPTransport resolver = newSocketTransport resolver udpScheme (udpBind NS.AF_INET) (newUDPConnection NS.AF_INET) newUDPMessenger -udpHandles :: SocketTransport -> Name -> IO Bool-udpHandles transport name = do -  resolved <- resolve (socketResolver transport) name-  return $ isJust resolved-  where-    isJust (Just _) = True-    isJust _ = False+newUDPTransport6 :: Resolver -> IO Transport+newUDPTransport6 resolver = newSocketTransport resolver udpScheme (udpBind NS.AF_INET6) (newUDPConnection NS.AF_INET6) newUDPMessenger -udpBind :: SocketTransport -> SocketBindings -> Mailbox Message -> Name -> IO (Either String Binding)-udpBind transport sockets inc name = do+udpBind :: NS.Family -> SocketTransport -> SocketBindings -> Mailbox Message -> Name -> IO (Either String Binding)+udpBind family transport sockets inc name = do     atomically $ modifyTVar (socketBindings transport) $ \bindings ->         M.insert name inc bindings     Just address <- resolve (socketResolver transport) name     bindAddress sockets address $ do-        sockaddr <- lookupWildcardUDPAddress address-        sock <-  NS.socket NS.AF_INET NS.Datagram NS.defaultProtocol+        sockaddr <- lookupWildcardUDPAddress address family+        sock <-  NS.socket family NS.Datagram NS.defaultProtocol         -- have to set this option in case we frequently rebind sockets         infoM _log $ "Binding to " ++ (show address) ++ " over UDP"         NS.setSocketOption sock NS.ReuseAddr 1@@ -121,15 +98,15 @@             infoM _log $ "Unbound from UDP port " ++ (show address)     } -newUDPConnection :: Address -> IO Connection-newUDPConnection address = do+newUDPConnection :: NS.Family -> Address -> IO Connection+newUDPConnection family address = do   sock <- atomically newEmptyTMVar   return Connection {     connAddress = address,     connSocket = sock,-    connConnect = NS.socket NS.AF_INET NS.Datagram NS.defaultProtocol,+    connConnect = NS.socket family NS.Datagram NS.defaultProtocol,     connSend = (\s bs -> do-        addr <- lookupUDPAddress address+        addr <- lookupUDPAddress address family         infoM _log $ "Sending via UDP to " ++ (show addr)         sendAllTo s bs addr         infoM _log $ "Sent via UDP to " ++ (show addr)),@@ -142,8 +119,8 @@         return ()     } -newUDPMessenger :: Connection -> Mailbox Message -> IO Messenger-newUDPMessenger conn mailbox = do+newUDPMessenger :: Bindings -> Resolver -> Connection -> Mailbox Message -> IO Messenger+newUDPMessenger _ _ conn mailbox = do     msngr <- newMessenger conn mailbox     return msngr @@ -175,15 +152,3 @@     if B.null bs         then return Nothing         else return $ Just bs--udpShutdown :: SocketTransport -> SocketBindings -> IO ()-udpShutdown transport sockets = do-  infoM _log $ "Unbinding transport"-  closeBindings sockets-  infoM _log $ "Closing messengers"-  msngrs <- atomically $ readTVar $ socketMessengers transport-  mapM_ closeMessenger $ M.elems msngrs-  infoM _log $ "Closing dispatcher"-  mapM_ cancel $ S.toList $ socketDispatchers transport-  mapM_ wait $ S.toList $ socketDispatchers transport-

@@ -7,6 +7,8 @@  -- external imports +import Control.Exception+ import Data.Serialize  import Test.Framework@@ -24,52 +26,58 @@     testCase "mem-unbind" testEndpointBindUnbind,     testCase "mem-sendReceive" testEndpointSendReceive,     testCase "mem-transport" testMemoryTransport-  ] -  -testEndpointTransport :: Assertion  -testEndpointTransport = do  +  ]++testEndpointTransport :: Assertion+testEndpointTransport = do   transport <- newMemoryTransport   _ <- newEndpoint [transport]   return ()-  + testEndpointBind :: Assertion-testEndpointBind = do  +testEndpointBind = do   let name1 = "endpoint1"   transport <- newMemoryTransport-  endpoint <- newEndpoint [transport]-  Right () <- bindEndpoint endpoint name1-  return ()+  finally (do+          endpoint <- newEndpoint [transport]+          Right () <- bindEndpoint endpoint name1+          return ())+      (shutdown transport)  testEndpointBindUnbind :: Assertion-testEndpointBindUnbind = do  +testEndpointBindUnbind = do   let name1 = "endpoint1"   transport <- newMemoryTransport-  endpoint <- newEndpoint [transport]-  Right () <- bindEndpoint endpoint name1-  unbound <- unbindEndpoint endpoint name1-  case unbound of-    Left err -> assertFailure $ "Unbind failed: " ++ err-    Right () -> assertBool "Unbind succeeded" True-  return ()-  -testEndpointSendReceive :: Assertion  +  finally (do+          endpoint <- newEndpoint [transport]+          Right () <- bindEndpoint endpoint name1+          unbound <- unbindEndpoint endpoint name1+          case unbound of+            Left err -> assertFailure $ "Unbind failed: " ++ err+            Right () -> assertBool "Unbind succeeded" True+          return ())+      (shutdown transport)++testEndpointSendReceive :: Assertion testEndpointSendReceive = do   let name1 = "endpoint1"       name2 = "endpoint2"   transport <- newMemoryTransport-  endpoint1 <- newEndpoint [transport]-  endpoint2 <- newEndpoint [transport]-  Right () <- bindEndpoint endpoint1 name1-  Right () <- bindEndpoint endpoint2 name2-  _ <- sendMessage endpoint1 name2 $ encode "hello!"-  msg <- receiveMessage endpoint2    -  assertEqual "Received message not same as sent" (Right "hello!") (decode msg)-  return ()-  +  finally (do+          endpoint1 <- newEndpoint [transport]+          endpoint2 <- newEndpoint [transport]+          Right () <- bindEndpoint endpoint1 name1+          Right () <- bindEndpoint endpoint2 name2+          _ <- sendMessage endpoint1 name2 $ encode "hello!"+          msg <- receiveMessage endpoint2+          assertEqual "Received message not same as sent" (Right "hello!") (decode msg)+          return ())+      (shutdown transport)+ -- Memory tests-  + testMemoryTransport :: Assertion testMemoryTransport = do-  _ <- newMemoryTransport-  return ()+    transport <- newMemoryTransport+    shutdown transport 

@@ -49,6 +49,7 @@     testCase "call-one-handler" testOneHandler,     testCase "call-two-handlers" testTwoHandlers,     testCase "gcall-three-handlers" testGroupCall,+    testCase "anycall-three-handlers" testAnyCall,     testCase "call-one-with-timeout" testOneHandlerWithTimeout,     testCase "gcall-three-handlers-with-timeout"testGroupCallWithTimeout   ]@@ -189,6 +190,35 @@     assertBool "Bar not present in results" (elem (encode "bar") $ M.elems results)     assertBool "Bar not present in results" (elem (encode "baz") $ M.elems results)     assertEqual "Unxpected number of results" 3 (M.size results)+    hangup h2+    hangup h3+    hangup h4++testAnyCall :: Assertion+testAnyCall = do+    let name1 = "endpoint1"+        name2 = "endpoint2"+        name3 = "endpoint3"+        name4 = "endpoint4"+    transport <- newMemoryTransport+    endpoint1 <- newEndpoint [transport]+    endpoint2 <- newEndpoint [transport]+    endpoint3 <- newEndpoint [transport]+    endpoint4 <- newEndpoint [transport]+    Right () <- bindEndpoint endpoint1 name1+    Right () <- bindEndpoint endpoint2 name2+    Right () <- bindEndpoint endpoint3 name3+    Right () <- bindEndpoint endpoint4 name4+    h2 <- handle endpoint2 name2 "foo" $ \bytes -> let Right msg = decode bytes in+                                                      return $ encode $ if msg == "hello" then "foo" else ""+    h3 <- handle endpoint3 name3 "foo" $ \bytes -> let Right msg = decode bytes in+                                                       return $ encode $ if msg == "hello" then "foo" else ""+    h4 <- handle endpoint4 name4 "foo" $ \bytes -> let Right msg = decode bytes in+                                                       return $ encode $ if msg == "hello" then "foo" else ""+    let cs = newCallSite endpoint1 name1+    (result,responder) <- (anyCall cs [name2,name3,name4] "foo" $ encode "hello")+    assertEqual "Response should have been 'foo'" (encode "foo") result+    assertBool "Responder was not in original list of names" $ elem responder [name2,name3,name4]     hangup h2     hangup h3     hangup h4

@@ -6,12 +6,12 @@ import Network.Transport.TCP  import TestTransports+import TestUtils  -- external imports  import Control.Exception - import Test.Framework import Test.HUnit import Test.Framework.Providers.HUnit@@ -23,31 +23,35 @@ _log :: String _log = "test.transport.tcp" -address1 :: Address-address1 = "localhost:20001"--address2 :: Address-address2 = "localhost:20002"- tests :: [Test.Framework.Test] tests =   [-    testCase "tcp-endpoints+transport" testEndpointTransport,-    testCase "tcp-bind-unbind" $ endpointBindUnbind _log newTCPTransport address1 address2,-    testCase "tcp-send-receive" $ endpointSendReceive _log newTCPTransport address1 address2,-    testCase "tcp-double-send-receive" $ endpointDoubleSendReceive _log newTCPTransport address1 address2,-    testCase "tcp-send-receive-reply" $ endpointSendReceiveReply _log newTCPTransport address1 address2,-    testCase "tcp-multiple-send-receive-reply" $ endpointMultipleSendReceiveReply _log newTCPTransport address1 address2,-    testCase "tcp-local-send-receive-reply" $ endpointLocalSendReceiveReply _log newTCPTransport address1 address2+    testCase "tcp-endpoints+transport" $ testEndpointTransport newTCPTransport,+    testCase "tcp-bind-unbind" $ endpointBindUnbind _log newTCPTransport newTCPAddress,+    testCase "tcp-send-receive" $ endpointSendReceive _log newTCPTransport newTCPAddress,+    testCase "tcp-double-send-receive" $ endpointDoubleSendReceive _log newTCPTransport newTCPAddress,+    testCase "tcp-send-receive-reply" $ endpointSendReceiveReply _log newTCPTransport newTCPAddress,+    testCase "tcp-multiple-send-receive-reply" $ endpointMultipleSendReceiveReply _log newTCPTransport newTCPAddress,+    testCase "tcp-local-send-receive-reply" $ endpointLocalSendReceiveReply _log newTCPTransport newTCPAddress,++    testCase "tcp6-endpoints+transport" $ whenIPv6 $ testEndpointTransport newTCPTransport6,+    testCase "tcp6-bind-unbind" $ whenIPv6 $ endpointBindUnbind _log newTCPTransport6 newTCPAddress6,+    testCase "tcp6-send-receive" $ whenIPv6 $ endpointSendReceive _log newTCPTransport6 newTCPAddress6,+    testCase "tcp6-double-send-receive" $ whenIPv6 $ endpointDoubleSendReceive _log newTCPTransport6 newTCPAddress6,+    testCase "tcp6-send-receive-reply" $ whenIPv6 $ endpointSendReceiveReply _log newTCPTransport6 newTCPAddress6,+    testCase "tcp6-multiple-send-receive-reply" $ whenIPv6 $ endpointMultipleSendReceiveReply _log newTCPTransport6 newTCPAddress6,+    testCase "tcp6-local-send-receive-reply" $ whenIPv6 $ endpointLocalSendReceiveReply _log newTCPTransport6 newTCPAddress6   ] -testEndpointTransport :: Assertion-testEndpointTransport = do+testEndpointTransport :: (Resolver -> IO Transport) -> Assertion+testEndpointTransport transportFactory = do   let name1 = "endpoint1"       name2 = "endpoint2"+  address1 <- newTCPAddress+  address2 <- newTCPAddress   let resolver = resolverFromList [(name1,address1),                                (name2,address2)]-  bracket (newTCPTransport resolver)+  bracket (transportFactory resolver)           shutdown           (\transport -> do             _ <- newEndpoint [transport]

@@ -1,6 +1,7 @@ module TestTransports (     testDelay,     verifiedSend,+    whenIPv6,      -- Common tests     endpointTransport,@@ -16,6 +17,8 @@  import Network.Endpoints +import Network.Transport.TCP+ -- external imports  import Control.Concurrent@@ -23,6 +26,8 @@  import Data.Serialize +import qualified Network.Socket as NS+ import System.Log.Logger  import Test.HUnit@@ -30,18 +35,32 @@ ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- +_log :: String+_log = "test.transports"+ testDelay :: Int testDelay = 1 * 1000000  pause :: IO () pause = threadDelay testDelay +whenIPv6 :: Assertion -> Assertion+whenIPv6 assn = do+    addresses <- lookupAddresses NS.AF_INET6 NS.Stream "localhost:1"+    case addresses of+        [] -> do+            warningM _log $ "IPv6 not available"+            return ()+        _ -> assn+ {--Common tests--just supply the transport factory and 2 addresses+Common tests--just supply the transport factory and an address generator -} -endpointTransport :: String -> (Resolver -> IO Transport) -> Address -> Address -> Assertion-endpointTransport _log newTransport address1 address2 = do+endpointTransport :: String -> (Resolver -> IO Transport) -> IO Address -> Assertion+endpointTransport _log newTransport newAddress = do+  address1 <- newAddress+  address2 <- newAddress   let name1 = "endpoint1"       name2 = "endpoint2"   let resolver = resolverFromList [(name1,address1),@@ -52,9 +71,11 @@             _ <- newEndpoint [transport]             return ()) -endpointBindUnbind :: String -> (Resolver -> IO Transport) -> Address -> Address -> Assertion-endpointBindUnbind _log newTransport address1 address2 = do+endpointBindUnbind :: String -> (Resolver -> IO Transport) -> IO Address -> Assertion+endpointBindUnbind _log newTransport newAddress = do   infoM _log "Starting bind-unbind test"+  address1 <- newAddress+  address2 <- newAddress   let name1 = "endpoint1"       name2 = "endpoint2"   let resolver = resolverFromList [(name1,address1),@@ -70,9 +91,11 @@               Right () -> assertBool "Unbind succeeded" True             return ()) -endpointSendReceive :: String -> (Resolver -> IO Transport) -> Address -> Address -> Assertion-endpointSendReceive _log newTransport address1 address2 = do+endpointSendReceive :: String -> (Resolver -> IO Transport) -> IO Address -> Assertion+endpointSendReceive _log newTransport newAddress = do   infoM _log "Starting send-receive test"+  address1 <- newAddress+  address2 <- newAddress   let name1 = "endpoint1"       name2 = "endpoint2"   let resolver = resolverFromList [(name1,address1),@@ -91,9 +114,11 @@       return ()   infoM _log "Finished send-receive test" -endpointDoubleSendReceive :: String -> (Resolver -> IO Transport) -> Address -> Address -> Assertion-endpointDoubleSendReceive _log newTransport address1 address2 = do+endpointDoubleSendReceive :: String -> (Resolver -> IO Transport) -> IO Address -> Assertion+endpointDoubleSendReceive _log newTransport newAddress = do   infoM _log "Starting double-send-receive test"+  address1 <- newAddress+  address2 <- newAddress   let name1 = "endpoint1"       name2 = "endpoint2"       name3 = "endpoint3"@@ -121,9 +146,11 @@       return ()   infoM _log "Finished double-send-receive test" -endpointSendReceiveReply :: String -> (Resolver -> IO Transport) -> Address -> Address -> Assertion-endpointSendReceiveReply _log newTransport address1 address2 = do+endpointSendReceiveReply :: String -> (Resolver -> IO Transport) -> IO Address -> Assertion+endpointSendReceiveReply _log newTransport newAddress = do   infoM _log "Starting send-receive-reply test"+  address1 <- newAddress+  address2 <- newAddress   let name1 = "endpoint1"       name2 = "endpoint2"   let resolver = resolverFromList [(name1,address1),@@ -144,9 +171,10 @@       return ()   infoM _log "Finished send-receive-reply test" -endpointLocalSendReceiveReply :: String -> (Resolver -> IO Transport) -> Address -> Address -> Assertion-endpointLocalSendReceiveReply _log newTransport address1 _ = do+endpointLocalSendReceiveReply :: String -> (Resolver -> IO Transport) -> IO Address -> Assertion+endpointLocalSendReceiveReply _log newTransport newAddress = do   infoM _log "Starting local-send-receive-reply test"+  address1 <- newAddress   let name1 = "endpoint1"       name2 = "endpoint2"   let resolver = resolverFromList [(name1,address1),@@ -169,9 +197,11 @@         return ())   infoM _log "Finished local-send-receive-reply test" -endpointMultipleSendReceiveReply :: String -> (Resolver -> IO Transport) -> Address -> Address -> Assertion-endpointMultipleSendReceiveReply _log newTransport address1 address2 = do+endpointMultipleSendReceiveReply :: String -> (Resolver -> IO Transport) -> IO Address -> Assertion+endpointMultipleSendReceiveReply _log newTransport newAddress = do   infoM _log "Starting multiple-send-receive-reply test"+  address1 <- newAddress+  address2 <- newAddress   let name1 = "endpoint1"       name2 = "endpoint2"   let resolver = resolverFromList [(name1,address1),

@@ -6,11 +6,11 @@ import Network.Transport.UDP  import TestTransports+import TestUtils  -- external imports  import Control.Exception- import Test.Framework import Test.HUnit import Test.Framework.Providers.HUnit@@ -22,30 +22,34 @@ _log :: String _log = "test.transport.udp" -address1 :: Address-address1 = "localhost:2003"--address2 :: Address-address2 = "localhost:2004"- tests :: [Test.Framework.Test] tests =    [     testCase "udp-endpoints+transport" testEndpointTransport, -    testCase "udp-bind-unbind" $ endpointBindUnbind _log newUDPTransport address1 address2,-    testCase "udp-send-receive" $ endpointSendReceive _log newUDPTransport address1 address2,-    testCase "udp-double-send-receive" $ endpointDoubleSendReceive _log newUDPTransport address1 address2,-    testCase "udp-send-receive-reply" $ endpointSendReceiveReply _log newUDPTransport address1 address2,-    testCase "udp-multiple-send-receive-reply" $ endpointMultipleSendReceiveReply _log newUDPTransport address1 address2,-    testCase "udp-local-send-receive-reply" $ endpointLocalSendReceiveReply _log newUDPTransport address1 address2+    testCase "udp-bind-unbind" $ endpointBindUnbind _log newUDPTransport newUDPAddress,+    testCase "udp-send-receive" $ endpointSendReceive _log newUDPTransport newUDPAddress,+    testCase "udp-double-send-receive" $ endpointDoubleSendReceive _log newUDPTransport newUDPAddress,+    testCase "udp-send-receive-reply" $ endpointSendReceiveReply _log newUDPTransport newUDPAddress,+    testCase "udp-multiple-send-receive-reply" $ endpointMultipleSendReceiveReply _log newUDPTransport newUDPAddress,+    testCase "udp-local-send-receive-reply" $ endpointLocalSendReceiveReply _log newUDPTransport newUDPAddress,     +    testCase "udp6-endpoints+transport" $ whenIPv6 $ testEndpointTransport,++    testCase "udp6-bind-unbind" $ whenIPv6 $ endpointBindUnbind _log newUDPTransport6 newUDPAddress6,+    testCase "udp6-send-receive" $ whenIPv6 $ endpointSendReceive _log newUDPTransport6 newUDPAddress6,+    testCase "udp6-double-send-receive" $ whenIPv6 $ endpointDoubleSendReceive _log newUDPTransport6 newUDPAddress6,+    testCase "udp6-send-receive-reply" $ whenIPv6 $ endpointSendReceiveReply _log newUDPTransport6 newUDPAddress6,+    testCase "udp6-multiple-send-receive-reply" $ whenIPv6 $ endpointMultipleSendReceiveReply _log newUDPTransport6 newUDPAddress6,+    testCase "udp6-local-send-receive-reply" $ whenIPv6 $ endpointLocalSendReceiveReply _log newUDPTransport6 newUDPAddress6   ]  testEndpointTransport :: Assertion testEndpointTransport = do   let name1 = "endpoint1"       name2 = "endpoint2"+  address1 <- newUDPAddress+  address2 <- newUDPAddress   let resolver = resolverFromList [(name1,address1),                                (name2,address2)]   bracket (newUDPTransport resolver)

@@ -0,0 +1,53 @@+module TestUtils+    ( newTCPAddress+    , newUDPAddress+    , newTCPAddress6+    , newUDPAddress6)+    where++import Control.Exception+import qualified Network.Socket as NS++newTCPAddress :: IO String+newTCPAddress = do+  NS.SockAddrInet (NS.PortNum p) _ <- availablePort NS.AF_INET NS.Stream+  return $ "localhost:" ++ show p++newUDPAddress :: IO String+newUDPAddress = do+  NS.SockAddrInet (NS.PortNum p) _ <- availablePort NS.AF_INET NS.Datagram+  return $ "localhost:" ++ show p++newTCPAddress6 :: IO String+newTCPAddress6 = do+  NS.SockAddrInet6 (NS.PortNum p) _ _ _ <- availablePort NS.AF_INET6 NS.Stream+  return $ "localhost:" ++ show p++newUDPAddress6 :: IO String+newUDPAddress6 = do+  NS.SockAddrInet6 (NS.PortNum p) _ _ _ <- availablePort NS.AF_INET6 NS.Datagram+  return $ "localhost:" ++ show p++availablePort     :: NS.Family -> NS.SocketType -> IO NS.SockAddr+availablePort f t = do+  let hints = NS.defaultHints { NS.addrFamily = f+                              , NS.addrSocketType = t+                              , NS.addrFlags = [ NS.AI_PASSIVE ]+                              , NS.addrProtocol = NS.defaultProtocol }+  addrs <- NS.getAddrInfo (Just hints) Nothing (Just "0")+  let a = head addrs+  bracket+    (NS.socket (NS.addrFamily a) (NS.addrSocketType a) (NS.addrProtocol a))+    NS.close+    (\s -> do+       NS.bindSocket s (NS.addrAddress a)+       addr <- NS.getSocketName s+       if isPrivileged addr+         then availablePort f t+         else return addr+    )++isPrivileged :: NS.SockAddr -> Bool+isPrivileged (NS.SockAddrInet (NS.PortNum p) _) = p < 1025+isPrivileged (NS.SockAddrInet6 (NS.PortNum p) _ _ _) = p < 1025+isPrivileged (NS.SockAddrUnix _) = False