883830f · distributed-process

git.iko.soy/distributed-process

on master help sign in

Remove trailing whitespace

883830fEdsko de Vries14 years ago

azure-service-api/src/Network/Azure/ServiceManagement.hs+35−35

compare with master

unifiedsplit

@@ -1,5 +1,5 @@

1{-# LANGUAGE Arrows #-}

2−module Network.Azure.ServiceManagement

2+module Network.Azure.ServiceManagement

3 ( -- * Data types

4 CloudService

5 , cloudServiceName

@@ -13,12 +13,12 @@ module Network.Azure.ServiceManagement

13 , endpointPort

14 , endpointVip

15 -- * Pure functions

16− , vmSshEndpoint

16+ , vmSshEndpoint

17 -- * Setup

18 , AzureSetup(..)

19 , azureSetup

20 -- * High-level API

21− , cloudServices

21+ , cloudServices

22 ) where

24import Prelude hiding (id, (.))

@@ -40,7 +40,7 @@ import qualified Crypto.Types.PubKey.RSA as RSA (PrivateKey(..))

40import Control.Monad.Trans.Resource (ResourceT)

41import Control.Monad.IO.Class (liftIO)

42import Control.Arrow.ArrowList (listA, arr2A)

43−import Text.PrettyPrint

43+import Text.PrettyPrint

44 ( Doc

45 , text

46 , (<+>)

@@ -49,7 +49,7 @@ import Text.PrettyPrint

49 , hang

50 , doubleQuotes

51 )

52−import Network.HTTP.Conduit

52+import Network.HTTP.Conduit

53 ( parseUrl

54 , clientCertificates

55 , requestHeaders

@@ -59,7 +59,7 @@ import Network.HTTP.Conduit

59 , Manager

60 )

61import Data.CaseInsensitive as CI (mk)

62−import Text.XML.HXT.Core

62+import Text.XML.HXT.Core

63 ( runX

64 , readString

65 , withValidate

@@ -75,25 +75,25 @@ import Text.XML.HXT.XPath (getXPathTrees)

75-- Data types --

76--------------------------------------------------------------------------------

78−data HostedService = HostedService {

78+data HostedService = HostedService {

79− hostedServiceName :: String

79+ hostedServiceName :: String

80 }

82-- | A cloud service is a bunch of virtual machines that are part of the same

83−-- network (i.e., can talk to each other directly using standard TCP

83+-- network (i.e., can talk to each other directly using standard TCP

84-- connections).

85data CloudService = CloudService {

86 -- | Name of the service.

87− cloudServiceName :: String

87+ cloudServiceName :: String

88 -- | Virtual machines that are part of this cloud service.

89 , cloudServiceVMs :: [VirtualMachine]

90 }

92-- | Virtual machine

93−data VirtualMachine = VirtualMachine {

93+data VirtualMachine = VirtualMachine {

94 -- | Name of the virtual machine.

95 vmName :: String

96− -- | The /internal/ IP address of the virtual machine (that is, the

96+ -- | The /internal/ IP address of the virtual machine (that is, the

97 -- IP address on the Cloud Service). For the globally accessible IP

98 -- address see 'vmInputEndpoints'.

99 , vmIpAddress :: String

@@ -105,12 +105,12 @@ data VirtualMachine = VirtualMachine {

105data Endpoint = Endpoint {

106 -- | Name of the endpoint (typical example: @SSH@)

107 endpointName :: String

108− -- | Port number (typical examples are 22 or high numbered ports such as 53749)

108+ -- | Port number (typical examples are 22 or high numbered ports such as 53749)

109− , endpointPort :: String

109+ , endpointPort :: String

110 -- | Virtual IP address (that is, globally accessible IP address).

111 --

112 -- This corresponds to the IP address associated with the Cloud Service

113− -- (i.e., that would be returned by a DNS lookup for @name.cloudapp.net@,

113+ -- (i.e., that would be returned by a DNS lookup for @name.cloudapp.net@,

114 -- where @name@ is the name of the Cloud Service).

115 , endpointVip :: String

116 }

@@ -119,7 +119,7 @@ data Endpoint = Endpoint {

119-- Pretty-printing --

120--------------------------------------------------------------------------------

121

122−instance Show HostedService where

122+instance Show HostedService where

123 show = show . ppHostedService

124

125instance Show CloudService where

@@ -136,7 +136,7 @@ ppHostedService = text . hostedServiceName

136

137ppCloudService :: CloudService -> Doc

138ppCloudService cs =

139− (text "Cloud Service" <+> (doubleQuotes . text . cloudServiceName $ cs))

139+ (text "Cloud Service" <+> (doubleQuotes . text . cloudServiceName $ cs))

140 `hang2`

141 ( text "VIRTUAL MACHINES"

142 `hang2`

@@ -144,7 +144,7 @@ ppCloudService cs =

144 )

145

146ppVirtualMachine :: VirtualMachine -> Doc

147−ppVirtualMachine vm =

147+ppVirtualMachine vm =

148 (text "Virtual Machine" <+> (doubleQuotes . text . vmName $ vm))

149 `hang2`

150 ( text "IP" <+> text (vmIpAddress vm)

@@ -155,7 +155,7 @@ ppVirtualMachine vm =

155 )

156

157ppEndpoint :: Endpoint -> Doc

158−ppEndpoint ep =

158+ppEndpoint ep =

159 (text "Input endpoint" <+> (doubleQuotes . text . endpointName $ ep))

160 `hang2`

161 ( text "Port" <+> text (endpointPort ep)

@@ -171,7 +171,7 @@ hang2 d1 = hang d1 2

171

172-- | Find the endpoint with name @SSH@.

173vmSshEndpoint :: VirtualMachine -> Maybe Endpoint

174−vmSshEndpoint vm = listToMaybe

174+vmSshEndpoint vm = listToMaybe

175 [ ep

176 | ep <- vmInputEndpoints vm

177 , endpointName ep == "SSH"

@@ -181,7 +181,7 @@ vmSshEndpoint vm = listToMaybe

181-- Setup --

182--------------------------------------------------------------------------------

183

184−-- | Azure setup

184+-- | Azure setup

185--

186-- The documentation of "distributed-process-azure" explains in detail how

187-- to obtain the SSL client certificate and the private key for your Azure

@@ -201,7 +201,7 @@ data AzureSetup = AzureSetup

201

202-- TODO: it's dubious to be transferring private keys, but we transfer them

203-- over a secure connection and it can be argued that it's safer than actually

204−-- storing the private key on each remote server

204+-- storing the private key on each remote server

205

206encodePrivateKey :: PrivateKey -> ByteString

207encodePrivateKey (PrivRSA pkey) = runPut $ do

@@ -215,10 +215,10 @@ encodePrivateKey (PrivRSA pkey) = runPut $ do

215 put (RSA.private_qinv pkey)

216

217decodePrivateKey :: ByteString -> PrivateKey

218−decodePrivateKey = PrivRSA . runGet getPrivateKey

218+decodePrivateKey = PrivRSA . runGet getPrivateKey

219 where

220 getPrivateKey :: Get RSA.PrivateKey

221− getPrivateKey =

221+ getPrivateKey =

222 RSA.PrivateKey <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get

223

224instance Binary AzureSetup where

@@ -226,7 +226,7 @@ instance Binary AzureSetup where

226 put sid

227 put (encodeCertificate cert)

228 put (encodePrivateKey pkey)

229− put url

229+ put url

230 get = do

231 sid <- get

232 Right cert <- decodeCertificate <$> get

@@ -253,13 +253,13 @@ azureSetup sid certPath pkeyPath = do

253-- High-level API --

254--------------------------------------------------------------------------------

255

256−-- | Find available cloud services

256+-- | Find available cloud services

257cloudServices :: AzureSetup -> IO [CloudService]

258cloudServices setup = azureExecute setup $ \exec -> do

259 services <- exec hostedServicesRequest

260 forM services $ \service -> do

261 roles <- exec AzureRequest {

262− relativeUrl = "/services/hostedservices/" ++ hostedServiceName service

262+ relativeUrl = "/services/hostedservices/" ++ hostedServiceName service

263 ++ "?embed-detail=true"

264 , apiVersion = "2012-03-01"

265 , parser = proc xml -> do

@@ -273,15 +273,15 @@ cloudServices setup = azureExecute setup $ \exec -> do

273 return $ CloudService (hostedServiceName service) roles

274

275hostedServicesRequest :: AzureRequest HostedService

276−hostedServicesRequest = AzureRequest

276+hostedServicesRequest = AzureRequest

277 { relativeUrl = "/services/hostedservices"

278 , apiVersion = "2012-03-01"

279− , parser = arr HostedService

279+ , parser = arr HostedService

280− . getText

280+ . getText

281 . getXPathTrees "//ServiceName/text()"

282 }

283

284−parseEndpoint :: ArrowXml t => t XmlTree Endpoint

284+parseEndpoint :: ArrowXml t => t XmlTree Endpoint

285parseEndpoint = proc endpoint -> do

286 name <- getText . getXPathTrees "//Name/text()" -< endpoint

287 port <- getText . getXPathTrees "//Port/text()" -< endpoint

@@ -299,12 +299,12 @@ data AzureRequest c = AzureRequest {

299 }

300

301azureExecute :: AzureSetup -> ((forall b. AzureRequest b -> ResourceT IO [b]) -> ResourceT IO a) -> IO a

302−azureExecute setup f = withManager (\manager -> f (go manager))

302+azureExecute setup f = withManager (\manager -> f (go manager))

303 where

304 go :: Manager -> forall b. AzureRequest b -> ResourceT IO [b]

305 go manager request = do

306− req <- parseUrl $ baseUrl setup

306+ req <- parseUrl $ baseUrl setup

307− ++ "/" ++ subscriptionId setup

307+ ++ "/" ++ subscriptionId setup

308 ++ "/" ++ relativeUrl request

309 let req' = req {

310 clientCertificates = [ (certificate setup, Just $ privateKey setup) ]

@@ -312,7 +312,7 @@ azureExecute setup f = withManager (\manager -> f (go manager))

312 , (CI.mk $ BSC.pack "content-type", BSC.pack "application/xml")

313 ]

314 }

315− Response _ _ _ lbs <- httpLbs req' manager

315+ Response _ _ _ lbs <- httpLbs req' manager

316 liftIO . runX $ proc _ -> do

317 xml <- readString [withValidate no] (BSLC.unpack lbs) -< ()

318 -- arrIO putStrLn . writeDocumentToString [withIndent yes] -< xml

distributed-process-azure/demos/Echo.hs+8−8

@@ -5,12 +5,12 @@ import System.Environment (getArgs)

5import Control.Monad (unless, forever)

6import Control.Monad.IO.Class (liftIO)

7import Control.Distributed.Process (Process, expect)

8−import Control.Distributed.Process.Closure (remotable, mkClosure)

8+import Control.Distributed.Process.Closure (remotable, mkClosure)

9−import Control.Distributed.Process.Backend.Azure

9+import Control.Distributed.Process.Backend.Azure

11echoRemote :: () -> Backend -> Process ()

12echoRemote () _backend = forever $ do

13− str <- expect

13+ str <- expect

14 remoteSend (str :: String)

16remotable ['echoRemote]

@@ -29,21 +29,21 @@ main :: IO ()

29main = do

30 args <- getArgs

31 case args of

32− "onvm":args' ->

32+ "onvm":args' ->

33 -- Pass execution to 'onVmMain' if we are running on the VM

34 -- ('callOnVM' will provide the right arguments)

35 onVmMain __remoteTable args'

37 sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do

38 -- Initialize the Azure backend

39− params <- defaultAzureParameters sid x509 pkey

39+ params <- defaultAzureParameters sid x509 pkey

40 let params' = params { azureSshUserName = user }

41 backend <- initializeBackend params' cloudService

43 -- Find the specified virtual machine

44 Just vm <- findNamedVM backend virtualMachine

45−

45+

46 -- Run the echo client proper

47 callOnVM backend vm port $

48− ProcessPair ($(mkClosure 'echoRemote) ())

48+ ProcessPair ($(mkClosure 'echoRemote) ())

49− echoLocal

49+ echoLocal

distributed-process-azure/demos/Fib.hs+8−8

@@ -13,8 +13,8 @@ import Control.Distributed.Process

13 , receiveChan

14 , spawnLocal

15 )

16−import Control.Distributed.Process.Backend.Azure

16+import Control.Distributed.Process.Backend.Azure

17−import Control.Distributed.Process.Closure

17+import Control.Distributed.Process.Closure

18 ( remotable

19 , remotableDecl

20 , mkClosure

@@ -25,7 +25,7 @@ randomElement xs = do

25 ix <- randomIO

26 return (xs !! (ix `mod` length xs))

28−remotableDecl [

28+remotableDecl [

29 [d| dfib :: ([NodeId], SendPort Integer, Integer) -> Process () ;

30 dfib (_, reply, 0) = sendChan reply 0

31 dfib (_, reply, 1) = sendChan reply 1

@@ -54,7 +54,7 @@ remotable ['remoteFib]

54printResult :: LocalProcess ()

55printResult = do

56 result <- localExpect :: LocalProcess Integer

57− liftIO $ print result

57+ liftIO $ print result

59main :: IO ()

60main = do

@@ -62,13 +62,13 @@ main = do

62 case args of

63 "onvm":args' -> onVmMain (__remoteTable . __remoteTableDecl) args'

64 [sid, x509, pkey, user, cloudService, n] -> do

65− params <- defaultAzureParameters sid x509 pkey

65+ params <- defaultAzureParameters sid x509 pkey

66 let params' = params { azureSshUserName = user }

67 backend <- initializeBackend params' cloudService

68 vms <- findVMs backend

69 nids <- forM vms $ \vm -> spawnNodeOnVM backend vm "8080"

70− callOnVM backend (head vms) "8081" $

70+ callOnVM backend (head vms) "8081" $

71− ProcessPair ($(mkClosure 'remoteFib) (nids, read n :: Integer))

71+ ProcessPair ($(mkClosure 'remoteFib) (nids, read n :: Integer))

72− printResult

72+ printResult

73 _ ->

74 error "Invalid command line arguments"

distributed-process-azure/demos/Ping.hs+21−21

@@ -5,7 +5,7 @@ import Data.Binary (encode, decode)

5import Control.Monad (forever)

6import Control.Monad.IO.Class (liftIO)

7import Control.Exception (try, IOException)

8−import Control.Distributed.Process

8+import Control.Distributed.Process

9 ( Process

10 , getSelfPid

11 , expect

@@ -15,30 +15,30 @@ import Control.Distributed.Process

15 , match

16 , ProcessMonitorNotification(..)

17 )

18−import Control.Distributed.Process.Closure (remotable, mkClosure)

18+import Control.Distributed.Process.Closure (remotable, mkClosure)

19−import Control.Distributed.Process.Backend.Azure

19+import Control.Distributed.Process.Backend.Azure

20−import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)

20+import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)

22pingServer :: () -> Backend -> Process ()

23pingServer () _backend = do

24 us <- getSelfPid

25 liftIO $ BSL.writeFile "pingServer.pid" (encode us)

26− forever $ do

26+ forever $ do

27 them <- expect

28 send them ()

30−pingClientRemote :: () -> Backend -> Process ()

30+pingClientRemote :: () -> Backend -> Process ()

31pingClientRemote () _backend = do

32 mPingServerEnc <- liftIO $ try (BSL.readFile "pingServer.pid")

33 case mPingServerEnc of

34− Left err ->

34+ Left err ->

35 remoteSend $ "Ping server not found: " ++ show (err :: IOException)

36− Right pingServerEnc -> do

36+ Right pingServerEnc -> do

37 let pingServerPid = decode pingServerEnc

38 pid <- getSelfPid

39− _ref <- monitor pingServerPid

39+ _ref <- monitor pingServerPid

40 send pingServerPid pid

41− gotReply <- receiveWait

41+ gotReply <- receiveWait

42 [ match (\() -> return True)

43 , match (\(ProcessMonitorNotification {}) -> return False)

44 ]

@@ -49,26 +49,26 @@ pingClientRemote () _backend = do

49remotable ['pingClientRemote, 'pingServer]

51pingClientLocal :: LocalProcess ()

52−pingClientLocal = localExpect >>= liftIO . putStrLn

52+pingClientLocal = localExpect >>= liftIO . putStrLn

54main :: IO ()

55main = do

56 args <- getArgs

57 case args of

58− "onvm":args' ->

58+ "onvm":args' ->

59 -- Pass execution to 'onVmMain' if we are running on the VM

60 onVmMain __remoteTable args'

62 "list":sid:x509:pkey:_ -> do

63 -- List all available cloud services

64 -- (useful, but not strictly necessary for the example)

65− params <- defaultAzureParameters sid x509 pkey

65+ params <- defaultAzureParameters sid x509 pkey

66 css <- cloudServices (azureSetup params)

67 mapM_ print css

69 cmd:sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do

70− -- Initialize the backend and find the right VM

70+ -- Initialize the backend and find the right VM

71− params <- defaultAzureParameters sid x509 pkey

71+ params <- defaultAzureParameters sid x509 pkey

72 let params' = params { azureSshUserName = user }

73 backend <- initializeBackend params' cloudService

74 Just vm <- findNamedVM backend virtualMachine

@@ -76,10 +76,10 @@ main = do

76 -- The same binary can behave as the client or the server,

77 -- depending on the command line arguments

78 case cmd of

79− "server" -> do

79+ "server" -> do

80− pid <- spawnOnVM backend vm port ($(mkClosure 'pingServer) ())

80+ pid <- spawnOnVM backend vm port ($(mkClosure 'pingServer) ())

81 putStrLn $ "Ping server started at " ++ show pid

82− "client" ->

82+ "client" ->

83− callOnVM backend vm port $

83+ callOnVM backend vm port $

84− ProcessPair ($(mkClosure 'pingClientRemote) ())

84+ ProcessPair ($(mkClosure 'pingClientRemote) ())

85− pingClientLocal

85+ pingClientLocal

distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hs+174−174

@@ -3,17 +3,17 @@

3-- Azure cloud service can talk to each other directly using standard Cloud

4-- Haskell primitives (using TCP/IP under the hood); to talk to the remote

5-- machines from your local machine you can use the primitives provided in this

6−-- module (which use ssh under the hood). It looks something like

6+-- module (which use ssh under the hood). It looks something like

7--

8-- > _ _

9-- > ( ` )_

10-- > ( ) `) Azure cloud service

11-- > (_ (_ . _) _)

12−-- >

12+-- >

13-- > |

14-- > | ssh connection

15-- > |

16−-- >

16+-- >

17-- > +---+

18-- > | | Local machine

19-- > +---+

@@ -39,27 +39,27 @@

39-- subsequent virtual machines to the first virtual machine, thereby implicitly

40-- setting up a Cloud Service.

41--

42−-- We have only tested Cloud Haskell with Linux based virtual machines;

42+-- We have only tested Cloud Haskell with Linux based virtual machines;

43-- Windows based virtual machines /might/ work, but you'll be entering

44-- uncharted territory. Cloud Haskell assumes that all nodes run the same

45−-- binary code; hence, you must use the same OS on all virtual machines,

45+-- binary code; hence, you must use the same OS on all virtual machines,

46-- /as well as on your local machine/. We use Ubuntu Server 12.04 LTS for our

47−-- tests (running on VirtualBox on our local machine).

47+-- tests (running on VirtualBox on our local machine).

48--

49-- When you set up your virtual machine, you can pick an arbitrary virtual

50-- machine name; these names are for your own use only and do not need to be

51-- globally unique. Set a username and password; you should use the same

52-- username on all virtual machines. You should also upload an SSH key for

53−-- authentication (see

53+-- authentication (see

54-- /Converting OpenSSH keys for use on Windows Azure Linux VM's/,

55-- <http://utlemming.azurewebsites.net/?p=91>, for

56-- information on how to convert a standard Linux @id_rsa.pub@ public key to

57-- X509 format suitable for Azure). For the first VM you create select

58-- /Standalone Virtual Machine/, and pick an appropriate DNS name. The DNS name

59-- /does/ have to be globally unique, and will also be the name of the Cloud

60−-- Service. For subsequent virtual machines, select

60+-- Service. For subsequent virtual machines, select

61-- /Connect to Existing Virtual Machine/ instead and then select the first VM

62−-- you created.

62+-- you created.

63--

64-- Once your virtual machines have been set up, you have to make sure that the

65-- user you created when you created the VM can ssh from any virtual machine to

@@ -91,24 +91,24 @@

91--

92-- And to extract the private key:

93--

94−-- > openssl pkcs12 -in credentials.pfx -nocerts -nodes | openssl rsa -out credentials.private

94+-- > openssl pkcs12 -in credentials.pfx -nocerts -nodes | openssl rsa -out credentials.private

95--

96-- (@openssl pkcs12@ outputs the private key in PKCS#8 format (BEGIN PRIVATE

97-- KEY), but we need it in PKCS#1 format (BEGIN RSA PRIVATE KEY).

98−--

98+--

99-- [Testing the Setup]

100--

101-- Build and install the @distributed-process-azure@ package, making sure to

102-- pass the @build-demos@ flag to Cabal.

103−--

103+--

104-- > cabal-dev install distributed-process-azure -f build-demos

105--

106-- We can the @cloud-haskell-azure-ping@ demo to test our setup:

107−--

107+--

108-- > cloud-haskell-azure-ping list \

109-- > <<your subscription ID>> \

110-- > /path/to/credentials.x509 \

111−-- > /path/to/credentials.private

111+-- > /path/to/credentials.private

112--

113-- (you can find your subscription ID in the @.publishsettings@ file from the previous step).

114-- If everything went well, this will output something like

@@ -157,7 +157,7 @@

157-- @RemoteProcess ()@, starts the executable on the remote node, sets up a new

158-- Cloud Haskell node, and then runs the specified process. The Cloud Haskell

159-- node will be shut down when the given process terminates. 'RemoteProcess' is

160−-- defined as

160+-- defined as

161--

162-- > type RemoteProcess a = Closure (Backend -> Process a)

163--

@@ -173,7 +173,7 @@

173-- because the remote process and the local process can communicate through a

174-- set of primitives provided in this module ('localSend', 'localExpect', and

175-- 'remoteSend' -- there is no 'remoteExpect'; instead the remote process can

176−-- use the standard Cloud Haskell 'expect' primitive).

176+-- use the standard Cloud Haskell 'expect' primitive).

177--

178-- [First Example: Echo]

179--

@@ -181,45 +181,45 @@

181-- starts a new Cloud Haskell node on the specified remote virtual machine. It

182-- then repeatedly waits for input from the user on the local machine, sends

183-- this to the remote virtual machine which will echo it back, and wait for and

184−-- show the echo.

184+-- show the echo.

185--

186-- Before you can try it you will first need to copy the executable (for

187-- example, using scp, although the Azure backend also provides this natively

188-- in Haskell). Once that's done, you can run the demo as follows:

189--

190−-- > cloud-haskell-azure-echo \

190+-- > cloud-haskell-azure-echo \

191−-- > <<subscription ID>> \

191+-- > <<subscription ID>> \

192−-- > /path/to/credentials.x509 \

192+-- > /path/to/credentials.x509 \

193−-- > /path/to/credentials.private \

193+-- > /path/to/credentials.private \

194−-- > <<remote username>> \

194+-- > <<remote username>> \

195−-- > <<cloud service name>> \

195+-- > <<cloud service name>> \

196−-- > <<virtual machine name>> \

196+-- > <<virtual machine name>> \

197−-- > <<port number>>

197+-- > <<port number>>

198-- > # Everything I type gets echoed back

199-- > Echo: Everything I type gets echoed back

200-- > # Until I enter a blank line

201-- > Echo: Until I enter a blank line

202−-- > #

202+-- > #

203--

204-- The full @echo@ demo is

205--

206-- > {-# LANGUAGE TemplateHaskell #-}

207−-- >

207+-- >

208-- > import System.IO (hFlush, stdout)

209-- > import System.Environment (getArgs)

210-- > import Control.Monad (unless, forever)

211-- > import Control.Monad.IO.Class (liftIO)

212-- > import Control.Distributed.Process (Process, expect)

213−-- > import Control.Distributed.Process.Closure (remotable, mkClosure)

213+-- > import Control.Distributed.Process.Closure (remotable, mkClosure)

214−-- > import Control.Distributed.Process.Backend.Azure

214+-- > import Control.Distributed.Process.Backend.Azure

215−-- >

215+-- >

216-- > echoRemote :: () -> Backend -> Process ()

217-- > echoRemote () _backend = forever $ do

218−-- > str <- expect

218+-- > str <- expect

219-- > remoteSend (str :: String)

220−-- >

220+-- >

221-- > remotable ['echoRemote]

222−-- >

222+-- >

223-- > echoLocal :: LocalProcess ()

224-- > echoLocal = do

225-- > str <- liftIO $ putStr "# " >> hFlush stdout >> getLine

@@ -229,35 +229,35 @@

229-- > echo <- localExpect

230-- > liftIO $ putStrLn echo

231-- > echoLocal

232−-- >

232+-- >

233-- > main :: IO ()

234-- > main = do

235-- > args <- getArgs

236-- > case args of

237−-- > "onvm":args' ->

237+-- > "onvm":args' ->

238-- > -- Pass execution to 'onVmMain' if we are running on the VM

239-- > -- ('callOnVM' will provide the right arguments)

240-- > onVmMain __remoteTable args'

241-- >

242-- > sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do

243-- > -- Initialize the Azure backend

244−-- > params <- defaultAzureParameters sid x509 pkey

244+-- > params <- defaultAzureParameters sid x509 pkey

245-- > let params' = params { azureSshUserName = user }

246-- > backend <- initializeBackend params' cloudService

247-- >

248-- > -- Find the specified virtual machine

249-- > Just vm <- findNamedVM backend virtualMachine

250-- >

251−-- > -- Run the echo client proper

251+-- > -- Run the echo client proper

252-- > callOnVM backend vm port $

253−-- > ProcessPair ($(mkClosure 'echoRemote) ())

253+-- > ProcessPair ($(mkClosure 'echoRemote) ())

254−-- > echoLocal

254+-- > echoLocal

255−--

255+--

256-- The most important part of this code is the last three lines

257--

258-- > callOnVM backend vm port $

259−-- > ProcessPair ($(mkClosure 'echoRemote) ())

259+-- > ProcessPair ($(mkClosure 'echoRemote) ())

260−-- > echoLocal

260+-- > echoLocal

261--

262-- 'callOnVM' creats a new Cloud Haskell node on the specified virtual machine,

263-- then runs @echoRemote@ on the remote machine and @echoLocal@ on the local

@@ -269,19 +269,19 @@

269-- 'callOnVM' and 'spawnOnVM'. It uses the latter to

270-- install a ping server which keeps running in the background; it uses the

271-- former to run a ping client which sends a request to the ping server and

272−-- outputs the response.

272+-- outputs the response.

273--

274-- As with the @echo@ demo, make sure to copy the executable to the remote server first.

275-- Once that is done, you can start a ping server on a virtual machine using

276--

277-- > cloud-haskell-azure-ping server \

278−-- > <<subscription ID>> \

278+-- > <<subscription ID>> \

279−-- > /path/to/credentials.x509 \

279+-- > /path/to/credentials.x509 \

280−-- > /path/to/credentials.private \

280+-- > /path/to/credentials.private \

281-- > <<remote username>> \

282−-- > <<cloud service name>> \

282+-- > <<cloud service name>> \

283−-- > <<virtual machine name>> \

283+-- > <<virtual machine name>> \

284−-- > <<port number>>

284+-- > <<port number>>

285--

286-- As before, when we execute this on our local machine, it starts a new Cloud

287-- Haskell node on the specified remote virtual machine and then executes the

@@ -294,11 +294,11 @@

294-- > cloud-haskell-azure-ping client \

295-- > <<subscription ID>> \

296-- > /path/to/credentials.x509 \

297−-- > /path/to/credentials.private \

297+-- > /path/to/credentials.private \

298-- > <<remote username>> \

299−-- > <<cloud service name>> \

299+-- > <<cloud service name>> \

300−-- > <<virtual machine name>> \

300+-- > <<virtual machine name>> \

301−-- > <<DIFFERENT port number>>

301+-- > <<DIFFERENT port number>>

302-- > Ping server at pid://10.59.224.122:8080:0:2 ok

303--

304-- Note that we must pass a different port number, because the client will run

@@ -309,13 +309,13 @@

309-- this case, through a PID file).

310--

311-- > {-# LANGUAGE TemplateHaskell #-}

312−-- >

312+-- >

313-- > import System.Environment (getArgs)

314-- > import Data.Binary (encode, decode)

315-- > import Control.Monad (void, forever)

316-- > import Control.Monad.IO.Class (liftIO)

317-- > import Control.Exception (try, IOException)

318−-- > import Control.Distributed.Process

318+-- > import Control.Distributed.Process

319-- > ( Process

320-- > , getSelfPid

321-- > , expect

@@ -325,72 +325,72 @@

325-- > , match

326-- > , ProcessMonitorNotification(..)

327-- > )

328−-- > import Control.Distributed.Process.Closure (remotable, mkClosure)

328+-- > import Control.Distributed.Process.Closure (remotable, mkClosure)

329−-- > import Control.Distributed.Process.Backend.Azure

329+-- > import Control.Distributed.Process.Backend.Azure

330−-- > import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)

330+-- > import qualified Data.ByteString.Lazy as BSL (readFile, writeFile)

331−-- >

331+-- >

332-- > pingServer :: () -> Backend -> Process ()

333-- > pingServer () _backend = do

334-- > us <- getSelfPid

335-- > liftIO $ BSL.writeFile "pingServer.pid" (encode us)

336−-- > forever $ do

336+-- > forever $ do

337-- > them <- expect

338-- > send them ()

339−-- >

339+-- >

340−-- > pingClientRemote :: () -> Backend -> Process ()

340+-- > pingClientRemote :: () -> Backend -> Process ()

341-- > pingClientRemote () _backend = do

342-- > mPingServerEnc <- liftIO $ try (BSL.readFile "pingServer.pid")

343-- > case mPingServerEnc of

344−-- > Left err ->

344+-- > Left err ->

345-- > remoteSend $ "Ping server not found: " ++ show (err :: IOException)

346−-- > Right pingServerEnc -> do

346+-- > Right pingServerEnc -> do

347-- > let pingServerPid = decode pingServerEnc

348-- > pid <- getSelfPid

349−-- > _ref <- monitor pingServerPid

349+-- > _ref <- monitor pingServerPid

350-- > send pingServerPid pid

351−-- > gotReply <- receiveWait

351+-- > gotReply <- receiveWait

352-- > [ match (\() -> return True)

353-- > , match (\(ProcessMonitorNotification {}) -> return False)

354-- > ]

355-- > if gotReply

356-- > then remoteSend $ "Ping server at " ++ show pingServerPid ++ " ok"

357-- > else remoteSend $ "Ping server at " ++ show pingServerPid ++ " failure"

358−-- >

358+-- >

359-- > remotable ['pingClientRemote, 'pingServer]

360−-- >

360+-- >

361-- > pingClientLocal :: LocalProcess ()

362−-- > pingClientLocal = localExpect >>= liftIO . putStrLn

362+-- > pingClientLocal = localExpect >>= liftIO . putStrLn

363−-- >

363+-- >

364-- > main :: IO ()

365-- > main = do

366-- > args <- getArgs

367-- > case args of

368−-- > "onvm":args' ->

368+-- > "onvm":args' ->

369-- > -- Pass execution to 'onVmMain' if we are running on the VM

370-- > onVmMain __remoteTable args'

371-- >

372-- > "list":sid:x509:pkey:_ -> do

373-- > -- List all available cloud services

374-- > -- (useful, but not strictly necessary for the example)

375−-- > params <- defaultAzureParameters sid x509 pkey

375+-- > params <- defaultAzureParameters sid x509 pkey

376-- > css <- cloudServices (azureSetup params)

377-- > mapM_ print css

378-- >

379-- > cmd:sid:x509:pkey:user:cloudService:virtualMachine:port:_ -> do

380-- > -- Initialize the backend and find the right VM

381−-- > params <- defaultAzureParameters sid x509 pkey

381+-- > params <- defaultAzureParameters sid x509 pkey

382-- > let params' = params { azureSshUserName = user }

383-- > backend <- initializeBackend params' cloudService

384-- > Just vm <- findNamedVM backend virtualMachine

385−-- >

385+-- >

386−-- > -- The same binary can behave as the client or the server,

386+-- > -- The same binary can behave as the client or the server,

387-- > -- depending on the command line arguments

388-- > case cmd of

389−-- > "server" -> void $ spawnOnVM backend vm port ($(mkClosure 'pingServer) ())

389+-- > "server" -> void $ spawnOnVM backend vm port ($(mkClosure 'pingServer) ())

390−-- > "client" -> callOnVM backend vm port $

390+-- > "client" -> callOnVM backend vm port $

391−-- > ProcessPair ($(mkClosure 'pingClientRemote) ())

391+-- > ProcessPair ($(mkClosure 'pingClientRemote) ())

392−-- > pingClientLocal

392+-- > pingClientLocal

393−module Control.Distributed.Process.Backend.Azure

393+module Control.Distributed.Process.Backend.Azure

394 ( -- * Initialization

395 Backend(..)

396 , AzureParameters(..)

@@ -422,7 +422,7 @@ import Prelude hiding (catch)

422import System.Environment (getEnv)

423import System.FilePath ((</>), takeFileName)

424import System.Environment.Executable (getExecutablePath)

425−import System.IO

425+import System.IO

426 ( stdout

427 , hFlush

428 , hSetBinaryMode

@@ -436,7 +436,7 @@ import qualified System.Posix.Process as Posix (forkProcess, createSession)

436import Data.Maybe (listToMaybe)

437import Data.Binary (Binary(get, put), encode, decode, getWord8, putWord8)

438import Data.Digest.Pure.MD5 (md5, MD5Digest)

439−import qualified Data.ByteString as BSS

439+import qualified Data.ByteString as BSS

440 ( ByteString

441 , length

442 , concat

@@ -444,7 +444,7 @@ import qualified Data.ByteString as BSS

444 , hGet

445 )

446import qualified Data.ByteString.Char8 as BSSC (pack)

447−import qualified Data.ByteString.Lazy as BSL

447+import qualified Data.ByteString.Lazy as BSL

448 ( ByteString

449 , readFile

450 , length

@@ -458,7 +458,7 @@ import Data.Foldable (forM_)

458import Control.Applicative ((<$>), (<*>))

459import Control.Monad (void, when)

460import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)

461−import Control.Exception

461+import Control.Exception

462 ( Exception

463 , catches

464 , Handler(Handler)

@@ -469,17 +469,17 @@ import Control.Monad.IO.Class (MonadIO, liftIO)

469import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, putMVar)

470

471-- Azure

472−import Network.Azure.ServiceManagement

472+import Network.Azure.ServiceManagement

473 ( CloudService(..)

474 , VirtualMachine(..)

475 , Endpoint(..)

476 , AzureSetup

477 )

478import qualified Network.Azure.ServiceManagement as Azure

479− ( cloudServices

479+ ( cloudServices

480 , azureSetup

481 , vmSshEndpoint

482− )

482+ )

483

484-- SSH

485import qualified Network.SSH.Client.LibSSH2 as SSH

@@ -505,7 +505,7 @@ import qualified Network.SSH.Client.LibSSH2.Errors as SSH

505 )

506

507-- CH

508−import Control.Distributed.Process

508+import Control.Distributed.Process

509 ( Process

510 , Closure

511 , RemoteTable

@@ -520,7 +520,7 @@ import Control.Distributed.Process

520 , nsendRemote

521 )

522import Control.Distributed.Process.Serializable (Serializable)

523−import qualified Control.Distributed.Process.Internal.Types as CH

523+import qualified Control.Distributed.Process.Internal.Types as CH

524 ( LocalNode

525 , LocalProcess(processQueue)

526 , Message

@@ -528,7 +528,7 @@ import qualified Control.Distributed.Process.Internal.Types as CH

528 , messageToPayload

529 , createMessage

530 )

531−import Control.Distributed.Process.Node

531+import Control.Distributed.Process.Node

532 ( runProcess

533 , forkProcess

534 , newLocalNode

@@ -539,7 +539,7 @@ import Network.Transport.TCP (createTransport, defaultTCPParameters)

539import Network.Transport.Internal (encodeInt32, decodeInt32, prependLength)

540

541-- Static

542−import Control.Distributed.Static

542+import Control.Distributed.Static

543 ( Static

544 , registerStatic

545 , staticClosure

@@ -552,18 +552,18 @@ data Backend = Backend {

552 -- | Find virtual machines

553 findVMs :: IO [VirtualMachine]

554 -- | Copy the executable to a virtual machine

555− , copyToVM :: VirtualMachine -> IO ()

555+ , copyToVM :: VirtualMachine -> IO ()

556 -- | Check the MD5 hash of the remote executable

557− , checkMD5 :: VirtualMachine -> IO Bool

557+ , checkMD5 :: VirtualMachine -> IO Bool

558 -- | @runOnVM vm port pp@ starts a new CH node on machine @vm@ and then

559 -- runs the specified process pair. The CH node will shut down when the

560 -- /local/ process exists. @callOnVM@ returns the returned by the local

561 -- process on exit.

562− , callOnVM :: forall a. VirtualMachine -> String -> ProcessPair a -> IO a

562+ , callOnVM :: forall a. VirtualMachine -> String -> ProcessPair a -> IO a

563 -- | Create a new CH node and run the specified process.

564 -- The CH node will shut down when the /remote/ process exists. @spawnOnVM@

565 -- returns as soon as the process has been spawned.

566− , spawnOnVM :: VirtualMachine -> String -> RemoteProcess () -> IO ProcessId

566+ , spawnOnVM :: VirtualMachine -> String -> RemoteProcess () -> IO ProcessId

567 } deriving (Typeable)

568

569-- | Azure connection parameters

@@ -588,7 +588,7 @@ instance Binary AzureParameters where

588 put (azureSshKnownHosts params)

589 put (azureSshRemotePath params)

590 put (azureSshLocalPath params)

591− get =

591+ get =

592 AzureParameters <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get

593

594-- | Create default azure parameters

@@ -600,9 +600,9 @@ defaultAzureParameters sid x509 pkey = do

600 home <- getEnv "HOME"

601 user <- getEnv "USER"

602 self <- getExecutablePath

603− setup <- Azure.azureSetup sid x509 pkey

603+ setup <- Azure.azureSetup sid x509 pkey

604− return AzureParameters

604+ return AzureParameters

605− { azureSetup = setup

605+ { azureSetup = setup

606 , azureSshUserName = user

607 , azureSshPublicKey = home </> ".ssh" </> "id_rsa.pub"

608 , azureSshPrivateKey = home </> ".ssh" </> "id_rsa"

@@ -616,10 +616,10 @@ defaultAzureParameters sid x509 pkey = do

616initializeBackend :: AzureParameters -- ^ Connection parameters

617 -> String -- ^ Cloud service name

618 -> IO Backend

619−initializeBackend params cloudService =

619+initializeBackend params cloudService =

620 return Backend {

621− findVMs = apiFindVMs params cloudService

621+ findVMs = apiFindVMs params cloudService

622− , copyToVM = apiCopyToVM params

622+ , copyToVM = apiCopyToVM params

623 , checkMD5 = apiCheckMD5 params

624 , callOnVM = apiCallOnVM params cloudService

625 , spawnOnVM = apiSpawnOnVM params cloudService

@@ -628,81 +628,81 @@ initializeBackend params cloudService =

628-- | Find virtual machines

629apiFindVMs :: AzureParameters -> String -> IO [VirtualMachine]

630apiFindVMs params cloudService = do

631− css <- Azure.cloudServices (azureSetup params)

631+ css <- Azure.cloudServices (azureSetup params)

632 case filter ((== cloudService) . cloudServiceName) css of

633 [cs] -> return $ cloudServiceVMs cs

634 _ -> return []

635

636-- | Start a CH node on the given virtual machine

637apiCopyToVM :: AzureParameters -> VirtualMachine -> IO ()

638−apiCopyToVM params vm =

638+apiCopyToVM params vm =

639 void . withSSH2 params vm $ \s -> catchSshError s $

640 SSH.scpSendFile s 0o700 (azureSshLocalPath params) (azureSshRemotePath params)

641

642−-- | Call a process on a VM

642+-- | Call a process on a VM

643−apiCallOnVM :: AzureParameters

643+apiCallOnVM :: AzureParameters

644+ -> String

645+ -> VirtualMachine

644 -> String

646 -> String

645− -> VirtualMachine

646− -> String

647 -> ProcessPair a

648 -> IO a

649apiCallOnVM = runOnVM False

650

651−apiSpawnOnVM :: AzureParameters

651+apiSpawnOnVM :: AzureParameters

652+ -> String

653+ -> VirtualMachine

652 -> String

654 -> String

653− -> VirtualMachine

654− -> String

655− -> Closure (Backend -> Process ())

655+ -> Closure (Backend -> Process ())

656− -> IO ProcessId

656+ -> IO ProcessId

657−apiSpawnOnVM params cloudService vm port rproc =

657+apiSpawnOnVM params cloudService vm port rproc =

658− runOnVM True params cloudService vm port $

658+ runOnVM True params cloudService vm port $

659 ProcessPair rproc localExpect

660−

660+

661-- | Internal generalization of 'spawnOnVM' and 'callOnVM'

662−runOnVM :: Bool

662+runOnVM :: Bool

663 -> AzureParameters

664 -> String

665 -> VirtualMachine

666 -> String

667 -> ProcessPair a

668 -> IO a

669−runOnVM bg params cloudService vm port ppair =

669+runOnVM bg params cloudService vm port ppair =

670 withSSH2 params vm $ \s -> do

671 -- TODO: reduce duplication with apiCallOnVM

672− let exe = "PATH=. " ++ azureSshRemotePath params

672+ let exe = "PATH=. " ++ azureSshRemotePath params

673 ++ " onvm"

674− ++ " " ++ vmIpAddress vm

674+ ++ " " ++ vmIpAddress vm

675 ++ " " ++ port

676 ++ " " ++ cloudService

677− ++ " " ++ show bg

677+ ++ " " ++ show bg

678 ++ " 2>&1"

679 let paramsEnc = encode params

680− let rprocEnc = encode (ppairRemote ppair)

680+ let rprocEnc = encode (ppairRemote ppair)

681 (status, r) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do

682 SSH.channelExecute ch exe

683 SSH.writeChannel ch (encodeInt32 (BSL.length rprocEnc))

684− SSH.writeAllChannel ch rprocEnc

684+ SSH.writeAllChannel ch rprocEnc

685 SSH.writeChannel ch (encodeInt32 (BSL.length paramsEnc))

686− SSH.writeAllChannel ch paramsEnc

686+ SSH.writeAllChannel ch paramsEnc

687 runLocalProcess (ppairLocal ppair) ch

688− if status == 0

688+ if status == 0

689− then return r

689+ then return r

690− else error "runOnVM: Non-zero exit status" -- This would a bug

690+ else error "runOnVM: Non-zero exit status" -- This would a bug

691

692-- | Check the MD5 hash of the executable on the remote machine

693−apiCheckMD5 :: AzureParameters -> VirtualMachine -> IO Bool

693+apiCheckMD5 :: AzureParameters -> VirtualMachine -> IO Bool

694apiCheckMD5 params vm = do

695 hash <- localHash params

696 withSSH2 params vm $ \s -> do

697 (r, _) <- SSH.withChannelBy (SSH.openChannelSession s) id $ \ch -> do

698 SSH.channelExecute ch "md5sum -c --status"

699− SSH.writeChannel ch . BSSC.pack $ show hash ++ " " ++ azureSshRemotePath params

699+ SSH.writeChannel ch . BSSC.pack $ show hash ++ " " ++ azureSshRemotePath params

700 SSH.channelSendEOF ch

701 SSH.readAllChannel ch

702 return (r == 0)

703

704−withSSH2 :: AzureParameters -> VirtualMachine -> (SSH.Session -> IO a) -> IO a

704+withSSH2 :: AzureParameters -> VirtualMachine -> (SSH.Session -> IO a) -> IO a

705−withSSH2 params (Azure.vmSshEndpoint -> Just ep) =

705+withSSH2 params (Azure.vmSshEndpoint -> Just ep) =

706 SSH.withSSH2 (azureSshKnownHosts params)

707 (azureSshPublicKey params)

708 (azureSshPrivateKey params)

@@ -710,11 +710,11 @@ withSSH2 params (Azure.vmSshEndpoint -> Just ep) =

710 (azureSshUserName params)

711 (endpointVip ep)

712 (read $ endpointPort ep)

713−withSSH2 _ vm =

713+withSSH2 _ vm =

714 error $ "withSSH2: No SSH endpoint for virtual machine " ++ vmName vm

715

716catchSshError :: SSH.Session -> IO a -> IO a

717−catchSshError s io =

717+catchSshError s io =

718 catches io [ Handler handleErrorCode

719 , Handler handleNullPointer

720 ]

@@ -725,12 +725,12 @@ catchSshError s io =

725 error str

726

727 handleNullPointer :: SSH.NULL_POINTER -> IO a

728− handleNullPointer _ = do

728+ handleNullPointer _ = do

729 (_, str) <- SSH.getLastError s

730 error str

731−

731+

732−localHash :: AzureParameters -> IO MD5Digest

732+localHash :: AzureParameters -> IO MD5Digest

733−localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)

733+localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)

734

735--------------------------------------------------------------------------------

736-- Utilities --

@@ -738,8 +738,8 @@ localHash params = md5 <$> BSL.readFile (azureSshLocalPath params)

738

739-- | Find a virtual machine with a particular name

740findNamedVM :: Backend -> String -> IO (Maybe VirtualMachine)

741−findNamedVM backend vm =

741+findNamedVM backend vm =

742− listToMaybe . filter ((== vm) . vmName) <$> findVMs backend

742+ listToMaybe . filter ((== vm) . vmName) <$> findVMs backend

743

744--------------------------------------------------------------------------------

745-- Local and remote processes --

@@ -750,10 +750,10 @@ findNamedVM backend vm =

750-- for messages from the remote process using 'localExpect'. The remote process

751-- can send messages to the local process using 'remoteSend', and wait for

752-- messages from the local process using the standard Cloud Haskell primitives.

753−--

753+--

754-- See also 'callOnVM'.

755data ProcessPair a = ProcessPair {

756− ppairRemote :: RemoteProcess ()

756+ ppairRemote :: RemoteProcess ()

757 , ppairLocal :: LocalProcess a

758 }

759

@@ -761,22 +761,22 @@ data ProcessPair a = ProcessPair {

761type RemoteProcess a = Closure (Backend -> Process a)

762

763-- | The process to run on the local node (see 'ProcessPair' and 'callOnVM').

764−newtype LocalProcess a = LocalProcess { unLocalProcess :: ReaderT SSH.Channel IO a }

764+newtype LocalProcess a = LocalProcess { unLocalProcess :: ReaderT SSH.Channel IO a }

765 deriving (Functor, Monad, MonadIO, MonadReader SSH.Channel)

766

767runLocalProcess :: LocalProcess a -> SSH.Channel -> IO a

768runLocalProcess = runReaderT . unLocalProcess

769

770−-- | Send a messages from the local process to the remote process

770+-- | Send a messages from the local process to the remote process

771-- (see 'ProcessPair')

772localSend :: Serializable a => a -> LocalProcess ()

773localSend x = LocalProcess $ do

774 ch <- ask

775− liftIO $ mapM_ (SSH.writeChannel ch)

775+ liftIO $ mapM_ (SSH.writeChannel ch)

776 . prependLength

777− . CH.messageToPayload

777+ . CH.messageToPayload

778− . CH.createMessage

778+ . CH.createMessage

779− $ x

779+ $ x

780

781-- | Wait for a message from the remote process (see 'ProcessPair').

782-- Note that unlike for the standard Cloud Haskell 'expect' it will result in a

@@ -784,14 +784,14 @@ localSend x = LocalProcess $ do

784--

785-- Since it is relatively easy for the remote process to mess up the

786-- communication protocol (for instance, by doing a putStr) we ask for the

787−-- length twice, as some sort of sanity check.

787+-- length twice, as some sort of sanity check.

788localExpect :: Serializable a => LocalProcess a

789localExpect = LocalProcess $ do

790 ch <- ask

791− liftIO $ do

791+ liftIO $ do

792 isE <- readIntChannel ch

793− len <- readIntChannel ch

793+ len <- readIntChannel ch

794− lenAgain <- readIntChannel ch

794+ lenAgain <- readIntChannel ch

795 when (len /= lenAgain) $ throwIO (userError "Internal error: protocol violation (perhaps the remote binary is not installed correctly?)")

796 msg <- readSizeChannel ch len

797 if isE /= 0

@@ -802,7 +802,7 @@ localExpect = LocalProcess $ do

802-- 'ProcessPair'). Note that the remote process can use the standard Cloud

803-- Haskell primitives to /receive/ messages from the local process.

804remoteSend :: Serializable a => a -> Process ()

805−remoteSend = liftIO . remoteSend'

805+remoteSend = liftIO . remoteSend'

806

807remoteSend' :: Serializable a => a -> IO ()

808remoteSend' = remoteSendFlagged 0

@@ -841,51 +841,51 @@ onVmMain rtable [host, port, cloudService, bg] = do

841 hSetBinaryMode stdout True

842 Just rprocEnc <- getWithLength stdin

843 Just paramsEnc <- getWithLength stdin

844− backend <- initializeBackend (decode paramsEnc) cloudService

844+ backend <- initializeBackend (decode paramsEnc) cloudService

845− let rproc = decode rprocEnc

845+ let rproc = decode rprocEnc

846 lprocMVar <- newEmptyMVar :: IO (MVar CH.LocalProcess)

847− if read bg

847+ if read bg

848 then

849 void . Posix.forkProcess $ do

850 -- We inherit the file descriptors from the parent, so the SSH

851 -- session will not be terminated until we close them

852 void Posix.createSession

853− startCH rproc lprocMVar backend

853+ startCH rproc lprocMVar backend

854 (\node proc -> runProcess node $ do

855 us <- getSelfPid

856 liftIO $ do

857 remoteSend' us

858 mapM_ hClose [stdin, stdout, stderr]

859− proc)

859+ proc)

860 else do

861− startCH rproc lprocMVar backend forkProcess

861+ startCH rproc lprocMVar backend forkProcess

862 lproc <- readMVar lprocMVar

863 queueFromHandle stdin (CH.processQueue lproc)

864 where

865− startCH :: RemoteProcess ()

865+ startCH :: RemoteProcess ()

866− -> MVar CH.LocalProcess

866+ -> MVar CH.LocalProcess

867 -> Backend

868− -> (CH.LocalNode -> Process () -> IO a)

868+ -> (CH.LocalNode -> Process () -> IO a)

869− -> IO ()

869+ -> IO ()

870 startCH rproc lprocMVar backend go = do

871− mTransport <- createTransport host port defaultTCPParameters

871+ mTransport <- createTransport host port defaultTCPParameters

872 case mTransport of

873 Left err -> remoteThrow err

874− Right transport -> do

874+ Right transport -> do

875 node <- newLocalNode transport (rtable . __remoteTable $ initRemoteTable)

876− void . go node $ do

876+ void . go node $ do

877 ask >>= liftIO . putMVar lprocMVar

878 proc <- unClosure rproc :: Process (Backend -> Process ())

879− catch (proc backend)

879+ catch (proc backend)

880 (liftIO . (remoteThrow :: SomeException -> IO ()))

881−onVmMain _ _

881+onVmMain _ _

882 = error "Invalid arguments passed on onVmMain"

883

884-- | Read a 4-byte length @l@ and then an @l@-byte payload

885--

886-- Returns Nothing on EOF

887getWithLength :: Handle -> IO (Maybe BSL.ByteString)

888−getWithLength h = do

888+getWithLength h = do

889 lenEnc <- BSS.hGet h 4

890 if BSS.length lenEnc < 4

891 then return Nothing

@@ -898,9 +898,9 @@ getWithLength h = do

898

899queueFromHandle :: Handle -> CQueue CH.Message -> IO ()

900queueFromHandle h q = do

901− mPayload <- getWithLength stdin

901+ mPayload <- getWithLength stdin

902 forM_ mPayload $ \payload -> do

903− enqueue q $ CH.payloadToMessage (BSL.toChunks payload)

903+ enqueue q $ CH.payloadToMessage (BSL.toChunks payload)

904 queueFromHandle h q

905

906--------------------------------------------------------------------------------

@@ -917,7 +917,7 @@ readSizeChannel ch = go []

917 go (bs : acc) (size - BSS.length bs)

918

919readIntChannel :: SSH.Channel -> IO Int

920−readIntChannel ch =

920+readIntChannel ch =

921 decodeInt32 . BSS.concat . BSL.toChunks <$> readSizeChannel ch 4

922

923--------------------------------------------------------------------------------

@@ -945,7 +945,7 @@ serviceProcess _backend = do

945 go = do

946 msg <- expect

947 case msg of

948− ServiceProcessTerminate ->

948+ ServiceProcessTerminate ->

949 return ()

950

951serviceProcessStatic :: Static (Backend -> Process ())

@@ -953,11 +953,11 @@ serviceProcessStatic = staticLabel "serviceProcess"

953

954-- | Start a new Cloud Haskell node on the given virtual machine

955spawnNodeOnVM :: Backend -> VirtualMachine -> String -> IO NodeId

956−spawnNodeOnVM backend vm port =

956+spawnNodeOnVM backend vm port =

957 processNodeId <$> spawnOnVM backend vm port (staticClosure serviceProcessStatic)

958

959-- | Terminate a node started with 'spawnNodeOnVM'

960−terminateNode :: NodeId -> Process ()

960+terminateNode :: NodeId -> Process ()

961terminateNode nid = nsendRemote nid "$azureBackendServiceProcess" ServiceProcessTerminate

962

963__remoteTable :: RemoteTable -> RemoteTable

distributed-process-demos/src/Common/PrimeFactors.hs+2−2

@@ -6,7 +6,7 @@ module PrimeFactors where

7primes :: [Integer]

8primes = primes' (2:[3,5..])

9− where

9+ where

10 primes' (x:xs) = x : primes' (filter (notDivisorOf x) xs)

11 notDivisorOf d n = n `mod` d /= 0

@@ -15,7 +15,7 @@ factors qs@(p:ps) n

15 | n <= 1 = []

16 | m == 0 = p : factors qs d

17 | otherwise = factors ps n

18− where

18+ where

19 (d,m) = n `divMod` p

21primeFactors :: Integer -> [Integer]

distributed-process-demos/src/MapReduce/CountWords.hs+5−5

@@ -1,5 +1,5 @@

1{-# LANGUAGE TupleSections #-}

2−module CountWords

2+module CountWords

3 ( Document

4 , localCountWords

5 , distrCountWords

@@ -8,8 +8,8 @@ module CountWords

9import Control.Distributed.Process

10import Control.Distributed.Process.Closure

11−import MapReduce

11+import MapReduce

12−import MonoDistrMapReduce hiding (__remoteTable)

12+import MonoDistrMapReduce hiding (__remoteTable)

14type Document = String

15type Word = String

@@ -18,7 +18,7 @@ type Frequency = Int

18countWords :: MapReduce FilePath Document Word Frequency Frequency

19countWords = MapReduce {

20 mrMap = const (map (, 1) . words)

21− , mrReduce = const sum

21+ , mrReduce = const sum

22 }

24localCountWords :: Map FilePath Document -> Map Word Frequency

@@ -31,4 +31,4 @@ remotable ['countWords_]

32distrCountWords :: [NodeId] -> Map FilePath Document -> Process (Map Word Frequency)

33distrCountWords = distrMapReduce ($(mkClosure 'countWords_) ())

34−

34+

distributed-process-demos/src/MapReduce/KMeans.hs+30−30

@@ -1,5 +1,5 @@

1{-# LANGUAGE TupleSections #-}

2−module KMeans

2+module KMeans

3 ( Point

4 , Cluster

5 , localKMeans

@@ -24,37 +24,37 @@ type Cluster = (Double, Double)

24average :: Fractional a => [a] -> a

25average xs = sum xs / fromIntegral (length xs)

27−distanceSq :: Point -> Point -> Double

27+distanceSq :: Point -> Point -> Double

28distanceSq (x1, y1) (x2, y2) = a * a + b * b

29 where

30 a = x2 - x1

31 b = y2 - y1

33nearest :: Point -> [Cluster] -> Cluster

34−nearest p = minimumBy (compare `on` distanceSq p)

34+nearest p = minimumBy (compare `on` distanceSq p)

36center :: [Point] -> Point

37−center ps = let (xs, ys) = unzip ps in (average xs, average ys)

37+center ps = let (xs, ys) = unzip ps in (average xs, average ys)

39kmeans :: Array Int Point -> MapReduce (Int, Int) [Cluster] Cluster Point ([Point], Point)

40kmeans points = MapReduce {

41 mrMap = \(lo, hi) cs -> [ let p = points ! i in (nearest p cs, p)

42 | i <- [lo .. hi]

43− ]

43+ ]

44 , mrReduce = \_ ps -> (ps, center ps)

45 }

47−localKMeans :: Array Int Point

47+localKMeans :: Array Int Point

48− -> [Cluster]

48+ -> [Cluster]

49 -> Int

50 -> Map Cluster ([Point], Point)

51localKMeans points cs iterations = go (iterations - 1)

52 where

53 mr :: [Cluster] -> Map Cluster ([Point], Point)

54 mr = localMapReduce (kmeans points) . trivialSegmentation

55−

55+

56 go :: Int -> Map Cluster ([Point], Point)

57− go 0 = mr cs

57+ go 0 = mr cs

58 go n = mr . map snd . Map.elems . go $ n - 1

60 trivialSegmentation :: [Cluster] -> Map (Int, Int) [Cluster]

@@ -68,60 +68,60 @@ dictOut = SerializableDict

69remotable ['kmeans, 'dictIn, 'dictOut]

71−distrKMeans :: Array Int Point

71+distrKMeans :: Array Int Point

72 -> [Cluster]

73− -> [NodeId]

73+ -> [NodeId]

74 -> Int

75 -> Process (Map Cluster ([Point], Point))

76−distrKMeans points cs mappers iterations =

76+distrKMeans points cs mappers iterations =

77− distrMapReduce $(mkStatic 'dictIn)

77+ distrMapReduce $(mkStatic 'dictIn)

78− $(mkStatic 'dictOut)

78+ $(mkStatic 'dictOut)

79− ($(mkClosure 'kmeans) points)

79+ ($(mkClosure 'kmeans) points)

80 mappers

81 (go (iterations - 1))

82 where

83 go :: Int

84− -> (Map (Int, Int) [Cluster] -> Process (Map Cluster ([Point], Point)))

84+ -> (Map (Int, Int) [Cluster] -> Process (Map Cluster ([Point], Point)))

85 -> Process (Map Cluster ([Point], Point))

86− go 0 iteration =

86+ go 0 iteration =

87− iteration (Map.fromList $ map (, cs) segments)

87+ iteration (Map.fromList $ map (, cs) segments)

88 go n iteration = do

89 clusters <- go (n - 1) iteration

90 let centers = map snd $ Map.elems clusters

91 iteration (Map.fromList $ map (, centers) segments)

92−

92+

93 segments :: [(Int, Int)]

94 segments = let (lo, _) = bounds points in dividePoints numPoints lo

96 dividePoints :: Int -> Int -> [(Int, Int)]

97− dividePoints pointsLeft offset

97+ dividePoints pointsLeft offset

98− | pointsLeft <= pointsPerMapper = [(offset, offset + pointsLeft - 1)]

98+ | pointsLeft <= pointsPerMapper = [(offset, offset + pointsLeft - 1)]

99 | otherwise = let offset' = offset + pointsPerMapper in

100 (offset, offset' - 1)

101− : dividePoints (pointsLeft - pointsPerMapper) offset'

101+ : dividePoints (pointsLeft - pointsPerMapper) offset'

102

103 pointsPerMapper :: Int

104− pointsPerMapper =

104+ pointsPerMapper =

105 ceiling (toRational numPoints / toRational (length mappers))

106−

106+

107 numPoints :: Int

108 numPoints = let (lo, hi) = bounds points in hi - lo + 1

109

110-- | Create a gnuplot data file for the output of the k-means algorithm

111--

112−-- To plot the data, use

112+-- To plot the data, use

113--

114-- > plot "<<filename>>" u 1:2:3 with points palette

115createGnuPlot :: Map KMeans.Cluster ([KMeans.Point], KMeans.Point) -> Handle -> IO ()

116−createGnuPlot clusters h =

116+createGnuPlot clusters h =

117 mapM_ printPoint . flatten . zip colors . Map.toList $ clusters

118 where

119− printPoint (x, y, color) =

119+ printPoint (x, y, color) =

120 hPutStrLn h $ show x ++ " " ++ show y ++ " " ++ show color

121

122− flatten :: [(Float, (KMeans.Cluster, ([KMeans.Point], KMeans.Point)))]

122+ flatten :: [(Float, (KMeans.Cluster, ([KMeans.Point], KMeans.Point)))]

123 -> [(Double, Double, Float)]

124− flatten = concatMap (\(color, (_, (points, _))) -> map (\(x, y) -> (x, y, color)) points)

124+ flatten = concatMap (\(color, (_, (points, _))) -> map (\(x, y) -> (x, y, color)) points)

125

126 colors :: [Float]

127− colors = [0, 1 / fromIntegral (Map.size clusters) .. 1]

127+ colors = [0, 1 / fromIntegral (Map.size clusters) .. 1]

distributed-process-demos/src/MapReduce/MapReduce.hs+6−6

@@ -1,5 +1,5 @@

1{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, GADTs #-}

2−module MapReduce

2+module MapReduce

3 ( -- * Map-reduce skeleton and implementation

4 MapReduce(..)

5 , localMapReduce

@@ -31,16 +31,16 @@ data MapReduce k1 v1 k2 v2 v3 = MapReduce {

31-- /Google’s MapReduce Programming Model---Revisited/ by Ralf Laemmel

32-- (<http://userpages.uni-koblenz.de/~laemmel/MapReduce/>).

33localMapReduce :: forall k1 k2 v1 v2 v3. Ord k2 =>

34− MapReduce k1 v1 k2 v2 v3

34+ MapReduce k1 v1 k2 v2 v3

35− -> Map k1 v1

35+ -> Map k1 v1

36 -> Map k2 v3

37localMapReduce mr = reducePerKey mr . groupByKey . mapPerKey mr

39reducePerKey :: MapReduce k1 v1 k2 v2 v3 -> Map k2 [v2] -> Map k2 v3

40−reducePerKey mr = Map.mapWithKey (mrReduce mr)

40+reducePerKey mr = Map.mapWithKey (mrReduce mr)

42groupByKey :: Ord k2 => [(k2, v2)] -> Map k2 [v2]

43−groupByKey = Map.fromListWith (++) . map (second return)

43+groupByKey = Map.fromListWith (++) . map (second return)

45mapPerKey :: MapReduce k1 v1 k2 v2 v3 -> Map k1 v1 -> [(k2, v2)]

46−mapPerKey mr = concatMap (uncurry (mrMap mr)) . Map.toList

46+mapPerKey mr = concatMap (uncurry (mrMap mr)) . Map.toList

distributed-process-demos/src/MapReduce/MonoDistrMapReduce.hs+8−8

@@ -17,16 +17,16 @@ mapperProcess :: (ProcessId, ProcessId, Closure (MapReduce String String String

17mapperProcess (master, workQueue, mrClosure) = do

18 us <- getSelfPid

19 mr <- unClosure mrClosure

20− go us mr

20+ go us mr

21 where

22 go us mr = do

23− -- Ask the queue for work

23+ -- Ask the queue for work

24 send workQueue us

25−

25+

26 -- Wait for a reply; if there is work, do it and repeat; otherwise, exit

27− receiveWait

27+ receiveWait

28 [ match $ \(key, val) -> send master (mrMap mr key val) >> go us mr

29− , match $ \() -> return ()

29+ , match $ \() -> return ()

30 ]

32remotable ['mapperProcess]

@@ -41,7 +41,7 @@ distrMapReduce mrClosure mappers input = do

42 workQueue <- spawnLocal $ do

43 -- Return the next bit of work to be done

44− forM_ (Map.toList input) $ \(key, val) -> do

44+ forM_ (Map.toList input) $ \(key, val) -> do

45 them <- expect

46 send them (key, val)

@@ -51,10 +51,10 @@ distrMapReduce mrClosure mappers input = do

51 send them ()

53 -- Start the mappers

54− forM_ mappers $ \nid -> spawn nid ($(mkClosure 'mapperProcess) (master, workQueue, mrClosure))

54+ forM_ mappers $ \nid -> spawn nid ($(mkClosure 'mapperProcess) (master, workQueue, mrClosure))

56 -- Wait for the partial results

57− partials <- replicateM (Map.size input) expect

57+ partials <- replicateM (Map.size input) expect

59 -- We reduce on this node

60 return (reducePerKey mr . groupByKey . concat $ partials)

distributed-process-demos/src/MapReduce/PolyDistrMapReduce.hs+23−23

@@ -26,65 +26,65 @@ sendDict SerializableDict = send

26sdictProcessIdPair :: SerializableDict (ProcessId, ProcessId)

27sdictProcessIdPair = SerializableDict

29−mapperProcess :: forall k1 v1 k2 v2 v3.

29+mapperProcess :: forall k1 v1 k2 v2 v3.

30 SerializableDict (k1, v1)

31 -> SerializableDict [(k2, v2)]

32 -> (ProcessId, ProcessId)

33− -> MapReduce k1 v1 k2 v2 v3

33+ -> MapReduce k1 v1 k2 v2 v3

34 -> Process ()

35−mapperProcess dictIn dictOut (master, workQueue) mr = getSelfPid >>= go

35+mapperProcess dictIn dictOut (master, workQueue) mr = getSelfPid >>= go

36 where

37 go us = do

38− -- Ask the queue for work

38+ -- Ask the queue for work

39 send workQueue us

40−

40+

41 -- Wait for a reply; if there is work, do it and repeat; otherwise, exit

42− receiveWait

42+ receiveWait

43 [ matchDict dictIn $ \(key, val) -> do

44 sendDict dictOut master (mrMap mr key val)

45 go us

46− , match $ \() ->

46+ , match $ \() ->

47− return ()

47+ return ()

48 ]

50remotable ['mapperProcess, 'sdictProcessIdPair]

52−mapperProcessClosure :: forall k1 v1 k2 v2 v3.

52+mapperProcessClosure :: forall k1 v1 k2 v2 v3.

53 (Typeable k1, Typeable v1, Typeable k2, Typeable v2, Typeable v3)

54 => Static (SerializableDict (k1, v1))

55 -> Static (SerializableDict [(k2, v2)])

56− -> Closure (MapReduce k1 v1 k2 v2 v3)

56+ -> Closure (MapReduce k1 v1 k2 v2 v3)

57− -> ProcessId

57+ -> ProcessId

58− -> ProcessId

58+ -> ProcessId

59 -> Closure (Process ())

60−mapperProcessClosure dictIn dictOut mr master workQueue =

60+mapperProcessClosure dictIn dictOut mr master workQueue =

61 closure decoder (encode (master, workQueue)) `closureApply` mr

62 where

63 decoder :: Static (ByteString -> MapReduce k1 v1 k2 v2 v3 -> Process ())

64− decoder =

64+ decoder =

65 ($(mkStatic 'mapperProcess) `staticApply` dictIn `staticApply` dictOut)

66− `staticCompose`

66+ `staticCompose`

67 staticDecode $(mkStatic 'sdictProcessIdPair)

69−distrMapReduce :: forall k1 k2 v1 v2 v3 a.

69+distrMapReduce :: forall k1 k2 v1 v2 v3 a.

70 (Serializable k1, Serializable v1, Serializable k2, Serializable v2, Serializable v3, Ord k2)

71 => Static (SerializableDict (k1, v1))

72 -> Static (SerializableDict [(k2, v2)])

73 -> Closure (MapReduce k1 v1 k2 v2 v3)

74 -> [NodeId]

75− -> ((Map k1 v1 -> Process (Map k2 v3)) -> Process a)

75+ -> ((Map k1 v1 -> Process (Map k2 v3)) -> Process a)

76− -> Process a

76+ -> Process a

77distrMapReduce dictIn dictOut mr mappers p = do

78 mr' <- unClosure mr

79 master <- getSelfPid

81 workQueue <- spawnChannelLocal $ \queue -> do

82 let go :: Process ()

83− go = do

83+ go = do

84 mWork <- receiveChan queue

85 case mWork of

86 Just (key, val) -> do

87− -- As long there is work, make it available to the mappers

87+ -- As long there is work, make it available to the mappers

88 them <- expect

89 send them (key, val)

90 go

@@ -100,8 +100,8 @@ distrMapReduce dictIn dictOut mr mappers p = do

100

101 -- Start the mappers

102 let workQueuePid = sendPortProcessId (sendPortId workQueue)

103− forM_ mappers $ \nid ->

103+ forM_ mappers $ \nid ->

104− spawn nid (mapperProcessClosure dictIn dictOut mr master workQueuePid)

104+ spawn nid (mapperProcessClosure dictIn dictOut mr master workQueuePid)

105

106 let iteration :: Map k1 v1 -> Process (Map k2 v3)

107 iteration input = do

@@ -109,7 +109,7 @@ distrMapReduce dictIn dictOut mr mappers p = do

109 mapM_ (sendChan workQueue . Just) (Map.toList input)

110

111 -- Wait for the partial results

112− partials <- replicateM (Map.size input) expect

112+ partials <- replicateM (Map.size input) expect

113

114 -- We reduce on this node

115 return (reducePerKey mr' . groupByKey . concat $ partials)

distributed-process-demos/src/MapReduce/SimpleLocalnet.hs+15−15

@@ -10,53 +10,53 @@ import Data.Map (Map)

10import Data.Array (Array, listArray)

11import qualified Data.Map as Map (fromList)

13−import qualified CountWords

13+import qualified CountWords

14import qualified PolyDistrMapReduce

15import qualified MonoDistrMapReduce

16import qualified KMeans

18rtable :: RemoteTable

19−rtable = PolyDistrMapReduce.__remoteTable

19+rtable = PolyDistrMapReduce.__remoteTable

20− . MonoDistrMapReduce.__remoteTable

20+ . MonoDistrMapReduce.__remoteTable

21 . CountWords.__remoteTable

22 . KMeans.__remoteTable

23− $ initRemoteTable

23+ $ initRemoteTable

25main :: IO ()

26main = do

27 args <- getArgs

29 case args of

30− -- Local word count

30+ -- Local word count

31 "local" : "count" : files -> do

32− input <- constructInput files

32+ input <- constructInput files

33− print $ CountWords.localCountWords input

33+ print $ CountWords.localCountWords input

35 -- Distributed word count

36 "master" : host : port : "count" : files -> do

37− input <- constructInput files

37+ input <- constructInput files

38− backend <- initializeBackend host port rtable

38+ backend <- initializeBackend host port rtable

39 startMaster backend $ \slaves -> do

40− result <- CountWords.distrCountWords slaves input

40+ result <- CountWords.distrCountWords slaves input

41− liftIO $ print result

41+ liftIO $ print result

43 -- Local k-means

44 "local" : "kmeans" : [] -> do

45 points <- replicateM 50000 randomPoint

46 withFile "plot.data" WriteMode $ KMeans.createGnuPlot $

47− KMeans.localKMeans (arrayFromList points) (take 5 points) 5

47+ KMeans.localKMeans (arrayFromList points) (take 5 points) 5

49 -- Distributed k-means

50 "master" : host : port : "kmeans" : [] -> do

51 points <- replicateM 50000 randomPoint

52− backend <- initializeBackend host port rtable

52+ backend <- initializeBackend host port rtable

53 startMaster backend $ \slaves -> do

54− result <- KMeans.distrKMeans (arrayFromList points) (take 5 points) slaves 5

54+ result <- KMeans.distrKMeans (arrayFromList points) (take 5 points) slaves 5

55 liftIO $ withFile "plot.data" WriteMode $ KMeans.createGnuPlot result

57 -- Generic slave for distributed examples

58 "slave" : host : port : [] -> do

59− backend <- initializeBackend host port rtable

59+ backend <- initializeBackend host port rtable

60 startSlave backend

62--------------------------------------------------------------------------------

distributed-process-demos/src/MasterSlave/Azure.hs+7−7

@@ -2,13 +2,13 @@ import System.Environment (getArgs)

2import Control.Monad

3import Control.Distributed.Process

4import Control.Distributed.Process.Closure

5−import Control.Distributed.Process.Backend.Azure

5+import Control.Distributed.Process.Backend.Azure

6import qualified MasterSlave

8azureMaster :: ([NodeId], Integer) -> Backend -> Process ()

9azureMaster (slaves, n) _backend = do

10 result <- MasterSlave.master n slaves

11− mapM_ terminateNode slaves

11+ mapM_ terminateNode slaves

12 remoteSend result

14remotable ['azureMaster]

@@ -16,7 +16,7 @@ remotable ['azureMaster]

16printResult :: LocalProcess ()

17printResult = do

18 result <- localExpect :: LocalProcess Integer

19− liftIO $ print result

19+ liftIO $ print result

21main :: IO ()

22main = do

@@ -24,14 +24,14 @@ main = do

24 case args of

25 "onvm":args' -> onVmMain (__remoteTable . MasterSlave.__remoteTable) args'

26 [sid, x509, pkey, user, cloudService, n] -> do

27− params <- defaultAzureParameters sid x509 pkey

27+ params <- defaultAzureParameters sid x509 pkey

28 let params' = params { azureSshUserName = user }

29 backend <- initializeBackend params' cloudService

30 vms <- findVMs backend

31 print vms

32 nids <- forM vms $ \vm -> spawnNodeOnVM backend vm "8080"

33− callOnVM backend (head vms) "8081" $

33+ callOnVM backend (head vms) "8081" $

34− ProcessPair ($(mkClosure 'azureMaster) (nids, read n :: Integer))

34+ ProcessPair ($(mkClosure 'azureMaster) (nids, read n :: Integer))

35− printResult

35+ printResult

36 _ ->

37 error "Invalid command line arguments"

distributed-process-demos/src/MasterSlave/MasterSlave.hs+4−4

@@ -16,21 +16,21 @@ sumIntegers = go 0

16 where

17 go :: Integer -> Int -> Process Integer

18 go !acc 0 = return acc

19− go !acc n = do

19+ go !acc n = do

20 m <- expect

21 go (acc + m) (n - 1)

23data SpawnStrategy = SpawnSyncWithReconnect

24 | SpawnSyncNoReconnect

25 | SpawnAsync

26− deriving (Show, Read)

26+ deriving (Show, Read)

28master :: Integer -> SpawnStrategy -> [NodeId] -> Process Integer

29master n spawnStrategy slaves = do

30 us <- getSelfPid

32− -- Distribute 1 .. n amongst the slave processes

32+ -- Distribute 1 .. n amongst the slave processes

33− spawnLocal $ case spawnStrategy of

33+ spawnLocal $ case spawnStrategy of

34 SpawnSyncWithReconnect ->

35 forM_ (zip [1 .. n] (cycle slaves)) $ \(m, there) -> do

36 them <- spawn there ($(mkClosure 'slave) (us, m))

distributed-process-demos/src/MasterSlave/SimpleLocalnet.hs+4−4

@@ -6,7 +6,7 @@ import Control.Distributed.Process.Backend.SimpleLocalnet

6import qualified MasterSlave

8rtable :: RemoteTable

9−rtable = MasterSlave.__remoteTable initRemoteTable

9+rtable = MasterSlave.__remoteTable initRemoteTable

11main :: IO ()

12main = do

@@ -14,12 +14,12 @@ main = do

15 case args of

16 ["master", host, port, strN, strSpawnStrategy] -> do

17− backend <- initializeBackend host port rtable

17+ backend <- initializeBackend host port rtable

18 n <- evaluate $ read strN

19 spawnStrategy <- evaluate $ read strSpawnStrategy

20 startMaster backend $ \slaves -> do

21 result <- MasterSlave.master n spawnStrategy slaves

22− liftIO $ print result

22+ liftIO $ print result

23 ["slave", host, port] -> do

24− backend <- initializeBackend host port rtable

24+ backend <- initializeBackend host port rtable

25 startSlave backend

distributed-process-demos/src/TypedWorkPushing/Azure.hs+7−7

@@ -2,13 +2,13 @@ import System.Environment (getArgs)

2import Control.Monad

3import Control.Distributed.Process

4import Control.Distributed.Process.Closure

5−import Control.Distributed.Process.Backend.Azure

5+import Control.Distributed.Process.Backend.Azure

6import qualified MasterSlave

8azureMaster :: ([NodeId], Integer) -> Backend -> Process ()

9azureMaster (slaves, n) _backend = do

10 result <- MasterSlave.master n slaves

11− mapM_ terminateNode slaves

11+ mapM_ terminateNode slaves

12 remoteSend result

14remotable ['azureMaster]

@@ -16,7 +16,7 @@ remotable ['azureMaster]

16printResult :: LocalProcess ()

17printResult = do

18 result <- localExpect :: LocalProcess Integer

19− liftIO $ print result

19+ liftIO $ print result

21main :: IO ()

22main = do

@@ -24,14 +24,14 @@ main = do

24 case args of

25 "onvm":args' -> onVmMain (__remoteTable . MasterSlave.__remoteTable) args'

26 [sid, x509, pkey, user, cloudService, n] -> do

27− params <- defaultAzureParameters sid x509 pkey

27+ params <- defaultAzureParameters sid x509 pkey

28 let params' = params { azureSshUserName = user }

29 backend <- initializeBackend params' cloudService

30 vms <- findVMs backend

31 print vms

32 nids <- forM vms $ \vm -> spawnNodeOnVM backend vm "8080"

33− callOnVM backend (head vms) "8081" $

33+ callOnVM backend (head vms) "8081" $

34− ProcessPair ($(mkClosure 'azureMaster) (nids, read n :: Integer))

34+ ProcessPair ($(mkClosure 'azureMaster) (nids, read n :: Integer))

35− printResult

35+ printResult

36 _ ->

37 error "Invalid command line arguments"

distributed-process-demos/src/TypedWorkPushing/SimpleLocalnet.hs+4−4

@@ -5,7 +5,7 @@ import Control.Distributed.Process.Backend.SimpleLocalnet

5import qualified TypedWorkPushing

7rtable :: RemoteTable

8−rtable = TypedWorkPushing.__remoteTable initRemoteTable

8+rtable = TypedWorkPushing.__remoteTable initRemoteTable

10main :: IO ()

11main = do

@@ -13,10 +13,10 @@ main = do

14 case args of

15 ["master", host, port, n] -> do

16− backend <- initializeBackend host port rtable

16+ backend <- initializeBackend host port rtable

17 startMaster backend $ \slaves -> do

18 result <- TypedWorkPushing.master (read n) slaves

19− liftIO $ print result

19+ liftIO $ print result

20 ["slave", host, port] -> do

21− backend <- initializeBackend host port rtable

21+ backend <- initializeBackend host port rtable

22 startSlave backend

distributed-process-demos/src/TypedWorkPushing/TypedWorkPushing.hs+7−7

@@ -7,7 +7,7 @@ import PrimeFactors

8slave :: SendPort Integer -> ReceivePort Integer -> Process ()

9slave results todo = forever $ do

10− n <- receiveChan todo

10+ n <- receiveChan todo

11 sendChan results (numPrimeFactors n)

13sdictInteger :: SerializableDict Integer

@@ -22,20 +22,20 @@ sumIntegers rport = go 0

22 go :: Integer -> Int -> Process Integer

23 go !acc 0 = return acc

24 go !acc n = do

25− m <- receiveChan rport

25+ m <- receiveChan rport

26 go (acc + m) (n - 1)

28master :: Integer -> [NodeId] -> Process Integer

29master n slaves = do

30 (sport, rport) <- newChan

32− -- Start slave processes

32+ -- Start slave processes

33− slaveProcesses <- forM slaves $ \nid ->

33+ slaveProcesses <- forM slaves $ \nid ->

34 spawnChannel $(mkStatic 'sdictInteger) nid ($(mkClosure 'slave) sport)

36− -- Distribute 1 .. n amongst the slave processes

36+ -- Distribute 1 .. n amongst the slave processes

37− spawnLocal $ forM_ (zip [1 .. n] (cycle slaveProcesses)) $

37+ spawnLocal $ forM_ (zip [1 .. n] (cycle slaveProcesses)) $

38− \(m, them) -> sendChan them m

38+ \(m, them) -> sendChan them m

40 -- Wait for the result

41 sumIntegers rport (fromIntegral n)

distributed-process-demos/src/WorkPushing/Azure.hs+7−7

@@ -2,13 +2,13 @@ import System.Environment (getArgs)

2import Control.Monad

3import Control.Distributed.Process

4import Control.Distributed.Process.Closure

5−import Control.Distributed.Process.Backend.Azure

5+import Control.Distributed.Process.Backend.Azure

6import qualified MasterSlave

8azureMaster :: ([NodeId], Integer) -> Backend -> Process ()

9azureMaster (slaves, n) _backend = do

10 result <- MasterSlave.master n slaves

11− mapM_ terminateNode slaves

11+ mapM_ terminateNode slaves

12 remoteSend result

14remotable ['azureMaster]

@@ -16,7 +16,7 @@ remotable ['azureMaster]

16printResult :: LocalProcess ()

17printResult = do

18 result <- localExpect :: LocalProcess Integer

19− liftIO $ print result

19+ liftIO $ print result

21main :: IO ()

22main = do

@@ -24,14 +24,14 @@ main = do

24 case args of

25 "onvm":args' -> onVmMain (__remoteTable . MasterSlave.__remoteTable) args'

26 [sid, x509, pkey, user, cloudService, n] -> do

27− params <- defaultAzureParameters sid x509 pkey

27+ params <- defaultAzureParameters sid x509 pkey

28 let params' = params { azureSshUserName = user }

29 backend <- initializeBackend params' cloudService

30 vms <- findVMs backend

31 print vms

32 nids <- forM vms $ \vm -> spawnNodeOnVM backend vm "8080"

33− callOnVM backend (head vms) "8081" $

33+ callOnVM backend (head vms) "8081" $

34− ProcessPair ($(mkClosure 'azureMaster) (nids, read n :: Integer))

34+ ProcessPair ($(mkClosure 'azureMaster) (nids, read n :: Integer))

35− printResult

35+ printResult

36 _ ->

37 error "Invalid command line arguments"

distributed-process-demos/src/WorkPushing/SimpleLocalnet.hs+4−4

@@ -5,7 +5,7 @@ import Control.Distributed.Process.Backend.SimpleLocalnet

5import qualified WorkPushing

7rtable :: RemoteTable

8−rtable = WorkPushing.__remoteTable initRemoteTable

8+rtable = WorkPushing.__remoteTable initRemoteTable

10main :: IO ()

11main = do

@@ -13,10 +13,10 @@ main = do

14 case args of

15 ["master", host, port, n] -> do

16− backend <- initializeBackend host port rtable

16+ backend <- initializeBackend host port rtable

17 startMaster backend $ \slaves -> do

18 result <- WorkPushing.master (read n) slaves

19− liftIO $ print result

19+ liftIO $ print result

20 ["slave", host, port] -> do

21− backend <- initializeBackend host port rtable

21+ backend <- initializeBackend host port rtable

22 startSlave backend

distributed-process-demos/src/WorkPushing/WorkPushing.hs+4−4

@@ -26,12 +26,12 @@ master :: Integer -> [NodeId] -> Process Integer

26master n slaves = do

27 us <- getSelfPid

29− -- Start slave processes

29+ -- Start slave processes

30 slaveProcesses <- forM slaves $ \nid -> spawn nid ($(mkClosure 'slave) us)

32− -- Distribute 1 .. n amongst the slave processes

32+ -- Distribute 1 .. n amongst the slave processes

33− spawnLocal $ forM_ (zip [1 .. n] (cycle slaveProcesses)) $

33+ spawnLocal $ forM_ (zip [1 .. n] (cycle slaveProcesses)) $

34− \(m, them) -> send them m

34+ \(m, them) -> send them m

36 -- Wait for the result

37 sumIntegers (fromIntegral n)

distributed-process-demos/src/WorkStealing/SimpleLocalnet.hs+4−4

@@ -5,7 +5,7 @@ import Control.Distributed.Process.Backend.SimpleLocalnet

5import qualified WorkStealing

7rtable :: RemoteTable

8−rtable = WorkStealing.__remoteTable initRemoteTable

8+rtable = WorkStealing.__remoteTable initRemoteTable

10main :: IO ()

11main = do

@@ -13,10 +13,10 @@ main = do

14 case args of

15 ["master", host, port, n] -> do

16− backend <- initializeBackend host port rtable

16+ backend <- initializeBackend host port rtable

17 startMaster backend $ \slaves -> do

18 result <- WorkStealing.master (read n) slaves

19− liftIO $ print result

19+ liftIO $ print result

20 ["slave", host, port] -> do

21− backend <- initializeBackend host port rtable

21+ backend <- initializeBackend host port rtable

22 startSlave backend

distributed-process-demos/src/WorkStealing/WorkStealing.hs+8−8

@@ -11,11 +11,11 @@ slave (master, workQueue) = do

11 go us

12 where

13 go us = do

14− -- Ask the queue for work

14+ -- Ask the queue for work

15 send workQueue us

16−

16+

17− -- If there is work, do it, otherwise terminate

17+ -- If there is work, do it, otherwise terminate

18− receiveWait

18+ receiveWait

19 [ match $ \n -> send master (numPrimeFactors n) >> go us

20 , match $ \() -> return ()

21 ]

@@ -37,17 +37,17 @@ master n slaves = do

37 us <- getSelfPid

39 workQueue <- spawnLocal $ do

40− -- Reply with the next bit of work to be done

40+ -- Reply with the next bit of work to be done

41 forM_ [1 .. n] $ \m -> do

42− them <- expect

42+ them <- expect

43− send them m

43+ send them m

45 -- Once all the work is done, tell the slaves to terminate

46 forever $ do

47 pid <- expect

48 send pid ()

50− -- Start slave processes

50+ -- Start slave processes

51 forM_ slaves $ \nid -> spawn nid ($(mkClosure 'slave) (us, workQueue))

53 -- Wait for the result

distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hs+52−52

@@ -3,41 +3,41 @@

3-- get you going with Cloud Haskell quickly without imposing any structure

4-- on your application.

5--

6−-- To simplify getting started we provide special support for /master/ and

6+-- To simplify getting started we provide special support for /master/ and

7-- /slave/ nodes (see 'startSlave' and 'startMaster'). Use of these functions

8-- is completely optional; you can use the local backend without making use

9-- of the predefined master and slave nodes.

10−--

10+--

11-- [Minimal example]

12--

13-- > import System.Environment (getArgs)

14-- > import Control.Distributed.Process

15-- > import Control.Distributed.Process.Node (initRemoteTable)

16-- > import Control.Distributed.Process.Backend.SimpleLocalnet

17−-- >

17+-- >

18-- > master :: Backend -> [NodeId] -> Process ()

19-- > master backend slaves = do

20-- > -- Do something interesting with the slaves

21-- > liftIO . putStrLn $ "Slaves: " ++ show slaves

22-- > -- Terminate the slaves when the master terminates (this is optional)

23-- > terminateAllSlaves backend

24−-- >

24+-- >

25-- > main :: IO ()

26-- > main = do

27-- > args <- getArgs

28−-- >

28+-- >

29-- > case args of

30-- > ["master", host, port] -> do

31−-- > backend <- initializeBackend host port initRemoteTable

31+-- > backend <- initializeBackend host port initRemoteTable

32-- > startMaster backend (master backend)

33-- > ["slave", host, port] -> do

34−-- > backend <- initializeBackend host port initRemoteTable

34+-- > backend <- initializeBackend host port initRemoteTable

35-- > startSlave backend

36−--

36+--

37-- [Compiling and Running]

38--

39-- Save to @example.hs@ and compile using

40−--

40+--

41-- > ghc -threaded example.hs

42--

43-- Fire up some slave nodes (for the example, we run them on a single machine):

@@ -68,7 +68,7 @@

68-- master on a fifth node (or on any of the four machines that run the slave

69-- nodes).

70--

71−-- It is important that every node has a unique (hostname, port number) pair,

71+-- It is important that every node has a unique (hostname, port number) pair,

72-- and that the hostname you use to initialize the node can be resolved by

73-- peer nodes. In other words, if you start a node and pass hostname @localhost@

74-- then peer nodes won't be able to reach it because @localhost@ will resolve

@@ -79,10 +79,10 @@

79-- If you try the above example and the master process cannot find any slaves,

80-- then it might be that your firewall settings do not allow for UDP multicast

81-- (in particular, the default iptables on some Linux distributions might not

82−-- allow it).

82+-- allow it).

83{-# OPTIONS_GHC -fno-warn-orphans #-}

84module Control.Distributed.Process.Backend.SimpleLocalnet

85− ( -- * Initialization

85+ ( -- * Initialization

86 Backend(..)

87 , initializeBackend

88 -- * Slave nodes

@@ -128,13 +128,13 @@ import Control.Distributed.Process

128 , unmonitor

129 , NodeMonitorNotification(..)

130 )

131−import qualified Control.Distributed.Process.Node as Node

131+import qualified Control.Distributed.Process.Node as Node

132 ( LocalNode

133 , newLocalNode

134 , localNodeId

135 , runProcess

136 )

137−import qualified Network.Transport.TCP as NT

137+import qualified Network.Transport.TCP as NT

138 ( createTransport

139 , defaultTCPParameters

140 )

@@ -142,7 +142,7 @@ import qualified Network.Transport as NT (Transport)

142import qualified Network.Socket as N (HostName, ServiceName, SockAddr)

143import Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast)

144

145−-- | Local backend

145+-- | Local backend

146data Backend = Backend {

147 -- | Create a new local node

148 newLocalNode :: IO Node.LocalNode

@@ -164,64 +164,64 @@ data BackendState = BackendState {

164-- | Initialize the backend

165initializeBackend :: N.HostName -> N.ServiceName -> RemoteTable -> IO Backend

166initializeBackend host port rtable = do

167− mTransport <- NT.createTransport host port NT.defaultTCPParameters

167+ mTransport <- NT.createTransport host port NT.defaultTCPParameters

168 (recv, send) <- initMulticast "224.0.0.99" 9999 1024

169 (_, backendState) <- fixIO $ \ ~(tid, _) -> do

170− backendState <- newMVar BackendState

170+ backendState <- newMVar BackendState

171− { _localNodes = []

171+ { _localNodes = []

172 , _peers = Set.empty

173 , discoveryDaemon = tid

174 }

175− tid' <- forkIO $ peerDiscoveryDaemon backendState recv send

175+ tid' <- forkIO $ peerDiscoveryDaemon backendState recv send

176 return (tid', backendState)

177 case mTransport of

178 Left err -> throw err

179− Right transport ->

179+ Right transport ->

180 let backend = Backend {

181− newLocalNode = apiNewLocalNode transport rtable backendState

181+ newLocalNode = apiNewLocalNode transport rtable backendState

182 , findPeers = apiFindPeers send backendState

183− , redirectLogsHere = apiRedirectLogsHere backend

183+ , redirectLogsHere = apiRedirectLogsHere backend

184 }

185 in return backend

186

187-- | Create a new local node

188−apiNewLocalNode :: NT.Transport

188+apiNewLocalNode :: NT.Transport

189− -> RemoteTable

189+ -> RemoteTable

190 -> MVar BackendState

191 -> IO Node.LocalNode

192apiNewLocalNode transport rtable backendState = do

193− localNode <- Node.newLocalNode transport rtable

193+ localNode <- Node.newLocalNode transport rtable

194 modifyMVar_ backendState $ return . (localNodes ^: (localNode :))

195 return localNode

196

197-- | Peer discovery

198−apiFindPeers :: (PeerDiscoveryMsg -> IO ())

198+apiFindPeers :: (PeerDiscoveryMsg -> IO ())

199− -> MVar BackendState

199+ -> MVar BackendState

200 -> Int

201 -> IO [NodeId]

202apiFindPeers send backendState delay = do

203− send PeerDiscoveryRequest

203+ send PeerDiscoveryRequest

204− threadDelay delay

204+ threadDelay delay

205− Set.toList . (^. peers) <$> readMVar backendState

205+ Set.toList . (^. peers) <$> readMVar backendState

206

207−data PeerDiscoveryMsg =

207+data PeerDiscoveryMsg =

208− PeerDiscoveryRequest

208+ PeerDiscoveryRequest

209 | PeerDiscoveryReply NodeId

210

211instance Binary PeerDiscoveryMsg where

212 put PeerDiscoveryRequest = putWord8 0

213 put (PeerDiscoveryReply nid) = putWord8 1 >> put nid

214 get = do

215− header <- getWord8

215+ header <- getWord8

216 case header of

217 0 -> return PeerDiscoveryRequest

218 1 -> PeerDiscoveryReply <$> get

219 _ -> fail "PeerDiscoveryMsg.get: invalid"

220

221-- | Respond to peer discovery requests sent by other nodes

222−peerDiscoveryDaemon :: MVar BackendState

222+peerDiscoveryDaemon :: MVar BackendState

223 -> IO (PeerDiscoveryMsg, N.SockAddr)

224− -> (PeerDiscoveryMsg -> IO ())

224+ -> (PeerDiscoveryMsg -> IO ())

225 -> IO ()

226peerDiscoveryDaemon backendState recv send = forever go

227 where

@@ -230,7 +230,7 @@ peerDiscoveryDaemon backendState recv send = forever go

230 case msg of

231 PeerDiscoveryRequest -> do

232 nodes <- (^. localNodes) <$> readMVar backendState

233− forM_ nodes $ send . PeerDiscoveryReply . Node.localNodeId

233+ forM_ nodes $ send . PeerDiscoveryReply . Node.localNodeId

234 PeerDiscoveryReply nid ->

235 modifyMVar_ backendState $ return . (peers ^: Set.insert nid)

236

@@ -243,7 +243,7 @@ apiRedirectLogsHere :: Backend -> Process ()

243apiRedirectLogsHere backend = do

244 mLogger <- whereis "logger"

245 forM_ mLogger $ \logger -> do

246− nids <- liftIO $ findPeers backend 1000000

246+ nids <- liftIO $ findPeers backend 1000000

247 forM_ nids $ \nid -> reregisterRemoteAsync nid "logger" logger -- ignore async response

248

249--------------------------------------------------------------------------------

@@ -254,12 +254,12 @@ apiRedirectLogsHere backend = do

254--

255-- This datatype is not exposed; instead, we expose primitives for dealing

256-- with slaves.

257−data SlaveControllerMsg =

257+data SlaveControllerMsg =

258 SlaveTerminate

259 deriving (Typeable, Show)

260

261instance Binary SlaveControllerMsg where

262− put SlaveTerminate = putWord8 0

262+ put SlaveTerminate = putWord8 0

263 get = do

264 header <- getWord8

265 case header of

@@ -273,8 +273,8 @@ instance Binary SlaveControllerMsg where

273-- the process or call terminateSlave from another node.

274startSlave :: Backend -> IO ()

275startSlave backend = do

276− node <- newLocalNode backend

276+ node <- newLocalNode backend

277− Node.runProcess node slaveController

277+ Node.runProcess node slaveController

278

279-- | The slave controller interprets 'SlaveControllerMsg's

280slaveController :: Process ()

@@ -295,26 +295,26 @@ terminateSlave nid = nsendRemote nid "slaveController" SlaveTerminate

295-- | Find slave nodes

296findSlaves :: Backend -> Process [NodeId]

297findSlaves backend = do

298− nodes <- liftIO $ findPeers backend 1000000

298+ nodes <- liftIO $ findPeers backend 1000000

299 -- Fire of asynchronous requests for the slave controller

300 refs <- forM nodes $ \nid -> do

301− whereisRemoteAsync nid "slaveController"

301+ whereisRemoteAsync nid "slaveController"

302 ref <- monitorNode nid

303 return (nid, ref)

304 -- Wait for the replies

305− catMaybes <$> replicateM (length nodes) (

305+ catMaybes <$> replicateM (length nodes) (

306− receiveWait

306+ receiveWait

307 [ matchIf (\(WhereIsReply label _) -> label == "slaveController")

308− (\(WhereIsReply _ mPid) ->

308+ (\(WhereIsReply _ mPid) ->

309 case mPid of

310− Nothing ->

310+ Nothing ->

311 return Nothing

312 Just pid -> do

313 let nid = processNodeId pid

314 Just ref = lookup nid refs

315− unmonitor ref

315+ unmonitor ref

316 return (Just nid))

317− , match (\(NodeMonitorNotification {}) -> return Nothing)

317+ , match (\(NodeMonitorNotification {}) -> return Nothing)

318 ])

319

320-- | Terminate all slaves

@@ -330,15 +330,15 @@ terminateAllSlaves backend = do

330

331-- | 'startMaster' finds all slaves /currently/ available on the local network,

332-- redirects all log messages to itself, and then calls the specified process,

333−-- passing the list of slaves nodes.

333+-- passing the list of slaves nodes.

334--

335-- Terminates when the specified process terminates. If you want to terminate

336−-- the slaves when the master terminates, you should manually call

336+-- the slaves when the master terminates, you should manually call

337-- 'terminateAllSlaves'.

338--

339-- If you start more slave nodes after having started the master node, you can

340-- discover them with later calls to 'findSlaves', but be aware that you will

341−-- need to call 'redirectLogHere' to redirect their logs to the master node.

341+-- need to call 'redirectLogHere' to redirect their logs to the master node.

342--

343-- Note that you can use functionality of "SimpleLocalnet" directly (through

344-- 'Backend'), instead of using 'startMaster'/'startSlave', if the master/slave

distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.hs+19−19

@@ -8,7 +8,7 @@ import qualified Data.Map as Map (empty)

8import Data.Binary (Binary, decode, encode)

9import Data.IORef (IORef, newIORef, readIORef, modifyIORef)

10import qualified Data.ByteString as BSS (ByteString, concat)

11−import qualified Data.ByteString.Lazy as BSL

11+import qualified Data.ByteString.Lazy as BSL

12 ( ByteString

13 , empty

14 , append

@@ -38,10 +38,10 @@ import Network.Multicast (multicastSender, multicastReceiver)

38--

39-- NOTE: By rights the two functions should be "locally" polymorphic in 'a',

40-- but this requires impredicative types.

41−initMulticast :: forall a. Binary a

41+initMulticast :: forall a. Binary a

42 => HostName -- ^ Multicast IP

43 -> PortNumber -- ^ Port number

44− -> Int -- ^ Maximum message size

44+ -> Int -- ^ Maximum message size

45 -> IO (IO (a, SockAddr), a -> IO ())

46initMulticast host port bufferSize = do

47 (sendSock, sendAddr) <- multicastSender host port

@@ -50,8 +50,8 @@ initMulticast host port bufferSize = do

50 return (recvBinary readSock st bufferSize, writer sendSock sendAddr)

51 where

52 writer :: forall a. Binary a => Socket -> SockAddr -> a -> IO ()

53− writer sock addr val = do

53+ writer sock addr val = do

54− let bytes = encode val

54+ let bytes = encode val

55 len = encodeInt32 (BSL.length bytes)

56 NBS.sendManyTo sock (len : BSL.toChunks bytes) addr

@@ -59,7 +59,7 @@ initMulticast host port bufferSize = do

59-- UDP multicast read, dealing with multiple senders --

60--------------------------------------------------------------------------------

62−type UDPState = Map SockAddr BSL.ByteString

62+type UDPState = Map SockAddr BSL.ByteString

64#if MIN_VERSION_network(2,4,0)

65-- network-2.4.0 provides the Ord instance for us

@@ -72,16 +72,16 @@ bufferFor :: SockAddr -> Accessor UDPState BSL.ByteString

72bufferFor = DAC.mapDefault BSL.empty

74bufferAppend :: SockAddr -> BSS.ByteString -> UDPState -> UDPState

75−bufferAppend addr bytes =

75+bufferAppend addr bytes =

76− bufferFor addr ^: flip BSL.append (BSL.fromChunks [bytes])

76+ bufferFor addr ^: flip BSL.append (BSL.fromChunks [bytes])

78recvBinary :: Binary a => Socket -> IORef UDPState -> Int -> IO (a, SockAddr)

79recvBinary sock st bufferSize = do

80 (bytes, addr) <- recvWithLength sock st bufferSize

81 return (decode bytes, addr)

83−recvWithLength :: Socket

83+recvWithLength :: Socket

84− -> IORef UDPState

84+ -> IORef UDPState

85 -> Int

86 -> IO (BSL.ByteString, SockAddr)

87recvWithLength sock st bufferSize = do

@@ -93,13 +93,13 @@ recvWithLength sock st bufferSize = do

93-- Receive all bytes currently in the buffer

94recvAll :: Socket -> IORef UDPState -> Int -> IO SockAddr

95recvAll sock st bufferSize = do

96− (bytes, addr) <- NBS.recvFrom sock bufferSize

96+ (bytes, addr) <- NBS.recvFrom sock bufferSize

97 modifyIORef st $ bufferAppend addr bytes

98 return addr

99−

99+

100−recvExact :: Socket

100+recvExact :: Socket

101− -> Int

101+ -> Int

102− -> IORef UDPState

102+ -> IORef UDPState

103 -> Int

104 -> IO (BSL.ByteString, SockAddr)

105recvExact sock n st bufferSize = do

@@ -113,16 +113,16 @@ recvExactFrom :: SockAddr

113 -> IORef UDPState

114 -> Int

115 -> IO BSL.ByteString

116−recvExactFrom addr sock n st bufferSize = go

116+recvExactFrom addr sock n st bufferSize = go

117 where

118 go :: IO BSL.ByteString

119 go = do

120− accAddr <- (^. bufferFor addr) <$> readIORef st

120+ accAddr <- (^. bufferFor addr) <$> readIORef st

121− if BSL.length accAddr >= fromIntegral n

121+ if BSL.length accAddr >= fromIntegral n

122 then do

123 let (bytes, accAddr') = BSL.splitAt (fromIntegral n) accAddr

124 modifyIORef st $ bufferFor addr ^= accAddr'

125 return bytes

126− else do

126+ else do

127 _ <- recvAll sock st bufferSize

128 go

distributed-process-simplelocalnet/tests/TestSimpleLocalnet.hs+3−3

@@ -15,10 +15,10 @@ main = do

16 case args of

17 ["master", host, port] -> do

18− backend <- initializeBackend host port initRemoteTable

18+ backend <- initializeBackend host port initRemoteTable

19 startMaster backend (master backend)

20 ["slave", host, port] -> do

21− backend <- initializeBackend host port initRemoteTable

21+ backend <- initializeBackend host port initRemoteTable

22 startSlave backend

23− _ ->

23+ _ ->

24 putStrLn $ "usage: " ++ prog ++ " (master | slave) host port"

distributed-process-simplelocalnet/tests/runTestSimpleLocalnet.hs+4−4

@@ -1,11 +1,11 @@

1#!/bin/bash

2TestSimpleLocalnet=dist/build/TestSimpleLocalnet/TestSimpleLocalnet

3−$TestSimpleLocalnet slave 127.0.0.1 8080 &

3+$TestSimpleLocalnet slave 127.0.0.1 8080 &

4sleep 1

5−$TestSimpleLocalnet slave 127.0.0.1 8081 &

5+$TestSimpleLocalnet slave 127.0.0.1 8081 &

6sleep 1

7−$TestSimpleLocalnet slave 127.0.0.1 8082 &

7+$TestSimpleLocalnet slave 127.0.0.1 8082 &

8sleep 1

9−$TestSimpleLocalnet slave 127.0.0.1 8083 &

9+$TestSimpleLocalnet slave 127.0.0.1 8083 &

10sleep 1

11$TestSimpleLocalnet master 127.0.0.1 8084

distributed-process/benchmarks/Channels.hs+4−4

@@ -23,11 +23,11 @@ pingClient n them = do

23 receiveChan rc

24 liftIO . putStrLn $ "Did " ++ show n ++ " pings"

26−initialProcess :: String -> Process ()

26+initialProcess :: String -> Process ()

27initialProcess "SERVER" = do

28 us <- getSelfPid

29 liftIO $ BSL.writeFile "pingServer.pid" (encode us)

30− pingServer

30+ pingServer

31initialProcess "CLIENT" = do

32 n <- liftIO $ getLine

33 them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"

@@ -37,5 +37,5 @@ main :: IO ()

37main = do

38 [role, host, port] <- getArgs

39 Right transport <- createTransport host port defaultTCPParameters

40− node <- newLocalNode transport initRemoteTable

40+ node <- newLocalNode transport initRemoteTable

41− runProcess node $ initialProcess role

41+ runProcess node $ initialProcess role

distributed-process/benchmarks/Latency.hs+4−4

@@ -18,11 +18,11 @@ pingClient n them = do

18 replicateM_ n $ send them us >> (expect :: Process ())

19 liftIO . putStrLn $ "Did " ++ show n ++ " pings"

21−initialProcess :: String -> Process ()

21+initialProcess :: String -> Process ()

22initialProcess "SERVER" = do

23 us <- getSelfPid

24 liftIO $ BSL.writeFile "pingServer.pid" (encode us)

25− pingServer

25+ pingServer

26initialProcess "CLIENT" = do

27 n <- liftIO $ getLine

28 them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"

@@ -32,5 +32,5 @@ main :: IO ()

32main = do

33 [role, host, port] <- getArgs

34 Right transport <- createTransport host port defaultTCPParameters

35− node <- newLocalNode transport initRemoteTable

35+ node <- newLocalNode transport initRemoteTable

36− runProcess node $ initialProcess role

36+ runProcess node $ initialProcess role

distributed-process/benchmarks/Spawns.hs+4−4

@@ -12,7 +12,7 @@ import qualified Data.ByteString.Lazy as BSL

12counter :: Process ()

13counter = go 0

14 where

15− go :: Int -> Process ()

15+ go :: Int -> Process ()

16 go !n = do

17 b <- expect

18 case b of

@@ -27,7 +27,7 @@ count n them = do

27 n' <- expect

28 liftIO $ print (n == n')

30−initialProcess :: String -> Process ()

30+initialProcess :: String -> Process ()

31initialProcess "SERVER" = do

32 us <- getSelfPid

33 liftIO $ BSL.writeFile "counter.pid" (encode us)

@@ -41,5 +41,5 @@ main :: IO ()

41main = do

42 [role, host, port] <- getArgs

43 Right transport <- createTransport host port defaultTCPParameters

44− node <- newLocalNode transport initRemoteTable

44+ node <- newLocalNode transport initRemoteTable

45− runProcess node $ initialProcess role

45+ runProcess node $ initialProcess role

distributed-process/benchmarks/Throughput.hs+7−7

@@ -14,8 +14,8 @@ data SizedList a = SizedList { size :: Int , elems :: [a] }

15instance Binary a => Binary (SizedList a) where

16 put (SizedList sz xs) = put sz >> mapM_ put xs

17− get = do

17+ get = do

18− sz <- get

18+ sz <- get

19 xs <- getMany sz

20 return (SizedList sz xs)

@@ -37,9 +37,9 @@ nats = \n -> SizedList n (aux n)

37counter :: Process ()

38counter = go 0

39 where

40− go :: Int -> Process ()

40+ go :: Int -> Process ()

41 go !n =

42− receiveWait

42+ receiveWait

43 [ match $ \xs -> go (n + size (xs :: SizedList Int))

44 , match $ \them -> send them n >> go 0

45 ]

@@ -52,7 +52,7 @@ count (packets, sz) them = do

52 n' <- expect

53 liftIO $ print (packets * sz, n' == packets * sz)

55−initialProcess :: String -> Process ()

55+initialProcess :: String -> Process ()

56initialProcess "SERVER" = do

57 us <- getSelfPid

58 liftIO $ BSL.writeFile "counter.pid" (encode us)

@@ -66,5 +66,5 @@ main :: IO ()

66main = do

67 [role, host, port] <- getArgs

68 Right transport <- createTransport host port defaultTCPParameters

69− node <- newLocalNode transport initRemoteTable

69+ node <- newLocalNode transport initRemoteTable

70− runProcess node $ initialProcess role

70+ runProcess node $ initialProcess role

distributed-process/benchmarks/remote/Latency.hs+3−3

@@ -18,15 +18,15 @@ pingClient n them = do

18 replicateM_ n $ send them us >> (expect :: ProcessM ())

19 liftIO . putStrLn $ "Did " ++ show n ++ " pings"

21−initialProcess :: String -> ProcessM ()

21+initialProcess :: String -> ProcessM ()

22initialProcess "SERVER" = do

23 us <- getSelfPid

24 liftIO $ BSL.writeFile "pingServer.pid" (encode us)

25− pingServer

25+ pingServer

26initialProcess "CLIENT" = do

27 n <- liftIO $ getLine

28 them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"

29 pingClient (read n) them

31main :: IO ()

32−main = remoteInit (Just "config") [] initialProcess

32+main = remoteInit (Just "config") [] initialProcess

distributed-process/benchmarks/remote/Throughput.hs+3−3

@@ -10,7 +10,7 @@ import Remote

10counter :: ProcessM ()

11counter = go 0

12 where

13− go :: Int -> ProcessM ()

13+ go :: Int -> ProcessM ()

14 go !n = do

15 b <- expect

16 case b of

@@ -25,7 +25,7 @@ count n them = do

25 n' <- expect

26 liftIO $ print (n == n')

28−initialProcess :: String -> ProcessM ()

28+initialProcess :: String -> ProcessM ()

29initialProcess "SERVER" = do

30 us <- getSelfPid

31 liftIO $ BSL.writeFile "counter.pid" (encode us)

@@ -36,4 +36,4 @@ initialProcess "CLIENT" = do

36 count (read n) them

38main :: IO ()

39−main = remoteInit (Just "config") [] initialProcess

39+main = remoteInit (Just "config") [] initialProcess

distributed-process/src/Control/Distributed/Process.hs+42−42

@@ -1,14 +1,14 @@

1-- | [Cloud Haskell]

2−--

2+--

3−-- This is an implementation of Cloud Haskell, as described in

3+-- This is an implementation of Cloud Haskell, as described in

4-- /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black, and Simon

5-- Peyton Jones

6-- (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),

7-- although some of the details are different. The precise message passing

8-- semantics are based on /A unified semantics for future Erlang/ by Hans

9-- Svensson, Lars-Åke Fredlund and Clara Benac Earle.

10−module Control.Distributed.Process

10+module Control.Distributed.Process

11− ( -- * Basic types

11+ ( -- * Basic types

12 ProcessId

13 , NodeId

14 , Process

@@ -17,7 +17,7 @@ module Control.Distributed.Process

17 , sendPortProcessId

18 , liftIO -- Reexported for convenience

19 -- * Basic messaging

20− , send

20+ , send

21 , expect

22 , expectTimeout

23 -- * Channels

@@ -37,7 +37,7 @@ module Control.Distributed.Process

37 , match

38 , matchIf

39 , matchUnknown

40− , AbstractMessage(..)

40+ , AbstractMessage(..)

41 , matchAny

42 -- * Process management

43 , spawn

@@ -102,7 +102,7 @@ module Control.Distributed.Process

102 , spawnMonitor

103 , spawnChannel

104 , DidSpawn(..)

105− -- * Local versions of 'spawn'

105+ -- * Local versions of 'spawn'

106 , spawnLocal

107 , spawnChannelLocal

108 -- * Reconnecting

@@ -119,7 +119,7 @@ import Control.Monad.IO.Class (liftIO)

119import Control.Applicative ((<$>))

120import Control.Monad.Reader (ask)

121import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)

122−import Control.Distributed.Static

122+import Control.Distributed.Static

123 ( Closure

124 , closure

125 , Static

@@ -127,7 +127,7 @@ import Control.Distributed.Static

127 , closureCompose

128 , staticClosure

129 )

130−import Control.Distributed.Process.Internal.Types

130+import Control.Distributed.Process.Internal.Types

131 ( NodeId(..)

132 , ProcessId(..)

133 , Process(..)

@@ -154,8 +154,8 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn

154 ( sdictSendPort

155 , sndStatic

156 , idCP

157− , seqCP

157+ , seqCP

158− , bindCP

158+ , bindCP

159 , splitCP

160 , cpLink

161 , cpSend

@@ -164,7 +164,7 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn

164 )

165import Control.Distributed.Process.Internal.Primitives

166 ( -- Basic messaging

167− send

167+ send

168 , expect

169 -- Channels

170 , newChan

@@ -179,7 +179,7 @@ import Control.Distributed.Process.Internal.Primitives

179 , match

180 , matchIf

181 , matchUnknown

182− , AbstractMessage(..)

182+ , AbstractMessage(..)

183 , matchAny

184 -- Process management

185 , terminate

@@ -231,7 +231,7 @@ import Control.Distributed.Process.Internal.Primitives

231import Control.Distributed.Process.Node (forkProcess)

232

233-- INTERNAL NOTES

234−--

234+--

235-- 1. 'send' never fails. If you want to know that the remote process received

236-- your message, you will need to send an explicit acknowledgement. If you

237-- want to know when the remote process failed, you will need to monitor

@@ -269,17 +269,17 @@ import Control.Distributed.Process.Node (forkProcess)

269-- http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf

270--

271-- The precise semantics for message passing is based on

272−--

272+--

273-- [2] "A Unified Semantics for Future Erlang", Hans Svensson, Lars-Ake Fredlund

274-- and Clara Benac Earle (not freely available online, unfortunately)

275--

276-- Some pointers to related documentation about Erlang, for comparison and

277−-- inspiration:

277+-- inspiration:

278--

279-- [3] "Programming Distributed Erlang Applications: Pitfalls and Recipes",

280−-- Hans Svensson and Lars-Ake Fredlund

280+-- Hans Svensson and Lars-Ake Fredlund

281-- http://man.lupaworld.com/content/develop/p37-svensson.pdf

282−-- [4] The Erlang manual, sections "Message Sending" and "Send"

282+-- [4] The Erlang manual, sections "Message Sending" and "Send"

283-- http://www.erlang.org/doc/reference_manual/processes.html#id82409

284-- http://www.erlang.org/doc/reference_manual/expressions.html#send

285-- [5] Questions "Is the order of message reception guaranteed?" and

@@ -297,9 +297,9 @@ import Control.Distributed.Process.Node (forkProcess)

297-- | Spawn a process

298--

299-- For more information about 'Closure', see

300−-- "Control.Distributed.Process.Closure".

300+-- "Control.Distributed.Process.Closure".

301--

302−-- See also 'call'.

302+-- See also 'call'.

303spawn :: NodeId -> Closure (Process ()) -> Process ProcessId

304spawn nid proc = do

305 us <- getSelfPid

@@ -316,7 +316,7 @@ spawn nid proc = do

316

317-- | Spawn a process and link to it

318--

319−-- Note that this is just the sequential composition of 'spawn' and 'link'.

319+-- Note that this is just the sequential composition of 'spawn' and 'link'.

320-- (The "Unified" semantics that underlies Cloud Haskell does not even support

321-- a synchronous link operation)

322spawnLink :: NodeId -> Closure (Process ()) -> Process ProcessId

@@ -333,16 +333,16 @@ spawnMonitor nid proc = do

333 return (pid, ref)

334

335-- | Run a process remotely and wait for it to reply

336−--

336+--

337-- We monitor the remote process: if it dies before it can send a reply, we die

338-- too.

339--

340-- For more information about 'Static', 'SerializableDict', and 'Closure', see

341−-- "Control.Distributed.Process.Closure".

341+-- "Control.Distributed.Process.Closure".

342--

343−-- See also 'spawn'.

343+-- See also 'spawn'.

344call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a

345−call dict nid proc = do

345+call dict nid proc = do

346 us <- getSelfPid

347 (pid, mRef) <- spawnMonitor nid (proc `bindCP` cpSend dict us)

348 -- We are guaranteed to receive the reply before the monitor notification

@@ -355,25 +355,25 @@ call dict nid proc = do

355 ]

356 case mResult of

357 Right a -> do

358− -- Wait for the monitor message so that we the mailbox doesn't grow

358+ -- Wait for the monitor message so that we the mailbox doesn't grow

359− receiveWait

359+ receiveWait

360 [ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)

361 (\(ProcessMonitorNotification {}) -> return ())

362 ]

363 -- Clean up connection to pid

364 reconnect pid

365 return a

366− Left err ->

366+ Left err ->

367− fail $ "call: remote process died: " ++ show err

367+ fail $ "call: remote process died: " ++ show err

368

369-- | Spawn a child process, have the child link to the parent and the parent

370-- monitor the child

371−spawnSupervised :: NodeId

371+spawnSupervised :: NodeId

372− -> Closure (Process ())

372+ -> Closure (Process ())

373 -> Process (ProcessId, MonitorRef)

374spawnSupervised nid proc = do

375 us <- getSelfPid

376− them <- spawn nid (cpLink us `seqCP` proc)

376+ them <- spawn nid (cpLink us `seqCP` proc)

377 ref <- monitor them

378 return (them, ref)

379

@@ -381,19 +381,19 @@ spawnSupervised nid proc = do

381-- the corresponding 'SendPort'.

382spawnChannel :: forall a. Typeable a => Static (SerializableDict a)

383 -> NodeId

384− -> Closure (ReceivePort a -> Process ())

384+ -> Closure (ReceivePort a -> Process ())

385 -> Process (SendPort a)

386spawnChannel dict nid proc = do

387 us <- getSelfPid

388− spawn nid (go us)

388+ spawn nid (go us)

389 expect

390 where

391 go :: ProcessId -> Closure (Process ())

392− go pid = cpNewChan dict

392+ go pid = cpNewChan dict

393− `bindCP`

393+ `bindCP`

394 (cpSend (sdictSendPort dict) pid `splitCP` proc)

395 `bindCP`

396− (idCP `closureCompose` staticClosure sndStatic)

396+ (idCP `closureCompose` staticClosure sndStatic)

397

398--------------------------------------------------------------------------------

399-- Local versions of spawn --

@@ -402,16 +402,16 @@ spawnChannel dict nid proc = do

402-- | Spawn a process on the local node

403spawnLocal :: Process () -> Process ProcessId

404spawnLocal proc = do

405− node <- processNode <$> ask

405+ node <- processNode <$> ask

406 liftIO $ forkProcess node proc

407

408-- | Create a new typed channel, spawn a process on the local node, passing it

409-- the receive port, and return the send port

410spawnChannelLocal :: Serializable a

411− => (ReceivePort a -> Process ())

411+ => (ReceivePort a -> Process ())

412 -> Process (SendPort a)

413−spawnChannelLocal proc = do

413+spawnChannelLocal proc = do

414− node <- processNode <$> ask

414+ node <- processNode <$> ask

415 liftIO $ do

416 mvar <- newEmptyMVar

417 forkProcess node $ do

@@ -420,4 +420,4 @@ spawnChannelLocal proc = do

420 (sport, rport) <- newChan

421 liftIO $ putMVar mvar sport

422 proc rport

423− takeMVar mvar

423+ takeMVar mvar

distributed-process/src/Control/Distributed/Process/Closure.hs+39−39

@@ -15,15 +15,15 @@

15-- > f = ...

16--

17-- you can use a Template Haskell splice to create a static version of 'f':

18−--

18+--

19-- > $(mkStatic 'f) :: forall a1 .. an. (Typeable a1, .., Typeable an) => Static T

20−--

20+--

21-- Every module that you write that contains calls to 'mkStatic' needs to

22-- have a call to 'remotable':

23--

24-- > remotable [ 'f, 'g, ... ]

25--

26−-- where you must pass every function (or other value) that you pass as an

26+-- where you must pass every function (or other value) that you pass as an

27-- argument to 'mkStatic'. The call to 'remotable' will create a definition

28--

29-- > __remoteTable :: RemoteTable -> RemoteTable

@@ -32,12 +32,12 @@

32-- Cloud Haskell. You should have (at most) one call to 'remotable' per module,

33-- and compose all created functions when initializing Cloud Haskell:

34--

35−-- > let rtable :: RemoteTable

35+-- > let rtable :: RemoteTable

36-- > rtable = M1.__remoteTable

37-- > . M2.__remoteTable

38-- > . ...

39-- > . Mn.__remoteTable

40−-- > $ initRemoteTable

40+-- > $ initRemoteTable

41--

42-- NOTE: If you get a type error from ghc along these lines

43--

@@ -52,19 +52,19 @@

52--

53-- > call :: Serializable a => Static (SerializableDict a) -> NodeId -> Closure (Process a) -> Process a

54--

55−-- Given some serializable type 'T' you can define

55+-- Given some serializable type 'T' you can define

56--

57-- > sdictT :: SerializableDict T

58-- > sdictT = SerializableDict

59--

60-- and then have

61−--

61+--

62-- > $(mkStatic 'sdictT) :: Static (SerializableDict T)

63--

64-- However, since these dictionaries are so frequently required Cloud Haskell

65-- provides special support for them. When you call 'remotable' on a

66-- /monomorphic/ function @f :: T1 -> T2@

67−--

67+--

68-- > remotable ['f]

69--

70-- then a serialization dictionary is automatically created for you, which you

@@ -80,26 +80,26 @@

80--

81-- Suppose you have a process

82--

83−-- > isPrime :: Integer -> Process Bool

83+-- > isPrime :: Integer -> Process Bool

84--

85−-- Then

85+-- Then

86--

87-- > $(mkClosure 'isPrime) :: Integer -> Closure (Process Bool)

88--

89−-- which you can then 'call', for example, to have a remote node check if

89+-- which you can then 'call', for example, to have a remote node check if

90-- a number is prime.

91--

92-- In general, if you have a /monomorphic/ function

93--

94-- > f :: T1 -> T2

95−--

95+--

96-- then

97--

98-- > $(mkClosure 'f) :: T1 -> Closure T2

99--

100-- provided that 'T1' is serializable (*) (remember to pass 'f' to 'remotable').

101--

102−-- (You can also create closures manually--see the documentation of

102+-- (You can also create closures manually--see the documentation of

103-- "Control.Distributed.Static" for examples.)

104--

105-- [Example]

@@ -114,34 +114,34 @@

114-- > import Control.Distributed.Process.Closure

115-- > import Control.Distributed.Process.Backend.SimpleLocalnet

116-- > import Control.Distributed.Process.Node (initRemoteTable)

117−-- >

117+-- >

118-- > isPrime :: Integer -> Process Bool

119-- > isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]

120-- > where

121-- > sieve :: [Integer] -> [Integer]

122-- > sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]

123−-- >

123+-- >

124-- > remotable ['isPrime]

125−-- >

125+-- >

126-- > master :: [NodeId] -> Process ()

127-- > master [] = liftIO $ putStrLn "no slaves"

128-- > master (slave:_) = do

129-- > isPrime79 <- call $(functionTDict 'isPrime) slave ($(mkClosure 'isPrime) (79 :: Integer))

130−-- > liftIO $ print isPrime79

130+-- > liftIO $ print isPrime79

131−-- >

131+-- >

132-- > main :: IO ()

133-- > main = do

134-- > args <- getArgs

135-- > case args of

136-- > ["master", host, port] -> do

137−-- > backend <- initializeBackend host port rtable

137+-- > backend <- initializeBackend host port rtable

138−-- > startMaster backend master

138+-- > startMaster backend master

139-- > ["slave", host, port] -> do

140−-- > backend <- initializeBackend host port rtable

140+-- > backend <- initializeBackend host port rtable

141-- > startSlave backend

142-- > where

143-- > rtable :: RemoteTable

144−-- > rtable = __remoteTable initRemoteTable

144+-- > rtable = __remoteTable initRemoteTable

145--

146-- [Notes]

147--

@@ -150,34 +150,34 @@

150-- a priori if 'T1' is serializable or not due to a bug in the Template

151-- Haskell libraries (<http://hackage.haskell.org/trac/ghc/ticket/7066>)

152--

153−-- (**) Even though 'call' is passed an explicit serialization

153+-- (**) Even though 'call' is passed an explicit serialization

154−-- dictionary, we still need the 'Serializable' constraint because

154+-- dictionary, we still need the 'Serializable' constraint because

155-- 'Static' is not the /true/ static. If it was, we could 'unstatic'

156-- the dictionary and pattern match on it to bring the 'Typeable'

157-- instance into scope, but unless proper 'static' support is added to

158−-- ghc we need both the type class argument and the explicit dictionary.

158+-- ghc we need both the type class argument and the explicit dictionary.

159−module Control.Distributed.Process.Closure

159+module Control.Distributed.Process.Closure

160 ( -- * Serialization dictionaries (and their static versions)

161 SerializableDict(..)

162 , staticDecode

163 , sdictUnit

164 , sdictProcessId

165 , sdictSendPort

166− -- * The CP type and associated combinators

166+ -- * The CP type and associated combinators

167 , CP

168 , idCP

169 , splitCP

170 , returnCP

171− , bindCP

171+ , bindCP

172− , seqCP

172+ , seqCP

173− -- * CP versions of Cloud Haskell primitives

173+ -- * CP versions of Cloud Haskell primitives

174 , cpLink

175 , cpUnlink

176 , cpSend

177 , cpExpect

178 , cpNewChan

179−#ifdef TemplateHaskellSupport

179+#ifdef TemplateHaskellSupport

180− -- * Template Haskell support for creating static values and closures

180+ -- * Template Haskell support for creating static values and closures

181 , remotable

182 , remotableDecl

183 , mkStatic

@@ -185,7 +185,7 @@ module Control.Distributed.Process.Closure

185 , functionSDict

186 , functionTDict

187#endif

188− ) where

188+ ) where

189

190import Control.Distributed.Process.Serializable (SerializableDict(..))

191import Control.Distributed.Process.Internal.Closure.BuiltIn

@@ -194,22 +194,22 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn

194 , sdictUnit

195 , sdictProcessId

196 , sdictSendPort

197− -- The CP type and associated combinators

197+ -- The CP type and associated combinators

198 , CP

199 , idCP

200 , splitCP

201 , returnCP

202− , bindCP

202+ , bindCP

203− , seqCP

203+ , seqCP

204− -- CP versions of Cloud Haskell primitives

204+ -- CP versions of Cloud Haskell primitives

205 , cpLink

206 , cpUnlink

207 , cpSend

208 , cpExpect

209 , cpNewChan

210 )

211−#ifdef TemplateHaskellSupport

211+#ifdef TemplateHaskellSupport

212−import Control.Distributed.Process.Internal.Closure.TH

212+import Control.Distributed.Process.Internal.Closure.TH

213 ( remotable

214 , remotableDecl

215 , mkStatic

distributed-process/src/Control/Distributed/Process/Internal/CQueue.hs+20−20

@@ -1,6 +1,6 @@

1-- | Concurrent queue for single reader, single writer

2{-# LANGUAGE MagicHash, UnboxedTuples #-}

3−module Control.Distributed.Process.Internal.CQueue

3+module Control.Distributed.Process.Internal.CQueue

4 ( CQueue

5 , BlockSpec(..)

6 , newCQueue

@@ -10,7 +10,7 @@ module Control.Distributed.Process.Internal.CQueue

10 ) where

12import Prelude hiding (length, reverse)

13−import Control.Concurrent.STM

13+import Control.Concurrent.STM

14 ( atomically

15 , TChan

16 , newTChan

@@ -21,7 +21,7 @@ import Control.Concurrent.STM

21import Control.Applicative ((<$>), (<*>))

22import Control.Exception (mask, onException)

23import System.Timeout (timeout)

24−import Control.Distributed.Process.Internal.StrictMVar

24+import Control.Distributed.Process.Internal.StrictMVar

25 ( StrictMVar(StrictMVar)

26 , newMVar

27 , takeMVar

@@ -33,7 +33,7 @@ import Control.Distributed.Process.Internal.StrictList

33 , reverse'

34 )

35import GHC.MVar (MVar(MVar))

36−import GHC.IO (IO(IO))

36+import GHC.IO (IO(IO))

37import GHC.Prim (mkWeak#)

38import GHC.Weak (Weak(Weak))

@@ -48,9 +48,9 @@ newCQueue = CQueue <$> newMVar Nil <*> atomically newTChan

48--

49-- Enqueue is strict.

50enqueue :: CQueue a -> a -> IO ()

51−enqueue (CQueue _arrived incoming) !a = atomically $ writeTChan incoming a

51+enqueue (CQueue _arrived incoming) !a = atomically $ writeTChan incoming a

53−data BlockSpec =

53+data BlockSpec =

54 NonBlocking

55 | Blocking

56 | Timeout Int

@@ -59,35 +59,35 @@ data BlockSpec =

59--

60-- The timeout (if any) is applied only to waiting for incoming messages, not

61-- to checking messages that have already arrived

62−dequeue :: forall a b.

62+dequeue :: forall a b.

63 CQueue a -- ^ Queue

64− -> BlockSpec -- ^ Blocking behaviour

64+ -> BlockSpec -- ^ Blocking behaviour

65 -> [a -> Maybe b] -- ^ List of matches

66 -> IO (Maybe b) -- ^ 'Nothing' only on timeout

67−dequeue (CQueue arrived incoming) blockSpec matches = go

67+dequeue (CQueue arrived incoming) blockSpec matches = go

68− where

68+ where

69 go :: IO (Maybe b)

70 go = mask $ \restore -> do

71− arr <- takeMVar arrived

71+ arr <- takeMVar arrived

72 -- We first check the arrived messages. If we get interrupted during this

73 -- search, we just put the MVar back (we haven't read from the Chan yet)

74 (arr', mb) <- onException (restore (checkArrived Nil arr))

75− (putMVar arrived arr)

75+ (putMVar arrived arr)

76 case (mb, blockSpec) of

77− (Just b, _) -> do

77+ (Just b, _) -> do

78 putMVar arrived arr'

79 return (Just b)

80 (Nothing, NonBlocking) ->

81 checkNonBlocking arr'

82 (Nothing, Blocking) ->

83− Just <$> checkBlocking arr'

83+ Just <$> checkBlocking arr'

84 (Nothing, Timeout n) ->

85 timeout n $ checkBlocking arr'

87 -- We reverse the accumulator on return only if we find a match

88 checkArrived :: StrictList a -> StrictList a -> IO (StrictList a, Maybe b)

89 checkArrived acc Nil = return (acc, Nothing)

90− checkArrived acc (Cons x xs) =

90+ checkArrived acc (Cons x xs) =

91 case check x of

92 Just y -> return (reverse' acc xs, Just y)

93 Nothing -> checkArrived (Cons x acc) xs

@@ -95,15 +95,15 @@ dequeue (CQueue arrived incoming) blockSpec matches = go

95 -- If we call checkBlocking there may or may not be a timeout

96 checkBlocking :: StrictList a -> IO b

97 checkBlocking acc = do

98− -- readTChan is a blocking call, and hence is interruptable. If it is

98+ -- readTChan is a blocking call, and hence is interruptable. If it is

99− -- interrupted, we put the value of the accumulator in 'arrived'

99+ -- interrupted, we put the value of the accumulator in 'arrived'

100 -- (as opposed to the original value), so that no messages get lost

101 -- (hence the low-level structure using mask rather than modifyMVar)

102 x <- onException (atomically $ readTChan incoming)

103 (putMVar arrived $ reverse acc)

104 case check x of

105 Nothing -> checkBlocking (Cons x acc)

106− Just y -> putMVar arrived (reverse acc) >> return y

106+ Just y -> putMVar arrived (reverse acc) >> return y

107

108 -- checkNonBlocking is only called if there is no timeout

109 checkNonBlocking :: StrictList a -> IO (Maybe b)

@@ -115,9 +115,9 @@ dequeue (CQueue arrived incoming) blockSpec matches = go

115 Just x -> case check x of

116 Nothing -> checkNonBlocking (Cons x acc)

117 Just y -> putMVar arrived (reverse acc) >> return (Just y)

118−

118+

119 check :: a -> Maybe b

120− check = checkMatches matches

120+ check = checkMatches matches

121

122 checkMatches :: [a -> Maybe b] -> a -> Maybe b

123 checkMatches [] _ = Nothing

distributed-process/src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs+41−41

@@ -1,5 +1,5 @@

1−module Control.Distributed.Process.Internal.Closure.BuiltIn

1+module Control.Distributed.Process.Internal.Closure.BuiltIn

2− ( -- * Remote table

2+ ( -- * Remote table

3 remoteTable

4 -- * Static dictionaries and associated operations

5 , staticDecode

@@ -8,14 +8,14 @@ module Control.Distributed.Process.Internal.Closure.BuiltIn

8 , sdictSendPort

9 -- * Some static values

10 , sndStatic

11− -- * The CP type and associated combinators

11+ -- * The CP type and associated combinators

12 , CP

13 , idCP

14 , splitCP

15 , returnCP

16− , bindCP

16+ , bindCP

17− , seqCP

17+ , seqCP

18− -- * CP versions of Cloud Haskell primitives

18+ -- * CP versions of Cloud Haskell primitives

19 , cpLink

20 , cpUnlink

21 , cpSend

@@ -25,11 +25,11 @@ module Control.Distributed.Process.Internal.Closure.BuiltIn

25 , cpDelay

26 ) where

28−import Data.ByteString.Lazy (ByteString)

28+import Data.ByteString.Lazy (ByteString)

29import Data.Binary (decode, encode)

30import Data.Rank1Typeable (Typeable, ANY, ANY1, ANY2, ANY3, ANY4)

31import Data.Rank1Dynamic (toDynamic)

32−import Control.Distributed.Static

32+import Control.Distributed.Static

33 ( RemoteTable

34 , registerStatic

35 , Static

@@ -42,18 +42,18 @@ import Control.Distributed.Static

42 , staticCompose

43 , staticClosure

44 )

45−import Control.Distributed.Process.Serializable

45+import Control.Distributed.Process.Serializable

46 ( SerializableDict(..)

47 , Serializable

48 )

49−import Control.Distributed.Process.Internal.Types

49+import Control.Distributed.Process.Internal.Types

50 ( Process

51 , ProcessId

52 , SendPort

53 , ReceivePort

54 , ProcessMonitorNotification(ProcessMonitorNotification)

55 )

56−import Control.Distributed.Process.Internal.Primitives

56+import Control.Distributed.Process.Internal.Primitives

57 ( link

58 , unlink

59 , send

@@ -71,10 +71,10 @@ import Control.Distributed.Process.Internal.Primitives

71--------------------------------------------------------------------------------

73remoteTable :: RemoteTable -> RemoteTable

74−remoteTable =

74+remoteTable =

75 registerStatic "$decodeDict" (toDynamic (decodeDict :: SerializableDict ANY -> ByteString -> ANY))

76 . registerStatic "$sdictUnit" (toDynamic (SerializableDict :: SerializableDict ()))

77− . registerStatic "$sdictProcessId" (toDynamic (SerializableDict :: SerializableDict ProcessId))

77+ . registerStatic "$sdictProcessId" (toDynamic (SerializableDict :: SerializableDict ProcessId))

78 . registerStatic "$sdictSendPort_" (toDynamic (sdictSendPort_ :: SerializableDict ANY -> SerializableDict (SendPort ANY)))

79 . registerStatic "$returnProcess" (toDynamic (return :: ANY -> Process ANY))

80 . registerStatic "$seqProcess" (toDynamic ((>>) :: Process ANY1 -> Process ANY2 -> Process ANY2))

@@ -119,23 +119,23 @@ remoteTable =

119-- See module documentation of "Control.Distributed.Process.Closure" for an

120-- example.

121staticDecode :: Typeable a => Static (SerializableDict a) -> Static (ByteString -> a)

122−staticDecode dict = decodeDictStatic `staticApply` dict

122+staticDecode dict = decodeDictStatic `staticApply` dict

123 where

124 decodeDictStatic :: Typeable a => Static (SerializableDict a -> ByteString -> a)

125 decodeDictStatic = staticLabel "$decodeDict"

126

127−-- | Serialization dictionary for '()'

127+-- | Serialization dictionary for '()'

128sdictUnit :: Static (SerializableDict ())

129−sdictUnit = staticLabel "$sdictUnit"

129+sdictUnit = staticLabel "$sdictUnit"

130

131−-- | Serialization dictionary for 'ProcessId'

131+-- | Serialization dictionary for 'ProcessId'

132sdictProcessId :: Static (SerializableDict ProcessId)

133−sdictProcessId = staticLabel "$sdictProcessId"

133+sdictProcessId = staticLabel "$sdictProcessId"

134

135-- | Serialization dictionary for 'SendPort'

136−sdictSendPort :: Typeable a

136+sdictSendPort :: Typeable a

137 => Static (SerializableDict a) -> Static (SerializableDict (SendPort a))

138−sdictSendPort = staticApply (staticLabel "$sdictSendPort_")

138+sdictSendPort = staticApply (staticLabel "$sdictSendPort_")

139

140--------------------------------------------------------------------------------

141-- Static values --

@@ -154,20 +154,20 @@ type CP a b = Closure (a -> Process b)

154returnProcessStatic :: Typeable a => Static (a -> Process a)

155returnProcessStatic = staticLabel "$returnProcess"

156

157−-- | 'CP' version of 'Control.Category.id'

157+-- | 'CP' version of 'Control.Category.id'

158idCP :: Typeable a => CP a a

159idCP = staticClosure returnProcessStatic

160

161-- | 'CP' version of ('Control.Arrow.***')

162−splitCP :: (Typeable a, Typeable b, Typeable c, Typeable d)

162+splitCP :: (Typeable a, Typeable b, Typeable c, Typeable d)

163 => CP a c -> CP b d -> CP (a, b) (c, d)

164splitCP p q = cpSplitStatic `closureApplyStatic` p `closureApply` q

165 where

166 cpSplitStatic :: Static ((a -> Process c) -> (b -> Process d) -> (a, b) -> Process (c, d))

167− cpSplitStatic = staticLabel "$cpSplit"

167+ cpSplitStatic = staticLabel "$cpSplit"

168

169-- | 'CP' version of 'Control.Monad.return'

170−returnCP :: forall a. Serializable a

170+returnCP :: forall a. Serializable a

171 => Static (SerializableDict a) -> a -> Closure (Process a)

172returnCP dict x = closure decoder (encode x)

173 where

@@ -179,18 +179,18 @@ returnCP dict x = closure decoder (encode x)

179-- | 'CP' version of ('Control.Monad.>>')

180seqCP :: (Typeable a, Typeable b)

181 => Closure (Process a) -> Closure (Process b) -> Closure (Process b)

182−seqCP p q = seqProcessStatic `closureApplyStatic` p `closureApply` q

182+seqCP p q = seqProcessStatic `closureApplyStatic` p `closureApply` q

183 where

184 seqProcessStatic :: (Typeable a, Typeable b)

185 => Static (Process a -> Process b -> Process b)

186 seqProcessStatic = staticLabel "$seqProcess"

187

188−-- | (Not quite the) 'CP' version of ('Control.Monad.>>=')

188+-- | (Not quite the) 'CP' version of ('Control.Monad.>>=')

189bindCP :: forall a b. (Typeable a, Typeable b)

190 => Closure (Process a) -> CP a b -> Closure (Process b)

191−bindCP x f = bindProcessStatic `closureApplyStatic` x `closureApply` f

191+bindCP x f = bindProcessStatic `closureApplyStatic` x `closureApply` f

192 where

193− bindProcessStatic :: (Typeable a, Typeable b)

193+ bindProcessStatic :: (Typeable a, Typeable b)

194 => Static (Process a -> (a -> Process b) -> Process b)

195 bindProcessStatic = staticLabel "$bindProcess"

196

@@ -203,7 +203,7 @@ decodeProcessIdStatic = staticLabel "$decodeProcessId"

203

204-- | 'CP' version of 'link'

205cpLink :: ProcessId -> Closure (Process ())

206−cpLink = closure (linkStatic `staticCompose` decodeProcessIdStatic) . encode

206+cpLink = closure (linkStatic `staticCompose` decodeProcessIdStatic) . encode

207 where

208 linkStatic :: Static (ProcessId -> Process ())

209 linkStatic = staticLabel "$link"

@@ -216,18 +216,18 @@ cpUnlink = closure (unlinkStatic `staticCompose` decodeProcessIdStatic) . encode

216 unlinkStatic = staticLabel "$unlink"

217

218-- | 'CP' version of 'send'

219−cpSend :: forall a. Typeable a

219+cpSend :: forall a. Typeable a

220− => Static (SerializableDict a) -> ProcessId -> CP a ()

220+ => Static (SerializableDict a) -> ProcessId -> CP a ()

221cpSend dict pid = closure decoder (encode pid)

222 where

223 decoder :: Static (ByteString -> a -> Process ())

224 decoder = (sendDictStatic `staticApply` dict)

225− `staticCompose`

225+ `staticCompose`

226− decodeProcessIdStatic

226+ decodeProcessIdStatic

227

228− sendDictStatic :: Typeable a

228+ sendDictStatic :: Typeable a

229 => Static (SerializableDict a -> ProcessId -> a -> Process ())

230− sendDictStatic = staticLabel "$sendDict"

230+ sendDictStatic = staticLabel "$sendDict"

231

232-- | 'CP' version of 'expect'

233cpExpect :: Typeable a => Static (SerializableDict a) -> Closure (Process a)

@@ -237,14 +237,14 @@ cpExpect dict = staticClosure (expectDictStatic `staticApply` dict)

237 expectDictStatic = staticLabel "$expectDict"

238

239-- | 'CP' version of 'newChan'

240−cpNewChan :: Typeable a

240+cpNewChan :: Typeable a

241− => Static (SerializableDict a)

241+ => Static (SerializableDict a)

242 -> Closure (Process (SendPort a, ReceivePort a))

243cpNewChan dict = staticClosure (newChanDictStatic `staticApply` dict)

244 where

245− newChanDictStatic :: Typeable a

245+ newChanDictStatic :: Typeable a

246 => Static (SerializableDict a -> Process (SendPort a, ReceivePort a))

247− newChanDictStatic = staticLabel "$newChanDict"

247+ newChanDictStatic = staticLabel "$newChanDict"

248

249--------------------------------------------------------------------------------

250-- Support for spawn --

@@ -252,7 +252,7 @@ cpNewChan dict = staticClosure (newChanDictStatic `staticApply` dict)

252

253-- | @delay them p@ is a process that waits for a signal (a message of type @()@)

254-- from 'them' (origin is not verified) before proceeding as @p@. In order to

255−-- avoid waiting forever, @delay them p@ monitors 'them'. If it receives a

255+-- avoid waiting forever, @delay them p@ monitors 'them'. If it receives a

256-- monitor message instead it simply terminates.

257delay :: ProcessId -> Process () -> Process ()

258delay them p = do

@@ -269,7 +269,7 @@ cpDelay = closureApply . cpDelay'

269 where

270 cpDelay' :: ProcessId -> Closure (Process () -> Process ())

271 cpDelay' pid = closure decoder (encode pid)

272−

272+

273 decoder :: Static (ByteString -> Process () -> Process ())

274 decoder = delayStatic `staticCompose` decodeProcessIdStatic

275

distributed-process/src/Control/Distributed/Process/Internal/Closure/TH.hs+56−56

@@ -1,6 +1,6 @@

1-- | Template Haskell support

2{-# LANGUAGE TemplateHaskell #-}

3−module Control.Distributed.Process.Internal.Closure.TH

3+module Control.Distributed.Process.Internal.Closure.TH

4 ( -- * User-level API

5 remotable

6 , remotableDecl

@@ -12,7 +12,7 @@ module Control.Distributed.Process.Internal.Closure.TH

13import Prelude hiding (succ, any)

14import Control.Applicative ((<$>))

15−import Language.Haskell.TH

15+import Language.Haskell.TH

16 ( -- Q monad and operations

17 Q

18 , reify

@@ -42,7 +42,7 @@ import Language.Haskell.TH

42 , funD

43 , sigD

44 )

45−import Data.Maybe (catMaybes)

45+import Data.Maybe (catMaybes)

46import Data.Binary (encode)

47import Data.Generics (everywhereM, mkM, gmapM)

48import Data.Rank1Dynamic (toDynamic)

@@ -51,7 +51,7 @@ import Data.Rank1Typeable

51 , Succ

52 , TypVar

53 )

54−import Control.Distributed.Static

54+import Control.Distributed.Static

55 ( RemoteTable

56 , registerStatic

57 , Static

@@ -60,7 +60,7 @@ import Control.Distributed.Static

60 , staticCompose

61 )

62import Control.Distributed.Process.Internal.Types (Process)

63−import Control.Distributed.Process.Serializable

63+import Control.Distributed.Process.Serializable

64 ( SerializableDict(SerializableDict)

65 )

66import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)

@@ -71,12 +71,12 @@ import Control.Distributed.Process.Internal.Closure.BuiltIn (staticDecode)

72-- | Create the closure, decoder, and metadata definitions for the given list

73-- of functions

74−remotable :: [Name] -> Q [Dec]

74+remotable :: [Name] -> Q [Dec]

75remotable ns = do

76− types <- mapM getType ns

76+ types <- mapM getType ns

77− (closures, inserts) <- unzip <$> mapM generateDefs types

77+ (closures, inserts) <- unzip <$> mapM generateDefs types

78 rtable <- createMetaData (mkName "__remoteTable") (concat inserts)

79− return $ concat closures ++ rtable

79+ return $ concat closures ++ rtable

81-- | Like 'remotable', but parameterized by the declaration of a function

82-- instead of the function name. So where for 'remotable' you'd do

@@ -106,9 +106,9 @@ remotableDecl :: [Q [Dec]] -> Q [Dec]

106remotableDecl qDecs = do

107 decs <- concat <$> sequence qDecs

108 let types = catMaybes (map typeOf decs)

109− (closures, inserts) <- unzip <$> mapM generateDefs types

109+ (closures, inserts) <- unzip <$> mapM generateDefs types

110 rtable <- createMetaData (mkName "__remoteTableDecl") (concat inserts)

111− return $ decs ++ concat closures ++ rtable

111+ return $ decs ++ concat closures ++ rtable

112 where

113 typeOf :: Dec -> Maybe (Name, Type)

114 typeOf (SigD name typ) = Just (name, typ)

@@ -116,15 +116,15 @@ remotableDecl qDecs = do

116

117-- | Construct a static value.

118--

119−-- If @f : forall a1 .. an. T@

119+-- If @f : forall a1 .. an. T@

120−-- then @$(mkStatic 'f) :: forall a1 .. an. Static T@.

120+-- then @$(mkStatic 'f) :: forall a1 .. an. Static T@.

121−-- Be sure to pass 'f' to 'remotable'.

121+-- Be sure to pass 'f' to 'remotable'.

122mkStatic :: Name -> Q Exp

123mkStatic = varE . staticName

124

125−-- | If @f : T1 -> T2@ is a monomorphic function

125+-- | If @f : T1 -> T2@ is a monomorphic function

126-- then @$(functionSDict 'f) :: Static (SerializableDict T1)@.

127−--

127+--

128-- Be sure to pass 'f' to 'remotable'.

129functionSDict :: Name -> Q Exp

130functionSDict = varE . sdictName

@@ -136,13 +136,13 @@ functionSDict = varE . sdictName

136functionTDict :: Name -> Q Exp

137functionTDict = varE . tdictName

138

139−-- | If @f : T1 -> T2@ then @$(mkClosure 'f) :: T1 -> Closure T2@.

139+-- | If @f : T1 -> T2@ then @$(mkClosure 'f) :: T1 -> Closure T2@.

140--

141−-- TODO: The current version of mkClosure is too polymorphic

141+-- TODO: The current version of mkClosure is too polymorphic

142-- (@forall a. Binary a => a -> Closure T2).

143mkClosure :: Name -> Q Exp

144−mkClosure n =

144+mkClosure n =

145− [| closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))

145+ [| closure ($(mkStatic n) `staticCompose` staticDecode $(functionSDict n))

146 . encode

147 |]

148

@@ -152,8 +152,8 @@ mkClosure n =

152

153-- | Generate the code to add the metadata to the CH runtime

154createMetaData :: Name -> [Q Exp] -> Q [Dec]

155−createMetaData name is =

155+createMetaData name is =

156− sequence [ sigD name [t| RemoteTable -> RemoteTable |]

156+ sequence [ sigD name [t| RemoteTable -> RemoteTable |]

157 , sfnD name (compose is)

158 ]

159

@@ -163,52 +163,52 @@ generateDefs (origName, fullType) = do

163 let (typVars, typ') = case fullType of ForallT vars [] mono -> (vars, mono)

164 _ -> ([], fullType)

165

166− -- The main "static" entry

166+ -- The main "static" entry

167− (static, register) <- makeStatic typVars typ'

167+ (static, register) <- makeStatic typVars typ'

168−

168+

169− -- If n :: T1 -> T2, static serializable dictionary for T1

169+ -- If n :: T1 -> T2, static serializable dictionary for T1

170 -- TODO: we should check if arg is an instance of Serializable, but we cannot

171 -- http://hackage.haskell.org/trac/ghc/ticket/7066

172 (sdict, registerSDict) <- case (typVars, typ') of

173− ([], ArrowT `AppT` arg `AppT` _res) ->

173+ ([], ArrowT `AppT` arg `AppT` _res) ->

174 makeDict (sdictName origName) arg

175− _ ->

175+ _ ->

176 return ([], [])

177−

177+

178 -- If n :: T1 -> Process T2, static serializable dictionary for T2

179 -- TODO: check if T2 is serializable (same as above)

180 (tdict, registerTDict) <- case (typVars, typ') of

181− ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->

181+ ([], ArrowT `AppT` _arg `AppT` (proc' `AppT` res)) | proc' == proc ->

182− makeDict (tdictName origName) res

182+ makeDict (tdictName origName) res

183 _ ->

184 return ([], [])

185−

185+

186 return ( concat [static, sdict, tdict]

187 , concat [register, registerSDict, registerTDict]

188 )

189 where

190 makeStatic :: [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])

191− makeStatic typVars typ = do

191+ makeStatic typVars typ = do

192 static <- generateStatic origName typVars typ

193− let dyn = case typVars of

193+ let dyn = case typVars of

194 [] -> [| toDynamic $(varE origName) |]

195 _ -> [| toDynamic ($(varE origName) :: $(monomorphize typVars typ)) |]

196 return ( static

197 , [ [| registerStatic $(showFQN origName) $dyn |] ]

198 )

199

200− makeDict :: Name -> Type -> Q ([Dec], [Q Exp])

200+ makeDict :: Name -> Type -> Q ([Dec], [Q Exp])

201 makeDict dictName typ = do

202− sdict <- generateDict dictName typ

202+ sdict <- generateDict dictName typ

203 let dyn = [| toDynamic (SerializableDict :: SerializableDict $(return typ)) |]

204 return ( sdict

205− , [ [| registerStatic $(showFQN dictName) $dyn |] ]

205+ , [ [| registerStatic $(showFQN dictName) $dyn |] ]

206 )

207

208-- | Turn a polymorphic type into a monomorphic type using ANY and co

209monomorphize :: [TyVarBndr] -> Type -> Q Type

210−monomorphize tvs =

210+monomorphize tvs =

211− let subst = zip (map tyVarBndrName tvs) anys

211+ let subst = zip (map tyVarBndrName tvs) anys

212 in everywhereM (mkM (applySubst subst))

213 where

214 anys :: [Q Type]

@@ -219,34 +219,34 @@ monomorphize tvs =

219

220 zero :: Q Type

221 zero = [t| Zero |]

222−

222+

223 succ :: Q Type -> Q Type

224 succ t = [t| Succ $t |]

225−

225+

226 applySubst :: [(Name, Q Type)] -> Type -> Q Type

227− applySubst s (VarT n) =

227+ applySubst s (VarT n) =

228− case lookup n s of

228+ case lookup n s of

229 Nothing -> return (VarT n)

230 Just t -> t

231 applySubst s t = gmapM (mkM (applySubst s)) t

232

233−-- | Generate a static value

233+-- | Generate a static value

234generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]

235generateStatic n xs typ = do

236 staticTyp <- [t| Static |]

237 sequence

238− [ sigD (staticName n) $

238+ [ sigD (staticName n) $

239− return (ForallT xs

239+ return (ForallT xs

240− (map typeable xs)

240+ (map typeable xs)

241 (staticTyp `AppT` typ)

242 )

243 , sfnD (staticName n) [| staticLabel $(showFQN n) |]

244 ]

245 where

246 typeable :: TyVarBndr -> Pred

247− typeable tv = ClassP (mkName "Typeable") [VarT (tyVarBndrName tv)]

247+ typeable tv = ClassP (mkName "Typeable") [VarT (tyVarBndrName tv)]

248

249−-- | Generate a serialization dictionary with name 'n' for type 'typ'

249+-- | Generate a serialization dictionary with name 'n' for type 'typ'

250generateDict :: Name -> Type -> Q [Dec]

251generateDict n typ = do

252 sequence

@@ -270,7 +270,7 @@ tdictName n = mkName $ nameBase n ++ "__tdict"

270-- | Compose a set of expressions

271compose :: [Q Exp] -> Q Exp

272compose [] = [| id |]

273−compose [e] = e

273+compose [e] = e

274compose (e:es) = [| $e . $(compose es) |]

275

276-- | Literal string as an expression

@@ -279,17 +279,17 @@ stringE = litE . stringL

279

280-- | Look up the "original name" (module:name) and type of a top-level function

281getType :: Name -> Q (Name, Type)

282−getType name = do

282+getType name = do

283 info <- reify name

284− case info of

284+ case info of

285 VarI origName typ _ _ -> return (origName, typ)

286 _ -> fail $ show name ++ " not found"

287

288-- | Variation on 'funD' which takes a single expression to define the function

289sfnD :: Name -> Q Exp -> Q Dec

290−sfnD n e = funD n [clause [] (normalB e) []]

290+sfnD n e = funD n [clause [] (normalB e) []]

291−

291+

292−-- | The name of a type variable binding occurrence

292+-- | The name of a type variable binding occurrence

293tyVarBndrName :: TyVarBndr -> Name

294tyVarBndrName (PlainTV n) = n

295tyVarBndrName (KindedTV n _) = n

@@ -299,7 +299,7 @@ tyVarBndrName (KindedTV n _) = n

299-- We ignore the module part of the Name argument (which may or may not exist)

300-- because we construct various names (`staticName`, `sdictName`, `tdictName`)

301-- and those names certainly won't have Module components.

302−showFQN :: Name -> Q Exp

302+showFQN :: Name -> Q Exp

303showFQN n = do

304 loc <- location

305 stringE (loc_module loc ++ "." ++ nameBase n)

distributed-process/src/Control/Distributed/Process/Internal/Messaging.hs+42−42

@@ -2,8 +2,8 @@ module Control.Distributed.Process.Internal.Messaging

2 ( sendPayload

3 , sendBinary

4 , sendMessage

5− , disconnect

5+ , disconnect

6− , closeImplicitReconnections

6+ , closeImplicitReconnections

7 , impliesDeathOf

8 ) where

@@ -15,7 +15,7 @@ import qualified Data.ByteString as BSS (ByteString)

15import Control.Distributed.Process.Internal.StrictMVar (withMVar, modifyMVar_)

16import Control.Concurrent.Chan (writeChan)

17import Control.Monad (unless)

18−import qualified Network.Transport as NT

18+import qualified Network.Transport as NT

19 ( Connection

20 , send

21 , defaultConnectHints

@@ -23,7 +23,7 @@ import qualified Network.Transport as NT

23 , Reliability(ReliableOrdered)

24 , close

25 )

26−import Control.Distributed.Process.Internal.Types

26+import Control.Distributed.Process.Internal.Types

27 ( LocalNode(localState, localEndPoint, localCtrlChan)

28 , Identifier

29 , localConnections

@@ -44,14 +44,14 @@ import Control.Distributed.Process.Internal.Types

44import Control.Distributed.Process.Serializable (Serializable)

46--------------------------------------------------------------------------------

47−-- Message sending --

47+-- Message sending --

48--------------------------------------------------------------------------------

50−sendPayload :: LocalNode

50+sendPayload :: LocalNode

51 -> Identifier

52 -> Identifier

53 -> ImplicitReconnect

54− -> [BSS.ByteString]

54+ -> [BSS.ByteString]

55 -> IO ()

56sendPayload node from to implicitReconnect payload = do

57 mConn <- connBetween node from to implicitReconnect

@@ -59,53 +59,53 @@ sendPayload node from to implicitReconnect payload = do

59 Just conn -> do

60 didSend <- NT.send conn payload

61 case didSend of

62− Left _err -> return False

62+ Left _err -> return False

63− Right () -> return True

63+ Right () -> return True

64 Nothing -> return False

65 unless didSend $ do

66 writeChan (localCtrlChan node) NCMsg

67− { ctrlMsgSender = to

67+ { ctrlMsgSender = to

68 , ctrlMsgSignal = Died to DiedDisconnect

69 }

71−sendBinary :: Binary a

71+sendBinary :: Binary a

72− => LocalNode

72+ => LocalNode

73− -> Identifier

73+ -> Identifier

74− -> Identifier

74+ -> Identifier

75 -> ImplicitReconnect

76− -> a

76+ -> a

77 -> IO ()

78−sendBinary node from to implicitReconnect

78+sendBinary node from to implicitReconnect

79 = sendPayload node from to implicitReconnect . BSL.toChunks . encode

81−sendMessage :: Serializable a

81+sendMessage :: Serializable a

82− => LocalNode

82+ => LocalNode

83− -> Identifier

83+ -> Identifier

84− -> Identifier

84+ -> Identifier

85 -> ImplicitReconnect

86− -> a

86+ -> a

87 -> IO ()

88−sendMessage node from to implicitReconnect =

88+sendMessage node from to implicitReconnect =

89 sendPayload node from to implicitReconnect . messageToPayload . createMessage

91−setupConnBetween :: LocalNode

91+setupConnBetween :: LocalNode

92− -> Identifier

92+ -> Identifier

93− -> Identifier

93+ -> Identifier

94− -> ImplicitReconnect

94+ -> ImplicitReconnect

95 -> IO (Maybe NT.Connection)

96setupConnBetween node from to implicitReconnect = do

97− mConn <- NT.connect endPoint

97+ mConn <- NT.connect endPoint

98− (nodeAddress . nodeOf $ to)

98+ (nodeAddress . nodeOf $ to)

99− NT.ReliableOrdered

99+ NT.ReliableOrdered

100 NT.defaultConnectHints

101− case mConn of

101+ case mConn of

102 Right conn -> do

103 didSend <- NT.send conn (BSL.toChunks . encode $ to)

104 case didSend of

105 Left _ ->

106 return Nothing

107 Right () -> do

108− modifyMVar_ nodeState $ return .

108+ modifyMVar_ nodeState $ return .

109 (localConnectionBetween from to ^= Just (conn, implicitReconnect))

110 return $ Just conn

111 Left _ ->

@@ -114,33 +114,33 @@ setupConnBetween node from to implicitReconnect = do

114 endPoint = localEndPoint node

115 nodeState = localState node

116

117−connBetween :: LocalNode

117+connBetween :: LocalNode

118− -> Identifier

118+ -> Identifier

119− -> Identifier

119+ -> Identifier

120 -> ImplicitReconnect

121 -> IO (Maybe NT.Connection)

122connBetween node from to implicitReconnect = do

123 mConn <- withMVar nodeState $ return . (^. localConnectionBetween from to)

124 case mConn of

125− Just (conn, _) ->

125+ Just (conn, _) ->

126 return $ Just conn

127− Nothing ->

127+ Nothing ->

128− setupConnBetween node from to implicitReconnect

128+ setupConnBetween node from to implicitReconnect

129 where

130 nodeState = localState node

131

132disconnect :: LocalNode -> Identifier -> Identifier -> IO ()

133disconnect node from to =

134− modifyMVar_ (localState node) $ \st ->

134+ modifyMVar_ (localState node) $ \st ->

135 case st ^. localConnectionBetween from to of

136− Nothing ->

136+ Nothing ->

137 return st

138 Just (conn, _) -> do

139− NT.close conn

139+ NT.close conn

140 return (localConnectionBetween from to ^= Nothing $ st)

141

142closeImplicitReconnections :: LocalNode -> Identifier -> IO ()

143−closeImplicitReconnections node to =

143+closeImplicitReconnections node to =

144 modifyMVar_ (localState node) $ \st -> do

145 let shouldClose (_, to') (_, WithImplicitReconnect) = to `impliesDeathOf` to'

146 shouldClose _ _ = False

@@ -153,7 +153,7 @@ closeImplicitReconnections node to =

153impliesDeathOf :: Identifier

154 -> Identifier

155 -> Bool

156−NodeIdentifier nid `impliesDeathOf` NodeIdentifier nid' =

156+NodeIdentifier nid `impliesDeathOf` NodeIdentifier nid' =

157 nid' == nid

158NodeIdentifier nid `impliesDeathOf` ProcessIdentifier pid =

159 processNodeId pid == nid

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+93−93

@@ -1,10 +1,10 @@

1-- | Cloud Haskell primitives

2--

3−-- We define these in a separate module so that we don't have to rely on

3+-- We define these in a separate module so that we don't have to rely on

4-- the closure combinators

5−module Control.Distributed.Process.Internal.Primitives

5+module Control.Distributed.Process.Internal.Primitives

6 ( -- * Basic messaging

7− send

7+ send

8 , expect

9 -- * Channels

10 , newChan

@@ -19,7 +19,7 @@ module Control.Distributed.Process.Internal.Primitives

19 , match

20 , matchIf

21 , matchUnknown

22− , AbstractMessage(..)

22+ , AbstractMessage(..)

23 , matchAny

24 -- * Process management

25 , terminate

@@ -84,13 +84,13 @@ import Control.Monad.IO.Class (MonadIO, liftIO)

84import Control.Applicative ((<$>))

85import Control.Exception (Exception, throwIO, SomeException)

86import qualified Control.Exception as Ex (catch, mask)

87−import Control.Distributed.Process.Internal.StrictMVar

87+import Control.Distributed.Process.Internal.StrictMVar

88 ( StrictMVar

89 , modifyMVar

90 , modifyMVar_

91 )

92import Control.Concurrent.Chan (writeChan)

93−import Control.Concurrent.STM

93+import Control.Concurrent.STM

94 ( STM

95 , TVar

96 , atomically

@@ -105,7 +105,7 @@ import Data.Accessor ((^.), (^:), (^=))

105import Control.Distributed.Static (Closure, Static)

106import Data.Rank1Typeable (Typeable)

107import qualified Control.Distributed.Static as Static (unstatic, unclosure)

108−import Control.Distributed.Process.Internal.Types

108+import Control.Distributed.Process.Internal.Types

109 ( NodeId(..)

110 , ProcessId(..)

111 , LocalNode(..)

@@ -116,7 +116,7 @@ import Control.Distributed.Process.Internal.Types

116 , SpawnRef(..)

117 , NCMsg(..)

118 , ProcessSignal(..)

119− , monitorCounter

119+ , monitorCounter

120 , spawnCounter

121 , SendPort(..)

122 , ReceivePort(..)

@@ -139,13 +139,13 @@ import Control.Distributed.Process.Internal.Types

139 , LocalSendPortId

140 , messageToPayload

141 )

142−import Control.Distributed.Process.Internal.Messaging

142+import Control.Distributed.Process.Internal.Messaging

143 ( sendMessage

144 , sendBinary

145 , sendPayload

146 , disconnect

147− )

147+ )

148−import Control.Distributed.Process.Internal.WeakTQueue

148+import Control.Distributed.Process.Internal.WeakTQueue

149 ( newTQueueIO

150 , readTQueue

151 , mkWeakTQueue

@@ -160,16 +160,16 @@ send :: Serializable a => ProcessId -> a -> Process ()

160-- This requires a lookup on every send. If we want to avoid that we need to

161-- modify serializable to allow for stateful (IO) deserialization

162send them msg = do

163− proc <- ask

163+ proc <- ask

164− liftIO $ sendMessage (processNode proc)

164+ liftIO $ sendMessage (processNode proc)

165− (ProcessIdentifier (processId proc))

165+ (ProcessIdentifier (processId proc))

166 (ProcessIdentifier them)

167 NoImplicitReconnect

168 msg

169

170-- | Wait for a message of a specific type

171expect :: forall a. Serializable a => Process a

172−expect = receiveWait [match return]

172+expect = receiveWait [match return]

173

174--------------------------------------------------------------------------------

175-- Channels --

@@ -178,17 +178,17 @@ expect = receiveWait [match return]

178-- | Create a new typed channel

179newChan :: Serializable a => Process (SendPort a, ReceivePort a)

180newChan = do

181− proc <- ask

181+ proc <- ask

182 liftIO . modifyMVar (processState proc) $ \st -> do

183 let lcid = st ^. channelCounter

184 let cid = SendPortId { sendPortProcessId = processId proc

185 , sendPortLocalId = lcid

186 }

187− let sport = SendPort cid

187+ let sport = SendPort cid

188 chan <- liftIO newTQueueIO

189 chan' <- mkWeakTQueue chan $ finalizer (processState proc) lcid

190 let rport = ReceivePort $ readTQueue chan

191− let tch = TypedChannel chan'

191+ let tch = TypedChannel chan'

192 return ( (channelCounter ^: (+ 1))

193 . (typedChannelWithId lcid ^= Just tch)

194 $ st

@@ -196,7 +196,7 @@ newChan = do

196 )

197 where

198 finalizer :: StrictMVar LocalProcessState -> LocalSendPortId -> IO ()

199− finalizer st lcid = modifyMVar_ st $

199+ finalizer st lcid = modifyMVar_ st $

200 return . (typedChannelWithId lcid ^= Nothing)

201

202-- | Send a message on a typed channel

@@ -205,24 +205,24 @@ sendChan (SendPort cid) msg = do

205 proc <- ask

206 liftIO $ sendBinary (processNode proc)

207 (ProcessIdentifier (processId proc))

208− (SendPortIdentifier cid)

208+ (SendPortIdentifier cid)

209 NoImplicitReconnect

210− msg

210+ msg

211

212-- | Wait for a message on a typed channel

213receiveChan :: Serializable a => ReceivePort a -> Process a

214−receiveChan = liftIO . atomically . receiveSTM

214+receiveChan = liftIO . atomically . receiveSTM

215

216−-- | Like 'receiveChan' but with a timeout. If the timeout is 0, do a

216+-- | Like 'receiveChan' but with a timeout. If the timeout is 0, do a

217-- non-blocking check for a message.

218receiveChanTimeout :: Serializable a => Int -> ReceivePort a -> Process (Maybe a)

219−receiveChanTimeout 0 ch = liftIO . atomically $

219+receiveChanTimeout 0 ch = liftIO . atomically $

220 (Just <$> receiveSTM ch) `orElse` return Nothing

221−receiveChanTimeout n ch = liftIO . timeout n . atomically $

221+receiveChanTimeout n ch = liftIO . timeout n . atomically $

222 receiveSTM ch

223

224-- | Merge a list of typed channels.

225−--

225+--

226-- The result port is left-biased: if there are messages available on more

227-- than one port, the first available message is returned.

228mergePortsBiased :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)

@@ -233,7 +233,7 @@ mergePortsBiased = return . ReceivePort. foldr1 orElse . map receiveSTM

233mergePortsRR :: Serializable a => [ReceivePort a] -> Process (ReceivePort a)

234mergePortsRR = \ps -> do

235 psVar <- liftIO . atomically $ newTVar (map receiveSTM ps)

236− return $ ReceivePort (rr psVar)

236+ return $ ReceivePort (rr psVar)

237 where

238 rotate :: [a] -> [a]

239 rotate [] = []

@@ -242,12 +242,12 @@ mergePortsRR = \ps -> do

242 rr :: TVar [STM a] -> STM a

243 rr psVar = do

244 ps <- readTVar psVar

245− a <- foldr1 orElse ps

245+ a <- foldr1 orElse ps

246 writeTVar psVar (rotate ps)

247 return a

248

249--------------------------------------------------------------------------------

250−-- Advanced messaging --

250+-- Advanced messaging --

251--------------------------------------------------------------------------------

252

253-- | Opaque type used in 'receiveWait' and 'receiveTimeout'

@@ -261,7 +261,7 @@ receiveWait ms = do

261 proc

262

263-- | Like 'receiveWait' but with a timeout.

264−--

264+--

265-- If the timeout is zero do a non-blocking check for matching messages. A

266-- non-zero timeout is applied only when waiting for incoming messages (that is,

267-- /after/ we have checked the messages that are already in the mailbox).

@@ -276,16 +276,16 @@ receiveTimeout t ms = do

276

277-- | Match against any message of the right type

278match :: forall a b. Serializable a => (a -> Process b) -> Match b

279−match = matchIf (const True)

279+match = matchIf (const True)

280

281-- | Match against any message of the right type that satisfies a predicate

282matchIf :: forall a b. Serializable a => (a -> Bool) -> (a -> Process b) -> Match b

283−matchIf c p = Match $ \msg ->

283+matchIf c p = Match $ \msg ->

284 case messageFingerprint msg == fingerprint (undefined :: a) of

285 True | c decoded -> Just (p decoded)

286 where

287 decoded :: a

288− -- Make sure the value is fully decoded so that we don't hang to

288+ -- Make sure the value is fully decoded so that we don't hang to

289 -- bytestrings when the process calling 'matchIf' doesn't process

290 -- the values immediately

291 !decoded = decode (messageEncoding msg)

@@ -298,7 +298,7 @@ data AbstractMessage = AbstractMessage {

298-- | Match against an arbitrary message

299matchAny :: forall b. (AbstractMessage -> Process b) -> Match b

300matchAny p = Match $ Just . p . abstract

301− where

301+ where

302 abstract :: Message -> AbstractMessage

303 abstract msg = AbstractMessage {

304 forward = \them -> do

@@ -306,7 +306,7 @@ matchAny p = Match $ Just . p . abstract

306 liftIO $ sendPayload (processNode proc)

307 (ProcessIdentifier (processId proc))

308 (ProcessIdentifier them)

309− NoImplicitReconnect

309+ NoImplicitReconnect

310 (messageToPayload msg)

311 }

312

@@ -330,11 +330,11 @@ terminate = liftIO $ throwIO ProcessTerminationException

330

331-- | Our own process ID

332getSelfPid :: Process ProcessId

333−getSelfPid = processId <$> ask

333+getSelfPid = processId <$> ask

334

335-- | Get the node ID of our local node

336getSelfNode :: Process NodeId

337−getSelfNode = localNodeId . processNode <$> ask

337+getSelfNode = localNodeId . processNode <$> ask

338

339--------------------------------------------------------------------------------

340-- Monitoring and linking --

@@ -354,7 +354,7 @@ getSelfNode = localNodeId . processNode <$> ask

354-- > unlink pidB -- Unlink again

355--

356-- doesn't quite do what one might expect: if process B sends a message to

357−-- process A, and /subsequently terminates/, then process A might or might not

357+-- process A, and /subsequently terminates/, then process A might or might not

358-- be terminated too, depending on whether the exception is thrown before or

359-- after the 'unlink' (i.e., this code has a race condition).

360--

@@ -369,7 +369,7 @@ link = sendCtrlMsg Nothing . Link . ProcessIdentifier

369

370-- | Monitor another process (asynchronous)

371--

372−-- When process A monitors process B (that is, process A calls

372+-- When process A monitors process B (that is, process A calls

373-- @monitor pidB@) then process A will receive a 'ProcessMonitorNotification'

374-- when process B terminates (normally or abnormally), or when process A gets

375-- disconnected from process B. You receive this message like any other (using

@@ -377,27 +377,27 @@ link = sendCtrlMsg Nothing . Link . ProcessIdentifier

377-- 'DiedDisconnect', etc.).

378--

379-- Every call to 'monitor' returns a new monitor reference 'MonitorRef'; if

380−-- multiple monitors are set up, multiple notifications will be delivered

380+-- multiple monitors are set up, multiple notifications will be delivered

381-- and monitors can be disabled individually using 'unmonitor'.

382−monitor :: ProcessId -> Process MonitorRef

382+monitor :: ProcessId -> Process MonitorRef

383−monitor = monitor' . ProcessIdentifier

383+monitor = monitor' . ProcessIdentifier

384

385−-- | Remove a link

385+-- | Remove a link

386--

387-- This is synchronous in the sense that once it returns you are guaranteed

388-- that no exception will be raised if the remote process dies. However, it is

389−-- asynchronous in the sense that we do not wait for a response from the remote

389+-- asynchronous in the sense that we do not wait for a response from the remote

390-- node.

391unlink :: ProcessId -> Process ()

392unlink pid = do

393 unlinkAsync pid

394− receiveWait [ matchIf (\(DidUnlinkProcess pid') -> pid' == pid)

394+ receiveWait [ matchIf (\(DidUnlinkProcess pid') -> pid' == pid)

395− (\_ -> return ())

395+ (\_ -> return ())

396 ]

397

398−-- | Remove a node link

398+-- | Remove a node link

399--

400−-- This has the same synchronous/asynchronous nature as 'unlink'.

400+-- This has the same synchronous/asynchronous nature as 'unlink'.

401unlinkNode :: NodeId -> Process ()

402unlinkNode nid = do

403 unlinkNodeAsync nid

@@ -407,7 +407,7 @@ unlinkNode nid = do

407

408-- | Remove a channel (send port) link

409--

410−-- This has the same synchronous/asynchronous nature as 'unlink'.

410+-- This has the same synchronous/asynchronous nature as 'unlink'.

411unlinkPort :: SendPort a -> Process ()

412unlinkPort sport = do

413 unlinkPortAsync sport

@@ -415,9 +415,9 @@ unlinkPort sport = do

415 (\_ -> return ())

416 ]

417

418−-- | Remove a monitor

418+-- | Remove a monitor

419--

420−-- This has the same synchronous/asynchronous nature as 'unlink'.

420+-- This has the same synchronous/asynchronous nature as 'unlink'.

421unmonitor :: MonitorRef -> Process ()

422unmonitor ref = do

423 unmonitorAsync ref

@@ -433,11 +433,11 @@ unmonitor ref = do

433catch :: Exception e => Process a -> (e -> Process a) -> Process a

434catch p h = do

435 lproc <- ask

436− liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)

436+ liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)

437

438−-- | Lift 'Control.Exception.mask'

438+-- | Lift 'Control.Exception.mask'

439mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b

440−mask p = do

440+mask p = do

441 lproc <- ask

442 liftIO $ Ex.mask $ \restore ->

443 runLocalProcess lproc (p (liftRestore lproc restore))

@@ -465,7 +465,7 @@ bracket_ before after thing = bracket before (const after) (const thing)

465

466-- | Lift 'Control.Exception.finally'

467finally :: Process a -> Process b -> Process a

468−finally a sequel = bracket_ (return ()) sequel a

468+finally a sequel = bracket_ (return ()) sequel a

469

470--------------------------------------------------------------------------------

471-- Auxiliary API --

@@ -473,10 +473,10 @@ finally a sequel = bracket_ (return ()) sequel a

473

474-- | Like 'expect' but with a timeout

475expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)

476−expectTimeout n = receiveTimeout n [match return]

476+expectTimeout n = receiveTimeout n [match return]

477

478-- | Asynchronous version of 'spawn'

479−--

479+--

480-- ('spawn' is defined in terms of 'spawnAsync' and 'expect')

481spawnAsync :: NodeId -> Closure (Process ()) -> Process SpawnRef

482spawnAsync nid proc = do

@@ -486,41 +486,41 @@ spawnAsync nid proc = do

486

487-- | Monitor a node (asynchronous)

488monitorNode :: NodeId -> Process MonitorRef

489−monitorNode =

489+monitorNode =

490 monitor' . NodeIdentifier

491

492-- | Monitor a typed channel (asynchronous)

493monitorPort :: forall a. Serializable a => SendPort a -> Process MonitorRef

494−monitorPort (SendPort cid) =

494+monitorPort (SendPort cid) =

495− monitor' (SendPortIdentifier cid)

495+ monitor' (SendPortIdentifier cid)

496

497-- | Remove a monitor (asynchronous)

498unmonitorAsync :: MonitorRef -> Process ()

499−unmonitorAsync =

499+unmonitorAsync =

500 sendCtrlMsg Nothing . Unmonitor

501

502-- | Link to a node (asynchronous)

503linkNode :: NodeId -> Process ()

504−linkNode = link' . NodeIdentifier

504+linkNode = link' . NodeIdentifier

505

506-- | Link to a channel (asynchronous)

507linkPort :: SendPort a -> Process ()

508−linkPort (SendPort cid) =

508+linkPort (SendPort cid) =

509 link' (SendPortIdentifier cid)

510

511-- | Remove a process link (asynchronous)

512unlinkAsync :: ProcessId -> Process ()

513−unlinkAsync =

513+unlinkAsync =

514 sendCtrlMsg Nothing . Unlink . ProcessIdentifier

515

516-- | Remove a node link (asynchronous)

517unlinkNodeAsync :: NodeId -> Process ()

518−unlinkNodeAsync =

518+unlinkNodeAsync =

519 sendCtrlMsg Nothing . Unlink . NodeIdentifier

520

521-- | Remove a channel (send port) link (asynchronous)

522unlinkPortAsync :: SendPort a -> Process ()

523−unlinkPortAsync (SendPort cid) =

523+unlinkPortAsync (SendPort cid) =

524 sendCtrlMsg Nothing . Unlink $ SendPortIdentifier cid

525

526--------------------------------------------------------------------------------

@@ -573,12 +573,12 @@ registerImpl force label pid = do

573--

574-- See comments in 'whereisRemoteAsync'

575registerRemoteAsync :: NodeId -> String -> ProcessId -> Process ()

576−registerRemoteAsync nid label pid =

576+registerRemoteAsync nid label pid =

577− sendCtrlMsg (Just nid) (Register label nid (Just pid) False)

577+ sendCtrlMsg (Just nid) (Register label nid (Just pid) False)

578

579reregisterRemoteAsync :: NodeId -> String -> ProcessId -> Process ()

580−reregisterRemoteAsync nid label pid =

580+reregisterRemoteAsync nid label pid =

581− sendCtrlMsg (Just nid) (Register label nid (Just pid) True)

581+ sendCtrlMsg (Just nid) (Register label nid (Just pid) True)

582

583-- | Remove a process from the local registry (asynchronous).

584-- This version will wait until a response is gotten from the

@@ -594,12 +594,12 @@ unregister label = do

594-- | Deal with the result from an attempted registration or unregistration

595-- by throwing an exception if necessary

596handleRegistrationReply :: String -> Bool -> Process ()

597−handleRegistrationReply label ok =

597+handleRegistrationReply label ok =

598 when (not ok) $

599 liftIO $ throwIO $ ProcessRegistrationException label

600

601-- | Remove a process from a remote registry (asynchronous).

602−--

602+--

603-- Reply wil come in the form of a 'RegisterReply' message

604--

605-- See comments in 'whereisRemoteAsync'

@@ -617,25 +617,25 @@ whereis label = do

617

618-- | Query a remote process registry (asynchronous)

619--

620−-- Reply will come in the form of a 'WhereIsReply' message.

620+-- Reply will come in the form of a 'WhereIsReply' message.

621--

622-- There is currently no synchronous version of 'whereisRemoteAsync': if

623-- you implement one yourself, be sure to take into account that the remote

624-- node might die or get disconnect before it can respond (i.e. you should

625−-- use 'monitorNode' and take appropriate action when you receive a

625+-- use 'monitorNode' and take appropriate action when you receive a

626-- 'NodeMonitorNotification').

627whereisRemoteAsync :: NodeId -> String -> Process ()

628−whereisRemoteAsync nid label =

628+whereisRemoteAsync nid label =

629 sendCtrlMsg (Just nid) (WhereIs label)

630

631−-- | Named send to a process in the local registry (asynchronous)

631+-- | Named send to a process in the local registry (asynchronous)

632nsend :: Serializable a => String -> a -> Process ()

633−nsend label msg =

633+nsend label msg =

634 sendCtrlMsg Nothing (NamedSend label (createMessage msg))

635

636-- | Named send to a process in a remote registry (asynchronous)

637nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()

638−nsendRemote nid label msg =

638+nsendRemote nid label msg =

639 sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))

640

641--------------------------------------------------------------------------------

@@ -653,9 +653,9 @@ unStatic static = do

653-- | Resolve a closure

654unClosure :: Typeable a => Closure a -> Process a

655unClosure closure = do

656− rtable <- remoteTable . processNode <$> ask

656+ rtable <- remoteTable . processNode <$> ask

657 case Static.unclosure rtable closure of

658− Left err -> fail $ "Could not resolve closure: " ++ err

658+ Left err -> fail $ "Could not resolve closure: " ++ err

659 Right x -> return x

660

661--------------------------------------------------------------------------------

@@ -666,11 +666,11 @@ unClosure closure = do

666-- message passing. However, when network connections get disrupted this

667-- illusion cannot always be maintained. Once a network connection breaks (even

668-- temporarily) no further communication on that connection will be possible.

669−-- For example, if process A sends a message to process B, and A is then

669+-- For example, if process A sends a message to process B, and A is then

670-- notified (by monitor notification) that it got disconnected from B, A will

671−-- not be able to send any further messages to B, /unless/ A explicitly

671+-- not be able to send any further messages to B, /unless/ A explicitly

672-- indicates that it is acceptable to attempt to reconnect to B using the

673−-- Cloud Haskell 'reconnect' primitive.

673+-- Cloud Haskell 'reconnect' primitive.

674--

675-- Importantly, when A calls 'reconnect' it acknowledges that some messages to

676-- B might have been lost. For instance, if A sends messages m1 and m2 to B,

@@ -690,7 +690,7 @@ reconnect them = do

690

691-- | Reconnect to a sendport. See 'reconnect' for more information.

692reconnectPort :: SendPort a -> Process ()

693−reconnectPort them = do

693+reconnectPort them = do

694 us <- getSelfPid

695 node <- processNode <$> ask

696 liftIO $ disconnect node (ProcessIdentifier us) (SendPortIdentifier (sendPortId them))

@@ -702,10 +702,10 @@ reconnectPort them = do

702getMonitorRefFor :: Identifier -> Process MonitorRef

703getMonitorRefFor ident = do

704 proc <- ask

705− liftIO $ modifyMVar (processState proc) $ \st -> do

705+ liftIO $ modifyMVar (processState proc) $ \st -> do

706− let counter = st ^. monitorCounter

706+ let counter = st ^. monitorCounter

707 return ( monitorCounter ^: (+ 1) $ st

708− , MonitorRef ident counter

708+ , MonitorRef ident counter

709 )

710

711getSpawnRef :: Process SpawnRef

@@ -720,7 +720,7 @@ getSpawnRef = do

720-- | Monitor a process/node/channel

721monitor' :: Identifier -> Process MonitorRef

722monitor' ident = do

723− monitorRef <- getMonitorRefFor ident

723+ monitorRef <- getMonitorRefFor ident

724 sendCtrlMsg Nothing $ Monitor monitorRef

725 return monitorRef

726

@@ -730,17 +730,17 @@ link' = sendCtrlMsg Nothing . Link

730

731-- Send a control message

732sendCtrlMsg :: Maybe NodeId -- ^ Nothing for the local node

733− -> ProcessSignal -- ^ Message to send

733+ -> ProcessSignal -- ^ Message to send

734 -> Process ()

735−sendCtrlMsg mNid signal = do

735+sendCtrlMsg mNid signal = do

736 proc <- ask

737− let msg = NCMsg { ctrlMsgSender = ProcessIdentifier (processId proc)

737+ let msg = NCMsg { ctrlMsgSender = ProcessIdentifier (processId proc)

738 , ctrlMsgSignal = signal

739 }

740 case mNid of

741 Nothing -> do

742− ctrlChan <- localCtrlChan . processNode <$> ask

742+ ctrlChan <- localCtrlChan . processNode <$> ask

743− liftIO $ writeChan ctrlChan msg

743+ liftIO $ writeChan ctrlChan msg

744 Just nid ->

745 liftIO $ sendBinary (processNode proc)

746 (ProcessIdentifier (processId proc))

distributed-process/src/Control/Distributed/Process/Internal/StrictContainerAccessors.hs+1−1

@@ -1,4 +1,4 @@

1−module Control.Distributed.Process.Internal.StrictContainerAccessors

1+module Control.Distributed.Process.Internal.StrictContainerAccessors

2 ( mapMaybe

3 , mapDefault

4 ) where

distributed-process/src/Control/Distributed/Process/Internal/StrictList.hs+4−4

@@ -1,7 +1,7 @@

1-- | Spine and element strict list

2−module Control.Distributed.Process.Internal.StrictList

2+module Control.Distributed.Process.Internal.StrictList

3 ( StrictList(Cons, Nil)

4− , length

4+ , length

5 , reverse

6 , reverse'

7 ) where

@@ -16,10 +16,10 @@ length Nil = 0

16length (Cons _ xs) = 1 + length xs

18-- | Reverse a strict list

19−reverse :: StrictList a -> StrictList a

19+reverse :: StrictList a -> StrictList a

20reverse xs = reverse' xs Nil

22-- | @reverseStrict' xs ys@ is 'reverse xs ++ ys' if they were lists

23−reverse' :: StrictList a -> StrictList a -> StrictList a

23+reverse' :: StrictList a -> StrictList a -> StrictList a

24reverse' Nil ys = ys

25reverse' (Cons x xs) ys = reverse' xs (Cons x ys)

distributed-process/src/Control/Distributed/Process/Internal/StrictMVar.hs+4−4

@@ -1,6 +1,6 @@

1-- | Like Control.Concurrent.MVar.Strict but reduce to HNF, not NF

2{-# LANGUAGE MagicHash, UnboxedTuples #-}

3−module Control.Distributed.Process.Internal.StrictMVar

3+module Control.Distributed.Process.Internal.StrictMVar

4 ( StrictMVar(StrictMVar)

5 , newEmptyMVar

6 , newMVar

@@ -15,7 +15,7 @@ module Control.Distributed.Process.Internal.StrictMVar

15import Control.Applicative ((<$>))

16import Control.Monad ((>=>))

17import Control.Exception (evaluate)

18−import qualified Control.Concurrent.MVar as MVar

18+import qualified Control.Concurrent.MVar as MVar

19 ( MVar

20 , newEmptyMVar

21 , newMVar

@@ -26,7 +26,7 @@ import qualified Control.Concurrent.MVar as MVar

26 , modifyMVar

27 )

28import GHC.MVar (MVar(MVar))

29−import GHC.IO (IO(IO))

29+import GHC.IO (IO(IO))

30import GHC.Prim (mkWeak#)

31import GHC.Weak (Weak(Weak))

@@ -48,7 +48,7 @@ withMVar :: StrictMVar a -> (a -> IO b) -> IO b

48withMVar (StrictMVar v) = MVar.withMVar v

50modifyMVar_ :: StrictMVar a -> (a -> IO a) -> IO ()

51−modifyMVar_ (StrictMVar v) f = MVar.modifyMVar_ v (f >=> evaluate)

51+modifyMVar_ (StrictMVar v) f = MVar.modifyMVar_ v (f >=> evaluate)

53modifyMVar :: StrictMVar a -> (a -> IO (a, b)) -> IO b

54modifyMVar (StrictMVar v) f = MVar.modifyMVar v (f >=> evaluateFst)

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+69−69

@@ -1,10 +1,10 @@

1-- | Types used throughout the Cloud Haskell framework

2--

3−-- We collect all types used internally in a single module because

3+-- We collect all types used internally in a single module because

4-- many of these data types are mutually recursive and cannot be split across

5-- modules.

6module Control.Distributed.Process.Internal.Types

7− ( -- * Node and process identifiers

7+ ( -- * Node and process identifiers

8 NodeId(..)

9 , LocalProcessId(..)

10 , ProcessId(..)

@@ -21,17 +21,17 @@ module Control.Distributed.Process.Internal.Types

21 , runLocalProcess

22 , ImplicitReconnect(..)

23 -- * Typed channels

24− , LocalSendPortId

24+ , LocalSendPortId

25 , SendPortId(..)

26 , TypedChannel(..)

27 , SendPort(..)

28 , ReceivePort(..)

29− -- * Messages

29+ -- * Messages

30 , Message(..)

31 , createMessage

32 , messageToPayload

33 , payloadToMessage

34− -- * Node controller user-visible data types

34+ -- * Node controller user-visible data types

35 , MonitorRef(..)

36 , ProcessMonitorNotification(..)

37 , NodeMonitorNotification(..)

@@ -49,7 +49,7 @@ module Control.Distributed.Process.Internal.Types

49 , DidSpawn(..)

50 , WhereIsReply(..)

51 , RegisterReply(..)

52− -- * Node controller internal data types

52+ -- * Node controller internal data types

53 , NCMsg(..)

54 , ProcessSignal(..)

55 -- * Accessors

@@ -72,7 +72,7 @@ import Data.Int (Int32)

72import Data.Typeable (Typeable)

73import Data.Binary (Binary(put, get), putWord8, getWord8, encode)

74import qualified Data.ByteString as BSS (ByteString, concat, copy)

75−import qualified Data.ByteString.Lazy as BSL

75+import qualified Data.ByteString.Lazy as BSL

76 ( ByteString

77 , toChunks

78 , splitAt

@@ -89,7 +89,7 @@ import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)

89import Control.Applicative (Applicative, Alternative, (<$>), (<*>))

90import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)

91import Control.Monad.IO.Class (MonadIO)

92−import Control.Distributed.Process.Serializable

92+import Control.Distributed.Process.Serializable

93 ( Fingerprint

94 , Serializable

95 , fingerprint

@@ -108,38 +108,38 @@ import qualified Control.Distributed.Process.Internal.StrictContainerAccessors a

108-- Node and process identifiers --

109--------------------------------------------------------------------------------

110

111−-- | Node identifier

111+-- | Node identifier

112newtype NodeId = NodeId { nodeAddress :: NT.EndPointAddress }

113 deriving (Eq, Ord, Binary, Typeable)

114

115instance Show NodeId where

116− show (NodeId addr) = "nid://" ++ show addr

116+ show (NodeId addr) = "nid://" ++ show addr

117

118-- | A local process ID consists of a seed which distinguishes processes from

119-- different instances of the same local node and a counter

120−data LocalProcessId = LocalProcessId

120+data LocalProcessId = LocalProcessId

121 { lpidUnique :: {-# UNPACK #-} !Int32

122 , lpidCounter :: {-# UNPACK #-} !Int32

123 }

124 deriving (Eq, Ord, Typeable, Show)

125

126-- | Process identifier

127−data ProcessId = ProcessId

127+data ProcessId = ProcessId

128 { -- | The ID of the node the process is running on

129 processNodeId :: !NodeId

130 -- | Node-local identifier for the process

131− , processLocalId :: {-# UNPACK #-} !LocalProcessId

131+ , processLocalId :: {-# UNPACK #-} !LocalProcessId

132 }

133 deriving (Eq, Ord, Typeable)

134

135instance Show ProcessId where

136− show (ProcessId (NodeId addr) (LocalProcessId _ lid))

136+ show (ProcessId (NodeId addr) (LocalProcessId _ lid))

137 = "pid://" ++ show addr ++ ":" ++ show lid

138

139−-- | Union of all kinds of identifiers

139+-- | Union of all kinds of identifiers

140−data Identifier =

140+data Identifier =

141 NodeIdentifier !NodeId

142− | ProcessIdentifier !ProcessId

142+ | ProcessIdentifier !ProcessId

143 | SendPortIdentifier !SendPortId

144 deriving (Eq, Ord)

145

@@ -161,7 +161,7 @@ firstNonReservedProcessId :: Int32

161firstNonReservedProcessId = 1

162

163nullProcessId :: NodeId -> ProcessId

164−nullProcessId nid =

164+nullProcessId nid =

165 ProcessId { processNodeId = nid

166 , processLocalId = LocalProcessId { lpidUnique = 0

167 , lpidCounter = 0

@@ -173,39 +173,39 @@ nullProcessId nid =

173--------------------------------------------------------------------------------

174

175-- | Local nodes

176−data LocalNode = LocalNode

176+data LocalNode = LocalNode

177 { -- | 'NodeId' of the node

178 localNodeId :: !NodeId

179− -- | The network endpoint associated with this node

179+ -- | The network endpoint associated with this node

180− , localEndPoint :: !NT.EndPoint

180+ , localEndPoint :: !NT.EndPoint

181− -- | Local node state

181+ -- | Local node state

182 , localState :: !(StrictMVar LocalNodeState)

183 -- | Channel for the node controller

184 , localCtrlChan :: !(Chan NCMsg)

185 -- | Runtime lookup table for supporting closures

186 -- TODO: this should be part of the CH state, not the local endpoint state

187− , remoteTable :: !RemoteTable

187+ , remoteTable :: !RemoteTable

188 }

189

190data ImplicitReconnect = WithImplicitReconnect | NoImplicitReconnect

191 deriving (Eq, Show)

192

193-- | Local node state

194−data LocalNodeState = LocalNodeState

194+data LocalNodeState = LocalNodeState

195 { -- | Processes running on this node

196 _localProcesses :: !(Map LocalProcessId LocalProcess)

197− -- | Counter to assign PIDs

197+ -- | Counter to assign PIDs

198 , _localPidCounter :: !Int32

199 -- | The 'unique' value used to create PIDs (so that processes on

200 -- restarted nodes have new PIDs)

201 , _localPidUnique :: !Int32

202 -- | Outgoing connections

203− , _localConnections :: !(Map (Identifier, Identifier)

203+ , _localConnections :: !(Map (Identifier, Identifier)

204 (NT.Connection, ImplicitReconnect))

205 }

206

207-- | Processes running on our local node

208−data LocalProcess = LocalProcess

208+data LocalProcess = LocalProcess

209 { processQueue :: !(CQueue Message)

210 , processWeakQ :: !(Weak (CQueue Message))

211 , processId :: !ProcessId

@@ -214,7 +214,7 @@ data LocalProcess = LocalProcess

214 , processNode :: !LocalNode

215 }

216

217−-- | Deconstructor for 'Process' (not exported to the public API)

217+-- | Deconstructor for 'Process' (not exported to the public API)

218runLocalProcess :: LocalProcess -> Process a -> IO a

219runLocalProcess lproc proc = runReaderT (unProcess proc) lproc

220

@@ -227,8 +227,8 @@ data LocalProcessState = LocalProcessState

227 }

228

229-- | The Cloud Haskell 'Process' type

230−newtype Process a = Process {

230+newtype Process a = Process {

231− unProcess :: ReaderT LocalProcess IO a

231+ unProcess :: ReaderT LocalProcess IO a

232 }

233 deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative)

234

@@ -251,15 +251,15 @@ data SendPortId = SendPortId {

251 deriving (Eq, Ord)

252

253instance Show SendPortId where

254− show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid)

254+ show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid)

255 = "cid://" ++ show addr ++ ":" ++ show plid ++ ":" ++ show clid

256

257data TypedChannel = forall a. Serializable a => TypedChannel (Weak (TQueue a))

258

259-- | The send send of a typed channel (serializable)

260−newtype SendPort a = SendPort {

260+newtype SendPort a = SendPort {

261 -- | The (unique) ID of this send port

262− sendPortId :: SendPortId

262+ sendPortId :: SendPortId

263 }

264 deriving (Typeable, Binary, Show, Eq, Ord)

265

@@ -271,13 +271,13 @@ newtype ReceivePort a = ReceivePort { receiveSTM :: STM a }

271 deriving (Typeable, Functor, Applicative, Alternative, Monad)

272

273{-

274−data ReceivePort a =

274+data ReceivePort a =

275 -- | A single receive port

276 ReceivePortSingle (TQueue a)

277− -- | A left-biased combination of receive ports

277+ -- | A left-biased combination of receive ports

278− | ReceivePortBiased [ReceivePort a]

278+ | ReceivePortBiased [ReceivePort a]

279 -- | A round-robin combination of receive ports

280− | ReceivePortRR (TVar [ReceivePort a])

280+ | ReceivePortRR (TVar [ReceivePort a])

281 deriving Typeable

282-}

283

@@ -286,13 +286,13 @@ data ReceivePort a =

286--------------------------------------------------------------------------------

287

288-- | Messages consist of their typeRep fingerprint and their encoding

289−data Message = Message

289+data Message = Message

290− { messageFingerprint :: !Fingerprint

290+ { messageFingerprint :: !Fingerprint

291 , messageEncoding :: !BSL.ByteString

292 }

293

294instance Show Message where

295− show (Message fp enc) = show enc ++ " :: " ++ showFingerprint fp []

295+ show (Message fp enc) = show enc ++ " :: " ++ showFingerprint fp []

296

297-- | Turn any serialiable term into a message

298createMessage :: Serializable a => a -> Message

@@ -304,26 +304,26 @@ messageToPayload (Message fp enc) = encodeFingerprint fp : BSL.toChunks enc

304

305-- | Deserialize a message

306payloadToMessage :: [BSS.ByteString] -> Message

307−payloadToMessage payload = Message fp (copy msg)

307+payloadToMessage payload = Message fp (copy msg)

308 where

309 encFp :: BSL.ByteString

310 msg :: BSL.ByteString

311− (encFp, msg) = BSL.splitAt (fromIntegral sizeOfFingerprint)

311+ (encFp, msg) = BSL.splitAt (fromIntegral sizeOfFingerprint)

312− $ BSL.fromChunks payload

312+ $ BSL.fromChunks payload

313

314 fp :: Fingerprint

315 fp = decodeFingerprint . BSS.concat . BSL.toChunks $ encFp

316

317 copy :: BSL.ByteString -> BSL.ByteString

318 copy (BSL.Chunk bs BSL.Empty) = BSL.Chunk (BSS.copy bs) BSL.Empty

319− copy bsl = BSL.fromChunks . return . BSS.concat . BSL.toChunks $ bsl

319+ copy bsl = BSL.fromChunks . return . BSS.concat . BSL.toChunks $ bsl

320

321--------------------------------------------------------------------------------

322-- Node controller user-visible data types --

323--------------------------------------------------------------------------------

324

325−-- | MonitorRef is opaque for regular Cloud Haskell processes

325+-- | MonitorRef is opaque for regular Cloud Haskell processes

326−data MonitorRef = MonitorRef

326+data MonitorRef = MonitorRef

327 { -- | ID of the entity to be monitored

328 monitorRefIdent :: !Identifier

329 -- | Unique to distinguish multiple monitor requests by the same process

@@ -332,39 +332,39 @@ data MonitorRef = MonitorRef

332 deriving (Eq, Ord, Show)

333

334-- | Message sent by process monitors

335−data ProcessMonitorNotification =

335+data ProcessMonitorNotification =

336 ProcessMonitorNotification !MonitorRef !ProcessId !DiedReason

337 deriving (Typeable, Show)

338

339-- | Message sent by node monitors

340−data NodeMonitorNotification =

340+data NodeMonitorNotification =

341 NodeMonitorNotification !MonitorRef !NodeId !DiedReason

342 deriving (Typeable, Show)

343

344-- | Message sent by channel (port) monitors

345−data PortMonitorNotification =

345+data PortMonitorNotification =

346 PortMonitorNotification !MonitorRef !SendPortId !DiedReason

347 deriving (Typeable, Show)

348

349-- | Exceptions thrown when a linked process dies

350−data ProcessLinkException =

350+data ProcessLinkException =

351 ProcessLinkException !ProcessId !DiedReason

352 deriving (Typeable, Show)

353

354-- | Exception thrown when a linked node dies

355−data NodeLinkException =

355+data NodeLinkException =

356 NodeLinkException !NodeId !DiedReason

357 deriving (Typeable, Show)

358

359-- | Exception thrown when a linked channel (port) dies

360−data PortLinkException =

360+data PortLinkException =

361 PortLinkException !SendPortId !DiedReason

362 deriving (Typeable, Show)

363

364-- | Exception thrown when a process attempts to register

365-- a process under an already-registered name or to

366-- unregister a name that hasn't been registered

367−data ProcessRegistrationException =

367+data ProcessRegistrationException =

368 ProcessRegistrationException !String

369 deriving (Typeable, Show)

370

@@ -374,7 +374,7 @@ instance Exception PortLinkException

374instance Exception ProcessRegistrationException

375

376-- | Why did a process die?

377−data DiedReason =

377+data DiedReason =

378 -- | Normal termination

379 DiedNormal

380 -- | The process exited with an exception

@@ -384,7 +384,7 @@ data DiedReason =

384 | DiedDisconnect

385 -- | The process node died

386 | DiedNodeDown

387− -- | Invalid (process/node/channel) identifier

387+ -- | Invalid (process/node/channel) identifier

388 | DiedUnknownId

389 deriving (Show, Eq)

390

@@ -401,7 +401,7 @@ newtype DidUnlinkNode = DidUnlinkNode NodeId

401 deriving (Typeable, Binary)

402

403-- | (Asynchronous) reply from unlinkPort

404−newtype DidUnlinkPort = DidUnlinkPort SendPortId

404+newtype DidUnlinkPort = DidUnlinkPort SendPortId

405 deriving (Typeable, Binary)

406

407-- | 'SpawnRef' are used to return pids of spawned processes

@@ -425,20 +425,20 @@ data RegisterReply = RegisterReply String Bool

425--------------------------------------------------------------------------------

426

427-- | Messages to the node controller

428−data NCMsg = NCMsg

428+data NCMsg = NCMsg

429− { ctrlMsgSender :: !Identifier

429+ { ctrlMsgSender :: !Identifier

430 , ctrlMsgSignal :: !ProcessSignal

431 }

432 deriving Show

433

434-- | Signals to the node controller (see 'NCMsg')

435data ProcessSignal =

436− Link !Identifier

436+ Link !Identifier

437− | Unlink !Identifier

437+ | Unlink !Identifier

438 | Monitor !MonitorRef

439 | Unmonitor !MonitorRef

440 | Died Identifier !DiedReason

441− | Spawn !(Closure (Process ())) !SpawnRef

441+ | Spawn !(Closure (Process ())) !SpawnRef

442 | WhereIs !String

443 | Register !String !NodeId !(Maybe ProcessId) !Bool -- Use 'Nothing' to unregister, use True to force reregister

444 | NamedSend !String !Message

@@ -480,12 +480,12 @@ instance Binary ProcessSignal where

480 put (Link pid) = putWord8 0 >> put pid

481 put (Unlink pid) = putWord8 1 >> put pid

482 put (Monitor ref) = putWord8 2 >> put ref

483− put (Unmonitor ref) = putWord8 3 >> put ref

483+ put (Unmonitor ref) = putWord8 3 >> put ref

484 put (Died who reason) = putWord8 4 >> put who >> put reason

485 put (Spawn proc ref) = putWord8 5 >> put proc >> put ref

486 put (WhereIs label) = putWord8 6 >> put label

487 put (Register label nid pid force) = putWord8 7 >> put label >> put nid >> put pid >> put force

488− put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)

488+ put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)

489 get = do

490 header <- getWord8

491 case header of

@@ -502,7 +502,7 @@ instance Binary ProcessSignal where

502

503instance Binary DiedReason where

504 put DiedNormal = putWord8 0

505− put (DiedException e) = putWord8 1 >> put e

505+ put (DiedException e) = putWord8 1 >> put e

506 put DiedDisconnect = putWord8 2

507 put DiedNodeDown = putWord8 3

508 put DiedUnknownId = putWord8 4

@@ -513,7 +513,7 @@ instance Binary DiedReason where

513 1 -> DiedException <$> get

514 2 -> return DiedDisconnect

515 3 -> return DiedNodeDown

516− 4 -> return DiedUnknownId

516+ 4 -> return DiedUnknownId

517 _ -> fail "DiedReason.get: invalid"

518

519instance Binary DidSpawn where

@@ -522,18 +522,18 @@ instance Binary DidSpawn where

522

523instance Binary SendPortId where

524 put cid = put (sendPortProcessId cid) >> put (sendPortLocalId cid)

525− get = SendPortId <$> get <*> get

525+ get = SendPortId <$> get <*> get

526

527instance Binary Identifier where

528 put (ProcessIdentifier pid) = putWord8 0 >> put pid

529 put (NodeIdentifier nid) = putWord8 1 >> put nid

530 put (SendPortIdentifier cid) = putWord8 2 >> put cid

531 get = do

532− header <- getWord8

532+ header <- getWord8

533 case header of

534 0 -> ProcessIdentifier <$> get

535 1 -> NodeIdentifier <$> get

536− 2 -> SendPortIdentifier <$> get

536+ 2 -> SendPortIdentifier <$> get

537 _ -> fail "Identifier.get: invalid"

538

539instance Binary WhereIsReply where

@@ -541,7 +541,7 @@ instance Binary WhereIsReply where

541 get = WhereIsReply <$> get <*> get

542

543instance Binary RegisterReply where

544− put (RegisterReply label ok) = put label >> put ok

544+ put (RegisterReply label ok) = put label >> put ok

545 get = RegisterReply <$> get <*> get

546

547--------------------------------------------------------------------------------

distributed-process/src/Control/Distributed/Process/Internal/WeakTQueue.hs+2−2

@@ -21,7 +21,7 @@ module Control.Distributed.Process.Internal.WeakTQueue (

21import Prelude hiding (read)

22import GHC.Conc

23import Data.Typeable (Typeable)

24−import GHC.IO (IO(IO))

24+import GHC.IO (IO(IO))

25import GHC.Prim (mkWeak#)

26import GHC.Weak (Weak(Weak))

@@ -98,4 +98,4 @@ isEmptyTQueue (TQueue read write) = do

99mkWeakTQueue :: TQueue a -> IO () -> IO (Weak (TQueue a))

100mkWeakTQueue q@(TQueue _read (TVar write#)) f = IO $ \s ->

101− case mkWeak# write# q f s of (# s', w #) -> (# s', Weak w #)

101+ case mkWeak# write# q f s of (# s', w #) -> (# s', Weak w #)

distributed-process/src/Control/Distributed/Process/Node.hs+122−122

@@ -2,7 +2,7 @@

2--

3-- TODO: Calls to 'sendBinary' and co by the node controller may stall the

4-- node controller.

5−module Control.Distributed.Process.Node

5+module Control.Distributed.Process.Node

6 ( LocalNode

7 , newLocalNode

8 , closeLocalNode

@@ -21,7 +21,7 @@ import System.Mem.Weak (Weak, deRefWeak)

21import qualified Data.ByteString.Lazy as BSL (fromChunks)

22import Data.Binary (decode)

23import Data.Map (Map)

24−import qualified Data.Map as Map

24+import qualified Data.Map as Map

25 ( empty

26 , toList

27 , fromList

@@ -46,7 +46,7 @@ import Control.Exception (throwIO, SomeException, Exception, throwTo)

46import qualified Control.Exception as Exception (catch)

47import Control.Concurrent (forkIO)

48import Control.Distributed.Process.Internal.StrictMVar

49− ( newMVar

49+ ( newMVar

50 , withMVar

51 , modifyMVar

52 , modifyMVar_

@@ -56,13 +56,13 @@ import Control.Distributed.Process.Internal.StrictMVar

56 )

57import Control.Concurrent.Chan (newChan, writeChan, readChan)

58import Control.Concurrent.STM (atomically)

59−import Control.Distributed.Process.Internal.CQueue

59+import Control.Distributed.Process.Internal.CQueue

60 ( CQueue

61 , enqueue

62 , newCQueue

63 , mkWeakCQueue

64 )

65−import qualified Network.Transport as NT

65+import qualified Network.Transport as NT

66 ( Transport

67 , EndPoint

68 , newEndPoint

@@ -81,11 +81,11 @@ import qualified Network.Transport as NT

81import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))

82import System.Random (randomIO)

83import Control.Distributed.Static (RemoteTable, Closure)

84−import qualified Control.Distributed.Static as Static

84+import qualified Control.Distributed.Static as Static

85 ( unclosure

86 , initRemoteTable

87 )

88−import Control.Distributed.Process.Internal.Types

88+import Control.Distributed.Process.Internal.Types

89 ( NodeId(..)

90 , LocalProcessId(..)

91 , ProcessId(..)

@@ -134,7 +134,7 @@ import Control.Distributed.Process.Internal.Messaging

134 ( sendBinary

135 , sendMessage

136 , sendPayload

137− , closeImplicitReconnections

137+ , closeImplicitReconnections

138 , impliesDeathOf

139 )

140import Control.Distributed.Process.Internal.Primitives

@@ -153,27 +153,27 @@ import qualified Control.Distributed.Process.Internal.StrictContainerAccessors a

153--------------------------------------------------------------------------------

154

155initRemoteTable :: RemoteTable

156−initRemoteTable = BuiltIn.remoteTable Static.initRemoteTable

156+initRemoteTable = BuiltIn.remoteTable Static.initRemoteTable

157

158−-- | Initialize a new local node.

158+-- | Initialize a new local node.

159newLocalNode :: NT.Transport -> RemoteTable -> IO LocalNode

160newLocalNode transport rtable = do

161 mEndPoint <- NT.newEndPoint transport

162 case mEndPoint of

163 Left ex -> throwIO ex

164 Right endPoint -> do

165− localNode <- createBareLocalNode endPoint rtable

165+ localNode <- createBareLocalNode endPoint rtable

166 startServiceProcesses localNode

167 return localNode

168−

168+

169-- | Create a new local node (without any service processes running)

170createBareLocalNode :: NT.EndPoint -> RemoteTable -> IO LocalNode

171createBareLocalNode endPoint rtable = do

172 unq <- randomIO

173− state <- newMVar LocalNodeState

173+ state <- newMVar LocalNodeState

174 { _localProcesses = Map.empty

175− , _localPidCounter = firstNonReservedProcessId

175+ , _localPidCounter = firstNonReservedProcessId

176− , _localPidUnique = unq

176+ , _localPidUnique = unq

177 , _localConnections = Map.empty

178 }

179 ctrlChan <- newChan

@@ -183,7 +183,7 @@ createBareLocalNode endPoint rtable = do

183 , localCtrlChan = ctrlChan

184 , remoteTable = rtable

185 }

186− void . forkIO $ runNodeController node

186+ void . forkIO $ runNodeController node

187 void . forkIO $ handleIncomingMessages node

188 return node

189

@@ -192,7 +192,7 @@ createBareLocalNode endPoint rtable = do

192forever' :: Monad m => m a -> m b

193forever' a = let a' = a >> a' in a'

194

195−-- | Start and register the service processes on a node

195+-- | Start and register the service processes on a node

196-- (for now, this is only the logger)

197startServiceProcesses :: LocalNode -> IO ()

198startServiceProcesses node = do

@@ -231,7 +231,7 @@ forkProcess node proc = modifyMVar (localState node) startProcess

231 let lpid = LocalProcessId { lpidCounter = st ^. localPidCounter

232 , lpidUnique = st ^. localPidUnique

233 }

234− let pid = ProcessId { processNodeId = localNodeId node

234+ let pid = ProcessId { processNodeId = localNodeId node

235 , processLocalId = lpid

236 }

237 pst <- newMVar LocalProcessState { _monitorCounter = 0

@@ -245,19 +245,19 @@ forkProcess node proc = modifyMVar (localState node) startProcess

245 let lproc = LocalProcess { processQueue = queue

246 , processWeakQ = weakQueue

247 , processId = pid

248− , processState = pst

248+ , processState = pst

249 , processThread = tid

250 , processNode = node

251 }

252 tid' <- forkIO $ do

253− reason <- Exception.catch

253+ reason <- Exception.catch

254 (runLocalProcess lproc proc >> return DiedNormal)

255 (return . DiedException . (show :: SomeException -> String))

256 -- [Unified: Table 4, rules termination and exiting]

257 modifyMVar_ (localState node) (cleanupProcess pid)

258− writeChan (localCtrlChan node) NCMsg

258+ writeChan (localCtrlChan node) NCMsg

259− { ctrlMsgSender = ProcessIdentifier pid

259+ { ctrlMsgSender = ProcessIdentifier pid

260− , ctrlMsgSignal = Died (ProcessIdentifier pid) reason

260+ , ctrlMsgSignal = Died (ProcessIdentifier pid) reason

261 }

262 return (tid', lproc)

263

@@ -274,12 +274,12 @@ forkProcess node proc = modifyMVar (localState node) startProcess

274 return ( (localProcessWithId lpid ^= Just lproc)

275 . (localPidCounter ^: (+ 1))

276 $ st

277− , pid

277+ , pid

278 )

279

280 cleanupProcess :: ProcessId -> LocalNodeState -> IO LocalNodeState

281 cleanupProcess pid st = do

282− let pid' = ProcessIdentifier pid

282+ let pid' = ProcessIdentifier pid

283 let (affected, unaffected) = Map.partitionWithKey (\(fr, _to) !_v -> impliesDeathOf pid' fr) (st ^. localConnections)

284 mapM_ (NT.close . fst) (Map.elems affected)

285 return $ (localProcessWithId (processLocalId pid) ^= Nothing)

@@ -292,7 +292,7 @@ forkProcess node proc = modifyMVar (localState node) startProcess

292

293type IncomingConnection = (NT.EndPointAddress, IncomingTarget)

294

295−data IncomingTarget =

295+data IncomingTarget =

296 Uninit

297 | ToProc (Weak (CQueue Message))

298 | ToChan TypedChannel

@@ -315,20 +315,20 @@ incoming = accessor _incoming (\conns st -> st { _incoming = conns })

315incomingAt :: NT.ConnectionId -> Accessor ConnectionState (Maybe IncomingConnection)

316incomingAt cid = incoming >>> DAC.mapMaybe cid

317

318−incomingFrom :: NT.EndPointAddress -> Accessor ConnectionState (Set NT.ConnectionId)

318+incomingFrom :: NT.EndPointAddress -> Accessor ConnectionState (Set NT.ConnectionId)

319incomingFrom addr = aux >>> DAC.mapDefault Set.empty addr

320 where

321 aux = accessor _incomingFrom (\fr st -> st { _incomingFrom = fr })

322

323handleIncomingMessages :: LocalNode -> IO ()

324−handleIncomingMessages node = go initConnectionState

324+handleIncomingMessages node = go initConnectionState

325 where

326− go :: ConnectionState -> IO ()

326+ go :: ConnectionState -> IO ()

327 go !st = do

328 event <- NT.receive endpoint

329 case event of

330 NT.ConnectionOpened cid rel theirAddr ->

331− if rel == NT.ReliableOrdered

331+ if rel == NT.ReliableOrdered

332 then go ( (incomingAt cid ^= Just (theirAddr, Uninit))

333 . (incomingFrom theirAddr ^: Set.insert cid)

334 $ st

@@ -338,33 +338,33 @@ handleIncomingMessages node = go initConnectionState

338 case st ^. incomingAt cid of

339 Just (_, ToProc weakQueue) -> do

340 mQueue <- deRefWeak weakQueue

341− forM_ mQueue $ \queue -> do

341+ forM_ mQueue $ \queue -> do

342 -- TODO: if we find that the queue is Nothing, should we remove

343 -- it from the NC state? (and same for channels, below)

344 let msg = payloadToMessage payload

345 enqueue queue msg -- 'enqueue' is strict

346− go st

346+ go st

347 Just (_, ToChan (TypedChannel chan')) -> do

348 mChan <- deRefWeak chan'

349 -- If mChan is Nothing, the process has given up the read end of

350 -- the channel and we simply ignore the incoming message

351− forM_ mChan $ \chan -> atomically $

351+ forM_ mChan $ \chan -> atomically $

352 -- We make sure the message is fully decoded when it is enqueued

353 writeTQueue chan $! decode (BSL.fromChunks payload)

354− go st

354+ go st

355 Just (_, ToNode) -> do

356 let ctrlMsg = decode . BSL.fromChunks $ payload

357 writeChan ctrlChan $! ctrlMsg

358− go st

358+ go st

359− Just (src, Uninit) ->

359+ Just (src, Uninit) ->

360 case decode (BSL.fromChunks payload) of

361 ProcessIdentifier pid -> do

362 let lpid = processLocalId pid

363− mProc <- withMVar state $ return . (^. localProcessWithId lpid)

363+ mProc <- withMVar state $ return . (^. localProcessWithId lpid)

364 case mProc of

365− Just proc ->

365+ Just proc ->

366− go (incomingAt cid ^= Just (src, ToProc (processWeakQ proc)) $ st)

366+ go (incomingAt cid ^= Just (src, ToProc (processWeakQ proc)) $ st)

367− Nothing ->

367+ Nothing ->

368 invalidRequest cid st

369 SendPortIdentifier chId -> do

370 let lcid = sendPortLocalId chId

@@ -374,7 +374,7 @@ handleIncomingMessages node = go initConnectionState

374 Just proc -> do

375 mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)

376 case mChannel of

377− Just channel ->

377+ Just channel ->

378 go (incomingAt cid ^= Just (src, ToChan channel) $ st)

379 Nothing ->

380 invalidRequest cid st

@@ -383,35 +383,35 @@ handleIncomingMessages node = go initConnectionState

383 NodeIdentifier nid ->

384 if nid == localNodeId node

385 then go (incomingAt cid ^= Just (src, ToNode) $ st)

386− else invalidRequest cid st

386+ else invalidRequest cid st

387 Nothing ->

388 invalidRequest cid st

389− NT.ConnectionClosed cid ->

389+ NT.ConnectionClosed cid ->

390 case st ^. incomingAt cid of

391− Nothing ->

391+ Nothing ->

392 invalidRequest cid st

393− Just (src, _) ->

393+ Just (src, _) ->

394 go ( (incomingAt cid ^= Nothing)

395 . (incomingFrom src ^: Set.delete cid)

396 $ st

397 )

398− NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost theirAddr) _) -> do

398+ NT.ErrorEvent (NT.TransportError (NT.EventConnectionLost theirAddr) _) -> do

399 -- [Unified table 9, rule node_disconnect]

400 let nid = NodeIdentifier $ NodeId theirAddr

401− writeChan ctrlChan NCMsg

401+ writeChan ctrlChan NCMsg

402 { ctrlMsgSender = nid

403 , ctrlMsgSignal = Died nid DiedDisconnect

404 }

405 let notLost k = not (k `Set.member` (st ^. incomingFrom theirAddr))

406− closeImplicitReconnections node nid

406+ closeImplicitReconnections node nid

407 go ( (incomingFrom theirAddr ^= Set.empty)

408 . (incoming ^: Map.filterWithKey (const . notLost))

409− $ st

409+ $ st

410 )

411 NT.ErrorEvent (NT.TransportError NT.EventEndPointFailed str) ->

412− fail $ "Cloud Haskell fatal error: end point failed: " ++ str

412+ fail $ "Cloud Haskell fatal error: end point failed: " ++ str

413 NT.ErrorEvent (NT.TransportError NT.EventTransportFailed str) ->

414− fail $ "Cloud Haskell fatal error: transport failed: " ++ str

414+ fail $ "Cloud Haskell fatal error: transport failed: " ++ str

415 NT.EndPointClosed ->

416 return ()

417 NT.ReceivedMulticast _ _ ->

@@ -420,13 +420,13 @@ handleIncomingMessages node = go initConnectionState

420 fail "Cloud Haskell fatal error: received unexpected multicast"

421

422 invalidRequest :: NT.ConnectionId -> ConnectionState -> IO ()

423− invalidRequest cid st =

423+ invalidRequest cid st =

424 -- TODO: We should treat this as a fatal error on the part of the remote

425 -- node. That is, we should report the remote node as having died, and we

426 -- should close incoming connections (this requires a Transport layer

427 -- extension).

428 go ( incomingAt cid ^= Nothing

429− $ st

429+ $ st

430 )

431

432 state = localState node

@@ -445,8 +445,8 @@ runNodeController =

445-- Internal data types --

446--------------------------------------------------------------------------------

447

448−data NCState = NCState

448+data NCState = NCState

449− { -- Mapping from remote processes to linked local processes

449+ { -- Mapping from remote processes to linked local processes

450 _links :: !(Map Identifier (Set ProcessId))

451 -- Mapping from remote processes to monitoring local processes

452 , _monitors :: !(Map Identifier (Set (ProcessId, MonitorRef)))

@@ -472,19 +472,19 @@ initNCState = NCState { _links = Map.empty

472-- [Unified: Table 7]

473nodeController :: NC ()

474nodeController = do

475− node <- ask

475+ node <- ask

476 forever' $ do

477 msg <- liftIO $ readChan (localCtrlChan node)

478

479− -- [Unified: Table 7, rule nc_forward]

479+ -- [Unified: Table 7, rule nc_forward]

480 case destNid (ctrlMsgSignal msg) of

481− Just nid' | nid' /= localNodeId node ->

481+ Just nid' | nid' /= localNodeId node ->

482 liftIO $ sendBinary node

483 (ctrlMsgSender msg)

484− (NodeIdentifier nid')

484+ (NodeIdentifier nid')

485 WithImplicitReconnect

486 msg

487− _ ->

487+ _ ->

488 return ()

489

490 case msg of

@@ -493,7 +493,7 @@ nodeController = do

493 NCMsg (ProcessIdentifier from) (Monitor ref) ->

494 ncEffectMonitor from (monitorRefIdent ref) (Just ref)

495 NCMsg (ProcessIdentifier from) (Unlink them) ->

496− ncEffectUnlink from them

496+ ncEffectUnlink from them

497 NCMsg (ProcessIdentifier from) (Unmonitor ref) ->

498 ncEffectUnmonitor from ref

499 NCMsg _from (Died ident reason) ->

@@ -510,23 +510,23 @@ nodeController = do

510 error $ "nodeController: unexpected message " ++ show unexpected

511

512-- [Unified: Table 10]

513−ncEffectMonitor :: ProcessId -- ^ Who's watching?

513+ncEffectMonitor :: ProcessId -- ^ Who's watching?

514 -> Identifier -- ^ Who's being watched?

515 -> Maybe MonitorRef -- ^ 'Nothing' to link

516 -> NC ()

517ncEffectMonitor from them mRef = do

518− node <- ask

518+ node <- ask

519− shouldLink <-

519+ shouldLink <-

520− if not (isLocal node them)

520+ if not (isLocal node them)

521 then return True

522 else isValidLocalIdentifier them

523 case (shouldLink, isLocal node (ProcessIdentifier from)) of

524 (True, _) -> -- [Unified: first rule]

525 case mRef of

526 Just ref -> modify' $ monitorsFor them ^: Set.insert (from, ref)

527− Nothing -> modify' $ linksFor them ^: Set.insert from

527+ Nothing -> modify' $ linksFor them ^: Set.insert from

528 (False, True) -> -- [Unified: second rule]

529− notifyDied from them DiedUnknownId mRef

529+ notifyDied from them DiedUnknownId mRef

530 (False, False) -> -- [Unified: third rule]

531 -- TODO: this is the right sender according to the Unified semantics,

532 -- but perhaps having 'them' as the sender would make more sense

@@ -535,7 +535,7 @@ ncEffectMonitor from them mRef = do

535 (NodeIdentifier $ localNodeId node)

536 (NodeIdentifier $ processNodeId from)

537 WithImplicitReconnect

538− NCMsg

538+ NCMsg

539 { ctrlMsgSender = NodeIdentifier (localNodeId node)

540 , ctrlMsgSignal = Died them DiedUnknownId

541 }

@@ -543,22 +543,22 @@ ncEffectMonitor from them mRef = do

543-- [Unified: Table 11]

544ncEffectUnlink :: ProcessId -> Identifier -> NC ()

545ncEffectUnlink from them = do

546− node <- ask

546+ node <- ask

547− when (isLocal node (ProcessIdentifier from)) $

547+ when (isLocal node (ProcessIdentifier from)) $

548 case them of

549− ProcessIdentifier pid ->

549+ ProcessIdentifier pid ->

550− postAsMessage from $ DidUnlinkProcess pid

550+ postAsMessage from $ DidUnlinkProcess pid

551− NodeIdentifier nid ->

551+ NodeIdentifier nid ->

552 postAsMessage from $ DidUnlinkNode nid

553− SendPortIdentifier cid ->

553+ SendPortIdentifier cid ->

554− postAsMessage from $ DidUnlinkPort cid

554+ postAsMessage from $ DidUnlinkPort cid

555 modify' $ linksFor them ^: Set.delete from

556

557-- [Unified: Table 11]

558ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()

559ncEffectUnmonitor from ref = do

560− node <- ask

560+ node <- ask

561− when (isLocal node (ProcessIdentifier from)) $

561+ when (isLocal node (ProcessIdentifier from)) $

562 postAsMessage from $ DidUnmonitor ref

563 modify' $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)

564

@@ -573,40 +573,40 @@ ncEffectDied ident reason = do

573

574 let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False

575

576− forM_ (Map.toList affectedLinks) $ \(them, uss) ->

576+ forM_ (Map.toList affectedLinks) $ \(them, uss) ->

577 forM_ uss $ \us ->

578− when (localOnly <= isLocal node (ProcessIdentifier us)) $

578+ when (localOnly <= isLocal node (ProcessIdentifier us)) $

579 notifyDied us them reason Nothing

580

581 forM_ (Map.toList affectedMons) $ \(them, refs) ->

582 forM_ refs $ \(us, ref) ->

583 when (localOnly <= isLocal node (ProcessIdentifier us)) $

584− notifyDied us them reason (Just ref)

584+ notifyDied us them reason (Just ref)

585

586 modify' $ (links ^= unaffectedLinks) . (monitors ^= unaffectedMons)

587

588 modify' $ registeredHere ^: Map.filter (\pid -> not $ ident `impliesDeathOf` ProcessIdentifier pid)

589

590 remaining <- fmap Map.toList (gets (^. registeredOnNodes)) >>=

591− mapM (\(pid,nidlist) ->

591+ mapM (\(pid,nidlist) ->

592 case ident `impliesDeathOf` ProcessIdentifier pid of

593− True ->

593+ True ->

594 do forM_ nidlist $ \(nid,_) ->

595− when (not $ isLocal node (NodeIdentifier nid))

595+ when (not $ isLocal node (NodeIdentifier nid))

596 (forwardNameDeath node nid)

597 return Nothing

598 False -> return $ Just (pid,nidlist) )

599 modify' $ registeredOnNodes ^= (Map.fromList (catMaybes remaining))

600− where

600+ where

601 forwardNameDeath node nid =

602 liftIO $ sendBinary node

603 (NodeIdentifier $ localNodeId node)

604 (NodeIdentifier $ nid)

605 WithImplicitReconnect

606 NCMsg

607− { ctrlMsgSender = NodeIdentifier (localNodeId node)

607+ { ctrlMsgSender = NodeIdentifier (localNodeId node)

608 , ctrlMsgSignal = Died ident reason

609− }

609+ }

610

611

612-- [Unified: Table 13]

@@ -622,9 +622,9 @@ ncEffectSpawn pid cProc ref = do

622 pid' <- liftIO $ forkProcess node proc

623 liftIO $ sendMessage node

624 (NodeIdentifier (localNodeId node))

625− (ProcessIdentifier pid)

625+ (ProcessIdentifier pid)

626 WithImplicitReconnect

627− (DidSpawn ref pid')

627+ (DidSpawn ref pid')

628

629-- Unified semantics does not explicitly describe how to implement 'register',

630-- but mentions it's "very similar to nsend" (Table 14)

@@ -639,7 +639,7 @@ ncEffectRegister from label atnode mPid reregistration = do

639 return $ isJust currentVal

640 Just thepid -> -- register request

641 do isvalidlocal <- isValidLocalIdentifier (ProcessIdentifier thepid)

642− return $ (isNothing currentVal /= reregistration) &&

642+ return $ (isNothing currentVal /= reregistration) &&

643 (not (isLocal node (ProcessIdentifier thepid) ) || isvalidlocal )

644 if isLocal node (NodeIdentifier atnode)

645 then do when (isOk) $

@@ -647,10 +647,10 @@ ncEffectRegister from label atnode mPid reregistration = do

647 updateRemote node currentVal mPid

648 liftIO $ sendMessage node

649 (NodeIdentifier (localNodeId node))

650− (ProcessIdentifier from)

650+ (ProcessIdentifier from)

651 WithImplicitReconnect

652 (RegisterReply label isOk)

653− else let operation =

653+ else let operation =

654 case reregistration of

655 True -> flip decList

656 False -> flip incList

@@ -676,7 +676,7 @@ ncEffectRegister from label atnode mPid reregistration = do

676 decList ((atag,1):xs) tag | atag == tag = xs

677 decList ((atag,n):xs) tag | atag == tag = (atag,n-1):xs

678 decList (x:xs) tag = x:decList xs tag

679− forward node to reg =

679+ forward node to reg =

680 when (not $ isLocal node (NodeIdentifier to)) $

681 liftIO $ sendBinary node

682 (ProcessIdentifier from)

@@ -695,22 +695,22 @@ ncEffectWhereIs from label = do

695 mPid <- gets (^. registeredHereFor label)

696 liftIO $ sendMessage node

697 (NodeIdentifier (localNodeId node))

698− (ProcessIdentifier from)

698+ (ProcessIdentifier from)

699 WithImplicitReconnect

700 (WhereIsReply label mPid)

701

702-- [Unified: Table 14]

703ncEffectNamedSend :: Identifier -> String -> Message -> NC ()

704ncEffectNamedSend from label msg = do

705− node <- ask

705+ node <- ask

706 mPid <- gets (^. registeredHereFor label)

707 -- If mPid is Nothing, we just ignore the named send (as per Table 14)

708− forM_ mPid $ \pid ->

708+ forM_ mPid $ \pid ->

709 liftIO $ sendPayload node

710 from

711− (ProcessIdentifier pid)

711+ (ProcessIdentifier pid)

712 NoImplicitReconnect

713− (messageToPayload msg)

713+ (messageToPayload msg)

714

715--------------------------------------------------------------------------------

716-- Auxiliary --

@@ -722,20 +722,20 @@ notifyDied :: ProcessId -- ^ Who to notify?

722 -> Maybe MonitorRef -- ^ 'Nothing' for linking

723 -> NC ()

724notifyDied dest src reason mRef = do

725− node <- ask

725+ node <- ask

726 case (isLocal node (ProcessIdentifier dest), mRef, src) of

727 (True, Just ref, ProcessIdentifier pid) ->

728− postAsMessage dest $ ProcessMonitorNotification ref pid reason

728+ postAsMessage dest $ ProcessMonitorNotification ref pid reason

729 (True, Just ref, NodeIdentifier nid) ->

730 postAsMessage dest $ NodeMonitorNotification ref nid reason

731 (True, Just ref, SendPortIdentifier cid) ->

732 postAsMessage dest $ PortMonitorNotification ref cid reason

733 (True, Nothing, ProcessIdentifier pid) ->

734− throwException dest $ ProcessLinkException pid reason

734+ throwException dest $ ProcessLinkException pid reason

735 (True, Nothing, NodeIdentifier pid) ->

736− throwException dest $ NodeLinkException pid reason

736+ throwException dest $ NodeLinkException pid reason

737 (True, Nothing, SendPortIdentifier pid) ->

738− throwException dest $ PortLinkException pid reason

738+ throwException dest $ PortLinkException pid reason

739 (False, _, _) ->

740 -- The change in sender comes from [Unified: Table 10]

741 liftIO $ sendBinary node

@@ -743,30 +743,30 @@ notifyDied dest src reason mRef = do

743 (NodeIdentifier $ processNodeId dest)

744 WithImplicitReconnect

745 NCMsg

746− { ctrlMsgSender = NodeIdentifier (localNodeId node)

746+ { ctrlMsgSender = NodeIdentifier (localNodeId node)

747 , ctrlMsgSignal = Died src reason

748 }

749−

749+

750-- | [Unified: Table 8]

751destNid :: ProcessSignal -> Maybe NodeId

752destNid (Link ident) = Just $ nodeOf ident

753destNid (Unlink ident) = Just $ nodeOf ident

754destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)

755destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)

756−destNid (Spawn _ _) = Nothing

756+destNid (Spawn _ _) = Nothing

757destNid (Register _ _ _ _) = Nothing

758destNid (WhereIs _) = Nothing

759destNid (NamedSend _ _) = Nothing

760-- We don't need to forward 'Died' signals; if monitoring/linking is setup,

761-- then when a local process dies the monitoring/linking machinery will take

762-- care of notifying remote nodes

763−destNid (Died _ _) = Nothing

763+destNid (Died _ _) = Nothing

764

765-- | Check if a process is local to our own node

766−isLocal :: LocalNode -> Identifier -> Bool

766+isLocal :: LocalNode -> Identifier -> Bool

767isLocal nid ident = nodeOf ident == localNodeId nid

768

769−-- | Lookup a local closure

769+-- | Lookup a local closure

770unClosure :: Typeable a => Closure a -> NC (Either String a)

771unClosure closure = do

772 rtable <- remoteTable <$> ask

@@ -776,13 +776,13 @@ unClosure closure = do

776isValidLocalIdentifier :: Identifier -> NC Bool

777isValidLocalIdentifier ident = do

778 node <- ask

779− liftIO . withMVar (localState node) $ \nSt ->

779+ liftIO . withMVar (localState node) $ \nSt ->

780 case ident of

781 NodeIdentifier nid ->

782 return $ nid == localNodeId node

783 ProcessIdentifier pid -> do

784 let mProc = nSt ^. localProcessWithId (processLocalId pid)

785− return $ isJust mProc

785+ return $ isJust mProc

786 SendPortIdentifier cid -> do

787 let pid = sendPortProcessId cid

788 mProc = nSt ^. localProcessWithId (processLocalId pid)

@@ -797,24 +797,24 @@ isValidLocalIdentifier ident = do

797--------------------------------------------------------------------------------

798

799postAsMessage :: Serializable a => ProcessId -> a -> NC ()

800−postAsMessage pid = postMessage pid . createMessage

800+postAsMessage pid = postMessage pid . createMessage

801

802postMessage :: ProcessId -> Message -> NC ()

803postMessage pid msg = withLocalProc pid $ \p -> enqueue (processQueue p) msg

804

805throwException :: Exception e => ProcessId -> e -> NC ()

806−throwException pid e = withLocalProc pid $ \p ->

806+throwException pid e = withLocalProc pid $ \p ->

807 throwTo (processThread p) e

808

809−withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()

809+withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()

810withLocalProc pid p = do

811− node <- ask

811+ node <- ask

812− liftIO $ do

812+ liftIO $ do

813 -- By [Unified: table 6, rule missing_process] messages to dead processes

814 -- can silently be dropped

815 let lpid = processLocalId pid

816 mProc <- withMVar (localState node) $ return . (^. localProcessWithId lpid)

817− forM_ mProc p

817+ forM_ mProc p

818

819--------------------------------------------------------------------------------

820-- Accessors --

@@ -851,23 +851,23 @@ registeredOnNodesFor ident = registeredOnNodes >>> DAC.mapMaybe ident

851-- There is a hierarchy between identifiers: failure of a node implies failure

852-- of all processes on that node, and failure of a process implies failure of

853-- all typed channels to that process. In other words, if 'ident' refers to a

854−-- node, then the /should trigger/ set will include

854+-- node, then the /should trigger/ set will include

855--

856-- * the notifications for the node specifically

857−-- * the notifications for processes on that node, and

857+-- * the notifications for processes on that node, and

858−-- * the notifications for typed channels to processes on that node.

858+-- * the notifications for typed channels to processes on that node.

859--

860-- Similarly, if 'ident' refers to a process, the /should trigger/ set will

861−-- include

861+-- include

862--

863−-- * the notifications for that process specifically and

863+-- * the notifications for that process specifically and

864-- * the notifications for typed channels to that process.

865--

866-- See https://github.com/haskell/containers/issues/14 for the bang on _v.

867splitNotif :: Identifier

868 -> Map Identifier a

869 -> (Map Identifier a, Map Identifier a)

870−splitNotif ident = Map.partitionWithKey (\k !_v -> ident `impliesDeathOf` k)

870+splitNotif ident = Map.partitionWithKey (\k !_v -> ident `impliesDeathOf` k)

871

872--------------------------------------------------------------------------------

873-- Auxiliary --

distributed-process/src/Control/Distributed/Process/Serializable.hs+8−8

@@ -1,4 +1,4 @@

1−module Control.Distributed.Process.Serializable

1+module Control.Distributed.Process.Serializable

2 ( Serializable

3 , encodeFingerprint

4 , decodeFingerprint

@@ -35,29 +35,29 @@ instance (Binary a, Typeable a) => Serializable a

36-- | Encode type representation as a bytestring

37encodeFingerprint :: Fingerprint -> ByteString

38−encodeFingerprint fp =

38+encodeFingerprint fp =

39 -- Since all CH nodes will run precisely the same binary, we don't have to

40 -- worry about cross-arch issues here (like endianness)

41− BSI.unsafeCreate sizeOfFingerprint $ \p -> pokeByteOff p 0 fp

41+ BSI.unsafeCreate sizeOfFingerprint $ \p -> pokeByteOff p 0 fp

43−-- | Decode a bytestring into a fingerprint. Throws an IO exception on failure

43+-- | Decode a bytestring into a fingerprint. Throws an IO exception on failure

44decodeFingerprint :: ByteString -> Fingerprint

45decodeFingerprint bs

46− | BS.length bs /= sizeOfFingerprint =

46+ | BS.length bs /= sizeOfFingerprint =

47 throw $ userError "decodeFingerprint: Invalid length"

48 | otherwise = BSI.inlinePerformIO $ do

49 let (fp, offset, _) = BSI.toForeignPtr bs

50− withForeignPtr fp $ \p -> peekByteOff p offset

50+ withForeignPtr fp $ \p -> peekByteOff p offset

52-- | Size of a fingerprint

53sizeOfFingerprint :: Int

54sizeOfFingerprint = sizeOf (undefined :: Fingerprint)

56−-- | The fingerprint of the typeRep of the argument

56+-- | The fingerprint of the typeRep of the argument

57fingerprint :: Typeable a => a -> Fingerprint

58fingerprint a = let TypeRep fp _ _ = typeOf a in fp

60-- | Show fingerprint (for debugging purposes)

61showFingerprint :: Fingerprint -> ShowS

62−showFingerprint (Fingerprint hi lo) =

62+showFingerprint (Fingerprint hi lo) =

63 showString "(" . showHex hi . showString "," . showHex lo . showString ")"

distributed-process/tests/TestCH.hs+104−104

@@ -1,4 +1,4 @@

1−module Main where

1+module Main where

3#if ! MIN_VERSION_base(4,6,0)

4import Prelude hiding (catch)

@@ -9,7 +9,7 @@ import Data.Binary (Binary(..))

9import Data.Typeable (Typeable)

10import Data.Foldable (forM_)

11import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId)

12−import Control.Concurrent.MVar

12+import Control.Concurrent.MVar

13 ( MVar

14 , newEmptyMVar

15 , putMVar

@@ -22,14 +22,14 @@ import qualified Control.Exception as Ex (catch)

22import Control.Applicative ((<$>), (<*>), pure, (<|>))

23import qualified Network.Transport as NT (Transport, closeEndPoint)

24import Network.Socket (sClose)

25−import Network.Transport.TCP

25+import Network.Transport.TCP

26 ( createTransportExposeInternals

27 , TransportInternals(socketBetween)

28 , defaultTCPParameters

29 )

30import Control.Distributed.Process

31−import Control.Distributed.Process.Internal.Types

31+import Control.Distributed.Process.Internal.Types

32− ( NodeId(nodeAddress)

32+ ( NodeId(nodeAddress)

33 , LocalNode(localEndPoint)

34 , RegisterReply(..)

35 )

@@ -51,7 +51,7 @@ newtype Pong = Pong ProcessId

51--------------------------------------------------------------------------------

53-- | Like fork, but throw exceptions in the child thread to the parent

54−forkTry :: IO () -> IO ThreadId

54+forkTry :: IO () -> IO ThreadId

55forkTry p = do

56 tid <- myThreadId

57 forkIO $ Ex.catch p (\e -> throwTo tid (e :: SomeException))

@@ -71,7 +71,7 @@ whereisRemote nid string = do

71 WhereIsReply _ mPid <- expect

72 return mPid

74−data Add = Add ProcessId Double Double deriving (Typeable)

74+data Add = Add ProcessId Double Double deriving (Typeable)

75data Divide = Divide ProcessId Double Double deriving (Typeable)

76data DivByZero = DivByZero deriving (Typeable)

@@ -102,7 +102,7 @@ math = do

102monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link

103 -> ProcessId -- Process to monitor/link to

104 -> Maybe (MVar ()) -- MVar to signal on once the monitor has been set up

105− -> Process (Maybe MonitorRef)

105+ -> Process (Maybe MonitorRef)

106monitorOrLink mOrL pid mSignal = do

107 result <- if mOrL then Just <$> monitor pid

108 else link pid >> return Nothing

@@ -116,11 +116,11 @@ monitorTestProcess :: ProcessId -- Process to monitor/link to

116 -> Bool -- 'True' for monitor, 'False' for link

117 -> Bool -- Should we unmonitor?

118 -> DiedReason -- Expected cause of death

119− -> Maybe (MVar ()) -- Signal for 'monitor set up'

119+ -> Maybe (MVar ()) -- Signal for 'monitor set up'

120 -> MVar () -- Signal for successful termination

121 -> Process ()

122−monitorTestProcess theirAddr mOrL un reason monitorSetup done =

122+monitorTestProcess theirAddr mOrL un reason monitorSetup done =

123− catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup

123+ catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup

124 case (un, mRef) of

125 (True, Nothing) -> do

126 unlink theirAddr

@@ -137,13 +137,13 @@ monitorTestProcess theirAddr mOrL un reason monitorSetup done =

137 True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'

138 liftIO $ putMVar done ()

139 )

140−

140+

141--------------------------------------------------------------------------------

142-- The tests proper --

143--------------------------------------------------------------------------------

144

145-- | Basic ping test

146−testPing :: NT.Transport -> Assertion

146+testPing :: NT.Transport -> Assertion

147testPing transport = do

148 serverAddr <- newEmptyMVar

149 clientDone <- newEmptyMVar

@@ -172,15 +172,15 @@ testPing transport = do

172

173 takeMVar clientDone

174

175−-- | Monitor a process on an unreachable node

175+-- | Monitor a process on an unreachable node

176−testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> Assertion

176+testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> Assertion

177testMonitorUnreachable transport mOrL un = do

178 deadProcess <- newEmptyMVar

179 done <- newEmptyMVar

180

181 forkIO $ do

182 localNode <- newLocalNode transport initRemoteTable

183− addr <- forkProcess localNode . liftIO $ threadDelay 1000000

183+ addr <- forkProcess localNode . liftIO $ threadDelay 1000000

184 closeLocalNode localNode

185 putMVar deadProcess addr

186

@@ -188,12 +188,12 @@ testMonitorUnreachable transport mOrL un = do

188 localNode <- newLocalNode transport initRemoteTable

189 theirAddr <- readMVar deadProcess

190 runProcess localNode $

191− monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done

191+ monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done

192

193 takeMVar done

194

195-- | Monitor a process which terminates normally

196−testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> Assertion

196+testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> Assertion

197testMonitorNormalTermination transport mOrL un = do

198 monitorSetup <- newEmptyMVar

199 monitoredProcess <- newEmptyMVar

@@ -201,20 +201,20 @@ testMonitorNormalTermination transport mOrL un = do

201

202 forkIO $ do

203 localNode <- newLocalNode transport initRemoteTable

204− addr <- forkProcess localNode $

204+ addr <- forkProcess localNode $

205 liftIO $ readMVar monitorSetup

206 putMVar monitoredProcess addr

207

208 forkIO $ do

209 localNode <- newLocalNode transport initRemoteTable

210 theirAddr <- readMVar monitoredProcess

211− runProcess localNode $

211+ runProcess localNode $

212 monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done

213

214 takeMVar done

215

216-- | Monitor a process which terminates abnormally

217−testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> Assertion

217+testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> Assertion

218testMonitorAbnormalTermination transport mOrL un = do

219 monitorSetup <- newEmptyMVar

220 monitoredProcess <- newEmptyMVar

@@ -226,19 +226,19 @@ testMonitorAbnormalTermination transport mOrL un = do

226 localNode <- newLocalNode transport initRemoteTable

227 addr <- forkProcess localNode . liftIO $ do

228 readMVar monitorSetup

229− throwIO err

229+ throwIO err

230 putMVar monitoredProcess addr

231

232 forkIO $ do

233 localNode <- newLocalNode transport initRemoteTable

234 theirAddr <- readMVar monitoredProcess

235− runProcess localNode $

235+ runProcess localNode $

236 monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done

237

238 takeMVar done

239−

239+

240-- | Monitor a local process that is already dead

241−testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion

241+testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion

242testMonitorLocalDeadProcess transport mOrL un = do

243 processDead <- newEmptyMVar

244 processAddr <- newEmptyMVar

@@ -258,7 +258,7 @@ testMonitorLocalDeadProcess transport mOrL un = do

258 takeMVar done

259

260-- | Monitor a remote process that is already dead

261−testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion

261+testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion

262testMonitorRemoteDeadProcess transport mOrL un = do

263 processDead <- newEmptyMVar

264 processAddr <- newEmptyMVar

@@ -279,7 +279,7 @@ testMonitorRemoteDeadProcess transport mOrL un = do

279 takeMVar done

280

281-- | Monitor a process that becomes disconnected

282−testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> Assertion

282+testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> Assertion

283testMonitorDisconnect transport mOrL un = do

284 processAddr <- newEmptyMVar

285 monitorSetup <- newEmptyMVar

@@ -287,7 +287,7 @@ testMonitorDisconnect transport mOrL un = do

287

288 forkIO $ do

289 localNode <- newLocalNode transport initRemoteTable

290− addr <- forkProcess localNode . liftIO $ threadDelay 1000000

290+ addr <- forkProcess localNode . liftIO $ threadDelay 1000000

291 putMVar processAddr addr

292 readMVar monitorSetup

293 NT.closeEndPoint (localEndPoint localNode)

@@ -297,18 +297,18 @@ testMonitorDisconnect transport mOrL un = do

297 theirAddr <- readMVar processAddr

298 runProcess localNode $ do

299 monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done

300−

300+

301 takeMVar done

302

303-- | Test the math server (i.e., receiveWait)

304−testMath :: NT.Transport -> Assertion

304+testMath :: NT.Transport -> Assertion

305testMath transport = do

306− serverAddr <- newEmptyMVar

306+ serverAddr <- newEmptyMVar

307 clientDone <- newEmptyMVar

308

309 -- Server

310 forkIO $ do

311− localNode <- newLocalNode transport initRemoteTable

311+ localNode <- newLocalNode transport initRemoteTable

312 addr <- forkProcess localNode math

313 putMVar serverAddr addr

314

@@ -320,7 +320,7 @@ testMath transport = do

320 runProcess localNode $ do

321 pid <- getSelfPid

322 send mathServer (Add pid 1 2)

323− 3 <- expect :: Process Double

323+ 3 <- expect :: Process Double

324 send mathServer (Divide pid 8 2)

325 4 <- expect :: Process Double

326 send mathServer (Divide pid 8 0)

@@ -330,15 +330,15 @@ testMath transport = do

330 takeMVar clientDone

331

332-- | Send first message (i.e. connect) to an already terminated process

333−-- (without monitoring); then send another message to a second process on

333+-- (without monitoring); then send another message to a second process on

334-- the same remote node (we're checking that the remote node did not die)

335−testSendToTerminated :: NT.Transport -> Assertion

335+testSendToTerminated :: NT.Transport -> Assertion

336testSendToTerminated transport = do

337 serverAddr1 <- newEmptyMVar

338 serverAddr2 <- newEmptyMVar

339 clientDone <- newEmptyMVar

340

341− forkIO $ do

341+ forkIO $ do

342 terminated <- newEmptyMVar

343 localNode <- newLocalNode transport initRemoteTable

344 addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()

@@ -356,13 +356,13 @@ testSendToTerminated transport = do

356 send server1 "Hi"

357 send server2 (Pong pid)

358 Ping pid' <- expect

359− True <- return $ pid' == server2

359+ True <- return $ pid' == server2

360 liftIO $ putMVar clientDone ()

361

362 takeMVar clientDone

363

364-- | Test (non-zero) timeout

365−testTimeout :: NT.Transport -> Assertion

365+testTimeout :: NT.Transport -> Assertion

366testTimeout transport = do

367 localNode <- newLocalNode transport initRemoteTable

368 runProcess localNode $ do

@@ -370,20 +370,20 @@ testTimeout transport = do

370 return ()

371

372-- | Test zero timeout

373−testTimeout0 :: NT.Transport -> Assertion

373+testTimeout0 :: NT.Transport -> Assertion

374testTimeout0 transport = do

375 serverAddr <- newEmptyMVar

376 clientDone <- newEmptyMVar

377 messagesSent <- newEmptyMVar

378

379− forkIO $ do

379+ forkIO $ do

380 localNode <- newLocalNode transport initRemoteTable

381 addr <- forkProcess localNode $ do

382 liftIO $ readMVar messagesSent >> threadDelay 1000000

383 -- Variation on the venerable ping server which uses a zero timeout

384 -- Since we wait for all messages to be sent before doing this receive,

385 -- we should nevertheless find the right message immediately

386− Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]

386+ Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]

387 self <- getSelfPid

388 send partner (Ping self)

389 putMVar serverAddr addr

@@ -398,13 +398,13 @@ testTimeout0 transport = do

398 replicateM_ 10000 $ send server "Irrelevant message"

399 send server (Pong pid)

400 liftIO $ putMVar messagesSent ()

401− Ping _ <- expect

401+ Ping _ <- expect

402 liftIO $ putMVar clientDone ()

403

404 takeMVar clientDone

405

406-- | Test typed channels

407−testTypedChannels :: NT.Transport -> Assertion

407+testTypedChannels :: NT.Transport -> Assertion

408testTypedChannels transport = do

409 serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))

410 clientDone <- newEmptyMVar

@@ -413,7 +413,7 @@ testTypedChannels transport = do

413 localNode <- newLocalNode transport initRemoteTable

414 forkProcess localNode $ do

415 (serverSendPort, rport) <- newChan

416− liftIO $ putMVar serverChannel serverSendPort

416+ liftIO $ putMVar serverChannel serverSendPort

417 (clientSendPort, i) <- receiveChan rport

418 sendChan clientSendPort (even i)

419 return ()

@@ -423,14 +423,14 @@ testTypedChannels transport = do

423 serverSendPort <- readMVar serverChannel

424 runProcess localNode $ do

425 (clientSendPort, rport) <- newChan

426− sendChan serverSendPort (clientSendPort, 5)

426+ sendChan serverSendPort (clientSendPort, 5)

427 False <- receiveChan rport

428 liftIO $ putMVar clientDone ()

429−

429+

430− takeMVar clientDone

430+ takeMVar clientDone

431

432-- | Test merging receive ports

433−testMergeChannels :: NT.Transport -> Assertion

433+testMergeChannels :: NT.Transport -> Assertion

434testMergeChannels transport = do

435 localNode <- newLocalNode transport initRemoteTable

436 testFlat localNode True "aaabbbccc"

@@ -443,13 +443,13 @@ testMergeChannels transport = do

443 testBlocked localNode False

444 where

445 -- Single layer of merging

446− testFlat :: LocalNode -> Bool -> String -> IO ()

446+ testFlat :: LocalNode -> Bool -> String -> IO ()

447 testFlat localNode biased expected = do

448 done <- newEmptyMVar

449 forkProcess localNode $ do

450− rs <- mapM charChannel "abc"

450+ rs <- mapM charChannel "abc"

451− m <- mergePorts biased rs

451+ m <- mergePorts biased rs

452− xs <- replicateM 9 $ receiveChan m

452+ xs <- replicateM 9 $ receiveChan m

453 True <- return $ xs == expected

454 liftIO $ putMVar done ()

455 takeMVar done

@@ -462,7 +462,7 @@ testMergeChannels transport = do

462 rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]

463 ms <- mapM (mergePorts biasedInner) rss

464 m <- mergePorts biasedOuter ms

465− xs <- replicateM (9 * 3) $ receiveChan m

465+ xs <- replicateM (9 * 3) $ receiveChan m

466 True <- return $ xs == expected

467 liftIO $ putMVar done ()

468 takeMVar done

@@ -470,12 +470,12 @@ testMergeChannels transport = do

470 -- Test that if no messages are (immediately) available, the scheduler makes no difference

471 testBlocked :: LocalNode -> Bool -> IO ()

472 testBlocked localNode biased = do

473− vs <- replicateM 3 newEmptyMVar

473+ vs <- replicateM 3 newEmptyMVar

474 done <- newEmptyMVar

475

476 forkProcess localNode $ do

477− [sa, sb, sc] <- liftIO $ mapM readMVar vs

477+ [sa, sb, sc] <- liftIO $ mapM readMVar vs

478− mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)

478+ mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)

479 [ -- a, b, c

480 (sa, 'a')

481 , (sb, 'b')

@@ -504,8 +504,8 @@ testMergeChannels transport = do

504

505 forkProcess localNode $ do

506 (ss, rs) <- unzip <$> replicateM 3 newChan

507− liftIO $ mapM_ (uncurry putMVar) $ zip vs ss

507+ liftIO $ mapM_ (uncurry putMVar) $ zip vs ss

508− m <- mergePorts biased rs

508+ m <- mergePorts biased rs

509 xs <- replicateM (6 * 3) $ receiveChan m

510 True <- return $ xs == "abcacbbacbcacabcba"

511 liftIO $ putMVar done ()

@@ -514,16 +514,16 @@ testMergeChannels transport = do

514

515 mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)

516 mergePorts True = mergePortsBiased

517− mergePorts False = mergePortsRR

517+ mergePorts False = mergePortsRR

518

519 charChannel :: Char -> Process (ReceivePort Char)

520 charChannel c = do

521 (sport, rport) <- newChan

522− replicateM_ 3 $ sendChan sport c

522+ replicateM_ 3 $ sendChan sport c

523 liftIO $ threadDelay 10000 -- Make sure messages have been sent

524 return rport

525

526−testTerminate :: NT.Transport -> Assertion

526+testTerminate :: NT.Transport -> Assertion

527testTerminate transport = do

528 localNode <- newLocalNode transport initRemoteTable

529

@@ -534,10 +534,10 @@ testTerminate transport = do

534 runProcess localNode $ do

535 ref <- monitor pid

536 ProcessMonitorNotification ref' pid' (DiedException ex) <- expect

537− True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException

537+ True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException

538 return ()

539

540−testMonitorNode :: NT.Transport -> Assertion

540+testMonitorNode :: NT.Transport -> Assertion

541testMonitorNode transport = do

542 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable

543

@@ -549,7 +549,7 @@ testMonitorNode transport = do

549 True <- return $ ref == ref' && nid == localNodeId node1

550 return ()

551

552−testMonitorChannel :: NT.Transport -> Assertion

552+testMonitorChannel :: NT.Transport -> Assertion

553testMonitorChannel transport = do

554 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable

555 gotNotification <- newEmptyMVar

@@ -558,7 +558,7 @@ testMonitorChannel transport = do

558 sport <- expect :: Process (SendPort ())

559 ref <- monitorPort sport

560 PortMonitorNotification ref' port' reason <- expect

561− -- reason might be DiedUnknownId if the receive port is GCed before the

561+ -- reason might be DiedUnknownId if the receive port is GCed before the

562 -- monitor is established (TODO: not sure that this is reasonable)

563 return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)

564 liftIO $ putMVar gotNotification ()

@@ -570,45 +570,45 @@ testMonitorChannel transport = do

570

571 takeMVar gotNotification

572

573−testRegistry :: NT.Transport -> Assertion

573+testRegistry :: NT.Transport -> Assertion

574testRegistry transport = do

575 node <- newLocalNode transport initRemoteTable

576

577− pingServer <- forkProcess node ping

577+ pingServer <- forkProcess node ping

578

579 runProcess node $ do

580 register "ping" pingServer

581 Just pid <- whereis "ping"

582− True <- return $ pingServer == pid

582+ True <- return $ pingServer == pid

583 us <- getSelfPid

584 nsend "ping" (Pong us)

585− Ping pid' <- expect

585+ Ping pid' <- expect

586 True <- return $ pingServer == pid'

587 return ()

588

589−testRemoteRegistry :: NT.Transport -> Assertion

589+testRemoteRegistry :: NT.Transport -> Assertion

590testRemoteRegistry transport = do

591 node1 <- newLocalNode transport initRemoteTable

592 node2 <- newLocalNode transport initRemoteTable

593

594− pingServer <- forkProcess node1 ping

594+ pingServer <- forkProcess node1 ping

595

596 runProcess node2 $ do

597 let nid1 = localNodeId node1

598 registerRemoteAsync nid1 "ping" pingServer

599− receiveWait [

599+ receiveWait [

600 matchIf (\(RegisterReply label' _) -> "ping" == label')

601 (\(RegisterReply _ _) -> return ()) ]

602

603 Just pid <- whereisRemote nid1 "ping"

604− True <- return $ pingServer == pid

604+ True <- return $ pingServer == pid

605 us <- getSelfPid

606 nsendRemote nid1 "ping" (Pong us)

607− Ping pid' <- expect

607+ Ping pid' <- expect

608 True <- return $ pingServer == pid'

609 return ()

610

611−testSpawnLocal :: NT.Transport -> Assertion

611+testSpawnLocal :: NT.Transport -> Assertion

612testSpawnLocal transport = do

613 node <- newLocalNode transport initRemoteTable

614

@@ -626,7 +626,7 @@ testSpawnLocal transport = do

626 send pid sport

627 expect

628

629−testReconnect :: NT.Transport -> TransportInternals -> Assertion

629+testReconnect :: NT.Transport -> TransportInternals -> Assertion

630testReconnect transport transportInternals = do

631 [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable

632 let nid1 = localNodeId node1

@@ -651,40 +651,40 @@ testReconnect transport transportInternals = do

651 send them "message 1" >> liftIO (threadDelay 100000)

652

653 -- Simulate network failure

654− liftIO $ do

654+ liftIO $ do

655 sock <- socketBetween transportInternals (nodeAddress nid1) (nodeAddress nid2)

656 sClose sock

657 threadDelay 10000

658

659 -- Should not arrive

660− send them "message 2"

660+ send them "message 2"

661

662 -- Should arrive

663 reconnect them

664− send them "message 3"

664+ send them "message 3"

665

666 liftIO $ takeMVar sendTestOk

667

668 {-

669 - Test that there *is* implicit reconnect on node controller messages

670 -}

671−

671+

672 us <- getSelfPid

673 registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous

674 receiveWait [

675 matchIf (\(RegisterReply label' _) -> "a" == label')

676 (\(RegisterReply _ _) -> return ()) ]

677

678− Just _ <- whereisRemote nid1 "a"

678+ Just _ <- whereisRemote nid1 "a"

679−

679+

680

681 -- Simulate network failure

682− liftIO $ do

682+ liftIO $ do

683 sock <- socketBetween transportInternals (nodeAddress nid1) (nodeAddress nid2)

684 sClose sock

685 threadDelay 10000

686

687− -- This will happen due to implicit reconnect

687+ -- This will happen due to implicit reconnect

688 registerRemoteAsync nid1 "b" us

689 receiveWait [

690 matchIf (\(RegisterReply label' _) -> "b" == label')

@@ -699,27 +699,27 @@ testReconnect transport transportInternals = do

699 -- Check

700 Nothing <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected

701 Just _ <- whereisRemote nid1 "b" -- this will suceed because the value is set after thereconnect

702− Just _ <- whereisRemote nid1 "c"

702+ Just _ <- whereisRemote nid1 "c"

703

704 liftIO $ putMVar registerTestOk ()

705

706 takeMVar registerTestOk

707

708−-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server

708+-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server

709-- in between

710−testMatchAny :: NT.Transport -> Assertion

710+testMatchAny :: NT.Transport -> Assertion

711testMatchAny transport = do

712− proxyAddr <- newEmptyMVar

712+ proxyAddr <- newEmptyMVar

713 clientDone <- newEmptyMVar

714

715 -- Math server

716 forkIO $ do

717− localNode <- newLocalNode transport initRemoteTable

717+ localNode <- newLocalNode transport initRemoteTable

718 mathServer <- forkProcess localNode math

719− proxyServer <- forkProcess localNode $ forever $ do

719+ proxyServer <- forkProcess localNode $ forever $ do

720 msg <- receiveWait [ matchAny return ]

721 forward msg mathServer

722− putMVar proxyAddr proxyServer

722+ putMVar proxyAddr proxyServer

723

724 -- Client

725 forkIO $ do

@@ -729,7 +729,7 @@ testMatchAny transport = do

729 runProcess localNode $ do

730 pid <- getSelfPid

731 send mathServer (Add pid 1 2)

732− 3 <- expect :: Process Double

732+ 3 <- expect :: Process Double

733 send mathServer (Divide pid 8 2)

734 4 <- expect :: Process Double

735 send mathServer (Divide pid 8 0)

@@ -739,11 +739,11 @@ testMatchAny transport = do

739 takeMVar clientDone

740

741-- Test 'receiveChanTimeout'

742−testReceiveChanTimeout :: NT.Transport -> Assertion

742+testReceiveChanTimeout :: NT.Transport -> Assertion

743testReceiveChanTimeout transport = do

744 done <- newEmptyMVar

745 sendPort <- newEmptyMVar

746−

746+

747 forkTry $ do

748 localNode <- newLocalNode transport initRemoteTable

749 runProcess localNode $ do

@@ -751,7 +751,7 @@ testReceiveChanTimeout transport = do

751 (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)

752 liftIO $ putMVar sendPort sp

753

754− -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second

754+ -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second

755 Nothing <- receiveChanTimeout 1000000 rp

756

757 -- Wait for a message with a delay again. Now a message arrives after 0.5 seconds

@@ -762,7 +762,7 @@ testReceiveChanTimeout transport = do

762

763 -- Again, but now there is a message available

764 liftIO $ threadDelay 1000000

765− Just False <- receiveChanTimeout 0 rp

765+ Just False <- receiveChanTimeout 0 rp

766

767 liftIO $ putMVar done ()

768

@@ -810,9 +810,9 @@ testReceiveChanFeatures transport = do

810 7 <- receiveChan rp2

811

812 -- Test Alternative instance

813−

813+

814 sendChan spInt 3

815− sendChan spBool True

815+ sendChan spBool True

816

817 let rp3 = (even <$> rpInt) <|> rpBool

818

@@ -820,14 +820,14 @@ testReceiveChanFeatures transport = do

820 True <- receiveChan rp3

821

822 -- Test Monad instance

823−

823+

824 sendChan spBool True

825 sendChan spBool False

826 sendChan spInt 5

827

828 let rp4 :: ReceivePort Int

829 rp4 = do b <- rpBool

830− if b

830+ if b

831 then rpInt

832 else return 7

833

@@ -839,13 +839,13 @@ testReceiveChanFeatures transport = do

839 takeMVar done

840

841tests :: (NT.Transport, TransportInternals) -> [Test]

842−tests (transport, transportInternals) = [

842+tests (transport, transportInternals) = [

843 testGroup "Basic features" [

844 testCase "Ping" (testPing transport)

845− , testCase "Math" (testMath transport)

845+ , testCase "Math" (testMath transport)

846 , testCase "Timeout" (testTimeout transport)

847 , testCase "Timeout0" (testTimeout0 transport)

848− , testCase "SendToTerminated" (testSendToTerminated transport)

848+ , testCase "SendToTerminated" (testSendToTerminated transport)

849 , testCase "TypedChannnels" (testTypedChannels transport)

850 , testCase "MergeChannels" (testMergeChannels transport)

851 , testCase "Terminate" (testTerminate transport)

@@ -860,7 +860,7 @@ tests (transport, transportInternals) = [

860 -- Monitoring processes

861 --

862 -- The "missing" combinations in the list below don't make much sense, as

863− -- we cannot guarantee that the monitor reply or link exception will not

863+ -- we cannot guarantee that the monitor reply or link exception will not

864 -- happen before the unmonitor or unlink

865 testCase "MonitorUnreachable" (testMonitorUnreachable transport True False)

866 , testCase "MonitorNormalTermination" (testMonitorNormalTermination transport True False)

distributed-process/tests/TestClosure.hs+66−66

@@ -6,7 +6,7 @@ import Data.Typeable (Typeable)

6import Control.Monad (join, replicateM, forever, replicateM_, void)

7import Control.Exception (IOException, throw)

8import Control.Concurrent (forkIO, threadDelay)

9−import Control.Concurrent.MVar

9+import Control.Concurrent.MVar

10 ( MVar

11 , newEmptyMVar

12 , readMVar

@@ -18,12 +18,12 @@ import Control.Concurrent.MVar

18import Control.Applicative ((<$>))

19import System.Random (randomIO)

20import Network.Transport (Transport)

21−import Network.Transport.TCP

21+import Network.Transport.TCP

22 ( createTransportExposeInternals

23 , defaultTCPParameters

24 , TransportInternals(socketBetween)

25 )

26−import Network.Socket (sClose)

26+import Network.Socket (sClose)

27import Control.Distributed.Process

28import Control.Distributed.Process.Closure

29import Control.Distributed.Process.Node

@@ -46,7 +46,7 @@ sdictInt = SerializableDict

47factorial :: Int -> Process Int

48factorial 0 = return 1

49−factorial n = (n *) <$> factorial (n - 1)

49+factorial n = (n *) <$> factorial (n - 1)

51addInt :: Int -> Int -> Int

52addInt x y = x + y

@@ -95,7 +95,7 @@ randomElement xs = do

95 ix <- randomIO

96 return (xs !! (ix `mod` length xs))

98−remotableDecl [

98+remotableDecl [

99 [d| dfib :: ([NodeId], SendPort Integer, Integer) -> Process () ;

100 dfib (_, reply, 0) = sendChan reply 0

101 dfib (_, reply, 1) = sendChan reply 1

@@ -117,33 +117,33 @@ staticQuintuple :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e)

117staticQuintuple = $(mkStatic 'quintuple)

118

119factorialClosure :: Int -> Closure (Process Int)

120−factorialClosure = $(mkClosure 'factorial)

120+factorialClosure = $(mkClosure 'factorial)

121

122addIntClosure :: Int -> Closure (Int -> Int)

123−addIntClosure = $(mkClosure 'addInt)

123+addIntClosure = $(mkClosure 'addInt)

124

125putIntClosure :: Int -> Closure (MVar Int -> IO ())

126−putIntClosure = $(mkClosure 'putInt)

126+putIntClosure = $(mkClosure 'putInt)

127

128sendPidClosure :: ProcessId -> Closure (Process ())

129−sendPidClosure = $(mkClosure 'sendPid)

129+sendPidClosure = $(mkClosure 'sendPid)

130

131sendFac :: Int -> ProcessId -> Closure (Process ())

132−sendFac n pid = factorialClosure n `bindCP` cpSend $(mkStatic 'sdictInt) pid

132+sendFac n pid = factorialClosure n `bindCP` cpSend $(mkStatic 'sdictInt) pid

133

134factorialOf :: Closure (Int -> Process Int)

135factorialOf = staticClosure $(mkStatic 'factorial)

136

137factorial' :: Int -> Closure (Process Int)

138−factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf

138+factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf

139

140waitClosure :: Int -> Closure (Process ())

141−waitClosure = $(mkClosure 'wait)

141+waitClosure = $(mkClosure 'wait)

142

143simulateNetworkFailure :: TransportInternals -> NodeId -> NodeId -> Process ()

144simulateNetworkFailure transportInternals fr to = liftIO $ do

145 threadDelay 10000

146− sock <- socketBetween transportInternals (nodeAddress fr) (nodeAddress to)

146+ sock <- socketBetween transportInternals (nodeAddress fr) (nodeAddress to)

147 sClose sock

148 threadDelay 10000

149

@@ -160,87 +160,87 @@ testUnclosure transport rtable = do

160 liftIO $ putMVar done ()

161 takeMVar done

162

163−testBind :: Transport -> RemoteTable -> Assertion

163+testBind :: Transport -> RemoteTable -> Assertion

164testBind transport rtable = do

165 node <- newLocalNode transport rtable

166 done <- newEmptyMVar

167 runProcess node $ do

168 us <- getSelfPid

169− join . unClosure $ sendFac 6 us

169+ join . unClosure $ sendFac 6 us

170− (720 :: Int) <- expect

170+ (720 :: Int) <- expect

171 liftIO $ putMVar done ()

172 takeMVar done

173

174−testSendPureClosure :: Transport -> RemoteTable -> Assertion

174+testSendPureClosure :: Transport -> RemoteTable -> Assertion

175testSendPureClosure transport rtable = do

176 serverAddr <- newEmptyMVar

177 serverDone <- newEmptyMVar

178

179− forkIO $ do

179+ forkIO $ do

180− node <- newLocalNode transport rtable

180+ node <- newLocalNode transport rtable

181 addr <- forkProcess node $ do

182 cl <- expect

183 fn <- unClosure cl :: Process (Int -> Int)

184 13 <- return $ fn 6

185− liftIO $ putMVar serverDone ()

185+ liftIO $ putMVar serverDone ()

186− putMVar serverAddr addr

186+ putMVar serverAddr addr

187

188 forkIO $ do

189− node <- newLocalNode transport rtable

189+ node <- newLocalNode transport rtable

190 theirAddr <- readMVar serverAddr

191 runProcess node $ send theirAddr (addIntClosure 7)

192

193 takeMVar serverDone

194

195−testSendIOClosure :: Transport -> RemoteTable -> Assertion

195+testSendIOClosure :: Transport -> RemoteTable -> Assertion

196testSendIOClosure transport rtable = do

197 serverAddr <- newEmptyMVar

198 serverDone <- newEmptyMVar

199

200− forkIO $ do

200+ forkIO $ do

201− node <- newLocalNode transport rtable

201+ node <- newLocalNode transport rtable

202 addr <- forkProcess node $ do

203 cl <- expect

204 io <- unClosure cl :: Process (MVar Int -> IO ())

205− liftIO $ do

205+ liftIO $ do

206 someMVar <- newEmptyMVar

207− io someMVar

207+ io someMVar

208 5 <- readMVar someMVar

209− putMVar serverDone ()

209+ putMVar serverDone ()

210− putMVar serverAddr addr

210+ putMVar serverAddr addr

211

212 forkIO $ do

213− node <- newLocalNode transport rtable

213+ node <- newLocalNode transport rtable

214 theirAddr <- readMVar serverAddr

215− runProcess node $ send theirAddr (putIntClosure 5)

215+ runProcess node $ send theirAddr (putIntClosure 5)

216

217 takeMVar serverDone

218

219−testSendProcClosure :: Transport -> RemoteTable -> Assertion

219+testSendProcClosure :: Transport -> RemoteTable -> Assertion

220testSendProcClosure transport rtable = do

221 serverAddr <- newEmptyMVar

222 clientDone <- newEmptyMVar

223

224− forkIO $ do

224+ forkIO $ do

225− node <- newLocalNode transport rtable

225+ node <- newLocalNode transport rtable

226 addr <- forkProcess node $ do

227 cl <- expect

228 pr <- unClosure cl :: Process (Int -> Process ())

229 pr 5

230− putMVar serverAddr addr

230+ putMVar serverAddr addr

231

232 forkIO $ do

233− node <- newLocalNode transport rtable

233+ node <- newLocalNode transport rtable

234 theirAddr <- readMVar serverAddr

235 runProcess node $ do

236 pid <- getSelfPid

237− send theirAddr (cpSend $(mkStatic 'sdictInt) pid)

237+ send theirAddr (cpSend $(mkStatic 'sdictInt) pid)

238 5 <- expect :: Process Int

239 liftIO $ putMVar clientDone ()

240

241 takeMVar clientDone

242

243−testSpawn :: Transport -> RemoteTable -> Assertion

243+testSpawn :: Transport -> RemoteTable -> Assertion

244testSpawn transport rtable = do

245 serverNodeAddr <- newEmptyMVar

246 clientDone <- newEmptyMVar

@@ -261,7 +261,7 @@ testSpawn transport rtable = do

261

262 takeMVar clientDone

263

264−testCall :: Transport -> RemoteTable -> Assertion

264+testCall :: Transport -> RemoteTable -> Assertion

265testCall transport rtable = do

266 serverNodeAddr <- newEmptyMVar

267 clientDone <- newEmptyMVar

@@ -279,7 +279,7 @@ testCall transport rtable = do

279

280 takeMVar clientDone

281

282−testCallBind :: Transport -> RemoteTable -> Assertion

282+testCallBind :: Transport -> RemoteTable -> Assertion

283testCallBind transport rtable = do

284 serverNodeAddr <- newEmptyMVar

285 clientDone <- newEmptyMVar

@@ -297,7 +297,7 @@ testCallBind transport rtable = do

297

298 takeMVar clientDone

299

300−testSeq :: Transport -> RemoteTable -> Assertion

300+testSeq :: Transport -> RemoteTable -> Assertion

301testSeq transport rtable = do

302 node <- newLocalNode transport rtable

303 done <- newEmptyMVar

@@ -315,7 +315,7 @@ testSeq transport rtable = do

315-- child. The supervisor then throws an exception, the child dies because it

316-- was linked to the supervisor, and the third process notices that the child

317-- dies.

318−testSpawnSupervised :: Transport -> RemoteTable -> Assertion

318+testSpawnSupervised :: Transport -> RemoteTable -> Assertion

319testSpawnSupervised transport rtable = do

320 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

321 [superPid, childPid] <- replicateM 2 $ newEmptyMVar

@@ -324,7 +324,7 @@ testSpawnSupervised transport rtable = do

324 forkProcess node1 $ do

325 us <- getSelfPid

326 liftIO $ putMVar superPid us

327− (child, _ref) <- spawnSupervised (localNodeId node2) (waitClosure 1000000)

327+ (child, _ref) <- spawnSupervised (localNodeId node2) (waitClosure 1000000)

328 liftIO $ do

329 putMVar childPid child

330 threadDelay 500000 -- Give the child a chance to link to us

@@ -334,8 +334,8 @@ testSpawnSupervised transport rtable = do

334 [super, child] <- liftIO $ mapM readMVar [superPid, childPid]

335 ref <- monitor child

336 ProcessMonitorNotification ref' pid' (DiedException e) <- expect

337− True <- return $ ref' == ref

337+ True <- return $ ref' == ref

338− && pid' == child

338+ && pid' == child

339 && e == show (ProcessLinkException super (DiedException (show supervisorDeath)))

340 liftIO $ putMVar thirdProcessDone ()

341

@@ -344,19 +344,19 @@ testSpawnSupervised transport rtable = do

344 supervisorDeath :: IOException

345 supervisorDeath = userError "Supervisor died"

346

347−testSpawnInvalid :: Transport -> RemoteTable -> Assertion

347+testSpawnInvalid :: Transport -> RemoteTable -> Assertion

348testSpawnInvalid transport rtable = do

349 node <- newLocalNode transport rtable

350 done <- newEmptyMVar

351 forkProcess node $ do

352 (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)

353− ProcessMonitorNotification ref' pid' _reason <- expect

353+ ProcessMonitorNotification ref' pid' _reason <- expect

354 -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure

355− True <- return $ ref' == ref && pid == pid'

355+ True <- return $ ref' == ref && pid == pid'

356 liftIO $ putMVar done ()

357 takeMVar done

358

359−testClosureExpect :: Transport -> RemoteTable -> Assertion

359+testClosureExpect :: Transport -> RemoteTable -> Assertion

360testClosureExpect transport rtable = do

361 node <- newLocalNode transport rtable

362 done <- newEmptyMVar

@@ -369,15 +369,15 @@ testClosureExpect transport rtable = do

369 liftIO $ putMVar done ()

370 takeMVar done

371

372−testSpawnChannel :: Transport -> RemoteTable -> Assertion

372+testSpawnChannel :: Transport -> RemoteTable -> Assertion

373testSpawnChannel transport rtable = do

374 done <- newEmptyMVar

375 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

376

377 forkProcess node1 $ do

378− pingServer <- spawnChannel

378+ pingServer <- spawnChannel

379 (sdictSendPort sdictUnit)

380− (localNodeId node2)

380+ (localNodeId node2)

381 ($(mkClosure 'typedPingServer) ())

382 (sendReply, receiveReply) <- newChan

383 sendChan pingServer sendReply

@@ -386,7 +386,7 @@ testSpawnChannel transport rtable = do

386

387 takeMVar done

388

389−testTDict :: Transport -> RemoteTable -> Assertion

389+testTDict :: Transport -> RemoteTable -> Assertion

390testTDict transport rtable = do

391 done <- newEmptyMVar

392 [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

@@ -395,7 +395,7 @@ testTDict transport rtable = do

395 liftIO $ putMVar done ()

396 takeMVar done

397

398−testFib :: Transport -> RemoteTable -> Assertion

398+testFib :: Transport -> RemoteTable -> Assertion

399testFib transport rtable = do

400 nodes <- replicateM 4 $ newLocalNode transport rtable

401 done <- newEmptyMVar

@@ -408,28 +408,28 @@ testFib transport rtable = do

408

409 takeMVar done

410

411−testSpawnReconnect :: Transport -> RemoteTable -> TransportInternals -> Assertion

411+testSpawnReconnect :: Transport -> RemoteTable -> TransportInternals -> Assertion

412testSpawnReconnect transport rtable transportInternals = do

413− [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

413+ [node1, node2] <- replicateM 2 $ newLocalNode transport rtable

414 let nid1 = localNodeId node1

415 nid2 = localNodeId node2

416− done <- newEmptyMVar

416+ done <- newEmptyMVar

417− iv <- newMVar (0 :: Int)

417+ iv <- newMVar (0 :: Int)

418

419 incr <- forkProcess node1 $ forever $ do

420 () <- expect

421 liftIO $ modifyMVar_ iv (return . (+ 1))

422

423 forkProcess node2 $ do

424− _pid1 <- spawn nid1 ($(mkClosure 'signal) incr)

424+ _pid1 <- spawn nid1 ($(mkClosure 'signal) incr)

425 simulateNetworkFailure transportInternals nid2 nid1

426− _pid2 <- spawn nid1 ($(mkClosure 'signal) incr)

426+ _pid2 <- spawn nid1 ($(mkClosure 'signal) incr)

427− _pid3 <- spawn nid1 ($(mkClosure 'signal) incr)

427+ _pid3 <- spawn nid1 ($(mkClosure 'signal) incr)

428

429 liftIO $ threadDelay 100000

430

431 count <- liftIO $ takeMVar iv

432− True <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'

432+ True <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'

433

434 liftIO $ putMVar done ()

435

@@ -437,10 +437,10 @@ testSpawnReconnect transport rtable transportInternals = do

437

438-- | 'spawn' used to ave a race condition which would be triggered if the

439-- spawning process terminates immediately after spawning

440−testSpawnTerminate :: Transport -> RemoteTable -> Assertion

440+testSpawnTerminate :: Transport -> RemoteTable -> Assertion

441testSpawnTerminate transport rtable = do

442− slave <- newLocalNode transport rtable

442+ slave <- newLocalNode transport rtable

443− master <- newLocalNode transport rtable

443+ master <- newLocalNode transport rtable

444 masterDone <- newEmptyMVar

445

446 runProcess master $ do

@@ -476,5 +476,5 @@ tests (transport, transportInternals) rtable = [

476main :: IO ()

477main = do

478 Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters

479− let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable

479+ let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable

480 defaultMain (tests transport rtable)

distributed-static/src/Control/Distributed/Static.hs+64−64

@@ -1,9 +1,9 @@

1−-- | /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011)

1+-- | /Towards Haskell in the Cloud/ (Epstein et al, Haskell Symposium 2011)

2-- introduces the concept of /static/ values: values that are known at compile

3−-- time. In a distributed setting where all nodes are running the same

3+-- time. In a distributed setting where all nodes are running the same

4-- executable, static values can be serialized simply by transmitting a code

5-- pointer to the value. This however requires special compiler support, which

6−-- is not yet available in ghc. We can mimick the behaviour by keeping an

6+-- is not yet available in ghc. We can mimick the behaviour by keeping an

7-- explicit mapping ('RemoteTable') from labels to values (and making sure that

8-- all distributed nodes are using the same 'RemoteTable'). In this module

9-- we implement this mimickry and various extensions.

@@ -13,13 +13,13 @@

13-- The paper stipulates that 'Static' values should have a free 'Binary'

14-- instance:

15--

16−-- > instance Binary (Static a)

16+-- > instance Binary (Static a)

17--

18-- This however is not (runtime) type safe: for instance, what would be the

19-- behaviour of

20--

21−-- > f :: Static Int -> Static Bool

21+-- > f :: Static Int -> Static Bool

22−-- > f = decode . encode

22+-- > f = decode . encode

23--

24-- For this reason we work only with 'Typeable' terms in this module, and

25-- implement runtime checks

@@ -34,7 +34,7 @@

34--

35-- Since the runtime mapping ('RemoteTable') contains values of different types,

36-- it maps labels ('String's) to 'Data.Rank1Dynamic.Dynamic' values. Again, we

37−-- use the implementation from "Data.Rank1Dynamic" so that we can store

37+-- use the implementation from "Data.Rank1Dynamic" so that we can store

38-- polymorphic dynamic values.

39--

40-- [Compositionality]

@@ -43,18 +43,18 @@

43-- way to combine two static values and get a static value out of it. This

44-- makes sense when interpreting static strictly as /known at compile time/,

45-- but it severely limits expressiveness. However, the main motivation for

46−-- 'static' is not that they are known at compile time but rather that

46+-- 'static' is not that they are known at compile time but rather that

47-- /they provide a free/ 'Binary' /instance/. We therefore provide two basic

48-- constructors for 'Static' values:

49--

50-- > staticLabel :: String -> Static a

51-- > staticApply :: Static (a -> b) -> Static a -> Static b

52--

53−-- The first constructor refers to a label in a 'RemoteTable'. The second

53+-- The first constructor refers to a label in a 'RemoteTable'. The second

54-- allows to apply a static function to a static argument, and makes 'Static'

55-- compositional: once we have 'staticApply' we can implement numerous derived

56-- combinators on 'Static' values (we define a few in this module; see

57−-- 'staticCompose', 'staticSplit', and 'staticConst').

57+-- 'staticCompose', 'staticSplit', and 'staticConst').

58--

59-- [Closures]

60--

@@ -67,7 +67,7 @@

67--

68-- See /Towards Haskell in the Cloud/ for the rationale behind representing

69-- the function closure environment in serialized ('ByteString') form. Any

70−-- static value can trivially be turned into a 'Closure' ('staticClosure').

70+-- static value can trivially be turned into a 'Closure' ('staticClosure').

71-- Moreover, since 'Static' is now compositional, we can also define derived

72-- operators on 'Closure' values ('closureApplyStatic', 'closureApply',

73-- 'closureCompose', 'closureSplit').

@@ -76,9 +76,9 @@

76--

77-- Suppose we are working in the context of some distributed environment, with

78-- a monadic type 'Process' representing processes, 'NodeId' representing node

79−-- addresses and 'ProcessId' representing process addresses. Suppose further

79+-- addresses and 'ProcessId' representing process addresses. Suppose further

80−-- that we have a primitive

80+-- that we have a primitive

81−--

81+--

82-- > sendInt :: ProcessId -> Int -> Process ()

83--

84-- We might want to define

@@ -106,7 +106,7 @@

106-- > sendIntClosure :: ProcessId -> Closure (Int -> Process ())

107-- > sendIntClosure pid = closure decoder (encode pid)

108-- > where

109−-- > decoder :: Static (ByteString -> Int -> Process ())

109+-- > decoder :: Static (ByteString -> Int -> Process ())

110-- > decoder = sendIntStatic `staticCompose` decodeProcessIdStatic

111--

112-- [Polymorphic example]

@@ -118,8 +118,8 @@

118-- which turns a process that computes an integer into a process that computes

119-- the integer and then sends it someplace else.

120--

121−-- We can define

121+-- We can define

122−--

122+--

123-- > bindStatic :: (Typeable a, Typeable b) => Static (Process a -> (a -> Process b) -> Process b)

124-- > bindStatic = staticLabel "$bind"

125--

@@ -132,7 +132,7 @@

132--

133-- (Note that we are using the special 'Data.Rank1Typeable.ANY1' and

134-- 'Data.Rank1Typeable.ANY2' types from "Data.Rank1Typeable" to represent this

135−-- polymorphic value.) Once we have a static bind we can define

135+-- polymorphic value.) Once we have a static bind we can define

136--

137-- > sendIntResult :: ProcessId -> Closure (Process Int) -> Closure (Process ())

138-- > sendIntResult pid cl = bindStatic `closureApplyStatic` cl `closureApply` sendIntClosure pid

@@ -157,7 +157,7 @@

157-- > sendDict BinaryDict = send

158--

159-- Now 'sendDict' is a normal polymorphic value:

160−--

160+--

161-- > sendDictStatic :: Static (BinaryDict a -> ProcessId -> a -> Process ())

162-- > sendDictStatic = staticLabel "$sendDict"

163-- >

@@ -165,20 +165,20 @@

165-- > rtable = ...

166-- > . registerStatic "$sendDict" (sendDict :: BinaryDict ANY -> ProcessId -> ANY -> Process ())

167-- > $ initRemoteTable

168−--

168+--

169-- so that we can define

170--

171-- > sendClosure :: Static (BinaryDict a) -> Process a -> Closure (a -> Process ())

172-- > sendClosure dict pid = closure decoder (encode pid)

173-- > where

174-- > decoder :: Static (ByteString -> a -> Process ())

175−-- > decoder = (sendDictStatic `staticApply` dict) `staticCompose` decodeProcessIdStatic

175+-- > decoder = (sendDictStatic `staticApply` dict) `staticCompose` decodeProcessIdStatic

176--

177-- [Word of Caution]

178--

179-- You should not /define/ functions on 'ANY' and co. For example, the following

180-- definition of 'rtable' is incorrect:

181−--

181+--

182-- > rtable :: RemoteTable

183-- > rtable = registerStatic "$sdictSendPort" sdictSendPort

184-- > $ initRemoteTable

@@ -186,7 +186,7 @@

186-- > sdictSendPort :: SerializableDict ANY -> SerializableDict (SendPort ANY)

187-- > sdictSendPort SerializableDict = SerializableDict

188--

189−-- This definition of 'sdictSendPort' ignores its argument completely, and

189+-- This definition of 'sdictSendPort' ignores its argument completely, and

190-- constructs a 'SerializableDict' for the /monomorphic/ type @SendPort ANY@,

191-- which isn't what you want. Instead, you should do

192--

@@ -196,8 +196,8 @@

196-- > where

197-- > sdictSendPort :: forall a. SerializableDict a -> SerializableDict (SendPort a)

198-- > sdictSendPort SerializableDict = SerializableDict

199−module Control.Distributed.Static

199+module Control.Distributed.Static

200− ( -- * Static values

200+ ( -- * Static values

201 Static

202 , staticLabel

203 , staticApply

@@ -215,15 +215,15 @@ module Control.Distributed.Static

215 , closureApply

216 , closureCompose

217 , closureSplit

218− -- * Resolution

218+ -- * Resolution

219 , RemoteTable

220 , initRemoteTable

221 , registerStatic

222− , unstatic

222+ , unstatic

223− , unclosure

223+ , unclosure

224 ) where

225

226−import Data.Binary

226+import Data.Binary

227 ( Binary(get, put)

228 , Put

229 , Get

@@ -238,7 +238,7 @@ import qualified Data.Map as Map (lookup, empty, insert)

238import Control.Applicative ((<$>), (<*>))

239import Control.Arrow as Arrow ((***), app)

240import Data.Rank1Dynamic (Dynamic, toDynamic, fromDynamic, dynApply)

241−import Data.Rank1Typeable

241+import Data.Rank1Typeable

242 ( Typeable

243 , typeOf

244 , ANY1

@@ -258,7 +258,7 @@ data StaticLabel =

258 deriving (Typeable, Show)

259

260-- | A static value. Static is opaque; see 'staticLabel' and 'staticApply'.

261−newtype Static a = Static StaticLabel

261+newtype Static a = Static StaticLabel

262 deriving (Typeable, Show)

263

264instance Typeable a => Binary (Static a) where

@@ -272,9 +272,9 @@ instance Typeable a => Binary (Static a) where

272

273-- We don't want StaticLabel to be its own Binary instance

274putStaticLabel :: StaticLabel -> Put

275−putStaticLabel (StaticLabel string) =

275+putStaticLabel (StaticLabel string) =

276− putWord8 0 >> put string

276+ putWord8 0 >> put string

277−putStaticLabel (StaticApply label1 label2) =

277+putStaticLabel (StaticApply label1 label2) =

278 putWord8 1 >> putStaticLabel label1 >> putStaticLabel label2

279

280getStaticLabel :: Get StaticLabel

@@ -283,14 +283,14 @@ getStaticLabel = do

283 case header of

284 0 -> StaticLabel <$> get

285 1 -> StaticApply <$> getStaticLabel <*> getStaticLabel

286− _ -> fail "StaticLabel.get: invalid"

286+ _ -> fail "StaticLabel.get: invalid"

287−

287+

288-- | Create a primitive static value.

289−--

289+--

290-- It is the responsibility of the client code to make sure the corresponding

291-- entry in the 'RemoteTable' has the appropriate type.

292staticLabel :: String -> Static a

293−staticLabel = Static . StaticLabel

293+staticLabel = Static . StaticLabel

294

295-- | Apply two static values

296staticApply :: Static (a -> b) -> Static a -> Static b

@@ -300,12 +300,12 @@ staticApply (Static f) (Static x) = Static (StaticApply f x)

300-- Eliminating static values --

301--------------------------------------------------------------------------------

302

303−-- | Runtime dictionary for 'unstatic' lookups

303+-- | Runtime dictionary for 'unstatic' lookups

304newtype RemoteTable = RemoteTable (Map String Dynamic)

305

306-- | Initial remote table

307initRemoteTable :: RemoteTable

308−initRemoteTable =

308+initRemoteTable =

309 registerStatic "$compose" (toDynamic ((.) :: (ANY2 -> ANY3) -> (ANY1 -> ANY2) -> ANY1 -> ANY3))

310 . registerStatic "$const" (toDynamic (const :: ANY1 -> ANY2 -> ANY1))

311 . registerStatic "$split" (toDynamic ((***) :: (ANY1 -> ANY3) -> (ANY2 -> ANY4) -> (ANY1, ANY2) -> (ANY3, ANY4)))

@@ -321,23 +321,23 @@ registerStatic label dyn (RemoteTable rtable)

321

322-- Pseudo-type: RemoteTable -> Static a -> a

323resolveStaticLabel :: RemoteTable -> StaticLabel -> Either String Dynamic

324−resolveStaticLabel (RemoteTable rtable) (StaticLabel label) =

324+resolveStaticLabel (RemoteTable rtable) (StaticLabel label) =

325 case Map.lookup label rtable of

326 Nothing -> Left $ "Invalid static label '" ++ label ++ "'"

327 Just d -> Right d

328resolveStaticLabel rtable (StaticApply label1 label2) = do

329− f <- resolveStaticLabel rtable label1

329+ f <- resolveStaticLabel rtable label1

330 x <- resolveStaticLabel rtable label2

331 f `dynApply` x

332

333-- | Resolve a static value

334unstatic :: Typeable a => RemoteTable -> Static a -> Either String a

335−unstatic rtable (Static static) = do

335+unstatic rtable (Static static) = do

336− dyn <- resolveStaticLabel rtable static

336+ dyn <- resolveStaticLabel rtable static

337 fromDynamic dyn

338

339--------------------------------------------------------------------------------

340−-- Closures --

340+-- Closures --

341--------------------------------------------------------------------------------

342

343-- | A closure is a static value and an encoded environment

@@ -346,16 +346,16 @@ data Closure a = Closure (Static (ByteString -> a)) ByteString

346

347instance Typeable a => Binary (Closure a) where

348 put (Closure static env) = put static >> put env

349− get = Closure <$> get <*> get

349+ get = Closure <$> get <*> get

350

351closure :: Static (ByteString -> a) -- ^ Decoder

352 -> ByteString -- ^ Encoded closure environment

353 -> Closure a

354−closure = Closure

354+closure = Closure

355

356-- | Resolve a closure

357unclosure :: Typeable a => RemoteTable -> Closure a -> Either String a

358−unclosure rtable (Closure static env) = do

358+unclosure rtable (Closure static env) = do

359 f <- unstatic rtable static

360 return (f env)

361

@@ -368,18 +368,18 @@ staticClosure static = closure (staticConst static) empty

368--------------------------------------------------------------------------------

369

370-- | Static version of ('Prelude..')

371−composeStatic :: (Typeable a, Typeable b, Typeable c)

371+composeStatic :: (Typeable a, Typeable b, Typeable c)

372 => Static ((b -> c) -> (a -> b) -> a -> c)

373−composeStatic = staticLabel "$compose"

373+composeStatic = staticLabel "$compose"

374

375-- | Static version of 'const'

376constStatic :: (Typeable a, Typeable b)

377 => Static (a -> b -> a)

378−constStatic = staticLabel "$const"

378+constStatic = staticLabel "$const"

379

380-- | Static version of ('Arrow.***')

381−splitStatic :: (Typeable a, Typeable a', Typeable b, Typeable b')

381+splitStatic :: (Typeable a, Typeable a', Typeable b, Typeable b')

382− => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b'))

382+ => Static ((a -> b) -> (a' -> b') -> (a, a') -> (b, b'))

383splitStatic = staticLabel "$split"

384

385-- | Static version of 'Arrow.app'

@@ -390,31 +390,31 @@ appStatic = staticLabel "$app"

390-- | Static version of 'flip'

391flipStatic :: (Typeable a, Typeable b, Typeable c)

392 => Static ((a -> b -> c) -> b -> a -> c)

393−flipStatic = staticLabel "$flip"

393+flipStatic = staticLabel "$flip"

394

395--------------------------------------------------------------------------------

396-- Combinators on static values --

397--------------------------------------------------------------------------------

398

399−-- | Static version of ('Prelude..')

399+-- | Static version of ('Prelude..')

400staticCompose :: (Typeable a, Typeable b, Typeable c)

401 => Static (b -> c) -> Static (a -> b) -> Static (a -> c)

402staticCompose g f = composeStatic `staticApply` g `staticApply` f

403

404-- | Static version of ('Control.Arrow.***')

405−staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')

405+staticSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')

406 => Static (a -> b) -> Static (a' -> b') -> Static ((a, a') -> (b, b'))

407staticSplit f g = splitStatic `staticApply` f `staticApply` g

408

409-- | Static version of 'Prelude.const'

410staticConst :: (Typeable a, Typeable b)

411 => Static a -> Static (b -> a)

412−staticConst x = constStatic `staticApply` x

412+staticConst x = constStatic `staticApply` x

413

414-- | Static version of 'Prelude.flip'

415staticFlip :: (Typeable a, Typeable b, Typeable c)

416 => Static (a -> b -> c) -> Static (b -> a -> c)

417−staticFlip f = flipStatic `staticApply` f

417+staticFlip f = flipStatic `staticApply` f

418

419--------------------------------------------------------------------------------

420-- Combinators on Closures --

@@ -423,7 +423,7 @@ staticFlip f = flipStatic `staticApply` f

423-- | Apply a static function to a closure

424closureApplyStatic :: (Typeable a, Typeable b)

425 => Static (a -> b) -> Closure a -> Closure b

426−closureApplyStatic f (Closure decoder env) =

426+closureApplyStatic f (Closure decoder env) =

427 closure (f `staticCompose` decoder) env

428

429decodeEnvPairStatic :: Static (ByteString -> (ByteString, ByteString))

@@ -432,15 +432,15 @@ decodeEnvPairStatic = staticLabel "$decodeEnvPair"

432-- | Closure application

433closureApply :: forall a b. (Typeable a, Typeable b)

434 => Closure (a -> b) -> Closure a -> Closure b

435−closureApply (Closure fdec fenv) (Closure xdec xenv) =

435+closureApply (Closure fdec fenv) (Closure xdec xenv) =

436 closure decoder (encode (fenv, xenv))

437 where

438 decoder :: Static (ByteString -> b)

439− decoder = appStatic

439+ decoder = appStatic

440 `staticCompose`

441 (fdec `staticSplit` xdec)

442 `staticCompose`

443− decodeEnvPairStatic

443+ decodeEnvPairStatic

444

445-- | Closure composition

446closureCompose :: (Typeable a, Typeable b, Typeable c)

@@ -448,6 +448,6 @@ closureCompose :: (Typeable a, Typeable b, Typeable c)

448closureCompose g f = composeStatic `closureApplyStatic` g `closureApply` f

449

450-- | Closure version of ('Arrow.***')

451−closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')

451+closureSplit :: (Typeable a, Typeable a', Typeable b, Typeable b')

452 => Closure (a -> b) -> Closure (a' -> b') -> Closure ((a, a') -> (b, b'))

453−closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g

453+closureSplit f g = splitStatic `closureApplyStatic` f `closureApply` g

doc/tutorial/tutorial-client.hs+3−3

@@ -1,4 +1,4 @@

1−import Network.Transport

1+import Network.Transport

2import Network.Transport.TCP (createTransport, defaultTCPParameters)

3import System.Environment

4import Control.Monad

@@ -13,12 +13,12 @@ main = do

13 let addr = EndPointAddress (pack serverAddr)

14-- Right conn <- connect endpoint addr ReliableOrdered defaultConnectHints

15 x <- connect endpoint addr ReliableOrdered defaultConnectHints

16− let conn = case x of

16+ let conn = case x of

17 Right conn -> conn

18 Left err -> error$ "Error connecting: "++show err

19 send conn [pack "Hello world"]

20 close conn

22− replicateM_ 3 $ receive endpoint >>= print

22+ replicateM_ 3 $ receive endpoint >>= print

24 closeTransport transport

doc/tutorial/tutorial-server.hs+10−10

@@ -1,7 +1,7 @@

1import Network.Transport

2import Network.Transport.TCP (createTransport, defaultTCPParameters)

3import Control.Concurrent

4−import Data.Map

4+import Data.Map

5import Control.Exception

6import System.Environment

@@ -9,7 +9,7 @@ import System.Environment

9echoServer :: EndPoint -> MVar () -> IO ()

10echoServer endpoint serverDone = go empty

11 where

12− go :: Map ConnectionId (MVar Connection) -> IO ()

12+ go :: Map ConnectionId (MVar Connection) -> IO ()

13 go cs = do

14 event <- receive endpoint

15 case event of

@@ -18,20 +18,20 @@ echoServer endpoint serverDone = go empty

18 connMVar <- newEmptyMVar

19 forkIO $ do

20 Right conn <- connect endpoint addr rel defaultConnectHints

21− putMVar connMVar conn

21+ putMVar connMVar conn

22− go (insert cid connMVar cs)

22+ go (insert cid connMVar cs)

23 Received cid payload -> do

24 forkIO $ do

25 conn <- readMVar (cs ! cid)

26− send conn payload

26+ send conn payload

27 return ()

28 go cs

29− ConnectionClosed cid -> do

29+ ConnectionClosed cid -> do

30 putStrLn$ " Closed connection: ID "++show cid

31 forkIO $ do

32 conn <- readMVar (cs ! cid)

33− close conn

33+ close conn

34− go (delete cid cs)

34+ go (delete cid cs)

35 EndPointClosed -> do

36 putStrLn "Echo server exiting"

37 putMVar serverDone ()

@@ -39,7 +39,7 @@ echoServer endpoint serverDone = go empty

39onCtrlC :: IO a -> IO () -> IO a

40p `onCtrlC` q = catchJust isUserInterrupt p (const $ q >> p `onCtrlC` q)

41 where

42− isUserInterrupt :: AsyncException -> Maybe ()

42+ isUserInterrupt :: AsyncException -> Maybe ()

43 isUserInterrupt UserInterrupt = Just ()

44 isUserInterrupt _ = Nothing

@@ -49,6 +49,6 @@ main = do

49 serverDone <- newEmptyMVar

50 Right transport <- createTransport host port defaultTCPParameters

51 Right endpoint <- newEndPoint transport

52− forkIO $ echoServer endpoint serverDone

52+ forkIO $ echoServer endpoint serverDone

53 putStrLn $ "Echo server started at " ++ show (address endpoint)

54 readMVar serverDone `onCtrlC` closeTransport transport

network-transport-composed/src/Network/Transport/Composed.hs+43−43

@@ -8,38 +8,38 @@

8--

9-- When the address of combined endpoint C1 is sent to combined endpoint C2,

10-- and C2 attempts to make a connection to C1, it needs to choice an underlying

11−-- endpoint to make the connection. The choice is made by a parameter

11+-- endpoint to make the connection. The choice is made by a parameter

12-- 'resolveAddress' of the composed transport.

13--

14-- When C2 connects to C1 then it is assumed that whatever transport C2 uses

15-- to connect to C1, this is the same transport that C1 needs to use to connect

16−-- back to C2.

16+-- back to C2.

17--

18-- TODO: at the moment the address reported by a ConnectionOpened might differ

19-- from the address reported by the remote endpoint itself. This might cause

20-- difficulties?

21−module Network.Transport.Composed

21+module Network.Transport.Composed

22 ( ComposedTransport(..)

23 , createTransport

24 ) where

26−import qualified Data.ByteString as BSS

26+import qualified Data.ByteString as BSS

27 ( concat

28 , length

29 , splitAt

30 , singleton

31 , uncons

32 )

33−import Control.Monad (void)

33+import Control.Monad (void)

34import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)

35import Control.Concurrent (forkIO)

36−import Network.Transport

36+import Network.Transport

37 ( Transport(..)

38 , EndPointAddress(EndPointAddress)

39 , TransportError(TransportError)

40 , NewEndPointErrorCode

41 , EndPoint(..)

42− , NewMulticastGroupErrorCode(NewMulticastGroupUnsupported)

42+ , NewMulticastGroupErrorCode(NewMulticastGroupUnsupported)

43 , ResolveMulticastGroupErrorCode(ResolveMulticastGroupUnsupported)

44 , Event(EndPointClosed, ConnectionOpened, ErrorEvent)

45 , EventErrorCode(EventConnectionLost)

@@ -57,25 +57,25 @@ data ComposedTransport = ComposedTransport {

57 , transportB :: Transport

58 -- | Pick a suitable transport for an address

59 , resolveAddress :: (EndPoint, EndPoint)

60− -> (EndPointAddress, EndPointAddress)

60+ -> (EndPointAddress, EndPointAddress)

61− -> IO (EndPoint, EndPointAddress)

61+ -> IO (EndPoint, EndPointAddress)

62 }

64−data ComposedAddress =

64+data ComposedAddress =

65 LeftAddress EndPointAddress

66 | RightAddress EndPointAddress

67 | EitherAddress EndPointAddress EndPointAddress

69serializeComposedAddress :: ComposedAddress -> EndPointAddress

70−serializeComposedAddress (LeftAddress (EndPointAddress addr)) =

70+serializeComposedAddress (LeftAddress (EndPointAddress addr)) =

71 EndPointAddress $ BSS.concat [BSS.singleton 0, addr]

72−serializeComposedAddress (RightAddress (EndPointAddress addr)) =

72+serializeComposedAddress (RightAddress (EndPointAddress addr)) =

73 EndPointAddress $ BSS.concat [BSS.singleton 1, addr]

74serializeComposedAddress (EitherAddress (EndPointAddress addr1) (EndPointAddress addr2)) =

75 EndPointAddress $ BSS.concat [BSS.singleton 2, encodeInt32 (BSS.length addr1), addr1, addr2]

77deserializeComposedAddress :: EndPointAddress -> ComposedAddress

78−deserializeComposedAddress (EndPointAddress addr) =

78+deserializeComposedAddress (EndPointAddress addr) =

79 let (header, remainder) = case BSS.uncons addr of

80 Just (x, xs) -> (x, xs)

81 Nothing -> error "deserializeComposedAddress"

@@ -86,19 +86,19 @@ deserializeComposedAddress (EndPointAddress addr) =

86 (a, b) = BSS.splitAt (decodeInt32 len) remainder'

87 in EitherAddress (EndPointAddress a) (EndPointAddress b)

88 _ -> error "deserializeComposedAddress"

89−

89+

90−createTransport :: ComposedTransport -> IO Transport

90+createTransport :: ComposedTransport -> IO Transport

91−createTransport composed =

91+createTransport composed =

92 return Transport {

93− newEndPoint = apiNewEndPoint composed

93+ newEndPoint = apiNewEndPoint composed

94− , closeTransport = apiCloseTransport composed

94+ , closeTransport = apiCloseTransport composed

95 }

96−

96+

97apiNewEndPoint :: ComposedTransport -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)

98−apiNewEndPoint composed = do

98+apiNewEndPoint composed = do

99− mEndPoints <- createEndPoints

99+ mEndPoints <- createEndPoints

100 case mEndPoints of

101− Left err ->

101+ Left err ->

102 return $ Left err

103 Right (endPointA, endPointB) -> do

104 let addr = serializeComposedAddress (EitherAddress (address endPointA) (address endPointB))

@@ -106,21 +106,21 @@ apiNewEndPoint composed = do

106 void . forkIO $ forwardEvents endPointA chan LeftAddress

107 void . forkIO $ forwardEvents endPointB chan RightAddress

108 return . Right $ EndPoint {

109− receive = readChan chan

109+ receive = readChan chan

110− , address = addr

110+ , address = addr

111− , connect = apiConnect composed endPointA endPointB

111+ , connect = apiConnect composed endPointA endPointB

112 , closeEndPoint = apiCloseEndPoint endPointA endPointB

113− , newMulticastGroup = return . Left $ newMulticastGroupError

113+ , newMulticastGroup = return . Left $ newMulticastGroupError

114 , resolveMulticastGroup = return . Left . const resolveMulticastGroupError

115 }

116 where

117− newMulticastGroupError =

117+ newMulticastGroupError =

118− TransportError NewMulticastGroupUnsupported "Multicast not supported"

118+ TransportError NewMulticastGroupUnsupported "Multicast not supported"

119− resolveMulticastGroupError =

119+ resolveMulticastGroupError =

120− TransportError ResolveMulticastGroupUnsupported "Multicast not supported"

120+ TransportError ResolveMulticastGroupUnsupported "Multicast not supported"

121

122 createEndPoints = do

123− mEndPointA <- newEndPoint (transportA composed)

123+ mEndPointA <- newEndPoint (transportA composed)

124 case mEndPointA of

125 Left err -> return $ Left err

126 Right endPointA -> do

@@ -129,7 +129,7 @@ apiNewEndPoint composed = do

129 Left err -> do

130 closeEndPoint endPointA

131 return $ Left err

132− Right endPointB ->

132+ Right endPointB ->

133 return $ Right (endPointA, endPointB)

134

135 forwardEvents :: EndPoint -> Chan Event -> (EndPointAddress -> ComposedAddress) -> IO ()

@@ -138,19 +138,19 @@ apiNewEndPoint composed = do

138 go = do

139 event <- receive endPoint

140 case event of

141− ConnectionOpened cid rel addr -> do

141+ ConnectionOpened cid rel addr -> do

142 let addr' = serializeComposedAddress (inj addr)

143 writeChan chan (ConnectionOpened cid rel addr')

144− go

144+ go

145 ErrorEvent (TransportError (EventConnectionLost addr) msg) -> do

146 let addr' = serializeComposedAddress (inj addr)

147 writeChan chan $ ErrorEvent (TransportError (EventConnectionLost addr') msg)

148 go

149 EndPointClosed -> do

150− writeChan chan event

150+ writeChan chan event

151 return ()

152 _ -> do

153− writeChan chan event

153+ writeChan chan event

154 go

155

156apiCloseTransport :: ComposedTransport -> IO ()

@@ -161,21 +161,21 @@ apiCloseTransport composed = do

161apiConnect :: ComposedTransport

162 -> EndPoint

163 -> EndPoint

164− -> EndPointAddress

164+ -> EndPointAddress

165− -> Reliability

165+ -> Reliability

166− -> ConnectHints

166+ -> ConnectHints

167 -> IO (Either (TransportError ConnectErrorCode) Connection)

168−apiConnect composed endPointA endPointB theirComposedAddr rel hints =

168+apiConnect composed endPointA endPointB theirComposedAddr rel hints =

169 case deserializeComposedAddress theirComposedAddr of

170− LeftAddress addr ->

170+ LeftAddress addr ->

171 connect endPointA addr rel hints

172− RightAddress addr ->

172+ RightAddress addr ->

173 connect endPointB addr rel hints

174 EitherAddress addrA addrB -> do

175 (endPoint, addr) <- resolveAddress composed (endPointA, endPointB) (addrA, addrB)

176 connect endPoint addr rel hints

177

178apiCloseEndPoint :: EndPoint -> EndPoint -> IO ()

179−apiCloseEndPoint endPointA endPointB = do

179+apiCloseEndPoint endPointA endPointB = do

180 closeEndPoint endPointA

181 closeEndPoint endPointB

network-transport-inmemory/src/Network/Transport/Chan.hs+38−38

@@ -1,7 +1,7 @@

1-- | In-memory implementation of the Transport API.

2module Network.Transport.Chan (createTransport) where

4−import Network.Transport

4+import Network.Transport

5import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)

6import Control.Applicative ((<$>))

7import Control.Category ((>>>))

@@ -15,11 +15,11 @@ import qualified Data.Set as Set (empty, elems, insert, delete)

15import Data.ByteString (ByteString)

16import qualified Data.ByteString.Char8 as BSC (pack)

17import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))

18−import qualified Data.Accessor.Container as DAC (mapMaybe)

18+import qualified Data.Accessor.Container as DAC (mapMaybe)

20-- Global state: next available "address", mapping from addresses to channels and next available connection

21−data TransportState = State { _channels :: Map EndPointAddress (Chan Event)

21+data TransportState = State { _channels :: Map EndPointAddress (Chan Event)

22− , _nextConnectionId :: Map EndPointAddress ConnectionId

22+ , _nextConnectionId :: Map EndPointAddress ConnectionId

23 , _multigroups :: Map MulticastAddress (MVar (Set EndPointAddress))

24 }

@@ -29,11 +29,11 @@ data TransportState = State { _channels :: Map EndPointAddress (Chan Eve

29-- (threads can, and should, create their own endpoints though).

30createTransport :: IO Transport

31createTransport = do

32− state <- newMVar State { _channels = Map.empty

32+ state <- newMVar State { _channels = Map.empty

33 , _nextConnectionId = Map.empty

34 , _multigroups = Map.empty

35 }

36− return Transport { newEndPoint = apiNewEndPoint state

36+ return Transport { newEndPoint = apiNewEndPoint state

37 , closeTransport = throwIO (userError "closeEndPoint not implemented")

38 }

@@ -44,46 +44,46 @@ apiNewEndPoint state = do

44 addr <- modifyMVar state $ \st -> do

45 let addr = EndPointAddress . BSC.pack . show . Map.size $ st ^. channels

46 return ((channelAt addr ^= chan) . (nextConnectionIdAt addr ^= 1) $ st, addr)

47− return . Right $ EndPoint { receive = readChan chan

47+ return . Right $ EndPoint { receive = readChan chan

48 , address = addr

49− , connect = apiConnect addr state

49+ , connect = apiConnect addr state

50 , closeEndPoint = throwIO (userError "closeEndPoint not implemented")

51 , newMulticastGroup = apiNewMulticastGroup state addr

52 , resolveMulticastGroup = apiResolveMulticastGroup state addr

53 }

54−

54+

55-- | Create a new connection

56−apiConnect :: EndPointAddress

56+apiConnect :: EndPointAddress

57− -> MVar TransportState

57+ -> MVar TransportState

58− -> EndPointAddress

58+ -> EndPointAddress

59− -> Reliability

59+ -> Reliability

60− -> ConnectHints

60+ -> ConnectHints

61 -> IO (Either (TransportError ConnectErrorCode) Connection)

62−apiConnect myAddress state theirAddress _reliability _hints = do

62+apiConnect myAddress state theirAddress _reliability _hints = do

63 (chan, conn) <- modifyMVar state $ \st -> do

64 let chan = st ^. channelAt theirAddress

65 let conn = st ^. nextConnectionIdAt theirAddress

66 return (nextConnectionIdAt theirAddress ^: (+ 1) $ st, (chan, conn))

67 writeChan chan $ ConnectionOpened conn ReliableOrdered myAddress

68 connAlive <- newMVar True

69− return . Right $ Connection { send = apiSend chan conn connAlive

69+ return . Right $ Connection { send = apiSend chan conn connAlive

70− , close = apiClose chan conn connAlive

70+ , close = apiClose chan conn connAlive

71− }

71+ }

73-- | Send a message over a connection

74apiSend :: Chan Event -> ConnectionId -> MVar Bool -> [ByteString] -> IO (Either (TransportError SendErrorCode) ())

75−apiSend chan conn connAlive msg =

75+apiSend chan conn connAlive msg =

76− modifyMVar connAlive $ \alive ->

76+ modifyMVar connAlive $ \alive ->

77− if alive

77+ if alive

78− then do

78+ then do

79 writeChan chan (Received conn msg)

80 return (alive, Right ())

81− else

81+ else

82 return (alive, Left (TransportError SendFailed "Connection closed"))

84-- | Close a connection

85apiClose :: Chan Event -> ConnectionId -> MVar Bool -> IO ()

86−apiClose chan conn connAlive =

86+apiClose chan conn connAlive =

87 modifyMVar_ connAlive $ \alive -> do

88 when alive . writeChan chan $ ConnectionClosed conn

89 return False

@@ -91,7 +91,7 @@ apiClose chan conn connAlive =

91-- | Create a new multicast group

92apiNewMulticastGroup :: MVar TransportState -> EndPointAddress -> IO (Either (TransportError NewMulticastGroupErrorCode) MulticastGroup)

93apiNewMulticastGroup state ourAddress = do

94− group <- newMVar Set.empty

94+ group <- newMVar Set.empty

95 groupAddr <- modifyMVar state $ \st -> do

96 let addr = MulticastAddress . BSC.pack . show . Map.size $ st ^. multigroups

97 return (multigroupAt addr ^= group $ st, addr)

@@ -105,30 +105,30 @@ apiNewMulticastGroup state ourAddress = do

105-- deleted.

106createMulticastGroup :: MVar TransportState -> EndPointAddress -> MulticastAddress -> MVar (Set EndPointAddress) -> MulticastGroup

107createMulticastGroup state ourAddress groupAddress group =

108− MulticastGroup { multicastAddress = groupAddress

108+ MulticastGroup { multicastAddress = groupAddress

109 , deleteMulticastGroup = modifyMVar_ state $ return . (multigroups ^: Map.delete groupAddress)

110 , maxMsgSize = Nothing

111− , multicastSend = \payload -> do

111+ , multicastSend = \payload -> do

112 cs <- (^. channels) <$> readMVar state

113− es <- readMVar group

113+ es <- readMVar group

114− forM_ (Set.elems es) $ \ep -> do

114+ forM_ (Set.elems es) $ \ep -> do

115 let ch = cs ^. at ep "Invalid endpoint"

116− writeChan ch (ReceivedMulticast groupAddress payload)

116+ writeChan ch (ReceivedMulticast groupAddress payload)

117 , multicastSubscribe = modifyMVar_ group $ return . Set.insert ourAddress

118 , multicastUnsubscribe = modifyMVar_ group $ return . Set.delete ourAddress

119− , multicastClose = return ()

119+ , multicastClose = return ()

120 }

121

122-- | Resolve a multicast group

123−apiResolveMulticastGroup :: MVar TransportState

123+apiResolveMulticastGroup :: MVar TransportState

124 -> EndPointAddress

125− -> MulticastAddress

125+ -> MulticastAddress

126 -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)

127apiResolveMulticastGroup state ourAddress groupAddress = do

128− group <- (^. (multigroups >>> DAC.mapMaybe groupAddress)) <$> readMVar state

128+ group <- (^. (multigroups >>> DAC.mapMaybe groupAddress)) <$> readMVar state

129 case group of

130 Nothing -> return . Left $ TransportError ResolveMulticastGroupNotFound ("Group " ++ show groupAddress ++ " not found")

131− Just mvar -> return . Right $ createMulticastGroup state ourAddress groupAddress mvar

131+ Just mvar -> return . Right $ createMulticastGroup state ourAddress groupAddress mvar

132

133--------------------------------------------------------------------------------

134-- Lens definitions --

@@ -141,12 +141,12 @@ nextConnectionId :: Accessor TransportState (Map EndPointAddress ConnectionId)

141nextConnectionId = accessor _nextConnectionId (\cid st -> st { _nextConnectionId = cid })

142

143multigroups :: Accessor TransportState (Map MulticastAddress (MVar (Set EndPointAddress)))

144−multigroups = accessor _multigroups (\gs st -> st { _multigroups = gs })

144+multigroups = accessor _multigroups (\gs st -> st { _multigroups = gs })

145

146at :: Ord k => k -> String -> Accessor (Map k v) v

147−at k err = accessor (Map.findWithDefault (error err) k) (Map.insert k)

147+at k err = accessor (Map.findWithDefault (error err) k) (Map.insert k)

148

149−channelAt :: EndPointAddress -> Accessor TransportState (Chan Event)

149+channelAt :: EndPointAddress -> Accessor TransportState (Chan Event)

150channelAt addr = channels >>> at addr "Invalid channel"

151

152nextConnectionIdAt :: EndPointAddress -> Accessor TransportState ConnectionId

network-transport-inmemory/tests/TestInMemory.hs+1−1

@@ -3,6 +3,6 @@ module Main where

3import Network.Transport.Tests

4import Network.Transport.Chan

5import Control.Applicative ((<$>))

6−

7main :: IO ()

8main = testTransport (Right <$> createTransport)

network-transport-tcp/benchmarks/JustPingCacheHeader.hs+15−15

@@ -40,7 +40,7 @@ main = do

40 -- Start the server

41 forkIO $ do

42 putStrLn "server: creating TCP connection"

43− serverAddrs <- getAddrInfo

43+ serverAddrs <- getAddrInfo

44 (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))

45 Nothing

46 (Just "8080")

@@ -61,15 +61,15 @@ main = do

61 forkIO $ do

62 takeMVar serverReady

63 let pings = read pingsStr

64− serverAddrs <- getAddrInfo

64+ serverAddrs <- getAddrInfo

65 Nothing

66 (Just "127.0.0.1")

67 (Just "8080")

68 let serverAddr = head serverAddrs

69 sock <- socket (addrFamily serverAddr) Stream defaultProtocol

70−

70+

71 N.connect sock (addrAddress serverAddr)

72−

72+

73 ping sock pings

74 putMVar clientDone ()

@@ -79,20 +79,20 @@ main = do

79pingMessage :: ByteString

80pingMessage = pack "ping123"

82−ping :: Socket -> Int -> IO ()

82+ping :: Socket -> Int -> IO ()

83ping sock pings = go pings

84 where

85 go :: Int -> IO ()

86− go 0 = do

86+ go 0 = do

87 putStrLn $ "client did " ++ show pings ++ " pings"

88 go !i = do

89 before <- getCurrentTime

90− send sock pingMessage

90+ send sock pingMessage

91 bs <- recv sock 8

92 after <- getCurrentTime

93 -- putStrLn $ "client received " ++ unpack bs

94 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)

95− hPutStrLn stderr $ show i ++ " " ++ show latency

95+ hPutStrLn stderr $ show i ++ " " ++ show latency

96 go (i - 1)

98pong :: Socket -> IO ()

@@ -103,7 +103,7 @@ pong sock = do

103 send sock bs

104 pong sock

105

106−-- | Wrapper around NBS.recv (for profiling)

106+-- | Wrapper around NBS.recv (for profiling)

107recv :: Socket -> Int -> IO ByteString

108recv sock i = do

109 (header, payload) <- BS.splitAt 4 `fmap` NBS.recv sock (4 + i)

@@ -112,23 +112,23 @@ recv sock i = do

112

113-- | Cached header

114header :: ByteString

115−header = pack "fake"

115+header = pack "fake"

116

117-- | Wrapper around NBS.send (for profiling)

118−send :: Socket -> ByteString -> IO ()

118+send :: Socket -> ByteString -> IO ()

119send sock bs = do

120 NBS.sendMany sock [header, bs]

121

122-- | Encode length (manual for now)

123encodeLength :: Int32 -> IO ByteString

124−encodeLength i32 =

124+encodeLength i32 =

125 BSI.create 4 $ \p ->

126 pokeByteOff p 0 (htonl (fromIntegral i32))

127

128-- | Decode length (manual for now)

129decodeLength :: ByteString -> IO Int32

130−decodeLength bs =

130+decodeLength bs =

131− let (fp, _, _) = BSI.toForeignPtr bs in

131+ let (fp, _, _) = BSI.toForeignPtr bs in

132 withForeignPtr fp $ \p -> do

133− w32 <- peekByteOff p 0

133+ w32 <- peekByteOff p 0

134 return (fromIntegral (ntohl w32))

network-transport-tcp/benchmarks/JustPingHaskell.hs+9−9

@@ -33,7 +33,7 @@ main = do

33 -- Start the server

34 forkIO $ do

35 putStrLn "server: creating TCP connection"

36− serverAddrs <- getAddrInfo

36+ serverAddrs <- getAddrInfo

37 (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))

38 Nothing

39 (Just "8080")

@@ -54,15 +54,15 @@ main = do

54 forkIO $ do

55 takeMVar serverReady

56 let pings = read pingsStr

57− serverAddrs <- getAddrInfo

57+ serverAddrs <- getAddrInfo

58 Nothing

59 (Just "127.0.0.1")

60 (Just "8080")

61 let serverAddr = head serverAddrs

62 sock <- socket (addrFamily serverAddr) Stream defaultProtocol

63−

63+

64 N.connect sock (addrAddress serverAddr)

65−

65+

66 ping sock pings

67 putMVar clientDone ()

@@ -72,20 +72,20 @@ main = do

72pingMessage :: ByteString

73pingMessage = pack "ping123"

75−ping :: Socket -> Int -> IO ()

75+ping :: Socket -> Int -> IO ()

76ping sock pings = go pings

77 where

78 go :: Int -> IO ()

79− go 0 = do

79+ go 0 = do

80 putStrLn $ "client did " ++ show pings ++ " pings"

81 go !i = do

82 before <- getCurrentTime

83− send sock pingMessage

83+ send sock pingMessage

84 bs <- recv sock 8

85 after <- getCurrentTime

86 -- putStrLn $ "client received " ++ unpack bs

87 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)

88− hPutStrLn stderr $ show i ++ " " ++ show latency

88+ hPutStrLn stderr $ show i ++ " " ++ show latency

89 go (i - 1)

91pong :: Socket -> IO ()

@@ -96,7 +96,7 @@ pong sock = do

96 send sock bs

97 pong sock

99−-- | Wrapper around NBS.recv (for profiling)

99+-- | Wrapper around NBS.recv (for profiling)

100recv :: Socket -> Int -> IO ByteString

101recv = NBS.recv

102

network-transport-tcp/benchmarks/JustPingOneRecv.hs+14−14

@@ -40,7 +40,7 @@ main = do

40 -- Start the server

41 forkIO $ do

42 putStrLn "server: creating TCP connection"

43− serverAddrs <- getAddrInfo

43+ serverAddrs <- getAddrInfo

44 (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))

45 Nothing

46 (Just "8080")

@@ -61,15 +61,15 @@ main = do

61 forkIO $ do

62 takeMVar serverReady

63 let pings = read pingsStr

64− serverAddrs <- getAddrInfo

64+ serverAddrs <- getAddrInfo

65 Nothing

66 (Just "127.0.0.1")

67 (Just "8080")

68 let serverAddr = head serverAddrs

69 sock <- socket (addrFamily serverAddr) Stream defaultProtocol

70−

70+

71 N.connect sock (addrAddress serverAddr)

72−

72+

73 ping sock pings

74 putMVar clientDone ()

@@ -79,20 +79,20 @@ main = do

79pingMessage :: ByteString

80pingMessage = pack "ping123"

82−ping :: Socket -> Int -> IO ()

82+ping :: Socket -> Int -> IO ()

83ping sock pings = go pings

84 where

85 go :: Int -> IO ()

86− go 0 = do

86+ go 0 = do

87 putStrLn $ "client did " ++ show pings ++ " pings"

88 go !i = do

89 before <- getCurrentTime

90− send sock pingMessage

90+ send sock pingMessage

91 bs <- recv sock 8

92 after <- getCurrentTime

93 -- putStrLn $ "client received " ++ unpack bs

94 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)

95− hPutStrLn stderr $ show i ++ " " ++ show latency

95+ hPutStrLn stderr $ show i ++ " " ++ show latency

96 go (i - 1)

98pong :: Socket -> IO ()

@@ -103,7 +103,7 @@ pong sock = do

103 send sock bs

104 pong sock

105

106−-- | Wrapper around NBS.recv (for profiling)

106+-- | Wrapper around NBS.recv (for profiling)

107recv :: Socket -> Int -> IO ByteString

108recv sock i = do

109 (header, payload) <- BS.splitAt 4 `fmap` NBS.recv sock (4 + i)

@@ -111,21 +111,21 @@ recv sock i = do

111 return payload

112

113-- | Wrapper around NBS.send (for profiling)

114−send :: Socket -> ByteString -> IO ()

114+send :: Socket -> ByteString -> IO ()

115send sock bs = do

116 length <- encodeLength (fromIntegral (BS.length bs))

117 NBS.sendMany sock [length, bs]

118

119-- | Encode length (manual for now)

120encodeLength :: Int32 -> IO ByteString

121−encodeLength i32 =

121+encodeLength i32 =

122 BSI.create 4 $ \p ->

123 pokeByteOff p 0 (htonl (fromIntegral i32))

124

125-- | Decode length (manual for now)

126decodeLength :: ByteString -> IO Int32

127−decodeLength bs =

127+decodeLength bs =

128− let (fp, _, _) = BSI.toForeignPtr bs in

128+ let (fp, _, _) = BSI.toForeignPtr bs in

129 withForeignPtr fp $ \p -> do

130− w32 <- peekByteOff p 0

130+ w32 <- peekByteOff p 0

131 return (fromIntegral (ntohl w32))

network-transport-tcp/benchmarks/JustPingThroughChan.hs+15−15

@@ -56,9 +56,9 @@ main = do

56 putMVar serverReady ()

57 (clientSock, pingAddr) <- accept sock

58 forkIO $ socketToChan clientSock multiplexChannel

59−

59+

60− -- Reply to the client

60+ -- Reply to the client

61− forever $ readChan multiplexChannel >>= send clientSock

61+ forever $ readChan multiplexChannel >>= send clientSock

63 -- Start the client

64 forkIO $ do

@@ -83,45 +83,45 @@ socketToChan sock chan = go

83pingMessage :: ByteString

84pingMessage = pack "ping123"

86−ping :: Socket -> Int -> IO ()

86+ping :: Socket -> Int -> IO ()

87ping sock pings = go pings

88 where

89 go :: Int -> IO ()

90− go 0 = do

90+ go 0 = do

91 putStrLn $ "client did " ++ show pings ++ " pings"

92 go !i = do

93 before <- getCurrentTime

94− send sock pingMessage

94+ send sock pingMessage

95− bs <- recv sock

95+ bs <- recv sock

96 after <- getCurrentTime

97 -- putStrLn $ "client received " ++ unpack bs

98 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)

99− hPutStrLn stderr $ show i ++ " " ++ show latency

99+ hPutStrLn stderr $ show i ++ " " ++ show latency

100 go (i - 1)

101

102−-- | Receive a package

102+-- | Receive a package

103recv :: Socket -> IO ByteString

104recv sock = do

105 header <- NBS.recv sock 4

106− length <- decodeLength header

106+ length <- decodeLength header

107 NBS.recv sock (fromIntegral (length :: Int32))

108

109-- | Send a package

110−send :: Socket -> ByteString -> IO ()

110+send :: Socket -> ByteString -> IO ()

111send sock bs = do

112 length <- encodeLength (fromIntegral (BS.length bs))

113 NBS.sendMany sock [length, bs]

114

115-- | Encode length (manual for now)

116encodeLength :: Int32 -> IO ByteString

117−encodeLength i32 =

117+encodeLength i32 =

118 BSI.create 4 $ \p ->

119 pokeByteOff p 0 (htonl (fromIntegral i32))

120

121-- | Decode length (manual for now)

122decodeLength :: ByteString -> IO Int32

123−decodeLength bs =

123+decodeLength bs =

124− let (fp, _, _) = BSI.toForeignPtr bs in

124+ let (fp, _, _) = BSI.toForeignPtr bs in

125 withForeignPtr fp $ \p -> do

126− w32 <- peekByteOff p 0

126+ w32 <- peekByteOff p 0

127 return (fromIntegral (ntohl w32))

network-transport-tcp/benchmarks/JustPingThroughMVar.hs+15−15

@@ -56,9 +56,9 @@ main = do

56 putMVar serverReady ()

57 (clientSock, pingAddr) <- accept sock

58 forkIO $ socketToMVar clientSock multiplexMVar

59−

59+

60− -- Reply to the client

60+ -- Reply to the client

61− forever $ takeMVar multiplexMVar >>= send clientSock

61+ forever $ takeMVar multiplexMVar >>= send clientSock

63 -- Start the client

64 forkIO $ do

@@ -83,45 +83,45 @@ socketToMVar sock mvar = go

83pingMessage :: ByteString

84pingMessage = pack "ping123"

86−ping :: Socket -> Int -> IO ()

86+ping :: Socket -> Int -> IO ()

87ping sock pings = go pings

88 where

89 go :: Int -> IO ()

90− go 0 = do

90+ go 0 = do

91 putStrLn $ "client did " ++ show pings ++ " pings"

92 go !i = do

93 before <- getCurrentTime

94− send sock pingMessage

94+ send sock pingMessage

95− bs <- recv sock

95+ bs <- recv sock

96 after <- getCurrentTime

97 -- putStrLn $ "client received " ++ unpack bs

98 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)

99− hPutStrLn stderr $ show i ++ " " ++ show latency

99+ hPutStrLn stderr $ show i ++ " " ++ show latency

100 go (i - 1)

101

102−-- | Receive a package

102+-- | Receive a package

103recv :: Socket -> IO ByteString

104recv sock = do

105 header <- NBS.recv sock 4

106− length <- decodeLength header

106+ length <- decodeLength header

107 NBS.recv sock (fromIntegral (length :: Int32))

108

109-- | Send a package

110−send :: Socket -> ByteString -> IO ()

110+send :: Socket -> ByteString -> IO ()

111send sock bs = do

112 length <- encodeLength (fromIntegral (BS.length bs))

113 NBS.sendMany sock [length, bs]

114

115-- | Encode length (manual for now)

116encodeLength :: Int32 -> IO ByteString

117−encodeLength i32 =

117+encodeLength i32 =

118 BSI.create 4 $ \p ->

119 pokeByteOff p 0 (htonl (fromIntegral i32))

120

121-- | Decode length (manual for now)

122decodeLength :: ByteString -> IO Int32

123−decodeLength bs =

123+decodeLength bs =

124− let (fp, _, _) = BSI.toForeignPtr bs in

124+ let (fp, _, _) = BSI.toForeignPtr bs in

125 withForeignPtr fp $ \p -> do

126− w32 <- peekByteOff p 0

126+ w32 <- peekByteOff p 0

127 return (fromIntegral (ntohl w32))

network-transport-tcp/benchmarks/JustPingTransport.hs+14−14

@@ -31,18 +31,18 @@ main = do

31 forkIO $ do

32 -- establish transport and endpoint

33 putStrLn "server: creating TCP connection"

34− Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters

34+ Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters

35− Right endpoint <- newEndPoint transport

35+ Right endpoint <- newEndPoint transport

36 putMVar serverAddr (address endpoint)

38− -- Connect to the client so that we can reply

38+ -- Connect to the client so that we can reply

39 theirAddr <- takeMVar clientAddr

40− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

40+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

42 -- reply to pings with pongs

43 putStrLn "server: awaiting client connection"

44 ConnectionOpened _ _ _ <- receive endpoint

45− pong endpoint conn

45+ pong endpoint conn

47 -- Start the client

48 forkIO $ do

@@ -55,9 +55,9 @@ main = do

56 -- Connect to the server to send pings

57 theirAddr <- takeMVar serverAddr

58− Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

58+ Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

60− -- Send pings, waiting for a reply after every ping

60+ -- Send pings, waiting for a reply after every ping

61 ConnectionOpened _ _ _ <- receive endpoint

62 ping endpoint conn pings

63 putMVar clientDone ()

@@ -68,27 +68,27 @@ main = do

68pingMessage :: [ByteString]

69pingMessage = [pack "ping123"]

71−ping :: EndPoint -> Connection -> Int -> IO ()

71+ping :: EndPoint -> Connection -> Int -> IO ()

72ping endpoint conn pings = go pings

73 where

74 go :: Int -> IO ()

75− go 0 = do

75+ go 0 = do

76 putStrLn $ "client did " ++ show pings ++ " pings"

77 go !i = do

78 before <- getCurrentTime

79 send conn pingMessage

80− Received _ _payload <- receive endpoint

80+ Received _ _payload <- receive endpoint

81 after <- getCurrentTime

82− -- putStrLn $ "client received " ++ show _payload

82+ -- putStrLn $ "client received " ++ show _payload

83 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)

84− hPutStrLn stderr $ show i ++ " " ++ show latency

84+ hPutStrLn stderr $ show i ++ " " ++ show latency

85 go (i - 1)

87pong :: EndPoint -> Connection -> IO ()

88pong endpoint conn = go

89− where

89+ where

90 go = do

91− msg <- receive endpoint

91+ msg <- receive endpoint

92 case msg of

93 Received _ payload -> send conn payload >> go

94 ConnectionClosed _ -> return ()

network-transport-tcp/benchmarks/JustPingTwoSocketPairs.hs+14−14

@@ -60,7 +60,7 @@ main = do

60 pongSock <- socket (addrFamily clientAddr) Stream defaultProtocol

61 N.connect pongSock (addrAddress clientAddr)

62 when ("--NoDelay" `elem` args) $ setSocketOption pongSock NoDelay 1

63− forever $ readChan multiplexChannel >>= send pongSock

63+ forever $ readChan multiplexChannel >>= send pongSock

65 -- Wait for incoming connections (pings from the client)

66 putMVar serverReady ()

@@ -89,7 +89,7 @@ main = do

89 putMVar clientDone ()

91 -- Wait for incoming connections (pongs from the server)

92− putMVar clientReady ()

92+ putMVar clientReady ()

93 (pongSock, pongAddr) <- accept sock

94 socketToChan pongSock multiplexChannel

@@ -107,45 +107,45 @@ socketToChan sock chan = go

107pingMessage :: ByteString

108pingMessage = pack "ping123"

109

110−ping :: Socket -> Chan ByteString -> Int -> IO ()

110+ping :: Socket -> Chan ByteString -> Int -> IO ()

111ping sock chan pings = go pings

112 where

113 go :: Int -> IO ()

114− go 0 = do

114+ go 0 = do

115 putStrLn $ "client did " ++ show pings ++ " pings"

116 go !i = do

117 before <- getCurrentTime

118− send sock pingMessage

118+ send sock pingMessage

119− bs <- readChan chan

119+ bs <- readChan chan

120 after <- getCurrentTime

121 -- putStrLn $ "client received " ++ unpack bs

122 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)

123− hPutStrLn stderr $ show i ++ " " ++ show latency

123+ hPutStrLn stderr $ show i ++ " " ++ show latency

124 go (i - 1)

125

126−-- | Receive a package

126+-- | Receive a package

127recv :: Socket -> IO ByteString

128recv sock = do

129 header <- NBS.recv sock 4

130− length <- decodeLength header

130+ length <- decodeLength header

131 NBS.recv sock (fromIntegral (length :: Int32))

132

133-- | Send a package

134−send :: Socket -> ByteString -> IO ()

134+send :: Socket -> ByteString -> IO ()

135send sock bs = do

136 length <- encodeLength (fromIntegral (BS.length bs))

137 NBS.sendMany sock [length, bs]

138

139-- | Encode length (manual for now)

140encodeLength :: Int32 -> IO ByteString

141−encodeLength i32 =

141+encodeLength i32 =

142 BSI.create 4 $ \p ->

143 pokeByteOff p 0 (htonl (fromIntegral i32))

144

145-- | Decode length (manual for now)

146decodeLength :: ByteString -> IO Int32

147−decodeLength bs =

147+decodeLength bs =

148− let (fp, _, _) = BSI.toForeignPtr bs in

148+ let (fp, _, _) = BSI.toForeignPtr bs in

149 withForeignPtr fp $ \p -> do

150− w32 <- peekByteOff p 0

150+ w32 <- peekByteOff p 0

151 return (fromIntegral (ntohl w32))

network-transport-tcp/benchmarks/JustPingWithHeader.hs+15−15

@@ -40,7 +40,7 @@ main = do

40 -- Start the server

41 forkIO $ do

42 putStrLn "server: creating TCP connection"

43− serverAddrs <- getAddrInfo

43+ serverAddrs <- getAddrInfo

44 (Just (defaultHints { addrFlags = [AI_PASSIVE] } ))

45 Nothing

46 (Just "8080")

@@ -61,15 +61,15 @@ main = do

61 forkIO $ do

62 takeMVar serverReady

63 let pings = read pingsStr

64− serverAddrs <- getAddrInfo

64+ serverAddrs <- getAddrInfo

65 Nothing

66 (Just "127.0.0.1")

67 (Just "8080")

68 let serverAddr = head serverAddrs

69 sock <- socket (addrFamily serverAddr) Stream defaultProtocol

70−

70+

71 N.connect sock (addrAddress serverAddr)

72−

72+

73 ping sock pings

74 putMVar clientDone ()

@@ -79,20 +79,20 @@ main = do

79pingMessage :: ByteString

80pingMessage = pack "ping123"

82−ping :: Socket -> Int -> IO ()

82+ping :: Socket -> Int -> IO ()

83ping sock pings = go pings

84 where

85 go :: Int -> IO ()

86− go 0 = do

86+ go 0 = do

87 putStrLn $ "client did " ++ show pings ++ " pings"

88 go !i = do

89 before <- getCurrentTime

90− send sock pingMessage

90+ send sock pingMessage

91 bs <- recv sock 8

92 after <- getCurrentTime

93 -- putStrLn $ "client received " ++ unpack bs

94 let latency = (1e6 :: Double) * realToFrac (diffUTCTime after before)

95− hPutStrLn stderr $ show i ++ " " ++ show latency

95+ hPutStrLn stderr $ show i ++ " " ++ show latency

96 go (i - 1)

98pong :: Socket -> IO ()

@@ -103,29 +103,29 @@ pong sock = do

103 send sock bs

104 pong sock

105

106−-- | Wrapper around NBS.recv (for profiling)

106+-- | Wrapper around NBS.recv (for profiling)

107recv :: Socket -> Int -> IO ByteString

108recv sock _ = do

109 header <- NBS.recv sock 4

110− length <- decodeLength header

110+ length <- decodeLength header

111 NBS.recv sock (fromIntegral (length :: Int32))

112

113-- | Wrapper around NBS.send (for profiling)

114−send :: Socket -> ByteString -> IO ()

114+send :: Socket -> ByteString -> IO ()

115send sock bs = do

116 length <- encodeLength (fromIntegral (BS.length bs))

117 NBS.sendMany sock [length, bs]

118

119-- | Encode length (manual for now)

120encodeLength :: Int32 -> IO ByteString

121−encodeLength i32 =

121+encodeLength i32 =

122 BSI.create 4 $ \p ->

123 pokeByteOff p 0 (htonl (fromIntegral i32))

124

125-- | Decode length (manual for now)

126decodeLength :: ByteString -> IO Int32

127−decodeLength bs =

127+decodeLength bs =

128− let (fp, _, _) = BSI.toForeignPtr bs in

128+ let (fp, _, _) = BSI.toForeignPtr bs in

129 withForeignPtr fp $ \p -> do

130− w32 <- peekByteOff p 0

130+ w32 <- peekByteOff p 0

131 return (fromIntegral (ntohl w32))

network-transport-tcp/src/Network/Transport/TCP.hs+368−368

@@ -1,22 +1,22 @@

1−-- | TCP implementation of the transport layer.

1+-- | TCP implementation of the transport layer.

2−--

2+--

3-- The TCP implementation guarantees that only a single TCP connection (socket)

4-- will be used between endpoints, provided that the addresses specified are

5-- canonical. If /A/ connects to /B/ and reports its address as

6-- @192.168.0.1:8080@ and /B/ subsequently connects tries to connect to /A/ as

7-- @client1.local:http-alt@ then the transport layer will not realize that the

8−-- TCP connection can be reused.

8+-- TCP connection can be reused.

9--

10-- Applications that use the TCP transport should use

11-- 'Network.Socket.withSocketsDo' in their main function for Windows

12-- compatibility (see "Network.Socket").

13−module Network.Transport.TCP

13+module Network.Transport.TCP

14 ( -- * Main API

15 createTransport

16 , TCPParameters(..)

17 , defaultTCPParameters

18− -- * Internals (exposed for unit tests)

18+ -- * Internals (exposed for unit tests)

19− , createTransportExposeInternals

19+ , createTransportExposeInternals

20 , TransportInternals(..)

21 , EndPointId

22 , encodeEndPointAddress

@@ -25,27 +25,27 @@ module Network.Transport.TCP

25 , ConnectionRequestResponse(..)

26 , firstNonReservedLightweightConnectionId

27 , firstNonReservedHeavyweightConnectionId

28− , socketToEndPoint

28+ , socketToEndPoint

29 , LightweightConnectionId

30 -- * Design notes

31 -- $design

32 ) where

34−import Prelude hiding

34+import Prelude hiding

35 ( mapM_

36#if ! MIN_VERSION_base(4,6,0)

37 , catch

38#endif

39 )

40−

40+

41import Network.Transport

42−import Network.Transport.TCP.Internal

42+import Network.Transport.TCP.Internal

43 ( forkServer

44 , recvWithLength

45 , recvInt32

46 , tryCloseSocket

47 )

48−import Network.Transport.Internal

48+import Network.Transport.Internal

49 ( encodeInt32

50 , prependLength

51 , mapIOException

@@ -59,7 +59,7 @@ import Network.Transport.Internal

59#ifdef USE_MOCK_NETWORK

60import qualified Network.Transport.TCP.Mock.Socket as N

61#else

62−import qualified Network.Socket as N

62+import qualified Network.Socket as N

63#endif

64 ( HostName

65 , ServiceName

@@ -71,7 +71,7 @@ import qualified Network.Socket as N

71 , SocketType(Stream)

72 , defaultProtocol

73 , setSocketOption

74− , SocketOption(ReuseAddr)

74+ , SocketOption(ReuseAddr)

75 , connect

76 , sOMAXCONN

77 , AddrInfo

@@ -85,7 +85,7 @@ import Network.Socket.ByteString (sendMany)

86import Control.Concurrent (forkIO, ThreadId, killThread, myThreadId)

87import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)

88−import Control.Concurrent.MVar

88+import Control.Concurrent.MVar

89 ( MVar

90 , newMVar

91 , modifyMVar

@@ -98,7 +98,7 @@ import Control.Concurrent.MVar

98import Control.Category ((>>>))

99import Control.Applicative ((<$>))

100import Control.Monad (when, unless, join)

101−import Control.Exception

101+import Control.Exception

102 ( IOException

103 , SomeException

104 , AsyncException

@@ -117,7 +117,7 @@ import qualified Data.ByteString.Char8 as BSC (pack, unpack)

117import Data.Bits (shiftL, (.|.))

118import Data.Word (Word32)

119import Data.Set (Set)

120−import qualified Data.Set as Set

120+import qualified Data.Set as Set

121 ( empty

122 , insert

123 , elems

@@ -128,11 +128,11 @@ import qualified Data.Set as Set

128 )

129import Data.Map (Map)

130import qualified Data.Map as Map (empty)

131−import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))

131+import Data.Accessor (Accessor, accessor, (^.), (^=), (^:))

132import qualified Data.Accessor.Container as DAC (mapMaybe)

133import Data.Foldable (forM_, mapM_)

134

135−-- $design

135+-- $design

136--

137-- [Goals]

138--

@@ -146,7 +146,7 @@ import Data.Foldable (forM_, mapM_)

146-- > | \~~~|~~~~~~~~~~~~~~~~~~~~~~~~~<| |

147-- > | |==========================| |

148-- > +-------+ +-------+

149−--

149+--

150-- Ignoring the complications detailed below, the TCP connection is set up is

151-- when the first lightweight connection is created (in either direction), and

152-- torn down when the last lightweight connection (in either direction) is

@@ -177,7 +177,7 @@ import Data.Foldable (forM_, mapM_)

177-- with /B/'s connection request completes.

178--

179-- [Disconnecting]

180−--

180+--

181-- The TCP connection is created as soon as the first logical connection from

182-- /A/ to /B/ (or /B/ to /A/) is established. At this point a thread (@#@) is

183-- spawned that listens for incoming connections from /B/:

@@ -193,21 +193,21 @@ import Data.Foldable (forM_, mapM_)

193-- The question is when the TCP connection can be closed again. Conceptually,

194-- we want to do reference counting: when there are no logical connections left

195-- between /A/ and /B/ we want to close the socket (possibly after some

196−-- timeout).

196+-- timeout).

197--

198-- However, /A/ and /B/ need to agree that the refcount has reached zero. It

199-- might happen that /B/ sends a connection request over the existing socket at

200-- the same time that /A/ closes its logical connection to /B/ and closes the

201-- socket. This will cause a failure in /B/ (which will have to retry) which is

202-- not caused by a network failure, which is unfortunate. (Note that the

203−-- connection request from /B/ might succeed even if /A/ closes the socket.)

203+-- connection request from /B/ might succeed even if /A/ closes the socket.)

204--

205-- Instead, when /A/ is ready to close the socket it sends a 'CloseSocket'

206-- request to /B/ and records that its connection to /B/ is closing. If /A/

207-- receives a new connection request from /B/ after having sent the

208-- 'CloseSocket' request it simply forgets that it sent a 'CloseSocket' request

209-- and increments the reference count of the connection again.

210−--

210+--

211-- When /B/ receives a 'CloseSocket' message and it too is ready to close the

212-- connection, it will respond with a reciprocal 'CloseSocket' request to /A/

213-- and then actually close the socket. /A/ meanwhile will not send any more

@@ -216,11 +216,11 @@ import Data.Foldable (forM_, mapM_)

216-- from /B/. (Since /A/ recorded that its connection to /B/ is in closing state

217-- after sending a 'CloseSocket' request to /B/, it knows not to reciprocate /B/

218-- reciprocal 'CloseSocket' message.)

219−--

219+--

220-- If there is a concurrent thread in /A/ waiting to connect to /B/ after /A/

221-- has sent a 'CloseSocket' request then this thread will block until /A/ knows

222-- whether to reuse the old socket (if /B/ sends a new connection request

223−-- instead of acknowledging the 'CloseSocket') or to set up a new socket.

223+-- instead of acknowledging the 'CloseSocket') or to set up a new socket.

224

225--------------------------------------------------------------------------------

226-- Internal datatypes --

@@ -229,30 +229,30 @@ import Data.Foldable (forM_, mapM_)

229-- We use underscores for fields that we might update (using accessors)

230--

231-- All data types follow the same structure:

232−--

232+--

233-- * A top-level data type describing static properties (TCPTransport,

234-- LocalEndPoint, RemoteEndPoint)

235-- * The 'static' properties include an MVar containing a data structure for

236-- the dynamic properties (TransportState, LocalEndPointState,

237−-- RemoteEndPointState). The state could be invalid/valid/closed,/etc.

237+-- RemoteEndPointState). The state could be invalid/valid/closed,/etc.

238-- * For the case of "valid" we use third data structure to give more details

239-- about the state (ValidTransportState, ValidLocalEndPointState,

240-- ValidRemoteEndPointState).

241

242−data TCPTransport = TCPTransport

242+data TCPTransport = TCPTransport

243 { transportHost :: !N.HostName

244 , transportPort :: !N.ServiceName

245 , transportState :: !(MVar TransportState)

246 , transportParams :: !TCPParameters

247 }

248

249−data TransportState =

249+data TransportState =

250 TransportValid !ValidTransportState

251 | TransportClosed

252

253−data ValidTransportState = ValidTransportState

253+data ValidTransportState = ValidTransportState

254 { _localEndPoints :: !(Map EndPointAddress LocalEndPoint)

255− , _nextEndPointId :: !EndPointId

255+ , _nextEndPointId :: !EndPointId

256 }

257

258data LocalEndPoint = LocalEndPoint

@@ -261,12 +261,12 @@ data LocalEndPoint = LocalEndPoint

261 , localState :: !(MVar LocalEndPointState)

262 }

263

264−data LocalEndPointState =

264+data LocalEndPointState =

265 LocalEndPointValid !ValidLocalEndPointState

266 | LocalEndPointClosed

267

268−data ValidLocalEndPointState = ValidLocalEndPointState

268+data ValidLocalEndPointState = ValidLocalEndPointState

269− { -- Next available ID for an outgoing lightweight self-connection

269+ { -- Next available ID for an outgoing lightweight self-connection

270 -- (see also remoteNextConnOutId)

271 _localNextConnOutId :: !LightweightConnectionId

272 -- Next available ID for an incoming heavyweight connection

@@ -275,7 +275,7 @@ data ValidLocalEndPointState = ValidLocalEndPointState

275 , _localConnections :: !(Map EndPointAddress RemoteEndPoint)

276 }

277

278−-- REMOTE ENDPOINTS

278+-- REMOTE ENDPOINTS

279--

280-- Remote endpoints (basically, TCP connections) have the following lifecycle:

281--

@@ -302,7 +302,7 @@ data ValidLocalEndPointState = ValidLocalEndPointState

302-- createConnectionTo when we fail to connect.

303--

304-- Valid: This is the "normal" state for a working remote endpoint.

305−--

305+--

306-- Closing: When we detect that a remote endpoint is no longer used, we send a

307-- CloseSocket request across the connection and put the remote endpoint in

308-- closing state. As with Init, 'Closing' carries an MVar () 'resolved' which

@@ -335,16 +335,16 @@ data ValidLocalEndPointState = ValidLocalEndPointState

335-- localConnections it is guaranteed to either find a different remote

336-- endpoint, or else none at all (if we don't insist in this order some

337-- threads might start spinning).

338−--

338+--

339-- INV-RESOLVE: We should only signal on 'resolved' while the remote endpoint is

340-- locked, and the remote endpoint must be in Valid or Closed state once

341-- unlocked. This guarantees that there will not be two threads attempting to

342−-- both signal on 'resolved'.

342+-- both signal on 'resolved'.

343--

344-- INV-LOST: If a send or recv fails, or a socket is closed unexpectedly, we

345-- first put the remote endpoint in Closed state, and then send a

346-- EventConnectionLost event. This guarantees that we only send this event

347−-- once.

347+-- once.

348--

349-- INV-CLOSING: An endpoint in closing state is for all intents and purposes

350-- closed; that is, we shouldn't do any 'send's on it (although 'recv' is

@@ -357,23 +357,23 @@ data ValidLocalEndPointState = ValidLocalEndPointState

357-- particular, it is okay to call removeRemoteEndPoint inside

358-- modifyRemoteState.

359

360−data RemoteEndPoint = RemoteEndPoint

360+data RemoteEndPoint = RemoteEndPoint

361 { remoteAddress :: !EndPointAddress

362 , remoteState :: !(MVar RemoteState)

363 , remoteId :: !HeavyweightConnectionId

364 , remoteScheduled :: !(Chan (IO ()))

365 }

366

367−data RequestedBy = RequestedByUs | RequestedByThem

367+data RequestedBy = RequestedByUs | RequestedByThem

368 deriving (Eq, Show)

369

370data RemoteState =

371 -- | Invalid remote endpoint (for example, invalid address)

372 RemoteEndPointInvalid !(TransportError ConnectErrorCode)

373 -- | The remote endpoint is being initialized

374− | RemoteEndPointInit !(MVar ()) !(MVar ()) !RequestedBy

374+ | RemoteEndPointInit !(MVar ()) !(MVar ()) !RequestedBy

375 -- | "Normal" working endpoint

376− | RemoteEndPointValid !ValidRemoteEndPointState

376+ | RemoteEndPointValid !ValidRemoteEndPointState

377 -- | The remote endpoint is being closed (garbage collected)

378 | RemoteEndPointClosing !(MVar ()) !ValidRemoteEndPointState

379 -- | The remote endpoint has been closed (garbage collected)

@@ -382,12 +382,12 @@ data RemoteState =

382 -- using a closeTransport or closeEndPoint API call

383 | RemoteEndPointFailed !IOException

384

385−-- TODO: we might want to replace Set (here and elsewhere) by faster

385+-- TODO: we might want to replace Set (here and elsewhere) by faster

386-- containers

387--

388-- TODO: we could get rid of 'remoteIncoming' (and maintain less state) if

389−-- we introduce a new event 'AllConnectionsClosed'

389+-- we introduce a new event 'AllConnectionsClosed'

390−data ValidRemoteEndPointState = ValidRemoteEndPointState

390+data ValidRemoteEndPointState = ValidRemoteEndPointState

391 { _remoteOutgoing :: !Int

392 , _remoteIncoming :: !(Set LightweightConnectionId)

393 , _remoteMaxIncoming :: !LightweightConnectionId

@@ -414,24 +414,24 @@ type LightweightConnectionId = Word32

414-- 'LightweightConnectionId'.

415type HeavyweightConnectionId = Word32

416

417−-- | Control headers

417+-- | Control headers

418−data ControlHeader =

418+data ControlHeader =

419 -- | Tell the remote endpoint that we created a new connection

420− CreatedNewConnection

420+ CreatedNewConnection

421 -- | Tell the remote endpoint we will no longer be using a connection

422− | CloseConnection

422+ | CloseConnection

423 -- | Request to close the connection (see module description)

424− | CloseSocket

424+ | CloseSocket

425 deriving (Enum, Bounded, Show)

426

427-- | Response sent by /B/ to /A/ when /A/ tries to connect

428data ConnectionRequestResponse =

429 -- | /B/ accepts the connection

430− ConnectionRequestAccepted

430+ ConnectionRequestAccepted

431 -- | /A/ requested an invalid endpoint

432− | ConnectionRequestInvalid

432+ | ConnectionRequestInvalid

433 -- | /A/s request crossed with a request from /B/ (see protocols)

434− | ConnectionRequestCrossed

434+ | ConnectionRequestCrossed

435 deriving (Enum, Bounded, Show)

436

437-- | Parameters for setting up the TCP transport

@@ -439,7 +439,7 @@ data TCPParameters = TCPParameters {

439 -- | Backlog for 'listen'.

440 -- Defaults to SOMAXCONN.

441 tcpBacklog :: Int

442− -- | Should we set SO_REUSEADDR on the server socket?

442+ -- | Should we set SO_REUSEADDR on the server socket?

443 -- Defaults to True.

444 , tcpReuseServerAddr :: Bool

445 -- | Should we set SO_REUSEADDR on client sockets?

@@ -448,13 +448,13 @@ data TCPParameters = TCPParameters {

448 }

449

450-- | Internal functionality we expose for unit testing

451−data TransportInternals = TransportInternals

451+data TransportInternals = TransportInternals

452 { -- | The ID of the thread that listens for new incoming connections

453 transportThread :: ThreadId

454 -- | Find the socket between a local and a remote endpoint

455− , socketBetween :: EndPointAddress

455+ , socketBetween :: EndPointAddress

456− -> EndPointAddress

456+ -> EndPointAddress

457− -> IO N.Socket

457+ -> IO N.Socket

458 }

459

460--------------------------------------------------------------------------------

@@ -462,62 +462,62 @@ data TransportInternals = TransportInternals

462--------------------------------------------------------------------------------

463

464-- | Create a TCP transport

465−createTransport :: N.HostName

465+createTransport :: N.HostName

466− -> N.ServiceName

466+ -> N.ServiceName

467 -> TCPParameters

468 -> IO (Either IOException Transport)

469−createTransport host port params =

469+createTransport host port params =

470 either Left (Right . fst) <$> createTransportExposeInternals host port params

471

472-- | You should probably not use this function (used for unit testing only)

473−createTransportExposeInternals

473+createTransportExposeInternals

474− :: N.HostName

474+ :: N.HostName

475− -> N.ServiceName

475+ -> N.ServiceName

476 -> TCPParameters

477− -> IO (Either IOException (Transport, TransportInternals))

477+ -> IO (Either IOException (Transport, TransportInternals))

478−createTransportExposeInternals host port params = do

478+createTransportExposeInternals host port params = do

479− state <- newMVar . TransportValid $ ValidTransportState

479+ state <- newMVar . TransportValid $ ValidTransportState

480− { _localEndPoints = Map.empty

480+ { _localEndPoints = Map.empty

481− , _nextEndPointId = 0

481+ , _nextEndPointId = 0

482 }

483 let transport = TCPTransport { transportState = state

484 , transportHost = host

485 , transportPort = port

486 , transportParams = params

487 }

488− tryIO $ bracketOnError (forkServer

488+ tryIO $ bracketOnError (forkServer

489− host

489+ host

490− port

490+ port

491− (tcpBacklog params)

491+ (tcpBacklog params)

492 (tcpReuseServerAddr params)

493− (terminationHandler transport)

493+ (terminationHandler transport)

494 (handleConnectionRequest transport))

495 killThread

496 (mkTransport transport)

497 where

498− mkTransport :: TCPTransport

498+ mkTransport :: TCPTransport

499− -> ThreadId

499+ -> ThreadId

500 -> IO (Transport, TransportInternals)

501 mkTransport transport tid = return

502− ( Transport

502+ ( Transport

503− { newEndPoint = apiNewEndPoint transport

503+ { newEndPoint = apiNewEndPoint transport

504 , closeTransport = let evs = [ EndPointClosed

505 , throw $ userError "Transport closed"

506 ] in

507− apiCloseTransport transport (Just tid) evs

507+ apiCloseTransport transport (Just tid) evs

508− }

508+ }

509− , TransportInternals

509+ , TransportInternals

510 { transportThread = tid

511 , socketBetween = internalSocketBetween transport

512 }

513 )

514

515 terminationHandler :: TCPTransport -> SomeException -> IO ()

516− terminationHandler transport ex = do

516+ terminationHandler transport ex = do

517 let evs = [ ErrorEvent (TransportError EventTransportFailed (show ex))

518− , throw $ userError "Transport closed"

518+ , throw $ userError "Transport closed"

519 ]

520− apiCloseTransport transport Nothing evs

520+ apiCloseTransport transport Nothing evs

521

522-- | Default TCP parameters

523defaultTCPParameters :: TCPParameters

@@ -533,39 +533,39 @@ defaultTCPParameters = TCPParameters {

533

534-- | Close the transport

535apiCloseTransport :: TCPTransport -> Maybe ThreadId -> [Event] -> IO ()

536−apiCloseTransport transport mTransportThread evs =

536+apiCloseTransport transport mTransportThread evs =

537 asyncWhenCancelled return $ do

538 mTSt <- modifyMVar (transportState transport) $ \st -> case st of

539 TransportValid vst -> return (TransportClosed, Just vst)

540 TransportClosed -> return (TransportClosed, Nothing)

541− forM_ mTSt $ mapM_ (apiCloseEndPoint transport evs) . (^. localEndPoints)

541+ forM_ mTSt $ mapM_ (apiCloseEndPoint transport evs) . (^. localEndPoints)

542 -- This will invoke the termination handler, which in turn will call

543 -- apiCloseTransport again, but then the transport will already be closed

544 -- and we won't be passed a transport thread, so we terminate immmediate

545− forM_ mTransportThread killThread

545+ forM_ mTransportThread killThread

546−

546+

547−-- | Create a new endpoint

547+-- | Create a new endpoint

548−apiNewEndPoint :: TCPTransport

548+apiNewEndPoint :: TCPTransport

549 -> IO (Either (TransportError NewEndPointErrorCode) EndPoint)

550−apiNewEndPoint transport =

550+apiNewEndPoint transport =

551 try . asyncWhenCancelled closeEndPoint $ do

552 ourEndPoint <- createLocalEndPoint transport

553− return EndPoint

553+ return EndPoint

554 { receive = readChan (localChannel ourEndPoint)

555 , address = localAddress ourEndPoint

556− , connect = apiConnect (transportParams transport) ourEndPoint

556+ , connect = apiConnect (transportParams transport) ourEndPoint

557 , closeEndPoint = let evs = [ EndPointClosed

558− , throw $ userError "Endpoint closed"

558+ , throw $ userError "Endpoint closed"

559 ] in

560 apiCloseEndPoint transport evs ourEndPoint

561− , newMulticastGroup = return . Left $ newMulticastGroupError

561+ , newMulticastGroup = return . Left $ newMulticastGroupError

562 , resolveMulticastGroup = return . Left . const resolveMulticastGroupError

563 }

564 where

565− newMulticastGroupError =

565+ newMulticastGroupError =

566− TransportError NewMulticastGroupUnsupported "Multicast not supported"

566+ TransportError NewMulticastGroupUnsupported "Multicast not supported"

567− resolveMulticastGroupError =

567+ resolveMulticastGroupError =

568− TransportError ResolveMulticastGroupUnsupported "Multicast not supported"

568+ TransportError ResolveMulticastGroupUnsupported "Multicast not supported"

569

570-- | Connnect to an endpoint

571apiConnect :: TCPParameters -- ^ Parameters

@@ -575,35 +575,35 @@ apiConnect :: TCPParameters -- ^ Parameters

575 -> ConnectHints -- ^ Hints

576 -> IO (Either (TransportError ConnectErrorCode) Connection)

577apiConnect params ourEndPoint theirAddress _reliability hints =

578− try . asyncWhenCancelled close $

578+ try . asyncWhenCancelled close $

579− if localAddress ourEndPoint == theirAddress

579+ if localAddress ourEndPoint == theirAddress

580− then connectToSelf ourEndPoint

580+ then connectToSelf ourEndPoint

581 else do

582 resetIfBroken ourEndPoint theirAddress

583− (theirEndPoint, connId) <-

583+ (theirEndPoint, connId) <-

584 createConnectionTo params ourEndPoint theirAddress hints

585 -- connAlive can be an IORef rather than an MVar because it is protected

586 -- by the remoteState MVar. We don't need the overhead of locking twice.

587 connAlive <- newIORef True

588− return Connection

588+ return Connection

589− { send = apiSend (ourEndPoint, theirEndPoint) connId connAlive

589+ { send = apiSend (ourEndPoint, theirEndPoint) connId connAlive

590− , close = apiClose (ourEndPoint, theirEndPoint) connId connAlive

590+ , close = apiClose (ourEndPoint, theirEndPoint) connId connAlive

591 }

592

593-- | Close a connection

594apiClose :: EndPointPair -> LightweightConnectionId -> IORef Bool -> IO ()

595−apiClose (ourEndPoint, theirEndPoint) connId connAlive =

595+apiClose (ourEndPoint, theirEndPoint) connId connAlive =

596− void . tryIO . asyncWhenCancelled return $ do

596+ void . tryIO . asyncWhenCancelled return $ do

597 mAct <- modifyMVar (remoteState theirEndPoint) $ \st -> case st of

598 RemoteEndPointValid vst -> do

599 alive <- readIORef connAlive

600− if alive

600+ if alive

601 then do

602 writeIORef connAlive False

603− act <- schedule theirEndPoint $

603+ act <- schedule theirEndPoint $

604− sendOn vst [encodeInt32 CloseConnection, encodeInt32 connId]

604+ sendOn vst [encodeInt32 CloseConnection, encodeInt32 connId]

605− return ( RemoteEndPointValid

605+ return ( RemoteEndPointValid

606− . (remoteOutgoing ^: (\x -> x - 1))

606+ . (remoteOutgoing ^: (\x -> x - 1))

607 $ vst

608 , Just act

609 )

@@ -616,12 +616,12 @@ apiClose (ourEndPoint, theirEndPoint) connId connAlive =

616

617

618-- | Send data across a connection

619−apiSend :: EndPointPair -- ^ Local and remote endpoint

619+apiSend :: EndPointPair -- ^ Local and remote endpoint

620 -> LightweightConnectionId -- ^ Connection ID

621 -> IORef Bool -- ^ Is the connection still alive?

622 -> [ByteString] -- ^ Payload

623 -> IO (Either (TransportError SendErrorCode) ())

624−apiSend (ourEndPoint, theirEndPoint) connId connAlive payload =

624+apiSend (ourEndPoint, theirEndPoint) connId connAlive payload =

625 -- We don't need the overhead of asyncWhenCancelled here

626 try . mapIOException sendFailed $ do

627 act <- withMVar (remoteState theirEndPoint) $ \st -> case st of

@@ -631,70 +631,70 @@ apiSend (ourEndPoint, theirEndPoint) connId connAlive payload =

631 relyViolation (ourEndPoint, theirEndPoint) "apiSend"

632 RemoteEndPointValid vst -> do

633 alive <- readIORef connAlive

634− if alive

634+ if alive

635− then schedule theirEndPoint $

635+ then schedule theirEndPoint $

636 sendOn vst (encodeInt32 connId : prependLength payload)

637 else throwIO $ TransportError SendClosed "Connection closed"

638− RemoteEndPointClosing _ _ -> do

638+ RemoteEndPointClosing _ _ -> do

639 alive <- readIORef connAlive

640− if alive

640+ if alive

641− then relyViolation (ourEndPoint, theirEndPoint) "apiSend"

641+ then relyViolation (ourEndPoint, theirEndPoint) "apiSend"

642 else throwIO $ TransportError SendClosed "Connection closed"

643 RemoteEndPointClosed -> do

644 alive <- readIORef connAlive

645− if alive

645+ if alive

646− then relyViolation (ourEndPoint, theirEndPoint) "apiSend"

646+ then relyViolation (ourEndPoint, theirEndPoint) "apiSend"

647 else throwIO $ TransportError SendClosed "Connection closed"

648 RemoteEndPointFailed err -> do

649 alive <- readIORef connAlive

650− if alive

650+ if alive

651− then throwIO $ TransportError SendFailed (show err)

651+ then throwIO $ TransportError SendFailed (show err)

652 else throwIO $ TransportError SendClosed "Connection closed"

653 runScheduledAction (ourEndPoint, theirEndPoint) act

654 where

655 sendFailed = TransportError SendFailed . show

656

657-- | Force-close the endpoint

658−apiCloseEndPoint :: TCPTransport -- ^ Transport

658+apiCloseEndPoint :: TCPTransport -- ^ Transport

659− -> [Event] -- ^ Events used to report closure

659+ -> [Event] -- ^ Events used to report closure

660 -> LocalEndPoint -- ^ Local endpoint

661 -> IO ()

662apiCloseEndPoint transport evs ourEndPoint =

663 asyncWhenCancelled return $ do

664 -- Remove the reference from the transport state

665 removeLocalEndPoint transport ourEndPoint

666− -- Close the local endpoint

666+ -- Close the local endpoint

667 mOurState <- modifyMVar (localState ourEndPoint) $ \st ->

668 case st of

669− LocalEndPointValid vst ->

669+ LocalEndPointValid vst ->

670 return (LocalEndPointClosed, Just vst)

671 LocalEndPointClosed ->

672 return (LocalEndPointClosed, Nothing)

673 forM_ mOurState $ \vst -> do

674 forM_ (vst ^. localConnections) tryCloseRemoteSocket

675− forM_ evs $ writeChan (localChannel ourEndPoint)

675+ forM_ evs $ writeChan (localChannel ourEndPoint)

676 where

677 -- Close the remote socket and return the set of all incoming connections

678− tryCloseRemoteSocket :: RemoteEndPoint -> IO ()

678+ tryCloseRemoteSocket :: RemoteEndPoint -> IO ()

679 tryCloseRemoteSocket theirEndPoint = do

680− -- We make an attempt to close the connection nicely

680+ -- We make an attempt to close the connection nicely

681 -- (by sending a CloseSocket first)

682 let closed = RemoteEndPointFailed . userError $ "apiCloseEndPoint"

683 mAct <- modifyMVar (remoteState theirEndPoint) $ \st ->

684 case st of

685− RemoteEndPointInvalid _ ->

685+ RemoteEndPointInvalid _ ->

686 return (st, Nothing)

687 RemoteEndPointInit resolved _ _ -> do

688 putMVar resolved ()

689 return (closed, Nothing)

690− RemoteEndPointValid vst -> do

690+ RemoteEndPointValid vst -> do

691 act <- schedule theirEndPoint $ do

692 tryIO $ sendOn vst [ encodeInt32 CloseSocket

693 , encodeInt32 (vst ^. remoteMaxIncoming)

694 ]

695 tryCloseSocket (remoteSocket vst)

696 return (closed, Just act)

697− RemoteEndPointClosing resolved vst -> do

697+ RemoteEndPointClosing resolved vst -> do

698 putMVar resolved ()

699 act <- schedule theirEndPoint $ tryCloseSocket (remoteSocket vst)

700 return (closed, Just act)

@@ -703,7 +703,7 @@ apiCloseEndPoint transport evs ourEndPoint =

703 RemoteEndPointFailed err ->

704 return (RemoteEndPointFailed err, Nothing)

705 forM_ mAct $ runScheduledAction (ourEndPoint, theirEndPoint)

706−

706+

707

708--------------------------------------------------------------------------------

709-- Incoming requests --

@@ -720,11 +720,11 @@ apiCloseEndPoint transport evs ourEndPoint =

720-- the transport down. We must be careful to close the socket when a (possibly

721-- asynchronous, ThreadKilled) exception occurs. (If an exception escapes from

722-- handleConnectionRequest the transport will be shut down.)

723−handleConnectionRequest :: TCPTransport -> N.Socket -> IO ()

723+handleConnectionRequest :: TCPTransport -> N.Socket -> IO ()

724−handleConnectionRequest transport sock = handle handleException $ do

724+handleConnectionRequest transport sock = handle handleException $ do

725 ourEndPointId <- recvInt32 sock

726− theirAddress <- EndPointAddress . BS.concat <$> recvWithLength sock

726+ theirAddress <- EndPointAddress . BS.concat <$> recvWithLength sock

727− let ourAddress = encodeEndPointAddress (transportHost transport)

727+ let ourAddress = encodeEndPointAddress (transportHost transport)

728 (transportPort transport)

729 ourEndPointId

730 ourEndPoint <- withMVar (transportState transport) $ \st -> case st of

@@ -735,32 +735,32 @@ handleConnectionRequest transport sock = handle handleException $ do

735 throwIO $ userError "handleConnectionRequest: Invalid endpoint"

736 Just ourEndPoint ->

737 return ourEndPoint

738− TransportClosed ->

738+ TransportClosed ->

739 throwIO $ userError "Transport closed"

740 void . forkIO $ go ourEndPoint theirAddress

741 where

742 go :: LocalEndPoint -> EndPointAddress -> IO ()

743− go ourEndPoint theirAddress = do

743+ go ourEndPoint theirAddress = do

744 -- This runs in a thread that will never be killed

745− mEndPoint <- handle ((>> return Nothing) . handleException) $ do

745+ mEndPoint <- handle ((>> return Nothing) . handleException) $ do

746 resetIfBroken ourEndPoint theirAddress

747− (theirEndPoint, isNew) <-

747+ (theirEndPoint, isNew) <-

748 findRemoteEndPoint ourEndPoint theirAddress RequestedByThem

749−

749+

750− if not isNew

750+ if not isNew

751 then do

752 tryIO $ sendMany sock [encodeInt32 ConnectionRequestCrossed]

753 tryCloseSocket sock

754− return Nothing

754+ return Nothing

755 else do

756 sendLock <- newMVar ()

757− let vst = ValidRemoteEndPointState

757+ let vst = ValidRemoteEndPointState

758 { remoteSocket = sock

759 , remoteSendLock = sendLock

760 , _remoteOutgoing = 0

761 , _remoteIncoming = Set.empty

762 , _remoteMaxIncoming = 0

763− , _remoteNextConnOutId = firstNonReservedLightweightConnectionId

763+ , _remoteNextConnOutId = firstNonReservedLightweightConnectionId

764 }

765 sendMany sock [encodeInt32 ConnectionRequestAccepted]

766 resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)

@@ -769,30 +769,30 @@ handleConnectionRequest transport sock = handle handleException $ do

769 -- Nothing then the socket is already closed; otherwise, the socket has

770 -- been recorded as part of the remote endpoint. Either way, we no longer

771 -- have to worry about closing the socket on receiving an asynchronous

772− -- exception from this point forward.

772+ -- exception from this point forward.

773 forM_ mEndPoint $ handleIncomingMessages . (,) ourEndPoint

774

775 handleException :: SomeException -> IO ()

776− handleException ex = do

776+ handleException ex = do

777− tryCloseSocket sock

777+ tryCloseSocket sock

778 rethrowIfAsync (fromException ex)

779

780− rethrowIfAsync :: Maybe AsyncException -> IO ()

780+ rethrowIfAsync :: Maybe AsyncException -> IO ()

781− rethrowIfAsync = mapM_ throwIO

781+ rethrowIfAsync = mapM_ throwIO

782

783-- | Handle requests from a remote endpoint.

784−--

784+--

785-- Returns only if the remote party closes the socket or if an error occurs.

786-- This runs in a thread that will never be killed.

787−handleIncomingMessages :: EndPointPair -> IO ()

787+handleIncomingMessages :: EndPointPair -> IO ()

788handleIncomingMessages (ourEndPoint, theirEndPoint) = do

789 mSock <- withMVar theirState $ \st ->

790 case st of

791 RemoteEndPointInvalid _ ->

792− relyViolation (ourEndPoint, theirEndPoint)

792+ relyViolation (ourEndPoint, theirEndPoint)

793− "handleIncomingMessages (invalid)"

793+ "handleIncomingMessages (invalid)"

794 RemoteEndPointInit _ _ _ ->

795− relyViolation (ourEndPoint, theirEndPoint)

795+ relyViolation (ourEndPoint, theirEndPoint)

796 "handleIncomingMessages (init)"

797 RemoteEndPointValid ep ->

798 return . Just $ remoteSocket ep

@@ -800,13 +800,13 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do

800 return . Just $ remoteSocket ep

801 RemoteEndPointClosed ->

802 return Nothing

803− RemoteEndPointFailed _ ->

803+ RemoteEndPointFailed _ ->

804 return Nothing

805−

805+

806− forM_ mSock $ \sock ->

806+ forM_ mSock $ \sock ->

807 tryIO (go sock) >>= either (prematureExit sock) return

808 where

809− -- Dispatch

809+ -- Dispatch

810 --

811 -- If a recv throws an exception this will be caught top-level and

812 -- 'prematureExit' will be invoked. The same will happen if the remote

@@ -817,38 +817,38 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do

817 go :: N.Socket -> IO ()

818 go sock = do

819 lcid <- recvInt32 sock :: IO LightweightConnectionId

820− if lcid >= firstNonReservedLightweightConnectionId

820+ if lcid >= firstNonReservedLightweightConnectionId

821 then do

822− readMessage sock lcid

822+ readMessage sock lcid

823 go sock

824− else

824+ else

825 case tryToEnum (fromIntegral lcid) of

826 Just CreatedNewConnection -> do

827− recvInt32 sock >>= createdNewConnection

827+ recvInt32 sock >>= createdNewConnection

828− go sock

828+ go sock

829 Just CloseConnection -> do

830− recvInt32 sock >>= closeConnection

830+ recvInt32 sock >>= closeConnection

831 go sock

832− Just CloseSocket -> do

832+ Just CloseSocket -> do

833− didClose <- recvInt32 sock >>= closeSocket sock

833+ didClose <- recvInt32 sock >>= closeSocket sock

834 unless didClose $ go sock

835 Nothing ->

836 throwIO $ userError "Invalid control request"

837−

837+

838 -- Create a new connection

839− createdNewConnection :: LightweightConnectionId -> IO ()

839+ createdNewConnection :: LightweightConnectionId -> IO ()

840 createdNewConnection lcid = do

841 modifyMVar_ theirState $ \st -> do

842 vst <- case st of

843 RemoteEndPointInvalid _ ->

844− relyViolation (ourEndPoint, theirEndPoint)

844+ relyViolation (ourEndPoint, theirEndPoint)

845 "handleIncomingMessages:createNewConnection (invalid)"

846 RemoteEndPointInit _ _ _ ->

847− relyViolation (ourEndPoint, theirEndPoint)

847+ relyViolation (ourEndPoint, theirEndPoint)

848 "handleIncomingMessages:createNewConnection (init)"

849 RemoteEndPointValid vst ->

850 return ( (remoteIncoming ^: Set.insert lcid)

851− $ (remoteMaxIncoming ^= lcid)

851+ $ (remoteMaxIncoming ^= lcid)

852 vst

853 )

854 RemoteEndPointClosing resolved vst -> do

@@ -863,36 +863,36 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do

863 . (remoteMaxIncoming ^= lcid)

864 $ vst

865 )

866− RemoteEndPointFailed err ->

866+ RemoteEndPointFailed err ->

867 throwIO err

868 RemoteEndPointClosed ->

869− relyViolation (ourEndPoint, theirEndPoint)

869+ relyViolation (ourEndPoint, theirEndPoint)

870 "createNewConnection (closed)"

871 return (RemoteEndPointValid vst)

872− writeChan ourChannel (ConnectionOpened (connId lcid) ReliableOrdered theirAddr)

872+ writeChan ourChannel (ConnectionOpened (connId lcid) ReliableOrdered theirAddr)

873

874− -- Close a connection

874+ -- Close a connection

875 -- It is important that we verify that the connection is in fact open,

876 -- because otherwise we should not decrement the reference count

877− closeConnection :: LightweightConnectionId -> IO ()

877+ closeConnection :: LightweightConnectionId -> IO ()

878 closeConnection lcid = do

879 modifyMVar_ theirState $ \st -> case st of

880 RemoteEndPointInvalid _ ->

881 relyViolation (ourEndPoint, theirEndPoint) "closeConnection (invalid)"

882 RemoteEndPointInit _ _ _ ->

883 relyViolation (ourEndPoint, theirEndPoint) "closeConnection (init)"

884− RemoteEndPointValid vst -> do

884+ RemoteEndPointValid vst -> do

885− unless (Set.member lcid (vst ^. remoteIncoming)) $

885+ unless (Set.member lcid (vst ^. remoteIncoming)) $

886 throwIO $ userError "Invalid CloseConnection"

887− return ( RemoteEndPointValid

887+ return ( RemoteEndPointValid

888− . (remoteIncoming ^: Set.delete lcid)

888+ . (remoteIncoming ^: Set.delete lcid)

889 $ vst

890 )

891 RemoteEndPointClosing _ _ ->

892 -- If the remote endpoint is in Closing state, that means that are as

893 -- far as we are concerned there are no incoming connections. This

894 -- means that a CloseConnection request at this point is invalid.

895− throwIO $ userError "Invalid CloseConnection request"

895+ throwIO $ userError "Invalid CloseConnection request"

896 RemoteEndPointFailed err ->

897 throwIO err

898 RemoteEndPointClosed ->

@@ -900,7 +900,7 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do

900 writeChan ourChannel (ConnectionClosed (connId lcid))

901

902 -- Close the socket (if we don't have any outgoing connections)

903− closeSocket :: N.Socket -> LightweightConnectionId -> IO Bool

903+ closeSocket :: N.Socket -> LightweightConnectionId -> IO Bool

904 closeSocket sock lastReceivedId = do

905 mAct <- modifyMVar theirState $ \st -> do

906 case st of

@@ -908,38 +908,38 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do

908 relyViolation (ourEndPoint, theirEndPoint)

909 "handleIncomingMessages:closeSocket (invalid)"

910 RemoteEndPointInit _ _ _ ->

911− relyViolation (ourEndPoint, theirEndPoint)

911+ relyViolation (ourEndPoint, theirEndPoint)

912 "handleIncomingMessages:closeSocket (init)"

913 RemoteEndPointValid vst -> do

914 -- We regard a CloseSocket message as an (optimized) way for the

915 -- remote endpoint to indicate that all its connections to us are

916 -- now properly closed

917− forM_ (Set.elems $ vst ^. remoteIncoming) $

917+ forM_ (Set.elems $ vst ^. remoteIncoming) $

918 writeChan ourChannel . ConnectionClosed . connId

919− let vst' = remoteIncoming ^= Set.empty $ vst

919+ let vst' = remoteIncoming ^= Set.empty $ vst

920 -- If we still have outgoing connections then we ignore the

921 -- CloseSocket request (we sent a ConnectionCreated message to the

922 -- remote endpoint, but it did not receive it before sending the

923 -- CloseSocket request). Similarly, if lastReceivedId < lastSentId

924 -- then we sent a ConnectionCreated *AND* a ConnectionClosed

925 -- message to the remote endpoint, *both of which* it did not yet

926− -- receive before sending the CloseSocket request.

926+ -- receive before sending the CloseSocket request.

927− if vst' ^. remoteOutgoing > 0 || lastReceivedId < lastSentId vst

927+ if vst' ^. remoteOutgoing > 0 || lastReceivedId < lastSentId vst

928 then

929 return (RemoteEndPointValid vst', Nothing)

930− else do

930+ else do

931 removeRemoteEndPoint (ourEndPoint, theirEndPoint)

932 -- Attempt to reply (but don't insist)

933 act <- schedule theirEndPoint $ do

934 tryIO $ sendOn vst' [ encodeInt32 CloseSocket

935 , encodeInt32 (vst ^. remoteMaxIncoming)

936 ]

937− tryCloseSocket sock

937+ tryCloseSocket sock

938 return (RemoteEndPointClosed, Just act)

939 RemoteEndPointClosing resolved vst -> do

940 -- Like above, we need to check if there is a ConnectionCreated

941− -- message that we sent but that the remote endpoint has not yet

941+ -- message that we sent but that the remote endpoint has not yet

942− -- received. However, since we are in 'closing' state, the only

942+ -- received. However, since we are in 'closing' state, the only

943 -- way this may happen is when we sent a ConnectionCreated,

944 -- ConnectionClosed, and CloseSocket message, none of which have

945 -- yet been received. We leave the endpoint in closing state in

@@ -949,29 +949,29 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do

949 return (RemoteEndPointClosing resolved vst, Nothing)

950 else do

951 removeRemoteEndPoint (ourEndPoint, theirEndPoint)

952− act <- schedule theirEndPoint $ tryCloseSocket sock

952+ act <- schedule theirEndPoint $ tryCloseSocket sock

953 putMVar resolved ()

954 return (RemoteEndPointClosed, Just act)

955 RemoteEndPointFailed err ->

956 throwIO err

957 RemoteEndPointClosed ->

958− relyViolation (ourEndPoint, theirEndPoint)

958+ relyViolation (ourEndPoint, theirEndPoint)

959 "handleIncomingMessages:closeSocket (closed)"

960 case mAct of

961 Nothing -> return False

962 Just act -> do

963 runScheduledAction (ourEndPoint, theirEndPoint) act

964 return True

965−

965+

966 -- Read a message and output it on the endPoint's channel. By rights we

967 -- should verify that the connection ID is valid, but this is unnecessary

968 -- overhead

969− readMessage :: N.Socket -> LightweightConnectionId -> IO ()

969+ readMessage :: N.Socket -> LightweightConnectionId -> IO ()

970− readMessage sock lcid =

970+ readMessage sock lcid =

971− recvWithLength sock >>= writeChan ourChannel . Received (connId lcid)

971+ recvWithLength sock >>= writeChan ourChannel . Received (connId lcid)

972

973 -- Arguments

974− ourChannel = localChannel ourEndPoint

974+ ourChannel = localChannel ourEndPoint

975 theirState = remoteState theirEndPoint

976 theirAddr = remoteAddress theirEndPoint

977

@@ -982,20 +982,20 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do

982 modifyMVar_ theirState $ \st ->

983 case st of

984 RemoteEndPointInvalid _ ->

985− relyViolation (ourEndPoint, theirEndPoint)

985+ relyViolation (ourEndPoint, theirEndPoint)

986 "handleIncomingMessages:prematureExit"

987 RemoteEndPointInit _ _ _ ->

988− relyViolation (ourEndPoint, theirEndPoint)

988+ relyViolation (ourEndPoint, theirEndPoint)

989 "handleIncomingMessages:prematureExit"

990 RemoteEndPointValid _ -> do

991− let code = EventConnectionLost (remoteAddress theirEndPoint)

991+ let code = EventConnectionLost (remoteAddress theirEndPoint)

992 writeChan ourChannel . ErrorEvent $ TransportError code (show err)

993 return (RemoteEndPointFailed err)

994 RemoteEndPointClosing resolved _ -> do

995 putMVar resolved ()

996 return (RemoteEndPointFailed err)

997 RemoteEndPointClosed ->

998− relyViolation (ourEndPoint, theirEndPoint)

998+ relyViolation (ourEndPoint, theirEndPoint)

999 "handleIncomingMessages:prematureExit"

1000 RemoteEndPointFailed err' ->

1001 return (RemoteEndPointFailed err')

@@ -1006,7 +1006,7 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do

1006

1007 -- The ID of the last connection _we_ created (or 0 for none)

1008 lastSentId :: ValidRemoteEndPointState -> LightweightConnectionId

1009− lastSentId vst =

1009+ lastSentId vst =

1010 if vst ^. remoteNextConnOutId == firstNonReservedLightweightConnectionId

1011 then 0

1012 else (vst ^. remoteNextConnOutId) - 1

@@ -1021,12 +1021,12 @@ handleIncomingMessages (ourEndPoint, theirEndPoint) = do

1021-- | Create a connection to a remote endpoint

1022--

1023-- If the remote endpoint is in 'RemoteEndPointClosing' state then we will

1024−-- block until that is resolved.

1024+-- block until that is resolved.

1025--

1026-- May throw a TransportError ConnectErrorCode exception.

1027−createConnectionTo :: TCPParameters

1027+createConnectionTo :: TCPParameters

1028− -> LocalEndPoint

1028+ -> LocalEndPoint

1029− -> EndPointAddress

1029+ -> EndPointAddress

1030 -> ConnectHints

1031 -> IO (RemoteEndPoint, LightweightConnectionId)

1032createConnectionTo params ourEndPoint theirAddress hints = go

@@ -1035,27 +1035,27 @@ createConnectionTo params ourEndPoint theirAddress hints = go

1035 (theirEndPoint, isNew) <- mapIOException connectFailed $

1036 findRemoteEndPoint ourEndPoint theirAddress RequestedByUs

1037

1038− if isNew

1038+ if isNew

1039 then do

1040− forkIO . handle absorbAllExceptions $

1040+ forkIO . handle absorbAllExceptions $

1041− setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints

1041+ setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints

1042 go

1043 else do

1044 -- 'findRemoteEndPoint' will have increased 'remoteOutgoing'

1045 mapIOException connectFailed $ do

1046 act <- modifyMVar (remoteState theirEndPoint) $ \st -> case st of

1047− RemoteEndPointValid vst -> do

1047+ RemoteEndPointValid vst -> do

1048− let connId = vst ^. remoteNextConnOutId

1048+ let connId = vst ^. remoteNextConnOutId

1049 act <- schedule theirEndPoint $ do

1050 sendOn vst [encodeInt32 CreatedNewConnection, encodeInt32 connId]

1051 return connId

1052− return ( RemoteEndPointValid

1052+ return ( RemoteEndPointValid

1053− $ remoteNextConnOutId ^= connId + 1

1053+ $ remoteNextConnOutId ^= connId + 1

1054 $ vst

1055− , act

1055+ , act

1056 )

1057 -- Error cases

1058− RemoteEndPointInvalid err ->

1058+ RemoteEndPointInvalid err ->

1059 throwIO err

1060 RemoteEndPointFailed err ->

1061 throwIO err

@@ -1065,32 +1065,32 @@ createConnectionTo params ourEndPoint theirAddress hints = go

1065 -- TODO: deal with exception case?

1066 connId <- runScheduledAction (ourEndPoint, theirEndPoint) act

1067 return (theirEndPoint, connId)

1068−

1068+

1069

1070 connectFailed :: IOException -> TransportError ConnectErrorCode

1071 connectFailed = TransportError ConnectFailed . show

1072

1073 absorbAllExceptions :: SomeException -> IO ()

1074− absorbAllExceptions _ex =

1074+ absorbAllExceptions _ex =

1075 return ()

1076

1077-- | Set up a remote endpoint

1078−setupRemoteEndPoint :: TCPParameters -> EndPointPair -> ConnectHints -> IO ()

1078+setupRemoteEndPoint :: TCPParameters -> EndPointPair -> ConnectHints -> IO ()

1079setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do

1080− result <- socketToEndPoint ourAddress

1080+ result <- socketToEndPoint ourAddress

1081− theirAddress

1081+ theirAddress

1082 (tcpReuseClientAddr params)

1083 (connectTimeout hints)

1084 didAccept <- case result of

1085− Right (sock, ConnectionRequestAccepted) -> do

1085+ Right (sock, ConnectionRequestAccepted) -> do

1086− sendLock <- newMVar ()

1086+ sendLock <- newMVar ()

1087− let vst = ValidRemoteEndPointState

1087+ let vst = ValidRemoteEndPointState

1088 { remoteSocket = sock

1089 , remoteSendLock = sendLock

1090− , _remoteOutgoing = 0

1090+ , _remoteOutgoing = 0

1091 , _remoteIncoming = Set.empty

1092 , _remoteMaxIncoming = 0

1093− , _remoteNextConnOutId = firstNonReservedLightweightConnectionId

1093+ , _remoteNextConnOutId = firstNonReservedLightweightConnectionId

1094 }

1095 resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointValid vst)

1096 return True

@@ -1101,7 +1101,7 @@ setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do

1101 return False

1102 Right (sock, ConnectionRequestCrossed) -> do

1103 withMVar (remoteState theirEndPoint) $ \st -> case st of

1104− RemoteEndPointInit _ crossed _ ->

1104+ RemoteEndPointInit _ crossed _ ->

1105 putMVar crossed ()

1106 RemoteEndPointFailed ex ->

1107 throwIO ex

@@ -1109,11 +1109,11 @@ setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do

1109 relyViolation (ourEndPoint, theirEndPoint) "setupRemoteEndPoint: Crossed"

1110 tryCloseSocket sock

1111 return False

1112− Left err -> do

1112+ Left err -> do

1113 resolveInit (ourEndPoint, theirEndPoint) (RemoteEndPointInvalid err)

1114 return False

1115

1116− when didAccept $ handleIncomingMessages (ourEndPoint, theirEndPoint)

1116+ when didAccept $ handleIncomingMessages (ourEndPoint, theirEndPoint)

1117 where

1118 ourAddress = localAddress ourEndPoint

1119 theirAddress = remoteAddress theirEndPoint

@@ -1121,23 +1121,23 @@ setupRemoteEndPoint params (ourEndPoint, theirEndPoint) hints = do

1121

1122-- | Send a CloseSocket request if the remote endpoint is unused

1123closeIfUnused :: EndPointPair -> IO ()

1124−closeIfUnused (ourEndPoint, theirEndPoint) = do

1124+closeIfUnused (ourEndPoint, theirEndPoint) = do

1125 mAct <- modifyMVar (remoteState theirEndPoint) $ \st -> case st of

1126 RemoteEndPointValid vst ->

1127− if vst ^. remoteOutgoing == 0 && Set.null (vst ^. remoteIncoming)

1127+ if vst ^. remoteOutgoing == 0 && Set.null (vst ^. remoteIncoming)

1128− then do

1128+ then do

1129 resolved <- newEmptyMVar

1130− act <- schedule theirEndPoint $

1130+ act <- schedule theirEndPoint $

1131 sendOn vst [ encodeInt32 CloseSocket

1132 , encodeInt32 (vst ^. remoteMaxIncoming)

1133 ]

1134 return (RemoteEndPointClosing resolved vst, Just act)

1135− else

1135+ else

1136 return (RemoteEndPointValid vst, Nothing)

1137 _ ->

1138 return (st, Nothing)

1139− forM_ mAct $ runScheduledAction (ourEndPoint, theirEndPoint)

1139+ forM_ mAct $ runScheduledAction (ourEndPoint, theirEndPoint)

1140−

1140+

1141-- | Reset a remote endpoint if it is in Invalid mode

1142--

1143-- If the remote endpoint is currently in broken state, and

@@ -1156,7 +1156,7 @@ resetIfBroken ourEndPoint theirAddress = do

1156 return (vst ^. localConnectionTo theirAddress)

1157 LocalEndPointClosed ->

1158 throwIO $ TransportError ConnectFailed "Endpoint closed"

1159− forM_ mTheirEndPoint $ \theirEndPoint ->

1159+ forM_ mTheirEndPoint $ \theirEndPoint ->

1160 withMVar (remoteState theirEndPoint) $ \st -> case st of

1161 RemoteEndPointInvalid _ ->

1162 removeRemoteEndPoint (ourEndPoint, theirEndPoint)

@@ -1166,26 +1166,26 @@ resetIfBroken ourEndPoint theirAddress = do

1166 return ()

1167

1168-- | Special case of 'apiConnect': connect an endpoint to itself

1169−--

1169+--

1170-- May throw a TransportError ConnectErrorCode (if the local endpoint is closed)

1171−connectToSelf :: LocalEndPoint

1171+connectToSelf :: LocalEndPoint

1172 -> IO Connection

1173−connectToSelf ourEndPoint = do

1173+connectToSelf ourEndPoint = do

1174 connAlive <- newIORef True -- Protected by the local endpoint lock

1175− lconnId <- mapIOException connectFailed $ getLocalNextConnOutId ourEndPoint

1175+ lconnId <- mapIOException connectFailed $ getLocalNextConnOutId ourEndPoint

1176 let connId = createConnectionId heavyweightSelfConnectionId lconnId

1177 writeChan ourChan $

1178 ConnectionOpened connId ReliableOrdered (localAddress ourEndPoint)

1179− return Connection

1179+ return Connection

1180− { send = selfSend connAlive connId

1180+ { send = selfSend connAlive connId

1181 , close = selfClose connAlive connId

1182 }

1183 where

1184− selfSend :: IORef Bool

1184+ selfSend :: IORef Bool

1185− -> ConnectionId

1185+ -> ConnectionId

1186− -> [ByteString]

1186+ -> [ByteString]

1187 -> IO (Either (TransportError SendErrorCode) ())

1188− selfSend connAlive connId msg =

1188+ selfSend connAlive connId msg =

1189 try . withMVar ourState $ \st -> case st of

1190 LocalEndPointValid _ -> do

1191 alive <- readIORef connAlive

@@ -1196,19 +1196,19 @@ connectToSelf ourEndPoint = do

1196 throwIO $ TransportError SendFailed "Endpoint closed"

1197

1198 selfClose :: IORef Bool -> ConnectionId -> IO ()

1199− selfClose connAlive connId =

1199+ selfClose connAlive connId =

1200 withMVar ourState $ \st -> case st of

1201 LocalEndPointValid _ -> do

1202 alive <- readIORef connAlive

1203 when alive $ do

1204− writeChan ourChan (ConnectionClosed connId)

1204+ writeChan ourChan (ConnectionClosed connId)

1205 writeIORef connAlive False

1206 LocalEndPointClosed ->

1207− return ()

1207+ return ()

1208

1209 ourChan = localChannel ourEndPoint

1210 ourState = localState ourEndPoint

1211− connectFailed = TransportError ConnectFailed . show

1211+ connectFailed = TransportError ConnectFailed . show

1212

1213-- | Resolve an endpoint currently in 'Init' state

1214resolveInit :: EndPointPair -> RemoteState -> IO ()

@@ -1216,57 +1216,57 @@ resolveInit (ourEndPoint, theirEndPoint) newState =

1216 modifyMVar_ (remoteState theirEndPoint) $ \st -> case st of

1217 RemoteEndPointInit resolved _ _ -> do

1218 putMVar resolved ()

1219− case newState of

1219+ case newState of

1220− RemoteEndPointClosed ->

1220+ RemoteEndPointClosed ->

1221 removeRemoteEndPoint (ourEndPoint, theirEndPoint)

1222 _ ->

1223 return ()

1224 return newState

1225− RemoteEndPointFailed ex ->

1225+ RemoteEndPointFailed ex ->

1226 throwIO ex

1227 _ ->

1228 relyViolation (ourEndPoint, theirEndPoint) "resolveInit"

1229

1230-- | Get the next outgoing self-connection ID

1231−--

1231+--

1232-- Throws an IO exception when the endpoint is closed.

1233getLocalNextConnOutId :: LocalEndPoint -> IO LightweightConnectionId

1234−getLocalNextConnOutId ourEndpoint =

1234+getLocalNextConnOutId ourEndpoint =

1235 modifyMVar (localState ourEndpoint) $ \st -> case st of

1236 LocalEndPointValid vst -> do

1237− let connId = vst ^. localNextConnOutId

1237+ let connId = vst ^. localNextConnOutId

1238− return ( LocalEndPointValid

1238+ return ( LocalEndPointValid

1239− . (localNextConnOutId ^= connId + 1)

1239+ . (localNextConnOutId ^= connId + 1)

1240 $ vst

1241 , connId)

1242 LocalEndPointClosed ->

1243 throwIO $ userError "Local endpoint closed"

1244

1245-- | Create a new local endpoint

1246−--

1246+--

1247-- May throw a TransportError NewEndPointErrorCode exception if the transport

1248-- is closed.

1249createLocalEndPoint :: TCPTransport -> IO LocalEndPoint

1250−createLocalEndPoint transport = do

1250+createLocalEndPoint transport = do

1251 chan <- newChan

1252− state <- newMVar . LocalEndPointValid $ ValidLocalEndPointState

1252+ state <- newMVar . LocalEndPointValid $ ValidLocalEndPointState

1253 { _localNextConnOutId = firstNonReservedLightweightConnectionId

1254 , _localConnections = Map.empty

1255− , _nextConnInId = firstNonReservedHeavyweightConnectionId

1255+ , _nextConnInId = firstNonReservedHeavyweightConnectionId

1256 }

1257 modifyMVar (transportState transport) $ \st -> case st of

1258 TransportValid vst -> do

1259 let ix = vst ^. nextEndPointId

1260− let addr = encodeEndPointAddress (transportHost transport)

1260+ let addr = encodeEndPointAddress (transportHost transport)

1261 (transportPort transport)

1262− ix

1262+ ix

1263 let localEndPoint = LocalEndPoint { localAddress = addr

1264 , localChannel = chan

1265 , localState = state

1266 }

1267− return ( TransportValid

1267+ return ( TransportValid

1268− . (localEndPointAt addr ^= Just localEndPoint)

1268+ . (localEndPointAt addr ^= Just localEndPoint)

1269− . (nextEndPointId ^= ix + 1)

1269+ . (nextEndPointId ^= ix + 1)

1270 $ vst

1271 , localEndPoint

1272 )

@@ -1282,13 +1282,13 @@ removeRemoteEndPoint (ourEndPoint, theirEndPoint) =

1282 modifyMVar_ ourState $ \st -> case st of

1283 LocalEndPointValid vst ->

1284 case vst ^. localConnectionTo theirAddress of

1285− Nothing ->

1285+ Nothing ->

1286 return st

1287 Just remoteEndPoint' ->

1288− if remoteId remoteEndPoint' == remoteId theirEndPoint

1288+ if remoteId remoteEndPoint' == remoteId theirEndPoint

1289− then return

1289+ then return

1290− ( LocalEndPointValid

1290+ ( LocalEndPointValid

1291− . (localConnectionTo (remoteAddress theirEndPoint) ^= Nothing)

1291+ . (localConnectionTo (remoteAddress theirEndPoint) ^= Nothing)

1292 $ vst

1293 )

1294 else return st

@@ -1302,23 +1302,23 @@ removeRemoteEndPoint (ourEndPoint, theirEndPoint) =

1302--

1303-- Does nothing if the transport is closed

1304removeLocalEndPoint :: TCPTransport -> LocalEndPoint -> IO ()

1305−removeLocalEndPoint transport ourEndPoint =

1305+removeLocalEndPoint transport ourEndPoint =

1306− modifyMVar_ (transportState transport) $ \st -> case st of

1306+ modifyMVar_ (transportState transport) $ \st -> case st of

1307 TransportValid vst ->

1308− return ( TransportValid

1308+ return ( TransportValid

1309− . (localEndPointAt (localAddress ourEndPoint) ^= Nothing)

1309+ . (localEndPointAt (localAddress ourEndPoint) ^= Nothing)

1310 $ vst

1311 )

1312 TransportClosed ->

1313 return TransportClosed

1314

1315-- | Find a remote endpoint. If the remote endpoint does not yet exist we

1316−-- create it in Init state. Returns if the endpoint was new.

1316+-- create it in Init state. Returns if the endpoint was new.

1317−findRemoteEndPoint

1317+findRemoteEndPoint

1318 :: LocalEndPoint

1319 -> EndPointAddress

1320− -> RequestedBy

1320+ -> RequestedBy

1321− -> IO (RemoteEndPoint, Bool)

1321+ -> IO (RemoteEndPoint, Bool)

1322findRemoteEndPoint ourEndPoint theirAddress findOrigin = go

1323 where

1324 go = do

@@ -1335,55 +1335,55 @@ findRemoteEndPoint ourEndPoint theirAddress findOrigin = go

1335 { remoteAddress = theirAddress

1336 , remoteState = theirState

1337 , remoteId = vst ^. nextConnInId

1338− , remoteScheduled = scheduled

1338+ , remoteScheduled = scheduled

1339 }

1340− return ( LocalEndPointValid

1340+ return ( LocalEndPointValid

1341− . (localConnectionTo theirAddress ^= Just theirEndPoint)

1341+ . (localConnectionTo theirAddress ^= Just theirEndPoint)

1342− . (nextConnInId ^: (+ 1))

1342+ . (nextConnInId ^: (+ 1))

1343 $ vst

1344− , (theirEndPoint, True)

1344+ , (theirEndPoint, True)

1345 )

1346 LocalEndPointClosed ->

1347 throwIO $ userError "Local endpoint closed"

1348−

1348+

1349− if isNew

1349+ if isNew

1350 then

1351 return (theirEndPoint, True)

1352 else do

1353 let theirState = remoteState theirEndPoint

1354 snapshot <- modifyMVar theirState $ \st -> case st of

1355− RemoteEndPointValid vst ->

1355+ RemoteEndPointValid vst ->

1356 case findOrigin of

1357 RequestedByUs -> do

1358− let st' = RemoteEndPointValid

1358+ let st' = RemoteEndPointValid

1359− . (remoteOutgoing ^: (+ 1))

1359+ . (remoteOutgoing ^: (+ 1))

1360− $ vst

1360+ $ vst

1361 return (st', st')

1362 RequestedByThem ->

1363− return (st, st)

1363+ return (st, st)

1364 _ ->

1365 return (st, st)

1366 -- The snapshot may no longer be up to date at this point, but if we

1367− -- increased the refcount then it can only either be Valid or Failed

1367+ -- increased the refcount then it can only either be Valid or Failed

1368− -- (after an explicit call to 'closeEndPoint' or 'closeTransport')

1368+ -- (after an explicit call to 'closeEndPoint' or 'closeTransport')

1369 case snapshot of

1370 RemoteEndPointInvalid err ->

1371 throwIO err

1372 RemoteEndPointInit resolved crossed initOrigin ->

1373 case (findOrigin, initOrigin) of

1374− (RequestedByUs, RequestedByUs) ->

1374+ (RequestedByUs, RequestedByUs) ->

1375− readMVar resolved >> go

1376− (RequestedByUs, RequestedByThem) ->

1377 readMVar resolved >> go

1375 readMVar resolved >> go

1376+ (RequestedByUs, RequestedByThem) ->

1377+ readMVar resolved >> go

1378− (RequestedByThem, RequestedByUs) ->

1378+ (RequestedByThem, RequestedByUs) ->

1379− if ourAddress > theirAddress

1379+ if ourAddress > theirAddress

1380 then do

1381 -- Wait for the Crossed message

1382− readMVar crossed

1382+ readMVar crossed

1383 return (theirEndPoint, True)

1384 else

1385 return (theirEndPoint, False)

1386− (RequestedByThem, RequestedByThem) ->

1386+ (RequestedByThem, RequestedByThem) ->

1387 throwIO $ userError "Already connected"

1388 RemoteEndPointValid _ ->

1389 -- We assume that the request crossed if we find the endpoint in

@@ -1395,15 +1395,15 @@ findRemoteEndPoint ourEndPoint theirAddress findOrigin = go

1395 readMVar resolved >> go

1396 RemoteEndPointClosed ->

1397 go

1398− RemoteEndPointFailed err ->

1398+ RemoteEndPointFailed err ->

1399 throwIO err

1400−

1400+

1401− ourState = localState ourEndPoint

1401+ ourState = localState ourEndPoint

1402 ourAddress = localAddress ourEndPoint

1403

1404-- | Send a payload over a heavyweight connection (thread safe)

1405−sendOn :: ValidRemoteEndPointState -> [ByteString] -> IO ()

1405+sendOn :: ValidRemoteEndPointState -> [ByteString] -> IO ()

1406−sendOn vst bs = withMVar (remoteSendLock vst) $ \() ->

1406+sendOn vst bs = withMVar (remoteSendLock vst) $ \() ->

1407 sendMany (remoteSocket vst) bs

1408

1409--------------------------------------------------------------------------------

@@ -1417,7 +1417,7 @@ type Action a = MVar (Either SomeException a)

1417schedule :: RemoteEndPoint -> IO a -> IO (Action a)

1418schedule theirEndPoint act = do

1419 mvar <- newEmptyMVar

1420− writeChan (remoteScheduled theirEndPoint) $

1420+ writeChan (remoteScheduled theirEndPoint) $

1421 catch (act >>= putMVar mvar . Right) (putMVar mvar . Left)

1422 return mvar

1423

@@ -1429,7 +1429,7 @@ schedule theirEndPoint act = do

1429-- > runScheduledAction

1430--

1431-- 'runScheduledAction' will run @p@ (it might run some other scheduled action).

1432−-- However, it will then wait until @p@ is executed (by this call to

1432+-- However, it will then wait until @p@ is executed (by this call to

1433-- 'runScheduledAction' or by another).

1434runScheduledAction :: EndPointPair -> Action a -> IO a

1435runScheduledAction (ourEndPoint, theirEndPoint) mvar = do

@@ -1438,21 +1438,21 @@ runScheduledAction (ourEndPoint, theirEndPoint) mvar = do

1438 case ma of

1439 Right a -> return a

1440 Left e -> do

1441− forM_ (fromException e) $ \ioe ->

1441+ forM_ (fromException e) $ \ioe ->

1442 modifyMVar_ (remoteState theirEndPoint) $ \st ->

1443− case st of

1443+ case st of

1444 RemoteEndPointValid vst -> handleIOException ioe vst

1445 _ -> return (RemoteEndPointFailed ioe)

1446 throwIO e

1447 where

1448− handleIOException :: IOException

1448+ handleIOException :: IOException

1449− -> ValidRemoteEndPointState

1449+ -> ValidRemoteEndPointState

1450− -> IO RemoteState

1450+ -> IO RemoteState

1451 handleIOException ex vst = do

1452 tryCloseSocket (remoteSocket vst)

1453− let code = EventConnectionLost (remoteAddress theirEndPoint)

1453+ let code = EventConnectionLost (remoteAddress theirEndPoint)

1454 err = TransportError code (show ex)

1455− writeChan (localChannel ourEndPoint) $ ErrorEvent err

1455+ writeChan (localChannel ourEndPoint) $ ErrorEvent err

1456 return (RemoteEndPointFailed ex)

1457

1458--------------------------------------------------------------------------------

@@ -1462,25 +1462,25 @@ runScheduledAction (ourEndPoint, theirEndPoint) mvar = do

1462-- | Establish a connection to a remote endpoint

1463--

1464-- Maybe throw a TransportError

1465−socketToEndPoint :: EndPointAddress -- ^ Our address

1465+socketToEndPoint :: EndPointAddress -- ^ Our address

1466 -> EndPointAddress -- ^ Their address

1467 -> Bool -- ^ Use SO_REUSEADDR?

1468− -> Maybe Int -- ^ Timeout for connect

1468+ -> Maybe Int -- ^ Timeout for connect

1469− -> IO (Either (TransportError ConnectErrorCode)

1469+ -> IO (Either (TransportError ConnectErrorCode)

1470− (N.Socket, ConnectionRequestResponse))

1470+ (N.Socket, ConnectionRequestResponse))

1471−socketToEndPoint (EndPointAddress ourAddress) theirAddress reuseAddr timeout =

1471+socketToEndPoint (EndPointAddress ourAddress) theirAddress reuseAddr timeout =

1472− try $ do

1472+ try $ do

1473− (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of

1473+ (host, port, theirEndPointId) <- case decodeEndPointAddress theirAddress of

1474 Nothing -> throwIO (failed . userError $ "Could not parse")

1475 Just dec -> return dec

1476− addr:_ <- mapIOException invalidAddress $

1476+ addr:_ <- mapIOException invalidAddress $

1477 N.getAddrInfo Nothing (Just host) (Just port)

1478 bracketOnError (createSocket addr) tryCloseSocket $ \sock -> do

1479− when reuseAddr $

1479+ when reuseAddr $

1480 mapIOException failed $ N.setSocketOption sock N.ReuseAddr 1

1481− mapIOException invalidAddress $

1481+ mapIOException invalidAddress $

1482− timeoutMaybe timeout timeoutError $

1482+ timeoutMaybe timeout timeoutError $

1483− N.connect sock (N.addrAddress addr)

1483+ N.connect sock (N.addrAddress addr)

1484 response <- mapIOException failed $ do

1485 sendMany sock (encodeInt32 theirEndPointId : prependLength [ourAddress])

1486 recvInt32 sock

@@ -1489,50 +1489,50 @@ socketToEndPoint (EndPointAddress ourAddress) theirAddress reuseAddr timeout =

1489 Just r -> return (sock, r)

1490 where

1491 createSocket :: N.AddrInfo -> IO N.Socket

1492− createSocket addr = mapIOException insufficientResources $

1492+ createSocket addr = mapIOException insufficientResources $

1493 N.socket (N.addrFamily addr) N.Stream N.defaultProtocol

1494

1495− invalidAddress = TransportError ConnectNotFound . show

1495+ invalidAddress = TransportError ConnectNotFound . show

1496− insufficientResources = TransportError ConnectInsufficientResources . show

1496+ insufficientResources = TransportError ConnectInsufficientResources . show

1497 failed = TransportError ConnectFailed . show

1498 timeoutError = TransportError ConnectTimeout "Timed out"

1499

1500-- | Encode end point address

1501−encodeEndPointAddress :: N.HostName

1501+encodeEndPointAddress :: N.HostName

1502− -> N.ServiceName

1502+ -> N.ServiceName

1503− -> EndPointId

1503+ -> EndPointId

1504 -> EndPointAddress

1505encodeEndPointAddress host port ix = EndPointAddress . BSC.pack $

1506− host ++ ":" ++ port ++ ":" ++ show ix

1506+ host ++ ":" ++ port ++ ":" ++ show ix

1507

1508-- | Decode end point address

1509−decodeEndPointAddress :: EndPointAddress

1509+decodeEndPointAddress :: EndPointAddress

1510 -> Maybe (N.HostName, N.ServiceName, EndPointId)

1511−decodeEndPointAddress (EndPointAddress bs) =

1511+decodeEndPointAddress (EndPointAddress bs) =

1512 case splitMaxFromEnd (== ':') 2 $ BSC.unpack bs of

1513− [host, port, endPointIdStr] ->

1513+ [host, port, endPointIdStr] ->

1514− case reads endPointIdStr of

1514+ case reads endPointIdStr of

1515 [(endPointId, "")] -> Just (host, port, endPointId)

1516 _ -> Nothing

1517 _ ->

1518 Nothing

1519

1520-- | Construct a ConnectionId

1521−createConnectionId :: HeavyweightConnectionId

1521+createConnectionId :: HeavyweightConnectionId

1522− -> LightweightConnectionId

1522+ -> LightweightConnectionId

1523 -> ConnectionId

1524−createConnectionId hcid lcid =

1524+createConnectionId hcid lcid =

1525 (fromIntegral hcid `shiftL` 32) .|. fromIntegral lcid

1526

1527-- | @spltiMaxFromEnd p n xs@ splits list @xs@ at elements matching @p@,

1528-- returning at most @p@ segments -- counting from the /end/

1529−--

1529+--

1530-- > splitMaxFromEnd (== ':') 2 "ab:cd:ef:gh" == ["ab:cd", "ef", "gh"]

1531splitMaxFromEnd :: (a -> Bool) -> Int -> [a] -> [[a]]

1532−splitMaxFromEnd p = \n -> go [[]] n . reverse

1532+splitMaxFromEnd p = \n -> go [[]] n . reverse

1533 where

1534 -- go :: [[a]] -> Int -> [a] -> [[a]]

1535− go accs _ [] = accs

1535+ go accs _ [] = accs

1536 go ([] : accs) 0 xs = reverse xs : accs

1537 go (acc : accs) n (x:xs) =

1538 if p x then go ([] : acc : accs) (n - 1) xs

@@ -1544,40 +1544,40 @@ splitMaxFromEnd p = \n -> go [[]] n . reverse

1544--------------------------------------------------------------------------------

1545

1546-- Find a socket between two endpoints

1547−--

1547+--

1548-- Throws an IO exception if the socket could not be found.

1549−internalSocketBetween :: TCPTransport -- ^ Transport

1549+internalSocketBetween :: TCPTransport -- ^ Transport

1550 -> EndPointAddress -- ^ Local endpoint

1551 -> EndPointAddress -- ^ Remote endpoint

1552− -> IO N.Socket

1552+ -> IO N.Socket

1553internalSocketBetween transport ourAddress theirAddress = do

1554 ourEndPoint <- withMVar (transportState transport) $ \st -> case st of

1555− TransportClosed ->

1555+ TransportClosed ->

1556− throwIO $ userError "Transport closed"

1556+ throwIO $ userError "Transport closed"

1557− TransportValid vst ->

1557+ TransportValid vst ->

1558 case vst ^. localEndPointAt ourAddress of

1559 Nothing -> throwIO $ userError "Local endpoint not found"

1560 Just ep -> return ep

1561 theirEndPoint <- withMVar (localState ourEndPoint) $ \st -> case st of

1562 LocalEndPointClosed ->

1563 throwIO $ userError "Local endpoint closed"

1564− LocalEndPointValid vst ->

1564+ LocalEndPointValid vst ->

1565 case vst ^. localConnectionTo theirAddress of

1566 Nothing -> throwIO $ userError "Remote endpoint not found"

1567 Just ep -> return ep

1568 withMVar (remoteState theirEndPoint) $ \st -> case st of

1569 RemoteEndPointInit _ _ _ ->

1570 throwIO $ userError "Remote endpoint not yet initialized"

1571− RemoteEndPointValid vst ->

1571+ RemoteEndPointValid vst ->

1572 return $ remoteSocket vst

1573 RemoteEndPointClosing _ vst ->

1574− return $ remoteSocket vst

1574+ return $ remoteSocket vst

1575 RemoteEndPointClosed ->

1576 throwIO $ userError "Remote endpoint closed"

1577 RemoteEndPointInvalid err ->

1578− throwIO err

1578+ throwIO err

1579 RemoteEndPointFailed err ->

1580− throwIO err

1580+ throwIO err

1581

1582--------------------------------------------------------------------------------

1583-- Constants --

@@ -1611,7 +1611,7 @@ localNextConnOutId = accessor _localNextConnOutId (\cix st -> st { _localNextCon

1611localConnections :: Accessor ValidLocalEndPointState (Map EndPointAddress RemoteEndPoint)

1612localConnections = accessor _localConnections (\es st -> st { _localConnections = es })

1613

1614−nextConnInId :: Accessor ValidLocalEndPointState HeavyweightConnectionId

1614+nextConnInId :: Accessor ValidLocalEndPointState HeavyweightConnectionId

1615nextConnInId = accessor _nextConnInId (\rid st -> st { _nextConnInId = rid })

1616

1617remoteOutgoing :: Accessor ValidRemoteEndPointState Int

@@ -1627,10 +1627,10 @@ remoteNextConnOutId :: Accessor ValidRemoteEndPointState LightweightConnectionId

1627remoteNextConnOutId = accessor _remoteNextConnOutId (\cix st -> st { _remoteNextConnOutId = cix })

1628

1629localEndPointAt :: EndPointAddress -> Accessor ValidTransportState (Maybe LocalEndPoint)

1630−localEndPointAt addr = localEndPoints >>> DAC.mapMaybe addr

1630+localEndPointAt addr = localEndPoints >>> DAC.mapMaybe addr

1631

1632localConnectionTo :: EndPointAddress -> Accessor ValidLocalEndPointState (Maybe RemoteEndPoint)

1633−localConnectionTo addr = localConnections >>> DAC.mapMaybe addr

1633+localConnectionTo addr = localConnections >>> DAC.mapMaybe addr

1634

1635-------------------------------------------------------------------------------

1636-- Debugging --

@@ -1638,14 +1638,14 @@ localConnectionTo addr = localConnections >>> DAC.mapMaybe addr

1638

1639relyViolation :: EndPointPair -> String -> IO a

1640relyViolation (ourEndPoint, theirEndPoint) str = do

1641− elog (ourEndPoint, theirEndPoint) (str ++ " RELY violation")

1641+ elog (ourEndPoint, theirEndPoint) (str ++ " RELY violation")

1642 fail (str ++ " RELY violation")

1643

1644elog :: EndPointPair -> String -> IO ()

1645elog (ourEndPoint, theirEndPoint) msg = do

1646 tid <- myThreadId

1647− putStrLn $ show (localAddress ourEndPoint)

1647+ putStrLn $ show (localAddress ourEndPoint)

1648− ++ "/" ++ show (remoteAddress theirEndPoint)

1648+ ++ "/" ++ show (remoteAddress theirEndPoint)

1649 ++ "(" ++ show (remoteId theirEndPoint) ++ ")"

1650− ++ "/" ++ show tid

1650+ ++ "/" ++ show tid

1651 ++ ": " ++ msg

network-transport-tcp/src/Network/Transport/TCP/Internal.hs+22−22

@@ -1,8 +1,8 @@

1−-- | Utility functions for TCP sockets

1+-- | Utility functions for TCP sockets

2−module Network.Transport.TCP.Internal

2+module Network.Transport.TCP.Internal

3 ( forkServer

4 , recvWithLength

5− , recvExact

5+ , recvExact

6 , recvInt32

7 , tryCloseSocket

8 ) where

@@ -16,7 +16,7 @@ import Network.Transport.Internal (decodeInt32, void, tryIO, forkIOWithUnmask)

16#ifdef USE_MOCK_NETWORK

17import qualified Network.Transport.TCP.Mock.Socket as N

18#else

19−import qualified Network.Socket as N

19+import qualified Network.Socket as N

20#endif

21 ( HostName

22 , ServiceName

@@ -49,10 +49,10 @@ import Control.Applicative ((<$>))

49import Data.ByteString (ByteString)

50import qualified Data.ByteString as BS (length, concat, null)

51import Data.Int (Int32)

52−import Data.ByteString.Lazy.Internal (smallChunkSize)

52+import Data.ByteString.Lazy.Internal (smallChunkSize)

54-- | Start a server at the specified address.

55−--

55+--

56-- This sets up a server socket for the specified host and port. Exceptions

57-- thrown during setup are not caught.

58--

@@ -67,15 +67,15 @@ import Data.ByteString.Lazy.Internal (smallChunkSize)

67-- The request handler should spawn threads to handle each individual request

68-- or the server will block. Once a thread has been spawned it will be the

69-- responsibility of the new thread to close the socket when an exception

70−-- occurs.

70+-- occurs.

71forkServer :: N.HostName -- ^ Host

72− -> N.ServiceName -- ^ Port

72+ -> N.ServiceName -- ^ Port

73 -> Int -- ^ Backlog (maximum number of queued connections)

74 -> Bool -- ^ Set ReuseAddr option?

75 -> (SomeException -> IO ()) -- ^ Termination handler

76− -> (N.Socket -> IO ()) -- ^ Request handler

76+ -> (N.Socket -> IO ()) -- ^ Request handler

77 -> IO ThreadId

78−forkServer host port backlog reuseAddr terminationHandler requestHandler = do

78+forkServer host port backlog reuseAddr terminationHandler requestHandler = do

79 -- Resolve the specified address. By specification, getAddrInfo will never

80 -- return an empty list (but will throw an exception instead) and will return

81 -- the "best" address first, whatever that means

@@ -84,14 +84,14 @@ forkServer host port backlog reuseAddr terminationHandler requestHandler = do

84 tryCloseSocket $ \sock -> do

85 when reuseAddr $ N.setSocketOption sock N.ReuseAddr 1

86 N.bindSocket sock (N.addrAddress addr)

87− N.listen sock backlog

87+ N.listen sock backlog

88 -- We start listening for incoming requests in a separate thread. When

89 -- that thread is killed, we close the server socket and the termination

90 -- handler. We have to make sure that the exception handler is installed

91 -- /before/ any asynchronous exception occurs. So we mask_, then fork

92 -- (the child thread inherits the masked state from the parent), then

93 -- unmask only inside the catch.

94− mask_ $ forkIOWithUnmask $ \unmask ->

94+ mask_ $ forkIOWithUnmask $ \unmask ->

95 catch (unmask (forever $ acceptRequest sock)) $ \ex -> do

96 tryCloseSocket sock

97 terminationHandler ex

@@ -100,34 +100,34 @@ forkServer host port backlog reuseAddr terminationHandler requestHandler = do

100 acceptRequest sock = bracketOnError (N.accept sock)

101 (tryCloseSocket . fst)

102 (requestHandler . fst)

103−

103+

104-- | Read a length and then a payload of that length

105recvWithLength :: N.Socket -> IO [ByteString]

106recvWithLength sock = recvInt32 sock >>= recvExact sock

107

108-- | Receive a 32-bit integer

109−recvInt32 :: Num a => N.Socket -> IO a

109+recvInt32 :: Num a => N.Socket -> IO a

110−recvInt32 sock = decodeInt32 . BS.concat <$> recvExact sock 4

110+recvInt32 sock = decodeInt32 . BS.concat <$> recvExact sock 4

111

112-- | Close a socket, ignoring I/O exceptions

113tryCloseSocket :: N.Socket -> IO ()

114−tryCloseSocket sock = void . tryIO $

114+tryCloseSocket sock = void . tryIO $

115 N.sClose sock

116

117-- | Read an exact number of bytes from a socket

118−--

118+--

119-- Throws an I/O exception if the socket closes before the specified

120-- number of bytes could be read

121−recvExact :: N.Socket -- ^ Socket to read from

121+recvExact :: N.Socket -- ^ Socket to read from

122 -> Int32 -- ^ Number of bytes to read

123 -> IO [ByteString]

124−recvExact _ len | len < 0 = throwIO (userError "recvExact: Negative length")

124+recvExact _ len | len < 0 = throwIO (userError "recvExact: Negative length")

125recvExact sock len = go [] len

126 where

127− go :: [ByteString] -> Int32 -> IO [ByteString]

127+ go :: [ByteString] -> Int32 -> IO [ByteString]

128− go acc 0 = return (reverse acc)

128+ go acc 0 = return (reverse acc)

129 go acc l = do

130 bs <- NBS.recv sock (fromIntegral l `min` smallChunkSize)

131− if BS.null bs

131+ if BS.null bs

132 then throwIO (userError "recvExact: Socket closed")

133 else go (bs : acc) (l - fromIntegral (BS.length bs))

network-transport-tcp/src/Network/Transport/TCP/Mock/Socket.hs+47−47

@@ -38,7 +38,7 @@ import Data.Map (Map)

38import qualified Data.Map as Map

39import Control.Exception (throwIO)

40import Control.Category ((>>>))

41−import Control.Concurrent.MVar

41+import Control.Concurrent.MVar

42import Control.Concurrent.Chan

43import System.IO.Unsafe (unsafePerformIO)

44import Data.Accessor (Accessor, accessor, (^=), (^.), (^:))

@@ -70,7 +70,7 @@ get :: Accessor MockState a -> IO a

70get acc = timeoutThrow mvarThreshold $ withMVar mockState $ return . (^. acc)

72set :: Accessor MockState a -> a -> IO ()

73−set acc val = timeoutThrow mvarThreshold $ modifyMVar_ mockState $ return . (acc ^= val)

73+set acc val = timeoutThrow mvarThreshold $ modifyMVar_ mockState $ return . (acc ^= val)

75boundSockets :: Accessor MockState (Map SockAddr Socket)

76boundSockets = accessor _boundSockets (\bs st -> st { _boundSockets = bs })

@@ -90,34 +90,34 @@ validHostnames = accessor _validHostnames (\ns st -> st { _validHostnames = ns }

91type HostName = String

92type ServiceName = String

93−type PortNumber = String

93+type PortNumber = String

94−type HostAddress = String

94+type HostAddress = String

96−data SocketType = Stream

96+data SocketType = Stream

97data SocketOption = ReuseAddr

98data ShutdownCmd = ShutdownSend

100data Family

101data ProtocolNumber

102

103−data Socket = Socket {

103+data Socket = Socket {

104 socketState :: MVar SocketState

105 , socketDescription :: String

106 }

107

108−data SocketState =

108+data SocketState =

109 Uninit

110− | BoundSocket {

110+ | BoundSocket {

111− socketBacklog :: Chan (Socket, SockAddr, MVar Socket)

111+ socketBacklog :: Chan (Socket, SockAddr, MVar Socket)

112 }

113− | Connected {

113+ | Connected {

114− socketBuff :: Chan Message

114+ socketBuff :: Chan Message

115 , _socketPeer :: Maybe Socket

116 , _scheduledReadActions :: [(Int, IO ())]

117 }

118 | Closed

119

120−data Message =

120+data Message =

121 Payload Word8

122 | CloseSocket

123

@@ -145,43 +145,43 @@ getAddrInfo :: Maybe AddrInfo -> Maybe HostName -> Maybe ServiceName -> IO [Addr

145getAddrInfo _ (Just host) (Just port) = do

146 validHosts <- get validHostnames

147 if host `elem` validHosts

148− then return . return $ AddrInfo {

148+ then return . return $ AddrInfo {

149− addrFamily = error "Family unused"

149+ addrFamily = error "Family unused"

150− , addrAddress = SockAddrInet port host

150+ , addrAddress = SockAddrInet port host

151 }

152 else throwSocketError $ "getAddrInfo: invalid hostname '" ++ host ++ "'"

153getAddrInfo _ _ _ = error "getAddrInfo: unsupported arguments"

154

155defaultHints :: AddrInfo

156−defaultHints = error "defaultHints not implemented"

156+defaultHints = error "defaultHints not implemented"

157

158socket :: Family -> SocketType -> ProtocolNumber -> IO Socket

159socket _ Stream _ = do

160 state <- newMVar Uninit

161 sid <- get nextSocketId

162 set nextSocketId (sid + 1)

163− return Socket {

163+ return Socket {

164 socketState = state

165 , socketDescription = show sid

166 }

167−

167+

168bindSocket :: Socket -> SockAddr -> IO ()

169bindSocket sock addr = do

170 timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st -> case st of

171 Uninit -> do

172 backlog <- newChan

173− return BoundSocket {

173+ return BoundSocket {

174− socketBacklog = backlog

174+ socketBacklog = backlog

175 }

176 _ ->

177 throwSocketError "bind: socket already initialized"

178 set (boundSocketAt addr) (Just sock)

179−

179+

180listen :: Socket -> Int -> IO ()

181−listen _ _ = return ()

181+listen _ _ = return ()

182

183defaultProtocol :: ProtocolNumber

184−defaultProtocol = error "defaultProtocol not implemented"

184+defaultProtocol = error "defaultProtocol not implemented"

185

186setSocketOption :: Socket -> SocketOption -> Int -> IO ()

187setSocketOption _ ReuseAddr 1 = return ()

@@ -190,13 +190,13 @@ setSocketOption _ _ _ = error "setSocketOption: unsupported arguments"

190accept :: Socket -> IO (Socket, SockAddr)

191accept serverSock = do

192 backlog <- timeoutThrow mvarThreshold $ withMVar (socketState serverSock) $ \st -> case st of

193− BoundSocket {} ->

193+ BoundSocket {} ->

194 return (socketBacklog st)

195 _ ->

196 throwSocketError "accept: socket not bound"

197− (theirSocket, theirAddress, reply) <- readChan backlog

197+ (theirSocket, theirAddress, reply) <- readChan backlog

198 ourBuff <- newChan

199− ourState <- newMVar Connected {

199+ ourState <- newMVar Connected {

200 socketBuff = ourBuff

201 , _socketPeer = Just theirSocket

202 , _scheduledReadActions = []

@@ -205,13 +205,13 @@ accept serverSock = do

205 socketState = ourState

206 , socketDescription = ""

207 }

208− timeoutThrow mvarThreshold $ putMVar reply ourSocket

208+ timeoutThrow mvarThreshold $ putMVar reply ourSocket

209 return (ourSocket, theirAddress)

210

211sClose :: Socket -> IO ()

212sClose sock = do

213 -- Close the peer socket

214− writeSocket sock CloseSocket

214+ writeSocket sock CloseSocket

215

216 -- Close our socket

217 timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st ->

@@ -220,7 +220,7 @@ sClose sock = do

220 -- In case there is a parallel read stuck on a readChan

221 writeChan (socketBuff st) CloseSocket

222 return Closed

223− _ ->

223+ _ ->

224 return Closed

225

226connect :: Socket -> SockAddr -> IO ()

@@ -235,13 +235,13 @@ connect us serverAddr = do

235 throwSocketError "connect: server socket not bound"

236 reply <- newEmptyMVar

237 writeChan serverBacklog (us, SockAddrInet "" "", reply)

238− them <- timeoutThrow mvarThreshold $ readMVar reply

238+ them <- timeoutThrow mvarThreshold $ readMVar reply

239 timeoutThrow mvarThreshold $ modifyMVar_ (socketState us) $ \st -> case st of

240− Uninit -> do

240+ Uninit -> do

241 buff <- newChan

242− return Connected {

242+ return Connected {

243 socketBuff = buff

244− , _socketPeer = Just them

244+ , _socketPeer = Just them

245 , _scheduledReadActions = []

246 }

247 _ ->

@@ -249,7 +249,7 @@ connect us serverAddr = do

249 Nothing -> throwSocketError "connect: unknown address"

250

251sOMAXCONN :: Int

252−sOMAXCONN = error "sOMAXCONN not implemented"

252+sOMAXCONN = error "sOMAXCONN not implemented"

253

254shutdown :: Socket -> ShutdownCmd -> IO ()

255shutdown sock ShutdownSend = do

@@ -267,7 +267,7 @@ shutdown sock ShutdownSend = do

267peerBuffer :: Socket -> IO (Either String (Chan Message))

268peerBuffer sock = do

269 mPeer <- timeoutThrow mvarThreshold $ withMVar (socketState sock) $ \st -> case st of

270− Connected {} ->

270+ Connected {} ->

271 return (st ^. socketPeer)

272 _ ->

273 return Nothing

@@ -276,9 +276,9 @@ peerBuffer sock = do

276 Connected {} ->

277 return (Right (socketBuff st))

278 _ ->

279− return (Left "Peer socket closed")

279+ return (Left "Peer socket closed")

280− Nothing ->

280+ Nothing ->

281− return (Left "Socket closed")

281+ return (Left "Socket closed")

282

283throwSocketError :: String -> IO a

284throwSocketError = throwIO . userError

@@ -287,8 +287,8 @@ writeSocket :: Socket -> Message -> IO ()

287writeSocket sock msg = do

288 theirBuff <- peerBuffer sock

289 case theirBuff of

290− Right buff -> writeChan buff msg

290+ Right buff -> writeChan buff msg

291− Left err -> case msg of Payload _ -> throwSocketError $ "writeSocket: " ++ err

291+ Left err -> case msg of Payload _ -> throwSocketError $ "writeSocket: " ++ err

292 CloseSocket -> return ()

293

294readSocket :: Socket -> IO (Maybe Word8)

@@ -304,7 +304,7 @@ readSocket sock = do

304 case mBuff of

305 Just (buff, actions) -> do

306 sequence actions

307− msg <- timeoutThrow readSocketThreshold $ readChan buff

307+ msg <- timeoutThrow readSocketThreshold $ readChan buff

308 case msg of

309 Payload w -> return (Just w)

310 CloseSocket -> timeoutThrow mvarThreshold $ modifyMVar (socketState sock) $ \st -> case st of

@@ -312,7 +312,7 @@ readSocket sock = do

312 return (Closed, Nothing)

313 _ ->

314 throwSocketError "readSocket: socket in unexpected state"

315− Nothing ->

315+ Nothing ->

316 return Nothing

317

318-- | Given a list of scheduled actions, reduce all delays by 1, and return the

@@ -321,7 +321,7 @@ tick :: [(Int, IO ())] -> ([(Int, IO ())], [IO ()])

321tick = go [] []

322 where

323 go later now [] = (reverse later, reverse now)

324− go later now ((n, action) : actions)

324+ go later now ((n, action) : actions)

325 | n == 0 = go later (action : now) actions

326 | otherwise = go ((n - 1, action) : later) now actions

327

@@ -330,16 +330,16 @@ tick = go [] []

330--------------------------------------------------------------------------------

331

332-- | Schedule an action to be executed after /n/ reads on this socket

333−--

333+--

334-- If /n/ is zero we execute the action immediately.

335scheduleReadAction :: Socket -> Int -> IO () -> IO ()

336scheduleReadAction _ 0 action = action

337−scheduleReadAction sock n action =

337+scheduleReadAction sock n action =

338− modifyMVar_ (socketState sock) $ \st -> case st of

338+ modifyMVar_ (socketState sock) $ \st -> case st of

339 Connected {} ->

340 return (scheduledReadActions ^: ((n, action) :) $ st)

341 _ ->

342− throwSocketError "scheduleReadAction: socket not connected"

342+ throwSocketError "scheduleReadAction: socket not connected"

343

344--------------------------------------------------------------------------------

345-- Util --

network-transport-tcp/tests/TestQC.hs+120−120

@@ -1,10 +1,10 @@

1-- Test the TCP transport using QuickCheck generated scripts

2--

3−-- TODO: This is not quite working yet. The main problem, I think, is the

3+-- TODO: This is not quite working yet. The main problem, I think, is the

4-- allocation of "bundle ID"s to connections. The problem is exposed by the

5-- aptly-named regression test script_Foo (to be renamed once I figure out what

6-- bug that test is actually exposing :)

7−module Main

7+module Main

8 ( main

9 -- Shush the compiler about unused definitions

10 , log

@@ -18,7 +18,7 @@ import Prelude hiding (log)

18import Test.Framework (Test, TestName, defaultMain, testGroup)

19import Test.Framework.Providers.QuickCheck2 (testProperty)

20import Test.Framework.Providers.HUnit (testCase)

21−import Test.QuickCheck

21+import Test.QuickCheck

22 ( Gen

23 , choose

24 , suchThatMaybe

@@ -55,7 +55,7 @@ import qualified Data.Set as Set

55import GHC.Stack (currentCallStack, renderStack)

57import Network.Transport

58−import Network.Transport.TCP

58+import Network.Transport.TCP

59 ( createTransportExposeInternals

60 , defaultTCPParameters

61 , TransportInternals(socketBetween)

@@ -74,26 +74,26 @@ type ConnectionIx = Int

74-- | We randomly generate /scripts/ which are essentially a deep embedding of

75-- the Transport API. These scripts are then executed and the results compared

76-- against an abstract interpreter.

77−data ScriptCmd =

77+data ScriptCmd =

78 -- | Create a new endpoint

79 NewEndPoint

80 -- | @Connect i j@ creates a connection from endpoint @i@ to endpoint @j@,

81 -- where @i@ and @j@ are indices and refer to the @i@th and @j@th endpoint

82 -- created by NewEndPoint

83− | Connect SourceEndPointIx TargetEndPointIx

83+ | Connect SourceEndPointIx TargetEndPointIx

84 -- | @Close i@ closes the @i@ connection created using 'Connect'. Note that

85 -- closing a connection does not shift other indices; in other words, in

86 -- @[Connect 0 0, Close 0, Connect 0 0, Close 0]@ the second 'Close'

87 -- refers to the first (already closed) connection

88− | Close ConnectionIx

88+ | Close ConnectionIx

89− -- | @Send i bs@ sends payload @bs@ on the @i@ connection created

89+ -- | @Send i bs@ sends payload @bs@ on the @i@ connection created

90 | Send ConnectionIx [ByteString]

91 -- | @BreakAfterReads n i j@ force-closes the socket between endpoints @i@

92− -- and @j@ after @n@ reads by @i@

92+ -- and @j@ after @n@ reads by @i@

93− --

93+ --

94 -- We should have @i /= j@ because the TCP transport does not use sockets

95 -- for connections from an endpoint to itself

96− | BreakAfterReads Int SourceEndPointIx TargetEndPointIx

96+ | BreakAfterReads Int SourceEndPointIx TargetEndPointIx

97 deriving Show

99type Script = [ScriptCmd]

@@ -111,7 +111,7 @@ instance Show a => Show (Variable a) where

111

112-- | In the implementation "bundles" are purely a conceptual idea, but in the

113-- verifier we need to concretize this notion

114−type BundleId = Int

114+type BundleId = Int

115

116data ConnectionInfo = ConnectionInfo {

117 source :: EndPointAddress

@@ -120,10 +120,10 @@ data ConnectionInfo = ConnectionInfo {

120 , connectionBundle :: BundleId

121 }

122 deriving Show

123−

123+

124data ExpEvent =

125 ExpConnectionOpened ConnectionInfo

126− | ExpConnectionClosed ConnectionInfo

126+ | ExpConnectionClosed ConnectionInfo

127 | ExpReceived ConnectionInfo [ByteString]

128 | ExpConnectionLost BundleId EndPointAddress

129 deriving Show

@@ -149,18 +149,18 @@ data RunState = RunState {

149 -- | Current bundle ID between two endpoints

150 --

151 -- Invariant: For all keys (A, B), A <= B

152− , _currentBundle :: Map (EndPointAddress, EndPointAddress) BundleId

152+ , _currentBundle :: Map (EndPointAddress, EndPointAddress) BundleId

153 }

154

155−initialRunState :: RunState

155+initialRunState :: RunState

156initialRunState = RunState {

157 _endPoints = []

158 , _connections = []

159 , _expectedEvents = Map.empty

160 , _forwardingThreads = []

161− , _mayBreak = Set.empty

161+ , _mayBreak = Set.empty

162 , _broken = Set.empty

163− , _currentBundle = Map.empty

163+ , _currentBundle = Map.empty

164 }

165

166verify :: (Transport, TransportInternals) -> Script -> IO (Either String ())

@@ -168,17 +168,17 @@ verify (transport, transportInternals) script = do

168 allEvents <- newQ

169

170 let runScript :: Script -> StateT RunState IO ()

171− runScript = mapM_ runCmd

171+ runScript = mapM_ runCmd

172

173− runCmd :: ScriptCmd -> StateT RunState IO ()

173+ runCmd :: ScriptCmd -> StateT RunState IO ()

174 runCmd NewEndPoint = do

175 mEndPoint <- liftIO $ newEndPoint transport

176 case mEndPoint of

177 Right endPoint -> do

178− tid <- liftIO $ forkIO (forward endPoint)

178+ tid <- liftIO $ forkIO (forward endPoint)

179− append endPoints endPoint

179+ append endPoints endPoint

180− append forwardingThreads tid

180+ append forwardingThreads tid

181− set (expectedEventsAt (address endPoint)) []

181+ set (expectedEventsAt (address endPoint)) []

182 Left err ->

183 liftIO $ throwIO err

184 runCmd (Connect i j) = do

@@ -190,11 +190,11 @@ verify (transport, transportInternals) script = do

190 connMayBreak = mayBreak (address endPointA) endPointB

191 case mConn of

192 Right conn -> do

193− bundleBroken <- get bundleId >>= get . connBroken

193+ bundleBroken <- get bundleId >>= get . connBroken

194− currentBundleId <- if bundleBroken

194+ currentBundleId <- if bundleBroken

195 then modify bundleId (+ 1) >> get bundleId

196− else get bundleId

196+ else get bundleId

197− connId <- Variable <$> liftIO newUnique

197+ connId <- Variable <$> liftIO newUnique

198 let connInfo = ConnectionInfo {

199 source = address endPointA

200 , target = endPointB

@@ -204,17 +204,17 @@ verify (transport, transportInternals) script = do

204 append connections (conn, connInfo)

205 append (expectedEventsAt endPointB) (ExpConnectionOpened connInfo)

206 Left err -> do

207− currentBundleId <- get bundleId

207+ currentBundleId <- get bundleId

208 expectingBreak <- get $ connMayBreak currentBundleId

209− if expectingBreak

209+ if expectingBreak

210 then do

211 set (connMayBreak currentBundleId) False

212 set (connBroken currentBundleId) True

213− else

213+ else

214 liftIO $ throwIO err

215 runCmd (Close i) = do

216 (conn, connInfo) <- get (connectionAt i)

217− liftIO $ close conn

217+ liftIO $ close conn

218 append (expectedEventsAt (target connInfo)) (ExpConnectionClosed connInfo)

219 runCmd (Send i payload) = do

220 (conn, connInfo) <- get (connectionAt i)

@@ -224,16 +224,16 @@ verify (transport, transportInternals) script = do

224 case mResult of

225 Right () -> return ()

226 Left err -> do

227− expectingBreak <- get connMayBreak

227+ expectingBreak <- get connMayBreak

228 isBroken <- get connBroken

229 if expectingBreak || isBroken

230 then do

231 set connMayBreak False

232 set connBroken True

233− else

233+ else

234 liftIO $ throwIO err

235 append (expectedEventsAt (target connInfo)) (ExpReceived connInfo payload)

236− -- TODO: This will only work if a connection between 'i' and 'j' has

236+ -- TODO: This will only work if a connection between 'i' and 'j' has

237 -- already been established. We would need to modify the mock network

238 -- layer to support breaking "future" connections

239 runCmd (BreakAfterReads n i j) = do

@@ -247,13 +247,13 @@ verify (transport, transportInternals) script = do

247 set (mayBreak endPointB endPointA currentBundleId) True

248 append (expectedEventsAt endPointA) (ExpConnectionLost currentBundleId endPointB)

249 append (expectedEventsAt endPointB) (ExpConnectionLost currentBundleId endPointA)

250−

250+

251 forward :: EndPoint -> IO ()

252 forward endPoint = forever $ do

253 ev <- receive endPoint

254 pushL allEvents (address endPoint, ev)

255

256− collectEvents :: RunState -> IO (Map EndPointAddress [Event])

256+ collectEvents :: RunState -> IO (Map EndPointAddress [Event])

257 collectEvents st = do

258 threadDelay 10000

259 mapM_ killThread (st ^. forwardingThreads)

@@ -264,17 +264,17 @@ verify (transport, transportInternals) script = do

264 mEv <- tryPopR allEvents

265 case mEv of

266 Just ev -> go (ev : acc)

267− Nothing -> return (reverse acc)

267+ Nothing -> return (reverse acc)

268−

268+

269− st <- execStateT (runScript script) initialRunState

269+ st <- execStateT (runScript script) initialRunState

270 actualEvents <- collectEvents st

271−

271+

272− let eventsMatch = all (uncurry match) $

272+ let eventsMatch = all (uncurry match) $

273 zip (Map.elems (st ^. expectedEvents))

274 (Map.elems actualEvents)

275

276− return $ if eventsMatch

276+ return $ if eventsMatch

277− then Right ()

277+ then Right ()

278 else Left ("Could not match " ++ show (st ^. expectedEvents)

279 ++ " and " ++ show actualEvents)

280

@@ -296,7 +296,7 @@ possibleTraces :: [ExpEvent] -> [[ExpEvent]]

296possibleTraces = go

297 where

298 go [] = [[]]

299− go (ev@(ExpConnectionLost _ _) : evs) =

299+ go (ev@(ExpConnectionLost _ _) : evs) =

300 [ trace | evs' <- possibleTraces evs, trace <- insertConnectionLost ev evs' ]

301 go (ev : evs) =

302 [ trace | evs' <- possibleTraces evs, trace <- insertEvent ev evs' ]

@@ -304,38 +304,38 @@ possibleTraces = go

304 -- We don't know when exactly the error will occur (indeed, it may never

305 -- happen at all), but it must occur before any future connection lost

306 -- event to the same destination.

307− -- If it occurs now, then all other events on this bundle will not happen.

307+ -- If it occurs now, then all other events on this bundle will not happen.

308 insertConnectionLost :: ExpEvent -> [ExpEvent] -> [[ExpEvent]]

309 insertConnectionLost ev [] = [[ev], []]

310 insertConnectionLost ev@(ExpConnectionLost bid addr) (ev' : evs) =

311 (ev : removeBundle bid (ev' : evs)) :

312 case ev' of

313− ExpConnectionLost _ addr' | addr == addr' -> []

313+ ExpConnectionLost _ addr' | addr == addr' -> []

314 _ -> [ev' : evs' | evs' <- insertConnectionLost ev evs]

315 insertConnectionLost _ _ = error "The impossible happened"

316−

316+

317 -- All other events can be arbitrarily reordered /across/ connections, but

318 -- never /within/ connections

319 insertEvent :: ExpEvent -> [ExpEvent] -> [[ExpEvent]]

320 insertEvent ev [] = [[ev]]

321 insertEvent ev (ev' : evs) =

322− (ev : ev' : evs) :

322+ (ev : ev' : evs) :

323− if eventConnId ev == eventConnId ev'

323+ if eventConnId ev == eventConnId ev'

324 then []

325 else [ev' : evs' | evs' <- insertEvent ev evs]

326

327 removeBundle :: BundleId -> [ExpEvent] -> [ExpEvent]

328− removeBundle bid = filter ((/= bid) . eventBundleId)

328+ removeBundle bid = filter ((/= bid) . eventBundleId)

329

330 eventBundleId :: ExpEvent -> BundleId

331 eventBundleId (ExpConnectionOpened connInfo) = connectionBundle connInfo

332 eventBundleId (ExpConnectionClosed connInfo) = connectionBundle connInfo

333 eventBundleId (ExpReceived connInfo _) = connectionBundle connInfo

334 eventBundleId (ExpConnectionLost bid _) = bid

335−

335+

336− eventConnId :: ExpEvent -> Maybe (Variable ConnectionId)

336+ eventConnId :: ExpEvent -> Maybe (Variable ConnectionId)

337− eventConnId (ExpConnectionOpened connInfo) = Just $ connectionId connInfo

337+ eventConnId (ExpConnectionOpened connInfo) = Just $ connectionId connInfo

338− eventConnId (ExpConnectionClosed connInfo) = Just $ connectionId connInfo

338+ eventConnId (ExpConnectionClosed connInfo) = Just $ connectionId connInfo

339 eventConnId (ExpReceived connInfo _) = Just $ connectionId connInfo

340 eventConnId (ExpConnectionLost _ _) = Nothing

341

@@ -343,56 +343,56 @@ possibleTraces = go

343-- Unification --

344--------------------------------------------------------------------------------

345

346−type Substitution = Map Unique ConnectionId

346+type Substitution = Map Unique ConnectionId

347

348−newtype Unifier a = Unifier {

348+newtype Unifier a = Unifier {

349− runUnifier :: Substitution -> Maybe (a, Substitution)

349+ runUnifier :: Substitution -> Maybe (a, Substitution)

350− }

350+ }

351

352instance Monad Unifier where

353 return x = Unifier $ \subst -> Just (x, subst)

354 x >>= f = Unifier $ \subst -> case runUnifier x subst of

355 Nothing -> Nothing

356 Just (a, subst') -> runUnifier (f a) subst'

357− fail _str = mzero

357+ fail _str = mzero

358

359−instance MonadPlus Unifier where

359+instance MonadPlus Unifier where

360 mzero = Unifier $ const Nothing

361 f `mplus` g = Unifier $ \subst -> case runUnifier f subst of

362 Nothing -> runUnifier g subst

363 Just (a, subst') -> Just (a, subst')

364

365class Unify a b where

366− unify :: a -> b -> Unifier ()

366+ unify :: a -> b -> Unifier ()

367

368canUnify :: Unify a b => a -> b -> Bool

369canUnify a b = isJust $ runUnifier (unify a b) Map.empty

370

371instance Unify Unique ConnectionId where

372− unify x cid = Unifier $ \subst ->

372+ unify x cid = Unifier $ \subst ->

373 case Map.lookup x subst of

374 Just cid' -> if cid == cid' then Just ((), subst)

375 else Nothing

376 Nothing -> Just ((), Map.insert x cid subst)

377

378instance Unify (Variable ConnectionId) ConnectionId where

379− unify (Variable x) connId = unify x connId

379+ unify (Variable x) connId = unify x connId

380− unify (Value connId') connId = guard $ connId' == connId

380+ unify (Value connId') connId = guard $ connId' == connId

381

382instance Unify ExpEvent Event where

383− unify (ExpConnectionOpened connInfo) (ConnectionOpened connId _ _) =

383+ unify (ExpConnectionOpened connInfo) (ConnectionOpened connId _ _) =

384− unify (connectionId connInfo) connId

384+ unify (connectionId connInfo) connId

385− unify (ExpConnectionClosed connInfo) (ConnectionClosed connId) =

385+ unify (ExpConnectionClosed connInfo) (ConnectionClosed connId) =

386 unify (connectionId connInfo) connId

387 unify (ExpReceived connInfo payload) (Received connId payload') = do

388 guard $ BSS.concat payload == BSS.concat payload'

389 unify (connectionId connInfo) connId

390− unify (ExpConnectionLost _ addr) (ErrorEvent (TransportError (EventConnectionLost addr') _)) =

390+ unify (ExpConnectionLost _ addr) (ErrorEvent (TransportError (EventConnectionLost addr') _)) =

391 guard $ addr == addr'

392− unify _ _ = fail "Cannot unify"

392+ unify _ _ = fail "Cannot unify"

393

394instance Unify a b => Unify [a] [b] where

395− unify [] [] = return ()

395+ unify [] [] = return ()

396 unify (x:xs) (y:ys) = unify x y >> unify xs ys

397 unify _ _ = fail "Cannot unify"

398

@@ -422,7 +422,7 @@ script_Connect numEndPoints = do

422

423script_ConnectClose :: Int -> Gen Script

424script_ConnectClose numEndPoints = do

425− script <- go Map.empty

425+ script <- go Map.empty

426 return (replicate numEndPoints NewEndPoint ++ script)

427 where

428 go :: Map Int Bool -> Gen Script

@@ -432,15 +432,15 @@ script_ConnectClose numEndPoints = do

432 0 -> do

433 fr <- choose (0, numEndPoints - 1)

434 to <- choose (0, numEndPoints - 1)

435− cmds <- go (Map.insert (Map.size conns) True conns)

435+ cmds <- go (Map.insert (Map.size conns) True conns)

436 return (Connect fr to : cmds)

437 1 -> do

438− mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns

438+ mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns

439− case mConn of

439+ case mConn of

440 Nothing -> go conns

441 Just conn -> do

442 cmds <- go (Map.insert conn False conns)

443− return (Close conn : cmds)

443+ return (Close conn : cmds)

444 _ ->

445 return []

446

@@ -449,7 +449,7 @@ script_ConnectClose numEndPoints = do

449

450script_ConnectSendClose :: Int -> Gen Script

451script_ConnectSendClose numEndPoints = do

452− script <- go Map.empty

452+ script <- go Map.empty

453 return (replicate numEndPoints NewEndPoint ++ script)

454 where

455 go :: Map Int Bool -> Gen Script

@@ -459,24 +459,24 @@ script_ConnectSendClose numEndPoints = do

459 0 -> do

460 fr <- choose (0, numEndPoints - 1)

461 to <- choose (0, numEndPoints - 1)

462− cmds <- go (Map.insert (Map.size conns) True conns)

462+ cmds <- go (Map.insert (Map.size conns) True conns)

463 return (Connect fr to : cmds)

464 1 -> do

465− mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns

465+ mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns

466− case mConn of

466+ case mConn of

467 Nothing -> go conns

468 Just conn -> do

469 numSegments <- choose (0, 2)

470− payload <- replicateM numSegments arbitrary

470+ payload <- replicateM numSegments arbitrary

471− cmds <- go conns

471+ cmds <- go conns

472− return (Send conn payload : cmds)

472+ return (Send conn payload : cmds)

473 2 -> do

474− mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns

474+ mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns

475− case mConn of

475+ case mConn of

476 Nothing -> go conns

477 Just conn -> do

478 cmds <- go (Map.insert conn False conns)

479− return (Close conn : cmds)

479+ return (Close conn : cmds)

480 _ ->

481 return []

482

@@ -505,7 +505,7 @@ withErrors numErrors gen = gen >>= insertError numErrors

505 return $ cmd : cmds'

506

507--------------------------------------------------------------------------------

508−-- Individual scripts to test specific bugs --

508+-- Individual scripts to test specific bugs --

509--------------------------------------------------------------------------------

510

511-- | Bug #1

@@ -513,15 +513,15 @@ withErrors numErrors gen = gen >>= insertError numErrors

513-- When process A wants to close the heavyweight connection to process B it

514-- sends a CloseSocket request together with the ID of the last connection from

515-- B. When B receives the CloseSocket request it can compare this ID to the last

516−-- connection it created; if they don't match, B knows that there are some

516+-- connection it created; if they don't match, B knows that there are some

517−-- messages still on the way from B to A (in particular, a CreatedConnection

517+-- messages still on the way from B to A (in particular, a CreatedConnection

518−-- message) which will cancel the CloseSocket request from A. Hence, it will

518+-- message) which will cancel the CloseSocket request from A. Hence, it will

519-- know to ignore the CloseSocket request from A.

520--

521-- The bug was that we recorded the last _created_ outgoing connection on the

522-- local endpoint, but the last _received_ incoming connection on the state of

523-- the heavyweight connection. So, in the script below, the following happened:

524−--

524+--

525-- A connects to B, records "last connection ID is 1024"

526-- A closes the lightweight connection, sends [CloseConnection 1024]

527-- A closes the heivyweight connection, sends [CloseSocket 0]

@@ -541,7 +541,7 @@ withErrors numErrors gen = gen >>= insertError numErrors

541-- A receives the [CloseSocket 0] request, compares it to the last recorded

542-- outgoing ID (1024), sees that they are not equal, and concludes that this

543-- must mean that there is still a CreatedConnection message on the way from A

544−-- to B.

544+-- to B.

545--

546-- This of course is not the case, so B will wait forever for A to confirm

547-- the CloseSocket request, and deadlock arises. (This deadlock doesn't become

@@ -572,7 +572,7 @@ script_MultipleSends = [

572 , Send 0 ["E"]

573 ]

574

575−-- | Simulate broken network connection during send

575+-- | Simulate broken network connection during send

576script_BreakSend :: Script

577script_BreakSend = [

578 NewEndPoint

@@ -650,12 +650,12 @@ tests transport = [

650 , testOne "Foo" transport script_Foo

651 ]

652 , testGroup "Without errors" [

653− testGroup "One endpoint, with delays" (basicTests transport 1 id)

653+ testGroup "One endpoint, with delays" (basicTests transport 1 id)

654− , testGroup "Two endpoints, with delays" (basicTests transport 2 id)

654+ , testGroup "Two endpoints, with delays" (basicTests transport 2 id)

655 , testGroup "Three endpoints, with delays" (basicTests transport 3 id)

656 ]

657 , testGroup "Single error" [

658− testGroup "Two endpoints, with delays" (basicTests transport 2 (withErrors 1))

658+ testGroup "Two endpoints, with delays" (basicTests transport 2 (withErrors 1))

659 , testGroup "Three endpoints, with delays" (basicTests transport 3 (withErrors 1))

660 ]

661 ]

@@ -665,7 +665,7 @@ testOne :: TestName -> (Transport, TransportInternals) -> Script -> Test

665testOne label transport script = testCase label (testScript transport script)

666

667testGen :: TestName -> (Transport, TransportInternals) -> Gen Script -> Test

668−testGen label transport script = testProperty label (testScriptGen transport script)

668+testGen label transport script = testProperty label (testScriptGen transport script)

669

670main :: IO ()

671main = do

@@ -677,10 +677,10 @@ main = do

677--------------------------------------------------------------------------------

678

679testScriptGen :: (Transport, TransportInternals) -> Gen Script -> Property

680−testScriptGen transport scriptGen =

680+testScriptGen transport scriptGen =

681− forAll scriptGen $ \script ->

681+ forAll scriptGen $ \script ->

682− morallyDubiousIOProperty $ do

682+ morallyDubiousIOProperty $ do

683− logShow script

683+ logShow script

684 mErr <- try $ verify transport script

685 return $ case mErr of

686 Left (ExpectedFailure str) ->

@@ -696,12 +696,12 @@ testScriptGen transport scriptGen =

696

697testScript :: (Transport, TransportInternals) -> Script -> Assertion

698testScript transport script = do

699− logShow script

699+ logShow script

700 mErr <- try $ verify transport script

701 case mErr of

702− Left (ExpectedFailure _str) ->

702+ Left (ExpectedFailure _str) ->

703 return ()

704− Right (Left err) ->

704+ Right (Left err) ->

705 assertFailure $ "Failed with script " ++ show script ++ ": " ++ err ++ "\n"

706 Right (Right ()) ->

707 return ()

@@ -756,7 +756,7 @@ verticalList :: Show a => [a] -> PP.Doc

756verticalList = PP.brackets . PP.vcat . map (PP.text . show)

757

758instance Show Script where

759− show = ("\n" ++) . show . verticalList

759+ show = ("\n" ++) . show . verticalList

760

761instance Show [Event] where

762 show = ("\n" ++) . show . verticalList

@@ -765,13 +765,13 @@ instance Show [ExpEvent] where

765 show = ("\n" ++) . show . verticalList

766

767instance Show (Map EndPointAddress [ExpEvent]) where

768− show = ("\n" ++) . show . PP.brackets . PP.vcat

768+ show = ("\n" ++) . show . PP.brackets . PP.vcat

769− . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs])

769+ . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs])

770 . Map.toList

771

772instance Show (Map EndPointAddress [Event]) where

773− show = ("\n" ++) . show . PP.brackets . PP.vcat

773+ show = ("\n" ++) . show . PP.brackets . PP.vcat

774− . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs])

774+ . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs])

775 . Map.toList

776

777--------------------------------------------------------------------------------

@@ -784,25 +784,25 @@ class Distribution d where

784 probabilityOf :: d -> Double -> Double

785

786instance Distribution NormalD where

787− probabilityOf d x = a * exp (-0.5 * b * b)

787+ probabilityOf d x = a * exp (-0.5 * b * b)

788 where

789 a = 1 / (stdDev d * sqrt (2 * pi))

790 b = (x - mean d) / stdDev d

791

792−-- | Choose from a distribution

792+-- | Choose from a distribution

793chooseFrom :: Distribution d => d -> (Double, Double) -> Gen Double

794−chooseFrom d (lo, hi) = findCandidate

794+chooseFrom d (lo, hi) = findCandidate

795 where

796− findCandidate :: Gen Double

796+ findCandidate :: Gen Double

797 findCandidate = do

798 candidate <- choose (lo, hi)

799 uniformSample <- choose (0, 1)

800 if uniformSample < probabilityOf d candidate

801 then return candidate

802− else findCandidate

802+ else findCandidate

803

804chooseFrom' :: Distribution d => d -> (Int, Int) -> Gen Int

805−chooseFrom' d (lo, hi) =

805+chooseFrom' d (lo, hi) =

806 round <$> chooseFrom d (fromIntegral lo, fromIntegral hi)

807

808--------------------------------------------------------------------------------

@@ -817,15 +817,15 @@ logShow = log . show

817

818instance Arbitrary ByteString where

819 arbitrary = do

820− len <- chooseFrom' NormalD { mean = 5, stdDev = 10 } (0, 100)

820+ len <- chooseFrom' NormalD { mean = 5, stdDev = 10 } (0, 100)

821 xs <- replicateM len arbitrary

822 return (pack xs)

823

824listAccessor :: Int -> Accessor [a] a

825−listAccessor i = accessor (!! i) (error "listAccessor.set not defined")

825+listAccessor i = accessor (!! i) (error "listAccessor.set not defined")

826

827append :: Monad m => Accessor st [a] -> a -> StateT st m ()

828−append acc x = modify acc (snoc x)

828+append acc x = modify acc (snoc x)

829

830snoc :: a -> [a] -> [a]

831snoc x xs = xs ++ [x]

@@ -833,8 +833,8 @@ snoc x xs = xs ++ [x]

833groupByKey :: Ord a => [a] -> [(a, b)] -> Map a [b]

834groupByKey keys = go (Map.fromList [(key, []) | key <- keys])

835 where

836− go acc [] = Map.map reverse acc

836+ go acc [] = Map.map reverse acc

837− go acc ((key, val) : rest) = go (Map.adjust (val :) key acc) rest

837+ go acc ((key, val) : rest) = go (Map.adjust (val :) key acc) rest

838

839--------------------------------------------------------------------------------

840-- Expected failures (can't find explicit support for this in test-framework) --

network-transport-tcp/tests/TestTCP.hs+98−98

@@ -2,7 +2,7 @@

2{-# OPTIONS_GHC -fno-warn-orphans #-}

3module Main where

5−import Prelude hiding

5+import Prelude hiding

6 ( (>>=)

7 , return

8 , fail

@@ -49,7 +49,7 @@ import Network.Transport.TCP.Internal (recvInt32, forkServer, recvWithLength)

49#ifdef USE_MOCK_NETWORK

50import qualified Network.Transport.TCP.Mock.Socket as N

51#else

52−import qualified Network.Socket as N

52+import qualified Network.Socket as N

53#endif

54 ( sClose

55 , ServiceName

@@ -69,9 +69,9 @@ import Data.String (fromString)

69import GHC.IO.Exception (ioe_errno)

70import Foreign.C.Error (Errno(..), eADDRNOTAVAIL)

71import System.Timeout (timeout)

72−import Network.Transport.Tests (testTransport)

72+import Network.Transport.Tests (testTransport)

73import Network.Transport.Tests.Auxiliary (forkTry, runTests)

74−import Network.Transport.Tests.Traced

74+import Network.Transport.Tests.Traced

76instance Traceable ControlHeader where

77 trace = traceShow

@@ -80,7 +80,7 @@ instance Traceable ConnectionRequestResponse where

80 trace = traceShow

82instance Traceable N.Socket where

83− trace = traceShow

83+ trace = traceShow

85instance Traceable N.AddrInfo where

86 trace = traceShow

@@ -112,17 +112,17 @@ testEarlyDisconnect nextPort = do

112

113 -- TEST 1: they connect to us, then drop the connection

114 do

115− ConnectionOpened _ _ addr <- receive endpoint

115+ ConnectionOpened _ _ addr <- receive endpoint

116 True <- return $ addr == theirAddr

117−

117+

118− ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint

118+ ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint

119− True <- return $ addr' == theirAddr

119+ True <- return $ addr' == theirAddr

120

121 return ()

122

123 -- TEST 2: after they dropped their connection to us, we now try to

124 -- establish a connection to them. This should re-establish the broken

125− -- TCP connection.

125+ -- TCP connection.

126 tlog "Trying to connect to client"

127 Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

128

@@ -131,39 +131,39 @@ testEarlyDisconnect nextPort = do

131 -- closes the socket

132 do

133 Right () <- send conn ["ping"]

134−

134+

135− ConnectionOpened cid _ addr <- receive endpoint

135+ ConnectionOpened cid _ addr <- receive endpoint

136 True <- return $ addr == theirAddr

137−

137+

138 Received cid' ["pong"] <- receive endpoint

139 True <- return $ cid == cid'

140−

140+

141 ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint

142− True <- return $ addr' == theirAddr

142+ True <- return $ addr' == theirAddr

143

144 return ()

145

146 -- TEST 4: A subsequent send on an already-open connection will now break

147 Left (TransportError SendFailed _) <- send conn ["ping2"]

148

149− -- *Pfew*

149+ -- *Pfew*

150 putMVar serverDone ()

151

152 client :: MVar EndPointAddress -> MVar EndPointAddress -> IO ()

153 client serverAddr clientAddr = do

154 tlog "Client"

155 clientPort <- nextPort

156− let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0

156+ let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0

157− putMVar clientAddr ourAddress

157+ putMVar clientAddr ourAddress

158−

158+

159 -- Listen for incoming messages

160 forkServer "127.0.0.1" clientPort 5 True throwIO $ \sock -> do

161− -- Initial setup

161+ -- Initial setup

162 0 <- recvInt32 sock :: IO Int

163− _ <- recvWithLength sock

163+ _ <- recvWithLength sock

164 sendMany sock [encodeInt32 ConnectionRequestAccepted]

165

166− -- Server opens a logical connection

166+ -- Server opens a logical connection

167 CreatedNewConnection <- toEnum <$> (recvInt32 sock :: IO Int)

168 1024 <- recvInt32 sock :: IO LightweightConnectionId

169

@@ -171,21 +171,21 @@ testEarlyDisconnect nextPort = do

171 1024 <- recvInt32 sock :: IO Int

172 ["ping"] <- recvWithLength sock

173

174− -- Reply

174+ -- Reply

175 sendMany sock [encodeInt32 CreatedNewConnection, encodeInt32 (10002 :: Int)]

176− sendMany sock (encodeInt32 10002 : prependLength ["pong"])

176+ sendMany sock (encodeInt32 10002 : prependLength ["pong"])

177

178 -- Close the socket

179 N.sClose sock

180−

180+

181 -- Connect to the server

182 Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing

183−

183+

184 -- Open a new connection

185 sendMany sock [encodeInt32 CreatedNewConnection, encodeInt32 (10003 :: Int)]

186−

186+

187 -- Close the socket without closing the connection explicitly

188− -- The server should receive an error event

188+ -- The server should receive an error event

189 N.sClose sock

190

191-- | Test the behaviour of a premature CloseSocket request

@@ -211,19 +211,19 @@ testEarlyCloseSocket nextPort = do

211

212 -- TEST 1: they connect to us, then send a CloseSocket. Since we don't

213 -- have any outgoing connections, this means we will agree to close the

214− -- socket

214+ -- socket

215 do

216− ConnectionOpened cid _ addr <- receive endpoint

216+ ConnectionOpened cid _ addr <- receive endpoint

217 True <- return $ addr == theirAddr

218−

218+

219− ConnectionClosed cid' <- receive endpoint

219+ ConnectionClosed cid' <- receive endpoint

220 True <- return $ cid' == cid

221

222 return ()

223

224 -- TEST 2: after they dropped their connection to us, we now try to

225 -- establish a connection to them. This should re-establish the broken

226− -- TCP connection.

226+ -- TCP connection.

227 tlog "Trying to connect to client"

228 Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

229

@@ -234,65 +234,65 @@ testEarlyCloseSocket nextPort = do

234 -- the socket gets closed

235 do

236 Right () <- send conn ["ping"]

237−

237+

238 ConnectionOpened cid _ addr <- receive endpoint

239 True <- return $ addr == theirAddr

240−

240+

241 Received cid' ["pong"] <- receive endpoint

242 True <- return $ cid' == cid

243−

243+

244 ConnectionClosed cid'' <- receive endpoint

245 True <- return $ cid'' == cid

246−

246+

247 ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint

248− True <- return $ addr' == theirAddr

248+ True <- return $ addr' == theirAddr

249−

249+

250 return ()

251

252 -- TEST 4: A subsequent send on an already-open connection will now break

253 Left (TransportError SendFailed _) <- send conn ["ping2"]

254

255− -- *Pfew*

255+ -- *Pfew*

256 putMVar serverDone ()

257

258 client :: MVar EndPointAddress -> MVar EndPointAddress -> IO ()

259 client serverAddr clientAddr = do

260 tlog "Client"

261 clientPort <- nextPort

262− let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0

262+ let ourAddress = encodeEndPointAddress "127.0.0.1" clientPort 0

263− putMVar clientAddr ourAddress

263+ putMVar clientAddr ourAddress

264−

264+

265 -- Listen for incoming messages

266 forkServer "127.0.0.1" clientPort 5 True throwIO $ \sock -> do

267− -- Initial setup

267+ -- Initial setup

268 0 <- recvInt32 sock :: IO Int

269− _ <- recvWithLength sock

269+ _ <- recvWithLength sock

270 sendMany sock [encodeInt32 ConnectionRequestAccepted]

271

272− -- Server opens a logical connection

272+ -- Server opens a logical connection

273 CreatedNewConnection <- toEnum <$> (recvInt32 sock :: IO Int)

274− 1024 <- recvInt32 sock :: IO LightweightConnectionId

274+ 1024 <- recvInt32 sock :: IO LightweightConnectionId

275

276 -- Server sends a message

277 1024 <- recvInt32 sock :: IO Int

278 ["ping"] <- recvWithLength sock

279

280− -- Reply

280+ -- Reply

281 sendMany sock [encodeInt32 CreatedNewConnection, encodeInt32 (10002 :: Int)]

282− sendMany sock (encodeInt32 (10002 :: Int) : prependLength ["pong"])

282+ sendMany sock (encodeInt32 (10002 :: Int) : prependLength ["pong"])

283

284 -- Send a CloseSocket even though there are still connections *in both

285 -- directions*

286 sendMany sock [encodeInt32 CloseSocket, encodeInt32 (1024 :: Int)]

287 N.sClose sock

288−

288+

289 -- Connect to the server

290 Right (sock, ConnectionRequestAccepted) <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing

291−

291+

292 -- Open a new connection

293 sendMany sock [encodeInt32 CreatedNewConnection, encodeInt32 (10003 :: Int)]

294−

294+

295− -- Send a CloseSocket without sending a closeconnecton

295+ -- Send a CloseSocket without sending a closeconnecton

296 -- The server should still receive a ConnectionClosed message

297 sendMany sock [encodeInt32 CloseSocket, encodeInt32 (0 :: Int)]

298 N.sClose sock

@@ -311,26 +311,26 @@ testInvalidConnect nextPort = do

311 Right endpoint <- newEndPoint transport

312

313 -- Syntax error in the endpoint address

314− Left (TransportError ConnectFailed _) <-

314+ Left (TransportError ConnectFailed _) <-

315 connect endpoint (EndPointAddress "InvalidAddress") ReliableOrdered defaultConnectHints

316−

316+

317 -- Syntax connect, but invalid hostname (TCP address lookup failure)

318− Left (TransportError ConnectNotFound _) <-

318+ Left (TransportError ConnectNotFound _) <-

319 connect endpoint (encodeEndPointAddress "invalidHost" "port" 0) ReliableOrdered defaultConnectHints

320−

320+

321 -- TCP address correct, but nobody home at that address

322− Left (TransportError ConnectNotFound _) <-

322+ Left (TransportError ConnectNotFound _) <-

323 connect endpoint (encodeEndPointAddress "127.0.0.1" "9000" 0) ReliableOrdered defaultConnectHints

324−

324+

325 -- Valid TCP address but invalid endpoint number

326− Left (TransportError ConnectNotFound _) <-

326+ Left (TransportError ConnectNotFound _) <-

327 connect endpoint (encodeEndPointAddress "127.0.0.1" port 1) ReliableOrdered defaultConnectHints

328

329 return ()

330

331-- | Test that an endpoint can ignore CloseSocket requests (in "reality" this

332-- would happen when the endpoint sends a new connection request before

333−-- receiving an (already underway) CloseSocket request)

333+-- receiving an (already underway) CloseSocket request)

334testIgnoreCloseSocket :: IO N.ServiceName -> IO ()

335testIgnoreCloseSocket nextPort = do

336 serverAddr <- newEmptyMVar

@@ -397,7 +397,7 @@ testIgnoreCloseSocket nextPort = do

397

398 -- Close it again

399 tlog "Closing connection"

400− sendMany sock [encodeInt32 CloseConnection, encodeInt32 (1024 :: Int)]

400+ sendMany sock [encodeInt32 CloseConnection, encodeInt32 (1024 :: Int)]

401

402 -- And close the connection completely

403 tlog "Closing socket"

@@ -471,7 +471,7 @@ testBlockAfterCloseSocket nextPort = do

471 unblocked <- newMVar False

472

473 -- We should not hear from the server until we unblock him by

474− -- responding to the CloseSocket request (in this case, we

474+ -- responding to the CloseSocket request (in this case, we

475 -- respond by sending a ConnectionRequest)

476 forkTry $ do

477 recvInt32 sock :: IO Int32

@@ -490,7 +490,7 @@ testBlockAfterCloseSocket nextPort = do

490

491-- | Test what happens when a remote endpoint sends a connection request to our

492-- transport for an endpoint it already has a connection to

493−testUnnecessaryConnect :: IO N.ServiceName -> Int -> IO ()

493+testUnnecessaryConnect :: IO N.ServiceName -> Int -> IO ()

494testUnnecessaryConnect nextPort numThreads = do

495 clientDone <- newEmptyMVar

496 serverAddr <- newEmptyMVar

@@ -501,22 +501,22 @@ testUnnecessaryConnect nextPort numThreads = do

501 putMVar serverAddr (address endpoint)

502

503 forkTry $ do

504− -- We pick an address < 127.0.0.1 so that this is not rejected purely because of the "crossed" check

504+ -- We pick an address < 127.0.0.1 so that this is not rejected purely because of the "crossed" check

505 let ourAddress = EndPointAddress "126.0.0.1"

506

507 -- We should only get a single 'Accepted' reply

508 gotAccepted <- newEmptyMVar

509 dones <- replicateM numThreads $ do

510− done <- newEmptyMVar

510+ done <- newEmptyMVar

511 forkTry $ do

512 -- It is possible that the remote endpoint just rejects the request by closing the socket

513 -- immediately (depending on far the remote endpoint got with the initialization)

514− response <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing

514+ response <- readMVar serverAddr >>= \addr -> socketToEndPoint ourAddress addr True Nothing

515 case response of

516− Right (_, ConnectionRequestAccepted) ->

516+ Right (_, ConnectionRequestAccepted) ->

517 -- We don't close this socket because we want to keep this connection open

518 putMVar gotAccepted ()

519− -- We might get either Invalid or Crossed (the transport does not

519+ -- We might get either Invalid or Crossed (the transport does not

520 -- maintain enough history to be able to tell)

521 Right (sock, ConnectionRequestInvalid) ->

522 N.sClose sock

@@ -536,7 +536,7 @@ testUnnecessaryConnect nextPort numThreads = do

536testMany :: IO N.ServiceName -> IO ()

537testMany nextPort = do

538 Right masterTransport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters

539− Right masterEndPoint <- newEndPoint masterTransport

539+ Right masterEndPoint <- newEndPoint masterTransport

540

541 replicateM_ 10 $ do

542 mTransport <- nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters

@@ -544,7 +544,7 @@ testMany nextPort = do

544 Left ex -> do

545 putStrLn $ "IOException: " ++ show ex ++ "; errno = " ++ show (ioe_errno ex)

546 case (ioe_errno ex) of

547− Just no | Errno no == eADDRNOTAVAIL -> putStrLn "(ADDRNOTAVAIL)"

547+ Just no | Errno no == eADDRNOTAVAIL -> putStrLn "(ADDRNOTAVAIL)"

548 _ -> return ()

549 throwIO ex

550 Right transport ->

@@ -561,7 +561,7 @@ testBreakTransport nextPort = do

561

562 killThread (transportThread internals) -- Uh oh

563

564− ErrorEvent (TransportError EventTransportFailed _) <- receive endpoint

564+ ErrorEvent (TransportError EventTransportFailed _) <- receive endpoint

565

566 return ()

567

@@ -580,16 +580,16 @@ testReconnect nextPort = do

580 endpointCreated <- newEmptyMVar

581

582 -- Server

583− forkTry $ do

583+ forkTry $ do

584 -- Wait for the client to do its first attempt

585− readMVar firstAttempt

585+ readMVar firstAttempt

586

587− counter <- newMVar (0 :: Int)

587+ counter <- newMVar (0 :: Int)

588

589 forkServer "127.0.0.1" serverPort 5 True throwIO $ \sock -> do

590− -- Accept the connection

590+ -- Accept the connection

591 Right 0 <- tryIO $ (recvInt32 sock :: IO Int)

592− Right _ <- tryIO $ recvWithLength sock

592+ Right _ <- tryIO $ recvWithLength sock

593 Right () <- tryIO $ sendMany sock [encodeInt32 ConnectionRequestAccepted]

594

595 -- The first time we close the socket before accepting the logical connection

@@ -604,10 +604,10 @@ testReconnect nextPort = do

604 when (count > 1) $ do

605 -- Client sends a message

606 Right connId' <- tryIO $ (recvInt32 sock :: IO LightweightConnectionId)

607− True <- return $ connId == connId'

607+ True <- return $ connId == connId'

608 Right ["ping"] <- tryIO $ recvWithLength sock

609 putMVar serverDone ()

610−

610+

611 Right () <- tryIO $ N.sClose sock

612 return ()

613

@@ -626,17 +626,17 @@ testReconnect nextPort = do

626 -- The second attempt will fail because the server closes the socket before we can request a connection

627 takeMVar endpointCreated

628 -- This might time out or not, depending on whether the server closes the

629− -- socket before or after we can send the RequestConnectionId request

629+ -- socket before or after we can send the RequestConnectionId request

630− resultConnect <- timeout 500000 $ connect endpoint theirAddr ReliableOrdered defaultConnectHints

630+ resultConnect <- timeout 500000 $ connect endpoint theirAddr ReliableOrdered defaultConnectHints

631 case resultConnect of

632 Nothing -> return ()

633 Just (Left (TransportError ConnectFailed _)) -> return ()

634 Just (Left err) -> throwIO err

635− Just (Right _) -> throwIO $ userError "testConnect: unexpected connect success"

635+ Just (Right _) -> throwIO $ userError "testConnect: unexpected connect success"

636

637 -- The third attempt succeeds

638 Right conn1 <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

639−

639+

640 -- But a send will fail because the server has closed the connection again

641 threadDelay 100000

642 Left (TransportError SendFailed _) <- send conn1 ["ping"]

@@ -675,12 +675,12 @@ testUnidirectionalError nextPort = do

675

676 CreatedNewConnection <- toEnum <$> (recvInt32 sock :: IO Int)

677 connId <- recvInt32 sock :: IO LightweightConnectionId

678−

678+

679 connId' <- recvInt32 sock :: IO LightweightConnectionId

680 True <- return $ connId == connId'

681 ["ping"] <- recvWithLength sock

682 putMVar serverGotPing ()

683−

683+

684 -- Client

685 forkTry $ do

686 Right (transport, internals) <- nextPort >>= \port -> createTransportExposeInternals "127.0.0.1" port defaultTCPParameters

@@ -693,12 +693,12 @@ testUnidirectionalError nextPort = do

693 takeMVar serverGotPing

694

695 -- Close the *outgoing* part of the socket only

696− sock <- socketBetween internals (address endpoint) theirAddr

696+ sock <- socketBetween internals (address endpoint) theirAddr

697 N.shutdown sock N.ShutdownSend

698

699 -- At this point we cannot notice the problem yet so we shouldn't receive an event yet

700 Nothing <- timeout 500000 $ receive endpoint

701−

701+

702 -- But when we send we find the error

703 Left (TransportError SendFailed _) <- send conn1 ["ping"]

704 ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint

@@ -709,7 +709,7 @@ testUnidirectionalError nextPort = do

709 takeMVar serverGotPing

710

711 -- Again, close the outgoing part of the socket

712− sock' <- socketBetween internals (address endpoint) theirAddr

712+ sock' <- socketBetween internals (address endpoint) theirAddr

713 N.shutdown sock' N.ShutdownSend

714

715 -- We now find the error when we attempt to close the connection

@@ -720,10 +720,10 @@ testUnidirectionalError nextPort = do

720 send conn3 ["ping"]

721 takeMVar serverGotPing

722

723− -- We repeat once more.

723+ -- We repeat once more.

724− sock'' <- socketBetween internals (address endpoint) theirAddr

724+ sock'' <- socketBetween internals (address endpoint) theirAddr

725 N.shutdown sock'' N.ShutdownSend

726−

726+

727 -- Now we notice the problem when we try to connect

728 Nothing <- timeout 500000 $ receive endpoint

729 Left (TransportError ConnectFailed _) <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

@@ -754,7 +754,7 @@ testInvalidCloseConnection nextPort = do

754 -- connection

755 ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint

756

757− putMVar serverDone ()

757+ putMVar serverDone ()

758

759 -- Client

760 forkTry $ do

@@ -766,7 +766,7 @@ testInvalidCloseConnection nextPort = do

766 Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

767

768 -- Get a handle on the TCP connection and manually send an invalid CloseConnection request

769− sock <- socketBetween internals ourAddr theirAddr

769+ sock <- socketBetween internals ourAddr theirAddr

770 sendMany sock [encodeInt32 CloseConnection, encodeInt32 (12345 :: Int)]

771

772 putMVar clientDone ()

@@ -776,23 +776,23 @@ testInvalidCloseConnection nextPort = do

776main :: IO ()

777main = do

778 portMVar <- newEmptyMVar

779− forkTry $ forM_ ([10080 ..] :: [Int]) $ putMVar portMVar . show

779+ forkTry $ forM_ ([10080 ..] :: [Int]) $ putMVar portMVar . show

780− let nextPort = takeMVar portMVar

780+ let nextPort = takeMVar portMVar

781− tcpResult <- tryIO $ runTests

781+ tcpResult <- tryIO $ runTests

782 [ ("EarlyDisconnect", testEarlyDisconnect nextPort)

783 , ("EarlyCloseSocket", testEarlyCloseSocket nextPort)

784 , ("IgnoreCloseSocket", testIgnoreCloseSocket nextPort)

785 , ("BlockAfterCloseSocket", testBlockAfterCloseSocket nextPort)

786 , ("UnnecessaryConnect", testUnnecessaryConnect nextPort 10)

787 , ("InvalidAddress", testInvalidAddress nextPort)

788− , ("InvalidConnect", testInvalidConnect nextPort)

788+ , ("InvalidConnect", testInvalidConnect nextPort)

789 , ("Many", testMany nextPort)

790 , ("BreakTransport", testBreakTransport nextPort)

791 , ("Reconnect", testReconnect nextPort)

792 , ("UnidirectionalError", testUnidirectionalError nextPort)

793 , ("InvalidCloseConnection", testInvalidCloseConnection nextPort)

794 ]

795− -- Run the generic tests even if the TCP specific tests failed..

795+ -- Run the generic tests even if the TCP specific tests failed..

796 testTransport (either (Left . show) (Right) <$> nextPort >>= \port -> createTransport "127.0.0.1" port defaultTCPParameters)

797 -- ..but if the generic tests pass, still fail if the specific tests did not

798 case tcpResult of

network-transport-tests/src/Network/Transport/Tests.hs+113−113

@@ -1,7 +1,7 @@

1{-# LANGUAGE RebindableSyntax #-}

2module Network.Transport.Tests where

4−import Prelude hiding

4+import Prelude hiding

5 ( (>>=)

6 , return

7 , fail

@@ -16,7 +16,7 @@ import Control.Exception (evaluate, throw, throwIO, bracket)

16import Control.Monad (replicateM, replicateM_, when, guard, forM_, unless)

17import Control.Monad.Error ()

18import Control.Applicative ((<$>))

19−import Network.Transport

19+import Network.Transport

20import Network.Transport.Internal (tlog, tryIO, timeoutMaybe)

21import Network.Transport.Util (spawn)

22import System.Random (randomIO)

@@ -34,22 +34,22 @@ echoServer :: EndPoint -> IO ()

34echoServer endpoint = do

35 go Map.empty

36 where

37− go :: Map ConnectionId Connection -> IO ()

37+ go :: Map ConnectionId Connection -> IO ()

38 go cs = do

39 event <- receive endpoint

40 case event of

41 ConnectionOpened cid rel addr -> do

42 tlog $ "Opened new connection " ++ show cid

43 Right conn <- connect endpoint addr rel defaultConnectHints

44− go (Map.insert cid conn cs)

44+ go (Map.insert cid conn cs)

45 Received cid payload -> do

46− send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload

46+ send (Map.findWithDefault (error $ "Received: Invalid cid " ++ show cid) cid cs) payload

47 go cs

48− ConnectionClosed cid -> do

48+ ConnectionClosed cid -> do

49 tlog $ "Close connection " ++ show cid

50 close (Map.findWithDefault (error $ "ConnectionClosed: Invalid cid " ++ show cid) cid cs)

51− go (Map.delete cid cs)

51+ go (Map.delete cid cs)

52− ReceivedMulticast _ _ ->

52+ ReceivedMulticast _ _ ->

53 -- Ignore

54 go cs

55 ErrorEvent _ ->

@@ -81,49 +81,49 @@ ping endpoint server numPings msg = do

82 -- Wait for the server to close its connection to us

83 tlog "Wait for ConnectionClosed message"

84− ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'

84+ ConnectionClosed cid' <- receive endpoint ; True <- return $ cid == cid'

86 -- Done

87 tlog "Ping client done"

88−

88+

89-- | Basic ping test

90−testPingPong :: Transport -> Int -> IO ()

90+testPingPong :: Transport -> Int -> IO ()

91testPingPong transport numPings = do

92 tlog "Starting ping pong test"

93 server <- spawn transport echoServer

94 result <- newEmptyMVar

96− -- Client

96+ -- Client

97 forkTry $ do

98 tlog "Ping client"

99 Right endpoint <- newEndPoint transport

100 ping endpoint server numPings "ping"

101− putMVar result ()

101+ putMVar result ()

102−

102+

103 takeMVar result

104

105-- | Test that endpoints don't get confused

106−testEndPoints :: Transport -> Int -> IO ()

106+testEndPoints :: Transport -> Int -> IO ()

107testEndPoints transport numPings = do

108 server <- spawn transport echoServer

109 dones <- replicateM 2 newEmptyMVar

110

111− forM_ (zip dones ['A'..]) $ \(done, name) -> forkTry $ do

111+ forM_ (zip dones ['A'..]) $ \(done, name) -> forkTry $ do

112 let name' :: ByteString

113 name' = pack [name]

114 Right endpoint <- newEndPoint transport

115 tlog $ "Ping client " ++ show name' ++ ": " ++ show (address endpoint)

116− ping endpoint server numPings name'

116+ ping endpoint server numPings name'

117− putMVar done ()

117+ putMVar done ()

118

119 forM_ dones takeMVar

120

121-- Test that connections don't get confused

122−testConnections :: Transport -> Int -> IO ()

122+testConnections :: Transport -> Int -> IO ()

123testConnections transport numPings = do

124 server <- spawn transport echoServer

125 result <- newEmptyMVar

126−

126+

127 -- Client

128 forkTry $ do

129 Right endpoint <- newEndPoint transport

@@ -131,7 +131,7 @@ testConnections transport numPings = do

131 -- Open two connections to the server

132 Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints

133 ConnectionOpened serv1 _ _ <- receive endpoint

134−

134+

135 Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints

136 ConnectionOpened serv2 _ _ <- receive endpoint

137

@@ -141,17 +141,17 @@ testConnections transport numPings = do

141 -- One thread to send "pingB" on the second connection

142 forkTry $ replicateM_ numPings $ send conn2 ["pingB"]

143

144− -- Verify server responses

144+ -- Verify server responses

145− let verifyResponse 0 = putMVar result ()

145+ let verifyResponse 0 = putMVar result ()

146− verifyResponse n = do

146+ verifyResponse n = do

147 event <- receive endpoint

148 case event of

149 Received cid [payload] -> do

150 when (cid == serv1 && payload /= "pingA") $ error "Wrong message"

151 when (cid == serv2 && payload /= "pingB") $ error "Wrong message"

152− verifyResponse (n - 1)

152+ verifyResponse (n - 1)

153− _ ->

153+ _ ->

154− verifyResponse n

154+ verifyResponse n

155 verifyResponse (2 * numPings)

156

157 takeMVar result

@@ -161,7 +161,7 @@ testCloseOneConnection :: Transport -> Int -> IO ()

161testCloseOneConnection transport numPings = do

162 server <- spawn transport echoServer

163 result <- newEmptyMVar

164−

164+

165 -- Client

166 forkTry $ do

167 Right endpoint <- newEndPoint transport

@@ -169,7 +169,7 @@ testCloseOneConnection transport numPings = do

169 -- Open two connections to the server

170 Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints

171 ConnectionOpened serv1 _ _ <- receive endpoint

172−

172+

173 Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints

174 ConnectionOpened serv2 _ _ <- receive endpoint

175

@@ -177,21 +177,21 @@ testCloseOneConnection transport numPings = do

177 forkTry $ do

178 replicateM_ numPings $ send conn1 ["pingA"]

179 close conn1

180−

180+

181 -- One thread to send "pingB" on the second connection

182 forkTry $ replicateM_ (numPings * 2) $ send conn2 ["pingB"]

183

184− -- Verify server responses

184+ -- Verify server responses

185− let verifyResponse 0 = putMVar result ()

185+ let verifyResponse 0 = putMVar result ()

186− verifyResponse n = do

186+ verifyResponse n = do

187 event <- receive endpoint

188 case event of

189 Received cid [payload] -> do

190 when (cid == serv1 && payload /= "pingA") $ error "Wrong message"

191 when (cid == serv2 && payload /= "pingB") $ error "Wrong message"

192− verifyResponse (n - 1)

192+ verifyResponse (n - 1)

193− _ ->

193+ _ ->

194− verifyResponse n

194+ verifyResponse n

195 verifyResponse (3 * numPings)

196

197 takeMVar result

@@ -208,7 +208,7 @@ testCloseOneDirection transport numPings = do

208

209 -- A

210 forkTry $ do

211− tlog "A"

211+ tlog "A"

212 Right endpoint <- newEndPoint transport

213 tlog (show (address endpoint))

214 putMVar addrA (address endpoint)

@@ -218,25 +218,25 @@ testCloseOneDirection transport numPings = do

218 Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints

219

220 -- Wait for B to connect to us

221− tlog "Wait for B"

221+ tlog "Wait for B"

222 ConnectionOpened cid _ _ <- receive endpoint

223

224 -- Send pings to B

225 tlog "Send pings to B"

226− replicateM_ numPings $ send conn ["ping"]

226+ replicateM_ numPings $ send conn ["ping"]

227

228 -- Close our connection to B

229 tlog "Close connection"

230 close conn

231−

231+

232 -- Wait for B's pongs

233− tlog "Wait for pongs from B"

233+ tlog "Wait for pongs from B"

234 replicateM_ numPings $ do Received _ _ <- receive endpoint ; return ()

235

236 -- Wait for B to close it's connection to us

237 tlog "Wait for B to close connection"

238 ConnectionClosed cid' <- receive endpoint

239− guard (cid == cid')

239+ guard (cid == cid')

240

241 -- Done

242 tlog "Done"

@@ -264,12 +264,12 @@ testCloseOneDirection transport numPings = do

264 -- Wait for A to close it's connection to us

265 tlog "Wait for A to close connection"

266 ConnectionClosed cid' <- receive endpoint

267− guard (cid == cid')

267+ guard (cid == cid')

268

269 -- Send pongs to A

270 tlog "Send pongs to A"

271 replicateM_ numPings $ send conn ["pong"]

272−

272+

273 -- Close our connection to A

274 tlog "Close connection to A"

275 close conn

@@ -285,10 +285,10 @@ collect :: EndPoint -> Maybe Int -> Maybe Int -> IO [(ConnectionId, [[ByteString

285collect endPoint maxEvents timeout = go maxEvents Map.empty Map.empty

286 where

287 -- TODO: for more serious use of this function we'd need to make these arguments strict

288− go (Just 0) open closed = finish open closed

288+ go (Just 0) open closed = finish open closed

289 go n open closed = do

290− mEvent <- tryIO . timeoutMaybe timeout (userError "timeout") $ receive endPoint

290+ mEvent <- tryIO . timeoutMaybe timeout (userError "timeout") $ receive endPoint

291− case mEvent of

291+ case mEvent of

292 Left _ -> finish open closed

293 Right event -> do

294 let n' = (\x -> x - 1) <$> n

@@ -307,8 +307,8 @@ collect endPoint maxEvents timeout = go maxEvents Map.empty Map.empty

307 EndPointClosed ->

308 fail "Unexpected endpoint closure"

309

310− finish open closed =

310+ finish open closed =

311− if Map.null open

311+ if Map.null open

312 then return . Map.toList . Map.map reverse $ closed

313 else fail $ "Open connections: " ++ show (map fst . Map.toList $ open)

314

@@ -319,12 +319,12 @@ collect endPoint maxEvents timeout = go maxEvents Map.empty Map.empty

319-- before receiving the messages on the second connection. What might (and sometimes

320-- does) happen is that finishes sending all of its messages on the first connection

321-- (in the TCP transport, the first socket pair) while B is behind on reading _from_

322−-- this connection (socket pair) -- the messages are "in transit" on the network

322+-- this connection (socket pair) -- the messages are "in transit" on the network

323-- (these tests are done on localhost, so there are in some OS buffer). Then when

324-- A opens the second connection (socket pair) B will spawn a new thread for this

325-- connection, and hence might start interleaving messages from the first and second

326−-- connection.

326+-- connection.

327−--

327+--

328-- This is correct behaviour, however: the transport API guarantees reliability and

329-- ordering _per connection_, but not _across_ connections.

330testCloseReopen :: Transport -> Int -> IO ()

@@ -332,7 +332,7 @@ testCloseReopen transport numPings = do

332 addrB <- newEmptyMVar

333 doneB <- newEmptyMVar

334

335− let numRepeats = 2 :: Int

335+ let numRepeats = 2 :: Int

336

337 -- A

338 forkTry $ do

@@ -342,7 +342,7 @@ testCloseReopen transport numPings = do

342 tlog "A connecting"

343 -- Connect to B

344 Right conn <- readMVar addrB >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints

345−

345+

346 tlog "A pinging"

347 -- Say hi

348 forM_ [1 .. numPings] $ \j -> send conn [pack $ "ping" ++ show i ++ "/" ++ show j]

@@ -372,12 +372,12 @@ testCloseReopen transport numPings = do

372testParallelConnects :: Transport -> Int -> IO ()

373testParallelConnects transport numPings = do

374 server <- spawn transport echoServer

375− done <- newEmptyMVar

375+ done <- newEmptyMVar

376

377 Right endpoint <- newEndPoint transport

378

379 -- Spawn lots of clients

380− forM_ [1 .. numPings] $ \i -> forkTry $ do

380+ forM_ [1 .. numPings] $ \i -> forkTry $ do

381 Right conn <- connect endpoint server ReliableOrdered defaultConnectHints

382 send conn [pack $ "ping" ++ show i]

383 send conn [pack $ "ping" ++ show i]

@@ -386,7 +386,7 @@ testParallelConnects transport numPings = do

386 forkTry $ do

387 eventss <- collect endpoint (Just (numPings * 4)) Nothing

388 -- Check that no pings got sent to the wrong connection

389− forM_ eventss $ \(_, [[ping1], [ping2]]) ->

389+ forM_ eventss $ \(_, [[ping1], [ping2]]) ->

390 guard (ping1 == ping2)

391 putMVar done ()

392

@@ -405,13 +405,13 @@ testSendAfterClose transport numRepeats = do

405 replicateM numRepeats $ do

406 Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints

407 Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints

408−

408+

409 -- Close the second, but leave the first open; then output on the second

410 -- connection (i.e., on a closed connection while there is still another

411 -- connection open)

412 close conn2

413 Left (TransportError SendClosed _) <- send conn2 ["ping2"]

414−

414+

415 -- Now close the first connection, and output on it (i.e., output while

416 -- there are no lightweight connection at all anymore)

417 close conn1

@@ -425,7 +425,7 @@ testSendAfterClose transport numRepeats = do

425

426-- | Test that closing the same connection twice has no effect

427testCloseTwice :: Transport -> Int -> IO ()

428−testCloseTwice transport numRepeats = do

428+testCloseTwice transport numRepeats = do

429 server <- spawn transport echoServer

430 clientDone <- newEmptyMVar

431

@@ -436,11 +436,11 @@ testCloseTwice transport numRepeats = do

436 -- We request two lightweight connections

437 Right conn1 <- connect endpoint server ReliableOrdered defaultConnectHints

438 Right conn2 <- connect endpoint server ReliableOrdered defaultConnectHints

439−

439+

440 -- Close the second one twice

441 close conn2

442 close conn2

443−

443+

444 -- Then send a message on the first and close that twice too

445 send conn1 ["ping"]

446 close conn1

@@ -449,11 +449,11 @@ testCloseTwice transport numRepeats = do

449 ConnectionOpened cid1 _ _ <- receive endpoint

450 ConnectionOpened cid2 _ _ <- receive endpoint

451 ConnectionClosed cid2' <- receive endpoint ; True <- return $ cid2' == cid2

452− Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1

452+ Received cid1' ["ping"] <- receive endpoint ; True <- return $ cid1' == cid1

453 ConnectionClosed cid1'' <- receive endpoint ; True <- return $ cid1'' == cid1

454−

454+

455 return ()

456−

456+

457 putMVar clientDone ()

458

459 takeMVar clientDone

@@ -471,7 +471,7 @@ testConnectToSelf transport numPings = do

471

472 -- One thread to write to the endpoint

473 forkTry $ do

474− tlog $ "writing"

474+ tlog $ "writing"

475

476 tlog $ "Sending ping"

477 replicateM_ numPings $ send conn ["ping"]

@@ -513,17 +513,17 @@ testConnectToSelfTwice transport numPings = do

513

514 -- One thread to write to the endpoint using the first connection

515 forkTry $ do

516− tlog $ "writing"

516+ tlog $ "writing"

517

518 tlog $ "Sending ping"

519 replicateM_ numPings $ send conn1 ["pingA"]

520

521 tlog $ "Closing connection"

522 close conn1

523−

523+

524 -- One thread to write to the endpoint using the second connection

525 forkTry $ do

526− tlog $ "writing"

526+ tlog $ "writing"

527

528 tlog $ "Sending ping"

529 replicateM_ numPings $ send conn2 ["pingB"]

@@ -554,11 +554,11 @@ testCloseSelf newTransport = do

554 Right conn1 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints

555 Right conn2 <- connect endpoint1 (address endpoint1) ReliableOrdered defaultConnectHints

556 Right conn3 <- connect endpoint2 (address endpoint2) ReliableOrdered defaultConnectHints

557−

557+

558 -- Close the conneciton and try to send

559 close conn1

560 Left (TransportError SendClosed _) <- send conn1 ["ping"]

561−

561+

562 -- Close the first endpoint. We should not be able to use the first

563 -- connection anymore, or open more self connections, but the self connection

564 -- to the second endpoint should still be fine

@@ -574,7 +574,7 @@ testCloseSelf newTransport = do

574

575 return ()

576

577−-- | Test various aspects of 'closeEndPoint'

577+-- | Test various aspects of 'closeEndPoint'

578testCloseEndPoint :: Transport -> Int -> IO ()

579testCloseEndPoint transport _ = do

580 serverDone <- newEmptyMVar

@@ -598,7 +598,7 @@ testCloseEndPoint transport _ = do

598 -- Second test

599 do

600 theirAddr <- readMVar clientAddr2

601−

601+

602 ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr

603 Received cid' ["ping"] <- receive endpoint ; True <- return $ cid == cid'

604

@@ -609,7 +609,7 @@ testCloseEndPoint transport _ = do

609 ErrorEvent (TransportError (EventConnectionLost addr') _) <- receive endpoint ; True <- return $ addr' == theirAddr

610

611 Left (TransportError SendFailed _) <- send conn ["pong2"]

612−

612+

613 return ()

614

615 putMVar serverDone ()

@@ -621,7 +621,7 @@ testCloseEndPoint transport _ = do

621 -- First test: close endpoint with one outgoing but no incoming connections

622 do

623 Right endpoint <- newEndPoint transport

624− putMVar clientAddr1 (address endpoint)

624+ putMVar clientAddr1 (address endpoint)

625

626 -- Connect to the server, then close the endpoint without disconnecting explicitly

627 Right _ <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

@@ -632,7 +632,7 @@ testCloseEndPoint transport _ = do

632 -- Second test: close endpoint with one outgoing and one incoming connection

633 do

634 Right endpoint <- newEndPoint transport

635− putMVar clientAddr2 (address endpoint)

635+ putMVar clientAddr2 (address endpoint)

636

637 Right conn <- connect endpoint theirAddr ReliableOrdered defaultConnectHints

638 send conn ["ping"]

@@ -641,7 +641,7 @@ testCloseEndPoint transport _ = do

641 ConnectionOpened cid ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr

642 Received cid' ["pong"] <- receive endpoint ; True <- return $ cid == cid'

643

644− -- Close the endpoint

644+ -- Close the endpoint

645 closeEndPoint endpoint

646 EndPointClosed <- receive endpoint

647

@@ -677,13 +677,13 @@ testCloseTransport newTransport = do

677 Right endpoint <- newEndPoint transport

678 putMVar serverAddr (address endpoint)

679

680− -- Client sets up first endpoint

680+ -- Client sets up first endpoint

681 theirAddr1 <- readMVar clientAddr1

682 ConnectionOpened cid1 ReliableOrdered addr <- receive endpoint ; True <- return $ addr == theirAddr1

683

684− -- Client sets up second endpoint

684+ -- Client sets up second endpoint

685 theirAddr2 <- readMVar clientAddr2

686−

686+

687 ConnectionOpened cid2 ReliableOrdered addr' <- receive endpoint ; True <- return $ addr' == theirAddr2

688 Received cid2' ["ping"] <- receive endpoint ; True <- return $ cid2' == cid2

689

@@ -702,7 +702,7 @@ testCloseTransport newTransport = do

702

703 -- An attempt to send to the endpoint should now fail

704 Left (TransportError SendFailed _) <- send conn ["pong2"]

705−

705+

706 putMVar serverDone ()

707

708 -- Client

@@ -712,14 +712,14 @@ testCloseTransport newTransport = do

712

713 -- Set up endpoint with one outgoing but no incoming connections

714 Right endpoint1 <- newEndPoint transport

715− putMVar clientAddr1 (address endpoint1)

715+ putMVar clientAddr1 (address endpoint1)

716

717 -- Connect to the server, then close the endpoint without disconnecting explicitly

718 Right _ <- connect endpoint1 theirAddr ReliableOrdered defaultConnectHints

719

720 -- Set up an endpoint with one outgoing and out incoming connection

721 Right endpoint2 <- newEndPoint transport

722− putMVar clientAddr2 (address endpoint2)

722+ putMVar clientAddr2 (address endpoint2)

723

724 Right conn <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints

725 send conn ["ping"]

@@ -746,7 +746,7 @@ testCloseTransport newTransport = do

746 Left (TransportError ConnectFailed _) <- connect endpoint2 theirAddr ReliableOrdered defaultConnectHints

747

748 -- And finally, so should an attempt to create a new endpoint

749− Left (TransportError NewEndPointFailed _) <- newEndPoint transport

749+ Left (TransportError NewEndPointFailed _) <- newEndPoint transport

750

751 putMVar clientDone ()

752

@@ -758,7 +758,7 @@ testConnectClosedEndPoint transport = do

758 serverAddr <- newEmptyMVar

759 serverClosed <- newEmptyMVar

760 clientDone <- newEmptyMVar

761−

761+

762 -- Server

763 forkTry $ do

764 Right endpoint <- newEndPoint transport

@@ -770,12 +770,12 @@ testConnectClosedEndPoint transport = do

770 -- Client

771 forkTry $ do

772 Right endpoint <- newEndPoint transport

773− readMVar serverClosed

773+ readMVar serverClosed

774

775 Left (TransportError ConnectNotFound _) <- readMVar serverAddr >>= \addr -> connect endpoint addr ReliableOrdered defaultConnectHints

776

777 putMVar clientDone ()

778−

778+

779 takeMVar clientDone

780

781-- | We should receive an exception when doing a 'receive' after we have been

@@ -783,7 +783,7 @@ testConnectClosedEndPoint transport = do

783testExceptionOnReceive :: IO (Either String Transport) -> IO ()

784testExceptionOnReceive newTransport = do

785 Right transport <- newTransport

786−

786+

787 -- Test one: when we close an endpoint specifically

788 Right endpoint1 <- newEndPoint transport

789 closeEndPoint endpoint1

@@ -804,7 +804,7 @@ testSendException newTransport = do

804 Right transport <- newTransport

805 Right endpoint1 <- newEndPoint transport

806 Right endpoint2 <- newEndPoint transport

807−

807+

808 -- Connect endpoint1 to endpoint2

809 Right conn <- connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints

810 ConnectionOpened _ _ _ <- receive endpoint2

@@ -814,7 +814,7 @@ testSendException newTransport = do

814

815 -- This will have been as a failure to send by endpoint1, which will

816 -- therefore have closed the socket. In turn this will have caused endpoint2

817− -- to report that the connection was lost

817+ -- to report that the connection was lost

818 ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint1

819 ErrorEvent (TransportError (EventConnectionLost _) _) <- receive endpoint2

820

@@ -831,27 +831,27 @@ testSendException newTransport = do

831

832-- | If threads get killed while executing a 'connect', 'send', or 'close', this

833-- should not affect other threads.

834−--

834+--

835-- The intention of this test is to see what happens when a asynchronous

836-- exception happes _while executing a send_. This is exceedingly difficult to

837-- guarantee, however. Hence we run a large number of tests and insert random

838-- thread delays -- and even then it might not happen. Moreover, it will only

839−-- happen when we run on multiple cores.

839+-- happen when we run on multiple cores.

840testKill :: IO (Either String Transport) -> Int -> IO ()

841testKill newTransport numThreads = do

842 Right transport1 <- newTransport

843 Right transport2 <- newTransport

844 Right endpoint1 <- newEndPoint transport1

845 Right endpoint2 <- newEndPoint transport2

846−

846+

847− threads <- replicateM numThreads . forkIO $ do

847+ threads <- replicateM numThreads . forkIO $ do

848− randomThreadDelay 100

848+ randomThreadDelay 100

849 bracket (connect endpoint1 (address endpoint2) ReliableOrdered defaultConnectHints)

850− -- Note that we should not insert a randomThreadDelay into the

850+ -- Note that we should not insert a randomThreadDelay into the

851 -- exception handler itself as this means that the exception handler

852 -- could be interrupted and we might not close

853 (\(Right conn) -> close conn)

854− (\(Right conn) -> do randomThreadDelay 100

854+ (\(Right conn) -> do randomThreadDelay 100

855 Right () <- send conn ["ping"]

856 randomThreadDelay 100)

857

@@ -861,26 +861,26 @@ testKill newTransport numThreads = do

861 forkIO . forM_ threads $ \tid -> do

862 shouldKill <- randomIO

863 if shouldKill

864− then randomThreadDelay 600 >> killThread tid

864+ then randomThreadDelay 600 >> killThread tid

865 else modifyMVar_ numAlive (return . (+ 1))

866

867 -- Since it is impossible to predict when the kill exactly happens, we don't

868 -- know how many connects were opened and how many pings were sent. But we

869 -- should not have any open connections (if we do, collect will throw an

870 -- error) and we should have at least the number of pings equal to the number

871− -- of threads we did *not* kill

871+ -- of threads we did *not* kill

872− eventss <- collect endpoint2 Nothing (Just 1000000)

872+ eventss <- collect endpoint2 Nothing (Just 1000000)

873 let actualPings = sum . map (length . snd) $ eventss

874 expectedPings <- takeMVar numAlive

875− unless (actualPings >= expectedPings) $

875+ unless (actualPings >= expectedPings) $

876 throwIO (userError "Missing pings")

877−

877+

878-- print (actualPings, expectedPings)

879

880

881-- | Set up conditions with a high likelyhood of "crossing" (for transports

882-- that multiplex lightweight connections across heavyweight connections)

883−testCrossing :: Transport -> Int -> IO ()

883+testCrossing :: Transport -> Int -> IO ()

884testCrossing transport numRepeats = do

885 [aAddr, bAddr] <- replicateM 2 newEmptyMVar

886 [aDone, bDone] <- replicateM 2 newEmptyMVar

@@ -902,10 +902,10 @@ testCrossing transport numRepeats = do

902 -- Because we are creating lots of connections, it's possible that

903 -- connect times out (for instance, in the TCP transport,

904 -- Network.Socket.connect may time out). We shouldn't regard this as an

905− -- error in the Transport, though.

905+ -- error in the Transport, though.

906 connectResult <- connect endpoint theirAddress ReliableOrdered hints

907 case connectResult of

908− Right conn -> close conn

908+ Right conn -> close conn

909 Left (TransportError ConnectTimeout _) -> putMVar aTimeout ()

910 Left (TransportError ConnectFailed _) -> readMVar bTimeout

911 Left err -> throwIO . userError $ "testCrossed: " ++ show err

@@ -916,23 +916,23 @@ testCrossing transport numRepeats = do

916 Right endpoint <- newEndPoint transport

917 putMVar bAddr (address endpoint)

918 theirAddress <- readMVar aAddr

919−

919+

920 replicateM_ numRepeats $ do

921 takeMVar bGo >> yield

922 connectResult <- connect endpoint theirAddress ReliableOrdered hints

923 case connectResult of

924− Right conn -> close conn

924+ Right conn -> close conn

925− Left (TransportError ConnectTimeout _) -> putMVar bTimeout ()

925+ Left (TransportError ConnectTimeout _) -> putMVar bTimeout ()

926 Left (TransportError ConnectFailed _) -> readMVar aTimeout

927 Left err -> throwIO . userError $ "testCrossed: " ++ show err

928 putMVar bDone ()

929−

929+

930 -- Driver

931 forM_ [1 .. numRepeats] $ \_i -> do

932 -- putStrLn $ "Round " ++ show _i

933 tryTakeMVar aTimeout

934 tryTakeMVar bTimeout

935− b <- randomIO

935+ b <- randomIO

936 if b then do putMVar aGo () ; putMVar bGo ()

937 else do putMVar bGo () ; putMVar aGo ()

938 yield

@@ -954,14 +954,14 @@ testTransport newTransport = do

954 , ("SendAfterClose", testSendAfterClose transport 100)

955 , ("Crossing", testCrossing transport 10)

956 , ("CloseTwice", testCloseTwice transport 100)

957− , ("ConnectToSelf", testConnectToSelf transport numPings)

957+ , ("ConnectToSelf", testConnectToSelf transport numPings)

958 , ("ConnectToSelfTwice", testConnectToSelfTwice transport numPings)

959 , ("CloseSelf", testCloseSelf newTransport)

960− , ("CloseEndPoint", testCloseEndPoint transport numPings)

960+ , ("CloseEndPoint", testCloseEndPoint transport numPings)

961 , ("CloseTransport", testCloseTransport newTransport)

962 , ("ConnectClosedEndPoint", testConnectClosedEndPoint transport)

963 , ("ExceptionOnReceive", testExceptionOnReceive newTransport)

964− , ("SendException", testSendException newTransport)

964+ , ("SendException", testSendException newTransport)

965 , ("Kill", testKill newTransport 1000)

966 ]

967 where

network-transport-tests/src/Network/Transport/Tests/Auxiliary.hs+14−14

@@ -30,7 +30,7 @@ import Network.Transport

30import Network.Transport.Tests.Traced (Traceable(..), traceShow)

32-- | Like fork, but throw exceptions in the child thread to the parent

33−forkTry :: IO () -> IO ThreadId

33+forkTry :: IO () -> IO ThreadId

34forkTry p = do

35 tid <- myThreadId

36 forkIO $ catch p (\e -> throwTo tid (e :: SomeException))

@@ -40,17 +40,17 @@ trySome :: IO a -> IO (Either SomeException a)

40trySome = try

42-- | Run the given test, catching timeouts and exceptions

43−runTest :: String -> IO () -> IO Bool

43+runTest :: String -> IO () -> IO Bool

44runTest description test = do

45 putStr $ "Running " ++ show description ++ ": "

46 hFlush stdout

47 done <- try . timeout 60000000 $ test -- 60 seconds

48 case done of

49− Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"

49+ Left err -> failed $ "(exception: " ++ show (err :: SomeException) ++ ")"

50 Right Nothing -> failed $ "(timeout)"

51− Right (Just ()) -> ok

51+ Right (Just ()) -> ok

52 where

53− failed :: String -> IO Bool

53+ failed :: String -> IO Bool

54 failed err = do

55 setSGR [SetColor Foreground Vivid Red]

56 putStr "failed "

@@ -58,43 +58,43 @@ runTest description test = do

58 putStrLn err

59 return False

61− ok :: IO Bool

61+ ok :: IO Bool

62 ok = do

63 setSGR [SetColor Foreground Vivid Green]

64 putStrLn "ok"

65 setSGR [Reset]

66 return True

68−-- | Run a bunch of tests and throw an exception if any fails

68+-- | Run a bunch of tests and throw an exception if any fails

69runTests :: [(String, IO ())] -> IO ()

70runTests tests = do

71 success <- foldr (liftM2 (&&) . uncurry runTest) (return True) $ tests

72 unless success $ fail "Some tests failed"

74−-- | Random thread delay between 0 and the specified max

74+-- | Random thread delay between 0 and the specified max

75randomThreadDelay :: Int -> IO ()

76randomThreadDelay maxDelay = do

77 delay <- randomIO :: IO Int

78− threadDelay (delay `mod` maxDelay)

78+ threadDelay (delay `mod` maxDelay)

80--------------------------------------------------------------------------------

81−-- traceShow instances --

81+-- traceShow instances --

82--------------------------------------------------------------------------------

84instance Traceable EndPoint where

85 trace = const Nothing

87instance Traceable Transport where

88− trace = const Nothing

88+ trace = const Nothing

90instance Traceable Connection where

91− trace = const Nothing

91+ trace = const Nothing

93instance Traceable Event where

94− trace = traceShow

94+ trace = traceShow

96instance Show err => Traceable (TransportError err) where

97− trace = traceShow

97+ trace = traceShow

99instance Traceable EndPointAddress where

100 trace = traceShow . endPointAddressToByteString

network-transport-tests/src/Network/Transport/Tests/Multicast.hs+15−15

@@ -10,10 +10,10 @@ import Network.Transport.Tests.Auxiliary (runTests)

11-- | Node for the "No confusion" test

12noConfusionNode :: Transport -- ^ Transport

13− -> [MVar MulticastAddress] -- ^ my group : groups to subscribe to

13+ -> [MVar MulticastAddress] -- ^ my group : groups to subscribe to

14 -> [MVar ()] -- ^ I'm ready : others ready

15 -> Int -- ^ number of pings

16− -> [ByteString] -- ^ my message : messages from subscribed groups (same order as 'groups to subscribe to')

16+ -> [ByteString] -- ^ my message : messages from subscribed groups (same order as 'groups to subscribe to')

17 -> MVar () -- ^ I'm done

18 -> IO ()

19noConfusionNode transport groups ready numPings msgs done = do

@@ -25,8 +25,8 @@ noConfusionNode transport groups ready numPings msgs done = do

25 putMVar (head groups) (multicastAddress myGroup)

27 -- Subscribe to the given multicast groups

28− addrs <- mapM readMVar (tail groups)

28+ addrs <- mapM readMVar (tail groups)

29− forM_ addrs $ \addr -> do Right group <- resolveMulticastGroup endpoint addr

29+ forM_ addrs $ \addr -> do Right group <- resolveMulticastGroup endpoint addr

30 multicastSubscribe group

32 -- Indicate that we're ready and wait for everybody else to be ready

@@ -42,31 +42,31 @@ noConfusionNode transport groups ready numPings msgs done = do

42 case event of

43 ReceivedMulticast addr [msg] ->

44 let mix = addr `elemIndex` addrs in

45− case mix of

45+ case mix of

46 Nothing -> error "Message from unexpected source"

47 Just ix -> when (msgs !! (ix + 1) /= msg) $ error "Unexpected message"

48 _ ->

49 error "Unexpected event"

51 -- Success

52− putMVar done ()

52+ putMVar done ()

54-- | Test that distinct multicast groups are not confused

55−testNoConfusion :: Transport -> Int -> IO ()

55+testNoConfusion :: Transport -> Int -> IO ()

56testNoConfusion transport numPings = do

57 [group1, group2, group3] <- replicateM 3 newEmptyMVar

58 [readyA, readyB, readyC] <- replicateM 3 newEmptyMVar

59 [doneA, doneB, doneC] <- replicateM 3 newEmptyMVar

60 let [msgA, msgB, msgC] = ["A says hi", "B says hi", "C says hi"]

62− forkIO $ noConfusionNode transport [group1, group1, group2] [readyA, readyB, readyC] numPings [msgA, msgA, msgB] doneA

62+ forkIO $ noConfusionNode transport [group1, group1, group2] [readyA, readyB, readyC] numPings [msgA, msgA, msgB] doneA

63− forkIO $ noConfusionNode transport [group2, group1, group3] [readyB, readyC, readyA] numPings [msgB, msgA, msgC] doneB

63+ forkIO $ noConfusionNode transport [group2, group1, group3] [readyB, readyC, readyA] numPings [msgB, msgA, msgC] doneB

64− forkIO $ noConfusionNode transport [group3, group2, group3] [readyC, readyA, readyB] numPings [msgC, msgB, msgC] doneC

64+ forkIO $ noConfusionNode transport [group3, group2, group3] [readyC, readyA, readyB] numPings [msgC, msgB, msgC] doneC

65−

65+

66− mapM_ takeMVar [doneA, doneB, doneC]

66+ mapM_ takeMVar [doneA, doneB, doneC]

68-- | Test multicast

69−testMulticast :: Transport -> IO ()

69+testMulticast :: Transport -> IO ()

70−testMulticast transport =

70+testMulticast transport =

71− runTests

71+ runTests

72 [ ("NoConfusion", testNoConfusion transport 10000) ]

network-transport-tests/src/Network/Transport/Tests/Traced.hs+31−31

@@ -1,7 +1,7 @@

1−-- | Add tracing to the IO monad (see examples).

1+-- | Add tracing to the IO monad (see examples).

2−--

2+--

3-- [Usage]

4−--

4+--

5-- > {-# LANGUAGE RebindableSyntax #-}

6-- > import Prelude hiding (catch, (>>=), (>>), return, fail)

7-- > import Traced

@@ -15,7 +15,7 @@

15-- > Right y <- return (Left 2 :: Either Int Int)

16-- > return (x + y)

17--

18−-- outputs

18+-- outputs

19--

20-- > Hello world

21-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:187:3-9)

@@ -31,7 +31,7 @@

31-- > test2 = do

32-- > Left x <- return (Left 1 :: Either Int Int)

33-- > True <- return (x == 3)

34−-- > return x

34+-- > return x

35--

36-- The advantage of this idiom is that it gives you line number information when the guard fails:

37--

@@ -39,7 +39,7 @@

39-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:193:3-6)

40-- > Trace:

41-- > 0 Left 1

42−module Network.Transport.Tests.Traced

42+module Network.Transport.Tests.Traced

43 ( MonadS(..)

44 , return

45 , (>>=)

@@ -51,7 +51,7 @@ module Network.Transport.Tests.Traced

51 , traceShow

52 ) where

54−import Prelude hiding

54+import Prelude hiding

55 ( (>>=)

56 , return

57 , fail

@@ -76,12 +76,12 @@ import Control.Concurrent.MVar (MVar)

77-- | Like 'Monad' but bind is only defined for 'Trace'able instances

78class MonadS m where

79− returnS :: a -> m a

79+ returnS :: a -> m a

80 bindS :: Traceable a => m a -> (a -> m b) -> m b

81 failS :: String -> m a

82 seqS :: m a -> m b -> m b

84−-- | Redefinition of 'Prelude.>>='

84+-- | Redefinition of 'Prelude.>>='

85(>>=) :: (MonadS m, Traceable a) => m a -> (a -> m b) -> m b

86(>>=) = bindS

@@ -95,7 +95,7 @@ return = returnS

96-- | Redefinition of 'Prelude.fail'

97fail :: MonadS m => String -> m a

98−fail = failS

98+fail = failS

100--------------------------------------------------------------------------------

101-- Trace typeclass (for adding elements to a trace --

@@ -106,17 +106,17 @@ data Showable = forall a. Show a => Showable a

106instance Show Showable where

107 show (Showable x) = show x

108

109−mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable

109+mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable

110−mapShowable f (Showable x) = f x

110+mapShowable f (Showable x) = f x

111

112traceShow :: Show a => a -> Maybe Showable

113−traceShow = Just . Showable

113+traceShow = Just . Showable

114

115class Traceable a where

116− trace :: a -> Maybe Showable

116+ trace :: a -> Maybe Showable

117

118instance (Traceable a, Traceable b) => Traceable (Either a b) where

119− trace (Left x) = (mapShowable $ Showable . (Left :: forall c. c -> Either c ())) <$> trace x

119+ trace (Left x) = (mapShowable $ Showable . (Left :: forall c. c -> Either c ())) <$> trace x

120 trace (Right y) = (mapShowable $ Showable . (Right :: forall c. c -> Either () c)) <$> trace y

121

122instance (Traceable a, Traceable b) => Traceable (a, b) where

@@ -128,7 +128,7 @@ instance (Traceable a, Traceable b) => Traceable (a, b) where

128

129instance (Traceable a, Traceable b, Traceable c) => Traceable (a, b, c) where

130 trace (x, y, z) = case (trace x, trace y, trace z) of

131− (Nothing, Nothing, Nothing) -> Nothing

131+ (Nothing, Nothing, Nothing) -> Nothing

132 (Just t1, Nothing, Nothing) -> traceShow t1

133 (Nothing, Just t2, Nothing) -> traceShow t2

134 (Just t1, Just t2, Nothing) -> traceShow (t1, t2)

@@ -139,40 +139,40 @@ instance (Traceable a, Traceable b, Traceable c) => Traceable (a, b, c) where

139

140instance Traceable a => Traceable (Maybe a) where

141 trace Nothing = traceShow (Nothing :: Maybe ())

142− trace (Just x) = mapShowable (Showable . Just) <$> trace x

142+ trace (Just x) = mapShowable (Showable . Just) <$> trace x

143

144instance Traceable a => Traceable [a] where

145− trace = traceShow . catMaybes . map trace

145+ trace = traceShow . catMaybes . map trace

146

147instance Traceable () where

148− trace = const Nothing

148+ trace = const Nothing

149

150instance Traceable Int where

151− trace = traceShow

151+ trace = traceShow

152

153instance Traceable Int32 where

154− trace = traceShow

154+ trace = traceShow

155

156instance Traceable Int64 where

157− trace = traceShow

157+ trace = traceShow

158

159instance Traceable Word32 where

160− trace = traceShow

160+ trace = traceShow

161

162instance Traceable Word64 where

163− trace = traceShow

163+ trace = traceShow

164

165instance Traceable Bool where

166− trace = const Nothing

166+ trace = const Nothing

167

168instance Traceable ByteString where

169− trace = traceShow

169+ trace = traceShow

170

171instance Traceable (MVar a) where

172− trace = const Nothing

172+ trace = const Nothing

173

174instance Traceable [Char] where

175− trace = traceShow

175+ trace = traceShow

176

177instance Traceable IOException where

178 trace = traceShow

@@ -186,7 +186,7 @@ data TracedException = TracedException [String] SomeException

186

187instance Exception TracedException

188

189−-- | Add tracing to 'IO' (see examples)

189+-- | Add tracing to 'IO' (see examples)

190instance MonadS IO where

191 returnS = Prelude.return

192 bindS = \x f -> x Prelude.>>= \a -> catches (f a) (traceHandlers a)

@@ -194,7 +194,7 @@ instance MonadS IO where

194 seqS = (Prelude.>>)

195

196instance Show TracedException where

197− show (TracedException ts ex) =

197+ show (TracedException ts ex) =

198 show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (take 10 . reverse $ ts)))

199

200traceHandlers :: Traceable a => a -> [Handler b]

@@ -204,7 +204,7 @@ traceHandlers a = case trace a of

204 , Handler $ \ex -> throwIO $ TracedException [show t] (ex :: SomeException)

205 ]

206

207−-- | Definition of 'ifThenElse' for use with RebindableSyntax

207+-- | Definition of 'ifThenElse' for use with RebindableSyntax

208ifThenElse :: Bool -> a -> a -> a

209ifThenElse True x _ = x

210ifThenElse False _ y = y

network-transport/src/Network/Transport.hs+36−36

@@ -1,5 +1,5 @@

1−-- | Network Transport

1+-- | Network Transport

2−module Network.Transport

2+module Network.Transport

3 ( -- * Types

4 Transport(..)

5 , EndPoint(..)

@@ -41,8 +41,8 @@ import Data.Word (Word64)

41data Transport = Transport {

42 -- | Create a new end point (heavyweight operation)

43 newEndPoint :: IO (Either (TransportError NewEndPointErrorCode) EndPoint)

44− -- | Shutdown the transport completely

44+ -- | Shutdown the transport completely

45− , closeTransport :: IO ()

45+ , closeTransport :: IO ()

46 }

48-- | Network endpoint.

@@ -50,8 +50,8 @@ data EndPoint = EndPoint {

50 -- | Endpoints have a single shared receive queue.

51 receive :: IO Event

52 -- | EndPointAddress of the endpoint.

53− , address :: EndPointAddress

53+ , address :: EndPointAddress

54− -- | Create a new lightweight connection.

54+ -- | Create a new lightweight connection.

55 --

56 -- 'connect' should be as asynchronous as possible; for instance, in

57 -- Transport implementations based on some heavy-weight underlying network

@@ -64,12 +64,12 @@ data EndPoint = EndPoint {

64 , resolveMulticastGroup :: MulticastAddress -> IO (Either (TransportError ResolveMulticastGroupErrorCode) MulticastGroup)

65 -- | Close the endpoint

66 , closeEndPoint :: IO ()

67− }

67+ }

69-- | Lightweight connection to an endpoint.

70data Connection = Connection {

71 -- | Send a message on this connection.

72− --

72+ --

73 -- 'send' provides vectored I/O, and allows multiple data segments to be

74 -- sent using a single call (cf. 'Network.Socket.ByteString.sendMany').

75 -- Note that this segment structure is entirely unrelated to the segment

@@ -80,7 +80,7 @@ data Connection = Connection {

80 }

82-- | Event on an endpoint.

83−data Event =

83+data Event =

84 -- | Received a message

85 Received {-# UNPACK #-} !ConnectionId [ByteString]

86 -- | Connection closed

@@ -88,33 +88,33 @@ data Event =

88 -- | Connection opened

89 --

90 -- 'ConnectionId's need not be allocated contiguously.

91− | ConnectionOpened {-# UNPACK #-} !ConnectionId Reliability EndPointAddress

91+ | ConnectionOpened {-# UNPACK #-} !ConnectionId Reliability EndPointAddress

92 -- | Received multicast

93 | ReceivedMulticast MulticastAddress [ByteString]

94 -- | The endpoint got closed (manually, by a call to closeEndPoint or closeTransport)

95 | EndPointClosed

96− -- | An error occurred

96+ -- | An error occurred

97− | ErrorEvent (TransportError EventErrorCode)

97+ | ErrorEvent (TransportError EventErrorCode)

98 deriving (Show, Eq)

100-- | Connection data ConnectHintsIDs enable receivers to distinguish one connection from another.

101−type ConnectionId = Word64

101+type ConnectionId = Word64

102

103-- | Reliability guarantees of a connection.

104−data Reliability =

104+data Reliability =

105− ReliableOrdered

105+ ReliableOrdered

106− | ReliableUnordered

106+ | ReliableUnordered

107 | Unreliable

108 deriving (Show, Eq)

109

110-- | Multicast group.

111data MulticastGroup = MulticastGroup {

112− -- | EndPointAddress of the multicast group.

112+ -- | EndPointAddress of the multicast group.

113 multicastAddress :: MulticastAddress

114 -- | Delete the multicast group completely.

115 , deleteMulticastGroup :: IO ()

116 -- | Maximum message size that we can send to this group.

117− , maxMsgSize :: Maybe Int

117+ , maxMsgSize :: Maybe Int

118 -- | Send a message to the group.

119 , multicastSend :: [ByteString] -> IO ()

120 -- | Subscribe to the given multicast group (to start receiving messages from the group).

@@ -172,13 +172,13 @@ defaultConnectHints = ConnectHints {

172--------------------------------------------------------------------------------

173

174-- | Errors returned by Network.Transport API functions consist of an error

175−-- code and a human readable description of the problem

175+-- code and a human readable description of the problem

176data TransportError error = TransportError error String

177 deriving (Show, Typeable)

178

179-- | Although the functions in the transport API never throw TransportErrors

180-- (but return them explicitly), application code may want to turn these into

181−-- exceptions.

181+-- exceptions.

182instance (Typeable err, Show err) => Exception (TransportError err)

183

184-- | When comparing errors we ignore the human-readable strings

@@ -190,19 +190,19 @@ data NewEndPointErrorCode =

190 -- | Not enough resources

191 NewEndPointInsufficientResources

192 -- | Failed for some other reason

193− | NewEndPointFailed

193+ | NewEndPointFailed

194 deriving (Show, Typeable, Eq)

195

196−-- | Connection failure

196+-- | Connection failure

197−data ConnectErrorCode =

197+data ConnectErrorCode =

198− -- | Could not resolve the address

198+ -- | Could not resolve the address

199 ConnectNotFound

200 -- | Insufficient resources (for instance, no more sockets available)

201− | ConnectInsufficientResources

201+ | ConnectInsufficientResources

202 -- | Timeout

203 | ConnectTimeout

204 -- | Failed for other reasons (including syntax error)

205− | ConnectFailed

205+ | ConnectFailed

206 deriving (Show, Typeable, Eq)

207

208-- | Failure during the creation of a new multicast group

@@ -221,7 +221,7 @@ data ResolveMulticastGroupErrorCode =

221 ResolveMulticastGroupNotFound

222 -- | Failed for some other reason (including syntax error)

223 | ResolveMulticastGroupFailed

224− -- | Not all transport implementations support multicast

224+ -- | Not all transport implementations support multicast

225 | ResolveMulticastGroupUnsupported

226 deriving (Show, Typeable, Eq)

227

@@ -230,12 +230,12 @@ data SendErrorCode =

230 -- | Connection was closed

231 SendClosed

232 -- | Send failed for some other reason

233− | SendFailed

233+ | SendFailed

234 deriving (Show, Typeable, Eq)

235

236-- | Error codes used when reporting errors to endpoints (through receive)

237−data EventErrorCode =

237+data EventErrorCode =

238− -- | Failure of the entire endpoint

238+ -- | Failure of the entire endpoint

239 EventEndPointFailed

240 -- | Transport-wide fatal error

241 | EventTransportFailed

@@ -247,27 +247,27 @@ data EventErrorCode =

247 -- both directions, must now be considered to have failed; they fail as a

248 -- "bundle" of connections, with only a single "bundle" of connections per

249 -- endpoint at any point in time.

250− --

250+ --

251 -- That is, suppose there are multiple connections in either direction

252 -- between endpoints A and B, and A receives a notification that it has

253 -- lost contact with B. Then A must not be able to send any further

254− -- messages to B on existing connections.

254+ -- messages to B on existing connections.

255 --

256 -- Although B may not realize /immediately/ that its connection to A has

257 -- been broken, messages sent by B on existing connections should not be

258 -- delivered, and B must eventually get an EventConnectionLost message,

259− -- too.

259+ -- too.

260 --

261 -- Moreover, this event must be posted before A has successfully

262 -- reconnected (in other words, if B notices a reconnection attempt from A,

263 -- it must post the EventConnectionLost before acknowledging the connection

264 -- from A) so that B will not receive events about new connections or

265− -- incoming messages from A without realizing that it got disconnected.

265+ -- incoming messages from A without realizing that it got disconnected.

266− --

266+ --

267 -- If B attempts to establish another connection to A before it realized

268 -- that it got disconnected from A then it's okay for this connection

269 -- attempt to fail, and the EventConnectionLost to be posted at that point,

270 -- or for the EventConnectionLost to be posted and for the new connection

271 -- to be considered the first connection of the "new bundle".

272− | EventConnectionLost EndPointAddress

272+ | EventConnectionLost EndPointAddress

273 deriving (Show, Typeable, Eq)

network-transport/src/Network/Transport/Internal.hs+26−26

@@ -1,5 +1,5 @@

1-- | Internal functions

2−module Network.Transport.Internal

2+module Network.Transport.Internal

3 ( -- * Encoders/decoders

4 encodeInt32

5 , decodeInt32

@@ -28,13 +28,13 @@ import Foreign.C (CInt(..), CShort(..))

28import Foreign.ForeignPtr (withForeignPtr)

29import Data.ByteString (ByteString)

30import qualified Data.ByteString as BS (length)

31−import qualified Data.ByteString.Internal as BSI

31+import qualified Data.ByteString.Internal as BSI

32 ( unsafeCreate

33 , toForeignPtr

34 , inlinePerformIO

35 )

36import Control.Monad.IO.Class (MonadIO, liftIO)

37−import Control.Exception

37+import Control.Exception

38 ( IOException

39 , SomeException

40 , AsyncException

@@ -56,36 +56,36 @@ foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt

56foreign import ccall unsafe "htons" htons :: CShort -> CShort

57foreign import ccall unsafe "ntohs" ntohs :: CShort -> CShort

59−-- | Serialize 32-bit to network byte order

59+-- | Serialize 32-bit to network byte order

60encodeInt32 :: Enum a => a -> ByteString

61−encodeInt32 i32 =

61+encodeInt32 i32 =

62 BSI.unsafeCreate 4 $ \p ->

63 pokeByteOff p 0 (htonl . fromIntegral . fromEnum $ i32)

65−-- | Deserialize 32-bit from network byte order

65+-- | Deserialize 32-bit from network byte order

66-- Throws an IO exception if this is not a valid integer.

67−decodeInt32 :: Num a => ByteString -> a

67+decodeInt32 :: Num a => ByteString -> a

68−decodeInt32 bs

68+decodeInt32 bs

69− | BS.length bs /= 4 = throw $ userError "decodeInt32: Invalid length"

69+ | BS.length bs /= 4 = throw $ userError "decodeInt32: Invalid length"

70− | otherwise = BSI.inlinePerformIO $ do

70+ | otherwise = BSI.inlinePerformIO $ do

71− let (fp, offset, _) = BSI.toForeignPtr bs

71+ let (fp, offset, _) = BSI.toForeignPtr bs

72 withForeignPtr fp $ \p -> do

73− w32 <- peekByteOff p offset

73+ w32 <- peekByteOff p offset

74 return (fromIntegral . ntohl $ w32)

76−-- | Serialize 16-bit to network byte order

76+-- | Serialize 16-bit to network byte order

77−encodeInt16 :: Enum a => a -> ByteString

77+encodeInt16 :: Enum a => a -> ByteString

78−encodeInt16 i16 =

78+encodeInt16 i16 =

79 BSI.unsafeCreate 2 $ \p ->

80 pokeByteOff p 0 (htons . fromIntegral . fromEnum $ i16)

82−-- | Deserialize 16-bit from network byte order

82+-- | Deserialize 16-bit from network byte order

83-- Throws an IO exception if this is not a valid integer

84decodeInt16 :: Num a => ByteString -> a

85−decodeInt16 bs

85+decodeInt16 bs

86− | BS.length bs /= 2 = throw $ userError "decodeInt16: Invalid length"

86+ | BS.length bs /= 2 = throw $ userError "decodeInt16: Invalid length"

87 | otherwise = BSI.inlinePerformIO $ do

88− let (fp, offset, _) = BSI.toForeignPtr bs

88+ let (fp, offset, _) = BSI.toForeignPtr bs

89 withForeignPtr fp $ \p -> do

90 w16 <- peekByteOff p offset

91 return (fromIntegral . ntohs $ w16)

@@ -120,17 +120,17 @@ forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId

120forkIOWithUnmask io = forkIO (io unsafeUnmask)

121

122-- | Safe version of 'toEnum'

123−tryToEnum :: (Enum a, Bounded a) => Int -> Maybe a

123+tryToEnum :: (Enum a, Bounded a) => Int -> Maybe a

124tryToEnum = go minBound maxBound

125 where

126 go :: Enum b => b -> b -> Int -> Maybe b

127− go lo hi n = if fromEnum lo <= n && n <= fromEnum hi then Just (toEnum n) else Nothing

127+ go lo hi n = if fromEnum lo <= n && n <= fromEnum hi then Just (toEnum n) else Nothing

128

129-- | If the timeout value is not Nothing, wrap the given computation with a

130-- timeout and it if times out throw the specified exception. Identity

131-- otherwise.

132timeoutMaybe :: Exception e => Maybe Int -> e -> IO a -> IO a

133−timeoutMaybe Nothing _ f = f

133+timeoutMaybe Nothing _ f = f

134timeoutMaybe (Just n) e f = do

135 ma <- timeout n f

136 case ma of

@@ -138,19 +138,19 @@ timeoutMaybe (Just n) e f = do

138 Just a -> return a

139

140-- | @asyncWhenCancelled g f@ runs f in a separate thread and waits for it

141−-- to complete. If f throws an exception we catch it and rethrow it in the

141+-- to complete. If f throws an exception we catch it and rethrow it in the

142-- current thread. If the current thread is interrupted before f completes,

143-- we run the specified clean up handler (if f throws an exception we assume

144-- that no cleanup is necessary).

145asyncWhenCancelled :: forall a. (a -> IO ()) -> IO a -> IO a

146asyncWhenCancelled g f = mask_ $ do

147 mvar <- newEmptyMVar

148− forkIO $ try f >>= putMVar mvar

148+ forkIO $ try f >>= putMVar mvar

149 -- takeMVar is interruptible (even inside a mask_)

150 catch (takeMVar mvar) (exceptionHandler mvar) >>= either throwIO return

151 where

152− exceptionHandler :: MVar (Either SomeException a)

152+ exceptionHandler :: MVar (Either SomeException a)

153− -> AsyncException

153+ -> AsyncException

154 -> IO (Either SomeException a)

155 exceptionHandler mvar ex = do

156 forkIO $ takeMVar mvar >>= either (const $ return ()) g

network-transport/src/Network/Transport/Util.hs+5−5

@@ -1,9 +1,9 @@

1−-- | Utility functions

1+-- | Utility functions

2−--

2+--

3-- Note: this module is bound to change even more than the rest of the API :)

4module Network.Transport.Util (spawn) where

6−import Network.Transport

6+import Network.Transport

7 ( Transport

8 , EndPoint(..)

9 , EndPointAddress

@@ -14,9 +14,9 @@ import Control.Concurrent (forkIO)

14import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)

16-- | Fork a new thread, create a new end point on that thread, and run the specified IO operation on that thread.

17−--

17+--

18-- Returns the address of the new end point.

19−spawn :: Transport -> (EndPoint -> IO ()) -> IO EndPointAddress

19+spawn :: Transport -> (EndPoint -> IO ()) -> IO EndPointAddress

20spawn transport proc = do

21 addrMVar <- newEmptyMVar

22 forkIO $ do

network-transport/tests/chat/ChatClient.hs+13−13

@@ -12,7 +12,7 @@ import qualified Data.Map as Map (fromList, elems, insert, member, empty, size,

12chatClient :: MVar () -> EndPoint -> EndPointAddress -> IO ()

13chatClient done endpoint serverAddr = do

14 connect endpoint serverAddr ReliableOrdered

15− cOut <- getPeers >>= connectToPeers

15+ cOut <- getPeers >>= connectToPeers

16 cIn <- newMVar Map.empty

18 -- Listen for incoming messages

@@ -20,11 +20,11 @@ chatClient done endpoint serverAddr = do

20 event <- receive endpoint

21 case event of

22 Received _ msg ->

23− putStrLn . BSC.unpack . BS.concat $ 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)

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)

@@ -43,24 +43,24 @@ chatClient done endpoint serverAddr = do

44{-

45 chatState <- newMVar (Map.fromList peerConns)

46−

46+

47 -- Thread to listen to incoming messages

48 forkIO . forever $ do

49− event <- receive endpoint

49+ event <- receive endpoint

50 case event of

51 ConnectionOpened _ _ (EndPointAddress addr) -> do

52− modifyMVar_ chatState $ \peers ->

52+ modifyMVar_ chatState $ \peers ->

53 if not (Map.member addr peers)

54 then do

55− Right conn <- connect endpoint (EndPointAddress addr) ReliableOrdered

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

60+ putStrLn . BSC.unpack . BS.concat $ msg

61 ConnectionClosed _ ->

62 return ()

63−

63+

64-}

65 -- Thread to interact with the user

66 showNumPeers cOut

@@ -74,7 +74,7 @@ chatClient done endpoint serverAddr = do

75 where

76 getPeers :: IO [EndPointAddress]

77− getPeers = do

77+ getPeers = do

78 ConnectionOpened _ _ _ <- receive endpoint

79 Received _ msg <- receive endpoint

80 ConnectionClosed _ <- receive endpoint

@@ -86,11 +86,11 @@ chatClient done endpoint serverAddr = do

86 Right conn <- connect endpoint addr ReliableOrdered

87 return (addr, conn)

88 newMVar (Map.fromList conns)

89−

89+

90 showNumPeers :: MVar (Map EndPointAddress Connection) -> IO ()

91− showNumPeers cOut =

91+ showNumPeers cOut =

92 readMVar cOut >>= \conns -> putStrLn $ "# " ++ show (Map.size conns) ++ " peers"

93−

93+

network-transport/tests/chat/ChatServer.hs+1−1

@@ -23,6 +23,6 @@ main = 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)

26+ modify $ IntMap.insert cid (endPointAddressToByteString addr)

27 ConnectionClosed cid ->

28 modify $ IntMap.delete cid

network-transport/tests/sumeuler/SumEulerMaster.hs+4−4

@@ -11,7 +11,7 @@ import Control.Monad.IO.Class (liftIO)

12master :: MVar () -> EndPoint -> [String] -> IO ()

13master done endpoint workers = do

14− conns <- forM workers $ \worker -> do

14+ conns <- forM workers $ \worker -> do

15 Right conn <- connect endpoint (EndPointAddress $ BSC.pack worker) ReliableOrdered

16 return conn

17 -- Send out requests

@@ -24,10 +24,10 @@ master done endpoint workers = do

24 case event of

25 Received _ msg ->

26 tell [read . BSC.unpack . BS.concat $ msg]

27− _ ->

27+ _ ->

28 return ()

29 putStrLn $ "Replies: " ++ show (replies :: [Int])

30− putMVar done ()

30+ putMVar done ()

32main :: IO ()

33main = do

@@ -41,4 +41,4 @@ main = do

41 forkIO $ master masterDone endpoint workers

43 takeMVar masterDone

44−

44+

network-transport/tests/sumeuler/SumEulerWorker.hs+4−4

@@ -20,15 +20,15 @@ sumEuler :: Int -> Int

20sumEuler = sum . (map euler) . mkList

22worker :: String -> MVar () -> EndPoint -> IO ()

23−worker id done endpoint = do

23+worker id done endpoint = do

24− ConnectionOpened _ _ theirAddr <- receive endpoint

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

31+ ConnectionClosed _ -> do

32 close replyChan

33 putMVar done ()

34 Received _ msg -> do

@@ -39,7 +39,7 @@ worker id done endpoint = do

40main :: IO ()

41main = do

42− (id:host:port:_) <- getArgs

42+ (id:host:port:_) <- getArgs

43 Right transport <- createTransport host port

44 Right endpoint <- newEndPoint transport

45 workerDone <- newEmptyMVar

rank1dynamic/src/Data/Rank1Dynamic.hs+21−21

@@ -5,42 +5,42 @@

5-- These examples correspond to the 'Data.Rank1Typeable.isInstanceOf' examples

6-- in "Data.Rank1Typeable".

7--

8−-- > > do f <- fromDynamic (toDynamic (even :: Int -> Bool)) ; return $ (f :: Int -> Int) 0

8+-- > > do f <- fromDynamic (toDynamic (even :: Int -> Bool)) ; return $ (f :: Int -> Int) 0

9-- > Left "Cannot unify Int and Bool"

10−-- >

10+-- >

11-- > > do f <- fromDynamic (toDynamic (const 1 :: ANY -> Int)) ; return $ (f :: Int -> Int) 0

12-- > Right 1

13−-- >

13+-- >

14-- > > do f <- fromDynamic (toDynamic (unsafeCoerce :: ANY1 -> ANY2)) ; return $ (f :: Int -> Int) 0

15-- > Right 0

16−-- >

16+-- >

17-- > > do f <- fromDynamic (toDynamic (id :: ANY -> ANY)) ; return $ (f :: Int -> Bool) 0

18-- > Left "Cannot unify Bool and Int"

19−-- >

19+-- >

20-- > > do f <- fromDynamic (toDynamic (undefined :: ANY)) ; return $ (f :: Int -> Int) 0

21-- > Right *** Exception: Prelude.undefined

22−-- >

22+-- >

23-- > > do f <- fromDynamic (toDynamic (id :: ANY -> ANY)) ; return $ (f :: Int)

24-- > Left "Cannot unify Int and ->"

25--

26-- [Examples of dynApply]

27−--

27+--

28-- These examples correspond to the 'Data.Rank1Typeable.funResultTy' examples

29-- in "Data.Rank1Typeable".

30--

31-- > > do app <- toDynamic (id :: ANY -> ANY) `dynApply` toDynamic True ; f <- fromDynamic app ; return $ (f :: Bool)

32-- > Right True

33−-- >

33+-- >

34-- > > do app <- toDynamic (const :: ANY -> ANY1 -> ANY) `dynApply` toDynamic True ; f <- fromDynamic app ; return $ (f :: Int -> Bool) 0

35-- > Right True

36−-- >

36+-- >

37-- > > do app <- toDynamic (($ True) :: (Bool -> ANY) -> ANY) `dynApply` toDynamic (id :: ANY -> ANY) ; f <- fromDynamic app ; return (f :: Bool)

38-- > Right True

39−-- >

39+-- >

40-- > > app <- toDynamic (const :: ANY -> ANY1 -> ANY) `dynApply` toDynamic (id :: ANY -> ANY) ; f <- fromDynamic app ; return $ (f :: Int -> Bool -> Bool) 0 True

41-- > Right True

42−-- >

42+-- >

43−-- > > do app <- toDynamic ((\f -> f . f) :: (ANY -> ANY) -> ANY -> ANY) `dynApply` toDynamic (even :: Int -> Bool) ; f <- fromDynamic app ; return (f :: ())

43+-- > > do app <- toDynamic ((\f -> f . f) :: (ANY -> ANY) -> ANY -> ANY) `dynApply` toDynamic (even :: Int -> Bool) ; f <- fromDynamic app ; return (f :: ())

44-- > Left "Cannot unify Int and Bool"

45--

46-- [Using toDynamic]

@@ -48,30 +48,30 @@

48-- When using polymorphic values you need to give an explicit type annotation:

49--

50-- > > toDynamic id

51−-- >

51+-- >

52-- > <interactive>:46:1:

53-- > Ambiguous type variable `a0' in the constraint:

54-- > (Typeable a0) arising from a use of `toDynamic'

55-- > Probable fix: add a type signature that fixes these type variable(s)

56-- > In the expression: toDynamic id

57-- > In an equation for `it': it = toDynamic id

58−--

58+--

59-- versus

60--

61-- > > toDynamic (id :: ANY -> ANY)

62-- > <<ANY -> ANY>>

63−--

63+--

64-- Note that these type annotation are checked by ghc like any other:

65--

66-- > > toDynamic (id :: ANY -> ANY1)

67−-- >

67+-- >

68-- > <interactive>:45:12:

69-- > Couldn't match expected type `V1' with actual type `V0'

70-- > Expected type: ANY -> ANY1

71-- > Actual type: ANY -> ANY

72-- > In the first argument of `toDynamic', namely `(id :: ANY -> ANY1)'

73-- > In the expression: toDynamic (id :: ANY -> ANY1)

74−module Data.Rank1Dynamic

74+module Data.Rank1Dynamic

75 ( Dynamic

76 , toDynamic

77 , fromDynamic

@@ -81,7 +81,7 @@ module Data.Rank1Dynamic

81 ) where

83import qualified GHC.Prim as GHC (Any)

84−import Data.Rank1Typeable

84+import Data.Rank1Typeable

85 ( Typeable

86 , TypeRep

87 , typeOf

@@ -95,16 +95,16 @@ import Unsafe.Coerce (unsafeCoerce)

95data Dynamic = Dynamic TypeRep GHC.Any

97instance Show Dynamic where

98− showsPrec _ (Dynamic t _) = showString "<<" . shows t . showString ">>"

98+ showsPrec _ (Dynamic t _) = showString "<<" . shows t . showString ">>"

100−-- | Introduce a dynamic value

100+-- | Introduce a dynamic value

101toDynamic :: Typeable a => a -> Dynamic

102toDynamic x = Dynamic (typeOf x) (unsafeCoerce x)

103

104-- | Eliminate a dynamic value

105fromDynamic :: Typeable a => Dynamic -> Either TypeError a

106fromDynamic (Dynamic t v) =

107− case unsafeCoerce v of

107+ case unsafeCoerce v of

108 r -> case typeOf r `isInstanceOf` t of

109 Left err -> Left err

110 Right () -> Right r

rank1dynamic/src/Data/Rank1Typeable.hs+51−51

@@ -1,7 +1,7 @@

1-- | Runtime type representation of terms with support for rank-1 polymorphic

2-- types with type variables of kind *.

3--

4−-- The essence of this module is that we use the standard 'Typeable'

4+-- The essence of this module is that we use the standard 'Typeable'

5-- representation of "Data.Typeable" but we introduce a special (empty) data

6-- type 'TypVar' which represents type variables. 'TypVar' is indexed by an

7-- arbitrary other data type, giving you an unbounded number of type variables;

@@ -12,23 +12,23 @@

12-- > -- We CANNOT use a term of type 'Int -> Bool' as 'Int -> Int'

13-- > > typeOf (undefined :: Int -> Int) `isInstanceOf` typeOf (undefined :: Int -> Bool)

14-- > Left "Cannot unify Int and Bool"

15−-- >

15+-- >

16-- > -- We CAN use a term of type 'forall a. a -> Int' as 'Int -> Int'

17-- > > typeOf (undefined :: Int -> Int) `isInstanceOf` typeOf (undefined :: ANY -> Int)

18-- > Right ()

19−-- >

19+-- >

20-- > -- We CAN use a term of type 'forall a b. a -> b' as 'forall a. a -> a'

21-- > > typeOf (undefined :: ANY -> ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY1)

22-- > Right ()

23−-- >

23+-- >

24-- > -- We CANNOT use a term of type 'forall a. a -> a' as 'forall a b. a -> b'

25-- > > typeOf (undefined :: ANY -> ANY1) `isInstanceOf` typeOf (undefined :: ANY -> ANY)

26-- > Left "Cannot unify Succ and Zero"

27−-- >

27+-- >

28-- > -- We CAN use a term of type 'forall a. a' as 'forall a. a -> a'

29-- > > typeOf (undefined :: ANY -> ANY) `isInstanceOf` typeOf (undefined :: ANY)

30-- > Right ()

31−-- >

31+-- >

32-- > -- We CANNOT use a term of type 'forall a. a -> a' as 'forall a. a'

33-- > > typeOf (undefined :: ANY) `isInstanceOf` typeOf (undefined :: ANY -> ANY)

34-- > Left "Cannot unify Skolem and ->"

@@ -37,14 +37,14 @@

37--

38-- [Examples of funResultTy]

39--

40−-- > -- Apply fn of type (forall a. a -> a) to arg of type Bool gives Bool

40+-- > -- Apply fn of type (forall a. a -> a) to arg of type Bool gives Bool

41-- > > funResultTy (typeOf (undefined :: ANY -> ANY)) (typeOf (undefined :: Bool))

42-- > Right Bool

43−-- >

43+-- >

44-- > -- Apply fn of type (forall a b. a -> b -> a) to arg of type Bool gives forall a. a -> Bool

45-- > > funResultTy (typeOf (undefined :: ANY -> ANY1 -> ANY)) (typeOf (undefined :: Bool))

46-- > Right (ANY -> Bool) -- forall a. a -> Bool

47−-- >

47+-- >

48-- > -- Apply fn of type (forall a. (Bool -> a) -> a) to argument of type (forall a. a -> a) gives Bool

49-- > > funResultTy (typeOf (undefined :: (Bool -> ANY) -> ANY)) (typeOf (undefined :: ANY -> ANY))

50-- > Right Bool

@@ -56,14 +56,14 @@

56-- > -- Cannot apply function of type (forall a. (a -> a) -> a -> a) to arg of type (Int -> Bool)

57-- > > funResultTy (typeOf (undefined :: (ANY -> ANY) -> (ANY -> ANY))) (typeOf (undefined :: Int -> Bool))

58-- > Left "Cannot unify Int and Bool"

59−module Data.Rank1Typeable

59+module Data.Rank1Typeable

60− ( -- * Basic types

60+ ( -- * Basic types

61 TypeRep

62 , typeOf

63 , splitTyConApp

64 , mkTyConApp

65 , underlyingTypeRep

66− -- * Operations on type representations

66+ -- * Operations on type representations

67 , isInstanceOf

68 , funResultTy

69 , TypeError

@@ -105,7 +105,7 @@ import Data.Typeable (Typeable, mkTyCon3)

105import Data.Typeable.Internal (listTc, funTc, TyCon(TyCon), tyConName)

106import Data.Binary (Binary(get, put))

107import GHC.Fingerprint.Type (Fingerprint(..))

108−import qualified Data.Typeable as Typeable

108+import qualified Data.Typeable as Typeable

109 ( TypeRep

110 , typeOf

111 , splitTyConApp

@@ -117,15 +117,15 @@ import qualified Data.Typeable as Typeable

117--------------------------------------------------------------------------------

118

119-- | Dynamic type representation with support for rank-1 types

120−newtype TypeRep = TypeRep {

120+newtype TypeRep = TypeRep {

121 -- | Return the underlying standard ("Data.Typeable") type representation

122− underlyingTypeRep :: Typeable.TypeRep

122+ underlyingTypeRep :: Typeable.TypeRep

123 }

124

125-- | Compare two type representations

126--

127-- For base >= 4.6 this compares fingerprints, but older versions of base

128−-- have a bug in the fingerprint construction

128+-- have a bug in the fingerprint construction

129-- (<http://hackage.haskell.org/trac/ghc/ticket/5962>)

130instance Eq TypeRep where

131#if ! MIN_VERSION_base(4,6,0)

@@ -138,7 +138,7 @@ instance Eq TypeRep where

138-- Binary instance for 'TypeRep', avoiding orphan instances

139instance Binary TypeRep where

140 put (splitTyConApp -> (TyCon (Fingerprint hi lo) package modul name, ts)) = do

141− put hi

141+ put hi

142 put lo

143 put package

144 put modul

@@ -164,16 +164,16 @@ typeOf = TypeRep . Typeable.typeOf

164-- | Split a type representation into the application of

165-- a type constructor and its argument

166splitTyConApp :: TypeRep -> (TyCon, [TypeRep])

167−splitTyConApp t =

167+splitTyConApp t =

168 let (c, ts) = Typeable.splitTyConApp (underlyingTypeRep t)

169 in (c, map TypeRep ts)

170

171-- | Inverse of 'splitTyConApp'

172mkTyConApp :: TyCon -> [TypeRep] -> TypeRep

173−mkTyConApp c ts

173+mkTyConApp c ts

174 = TypeRep (Typeable.mkTyConApp c (map underlyingTypeRep ts))

175

176−isTypVar :: TypeRep -> Maybe Var

176+isTypVar :: TypeRep -> Maybe Var

177isTypVar (splitTyConApp -> (c, [t])) | c == typVar = Just t

178isTypVar _ = Nothing

179

@@ -190,7 +190,7 @@ skolem = let (c, _) = splitTyConApp (typeOf (undefined :: Skolem V0)) in c

190-- Type variables --

191--------------------------------------------------------------------------------

192

193−data TypVar a deriving Typeable

193+data TypVar a deriving Typeable

194data Skolem a deriving Typeable

195data Zero deriving Typeable

196data Succ a deriving Typeable

@@ -206,7 +206,7 @@ type V7 = Succ V6

206type V8 = Succ V7

207type V9 = Succ V8

208

209−type ANY = TypVar V0

209+type ANY = TypVar V0

210type ANY1 = TypVar V1

211type ANY2 = TypVar V2

212type ANY3 = TypVar V3

@@ -224,17 +224,17 @@ type ANY9 = TypVar V9

224-- | If 'isInstanceOf' fails it returns a type error

225type TypeError = String

226

227−-- | @t1 `isInstanceOf` t2@ checks if @t1@ is an instance of @t2@

227+-- | @t1 `isInstanceOf` t2@ checks if @t1@ is an instance of @t2@

228−isInstanceOf :: TypeRep -> TypeRep -> Either TypeError ()

228+isInstanceOf :: TypeRep -> TypeRep -> Either TypeError ()

229isInstanceOf t1 t2 = void (unify (skolemize t1) t2)

230

231-- | @funResultTy t1 t2@ is the type of the result when applying a function

232-- of type @t1@ to an argument of type @t2@

233−funResultTy :: TypeRep -> TypeRep -> Either TypeError TypeRep

233+funResultTy :: TypeRep -> TypeRep -> Either TypeError TypeRep

234−funResultTy (splitTyConApp -> (fc, [farg, fres])) x | fc == funTc = do

234+funResultTy (splitTyConApp -> (fc, [farg, fres])) x | fc == funTc = do

235 s <- unify (alphaRename "f" farg) (alphaRename "x" x)

236 return (normalize (subst s (alphaRename "f" fres)))

237−funResultTy f _ =

237+funResultTy f _ =

238 Left $ show f ++ " is not a function"

239

240--------------------------------------------------------------------------------

@@ -251,7 +251,7 @@ tvars :: TypeRep -> [Var]

251tvars (isTypVar -> Just x) = [x]

252tvars (splitTyConApp -> (_, ts)) = concatMap tvars ts

253

254−normalize :: TypeRep -> TypeRep

254+normalize :: TypeRep -> TypeRep

255normalize t = subst (zip (tvars t) anys) t

256 where

257 anys :: [TypeRep]

@@ -261,7 +261,7 @@ normalize t = subst (zip (tvars t) anys) t

261 succ = mkTyConApp succTyCon . (:[])

262

263 zero :: TypeRep

264− zero = mkTyConApp zeroTyCon []

264+ zero = mkTyConApp zeroTyCon []

265

266mkTyCon :: String -> TyCon

267mkTyCon = mkTyCon3 "rank1typeable" "Data.Rank1Typeable"

@@ -281,38 +281,38 @@ type Equation = (TypeRep, TypeRep)

281type Var = TypeRep

282

283skolemize :: TypeRep -> TypeRep

284−skolemize (isTypVar -> Just x) = mkTyConApp skolem [x]

284+skolemize (isTypVar -> Just x) = mkTyConApp skolem [x]

285skolemize (splitTyConApp -> (c, ts)) = mkTyConApp c (map skolemize ts)

286

287occurs :: Var -> TypeRep -> Bool

288−occurs x (isTypVar -> Just x') = x == x'

288+occurs x (isTypVar -> Just x') = x == x'

289occurs x (splitTyConApp -> (_, ts)) = any (occurs x) ts

290

291subst :: Substitution -> TypeRep -> TypeRep

292subst s (isTypVar -> Just x) = fromMaybe (mkTypVar x) (lookup x s)

293subst s (splitTyConApp -> (c, ts)) = mkTyConApp c (map (subst s) ts)

294

295−unify :: TypeRep

295+unify :: TypeRep

296− -> TypeRep

296+ -> TypeRep

297− -> Either TypeError Substitution

297+ -> Either TypeError Substitution

298unify = \t1 t2 -> go [] [(t1, t2)]

299 where

300− go :: Substitution

300+ go :: Substitution

301− -> [Equation]

301+ -> [Equation]

302− -> Either TypeError Substitution

302+ -> Either TypeError Substitution

303− go acc [] =

303+ go acc [] =

304 return acc

305 go acc ((t1, t2) : eqs) | t1 == t2 = -- Note: equality check is fast

306 go acc eqs

307 go acc ((isTypVar -> Just x, t) : eqs) =

308− if x `occurs` t

308+ if x `occurs` t

309 then Left "Occurs check"

310− else go ((x, t) : map (second $ subst [(x, t)]) acc)

310+ else go ((x, t) : map (second $ subst [(x, t)]) acc)

311 (map (subst [(x, t)] *** subst [(x, t)]) eqs)

312 go acc ((t, isTypVar -> Just x) : eqs) =

313 go acc ((mkTypVar x, t) : eqs)

314− go acc ((splitTyConApp -> (c1, ts1), splitTyConApp -> (c2, ts2)) : eqs) =

314+ go acc ((splitTyConApp -> (c1, ts1), splitTyConApp -> (c2, ts2)) : eqs) =

315− if c1 /= c2

315+ if c1 /= c2

316 then Left $ "Cannot unify " ++ show c1 ++ " and " ++ show c2

317 else go acc (zip ts1 ts2 ++ eqs)

318

@@ -324,14 +324,14 @@ instance Show TypeRep where

324 showsPrec p (splitTyConApp -> (tycon, tys)) =

325 case tys of

326 [] -> showsPrec p tycon

327− [anyIdx -> Just i] | tycon == typVar -> showString "ANY" . showIdx i

327+ [anyIdx -> Just i] | tycon == typVar -> showString "ANY" . showIdx i

328− [x] | tycon == listTc ->

328+ [x] | tycon == listTc ->

329 showChar '[' . shows x . showChar ']'

330− [a,r] | tycon == funTc ->

330+ [a,r] | tycon == funTc ->

331− showParen (p > 8) $ showsPrec 9 a

331+ showParen (p > 8) $ showsPrec 9 a

332− . showString " -> "

332+ . showString " -> "

333 . showsPrec 8 r

334− xs | isTupleTyCon tycon ->

334+ xs | isTupleTyCon tycon ->

335 showTuple xs

336 _ ->

337 showParen (p > 9) $ showsPrec p tycon

@@ -344,16 +344,16 @@ instance Show TypeRep where

344showArgs :: Show a => [a] -> ShowS

345showArgs [] = id

346showArgs [a] = showsPrec 10 a

347−showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as

347+showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as

348

349−anyIdx :: TypeRep -> Maybe Int

349+anyIdx :: TypeRep -> Maybe Int

350anyIdx (splitTyConApp -> (c, [])) | c == zeroTyCon = Just 0

351anyIdx (splitTyConApp -> (c, [t])) | c == succTyCon = (+1) <$> anyIdx t

352anyIdx _ = Nothing

353

354showTuple :: [TypeRep] -> ShowS

355showTuple args = showChar '('

356− . foldr (.) id ( intersperse (showChar ',')

356+ . foldr (.) id ( intersperse (showChar ',')

357 $ map (showsPrec 10) args

358 )

359 . showChar ')'