├── .gitignore ├── .travis.yml ├── CONTRIBUTING.md ├── ChangeLog ├── LICENSE ├── README.md ├── Setup.hs ├── network-transport.cabal ├── src └── Network │ ├── Transport.hs │ └── Transport │ ├── Internal.hs │ └── Util.hs └── tests ├── chat ├── ChatClient.hs └── ChatServer.hs └── sumeuler ├── SumEulerMaster.hs ├── SumEulerWorker.hs └── sumeuler.sh /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | .stack* 5 | dist-newstyle/ 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | sudo: false 4 | 5 | matrix: 6 | include: 7 | - env: CABALVER=1.22 GHCVER=7.6.3 8 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.6.3], sources: [hvr-ghc]}} 9 | - env: CABALVER=1.22 GHCVER=7.8.4 10 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4], sources: [hvr-ghc]}} 11 | - env: CABALVER=1.22 GHCVER=7.10.3 12 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3],sources: [hvr-ghc]}} 13 | - env: CABALVER=1.24 GHCVER=8.0.1 14 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1],sources: [hvr-ghc]}} 15 | 16 | before_install: 17 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:~/.cabal/bin:$PATH 18 | - ghc --version 19 | - cabal --version 20 | - cabal update 21 | # workaround for https://ghc.haskell.org/trac/ghc/ticket/9221 22 | # taken from https://github.com/hvr/multi-ghc-travis/blob/0fa68f78c2b1b059f904c9abc85510a3bb4f57e2/README.md 23 | - sed -i 's/^jobs:/-- jobs:/' $HOME/.cabal/config 24 | 25 | install: 26 | - cabal install --only-dependencies --enable-tests 27 | 28 | script: 29 | - cabal configure --enable-tests 30 | - cabal build 31 | - cabal test 32 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md. 2 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 2024-03-25 David Simmons-Duffin 0.5.7 2 | 3 | * Bump bytestring and deepseq versions to build with GHC 9.8. 4 | 5 | 2022-08-30 Facundo Domínguez 0.5.6 6 | 7 | * Fix extension fields in the cabal file (#41). 8 | 9 | 2022-08-09 Facundo Domínguez 0.5.5 10 | 11 | * Relax dependency bounds to build with ghc9 (#40). 12 | 13 | 2019-05-12 Facundo Domínguez 0.5.4 14 | 15 | * Fix documentation typo (#39). 16 | 17 | 2019-05-12 Facundo Domínguez 0.5.3 18 | 19 | * Relax upper bound of hashable. 20 | 21 | 2017-07-25 Facundo Domínguez 0.5.2 22 | 23 | * prependLength checks for overflow (5608f0f) 24 | * Drop inlinePerformIO for unsafeDupablePerformIO (18bf80c) 25 | * Have travis build n-t even with no tests (7ffe43e) 26 | 27 | 2017-02-23 Facundo Domínguez 0.5.1 28 | 29 | * Add {encode|decode}{Word|Enum|Num}{32|16}. 30 | * Removed {encode|decode}Int{32|16} 31 | 32 | 2016-01-28 Facundo Domínguez 0.4.4.0 33 | 34 | * Add compatibility with ghc-8. 35 | 36 | 2016-01-28 Facundo Domínguez 0.4.3.0 37 | 38 | * Derive Binary instances for missing types. 39 | * Use auto-derive for Reliability as Binary instance. 40 | * Stop testing with ghc-7.4 and build with ghc-7.10. 41 | 42 | 2015-06-15 Facundo Domínguez 0.4.2.0 43 | 44 | * Add NFData instance for EndPointAddress. 45 | * Relax dependency bounds. 46 | 47 | 2014-12-09 Tim Watson 0.4.1.0 48 | 49 | * foreigns htonl, ntohl, htons, ntohs are imported from ws2_32 on windows 50 | * Created Data instance for EndPointAddress (thanks Andrew Rademacher) 51 | 52 | 2014-05-30 Tim Watson 0.4.0.0 53 | 54 | * Fix build for GHC 7.4 - thanks mboes! 55 | * Allow transformers above v5 56 | * Bump binary version to include 0.7.* 57 | * Binary instance for 'Reliability' - thanks mboes! 58 | * Hashable instance for 'EndPointAddress' 59 | 60 | 2012-11-22 Edsko de Vries 0.3.0.1 61 | 62 | * Relax bounds on Binary 63 | 64 | 2012-10-03 Edsko de Vries 0.3.0 65 | 66 | * Clarify disconnection 67 | * Require that 'connect' be "as asynchronous as possible" 68 | * Added strictness annotations 69 | 70 | 2012-07-16 Edsko de Vries 0.2.0.2 71 | 72 | * Base 4.6 compatible test suites 73 | * Relax package constraints for bytestring 74 | 75 | 2012-07-16 Edsko de Vries 0.2.0.1 76 | 77 | * Hide catch only for base < 4.6 78 | 79 | 2012-07-07 Edsko de Vries 0.2.0 80 | 81 | * Initial release. 82 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Well-Typed LLP, 2011-2012 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of the owner nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # network-transport (archive) 2 | 3 | ## :warning: This package is now developed here: https://github.com/haskell-distributed/distributed-process :warning: 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /network-transport.cabal: -------------------------------------------------------------------------------- 1 | Name: network-transport 2 | Version: 0.5.7 3 | Cabal-Version: >=1.10 4 | Build-Type: Simple 5 | License: BSD3 6 | License-File: LICENSE 7 | Copyright: Well-Typed LLP 8 | Author: Duncan Coutts, Nicolas Wu, Edsko de Vries 9 | Maintainer: Facundo Domínguez 10 | Stability: experimental 11 | Homepage: https://haskell-distributed.github.io 12 | Bug-Reports: https://github.com/haskell-distributed/network-transport/issues 13 | Synopsis: Network abstraction layer 14 | Description: "Network.Transport" is a Network Abstraction Layer which provides 15 | the following high-level concepts: 16 | . 17 | * Nodes in the network are represented by 'EndPoint's. These are 18 | heavyweight stateful objects. 19 | . 20 | * Each 'EndPoint' has an 'EndPointAddress'. 21 | . 22 | * Connections can be established from one 'EndPoint' to another 23 | using the 'EndPointAddress' of the remote end. 24 | . 25 | * The 'EndPointAddress' can be serialised and sent over the 26 | network, whereas 'EndPoint's and connections cannot. 27 | . 28 | * Connections between 'EndPoint's are unidirectional and lightweight. 29 | . 30 | * Outgoing messages are sent via a 'Connection' object that 31 | represents the sending end of the connection. 32 | . 33 | * Incoming messages for /all/ of the incoming connections on 34 | an 'EndPoint' are collected via a shared receive queue. 35 | . 36 | * In addition to incoming messages, 'EndPoint's are notified of 37 | other 'Event's such as new connections or broken connections. 38 | . 39 | This design was heavily influenced by the design of the Common 40 | Communication Interface 41 | (). 42 | Important design goals are: 43 | . 44 | * Connections should be lightweight: it should be no problem to 45 | create thousands of connections between endpoints. 46 | . 47 | * Error handling is explicit: every function declares as part of 48 | its type which errors it can return (no exceptions are thrown) 49 | . 50 | * Error handling is "abstract": errors that originate from 51 | implementation specific problems (such as "no more sockets" in 52 | the TCP implementation) get mapped to generic errors 53 | ("insufficient resources") at the Transport level. 54 | . 55 | This package provides the generic interface only; you will 56 | probably also want to install at least one transport 57 | implementation (network-transport-*). 58 | Tested-With: GHC==7.6.3 GHC==7.8.4 GHC==7.10.3 59 | Category: Network 60 | extra-source-files: ChangeLog 61 | 62 | Source-Repository head 63 | Type: git 64 | Location: https://github.com/haskell-distributed/network-transport 65 | 66 | Library 67 | Build-Depends: base >= 4.6 && < 5, 68 | binary >= 0.5 && < 0.9, 69 | bytestring >= 0.9 && < 0.13, 70 | hashable >= 1.2.0.5 && < 1.5, 71 | transformers >= 0.2 && < 0.7, 72 | deepseq >= 1.0 && < 1.6 73 | if impl(ghc < 7.6) 74 | Build-Depends: ghc-prim >= 0.2 && < 0.4 75 | Exposed-Modules: Network.Transport, 76 | Network.Transport.Util 77 | Network.Transport.Internal 78 | Other-Extensions: ForeignFunctionInterface 79 | Default-Extensions: 80 | RankNTypes, 81 | ScopedTypeVariables, 82 | DeriveDataTypeable, 83 | GeneralizedNewtypeDeriving, 84 | CPP 85 | GHC-Options: -Wall -fno-warn-unused-do-bind 86 | HS-Source-Dirs: src 87 | Default-Language: Haskell2010 88 | if os(win32) 89 | extra-libraries: ws2_32 90 | -------------------------------------------------------------------------------- /src/Network/Transport.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | -- | Network Transport 3 | module Network.Transport 4 | ( -- * Types 5 | Transport(..) 6 | , EndPoint(..) 7 | , Connection(..) 8 | , Event(..) 9 | , ConnectionId 10 | , Reliability(..) 11 | , MulticastGroup(..) 12 | , EndPointAddress(..) 13 | , MulticastAddress(..) 14 | -- * Hints 15 | , ConnectHints(..) 16 | , defaultConnectHints 17 | -- * Error codes 18 | , TransportError(..) 19 | , NewEndPointErrorCode(..) 20 | , ConnectErrorCode(..) 21 | , NewMulticastGroupErrorCode(..) 22 | , ResolveMulticastGroupErrorCode(..) 23 | , SendErrorCode(..) 24 | , EventErrorCode(..) 25 | ) where 26 | 27 | import Data.ByteString (ByteString) 28 | import qualified Data.ByteString as BS (copy) 29 | import qualified Data.ByteString.Char8 as BSC (unpack) 30 | import Control.DeepSeq (NFData(rnf)) 31 | import Control.Exception (Exception) 32 | import Data.Typeable (Typeable) 33 | import Data.Binary (Binary(..)) 34 | import Data.Hashable 35 | import Data.Word (Word64) 36 | import Data.Data (Data) 37 | import GHC.Generics (Generic) 38 | 39 | -------------------------------------------------------------------------------- 40 | -- Main API -- 41 | -------------------------------------------------------------------------------- 42 | 43 | -- | To create a network abstraction layer, use one of the 44 | -- @Network.Transport.*@ packages. 45 | data Transport = Transport { 46 | -- | Create a new end point (heavyweight operation) 47 | newEndPoint :: IO (Either (TransportError NewEndPointErrorCode) EndPoint) 48 | -- | Shutdown the transport completely 49 | , closeTransport :: IO () 50 | } 51 | 52 | -- | Network endpoint. 53 | data EndPoint = EndPoint { 54 | -- | Endpoints have a single shared receive queue. 55 | receive :: IO Event 56 | -- | EndPointAddress of the endpoint. 57 | , address :: EndPointAddress 58 | -- | Create a new lightweight connection. 59 | -- 60 | -- 'connect' should be as asynchronous as possible; for instance, in 61 | -- Transport implementations based on some heavy-weight underlying network 62 | -- protocol (TCP, ssh), a call to 'connect' should be asynchronous when a 63 | -- heavyweight connection has already been established. 64 | , connect :: EndPointAddress -> Reliability -> ConnectHints -> IO (Either (TransportError ConnectErrorCode) Connection) 65 | -- | Create a new multicast group. 66 | , newMulticastGroup :: IO (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup) 67 | -- | Resolve an address to a multicast group. 68 | , resolveMulticastGroup :: MulticastAddress -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup) 69 | -- | Close the endpoint 70 | , closeEndPoint :: IO () 71 | } 72 | 73 | -- | Lightweight connection to an endpoint. 74 | data Connection = Connection { 75 | -- | Send a message on this connection. 76 | -- 77 | -- 'send' provides vectored I/O, and allows multiple data segments to be 78 | -- sent using a single call (cf. 'Network.Socket.ByteString.sendMany'). 79 | -- Note that this segment structure is entirely unrelated to the segment 80 | -- structure /returned/ by a 'Received' event. 81 | send :: [ByteString] -> IO (Either (TransportError SendErrorCode) ()) 82 | -- | Close the connection. 83 | , close :: IO () 84 | } 85 | 86 | -- | Event on an endpoint. 87 | data Event = 88 | -- | Received a message 89 | Received {-# UNPACK #-} !ConnectionId [ByteString] 90 | -- | Connection closed 91 | | ConnectionClosed {-# UNPACK #-} !ConnectionId 92 | -- | Connection opened 93 | -- 94 | -- 'ConnectionId's need not be allocated contiguously. 95 | | ConnectionOpened {-# UNPACK #-} !ConnectionId Reliability EndPointAddress 96 | -- | Received multicast 97 | | ReceivedMulticast MulticastAddress [ByteString] 98 | -- | The endpoint got closed (manually, by a call to closeEndPoint or closeTransport) 99 | | EndPointClosed 100 | -- | An error occurred 101 | | ErrorEvent (TransportError EventErrorCode) 102 | deriving (Show, Eq, Generic) 103 | 104 | instance Binary Event 105 | 106 | -- | Connection data ConnectHintsIDs enable receivers to distinguish one connection from another. 107 | type ConnectionId = Word64 108 | 109 | -- | Reliability guarantees of a connection. 110 | data Reliability = 111 | ReliableOrdered 112 | | ReliableUnordered 113 | | Unreliable 114 | deriving (Show, Eq, Typeable, Generic) 115 | 116 | instance Binary Reliability 117 | -- | Multicast group. 118 | data MulticastGroup = MulticastGroup { 119 | -- | EndPointAddress of the multicast group. 120 | multicastAddress :: MulticastAddress 121 | -- | Delete the multicast group completely. 122 | , deleteMulticastGroup :: IO () 123 | -- | Maximum message size that we can send to this group. 124 | , maxMsgSize :: Maybe Int 125 | -- | Send a message to the group. 126 | , multicastSend :: [ByteString] -> IO () 127 | -- | Subscribe to the given multicast group (to start receiving messages from the group). 128 | , multicastSubscribe :: IO () 129 | -- | Unsubscribe from the given multicast group (to stop receiving messages from the group). 130 | , multicastUnsubscribe :: IO () 131 | -- | Close the group (that is, indicate you no longer wish to send to the group). 132 | , multicastClose :: IO () 133 | } 134 | 135 | -- | EndPointAddress of an endpoint. 136 | newtype EndPointAddress = EndPointAddress { endPointAddressToByteString :: ByteString } 137 | deriving (Eq, Ord, Typeable, Data, Hashable) 138 | 139 | instance Binary EndPointAddress where 140 | put = put . endPointAddressToByteString 141 | get = EndPointAddress . BS.copy <$> get 142 | 143 | instance Show EndPointAddress where 144 | show = BSC.unpack . endPointAddressToByteString 145 | 146 | instance NFData EndPointAddress where rnf x = x `seq` () 147 | 148 | -- | EndPointAddress of a multicast group. 149 | newtype MulticastAddress = MulticastAddress { multicastAddressToByteString :: ByteString } 150 | deriving (Eq, Ord, Generic) 151 | 152 | instance Binary MulticastAddress 153 | 154 | instance Show MulticastAddress where 155 | show = show . multicastAddressToByteString 156 | 157 | -------------------------------------------------------------------------------- 158 | -- Hints -- 159 | -- -- 160 | -- Hints provide transport-generic "suggestions". For now, these are -- 161 | -- placeholders only. -- 162 | -------------------------------------------------------------------------------- 163 | 164 | -- | Hints used by 'connect' 165 | data ConnectHints = ConnectHints { 166 | -- Timeout 167 | connectTimeout :: Maybe Int 168 | } 169 | 170 | -- | Default hints for connecting 171 | defaultConnectHints :: ConnectHints 172 | defaultConnectHints = ConnectHints { 173 | connectTimeout = Nothing 174 | } 175 | 176 | -------------------------------------------------------------------------------- 177 | -- Error codes -- 178 | -- -- 179 | -- Errors should be transport-implementation independent. The deciding factor -- 180 | -- for distinguishing one kind of error from another should be: might -- 181 | -- application code have to take a different action depending on the kind of -- 182 | -- error? -- 183 | -------------------------------------------------------------------------------- 184 | 185 | -- | Errors returned by Network.Transport API functions consist of an error 186 | -- code and a human readable description of the problem 187 | data TransportError error = TransportError error String 188 | deriving (Show, Typeable, Generic) 189 | 190 | instance (Binary error) => Binary (TransportError error) 191 | 192 | -- | Although the functions in the transport API never throw TransportErrors 193 | -- (but return them explicitly), application code may want to turn these into 194 | -- exceptions. 195 | instance (Typeable err, Show err) => Exception (TransportError err) 196 | 197 | -- | When comparing errors we ignore the human-readable strings 198 | instance Eq error => Eq (TransportError error) where 199 | TransportError err1 _ == TransportError err2 _ = err1 == err2 200 | 201 | -- | Errors during the creation of an endpoint 202 | data NewEndPointErrorCode = 203 | -- | Not enough resources 204 | NewEndPointInsufficientResources 205 | -- | Failed for some other reason 206 | | NewEndPointFailed 207 | deriving (Show, Typeable, Eq) 208 | 209 | -- | Connection failure 210 | data ConnectErrorCode = 211 | -- | Could not resolve the address 212 | ConnectNotFound 213 | -- | Insufficient resources (for instance, no more sockets available) 214 | | ConnectInsufficientResources 215 | -- | Timeout 216 | | ConnectTimeout 217 | -- | Failed for other reasons (including syntax error) 218 | | ConnectFailed 219 | deriving (Show, Typeable, Eq) 220 | 221 | -- | Failure during the creation of a new multicast group 222 | data NewMulticastGroupErrorCode = 223 | -- | Insufficient resources 224 | NewMulticastGroupInsufficientResources 225 | -- | Failed for some other reason 226 | | NewMulticastGroupFailed 227 | -- | Not all transport implementations support multicast 228 | | NewMulticastGroupUnsupported 229 | deriving (Show, Typeable, Eq) 230 | 231 | -- | Failure during the resolution of a multicast group 232 | data ResolveMulticastGroupErrorCode = 233 | -- | Multicast group not found 234 | ResolveMulticastGroupNotFound 235 | -- | Failed for some other reason (including syntax error) 236 | | ResolveMulticastGroupFailed 237 | -- | Not all transport implementations support multicast 238 | | ResolveMulticastGroupUnsupported 239 | deriving (Show, Typeable, Eq) 240 | 241 | -- | Failure during sending a message 242 | data SendErrorCode = 243 | -- | Connection was closed 244 | SendClosed 245 | -- | Send failed for some other reason 246 | | SendFailed 247 | deriving (Show, Typeable, Eq) 248 | 249 | -- | Error codes used when reporting errors to endpoints (through receive) 250 | data EventErrorCode = 251 | -- | Failure of the entire endpoint 252 | EventEndPointFailed 253 | -- | Transport-wide fatal error 254 | | EventTransportFailed 255 | -- | We lost connection to another endpoint 256 | -- 257 | -- Although "Network.Transport" provides multiple independent lightweight 258 | -- connections between endpoints, those connections cannot /fail/ 259 | -- independently: once one connection has failed, /all/ connections, in 260 | -- both directions, must now be considered to have failed; they fail as a 261 | -- "bundle" of connections, with only a single "bundle" of connections per 262 | -- endpoint at any point in time. 263 | -- 264 | -- That is, suppose there are multiple connections in either direction 265 | -- between endpoints A and B, and A receives a notification that it has 266 | -- lost contact with B. Then A must not be able to send any further 267 | -- messages to B on existing connections. 268 | -- 269 | -- Although B may not realize /immediately/ that its connection to A has 270 | -- been broken, messages sent by B on existing connections should not be 271 | -- delivered, and B must eventually get an EventConnectionLost message, 272 | -- too. 273 | -- 274 | -- Moreover, this event must be posted before A has successfully 275 | -- reconnected (in other words, if B notices a reconnection attempt from A, 276 | -- it must post the EventConnectionLost before acknowledging the connection 277 | -- from A) so that B will not receive events about new connections or 278 | -- incoming messages from A without realizing that it got disconnected. 279 | -- 280 | -- If B attempts to establish another connection to A before it realized 281 | -- that it got disconnected from A then it's okay for this connection 282 | -- attempt to fail, and the EventConnectionLost to be posted at that point, 283 | -- or for the EventConnectionLost to be posted and for the new connection 284 | -- to be considered the first connection of the "new bundle". 285 | | EventConnectionLost EndPointAddress 286 | deriving (Show, Typeable, Eq, Generic) 287 | 288 | instance Binary EventErrorCode 289 | -------------------------------------------------------------------------------- /src/Network/Transport/Internal.hs: -------------------------------------------------------------------------------- 1 | -- | Internal functions 2 | module Network.Transport.Internal 3 | ( -- * Encoders/decoders 4 | encodeWord32 5 | , decodeWord32 6 | , encodeEnum32 7 | , decodeNum32 8 | , encodeWord16 9 | , decodeWord16 10 | , encodeEnum16 11 | , decodeNum16 12 | , prependLength 13 | -- * Miscellaneous abstractions 14 | , mapIOException 15 | , tryIO 16 | , tryToEnum 17 | , timeoutMaybe 18 | , asyncWhenCancelled 19 | -- * Replicated functionality from "base" 20 | , void 21 | , forkIOWithUnmask 22 | -- * Debugging 23 | , tlog 24 | ) where 25 | 26 | #if ! MIN_VERSION_base(4,6,0) 27 | import Prelude hiding (catch) 28 | #endif 29 | 30 | import Foreign.Storable (pokeByteOff, peekByteOff) 31 | import Foreign.ForeignPtr (withForeignPtr) 32 | import Data.ByteString (ByteString) 33 | import Data.List (foldl') 34 | import qualified Data.ByteString as BS (length) 35 | import qualified Data.ByteString.Internal as BSI 36 | ( unsafeCreate 37 | , toForeignPtr 38 | ) 39 | import Data.Word (Word32, Word16) 40 | import Control.Monad.IO.Class (MonadIO, liftIO) 41 | import Control.Exception 42 | ( IOException 43 | , SomeException 44 | , AsyncException 45 | , Exception 46 | , catch 47 | , try 48 | , throw 49 | , throwIO 50 | , mask_ 51 | ) 52 | import Control.Concurrent (ThreadId, forkIO) 53 | import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar) 54 | import GHC.IO (unsafeUnmask) 55 | import System.IO.Unsafe (unsafeDupablePerformIO) 56 | import System.Timeout (timeout) 57 | --import Control.Concurrent (myThreadId) 58 | 59 | #ifdef mingw32_HOST_OS 60 | 61 | foreign import stdcall unsafe "htonl" htonl :: Word32 -> Word32 62 | foreign import stdcall unsafe "ntohl" ntohl :: Word32 -> Word32 63 | foreign import stdcall unsafe "htons" htons :: Word16 -> Word16 64 | foreign import stdcall unsafe "ntohs" ntohs :: Word16 -> Word16 65 | 66 | #else 67 | 68 | foreign import ccall unsafe "htonl" htonl :: Word32 -> Word32 69 | foreign import ccall unsafe "ntohl" ntohl :: Word32 -> Word32 70 | foreign import ccall unsafe "htons" htons :: Word16 -> Word16 71 | foreign import ccall unsafe "ntohs" ntohs :: Word16 -> Word16 72 | 73 | #endif 74 | 75 | -- | Serialize 32-bit to network byte order 76 | encodeWord32 :: Word32 -> ByteString 77 | encodeWord32 w32 = 78 | BSI.unsafeCreate 4 $ \p -> 79 | pokeByteOff p 0 (htonl w32) 80 | 81 | -- | Deserialize 32-bit from network byte order 82 | -- Throws an IO exception if this is not exactly 32 bits. 83 | decodeWord32 :: ByteString -> Word32 84 | decodeWord32 bs 85 | | BS.length bs /= 4 = throw $ userError "decodeWord32: not 4 bytes" 86 | | otherwise = unsafeDupablePerformIO $ do 87 | let (fp, offset, _) = BSI.toForeignPtr bs 88 | withForeignPtr fp $ \p -> ntohl <$> peekByteOff p offset 89 | 90 | -- | Serialize 16-bit to network byte order 91 | encodeWord16 :: Word16 -> ByteString 92 | encodeWord16 w16 = 93 | BSI.unsafeCreate 2 $ \p -> 94 | pokeByteOff p 0 (htons w16) 95 | 96 | -- | Deserialize 16-bit from network byte order 97 | -- Throws an IO exception if this is not exactly 16 bits. 98 | decodeWord16 :: ByteString -> Word16 99 | decodeWord16 bs 100 | | BS.length bs /= 2 = throw $ userError "decodeWord16: not 2 bytes" 101 | | otherwise = unsafeDupablePerformIO $ do 102 | let (fp, offset, _) = BSI.toForeignPtr bs 103 | withForeignPtr fp $ \p -> ntohs <$> peekByteOff p offset 104 | 105 | -- | Encode an Enum in 32 bits by encoding its signed Int equivalent (beware 106 | -- of truncation, an Enum may contain more than 2^32 points). 107 | encodeEnum32 :: Enum a => a -> ByteString 108 | encodeEnum32 = encodeWord32 . fromIntegral . fromEnum 109 | 110 | -- | Decode any Num type from 32 bits by using fromIntegral to convert from 111 | -- a Word32. 112 | decodeNum32 :: Num a => ByteString -> a 113 | decodeNum32 = fromIntegral . decodeWord32 114 | 115 | -- | Encode an Enum in 16 bits by encoding its signed Int equivalent (beware 116 | -- of truncation, an Enum may contain more than 2^16 points). 117 | encodeEnum16 :: Enum a => a -> ByteString 118 | encodeEnum16 = encodeWord16 . fromIntegral . fromEnum 119 | 120 | -- | Decode any Num type from 16 bits by using fromIntegral to convert from 121 | -- a Word16. 122 | decodeNum16 :: Num a => ByteString -> a 123 | decodeNum16 = fromIntegral . decodeWord16 124 | 125 | -- | Prepend a list of bytestrings with their total length 126 | -- Will be an exception in case of overflow: the sum of the lengths of 127 | -- the ByteStrings overflows Int, or that sum overflows Word32. 128 | prependLength :: [ByteString] -> [ByteString] 129 | prependLength bss = case word32Length of 130 | Nothing -> overflow 131 | Just w32 -> encodeWord32 w32 : bss 132 | where 133 | intLength :: Int 134 | intLength = foldl' safeAdd 0 . map BS.length $ bss 135 | word32Length :: Maybe Word32 136 | word32Length = tryToEnum intLength 137 | -- Non-negative integer addition with overflow check. 138 | safeAdd :: Int -> Int -> Int 139 | safeAdd i j 140 | | r >= 0 = r 141 | | otherwise = overflow 142 | where 143 | r = i + j 144 | overflow = throw $ userError "prependLength: input is too long (overflow)" 145 | 146 | -- | Translate exceptions that arise in IO computations 147 | mapIOException :: Exception e => (IOException -> e) -> IO a -> IO a 148 | mapIOException f p = catch p (throwIO . f) 149 | 150 | -- | Like 'try', but lifted and specialized to IOExceptions 151 | tryIO :: MonadIO m => IO a -> m (Either IOException a) 152 | tryIO = liftIO . try 153 | 154 | -- | Logging (for debugging) 155 | tlog :: MonadIO m => String -> m () 156 | tlog _ = return () 157 | {- 158 | tlog msg = liftIO $ do 159 | tid <- myThreadId 160 | putStrLn $ show tid ++ ": " ++ msg 161 | -} 162 | 163 | -- | Not all versions of "base" export 'void' 164 | void :: Monad m => m a -> m () 165 | void p = p >> return () 166 | 167 | -- | This was introduced in "base" some time after 7.0.4 168 | forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId 169 | forkIOWithUnmask io = forkIO (io unsafeUnmask) 170 | 171 | -- | Safe version of 'toEnum' 172 | tryToEnum :: (Enum a, Bounded a) => Int -> Maybe a 173 | tryToEnum = go minBound maxBound 174 | where 175 | go :: Enum b => b -> b -> Int -> Maybe b 176 | go lo hi n = if fromEnum lo <= n && n <= fromEnum hi then Just (toEnum n) else Nothing 177 | 178 | -- | If the timeout value is not Nothing, wrap the given computation with a 179 | -- timeout and it if times out throw the specified exception. Identity 180 | -- otherwise. 181 | timeoutMaybe :: Exception e => Maybe Int -> e -> IO a -> IO a 182 | timeoutMaybe Nothing _ f = f 183 | timeoutMaybe (Just n) e f = do 184 | ma <- timeout n f 185 | case ma of 186 | Nothing -> throwIO e 187 | Just a -> return a 188 | 189 | -- | @asyncWhenCancelled g f@ runs f in a separate thread and waits for it 190 | -- to complete. If f throws an exception we catch it and rethrow it in the 191 | -- current thread. If the current thread is interrupted before f completes, 192 | -- we run the specified clean up handler (if f throws an exception we assume 193 | -- that no cleanup is necessary). 194 | asyncWhenCancelled :: forall a. (a -> IO ()) -> IO a -> IO a 195 | asyncWhenCancelled g f = mask_ $ do 196 | mvar <- newEmptyMVar 197 | forkIO $ try f >>= putMVar mvar 198 | -- takeMVar is interruptible (even inside a mask_) 199 | catch (takeMVar mvar) (exceptionHandler mvar) >>= either throwIO return 200 | where 201 | exceptionHandler :: MVar (Either SomeException a) 202 | -> AsyncException 203 | -> IO (Either SomeException a) 204 | exceptionHandler mvar ex = do 205 | forkIO $ takeMVar mvar >>= either (const $ return ()) g 206 | throwIO ex 207 | -------------------------------------------------------------------------------- /src/Network/Transport/Util.hs: -------------------------------------------------------------------------------- 1 | -- | Utility functions 2 | -- 3 | -- Note: this module is bound to change even more than the rest of the API :) 4 | module Network.Transport.Util (spawn) where 5 | 6 | import Network.Transport 7 | ( Transport 8 | , EndPoint(..) 9 | , EndPointAddress 10 | , newEndPoint 11 | ) 12 | import Control.Exception (throwIO) 13 | import Control.Concurrent (forkIO) 14 | import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) 15 | 16 | -- | Fork a new thread, create a new end point on that thread, and run the specified IO operation on that thread. 17 | -- 18 | -- Returns the address of the new end point. 19 | spawn :: Transport -> (EndPoint -> IO ()) -> IO EndPointAddress 20 | spawn transport proc = do 21 | addrMVar <- newEmptyMVar 22 | forkIO $ do 23 | mEndPoint <- newEndPoint transport 24 | case mEndPoint of 25 | Left err -> 26 | putMVar addrMVar (Left err) 27 | Right endPoint -> do 28 | putMVar addrMVar (Right (address endPoint)) 29 | proc endPoint 30 | mAddr <- takeMVar addrMVar 31 | case mAddr of 32 | Left err -> throwIO err 33 | Right addr -> return addr 34 | -------------------------------------------------------------------------------- /tests/chat/ChatClient.hs: -------------------------------------------------------------------------------- 1 | import System.Environment (getArgs) 2 | import Network.Transport 3 | import Network.Transport.TCP (createTransport) 4 | import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar, newMVar, readMVar, modifyMVar_, modifyMVar) 5 | import Control.Concurrent (forkIO) 6 | import Control.Monad (forever, forM, unless, when) 7 | import qualified Data.ByteString as BS (concat, null) 8 | import qualified Data.ByteString.Char8 as BSC (pack, unpack, getLine) 9 | import Data.Map (Map) 10 | import qualified Data.Map as Map (fromList, elems, insert, member, empty, size, delete, (!)) 11 | 12 | chatClient :: MVar () -> EndPoint -> EndPointAddress -> IO () 13 | chatClient done endpoint serverAddr = do 14 | connect endpoint serverAddr ReliableOrdered 15 | cOut <- getPeers >>= connectToPeers 16 | cIn <- newMVar Map.empty 17 | 18 | -- Listen for incoming messages 19 | forkIO . forever $ do 20 | event <- receive endpoint 21 | case event of 22 | Received _ msg -> 23 | putStrLn . BSC.unpack . BS.concat $ msg 24 | ConnectionOpened cid _ addr -> do 25 | modifyMVar_ cIn $ return . Map.insert cid addr 26 | didAdd <- modifyMVar cOut $ \conns -> 27 | if not (Map.member addr conns) 28 | then do 29 | Right conn <- connect endpoint addr ReliableOrdered 30 | return (Map.insert addr conn conns, True) 31 | else 32 | return (conns, False) 33 | when didAdd $ showNumPeers cOut 34 | ConnectionClosed cid -> do 35 | addr <- modifyMVar cIn $ \conns -> 36 | return (Map.delete cid conns, conns Map.! cid) 37 | modifyMVar_ cOut $ \conns -> do 38 | close (conns Map.! addr) 39 | return (Map.delete addr conns) 40 | showNumPeers cOut 41 | 42 | 43 | 44 | {- 45 | chatState <- newMVar (Map.fromList peerConns) 46 | 47 | -- Thread to listen to incoming messages 48 | forkIO . forever $ do 49 | event <- receive endpoint 50 | case event of 51 | ConnectionOpened _ _ (EndPointAddress addr) -> do 52 | modifyMVar_ chatState $ \peers -> 53 | if not (Map.member addr peers) 54 | then do 55 | Right conn <- connect endpoint (EndPointAddress addr) ReliableOrdered 56 | return (Map.insert addr conn peers) 57 | else 58 | return peers 59 | Received _ msg -> 60 | putStrLn . BSC.unpack . BS.concat $ msg 61 | ConnectionClosed _ -> 62 | return () 63 | 64 | -} 65 | -- Thread to interact with the user 66 | showNumPeers cOut 67 | let go = do 68 | msg <- BSC.getLine 69 | unless (BS.null msg) $ do 70 | readMVar cOut >>= \conns -> forM (Map.elems conns) $ \conn -> send conn [msg] 71 | go 72 | go 73 | putMVar done () 74 | 75 | where 76 | getPeers :: IO [EndPointAddress] 77 | getPeers = do 78 | ConnectionOpened _ _ _ <- receive endpoint 79 | Received _ msg <- receive endpoint 80 | ConnectionClosed _ <- receive endpoint 81 | return . map EndPointAddress . read . BSC.unpack . BS.concat $ msg 82 | 83 | connectToPeers :: [EndPointAddress] -> IO (MVar (Map EndPointAddress Connection)) 84 | connectToPeers addrs = do 85 | conns <- forM addrs $ \addr -> do 86 | Right conn <- connect endpoint addr ReliableOrdered 87 | return (addr, conn) 88 | newMVar (Map.fromList conns) 89 | 90 | showNumPeers :: MVar (Map EndPointAddress Connection) -> IO () 91 | showNumPeers cOut = 92 | readMVar cOut >>= \conns -> putStrLn $ "# " ++ show (Map.size conns) ++ " peers" 93 | 94 | 95 | 96 | 97 | main :: IO () 98 | main = do 99 | host:port:server:_ <- getArgs 100 | Right transport <- createTransport host port 101 | Right endpoint <- newEndPoint transport 102 | clientDone <- newEmptyMVar 103 | 104 | forkIO $ chatClient clientDone endpoint (EndPointAddress . BSC.pack $ server) 105 | 106 | takeMVar clientDone 107 | 108 | -------------------------------------------------------------------------------- /tests/chat/ChatServer.hs: -------------------------------------------------------------------------------- 1 | import System.Environment (getArgs) 2 | import Network.Transport 3 | import Network.Transport.TCP (createTransport) 4 | import Control.Monad.State (evalStateT, modify, get) 5 | import Control.Monad (forever) 6 | import Control.Monad.IO.Class (liftIO) 7 | import qualified Data.IntMap as IntMap (empty, insert, delete, elems) 8 | import qualified Data.ByteString.Char8 as BSC (pack) 9 | 10 | main :: IO () 11 | main = do 12 | host:port:_ <- getArgs 13 | Right transport <- createTransport host port 14 | Right endpoint <- newEndPoint transport 15 | 16 | putStrLn $ "Chat server ready at " ++ (show . endPointAddressToByteString . address $ endpoint) 17 | 18 | flip evalStateT IntMap.empty . forever $ do 19 | event <- liftIO $ receive endpoint 20 | case event of 21 | ConnectionOpened cid _ addr -> do 22 | get >>= \clients -> liftIO $ do 23 | Right conn <- connect endpoint addr ReliableOrdered 24 | send conn [BSC.pack . show . IntMap.elems $ clients] 25 | close conn 26 | modify $ IntMap.insert cid (endPointAddressToByteString addr) 27 | ConnectionClosed cid -> 28 | modify $ IntMap.delete cid 29 | -------------------------------------------------------------------------------- /tests/sumeuler/SumEulerMaster.hs: -------------------------------------------------------------------------------- 1 | import System.Environment (getArgs) 2 | import Network.Transport 3 | import Network.Transport.TCP (createTransport) 4 | import Control.Concurrent (forkIO) 5 | import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) 6 | import Control.Monad (forM, forM_, replicateM_) 7 | import qualified Data.ByteString as BS (concat) 8 | import qualified Data.ByteString.Char8 as BSC (pack, unpack) 9 | import Control.Monad.Trans.Writer (execWriterT, tell) 10 | import Control.Monad.IO.Class (liftIO) 11 | 12 | master :: MVar () -> EndPoint -> [String] -> IO () 13 | master done endpoint workers = do 14 | conns <- forM workers $ \worker -> do 15 | Right conn <- connect endpoint (EndPointAddress $ BSC.pack worker) ReliableOrdered 16 | return conn 17 | -- Send out requests 18 | forM_ conns $ \conn -> do 19 | send conn [BSC.pack $ show 5300] 20 | close conn 21 | -- Print all replies 22 | replies <- execWriterT $ replicateM_ (length workers * 3) $ do 23 | event <- liftIO $ receive endpoint 24 | case event of 25 | Received _ msg -> 26 | tell [read . BSC.unpack . BS.concat $ msg] 27 | _ -> 28 | return () 29 | putStrLn $ "Replies: " ++ show (replies :: [Int]) 30 | putMVar done () 31 | 32 | main :: IO () 33 | main = do 34 | host:port:workers <- getArgs 35 | Right transport <- createTransport host port 36 | Right endpoint <- newEndPoint transport 37 | masterDone <- newEmptyMVar 38 | 39 | putStrLn $ "Master using workers " ++ show workers 40 | 41 | forkIO $ master masterDone endpoint workers 42 | 43 | takeMVar masterDone 44 | 45 | -------------------------------------------------------------------------------- /tests/sumeuler/SumEulerWorker.hs: -------------------------------------------------------------------------------- 1 | import System.Environment (getArgs) 2 | import Network.Transport 3 | import Network.Transport.TCP (createTransport) 4 | import qualified Data.ByteString.Char8 as BSC (putStrLn, pack, unpack) 5 | import qualified Data.ByteString as BS (concat) 6 | import Control.Concurrent (forkIO) 7 | import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) 8 | import System.IO (hFlush, stdout, stderr, hPutStrLn) 9 | 10 | mkList :: Int -> [Int] 11 | mkList n = [1 .. n - 1] 12 | 13 | relPrime :: Int -> Int -> Bool 14 | relPrime x y = gcd x y == 1 15 | 16 | euler :: Int -> Int 17 | euler n = length (filter (relPrime n) (mkList n)) 18 | 19 | sumEuler :: Int -> Int 20 | sumEuler = sum . (map euler) . mkList 21 | 22 | worker :: String -> MVar () -> EndPoint -> IO () 23 | worker id done endpoint = do 24 | ConnectionOpened _ _ theirAddr <- receive endpoint 25 | Right replyChan <- connect endpoint theirAddr ReliableOrdered 26 | go replyChan 27 | where 28 | go replyChan = do 29 | event <- receive endpoint 30 | case event of 31 | ConnectionClosed _ -> do 32 | close replyChan 33 | putMVar done () 34 | Received _ msg -> do 35 | let i :: Int 36 | i = read . BSC.unpack . BS.concat $ msg 37 | send replyChan [BSC.pack . show $ sumEuler i] 38 | go replyChan 39 | 40 | main :: IO () 41 | main = do 42 | (id:host:port:_) <- getArgs 43 | Right transport <- createTransport host port 44 | Right endpoint <- newEndPoint transport 45 | workerDone <- newEmptyMVar 46 | 47 | BSC.putStrLn (endPointAddressToByteString (address endpoint)) 48 | hFlush stdout 49 | 50 | forkIO $ worker id workerDone endpoint 51 | 52 | takeMVar workerDone 53 | -------------------------------------------------------------------------------- /tests/sumeuler/sumeuler.sh: -------------------------------------------------------------------------------- 1 | #/bin/bash 2 | 3 | rm -f workers 4 | killall -9 SumEulerWorker 5 | 6 | ghc -O2 -i../src -XScopedTypeVariables SumEulerWorker 7 | ghc -O2 -i../src -XScopedTypeVariables SumEulerMaster 8 | 9 | ./SumEulerWorker 1 127.0.0.1 8080 >> workers & 10 | ./SumEulerWorker 1 127.0.0.1 8081 >> workers & 11 | ./SumEulerWorker 1 127.0.0.1 8082 >> workers & 12 | ./SumEulerWorker 1 127.0.0.1 8083 >> workers & 13 | ./SumEulerWorker 1 127.0.0.1 8084 >> workers & 14 | ./SumEulerWorker 1 127.0.0.1 8085 >> workers & 15 | ./SumEulerWorker 1 127.0.0.1 8086 >> workers & 16 | ./SumEulerWorker 1 127.0.0.1 8087 >> workers & 17 | 18 | echo "Waiting for all workers to be ready" 19 | sleep 1 20 | cat workers | xargs ./SumEulerMaster 127.0.0.1 8090 21 | --------------------------------------------------------------------------------