master..e89d355 · distributed-process

git.iko.soy/distributed-process

162 files changed+15986−13753

unifiedsplit

.gitignore+12−3

@@ -1,4 +1,13 @@

1+tags

2+TAGS

13dist/

2−.cabal-sandbox

3−cabal.sandbox.config

4−.stack*

4+\#*#

5+*~

6+*.aux

7+*.hp

8+*.hi

9+*.o

10+*.prof

11+*.ps

12+*.swp

13+cabal-dev

.travis.ymldeleted−43

@@ -1,43 +0,0 @@

1−language: c

2−

3−sudo: false

4−

5−matrix:

6− include:

7− - env: ARGS="--stack-yaml stack-ghc-7.10.3.yaml"

8− addons: {apt: {packages: [libgmp-dev]}}

9− - env: ARGS="--stack-yaml stack-ghc-8.2.2.yaml"

10− addons: {apt: {packages: [libgmp-dev]}}

11− - env: ARGS="--stack-yaml stack-ghc-8.4.4.yaml"

12− addons: {apt: {packages: [libgmp-dev]}}

13− - env: ARGS="--stack-yaml stack-nightly.yaml --resolver nightly"

14− addons: {apt: {packages: [libgmp-dev]}}

15−

16−cache:

17− directories:

18− - $HOME/.stack

19−

20−before_install:

21−- export PATH=$HOME/.local/bin:$PATH;

22− mkdir -p ~/.local/bin;

23− travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack';

24− stack --version

25−

26−install:

27−- stack $ARGS setup --no-terminal;

28− stack $ARGS build --no-terminal --only-snapshot --test --no-run-tests;

29−

30−script:

31−- export ARG='--test-arguments'

32− export TEST_PACKAGE="distributed-process-tests:"

33−- stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInMemory

34−- stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInTCP

35−- stack ${ARGS} test $ARG='--plain -t "!SpawnReconnect"' ${TEST_PACKAGE}TestClosure

36−- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestStats

37−- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInMemory

38−- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInTCP

39−- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestTracingInMemory

40−

41−notifications:

42− slack:

43− secure: LbqbNjK1KiHNiQo/i/Za4vkMD9l9mhmN+PWYFBQkNvGFWffSRayRKFrTqt4znV2p7h4dY1XZFoC7T5RemBVQLq2ppZAUWxkITeu1OUlnmVLDfJLeVYGTR/fn90nP6Y5ITE7T3A07nKmWaRbKpIgFBAOjzgqaM0csscDx3z0WW18=

CONTRIBUTING.mddeleted−1

@@ -1 +0,0 @@

1−See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md.

ChangeLogdeleted−236

@@ -1,236 +0,0 @@

1−[Unrealeased]

2−

3−*

4−

5−2018-06-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.4

6−

7−* Added support for exceptions >= 0.10

8−

9−2017-08-31 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.3

10−

11−* Drop support for ghc-7.8.* and earlier.

12−

13−2017-08-31 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.2

14−

15−* Fixed build errors with ghc-8.2.1.

16−

17−2017-08-22 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.1

18−

19−* Relax upper bounds in dependencies to build with ghc-8.2.1.

20−

21−2017-08-21 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.0

22−

23−* Change type of message sent by `say` from a 3-tuple to a proper

24−type (`SayMessage`) with a proper `UTCTime`. (#291)

25−* Expose the MonitorRef in the withMonitor call.

26−* Have unmonitor remove the monitor message in the inbox. (#268)

27−* Remove Mx Data Tables. This API isn't used, is easy to replace with various

28−other packages. (#276)

29−* Add Ord instance to SpawnRef.

30−

31−2016-10-13 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.6

32−

33−* Remove monitors from remote nodes when a process dies. (#295)

34−

35−2016-10-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.5

36−

37−* Use only one connection to communicate between NCs. (#296, #297)

38−* Improve documentation of CQueue.

39−* Implement bidirectional multimaps for links and monitors. (#293, #294)

40−* Fix various warnings. (#292)

41−* Fix some of the intermittent failures in tests.

42−* Improve error messages when node controllers receive invalid requests.

43−(#290)

44−

45−2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.4

46−

47−* Fixup build errors.

48−

49−2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.3

50−

51−* Relax template-haskell upper bound.

52−

53−2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.2

54−

55−* Provide compatibility with ghc-8.0.1

56−* Remove dependency on ghc-prim.

57−* Don't throw exceptions asynchronously.

58−* Bump upper bounds of dependencies.

59−* Fix exception handling in callLocal.

60−* Have spawnLocal inherit the masking state of the caller.

61−* Have nsend send unencoded messages to local processes.

62−

63−2016-03-03 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.1

64−

65−* Implement MonadCatch, MonadThrow, MonadMask for Process.

66−

67−2016-02-18 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.0

68−

69−* Have nsendRemote skip the transport for local communication.

70−* Unsafe primitives for usend and nsendRemote.

71−* Stop using the transport for local communication.

72−* Skip the transport for whereisRemoteAsync and registerRemoteAsync.

73−* Have nsendRemote skip the transport for local communication.

74−* Have runProcess forward exceptions.

75−* Reimport distributed-process-tests. d-p and d-p-test now can be kept in

76−sync.

77−* Add a stack.yaml file for building tests and d-p all at once conveniently.

78−* Implement unreliable forward (uforward).

79−* Add Functor instance for Match data type

80−* Have `spawnAsync` not use the transport in the local case.

81−* Fix monitor race in 'call'.

82−* Add compatibility with ghc-7.10: support new typeable, loosen deps, write

83−proper NFData instances, support new TH.

84−* Kill processes on a local node upon closeLocalNode.

85−* Fix getNodeStats function, see DP-97

86−* Return size of the queue in ProcessInfo.

87−* Implement unreliable send (usend).

88−* Implement MonadFix instance for Process.

89−* Introduce callLocal primitive.

90−* Prevent message loss due to timeouts in CQueue.

91−* More informative ProcessRegistrationException. Now includes the identifier

92−of the process that owns the name, if any.

93−* Avoid message loop between threads when tracing received messages.

94−

95−2015-06-15 Facundo Domínguez <facundo.dominguez@tweag.io> 0.5.5

96−

97−* Fix dependencies.

98−* Add compatibility with GHC-7.10.

99−* Fix various race conditions (DP-99, DP-103).

100−

101−2014-12-09 Tim Watson <watson.timothy@gmail.com> 0.5.2

102−

103−* Fix docstring for `register`

104−* Added Data instance to ProcessId, LocalProcessId and NodeId

105−* Add static serialiation dictionary for 'Static', for completeness

106−* Add Closure static serialization dictionary

107−* Replacement for modifyMVarMasked for GHC <= 7.4

108−* Document the use of built-in trace flags

109−* Make forkProcess exception-safe

110−* Make -Wall clean

111−

112−2014-08-13 Tim Watson <watson.timothy@gmail.com> 0.5.1

113−

114−* Fix cabal docs (thanks Markus Barenhoff)

115−* Expose lifted version of Control.Exception.mask_ (thanks Alexander Vershilov)

116−

117−2014-05-30 Tim Watson <watson.timothy@gmail.com> 0.5.0

118−

119−* Dependency on STM implicitly changed from 1.3 to 1.4, but was not reflected in the cabal file

120−* Race condition in local monitoring when using call

121−* mask now works correctly if unmask is called by another process

122−* Improve efficiency of local message passing

123−* nsend uses local communication channels

124−* Link Node Controller and Network Listener

125−* Label spawned processes using labelThread

126−* Relaxed upper bound on syb in the cabal manifest

127−* Bump binary version to include 0.7.*

128−* Exposed process info

129−* Exposed node statistics

130−* Moved tests to https://github.com/haskell-distributed/distributed-process-tests

131−* Added "polymorphic expect"

132−* Exposed Message type and broaden scope of polymorphic expect

133−* Added Management API (for working with internal/system events)

134−* Tracing can no longer be disabled

135−* We now report node statistics for monitoring/management

136−* Node.runProcess now propagates exceptions to its caller

137−* Added simple micro benchmarks

138−

139−2013-01-27 Tim Watson <watson.timothy@gmail.com> 0.4.2

140−

141−* Improved exception handling for deferred type checked exit reasons

142−* Add matchChan primitive (thanks Simon Marlow)

143−* Expose deferred message handling/checking for AbstractMessage

144−* Add `getProcessInfo' API

145−* Add `trace' API backed by the GHC eventlog

146−

147−2012-11-22 Edsko de Vries <edsko@well-typed.com> 0.4.1

148−

149−* Make behaviour of 'register' more Erlang-like (register will now fail if the

150−name is already registered). Patch by Jeff Epstein.

151−* Functor, Applicative, Alternative and Monad instances for ReceivePort

152−* Add support for receiveChanTimeout

153−* Improved documentation

154−* Avoid name clashes in the TH generation for closures

155−* Relax package bounds to allow for Binary 0.6

156−

157−2012-10-23 Edsko de Vries <edsko@well-typed.com> 0.4.0.2

158−

159−* Fix race condition in spawn

160−

161−2012-10-04 Edsko de Vries <edsko@well-typed.com> 0.4.0.1

162−

163−* Relax package boundaries

164−

165−2012-10-03 Edsko de Vries <edsko@well-typed.com> 0.4.0

166−

167−* Improved treatment of network failure, using new failure semantics of

168−Network.Transport.

169−* Make NodeId Typeable

170−* Extend Template Haskell support with "remotableDec" so that you can refer to

171−$(mkClosure 'f) within the body of "f".

172−* Fix bug in spawnChannelLocal

173−* Numerous memory leaks plugged

174−* Relax upper bound on dependency on 'network'

175−* New primitive 'matchAny'

176−* Remove 'whereisRemote' (see comment of 'whereisRemoteAsync')

177−

178−2012-08-16 Edsko de Vries <edsko@well-typed.com> 0.3.1

179−

180−* Fix memory leaks

181−* Make Template Haskell support optional

182−* Relax dependency constraints

183−

184−2012-08-07 Edsko de Vries <edsko@well-typed.com> 0.3.0

185−

186−* Extract 'static' into a separate package (C.D.Static)

187−* Use new package rank1dynamic to proper runtime checks for polymorphic values

188−

189−2012-08-02 Edsko de Vries <edsko@well-typed.com> 0.2.3.0

190−

191−* Expose the constructors of Closure

192−* Add instance (Typeable a => Serializable (Static a)) and make sure we only

193−use the internal representation of Static where really necessary

194−* Improved docs

195−

196−2012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0

197−

198−* Add exception handling primitives

199−* Fix runProcess: if the process threw an exception, a 'waiting indefinitely on

200−MVar' exception would be thrown.

201−

202−2012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4

203−

204−* Bugfix in the node controller

205−(one way this bug materialized: when using the SimpleLocalnet backend,

206−slave nodes could not be reused)

207−* Improved documentation in Control.Distributed.Process.Closure

208−

209−2012-07-20 Edsko de Vries <edsko@well-typed.com> 0.2.1.3

210−

211−* Improve docs

212−* Local versions of spawn

213−

214−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.2

215−

216−* Base 4.6 compatibility

217−* Relax constraints on bytestring and containers

218−

219−2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.1

220−

221−* Relax upper bound on 'time' dependency

222−

223−2012-07-11 Edsko de Vries <edsko@well-typed.com> 0.2.1

224−

225−* Complete redesign of the underlying implementation of static values and

226−closures.

227−

228−* Add support for 'spawnChannel'

229−

230−2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1

231−

232−* Bugfix: Continue processing messages when a connection breaks.

233−

234−2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0

235−

236−* Initial release.

README.md+27−11

@@ -1,16 +1,32 @@

1−# distributed-process

2−[![travis](https://secure.travis-ci.org/haskell-distributed/distributed-process.png)](http://travis-ci.org/haskell-distributed/distributed-process)

3−[![Release](https://img.shields.io/hackage/v/distributed-process.svg)](https://hackage.haskell.org/package/distributed-process)

1+Haskell Distributed Project

2+===========================

5−This repository is part of Cloud Haskell.

4+This repository holds an implementation of [Cloud Haskell][1].

7−See http://haskell-distributed.github.com for documentation, user guides,

8−tutorials and assistance.

6+At present, this repository hosts

10−## Getting Help / Raising Issues

8+* network-transport: Generic Network.Transport API

9+* network-transport-tcp: TCP instantiation of Network.Transport

10+* network-transport-inmemory: In-memory instantiation of Network.Transport (incomplete)

11+* distributed-static: Support for static values

12+* distributed-process: The main Cloud Haskell package

13+* distributed-process-simplelocalnet: Simple backend for local networks

14+* distributed-process-azure: Azure backend for Cloud Haskell (work in progress)

15+* azure-service-api: Haskell bindings for the Azure service API (work in progress)

16+* rank1dynamic: Like Data.Dynamic and Data.Typeable but with support for polymorphic values

1117

12−Please visit the [bug tracker](https://github.com/haskell-distributed/distributed-process/issues) to submit issues. You can contact the distributed-haskell@googlegroups.com mailing list for help and comments.

18+For more detailed information about the interfaces provided by these packages,

19+please refer to the [distributed-process repository wiki][2]. People who wish

20+to get started with Cloud Haskell should cabal install

21+distributed-process and possibly distributed-process-simplelocalnet and refer

22+to the corresponding Haddock documentation ([Control.Distributed.Process][3],

23+[Control.Distributed.Process.Closure][4],

24+[Control.Distributed.Process.Node][5], and

25+[Control.Distributed.Process.Backend.SimpleLocalnet][6]).

1326

14−## License

15−

16−This package is made available under a 3-clause BSD-style license.

27+[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf

28+[2]: https://github.com/haskell-distributed/distributed-process/wiki

29+[3]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process.html

30+[4]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Closure.html

31+[5]: http://hackage.haskell.org/packages/archive/distributed-process/0.2.1.4/doc/html/Control-Distributed-Process-Node.html

32+[6]: http://hackage.haskell.org/packages/archive/distributed-process-simplelocalnet/0.2.0.3/doc/html/Control-Distributed-Process-Backend-SimpleLocalnet.html

azure-service-api/LICENSEnew file+30

@@ -0,0 +1,30 @@

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Edsko de Vries nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs → azure-service-api/Setup.hsrenamed

The content is the same.

azure-service-api/azure-service-api.cabalnew file+34

@@ -0,0 +1,34 @@

1+-- Initial azure-service-api.cabal generated by cabal init. For further

2+-- documentation, see http://haskell.org/cabal/users-guide/

4+Name: azure-service-api

5+Version: 0.1.0.0

6+Synopsis: Haskell bindings for the Azure Service Management API

7+-- description:

8+Homepage: github.com/haskell-distributed/azure-service-api

9+License: BSD3

10+License-File: LICENSE

11+Author: Edsko de Vries

12+Maintainer: edsko@well-typed.com

13+Copyright: Well-Typed LLP

14+Category: Network

15+Build-Type: Simple

16+Cabal-Version: >=1.8

17+

18+Library

19+ Exposed-Modules: Network.Azure.ServiceManagement

20+ Build-Depends: base ==4.5.*,

21+ http-conduit >= 1.5.1 && < 1.6,

22+ tls >= 1.0 && < 1.1,

23+ tls-extra >= 0.5 && < 0.6,

24+ bytestring >= 0.9 && < 1.0,

25+ certificate >= 1.2 && < 1.3,

26+ case-insensitive >= 0.4 && < 0.5,

27+ hxt >= 9.2 && < 9.3,

28+ pretty >= 1.1 && < 1.2,

29+ resourcet,

30+ transformers,

31+ hxt-xpath

32+ HS-Source-Dirs: src

33+ ghc-options: -Wall

34+ Extensions: RankNTypes

azure-service-api/src/Network/Azure/ServiceManagement.hsnew file+250

@@ -0,0 +1,250 @@

1+{-# LANGUAGE Arrows #-}

2+module Network.Azure.ServiceManagement

3+ ( -- * Data types

4+ HostedService(..)

5+ , CloudService(..)

6+ , VirtualMachine(..)

7+ , Endpoint(..)

8+ -- * Pure functions

9+ , vmSshEndpoint

10+ -- * Setup

11+ , AzureSetup(..)

12+ , azureSetup

13+ -- * High-level API

14+ , hostedServices

15+ , cloudServices

16+ ) where

17+

18+import Prelude hiding (id, (.))

19+import Control.Category (id, (.))

20+import Control.Arrow (arr)

21+import Control.Monad (forM)

22+import Data.Maybe (listToMaybe)

23+import Data.ByteString.Char8 as BSC (pack)

24+import Data.ByteString.Lazy.Char8 as BSLC (unpack)

25+import Network.TLS (PrivateKey)

26+import Network.TLS.Extra (fileReadCertificate, fileReadPrivateKey)

27+import Data.Certificate.X509 (X509)

28+import Control.Monad.Trans.Resource (ResourceT)

29+import Control.Monad.IO.Class (liftIO)

30+import Control.Arrow.ArrowList (listA, arr2A)

31+import Text.PrettyPrint

32+ ( Doc

33+ , text

34+ , (<+>)

35+ , ($$)

36+ , vcat

37+ , hang

38+ , doubleQuotes

39+ )

40+import Network.HTTP.Conduit

41+ ( parseUrl

42+ , clientCertificates

43+ , requestHeaders

44+ , withManager

45+ , Response(Response)

46+ , httpLbs

47+ , Manager

48+ )

49+import Data.CaseInsensitive as CI (mk)

50+import Text.XML.HXT.Core

51+ ( runX

52+ , readString

53+ , withValidate

54+ , no

55+ , XmlTree

56+ , IOSArrow

57+ , ArrowXml

58+ , getText

59+-- , writeDocumentToString

60+-- , withIndent

61+-- , yes

62+ )

63+-- import Control.Arrow.ArrowIO (arrIO)

64+import Text.XML.HXT.XPath (getXPathTrees)

65+

66+--------------------------------------------------------------------------------

67+-- Data types --

68+--------------------------------------------------------------------------------

69+

70+data HostedService = HostedService {

71+ hostedServiceName :: String

72+ }

73+

74+data CloudService = CloudService {

75+ cloudServiceName :: String

76+ , cloudServiceVMs :: [VirtualMachine]

77+ }

78+

79+data VirtualMachine = VirtualMachine {

80+ vmName :: String

81+ , vmIpAddress :: String

82+ , vmInputEndpoints :: [Endpoint]

83+ }

84+

85+data Endpoint = Endpoint {

86+ endpointName :: String

87+ , endpointPort :: String

88+ , endpointVip :: String

89+ }

90+

91+--------------------------------------------------------------------------------

92+-- Pretty-printing --

93+--------------------------------------------------------------------------------

94+

95+instance Show HostedService where

96+ show = show . ppHostedService

97+

98+instance Show CloudService where

99+ show = show . ppCloudService

100+

101+instance Show VirtualMachine where

102+ show = show . ppVirtualMachine

103+

104+instance Show Endpoint where

105+ show = show . ppEndpoint

106+

107+ppHostedService :: HostedService -> Doc

108+ppHostedService = text . hostedServiceName

109+

110+ppCloudService :: CloudService -> Doc

111+ppCloudService cs =

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

113+ `hang2`

114+ ( text "VIRTUAL MACHINES"

115+ `hang2`

116+ (vcat . map ppVirtualMachine . cloudServiceVMs $ cs)

117+ )

118+

119+ppVirtualMachine :: VirtualMachine -> Doc

120+ppVirtualMachine vm =

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

122+ `hang2`

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

124+ $$ ( text "INPUT ENDPOINTS"

125+ `hang2`

126+ (vcat . map ppEndpoint . vmInputEndpoints $ vm)

127+ )

128+ )

129+

130+ppEndpoint :: Endpoint -> Doc

131+ppEndpoint ep =

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

133+ `hang2`

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

135+ $$ text "VIP" <+> text (endpointVip ep)

136+ )

137+

138+hang2 :: Doc -> Doc -> Doc

139+hang2 d1 = hang d1 2

140+

141+--------------------------------------------------------------------------------

142+-- Pure operations --

143+--------------------------------------------------------------------------------

144+

145+vmSshEndpoint :: VirtualMachine -> Maybe Endpoint

146+vmSshEndpoint vm = listToMaybe

147+ [ ep

148+ | ep <- vmInputEndpoints vm

149+ , endpointName ep == "SSH"

150+ ]

151+

152+--------------------------------------------------------------------------------

153+-- Setup --

154+--------------------------------------------------------------------------------

155+

156+-- | Azure setup

157+data AzureSetup = AzureSetup

158+ { subscriptionId :: String

159+ , certificate :: X509

160+ , privateKey :: PrivateKey

161+ , baseUrl :: String

162+ }

163+

164+-- | Initialize Azure

165+azureSetup :: String -- ^ Subscription ID

166+ -> String -- ^ Path to certificate

167+ -> String -- ^ Path to private key

168+ -> IO AzureSetup

169+azureSetup sid certPath pkeyPath = do

170+ cert <- fileReadCertificate certPath

171+ pkey <- fileReadPrivateKey pkeyPath

172+ return AzureSetup {

173+ subscriptionId = sid

174+ , certificate = cert

175+ , privateKey = pkey

176+ , baseUrl = "https://management.core.windows.net"

177+ }

178+

179+--------------------------------------------------------------------------------

180+-- High-level API --

181+--------------------------------------------------------------------------------

182+

183+-- | Get a list of virtual machines

184+cloudServices :: AzureSetup -> IO [CloudService]

185+cloudServices setup = azureExecute setup $ \exec -> do

186+ services <- exec hostedServicesRequest

187+ forM services $ \service -> do

188+ roles <- exec AzureRequest {

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

190+ ++ "?embed-detail=true"

191+ , apiVersion = "2012-03-01"

192+ , parser = proc xml -> do

193+ role <- getXPathTrees "//Role[@type='PersistentVMRole']" -< xml

194+ name <- getText . getXPathTrees "/Role/RoleName/text()" -< role

195+ roleInst <- arr2A getXPathTrees -< ("//RoleInstance[RoleName='" ++ name ++ "']", xml)

196+ ip <- getText . getXPathTrees "/RoleInstance/IpAddress/text()" -< roleInst

197+ endpoints <- listA (parseEndpoint . getXPathTrees "//InputEndpoint") -< role

198+ id -< VirtualMachine name ip endpoints

199+ }

200+ return $ CloudService (hostedServiceName service) roles

201+

202+-- | Get list of available hosted services

203+hostedServices :: AzureSetup -> IO [HostedService]

204+hostedServices setup = azureExecute setup (\exec -> exec hostedServicesRequest)

205+

206+hostedServicesRequest :: AzureRequest HostedService

207+hostedServicesRequest = AzureRequest

208+ { relativeUrl = "/services/hostedservices"

209+ , apiVersion = "2012-03-01"

210+ , parser = arr HostedService

211+ . getText

212+ . getXPathTrees "//ServiceName/text()"

213+ }

214+

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

216+parseEndpoint = proc endpoint -> do

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

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

219+ vip <- getText . getXPathTrees "//Vip/text()" -< endpoint

220+ id -< Endpoint name port vip

221+

222+--------------------------------------------------------------------------------

223+-- Low-level API --

224+--------------------------------------------------------------------------------

225+

226+data AzureRequest c = AzureRequest {

227+ relativeUrl :: String

228+ , apiVersion :: String

229+ , parser :: IOSArrow XmlTree c

230+ }

231+

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

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

234+ where

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

236+ go manager request = do

237+ req <- parseUrl $ baseUrl setup

238+ ++ "/" ++ subscriptionId setup

239+ ++ "/" ++ relativeUrl request

240+ let req' = req {

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

242+ , requestHeaders = [ (CI.mk $ BSC.pack "x-ms-version", BSC.pack $ apiVersion request)

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

244+ ]

245+ }

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

247+ liftIO . runX $ proc _ -> do

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

249+ -- arrIO putStrLn . writeDocumentToString [withIndent yes] -< xml

250+ parser request -< xml

benchmarks/Channels.hsdeleted−43

@@ -1,43 +0,0 @@

1−-- | Like Latency, but creating lots of channels

2−import System.Environment

3−import Control.Monad

4−import Control.Applicative

5−import Control.Distributed.Process

6−import Control.Distributed.Process.Node

7−import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)

8−import Data.Binary (encode, decode)

9−import qualified Data.ByteString.Lazy as BSL

10−

11−pingServer :: Process ()

12−pingServer = forever $ do

13− them <- expect

14− sendChan them ()

15− -- TODO: should this be automatic?

16− reconnectPort them

17−

18−pingClient :: Int -> ProcessId -> Process ()

19−pingClient n them = do

20− replicateM_ n $ do

21− (sc, rc) <- newChan :: Process (SendPort (), ReceivePort ())

22− send them sc

23− receiveChan rc

24− liftIO . putStrLn $ "Did " ++ show n ++ " pings"

25−

26−initialProcess :: String -> Process ()

27−initialProcess "SERVER" = do

28− us <- getSelfPid

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

30− pingServer

31−initialProcess "CLIENT" = do

32− n <- liftIO $ getLine

33− them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"

34− pingClient (read n) them

35−

36−main :: IO ()

37−main = do

38− [role, host, port] <- getArgs

39− trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters

40− case trans of

41− Right transport -> do node <- newLocalNode transport initRemoteTable

42− runProcess node $ initialProcess role

43− Left other -> error $ show other

benchmarks/Latency.hsdeleted−39

@@ -1,39 +0,0 @@

1−import System.Environment

2−import Control.Monad

3−import Control.Applicative

4−import Control.Distributed.Process

5−import Control.Distributed.Process.Node

6−import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)

7−import Data.Binary (encode, decode)

8−import qualified Data.ByteString.Lazy as BSL

9−

10−pingServer :: Process ()

11−pingServer = forever $ do

12− them <- expect

13− send them ()

14−

15−pingClient :: Int -> ProcessId -> Process ()

16−pingClient n them = do

17− us <- getSelfPid

18− replicateM_ n $ send them us >> (expect :: Process ())

19− liftIO . putStrLn $ "Did " ++ show n ++ " pings"

20−

21−initialProcess :: String -> Process ()

22−initialProcess "SERVER" = do

23− us <- getSelfPid

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

25− pingServer

26−initialProcess "CLIENT" = do

27− n <- liftIO $ getLine

28− them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"

29− pingClient (read n) them

30−

31−main :: IO ()

32−main = do

33− [role, host, port] <- getArgs

34− trans <- createTransport

35− (defaultTCPAddr host port) defaultTCPParameters

36− case trans of

37− Right transport -> do node <- newLocalNode transport initRemoteTable

38− runProcess node $ initialProcess role

39− Left other -> error $ show other

benchmarks/ProcessRing.hsdeleted−117

@@ -1,117 +0,0 @@

1−{- ProcessRing benchmarks.

2−

3−To run the benchmarks, select a value for the ring size (sz) and

4−the number of times to send a message around the ring

5−

6−-}

7−

8−{-# LANGUAGE BangPatterns #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−

11−import Control.Monad

12−import Control.Distributed.Process hiding (catch)

13−import Control.Distributed.Process.Node

14−import Control.Exception (catch, SomeException)

15−import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)

16−import System.Environment

17−import System.Console.GetOpt

18−

19−data Options = Options

20− { optRingSize :: Int

21− , optIterations :: Int

22− , optForward :: Bool

23− , optParallel :: Bool

24− , optUnsafe :: Bool

25− } deriving Show

26−

27−initialProcess :: Options -> Process ()

28−initialProcess op =

29− let ringSz = optRingSize op

30− msgCnt = optIterations op

31− fwd = optForward op

32− unsafe = optUnsafe op

33− msg = ("foobar", "baz")

34− in do

35− self <- getSelfPid

36− ring <- makeRing fwd unsafe ringSz self

37− forM_ [1..msgCnt] (\_ -> send ring msg)

38− collect msgCnt

39− where relay fsend pid = do

40− msg <- expect :: Process (String, String)

41− fsend pid msg

42− relay fsend pid

43−

44− forward' pid =

45− receiveWait [ matchAny (\m -> forward m pid) ] >> forward' pid

46−

47− makeRing :: Bool -> Bool -> Int -> ProcessId -> Process ProcessId

48− makeRing !f !u !n !pid

49− | n == 0 = go f u pid

50− | otherwise = go f u pid >>= makeRing f u (n - 1)

51−

52− go :: Bool -> Bool -> ProcessId -> Process ProcessId

53− go False False next = spawnLocal $ relay send next

54− go False True next = spawnLocal $ relay unsafeSend next

55− go True _ next = spawnLocal $ forward' next

56−

57− collect :: Int -> Process ()

58− collect !n

59− | n == 0 = return ()

60− | otherwise = do

61− receiveWait [

62− matchIf (\(a, b) -> a == "foobar" && b == "baz")

63− (\_ -> return ())

64− , matchAny (\_ -> error "unexpected input!")

65− ]

66− collect (n - 1)

67−

68−defaultOptions :: Options

69−defaultOptions = Options

70− { optRingSize = 10

71− , optIterations = 100

72− , optForward = False

73− , optParallel = False

74− , optUnsafe = False

75− }

76−

77−options :: [OptDescr (Options -> Options)]

78−options =

79− [ Option ['s'] ["ring-size"] (OptArg optSz "SIZE") "# of processes in ring"

80− , Option ['i'] ["iterations"] (OptArg optMsgCnt "ITER") "# of times to send"

81− , Option ['f'] ["forward"]

82− (NoArg (\opts -> opts { optForward = True }))

83− "use `forward' instead of send - default = False"

84− , Option ['u'] ["unsafe-send"]

85− (NoArg (\opts -> opts { optUnsafe = True }))

86− "use 'unsafeSend' (ignored with -f) - default = False"

87− , Option ['p'] ["parallel"]

88− (NoArg (\opts -> opts { optParallel = True }))

89− "send in parallel and consume sequentially - default = False"

90− ]

91−

92−optMsgCnt :: Maybe String -> Options -> Options

93−optMsgCnt Nothing opts = opts

94−optMsgCnt (Just c) opts = opts { optIterations = ((read c) :: Int) }

95−

96−optSz :: Maybe String -> Options -> Options

97−optSz Nothing opts = opts

98−optSz (Just s) opts = opts { optRingSize = ((read s) :: Int) }

99−

100−parseArgv :: [String] -> IO (Options, [String])

101−parseArgv argv = do

102− pn <- getProgName

103− case getOpt Permute options argv of

104− (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n)

105− (_,_,errs) -> ioError (userError (concat errs ++ usageInfo (header pn) options))

106− where header pn' = "Usage: " ++ pn' ++ " [OPTION...]"

107−

108−main :: IO ()

109−main = do

110− argv <- getArgs

111− (opt, _) <- parseArgv argv

112− putStrLn $ "options: " ++ (show opt)

113− Right transport <- createTransport

114− (defaultTCPAddr "127.0.0.1" "8090" ) defaultTCPParameters

115− node <- newLocalNode transport initRemoteTable

116− catch (void $ runProcess node $ initialProcess opt)

117− (\(e :: SomeException) -> putStrLn $ "ERROR: " ++ (show e))

benchmarks/Spawns.hsdeleted−49

@@ -1,49 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−

3−-- | Like Throughput, but send every ping from a different process

4−-- (i.e., require a lightweight connection per ping)

5−import System.Environment

6−import Control.Monad

7−import Control.Applicative

8−import Control.Distributed.Process

9−import Control.Distributed.Process.Node

10−import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)

11−import Data.Binary (encode, decode)

12−import qualified Data.ByteString.Lazy as BSL

13−

14−counter :: Process ()

15−counter = go 0

16− where

17− go :: Int -> Process ()

18− go !n = do

19− b <- expect

20− case b of

21− Nothing -> go (n + 1)

22− Just them -> send them n >> go 0

23−

24−count :: Int -> ProcessId -> Process ()

25−count n them = do

26− us <- getSelfPid

27− replicateM_ n . spawnLocal $ send them (Nothing :: Maybe ProcessId)

28− send them (Just us)

29− n' <- expect

30− liftIO $ print (n == n')

31−

32−initialProcess :: String -> Process ()

33−initialProcess "SERVER" = do

34− us <- getSelfPid

35− liftIO $ BSL.writeFile "counter.pid" (encode us)

36− counter

37−initialProcess "CLIENT" = do

38− n <- liftIO $ getLine

39− them <- liftIO $ decode <$> BSL.readFile "counter.pid"

40− count (read n) them

41−

42−main :: IO ()

43−main = do

44− [role, host, port] <- getArgs

45− trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters

46− case trans of

47− Right transport -> do node <- newLocalNode transport initRemoteTable

48− runProcess node $ initialProcess role

49− Left other -> error $ show other

benchmarks/Throughput.hsdeleted−74

@@ -1,74 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−

4−import System.Environment

5−import Control.Monad

6−import Control.Applicative

7−import Control.Distributed.Process

8−import Control.Distributed.Process.Node

9−import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr)

10−import Data.Binary

11−import qualified Data.ByteString.Lazy as BSL

12−import Data.Typeable

13−

14−data SizedList a = SizedList { size :: Int , elems :: [a] }

15− deriving (Typeable)

16−

17−instance Binary a => Binary (SizedList a) where

18− put (SizedList sz xs) = put sz >> mapM_ put xs

19− get = do

20− sz <- get

21− xs <- getMany sz

22− return (SizedList sz xs)

23−

24−-- Copied from Data.Binary

25−getMany :: Binary a => Int -> Get [a]

26−getMany = go []

27− where

28− go xs 0 = return $! reverse xs

29− go xs i = do x <- get

30− x `seq` go (x:xs) (i-1)

31−{-# INLINE getMany #-}

32−

33−nats :: Int -> SizedList Int

34−nats = \n -> SizedList n (aux n)

35− where

36− aux 0 = []

37− aux n = n : aux (n - 1)

38−

39−counter :: Process ()

40−counter = go 0

41− where

42− go :: Int -> Process ()

43− go !n =

44− receiveWait

45− [ match $ \xs -> go (n + size (xs :: SizedList Int))

46− , match $ \them -> send them n >> go 0

47− ]

48−

49−count :: (Int, Int) -> ProcessId -> Process ()

50−count (packets, sz) them = do

51− us <- getSelfPid

52− replicateM_ packets $ send them (nats sz)

53− send them us

54− n' <- expect

55− liftIO $ print (packets * sz, n' == packets * sz)

56−

57−initialProcess :: String -> Process ()

58−initialProcess "SERVER" = do

59− us <- getSelfPid

60− liftIO $ BSL.writeFile "counter.pid" (encode us)

61− counter

62−initialProcess "CLIENT" = do

63− n <- liftIO getLine

64− them <- liftIO $ decode <$> BSL.readFile "counter.pid"

65− count (read n) them

66−

67−main :: IO ()

68−main = do

69− [role, host, port] <- getArgs

70− trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters

71− case trans of

72− Right transport -> do node <- newLocalNode transport initRemoteTable

73− runProcess node $ initialProcess role

74− Left other -> error $ show other

benchmarks/erlang/latency.erldeleted−35

@@ -1,35 +0,0 @@

1−-module(latency).

2−

3−-export([server/0, client/2, start_server/0, start_client/2]).

4−

5−forever(What) ->

6− What(),

7− forever(What).

8−

9−replicate(0, _) ->

10− ok;

11−replicate(N, What) ->

12− What(),

13− replicate(N - 1, What).

14−

15−server() ->

16− forever(fun () ->

17− receive

18− Them -> Them ! pong

19− end

20− end).

21−

22−client(N, Them) ->

23− replicate(N, fun() ->

24− {pingServer, Them} ! self(),

25− receive

26− pong -> ok

27− end

28− end),

29− io:format("Did ~B pings", [N]).

30−

31−start_server() ->

32− register(pingServer, spawn(latency, server, [])).

33−

34−start_client(N, Them) ->

35− client(N, Them).

benchmarks/erlang/ring.erldeleted−62

@@ -1,62 +0,0 @@

1−%% can be run via escript if desired...

2−-module(ring).

3−

4−-export([main/1]).

5−

6−-record(opts, {

7− ring_size = 1 :: non_neg_integer(),

8− iterations = 1 :: non_neg_integer()

9−}).

10−

11−main(Argv) when is_list(Argv) ->

12− Opts = parse_args(Argv),

13− {Time, ok} = timer:tc(fun() -> run(Opts) end),

14− io:format("elapsed (wallclock) time: ~pms~n", [Time / 1000]).

15−

16−run(#opts{ ring_size=RingSize, iterations=SendCount }) ->

17− Self = self(),

18− Msg = {"foobar", "baz"},

19− Pid = make_ring(RingSize, Self),

20− [Pid ! Msg || _ <- lists:seq(1, SendCount)],

21− collect(SendCount).

22−

23−collect(0) ->

24− ok;

25−collect(N) ->

26− receive

27− {"foobar", "baz"} -> collect(N - 1);

28− Other -> exit({unexpected_message, Other})

29− end.

30−

31−-spec(make_ring(integer(), pid()) -> pid()).

32−make_ring(0, NextPid) ->

33− go(NextPid);

34−make_ring(NumProcs, NextPid) ->

35− make_ring(NumProcs - 1, go(NextPid)).

36−

37−-spec(go(pid()) -> pid()).

38−go(NextPid) ->

39− spawn(fun() -> relay(NextPid) end).

40−

41−-spec(relay(pid()) -> no_return()).

42−relay(NextPid) ->

43− receive

44− {_, _}=Msg -> NextPid ! Msg, relay(NextPid)

45− end.

46−

47−-spec(parse_args([string()]) -> #opts{}).

48−parse_args(Argv) ->

49− lists:foldl(fun parse_args/2, #opts{}, Argv).

50−

51−parse_args(("-r" ++ Val), Opts) ->

52− Sz = check_positive(ring_size, list_to_integer(Val)),

53− Opts#opts{ ring_size = Sz };

54−parse_args(("-i" ++ Val), Opts) ->

55− Iter = check_positive(iterations, list_to_integer(Val)),

56− Opts#opts{ iterations = Iter }.

57−

58−check_positive(K, N) when N < 1 ->

59− io:format("~p must be >= 1~n", [K]),

60− error({K, N});

61−check_positive(_, N) ->

62− N.

benchmarks/erlang/throughput.erldeleted−39

@@ -1,39 +0,0 @@

1−-module(throughput).

2−

3−-export([start_counter/0, start_count/3, counter/0, count/3, nats/1]).

4−

5−nats(0) ->

6− [];

7−nats(N) ->

8− [N | nats(N - 1)].

9−

10−counter() ->

11− counter(0).

12−

13−counter(N) ->

14− receive

15− {count, List} ->

16− counter(N + length(List));

17− {get, Them} ->

18− Them ! N,

19− counter(0)

20− end.

21−

22−replicate(0, _) ->

23− ok;

24−replicate(N, What) ->

25− What(),

26− replicate(N - 1, What).

27−

28−count(Packets, Size, Them) ->

29− replicate(Packets, fun() -> {counter, Them} ! {count, nats(Size)} end),

30− {counter, Them} ! {get, self()},

31− receive

32− N -> io:format("Did ~B pings", [N])

33− end.

34−

35−start_counter() ->

36− register(counter, spawn(throughput, counter, [])).

37−

38−start_count(Packets, Size, Them) ->

39− count(Packets, Size, Them).

benchmarks/remote/Latency.hsdeleted−32

@@ -1,32 +0,0 @@

1−{-# LANGUAGE BangPatterns, TemplateHaskell #-}

2−

3−import Control.Monad

4−import Control.Applicative

5−import Control.Monad.IO.Class (liftIO)

6−import qualified Data.ByteString.Lazy as BSL

7−import Data.Binary (encode, decode)

8−import Remote

9−

10−pingServer :: ProcessM ()

11−pingServer = forever $ do

12− them <- expect

13− send them ()

14−

15−pingClient :: Int -> ProcessId -> ProcessM ()

16−pingClient n them = do

17− us <- getSelfPid

18− replicateM_ n $ send them us >> (expect :: ProcessM ())

19− liftIO . putStrLn $ "Did " ++ show n ++ " pings"

20−

21−initialProcess :: String -> ProcessM ()

22−initialProcess "SERVER" = do

23− us <- getSelfPid

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

25− pingServer

26−initialProcess "CLIENT" = do

27− n <- liftIO $ getLine

28− them <- liftIO $ decode <$> BSL.readFile "pingServer.pid"

29− pingClient (read n) them

30−

31−main :: IO ()

32−main = remoteInit (Just "config") [] initialProcess

benchmarks/remote/Throughput.hsdeleted−39

@@ -1,39 +0,0 @@

1−{-# LANGUAGE BangPatterns, TemplateHaskell #-}

2−

3−import Control.Monad

4−import Control.Applicative

5−import Control.Monad.IO.Class (liftIO)

6−import qualified Data.ByteString.Lazy as BSL

7−import Data.Binary (encode, decode)

8−import Remote

9−

10−counter :: ProcessM ()

11−counter = go 0

12− where

13− go :: Int -> ProcessM ()

14− go !n = do

15− b <- expect

16− case b of

17− Nothing -> go (n + 1)

18− Just them -> send them n >> go 0

19−

20−count :: Int -> ProcessId -> ProcessM ()

21−count n them = do

22− us <- getSelfPid

23− replicateM_ n $ send them (Nothing :: Maybe ProcessId)

24− send them (Just us)

25− n' <- expect

26− liftIO $ print (n == n')

27−

28−initialProcess :: String -> ProcessM ()

29−initialProcess "SERVER" = do

30− us <- getSelfPid

31− liftIO $ BSL.writeFile "counter.pid" (encode us)

32− counter

33−initialProcess "CLIENT" = do

34− n <- liftIO $ getLine

35− them <- liftIO $ decode <$> BSL.readFile "counter.pid"

36− count (read n) them

37−

38−main :: IO ()

39−main = remoteInit (Just "config") [] initialProcess

distributed-process-tests/LICENSE → distributed-process-azure/LICENSErenamed

The content is the same.

distributed-process-tests/Setup.hs → distributed-process-azure/Setup.hsrenamed

The content is the same.

distributed-process-azure/demos/Conway.hsnew file+47

@@ -0,0 +1,47 @@

1+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}

2+import Data.Data (Typeable, Data)

3+import Data.Binary (Binary(get, put))

4+import Data.Binary.Generic (getGeneric, putGeneric)

5+import Control.Distributed.Process

6+ ( Process

7+ , expect

8+ )

9+import Control.Distributed.Process.Closure

10+ ( remotable

11+ , mkClosure

12+ )

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

14+ ( Backend

15+ , ProcessPair(..)

16+ , RemoteProcess

17+ )

18+import Control.Distributed.Process.Backend.Azure.GenericMain (genericMain)

19+

20+data ControllerMsg =

21+ ControllerExit

22+ deriving (Typeable, Data)

23+

24+instance Binary ControllerMsg where

25+ get = getGeneric

26+ put = putGeneric

27+

28+conwayController :: () -> Backend -> Process ()

29+conwayController () _backend = go

30+ where

31+ go = do

32+ msg <- expect

33+ case msg of

34+ ControllerExit ->

35+ return ()

36+

37+remotable ['conwayController]

38+

39+main :: IO ()

40+main = genericMain __remoteTable callable spawnable

41+ where

42+ callable :: String -> IO (ProcessPair ())

43+ callable _ = error "spawnable: unknown"

44+

45+ spawnable :: String -> IO (RemoteProcess ())

46+ spawnable "controller" = return $ $(mkClosure 'conwayController) ()

47+ spawnable _ = error "callable: unknown"

distributed-process-azure/demos/Echo.hsnew file+44

@@ -0,0 +1,44 @@

1+{-# LANGUAGE TemplateHaskell #-}

3+import System.IO (hFlush, stdout)

4+import Control.Monad (unless, forever)

5+import Control.Monad.IO.Class (liftIO)

6+import Control.Distributed.Process (Process, expect)

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

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

9+ ( Backend

10+ , ProcessPair(..)

11+ , RemoteProcess

12+ , LocalProcess

13+ , localExpect

14+ , remoteSend

15+ , localSend

16+ )

17+import Control.Distributed.Process.Backend.Azure.GenericMain (genericMain)

18+

19+echoServer :: () -> Backend -> Process ()

20+echoServer () _backend = forever $ do

21+ str <- expect

22+ remoteSend (str :: String)

23+

24+remotable ['echoServer]

25+

26+echoClient :: LocalProcess ()

27+echoClient = do

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

29+ unless (null str) $ do

30+ localSend str

31+ liftIO $ putStr "Echo: " >> hFlush stdout

32+ echo <- localExpect

33+ liftIO $ putStrLn echo

34+ echoClient

35+

36+main :: IO ()

37+main = genericMain __remoteTable callable spawnable

38+ where

39+ callable :: String -> IO (ProcessPair ())

40+ callable "echo" = return $ ProcessPair ($(mkClosure 'echoServer) ()) echoClient

41+ callable _ = error "callable: unknown"

42+

43+ spawnable :: String -> IO (RemoteProcess ())

44+ spawnable _ = error "spawnable: unknown"

distributed-process-azure/demos/Ping.hsnew file+70

@@ -0,0 +1,70 @@

1+{-# LANGUAGE TemplateHaskell #-}

3+import Data.Binary (encode, decode)

4+import Control.Monad (forever)

5+import Control.Monad.IO.Class (liftIO)

6+import Control.Exception (try, IOException)

7+import Control.Distributed.Process

8+ ( Process

9+ , getSelfPid

10+ , expect

11+ , send

12+ , monitor

13+ , receiveWait

14+ , match

15+ , ProcessMonitorNotification(..)

16+ )

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

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

19+ ( Backend

20+ , ProcessPair(..)

21+ , RemoteProcess

22+ , LocalProcess

23+ , localExpect

24+ , remoteSend

25+ )

26+import Control.Distributed.Process.Backend.Azure.GenericMain (genericMain)

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

28+

29+pingClient :: () -> Backend -> Process ()

30+pingClient () _backend = do

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

32+ case mPingServerEnc of

33+ Left err ->

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

35+ Right pingServerEnc -> do

36+ let pingServerPid = decode pingServerEnc

37+ pid <- getSelfPid

38+ _ref <- monitor pingServerPid

39+ send pingServerPid pid

40+ gotReply <- receiveWait

41+ [ match (\() -> return True)

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

43+ ]

44+ if gotReply

45+ then remoteSend $ "Ping server at " ++ show pingServerPid ++ " ok"

46+ else remoteSend $ "Ping server at " ++ show pingServerPid ++ " failure"

47+

48+pingServer :: () -> Backend -> Process ()

49+pingServer () _backend = do

50+ us <- getSelfPid

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

52+ forever $ do

53+ them <- expect

54+ send them ()

55+

56+remotable ['pingClient, 'pingServer]

57+

58+receiveString :: LocalProcess ()

59+receiveString = localExpect >>= liftIO . putStrLn

60+

61+main :: IO ()

62+main = genericMain __remoteTable callable spawnable

63+ where

64+ callable :: String -> IO (ProcessPair ())

65+ callable "ping" = return $ ProcessPair ($(mkClosure 'pingClient) ()) receiveString

66+ callable _ = error "callable: unknown"

67+

68+ spawnable :: String -> IO (RemoteProcess ())

69+ spawnable "pingServer" = return $ ($(mkClosure 'pingServer) ())

70+ spawnable _ = error "spawnable: unknown"

distributed-process-azure/distributed-process-azure.cabalnew file+91

@@ -0,0 +1,91 @@

1+Name: distributed-process-azure

2+Version: 0.1.0

3+Cabal-Version: >=1.8

4+Build-Type: Simple

5+License: BSD3

6+License-File: LICENSE

7+Copyright: Well-Typed LLP

8+Author: Duncan Coutts, Nicolas Wu, Edsko de Vries

9+Maintainer: edsko@well-typed.com, dcoutts@well-typed.com

10+Stability: experimental

11+Homepage: http://github.com/haskell-distributed/distributed-process

12+Bug-Reports: mailto:edsko@well-typed.com

13+Synopsis: Microsoft Azure backend for Cloud Haskell

14+Category: Control

15+

16+Source-Repository head

17+ Type: git

18+ Location: https://github.com/haskell-distributed/distributed-process

19+ SubDir: distributed-process-azure

20+

21+Flag build-demos

22+ description: Build the demos

23+ default: False

24+

25+Library

26+ Build-Depends: base >= 4.4 && < 5,

27+ azure-service-api >= 0.1 && < 0.2,

28+ filepath >= 1.3 && < 1.4,

29+ executable-path >= 0.0.3 && < 0.1,

30+ libssh2 >= 0.2 && < 0.3,

31+ pureMD5 >= 2.1 && < 2.2,

32+ bytestring >= 0.9 && < 0.11,

33+ distributed-process >= 0.2.3 && < 0.3,

34+ binary >= 0.5 && < 0.6,

35+ network-transport-tcp >= 0.2 && < 0.3,

36+ optparse-applicative >= 0.2 && < 0.4,

37+ transformers >= 0.3 && < 0.4,

38+ certificate >= 1.2.4 && < 1.3,

39+ unix >= 2.5 && < 2.6,

40+ network-transport >= 0.2 && < 0.3,

41+ mtl >= 2.1 && < 2.2

42+ Exposed-modules: Control.Distributed.Process.Backend.Azure,

43+ Control.Distributed.Process.Backend.Azure.GenericMain

44+ Extensions: ViewPatterns,

45+ RankNTypes,

46+ ExistentialQuantification,

47+ ScopedTypeVariables,

48+ DeriveDataTypeable,

49+ GeneralizedNewtypeDeriving

50+ ghc-options: -Wall

51+ HS-Source-Dirs: src

52+

53+Executable cloud-haskell-azure-echo

54+ if flag(build-demos)

55+ Build-Depends: base >= 4.4 && < 5,

56+ distributed-process-azure >= 0.1 && < 0.2,

57+ distributed-process >= 0.2 && < 0.3,

58+ transformers >= 0.3 && < 0.4

59+ else

60+ buildable: False

61+ Main-Is: demos/Echo.hs

62+ ghc-options: -Wall

63+

64+Executable cloud-haskell-azure-ping

65+ if flag(build-demos)

66+ Build-Depends: base >= 4.4 && < 5,

67+ distributed-process-azure >= 0.1 && < 0.2,

68+ distributed-process >= 0.2 && < 0.3,

69+ transformers >= 0.3 && < 0.4,

70+ bytestring >= 0.9 && < 0.11,

71+ binary >= 0.5 && < 0.6,

72+ mtl,

73+ libssh2

74+ else

75+ buildable: False

76+ Main-Is: demos/Ping.hs

77+ ghc-options: -Wall

78+

79+Executable cloud-haskell-azure-conway

80+ if flag(build-demos)

81+ Build-Depends: base >= 4.4 && < 5,

82+ distributed-process-azure >= 0.1 && < 0.2,

83+ distributed-process >= 0.2 && < 0.3,

84+ transformers >= 0.3 && < 0.4,

85+ bytestring >= 0.9 && < 0.11,

86+ binary >= 0.5 && < 0.6,

87+ binary-generic >= 0.2 && < 0.3

88+ else

89+ buildable: False

90+ Main-Is: demos/Conway.hs

91+ ghc-options: -Wall

distributed-process-azure/src/Control/Distributed/Process/Backend/Azure.hsnew file+335

@@ -0,0 +1,335 @@

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

2+ ( -- * Initialization

3+ Backend(..)

4+ , AzureParameters(..)

5+ , defaultAzureParameters

6+ , initializeBackend

7+ -- * Re-exports from Azure Service Management

8+ , CloudService(..)

9+ , VirtualMachine(..)

10+ , Azure.cloudServices

11+ -- * Remote and local processes

12+ , ProcessPair(..)

13+ , RemoteProcess

14+ , LocalProcess

15+ , localExpect

16+ , remoteSend

17+ , remoteThrow

18+ , remoteSend'

19+ , localSend

20+ ) where

21+

22+import System.Environment (getEnv)

23+import System.FilePath ((</>), takeFileName)

24+import System.Environment.Executable (getExecutablePath)

25+import System.IO (stdout, hFlush)

26+import Data.Binary (encode, decode)

27+import Data.Digest.Pure.MD5 (md5, MD5Digest)

28+import qualified Data.ByteString as BSS

29+ ( ByteString

30+ , length

31+ , concat

32+ , hPut

33+ )

34+import qualified Data.ByteString.Char8 as BSSC (pack)

35+import qualified Data.ByteString.Lazy as BSL

36+ ( ByteString

37+ , readFile

38+ , length

39+ , fromChunks

40+ , toChunks

41+ , hPut

42+ )

43+import qualified Data.ByteString.Lazy.Char8 as BSLC (unpack)

44+import Data.Typeable (Typeable)

45+import Control.Applicative ((<$>))

46+import Control.Monad (void, unless)

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

48+import Control.Exception (Exception, catches, Handler(Handler))

49+import Control.Monad.IO.Class (MonadIO, liftIO)

50+

51+-- Azure

52+import Network.Azure.ServiceManagement

53+ ( CloudService(..)

54+ , VirtualMachine(..)

55+ , Endpoint(..)

56+ , AzureSetup

57+ )

58+import qualified Network.Azure.ServiceManagement as Azure

59+ ( cloudServices

60+ , azureSetup

61+ , vmSshEndpoint

62+ )

63+

64+-- SSH

65+import qualified Network.SSH.Client.LibSSH2 as SSH

66+ ( withSSH2

67+ , scpSendFile

68+ , withChannelBy

69+ , Session

70+ , readAllChannel

71+ , writeAllChannel

72+ , Channel

73+ )

74+import qualified Network.SSH.Client.LibSSH2.Foreign as SSH

75+ ( openChannelSession

76+ , channelExecute

77+ , writeChannel

78+ , readChannel

79+ , channelSendEOF

80+ )

81+import qualified Network.SSH.Client.LibSSH2.Errors as SSH

82+ ( ErrorCode

83+ , NULL_POINTER

84+ , getLastError

85+ )

86+

87+-- CH

88+import Control.Distributed.Process (Process, Closure)

89+import Control.Distributed.Process.Serializable (Serializable)

90+import Control.Distributed.Process.Internal.Types

91+ ( messageToPayload

92+ , createMessage

93+ )

94+import Network.Transport.Internal (encodeInt32, decodeInt32, prependLength)

95+

96+-- | Azure backend

97+data Backend = Backend {

98+ -- | Find virtual machines

99+ findVMs :: IO [VirtualMachine]

100+ -- | Copy the executable to a virtual machine

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

102+ -- | Check the MD5 hash of the remote executable

103+ , checkMD5 :: VirtualMachine -> IO Bool

104+ -- | @runOnVM dict vm port p@ starts a CH node on port 'port' and runs 'p'

105+ , callOnVM :: forall a.

106+ VirtualMachine

107+ -> String

108+ -> ProcessPair a

109+ -> IO a

110+ -- | Create a new CH node and run the specified process in the background.

111+ -- The CH node will exit when the process exists.

112+ , spawnOnVM :: VirtualMachine

113+ -> String

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

115+ -> IO ()

116+ } deriving (Typeable)

117+

118+data AzureParameters = AzureParameters {

119+ azureSetup :: AzureSetup

120+ , azureSshUserName :: FilePath

121+ , azureSshPublicKey :: FilePath

122+ , azureSshPrivateKey :: FilePath

123+ , azureSshPassphrase :: String

124+ , azureSshKnownHosts :: FilePath

125+ , azureSshRemotePath :: FilePath

126+ , azureSshLocalPath :: FilePath

127+ }

128+

129+-- | Create default azure parameters

130+defaultAzureParameters :: String -- ^ Azure subscription ID

131+ -> FilePath -- ^ Path to X509 certificate

132+ -> FilePath -- ^ Path to private key

133+ -> IO AzureParameters

134+defaultAzureParameters sid x509 pkey = do

135+ home <- getEnv "HOME"

136+ user <- getEnv "USER"

137+ self <- getExecutablePath

138+ setup <- Azure.azureSetup sid x509 pkey

139+ return AzureParameters

140+ { azureSetup = setup

141+ , azureSshUserName = user

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

143+ , azureSshPrivateKey = home </> ".ssh" </> "id_rsa"

144+ , azureSshPassphrase = ""

145+ , azureSshKnownHosts = home </> ".ssh" </> "known_hosts"

146+ , azureSshRemotePath = takeFileName self

147+ , azureSshLocalPath = self

148+ }

149+

150+-- | Initialize the backend

151+initializeBackend :: AzureParameters -- ^ Connection parameters

152+ -> String -- ^ Cloud service name

153+ -> IO Backend

154+initializeBackend params cloudService =

155+ return Backend {

156+ findVMs = apiFindVMs params cloudService

157+ , copyToVM = apiCopyToVM params

158+ , checkMD5 = apiCheckMD5 params

159+ , callOnVM = apiCallOnVM params

160+ , spawnOnVM = apiSpawnOnVM params

161+ }

162+

163+-- | Find virtual machines

164+apiFindVMs :: AzureParameters -> String -> IO [VirtualMachine]

165+apiFindVMs params cloudService = do

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

167+ case filter ((== cloudService) . cloudServiceName) css of

168+ [cs] -> return $ cloudServiceVMs cs

169+ _ -> return []

170+

171+-- | Start a CH node on the given virtual machine

172+apiCopyToVM :: AzureParameters -> VirtualMachine -> IO ()

173+apiCopyToVM params vm =

174+ void . withSSH2 params vm $ \s -> catchSshError s $

175+ SSH.scpSendFile s 0o700 (azureSshLocalPath params) (azureSshRemotePath params)

176+

177+-- | Call a process on a VM

178+apiCallOnVM :: AzureParameters

179+ -> VirtualMachine

180+ -> String

181+ -> ProcessPair a

182+ -> IO a

183+apiCallOnVM params vm port ppair =

184+ withSSH2 params vm $ \s -> do

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

186+ ++ " onvm run "

187+ ++ " --host " ++ vmIpAddress vm

188+ ++ " --port " ++ port

189+ ++ " 2>&1"

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

191+ SSH.channelExecute ch exe

192+ _ <- SSH.writeChannel ch (encodeInt32 (BSL.length rprocEnc))

193+ _ <- SSH.writeAllChannel ch rprocEnc

194+ runLocalProcess (ppairLocal ppair) ch

195+ if status == 0

196+ then return r

197+ else error "callOnVM: Non-zero exit status"

198+ where

199+ rprocEnc :: BSL.ByteString

200+ rprocEnc = encode (ppairRemote ppair)

201+

202+apiSpawnOnVM :: AzureParameters

203+ -> VirtualMachine

204+ -> String

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

206+ -> IO ()

207+apiSpawnOnVM params vm port proc =

208+ withSSH2 params vm $ \s -> do

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

210+ ++ " onvm run "

211+ ++ " --host " ++ vmIpAddress vm

212+ ++ " --port " ++ port

213+ ++ " --background "

214+ ++ " 2>&1"

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

216+ SSH.channelExecute ch exe

217+ _ <- SSH.writeChannel ch (encodeInt32 (BSL.length procEnc))

218+ _ <- SSH.writeAllChannel ch procEnc

219+ SSH.channelSendEOF ch

220+ SSH.readAllChannel ch

221+ unless (status == 0) $ error (BSLC.unpack r)

222+ where

223+ procEnc :: BSL.ByteString

224+ procEnc = encode proc

225+

226+-- | Check the MD5 hash of the executable on the remote machine

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

228+apiCheckMD5 params vm = do

229+ hash <- localHash params

230+ withSSH2 params vm $ \s -> do

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

232+ SSH.channelExecute ch "md5sum -c --status"

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

234+ SSH.channelSendEOF ch

235+ SSH.readAllChannel ch

236+ return (r == 0)

237+

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

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

240+ SSH.withSSH2 (azureSshKnownHosts params)

241+ (azureSshPublicKey params)

242+ (azureSshPrivateKey params)

243+ (azureSshPassphrase params)

244+ (azureSshUserName params)

245+ (endpointVip ep)

246+ (read $ endpointPort ep)

247+withSSH2 _ vm =

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

249+

250+catchSshError :: SSH.Session -> IO a -> IO a

251+catchSshError s io =

252+ catches io [ Handler handleErrorCode

253+ , Handler handleNullPointer

254+ ]

255+ where

256+ handleErrorCode :: SSH.ErrorCode -> IO a

257+ handleErrorCode _ = do

258+ (_, str) <- SSH.getLastError s

259+ error str

260+

261+ handleNullPointer :: SSH.NULL_POINTER -> IO a

262+ handleNullPointer _ = do

263+ (_, str) <- SSH.getLastError s

264+ error str

265+

266+localHash :: AzureParameters -> IO MD5Digest

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

268+

269+--------------------------------------------------------------------------------

270+-- Local and remote processes --

271+--------------------------------------------------------------------------------

272+

273+data ProcessPair a = ProcessPair {

274+ ppairRemote :: RemoteProcess ()

275+ , ppairLocal :: LocalProcess a

276+ }

277+

278+type RemoteProcess a = Closure (Backend -> Process a)

279+

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

281+ deriving (Functor, Monad, MonadIO, MonadReader SSH.Channel)

282+

283+runLocalProcess :: LocalProcess a -> SSH.Channel -> IO a

284+runLocalProcess = runReaderT . unLocalProcess

285+

286+localExpect :: Serializable a => LocalProcess a

287+localExpect = LocalProcess $ do

288+ ch <- ask

289+ liftIO $ do

290+ isE <- readIntChannel ch

291+ len <- readIntChannel ch

292+ msg <- readSizeChannel ch len

293+ if isE /= 0

294+ then error (decode msg)

295+ else return (decode msg)

296+

297+localSend :: Serializable a => a -> LocalProcess ()

298+localSend x = LocalProcess $ do

299+ ch <- ask

300+ liftIO $ mapM_ (SSH.writeChannel ch)

301+ . prependLength

302+ . messageToPayload

303+ . createMessage

304+ $ x

305+

306+remoteSend :: Serializable a => a -> Process ()

307+remoteSend = liftIO . remoteSend' 0

308+

309+remoteThrow :: Exception e => e -> Process ()

310+remoteThrow = liftIO . remoteSend' 1 . show

311+

312+remoteSend' :: Serializable a => Int -> a -> IO ()

313+remoteSend' flags x = do

314+ let enc = encode x

315+ BSS.hPut stdout (encodeInt32 flags)

316+ BSS.hPut stdout (encodeInt32 (BSL.length enc))

317+ BSL.hPut stdout enc

318+ hFlush stdout

319+

320+--------------------------------------------------------------------------------

321+-- SSH utilities --

322+--------------------------------------------------------------------------------

323+

324+readSizeChannel :: SSH.Channel -> Int -> IO BSL.ByteString

325+readSizeChannel ch = go []

326+ where

327+ go :: [BSS.ByteString] -> Int -> IO BSL.ByteString

328+ go acc 0 = return (BSL.fromChunks $ reverse acc)

329+ go acc size = do

330+ bs <- SSH.readChannel ch (fromIntegral (0x400 `min` size))

331+ go (bs : acc) (size - BSS.length bs)

332+

333+readIntChannel :: SSH.Channel -> IO Int

334+readIntChannel ch =

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

distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/GenericMain.hsnew file+401

@@ -0,0 +1,401 @@

1+-- | Generic main

2+module Control.Distributed.Process.Backend.Azure.GenericMain

3+ ( genericMain

4+ , ProcessPair(..)

5+ ) where

7+import Prelude hiding (catch)

8+import System.Exit (exitSuccess, exitFailure)

9+import System.IO

10+ ( hFlush

11+ , stdout

12+ , stdin

13+ , stderr

14+ , hSetBinaryMode

15+ , hClose

16+ , Handle

17+ )

18+import Data.Foldable (forM_)

19+import Data.Binary (decode)

20+import qualified Data.ByteString.Lazy as BSL (ByteString, hGet, toChunks, length)

21+import qualified Data.ByteString as BSS (hGet, length)

22+import Control.Monad (unless, forM, void)

23+import Control.Monad.Reader (ask)

24+import Control.Exception (SomeException)

25+import Control.Applicative ((<$>), (<*>), optional)

26+import Control.Monad.IO.Class (liftIO)

27+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)

28+

29+-- Posix

30+import qualified System.Posix.Process as Posix (forkProcess, createSession)

31+

32+-- SSH

33+import qualified Network.SSH.Client.LibSSH2.Foreign as SSH

34+ ( initialize

35+ , exit

36+ )

37+

38+-- Command line options

39+import Options.Applicative

40+ ( Parser

41+ , strOption

42+ , long

43+ , (&)

44+ , metavar

45+ , help

46+ , subparser

47+ , command

48+ , info

49+ , progDesc

50+ , execParser

51+ , helper

52+ , fullDesc

53+ , header

54+ , switch

55+ )

56+

57+-- CH

58+import Control.Distributed.Process

59+ ( RemoteTable

60+ , Process

61+ , unClosure

62+ , catch

63+ )

64+import Control.Distributed.Process.Node

65+ ( newLocalNode

66+ , runProcess

67+ , forkProcess

68+ , initRemoteTable

69+ , LocalNode

70+ )

71+import Control.Distributed.Process.Internal.Types

72+ ( LocalProcess(processQueue)

73+ , payloadToMessage

74+ , Message

75+ )

76+import Control.Distributed.Process.Internal.CQueue (CQueue, enqueue)

77+

78+-- Azure

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

80+ ( AzureParameters(azureSshUserName, azureSetup)

81+ , defaultAzureParameters

82+ , initializeBackend

83+ , cloudServices

84+ , VirtualMachine(vmName)

85+ , Backend(findVMs, copyToVM, checkMD5, callOnVM, spawnOnVM)

86+ , ProcessPair(..)

87+ , RemoteProcess

88+ , remoteSend'

89+ , remoteThrow

90+ )

91+

92+-- Transport

93+import Network.Transport.Internal (decodeInt32)

94+import Network.Transport.TCP (createTransport, defaultTCPParameters)

95+

96+--------------------------------------------------------------------------------

97+-- Main --

98+--------------------------------------------------------------------------------

99+

100+genericMain :: (RemoteTable -> RemoteTable) -- ^ Standard CH remote table

101+ -> (String -> IO (ProcessPair ())) -- ^ Closures to support in 'run'

102+ -> (String -> IO (RemoteProcess ())) -- ^ Closures to support in @run --background@

103+ -> IO ()

104+genericMain remoteTable callable spawnable = do

105+ _ <- SSH.initialize True

106+ cmd <- execParser opts

107+ case cmd of

108+ List {} -> do

109+ params <- azureParameters (azureOptions cmd) Nothing

110+ css <- cloudServices (azureSetup params)

111+ mapM_ print css

112+ CopyTo {} -> do

113+ params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))

114+ backend <- initializeBackend params (targetService (target cmd))

115+ vms <- findMatchingVMs backend (targetVM (target cmd))

116+ forM_ vms $ \vm -> do

117+ putStr (vmName vm ++ ": ") >> hFlush stdout

118+ copyToVM backend vm

119+ putStrLn "Done"

120+ CheckMD5 {} -> do

121+ params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))

122+ backend <- initializeBackend params (targetService (target cmd))

123+ vms <- findMatchingVMs backend (targetVM (target cmd))

124+ matches <- forM vms $ \vm -> do

125+ unless (status cmd) $ putStr (vmName vm ++ ": ") >> hFlush stdout

126+ match <- checkMD5 backend vm

127+ unless (status cmd) $ putStrLn $ if match then "OK" else "FAILED"

128+ return match

129+ if and matches

130+ then exitSuccess

131+ else exitFailure

132+ RunOn {} | background cmd -> do

133+ params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))

134+ backend <- initializeBackend params (targetService (target cmd))

135+ vms <- findMatchingVMs backend (targetVM (target cmd))

136+ rProc <- spawnable (closureId cmd)

137+ forM_ vms $ \vm -> do

138+ putStr (vmName vm ++ ": ") >> hFlush stdout

139+ spawnOnVM backend vm (remotePort cmd) rProc

140+ putStrLn "OK"

141+ RunOn {} {- not (background cmd) -} -> do

142+ params <- azureParameters (azureOptions cmd) (Just (sshOptions cmd))

143+ backend <- initializeBackend params (targetService (target cmd))

144+ vms <- findMatchingVMs backend (targetVM (target cmd))

145+ procPair <- callable (closureId cmd)

146+ forM_ vms $ \vm -> do

147+ putStr (vmName vm ++ ": ") >> hFlush stdout

148+ callOnVM backend vm (remotePort cmd) procPair

149+ OnVmCommand (vmCmd@OnVmRun {}) ->

150+ onVmRun (remoteTable initRemoteTable)

151+ (onVmIP vmCmd)

152+ (onVmPort vmCmd)

153+ (onVmBackground vmCmd)

154+ SSH.exit

155+ where

156+ opts = info (helper <*> commandParser)

157+ ( fullDesc

158+ & header "Cloud Haskell backend for Azure"

159+ )

160+

161+findMatchingVMs :: Backend -> Maybe String -> IO [VirtualMachine]

162+findMatchingVMs backend Nothing = findVMs backend

163+findMatchingVMs backend (Just vm) = filter ((== vm) . vmName) `fmap` findVMs backend

164+

165+azureParameters :: AzureOptions -> Maybe SshOptions -> IO AzureParameters

166+azureParameters opts Nothing =

167+ defaultAzureParameters (subscriptionId opts)

168+ (pathToCert opts)

169+ (pathToKey opts)

170+azureParameters opts (Just sshOpts) = do

171+ params <- defaultAzureParameters (subscriptionId opts)

172+ (pathToCert opts)

173+ (pathToKey opts)

174+ return params {

175+ azureSshUserName = remoteUser sshOpts

176+ }

177+

178+--------------------------------------------------------------------------------

179+-- Executing a closure on the VM --

180+--------------------------------------------------------------------------------

181+

182+onVmRun :: RemoteTable -> String -> String -> Bool -> IO ()

183+onVmRun rtable host port bg = do

184+ hSetBinaryMode stdin True

185+ hSetBinaryMode stdout True

186+ mProcEnc <- getWithLength stdin

187+ forM_ mProcEnc $ \procEnc -> do

188+ let proc = decode procEnc

189+ lprocMVar <- newEmptyMVar :: IO (MVar LocalProcess)

190+ if bg

191+ then detach $ startCH proc lprocMVar runProcess (\_ -> return ())

192+ else do

193+ startCH proc lprocMVar forkProcess remoteThrow

194+ lproc <- readMVar lprocMVar

195+ queueFromHandle stdin (processQueue lproc)

196+ where

197+ startCH :: RemoteProcess ()

198+ -> MVar LocalProcess

199+ -> (LocalNode -> Process () -> IO a)

200+ -> (SomeException -> Process ())

201+ -> IO ()

202+ startCH rproc lprocMVar go exceptionHandler = do

203+ mTransport <- createTransport host port defaultTCPParameters

204+ case mTransport of

205+ Left err -> remoteSend' 1 (show err)

206+ Right transport -> do

207+ node <- newLocalNode transport rtable

208+ void . go node $ do

209+ ask >>= liftIO . putMVar lprocMVar

210+ let backend = error "TODO: backend not initialized in onVmRun"

211+ proc <- unClosure rproc :: Process (Backend -> Process ())

212+ catch (proc backend) exceptionHandler

213+

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

215+--

216+-- Returns Nothing on EOF

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

218+getWithLength h = do

219+ lenEnc <- BSS.hGet h 4

220+ if BSS.length lenEnc < 4

221+ then return Nothing

222+ else do

223+ let len = decodeInt32 lenEnc

224+ bs <- BSL.hGet h len

225+ if BSL.length bs < fromIntegral len

226+ then return Nothing

227+ else return (Just bs)

228+

229+queueFromHandle :: Handle -> CQueue Message -> IO ()

230+queueFromHandle h q = do

231+ mPayload <- getWithLength stdin

232+ forM_ mPayload $ \payload -> do

233+ enqueue q $ payloadToMessage (BSL.toChunks payload)

234+ queueFromHandle h q

235+

236+detach :: IO () -> IO ()

237+detach io = do

238+ mapM_ hClose [stdin, stdout, stderr]

239+ void . Posix.forkProcess $ void Posix.createSession >> io

240+

241+--------------------------------------------------------------------------------

242+-- Command line options --

243+--------------------------------------------------------------------------------

244+

245+data AzureOptions = AzureOptions {

246+ subscriptionId :: String

247+ , pathToCert :: FilePath

248+ , pathToKey :: FilePath

249+ }

250+ deriving Show

251+

252+data SshOptions = SshOptions {

253+ remoteUser :: String

254+ }

255+ deriving Show

256+

257+data Target = Target {

258+ targetService :: String

259+ , targetVM :: Maybe String

260+ }

261+ deriving Show

262+

263+data Command =

264+ List {

265+ azureOptions :: AzureOptions

266+ }

267+ | CopyTo {

268+ azureOptions :: AzureOptions

269+ , sshOptions :: SshOptions

270+ , target :: Target

271+ }

272+ | CheckMD5 {

273+ azureOptions :: AzureOptions

274+ , sshOptions :: SshOptions

275+ , target :: Target

276+ , status :: Bool

277+ }

278+ | RunOn {

279+ azureOptions :: AzureOptions

280+ , sshOptions :: SshOptions

281+ , target :: Target

282+ , remotePort :: String

283+ , closureId :: String

284+ , background :: Bool

285+ }

286+ | OnVmCommand {

287+ _onVmCommand :: OnVmCommand

288+ }

289+ deriving Show

290+

291+data OnVmCommand =

292+ OnVmRun {

293+ onVmIP :: String

294+ , onVmPort :: String

295+ , onVmBackground :: Bool

296+ }

297+ deriving Show

298+

299+azureOptionsParser :: Parser AzureOptions

300+azureOptionsParser = AzureOptions

301+ <$> strOption ( long "subscription-id"

302+ & metavar "SID"

303+ & help "Azure subscription ID"

304+ )

305+ <*> strOption ( long "certificate"

306+ & metavar "CERT"

307+ & help "X509 certificate"

308+ )

309+ <*> strOption ( long "private"

310+ & metavar "PRI"

311+ & help "Private key in PKCS#1 format"

312+ )

313+

314+sshOptionsParser :: Parser SshOptions

315+sshOptionsParser = SshOptions

316+ <$> strOption ( long "user"

317+ & metavar "USER"

318+ & help "Remove SSH username"

319+ )

320+

321+listParser :: Parser Command

322+listParser = List <$> azureOptionsParser

323+

324+copyToParser :: Parser Command

325+copyToParser = CopyTo

326+ <$> azureOptionsParser

327+ <*> sshOptionsParser

328+ <*> targetParser

329+

330+targetParser :: Parser Target

331+targetParser = Target

332+ <$> strOption ( long "cloud-service"

333+ & metavar "CS"

334+ & help "Cloud service name"

335+ )

336+ <*> optional (strOption ( long "virtual-machine"

337+ & metavar "VM"

338+ & help "Virtual machine name (all VMs if unspecified)"

339+ ))

340+

341+checkMD5Parser :: Parser Command

342+checkMD5Parser = CheckMD5

343+ <$> azureOptionsParser

344+ <*> sshOptionsParser

345+ <*> targetParser

346+ <*> switch ( long "status"

347+ & help "Don't output anything, status code shows success"

348+ )

349+

350+commandParser :: Parser Command

351+commandParser = subparser

352+ ( command "list" (info listParser

353+ (progDesc "List Azure cloud services"))

354+ & command "install" (info copyToParser

355+ (progDesc "Install the executable"))

356+ & command "md5" (info checkMD5Parser

357+ (progDesc "Check if the remote and local MD5 hash match"))

358+ & command "run" (info runOnParser

359+ (progDesc "Run the executable"))

360+ & command "onvm" (info onVmCommandParser

361+ (progDesc "Commands used when running ON the vm (usually used internally only)"))

362+ )

363+

364+runOnParser :: Parser Command

365+runOnParser = RunOn

366+ <$> azureOptionsParser

367+ <*> sshOptionsParser

368+ <*> targetParser

369+ <*> strOption ( long "port"

370+ & metavar "PORT"

371+ & help "Port number of the CH instance"

372+ )

373+ <*> strOption ( long "closure"

374+ & metavar "PROC"

375+ & help "Process to run on the CH instance"

376+ )

377+ <*> switch ( long "background"

378+ & help "Run the process in the background"

379+ )

380+

381+onVmRunParser :: Parser OnVmCommand

382+onVmRunParser = OnVmRun

383+ <$> strOption ( long "host"

384+ & metavar "IP"

385+ & help "IP address"

386+ )

387+ <*> strOption ( long "port"

388+ & metavar "PORT"

389+ & help "port number"

390+ )

391+ <*> switch ( long "background"

392+ & help "Run the process in the background"

393+ )

394+

395+onVmCommandParser :: Parser Command

396+onVmCommandParser = OnVmCommand <$> subparser

397+ ( command "run" (info onVmRunParser

398+ (progDesc "Run the executable"))

399+ )

400+

401+

distributed-process-simplelocalnet/ChangeLognew file+15

@@ -0,0 +1,15 @@

1+2012-07-17 Edsko de Vries <edsko@well-typed.com> 0.2.0.3

3+* Improve documentation

5+2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.0.2

7+* Relax contraints on bytestring and containers

9+2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1

10+

11+* Bugfix: Documentation referred to old module name

12+

13+2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0

14+

15+* Initial release.

LICENSE → distributed-process-simplelocalnet/LICENSErenamed−1

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

11Copyright Well-Typed LLP, 2011-2012

2−Copyright Tweag I/O Limited, 2015

43All rights reserved.

distributed-process-simplelocalnet/Setup.hsnew file+2

@@ -0,0 +1,2 @@

1+import Distribution.Simple

2+main = defaultMain

distributed-process-simplelocalnet/distributed-process-simplelocalnet.cabalnew file+63

@@ -0,0 +1,63 @@

1+Name: distributed-process-simplelocalnet

2+Version: 0.2.0.3

3+Cabal-Version: >=1.8

4+Build-Type: Simple

5+License: BSD3

6+License-File: LICENSE

7+Copyright: Well-Typed LLP

8+Author: Duncan Coutts, Nicolas Wu, Edsko de Vries

9+Maintainer: edsko@well-typed.com, dcoutts@well-typed.com

10+Stability: experimental

11+Homepage: http://github.com/haskell-distributed/distributed-process

12+Bug-Reports: mailto:edsko@well-typed.com

13+Synopsis: Simple zero-configuration backend for Cloud Haskell

14+Description: Simple backend based on the TCP transport which offers node

15+ discovery based on UDP multicast. This is a zero-configuration

16+ backend designed to get you going with Cloud Haskell quickly

17+ without imposing any structure on your application.

18+Tested-With: GHC==7.2.2 GHC==7.4.1 GHC==7.4.2

19+Category: Control

20+

21+Source-Repository head

22+ Type: git

23+ Location: https://github.com/haskell-distributed/distributed-process

24+ SubDir: distributed-process-simplelocalnet

25+

26+Library

27+ Build-Depends: base >= 4.4 && < 5,

28+ bytestring >= 0.9 && < 0.11,

29+ network >= 2.3 && < 2.4,

30+ network-multicast >= 0.0 && < 0.1,

31+ data-accessor >= 0.2 && < 0.3,

32+ binary >= 0.5 && < 0.6,

33+ containers >= 0.4 && < 0.6,

34+ transformers >= 0.2 && < 0.4,

35+ network-transport >= 0.2 && < 0.3,

36+ network-transport-tcp >= 0.2 && < 0.3,

37+ distributed-process >= 0.2 && < 0.3

38+ Exposed-modules: Control.Distributed.Process.Backend.SimpleLocalnet,

39+ Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast

40+ Extensions: RankNTypes,

41+ DeriveDataTypeable

42+ ghc-options: -Wall

43+ HS-Source-Dirs: src

44+

45+-- Not a proper test, but we want to use cabal to compile it

46+Test-Suite TestSimpleLocalnet

47+ Type: exitcode-stdio-1.0

48+ Main-Is: TestSimpleLocalnet.hs

49+ Build-Depends: base >= 4.4 && < 5,

50+ bytestring >= 0.9 && < 0.11,

51+ network >= 2.3 && < 2.4,

52+ network-multicast >= 0.0 && < 0.1,

53+ data-accessor >= 0.2 && < 0.3,

54+ binary >= 0.5 && < 0.6,

55+ containers >= 0.4 && < 0.6,

56+ transformers >= 0.2 && < 0.4,

57+ network-transport >= 0.2 && < 0.3,

58+ network-transport-tcp >= 0.2 && < 0.3,

59+ distributed-process >= 0.2 && < 0.3

60+ Extensions: RankNTypes,

61+ DeriveDataTypeable

62+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

63+ HS-Source-Dirs: tests src

distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet.hsnew file+332

@@ -0,0 +1,332 @@

1+-- | Simple backend based on the TCP transport which offers node discovery

2+-- based on UDP multicast. This is a zero-configuration backend designed to

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

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+--

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+-- >

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+-- >

25+-- > main :: IO ()

26+-- > main = do

27+-- > args <- getArgs

28+-- >

29+-- > case args of

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

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

32+-- > startMaster backend (master backend)

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

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

35+-- > startSlave backend

36+--

37+-- [Compiling and Running]

38+--

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

40+--

41+-- > ghc -threaded example.hs

42+--

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

44+--

45+-- > ./example slave localhost 8080 &

46+-- > ./example slave localhost 8081 &

47+-- > ./example slave localhost 8082 &

48+-- > ./example slave localhost 8083 &

49+--

50+-- And start the master node:

51+--

52+-- > ./example master localhost 8084

53+--

54+-- which should then output:

55+--

56+-- > Slaves: [nid://localhost:8083:0,nid://localhost:8082:0,nid://localhost:8081:0,nid://localhost:8080:0]

57+--

58+-- at which point the slaves should exit.

59+--

60+-- To run the example on multiple machines, you could run

61+--

62+-- > ./example slave 198.51.100.1 8080 &

63+-- > ./example slave 198.51.100.2 8080 &

64+-- > ./example slave 198.51.100.3 8080 &

65+-- > ./example slave 198.51.100.4 8080 &

66+--

67+-- on four different machines (with IP addresses 198.51.100.1..4), and run the

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,

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

75+-- to a different IP address for them.

76+{-# OPTIONS_GHC -fno-warn-orphans #-}

77+module Control.Distributed.Process.Backend.SimpleLocalnet

78+ ( -- * Initialization

79+ Backend(..)

80+ , initializeBackend

81+ -- * Slave nodes

82+ , startSlave

83+ , terminateSlave

84+ , findSlaves

85+ , terminateAllSlaves

86+ -- * Master nodes

87+ , startMaster

88+ ) where

89+

90+import System.IO (fixIO)

91+import Data.Maybe (catMaybes)

92+import Data.Binary (Binary(get, put), getWord8, putWord8)

93+import Data.Accessor (Accessor, accessor, (^:), (^.))

94+import Data.Set (Set)

95+import qualified Data.Set as Set (insert, empty, toList)

96+import Data.Foldable (forM_)

97+import Data.Typeable (Typeable)

98+import Control.Applicative ((<$>))

99+import Control.Exception (throw)

100+import Control.Monad (forever, forM)

101+import Control.Monad.IO.Class (liftIO)

102+import Control.Concurrent (forkIO, threadDelay, ThreadId)

103+import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)

104+import Control.Distributed.Process

105+ ( RemoteTable

106+ , NodeId

107+ , Process

108+ , WhereIsReply(..)

109+ , whereis

110+ , whereisRemoteAsync

111+ , registerRemote

112+ , getSelfPid

113+ , register

114+ , expect

115+ , nsendRemote

116+ , receiveWait

117+ , matchIf

118+ , processNodeId

119+ )

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

121+ ( LocalNode

122+ , newLocalNode

123+ , localNodeId

124+ , runProcess

125+ )

126+import qualified Network.Transport.TCP as NT

127+ ( createTransport

128+ , defaultTCPParameters

129+ )

130+import qualified Network.Transport as NT (Transport)

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

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

133+

134+-- | Local backend

135+data Backend = Backend {

136+ -- | Create a new local node

137+ newLocalNode :: IO Node.LocalNode

138+ -- | @findPeers t@ broadcasts a /who's there?/ message on the local

139+ -- network, waits 't' msec, and then collects and returns the answers.

140+ -- You can use this to dynamically discover peer nodes.

141+ , findPeers :: Int -> IO [NodeId]

142+ -- | Make sure that all log messages are printed by the logger on the

143+ -- current node

144+ , redirectLogsHere :: Process ()

145+ }

146+

147+data BackendState = BackendState {

148+ _localNodes :: [Node.LocalNode]

149+ , _peers :: Set NodeId

150+ , discoveryDaemon :: ThreadId

151+ }

152+

153+-- | Initialize the backend

154+initializeBackend :: N.HostName -> N.ServiceName -> RemoteTable -> IO Backend

155+initializeBackend host port rtable = do

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

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

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

159+ backendState <- newMVar BackendState

160+ { _localNodes = []

161+ , _peers = Set.empty

162+ , discoveryDaemon = tid

163+ }

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

165+ return (tid', backendState)

166+ case mTransport of

167+ Left err -> throw err

168+ Right transport ->

169+ let backend = Backend {

170+ newLocalNode = apiNewLocalNode transport rtable backendState

171+ , findPeers = apiFindPeers send backendState

172+ , redirectLogsHere = apiRedirectLogsHere backend

173+ }

174+ in return backend

175+

176+-- | Create a new local node

177+apiNewLocalNode :: NT.Transport

178+ -> RemoteTable

179+ -> MVar BackendState

180+ -> IO Node.LocalNode

181+apiNewLocalNode transport rtable backendState = do

182+ localNode <- Node.newLocalNode transport rtable

183+ modifyMVar_ backendState $ return . (localNodes ^: (localNode :))

184+ return localNode

185+

186+-- | Peer discovery

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

188+ -> MVar BackendState

189+ -> Int

190+ -> IO [NodeId]

191+apiFindPeers send backendState delay = do

192+ send PeerDiscoveryRequest

193+ threadDelay delay

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

195+

196+data PeerDiscoveryMsg =

197+ PeerDiscoveryRequest

198+ | PeerDiscoveryReply NodeId

199+

200+instance Binary PeerDiscoveryMsg where

201+ put PeerDiscoveryRequest = putWord8 0

202+ put (PeerDiscoveryReply nid) = putWord8 1 >> put nid

203+ get = do

204+ header <- getWord8

205+ case header of

206+ 0 -> return PeerDiscoveryRequest

207+ 1 -> PeerDiscoveryReply <$> get

208+ _ -> fail "PeerDiscoveryMsg.get: invalid"

209+

210+-- | Respond to peer discovery requests sent by other nodes

211+peerDiscoveryDaemon :: MVar BackendState

212+ -> IO (PeerDiscoveryMsg, N.SockAddr)

213+ -> (PeerDiscoveryMsg -> IO ())

214+ -> IO ()

215+peerDiscoveryDaemon backendState recv send = forever go

216+ where

217+ go = do

218+ (msg, _) <- recv

219+ case msg of

220+ PeerDiscoveryRequest -> do

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

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

223+ PeerDiscoveryReply nid ->

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

225+

226+--------------------------------------------------------------------------------

227+-- Back-end specific primitives --

228+--------------------------------------------------------------------------------

229+

230+-- | Make sure that all log messages are printed by the logger on this node

231+apiRedirectLogsHere :: Backend -> Process ()

232+apiRedirectLogsHere backend = do

233+ mLogger <- whereis "logger"

234+ forM_ mLogger $ \logger -> do

235+ nids <- liftIO $ findPeers backend 1000000

236+ forM_ nids $ \nid -> registerRemote nid "logger" logger

237+

238+--------------------------------------------------------------------------------

239+-- Slaves --

240+--------------------------------------------------------------------------------

241+

242+-- | Messages to slave nodes

243+--

244+-- This datatype is not exposed; instead, we expose primitives for dealing

245+-- with slaves.

246+data SlaveControllerMsg =

247+ SlaveTerminate

248+ deriving (Typeable, Show)

249+

250+instance Binary SlaveControllerMsg where

251+ put SlaveTerminate = putWord8 0

252+ get = do

253+ header <- getWord8

254+ case header of

255+ 0 -> return SlaveTerminate

256+ _ -> fail "SlaveControllerMsg.get: invalid"

257+

258+-- | Calling 'slave' sets up a new local node and then waits. You start

259+-- processes on the slave by calling 'spawn' from other nodes.

260+--

261+-- This function does not return. The only way to exit the slave is to CTRL-C

262+-- the process or call terminateSlave from another node.

263+startSlave :: Backend -> IO ()

264+startSlave backend = do

265+ node <- newLocalNode backend

266+ Node.runProcess node slaveController

267+

268+-- | The slave controller interprets 'SlaveControllerMsg's

269+slaveController :: Process ()

270+slaveController = do

271+ pid <- getSelfPid

272+ register "slaveController" pid

273+ go

274+ where

275+ go = do

276+ msg <- expect

277+ case msg of

278+ SlaveTerminate -> return ()

279+

280+-- | Terminate the slave at the given node ID

281+terminateSlave :: NodeId -> Process ()

282+terminateSlave nid = nsendRemote nid "slaveController" SlaveTerminate

283+

284+-- | Find slave nodes

285+findSlaves :: Backend -> Process [NodeId]

286+findSlaves backend = do

287+ nodes <- liftIO $ findPeers backend 1000000

288+ -- Fire of asynchronous requests for the slave controller

289+ forM_ nodes $ \nid -> whereisRemoteAsync nid "slaveController"

290+ -- Wait for the replies

291+ catMaybes <$> forM nodes (\_ ->

292+ receiveWait

293+ [ matchIf (\(WhereIsReply label _) -> label == "slaveController")

294+ (\(WhereIsReply _ mPid) -> return (processNodeId <$> mPid))

295+ ])

296+

297+-- | Terminate all slaves

298+terminateAllSlaves :: Backend -> Process ()

299+terminateAllSlaves backend = do

300+ slaves <- findSlaves backend

301+ forM_ slaves terminateSlave

302+ liftIO $ threadDelay 1000000

303+

304+--------------------------------------------------------------------------------

305+-- Master nodes

306+--------------------------------------------------------------------------------

307+

308+-- | 'startMaster' finds all slaves currently available on the local network

309+-- (which should therefore be started first), redirects all log messages to

310+-- itself, and then calls the specified process, passing the list of slaves

311+-- nodes.

312+--

313+-- Terminates when the specified process terminates. If you want to terminate

314+-- the slaves when the master terminates, you should manually call

315+-- 'terminateAllSlaves'.

316+startMaster :: Backend -> ([NodeId] -> Process ()) -> IO ()

317+startMaster backend proc = do

318+ node <- newLocalNode backend

319+ Node.runProcess node $ do

320+ slaves <- findSlaves backend

321+ redirectLogsHere backend

322+ proc slaves

323+

324+--------------------------------------------------------------------------------

325+-- Accessors --

326+--------------------------------------------------------------------------------

327+

328+localNodes :: Accessor BackendState [Node.LocalNode]

329+localNodes = accessor _localNodes (\ns st -> st { _localNodes = ns })

330+

331+peers :: Accessor BackendState (Set NodeId)

332+peers = accessor _peers (\ps st -> st { _peers = ps })

distributed-process-simplelocalnet/src/Control/Distributed/Process/Backend/SimpleLocalnet/Internal/Multicast.hsnew file+126

@@ -0,0 +1,126 @@

1+-- | Multicast utilities

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

3+module Control.Distributed.Process.Backend.SimpleLocalnet.Internal.Multicast (initMulticast) where

5+import Data.Function (on)

6+import Data.Map (Map)

7+import qualified Data.Map as Map (empty)

8+import Data.Binary (Binary, decode, encode)

9+import Data.IORef (IORef, newIORef, readIORef, modifyIORef)

10+import qualified Data.ByteString as BSS (ByteString, concat)

11+import qualified Data.ByteString.Lazy as BSL

12+ ( ByteString

13+ , empty

14+ , append

15+ , fromChunks

16+ , toChunks

17+ , length

18+ , splitAt

19+ )

20+import Data.Accessor (Accessor, (^:), (^.), (^=))

21+import qualified Data.Accessor.Container as DAC (mapDefault)

22+import Control.Applicative ((<$>))

23+import Network.Socket (HostName, PortNumber, Socket, SockAddr)

24+import qualified Network.Socket.ByteString as NBS (recvFrom, sendManyTo)

25+import Network.Transport.Internal (decodeInt32, encodeInt32)

26+import Network.Multicast (multicastSender, multicastReceiver)

27+

28+--------------------------------------------------------------------------------

29+-- Top-level API --

30+--------------------------------------------------------------------------------

31+

32+-- | Given a hostname and a port number, initialize the multicast system.

33+--

34+-- Note: it is important that you never send messages larger than the maximum

35+-- message size; if you do, all subsequent communication will probably fail.

36+--

37+-- Returns a reader and a writer.

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

42+ => HostName -- ^ Multicast IP

43+ -> PortNumber -- ^ Port number

44+ -> Int -- ^ Maximum message size

45+ -> IO (IO (a, SockAddr), a -> IO ())

46+initMulticast host port bufferSize = do

47+ (sendSock, sendAddr) <- multicastSender host port

48+ readSock <- multicastReceiver host port

49+ st <- newIORef Map.empty

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

54+ let bytes = encode val

55+ len = encodeInt32 (BSL.length bytes)

56+ NBS.sendManyTo sock (len : BSL.toChunks bytes) addr

57+

58+--------------------------------------------------------------------------------

59+-- UDP multicast read, dealing with multiple senders --

60+--------------------------------------------------------------------------------

61+

62+type UDPState = Map SockAddr BSL.ByteString

63+

64+-- TODO: This is inefficient and an orphan instance.

65+-- Requested official instance (https://github.com/haskell/network/issues/38)

66+instance Ord SockAddr where

67+ compare = compare `on` show

68+

69+bufferFor :: SockAddr -> Accessor UDPState BSL.ByteString

70+bufferFor = DAC.mapDefault BSL.empty

71+

72+bufferAppend :: SockAddr -> BSS.ByteString -> UDPState -> UDPState

73+bufferAppend addr bytes =

74+ bufferFor addr ^: flip BSL.append (BSL.fromChunks [bytes])

75+

76+recvBinary :: Binary a => Socket -> IORef UDPState -> Int -> IO (a, SockAddr)

77+recvBinary sock st bufferSize = do

78+ (bytes, addr) <- recvWithLength sock st bufferSize

79+ return (decode bytes, addr)

80+

81+recvWithLength :: Socket

82+ -> IORef UDPState

83+ -> Int

84+ -> IO (BSL.ByteString, SockAddr)

85+recvWithLength sock st bufferSize = do

86+ (len, addr) <- recvExact sock 4 st bufferSize

87+ let n = decodeInt32 . BSS.concat . BSL.toChunks $ len

88+ bytes <- recvExactFrom addr sock n st bufferSize

89+ return (bytes, addr)

90+

91+-- Receive all bytes currently in the buffer

92+recvAll :: Socket -> IORef UDPState -> Int -> IO SockAddr

93+recvAll sock st bufferSize = do

94+ (bytes, addr) <- NBS.recvFrom sock bufferSize

95+ modifyIORef st $ bufferAppend addr bytes

96+ return addr

97+

98+recvExact :: Socket

99+ -> Int

100+ -> IORef UDPState

101+ -> Int

102+ -> IO (BSL.ByteString, SockAddr)

103+recvExact sock n st bufferSize = do

104+ addr <- recvAll sock st bufferSize

105+ bytes <- recvExactFrom addr sock n st bufferSize

106+ return (bytes, addr)

107+

108+recvExactFrom :: SockAddr

109+ -> Socket

110+ -> Int

111+ -> IORef UDPState

112+ -> Int

113+ -> IO BSL.ByteString

114+recvExactFrom addr sock n st bufferSize = go

115+ where

116+ go :: IO BSL.ByteString

117+ go = do

118+ accAddr <- (^. bufferFor addr) <$> readIORef st

119+ if BSL.length accAddr >= fromIntegral n

120+ then do

121+ let (bytes, accAddr') = BSL.splitAt (fromIntegral n) accAddr

122+ modifyIORef st $ bufferFor addr ^= accAddr'

123+ return bytes

124+ else do

125+ _ <- recvAll sock st bufferSize

126+ go

distributed-process-simplelocalnet/tests/TestSimpleLocalnet.hsnew file+24

@@ -0,0 +1,24 @@

1+import System.Environment (getArgs, getProgName)

2+import Control.Distributed.Process (NodeId, Process, liftIO)

3+import Control.Distributed.Process.Node (initRemoteTable)

4+import Control.Distributed.Process.Backend.SimpleLocalnet

6+master :: Backend -> [NodeId] -> Process ()

7+master backend slaves = do

8+ liftIO . putStrLn $ "Slaves: " ++ show slaves

9+ terminateAllSlaves backend

10+

11+main :: IO ()

12+main = do

13+ prog <- getProgName

14+ args <- getArgs

15+

16+ case args of

17+ ["master", host, port] -> do

18+ backend <- initializeBackend host port initRemoteTable

19+ startMaster backend (master backend)

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

21+ backend <- initializeBackend host port initRemoteTable

22+ startSlave backend

23+ _ ->

24+ putStrLn $ "usage: " ++ prog ++ " (master | slave) host port"

distributed-process-simplelocalnet/tests/runTestSimpleLocalnet.hsnew file+11

@@ -0,0 +1,11 @@

1+#!/bin/bash

2+TestSimpleLocalnet=dist/build/TestSimpleLocalnet/TestSimpleLocalnet

3+$TestSimpleLocalnet slave 127.0.0.1 8080 &

4+sleep 1

5+$TestSimpleLocalnet slave 127.0.0.1 8081 &

6+sleep 1

7+$TestSimpleLocalnet slave 127.0.0.1 8082 &

8+sleep 1

9+$TestSimpleLocalnet slave 127.0.0.1 8083 &

10+sleep 1

11+$TestSimpleLocalnet master 127.0.0.1 8084

distributed-process-tests/.gitignoredeleted−4

@@ -1,4 +0,0 @@

1−dist/

2−.cabal-sandbox

3−cabal.sandbox.config

4−.stack*

distributed-process-tests/CONTRIBUTING.mddeleted−1

@@ -1 +0,0 @@

1−See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md.

distributed-process-tests/README.mddeleted−14

@@ -1,14 +0,0 @@

1−# distributed-process-tests

2−[![travis](https://secure.travis-ci.org/haskell-distributed/distributed-process-tests.png)](http://travis-ci.org/haskell-distributed/distributed-process-tests)

3−[![Release](https://img.shields.io/hackage/v/distributed-process-tests.svg)](https://hackage.haskell.org/package/distributed-process-tests)

4−

5−See http://haskell-distributed.github.com for documentation, user guides,

6−tutorials and assistance.

7−

8−## Getting Help / Raising Issues

9−

10−Please visit the [bug tracker](https://github.com/haskell-distributed/distributed-process-tests/issues) to submit issues. You can contact the distributed-haskell@googlegroups.com mailing list for help and comments.

11−

12−## License

13−

14−This package is made available under a 3-clause BSD-style license.

distributed-process-tests/distributed-process-tests.cabaldeleted−158

@@ -1,158 +0,0 @@

1−name: distributed-process-tests

2−version: 0.4.11

3−synopsis: Tests and test support tools for distributed-process.

4−homepage: http://github.com/haskell-distributed/distributed-process/tree/master/distributed-process-tests

5−description: Tests and test suite for Cloud Haskell libraries.

6−license: BSD3

7−license-file: LICENSE

8−Author: Duncan Coutts, Nicolas Wu, Edsko de Vries

9−Maintainer: Tim Watson <watson.timothy@gmail.com>

10−copyright: Well-Typed LLP

11−category: Control, Cloud Haskell

12−build-type: Simple

13−cabal-version: >=1.8

14−

15−flag tcp

16− Description: build and run TCP tests

17− Default: False

18−

19−library

20− exposed-modules: Network.Transport.Test

21− Control.Distributed.Process.Tests.CH

22− Control.Distributed.Process.Tests.Closure

23− Control.Distributed.Process.Tests.Mx

24− Control.Distributed.Process.Tests.Receive

25− Control.Distributed.Process.Tests.Stats

26− Control.Distributed.Process.Tests.Tracing

27− Control.Distributed.Process.Tests.Internal.Utils

28− Build-Depends: base >= 4.4 && < 5,

29− ansi-terminal >= 0.5,

30− binary >= 0.5 && < 0.9,

31− bytestring >= 0.9 && < 0.12,

32− distributed-process >= 0.6.0 && < 0.8,

33− distributed-static,

34− exceptions >= 0.5,

35− HUnit >= 1.2 && < 1.7,

36− network-transport >= 0.4.1.0 && < 0.6,

37− network >= 2.5 && < 2.9,

38− random >= 1.0 && < 1.2,

39− rematch >= 0.1.2.1,

40− setenv >= 0.1.1.3,

41− test-framework >= 0.6 && < 0.9,

42− test-framework-hunit >= 0.2.0 && < 0.4,

43− stm

44− hs-source-dirs: src

45− ghc-options: -Wall -fno-warn-unused-do-bind

46− extensions: CPP,

47− ExistentialQuantification,

48− FlexibleInstances,

49− DeriveDataTypeable,

50− DeriveGeneric,

51− GeneralizedNewtypeDeriving,

52− RankNTypes,

53− RecordWildCards,

54− ScopedTypeVariables

55− if impl(ghc <= 7.4.2)

56− Build-Depends: ghc-prim == 0.2.0.0

57−

58−Test-Suite TestCHInMemory

59− Type: exitcode-stdio-1.0

60− Main-Is: runInMemory.hs

61− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.CH

62− Build-Depends: base >= 4.4 && < 5,

63− distributed-process-tests,

64− network >= 2.3 && < 2.9,

65− network-transport >= 0.4.1.0 && < 0.6,

66− network-transport-inmemory >= 0.5,

67− test-framework >= 0.6 && < 0.9

68− Extensions: CPP

69− ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

70− HS-Source-Dirs: tests

71−

72−Test-Suite TestCHInTCP

73− Type: exitcode-stdio-1.0

74− Main-Is: runTCP.hs

75− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.CH

76− if flag(tcp)

77− Build-Depends: base >= 4.4 && < 5,

78− distributed-process-tests,

79− network >= 2.3 && < 2.9,

80− network-transport >= 0.4.1.0 && < 0.6,

81− network-transport-tcp >= 0.5 && < 0.7,

82− test-framework >= 0.6 && < 0.9

83− else

84− Buildable: False

85− Extensions: CPP

86− ghc-options: -Wall -threaded -eventlog -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

87− HS-Source-Dirs: tests

88−

89−

90−Test-Suite TestClosure

91− Type: exitcode-stdio-1.0

92− Main-Is: runInMemory.hs

93− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Closure

94− Build-Depends: base >= 4.4 && < 5,

95− distributed-process-tests,

96− network >= 2.3 && < 2.9,

97− network-transport >= 0.4.1.0 && < 0.6,

98− network-transport-inmemory >= 0.5,

99− test-framework >= 0.6 && < 0.9

100− Extensions: CPP

101− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

102− HS-Source-Dirs: tests

103−

104−Test-Suite TestStats

105− Type: exitcode-stdio-1.0

106− Main-Is: runInMemory.hs

107− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Stats

108− Build-Depends: base >= 4.4 && < 5,

109− distributed-process-tests,

110− network >= 2.3 && < 2.9,

111− network-transport >= 0.4.1.0 && < 0.6,

112− network-transport-inmemory >= 0.5,

113− test-framework >= 0.6 && < 0.9

114− Extensions: CPP

115− ghc-options: -Wall -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

116− HS-Source-Dirs: tests

117−

118−Test-Suite TestMxInMemory

119− Type: exitcode-stdio-1.0

120− Main-Is: runInMemory.hs

121− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx

122− Build-Depends: base >= 4.4 && < 5,

123− distributed-process-tests,

124− network >= 2.3 && < 2.9,

125− network-transport >= 0.4.1.0 && < 0.6,

126− network-transport-inmemory >= 0.5,

127− test-framework >= 0.6 && < 0.9

128− Extensions: CPP

129− ghc-options: -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

130− HS-Source-Dirs: tests

131−

132−Test-Suite TestTracingInMemory

133− Type: exitcode-stdio-1.0

134− Main-Is: runInMemory.hs

135− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Tracing

136− Build-Depends: base >= 4.4 && < 5,

137− distributed-process-tests,

138− network >= 2.3 && < 2.9,

139− network-transport >= 0.4.1.0 && < 0.6,

140− network-transport-inmemory >= 0.5,

141− test-framework >= 0.6 && < 0.9

142− Extensions: CPP

143− ghc-options: -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

144− HS-Source-Dirs: tests

145−

146−Test-Suite TestMxInTCP

147− Type: exitcode-stdio-1.0

148− Main-Is: runInMemory.hs

149− CPP-Options: -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx

150− Build-Depends: base >= 4.4 && < 5,

151− distributed-process-tests,

152− network >= 2.3 && < 2.9,

153− network-transport >= 0.4.1.0 && < 0.6,

154− network-transport-inmemory >= 0.5,

155− test-framework >= 0.6 && < 0.9

156− Extensions: CPP

157− ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

158− HS-Source-Dirs: tests

distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hsdeleted−1879

@@ -1,1879 +0,0 @@

1−module Control.Distributed.Process.Tests.CH (tests) where

2−

3−#if ! MIN_VERSION_base(4,6,0)

4−import Prelude hiding (catch)

5−#endif

6−

7−import Network.Transport.Test (TestTransport(..))

8−

9−import Data.Binary (Binary(..))

10−import Data.Typeable (Typeable)

11−import Data.Foldable (forM_)

12−import Data.Function (fix)

13−import Data.IORef

14− ( readIORef

15− , writeIORef

16− , newIORef

17− )

18−import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId, yield)

19−import Control.Concurrent.MVar

20− ( MVar

21− , newEmptyMVar

22− , putMVar

23− , takeMVar

24− , readMVar

25− )

26−import Control.Monad (replicateM_, replicateM, forever, void, unless, join)

27−import Control.Exception (SomeException, throwIO, ErrorCall(..))

28−import Control.Monad.Catch (try, catch, finally, mask, onException)

29−import Control.Applicative ((<|>))

30−import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)

31−import Control.Distributed.Process hiding

32− ( try

33− , catch

34− , finally

35− , mask

36− , onException

37− )

38−import Control.Distributed.Process.Internal.Types

39− ( LocalNode(localEndPoint)

40− , ProcessExitException(..)

41− , nullProcessId

42− , createUnencodedMessage

43− )

44−import Control.Distributed.Process.Node

45−import Control.Distributed.Process.Debug

46−import Control.Distributed.Process.Management.Internal.Types

47−import Control.Distributed.Process.Tests.Internal.Utils (shouldBe, pause)

48−import Control.Distributed.Process.Serializable (Serializable)

49−import Data.Maybe (isNothing, isJust)

50−import Test.HUnit (Assertion, assertBool, assertFailure)

51−import Test.Framework (Test, testGroup)

52−import Test.Framework.Providers.HUnit (testCase)

53−import Control.Rematch hiding (match, isNothing, isJust)

54−import Control.Rematch.Run (Match(..))

55−

56−newtype Ping = Ping ProcessId

57− deriving (Typeable, Binary, Show)

58−

59−newtype Pong = Pong ProcessId

60− deriving (Typeable, Binary, Show)

61−

62−--------------------------------------------------------------------------------

63−-- Supporting definitions --

64−--------------------------------------------------------------------------------

65−

66−expectThat :: a -> Matcher a -> Assertion

67−expectThat a matcher = case res of

68− MatchSuccess -> return ()

69− (MatchFailure msg) -> assertFailure msg

70− where res = runMatch matcher a

71−

72−-- | Like fork, but throw exceptions in the child thread to the parent

73−forkTry :: IO () -> IO ThreadId

74−forkTry p = do

75− tid <- myThreadId

76− forkIO $ catch p (\e -> throwTo tid (e :: SomeException))

77−

78−-- | The ping server from the paper

79−ping :: Process ()

80−ping = do

81− Pong partner <- expect

82− self <- getSelfPid

83− send partner (Ping self)

84− ping

85−

86−verifyClient :: String -> MVar Bool -> IO ()

87−verifyClient s b = takeMVar b >>= assertBool s

88−

89−expectPing :: MVar Bool -> Process ()

90−expectPing mv = expect >>= liftIO . putMVar mv . checkPing

91− where

92− checkPing (Ping _) = True

93−

94−-- | Quick and dirty synchronous version of whereisRemoteAsync

95−whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)

96−whereisRemote nid string = do

97− whereisRemoteAsync nid string

98− receiveWait [

99− match (\(WhereIsReply _ mPid) -> return mPid)

100− ]

101−

102−verifyWhereIsRemote :: NodeId -> String -> Process ProcessId

103−verifyWhereIsRemote n s = whereisRemote n s >>= maybe (die "remote name not found") return

104−

105−waitForExit :: ProcessId -> Process DiedReason

106−waitForExit pid = monitor pid >>= waitForDown

107−

108−waitForDown :: MonitorRef -> Process DiedReason

109−waitForDown ref =

110− receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')

111− (\(ProcessMonitorNotification _ _ dr) -> return dr) ]

112−

113−syncBreakConnection :: (NT.EndPointAddress -> NT.EndPointAddress -> IO ()) -> LocalNode -> LocalNode -> IO ()

114−syncBreakConnection breakConnection nid0 nid1 = do

115− m <- newEmptyMVar

116− _ <- forkProcess nid1 $ getSelfPid >>= liftIO . putMVar m

117− runProcess nid0 $ do

118− them <- liftIO $ takeMVar m

119− pinger <- spawnLocal $ forever $ send them ()

120− _ <- monitorNode (localNodeId nid1)

121− liftIO $ breakConnection (nodeAddress $ localNodeId nid0)

122− (nodeAddress $ localNodeId nid1)

123− NodeMonitorNotification _ _ _ <- expect

124− kill pinger "finished"

125− return ()

126−

127−data Add = Add ProcessId Double Double deriving (Typeable)

128−data Divide = Divide ProcessId Double Double deriving (Typeable)

129−data DivByZero = DivByZero deriving (Typeable)

130−

131−instance Binary Add where

132− put (Add pid x y) = put pid >> put x >> put y

133− get = Add <$> get <*> get <*> get

134−

135−instance Binary Divide where

136− put (Divide pid x y) = put pid >> put x >> put y

137− get = Divide <$> get <*> get <*> get

138−

139−instance Binary DivByZero where

140− put DivByZero = return ()

141− get = return DivByZero

142−

143−-- The math server from the paper

144−math :: Process ()

145−math = do

146− receiveWait

147− [ match (\(Add pid x y) -> send pid (x + y))

148− , matchIf (\(Divide _ _ y) -> y /= 0)

149− (\(Divide pid x y) -> send pid (x / y))

150− , match (\(Divide pid _ _) -> send pid DivByZero)

151− ]

152− math

153−

154−-- | Monitor or link to a remote node

155−monitorOrLink :: Bool -- ^ 'True' for monitor, 'False' for link

156− -> ProcessId -- ^ Process to monitor/link to

157− -> Maybe (MVar ()) -- ^ MVar to signal on once the monitor has been set up

158− -> Process (Maybe MonitorRef)

159−monitorOrLink mOrL pid mSignal = do

160− result <- if mOrL then Just <$> monitor pid

161− else link pid >> return Nothing

162− -- Monitor is asynchronous, which usually does not matter but if we want a

163− -- *specific* signal then it does. Therefore we wait until the MonitorRef is

164− -- listed in the ProcessInfo and hope that this means the monitor has been set

165− -- up.

166− forM_ mSignal $ \signal -> do

167− self <- getSelfPid

168− spawnLocal $ do

169− let waitForMOrL = do

170− liftIO $ threadDelay 100000

171− mpinfo <- getProcessInfo pid

172− case mpinfo of

173− Nothing -> waitForMOrL

174− Just pinfo ->

175− if mOrL then

176− unless (result == lookup self (infoMonitors pinfo)) waitForMOrL

177− else

178− unless (elem self $ infoLinks pinfo) waitForMOrL

179− waitForMOrL

180− liftIO $ putMVar signal ()

181− return result

182−

183−monitorTestProcess :: ProcessId -- Process to monitor/link to

184− -> Bool -- 'True' for monitor, 'False' for link

185− -> Bool -- Should we unmonitor?

186− -> DiedReason -- Expected cause of death

187− -> Maybe (MVar ()) -- Signal for 'monitor set up'

188− -> MVar () -- Signal for successful termination

189− -> Process ()

190−monitorTestProcess theirAddr mOrL un reason monitorSetup done =

191− catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup

192− case (un, mRef) of

193− (True, Nothing) -> do

194− unlink theirAddr

195− liftIO $ putMVar done ()

196− (True, Just ref) -> do

197− unmonitor ref

198− liftIO $ putMVar done ()

199− (False, ref) -> do

200− receiveWait [

201− match (\(ProcessMonitorNotification ref' pid reason') -> do

202− liftIO $ do

203− assertBool "Bad Monitor Signal"

204− (Just ref' == ref && pid == theirAddr &&

205− mOrL && reason == reason')

206− putMVar done ())

207− ]

208− )

209− (\(ProcessLinkException pid reason') -> do

210− (liftIO $ assertBool "link exception unmatched" $

211− pid == theirAddr && not mOrL && not un && reason == reason')

212− liftIO $ putMVar done ()

213− )

214−

215−--------------------------------------------------------------------------------

216−-- The tests proper --

217−--------------------------------------------------------------------------------

218−

219−-- | Basic ping test

220−testPing :: TestTransport -> Assertion

221−testPing TestTransport{..} = do

222− serverAddr <- newEmptyMVar

223− clientDone <- newEmptyMVar

224−

225− -- Server

226− forkIO $ do

227− localNode <- newLocalNode testTransport initRemoteTable

228− addr <- forkProcess localNode ping

229− putMVar serverAddr addr

230−

231− -- Client

232− forkIO $ do

233− localNode <- newLocalNode testTransport initRemoteTable

234− pingServer <- readMVar serverAddr

235−

236− let numPings = 10000

237−

238− runProcess localNode $ do

239− pid <- getSelfPid

240− replicateM_ numPings $ do

241− send pingServer (Pong pid)

242− p <- expectTimeout 3000000

243− case p of

244− Just (Ping _) -> return ()

245− Nothing -> die "Failed to receive Ping"

246−

247− putMVar clientDone ()

248−

249− takeMVar clientDone

250−

251−-- | Monitor a process on an unreachable node

252−testMonitorUnreachable :: TestTransport -> Bool -> Bool -> Assertion

253−testMonitorUnreachable TestTransport{..} mOrL un = do

254− deadProcess <- newEmptyMVar

255− done <- newEmptyMVar

256−

257− forkIO $ do

258− localNode <- newLocalNode testTransport initRemoteTable

259− addr <- forkProcess localNode expect

260− closeLocalNode localNode

261− putMVar deadProcess addr

262−

263− forkIO $ do

264− localNode <- newLocalNode testTransport initRemoteTable

265− theirAddr <- readMVar deadProcess

266− runProcess localNode $

267− monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done

268−

269− takeMVar done

270−

271−-- | Monitor a process which terminates normally

272−testMonitorNormalTermination :: TestTransport -> Bool -> Bool -> Assertion

273−testMonitorNormalTermination TestTransport{..} mOrL un = do

274− monitorSetup <- newEmptyMVar

275− monitoredProcess <- newEmptyMVar

276− done <- newEmptyMVar

277−

278− forkIO $ do

279− localNode <- newLocalNode testTransport initRemoteTable

280− addr <- forkProcess localNode $

281− liftIO $ readMVar monitorSetup

282− putMVar monitoredProcess addr

283−

284− forkIO $ do

285− localNode <- newLocalNode testTransport initRemoteTable

286− theirAddr <- readMVar monitoredProcess

287− runProcess localNode $

288− monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done

289−

290− takeMVar done

291−

292−-- | Monitor a process which terminates abnormally

293−testMonitorAbnormalTermination :: TestTransport -> Bool -> Bool -> Assertion

294−testMonitorAbnormalTermination TestTransport{..} mOrL un = do

295− monitorSetup <- newEmptyMVar

296− monitoredProcess <- newEmptyMVar

297− done <- newEmptyMVar

298−

299− let err = userError "Abnormal termination"

300−

301− forkIO $ do

302− localNode <- newLocalNode testTransport initRemoteTable

303− addr <- forkProcess localNode . liftIO $ do

304− readMVar monitorSetup

305− throwIO err

306− putMVar monitoredProcess addr

307−

308− forkIO $ do

309− localNode <- newLocalNode testTransport initRemoteTable

310− theirAddr <- readMVar monitoredProcess

311− runProcess localNode $

312− monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done

313−

314− takeMVar done

315−

316−-- | Monitor a local process that is already dead

317−testMonitorLocalDeadProcess :: TestTransport -> Bool -> Bool -> Assertion

318−testMonitorLocalDeadProcess TestTransport{..} mOrL un = do

319− processAddr <- newEmptyMVar

320− localNode <- newLocalNode testTransport initRemoteTable

321− done <- newEmptyMVar

322−

323− forkIO $ do

324− addr <- forkProcess localNode $ return ()

325− putMVar processAddr addr

326−

327− forkIO $ do

328− theirAddr <- readMVar processAddr

329− runProcess localNode $ do

330− monitor theirAddr

331− -- wait for the process to die

332− expect :: Process ProcessMonitorNotification

333− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

334−

335− takeMVar done

336−

337−-- | Monitor a remote process that is already dead

338−testMonitorRemoteDeadProcess :: TestTransport -> Bool -> Bool -> Assertion

339−testMonitorRemoteDeadProcess TestTransport{..} mOrL un = do

340− processDead <- newEmptyMVar

341− processAddr <- newEmptyMVar

342− done <- newEmptyMVar

343−

344− forkIO $ do

345− localNode <- newLocalNode testTransport initRemoteTable

346− addr <- forkProcess localNode . liftIO $ putMVar processDead ()

347− putMVar processAddr addr

348−

349− forkIO $ do

350− localNode <- newLocalNode testTransport initRemoteTable

351− theirAddr <- readMVar processAddr

352− readMVar processDead

353− runProcess localNode $ do

354− monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done

355−

356− takeMVar done

357−

358−-- | Monitor a process that becomes disconnected

359−testMonitorDisconnect :: TestTransport -> Bool -> Bool -> Assertion

360−testMonitorDisconnect TestTransport{..} mOrL un = do

361− processAddr <- newEmptyMVar

362− processAddr2 <- newEmptyMVar

363− monitorSetup <- newEmptyMVar

364− done <- newEmptyMVar

365−

366− forkIO $ do

367− localNode <- newLocalNode testTransport initRemoteTable

368− addr <- forkProcess localNode $ expect

369− addr2 <- forkProcess localNode $ return ()

370− putMVar processAddr addr

371− readMVar monitorSetup

372− NT.closeEndPoint (localEndPoint localNode)

373− putMVar processAddr2 addr2

374−

375− forkIO $ do

376− localNode <- newLocalNode testTransport initRemoteTable

377− theirAddr <- readMVar processAddr

378− forkProcess localNode $ do

379− lc <- liftIO $ readMVar processAddr2

380− send lc ()

381− runProcess localNode $ do

382− monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done

383−

384− takeMVar done

385−

386−-- | Test the math server (i.e., receiveWait)

387−testMath :: TestTransport -> Assertion

388−testMath TestTransport{..} = do

389− serverAddr <- newEmptyMVar

390− clientDone <- newEmptyMVar

391−

392− -- Server

393− forkIO $ do

394− localNode <- newLocalNode testTransport initRemoteTable

395− addr <- forkProcess localNode math

396− putMVar serverAddr addr

397−

398− -- Client

399− forkIO $ do

400− localNode <- newLocalNode testTransport initRemoteTable

401− mathServer <- readMVar serverAddr

402−

403− runProcess localNode $ do

404− pid <- getSelfPid

405− send mathServer (Add pid 1 2)

406− three <- expect :: Process Double

407− send mathServer (Divide pid 8 2)

408− four <- expect :: Process Double

409− send mathServer (Divide pid 8 0)

410− divByZ <- expect

411− liftIO $ putMVar clientDone (three, four, divByZ)

412−

413− res <- takeMVar clientDone

414− case res of

415− (3, 4, DivByZero) -> return ()

416− _ -> error $ "Something went horribly wrong"

417−

418−-- | Send first message (i.e. connect) to an already terminated process

419−-- (without monitoring); then send another message to a second process on

420−-- the same remote node (we're checking that the remote node did not die)

421−testSendToTerminated :: TestTransport -> Assertion

422−testSendToTerminated TestTransport{..} = do

423− serverAddr1 <- newEmptyMVar

424− serverAddr2 <- newEmptyMVar

425− clientDone <- newEmptyMVar

426−

427− forkIO $ do

428− terminated <- newEmptyMVar

429− localNode <- newLocalNode testTransport initRemoteTable

430− addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()

431− addr2 <- forkProcess localNode $ ping

432− readMVar terminated

433− putMVar serverAddr1 addr1

434− putMVar serverAddr2 addr2

435−

436− forkIO $ do

437− localNode <- newLocalNode testTransport initRemoteTable

438− server1 <- readMVar serverAddr1

439− server2 <- readMVar serverAddr2

440− runProcess localNode $ do

441− pid <- getSelfPid

442− send server1 "Hi"

443− send server2 (Pong pid)

444− expectPing clientDone

445−

446− verifyClient "Expected Ping from server" clientDone

447−

448−-- | Test (non-zero) timeout

449−testTimeout :: TestTransport -> Assertion

450−testTimeout TestTransport{..} = do

451− localNode <- newLocalNode testTransport initRemoteTable

452− done <- newEmptyMVar

453−

454− runProcess localNode $ do

455− res <- receiveTimeout 1000000 [match (\Add{} -> return ())]

456− liftIO $ putMVar done $ res == Nothing

457−

458− verifyClient "Expected receiveTimeout to timeout..." done

459−

460−-- | Test zero timeout

461−testTimeout0 :: TestTransport -> Assertion

462−testTimeout0 TestTransport{..} = do

463− serverAddr <- newEmptyMVar

464− clientDone <- newEmptyMVar

465−

466− forkIO $ do

467− localNode <- newLocalNode testTransport initRemoteTable

468− addr <- forkProcess localNode $ do

469− -- Variation on the venerable ping server which uses a zero timeout

470− partner <- fix $ \loop ->

471− receiveTimeout 0 [match (\(Pong partner) -> return partner)]

472− >>= maybe (liftIO (threadDelay 100000) >> loop) return

473− self <- getSelfPid

474− send partner (Ping self)

475− putMVar serverAddr addr

476−

477− forkIO $ do

478− localNode <- newLocalNode testTransport initRemoteTable

479− server <- readMVar serverAddr

480− runProcess localNode $ do

481− pid <- getSelfPid

482− -- Send a bunch of messages. A large number of messages that the server

483− -- is not interested in, and then a single message that it wants

484− replicateM_ 10000 $ send server "Irrelevant message"

485− send server (Pong pid)

486− expectPing clientDone

487−

488− verifyClient "Expected Ping from server" clientDone

489−

490−-- | Test typed channels

491−testTypedChannels :: TestTransport -> Assertion

492−testTypedChannels TestTransport{..} = do

493− serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))

494− clientDone <- newEmptyMVar

495−

496− forkIO $ do

497− localNode <- newLocalNode testTransport initRemoteTable

498− forkProcess localNode $ do

499− (serverSendPort, rport) <- newChan

500− liftIO $ putMVar serverChannel serverSendPort

501− (clientSendPort, i) <- receiveChan rport

502− sendChan clientSendPort (even i)

503− return ()

504−

505− forkIO $ do

506− localNode <- newLocalNode testTransport initRemoteTable

507− serverSendPort <- readMVar serverChannel

508− runProcess localNode $ do

509− (clientSendPort, rport) <- newChan

510− sendChan serverSendPort (clientSendPort, 5)

511− ch <- receiveChan rport

512− liftIO $ putMVar clientDone $ ch == False

513−

514− verifyClient "Expected channel to send 'False'" clientDone

515−

516−-- | Test merging receive ports

517−testMergeChannels :: TestTransport -> Assertion

518−testMergeChannels TestTransport{..} = do

519− localNode <- newLocalNode testTransport initRemoteTable

520− testFlat localNode True "aaabbbccc"

521− testFlat localNode False "abcabcabc"

522− testNested localNode True True "aaabbbcccdddeeefffggghhhiii"

523− testNested localNode True False "adgadgadgbehbehbehcficficfi"

524− testNested localNode False True "abcabcabcdefdefdefghighighi"

525− testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"

526− testBlocked localNode True

527− testBlocked localNode False

528− where

529− -- Single layer of merging

530− testFlat :: LocalNode -> Bool -> String -> IO ()

531− testFlat localNode biased expected = do

532− done <- newEmptyMVar

533− forkProcess localNode $ do

534− rs <- mapM charChannel "abc"

535− m <- mergePorts biased rs

536− xs <- replicateM 9 $ receiveChan m

537− liftIO $ putMVar done $ xs == expected

538− verifyClient "Expected single layer merge to match expected ordering" done

539−

540− -- Two layers of merging

541− testNested :: LocalNode -> Bool -> Bool -> String -> IO ()

542− testNested localNode biasedInner biasedOuter expected = do

543− done <- newEmptyMVar

544− forkProcess localNode $ do

545− rss <- mapM (mapM charChannel) ["abc", "def", "ghi"]

546− ms <- mapM (mergePorts biasedInner) rss

547− m <- mergePorts biasedOuter ms

548− xs <- replicateM (9 * 3) $ receiveChan m

549− liftIO $ putMVar done $ xs == expected

550− verifyClient "Expected nested channels to match expeted ordering" done

551−

552− -- Test that if no messages are (immediately) available, the scheduler makes no difference

553− testBlocked :: LocalNode -> Bool -> IO ()

554− testBlocked localNode biased = do

555− vs <- replicateM 3 newEmptyMVar

556− done <- newEmptyMVar

557−

558− forkProcess localNode $ do

559− ss <- liftIO $ mapM readMVar vs

560− case ss of

561− [sa, sb, sc] ->

562− mapM_ ((>> pause 10000) . uncurry sendChan)

563− [ -- a, b, c

564− (sa, 'a')

565− , (sb, 'b')

566− , (sc, 'c')

567− -- a, c, b

568− , (sa, 'a')

569− , (sc, 'c')

570− , (sb, 'b')

571− -- b, a, c

572− , (sb, 'b')

573− , (sa, 'a')

574− , (sc, 'c')

575− -- b, c, a

576− , (sb, 'b')

577− , (sc, 'c')

578− , (sa, 'a')

579− -- c, a, b

580− , (sc, 'c')

581− , (sa, 'a')

582− , (sb, 'b')

583− -- c, b, a

584− , (sc, 'c')

585− , (sb, 'b')

586− , (sa, 'a')

587− ]

588− _ -> die "Something went horribly wrong"

589−

590− forkProcess localNode $ do

591− (ss, rs) <- unzip <$> replicateM 3 newChan

592− liftIO $ mapM_ (uncurry putMVar) $ zip vs ss

593− m <- mergePorts biased rs

594− xs <- replicateM (6 * 3) $ receiveChan m

595− liftIO $ putMVar done $ xs == "abcacbbacbcacabcba"

596−

597− verifyClient "Expected merged ports to match expected ordering" done

598−

599− mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)

600− mergePorts True = mergePortsBiased

601− mergePorts False = mergePortsRR

602−

603− charChannel :: Char -> Process (ReceivePort Char)

604− charChannel c = do

605− (sport, rport) <- newChan

606− replicateM_ 3 $ sendChan sport c

607− liftIO $ threadDelay 10000 -- Make sure messages have been sent

608− return rport

609−

610−testTerminate :: TestTransport -> Assertion

611−testTerminate TestTransport{..} = do

612− localNode <- newLocalNode testTransport initRemoteTable

613− runProcess localNode $ do

614− e <- try terminate :: Process (Either ProcessTerminationException ())

615− if either show show e == show ProcessTerminationException

616− then return ()

617− else die "Unexpected result from terminate"

618−

619−testMonitorNode :: TestTransport -> Assertion

620−testMonitorNode TestTransport{..} = do

621− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable

622− done <- newEmptyMVar

623−

624− closeLocalNode node1

625−

626− runProcess node2 $ do

627− ref <- monitorNode (localNodeId node1)

628− receiveWait [

629− match (\(NodeMonitorNotification ref' nid DiedDisconnect) ->

630− return $ ref == ref' && nid == localNodeId node1)

631− ] >>= liftIO . putMVar done

632−

633− verifyClient "Expected NodeMonitorNotification with matching ref & nodeId" done

634−

635−testMonitorLiveNode :: TestTransport -> Assertion

636−testMonitorLiveNode TestTransport{..} = do

637− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable

638− ready <- newEmptyMVar

639− readyr <- newEmptyMVar

640− done <- newEmptyMVar

641−

642− p <- forkProcess node1 $ return ()

643− forkProcess node2 $ do

644− ref <- monitorNode (localNodeId node1)

645− liftIO $ putMVar ready ()

646− liftIO $ takeMVar readyr

647− send p ()

648− receiveWait [

649− match (\(NodeMonitorNotification ref' nid _) ->

650− (return $ ref == ref' && nid == localNodeId node1))

651− ] >>= liftIO . putMVar done

652−

653− takeMVar ready

654− closeLocalNode node1

655− putMVar readyr ()

656−

657− verifyClient "Expected NodeMonitorNotification for LIVE node" done

658−

659−testMonitorChannel :: TestTransport -> Assertion

660−testMonitorChannel TestTransport{..} = do

661− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable

662− gotNotification <- newEmptyMVar

663−

664− pid <- forkProcess node1 $ do

665− sport <- expect :: Process (SendPort ())

666− ref <- monitorPort sport

667− receiveWait [

668− -- reason might be DiedUnknownId if the receive port is GCed before the

669− -- monitor is established (TODO: not sure that this is reasonable)

670− match (\(PortMonitorNotification ref' port' reason) ->

671− return $ ref' == ref && port' == sendPortId sport &&

672− (reason == DiedNormal || reason == DiedUnknownId))

673− ] >>= liftIO . putMVar gotNotification

674−

675− runProcess node2 $ do

676− (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())

677− send pid sport

678− liftIO $ threadDelay 100000

679−

680− verifyClient "Expected PortMonitorNotification" gotNotification

681−

682−testRegistry :: TestTransport -> Assertion

683−testRegistry TestTransport{..} = do

684− node <- newLocalNode testTransport initRemoteTable

685− done <- newEmptyMVar

686−

687− pingServer <- forkProcess node ping

688− deadProcess <- forkProcess node (return ())

689−

690− runProcess node $ do

691− register "ping" pingServer

692− whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)

693− us <- getSelfPid

694− nsend "ping" (Pong us)

695− receiveWait [

696− matchIf (\(Ping pid') -> pingServer == pid') (const $ return ())

697− ]

698− checkRegException "dead" Nothing deadProcess

699− checkRegException "ping" (Just pingServer) deadProcess

700− try (unregister "dead") >>= checkReg "dead" Nothing

701− liftIO $ putMVar done ()

702−

703− takeMVar done

704−

705− where

706− checkRegException name pid dead =

707− try (register name dead) >>= checkReg name pid

708−

709− checkReg name pid res =

710− case res of

711− Left (ProcessRegistrationException name pid) -> return ()

712− _ -> die $ "Unexpected Registration" ++ show res

713−

714−testRegistryRemoteProcess :: TestTransport -> Assertion

715−testRegistryRemoteProcess TestTransport{..} = do

716− node1 <- newLocalNode testTransport initRemoteTable

717− node2 <- newLocalNode testTransport initRemoteTable

718− done <- newEmptyMVar

719−

720− pingServer <- forkProcess node1 ping

721−

722− runProcess node2 $ do

723− register "ping" pingServer

724− whereis "ping" >>= liftIO . assertBool "Unexpected ping" . (== Just pingServer)

725− us <- getSelfPid

726− nsend "ping" (Pong us)

727− receiveWait [

728− matchIf (\(Ping pid') -> pingServer == pid')

729− (const $ liftIO $ putMVar done ())

730− ]

731−

732− takeMVar done

733−

734−testRemoteRegistry :: TestTransport -> Assertion

735−testRemoteRegistry TestTransport{..} = do

736− node1 <- newLocalNode testTransport initRemoteTable

737− node2 <- newLocalNode testTransport initRemoteTable

738−

739− pingServer <- forkProcess node1 ping

740− deadProcess <- forkProcess node1 (return ())

741−

742− runProcess node2 $ do

743− let nid1 = localNodeId node1

744− registerRemoteAsync nid1 "ping" pingServer

745− receiveWait [

746− matchIf (\(RegisterReply label' _ (Just pid)) ->

747− "ping" == label' && pid == pingServer)

748− (\(RegisterReply _ _ _) -> return ()) ]

749−

750− pid <- verifyWhereIsRemote nid1 "ping"

751− liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid

752−

753− us <- getSelfPid

754− nsendRemote nid1 "ping" (Pong us)

755− receiveWait [

756− match (\(Ping pid') -> return $ pingServer == pid')

757− ] >>= liftIO . assertBool "Expected Ping with ping server's ProcessId"

758−

759− -- test that if process was not registered Nothing is returned

760− -- in owner field.

761− registerRemoteAsync nid1 "dead" deadProcess

762− receiveWait [ matchIf (\(RegisterReply label' f mPid) -> "dead" == label')

763− (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))

764− ] >>= liftIO . assertBool "Expected False Nothing in RegisterReply"

765−

766− registerRemoteAsync nid1 "ping" deadProcess

767− receiveWait [

768− matchIf (\(RegisterReply label' False mPid) ->

769− "ping" == label' && isJust mPid)

770− (\(RegisterReply _ f (Just pid'')) -> return (not f && pid'' == pingServer))

771− ] >>= liftIO . assertBool "Expected False and (Just alreadyRegisteredPid) in RegisterReply"

772−

773− unregisterRemoteAsync nid1 "dead"

774− receiveWait [

775− matchIf (\(RegisterReply label' _ _) -> "dead" == label')

776− (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))

777− ] >>= liftIO . assertBool "Expected False and Nothing in RegisterReply"

778−

779−testRemoteRegistryRemoteProcess :: TestTransport -> Assertion

780−testRemoteRegistryRemoteProcess TestTransport{..} = do

781− node1 <- newLocalNode testTransport initRemoteTable

782− node2 <- newLocalNode testTransport initRemoteTable

783− done <- newEmptyMVar

784−

785− pingServer <- forkProcess node2 ping

786−

787− runProcess node2 $ do

788− let nid1 = localNodeId node1

789− registerRemoteAsync nid1 "ping" pingServer

790− receiveWait [

791− matchIf (\(RegisterReply label' _ _) -> "ping" == label')

792− (\(RegisterReply _ _ _) -> return ()) ]

793− pid <- verifyWhereIsRemote nid1 "ping"

794− liftIO $ assertBool "Expected pingServer to match remote name" $ pingServer == pid

795− us <- getSelfPid

796− nsendRemote nid1 "ping" (Pong us)

797− receiveWait [

798− match (\(Ping pid') -> return $ pingServer == pid')

799− ] >>= liftIO . putMVar done

800−

801− verifyClient "Expected Ping with ping server's ProcessId" done

802−

803−testSpawnLocal :: TestTransport -> Assertion

804−testSpawnLocal TestTransport{..} = do

805− node <- newLocalNode testTransport initRemoteTable

806− done <- newEmptyMVar

807−

808− runProcess node $ do

809− us <- getSelfPid

810−

811− pid <- spawnLocal $ do

812− sport <- expect

813− sendChan sport (1234 :: Int)

814−

815− sport <- spawnChannelLocal $

816− \rport -> (receiveChan rport :: Process Int) >>= send us

817−

818− send pid sport

819− expect >>= liftIO . putMVar done

820−

821− res <- takeMVar done

822− assertBool "Expected 1234 :: Int" $ res == (1234 :: Int)

823−

824−testSpawnAsyncStrictness :: TestTransport -> Assertion

825−testSpawnAsyncStrictness TestTransport{..} = do

826− node <- newLocalNode testTransport initRemoteTable

827− done <- newEmptyMVar

828−

829− runProcess node $ do

830− here <-getSelfNode

831−

832− ev <- try $ spawnAsync here (error "boom")

833− liftIO $ case ev of

834− Right _ -> putMVar done (error "Exception didn't fire")

835− Left (_::SomeException) -> putMVar done (return ())

836−

837− join $ takeMVar done

838−

839−testReconnect :: TestTransport -> Assertion

840−testReconnect TestTransport{..} = do

841− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable

842− let nid1 = localNodeId node1

843− processA <- newEmptyMVar

844− [sendTestOk, registerTestOk] <- replicateM 2 newEmptyMVar

845−

846− forkProcess node1 $ do

847− us <- getSelfPid

848− liftIO $ putMVar processA us

849− msg1 <- expect

850− msg2 <- expect

851− liftIO $ do

852− assertBool "messages did not match" $ msg1 == "message 1" && msg2 == "message 3"

853− putMVar sendTestOk ()

854−

855− forkProcess node2 $ do

856− {-

857− - Make sure there is no implicit reconnect on normal message sending

858− -}

859−

860− them <- liftIO $ readMVar processA

861− send them "message 1" >> liftIO (threadDelay 100000)

862−

863− -- Simulate network failure

864− liftIO $ syncBreakConnection testBreakConnection node1 node2

865−

866−

867− -- Should not arrive

868− send them "message 2"

869−

870− -- Should arrive

871− reconnect them

872− send them "message 3"

873−

874− liftIO $ takeMVar sendTestOk

875−

876− {-

877− - Test that there *is* implicit reconnect on node controller messages

878− -}

879−

880− us <- getSelfPid

881− registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous

882− receiveWait [

883− matchIf (\(RegisterReply label' _ _) -> "a" == label')

884− (\(RegisterReply _ _ _) -> return ()) ]

885−

886− _ <- whereisRemote nid1 "a"

887−

888−

889− -- Simulate network failure

890− liftIO $ syncBreakConnection testBreakConnection node1 node2

891−

892− -- This will happen due to implicit reconnect

893− registerRemoteAsync nid1 "b" us

894− receiveWait [

895− matchIf (\(RegisterReply label' _ _) -> "b" == label')

896− (\(RegisterReply _ _ _) -> return ()) ]

897−

898− -- Should happen

899− registerRemoteAsync nid1 "c" us

900− receiveWait [

901− matchIf (\(RegisterReply label' _ _) -> "c" == label')

902− (\(RegisterReply _ _ _) -> return ()) ]

903−

904− -- Check

905− mPid <- whereisRemote nid1 "a" -- this will fail because the name is removed when the node is disconnected

906− liftIO $ assertBool "Expected remote name to be lost" $ mPid == Nothing

907− verifyWhereIsRemote nid1 "b" -- this will suceed because the value is set after thereconnect

908− verifyWhereIsRemote nid1 "c"

909−

910− liftIO $ putMVar registerTestOk ()

911−

912− takeMVar registerTestOk

913−

914−-- | Tests that unreliable messages arrive sorted even when there are connection

915−-- failures.

916−testUSend :: (ProcessId -> Int -> Process ())

917− -> TestTransport -> Int -> Assertion

918−testUSend usendPrim TestTransport{..} numMessages = do

919− [node1, node2] <- replicateM 2 $ newLocalNode testTransport initRemoteTable

920− let nid1 = localNodeId node1

921− nid2 = localNodeId node2

922− processA <- newEmptyMVar

923− usendTestOk <- newEmptyMVar

924−

925− forkProcess node1 $ flip catch (\e -> liftIO $ print (e :: SomeException) ) $ do

926− us <- getSelfPid

927− liftIO $ putMVar processA us

928− them <- expect

929− send them ()

930− _ <- monitor them

931− let -- Collects messages from 'them' until the sender dies.

932− -- Disconnection notifications are ignored.

933− receiveMessages :: Process [Int]

934− receiveMessages = receiveWait

935− [ match $ \mn -> case mn of

936− ProcessMonitorNotification _ _ DiedDisconnect -> do

937− monitor them

938− receiveMessages

939− _ -> return []

940− , match $ \i -> fmap (i :) receiveMessages

941− ]

942− msgs <- receiveMessages

943− let -- Checks that the input list is sorted.

944− isSorted :: [Int] -> Bool

945− isSorted (x : xs@(y : _)) = x <= y && isSorted xs

946− isSorted _ = True

947− -- The list can't be null since there are no failures after sending

948− -- the last message.

949− liftIO $ putMVar usendTestOk $ isSorted msgs && not (null msgs)

950−

951− forkProcess node2 $ do

952− them <- liftIO $ readMVar processA

953− getSelfPid >>= send them

954− expect :: Process ()

955− forM_ [1..numMessages] $ \i -> do

956− liftIO $ testBreakConnection (nodeAddress nid1) (nodeAddress nid2)

957− usendPrim them i

958− liftIO (threadDelay 30000)

959−

960− res <- takeMVar usendTestOk

961− assertBool "Unexpected failure after sending last msg" res

962−

963−-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server

964−-- in between

965−testMatchAny :: TestTransport -> Assertion

966−testMatchAny TestTransport{..} = do

967− proxyAddr <- newEmptyMVar

968− clientDone <- newEmptyMVar

969−

970− -- Math server

971− forkIO $ do

972− localNode <- newLocalNode testTransport initRemoteTable

973− mathServer <- forkProcess localNode math

974− proxyServer <- forkProcess localNode $ forever $ do

975− msg <- receiveWait [ matchAny return ]

976− forward msg mathServer

977− putMVar proxyAddr proxyServer

978−

979− -- Client

980− forkIO $ do

981− localNode <- newLocalNode testTransport initRemoteTable

982− mathServer <- readMVar proxyAddr

983−

984− runProcess localNode $ do

985− pid <- getSelfPid

986− send mathServer (Add pid 1 2)

987− three <- expect :: Process Double

988− send mathServer (Divide pid 8 2)

989− four <- expect :: Process Double

990− send mathServer (Divide pid 8 0)

991− divByZ <- expect

992− liftIO $ putMVar clientDone (three, four, divByZ)

993−

994− res <- takeMVar clientDone

995− case res of

996− (3, 4, DivByZero) -> return ()

997− _ -> error "Unexpected result"

998−

999−-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server

1000−-- in between, however we block 'Divide' requests ....

1001−testMatchAnyHandle :: TestTransport -> Assertion

1002−testMatchAnyHandle TestTransport{..} = do

1003− proxyAddr <- newEmptyMVar

1004− clientDone <- newEmptyMVar

1005−

1006− -- Math server

1007− forkIO $ do

1008− localNode <- newLocalNode testTransport initRemoteTable

1009− mathServer <- forkProcess localNode math

1010− proxyServer <- forkProcess localNode $ forever $ do

1011− receiveWait [

1012− matchAny (maybeForward mathServer)

1013− ]

1014− putMVar proxyAddr proxyServer

1015−

1016− -- Client

1017− forkIO $ do

1018− localNode <- newLocalNode testTransport initRemoteTable

1019− mathServer <- readMVar proxyAddr

1020−

1021− runProcess localNode $ do

1022− pid <- getSelfPid

1023− send mathServer (Add pid 1 2)

1024− three <- expect :: Process Double

1025− send mathServer (Divide pid 8 2)

1026− res <- (expectTimeout 100000) :: Process (Maybe Double)

1027− liftIO $ putMVar clientDone $ three == 3 && res == Nothing

1028−

1029− verifyClient "Expected Nothing (i.e. timeout)" clientDone

1030−

1031− where maybeForward :: ProcessId -> Message -> Process (Maybe ())

1032− maybeForward s msg =

1033− handleMessage msg (\m@(Add _ _ _) -> send s m)

1034−

1035−testMatchAnyNoHandle :: TestTransport -> Assertion

1036−testMatchAnyNoHandle TestTransport{..} = do

1037− addr <- newEmptyMVar

1038− clientDone <- newEmptyMVar

1039− serverDone <- newEmptyMVar

1040−

1041− -- Math server

1042− forkIO $ do

1043− localNode <- newLocalNode testTransport initRemoteTable

1044− server <- forkProcess localNode $ forever $ do

1045− receiveWait [

1046− matchAnyIf

1047− -- the condition has type `Add -> Bool`

1048− (\(Add _ _ _) -> True)

1049− -- the match `AbstractMessage -> Process ()` will succeed!

1050− (\m -> do

1051− -- `String -> Process ()` does *not* match the input types however

1052− r <- (handleMessage m (\(_ :: String) -> die "NONSENSE" ))

1053− case r of

1054− Nothing -> return ()

1055− Just _ -> die "NONSENSE")

1056− ]

1057− -- we *must* have removed the message from our mailbox though!!!

1058− res <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]

1059− liftIO $ do

1060− assertBool "Expected timeout!" $ res == Nothing

1061− putMVar serverDone ()

1062− putMVar addr server

1063−

1064− -- Client

1065− forkIO $ do

1066− localNode <- newLocalNode testTransport initRemoteTable

1067− server <- readMVar addr

1068−

1069− runProcess localNode $ do

1070− pid <- getSelfPid

1071− send server (Add pid 1 2)

1072− -- we only care about the client having sent a message, so we're done

1073− liftIO $ putMVar clientDone ()

1074−

1075− takeMVar clientDone

1076− takeMVar serverDone

1077−

1078−-- | Test 'matchAnyIf'. We provide an /echo/ server, but it ignores requests

1079−-- unless the text body @/= "bar"@ - this case should time out rather than

1080−-- removing the message from the process mailbox.

1081−testMatchAnyIf :: TestTransport -> Assertion

1082−testMatchAnyIf TestTransport{..} = do

1083− echoAddr <- newEmptyMVar

1084− clientDone <- newEmptyMVar

1085−

1086− -- echo server

1087− forkIO $ do

1088− localNode <- newLocalNode testTransport initRemoteTable

1089− echoServer <- forkProcess localNode $ forever $ do

1090− receiveWait [

1091− matchAnyIf (\(_ :: ProcessId, (s :: String)) -> s /= "bar")

1092− tryHandleMessage

1093− ]

1094− putMVar echoAddr echoServer

1095−

1096− -- Client

1097− forkIO $ do

1098− localNode <- newLocalNode testTransport initRemoteTable

1099− server <- readMVar echoAddr

1100−

1101− runProcess localNode $ do

1102− pid <- getSelfPid

1103− send server (pid, "foo")

1104− foo <- expect

1105− -- provoking what would be the wrong ordering is informative here...

1106−

1107− send server (pid, "bar")

1108− bar <- (expectTimeout 100000) :: Process (Maybe String) -- was Double o_O !?

1109−

1110− send server (pid, "baz")

1111− baz <- expect

1112−

1113− liftIO $ putMVar clientDone (foo, bar, baz)

1114−

1115− res <- takeMVar clientDone

1116− let res' = res == ("foo", Nothing, "baz")

1117− assertBool "Expected timeout due to type mismatch" res'

1118−

1119− where tryHandleMessage :: Message -> Process (Maybe ())

1120− tryHandleMessage msg =

1121− handleMessage msg (\(pid :: ProcessId, (m :: String))

1122− -> do { send pid m; return () })

1123−

1124−testMatchMessageWithUnwrap :: TestTransport -> Assertion

1125−testMatchMessageWithUnwrap TestTransport{..} = do

1126− echoAddr <- newEmptyMVar

1127− clientDone <- newEmptyMVar

1128−

1129− -- echo server

1130− forkIO $ do

1131− localNode <- newLocalNode testTransport initRemoteTable

1132− echoServer <- forkProcess localNode $ forever $ do

1133− msg <- receiveWait [

1134− matchMessage (\(m :: Message) -> do

1135− return m)

1136− ]

1137− unwrapped <- unwrapMessage msg :: Process (Maybe (ProcessId, Message))

1138− case unwrapped of

1139− (Just (p, msg')) -> forward msg' p

1140− Nothing -> die "unable to unwrap the message"

1141− putMVar echoAddr echoServer

1142−

1143− -- Client

1144− forkIO $ do

1145− localNode <- newLocalNode testTransport initRemoteTable

1146− server <- readMVar echoAddr

1147−

1148− runProcess localNode $ do

1149− pid <- getSelfPid

1150− send server (pid, wrapMessage ("foo" :: String))

1151− foo <- expect

1152− send server (pid, wrapMessage ("baz" :: String))

1153− baz <- expect

1154− liftIO $ putMVar clientDone (foo, baz)

1155−

1156− res <- takeMVar clientDone

1157− assertBool "Unexpected unwrapped results" $ res == ("foo", "baz")

1158−

1159−-- Test 'receiveChanTimeout'

1160−testReceiveChanTimeout :: TestTransport -> Assertion

1161−testReceiveChanTimeout TestTransport{..} = do

1162− done <- newEmptyMVar

1163− mvSender <- newEmptyMVar

1164− sendPort <- newEmptyMVar

1165−

1166− forkTry $ do

1167− localNode <- newLocalNode testTransport initRemoteTable

1168− runProcess localNode $ do

1169− -- Create a typed channel

1170− (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)

1171− liftIO $ putMVar sendPort sp

1172−

1173− -- Wait for a message with a delay. No message arrives, we should get

1174− -- Nothing after the delay.

1175− receiveChanTimeout 100000 rp >>= maybe (return ()) (const $ die "Expected Timeout")

1176−

1177− -- Let the sender know that it can send a message.

1178− liftIO $ putMVar mvSender ()

1179−

1180− -- Wait for a message with a delay again. Now a message arrives after

1181− -- 0.1 seconds

1182− res <- receiveChanTimeout 20000000 rp >>= maybe (die "Timeout") return

1183− liftIO $ assertBool "Expected result to be 'True'" res

1184−

1185− -- Wait for a message with zero timeout: non-blocking check. No message is

1186− -- available, we get Nothing

1187− receiveChanTimeout 0 rp >>= maybe (return ()) (const $ die "Expected Timeout")

1188−

1189− -- Let the sender know that it can send a message.

1190− liftIO $ putMVar mvSender ()

1191−

1192− -- Again, but now there is a message available

1193− fix $ \loop -> do

1194− liftIO $ threadDelay 100000

1195− mb <- receiveChanTimeout 0 rp

1196− case mb of

1197− Just b -> do liftIO $ assertBool "Unexpected Message" $ not b

1198− _ -> loop

1199−

1200− liftIO $ putMVar done ()

1201−

1202− forkTry $ do

1203− localNode <- newLocalNode testTransport initRemoteTable

1204− runProcess localNode $ do

1205− sp <- liftIO $ readMVar sendPort

1206−

1207− liftIO $ takeMVar mvSender

1208− liftIO $ threadDelay 100000

1209− sendChan sp True

1210−

1211− liftIO $ takeMVar mvSender

1212− sendChan sp False

1213−

1214− takeMVar done

1215−

1216−-- | Test Functor, Applicative, Alternative and Monad instances for ReceiveChan

1217−testReceiveChanFeatures :: TestTransport -> Assertion

1218−testReceiveChanFeatures TestTransport{..} = do

1219− done <- newEmptyMVar

1220−

1221− forkTry $ do

1222− localNode <- newLocalNode testTransport initRemoteTable

1223− runProcess localNode $ do

1224− (spInt, rpInt) <- newChan :: Process (SendPort Int, ReceivePort Int)

1225− (spBool, rpBool) <- newChan :: Process (SendPort Bool, ReceivePort Bool)

1226−

1227− -- Test Functor instance

1228−

1229− sendChan spInt 2

1230− sendChan spBool False

1231−

1232− rp1 <- mergePortsBiased [even <$> rpInt, rpBool]

1233−

1234− receiveChan rp1 >>= liftIO . assertBool "Expected True"

1235− receiveChan rp1 >>= liftIO . assertBool "Expected False" . not

1236−

1237− -- Test Applicative instance

1238−

1239− sendChan spInt 3

1240− sendChan spInt 4

1241−

1242− let rp2 = pure (+) <*> rpInt <*> rpInt

1243−

1244− receiveChan rp2 >>= liftIO . assertBool "Expected 7" . (== 7)

1245−

1246− -- Test Alternative instance

1247−

1248− sendChan spInt 3

1249− sendChan spBool True

1250−

1251− let rp3 = (even <$> rpInt) <|> rpBool

1252−

1253− receiveChan rp3 >>= liftIO . assertBool "Expected False" . not

1254− receiveChan rp3 >>= liftIO . assertBool "Expected True"

1255−

1256− -- Test Monad instance

1257−

1258− sendChan spBool True

1259− sendChan spBool False

1260− sendChan spInt 5

1261−

1262− let rp4 :: ReceivePort Int

1263− rp4 = do b <- rpBool

1264− if b

1265− then rpInt

1266− else return 7

1267−

1268− receiveChan rp4 >>= liftIO . assertBool "Expected 5" . (== 5)

1269− receiveChan rp4 >>= liftIO . assertBool "Expected 7" . (== 7)

1270−

1271− liftIO $ putMVar done ()

1272−

1273− takeMVar done

1274−

1275−testChanLifecycle :: TestTransport -> Assertion

1276−testChanLifecycle TestTransport{..} = let delay = 3000000 in do

1277− result <- newEmptyMVar

1278− tchMV <- newEmptyMVar

1279− localNode <- newLocalNode testTransport initRemoteTable

1280− runProcess localNode $ do

1281−

1282− pid <- spawnLocal $ do tCh <- newChan :: Process (SendPort (), ReceivePort ())

1283− liftIO $ putMVar tchMV tCh

1284− expect :: Process ()

1285− let (sp, _) = tCh

1286− sendChan sp ()

1287− expect :: Process ()

1288−

1289− mRefPid <- monitor pid

1290−

1291− cPid <- spawnLocal $ do

1292− (sp', rp) <- liftIO $ takeMVar tchMV

1293− -- say "picked up our test channel"

1294− send pid ()

1295− -- say "told pid to continue"

1296− res <- receiveChanTimeout delay rp

1297− case res of

1298− Nothing -> say "initial chan () missing!" >> (liftIO $ putMVar result False)

1299− Just () -> do mr <- monitor pid

1300− pause 10000

1301− -- say "sending pid a second () will cause it to exit"

1302− send pid ()

1303−

1304− -- say "make sure we see a DOWN notification for pid having stopped"

1305− receiveWait [ match (\(_ :: ProcessMonitorNotification) -> return ()) ]

1306−

1307− -- now that pid has died, the send port should be useless...

1308− liftIO $ putMVar tchMV (sp', rp)

1309−

1310− -- let's verify that we do not see the message from our

1311− -- parent process on the channel, once pid has died...

1312− recv <- receiveChanTimeout delay rp

1313− -- say $ "finished waiting for second (), writing result" ++ (show recv)

1314− liftIO $ putMVar result $ isNothing recv

1315−

1316− mRefCPid <- monitor cPid

1317−

1318− receiveWait

1319− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefPid)

1320− (\_ -> return ())

1321− ]

1322−

1323− -- say "seen first pid die..."

1324−

1325− (sendPort, _) <- liftIO $ takeMVar tchMV

1326− sendChan sendPort ()

1327− -- say "sent () after owning pid died"

1328−

1329− -- let cPid know we've written to the channel...

1330− send cPid ()

1331−

1332− receiveWait

1333− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefCPid)

1334− (\_ -> return ())

1335− ]

1336−

1337− -- say "seen both pids die now..."

1338−

1339− -- and wait on the result back in IO land...

1340− testRes <- takeMVar result

1341− -- runProcess localNode $ say "got result..."

1342− assertBool "Expected sending on the channel to fail, but received data!" testRes

1343−

1344−

1345−testKillLocal :: TestTransport -> Assertion

1346−testKillLocal TestTransport{..} = do

1347− localNode <- newLocalNode testTransport initRemoteTable

1348−

1349− pid <- forkProcess localNode $ do

1350− liftIO $ threadDelay 1000000

1351−

1352− runProcess localNode $ do

1353− ref <- monitor pid

1354− us <- getSelfPid

1355− kill pid "TestKill"

1356− mn <- expect

1357− case mn of

1358− ProcessMonitorNotification ref' pid' (DiedException ex) ->

1359− case ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill" of

1360− True -> return ()

1361− False -> die "Invalid ProcessMonitorNotification received"

1362− _ -> die "Something went horribly wrong"

1363−

1364−testKillRemote :: TestTransport -> Assertion

1365−testKillRemote TestTransport{..} = do

1366− node1 <- newLocalNode testTransport initRemoteTable

1367− node2 <- newLocalNode testTransport initRemoteTable

1368−

1369− pid <- forkProcess node1 $ do

1370− liftIO $ threadDelay 1000000

1371−

1372− runProcess node2 $ do

1373− ref <- monitor pid

1374− us <- getSelfPid

1375− kill pid "TestKill"

1376− mn <- expect

1377− case mn of

1378− ProcessMonitorNotification ref' pid' (DiedException reason) ->

1379− case (ref == ref', pid == pid', reason == "killed-by=" ++ show us ++ ",reason=TestKill") of

1380− (True, True, True) -> return ()

1381− (a, b, c) -> do

1382− let a' = if a then "" else "Invalid ref"

1383− let b' = if b then "" else "Invalid pid"

1384− let c' = if c then "" else "Invalid message"

1385− die $ unwords [a', b', c']

1386− _ -> die "Received unexpected message"

1387−

1388−testCatchesExit :: TestTransport -> Assertion

1389−testCatchesExit TestTransport{..} = do

1390− localNode <- newLocalNode testTransport initRemoteTable

1391− done <- newEmptyMVar

1392−

1393− _ <- forkProcess localNode $ do

1394− (die ("foobar", 123 :: Int))

1395− `catchesExit` [

1396− (\_ m -> handleMessage m (\(_ :: String) -> return ()))

1397− , (\_ m -> handleMessage m (\(_ :: Maybe Int) -> return ()))

1398− , (\_ m -> handleMessage m (\(_ :: String, _ :: Int)

1399− -> (liftIO $ putMVar done ()) >> return ()))

1400− ]

1401−

1402− takeMVar done

1403−

1404−testHandleMessageIf :: TestTransport -> Assertion

1405−testHandleMessageIf TestTransport{..} = do

1406− localNode <- newLocalNode testTransport initRemoteTable

1407− done <- newEmptyMVar

1408− _ <- forkProcess localNode $ do

1409− self <- getSelfPid

1410− send self (5 :: Integer, 10 :: Integer)

1411− msg <- receiveWait [ matchMessage return ]

1412− handleMessageIf msg

1413− (\() -> True)

1414− (\() -> die "whoops") >>= maybe (return ())

1415− (const $ die "Expected Mismatch")

1416− handleMessageIf msg (\(x :: Integer, y :: Integer) -> x == 5 && y == 10)

1417− (\input -> liftIO $ putMVar done input)

1418− return ()

1419−

1420− result <- takeMVar done

1421− expectThat result $ equalTo (5, 10)

1422−

1423−testCatches :: TestTransport -> Assertion

1424−testCatches TestTransport{..} = do

1425− localNode <- newLocalNode testTransport initRemoteTable

1426− done <- newEmptyMVar

1427−

1428− _ <- forkProcess localNode $ do

1429− node <- getSelfNode

1430− (liftIO $ throwIO (ProcessLinkException (nullProcessId node) DiedNormal))

1431− `catches` [

1432− Handler (\(ProcessLinkException _ _) -> liftIO $ putMVar done ())

1433− ]

1434−

1435− takeMVar done

1436−

1437−testMaskRestoreScope :: TestTransport -> Assertion

1438−testMaskRestoreScope TestTransport{..} = do

1439− localNode <- newLocalNode testTransport initRemoteTable

1440− parentPid <- newEmptyMVar :: IO (MVar ProcessId)

1441− spawnedPid <- newEmptyMVar :: IO (MVar ProcessId)

1442−

1443− void $ runProcess localNode $ mask $ \unmask -> do

1444− getSelfPid >>= liftIO . putMVar parentPid

1445− void $ spawnLocal $ unmask (getSelfPid >>= liftIO . putMVar spawnedPid)

1446−

1447− parent <- liftIO $ takeMVar parentPid

1448− child <- liftIO $ takeMVar spawnedPid

1449− expectThat parent $ isNot $ equalTo child

1450−

1451−testDie :: TestTransport -> Assertion

1452−testDie TestTransport{..} = do

1453− localNode <- newLocalNode testTransport initRemoteTable

1454− done <- newEmptyMVar

1455−

1456− _ <- forkProcess localNode $ do

1457− (die ("foobar", 123 :: Int))

1458− `catchExit` \_from reason -> do

1459− -- TODO: should verify that 'from' has the right value

1460− let res = reason == ("foobar", 123 :: Int)

1461− liftIO $ putMVar done ()

1462− if res

1463− then return ()

1464− else die "Something went horribly wrong"

1465−

1466− takeMVar done

1467−

1468−testPrettyExit :: TestTransport -> Assertion

1469−testPrettyExit TestTransport{..} = do

1470− localNode <- newLocalNode testTransport initRemoteTable

1471− done <- newEmptyMVar

1472−

1473− _ <- forkProcess localNode $ do

1474− (die "timeout")

1475− `catch` \ex@(ProcessExitException from _) ->

1476− let expected = "exit-from=" ++ (show from)

1477− in do

1478− let res = (show ex) == expected

1479− liftIO $ putMVar done ()

1480− if res

1481− then return ()

1482− else die "Something went horribly wrong"

1483−

1484− takeMVar done

1485−

1486−testExitLocal :: TestTransport -> Assertion

1487−testExitLocal TestTransport{..} = do

1488− localNode <- newLocalNode testTransport initRemoteTable

1489− supervisedDone <- newEmptyMVar

1490− supervisorDone <- newEmptyMVar

1491− -- XXX: we guarantee that exception handler will be set up

1492− -- regardless if forkProcess preserve masking state or not.

1493− handlerSetUp <- newEmptyMVar

1494−

1495− pid <- forkProcess localNode $ do

1496− (liftIO (putMVar handlerSetUp ()) >> expect) `catchExit` \_from reason -> do

1497− -- TODO: should verify that 'from' has the right value

1498− res <- return $ reason == "TestExit"

1499− liftIO $ putMVar supervisedDone ()

1500− if res

1501− then return ()

1502− else die "Something went horribly wrong"

1503−

1504− runProcess localNode $ do

1505− liftIO $ takeMVar handlerSetUp

1506− ref <- monitor pid

1507− exit pid "TestExit"

1508− -- This time the client catches the exception, so it dies normally

1509− mn <- expect

1510− case mn of

1511− ProcessMonitorNotification ref' pid' DiedNormal -> do

1512− let res = ref == ref' && pid == pid'

1513− liftIO $ putMVar supervisorDone ()

1514− if res

1515− then return ()

1516− else die "Something went horribly wrong"

1517− _ -> die "Something went horribly wrong"

1518−

1519− takeMVar supervisedDone

1520− takeMVar supervisorDone

1521−

1522−testExitRemote :: TestTransport -> Assertion

1523−testExitRemote TestTransport{..} = do

1524− node1 <- newLocalNode testTransport initRemoteTable

1525− node2 <- newLocalNode testTransport initRemoteTable

1526− supervisedDone <- newEmptyMVar

1527− supervisorDone <- newEmptyMVar

1528−

1529− pid <- forkProcess node1 $ do

1530− (receiveWait [] :: Process ()) -- block forever

1531− `catchExit` \_from reason -> do

1532− -- TODO: should verify that 'from' has the right value

1533− res <- return $ reason == "TestExit"

1534− liftIO $ putMVar supervisedDone ()

1535− if res

1536− then return ()

1537− else die "Something went horribly wrong"

1538−

1539− runProcess node2 $ do

1540− ref <- monitor pid

1541− exit pid "TestExit"

1542− mn <- expect

1543− case mn of

1544− ProcessMonitorNotification ref' pid' DiedNormal -> do

1545− res' <- return $ ref == ref' && pid == pid'

1546− liftIO $ putMVar supervisorDone ()

1547− if res'

1548− then return ()

1549− else die "Something went horribly wrong"

1550− _ -> die "Something went horribly wrong"

1551−

1552− takeMVar supervisedDone

1553− takeMVar supervisorDone

1554−

1555−testRegistryMonitoring :: TestTransport -> Assertion

1556−testRegistryMonitoring TestTransport{..} = do

1557− node1 <- newLocalNode testTransport initRemoteTable

1558− node2 <- newLocalNode testTransport initRemoteTable

1559−

1560− let nid = localNodeId node2

1561− pid <- forkProcess node1 $ do

1562− self <- getSelfPid

1563− runUntilRegistered nid self

1564− say $ (show self) ++ " registered as " ++ regName

1565− expect :: Process ()

1566− say $ (show self) ++ " exiting normally"

1567−

1568− runProcess node2 $ do

1569− register regName pid

1570− say $ regName ++ " registered to " ++ show pid

1571− res <- whereis regName

1572− send pid ()

1573− say $ " sent finish signal to " ++ show pid

1574− us <- getSelfPid

1575− liftIO $ assertBool "expected (Just pid)" $ res == (Just pid)

1576−

1577−

1578− -- This delay isn't essential!

1579− -- The test case passes perfectly fine without it (feel free to comment out

1580− -- and see), however waiting a few seconds here, makes it much more likely

1581− -- that in delayUntilMaybeUnregistered we will hit the match case right

1582− -- away, and thus not be subjected to a 20 second delay. The value of 4

1583− -- seconds appears to work optimally on osx and across several linux distros

1584− -- running in virtual machines (which is essentially what we do in CI)

1585− void $ receiveTimeout 4000000 [ matchAny return ]

1586−

1587− -- This delay doesn't serve much purpose in the happy path, however if some

1588− -- future patch breaks the cooperative behaviour of node controllers viz

1589− -- remote process registration and notification taking place via ncEffectDied,

1590− -- there would be the possibility of a race in the test case should we attempt

1591− -- to evaluate `whereis regName` on node2 right away. In case the name is still

1592− -- erroneously registered, observing the 20 second delay (or lack of), could at

1593− -- least give a hint that something is wrong, and we give up our time slice

1594− -- so that there's a higher change the registrations have been cleaned up

1595− -- in either case.

1596− runProcess node2 $ delayUntilMaybeUnregistered nid pid

1597−

1598− regHere <- newEmptyMVar

1599− runProcess node2 $ whereis regName >>= liftIO . putMVar regHere

1600− res <- takeMVar regHere

1601− case res of

1602− Nothing -> return ()

1603− Just pid -> assertBool ("expected Nothing, but got " ++ show pid) False

1604−

1605− where

1606− runUntilRegistered nid us = do

1607− whereisRemoteAsync nid regName

1608− receiveWait [

1609− matchIf (\(WhereIsReply n (Just p)) -> n == regName && p == us)

1610− (const $ return ())

1611− ]

1612−

1613− delayUntilMaybeUnregistered nid p = do

1614− whereisRemoteAsync nid regName

1615− res <- receiveTimeout 20000000 {- 20 sec delay -} [

1616− matchIf (\(WhereIsReply n p) -> n == regName && isNothing p)

1617− (const $ return ())

1618− ]

1619− case res of

1620− Just () -> return ()

1621− Nothing -> delayUntilMaybeUnregistered nid p

1622−

1623− regName = "testRegisterRemote"

1624−

1625−testUnsafeSend :: TestTransport -> Assertion

1626−testUnsafeSend TestTransport{..} = do

1627− serverAddr <- newEmptyMVar

1628− clientDone <- newEmptyMVar

1629−

1630− localNode <- newLocalNode testTransport initRemoteTable

1631− void $ forkProcess localNode $ do

1632− self <- getSelfPid

1633− liftIO $ putMVar serverAddr self

1634− clientAddr <- expect

1635− unsafeSend clientAddr ()

1636−

1637− void $ forkProcess localNode $ do

1638− serverPid <- liftIO $ takeMVar serverAddr

1639− getSelfPid >>= unsafeSend serverPid

1640− expect >>= liftIO . putMVar clientDone

1641−

1642− takeMVar clientDone

1643−

1644−testUnsafeUSend :: TestTransport -> Assertion

1645−testUnsafeUSend TestTransport{..} = do

1646− serverAddr <- newEmptyMVar

1647− clientDone <- newEmptyMVar

1648−

1649− localNode <- newLocalNode testTransport initRemoteTable

1650− void $ forkProcess localNode $ do

1651− self <- getSelfPid

1652− liftIO $ putMVar serverAddr self

1653− clientAddr <- expect

1654− unsafeUSend clientAddr ()

1655−

1656− void $ forkProcess localNode $ do

1657− serverPid <- liftIO $ takeMVar serverAddr

1658− getSelfPid >>= unsafeUSend serverPid

1659− expect >>= liftIO . putMVar clientDone

1660−

1661− takeMVar clientDone

1662−

1663−testUnsafeNSend :: TestTransport -> Assertion

1664−testUnsafeNSend TestTransport{..} = do

1665− clientDone <- newEmptyMVar

1666−

1667− localNode <- newLocalNode testTransport initRemoteTable

1668−

1669− pid <- forkProcess localNode $ do

1670− expect >>= liftIO . putMVar clientDone

1671−

1672− void $ runProcess localNode $ do

1673− register "foobar" pid

1674− unsafeNSend "foobar" ()

1675−

1676− takeMVar clientDone

1677−

1678−testUnsafeNSendRemote :: TestTransport -> Assertion

1679−testUnsafeNSendRemote TestTransport{..} = do

1680− clientDone <- newEmptyMVar

1681−

1682− localNode1 <- newLocalNode testTransport initRemoteTable

1683− localNode2 <- newLocalNode testTransport initRemoteTable

1684−

1685− _ <- forkProcess localNode1 $ do

1686− getSelfPid >>= register "foobar"

1687− liftIO $ putMVar clientDone ()

1688− expect >>= liftIO . putMVar clientDone

1689−

1690− takeMVar clientDone

1691− void $ runProcess localNode2 $ do

1692− unsafeNSendRemote (localNodeId localNode1) "foobar" ()

1693−

1694− takeMVar clientDone

1695−

1696−testUnsafeSendChan :: TestTransport -> Assertion

1697−testUnsafeSendChan TestTransport{..} = do

1698− serverAddr <- newEmptyMVar

1699− clientDone <- newEmptyMVar

1700−

1701− localNode <- newLocalNode testTransport initRemoteTable

1702− void $ forkProcess localNode $ do

1703− self <- getSelfPid

1704− liftIO $ putMVar serverAddr self

1705− sp <- expect

1706− unsafeSendChan sp ()

1707−

1708− void $ forkProcess localNode $ do

1709− serverPid <- liftIO $ takeMVar serverAddr

1710− (sp, rp) <- newChan

1711− unsafeSend serverPid sp

1712− receiveChan rp :: Process ()

1713− liftIO $ putMVar clientDone ()

1714−

1715− takeMVar clientDone

1716−

1717−testCallLocal :: TestTransport -> Assertion

1718−testCallLocal TestTransport{..} = do

1719− node <- newLocalNode testTransport initRemoteTable

1720−

1721− -- Testing that (/=) <$> getSelfPid <*> callLocal getSelfPid.

1722− result <- newEmptyMVar

1723− runProcess node $ do

1724− r <- (/=) <$> getSelfPid <*> callLocal getSelfPid

1725− liftIO $ putMVar result r

1726−

1727− takeMVar result >>= assertBool "Expected 'True'"

1728−

1729− -- Testing that when callLocal is interrupted, the worker is interrupted.

1730− ibox <- newIORef False

1731− runProcess node $ do

1732− keeper <- getSelfPid

1733− spawnLocal $ do

1734− caller <- getSelfPid

1735− send keeper caller

1736− onException

1737− (callLocal $ do

1738− onException (do send keeper caller

1739− expect)

1740− (do liftIO $ writeIORef ibox True))

1741− (send keeper ())

1742− caller <- expect

1743− exit caller "test"

1744− expect :: Process ()

1745−

1746− readIORef ibox >>= assertBool "Expected 'True'"

1747−

1748− -- Testing that when the worker raises an exception, the exception is propagated to the parent.

1749− ibox2 <- newIORef False

1750− runProcess node $ do

1751− r <- try (callLocal $ error "e" >> return ())

1752− liftIO $ writeIORef ibox2 $ case r of

1753− Left (ErrorCall "e") -> True

1754− _ -> False

1755−

1756− readIORef ibox >>= assertBool "Expected 'True'"

1757−

1758− -- Test that caller waits for the worker in correct situation

1759− ibox3 <- newIORef False

1760− result3 <- newEmptyMVar

1761− runProcess node $ do

1762− keeper <- getSelfPid

1763− spawnLocal $ do

1764− callLocal $

1765− (do us <- getSelfPid

1766− send keeper us

1767− () <- expect

1768− liftIO yield)

1769− `finally` (liftIO $ writeIORef ibox3 True)

1770− liftIO $ putMVar result3 =<< readIORef ibox3

1771− worker <- expect

1772− send worker ()

1773−

1774− takeMVar result3 >>= assertBool "Expected 'True'"

1775−

1776− -- Test that caller waits for the worker in case when caller gets an exception

1777− ibox4 <- newIORef False

1778− result4 <- newEmptyMVar

1779− runProcess node $ do

1780− keeper <- getSelfPid

1781− spawnLocal $ do

1782− caller <- getSelfPid

1783− callLocal

1784− ((do send keeper caller

1785− expect)

1786− `finally` (liftIO $ writeIORef ibox4 True))

1787− `finally` (liftIO $ putMVar result4 =<< readIORef ibox4)

1788− caller <- expect

1789− exit caller "hi!"

1790−

1791− takeMVar result4 >>= assertBool "Expected 'True'"

1792− -- XXX: Testing that when mask_ $ callLocal p runs p in masked state.

1793−

1794−tests :: TestTransport -> IO [Test]

1795−tests testtrans = return [

1796− testGroup "Basic features" [

1797− testCase "Ping" (testPing testtrans)

1798− , testCase "Math" (testMath testtrans)

1799− , testCase "Timeout" (testTimeout testtrans)

1800− , testCase "Timeout0" (testTimeout0 testtrans)

1801− , testCase "SendToTerminated" (testSendToTerminated testtrans)

1802− , testCase "TypedChannnels" (testTypedChannels testtrans)

1803− , testCase "Terminate" (testTerminate testtrans)

1804− , testCase "RegistryRemoteProcess" (testRegistryRemoteProcess testtrans)

1805− , testCase "RemoteRegistry" (testRemoteRegistry testtrans)

1806− , testCase "RemoteRegistryRemoteProcess" (testRemoteRegistryRemoteProcess testtrans)

1807− , testCase "SpawnLocal" (testSpawnLocal testtrans)

1808− , testCase "SpawnAsyncStrictness" (testSpawnAsyncStrictness testtrans)

1809− , testCase "HandleMessageIf" (testHandleMessageIf testtrans)

1810− , testCase "MatchAny" (testMatchAny testtrans)

1811− , testCase "MatchAnyHandle" (testMatchAnyHandle testtrans)

1812− , testCase "MatchAnyNoHandle" (testMatchAnyNoHandle testtrans)

1813− , testCase "MatchAnyIf" (testMatchAnyIf testtrans)

1814− , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)

1815− , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)

1816− , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)

1817− , testCase "ChanLifecycle" (testChanLifecycle testtrans)

1818− , testCase "KillLocal" (testKillLocal testtrans)

1819− , testCase "KillRemote" (testKillRemote testtrans)

1820− , testCase "Die" (testDie testtrans)

1821− , testCase "PrettyExit" (testPrettyExit testtrans)

1822− , testCase "CatchesExit" (testCatchesExit testtrans)

1823− , testCase "Catches" (testCatches testtrans)

1824− , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)

1825− , testCase "ExitLocal" (testExitLocal testtrans)

1826− , testCase "ExitRemote" (testExitRemote testtrans)

1827− , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)

1828− , testCase "TextCallLocal" (testCallLocal testtrans)

1829− -- Unsafe Primitives

1830− , testCase "TestUnsafeSend" (testUnsafeSend testtrans)

1831− , testCase "TestUnsafeUSend" (testUnsafeUSend testtrans)

1832− , testCase "TestUnsafeNSend" (testUnsafeNSend testtrans)

1833− , testCase "TestUnsafeNSendRemote" (testUnsafeNSendRemote testtrans)

1834− , testCase "TestUnsafeSendChan" (testUnsafeSendChan testtrans)

1835− -- usend

1836− , testCase "USend" (testUSend usend testtrans 50)

1837− , testCase "UForward"

1838− (testUSend (\p m -> uforward (createUnencodedMessage m) p)

1839− testtrans 50

1840− )

1841− ]

1842− , testGroup "Monitoring and Linking" [

1843− -- Monitoring processes

1844− --

1845− -- The "missing" combinations in the list below don't make much sense, as

1846− -- we cannot guarantee that the monitor reply or link exception will not

1847− -- happen before the unmonitor or unlink

1848− testCase "MonitorNormalTermination" (testMonitorNormalTermination testtrans True False)

1849− , testCase "MonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True False)

1850− , testCase "MonitorLocalDeadProcess" (testMonitorLocalDeadProcess testtrans True False)

1851− , testCase "MonitorRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans True False)

1852− , testCase "MonitorDisconnect" (testMonitorDisconnect testtrans True False)

1853− , testCase "LinkUnreachable" (testMonitorUnreachable testtrans False False)

1854− , testCase "LinkNormalTermination" (testMonitorNormalTermination testtrans False False)

1855− , testCase "LinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False False)

1856− , testCase "LinkLocalDeadProcess" (testMonitorLocalDeadProcess testtrans False False)

1857− , testCase "LinkRemoteDeadProcess" (testMonitorRemoteDeadProcess testtrans False False)

1858− , testCase "LinkDisconnect" (testMonitorDisconnect testtrans False False)

1859− , testCase "UnmonitorNormalTermination" (testMonitorNormalTermination testtrans True True)

1860− , testCase "UnmonitorAbnormalTermination" (testMonitorAbnormalTermination testtrans True True)

1861− , testCase "UnmonitorDisconnect" (testMonitorDisconnect testtrans True True)

1862− , testCase "UnlinkNormalTermination" (testMonitorNormalTermination testtrans False True)

1863− , testCase "UnlinkAbnormalTermination" (testMonitorAbnormalTermination testtrans False True)

1864− , testCase "UnlinkDisconnect" (testMonitorDisconnect testtrans False True)

1865− -- Monitoring nodes and channels

1866− , testCase "MonitorNode" (testMonitorNode testtrans)

1867− , testCase "MonitorLiveNode" (testMonitorLiveNode testtrans)

1868− , testCase "MonitorChannel" (testMonitorChannel testtrans)

1869− -- Reconnect

1870− ]

1871−

1872− -- Tests that fail occasionally and should be revised

1873− , testGroup "Flaky" [

1874− testCase "Reconnect" (testReconnect testtrans)

1875− , testCase "Registry" (testRegistry testtrans)

1876− , testCase "MergeChannels" (testMergeChannels testtrans)

1877− , testCase "MonitorUnreachable" (testMonitorUnreachable testtrans True False)

1878− ]

1879− ]

distributed-process-tests/src/Control/Distributed/Process/Tests/Closure.hsdeleted−589

@@ -1,589 +0,0 @@

1−{-# LANGUAGE TemplateHaskell, KindSignatures #-}

2−module Control.Distributed.Process.Tests.Closure (tests) where

3−

4−import Network.Transport.Test (TestTransport(..))

5−

6−import Data.ByteString.Lazy (empty)

7−import Data.IORef

8−import Data.Typeable (Typeable)

9−import Data.Maybe

10−import Control.Monad (join, replicateM, forever, replicateM_, void, when, unless)

11−import Control.Exception (IOException, throw)

12−import Control.Concurrent (forkIO, threadDelay)

13−import Control.Concurrent.MVar

14− ( MVar

15− , newEmptyMVar

16− , readMVar

17− , takeMVar

18− , putMVar

19− , modifyMVar_

20− , newMVar

21− )

22−import Control.Applicative ((<$>))

23−import System.Random (randomIO)

24−import Control.Distributed.Process

25−import Control.Distributed.Process.Closure

26−import Control.Distributed.Process.Node

27−import Control.Distributed.Process.Internal.Types

28− ( NodeId(nodeAddress)

29− , createMessage

30− , messageToPayload

31− )

32−import Control.Distributed.Static (staticLabel, staticClosure)

33−import qualified Network.Transport as NT

34−

35−import Test.HUnit (Assertion)

36−import Test.Framework (Test)

37−import Test.Framework.Providers.HUnit (testCase)

38−

39−--------------------------------------------------------------------------------

40−-- Supporting definitions --

41−--------------------------------------------------------------------------------

42−

43−quintuple :: a -> b -> c -> d -> e -> (a, b, c, d, e)

44−quintuple a b c d e = (a, b, c, d, e)

45−

46−sdictInt :: SerializableDict Int

47−sdictInt = SerializableDict

48−

49−factorial :: Int -> Process Int

50−factorial 0 = return 1

51−factorial n = (n *) <$> factorial (n - 1)

52−

53−addInt :: Int -> Int -> Int

54−addInt x y = x + y

55−

56−putInt :: Int -> MVar Int -> IO ()

57−putInt = flip putMVar

58−

59−sendPid :: ProcessId -> Process ()

60−sendPid toPid = do

61− fromPid <- getSelfPid

62− send toPid fromPid

63−

64−wait :: Int -> Process ()

65−wait = liftIO . threadDelay

66−

67−expectUnit :: Process ()

68−expectUnit = expect

69−

70−isPrime :: Integer -> Process Bool

71−isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]

72− where

73− sieve :: [Integer] -> [Integer]

74− sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]

75− sieve [] = error "Uh oh -- we've run out of primes"

76−

77−-- | First argument indicates empty closure environment

78−typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()

79−typedPingServer () rport = forever $ do

80− sport <- receiveChan rport

81− sendChan sport ()

82−

83−signal :: ProcessId -> Process ()

84−signal pid = send pid ()

85−

86−remotable [ 'factorial

87− , 'addInt

88− , 'putInt

89− , 'sendPid

90− , 'sdictInt

91− , 'wait

92− , 'expectUnit

93− , 'typedPingServer

94− , 'isPrime

95− , 'quintuple

96− , 'signal

97− ]

98−

99−randomElement :: [a] -> IO a

100−randomElement xs = do

101− ix <- randomIO

102− return (xs !! (ix `mod` length xs))

103−

104−remotableDecl [

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

106− dfib (_, reply, 0) = sendChan reply 0

107− dfib (_, reply, 1) = sendChan reply 1

108− dfib (nids, reply, n) = do

109− nid1 <- liftIO $ randomElement nids

110− nid2 <- liftIO $ randomElement nids

111− (sport, rport) <- newChan

112− spawn nid1 $ $(mkClosure 'dfib) (nids, sport, n - 2)

113− spawn nid2 $ $(mkClosure 'dfib) (nids, sport, n - 1)

114− n1 <- receiveChan rport

115− n2 <- receiveChan rport

116− sendChan reply $ n1 + n2

117− |]

118− ]

119−

120−-- Just try creating a static polymorphic value

121−staticQuintuple :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e)

122− => Static (a -> b -> c -> d -> e -> (a, b, c, d, e))

123−staticQuintuple = $(mkStatic 'quintuple)

124−

125−factorialClosure :: Int -> Closure (Process Int)

126−factorialClosure = $(mkClosure 'factorial)

127−

128−addIntClosure :: Int -> Closure (Int -> Int)

129−addIntClosure = $(mkClosure 'addInt)

130−

131−putIntClosure :: Int -> Closure (MVar Int -> IO ())

132−putIntClosure = $(mkClosure 'putInt)

133−

134−sendPidClosure :: ProcessId -> Closure (Process ())

135−sendPidClosure = $(mkClosure 'sendPid)

136−

137−sendFac :: Int -> ProcessId -> Closure (Process ())

138−sendFac n pid = factorialClosure n `bindCP` cpSend $(mkStatic 'sdictInt) pid

139−

140−factorialOf :: Closure (Int -> Process Int)

141−factorialOf = staticClosure $(mkStatic 'factorial)

142−

143−factorial' :: Int -> Closure (Process Int)

144−factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf

145−

146−waitClosure :: Int -> Closure (Process ())

147−waitClosure = $(mkClosure 'wait)

148−

149−simulateNetworkFailure :: TestTransport -> LocalNode -> LocalNode -> Process ()

150−simulateNetworkFailure TestTransport{..} from to = liftIO $ do

151− m <- newEmptyMVar

152− _ <- forkProcess to $ getSelfPid >>= liftIO . putMVar m

153− runProcess from $ do

154− them <- liftIO $ takeMVar m

155− pinger <- spawnLocal $ forever $ send them ()

156− _ <- monitorNode (localNodeId to)

157− liftIO $ testBreakConnection (nodeAddress $ localNodeId from)

158− (nodeAddress $ localNodeId to)

159− NodeMonitorNotification _ _ _ <- expect

160− kill pinger "finished"

161− return ()

162−

163−--------------------------------------------------------------------------------

164−-- The tests proper --

165−--------------------------------------------------------------------------------

166−

167−testUnclosure :: TestTransport -> RemoteTable -> Assertion

168−testUnclosure TestTransport{..} rtable = do

169− node <- newLocalNode testTransport rtable

170− done <- newEmptyMVar

171− forkProcess node $ do

172− i <- join . unClosure $ factorialClosure 5

173− liftIO $ putMVar done ()

174− if i == 720

175− then return ()

176− else error "Something went horribly wrong"

177− takeMVar done

178−

179−testBind :: TestTransport -> RemoteTable -> Assertion

180−testBind TestTransport{..} rtable = do

181− node <- newLocalNode testTransport rtable

182− done <- newEmptyMVar

183− runProcess node $ do

184− us <- getSelfPid

185− join . unClosure $ sendFac 6 us

186− (i :: Int) <- expect

187− liftIO $ putMVar done ()

188− if i == 720

189− then return ()

190− else error "Something went horribly wrong"

191− takeMVar done

192−

193−testSendPureClosure :: TestTransport -> RemoteTable -> Assertion

194−testSendPureClosure TestTransport{..} rtable = do

195− serverAddr <- newEmptyMVar

196− serverDone <- newEmptyMVar

197−

198− forkIO $ do

199− node <- newLocalNode testTransport rtable

200− addr <- forkProcess node $ do

201− cl <- expect

202− fn <- unClosure cl :: Process (Int -> Int)

203− (_ :: Int) <- return $ fn 6

204− liftIO $ putMVar serverDone ()

205− putMVar serverAddr addr

206−

207− forkIO $ do

208− node <- newLocalNode testTransport rtable

209− theirAddr <- readMVar serverAddr

210− runProcess node $ send theirAddr (addIntClosure 7)

211−

212− takeMVar serverDone

213−

214−testSendIOClosure :: TestTransport -> RemoteTable -> Assertion

215−testSendIOClosure TestTransport{..} rtable = do

216− serverAddr <- newEmptyMVar

217− serverDone <- newEmptyMVar

218−

219− forkIO $ do

220− node <- newLocalNode testTransport rtable

221− addr <- forkProcess node $ do

222− cl <- expect

223− io <- unClosure cl :: Process (MVar Int -> IO ())

224− liftIO $ do

225− someMVar <- newEmptyMVar

226− io someMVar

227− i <- readMVar someMVar

228− putMVar serverDone ()

229− if i == 5

230− then return ()

231− else error "Something went horribly wrong"

232− putMVar serverAddr addr

233−

234− forkIO $ do

235− node <- newLocalNode testTransport rtable

236− theirAddr <- readMVar serverAddr

237− runProcess node $ send theirAddr (putIntClosure 5)

238−

239− takeMVar serverDone

240−

241−testSendProcClosure :: TestTransport -> RemoteTable -> Assertion

242−testSendProcClosure TestTransport{..} rtable = do

243− serverAddr <- newEmptyMVar

244− clientDone <- newEmptyMVar

245−

246− forkIO $ do

247− node <- newLocalNode testTransport rtable

248− addr <- forkProcess node $ do

249− cl <- expect

250− pr <- unClosure cl :: Process (Int -> Process ())

251− pr 5

252− putMVar serverAddr addr

253−

254− forkIO $ do

255− node <- newLocalNode testTransport rtable

256− theirAddr <- readMVar serverAddr

257− runProcess node $ do

258− pid <- getSelfPid

259− send theirAddr (cpSend $(mkStatic 'sdictInt) pid)

260− i <- expect :: Process Int

261− if i == 5

262− then liftIO $ putMVar clientDone ()

263− else error "Something went horribly wrong"

264−

265− takeMVar clientDone

266−

267−testSpawn :: TestTransport -> RemoteTable -> Assertion

268−testSpawn TestTransport{..} rtable = do

269− serverNodeAddr <- newEmptyMVar

270− clientDone <- newEmptyMVar

271−

272− forkIO $ do

273− node <- newLocalNode testTransport rtable

274− putMVar serverNodeAddr (localNodeId node)

275−

276− forkIO $ do

277− node <- newLocalNode testTransport rtable

278− nid <- readMVar serverNodeAddr

279− runProcess node $ do

280− pid <- getSelfPid

281− pid' <- spawn nid (sendPidClosure pid)

282− pid'' <- expect

283− if pid' == pid''

284− then liftIO $ putMVar clientDone ()

285− else error "Something went horribly wrong"

286−

287− takeMVar clientDone

288−

289−-- | Tests that spawn executes the supplied closure even if the caller dies

290−-- immediately after calling spawn.

291−--

292−-- This situation is of interest because the implementation of spawn has the

293−-- remote peer monitor the caller. See DP-99.

294−--

295−-- The condition is tested by using a transport which refuses to send to the

296−-- remote peer the message that it is waiting to stop monitoring the caller,

297−-- namely @()@.

298−--

299−testSpawnRace :: TestTransport -> RemoteTable -> Assertion

300−testSpawnRace TestTransport{..} rtable = do

301− node1 <- newLocalNode (wrapTransport testTransport) rtable

302− node2 <- newLocalNode testTransport rtable

303−

304− runProcess node1 $ do

305− pid <- getSelfPid

306− spawnLocal $ spawn (localNodeId node2) (sendPidClosure pid) >>= send pid

307− pid' <- expect :: Process ProcessId

308− pid'' <- expect :: Process ProcessId

309− if pid' == pid''

310− then return ()

311− else error "Something went horribly wrong"

312−

313− where

314−

315− wrapTransport (NT.Transport ne ct) = NT.Transport (fmap (fmap wrapEP) ne) ct

316−

317− wrapEP :: NT.EndPoint -> NT.EndPoint

318− wrapEP e =

319− e { NT.connect = \x y z -> do

320− healthy <- newIORef True

321− fmap (fmap $ wrapConnection healthy e x) $ NT.connect e x y z

322− }

323−

324− wrapConnection :: IORef Bool -> NT.EndPoint -> NT.EndPointAddress

325− -> NT.Connection -> NT.Connection

326− wrapConnection healthy e remoteAddr (NT.Connection s closeC) =

327− flip NT.Connection closeC $ \msg -> do

328− when (msg == messageToPayload (createMessage ())) $ do

329− writeIORef healthy False

330− testBreakConnection (NT.address e) remoteAddr

331− isHealthy <- readIORef healthy

332− if isHealthy then s msg

333− else return $ Left $ NT.TransportError NT.SendFailed ""

334−

335−testCall :: TestTransport -> RemoteTable -> Assertion

336−testCall TestTransport{..} rtable = do

337− serverNodeAddr <- newEmptyMVar

338− clientDone <- newEmptyMVar

339−

340− forkIO $ do

341− node <- newLocalNode testTransport rtable

342− putMVar serverNodeAddr (localNodeId node)

343−

344− forkIO $ do

345− node <- newLocalNode testTransport rtable

346− nid <- readMVar serverNodeAddr

347− runProcess node $ do

348− (a :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)

349− if a == 120

350− then liftIO $ putMVar clientDone ()

351− else error "something went horribly wrong"

352−

353− takeMVar clientDone

354−

355−testCallBind :: TestTransport -> RemoteTable -> Assertion

356−testCallBind TestTransport{..} rtable = do

357− serverNodeAddr <- newEmptyMVar

358− clientDone <- newEmptyMVar

359−

360− forkIO $ do

361− node <- newLocalNode testTransport rtable

362− putMVar serverNodeAddr (localNodeId node)

363−

364− forkIO $ do

365− node <- newLocalNode testTransport rtable

366− nid <- readMVar serverNodeAddr

367− runProcess node $ do

368− (a :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)

369− if a == 120

370− then liftIO $ putMVar clientDone ()

371− else error "Something went horribly wrong"

372−

373− takeMVar clientDone

374−

375−testSeq :: TestTransport -> RemoteTable -> Assertion

376−testSeq TestTransport{..} rtable = do

377− node <- newLocalNode testTransport rtable

378− done <- newEmptyMVar

379− runProcess node $ do

380− us <- getSelfPid

381− join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us

382− a :: Int <- expect

383− b :: Int <- expect

384− if a == 120 && b == 720

385− then liftIO $ putMVar done ()

386− else error "Something went horribly wrong"

387− takeMVar done

388−

389−-- Test 'spawnSupervised'

390−--

391−-- Set up a supervisor, spawn a child, then have a third process monitor the

392−-- child. The supervisor then throws an exception, the child dies because it

393−-- was linked to the supervisor, and the third process notices that the child

394−-- dies.

395−testSpawnSupervised :: TestTransport -> RemoteTable -> Assertion

396−testSpawnSupervised TestTransport{..} rtable = do

397− [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable

398− [superPid, childPid] <- replicateM 2 $ newEmptyMVar

399− thirdProcessDone <- newEmptyMVar

400− linkUp <- newEmptyMVar

401−

402− forkProcess node1 $ do

403− us <- getSelfPid

404− liftIO $ putMVar superPid us

405− (child, _ref) <- spawnSupervised (localNodeId node2)

406− (sendPidClosure us `seqCP` $(mkStaticClosure 'expectUnit))

407− _ <- expect :: Process ProcessId

408−

409− liftIO $ do putMVar childPid child

410− -- Give the child a chance to link to us

411− takeMVar linkUp

412− throw supervisorDeath

413−

414− forkProcess node2 $ do

415− res <- liftIO $ mapM readMVar [superPid, childPid]

416− case res of

417− [super, child] -> do

418− ref <- monitor child

419− self <- getSelfPid

420− let waitForMOrL = do

421− liftIO $ threadDelay 10000

422− mpinfo <- getProcessInfo child

423− case mpinfo of

424− Nothing -> waitForMOrL

425− Just pinfo ->

426− unless (isJust $ lookup self (infoMonitors pinfo)) waitForMOrL

427− waitForMOrL

428− liftIO $ putMVar linkUp ()

429− -- because monitor message was sent before message to process

430− -- we hope that it will be processed before

431− res' <- expect

432− case res' of

433− (ProcessMonitorNotification ref' pid' (DiedException e)) ->

434− if (ref' == ref && pid' == child &&

435− e == show (ProcessLinkException super

436− (DiedException (show supervisorDeath))))

437− then liftIO $ putMVar thirdProcessDone ()

438− else error "Something went horribly wrong"

439− _ -> error "Something went horribly wrong"

440−

441− _ -> die $ "Something went horribly wrong"

442−

443− takeMVar thirdProcessDone

444− where

445− supervisorDeath :: IOException

446− supervisorDeath = userError "Supervisor died"

447−

448−testSpawnInvalid :: TestTransport -> RemoteTable -> Assertion

449−testSpawnInvalid TestTransport{..} rtable = do

450− node <- newLocalNode testTransport rtable

451− done <- newEmptyMVar

452− forkProcess node $ do

453− (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)

454− ProcessMonitorNotification ref' pid' _reason <- expect

455− -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure

456− res <- return $ ref' == ref && pid == pid'

457− if res == True

458− then liftIO $ putMVar done ()

459− else error "Something went horribly wrong"

460− takeMVar done

461−

462−testClosureExpect :: TestTransport -> RemoteTable -> Assertion

463−testClosureExpect TestTransport{..} rtable = do

464− node <- newLocalNode testTransport rtable

465− done <- newEmptyMVar

466− runProcess node $ do

467− nodeId <- getSelfNode

468− us <- getSelfPid

469− them <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us

470− send them (1234 :: Int)

471− (res :: Int) <- expect

472− if res == 1234

473− then liftIO $ putMVar done ()

474− else error "Something went horribly wrong"

475− takeMVar done

476−

477−testSpawnChannel :: TestTransport -> RemoteTable -> Assertion

478−testSpawnChannel TestTransport{..} rtable = do

479− done <- newEmptyMVar

480− [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable

481−

482− forkProcess node1 $ do

483− pingServer <- spawnChannel

484− (sdictSendPort sdictUnit)

485− (localNodeId node2)

486− ($(mkClosure 'typedPingServer) ())

487− (sendReply, receiveReply) <- newChan

488− sendChan pingServer sendReply

489− receiveChan receiveReply

490− liftIO $ putMVar done ()

491−

492− takeMVar done

493−

494−testTDict :: TestTransport -> RemoteTable -> Assertion

495−testTDict TestTransport{..} rtable = do

496− done <- newEmptyMVar

497− [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable

498− forkProcess node1 $ do

499− res <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))

500− if res == True

501− then liftIO $ putMVar done ()

502− else error "Something went horribly wrong..."

503− takeMVar done

504−

505−testFib :: TestTransport -> RemoteTable -> Assertion

506−testFib TestTransport{..} rtable = do

507− nodes <- replicateM 4 $ newLocalNode testTransport rtable

508− done <- newEmptyMVar

509−

510− forkProcess (head nodes) $ do

511− (sport, rport) <- newChan

512− spawnLocal $ dfib (map localNodeId nodes, sport, 10)

513− ff <- receiveChan rport :: Process Integer

514− liftIO $ putMVar done ()

515− if ff /= 55

516− then die $ "Something went horribly wrong"

517− else return ()

518−

519− takeMVar done

520−

521−testSpawnReconnect :: TestTransport -> RemoteTable -> Assertion

522−testSpawnReconnect testtrans@TestTransport{..} rtable = do

523− [node1, node2] <- replicateM 2 $ newLocalNode testTransport rtable

524− let nid1 = localNodeId node1

525− -- nid2 = localNodeId node2

526− done <- newEmptyMVar

527− iv <- newMVar (0 :: Int)

528−

529− incr <- forkProcess node1 $ forever $ do

530− () <- expect

531− liftIO $ modifyMVar_ iv (return . (+ 1))

532−

533− forkProcess node2 $ do

534− _pid1 <- spawn nid1 ($(mkClosure 'signal) incr)

535− simulateNetworkFailure testtrans node2 node1

536− _pid2 <- spawn nid1 ($(mkClosure 'signal) incr)

537− _pid3 <- spawn nid1 ($(mkClosure 'signal) incr)

538−

539− liftIO $ threadDelay 100000

540−

541− count <- liftIO $ takeMVar iv

542− res <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'

543−

544− liftIO $ putMVar done ()

545− if res /= True

546− then error "Something went horribly wrong"

547− else return ()

548−

549− takeMVar done

550−

551−-- | 'spawn' used to ave a race condition which would be triggered if the

552−-- spawning process terminates immediately after spawning

553−testSpawnTerminate :: TestTransport -> RemoteTable -> Assertion

554−testSpawnTerminate TestTransport{..} rtable = do

555− slave <- newLocalNode testTransport rtable

556− master <- newLocalNode testTransport rtable

557− masterDone <- newEmptyMVar

558−

559− runProcess master $ do

560− us <- getSelfPid

561− replicateM_ 1000 . spawnLocal . void . spawn (localNodeId slave) $ $(mkClosure 'signal) us

562− replicateM_ 1000 $ (expect :: Process ())

563− liftIO $ putMVar masterDone ()

564−

565− takeMVar masterDone

566−

567−tests :: TestTransport -> IO [Test]

568−tests testtrans = do

569− let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable

570− return

571− [ testCase "Unclosure" (testUnclosure testtrans rtable)

572− , testCase "Bind" (testBind testtrans rtable)

573− , testCase "SendPureClosure" (testSendPureClosure testtrans rtable)

574− , testCase "SendIOClosure" (testSendIOClosure testtrans rtable)

575− , testCase "SendProcClosure" (testSendProcClosure testtrans rtable)

576− , testCase "Spawn" (testSpawn testtrans rtable)

577− , testCase "SpawnRace" (testSpawnRace testtrans rtable)

578− , testCase "Call" (testCall testtrans rtable)

579− , testCase "CallBind" (testCallBind testtrans rtable)

580− , testCase "Seq" (testSeq testtrans rtable)

581− , testCase "SpawnSupervised" (testSpawnSupervised testtrans rtable)

582− , testCase "SpawnInvalid" (testSpawnInvalid testtrans rtable)

583− , testCase "ClosureExpect" (testClosureExpect testtrans rtable)

584− , testCase "SpawnChannel" (testSpawnChannel testtrans rtable)

585− , testCase "TDict" (testTDict testtrans rtable)

586− , testCase "Fib" (testFib testtrans rtable)

587− , testCase "SpawnTerminate" (testSpawnTerminate testtrans rtable)

588− , testCase "SpawnReconnect" (testSpawnReconnect testtrans rtable)

589− ]

distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hsdeleted−243

@@ -1,243 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE TemplateHaskell #-}

4−{-# LANGUAGE CPP #-}

5−

6−-----------------------------------------------------------------------------

7−-- |

8−-- Module : Control.Distributed.Process.Tests.Internal.Utils

9−-- Copyright : (c) Tim Watson, Jeff Epstein 2013

10−-- License : BSD3 (see the file LICENSE)

11−--

12−-- Maintainer : Tim Watson

13−-- Stability : experimental

14−-- Portability : non-portable (requires concurrency)

15−--

16−-- This module provides basic building blocks for testing Cloud Haskell programs.

17−-----------------------------------------------------------------------------

18−module Control.Distributed.Process.Tests.Internal.Utils

19− ( TestResult

20− -- ping !

21− , Ping(Ping)

22− , ping

23− , pause

24− , shouldBe

25− , shouldMatch

26− , shouldContain

27− , shouldNotContain

28− , expectThat

29− , synchronisedAssertion

30− -- test process utilities

31− , TestProcessControl

32− , startTestProcess

33− , runTestProcess

34− , testProcessGo

35− , testProcessStop

36− , testProcessReport

37− , delayedAssertion

38− , assertComplete

39− -- logging

40− , Logger()

41− , newLogger

42− , putLogMsg

43− , stopLogger

44− -- runners

45− , tryRunProcess

46− , tryForkProcess

47− , noop

48− , stash

49− ) where

50−

51−#if ! MIN_VERSION_base(4,6,0)

52−import Prelude hiding (catch)

53−#endif

54−import Control.Concurrent

55− ( ThreadId

56− , myThreadId

57− , forkIO

58− )

59−import Control.Concurrent.STM

60− ( TQueue

61− , newTQueueIO

62− , readTQueue

63− , writeTQueue

64− )

65−import Control.Concurrent.MVar

66− ( MVar

67− , newEmptyMVar

68− , takeMVar

69− )

70−

71−import Control.Concurrent

72− ( throwTo

73− )

74−import Control.Concurrent.MVar

75− ( putMVar

76− )

77−import Control.Distributed.Process hiding (finally, catch)

78−import Control.Distributed.Process.Node

79−import Control.Distributed.Process.Serializable()

80−

81−import Control.Exception (AsyncException(ThreadKilled), SomeException)

82−import Control.Monad (forever, void)

83−import Control.Monad.Catch (finally, catch)

84−import Control.Monad.STM (atomically)

85−import Control.Rematch hiding (match)

86−import Control.Rematch.Run

87−import Data.Binary

88−import Data.Typeable (Typeable)

89−

90−import Test.HUnit (Assertion, assertFailure)

91−import Test.HUnit.Base (assertBool)

92−

93−import GHC.Generics

94−import System.Timeout (timeout)

95−

96−-- | A mutable cell containing a test result.

97−type TestResult a = MVar a

98−

99−-- | A simple @Ping@ signal

100−data Ping = Ping

101− deriving (Typeable, Generic, Eq, Show)

102−instance Binary Ping where

103−

104−ping :: ProcessId -> Process ()

105−ping pid = send pid Ping

106−

107−-- | Control signals used to manage /test processes/

108−data TestProcessControl = Stop | Go | Report ProcessId

109− deriving (Typeable, Generic)

110−

111−instance Binary TestProcessControl where

112−

113−data Private = Private

114− deriving (Typeable, Generic)

115−instance Binary Private where

116−

117−-- | Does exactly what it says on the tin, doing so in the @Process@ monad.

118−noop :: Process ()

119−noop = return ()

120−

121−pause :: Int -> Process ()

122−pause delay =

123− void $ receiveTimeout delay [ match (\Private -> return ()) ]

124−

125−synchronisedAssertion :: Eq a

126− => String

127− -> LocalNode

128− -> a

129− -> (TestResult a -> Process ())

130− -> MVar ()

131− -> Assertion

132−synchronisedAssertion note localNode expected testProc lock = do

133− result <- newEmptyMVar

134− _ <- forkProcess localNode $ do

135− acquire lock

136− finally (testProc result)

137− (release lock)

138− assertComplete note result expected

139− where acquire lock' = liftIO $ takeMVar lock'

140− release lock' = liftIO $ putMVar lock' ()

141−

142−stash :: TestResult a -> a -> Process ()

143−stash mvar x = liftIO $ putMVar mvar x

144−

145−expectThat :: a -> Matcher a -> Process ()

146−expectThat a matcher = case res of

147− MatchSuccess -> return ()

148− (MatchFailure msg) -> liftIO $ assertFailure msg

149− where res = runMatch matcher a

150−

151−shouldBe :: a -> Matcher a -> Process ()

152−shouldBe = expectThat

153−

154−shouldContain :: (Show a, Eq a) => [a] -> a -> Process ()

155−shouldContain xs x = expectThat xs $ hasItem (equalTo x)

156−

157−shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process ()

158−shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x))

159−

160−shouldMatch :: a -> Matcher a -> Process ()

161−shouldMatch = expectThat

162−

163−-- | Run the supplied @testProc@ using an @MVar@ to collect and assert

164−-- against its result. Uses the supplied @note@ if the assertion fails.

165−delayedAssertion :: (Eq a) => String -> LocalNode -> a ->

166− (TestResult a -> Process ()) -> Assertion

167−delayedAssertion note localNode expected testProc = do

168− result <- newEmptyMVar

169− _ <- forkProcess localNode $ testProc result

170− assertComplete note result expected

171−

172−-- | Takes the value of @mv@ (using @takeMVar@) and asserts that it matches @a@

173−assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()

174−assertComplete msg mv a = do

175− b <- takeMVar mv

176− assertBool msg (a == b)

177−

178−-- synchronised logging

179−

180−data Logger = Logger { _tid :: ThreadId, msgs :: TQueue String }

181−

182−-- | Create a new Logger.

183−-- Logger uses a 'TQueue' to receive and process messages on a worker thread.

184−newLogger :: IO Logger

185−newLogger = do

186− tid <- liftIO $ myThreadId

187− q <- liftIO $ newTQueueIO

188− _ <- forkIO $ logger q

189− return $ Logger tid q

190− where logger q' = forever $ do

191− msg <- atomically $ readTQueue q'

192− putStrLn msg

193−

194−-- | Send a message to the Logger

195−putLogMsg :: Logger -> String -> Process ()

196−putLogMsg logger msg = liftIO $ atomically $ writeTQueue (msgs logger) msg

197−

198−-- | Stop the worker thread for the given Logger

199−stopLogger :: Logger -> IO ()

200−stopLogger = (flip throwTo) ThreadKilled . _tid

201−

202−-- | Starts a test process on the local node.

203−startTestProcess :: Process () -> Process ProcessId

204−startTestProcess proc =

205− spawnLocal $ do

206− getSelfPid >>= register "test-process"

207− runTestProcess proc

208−

209−-- | Runs a /test process/ around the supplied @proc@, which is executed

210−-- whenever the outer process loop receives a 'Go' signal.

211−runTestProcess :: Process () -> Process ()

212−runTestProcess proc = do

213− ctl <- expect

214− case ctl of

215− Stop -> return ()

216− Go -> proc >> runTestProcess proc

217− Report p -> receiveWait [matchAny (\m -> forward m p)] >> runTestProcess proc

218−

219−-- | Tell a /test process/ to continue executing

220−testProcessGo :: ProcessId -> Process ()

221−testProcessGo pid = send pid Go

222−

223−-- | Tell a /test process/ to stop (i.e., 'terminate')

224−testProcessStop :: ProcessId -> Process ()

225−testProcessStop pid = send pid Stop

226−

227−-- | Tell a /test process/ to send a report (message)

228−-- back to the calling process

229−testProcessReport :: ProcessId -> Process ()

230−testProcessReport pid = do

231− self <- getSelfPid

232− send pid $ Report self

233−

234−tryRunProcess :: LocalNode -> Process () -> IO ()

235−tryRunProcess node p = do

236− tid <- liftIO myThreadId

237− void $ timeout (1000000 * 60 * 5 :: Int) $

238− runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))

239−

240−tryForkProcess :: LocalNode -> Process () -> IO ProcessId

241−tryForkProcess node p = do

242− tid <- liftIO myThreadId

243− forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))

distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hsdeleted−542

@@ -1,542 +0,0 @@

1−{-# LANGUAGE DeriveGeneric #-}

2−{-# LANGUAGE ParallelListComp #-}

3−

4−module Control.Distributed.Process.Tests.Mx (tests) where

5−

6−import Control.Distributed.Process.Tests.Internal.Utils

7−import Network.Transport.Test (TestTransport(..))

8−import Control.Distributed.Process hiding (bracket, finally, try)

9−import Control.Distributed.Process.Internal.Types

10− ( ProcessExitException(..)

11− , unsafeCreateUnencodedMessage

12− )

13−import Control.Distributed.Process.Node

14−import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe

15− ( send

16− , nsend

17− , nsendRemote

18− , usend

19− , sendChan

20− )

21−import Control.Distributed.Process.Management

22− ( MxEvent(..)

23− , MxAgentId(..)

24− , mxAgent

25− , mxSink

26− , mxReady

27− , mxReceive

28− , mxDeactivate

29− , liftMX

30− , mxGetLocal

31− , mxSetLocal

32− , mxUpdateLocal

33− , mxNotify

34− , mxBroadcast

35− )

36−import Control.Monad (void, unless)

37−import Control.Monad.Catch(finally, bracket, try)

38−import Control.Rematch (equalTo)

39−import Data.Binary

40−import Data.List (find, sort, intercalate)

41−import Data.Maybe (isJust, fromJust, isNothing, fromMaybe, catMaybes)

42−import Data.Typeable

43−import GHC.Generics hiding (from)

44−#if ! MIN_VERSION_base(4,6,0)

45−import Prelude hiding (catch, log)

46−#endif

47−

48−import Test.Framework

49− ( Test

50− , testGroup

51− )

52−import Test.Framework.Providers.HUnit (testCase)

53−

54−data Publish = Publish

55− deriving (Typeable, Generic, Eq)

56−

57−instance Binary Publish where

58−

59−awaitExit :: ProcessId -> Process ()

60−awaitExit pid =

61− withMonitorRef pid $ \ref -> do

62− receiveWait

63− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == ref)

64− (\_ -> return ())

65− ]

66− where

67− withMonitorRef p = bracket (monitor p) unmonitor

68−

69−testAgentBroadcast :: TestResult (Maybe ()) -> Process ()

70−testAgentBroadcast result = do

71− (resultSP, resultRP) <- newChan :: Process (SendPort (), ReceivePort ())

72−

73− publisher <- mxAgent (MxAgentId "publisher-agent") () [

74− mxSink $ \() -> mxBroadcast Publish >> mxReady

75− ]

76−

77− consumer <- mxAgent (MxAgentId "consumer-agent") () [

78− mxSink $ \Publish -> (liftMX $ sendChan resultSP ()) >> mxReady

79− ]

80−

81− mxNotify ()

82− -- Once the publisher has seen our message, it will broadcast the Publish

83− -- and the consumer will see that and send the result to our typed channel.

84− stash result =<< receiveChanTimeout 10000000 resultRP

85−

86− kill publisher "finished"

87− kill consumer "finished"

88−

89−testAgentDualInput :: TestResult (Maybe Int) -> Process ()

90−testAgentDualInput result = do

91− (sp, rp) <- newChan

92− s <- mxAgent (MxAgentId "sum-agent") (0 :: Int) [

93− mxSink $ (\(i :: Int) -> do

94− mxSetLocal . (+i) =<< mxGetLocal

95− i' <- mxGetLocal

96− if i' == 15

97− then do mxGetLocal >>= liftMX . sendChan sp

98− mxDeactivate "finished"

99− else mxReady)

100− ]

101−

102− mRef <- monitor s

103−

104− mxNotify (1 :: Int)

105− nsend "sum-agent" (3 :: Int)

106− mxNotify (2 :: Int)

107− nsend "sum-agent" (4 :: Int)

108− mxNotify (5 :: Int)

109−

110− stash result =<< receiveChanTimeout 10000000 rp

111− died <- receiveTimeout 10000000 [

112− matchIf (\(ProcessMonitorNotification r _ _) -> r == mRef) (const $ return True)

113− ]

114− died `shouldBe` equalTo (Just True)

115−

116−testAgentPrioritisation :: TestResult [String] -> Process ()

117−testAgentPrioritisation result = do

118−

119− -- TODO: this isn't really testing how we /prioritise/ one source

120− -- over another at all, but I've not yet figured out the right way

121− -- to do so, since we're at the whim of the scheduler with regards

122− -- the timeliness of nsend versus mxNotify anyway.

123−

124− let name = "prioritising-agent"

125− (sp, rp) <- newChan

126− s <- mxAgent (MxAgentId name) ["first"] [

127− mxSink (\(s :: String) -> do

128− mxUpdateLocal (s:)

129− st <- mxGetLocal

130− case length st of

131− n | n == 5 -> do liftMX $ sendChan sp (sort st)

132− mxDeactivate "finished"

133− _ -> mxReceive -- go to the mailbox

134− )

135− ]

136−

137− nsend name "second"

138− mxNotify "third"

139− mxNotify "fourth"

140− nsend name "fifth"

141−

142− stash result . fromMaybe [] =<< receiveChanTimeout 10000000 rp

143− awaitExit s

144−

145−testAgentMailboxHandling :: TestResult (Maybe ()) -> Process ()

146−testAgentMailboxHandling result = do

147− (sp, rp) <- newChan

148− agent <- mxAgent (MxAgentId "mailbox-agent") () [

149− mxSink $ \() -> (liftMX $ sendChan sp ()) >> mxReady

150− ]

151−

152− nsend "mailbox-agent" ()

153−

154− stash result =<< receiveChanTimeout 1000000 rp

155− kill agent "finished"

156−

157−testAgentEventHandling :: TestResult Bool -> Process ()

158−testAgentEventHandling result = do

159− us <- getSelfPid

160− -- because this test is a bit racy, let's ensure it can't run indefinitely

161− timer <- spawnLocal $ do

162− pause (1000000 * 60 * 5)

163− -- okay we've waited 5 mins, let's kill the test off if it's stuck...

164− stash result False

165− kill us "Test Timed Out"

166−

167− let initState = [] :: [MxEvent]

168− (rc, rs) <- newChan

169− agentPid <- mxAgent (MxAgentId "lifecycle-listener-agent") initState [

170− (mxSink $ \ev -> do

171− st <- mxGetLocal

172− let act =

173− case ev of

174− (MxSpawned _) -> mxSetLocal (ev:st)

175− (MxProcessDied _ _) -> mxSetLocal (ev:st)

176− _ -> return ()

177− act >> (liftMX $ sendChan rc ()) >> mxReady),

178− (mxSink $ \(ev, sp :: SendPort Bool) -> do

179− st <- mxGetLocal

180− let found =

181− case ev of

182− MxSpawned p ->

183− isJust $ find (\ev' ->

184− case ev' of

185− (MxSpawned p') -> p' == p

186− _ -> False) st

187− MxProcessDied p r ->

188− isJust $ find (\ev' ->

189− case ev' of

190− (MxProcessDied p' r') -> p' == p && r == r'

191− _ -> False) st

192− _ -> False

193− liftMX $ sendChan sp found

194− mxReady)

195− ]

196−

197− -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...

198− faff 2000000 rs

199−

200− (sp, rp) <- newChan :: Process (SendPort (), ReceivePort ())

201−

202− pid <- spawnLocal $ expect >>= sendChan sp

203−

204− -- By waiting for a monitor notification, we have a

205− -- higher probably that the agent has seen the spawn and died events

206− monitor pid

207−

208− send pid ()

209− rct <- receiveChanTimeout 10000000 rp

210− unless (isJust rct) $ die "No response on channel"

211−

212− pmn <- receiveTimeout 2000000 [ match (\ProcessMonitorNotification{} -> return ()) ]

213− unless (isJust pmn) $ die "No monitor notification arrived"

214−

215− -- TODO: yes, this is racy, but we're at the mercy of the scheduler here...

216− faff 2000000 rs

217−

218− (replyTo, reply) <- newChan :: Process (SendPort Bool, ReceivePort Bool)

219− mxNotify (MxSpawned pid, replyTo)

220− mxNotify (MxProcessDied pid DiedNormal, replyTo)

221−

222− seenAlive <- receiveChanTimeout 10000000 reply

223− seenDead <- receiveChanTimeout 10000000 reply

224−

225− stash result $ foldr (&&) True $ catMaybes [seenAlive, seenDead]

226− kill timer "test-complete"

227− kill agentPid "test-complete"

228− where

229− faff delay port = do

230− res <- receiveChanTimeout delay port

231− unless (isNothing res) $ pause delay

232−

233−testMxRegEvents :: TestResult () -> Process ()

234−testMxRegEvents result = do

235− {- This test only deals with the local case, to ensure that we are being

236− notified in the expected order - the remote cases related to the

237− behaviour of the node controller are contained in the CH test suite. -}

238− ensure (stash result ()) $ do

239− let label = "testMxRegEvents"

240− let agentLabel = "mxRegEvents-agent"

241− let delay = 1000000

242− (regChan, regSink) <- newChan

243− (unRegChan, unRegSink) <- newChan

244− agent <- mxAgent (MxAgentId agentLabel) () [

245− mxSink $ \ev -> do

246− case ev of

247− MxRegistered pid label'

248− | label' == label -> liftMX $ sendChan regChan (label', pid)

249− MxUnRegistered pid label'

250− | label' == label -> liftMX $ sendChan unRegChan (label', pid)

251− _ -> return ()

252− mxReady

253− ]

254−

255− p1 <- spawnLocal expect

256− p2 <- spawnLocal expect

257−

258− register label p1

259− reg1 <- receiveChanTimeout delay regSink

260− reg1 `shouldBe` equalTo (Just (label, p1))

261−

262− unregister label

263− unreg1 <- receiveChanTimeout delay unRegSink

264− unreg1 `shouldBe` equalTo (Just (label, p1))

265−

266− register label p2

267− reg2 <- receiveChanTimeout delay regSink

268− reg2 `shouldBe` equalTo (Just (label, p2))

269−

270− reregister label p1

271− unreg2 <- receiveChanTimeout delay unRegSink

272− unreg2 `shouldBe` equalTo (Just (label, p2))

273−

274− reg3 <- receiveChanTimeout delay regSink

275− reg3 `shouldBe` equalTo (Just (label, p1))

276−

277− mapM_ (flip kill $ "test-complete") [agent, p1, p2]

278−

279−testMxRegMon :: LocalNode -> TestResult () -> Process ()

280−testMxRegMon remoteNode result = do

281− ensure (stash result ()) $ do

282− -- ensure that when a registered process dies, we get a notification that

283− -- it has been unregistered as well as seeing the name get removed

284− let label1 = "aaaaa"

285− let label2 = "bbbbb"

286− let isValid l = l == label1 || l == label2

287− let agentLabel = "mxRegMon-agent"

288− let delay = 1000000

289− (regChan, regSink) <- newChan

290− (unRegChan, unRegSink) <- newChan

291− agent <- mxAgent (MxAgentId agentLabel) () [

292− mxSink $ \ev -> do

293− case ev of

294− MxRegistered pid label

295− | isValid label -> liftMX $ sendChan regChan (label, pid)

296− MxUnRegistered pid label

297− | isValid label -> liftMX $ sendChan unRegChan (label, pid)

298− _ -> return ()

299− mxReady

300− ]

301−

302− (sp, rp) <- newChan

303− liftIO $ forkProcess remoteNode $ do

304− getSelfPid >>= sendChan sp

305− expect :: Process ()

306−

307− p1 <- receiveChan rp

308−

309− register label1 p1

310− reg1 <- receiveChanTimeout delay regSink

311− reg1 `shouldBe` equalTo (Just (label1, p1))

312−

313− register label2 p1

314− reg2 <- receiveChanTimeout delay regSink

315− reg2 `shouldBe` equalTo (Just (label2, p1))

316−

317− n1 <- whereis label1

318− n1 `shouldBe` equalTo (Just p1)

319−

320− n2 <- whereis label2

321− n2 `shouldBe` equalTo (Just p1)

322−

323− kill p1 "goodbye"

324−

325− unreg1 <- receiveChanTimeout delay unRegSink

326− unreg2 <- receiveChanTimeout delay unRegSink

327−

328− let evts = [unreg1, unreg2]

329− -- we can't rely on the order of the values in the node controller's

330− -- map (it's either racy to do so, or no such guarantee exists for Data.Map),

331− -- so we simply verify that we received the un-registration events we expect

332− evts `shouldContain` (Just (label1, p1))

333− evts `shouldContain` (Just (label2, p1))

334−

335− kill agent "test-complete"

336−

337−ensure :: Process () -> Process () -> Process ()

338−ensure = flip finally

339−

340−testNSend :: (String -> () -> Process ())

341− -> Maybe LocalNode

342− -> Process ()

343−testNSend op n = do

344− us <- getSelfPid

345− let delay = 5000000

346− let label = "testMxSend" ++ (show us)

347− let isValid = isValidLabel n label

348−

349− testMxSend n label $ \p1 sink -> do

350− register label p1

351− reg1 <- receiveChanTimeout delay sink

352− case reg1 of

353− Just (MxRegistered pd lb)

354− | pd == p1 && isValid lb -> return ()

355− _ -> die $ "Reg-Failed: " ++ show reg1

356−

357− op label ()

358−

359− sent <- receiveChanTimeout delay sink

360− case sent of

361− Just (MxSentToName lb by _)

362− | by == us && isValid lb -> return True

363− _ -> die $ "Send-Failed: " ++ show sent

364−

365− where

366− isValidLabel nd l1 l2

367− | l2 == l2 = True

368− | isJust nd = l2 == l1 ++ "@" ++ show (localNodeId $ fromJust nd)

369− | otherwise = False

370−

371−testSend :: (ProcessId -> () -> Process ())

372− -> Maybe LocalNode

373− -> Process ()

374−testSend op n = do

375− us <- getSelfPid

376− let label = "testMxSend" ++ (show us)

377− testMxSend n label $ \p1 sink -> do

378− -- initiate a send

379− op p1 ()

380−

381− -- verify the management event

382− sent <- receiveChanTimeout 5000000 sink

383− case sent of

384− Just (MxSent pidTo pidFrom _)

385− | pidTo == p1 && pidFrom == us -> return True

386− _ -> return False

387−

388−testChan :: (SendPort () -> () -> Process ())

389− -> Maybe LocalNode

390− -> Process ()

391−testChan op n = testMxSend n "" $ \p1 sink -> do

392−

393− us <- getSelfPid

394− send p1 us

395−

396− cleared <- receiveChanTimeout 2000000 sink

397− case cleared of

398− Just (MxSent pidTo pidFrom _)

399− | pidTo == p1 && pidFrom == us -> return ()

400− _ -> die "Received uncleared Mx Event"

401−

402− chan <- receiveTimeout 5000000 [ match return ]

403− let ch' = fromMaybe (error "No reply chan received") chan

404−

405− -- initiate a send

406− op ch' ()

407−

408− -- verify the management event

409− sent <- receiveChanTimeout 5000000 sink

410− case sent of

411− Just (MxSentToPort sId spId _)

412− | sId == us && spId == sendPortId ch' -> return True

413− _ -> return False

414−

415−type SendTest = ProcessId -> ReceivePort MxEvent -> Process Bool

416−

417−testMxSend :: Maybe LocalNode -> String -> SendTest -> Process ()

418−testMxSend mNode label test = do

419− us <- getSelfPid

420− (sp, rp) <- newChan

421− (chan, sink) <- newChan

422− agent <- mxAgent (MxAgentId $ agentLabel us) () [

423− mxSink $ \ev -> do

424− case ev of

425− m@(MxSentToPort _ cid _)

426− | cid /= sendPortId chan

427− && cid /= sendPortId sp -> liftMX $ sendChan chan m

428− m@(MxSent _ fromPid _)

429− | fromPid == us -> liftMX $ sendChan chan m

430− m@(MxSentToName _ fromPid _)

431− | fromPid == us -> liftMX $ sendChan chan m

432− m@(MxRegistered _ name)

433− | name == label -> liftMX $ sendChan chan m

434− _ -> return ()

435− mxReady

436− ]

437−

438− case mNode of

439− Nothing -> void $ spawnLocal (proc sp)

440− Just remoteNode -> void $ liftIO $ forkProcess remoteNode $ proc sp

441−

442− p1 <- receiveChanTimeout 2000000 rp

443− unless (isJust p1) $ die "Timed out waiting for ProcessId"

444− res <- try $ test (fromJust p1) sink

445−

446− kill agent "bye"

447− kill (fromJust p1) "bye"

448−

449− case res of

450− Left (ProcessExitException _ m) -> (liftIO $ putStrLn $ "SomeException-" ++ show m) >> die m

451− Right tr -> tr `shouldBe` equalTo True

452−

453−

454− where

455− agentLabel s = "mx-unsafe-check-agent-" ++ show s

456− proc sp' = getSelfPid >>= sendChan sp' >> go Nothing

457−

458− go :: Maybe (ReceivePort ()) -> Process ()

459− go Nothing = receiveTimeout 5000000 [ match replyChannel ] >>= go

460− go c@(Just c') = receiveWait [ matchChan c' return ] >> go c

461−

462− replyChannel p' = do

463− (s, r) <- newChan

464− send p' s

465− return r

466−

467−tests :: TestTransport -> IO [Test]

468−tests TestTransport{..} = do

469− node1 <- newLocalNode testTransport initRemoteTable

470− node2 <- newLocalNode testTransport initRemoteTable

471− return [

472− testGroup "MxAgents" [

473− testCase "EventHandling"

474− (delayedAssertion

475− "expected True, but events where not as expected"

476− node1 True testAgentEventHandling)

477− , testCase "InterAgentBroadcast"

478− (delayedAssertion

479− "expected (), but no broadcast was received"

480− node1 (Just ()) testAgentBroadcast)

481− , testCase "AgentMailboxHandling"

482− (delayedAssertion

483− "expected (Just ()), but no regular (mailbox) input was handled"

484− node1 (Just ()) testAgentMailboxHandling)

485− , testCase "AgentDualInputHandling"

486− (delayedAssertion

487− "expected sum = 15, but the result was Nothing"

488− node1 (Just 15 :: Maybe Int) testAgentDualInput)

489− , testCase "AgentInputPrioritisation"

490− (delayedAssertion

491− "expected [first, second, third, fourth, fifth], but result diverged"

492− node1 (sort ["first", "second",

493− "third", "fourth",

494− "fifth"]) testAgentPrioritisation)

495− ]

496− , testGroup "MxEvents" [

497− testCase "NameRegistrationEvents"

498− (delayedAssertion

499− "expected registration events to map to the correct ProcessId"

500− node1 () testMxRegEvents)

501− , testCase "PostDeathNameUnRegistrationEvents"

502− (delayedAssertion

503− "expected process deaths to result in unregistration events"

504− node1 () (testMxRegMon node2))

505− , testGroup "SendEvents" $ buildTestCases node1 node2

506− ]

507− ]

508− where

509− buildTestCases n1 n2 = let nid = localNodeId n2 in build n1 n2 [

510− ("NSend", [

511− ("nsend", testNSend nsend)

512− , ("Unsafe.nsend", testNSend Unsafe.nsend)

513− , ("nsendRemote", testNSend (nsendRemote nid))

514− , ("Unsafe.nsendRemote", testNSend (Unsafe.nsendRemote nid))

515− ])

516− , ("Send", [

517− ("send", testSend send)

518− , ("Unsafe.send", testSend Unsafe.send)

519− , ("usend", testSend usend)

520− , ("Unsafe.usend", testSend Unsafe.usend)

521− , ("sendChan", testChan sendChan)

522− , ("Unsafe.sendChan", testChan Unsafe.sendChan)

523− ])

524− , ("Forward", [

525− ("forward", testSend (\p m -> forward (unsafeCreateUnencodedMessage m) p))

526− , ("uforward", testSend (\p m -> uforward (unsafeCreateUnencodedMessage m) p))

527− ])

528− ]

529−

530− build :: LocalNode

531− -> LocalNode

532− -> [(String, [(String, (Maybe LocalNode -> Process ()))])]

533− -> [Test]

534− build n ln specs =

535− [ testGroup (intercalate "-" [groupName, caseSuffix]) [

536− testCase (intercalate "-" [caseName, caseSuffix])

537− (runProcess n (caseImpl caseNode))

538− | (caseName, caseImpl) <- groupCases

539− ]

540− | (groupName, groupCases) <- specs

541− , (caseSuffix, caseNode) <- [("RemotePid", Just ln), ("LocalPid", Nothing)]

542− ]

distributed-process-tests/src/Control/Distributed/Process/Tests/Receive.hsdeleted−154

@@ -1,154 +0,0 @@

1−{-# LANGUAGE TemplateHaskell #-}

2−{-# OPTIONS_GHC -Wall #-}

3−

4−-- | XXX test doesn't work, because failure exceptions don't get propagated. The

5−-- test always claims to succeed, even if it failed.

6−

7−module Control.Distributed.Process.Tests.Receive (tests) where

8−

9−import Network.Transport.Test (TestTransport(..))

10−

11−import Network.Transport (Transport)

12−import Control.Distributed.Process

13−import Control.Distributed.Process.Node

14−

15−import Control.Monad

16−

17−import Test.HUnit (Assertion, (@?=))

18−import Test.Framework (Test)

19−import Test.Framework.Providers.HUnit (testCase)

20−

21−-- Tests:

22−

23−-- 1. 2 matchChans, receive on each one

24−-- 2. matchChan/matchIf, receive on each one

25−-- 3. matchIf/matchChan, receive on each one

26−-- 4. matchIf/matchChan/matchIf, receive on each one

27−

28−recTest1 :: ReceivePort ()

29− -> SendPort String

30− -> ReceivePort String -> ReceivePort String

31− -> Process ()

32−recTest1 wait sync r1 r2 = do

33− forever $ do

34− receiveChan wait

35− r <- receiveWait

36− [ matchChan r1 $ \s -> return ("received1 " ++ s)

37− , matchChan r2 $ \s -> return ("received2 " ++ s)

38− ]

39− sendChan sync r

40−

41−recTest2 :: ReceivePort ()

42− -> SendPort String

43− -> ReceivePort String -> ReceivePort String

44− -> Process ()

45−recTest2 wait sync r1 _ = do

46− forever $ do

47− receiveChan wait

48− r <- receiveWait

49− [ matchChan r1 $ \s -> return ("received1 " ++ s)

50− , matchIf (== "foo") $ \s -> return ("received2 " ++ s)

51− ]

52− sendChan sync r

53−

54−recTest3 :: ReceivePort ()

55− -> SendPort String

56− -> ReceivePort String -> ReceivePort String

57− -> Process ()

58−recTest3 wait sync r1 _ = do

59− forever $ do

60− receiveChan wait

61− r <- receiveWait

62− [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)

63− , matchChan r1 $ \s -> return ("received2 " ++ s)

64− ]

65− sendChan sync r

66−

67−recTest4 :: ReceivePort ()

68− -> SendPort String

69− -> ReceivePort String -> ReceivePort String

70− -> Process ()

71−recTest4 wait sync r1 _ = do

72− forever $ do

73− receiveChan wait

74− r <- receiveWait

75− [ matchIf (== "foo") $ \s -> return ("received1 " ++ s)

76− , matchChan r1 $ \s -> return ("received2 " ++ s)

77− , matchIf (== "bar") $ \s -> return ("received3 " ++ s)

78− ]

79− sendChan sync r

80−

81−master :: Process ()

82−master = do

83− (waits,waitr) <- newChan

84− (syncs,syncr) <- newChan

85− let go expected = do

86− sendChan waits ()

87− r <- receiveChan syncr

88− liftIO $ print (r, expected, r == expected)

89− liftIO $ r @?= expected

90−

91− liftIO $ putStrLn "---- Test 1 ----"

92− (s1,r1) <- newChan

93− (s2,r2) <- newChan

94− p <- spawnLocal (recTest1 waitr syncs r1 r2)

95−

96− sendChan s1 "a" >> go "received1 a"

97− sendChan s2 "b" >> go "received2 b"

98− sendChan s1 "a" >> sendChan s2 "b" >> go "received1 a"

99− go "received2 b"

100−

101− kill p "BANG"

102−

103− liftIO $ putStrLn "\n---- Test 2 ----"

104− (s1,r1) <- newChan

105− (s2,r2) <- newChan

106− p <- spawnLocal (recTest2 waitr syncs r1 r2)

107−

108− sendChan s1 "a" >> go "received1 a"

109− send p "foo" >> go "received2 foo"

110− sendChan s1 "a" >> send p "foo" >> go "received1 a"

111− sendChan s1 "a" >> send p "bar" >> go "received1 a"

112− go "received2 foo"

113−

114− kill p "BANG"

115−

116− liftIO $ putStrLn "\n---- Test 3 ----"

117− (s1,r1) <- newChan

118− (s2,r2) <- newChan

119− p <- spawnLocal (recTest3 waitr syncs r1 r2)

120−

121− sendChan s1 "a" >> go "received2 a"

122− send p "foo" >> go "received1 foo"

123− sendChan s1 "a" >> send p "foo" >> go "received1 foo"

124− sendChan s1 "a" >> send p "bar" >> go "received2 a"

125− go "received2 a"

126−

127− kill p "BANG"

128−

129− liftIO $ putStrLn "\n---- Test 4 ----"

130− (s1,r1) <- newChan

131− (s2,r2) <- newChan

132− p <- spawnLocal (recTest4 waitr syncs r1 r2)

133−

134− sendChan s1 "a" >> go "received2 a"

135− send p "foo" >> go "received1 foo"

136− send p "bar" >> go "received3 bar"

137− sendChan s1 "a" >> send p "foo" >> go "received1 foo"

138− send p "bar" >> go "received2 a"

139− send p "foo" >> go "received1 foo" >> go "received3 bar"

140−

141− kill p "BANG"

142−

143− terminate

144−

145−testReceive :: Transport -> RemoteTable -> Assertion

146−testReceive transport rtable = do

147− node <- newLocalNode transport rtable

148− runProcess node $ master

149−

150−tests :: TestTransport -> IO [Test]

151−tests TestTransport{..} = do

152− let rtable = initRemoteTable

153− return

154− [ testCase "testReceive" (testReceive testTransport rtable) ]

distributed-process-tests/src/Control/Distributed/Process/Tests/Stats.hsdeleted−129

@@ -1,129 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# OPTIONS_GHC -fno-warn-orphans #-}

3−module Control.Distributed.Process.Tests.Stats (tests) where

4−

5−import Control.Distributed.Process.Tests.Internal.Utils

6−import Network.Transport.Test (TestTransport(..))

7−

8−import Control.Concurrent.MVar

9− ( MVar

10− , newEmptyMVar

11− , putMVar

12− , takeMVar

13− )

14−import Control.Distributed.Process

15−import Control.Distributed.Process.Node

16−import Data.Binary ()

17−import Data.Typeable ()

18−

19−#if ! MIN_VERSION_base(4,6,0)

20−import Prelude hiding (catch)

21−#endif

22−

23−import Test.Framework

24− ( Test

25− , testGroup

26− )

27−import Test.HUnit (Assertion)

28−import Test.Framework.Providers.HUnit (testCase)

29−

30−testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()

31−testLocalDeadProcessInfo result = do

32− pid <- spawnLocal $ do (_ :: String) <- expect; return ()

33− mref <- monitor pid

34− send pid "finish"

35− _ <- receiveWait [

36− matchIf (\(ProcessMonitorNotification ref' pid' r) ->

37− ref' == mref && pid' == pid && r == DiedNormal)

38− (\p -> return p)

39− ]

40− getProcessInfo pid >>= stash result

41−

42−testLocalLiveProcessInfo :: TestResult Bool -> Process ()

43−testLocalLiveProcessInfo result = do

44− self <- getSelfPid

45− node <- getSelfNode

46− register "foobar" self

47−

48− mon <- liftIO $ newEmptyMVar

49− -- TODO: we can't get the mailbox's length

50− -- mapM (send self) ["hello", "there", "mr", "process"]

51− pid <- spawnLocal $ do

52− link self

53− mRef <- monitor self

54− stash mon mRef

55− res <- expect

56− case res of

57− "die" -> return ()

58− _ -> die $ "unexpected message received: " ++ res

59−

60− monRef <- liftIO $ takeMVar mon

61−

62− mpInfo <- getProcessInfo self

63− case mpInfo of

64− Nothing -> stash result False

65− Just p -> verifyPInfo p pid monRef node

66− where verifyPInfo :: ProcessInfo

67− -> ProcessId

68− -> MonitorRef

69− -> NodeId

70− -> Process ()

71− verifyPInfo pInfo pid mref node =

72− stash result $ infoNode pInfo == node &&

73− infoLinks pInfo == [pid] &&

74− infoMonitors pInfo == [(pid, mref)] &&

75−-- infoMessageQueueLength pInfo == Just 4 &&

76− infoRegisteredNames pInfo == ["foobar"]

77−

78−testRemoteLiveProcessInfo :: TestTransport -> LocalNode -> Assertion

79−testRemoteLiveProcessInfo TestTransport{..} node1 = do

80− serverAddr <- liftIO $ newEmptyMVar :: IO (MVar ProcessId)

81− liftIO $ launchRemote serverAddr

82− serverPid <- liftIO $ takeMVar serverAddr

83− withActiveRemote node1 $ \result -> do

84− self <- getSelfPid

85− link serverPid

86− -- our send op shouldn't overtake link or monitor requests AFAICT

87− -- so a little table tennis should get us synchronised properly

88− send serverPid (self, "ping")

89− pong <- expect

90− pInfo <- getProcessInfo serverPid

91− stash result $ pong == "pong" && pInfo /= Nothing

92− where

93− launchRemote :: MVar ProcessId -> IO ()

94− launchRemote locMV = do

95− node2 <- liftIO $ newLocalNode testTransport initRemoteTable

96− _ <- liftIO $ forkProcess node2 $ do

97− self <- getSelfPid

98− liftIO $ putMVar locMV self

99− _ <- receiveWait [

100− match (\(pid, "ping") -> send pid "pong")

101− ]

102− res <- expect

103− case res of

104− "stop" -> return ()

105− _ -> die $ "unexpected message received: " ++ res

106− return ()

107−

108− withActiveRemote :: LocalNode

109− -> ((TestResult Bool -> Process ()) -> Assertion)

110− withActiveRemote n = do

111− a <- delayedAssertion "getProcessInfo remotePid failed" n True

112− return a

113−

114−tests :: TestTransport -> IO [Test]

115−tests testtrans@TestTransport{..} = do

116− node1 <- newLocalNode testTransport initRemoteTable

117− return [

118− testGroup "Process Info" [

119− testCase "testLocalDeadProcessInfo"

120− (delayedAssertion

121− "expected dead process-info to be ProcessInfoNone"

122− node1 (Nothing) testLocalDeadProcessInfo)

123− , testCase "testLocalLiveProcessInfo"

124− (delayedAssertion

125− "expected process-info to be correctly populated"

126− node1 True testLocalLiveProcessInfo)

127− , testCase "testRemoveLiveProcessInfo"

128− (testRemoteLiveProcessInfo testtrans node1)

129− ] ]

distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hsdeleted−431

@@ -1,431 +0,0 @@

1−{-# LANGUAGE DeriveDataTypeable #-}

2−{-# OPTIONS_GHC -fno-warn-orphans #-}

3−module Control.Distributed.Process.Tests.Tracing (tests) where

4−

5−import Control.Distributed.Process.Tests.Internal.Utils

6−import Network.Transport.Test (TestTransport(..))

7−

8−import Control.Applicative ((<*))

9−import Control.Concurrent (threadDelay)

10−import Control.Concurrent.MVar

11− ( MVar

12− , newEmptyMVar

13− , newMVar

14− , putMVar

15− , takeMVar

16− )

17−import Control.Distributed.Process

18−import Control.Distributed.Process.Node

19−import Control.Distributed.Process.Debug

20−import Control.Distributed.Process.Management

21− ( MxEvent(..)

22− )

23−import qualified Control.Exception as IO (bracket)

24−import Data.List (isPrefixOf, isSuffixOf)

25−

26−#if ! MIN_VERSION_base(4,6,0)

27−import Prelude hiding (catch, log)

28−#else

29−import Prelude hiding ((<*))

30−#endif

31−

32−import Test.Framework

33− ( Test

34− , testGroup

35− )

36−import Test.Framework.Providers.HUnit (testCase)

37−import System.Environment (getEnvironment)

38−-- These are available in System.Environment only since base 4.7

39−import System.SetEnv (setEnv, unsetEnv)

40−

41−

42−testSpawnTracing :: TestResult Bool -> Process ()

43−testSpawnTracing result = do

44− setTraceFlags defaultTraceFlags {

45− traceSpawned = (Just TraceAll)

46− , traceDied = (Just TraceAll)

47− }

48−

49− evSpawned <- liftIO $ newEmptyMVar

50− evDied <- liftIO $ newEmptyMVar

51− tracer <- startTracer $ \ev -> do

52− case ev of

53− (MxSpawned p) -> liftIO $ putMVar evSpawned p

54− (MxProcessDied p r) -> liftIO $ putMVar evDied (p, r)

55− _ -> return ()

56−

57− (sp, rp) <- newChan

58− pid <- spawnLocal $ sendChan sp ()

59− () <- receiveChan rp

60−

61− tracedAlive <- liftIO $ takeMVar evSpawned

62− (tracedDead, tracedReason) <- liftIO $ takeMVar evDied

63−

64− mref <- monitor tracer

65− stopTracer -- this is asynchronous, so we need to wait...

66− receiveWait [

67− matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref)

68− ((\_ -> return ()))

69− ]

70− setTraceFlags defaultTraceFlags

71− stash result (tracedAlive == pid &&

72− tracedDead == pid &&

73− tracedReason == DiedNormal)

74−

75−testTraceRecvExplicitPid :: TestResult Bool -> Process ()

76−testTraceRecvExplicitPid result = do

77− res <- liftIO $ newEmptyMVar

78− pid <- spawnLocal $ do

79− self <- getSelfPid

80− expect >>= (flip sendChan) self

81− withFlags defaultTraceFlags {

82− traceRecv = traceOnly [pid]

83− } $ do

84− withTracer

85− (\ev ->

86− case ev of

87− (MxReceived pid' _) -> stash res (pid == pid')

88− _ -> return ()) $ do

89− (sp, rp) <- newChan

90− send pid sp

91− p <- receiveChan rp

92− res' <- liftIO $ takeMVar res

93− stash result (res' && (p == pid))

94− return ()

95−

96−testTraceRecvNamedPid :: TestResult Bool -> Process ()

97−testTraceRecvNamedPid result = do

98− res <- liftIO $ newEmptyMVar

99− pid <- spawnLocal $ do

100− self <- getSelfPid

101− register "foobar" self

102− expect >>= (flip sendChan) self

103− withFlags defaultTraceFlags {

104− traceRecv = traceOnly ["foobar"]

105− } $ do

106− withTracer

107− (\ev ->

108− case ev of

109− (MxReceived pid' _) -> stash res (pid == pid')

110− _ -> return ()) $ do

111− (sp, rp) <- newChan

112− send pid sp

113− p <- receiveChan rp

114− res' <- liftIO $ takeMVar res

115− stash result (res' && (p == pid))

116− return ()

117−

118−testTraceSending :: TestResult Bool -> Process ()

119−testTraceSending result = do

120− pid <- spawnLocal $ (expect :: Process String) >> return ()

121− self <- getSelfPid

122− res <- liftIO $ newEmptyMVar

123− withFlags defaultTraceFlags { traceSend = traceOn } $ do

124− withTracer

125− (\ev ->

126− case ev of

127− (MxSent to from msg) -> do

128− mS <- unwrapMessage msg :: Process (Maybe String)

129− case mS of

130− (Just s) -> do stash res (to == pid && from == self && s == "hello there")

131− stash res (to == pid && from == self)

132− _ -> die "failed state invariant, message type unmatched..."

133− _ ->

134− return ()) $ do

135− send pid "hello there"

136− res' <- liftIO $ takeMVar res

137− stash result res'

138−

139−testTraceRegistration :: TestResult Bool -> Process ()

140−testTraceRegistration result = do

141− (sp, rp) <- newChan

142− pid <- spawnLocal $ do

143− self <- getSelfPid

144− () <- expect

145− register "foobar" self

146− sendChan sp ()

147− () <- expect

148− return ()

149− res <- liftIO $ newEmptyMVar

150− withFlags defaultTraceFlags { traceRegistered = traceOn } $ do

151− withTracer

152− (\ev ->

153− case ev of

154− MxRegistered p s ->

155− stash res (p == pid && s == "foobar")

156− _ ->

157− return ()) $ do

158− _ <- monitor pid

159− send pid ()

160− () <- receiveChan rp

161− send pid ()

162− receiveWait [

163− match (\(ProcessMonitorNotification _ _ _) -> return ())

164− ]

165− res' <- liftIO $ takeMVar res

166− stash result res'

167−

168−testTraceUnRegistration :: TestResult Bool -> Process ()

169−testTraceUnRegistration result = do

170− pid <- spawnLocal $ do

171− () <- expect

172− unregister "foobar"

173− () <- expect

174− return ()

175− register "foobar" pid

176− res <- liftIO $ newEmptyMVar

177− withFlags defaultTraceFlags { traceUnregistered = traceOn } $ do

178− withTracer

179− (\ev ->

180− case ev of

181− MxUnRegistered p n -> do

182− stash res (p == pid && n == "foobar")

183− send pid ()

184− _ ->

185− return ()) $ do

186− mref <- monitor pid

187− send pid ()

188− receiveWait [

189− matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')

190− (\_ -> return ())

191− ]

192− res' <- liftIO $ takeMVar res

193− stash result res'

194−

195−testTraceLayering :: TestResult () -> Process ()

196−testTraceLayering result = do

197− pid <- spawnLocal $ do

198− getSelfPid >>= register "foobar"

199− () <- expect

200− traceMessage ("traceMsg", 123 :: Int)

201− return ()

202− withFlags defaultTraceFlags {

203− traceDied = traceOnly [pid]

204− , traceRecv = traceOnly ["foobar"]

205− } $ doTest pid result

206− return ()

207− where

208− doTest :: ProcessId -> MVar () -> Process ()

209− doTest pid result' = do

210− -- TODO: this is pretty gross, even for a test case

211− died <- liftIO $ newEmptyMVar

212− withTracer

213− (\ev ->

214− case ev of

215− MxProcessDied _ _ -> liftIO $ putMVar died ()

216− _ -> return ())

217− ( do {

218− recv <- liftIO $ newEmptyMVar

219− ; withTracer

220− (\ev' ->

221− case ev' of

222− MxReceived _ _ -> liftIO $ putMVar recv ()

223− _ -> return ())

224− ( do {

225− user <- liftIO $ newEmptyMVar

226− ; withTracer

227− (\ev'' ->

228− case ev'' of

229− MxUser _ -> liftIO $ putMVar user ()

230− _ -> return ())

231− (send pid () >> (liftIO $ takeMVar user))

232− ; liftIO $ takeMVar recv

233− })

234− ; liftIO $ takeMVar died

235− })

236− liftIO $ putMVar result' ()

237−

238−testRemoteTraceRelay :: TestTransport -> TestResult Bool -> Process ()

239−testRemoteTraceRelay TestTransport{..} result =

240− let flags = defaultTraceFlags { traceSpawned = traceOn }

241− in do

242− node2 <- liftIO $ newLocalNode testTransport initRemoteTable

243− mvNid <- liftIO $ newEmptyMVar

244−

245− -- As well as needing node2's NodeId, we want to

246− -- redirect all its logs back here, to avoid generating

247− -- garbage on stderr for the duration of the test run.

248− -- Here we set up that relay, and then wait for a signal

249− -- that the tracer (on node1) has seen the expected

250− -- MxSpawned message, at which point we're finished

251−

252− pid <- splinchLogger node2 mvNid

253− nid <- liftIO $ takeMVar mvNid

254− mref <- monitor pid

255− observedPid <- liftIO $ newEmptyMVar

256− spawnedPid <- liftIO $ newEmptyMVar

257− setTraceFlagsRemote flags nid

258−

259− withFlags defaultTraceFlags { traceSpawned = traceOn } $ do

260− withTracer

261− (\ev ->

262− case ev of

263− MxSpawned p -> stash observedPid p >> send pid ()

264− _ -> return ()) $ do

265− relayPid <- startTraceRelay nid

266− liftIO $ threadDelay 1000000

267− p <- liftIO $ forkProcess node2 $ do

268− expectTimeout 1000000 :: Process (Maybe ())

269− return ()

270− stash spawnedPid p

271−

272− -- Now we wait for (the outer) pid to exit. This won't happen until

273− -- our tracer has seen the trace event for `p' and sent `p' the

274− -- message it's waiting for prior to exiting

275− receiveWait [

276− matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')

277− (\_ -> return ())

278− ]

279−

280− relayRef <- monitor relayPid

281− kill relayPid "stop"

282− receiveWait [

283− matchIf (\(ProcessMonitorNotification rref' _ _) -> rref' == relayRef)

284− (\_ -> return ())

285− ]

286− observed <- liftIO $ takeMVar observedPid

287− expected <- liftIO $ takeMVar spawnedPid

288− stash result (observed == expected)

289− -- and just to be polite...

290− liftIO $ closeLocalNode node2

291−

292− where

293− splinchLogger n2 mv = do

294− mLog <- whereis "logger"

295− case mLog of

296− Nothing -> die "no logger registered"

297− Just log' -> do liftIO $ forkProcess n2 $ do

298− logRelay <- spawnLocal $ relay log'

299− reregister "logger" logRelay

300− getSelfNode >>= stash mv >> (expect :: Process ())

301−

302−

303−-- | Sets the value of an environment variable while executing the given IO

304−-- computation and restores the preceeding value upon completion.

305−withEnv :: String -> String -> IO a -> IO a

306−withEnv var val =

307− IO.bracket (fmap (lookup var) getEnvironment <* setEnv var val)

308− (maybe (unsetEnv var) (setEnv var))

309− . const

310−

311−-- | Tests that one and only one interesting trace message is produced when a

312−-- given action is performed. A message is considered interesting when the given

313−-- function return @True@.

314−testSystemLoggerMsg :: TestTransport

315− -> Process a

316− -> (a -> String -> Bool)

317− -> IO ()

318−testSystemLoggerMsg t action interestingMessage =

319− withEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" "yes" $

320− withEnv "DISTRIBUTED_PROCESS_TRACE_FLAGS" "pdnusrl" $ do

321− n <- newLocalNode (testTransport t) initRemoteTable

322−

323− runProcess n $ do

324− self <- getSelfPid

325− reregister "trace.logger" self

326− a <- action

327− let interestingMessage' (_ :: String, msg) = interestingMessage a msg

328− -- Wait for the trace message.

329− receiveWait [ matchIf interestingMessage' $ const $ return () ]

330− -- Only one interesting message should arrive.

331− expectedTimeout <- receiveTimeout

332− 100000

333− [ matchIf interestingMessage' $ const $ return () ]

334− case expectedTimeout of

335− Nothing -> return ()

336− Just _ -> die "Unexpected message arrived..."

337−

338−

339−-- | Tests that one and only one trace message is produced when a message is

340−-- received.

341−testSystemLoggerMxReceive :: TestTransport -> IO ()

342−testSystemLoggerMxReceive t = testSystemLoggerMsg t

343− (getSelfPid >>= flip send ())

344− (\_ msg -> "MxReceived" `isPrefixOf` msg

345− -- discard traces of internal messages

346− && not (":: RegisterReply" `isSuffixOf` msg)

347− )

348−

349−-- | Tests that one and only one trace message is produced when a message is

350−-- sent.

351−testSystemLoggerMxSent :: TestTransport -> IO ()

352−testSystemLoggerMxSent t = testSystemLoggerMsg t

353− (getSelfPid >>= flip send ())

354− (const $ isPrefixOf "MxSent")

355−

356−-- | Tests that one and only one trace message is produced when a process dies.

357−testSystemLoggerMxProcessDied :: TestTransport -> IO ()

358−testSystemLoggerMxProcessDied t = testSystemLoggerMsg t

359− (spawnLocal $ return ())

360− (\pid -> isPrefixOf $ "MxProcessDied " ++ show pid)

361−

362−-- | Tests that one and only one trace message appears when a process spawns.

363−testSystemLoggerMxSpawned :: TestTransport -> IO ()

364−testSystemLoggerMxSpawned t = testSystemLoggerMsg t

365− (spawnLocal $ return ())

366− (\pid -> isPrefixOf $ "MxSpawned " ++ show pid)

367−

368−-- | Tests that one and only one trace message appears when a process is

369−-- registered.

370−testSystemLoggerMxRegistered :: TestTransport -> IO ()

371−testSystemLoggerMxRegistered t = testSystemLoggerMsg t

372− (getSelfPid >>= register "a" >> getSelfPid)

373− (\self -> isPrefixOf $ "MxRegistered " ++ show self ++ " " ++ show "a")

374−

375−-- | Tests that one and only one trace message appears when a process is

376−-- unregistered.

377−testSystemLoggerMxUnRegistered :: TestTransport -> IO ()

378−testSystemLoggerMxUnRegistered t = testSystemLoggerMsg t

379− (getSelfPid >>= register "a" >> unregister "a" >> getSelfPid)

380− (\self -> isPrefixOf $ "MxUnRegistered " ++ show self ++ " " ++ show "a")

381−

382−tests :: TestTransport -> IO [Test]

383−tests testtrans@TestTransport{..} = do

384− node1 <- newLocalNode testTransport initRemoteTable

385− -- if we execute the test cases in parallel, the

386− -- various tracers will race with one another and

387− -- we'll get garbage results (or worse, deadlocks)

388− lock <- liftIO $ newMVar ()

389− return [

390− testGroup "Tracing" [

391− testCase "Spawn Tracing"

392− (synchronisedAssertion

393− "expected dead process-info to be ProcessInfoNone"

394− node1 True testSpawnTracing lock)

395− , testCase "Recv Tracing (Explicit Pid)"

396− (synchronisedAssertion

397− "expected a recv trace for the supplied pid"

398− node1 True testTraceRecvExplicitPid lock)

399− , testCase "Recv Tracing (Named Pid)"

400− (synchronisedAssertion

401− "expected a recv trace for the process registered as 'foobar'"

402− node1 True testTraceRecvNamedPid lock)

403− , testCase "Trace Send(er)"

404− (synchronisedAssertion

405− "expected a 'send' trace with the requisite fields set"

406− node1 True testTraceSending lock)

407− , testCase "Trace Registration"

408− (synchronisedAssertion

409− "expected a 'registered' trace"

410− node1 True testTraceRegistration lock)

411− , testCase "Trace Unregistration"

412− (synchronisedAssertion

413− "expected an 'unregistered' trace"

414− node1 True testTraceUnRegistration lock)

415− , testCase "Trace Layering"

416− (synchronisedAssertion

417− "expected blah"

418− node1 () testTraceLayering lock)

419− , testCase "Remote Trace Relay"

420− (synchronisedAssertion

421− "expected blah"

422− node1 True (testRemoteTraceRelay testtrans) lock)

423− , testGroup "SystemLoggerTracer"

424− [ testCase "MxReceive" $ testSystemLoggerMxReceive testtrans

425− , testCase "MxSent" $ testSystemLoggerMxSent testtrans

426− , testCase "MxProcessDied" $ testSystemLoggerMxProcessDied testtrans

427− , testCase "MxSpawned" $ testSystemLoggerMxSpawned testtrans

428− , testCase "MxRegistered" $ testSystemLoggerMxRegistered testtrans

429− , testCase "MxUnRegistered" $ testSystemLoggerMxUnRegistered testtrans

430− ]

431− ] ]

distributed-process-tests/src/Network/Transport/Test.hsdeleted−12

@@ -1,12 +0,0 @@

1−module Network.Transport.Test where

2−

3−import qualified Network.Transport as NT

4−import Data.Typeable (Typeable)

5−

6−-- | Extra operations required of transports for the purposes of testing.

7−data TestTransport = TestTransport

8− { -- | The transport to use for testing.

9− testTransport :: NT.Transport

10− -- | IO action to perform to simulate losing a connection.

11− , testBreakConnection :: NT.EndPointAddress -> NT.EndPointAddress -> IO ()

12− } deriving (Typeable)

distributed-process-tests/tests/runInMemory.hsdeleted−30

@@ -1,30 +0,0 @@

1−-- Run tests using the TCP transport.

2−

3−module Main where

4−

5−import TEST_SUITE_MODULE (tests)

6−

7−import Network.Transport.Test (TestTransport(..))

8−import Network.Transport.InMemory

9−import Test.Framework (defaultMainWithArgs)

10−

11−import System.Environment (getArgs)

12−

13−main :: IO ()

14−main = do

15− (transport, internals) <- createTransportExposeInternals

16− ts <- tests TestTransport

17− { testTransport = transport

18− , testBreakConnection = \addr1 addr2 -> breakConnection internals addr1 addr2 "user error"

19− }

20− args <- getArgs

21− -- Tests are time sensitive. Running the tests concurrently can slow them

22− -- down enough that threads using threadDelay would wake up later than

23− -- expected, thus changing the order in which messages were expected.

24− -- Therefore we run the tests sequentially by passing "-j 1" to

25− -- test-framework. This does not solve the issue but makes it less likely.

26− --

27− -- The problem was first detected with

28− -- 'Control.Distributed.Process.Tests.CH.testMergeChannels'

29− -- in particular.

30− defaultMainWithArgs ts ("-j" : "1" : args)

distributed-process-tests/tests/runTCP.hsdeleted−47

@@ -1,47 +0,0 @@

1−-- Run tests using the TCP transport.

2−--

3−module Main where

4−

5−import TEST_SUITE_MODULE (tests)

6−

7−import Network.Transport.Test (TestTransport(..))

8−import Network.Socket (sClose)

9−import Network.Transport.TCP

10− ( createTransportExposeInternals

11− , TransportInternals(socketBetween)

12− , defaultTCPParameters

13− , defaultTCPAddr

14− , TCPParameters(..)

15− )

16−import Test.Framework (defaultMainWithArgs)

17−

18−import Control.Concurrent (threadDelay)

19−import Control.Exception (IOException, try)

20−import System.Environment (getArgs)

21−import System.IO

22−

23−main :: IO ()

24−main = do

25− hSetBuffering stdout LineBuffering

26− hSetBuffering stderr LineBuffering

27− Right (transport, internals) <-

28− createTransportExposeInternals (defaultTCPAddr "127.0.0.1" "8080")

29− defaultTCPParameters { transportConnectTimeout = Just 3000000 }

30− ts <- tests TestTransport

31− { testTransport = transport

32− , testBreakConnection = \addr1 addr2 -> do

33− esock <- try $ socketBetween internals addr1 addr2

34− either (\e -> const (return ()) (e :: IOException)) sClose esock

35− threadDelay 10000

36− }

37− args <- getArgs

38− -- Tests are time sensitive. Running the tests concurrently can slow them

39− -- down enough that threads using threadDelay would wake up later than

40− -- expected, thus changing the order in which messages were expected.

41− -- Therefore we run the tests sequentially by passing "-j 1" to

42− -- test-framework. This does not solve the issue but makes it less likely.

43− --

44− -- The problem was first detected with

45− -- 'Control.Distributed.Process.Tests.CH.testMergeChannels'

46− -- in particular.

47− defaultMainWithArgs ts ("-j" : "1" : args)

distributed-process.cabaldeleted−168

@@ -1,168 +0,0 @@

1−Name: distributed-process

2−Version: 0.7.4

3−Cabal-Version: >=1.8

4−Build-Type: Simple

5−License: BSD3

6−License-File: LICENSE

7−Copyright: Well-Typed LLP, Tweag I/O Limited

8−Author: Duncan Coutts, Nicolas Wu, Edsko de Vries

9−Maintainer: Tim Watson <watson.timothy@gmail.com>

10−Stability: experimental

11−Homepage: http://haskell-distributed.github.com/

12−Bug-Reports: https://github.com/haskell-distributed/distributed-process/issues

13−Synopsis: Cloud Haskell: Erlang-style concurrency in Haskell

14−Description: This is an implementation of Cloud Haskell, as described in

15− /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black,

16− and Simon Peyton Jones

17− (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),

18− although some of the details are different. The precise message

19− passing semantics are based on /A unified semantics for future Erlang/

20− by Hans Svensson, Lars-Åke Fredlund and Clara Benac Earle.

21−

22− You will probably also want to install a Cloud Haskell backend such

23− as distributed-process-simplelocalnet.

24−Tested-With: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 GHC==8.4.4

25−Category: Control

26−extra-source-files: ChangeLog

27−

28−Source-Repository head

29− Type: git

30− Location: https://github.com/haskell-distributed/distributed-process

31− SubDir: distributed-process

32−

33−flag th

34− description: Build with Template Haskell support

35− default: True

36−

37−flag old-locale

38− description: If false then depend on time >= 1.5.

39− .

40− If true then depend on time < 1.5 together with old-locale.

41− default: False

42−

43−Library

44− Build-Depends: base >= 4.6 && < 5,

45− binary >= 0.6.3 && < 0.10,

46− hashable >= 1.2.0.5 && < 1.3,

47− network-transport >= 0.4.1.0 && < 0.6,

48− stm >= 2.4 && < 2.6,

49− transformers >= 0.2 && < 0.6,

50− mtl >= 2.0 && < 2.4,

51− data-accessor >= 0.2 && < 0.3,

52− bytestring >= 0.9 && < 0.11,

53− random >= 1.0 && < 1.2,

54− distributed-static >= 0.2 && < 0.4,

55− rank1dynamic >= 0.1 && < 0.5,

56− syb >= 0.3 && < 0.8,

57− exceptions >= 0.5,

58− containers >= 0.5 && < 0.7,

59− deepseq >= 1.3.0.1 && < 1.6

60− Exposed-modules: Control.Distributed.Process,

61− Control.Distributed.Process.Closure,

62− Control.Distributed.Process.Debug,

63− Control.Distributed.Process.Internal.BiMultiMap,

64− Control.Distributed.Process.Internal.Closure.BuiltIn,

65− Control.Distributed.Process.Internal.Closure.Explicit,

66− Control.Distributed.Process.Internal.CQueue,

67− Control.Distributed.Process.Internal.Messaging,

68− Control.Distributed.Process.Internal.Primitives,

69− Control.Distributed.Process.Internal.Spawn,

70− Control.Distributed.Process.Internal.StrictContainerAccessors,

71− Control.Distributed.Process.Internal.StrictList,

72− Control.Distributed.Process.Internal.StrictMVar,

73− Control.Distributed.Process.Internal.Types,

74− Control.Distributed.Process.Internal.WeakTQueue,

75− Control.Distributed.Process.Management,

76− Control.Distributed.Process.Node,

77− Control.Distributed.Process.Serializable,

78− Control.Distributed.Process.UnsafePrimitives

79− Control.Distributed.Process.Management.Internal.Agent,

80− Control.Distributed.Process.Management.Internal.Bus,

81− Control.Distributed.Process.Management.Internal.Types,

82− Control.Distributed.Process.Management.Internal.Trace.Primitives,

83− Control.Distributed.Process.Management.Internal.Trace.Remote,

84− Control.Distributed.Process.Management.Internal.Trace.Types,

85− Control.Distributed.Process.Management.Internal.Trace.Tracer

86− ghc-options: -Wall

87− HS-Source-Dirs: src

88− other-extensions: BangPatterns

89− CPP

90− DeriveDataTypeable

91− DeriveFunctor

92− DeriveGeneric

93− ExistentialQuantification

94− FlexibleInstances

95− GADTs

96− GeneralizedNewtypeDeriving

97− KindSignatures

98− MagicHash

99− PatternGuards

100− RankNTypes

101− RecordWildCards

102− ScopedTypeVariables

103− StandaloneDeriving

104− TypeFamilies

105− TypeSynonymInstances

106− UnboxedTuples

107− UndecidableInstances

108− if flag(old-locale)

109− Build-Depends: time < 1.5, old-locale >= 1.0 && <1.1

110− else

111− Build-Depends: time >= 1.5

112− if flag(th)

113− other-extensions: TemplateHaskell

114− Build-Depends: template-haskell >= 2.6

115− Exposed-modules: Control.Distributed.Process.Internal.Closure.TH

116− CPP-Options: -DTemplateHaskellSupport

117−

118−-- Tests are in distributed-process-test package, for convenience.

119−

120−benchmark distributed-process-throughput

121− Type: exitcode-stdio-1.0

122− Build-Depends: base >= 4.6 && < 5,

123− distributed-process,

124− network-transport-tcp >= 0.3 && < 0.7,

125− bytestring >= 0.9 && < 0.11,

126− binary >= 0.6.3 && < 0.10

127− Main-Is: benchmarks/Throughput.hs

128− ghc-options: -Wall

129−

130−benchmark distributed-process-latency

131− Type: exitcode-stdio-1.0

132− Build-Depends: base >= 4.6 && < 5,

133− distributed-process,

134− network-transport-tcp >= 0.3 && < 0.7,

135− bytestring >= 0.9 && < 0.11,

136− binary >= 0.6.3 && < 0.10

137− Main-Is: benchmarks/Latency.hs

138− ghc-options: -Wall

139−

140−benchmark distributed-process-channels

141− Type: exitcode-stdio-1.0

142− Build-Depends: base >= 4.6 && < 5,

143− distributed-process,

144− network-transport-tcp >= 0.3 && < 0.7,

145− bytestring >= 0.9 && < 0.11,

146− binary >= 0.6.3 && < 0.10

147− Main-Is: benchmarks/Channels.hs

148− ghc-options: -Wall

149−

150−benchmark distributed-process-spawns

151− Type: exitcode-stdio-1.0

152− Build-Depends: base >= 4.6 && < 5,

153− distributed-process,

154− network-transport-tcp >= 0.3 && < 0.7,

155− bytestring >= 0.9 && < 0.11,

156− binary >= 0.6.3 && < 0.10

157− Main-Is: benchmarks/Spawns.hs

158− ghc-options: -Wall

159−

160−benchmark distributed-process-ring

161− Type: exitcode-stdio-1.0

162− Build-Depends: base >= 4.6 && < 5,

163− distributed-process,

164− network-transport-tcp >= 0.3 && < 0.7,

165− bytestring >= 0.9 && < 0.11,

166− binary >= 0.6.3 && < 0.10

167− Main-Is: benchmarks/ProcessRing.hs

168− ghc-options: -Wall -threaded -O2 -rtsopts

distributed-process/ChangeLognew file+48

@@ -0,0 +1,48 @@

1+2012-08-02 Edsko de Vries <edsko@well-typed.com> 0.2.3.0

3+* Expose the constructors of Closure

4+* Add instance (Typeable a => Serializable (Static a)) and make sure we only

5+use the internal representation of Static where really necessary

6+* Improved docs

8+2012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0

10+* Add exception handling primitives

11+* Fix runProcess: if the process threw an exception, a 'waiting indefinitely on

12+MVar' exception would be thrown.

13+

14+2012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4

15+

16+* Bugfix in the node controller

17+(one way this bug materialized: when using the SimpleLocalnet backend,

18+slave nodes could not be reused)

19+* Improved documentation in Control.Distributed.Process.Closure

20+

21+2012-07-20 Edsko de Vries <edsko@well-typed.com> 0.2.1.3

22+

23+* Improve docs

24+* Local versions of spawn

25+

26+2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.2

27+

28+* Base 4.6 compatibility

29+* Relax constraints on bytestring and containers

30+

31+2012-07-16 Edsko de Vries <edsko@well-typed.com> 0.2.1.1

32+

33+* Relax upper bound on 'time' dependency

34+

35+2012-07-11 Edsko de Vries <edsko@well-typed.com> 0.2.1

36+

37+* Complete redesign of the underlying implementation of static values and

38+closures.

39+

40+* Add support for 'spawnChannel'

41+

42+2012-07-09 Edsko de Vries <edsko@well-typed.com> 0.2.0.1

43+

44+* Bugfix: Continue processing messages when a connection breaks.

45+

46+2012-07-07 Edsko de Vries <edsko@well-typed.com> 0.2.0

47+

48+* Initial release.

distributed-process/LICENSEnew file+31

@@ -0,0 +1,31 @@

1+Copyright Well-Typed LLP, 2011-2012

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of the owner nor the names of other