packages feed

distributed-process 0.4.2 → 0.7.8

raw patch · 38 files changed

Files

+ ChangeLog view
@@ -0,0 +1,253 @@+2025-02-04 Laurent P. René de Cotret <laurent.decotret@outlook.com> 0.7.8++* Added documentation on the unit of measurement for timeout durations (#340)+* Added upper bound on `template-haskell` to prevent future breakage.+* Addressed some compilation warnings (#467)++2024-09-03 Laurent P. René de Cotret <laurent.decotret@outlook.com> 0.7.7++* Bumped dependency bounds to support GHC 8.10.7 - GHC 9.10.1+* Updated links to point to Distributed Haskell monorepo++2024-04-03 David Simmons-Duffin <dsd@caltech.edu> 0.7.6++* Bumped hashable upper bound.++2018-06-12 David Simmons-Duffin <dsd@caltech.edu> 0.7.5++* Bumped dependencies to build with ghc-9.8+* Turn Serializable into a type synonym+* Remove tests for ghc-8.8.* and earlier++2018-06-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.4++* Added support for exceptions >= 0.10++2017-08-31 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.3++* Drop support for ghc-7.8.* and earlier.++2017-08-31 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.2++* Fixed build errors with ghc-8.2.1.++2017-08-22 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.1++* Relax upper bounds in dependencies to build with ghc-8.2.1.++2017-08-21 Facundo Domínguez <facundo.dominguez@tweag.io> 0.7.0++* Change type of message sent by `say` from a 3-tuple to a proper+type (`SayMessage`) with a proper `UTCTime`. (#291)+* Expose the MonitorRef in the withMonitor call.+* Have unmonitor remove the monitor message in the inbox. (#268)+* Remove Mx Data Tables. This API isn't used, is easy to replace with various+other packages. (#276)+* Add Ord instance to SpawnRef.++2016-10-13 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.6++* Remove monitors from remote nodes when a process dies. (#295)++2016-10-12 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.5++* Use only one connection to communicate between NCs. (#296, #297)+* Improve documentation of CQueue.+* Implement bidirectional multimaps for links and monitors. (#293, #294)+* Fix various warnings. (#292)+* Fix some of the intermittent failures in tests.+* Improve error messages when node controllers receive invalid requests.+(#290)++2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.4++* Fixup build errors.++2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.3++* Relax template-haskell upper bound.++2016-06-09 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.2++* Provide compatibility with ghc-8.0.1+* Remove dependency on ghc-prim.+* Don't throw exceptions asynchronously.+* Bump upper bounds of dependencies.+* Fix exception handling in callLocal.+* Have spawnLocal inherit the masking state of the caller.+* Have nsend send unencoded messages to local processes.++2016-03-03 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.1++* Implement MonadCatch, MonadThrow, MonadMask for Process.++2016-02-18 Facundo Domínguez <facundo.dominguez@tweag.io> 0.6.0++* Have nsendRemote skip the transport for local communication.+* Unsafe primitives for usend and nsendRemote.+* Stop using the transport for local communication.+* Skip the transport for whereisRemoteAsync and registerRemoteAsync.+* Have nsendRemote skip the transport for local communication.+* Have runProcess forward exceptions.+* Reimport distributed-process-tests. d-p and d-p-test now can be kept in+sync.+* Add a stack.yaml file for building tests and d-p all at once conveniently.+* Implement unreliable forward (uforward).+* Add Functor instance for Match data type+* Have `spawnAsync` not use the transport in the local case.+* Fix monitor race in 'call'.+* Add compatibility with ghc-7.10: support new typeable, loosen deps, write+proper NFData instances, support new TH.+* Kill processes on a local node upon closeLocalNode.+* Fix getNodeStats function, see DP-97+* Return size of the queue in ProcessInfo.+* Implement unreliable send (usend).+* Implement MonadFix instance for Process.+* Introduce callLocal primitive.+* Prevent message loss due to timeouts in CQueue.+* More informative ProcessRegistrationException. Now includes the identifier+of the process that owns the name, if any.+* Avoid message loop between threads when tracing received messages.++2015-06-15 Facundo Domínguez <facundo.dominguez@tweag.io> 0.5.5++* Fix dependencies.+* Add compatibility with GHC-7.10.+* Fix various race conditions (DP-99, DP-103).++2014-12-09  Tim Watson  <watson.timothy@gmail.com>  0.5.2++* Fix docstring for `register`+* Added Data instance to ProcessId, LocalProcessId and NodeId+* Add static serialiation dictionary for 'Static', for completeness+* Add Closure static serialization dictionary+* Replacement for modifyMVarMasked for GHC <= 7.4+* Document the use of built-in trace flags+* Make forkProcess exception-safe+* Make -Wall clean++2014-08-13  Tim Watson  <watson.timothy@gmail.com>  0.5.1++* Fix cabal docs (thanks Markus Barenhoff)+* Expose lifted version of Control.Exception.mask_ (thanks Alexander Vershilov)++2014-05-30  Tim Watson  <watson.timothy@gmail.com>  0.5.0++* Dependency on STM implicitly changed from 1.3 to 1.4, but was not reflected in the cabal file+* Race condition in local monitoring when using call+* mask now works correctly if unmask is called by another process+* Improve efficiency of local message passing+* nsend uses local communication channels+* Link Node Controller and Network Listener+* Label spawned processes using labelThread+* Relaxed upper bound on syb in the cabal manifest+* Bump binary version to include 0.7.*+* Exposed process info+* Exposed node statistics+* Moved tests to https://github.com/haskell-distributed/distributed-process-tests+* Added "polymorphic expect"+* Exposed Message type and broaden scope of polymorphic expect+* Added Management API (for working with internal/system events)+* Tracing can no longer be disabled+* We now report node statistics for monitoring/management+* Node.runProcess now propagates exceptions to its caller+* Added simple micro benchmarks++2013-01-27  Tim Watson  <watson.timothy@gmail.com>  0.4.2++* Improved exception handling for deferred type checked exit reasons+* Add matchChan primitive (thanks Simon Marlow)+* Expose deferred message handling/checking for AbstractMessage+* Add `getProcessInfo' API+* Add `trace' API backed by the GHC eventlog++2012-11-22  Edsko de Vries  <edsko@well-typed.com>  0.4.1++* Make behaviour of 'register' more Erlang-like (register will now fail if the+name is already registered).  Patch by Jeff Epstein.+* Functor, Applicative, Alternative and Monad instances for ReceivePort+* Add support for receiveChanTimeout+* Improved documentation+* Avoid name clashes in the TH generation for closures+* Relax package bounds to allow for Binary 0.6++2012-10-23  Edsko de Vries  <edsko@well-typed.com>  0.4.0.2++* Fix race condition in spawn++2012-10-04  Edsko de Vries  <edsko@well-typed.com>  0.4.0.1++* Relax package boundaries++2012-10-03  Edsko de Vries  <edsko@well-typed.com>  0.4.0++* Improved treatment of network failure, using new failure semantics of+Network.Transport.+* Make NodeId Typeable+* Extend Template Haskell support with "remotableDec" so that you can refer to+$(mkClosure 'f) within the body of "f".+* Fix bug in spawnChannelLocal+* Numerous memory leaks plugged+* Relax upper bound on dependency on 'network'+* New primitive 'matchAny'+* Remove 'whereisRemote' (see comment of 'whereisRemoteAsync') ++2012-08-16  Edsko de Vries  <edsko@well-typed.com>  0.3.1++* Fix memory leaks+* Make Template Haskell support optional+* Relax dependency constraints++2012-08-07  Edsko de Vries  <edsko@well-typed.com>  0.3.0++* Extract 'static' into a separate package (C.D.Static)+* Use new package rank1dynamic to proper runtime checks for polymorphic values++2012-08-02  Edsko de Vries  <edsko@well-typed.com>  0.2.3.0++* Expose the constructors of Closure+* Add instance (Typeable a => Serializable (Static a)) and make sure we only+use the internal representation of Static where really necessary+* Improved docs++2012-07-31  Edsko de Vries  <edsko@well-typed.com>  0.2.2.0++* Add exception handling primitives+* Fix runProcess: if the process threw an exception, a 'waiting indefinitely on+MVar' exception would be thrown.++2012-07-21  Edsko de Vries  <edsko@well-typed.com>  0.2.1.4++* Bugfix in the node controller+(one way this bug materialized: when using the SimpleLocalnet backend,+slave nodes could not be reused)+* Improved documentation in Control.Distributed.Process.Closure++2012-07-20  Edsko de Vries  <edsko@well-typed.com>  0.2.1.3++* Improve docs+* Local versions of spawn++2012-07-16  Edsko de Vries  <edsko@well-typed.com>  0.2.1.2++* Base 4.6 compatibility+* Relax constraints on bytestring and containers++2012-07-16  Edsko de Vries  <edsko@well-typed.com>  0.2.1.1++* Relax upper bound on 'time' dependency++2012-07-11  Edsko de Vries  <edsko@well-typed.com>  0.2.1++* Complete redesign of the underlying implementation of static values and+closures. ++* Add support for 'spawnChannel' ++2012-07-09  Edsko de Vries  <edsko@well-typed.com>  0.2.0.1++* Bugfix: Continue processing messages when a connection breaks.++2012-07-07  Edsko de Vries  <edsko@well-typed.com>  0.2.0++* Initial release.
LICENSE view
@@ -1,4 +1,5 @@ Copyright Well-Typed LLP, 2011-2012+Copyright Tweag I/O Limited, 2015  All rights reserved.
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
benchmarks/Channels.hs view
@@ -4,7 +4,7 @@ import Control.Applicative import Control.Distributed.Process import Control.Distributed.Process.Node-import Network.Transport.TCP (createTransport, defaultTCPParameters)+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters) import Data.Binary (encode, decode) import qualified Data.ByteString.Lazy as BSL @@ -36,6 +36,8 @@ main :: IO () main = do   [role, host, port] <- getArgs-  Right transport <- createTransport host port defaultTCPParameters-  node <- newLocalNode transport initRemoteTable-  runProcess node $ initialProcess role+  trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters+  case trans of+    Right transport -> do node <- newLocalNode transport initRemoteTable+                          runProcess node $ initialProcess role+    Left other -> error $ show other
benchmarks/Latency.hs view
@@ -3,7 +3,7 @@ import Control.Applicative import Control.Distributed.Process import Control.Distributed.Process.Node-import Network.Transport.TCP (createTransport, defaultTCPParameters)+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters) import Data.Binary (encode, decode) import qualified Data.ByteString.Lazy as BSL @@ -31,6 +31,9 @@ main :: IO () main = do   [role, host, port] <- getArgs-  Right transport <- createTransport host port defaultTCPParameters-  node <- newLocalNode transport initRemoteTable-  runProcess node $ initialProcess role+  trans <- createTransport+                      (defaultTCPAddr host port) defaultTCPParameters+  case trans of+    Right transport -> do node <- newLocalNode transport initRemoteTable+                          runProcess node $ initialProcess role+    Left other -> error $ show other
+ benchmarks/ProcessRing.hs view
@@ -0,0 +1,117 @@+{- ProcessRing benchmarks.++To run the benchmarks, select a value for the ring size (sz) and+the number of times to send a message around the ring++-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++import Control.Monad+import Control.Distributed.Process hiding (catch)+import Control.Distributed.Process.Node+import Control.Exception (catch, SomeException)+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters)+import System.Environment+import System.Console.GetOpt++data Options = Options+  { optRingSize   :: Int+  , optIterations :: Int+  , optForward    :: Bool+  , optParallel   :: Bool+  , optUnsafe     :: Bool+  } deriving Show++initialProcess :: Options -> Process ()+initialProcess op =+  let ringSz = optRingSize op+      msgCnt = optIterations op+      fwd    = optForward op+      unsafe = optUnsafe op+      msg    = ("foobar", "baz")+  in do+    self <- getSelfPid+    ring <- makeRing fwd unsafe ringSz self+    forM_ [1..msgCnt] (\_ -> send ring msg)+    collect msgCnt+  where relay fsend pid = do+          msg <- expect :: Process (String, String)+          fsend pid msg+          relay fsend pid++        forward' pid =+          receiveWait [ matchAny (\m -> forward m pid) ] >> forward' pid++        makeRing :: Bool -> Bool -> Int -> ProcessId -> Process ProcessId+        makeRing !f !u !n !pid+          | n == 0    = go f u pid+          | otherwise = go f u pid >>= makeRing f u (n - 1)++        go :: Bool -> Bool -> ProcessId -> Process ProcessId+        go False False next = spawnLocal $ relay send next+        go False True  next = spawnLocal $ relay unsafeSend next+        go True  _     next = spawnLocal $ forward' next++        collect :: Int -> Process ()+        collect !n+          | n == 0    = return ()+          | otherwise = do+                receiveWait [+                    matchIf    (\(a, b) -> a == "foobar" && b == "baz")+                               (\_ -> return ())+                  , matchAny   (\_ -> error "unexpected input!")+                  ]+                collect (n - 1)++defaultOptions :: Options+defaultOptions = Options+  { optRingSize   = 10+  , optIterations = 100+  , optForward    = False+  , optParallel   = False+  , optUnsafe     = False+  }++options :: [OptDescr (Options -> Options)]+options =+    [ Option ['s'] ["ring-size"] (OptArg optSz "SIZE") "# of processes in ring"+    , Option ['i'] ["iterations"] (OptArg optMsgCnt "ITER") "# of times to send"+    , Option ['f'] ["forward"]+        (NoArg (\opts -> opts { optForward = True }))+        "use `forward' instead of send - default = False"+    , Option ['u'] ["unsafe-send"]+        (NoArg (\opts -> opts { optUnsafe = True }))+        "use 'unsafeSend' (ignored with -f) - default = False"+    , Option ['p'] ["parallel"]+        (NoArg (\opts -> opts { optParallel = True }))+        "send in parallel and consume sequentially - default = False"+    ]++optMsgCnt :: Maybe String -> Options -> Options+optMsgCnt Nothing  opts = opts+optMsgCnt (Just c) opts = opts { optIterations = ((read c) :: Int) }++optSz :: Maybe String -> Options -> Options+optSz Nothing  opts = opts+optSz (Just s) opts = opts { optRingSize = ((read s) :: Int) }++parseArgv :: [String] -> IO (Options, [String])+parseArgv argv = do+  pn <- getProgName+  case getOpt Permute options argv of+    (o,n,[]  ) -> return (foldl (flip id) defaultOptions o, n)+    (_,_,errs) -> ioError (userError (concat errs ++ usageInfo (header pn) options))+  where header pn' = "Usage: " ++ pn' ++ " [OPTION...]"++main :: IO ()+main = do+  argv <- getArgs+  (opt, _) <- parseArgv argv+  putStrLn $ "options: " ++ (show opt)+  Right transport <- createTransport+                        (defaultTCPAddr "127.0.0.1" "8090" ) defaultTCPParameters+  node <- newLocalNode transport initRemoteTable+  catch (void $ runProcess node $ initialProcess opt)+        (\(e :: SomeException) -> putStrLn $ "ERROR: " ++ (show e))
benchmarks/Spawns.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE BangPatterns #-}+ -- | Like Throughput, but send every ping from a different process -- (i.e., require a lightweight connection per ping) import System.Environment@@ -5,7 +7,7 @@ import Control.Applicative import Control.Distributed.Process import Control.Distributed.Process.Node-import Network.Transport.TCP (createTransport, defaultTCPParameters)+import Network.Transport.TCP (createTransport, defaultTCPAddr, defaultTCPParameters) import Data.Binary (encode, decode) import qualified Data.ByteString.Lazy as BSL @@ -40,6 +42,8 @@ main :: IO () main = do   [role, host, port] <- getArgs-  Right transport <- createTransport host port defaultTCPParameters-  node <- newLocalNode transport initRemoteTable-  runProcess node $ initialProcess role+  trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters+  case trans of+    Right transport -> do node <- newLocalNode transport initRemoteTable+                          runProcess node $ initialProcess role+    Left other -> error $ show other
benchmarks/Throughput.hs view
@@ -1,10 +1,12 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-}+ import System.Environment import Control.Monad import Control.Applicative import Control.Distributed.Process import Control.Distributed.Process.Node-import Network.Transport.TCP (createTransport, defaultTCPParameters)+import Network.Transport.TCP (createTransport, defaultTCPParameters, defaultTCPAddr) import Data.Binary import qualified Data.ByteString.Lazy as BSL import Data.Typeable@@ -65,6 +67,8 @@ main :: IO () main = do   [role, host, port] <- getArgs-  Right transport <- createTransport host port defaultTCPParameters-  node <- newLocalNode transport initRemoteTable-  runProcess node $ initialProcess role+  trans <- createTransport (defaultTCPAddr host port) defaultTCPParameters+  case trans of+    Right transport -> do node <- newLocalNode transport initRemoteTable+                          runProcess node $ initialProcess role+    Left other -> error $ show other
distributed-process.cabal view
@@ -1,203 +1,176 @@+cabal-version: 3.0 Name:          distributed-process-Version:       0.4.2-Cabal-Version: >=1.8+Version:       0.7.8 Build-Type:    Simple-License:       BSD3+License:       BSD-3-Clause License-File:  LICENSE-Copyright:     Well-Typed LLP+Copyright:     Well-Typed LLP, Tweag I/O Limited Author:        Duncan Coutts, Nicolas Wu, Edsko de Vries-Maintainer:    watson.timothy@gmail.com, edsko@well-typed.com, duncan@well-typed.com+maintainer:    The Distributed Haskell team Stability:     experimental-Homepage:      http://github.com/haskell-distributed/distributed-process-Bug-Reports:   http://github.com/haskell-distributed/distributed-process/issues+Homepage:      https://haskell-distributed.github.io/+Bug-Reports:   https://github.com/haskell-distributed/distributed-process/issues Synopsis:      Cloud Haskell: Erlang-style concurrency in Haskell Description:   This is an implementation of Cloud Haskell, as described in                /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black,                and Simon Peyton Jones-               (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),+               (<https://simon.peytonjones.org/haskell-cloud/>),                although some of the details are different. The precise message                passing semantics are based on /A unified semantics for future Erlang/-               by Hans Svensson, Lars-Åke Fredlund and Clara Benac Earle.+               by Hans Svensson, Lars-&#xc5;ke Fredlund and Clara Benac Earle.                 You will probably also want to install a Cloud Haskell backend such                as distributed-process-simplelocalnet.-Tested-With:   GHC==7.2.2 GHC==7.4.1 GHC==7.4.2+tested-with:   GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 GHC==9.12.1 Category:      Control+extra-doc-files: ChangeLog -Source-Repository head+common warnings+    ghc-options: -Wall+                 -Wcompat+                 -Widentities+                 -Wincomplete-uni-patterns+                 -Wincomplete-record-updates+                 -Wredundant-constraints+                 -fhide-source-paths+                 -Wpartial-fields+                 -Wunused-packages++source-repository head   Type:     git   Location: https://github.com/haskell-distributed/distributed-process-  SubDir:   distributed-process+  SubDir:   packages/distributed-process  flag th   description: Build with Template Haskell support   default: True -flag benchmarks-  description: Build benchmarks-  default: False- Library-  Build-Depends:     base >= 4.4 && < 5,-                     binary >= 0.5 && < 0.7,-                     network-transport >= 0.3 && < 0.4,-                     stm >= 2.3 && < 2.5,-                     transformers >= 0.2 && < 0.4,-                     mtl >= 2.0 && < 2.2,+  import:            warnings+  Build-Depends:     base >= 4.14 && < 5,+                     binary >= 0.8 && < 0.10,+                     hashable >= 1.2.0.5 && < 1.6,+                     network-transport >= 0.4.1.0 && < 0.6,+                     stm >= 2.4 && < 2.6,+                     mtl >= 2.0 && < 2.4,                      data-accessor >= 0.2 && < 0.3,-                     bytestring >= 0.9 && < 0.11,-                     containers >= 0.4 && < 0.6,-                     old-locale >= 1.0 && < 1.1,-                     time >= 1.2 && < 1.5,-                     random >= 1.0 && < 1.1,-                     ghc-prim >= 0.2 && < 0.4,-                     distributed-static >= 0.2 && < 0.3,-                     rank1dynamic >= 0.1 && < 0.2,-                     syb >= 0.3 && < 0.4-  Exposed-modules:   Control.Distributed.Process,-                     Control.Distributed.Process.Serializable,-                     Control.Distributed.Process.Closure,-                     Control.Distributed.Process.Node,-                     Control.Distributed.Process.Internal.Primitives,-                     Control.Distributed.Process.Internal.CQueue,-                     Control.Distributed.Process.Internal.Types,-                     Control.Distributed.Process.Internal.Trace,-                     Control.Distributed.Process.Internal.Closure.BuiltIn,-                     Control.Distributed.Process.Internal.Messaging,-                     Control.Distributed.Process.Internal.StrictList,-                     Control.Distributed.Process.Internal.StrictMVar,-                     Control.Distributed.Process.Internal.WeakTQueue+                     bytestring >= 0.10 && < 0.13,+                     random >= 1.0 && < 1.4,+                     distributed-static >= 0.2 && < 0.4,+                     rank1dynamic >= 0.1 && < 0.5,+                     syb >= 0.3 && < 0.8,+                     exceptions >= 0.10,+                     containers >= 0.6 && < 0.8,+                     deepseq >= 1.4 && < 1.7,+                     time >= 1.9+  Exposed-modules:   Control.Distributed.Process+                     Control.Distributed.Process.Closure+                     Control.Distributed.Process.Debug+                     Control.Distributed.Process.Internal.BiMultiMap+                     Control.Distributed.Process.Internal.Closure.BuiltIn+                     Control.Distributed.Process.Internal.Closure.Explicit+                     Control.Distributed.Process.Internal.CQueue+                     Control.Distributed.Process.Internal.Messaging+                     Control.Distributed.Process.Internal.Primitives+                     Control.Distributed.Process.Internal.Spawn                      Control.Distributed.Process.Internal.StrictContainerAccessors-  Extensions:        RankNTypes,-                     ScopedTypeVariables,-                     FlexibleInstances,-                     UndecidableInstances,-                     ExistentialQuantification,-                     GADTs,-                     GeneralizedNewtypeDeriving,-                     DeriveDataTypeable,-                     CPP,-                     BangPatterns-  ghc-options:       -Wall+                     Control.Distributed.Process.Internal.StrictList+                     Control.Distributed.Process.Internal.StrictMVar+                     Control.Distributed.Process.Internal.Types+                     Control.Distributed.Process.Internal.WeakTQueue+                     Control.Distributed.Process.Management+                     Control.Distributed.Process.Node+                     Control.Distributed.Process.Serializable+                     Control.Distributed.Process.UnsafePrimitives+                     Control.Distributed.Process.Management.Internal.Agent+                     Control.Distributed.Process.Management.Internal.Bus+                     Control.Distributed.Process.Management.Internal.Types+                     Control.Distributed.Process.Management.Internal.Trace.Primitives+                     Control.Distributed.Process.Management.Internal.Trace.Remote+                     Control.Distributed.Process.Management.Internal.Trace.Types+                     Control.Distributed.Process.Management.Internal.Trace.Tracer+  default-language:  Haskell2010   HS-Source-Dirs:    src+  other-extensions:  BangPatterns+                     CPP+                     DeriveDataTypeable+                     DeriveFunctor+                     DeriveGeneric+                     ExistentialQuantification+                     FlexibleInstances+                     GADTs+                     GeneralizedNewtypeDeriving+                     KindSignatures+                     MagicHash+                     PatternGuards+                     RankNTypes+                     RecordWildCards+                     ScopedTypeVariables+                     StandaloneDeriving+                     TypeFamilies+                     TypeSynonymInstances+                     UnboxedTuples+                     UndecidableInstances   if flag(th)-     Build-Depends:   template-haskell >= 2.6 && < 2.9+     other-extensions: TemplateHaskell+     Build-Depends: template-haskell >= 2.6 && <2.24      Exposed-modules: Control.Distributed.Process.Internal.Closure.TH      CPP-Options:     -DTemplateHaskellSupport -Test-Suite TestCH-  Type:              exitcode-stdio-1.0-  Main-Is:           TestCH.hs-  Build-Depends:     base >= 4.4 && < 5,-                     random >= 1.0 && < 1.1,-                     ansi-terminal >= 0.5 && < 0.6,-                     distributed-process,-                     network-transport >= 0.3 && < 0.4,-                     network-transport-tcp >= 0.3 && < 0.4,-                     binary >= 0.5 && < 0.7,-                     network >= 2.3 && < 2.5,-                     HUnit >= 1.2 && < 1.3,-                     test-framework >= 0.6 && < 0.9,-                     test-framework-hunit >= 0.2.0 && < 0.4-  Extensions:        CPP,-                     ScopedTypeVariables,-                     DeriveDataTypeable,-                     GeneralizedNewtypeDeriving-  ghc-options:       -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind-  HS-Source-Dirs:    tests--Test-Suite TestClosure-  Type:              exitcode-stdio-1.0-  Main-Is:           TestClosure.hs-  Build-Depends:     base >= 4.4 && < 5,-                     random >= 1.0 && < 1.1,-                     ansi-terminal >= 0.5 && < 0.6,-                     distributed-static >= 0.2 && < 0.3,-                     distributed-process,-                     network-transport >= 0.3 && < 0.4,-                     network-transport-tcp >= 0.3 && < 0.4,-                     bytestring >= 0.9 && < 0.11,-                     network >= 2.3 && < 2.5,-                     HUnit >= 1.2 && < 1.3,-                     test-framework >= 0.6 && < 0.9,-                     test-framework-hunit >= 0.2.0 && < 0.4-  Extensions:        CPP,-                     ScopedTypeVariables-  ghc-options:       -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind-  HS-Source-Dirs:    tests--Test-Suite TestStats-  Type:              exitcode-stdio-1.0-  Main-Is:           TestStats.hs-  Build-Depends:     base >= 4.4 && < 5,-                     random >= 1.0 && < 1.1,-                     ansi-terminal >= 0.5 && < 0.6,-                     containers >= 0.4 && < 0.6,-                     stm >= 2.3 && < 2.5,-                     distributed-process,-                     network-transport >= 0.3 && < 0.4,-                     network-transport-tcp >= 0.3 && < 0.4,-                     binary >= 0.5 && < 0.7,-                     network >= 2.3 && < 2.5,-                     HUnit >= 1.2 && < 1.3,-                     test-framework >= 0.6 && < 0.9,-                     test-framework-hunit >= 0.2.0 && < 0.4-  Extensions:        CPP,-                     ScopedTypeVariables,-                     DeriveDataTypeable,-                     GeneralizedNewtypeDeriving-  ghc-options:       -Wall -debug -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind-  HS-Source-Dirs:    tests +-- Tests are in distributed-process-test package, for convenience. +benchmark distributed-process-throughput+  import:           warnings+  Type:             exitcode-stdio-1.0+  Build-Depends:    base >= 4.14 && < 5,+                    distributed-process,+                    network-transport-tcp >= 0.3 && <= 0.9,+                    bytestring >= 0.10 && < 0.13,+                    binary >= 0.8 && < 0.10+  Main-Is:          benchmarks/Throughput.hs+  default-language: Haskell2010 -Executable distributed-process-throughput -  if flag(benchmarks)-    Build-Depends:   base >= 4.4 && < 5,-                     distributed-process,-                     network-transport-tcp >= 0.3 && < 0.4,-                     bytestring >= 0.9 && < 0.11,-                     binary >= 0.5 && < 0.7-  else-    buildable: False-  Main-Is:           benchmarks/Throughput.hs-  ghc-options:       -Wall-  Extensions:        BangPatterns+benchmark distributed-process-latency+  import:           warnings+  Type:             exitcode-stdio-1.0+  Build-Depends:    base >= 4.14 && < 5,+                    distributed-process,+                    network-transport-tcp >= 0.3 && <= 0.9,+                    bytestring >= 0.10 && < 0.13,+                    binary >= 0.8 && < 0.10+  Main-Is:          benchmarks/Latency.hs+  default-language: Haskell2010 -Executable distributed-process-latency-  if flag(benchmarks)-    Build-Depends:   base >= 4.4 && < 5,-                     distributed-process,-                     network-transport-tcp >= 0.3 && < 0.4,-                     bytestring >= 0.9 && < 0.11,-                     binary >= 0.5 && < 0.7-  else-    buildable: False-  Main-Is:           benchmarks/Latency.hs-  ghc-options:       -Wall-  Extensions:        BangPatterns+benchmark distributed-process-channels+  import:           warnings+  Type:             exitcode-stdio-1.0+  Build-Depends:    base >= 4.14 && < 5,+                    distributed-process,+                    network-transport-tcp >= 0.3 && <= 0.9,+                    bytestring >= 0.10 && < 0.13,+                    binary >= 0.8 && < 0.10+  Main-Is:          benchmarks/Channels.hs+  default-language: Haskell2010 -Executable distributed-process-channels-  if flag(benchmarks)-    Build-Depends:   base >= 4.4 && < 5,-                     distributed-process,-                     network-transport-tcp >= 0.3 && < 0.4,-                     bytestring >= 0.9 && < 0.11,-                     binary >= 0.5 && < 0.7-  else-    buildable: False-  Main-Is:           benchmarks/Channels.hs-  ghc-options:       -Wall-  Extensions:        BangPatterns+benchmark distributed-process-spawns+  import:           warnings+  Type:             exitcode-stdio-1.0+  Build-Depends:    base >= 4.14 && < 5,+                    distributed-process,+                    network-transport-tcp >= 0.3 && <= 0.9,+                    bytestring >= 0.10 && < 0.13,+                    binary >= 0.8 && < 0.10+  Main-Is:          benchmarks/Spawns.hs+  default-language: Haskell2010 -Executable distributed-process-spawns-  if flag(benchmarks)-    Build-Depends:   base >= 4.4 && < 5,-                     distributed-process,-                     network-transport-tcp >= 0.3 && < 0.4,-                     bytestring >= 0.9 && < 0.11,-                     binary >= 0.5 && < 0.7-  else-    buildable: False-  Main-Is:           benchmarks/Spawns.hs-  ghc-options:       -Wall-  Extensions:        BangPatterns+benchmark distributed-process-ring+  import:           warnings+  Type:             exitcode-stdio-1.0+  Build-Depends:    base >= 4.14 && < 5,+                    distributed-process,+                    network-transport-tcp >= 0.3 && <= 0.9,+                    bytestring >= 0.10 && < 0.13,+                    binary >= 0.8 && < 0.10+  Main-Is:          benchmarks/ProcessRing.hs+  default-language: Haskell2010+  ghc-options:      -threaded -O2 -rtsopts
src/Control/Distributed/Process.hs view
@@ -1,8 +1,10 @@+{-# LANGUAGE CPP  #-} {- | [Cloud Haskell]  This is an implementation of Cloud Haskell, as described in /Towards Haskell in the Cloud/ by Jeff Epstein, Andrew Black, and Simon-Peyton Jones (<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>),+Peyton Jones (see+<http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/>), although some of the details are different. The precise message passing semantics are based on /A unified semantics for future Erlang/ by Hans Svensson, Lars-Åke Fredlund and Clara Benac Earle.@@ -15,7 +17,7 @@ module Control.Distributed.Process   ( -- * Basic types     ProcessId-  , NodeId+  , NodeId(..)   , Process   , SendPortId   , processNodeId@@ -23,6 +25,7 @@   , liftIO -- Reexported for convenience     -- * Basic messaging   , send+  , usend   , expect   , expectTimeout     -- * Channels@@ -35,6 +38,13 @@   , receiveChanTimeout   , mergePortsBiased   , mergePortsRR+    -- * Unsafe messaging variants+  , unsafeSend+  , unsafeUSend+  , unsafeSendChan+  , unsafeNSend+  , unsafeNSendRemote+  , unsafeWrapMessage     -- * Advanced messaging   , Match   , receiveWait@@ -42,10 +52,25 @@   , match   , matchIf   , matchUnknown-  , AbstractMessage(..)   , matchAny   , matchAnyIf   , matchChan+  , matchSTM+  , Message+  , matchMessage+  , matchMessageIf+  , isEncoded+  , wrapMessage+  , unwrapMessage+  , handleMessage+  , handleMessageIf+  , handleMessage_+  , handleMessageIf_+  , forward+  , uforward+  , delegate+  , relay+  , proxy     -- * Process management   , spawn   , call@@ -62,6 +87,9 @@   , getSelfNode   , ProcessInfo(..)   , getProcessInfo+  , NodeStats(..)+  , getNodeStats+  , getLocalNodeStats     -- * Monitoring and linking   , link   , linkNode@@ -74,6 +102,7 @@   , monitorPort   , unmonitor   , withMonitor+  , withMonitor_   , MonitorRef -- opaque   , ProcessLinkException(..)   , NodeLinkException(..)@@ -110,6 +139,7 @@   , catches   , try   , mask+  , mask_   , onException   , bracket   , bracket_@@ -124,27 +154,27 @@     -- * Local versions of 'spawn'   , spawnLocal   , spawnChannelLocal+  , callLocal     -- * Reconnecting   , reconnect   , reconnectPort   ) where -#if ! MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif--import Data.Typeable (Typeable) import Control.Monad.IO.Class (liftIO)-import Control.Applicative ((<$>))+import Control.Applicative import Control.Monad.Reader (ask)-import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)+import Control.Concurrent (killThread)+import Control.Concurrent.MVar+  ( MVar+  , newEmptyMVar+  , takeMVar+  , putMVar+  ) import Control.Distributed.Static   ( Closure   , closure   , Static   , RemoteTable-  , closureCompose-  , staticClosure   ) import Control.Distributed.Process.Internal.Types   ( NodeId(..)@@ -167,24 +197,14 @@   , WhereIsReply(..)   , RegisterReply(..)   , LocalProcess(processNode)-  , nullProcessId-  )-import Control.Distributed.Process.Serializable (Serializable, SerializableDict)-import Control.Distributed.Process.Internal.Closure.BuiltIn-  ( sdictSendPort-  , sndStatic-  , idCP-  , seqCP-  , bindCP-  , splitCP-  , cpLink-  , cpSend-  , cpNewChan-  , cpDelay+  , Message+  , localProcessWithId   )+import Control.Distributed.Process.Serializable (Serializable) import Control.Distributed.Process.Internal.Primitives   ( -- Basic messaging     send+  , usend   , expect     -- Channels   , newChan@@ -192,6 +212,11 @@   , receiveChan   , mergePortsBiased   , mergePortsRR+  , unsafeSend+  , unsafeUSend+  , unsafeSendChan+  , unsafeNSend+  , unsafeNSendRemote     -- Advanced messaging   , Match   , receiveWait@@ -199,10 +224,25 @@   , match   , matchIf   , matchUnknown-  , AbstractMessage(..)   , matchAny   , matchAnyIf   , matchChan+  , matchSTM+  , matchMessage+  , matchMessageIf+  , isEncoded+  , wrapMessage+  , unsafeWrapMessage+  , unwrapMessage+  , handleMessage+  , handleMessageIf+  , handleMessage_+  , handleMessageIf_+  , forward+  , uforward+  , delegate+  , relay+  , proxy     -- Process management   , terminate   , ProcessTerminationException(..)@@ -215,6 +255,9 @@   , getSelfNode   , ProcessInfo(..)   , getProcessInfo+  , NodeStats(..)+  , getNodeStats+  , getLocalNodeStats     -- Monitoring and linking   , link   , linkNode@@ -227,6 +270,7 @@   , monitorPort   , unmonitor   , withMonitor+  , withMonitor_     -- Logging   , say     -- Registry@@ -249,6 +293,7 @@   , catches   , try   , mask+  , mask_   , onException   , bracket   , bracket_@@ -262,7 +307,27 @@   , reconnectPort   ) import Control.Distributed.Process.Node (forkProcess)+import Control.Distributed.Process.Internal.Types+  ( processThread+  , withValidLocalState+  )+import Control.Distributed.Process.Internal.Spawn+  ( -- Spawning Processes/Channels+    spawn+  , spawnLink+  , spawnMonitor+  , spawnChannel+  , spawnSupervised+  , call+  )+import qualified Control.Monad.Catch as Catch +import Prelude+import qualified Control.Exception as Exception (onException)+import Data.Accessor ((^.))+import Data.Foldable (forM_)++ -- INTERNAL NOTES -- -- 1.  'send' never fails. If you want to know that the remote process received@@ -273,7 +338,11 @@ -- 2.  'send' may block (when the system TCP buffers are full, while we are --     trying to establish a connection to the remote endpoint, etc.) but its --     return does not imply that the remote process received the message (much---     less processed it)+--     less processed it). When 'send' targets a local process, it is dispatched+--     via the node controller however, in which cases it will /not/ block. This+--     isn't part of the semantics, so it should be ok. The ordering is maintained+--     because the ctrlChannel still has FIFO semantics with regards interactions+--     between two disparate forkIO threads. -- -- 3.  Message delivery is reliable and ordered. That means that if process A --     sends messages m1, m2, m3 to process B, B will either arrive all three@@ -323,116 +392,6 @@ --       http://erlang.org/pipermail/erlang-questions/2012-February/064767.html  ----------------------------------------------------------------------------------- Primitives are defined in a separate module; here we only define derived   ----- constructs                                                                 --------------------------------------------------------------------------------------- | Spawn a process------ For more information about 'Closure', see--- "Control.Distributed.Process.Closure".------ See also 'call'.-spawn :: NodeId -> Closure (Process ()) -> Process ProcessId-spawn nid proc = do-  us   <- getSelfPid-  mRef <- monitorNode nid-  sRef <- spawnAsync nid (cpDelay us proc)-  receiveWait [-      matchIf (\(DidSpawn ref _) -> ref == sRef) $ \(DidSpawn _ pid) -> do-        unmonitor mRef-        send pid ()-        return pid-    , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef) $ \_ ->-        return (nullProcessId nid)-    ]---- | Spawn a process and link to it------ Note that this is just the sequential composition of 'spawn' and 'link'.--- (The "Unified" semantics that underlies Cloud Haskell does not even support--- a synchronous link operation)-spawnLink :: NodeId -> Closure (Process ()) -> Process ProcessId-spawnLink nid proc = do-  pid <- spawn nid proc-  link pid-  return pid---- | Like 'spawnLink', but monitor the spawned process-spawnMonitor :: NodeId -> Closure (Process ()) -> Process (ProcessId, MonitorRef)-spawnMonitor nid proc = do-  pid <- spawn nid proc-  ref <- monitor pid-  return (pid, ref)---- | Run a process remotely and wait for it to reply------ We monitor the remote process: if it dies before it can send a reply, we die--- too.------ For more information about 'Static', 'SerializableDict', and 'Closure', see--- "Control.Distributed.Process.Closure".------ See also 'spawn'.-call :: Serializable a-        => Static (SerializableDict a)-        -> NodeId-        -> Closure (Process a)-        -> Process a-call dict nid proc = do-  us <- getSelfPid-  (pid, mRef) <- spawnMonitor nid (proc `bindCP` cpSend dict us)-  -- We are guaranteed to receive the reply before the monitor notification-  -- (if a reply is sent at all)-  -- NOTE: This might not be true if we switch to unreliable delivery.-  mResult <- receiveWait-    [ match (return . Right)-    , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)-              (\(ProcessMonitorNotification _ _ reason) -> return (Left reason))-    ]-  case mResult of-    Right a  -> do-      -- Wait for the monitor message so that we the mailbox doesn't grow-      receiveWait-        [ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)-                  (\(ProcessMonitorNotification {}) -> return ())-        ]-      -- Clean up connection to pid-      reconnect pid-      return a-    Left err ->-      fail $ "call: remote process died: " ++ show err---- | Spawn a child process, have the child link to the parent and the parent--- monitor the child-spawnSupervised :: NodeId-                -> Closure (Process ())-                -> Process (ProcessId, MonitorRef)-spawnSupervised nid proc = do-  us   <- getSelfPid-  them <- spawn nid (cpLink us `seqCP` proc)-  ref  <- monitor them-  return (them, ref)---- | Spawn a new process, supplying it with a new 'ReceivePort' and return--- the corresponding 'SendPort'.-spawnChannel :: forall a. Typeable a => Static (SerializableDict a)-             -> NodeId-             -> Closure (ReceivePort a -> Process ())-             -> Process (SendPort a)-spawnChannel dict nid proc = do-    us <- getSelfPid-    _ <- spawn nid (go us)-    expect-  where-    go :: ProcessId -> Closure (Process ())-    go pid = cpNewChan dict-           `bindCP`-             (cpSend (sdictSendPort dict) pid `splitCP` proc)-           `bindCP`-             (idCP `closureCompose` staticClosure sndStatic)---------------------------------------------------------------------------------- -- Local versions of spawn                                                    -- -------------------------------------------------------------------------------- @@ -458,3 +417,27 @@       liftIO $ putMVar mvar sport       proc rport     takeMVar mvar++-- | Local version of 'call'. Running a process in this way isolates it from+-- messages sent to the caller process, and also allows silently dropping late+-- or duplicate messages sent to the isolated process after it exits.+-- Silently dropping messages may not always be the best approach.+callLocal :: Process a -> Process a+callLocal proc = Catch.mask $ \release -> do+    mv <- liftIO newEmptyMVar :: Process (MVar (Either Catch.SomeException a))+    child <- spawnLocal $ Catch.try (release proc) >>= liftIO . putMVar mv+    lproc <- ask+    liftIO $ do+      rs <- Exception.onException (takeMVar mv) $ Catch.uninterruptibleMask_ $+            -- Exceptions need to be prevented from interrupting the clean up or+            -- the original exception which caused entering the handler could be+            -- forgotten. For instance, this could have a problematic effect+            -- when the original exception was meant to kill the thread and the+            -- second exception doesn't (like the exception thrown by+            -- 'System.Timeout.timeout').+            do mchildThreadId <- withValidLocalState (processNode lproc) $+                 \vst -> return $ fmap processThread $+                           vst ^. localProcessWithId (processLocalId child)+               forM_ mchildThreadId killThread+               takeMVar mv+      either Catch.throwM return rs
src/Control/Distributed/Process/Closure.hs view
@@ -163,6 +163,8 @@   , sdictUnit   , sdictProcessId   , sdictSendPort+  , sdictStatic+  , sdictClosure     -- * The CP type and associated combinators   , CP   , idCP@@ -173,9 +175,17 @@     -- * CP versions of Cloud Haskell primitives   , cpLink   , cpUnlink+  , cpRelay   , cpSend   , cpExpect   , cpNewChan+    -- * Working with static values and closures (without Template Haskell)+  , RemoteRegister+  , MkTDict(..)+  , mkStaticVal+  , mkClosureValSingle+  , mkClosureVal+  , call' #ifdef TemplateHaskellSupport     -- * Template Haskell support for creating static values and closures   , remotable@@ -195,6 +205,8 @@   , sdictUnit   , sdictProcessId   , sdictSendPort+  , sdictStatic+  , sdictClosure     -- The CP type and associated combinators   , CP   , idCP@@ -205,9 +217,19 @@     -- CP versions of Cloud Haskell primitives   , cpLink   , cpUnlink+  , cpRelay   , cpSend   , cpExpect   , cpNewChan+  )+import Control.Distributed.Process.Internal.Closure.Explicit+  (+    RemoteRegister+  , MkTDict(..)+  , mkStaticVal+  , mkClosureValSingle+  , mkClosureVal+  , call'   ) #ifdef TemplateHaskellSupport import Control.Distributed.Process.Internal.Closure.TH
+ src/Control/Distributed/Process/Debug.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE CPP  #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE RankNTypes  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Debug+-- Copyright   :  (c) Well-Typed / Tim Watson+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- [Tracing/Debugging Facilities]+--+-- Cloud Haskell provides a general purpose tracing mechanism, allowing a+-- user supplied /tracer process/ to receive messages when certain classes of+-- system events occur. It's possible to use this facility to aid in debugging+-- and/or perform other diagnostic tasks to a program at runtime.+--+-- [Enabling Tracing]+--+-- Throughout the lifecycle of a local node, the distributed-process runtime+-- generates /trace events/, describing internal runtime activities such as+-- the spawning and death of processes, message sending, delivery and so on.+-- See the 'MxEvent' type's documentation for a list of all the published+-- event types, which correspond directly to the types of /management/ events.+-- Users can additionally publish custom trace events in the form of+-- 'MxLog' log messages or pass custom (i.e., completely user defined)+-- event data using the 'traceMessage' function.+--+-- All published traces are forwarded to a /tracer process/, which can be+-- specified (and changed) at runtime using 'traceEnable'. Some pre-defined+-- tracer processes are provided for conveniently printing to stderr, a log file+-- or the GHC eventlog.+--+-- If a tracer process crashes, no attempt is made to restart it.+--+-- [Working with multiple tracer processes]+--+-- The tracing facility only ever writes to a single tracer process. This+-- invariant insulates the tracer controller and ensures a fast path for+-- handling all trace events. /This/ module provides facilities for layering+-- trace handlers using Cloud Haskell's built-in delegation primitives.+--+-- The 'startTracer' function wraps the registered @tracer@ process with the+-- supplied handler and also forwards trace events to the original tracer.+-- The corresponding 'stopTracer' function terminates tracer processes in+-- reverse of the order in which they were started, and re-registers the+-- previous tracer process.+--+-- [Built in tracers]+--+-- The built in tracers provide a simple /logging/ facility that writes trace+-- events out to either a log file, @stderr@ or the GHC eventlog. These tracers+-- can be configured using environment variables, or specified manually using+-- the 'traceEnable' function.+--+-- When a new local node is started, the contents of several environment+-- variables are checked to determine which default tracer process is selected.+-- If none of these variables is set, a no-op tracer process is installed,+-- which effectively ignores all trace messages. Note that in this case,+-- trace events are still generated and passed through the system.+-- Only one default tracer will be chosen - the first that contains a (valid)+-- value. These environment variables, in the order they're examined, are:+--+-- 1. @DISTRIBUTED_PROCESS_TRACE_FILE@+-- This is checked for a valid file path. If it exists and the file can be+-- opened for writing, all trace output will be directed thence. If the supplied+-- path is invalid, or the file is unavailable for writing, this tracer will not+-- be selected.+--+-- 2. @DISTRIBUTED_PROCESS_TRACE_CONSOLE@+-- This is checked for /any/ non-empty value. If set, then all trace output will+-- be directed to the system logger process.+--+-- 3. @DISTRIBUTED_PROCESS_TRACE_EVENTLOG@+-- This is checked for /any/ non-empty value. If set, all internal traces are+-- written to the GHC eventlog.+--+-- By default, the built in tracers will ignore all trace events! In order to+-- enable tracing the incoming 'MxEvent' stream, the @DISTRIBUTED_PROCESS_TRACE_FLAGS@+-- environment variable accepts the following flags, which enable tracing specific+-- event types:+--+--  * @p@ = trace the spawning of new processes+--  * @d@ = trace the death of processes+--  * @n@ = trace registration of names (i.e., named processes)+--  * @u@ = trace un-registration of names (i.e., named processes)+--  * @s@ = trace the sending of messages to other processes+--  * @r@ = trace the receipt of messages from other processes+--  * @l@ = trace node up/down events+--+-- Users of the /simplelocalnet/ Cloud Haskell backend should also note that+-- because the trace file option only supports trace output from a single node+-- (so as to avoid interleaving), a file trace configured for the master node+-- will prevent slaves from tracing to the file. They will need to fall back to+-- the console or eventlog tracers instead, which can be accomplished by setting+-- one of these environment variables /as well/, since the latter will only be+-- selected on slaves (when the file tracer selection fails).+--+-- Support for writing to the eventlog requires specific intervention to work,+-- without which, written traces are silently dropped/ignored and no output will+-- be generated. The GHC eventlog documentation provides information about+-- enabling, viewing and working with event traces at+-- <http://hackage.haskell.org/trac/ghc/wiki/EventLog>.+--+module Control.Distributed.Process.Debug+  ( -- * Exported Data Types+    TraceArg(..)+  , TraceFlags(..)+  , TraceSubject(..)+    -- * Configuring Tracing+  , enableTrace+  , enableTraceAsync+  , disableTrace+  , withTracer+  , withFlags+  , getTraceFlags+  , setTraceFlags+  , setTraceFlagsAsync+  , defaultTraceFlags+  , traceOn+  , traceOnly+  , traceOff+    -- * Debugging+  , startTracer+  , stopTracer+    -- * Sending Custom Trace Data+  , traceLog+  , traceLogFmt+  , traceMessage+    -- * Working with remote nodes+  , Remote.remoteTable+  , Remote.startTraceRelay+  , Remote.setTraceFlagsRemote+    -- * Built in tracers+  , systemLoggerTracer+  , logfileTracer+  , eventLogTracer+  )+  where++import Control.Applicative+import Control.Distributed.Process.Internal.Primitives+  ( proxy+  , die+  , whereis+  , send+  , receiveWait+  , matchIf+  , monitor+  )+import Control.Distributed.Process.Internal.Types+  ( ProcessId+  , Process+  , LocalProcess(..)+  , ProcessMonitorNotification(..)+  )+import Control.Distributed.Process.Management.Internal.Types+  ( MxEvent(..)+  )+import Control.Distributed.Process.Management.Internal.Trace.Types+  ( TraceArg(..)+  , TraceFlags(..)+  , TraceSubject(..)+  , defaultTraceFlags+  )+import Control.Distributed.Process.Management.Internal.Trace.Tracer+  ( systemLoggerTracer+  , logfileTracer+  , eventLogTracer+  )+import Control.Distributed.Process.Management.Internal.Trace.Primitives+  ( withRegisteredTracer+  , enableTrace+  , enableTraceAsync+  , disableTrace+  , setTraceFlags+  , setTraceFlagsAsync+  , getTraceFlags+  , traceOn+  , traceOff+  , traceOnly+  , traceLog+  , traceLogFmt+  , traceMessage+  )+import qualified Control.Distributed.Process.Management.Internal.Trace.Remote as Remote+import Control.Distributed.Process.Node++import Control.Exception (SomeException)++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ask)+import Control.Monad.Catch (finally, try)++import Data.Binary()++import Prelude++--------------------------------------------------------------------------------+-- Debugging/Tracing API                                                      --+--------------------------------------------------------------------------------++-- | Starts a new tracer, using the supplied trace function.+-- Only one tracer can be registered at a time, however /this/ function overlays+-- the registered tracer with the supplied handler, allowing the user to layer+-- multiple tracers on top of one another, with trace events forwarded down+-- through all the layers in turn. Once the top layer is stopped, the user+-- is responsible for re-registering the original (prior) tracer pid before+-- terminating. See 'withTracer' for a mechanism that handles that.+startTracer :: (MxEvent -> Process ()) -> Process ProcessId+startTracer handler = do+  withRegisteredTracer $ \pid -> do+    node <- processNode <$> ask+    newPid <- liftIO $ forkProcess node $ traceProxy pid handler+    enableTrace newPid  -- invokes sync + registration+    return newPid++-- | Evaluate @proc@ with tracing enabled via @handler@, and immediately+-- disable tracing thereafter, before giving the result (or exception+-- in case of failure).+withTracer :: forall a.+              (MxEvent -> Process ())+           -> Process a+           -> Process (Either SomeException a)+withTracer handler proc = do+    previous <- whereis "tracer"+    tracer <- startTracer handler+    finally (try proc)+            (stopTracing tracer previous)+  where+    stopTracing :: ProcessId -> Maybe ProcessId -> Process ()+    stopTracing tracer previousTracer = do+      case previousTracer of+        Nothing -> return ()+        Just _  -> do+          ref <- monitor tracer+          send tracer MxTraceDisable+          receiveWait [+              matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')+                      (\_ -> return ())+            ]++-- | Evaluate @proc@ with the supplied flags enabled. Any previously set+-- trace flags are restored immediately afterwards.+withFlags :: forall a.+             TraceFlags+          -> Process a+          -> Process (Either SomeException a)+withFlags flags proc = do+  oldFlags <- getTraceFlags+  finally (setTraceFlags flags >> try proc)+          (setTraceFlags oldFlags)++traceProxy :: ProcessId -> (MxEvent -> Process ()) -> Process ()+traceProxy pid act = do+  proxy pid $ \(ev :: MxEvent) ->+    case ev of+      (MxTraceTakeover _) -> return False+      MxTraceDisable      -> die "disabled"+      _                   -> act ev >> return True++-- | Stops a user supplied tracer started with 'startTracer'.+-- Note that only one tracer process can be active at any given time.+-- This process will stop the last process started with 'startTracer'.+-- If 'startTracer' is called multiple times, successive calls to this+-- function will stop the tracers in the reverse order which they were+-- started.+--+-- This function will never stop the system tracer (i.e., the tracer+-- initially started when the node is created), therefore once all user+-- supplied tracers (i.e., processes started via 'startTracer') have exited,+-- subsequent calls to this function will have no effect.+--+-- If the last tracer to have been registered was not started+-- with 'startTracer' then the behaviour of this function is /undefined/.+stopTracer :: Process ()+stopTracer =+  withRegisteredTracer $ \pid -> do+    -- we need to avoid killing the initial (base) tracer, as+    -- nothing we rely on having exactly 1 registered tracer+    -- process at all times.+    basePid <- whereis "tracer.initial"+    case basePid == (Just pid) of+      True  -> return ()+      False -> send pid MxTraceDisable
+ src/Control/Distributed/Process/Internal/BiMultiMap.hs view
@@ -0,0 +1,135 @@+-- | This is an implementation of bidirectional multimaps.+module Control.Distributed.Process.Internal.BiMultiMap+  ( BiMultiMap+  , empty+  , singleton+  , size+  , insert+  , lookupBy1st+  , lookupBy2nd+  , delete+  , deleteAllBy1st+  , deleteAllBy2nd+  , partitionWithKeyBy1st+  , partitionWithKeyBy2nd+  , flip+  ) where++import Data.List (foldl')+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Prelude hiding (flip, lookup)++-- | A bidirectional multimaps @BiMultiMap a b v@ is a set of triplets of type+-- @(a, b, v)@.+--+-- It is possible to lookup values by using either @a@ or @b@ as keys.+--+data BiMultiMap a b v = BiMultiMap !(Map a (Set (b, v))) !(Map b (Set (a, v)))++-- The bidirectional multimap is implemented with a pair of multimaps.+--+-- Each multimap represents a set of triples, and one invariant is that both+-- multimaps should represent exactly the same set of triples.+--+-- Each of the multimaps, however, uses a different component of the triplets+-- as key. This allows to do efficient deletions by any of the two components.++-- | The empty bidirectional multimap.+empty :: BiMultiMap a b v+empty = BiMultiMap Map.empty Map.empty++-- | A bidirectional multimap containing a single triplet.+singleton :: (Ord a, Ord b, Ord v) => a -> b -> v -> BiMultiMap a b v+singleton a b v = insert a b v empty++-- | Yields the amount of triplets in the multimap.+size :: BiMultiMap a b v -> Int+size (BiMultiMap m _) = foldl' (+) 0 $ map Set.size $ Map.elems m++-- | Inserts a triplet in the multimap.+insert :: (Ord a, Ord b, Ord v)+       => a -> b -> v -> BiMultiMap a b v -> BiMultiMap a b v+insert a b v (BiMultiMap m r) =+    BiMultiMap (Map.insertWith (\_new old -> Set.insert (b, v) old)+                               a+                               (Set.singleton (b, v))+                               m)+               (Map.insertWith (\_new old -> Set.insert (a, v) old)+                               b+                               (Set.singleton (a, v))+                               r)++-- | Looks up all the triplets whose first component is the given value.+lookupBy1st :: Ord a => a -> BiMultiMap a b v -> Set (b, v)+lookupBy1st a (BiMultiMap m _) = maybe Set.empty id $ Map.lookup a m++-- | Looks up all the triplets whose second component is the given value.+lookupBy2nd :: Ord b => b -> BiMultiMap a b v -> Set (a, v)+lookupBy2nd b = lookupBy1st b . flip++-- | Deletes a triplet. It yields the original multimap if the triplet is+-- not present.+delete :: (Ord a, Ord b, Ord v)+       => a -> b -> v -> BiMultiMap a b v -> BiMultiMap a b v+delete a b v (BiMultiMap m r) =+  let m' = Map.update (nothingWhen Set.null . Set.delete (b, v)) a m+      r' = Map.update (nothingWhen Set.null . Set.delete (a, v)) b r+   in BiMultiMap m' r'++-- | Deletes all triplets whose first component is the given value.+deleteAllBy1st :: (Ord a, Ord b, Ord v) => a -> BiMultiMap a b v -> BiMultiMap a b v+deleteAllBy1st a (BiMultiMap m r) =+  let (mm, m') = Map.updateLookupWithKey (\_ _ -> Nothing) a m+      r' = case mm of+            Nothing -> r+            Just mb -> reverseDelete a (Set.toList mb) r+   in BiMultiMap m' r'++-- | Like 'deleteAllBy1st' but deletes by the second component of the triplets.+deleteAllBy2nd :: (Ord a, Ord b, Ord v)+               => b -> BiMultiMap a b v -> BiMultiMap a b v+deleteAllBy2nd b = flip . deleteAllBy1st b . flip++-- | Yields the triplets satisfying the given predicate, and a multimap+-- with all this triplets removed.+partitionWithKeyBy1st :: (Ord a, Ord b, Ord v)+                      => (a -> Set (b, v) -> Bool) -> BiMultiMap a b v+                      -> (Map a (Set (b, v)), BiMultiMap a b v)+partitionWithKeyBy1st p (BiMultiMap m r) =+    let (m0, m1) = Map.partitionWithKey p m+        r1 = foldl' (\rr (a, mb) -> reverseDelete a (Set.toList mb) rr) r $+               Map.toList m0+     in (m0, BiMultiMap m1 r1)++-- | Like 'partitionWithKeyBy1st' but the predicates takes the second component+-- of the triplets as first argument.+partitionWithKeyBy2nd :: (Ord a, Ord b, Ord v)+                      => (b -> Set (a, v) -> Bool) -> BiMultiMap a b v+                      -> (Map b (Set (a, v)), BiMultiMap a b v)+partitionWithKeyBy2nd p b = let (m, b') = partitionWithKeyBy1st p $ flip b+                             in (m, flip b')++-- | Exchange the first and the second components of all triplets.+flip :: BiMultiMap a b v -> BiMultiMap b a v+flip (BiMultiMap m r) = BiMultiMap r m++-- Internal functions++-- | @reverseDelete a bs m@ removes from @m@ all the triplets wich have @a@ as+-- first component and second and third components in @bs@.+--+-- The @m@ map is in reversed form, meaning that the second component of the+-- triplets is used as key.+reverseDelete :: (Ord a, Ord b, Ord v)+              => a -> [(b, v)] -> Map b (Set (a, v)) -> Map b (Set (a, v))+reverseDelete a bs r = foldl' (\rr (b, v) -> Map.update (rmb v) b rr) r bs+  where+    rmb v = nothingWhen Set.null . Set.delete (a, v)++-- | @nothingWhen p a@ is @Just a@ when @a@ satisfies predicate @p@.+-- Yields @Nothing@ otherwise.+nothingWhen :: (a -> Bool) -> a -> Maybe a+nothingWhen p a = if p a then Nothing else Just a
src/Control/Distributed/Process/Internal/CQueue.hs view
@@ -1,13 +1,18 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE BangPatterns  #-}+{-# LANGUAGE MagicHash, UnboxedTuples, PatternGuards, ScopedTypeVariables, RankNTypes #-} -- | Concurrent queue for single reader, single writer-{-# LANGUAGE MagicHash, UnboxedTuples, PatternGuards #-} module Control.Distributed.Process.Internal.CQueue   ( CQueue   , BlockSpec(..)   , MatchOn(..)   , newCQueue   , enqueue+  , enqueueSTM   , dequeue   , mkWeakCQueue+  , queueSize   ) where  import Prelude hiding (length, reverse)@@ -15,14 +20,17 @@   ( atomically   , STM   , TChan+  , TVar+  , modifyTVar'   , tryReadTChan   , newTChan+  , newTVarIO   , writeTChan   , readTChan+  , readTVarIO   , orElse   , retry   )-import Control.Applicative ((<$>), (<*>)) import Control.Exception (mask_, onException) import System.Timeout (timeout) import Control.Distributed.Process.Internal.StrictMVar@@ -37,34 +45,54 @@   ) import Data.Maybe (fromJust) import GHC.MVar (MVar(MVar))-import GHC.IO (IO(IO))-import GHC.Prim (mkWeak#)+import GHC.IO (IO(IO), unIO)+import GHC.Exts (mkWeak#) import GHC.Weak (Weak(Weak))  -- We use a TCHan rather than a Chan so that we have a non-blocking read data CQueue a = CQueue (StrictMVar (StrictList a)) -- Arrived                        (TChan a)                   -- Incoming+                       (TVar Int)                 -- Queue size  newCQueue :: IO (CQueue a)-newCQueue = CQueue <$> newMVar Nil <*> atomically newTChan+newCQueue = CQueue <$> newMVar Nil <*> atomically newTChan <*> newTVarIO 0  -- | Enqueue an element -- -- Enqueue is strict. enqueue :: CQueue a -> a -> IO ()-enqueue (CQueue _arrived incoming) !a = atomically $ writeTChan incoming a +enqueue c !a = atomically (enqueueSTM c a) +-- | Variant of enqueue for use in the STM monad.+enqueueSTM :: CQueue a -> a -> STM ()+enqueueSTM (CQueue _arrived incoming size) !a = do+   writeTChan incoming a+   modifyTVar' size succ+ data BlockSpec =     NonBlocking   | Blocking-  | Timeout Int+  | Timeout Int -- ^ Timeout in microseconds +-- Match operations+--+-- They can be either a message match or a channel match. data MatchOn m a  = MatchMsg  (m -> Maybe a)  | MatchChan (STM a)+ deriving (Functor) +-- Lists of chunks of matches+--+-- Two consecutive chunks never have the same kind of matches. i.e. if one chunk+-- contains message matches then the next one must contain channel matches and+-- viceversa. type MatchChunks m a = [Either [m -> Maybe a] [STM a]] +-- Splits a list of matches into chunks.+--+-- > concatMap (either (map MatchMsg) (map MatchChan)) . chunkMatches == id+-- chunkMatches :: [MatchOn m a] -> MatchChunks m a chunkMatches [] = [] chunkMatches (MatchMsg m : ms) = Left (m : chk) : chunkMatches rest@@ -72,6 +100,7 @@ chunkMatches (MatchChan r : ms) = Right (r : chk) : chunkMatches rest    where (chk, rest) = spanMatchChan ms +-- | @spanMatchMsg = first (map (\(MatchMsg x) -> x)) . span isMatchMsg@ spanMatchMsg :: [MatchOn m a] -> ([m -> Maybe a], [MatchOn m a]) spanMatchMsg [] = ([],[]) spanMatchMsg (m : ms)@@ -79,6 +108,7 @@     | otherwise         = ([], m:ms)     where !(msgs,rest) = spanMatchMsg ms +-- | @spanMatchMsg = first (map (\(MatchChan x) -> x)) . span isMatchChan@ spanMatchChan :: [MatchOn m a] -> ([STM a], [MatchOn m a]) spanMatchChan [] = ([],[]) spanMatchChan (m : ms)@@ -95,7 +125,7 @@         -> BlockSpec         -- ^ Blocking behaviour         -> [MatchOn m a]     -- ^ List of matches         -> IO (Maybe a)      -- ^ 'Nothing' only on timeout-dequeue (CQueue arrived incoming) blockSpec matchons =+dequeue (CQueue arrived incoming size) blockSpec matchons = mask_ $ decrementJust $   case blockSpec of     Timeout n -> timeout n $ fmap fromJust run     _other    ->@@ -107,9 +137,17 @@                               -- no onException needed          _other -> run   where+    -- Decrement counter is smth is returned from the queue,+    -- this is safe to use as method is called under a mask+    -- and there is no 'unmasked' operation inside+    decrementJust :: IO (Maybe (Either a a)) -> IO (Maybe a)+    decrementJust f =+       traverse (either return (\x -> decrement >> return x)) =<< f+    decrement = atomically $ modifyTVar' size pred+     chunks = chunkMatches matchons -    run = mask_ $ do+    run = do            arr <- takeMVar arrived            let grabNew xs = do                  r <- atomically $ tryReadTChan incoming@@ -119,17 +157,25 @@            arr' <- grabNew arr            goCheck chunks arr' +    -- Yields the value of the first succesful STM transaction as+    -- @Just (Left v)@. If all transactions fail, yields the value of the second+    -- argument.+    waitChans :: [STM a] -> STM (Maybe (Either a a)) -> STM (Maybe (Either a a))     waitChans ports on_block =-        foldr orElse on_block (map (fmap Just) ports)+        foldr orElse on_block (map (fmap (Just . Left)) ports)      --     -- First check the MatchChunks against the messages already in the     -- mailbox.  For channel matches, we do a non-blocking check at     -- this point.     --+    -- Yields @Just (Left a)@ when a channel is matched, @Just (Right a)@+    -- when a message is matched and @Nothing@ when there are no messages and we+    -- aren't blocking.+    --     goCheck :: MatchChunks m a             -> StrictList m  -- messages to check, in this order-            -> IO (Maybe a)+            -> IO (Maybe (Either a a))      goCheck [] old = goWait old @@ -146,7 +192,7 @@            -- of passing around restore and setting up exception handlers is            -- high.  So just don't use expensive matchIfs!       case checkArrived matches old of-        (old', Just r)  -> returnOld old' (Just r)+        (old', Just r)  -> returnOld old' (Just (Right r))         (old', Nothing) -> goCheck rest old'           -- use the result list, which is now left-biased @@ -175,6 +221,7 @@     -- Contents of 'arrived' from now on is (old ++ new), and     -- messages that arrive are snocced onto new.     --+    goWait :: StrictList m -> IO (Maybe (Either a a))     goWait old = do       r <- waitIncoming `onException` putMVar arrived old       case r of@@ -192,7 +239,7 @@           --           -- Right => message arrived on a channel first           ---          Right a -> returnOld old (Just a)+          Right a -> returnOld old (Just (Left a))      --     -- A message arrived in the process inbox; check the MatchChunks for@@ -201,7 +248,7 @@     goCheck1 :: MatchChunks m a              -> m               -- single message to check              -> StrictList m    -- old messages we have already checked-             -> IO (Maybe a)+             -> IO (Maybe (Either a a))      goCheck1 [] m old = goWait (Snoc old m) @@ -214,16 +261,17 @@     goCheck1 (Left matches : rest) m old = do       case checkMatches matches m of         Nothing -> goCheck1 rest m old-        Just p  -> returnOld old (Just p)+        Just p  -> returnOld old (Just (Right p))      -- a common pattern for putting back the arrived queue at the end-    returnOld :: StrictList m -> Maybe a -> IO (Maybe a)+    returnOld :: StrictList m -> Maybe (Either a a) -> IO (Maybe (Either a a))     returnOld old r = do putMVar arrived old; return r      -- as a side-effect, this left-biases the list     checkArrived :: [m -> Maybe a] -> StrictList m -> (StrictList m, Maybe a)     checkArrived matches list = go list Nil       where+        -- @go xs ys@ searches for a message match in @append xs ys@         go Nil Nil           = (Nil, Nothing)         go Nil r             = go r Nil         go (Append xs ys) tl = go xs (append ys tl)@@ -239,5 +287,8 @@  -- | Weak reference to a CQueue mkWeakCQueue :: CQueue a -> IO () -> IO (Weak (CQueue a))-mkWeakCQueue m@(CQueue (StrictMVar (MVar m#)) _) f = IO $ \s ->-  case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #)+mkWeakCQueue m@(CQueue (StrictMVar (MVar m#)) _ _) f = IO $ \s ->+  case mkWeak# m# m (unIO f) s of (# s1, w #) -> (# s1, Weak w #)++queueSize :: CQueue a -> IO Int+queueSize (CQueue _ _ size) = readTVarIO size
src/Control/Distributed/Process/Internal/Closure/BuiltIn.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE RankNTypes  #-} module Control.Distributed.Process.Internal.Closure.BuiltIn   ( -- * Remote table     remoteTable@@ -6,6 +8,8 @@   , sdictUnit   , sdictProcessId   , sdictSendPort+  , sdictStatic+  , sdictClosure     -- * Some static values   , sndStatic     -- * The CP type and associated combinators@@ -16,13 +20,16 @@   , bindCP   , seqCP     -- * CP versions of Cloud Haskell primitives+  , decodeProcessIdStatic   , cpLink   , cpUnlink+  , cpRelay   , cpSend   , cpExpect   , cpNewChan     -- * Support for some CH operations-  , cpDelay+  , cpDelayed+  , cpEnableTraceRemote   ) where  import Data.ByteString.Lazy (ByteString)@@ -45,6 +52,7 @@ import Control.Distributed.Process.Serializable   ( SerializableDict(..)   , Serializable+  , TypeableDict(..)   ) import Control.Distributed.Process.Internal.Types   ( Process@@ -56,6 +64,7 @@ import Control.Distributed.Process.Internal.Primitives   ( link   , unlink+  , relay   , send   , expect   , newChan@@ -76,12 +85,15 @@     . registerStatic "$sdictUnit"       (toDynamic (SerializableDict :: SerializableDict ()))     . registerStatic "$sdictProcessId"  (toDynamic (SerializableDict :: SerializableDict ProcessId))     . registerStatic "$sdictSendPort_"  (toDynamic (sdictSendPort_   :: SerializableDict ANY -> SerializableDict (SendPort ANY)))+    . registerStatic "$sdictStatic"     (toDynamic (sdictStatic_     :: TypeableDict ANY -> SerializableDict (Static ANY)))+    . registerStatic "$sdictClosure"    (toDynamic (sdictClosure_    :: TypeableDict ANY -> SerializableDict (Closure ANY)))     . registerStatic "$returnProcess"   (toDynamic (return           :: ANY -> Process ANY))     . registerStatic "$seqProcess"      (toDynamic ((>>)             :: Process ANY1 -> Process ANY2 -> Process ANY2))     . registerStatic "$bindProcess"     (toDynamic ((>>=)            :: Process ANY1 -> (ANY1 -> Process ANY2) -> Process ANY2))     . registerStatic "$decodeProcessId" (toDynamic (decode           :: ByteString -> ProcessId))     . registerStatic "$link"            (toDynamic link)     . registerStatic "$unlink"          (toDynamic unlink)+    . registerStatic "$relay"           (toDynamic relay)     . registerStatic "$sendDict"        (toDynamic (sendDict         :: SerializableDict ANY -> ProcessId -> ANY -> Process ()))     . registerStatic "$expectDict"      (toDynamic (expectDict       :: SerializableDict ANY -> Process ANY))     . registerStatic "$newChanDict"     (toDynamic (newChanDict      :: SerializableDict ANY -> Process (SendPort ANY, ReceivePort ANY)))@@ -95,6 +107,12 @@     sdictSendPort_ :: forall a. SerializableDict a -> SerializableDict (SendPort a)     sdictSendPort_ SerializableDict = SerializableDict +    sdictStatic_ :: forall a. TypeableDict a -> SerializableDict (Static a)+    sdictStatic_ TypeableDict = SerializableDict++    sdictClosure_ :: forall a. TypeableDict a -> SerializableDict (Closure a)+    sdictClosure_ TypeableDict = SerializableDict+     sendDict :: forall a. SerializableDict a -> ProcessId -> a -> Process ()     sendDict SerializableDict = send @@ -137,6 +155,14 @@               => Static (SerializableDict a) -> Static (SerializableDict (SendPort a)) sdictSendPort = staticApply (staticLabel "$sdictSendPort_") +-- | Serialization dictionary for 'Static'.+sdictStatic :: Typeable a => Static (TypeableDict a) -> Static (SerializableDict (Static a))+sdictStatic = staticApply (staticLabel "$sdictStatic")++-- | Serialization dictionary for 'Closure'.+sdictClosure :: Typeable a => Static (TypeableDict a) -> Static (SerializableDict (Closure a))+sdictClosure = staticApply (staticLabel "$sdictClosure")+ -------------------------------------------------------------------------------- -- Static values                                                              -- --------------------------------------------------------------------------------@@ -246,6 +272,22 @@                       => Static (SerializableDict a -> Process (SendPort a, ReceivePort a))     newChanDictStatic = staticLabel "$newChanDict" +-- | 'CP' version of 'relay'+cpRelay :: ProcessId -> Closure (Process ())+cpRelay = closure (relayStatic `staticCompose` decodeProcessIdStatic) . encode+  where+    relayStatic :: Static (ProcessId -> Process ())+    relayStatic = staticLabel "$relay"++-- TODO: move cpEnableTraceRemote into Trace/Primitives.hs++cpEnableTraceRemote :: ProcessId -> Closure (Process ())+cpEnableTraceRemote =+    closure (enableTraceStatic `staticCompose` decodeProcessIdStatic) . encode+  where+    enableTraceStatic :: Static (ProcessId -> Process ())+    enableTraceStatic = staticLabel "$enableTraceRemote"+ -------------------------------------------------------------------------------- -- Support for spawn                                                          -- --------------------------------------------------------------------------------@@ -253,19 +295,20 @@ -- | @delay them p@ is a process that waits for a signal (a message of type @()@) -- from 'them' (origin is not verified) before proceeding as @p@. In order to -- avoid waiting forever, @delay them p@ monitors 'them'. If it receives a--- monitor message instead it simply terminates.+-- monitor message instead, it proceeds as @p@ too. delay :: ProcessId -> Process () -> Process () delay them p = do   ref <- monitor them   let sameRef (ProcessMonitorNotification ref' _ _) = ref == ref'   receiveWait [-      match           $ \() -> unmonitor ref >> p+      match           $ \() -> unmonitor ref     , matchIf sameRef $ \_  -> return ()     ]+  p  -- | 'CP' version of 'delay'-cpDelay :: ProcessId -> Closure (Process ()) -> Closure (Process ())-cpDelay = closureApply . cpDelay'+cpDelayed :: ProcessId -> Closure (Process ()) -> Closure (Process ())+cpDelayed = closureApply . cpDelay'   where     cpDelay' :: ProcessId -> Closure (Process () -> Process ())     cpDelay' pid = closure decoder (encode pid)
+ src/Control/Distributed/Process/Internal/Closure/Explicit.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE ScopedTypeVariables+  , MultiParamTypeClasses+  , FlexibleInstances+  , FunctionalDependencies+  , FlexibleContexts+  , UndecidableInstances+  , KindSignatures+  , GADTs+  , EmptyDataDecls+  , TypeOperators+  , DeriveDataTypeable #-}+module Control.Distributed.Process.Internal.Closure.Explicit+  (+    RemoteRegister+  , MkTDict(..)+  , mkStaticVal+  , mkClosureValSingle+  , mkClosureVal+  , call'+  ) where++import Control.Distributed.Static+import Control.Distributed.Process.Serializable+import Control.Distributed.Process.Internal.Closure.BuiltIn+  ( -- Static dictionaries and associated operations+    staticDecode+  )+import Control.Distributed.Process+import Data.Rank1Dynamic+import Data.Rank1Typeable+import Data.Binary(encode,put,get,Binary)+import qualified Data.ByteString.Lazy as B+import Data.Kind (Type)++-- | A RemoteRegister is a trasformer on a RemoteTable to register additional static values.+type RemoteRegister = RemoteTable -> RemoteTable++-- | This takes an explicit name and a value, and produces both a static reference to the name and a RemoteRegister for it.+mkStaticVal :: Serializable a => String -> a -> (Static a, RemoteRegister)+mkStaticVal n v = (staticLabel n_s, registerStatic n_s (toDynamic v))+    where n_s = n++class MkTDict a where+    mkTDict :: String -> a -> RemoteRegister++instance (Serializable b) => MkTDict (Process b) where+    mkTDict _ _ = registerStatic (show (typeOf (undefined :: b)) ++ "__staticDict") (toDynamic (SerializableDict :: SerializableDict b))++instance MkTDict a where+    mkTDict _ _ = id++-- | This takes an explicit name, a function of arity one, and creates a creates a function yielding a closure and a remote register for it.+mkClosureValSingle :: forall a b. (Serializable a, Typeable b, MkTDict b) => String -> (a -> b) -> (a -> Closure b, RemoteRegister)+mkClosureValSingle n v = (c, registerStatic n_s (toDynamic v) .+                             registerStatic n_sdict (toDynamic sdict) .+                             mkTDict n_tdict (undefined :: b)+                         ) where+    n_s = n+    n_sdict = n ++ "__sdict"+    n_tdict = n ++ "__tdict"++    c = closure decoder . encode++    decoder = (staticLabel n_s :: Static (a -> b)) `staticCompose` staticDecode (staticLabel n_sdict :: Static (SerializableDict a))++    sdict :: (SerializableDict a)+    sdict = SerializableDict++-- | This takes an explict name, a function of any arity, and creates a function yielding a closure and a remote register for it.+mkClosureVal :: forall func argTuple result closureFunction.+                (Curry (argTuple -> Closure result) closureFunction,+                 MkTDict result,+                 Uncurry HTrue argTuple func result,+                 Typeable result, Serializable argTuple, IsFunction func HTrue) =>+                String -> func -> (closureFunction, RemoteRegister)+mkClosureVal n v = (curryFun c, rtable)+    where+      uv :: argTuple -> result+      uv = uncurry' reify v++      n_s = n+      n_sdict = n ++ "__sdict"+      n_tdict = n ++ "__tdict"++      c :: argTuple -> Closure result+      c = closure decoder . encode++      decoder :: Static (B.ByteString -> result)+      decoder = (staticLabel n_s :: Static (argTuple -> result)) `staticCompose` staticDecode (staticLabel n_sdict :: Static (SerializableDict argTuple))++      rtable = registerStatic n_s (toDynamic uv) .+               registerStatic n_sdict (toDynamic sdict) .+               mkTDict n_tdict (undefined :: result)+++      sdict :: (SerializableDict argTuple)+      sdict = SerializableDict++-- | Works just like standard call, but with a simpler signature.+call' :: forall a. Serializable a => NodeId -> Closure (Process a) -> Process a+call' = call (staticLabel $ (show $ typeOf $ (undefined :: a)) ++ "__staticDict")+++data EndOfTuple deriving Typeable+instance Binary EndOfTuple where+    put _ = return ()+    get = return undefined++-- This generic curry is straightforward+class Curry a b | a -> b where+    curryFun :: a -> b++instance Curry ((a, EndOfTuple) -> b) (a -> b) where+    curryFun f = \x -> f (x,undefined)++instance Curry (b -> c) r => Curry ((a,b) -> c) (a -> r) where+    curryFun f = \x -> curryFun (\y -> (f (x,y)))+++-- This generic uncurry courtesy Andrea Vezzosi+data HTrue+data HFalse+data Fun :: Type -> Type -> Type -> Type where+  Done :: Fun EndOfTuple r r+  Moar :: Fun xs f r -> Fun (x,xs) (x -> f) r++class Uncurry'' args func result | func -> args, func -> result, args result -> func where+    reify :: Fun args func result++class Uncurry flag args func result | flag func -> args, flag func -> result, args result -> func where+    reify' :: flag -> Fun args func result++instance Uncurry'' rest f r => Uncurry HTrue (a,rest) (a -> f) r where+    reify' _ = Moar reify++instance Uncurry HFalse EndOfTuple a a where+    reify' _ = Done++instance (IsFunction func b, Uncurry b args func result) => Uncurry'' args func result where+    reify = reify' (undefined :: b)++uncurry' :: Fun args func result -> func -> args -> result+uncurry' Done r _ = r+uncurry' (Moar fun) f (x,xs) = uncurry' fun (f x) xs++class IsFunction t b | t -> b+instance (b ~ HTrue) => IsFunction (a -> c) b+instance (b ~ HFalse) => IsFunction a b+
src/Control/Distributed/Process/Internal/Closure/TH.hs view
@@ -1,5 +1,5 @@ -- | Template Haskell support-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell, CPP #-} module Control.Distributed.Process.Internal.Closure.TH   ( -- * User-level API     remotable@@ -12,7 +12,6 @@   ) where  import Prelude hiding (succ, any)-import Control.Applicative ((<$>)) import Language.Haskell.TH   ( -- Q monad and operations     Q@@ -28,8 +27,18 @@   , Exp   , Type(AppT, ForallT, VarT, ArrowT)   , Info(VarI)+#if MIN_VERSION_template_haskell(2,17,0)+  , Specificity+#endif   , TyVarBndr(PlainTV, KindedTV)-  , Pred(ClassP)+  , Pred+#if MIN_VERSION_template_haskell(2,10,0)+  , conT+  , appT+#else+  , classP+#endif+  , varT     -- Lifted constructors     -- .. Literals   , stringL@@ -196,7 +205,11 @@            , concat [register, registerSDict, registerTDict]            )   where+#if MIN_VERSION_template_haskell(2,17,0)+    makeStatic :: [TyVarBndr Specificity] -> Type -> Q ([Dec], [Q Exp])+#else     makeStatic :: [TyVarBndr] -> Type -> Q ([Dec], [Q Exp])+#endif     makeStatic typVars typ = do       static <- generateStatic origName typVars typ       let dyn = case typVars of@@ -215,7 +228,12 @@              )  -- | Turn a polymorphic type into a monomorphic type using ANY and co+#if MIN_VERSION_template_haskell(2,17,0)+monomorphize :: [TyVarBndr Specificity] -> Type -> Q Type+#else monomorphize :: [TyVarBndr] -> Type -> Q Type+#endif+ monomorphize tvs =     let subst = zip (map tyVarBndrName tvs) anys     in everywhereM (mkM (applySubst subst))@@ -240,20 +258,33 @@     applySubst s t = gmapM (mkM (applySubst s)) t  -- | Generate a static value+#if MIN_VERSION_template_haskell(2,17,0)+generateStatic :: Name -> [TyVarBndr Specificity] -> Type -> Q [Dec]+#else generateStatic :: Name -> [TyVarBndr] -> Type -> Q [Dec]+#endif generateStatic n xs typ = do     staticTyp <- [t| Static |]     sequence-      [ sigD (staticName n) $+      [ sigD (staticName n) $ do+          txs <- sequence $ map typeable xs           return (ForallT xs-                  (map typeable xs)-                  (staticTyp `AppT` typ)-          )+                  txs+                  (staticTyp `AppT` typ))       , sfnD (staticName n) [| staticLabel $(showFQN n) |]       ]   where-    typeable :: TyVarBndr -> Pred-    typeable tv = ClassP (mkName "Typeable") [VarT (tyVarBndrName tv)]+#if MIN_VERSION_template_haskell(2,17,0)+    typeable :: TyVarBndr Specificity -> Q Pred+#else+    typeable :: TyVarBndr -> Q Pred+#endif+    typeable tv =+#if MIN_VERSION_template_haskell(2,10,0)+      conT (mkName "Typeable") `appT` varT (tyVarBndrName tv)+#else+      classP (mkName "Typeable") [varT (tyVarBndrName tv)]+#endif  -- | Generate a serialization dictionary with name 'n' for type 'typ' generateDict :: Name -> Type -> Q [Dec]@@ -291,7 +322,11 @@ getType name = do   info <- reify name   case info of+#if MIN_VERSION_template_haskell(2,11,0)+    VarI origName typ _   -> return (origName, typ)+#else     VarI origName typ _ _ -> return (origName, typ)+#endif     _                     -> fail $ show name ++ " not found"  -- | Variation on 'funD' which takes a single expression to define the function@@ -299,9 +334,16 @@ sfnD n e = funD n [clause [] (normalB e) []]  -- | The name of a type variable binding occurrence+#if MIN_VERSION_template_haskell(2,17,0)+tyVarBndrName :: TyVarBndr Specificity -> Name+tyVarBndrName (PlainTV n _)    = n+tyVarBndrName (KindedTV n _ _) = n+#else tyVarBndrName :: TyVarBndr -> Name tyVarBndrName (PlainTV n)    = n tyVarBndrName (KindedTV n _) = n+#endif+  -- | Fully qualified name; that is, the name and the _current_ module --
src/Control/Distributed/Process/Internal/Messaging.hs view
@@ -5,6 +5,7 @@   , disconnect   , closeImplicitReconnections   , impliesDeathOf+  , sendCtrlMsg   ) where  import Data.Accessor ((^.), (^=))@@ -12,9 +13,14 @@ import qualified Data.Map as Map (partitionWithKey, elems) import qualified Data.ByteString.Lazy as BSL (toChunks) import qualified Data.ByteString as BSS (ByteString)-import Control.Distributed.Process.Internal.StrictMVar (withMVar, modifyMVar_)+import Control.Distributed.Process.Serializable ()++import Control.Concurrent (forkIO) import Control.Concurrent.Chan (writeChan)+import Control.Exception (mask_) import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ask) import qualified Network.Transport as NT   ( Connection   , send@@ -24,7 +30,10 @@   , close   ) import Control.Distributed.Process.Internal.Types-  ( LocalNode(localState, localEndPoint, localCtrlChan)+  ( LocalNode(localEndPoint, localCtrlChan)+  , withValidLocalState+  , modifyValidLocalState+  , modifyValidLocalState_   , Identifier   , localConnections   , localConnectionBetween@@ -36,12 +45,16 @@   , ProcessSignal(Died)   , DiedReason(DiedDisconnect)   , ImplicitReconnect(WithImplicitReconnect)-  , NodeId-  , ProcessId(processNodeId)+  , NodeId(..)+  , ProcessId(..)+  , LocalNode(..)+  , LocalProcess(..)+  , Process(..)   , SendPortId(sendPortProcessId)   , Identifier(NodeIdentifier, ProcessIdentifier, SendPortIdentifier)   ) import Control.Distributed.Process.Serializable (Serializable)+import Data.Foldable (forM_)  -------------------------------------------------------------------------------- -- Message sending                                                            --@@ -65,7 +78,7 @@   unless didSend $ do     writeChan (localCtrlChan node) NCMsg       { ctrlMsgSender = to-      , ctrlMsgSignal = Died to DiedDisconnect+      , ctrlMsgSignal = Died (NodeIdentifier $ nodeOf to) DiedDisconnect       }  sendBinary :: Binary a@@ -94,7 +107,7 @@                  -> ImplicitReconnect                  -> IO (Maybe NT.Connection) setupConnBetween node from to implicitReconnect = do-    mConn <- NT.connect endPoint+    mConn <- NT.connect (localEndPoint node)                         (nodeAddress . nodeOf $ to)                         NT.ReliableOrdered                         NT.defaultConnectHints@@ -105,14 +118,11 @@           Left _ ->             return Nothing           Right () -> do-            modifyMVar_ nodeState $ return .-              (localConnectionBetween from to ^= Just (conn, implicitReconnect))+            modifyValidLocalState_ node $+              return . (localConnectionBetween from to ^= Just (conn, implicitReconnect))             return $ Just conn       Left _ ->         return Nothing-  where-    endPoint  = localEndPoint node-    nodeState = localState node  connBetween :: LocalNode             -> Identifier@@ -120,33 +130,37 @@             -> ImplicitReconnect             -> IO (Maybe NT.Connection) connBetween node from to implicitReconnect = do-    mConn <- withMVar nodeState $ return . (^. localConnectionBetween from to)+    mConn <- withValidLocalState node $+      return . (^. localConnectionBetween from to)     case mConn of       Just (conn, _) ->         return $ Just conn       Nothing ->         setupConnBetween node from to implicitReconnect-  where-    nodeState = localState node  disconnect :: LocalNode -> Identifier -> Identifier -> IO ()-disconnect node from to =-  modifyMVar_ (localState node) $ \st ->-    case st ^. localConnectionBetween from to of+disconnect node from to = mask_ $ do+  mio <- modifyValidLocalState node $ \vst ->+    case vst ^. localConnectionBetween from to of       Nothing ->-        return st+        return (vst, return ())       Just (conn, _) -> do-        NT.close conn-        return (localConnectionBetween from to ^= Nothing $ st)+        return ( localConnectionBetween from to ^= Nothing $ vst+               , NT.close conn+               )+  forM_ mio forkIO  closeImplicitReconnections :: LocalNode -> Identifier -> IO ()-closeImplicitReconnections node to =-  modifyMVar_ (localState node) $ \st -> do+closeImplicitReconnections node to = mask_ $ do+  mconns <- modifyValidLocalState node $ \vst -> do     let shouldClose (_, to') (_, WithImplicitReconnect) = to `impliesDeathOf` to'         shouldClose _ _ = False-    let (affected, unaffected) = Map.partitionWithKey shouldClose (st ^. localConnections)-    mapM_ (NT.close . fst) (Map.elems affected)-    return (localConnections ^= unaffected $ st)+    let (affected, unaffected) =+          Map.partitionWithKey shouldClose (vst ^. localConnections)+    return ( localConnections ^= unaffected $ vst+           , map fst $ Map.elems affected+           )+  forM_ mconns $ forkIO . mapM_ NT.close  -- | @a `impliesDeathOf` b@ is true if the death of @a@ (for instance, a node) -- implies the death of @b@ (for instance, a process on that node)@@ -167,3 +181,27 @@   cid' == cid _ `impliesDeathOf` _ =   False+++-- Send a control message. Evaluates the message to HNF before sending it.+--+-- The message shouldn't produce more errors when further evaluated. If+-- evaluation threw errors the node controller or the receiver would crash when+-- inspecting it.+sendCtrlMsg :: Maybe NodeId  -- ^ Nothing for the local node+            -> ProcessSignal -- ^ Message to send+            -> Process ()+sendCtrlMsg mNid signal = do+  proc <- ask+  let msg = NCMsg { ctrlMsgSender = ProcessIdentifier (processId proc)+                  , ctrlMsgSignal = signal+                  }+  case mNid of+    Nothing -> do+      liftIO $ writeChan (localCtrlChan (processNode proc)) $! msg+    Just nid ->+      liftIO $ sendBinary (processNode proc)+                          (NodeIdentifier (processNodeId $ processId proc))+                          (NodeIdentifier nid)+                          WithImplicitReconnect+                          msg
src/Control/Distributed/Process/Internal/Primitives.hs view
@@ -1,3 +1,11 @@+{-# LANGUAGE CPP  #-}+{-# LANGUAGE RankNTypes  #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE BangPatterns #-}+ -- | Cloud Haskell primitives -- -- We define these in a separate module so that we don't have to rely on@@ -5,6 +13,7 @@ module Control.Distributed.Process.Internal.Primitives   ( -- * Basic messaging     send+  , usend   , expect     -- * Channels   , newChan@@ -12,6 +21,12 @@   , receiveChan   , mergePortsBiased   , mergePortsRR+    -- * Unsafe messaging variants+  , unsafeSend+  , unsafeUSend+  , unsafeSendChan+  , unsafeNSend+  , unsafeNSendRemote     -- * Advanced messaging   , Match   , receiveWait@@ -19,10 +34,25 @@   , match   , matchIf   , matchUnknown-  , AbstractMessage(..)   , matchAny   , matchAnyIf   , matchChan+  , matchSTM+  , matchMessage+  , matchMessageIf+  , isEncoded+  , wrapMessage+  , unsafeWrapMessage+  , unwrapMessage+  , handleMessage+  , handleMessageIf+  , handleMessage_+  , handleMessageIf_+  , forward+  , uforward+  , delegate+  , relay+  , proxy     -- * Process management   , terminate   , ProcessTerminationException(..)@@ -38,13 +68,19 @@   , getSelfNode   , ProcessInfo(..)   , getProcessInfo+  , NodeStats(..)+  , getNodeStats+  , getLocalNodeStats     -- * Monitoring and linking   , link   , unlink   , monitor   , unmonitor+  , unmonitorAsync   , withMonitor+  , withMonitor_     -- * Logging+  , SayMessage(..)   , say     -- * Registry   , register@@ -66,6 +102,7 @@   , catches   , try   , mask+  , mask_   , onException   , bracket   , bracket_@@ -83,31 +120,32 @@     -- * Reconnecting   , reconnect   , reconnectPort-    -- * Tracing/Debugging-  , trace+    -- * Internal Exports+  , sendCtrlMsg   ) where -#if ! MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif--import Data.Binary (decode)-import Data.Time.Clock (getCurrentTime)+import Data.Binary (Binary(..), Put, Get, decode)+import Data.Time.Clock (getCurrentTime, UTCTime(..))+import Data.Time.Calendar (Day(..)) import Data.Time.Format (formatTime)-import System.Locale (defaultTimeLocale)+import Data.Time.Format (defaultTimeLocale) import System.Timeout (timeout)-import Control.Monad (when)+import Control.Monad (when, void) import Control.Monad.Reader (ask)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Applicative ((<$>))-import Control.Exception (Exception(..), throw, throwIO, SomeException)-import qualified Control.Exception as Ex (catch, mask, try)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Catch+  ( Exception+  , SomeException+  , throwM+  , fromException+  )+import qualified Control.Monad.Catch as Catch+import Control.Applicative import Control.Distributed.Process.Internal.StrictMVar   ( StrictMVar   , modifyMVar   , modifyMVar_   )-import Control.Concurrent.Chan (writeChan) import Control.Concurrent.STM   ( STM   , TVar@@ -124,9 +162,13 @@   ) import Control.Distributed.Process.Serializable (Serializable, fingerprint) import Data.Accessor ((^.), (^:), (^=))-import Control.Distributed.Static (Closure, Static)+import Control.Distributed.Static+  ( Static+  , Closure+  ) import Data.Rank1Typeable (Typeable) import qualified Control.Distributed.Static as Static (unstatic, unclosure)+import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe import Control.Distributed.Process.Internal.Types   ( NodeId(..)   , ProcessId(..)@@ -136,8 +178,9 @@   , Message(..)   , MonitorRef(..)   , SpawnRef(..)-  , NCMsg(..)   , ProcessSignal(..)+  , NodeMonitorNotification(..)+  , ProcessMonitorNotification(..)   , monitorCounter   , spawnCounter   , SendPort(..)@@ -148,6 +191,7 @@   , SendPortId(..)   , Identifier(..)   , ProcessExitException(..)+  , DiedReason(..)   , DidUnmonitor(..)   , DidUnlinkProcess(..)   , DidUnlinkNode(..)@@ -157,9 +201,11 @@   , ProcessRegistrationException(..)   , ProcessInfo(..)   , ProcessInfoNone(..)+  , NodeStats(..)+  , isEncoded   , createMessage-  , runLocalProcess-  , ImplicitReconnect(WithImplicitReconnect, NoImplicitReconnect)+  , createUnencodedMessage+  , ImplicitReconnect( NoImplicitReconnect)   , LocalProcessState   , LocalSendPortId   , messageToPayload@@ -169,14 +215,23 @@   , sendBinary   , sendPayload   , disconnect+  , sendCtrlMsg   )-import qualified Control.Distributed.Process.Internal.Trace as Trace+import Control.Distributed.Process.Management.Internal.Types+  ( MxEvent(..)+  )+import Control.Distributed.Process.Management.Internal.Trace.Types+  ( traceEvent+  ) import Control.Distributed.Process.Internal.WeakTQueue   ( newTQueueIO   , readTQueue   , mkWeakTQueue   )+import Prelude +import Unsafe.Coerce+ -------------------------------------------------------------------------------- -- Basic messaging                                                            -- --------------------------------------------------------------------------------@@ -184,15 +239,58 @@ -- | Send a message send :: Serializable a => ProcessId -> a -> Process () -- This requires a lookup on every send. If we want to avoid that we need to--- modify serializable to allow for stateful (IO) deserialization+-- modify serializable to allow for stateful (IO) deserialization. send them msg = do   proc <- ask-  liftIO $ sendMessage (processNode proc)-                       (ProcessIdentifier (processId proc))-                       (ProcessIdentifier them)-                       NoImplicitReconnect-                       msg+  let us       = processId proc+      node     = processNode proc+      nodeId   = localNodeId node+      destNode = (processNodeId them)+  liftIO $ traceEvent (localEventBus node)+                      (MxSent them us (createUnencodedMessage msg))+  if destNode == nodeId+    then sendLocal them msg+    else liftIO $ sendMessage (processNode proc)+                              (ProcessIdentifier (processId proc))+                              (ProcessIdentifier them)+                              NoImplicitReconnect+                              msg +-- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize+-- and (in the case when the destination process resides on the same local+-- node) therefore ensure that the payload is fully evaluated before it is+-- delivered.+unsafeSend :: Serializable a => ProcessId -> a -> Process ()+unsafeSend = Unsafe.send++-- | Send a message unreliably.+--+-- Unlike 'send', this function is insensitive to 'reconnect'. It will+-- try to send the message regardless of the history of connection failures+-- between the nodes.+--+-- Message passing with 'usend' is ordered for a given sender and receiver+-- if the messages arrive at all.+--+usend :: Serializable a => ProcessId -> a -> Process ()+usend them msg = do+    proc <- ask+    let there = processNodeId them+    let (us, node) = (processId proc, processNode proc)+    let msg' = wrapMessage msg+    liftIO $ traceEvent (localEventBus node) (MxSent them us msg')+    if localNodeId (processNode proc) == there+      then sendLocal them msg+      else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)+                                                     (createMessage msg)++-- | /Unsafe/ variant of 'usend'. This function makes /no/ attempt to serialize+-- the message when the destination process resides on the same local+-- node. Therefore, a local receiver would need to be prepared to cope with any+-- errors resulting from evaluation of the message.+unsafeUSend :: Serializable a => ProcessId -> a -> Process ()+unsafeUSend = Unsafe.usend+ -- | Wait for a message of a specific type expect :: forall a. Serializable a => Process a expect = receiveWait [match return]@@ -201,7 +299,13 @@ -- Channels                                                                   -- -------------------------------------------------------------------------------- --- | Create a new typed channel+-- | Create a new typed channel, bound to the calling Process+--+-- Note that the channel is bound to the lifecycle of the process that evaluates+-- this function, such that when it dies/exits, the channel will no longer+-- function, but will remain accessible. Thus reading from the ReceivePort will+-- fail silently thereafter, blocking indefinitely (unless a timeout is used).+-- newChan :: Serializable a => Process (SendPort a, ReceivePort a) newChan = do     proc <- ask@@ -229,12 +333,27 @@ sendChan :: Serializable a => SendPort a -> a -> Process () sendChan (SendPort cid) msg = do   proc <- ask-  liftIO $ sendBinary (processNode proc)-                      (ProcessIdentifier (processId proc))-                      (SendPortIdentifier cid)-                      NoImplicitReconnect-                      msg+  let node = processNode proc+      pid  = processId proc+      us   = localNodeId node+      them = processNodeId (sendPortProcessId cid)+  liftIO $ traceEvent (localEventBus node) (MxSentToPort pid cid $ wrapMessage msg)+  case them == us of+    True  -> sendChanLocal cid msg+    False -> do+      liftIO $ sendBinary node+                          (ProcessIdentifier pid)+                          (SendPortIdentifier cid)+                          NoImplicitReconnect+                          msg +-- | Send a message on a typed channel. This function makes /no/ attempt to+-- serialize and (in the case when the @ReceivePort@ resides on the same local+-- node) therefore ensure that the payload is fully evaluated before it is+-- delivered.+unsafeSendChan :: Serializable a => SendPort a -> a -> Process ()+unsafeSendChan = Unsafe.sendChan+ -- | Wait for a message on a typed channel receiveChan :: Serializable a => ReceivePort a -> Process a receiveChan = liftIO . atomically . receiveSTM@@ -278,20 +397,26 @@  -- | Opaque type used in 'receiveWait' and 'receiveTimeout' newtype Match b = Match { unMatch :: MatchOn Message (Process b) }+                  deriving (Functor)  -- | Test the matches in order against each message in the queue receiveWait :: [Match b] -> Process b receiveWait ms = do   queue <- processQueue <$> ask-  Just proc <- liftIO $ dequeue queue Blocking (map unMatch ms)-  proc+  mProc <- liftIO $ dequeue queue Blocking (map unMatch ms)+  case mProc of+    Just proc' -> proc'+    Nothing    -> die $ "System Invariant Violation: CQueue.hs returned `Nothing` "+                     ++ "in the absence of a timeout value."  -- | Like 'receiveWait' but with a timeout. -- -- If the timeout is zero do a non-blocking check for matching messages. A -- non-zero timeout is applied only when waiting for incoming messages (that is, -- /after/ we have checked the messages that are already in the mailbox).-receiveTimeout :: Int -> [Match b] -> Process (Maybe b)+receiveTimeout :: Int -- ^ Timeout in microseconds+               -> [Match b] +               -> Process (Maybe b) receiveTimeout t ms = do   queue <- processQueue <$> ask   let blockSpec = if t == 0 then NonBlocking else Timeout t@@ -300,9 +425,26 @@     Nothing   -> return Nothing     Just proc -> Just <$> proc +-- | Match on a typed channel matchChan :: ReceivePort a -> (a -> Process b) -> Match b matchChan p fn = Match $ MatchChan (fmap fn (receiveSTM p)) +-- | Match on an arbitrary STM action.+--+-- This rather unusaul /match primitive/ allows us to compose arbitrary STM+-- actions with checks against our process' mailbox and/or any typed channel+-- @ReceivePort@s we may hold.+--+-- This allows us to process multiple input streams /along with our mailbox/,+-- in just the same way that 'matchChan' supports checking both the mailbox+-- /and/ an arbitrary set of typed channels in one atomic transaction.+--+-- Note there are no ordering guarnatees with respect to these disparate input+-- sources.+--+matchSTM :: STM a -> (a -> Process b) -> Match b+matchSTM stm fn = Match $ MatchChan (fmap fn stm)+ -- | Match against any message of the right type match :: forall a b. Serializable a => (a -> Process b) -> Match b match = matchIf (const True)@@ -310,83 +452,251 @@ -- | Match against any message of the right type that satisfies a predicate matchIf :: forall a b. Serializable a => (a -> Bool) -> (a -> Process b) -> Match b matchIf c p = Match $ MatchMsg $ \msg ->-   case messageFingerprint msg == fingerprint (undefined :: a) of-     True | c decoded -> Just (p decoded)-       where-         decoded :: a-         -- Make sure the value is fully decoded so that we don't hang to-         -- bytestrings when the process calling 'matchIf' doesn't process-         -- the values immediately-         !decoded = decode (messageEncoding msg)-     _ -> Nothing+  case messageFingerprint msg == fingerprint (undefined :: a) of+    False -> Nothing+    True  -> case msg of+      (UnencodedMessage _ m) ->+        let m' = unsafeCoerce m :: a in+        case (c m') of+          True  -> Just (p m')+          False -> Nothing+      (EncodedMessage _ _) ->+        if (c decoded) then Just (p decoded) else Nothing+        where+          decoded :: a+            -- Make sure the value is fully decoded so that we don't hang to+            -- bytestrings when the process calling 'matchIf' doesn't process+            -- the values immediately+          !decoded = decode (messageEncoding msg) --- | Represents a received message and provides two basic operations on it.-data AbstractMessage = AbstractMessage {-    forward :: ProcessId -> Process () -- ^ forward the message to @ProcessId@-  , maybeHandleMessage :: forall a b. (Serializable a)-            => (a -> Process b) -> Process (Maybe b) {- ^ Handle the message.-        If the type of the message matches the type of the first argument to-        the supplied expression, then the expression will be evaluated against-        it. If this runtime type checking fails, then @Nothing@ will be returned-        to indicate the fact. If the check succeeds and evaluation proceeds-        however, the resulting value with be wrapped with @Just@.-    -}-  }+-- | Match against any message, regardless of the underlying (contained) type+matchMessage :: (Message -> Process Message) -> Match Message+matchMessage p = Match $ MatchMsg $ \msg -> Just (p msg) +-- | Match against any message (regardless of underlying type) that satisfies a predicate+matchMessageIf :: (Message -> Bool) -> (Message -> Process Message) -> Match Message+matchMessageIf c p = Match $ MatchMsg $ \msg ->+    case (c msg) of+      True  -> Just (p msg)+      False -> Nothing++-- | Forward a raw 'Message' to the given 'ProcessId'.+forward :: Message -> ProcessId -> Process ()+forward msg them = do+  proc <- ask+  let node     = processNode proc+      us       = processId proc+      nid      = localNodeId node+      destNode = (processNodeId them)+  liftIO $ traceEvent (localEventBus node) (MxSent them us msg)+  if destNode == nid+    then sendCtrlMsg Nothing (LocalSend them msg)+    else liftIO $ sendPayload (processNode proc)+                              (ProcessIdentifier (processId proc))+                              (ProcessIdentifier them)+                              NoImplicitReconnect+                              (messageToPayload msg)++-- | Forward a raw 'Message' to the given 'ProcessId'.+--+-- Unlike 'forward', this function is insensitive to 'reconnect'. It will+-- try to send the message regardless of the history of connection failures+-- between the nodes.+uforward :: Message -> ProcessId -> Process ()+uforward msg them = do+  proc <- ask+  let node     = processNode proc+      us       = processId proc+      nid      = localNodeId node+      destNode = (processNodeId them)+  liftIO $ traceEvent (localEventBus node) (MxSent them us msg)+  if destNode == nid+    then sendCtrlMsg Nothing (LocalSend them msg)+    else sendCtrlMsg (Just destNode) $ UnreliableSend (processLocalId them) msg++-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are+-- 'Serializable' - like the datum they contain - but also note, deserialising+-- such a 'Message' will yield a 'Message', not the type within it! To obtain the+-- wrapped datum, use 'unwrapMessage' or 'handleMessage' with a specific type.+--+-- @+-- do+--    self <- getSelfPid+--    send self (wrapMessage "blah")+--    Nothing  <- expectTimeout 1000000 :: Process (Maybe String)+--    (Just m) <- expectTimeout 1000000 :: Process (Maybe Message)+--    (Just "blah") <- unwrapMessage m :: Process (Maybe String)+-- @+--+wrapMessage :: Serializable a => a -> Message+wrapMessage = createUnencodedMessage -- see [note Serializable UnencodedMessage]++-- | This is the /unsafe/ variant of 'wrapMessage'. See+-- "Control.Distributed.Process.UnsafePrimitives" for details.+unsafeWrapMessage :: Serializable a => a -> Message+unsafeWrapMessage = Unsafe.wrapMessage++-- [note Serializable UnencodedMessage]+-- if we attempt to serialise an UnencodedMessage, it will be converted to an+-- EncodedMessage first, so we're ok here. See 'messageToPayload' in+-- Primitives.hs for the gory details++-- | Attempt to unwrap a raw 'Message'.+-- If the type of the decoded message payload matches the expected type, the+-- value will be returned with @Just@, otherwise @Nothing@ indicates the types+-- do not match.+--+-- This expression, for example, will evaluate to @Nothing@+-- > unwrapMessage (wrapMessage "foobar") :: Process (Maybe Int)+--+-- Whereas this expression, will yield @Just "foo"@+-- > unwrapMessage (wrapMessage "foo") :: Process (Maybe String)+--+unwrapMessage :: forall m a. (Monad m, Serializable a) => Message -> m (Maybe a)+unwrapMessage msg =+  case messageFingerprint msg == fingerprint (undefined :: a) of+    False -> return Nothing :: m (Maybe a)+    True  -> case msg of+      (UnencodedMessage _ ms) ->+        let ms' = unsafeCoerce ms :: a+        in return (Just ms')+      (EncodedMessage _ _) ->+        return (Just (decoded))+        where+          decoded :: a -- note [decoding]+          !decoded = decode (messageEncoding msg)++-- | Attempt to handle a raw 'Message'.+-- If the type of the message matches the type of the first argument to+-- the supplied expression, then the message will be decoded and the expression+-- evaluated against its value. If this runtime type checking fails however,+-- @Nothing@ will be returned to indicate the fact. If the check succeeds and+-- evaluation proceeds, the resulting value with be wrapped with @Just@.+--+-- Intended for use in `catchesExit` and `matchAny` primitives.+--+handleMessage :: forall m a b. (Monad m, Serializable a)+              => Message -> (a -> m b) -> m (Maybe b)+handleMessage msg proc = handleMessageIf msg (const True) proc++-- | Conditionally handle a raw 'Message'.+-- If the predicate @(a -> Bool)@ evaluates to @True@, invokes the supplied+-- handler, other returns @Nothing@ to indicate failure. See 'handleMessage'+-- for further information about runtime type checking.+--+handleMessageIf :: forall m a b . (Monad m, Serializable a)+                => Message+                -> (a -> Bool)+                -> (a -> m b)+                -> m (Maybe b)+handleMessageIf msg c proc = do+  case messageFingerprint msg == fingerprint (undefined :: a) of+    False -> return Nothing :: m (Maybe b)+    True  -> case msg of+      (UnencodedMessage _ ms) ->+        let ms' = unsafeCoerce ms :: a in+        case (c ms') of+          True  -> do { r <- proc ms'; return (Just r) }+          False -> return Nothing :: m (Maybe b)+      (EncodedMessage _ _) ->+        case (c decoded) of+          True  -> do { r <- proc (decoded :: a); return (Just r) }+          False -> return Nothing :: m (Maybe b)+        where+          decoded :: a -- note [decoding]+          !decoded = decode (messageEncoding msg)++-- | As 'handleMessage' but ignores result, which is useful if you don't+-- care whether or not the handler succeeded.+--+handleMessage_ :: forall m a . (Monad m, Serializable a)+               => Message -> (a -> m ()) -> m ()+handleMessage_ msg proc = handleMessageIf_ msg (const True) proc++-- | Conditional version of 'handleMessage_'.+--+handleMessageIf_ :: forall m a . (Monad m, Serializable a)+                => Message+                -> (a -> Bool)+                -> (a -> m ())+                -> m ()+handleMessageIf_ msg c proc = handleMessageIf msg c proc >> return ()+ -- | Match against an arbitrary message. 'matchAny' removes the first available--- message from the process mailbox, and via the 'AbstractMessage' type,--- supports forwarding /or/ handling the message /if/ it is of the correct--- type. If /not/ of the right type, then the 'AbstractMessage'--- @maybeHandleMessage@ function will not evaluate the supplied expression,--- /but/ the message will still have been removed from the process mailbox!+-- message from the process mailbox. To handle arbitrary /raw/ messages once+-- removed from the mailbox, see 'handleMessage' and 'unwrapMessage'. ---matchAny :: forall b. (AbstractMessage -> Process b) -> Match b-matchAny p = Match $ MatchMsg $ Just . p . abstract+matchAny :: forall b. (Message -> Process b) -> Match b+matchAny p = Match $ MatchMsg $ \msg -> Just (p msg) --- | Match against an arbitrary message. 'matchAnyIf' will /only/ remove the--- message from the process mailbox, /if/ the supplied condition matches. The--- success (or failure) of runtime type checks in @maybeHandleMessage@ does not--- count here, i.e., if the condition evaluates to @True@ then the message will+-- | Match against an arbitrary message. Intended for use with 'handleMessage'+-- and 'unwrapMessage', this function /only/ removes a message from the process+-- mailbox, /if/ the supplied condition matches. The success (or failure) of+-- runtime type checks deferred to @handleMessage@ and friends is irrelevant+-- here, i.e., if the condition evaluates to @True@ then the message will -- be removed from the process mailbox and decoded, but that does /not/--- guarantee that an expression passed to @maybeHandleMessage@ will pass the--- runtime type checks and therefore be evaluated. If the types do not match--- up, then @maybeHandleMessage@ returns 'Nothing'.+-- guarantee that an expression passed to @handleMessage@ will pass the+-- runtime type checks and therefore be evaluated.+-- matchAnyIf :: forall a b. (Serializable a)                        => (a -> Bool)-                       -> (AbstractMessage -> Process b)+                       -> (Message -> Process b)                        -> Match b matchAnyIf c p = Match $ MatchMsg $ \msg ->-   case messageFingerprint msg == fingerprint (undefined :: a) of-     True | c decoded -> Just (p (abstract msg))+  case messageFingerprint msg == fingerprint (undefined :: a) of+     True | check -> Just (p msg)        where-         decoded :: a-         -- Make sure the value is fully decoded so that we don't hang to-         -- bytestrings when the calling process doesn't evaluate immediately+         check :: Bool+         !check =+           case msg of+             (EncodedMessage _ _)    -> c decoded+             (UnencodedMessage _ m') -> c (unsafeCoerce m')++         decoded :: a -- note [decoding]          !decoded = decode (messageEncoding msg)      _ -> Nothing -abstract :: Message -> AbstractMessage-abstract msg = AbstractMessage {-    forward = \them -> do-      proc <- ask-      liftIO $ sendPayload (processNode proc)-                           (ProcessIdentifier (processId proc))-                           (ProcessIdentifier them)-                           NoImplicitReconnect-                           (messageToPayload msg)-  , maybeHandleMessage = \(proc :: (a -> Process b)) -> do-      case messageFingerprint msg == fingerprint (undefined :: a) of-        True -> do { r <- proc (decoded :: a); return (Just r) }-          where-            decoded :: a-            !decoded = decode (messageEncoding msg)-        _ -> return Nothing-  }+{- note [decoding]+For an EncodedMessage, we need to ensure the value is fully decoded so that+we don't hang to bytestrings if the calling process doesn't evaluate+immediately. For UnencodedMessage we know (because the fingerprint comparison+succeeds) that unsafeCoerce will not fail.+-}  -- | Remove any message from the queue matchUnknown :: Process b -> Match b matchUnknown p = Match $ MatchMsg (const (Just p)) +-- | Receives messages and forwards them to @pid@ if @p msg == True@.+delegate :: ProcessId -> (Message -> Bool) -> Process ()+delegate pid p = do+  receiveWait [+      matchAny (\m -> case (p m) of+                        True  -> forward m pid+                        False -> return ())+    ]+  delegate pid p++-- | A straight relay that forwards all messages to the supplied pid.+relay :: ProcessId -> Process ()+relay !pid = receiveWait [ matchAny (\m -> forward m pid) ] >> relay pid++-- | Proxies @pid@ and forwards messages whenever @proc@ evaluates to @True@.+-- Unlike 'delegate' the predicate @proc@ runs in the 'Process' monad, allowing+-- for richer proxy behaviour. If @proc@ returns @False@ or the /runtime type check/+-- fails, no action is taken and the proxy process will continue running.+proxy :: Serializable a => ProcessId -> (a -> Process Bool) -> Process ()+proxy pid proc = do+  receiveWait [+      matchAny (\m -> do+                   next <- handleMessage m proc+                   case next of+                     Just True  -> forward m pid+                     Just False -> return ()  -- explicitly ignored+                     Nothing    -> return ()) -- un-routable+    ]+  proxy pid proc+ -------------------------------------------------------------------------------- -- Process management                                                         -- --------------------------------------------------------------------------------@@ -399,14 +709,17 @@  -- | Terminate immediately (throws a ProcessTerminationException) terminate :: Process a-terminate = liftIO $ throwIO ProcessTerminationException+terminate = throwM ProcessTerminationException  -- [Issue #110] -- | Die immediately - throws a 'ProcessExitException' with the given @reason@. die :: Serializable a => a -> Process b die reason = do+-- NOTE: We do /not/ want to use UnencodedMessage here, as the exception+-- could be decoded by a handler passed to 'catchExit', re-thrown or even+-- passed to another process via the tracing mechanism.   pid <- getSelfPid-  liftIO $ throwIO (ProcessExitException pid (createMessage reason))+  throwM (ProcessExitException pid (createMessage reason))  -- | Forceful request to kill a process. Where 'exit' provides an exception -- that can be caught and handled, 'kill' throws an unexposed exception type@@ -439,12 +752,12 @@                        => Process b                        -> (ProcessId -> a -> Process b)                        -> Process b-catchExit act exitHandler = catch act handleExit+catchExit act exitHandler = Catch.catch act handleExit   where     handleExit ex@(ProcessExitException from msg) =         if messageFingerprint msg == fingerprint (undefined :: a)           then exitHandler from decoded-          else liftIO $ throwIO ex+          else throwM ex      where        decoded :: a        -- Make sure the value is fully decoded so that we don't hang to@@ -454,23 +767,23 @@ -- | Lift 'Control.Exception.catches' (almost). -- -- As 'ProcessExitException' stores the exit @reason@ as a typed, encoded--- message, a handler must accept an input of the expected type. In order to+-- message, a handler must accept inputs of the expected type. In order to -- handle a list of potentially different handlers (and therefore input types),--- a handler passed to 'catchesExit' must accept 'AbstractMessage' and return+-- a handler passed to 'catchesExit' must accept 'Message' and return -- @Maybe@ (i.e., @Just p@ if it handled the exit reason, otherwise @Nothing@). ----- See 'maybeHandleMessage' and 'AsbtractMessage' for more details.+-- See 'maybeHandleMessage' and 'Message' for more details. catchesExit :: Process b-            -> [(ProcessId -> AbstractMessage -> (Process (Maybe b)))]+            -> [(ProcessId -> Message -> (Process (Maybe b)))]             -> Process b-catchesExit act handlers = catch act ((flip handleExit) handlers)+catchesExit act handlers = Catch.catch act ((flip handleExit) handlers)   where     handleExit :: ProcessExitException-               -> [(ProcessId -> AbstractMessage -> Process (Maybe b))]+               -> [(ProcessId -> Message -> Process (Maybe b))]                -> Process b-    handleExit ex [] = liftIO $ throwIO ex+    handleExit ex [] = throwM ex     handleExit ex@(ProcessExitException from msg) (h:hs) = do-      r <- h from (abstract msg)+      r <- h from msg       case r of         Nothing -> handleExit ex hs         Just p  -> return p@@ -483,6 +796,31 @@ getSelfNode :: Process NodeId getSelfNode = localNodeId . processNode <$> ask ++-- | Get statistics about the specified node+getNodeStats :: NodeId -> Process (Either DiedReason NodeStats)+getNodeStats nid = do+    selfNode <- getSelfNode+    if nid == selfNode+      then Right `fmap` getLocalNodeStats -- optimisation+      else getNodeStatsRemote selfNode+  where+    getNodeStatsRemote :: NodeId -> Process (Either DiedReason NodeStats)+    getNodeStatsRemote selfNode = do+        sendCtrlMsg (Just nid) $ GetNodeStats selfNode+        bracket (monitorNode nid) unmonitor $ \mRef ->+            receiveWait [ match (\(stats :: NodeStats) -> return $ Right stats)+                        , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef)+                                  (\(NodeMonitorNotification _ _ dr) -> return $ Left dr)+                        ]++-- | Get statistics about our local node+getLocalNodeStats :: Process NodeStats+getLocalNodeStats = do+  self <- getSelfNode+  sendCtrlMsg Nothing $ GetNodeStats self+  receiveWait [ match (\(stats :: NodeStats) -> return stats) ]+ -- | Get information about the specified process getProcessInfo :: ProcessId -> Process (Maybe ProcessInfo) getProcessInfo pid =@@ -552,13 +890,20 @@ -- @withMonitor@ returns, there might still be unreceived monitor -- messages in the queue. ---withMonitor :: ProcessId -> Process a -> Process a-withMonitor pid code = bracket (monitor pid) unmonitor (\_ -> code)-  -- unmonitor blocks waiting for the response, so there's a possibility-  -- that an exception might interrupt withMonitor before the unmonitor-  -- has completed.  I think that's better than making the unmonitor-  -- uninterruptible.+withMonitor :: ProcessId -> (MonitorRef -> Process a) -> Process a+withMonitor pid = bracket (monitor pid) unmonitor +-- | Establishes temporary monitoring of another process.+--+-- @withMonitor_ pid code@ sets up monitoring of @pid@ for the duration+-- of @code@. Note: although monitoring is no longer active when+-- @withMonitor_@ returns, there might still be unreceived monitor+-- messages in the queue.+--+-- Since 0.6.1+withMonitor_ :: ProcessId -> Process a -> Process a+withMonitor_ p = withMonitor p . const+ -- | Remove a link -- -- This is synchronous in the sense that once it returns you are guaranteed@@ -595,12 +940,21 @@ -- | Remove a monitor -- -- This has the same synchronous/asynchronous nature as 'unlink'.+--+-- ProcessMonitorNotification messages for the given MonitorRef are removed from+-- the mailbox. unmonitor :: MonitorRef -> Process () unmonitor ref = do   unmonitorAsync ref   receiveWait [ matchIf (\(DidUnmonitor ref') -> ref' == ref)                         (\_ -> return ())               ]+  -- Discard the notification if any. With the current NC implementation at most+  -- one notification is in the mailbox for any given ref.+  void $ receiveTimeout 0+    [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref' == ref)+              (const $ return ())+    ]  -------------------------------------------------------------------------------- -- Exception handling                                                         --@@ -608,60 +962,56 @@  -- | Lift 'Control.Exception.catch' catch :: Exception e => Process a -> (e -> Process a) -> Process a-catch p h = do-  lproc <- ask-  liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)+catch = Catch.catch+{-# DEPRECATED catch "Use Control.Monad.Catch.catch instead" #-}  -- | Lift 'Control.Exception.try' try :: Exception e => Process a -> Process (Either e a)-try p = do-  lproc <- ask-  liftIO $ Ex.try (runLocalProcess lproc p)+try = Catch.try+{-# DEPRECATED try "Use Control.Monad.Catch.try instead" #-}  -- | Lift 'Control.Exception.mask' mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b-mask p = do-    lproc <- ask-    liftIO $ Ex.mask $ \restore ->-      runLocalProcess lproc (p (liftRestore lproc restore))-  where-    liftRestore :: LocalProcess -> (forall a. IO a -> IO a) -> (forall a. Process a -> Process a)-    liftRestore lproc restoreIO = liftIO . restoreIO . runLocalProcess lproc+mask = Catch.mask+{-# DEPRECATED mask "Use Control.Monad.Catch.mask_ instead" #-} +-- | Lift 'Control.Exception.mask_'+mask_ :: Process a -> Process a+mask_ = Catch.mask_+{-# DEPRECATED mask_ "Use Control.Monad.Catch.mask_ instead" #-}+ -- | Lift 'Control.Exception.onException' onException :: Process a -> Process b -> Process a-onException p what = p `catch` \e -> do _ <- what-                                        liftIO $ throwIO (e :: SomeException)+onException = Catch.onException+{-# DEPRECATED onException "Use Control.Monad.Catch.onException instead" #-}  -- | Lift 'Control.Exception.bracket' bracket :: Process a -> (a -> Process b) -> (a -> Process c) -> Process c-bracket before after thing =-  mask $ \restore -> do-    a <- before-    r <- restore (thing a) `onException` after a-    _ <- after a-    return r+bracket = Catch.bracket+{-# DEPRECATED bracket "Use Control.Monad.Catch.bracket instead" #-}  -- | Lift 'Control.Exception.bracket_' bracket_ :: Process a -> Process b -> Process c -> Process c-bracket_ before after thing = bracket before (const after) (const thing)+bracket_ = Catch.bracket_+{-# DEPRECATED bracket_ "Use Control.Monad.Catch.bracket_ instead" #-}  -- | Lift 'Control.Exception.finally' finally :: Process a -> Process b -> Process a-finally a sequel = bracket_ (return ()) sequel a+finally = Catch.finally+{-# DEPRECATED finally "Use Control.Monad.Catch.finally instead" #-}  -- | You need this when using 'catches' data Handler a = forall e . Exception e => Handler (e -> Process a)  instance Functor Handler where-     fmap f (Handler h) = Handler (fmap f . h)+    fmap f (Handler h) = Handler (fmap f . h)  -- | Lift 'Control.Exception.catches' catches :: Process a -> [Handler a] -> Process a-catches proc handlers = proc `catch` catchesHandler handlers+catches proc handlers = proc `Catch.catch` catchesHandler handlers  catchesHandler :: [Handler a] -> SomeException -> Process a-catchesHandler handlers e = foldr tryHandler (throw e) handlers+catchesHandler handlers e = foldr tryHandler (throwM e) handlers     where tryHandler (Handler handler) res               = case fromException e of                 Just e' -> handler e'@@ -672,7 +1022,9 @@ --------------------------------------------------------------------------------  -- | Like 'expect' but with a timeout-expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)+expectTimeout :: forall a. Serializable a +              => Int  -- ^ Timeout in microseconds+              -> Process (Maybe a) expectTimeout n = receiveTimeout n [match return]  -- | Asynchronous version of 'spawn'@@ -681,7 +1033,10 @@ spawnAsync :: NodeId -> Closure (Process ()) -> Process SpawnRef spawnAsync nid proc = do   spawnRef <- getSpawnRef-  sendCtrlMsg (Just nid) $ Spawn proc spawnRef+  node     <- getSelfNode+  if nid == node+    then sendCtrlMsg Nothing $ Spawn proc spawnRef+    else sendCtrlMsg (Just nid) $ Spawn proc spawnRef   return spawnRef  -- | Monitor a node (asynchronous)@@ -727,27 +1082,60 @@ -- Logging                                                                    -- -------------------------------------------------------------------------------- +data SayMessage = SayMessage { sayTime    :: UTCTime+                             , sayProcess :: ProcessId+                             , sayMessage :: String }+  deriving (Typeable)++-- There is sadly no Show UTCTime instance+instance Show SayMessage where+  showsPrec p msg =+    showParen (p >= 11)+    $ showString "SayMessage "+    . showString (formatTime defaultTimeLocale "%c" (sayTime msg))+    . showChar ' '+    . showsPrec 11 (sayProcess msg) . showChar ' '+    . showsPrec 11 (sayMessage msg) . showChar ' '++instance Binary SayMessage where+  put s = do+    putUTCTime (sayTime s)+    put (sayProcess s)+    put (sayMessage s)+  get = SayMessage <$> getUTCTime <*> get <*> get++-- Sadly there is no Binary UTCTime instance+putUTCTime :: UTCTime -> Put+putUTCTime (UTCTime (ModifiedJulianDay day) tod) = do+  put day+  put (toRational tod)++getUTCTime :: Get UTCTime+getUTCTime = do+  day <- get+  tod <- get+  return $! UTCTime (ModifiedJulianDay day)+                    (fromRational tod)+ -- | Log a string ----- @say message@ sends a message (time, pid of the current process, message)--- to the process registered as 'logger'.  By default, this process simply--- sends the string to 'stderr'. Individual Cloud Haskell backends might--- replace this with a different logger process, however.+-- @say message@ sends a message of type 'SayMessage' with the current time and+-- 'ProcessId' of the current process to the process registered as @logger@. By+-- default, this process simply sends the string to @stderr@. Individual Cloud+-- Haskell backends might replace this with a different logger process, however. say :: String -> Process () say string = do   now <- liftIO getCurrentTime   us  <- getSelfPid-  nsend "logger" (formatTime defaultTimeLocale "%c" now, us, string)+  nsend "logger" (SayMessage now us string)  -------------------------------------------------------------------------------- -- Registry                                                                   -- -------------------------------------------------------------------------------- --- | Register a process with the local registry (asynchronous).--- This version will wait until a response is gotten from the--- management process. The name must not already be registered.--- The process need not be on this node.--- A bad registration will result in a 'ProcessRegistrationException'+-- | Register a process with the local registry (synchronous). The name must not+--  already be registered. The process need not be on this node. A bad+--  registration will result in a 'ProcessRegistrationException' -- -- The process to be registered does not have to be local itself. register :: String -> ProcessId -> Process ()@@ -762,9 +1150,10 @@ registerImpl force label pid = do   mynid <- getSelfNode   sendCtrlMsg Nothing (Register label mynid (Just pid) force)-  receiveWait [ matchIf (\(RegisterReply label' _) -> label == label')-                        (\(RegisterReply _ ok) -> handleRegistrationReply label ok)-              ]+  receiveWait+    [ matchIf (\(RegisterReply label' _ _) -> label == label')+              (\(RegisterReply _ ok owner) -> handleRegistrationReply label ok owner)+    ]  -- | Register a process with a remote registry (asynchronous). --@@ -773,8 +1162,10 @@ -- -- See comments in 'whereisRemoteAsync' registerRemoteAsync :: NodeId -> String -> ProcessId -> Process ()-registerRemoteAsync nid label pid =-  sendCtrlMsg (Just nid) (Register label nid (Just pid) False)+registerRemoteAsync nid label pid = do+    here <- getSelfNode+    sendCtrlMsg (if nid == here then Nothing else Just nid)+                (Register label nid (Just pid) False)  reregisterRemoteAsync :: NodeId -> String -> ProcessId -> Process () reregisterRemoteAsync nid label pid =@@ -787,16 +1178,17 @@ unregister label = do   mynid <- getSelfNode   sendCtrlMsg Nothing (Register label mynid Nothing False)-  receiveWait [ matchIf (\(RegisterReply label' _) -> label == label')-                        (\(RegisterReply _ ok) -> handleRegistrationReply label ok)-              ]+  receiveWait+    [ matchIf (\(RegisterReply label' _ _) -> label == label')+              (\(RegisterReply _ ok owner) -> handleRegistrationReply label ok owner)+    ]  -- | Deal with the result from an attempted registration or unregistration -- by throwing an exception if necessary-handleRegistrationReply :: String -> Bool -> Process ()-handleRegistrationReply label ok =+handleRegistrationReply :: String -> Bool -> Maybe ProcessId -> Process ()+handleRegistrationReply label ok owner =   when (not ok) $-     liftIO $ throwIO $ ProcessRegistrationException label+     throwM $ ProcessRegistrationException label owner  -- | Remove a process from a remote registry (asynchronous). --@@ -825,19 +1217,46 @@ -- use 'monitorNode' and take appropriate action when you receive a -- 'NodeMonitorNotification'). whereisRemoteAsync :: NodeId -> String -> Process ()-whereisRemoteAsync nid label =-  sendCtrlMsg (Just nid) (WhereIs label)+whereisRemoteAsync nid label = do+    here <- getSelfNode+    sendCtrlMsg (if nid == here then Nothing else Just nid) (WhereIs label)  -- | Named send to a process in the local registry (asynchronous) nsend :: Serializable a => String -> a -> Process ()-nsend label msg =-  sendCtrlMsg Nothing (NamedSend label (createMessage msg))+nsend label msg = do+  proc <- ask+  let msg' = createUnencodedMessage msg+  liftIO $ traceEvent (localEventBus (processNode proc))+                      (MxSentToName label (processId proc) msg')+  sendCtrlMsg Nothing (NamedSend label msg') +-- | Named send to a process in the local registry (asynchronous).+-- This function makes /no/ attempt to serialize and (in the case when the+-- destination process resides on the same local node) therefore ensure that+-- the payload is fully evaluated before it is delivered.+unsafeNSend :: Serializable a => String -> a -> Process ()+unsafeNSend = Unsafe.nsend+ -- | Named send to a process in a remote registry (asynchronous) nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()-nsendRemote nid label msg =-  sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))+nsendRemote nid label msg = do+  proc <- ask+  let us = processId proc+  let node = processNode proc+  if localNodeId node == nid+    then nsend label msg+    else let lbl = label ++ "@" ++ show nid in do+            liftIO $ traceEvent (localEventBus node)+                                (MxSentToName lbl us (wrapMessage msg))+            sendCtrlMsg (Just nid) (NamedSend label (createMessage msg)) +-- | Named send to a process in a remote registry (asynchronous)+-- This function makes /no/ attempt to serialize and (in the case when the+-- destination process resides on the same local node) therefore ensure that+-- the payload is fully evaluated before it is delivered.+unsafeNSendRemote :: Serializable a => NodeId -> String -> a -> Process ()+unsafeNSendRemote = Unsafe.nsendRemote+ -------------------------------------------------------------------------------- -- Closures                                                                   -- --------------------------------------------------------------------------------@@ -896,51 +1315,19 @@   liftIO $ disconnect node (ProcessIdentifier us) (SendPortIdentifier (sendPortId them))  ----------------------------------------------------------------------------------- Debugging/Tracing                                                          --+-- Auxiliary functions                                                        -- -------------------------------------------------------------------------------- --- | Send a message to the internal (system) trace facility. If tracing is--- enabled, this will create a custom trace event. Note that several Cloud Haskell--- sub-systems also generate trace events for informational/debugging purposes,--- thus traces generated this way will not be the only output seen.------ Just as with the "Debug.Trace" module, this is a debugging/tracing facility--- for use in development, and should not be used in a production setting ---- which is why the default behaviour is to trace to the GHC eventlog. For a--- general purpose logging facility, you should consider 'say'.------ Trace events can be written to the GHC event log, a text file, or to the--- standard system logger process (see 'say'). The default behaviour for writing--- to the eventlog requires specific intervention to work, without which traces--- are silently dropped/ignored and no output will be generated.--- The GHC eventlog documentation provides information about enabling, viewing--- and working with event traces: <http://hackage.haskell.org/trac/ghc/wiki/EventLog>.------ When a new local node is started, the contents of the environment variable--- @DISTRIBUTED_PROCESS_TRACE_FILE@ are checked for a valid file path. If this--- exists and the file can be opened for writing, all trace output will be directed--- thence. If the environment variable is empty, the path invalid, or the file--- unavailable for writing - e.g., because another node has already started--- tracing to it - then the @DISTRIBUTED_PROCESS_TRACE_CONSOLE@ environment--- variable is checked for /any/ non-empty value. If this is set, then all trace--- output will be directed to the system logger process. If neither evironment--- variable provides a valid trace configuration, all internal traces are written--- to "Debug.Trace.traceEventIO", which writes to the GHC eventlog.------ Users of the /simplelocalnet/ Cloud Haskell backend should also note that--- because the trace file option only supports trace output from a single node--- (so as to avoid interleaving), a file trace configured for the master node will--- prevent slaves from tracing to the file and they will fall back to using the--- console/'say' or eventlog instead.----trace :: String -> Process ()-trace s = do-  node <- processNode <$> ask-  liftIO $ Trace.trace (localTracer node) s+sendLocal :: (Serializable a) => ProcessId -> a -> Process ()+sendLocal to msg =+  sendCtrlMsg Nothing $ LocalSend to (createUnencodedMessage msg) ------------------------------------------------------------------------------------ Auxiliary functions                                                        -----------------------------------------------------------------------------------+sendChanLocal :: (Serializable a) => SendPortId -> a -> Process ()+sendChanLocal spId msg =+  -- we *must* fully serialize/encode the message here, because+  -- attempting to use `unsafeCoerce' in the node controller+  -- won't work since we know nothing about the required type+  sendCtrlMsg Nothing $ LocalPortSend spId (createUnencodedMessage msg)  getMonitorRefFor :: Identifier -> Process MonitorRef getMonitorRefFor ident = do@@ -970,22 +1357,3 @@ -- | Link to a process/node/channel link' :: Identifier -> Process () link' = sendCtrlMsg Nothing . Link---- Send a control message-sendCtrlMsg :: Maybe NodeId  -- ^ Nothing for the local node-            -> ProcessSignal -- ^ Message to send-            -> Process ()-sendCtrlMsg mNid signal = do-  proc <- ask-  let msg = NCMsg { ctrlMsgSender = ProcessIdentifier (processId proc)-                  , ctrlMsgSignal = signal-                  }-  case mNid of-    Nothing -> do-      liftIO $ writeChan (localCtrlChan (processNode proc)) msg-    Just nid ->-      liftIO $ sendBinary (processNode proc)-                          (ProcessIdentifier (processId proc))-                          (NodeIdentifier nid)-                          WithImplicitReconnect-                          msg
+ src/Control/Distributed/Process/Internal/Spawn.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE RankNTypes  #-}+module Control.Distributed.Process.Internal.Spawn+  ( spawn+  , spawnLink+  , spawnMonitor+  , call+  , spawnSupervised+  , spawnChannel+  ) where++import Control.Distributed.Static+  ( Static+  , Closure+  , closureCompose+  , staticClosure+  )+import Control.Distributed.Process.Internal.Types+  ( NodeId(..)+  , ProcessId(..)+  , Process(..)+  , MonitorRef(..)+  , ProcessMonitorNotification(..)+  , NodeMonitorNotification(..)+  , DidSpawn(..)+  , SendPort(..)+  , ReceivePort(..)+  , nullProcessId+  )+import Control.Distributed.Process.Serializable (Serializable, SerializableDict)+import Control.Distributed.Process.Internal.Closure.BuiltIn+  ( sdictSendPort+  , sndStatic+  , idCP+  , seqCP+  , bindCP+  , splitCP+  , cpLink+  , cpSend+  , cpNewChan+  , cpDelayed+  , returnCP+  , sdictUnit+  )+import Control.Distributed.Process.Internal.Primitives+  ( -- Basic messaging+    usend+  , expect+  , receiveWait+  , match+  , matchIf+  , link+  , getSelfPid+  , monitor+  , monitorNode+  , unmonitor+  , spawnAsync+  , reconnect+  )++-- | Spawn a process+--+-- For more information about 'Closure', see+-- "Control.Distributed.Process.Closure".+--+-- See also 'call'.+spawn :: NodeId -> Closure (Process ()) -> Process ProcessId+spawn nid proc = do+  us   <- getSelfPid+  mRef <- monitorNode nid+  sRef <- spawnAsync nid (cpDelayed us proc)+  receiveWait [+      matchIf (\(DidSpawn ref _) -> ref == sRef) $ \(DidSpawn _ pid) -> do+        unmonitor mRef+        usend pid ()+        return pid+    , matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef) $ \_ ->+        return (nullProcessId nid)+    ]++-- | Spawn a process and link to it+--+-- Note that this is just the sequential composition of 'spawn' and 'link'.+-- (The "Unified" semantics that underlies Cloud Haskell does not even support+-- a synchronous link operation)+spawnLink :: NodeId -> Closure (Process ()) -> Process ProcessId+spawnLink nid proc = do+  pid <- spawn nid proc+  link pid+  return pid++-- | Like 'spawnLink', but monitor the spawned process+spawnMonitor :: NodeId -> Closure (Process ()) -> Process (ProcessId, MonitorRef)+spawnMonitor nid proc = do+  pid <- spawn nid proc+  ref <- monitor pid+  return (pid, ref)++-- | Run a process remotely and wait for it to reply+--+-- We monitor the remote process: if it dies before it can send a reply, we die+-- too.+--+-- For more information about 'Static', 'SerializableDict', and 'Closure', see+-- "Control.Distributed.Process.Closure".+--+-- See also 'spawn'.+call :: Serializable a+        => Static (SerializableDict a)+        -> NodeId+        -> Closure (Process a)+        -> Process a+call dict nid proc = do+  us <- getSelfPid+  (pid, mRef) <- spawnMonitor nid (proc `bindCP`+                                   cpSend dict us `seqCP`+                                   -- Delay so the process does not terminate+                                   -- before the response arrives.+                                   cpDelayed us (returnCP sdictUnit ())+                                  )+  mResult <- receiveWait+    [ match $ \a -> usend pid () >> return (Right a)+    , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)+              (\(ProcessMonitorNotification _ _ reason) -> return (Left reason))+    ]+  case mResult of+    Right a  -> do+      -- Wait for the monitor message so that we the mailbox doesn't grow+      receiveWait+        [ matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)+                  (\(ProcessMonitorNotification {}) -> return ())+        ]+      -- Clean up connection to pid+      reconnect pid+      return a+    Left err ->+      fail $ "call: remote process died: " ++ show err++-- | Spawn a child process, have the child link to the parent and the parent+-- monitor the child+spawnSupervised :: NodeId+                -> Closure (Process ())+                -> Process (ProcessId, MonitorRef)+spawnSupervised nid proc = do+  us   <- getSelfPid+  them <- spawn nid (cpLink us `seqCP` proc)+  ref  <- monitor them+  return (them, ref)++-- | Spawn a new process, supplying it with a new 'ReceivePort' and return+-- the corresponding 'SendPort'.+spawnChannel :: forall a. Serializable a => Static (SerializableDict a)+             -> NodeId+             -> Closure (ReceivePort a -> Process ())+             -> Process (SendPort a)+spawnChannel dict nid proc = do+    us <- getSelfPid+    _ <- spawn nid (go us)+    expect+  where+    go :: ProcessId -> Closure (Process ())+    go pid = cpNewChan dict+           `bindCP`+             (cpSend (sdictSendPort dict) pid `splitCP` proc)+           `bindCP`+             (idCP `closureCompose` staticClosure sndStatic)
src/Control/Distributed/Process/Internal/StrictMVar.hs view
@@ -1,33 +1,35 @@ -- | Like Control.Concurrent.MVar.Strict but reduce to HNF, not NF-{-# LANGUAGE MagicHash, UnboxedTuples #-}+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} module Control.Distributed.Process.Internal.StrictMVar   ( StrictMVar(StrictMVar)   , newEmptyMVar   , newMVar   , takeMVar   , putMVar+  , readMVar   , withMVar   , modifyMVar_   , modifyMVar+  , modifyMVarMasked   , mkWeakMVar   ) where -import Control.Applicative ((<$>)) import Control.Monad ((>=>))-import Control.Exception (evaluate)+import Control.Exception (evaluate, mask_, onException) import qualified Control.Concurrent.MVar as MVar   ( MVar   , newEmptyMVar   , newMVar   , takeMVar   , putMVar+  , readMVar   , withMVar   , modifyMVar_   , modifyMVar   ) import GHC.MVar (MVar(MVar))-import GHC.IO (IO(IO))-import GHC.Prim (mkWeak#)+import GHC.IO (IO(IO), unIO)+import GHC.Exts (mkWeak#) import GHC.Weak (Weak(Weak))  newtype StrictMVar a = StrictMVar (MVar.MVar a)@@ -44,6 +46,9 @@ putMVar :: StrictMVar a -> a -> IO () putMVar (StrictMVar v) x = evaluate x >> MVar.putMVar v x +readMVar :: StrictMVar a -> IO a+readMVar (StrictMVar v) = MVar.readMVar v+ withMVar :: StrictMVar a -> (a -> IO b) -> IO b withMVar (StrictMVar v) = MVar.withMVar v @@ -56,6 +61,14 @@     evaluateFst :: (a, b) -> IO (a, b)     evaluateFst (x, y) = evaluate x >> return (x, y) +modifyMVarMasked :: StrictMVar a -> (a -> IO (a, b)) -> IO b+modifyMVarMasked (StrictMVar v) f =+  mask_ $ do+    a      <- MVar.takeMVar v+    (a',b) <- (f a >>= evaluate) `onException` MVar.putMVar v a+    MVar.putMVar v a'+    return b+ mkWeakMVar :: StrictMVar a -> IO () -> IO (Weak (StrictMVar a))-mkWeakMVar m@(StrictMVar (MVar m#)) f = IO $ \s ->-  case mkWeak# m# m f s of (# s1, w #) -> (# s1, Weak w #)+mkWeakMVar q@(StrictMVar (MVar m#)) f = IO $ \s ->+  case mkWeak# m# q (unIO f) s of (# s', w #) -> (# s', Weak w #)
− src/Control/Distributed/Process/Internal/Trace.hs 
@@ -1,122 +0,0 @@--- | Simple (internal) system logging/tracing support.-module Control.Distributed.Process.Internal.Trace-  ( Tracer-  , TraceArg(..)-  , trace-  , traceFormat-  , startTracing-  , stopTracer-  ) where--import Control.Concurrent (forkIO)-import Control.Concurrent.Chan (writeChan)-import Control.Concurrent.STM-  ( TQueue-  , newTQueueIO-  , readTQueue-  , writeTQueue-  , atomically-  )-import Control.Distributed.Process.Internal.Types-  ( Tracer(..)-  , LocalNode(..)-  , NCMsg(..)-  , Identifier(ProcessIdentifier)-  , ProcessSignal(NamedSend)-  , forever'-  , nullProcessId-  , createMessage-  )-import Control.Exception-  ( catch-  , throwTo-  , SomeException-  , AsyncException(ThreadKilled)-  )-import Data.List (intersperse)-import Data.Time.Clock (getCurrentTime)-import Data.Time.Format (formatTime)-import Debug.Trace (traceEventIO)--import Prelude hiding (catch)--import System.Environment (getEnv)-import System.IO-  ( Handle-  , IOMode(AppendMode)-  , BufferMode(..)-  , openFile-  , hClose-  , hPutStrLn-  , hSetBuffering-  )-import System.Locale (defaultTimeLocale)--data TraceArg = -    TraceStr String-  | forall a. (Show a) => Trace a--startTracing :: LocalNode -> IO LocalNode-startTracing node = do-  tracer <- defaultTracer node-  return node { localTracer = tracer }--defaultTracer :: LocalNode -> IO Tracer-defaultTracer node = do-  catch (getEnv "DISTRIBUTED_PROCESS_TRACE_FILE" >>= logfileTracer)-        (\(_ :: IOError) -> defaultTracerAux node)--defaultTracerAux :: LocalNode -> IO Tracer-defaultTracerAux node = do-  catch (getEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" >> procTracer node)-        (\(_ :: IOError) -> return (EventLogTracer traceEventIO))-  where procTracer :: LocalNode -> IO Tracer-        procTracer n = return $ (LocalNodeTracer n)--logfileTracer :: FilePath -> IO Tracer-logfileTracer p = do-    q <- newTQueueIO-    h <- openFile p AppendMode-    hSetBuffering h LineBuffering-    tid <- forkIO $ logger h q `catch` (\(_ :: SomeException) ->-                                         hClose h >> return ())-    return $ LogFileTracer tid q h-  where logger :: Handle -> TQueue String -> IO ()-        logger h q' = forever' $ do-          msg <- atomically $ readTQueue q'-          now <- getCurrentTime-          hPutStrLn h $ msg ++ (formatTime defaultTimeLocale " - %c" now)---- TODO: compatibility layer for GHC/base versions (e.g., where's killThread?)--stopTracer :: Tracer -> IO ()  -- overzealous but harmless duplication of hClose-stopTracer (LogFileTracer tid _ h) = throwTo tid ThreadKilled >> hClose h-stopTracer _                       = return ()--trace :: Tracer -> String -> IO ()-trace (LogFileTracer _ q _) msg = atomically $ writeTQueue q msg-trace (LocalNodeTracer n)   msg = sendTraceMsg n msg-trace (EventLogTracer t)    msg = t msg-trace InactiveTracer        _   = return ()--traceFormat :: Tracer-            -> String-            -> [TraceArg]-            -> IO ()-traceFormat t d ls =-    trace t $ concat (intersperse d (map toS ls))-  where toS :: TraceArg -> String-        toS (TraceStr s) = s-        toS (Trace    a) = show a--sendTraceMsg :: LocalNode -> String -> IO ()-sendTraceMsg node string = do-  now <- getCurrentTime-  msg <- return $ (formatTime defaultTimeLocale "%c" now, string)-  emptyPid <- return $ (nullProcessId (localNodeId node))-  traceMsg <- return $ NCMsg {-                         ctrlMsgSender = ProcessIdentifier (emptyPid)-                       , ctrlMsgSignal = (NamedSend "logger" (createMessage msg))-                       }-  writeChan (localCtrlChan node) traceMsg-
src/Control/Distributed/Process/Internal/Types.hs view
@@ -1,3 +1,13 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE GADTs  #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-}+ -- | Types used throughout the Cloud Haskell framework -- -- We collect all types used internally in a single module because@@ -14,8 +24,14 @@   , nullProcessId     -- * Local nodes and processes   , LocalNode(..)-  , Tracer(..)   , LocalNodeState(..)+  , ValidLocalNodeState(..)+  , NodeClosedException(..)+  , withValidLocalState+  , modifyValidLocalState+  , modifyValidLocalState_+  , Tracer(..)+  , MxEventBus(..)   , LocalProcess(..)   , LocalProcessState(..)   , Process(..)@@ -29,7 +45,10 @@   , ReceivePort(..)     -- * Messages   , Message(..)+  , isEncoded   , createMessage+  , createUnencodedMessage+  , unsafeCreateUnencodedMessage   , messageToPayload   , payloadToMessage     -- * Node controller user-visible data types@@ -53,6 +72,7 @@   , RegisterReply(..)   , ProcessInfo(..)   , ProcessInfoNone(..)+  , NodeStats(..)     -- * Node controller internal data types   , NCMsg(..)   , ProcessSignal(..)@@ -75,7 +95,8 @@ import System.Mem.Weak (Weak) import Data.Map (Map) import Data.Int (Int32)-import Data.Typeable (Typeable)+import Data.Data (Data)+import Data.Typeable (Typeable, typeOf) import Data.Binary (Binary(put, get), putWord8, getWord8, encode) import qualified Data.ByteString as BSS (ByteString, concat, copy) import qualified Data.ByteString.Lazy as BSL@@ -83,19 +104,23 @@   , toChunks   , splitAt   , fromChunks+  , length   ) import qualified Data.ByteString.Lazy.Internal as BSL (ByteString(..)) import Data.Accessor (Accessor, accessor) import Control.Category ((>>>))-import Control.Exception (Exception)+import Control.DeepSeq (NFData(..))+import Control.Exception (Exception, throwIO) import Control.Concurrent (ThreadId) import Control.Concurrent.Chan (Chan) import Control.Concurrent.STM (STM)-import qualified Control.Concurrent.STM as STM (TQueue)+import Control.Concurrent.STM.TChan (TChan)+import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..)) import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)-import Control.Applicative (Applicative, Alternative, (<$>), (<*>))+import Control.Applicative+import Control.Monad.Fix (MonadFix) import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Class (MonadIO(..)) import Control.Distributed.Process.Serializable   ( Fingerprint   , Serializable@@ -106,20 +131,30 @@   , showFingerprint   ) import Control.Distributed.Process.Internal.CQueue (CQueue)-import Control.Distributed.Process.Internal.StrictMVar (StrictMVar)+import Control.Distributed.Process.Internal.StrictMVar+  ( StrictMVar+  , withMVar+  , modifyMVar+  , modifyMVar_+  ) import Control.Distributed.Process.Internal.WeakTQueue (TQueue) import Control.Distributed.Static (RemoteTable, Closure) import qualified Control.Distributed.Process.Internal.StrictContainerAccessors as DAC (mapMaybe)-import System.IO (Handle) +import Data.Hashable+import GHC.Generics+import Prelude+ -------------------------------------------------------------------------------- -- Node and process identifiers                                               -- --------------------------------------------------------------------------------  -- | Node identifier newtype NodeId = NodeId { nodeAddress :: NT.EndPointAddress }-  deriving (Eq, Ord, Binary, Typeable)-+  deriving (Eq, Ord, Typeable, Data, Generic)+instance Binary NodeId where+instance NFData NodeId where rnf (NodeId a) = rnf a `seq` ()+instance Hashable NodeId where instance Show NodeId where   show (NodeId addr) = "nid://" ++ show addr @@ -129,8 +164,10 @@   { lpidUnique  :: {-# UNPACK #-} !Int32   , lpidCounter :: {-# UNPACK #-} !Int32   }-  deriving (Eq, Ord, Typeable, Show)+  deriving (Eq, Ord, Typeable, Data, Generic, Show) +instance Hashable LocalProcessId where+ -- | Process identifier data ProcessId = ProcessId   { -- | The ID of the node the process is running on@@ -138,8 +175,12 @@     -- | Node-local identifier for the process   , processLocalId :: {-# UNPACK #-} !LocalProcessId   }-  deriving (Eq, Ord, Typeable)+  deriving (Eq, Ord, Typeable, Data, Generic) +instance Binary ProcessId where+instance NFData ProcessId where rnf (ProcessId n _) = rnf n `seq` ()+instance Hashable ProcessId where+ instance Show ProcessId where   show (ProcessId (NodeId addr) (LocalProcessId _ lid))     = "pid://" ++ show addr ++ ":" ++ show lid@@ -149,8 +190,14 @@     NodeIdentifier !NodeId   | ProcessIdentifier !ProcessId   | SendPortIdentifier !SendPortId-  deriving (Eq, Ord)+  deriving (Eq, Ord, Generic) +instance Hashable Identifier where+instance NFData Identifier where+  rnf (NodeIdentifier n) = rnf n `seq` ()+  rnf (ProcessIdentifier n) = rnf n `seq` ()+  rnf n@SendPortIdentifier{} = n `seq` ()+ instance Show Identifier where   show (NodeIdentifier nid)     = show nid   show (ProcessIdentifier pid)  = show pid@@ -180,13 +227,31 @@ -- Local nodes and processes                                                  -- -------------------------------------------------------------------------------- --- | Required for system tracing in the node controller-data Tracer =-    LogFileTracer   !ThreadId !(STM.TQueue String) !Handle-  | EventLogTracer  !(String -> IO ())-  | LocalNodeTracer !LocalNode-  | InactiveTracer  -- NB: never used, this is required to initialize LocalNode+-- | Provides access to the trace controller+data Tracer = Tracer+              {+                -- | Process id for the currently active trace handler+                tracerPid :: !ProcessId+                -- | Weak reference to the tracer controller's mailbox+              , weakQ     :: !(Weak (CQueue Message))+              } +-- | Local system management event bus state+data MxEventBus =+    MxEventBusInitialising+  | MxEventBus+    {+      -- | Process id of the management agent controller process+      agent  :: !ProcessId+      -- | Configuration for the local trace controller+    , tracer :: !Tracer+      -- | Weak reference to the management agent controller's mailbox+    , evbuss :: !(Weak (CQueue Message))+      -- | API for adding management agents to a running node+    , mxNew  :: !(((TChan Message, TChan Message) -> Process ()) -> IO ProcessId)+--    , mxReg  :: !(StrictMVar (Map MxAgentId ))+    }+ -- | Local nodes data LocalNode = LocalNode   { -- | 'NodeId' of the node@@ -197,8 +262,8 @@   , localState      :: !(StrictMVar LocalNodeState)     -- | Channel for the node controller   , localCtrlChan   :: !(Chan NCMsg)-    -- | Current active system debug/trace log-  , localTracer     :: !Tracer+    -- | Internal management event bus+  , localEventBus   :: !MxEventBus     -- | Runtime lookup table for supporting closures     -- TODO: this should be part of the CH state, not the local endpoint state   , remoteTable     :: !RemoteTable@@ -208,7 +273,11 @@   deriving (Eq, Show)  -- | Local node state-data LocalNodeState = LocalNodeState+data LocalNodeState =+    LocalNodeValid {-# UNPACK #-} !ValidLocalNodeState+  | LocalNodeClosed++data ValidLocalNodeState = ValidLocalNodeState   { -- | Processes running on this node     _localProcesses   :: !(Map LocalProcessId LocalProcess)     -- | Counter to assign PIDs@@ -221,6 +290,40 @@                                (NT.Connection, ImplicitReconnect))   } +-- | Thrown by some primitives when they notice the node has been closed.+data NodeClosedException = NodeClosedException NodeId+  deriving (Show, Typeable)++instance Exception NodeClosedException++-- | Wrapper around 'withMVar' that checks that the local node is still in+-- a valid state.+withValidLocalState :: LocalNode+                    -> (ValidLocalNodeState -> IO r)+                    -> IO r+withValidLocalState node f = withMVar (localState node) $ \st -> case st of+    LocalNodeValid vst -> f vst+    LocalNodeClosed -> throwIO $ NodeClosedException (localNodeId node)++-- | Wrapper around 'modifyMVar' that checks that the local node is still in+-- a valid state.+modifyValidLocalState :: LocalNode+                      -> (ValidLocalNodeState -> IO (ValidLocalNodeState, a))+                      -> IO (Maybe a)+modifyValidLocalState node f = modifyMVar (localState node) $ \st -> case st of+    LocalNodeValid vst -> do (vst', a) <- f vst+                             return (LocalNodeValid vst', Just a)+    LocalNodeClosed -> return (LocalNodeClosed, Nothing)++-- | Wrapper around 'modifyMVar_' that checks that the local node is still in+-- a valid state.+modifyValidLocalState_ :: LocalNode+                       -> (ValidLocalNodeState -> IO ValidLocalNodeState)+                       -> IO ()+modifyValidLocalState_ node f = modifyMVar_ (localState node) $ \st -> case st of+    LocalNodeValid vst -> LocalNodeValid <$> f vst+    LocalNodeClosed -> return LocalNodeClosed+ -- | Processes running on our local node data LocalProcess = LocalProcess   { processQueue  :: !(CQueue Message)@@ -247,8 +350,51 @@ newtype Process a = Process {     unProcess :: ReaderT LocalProcess IO a   }-  deriving (Functor, Monad, MonadIO, MonadReader LocalProcess, Typeable, Applicative)+  deriving ( Applicative+           , Functor+           , Monad+           , MonadFail+           , MonadFix+           , MonadIO+           , MonadReader LocalProcess+           , Typeable+           ) +instance MonadThrow Process where+  throwM = liftIO . throwIO+instance MonadCatch Process where+  catch p h = do+    lproc <- ask+    liftIO $ catch (runLocalProcess lproc p) (runLocalProcess lproc . h)+instance MonadMask Process where+  generalBracket acquire release inner = do+    lproc <- ask+    liftIO $+      generalBracket (runLocalProcess lproc acquire)+                     (\a e -> runLocalProcess lproc $ release a e)+                     (runLocalProcess lproc . inner)++  mask p = do+      lproc <- ask+      liftIO $ mask $ \restore ->+        runLocalProcess lproc (p (liftRestore restore))+    where+      liftRestore :: (forall a. IO a -> IO a)+                  -> (forall a. Process a -> Process a)+      liftRestore restoreIO = \p2 -> do+        ourLocalProc <- ask+        liftIO $ restoreIO $ runLocalProcess ourLocalProc p2+  uninterruptibleMask p = do+      lproc <- ask+      liftIO $ uninterruptibleMask $ \restore ->+        runLocalProcess lproc (p (liftRestore restore))+    where+      liftRestore :: (forall a. IO a -> IO a)+                  -> (forall a. Process a -> Process a)+      liftRestore restoreIO = \p2 -> do+        ourLocalProc <- ask+        liftIO $ restoreIO $ runLocalProcess ourLocalProc p2+ -------------------------------------------------------------------------------- -- Typed channels                                                             -- --------------------------------------------------------------------------------@@ -265,12 +411,16 @@     -- | Process-local ID of the channel   , sendPortLocalId   :: {-# UNPACK #-} !LocalSendPortId   }-  deriving (Eq, Ord)+  deriving (Eq, Ord, Typeable, Generic) +instance Hashable SendPortId where instance Show SendPortId where   show (SendPortId (ProcessId (NodeId addr) (LocalProcessId _ plid)) clid)     = "cid://" ++ show addr ++ ":" ++ show plid ++ ":" ++ show clid +instance NFData SendPortId where+  rnf (SendPortId p _) = rnf p `seq` ()+ data TypedChannel = forall a. Serializable a => TypedChannel (Weak (TQueue a))  -- | The send send of a typed channel (serializable)@@ -278,8 +428,12 @@     -- | The (unique) ID of this send port     sendPortId :: SendPortId   }-  deriving (Typeable, Binary, Show, Eq, Ord)+  deriving (Typeable, Generic, Show, Eq, Ord) +instance (Serializable a) => Binary (SendPort a) where+instance (Hashable a) => Hashable (SendPort a) where+instance (NFData a) => NFData (SendPort a) where rnf (SendPort x) = x `seq` ()+ -- | The receive end of a typed channel (not serializable) -- -- Note that 'ReceivePort' implements 'Functor', 'Applicative', 'Alternative'@@ -303,25 +457,62 @@ --------------------------------------------------------------------------------  -- | Messages consist of their typeRep fingerprint and their encoding-data Message = Message+data Message =+  EncodedMessage   { messageFingerprint :: !Fingerprint   , messageEncoding    :: !BSL.ByteString+  } |+  forall a . Serializable a =>+  UnencodedMessage+  {+    messageFingerprint :: !Fingerprint+  , messagePayload     :: !a   }+  deriving (Typeable) +instance NFData Message where+  rnf (EncodedMessage _ e) = rnf e `seq` ()+  rnf (UnencodedMessage _ a) = e `seq` ()+    where e = BSL.length (encode a)+ instance Show Message where-  show (Message fp enc) = show enc ++ " :: " ++ showFingerprint fp []+  show (EncodedMessage fp enc) = show enc ++ " :: " ++ showFingerprint fp []+  show (UnencodedMessage _ uenc) = "[unencoded message] :: " ++ (show $ typeOf uenc) +-- | /internal use only/.+isEncoded :: Message -> Bool+isEncoded (EncodedMessage _ _) = True+isEncoded _                    = False+-- [note] isEncoded:+-- This is just as internal as it looks and yes, it does feel a bit odd that+-- we're exporting it for use, however DPP does a /lot/ of work with low+-- level APIs such as unwrapMessage and handleMessage, and in the process+-- tries very hard to avoid copying (and re-serialisation) where possible.+-- Being able to determine that a message is encoded (or otherwise) makes+-- that a lot more manageable.+ -- | Turn any serialiable term into a message createMessage :: Serializable a => a -> Message-createMessage a = Message (fingerprint a) (encode a)+createMessage a = EncodedMessage (fingerprint a) (encode a) +-- | Turn any serializable term into an unencoded/local message+createUnencodedMessage :: Serializable a => a -> Message+createUnencodedMessage a =+  let encoded = encode a in BSL.length encoded `seq` UnencodedMessage (fingerprint a) a++-- | Turn any serializable term into an unencodede/local message, without+-- evalutaing it! This is a dangerous business.+unsafeCreateUnencodedMessage :: Serializable a => a -> Message+unsafeCreateUnencodedMessage a = UnencodedMessage (fingerprint a) a+ -- | Serialize a message messageToPayload :: Message -> [BSS.ByteString]-messageToPayload (Message fp enc) = encodeFingerprint fp : BSL.toChunks enc+messageToPayload (EncodedMessage fp enc) = encodeFingerprint fp : BSL.toChunks enc+messageToPayload (UnencodedMessage fp m) = messageToPayload ((EncodedMessage fp (encode m)))  -- | Deserialize a message payloadToMessage :: [BSS.ByteString] -> Message-payloadToMessage payload = Message fp (copy msg)+payloadToMessage payload = EncodedMessage fp (copy msg)   where     encFp :: BSL.ByteString     msg   :: BSL.ByteString@@ -346,8 +537,12 @@     -- | Unique to distinguish multiple monitor requests by the same process   , monitorRefCounter :: !Int32   }-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Typeable, Generic)+instance Hashable MonitorRef +instance NFData MonitorRef where+  rnf (MonitorRef i _) = rnf i `seq` ()+ -- | Message sent by process monitors data ProcessMonitorNotification =     ProcessMonitorNotification !MonitorRef !ProcessId !DiedReason@@ -380,9 +575,11 @@  -- | Exception thrown when a process attempts to register -- a process under an already-registered name or to--- unregister a name that hasn't been registered+-- unregister a name that hasn't been registered. Returns+-- the name and the identifier of the process that owns it,+-- if any. data ProcessRegistrationException =-    ProcessRegistrationException !String+    ProcessRegistrationException !String !(Maybe ProcessId)   deriving (Typeable, Show)  -- | Internal exception thrown indirectly by 'exit'@@ -414,6 +611,10 @@   | DiedUnknownId   deriving (Show, Eq) +instance NFData DiedReason where+  rnf (DiedException s) = rnf s `seq` ()+  rnf x = x `seq` ()+ -- | (Asynchronous) reply from unmonitor newtype DidUnmonitor = DidUnmonitor MonitorRef   deriving (Typeable, Binary)@@ -432,7 +633,7 @@  -- | 'SpawnRef' are used to return pids of spawned processes newtype SpawnRef = SpawnRef Int32-  deriving (Show, Binary, Typeable, Eq)+  deriving (Show, Binary, Typeable, Eq, Ord)  -- | (Asynchronius) reply from 'spawn' data DidSpawn = DidSpawn SpawnRef ProcessId@@ -443,14 +644,23 @@   deriving (Show, Typeable)  -- | (Asynchronous) reply from 'register' and 'unregister'-data RegisterReply = RegisterReply String Bool+data RegisterReply = RegisterReply String Bool (Maybe ProcessId)   deriving (Show, Typeable) +data NodeStats = NodeStats {+     nodeStatsNode            :: NodeId+   , nodeStatsRegisteredNames :: Int+   , nodeStatsMonitors        :: Int+   , nodeStatsLinks           :: Int+   , nodeStatsProcesses       :: Int+   }+   deriving (Show, Eq, Typeable)+ -- | Provide information about a running process data ProcessInfo = ProcessInfo {     infoNode               :: NodeId   , infoRegisteredNames    :: [String]-  , infoMessageQueueLength :: Maybe Int+  , infoMessageQueueLength :: Int   , infoMonitors           :: [(ProcessId, MonitorRef)]   , infoLinks              :: [ProcessId]   } deriving (Show, Eq, Typeable)@@ -480,23 +690,28 @@   | WhereIs !String   | Register !String !NodeId !(Maybe ProcessId) !Bool -- Use 'Nothing' to unregister, use True to force reregister   | NamedSend !String !Message+  | UnreliableSend !LocalProcessId !Message+  | LocalSend !ProcessId !Message+  | LocalPortSend !SendPortId !Message   | Kill !ProcessId !String   | Exit !ProcessId !Message   | GetInfo !ProcessId+  | SigShutdown+  | GetNodeStats !NodeId   deriving Show  -------------------------------------------------------------------------------- -- Binary instances                                                           -- -------------------------------------------------------------------------------- +instance Binary Message where+  put msg = put $ messageToPayload msg+  get = payloadToMessage <$> get+ instance Binary LocalProcessId where   put lpid = put (lpidUnique lpid) >> put (lpidCounter lpid)   get      = LocalProcessId <$> get <*> get -instance Binary ProcessId where-  put pid = put (processNodeId pid) >> put (processLocalId pid)-  get     = ProcessId <$> get <*> get- instance Binary ProcessMonitorNotification where   put (ProcessMonitorNotification ref pid reason) = put ref >> put pid >> put reason   get = ProcessMonitorNotification <$> get <*> get <*> get@@ -518,18 +733,23 @@   get     = MonitorRef <$> get <*> get  instance Binary ProcessSignal where-  put (Link pid)            = putWord8 0 >> put pid-  put (Unlink pid)          = putWord8 1 >> put pid-  put (Monitor ref)         = putWord8 2 >> put ref-  put (Unmonitor ref)       = putWord8 3 >> put ref-  put (Died who reason)     = putWord8 4 >> put who >> put reason-  put (Spawn proc ref)      = putWord8 5 >> put proc >> put ref-  put (WhereIs label)       = putWord8 6 >> put label+  put (Link pid)              = putWord8 0 >> put pid+  put (Unlink pid)            = putWord8 1 >> put pid+  put (Monitor ref)           = putWord8 2 >> put ref+  put (Unmonitor ref)         = putWord8 3 >> put ref+  put (Died who reason)       = putWord8 4 >> put who >> put reason+  put (Spawn proc ref)        = putWord8 5 >> put proc >> put ref+  put (WhereIs label)         = putWord8 6 >> put label   put (Register label nid pid force) = putWord8 7 >> put label >> put nid >> put pid >> put force-  put (NamedSend label msg) = putWord8 8 >> put label >> put (messageToPayload msg)-  put (Kill pid reason)     = putWord8 9 >> put pid >> put reason-  put (Exit pid reason)     = putWord8 10 >> put pid >> put (messageToPayload reason)-  put (GetInfo about)       = putWord8 30 >> put about+  put (NamedSend label msg)   = putWord8 8 >> put label >> put (messageToPayload msg)+  put (Kill pid reason)       = putWord8 9 >> put pid >> put reason+  put (Exit pid reason)       = putWord8 10 >> put pid >> put (messageToPayload reason)+  put (LocalSend to' msg)      = putWord8 11 >> put to' >> put (messageToPayload msg)+  put (LocalPortSend sid msg) = putWord8 12 >> put sid >> put (messageToPayload msg)+  put (UnreliableSend lpid msg) = putWord8 13 >> put lpid >> put (messageToPayload msg)+  put (GetInfo about)         = putWord8 30 >> put about+  put (SigShutdown)         = putWord8 31+  put (GetNodeStats nid)         = putWord8 32 >> put nid   get = do     header <- getWord8     case header of@@ -544,7 +764,12 @@       8  -> NamedSend <$> get <*> (payloadToMessage <$> get)       9  -> Kill <$> get <*> get       10 -> Exit <$> get <*> (payloadToMessage <$> get)+      11 -> LocalSend <$> get <*> (payloadToMessage <$> get)+      12 -> LocalPortSend <$> get <*> (payloadToMessage <$> get)+      13 -> UnreliableSend <$> get <*> (payloadToMessage <$> get)       30 -> GetInfo <$> get+      31 -> return SigShutdown+      32 -> GetNodeStats <$> get       _ -> fail "ProcessSignal.get: invalid"  instance Binary DiedReason where@@ -588,8 +813,8 @@   get = WhereIsReply <$> get <*> get  instance Binary RegisterReply where-  put (RegisterReply label ok) = put label >> put ok-  get = RegisterReply <$> get <*> get+  put (RegisterReply label ok owner) = put label >> put ok >> put owner+  get = RegisterReply <$> get <*> get <*> get  instance Binary ProcessInfo where   get = ProcessInfo <$> get <*> get <*> get <*> get <*> get@@ -599,6 +824,14 @@            >> put (infoMonitors pInfo)            >> put (infoLinks pInfo) +instance Binary NodeStats where+  get = NodeStats <$> get <*> get <*> get <*> get <*> get+  put nStats =  put (nodeStatsNode nStats)+             >> put (nodeStatsRegisteredNames nStats)+             >> put (nodeStatsMonitors nStats)+             >> put (nodeStatsLinks nStats)+             >> put (nodeStatsProcesses nStats)+ instance Binary ProcessInfoNone where   get = ProcessInfoNone <$> get   put (ProcessInfoNone r) = put r@@ -607,23 +840,23 @@ -- Accessors                                                                  -- -------------------------------------------------------------------------------- -localProcesses :: Accessor LocalNodeState (Map LocalProcessId LocalProcess)+localProcesses :: Accessor ValidLocalNodeState (Map LocalProcessId LocalProcess) localProcesses = accessor _localProcesses (\procs st -> st { _localProcesses = procs }) -localPidCounter :: Accessor LocalNodeState Int32+localPidCounter :: Accessor ValidLocalNodeState Int32 localPidCounter = accessor _localPidCounter (\ctr st -> st { _localPidCounter = ctr }) -localPidUnique :: Accessor LocalNodeState Int32+localPidUnique :: Accessor ValidLocalNodeState Int32 localPidUnique = accessor _localPidUnique (\unq st -> st { _localPidUnique = unq }) -localConnections :: Accessor LocalNodeState (Map (Identifier, Identifier) (NT.Connection, ImplicitReconnect))+localConnections :: Accessor ValidLocalNodeState (Map (Identifier, Identifier) (NT.Connection, ImplicitReconnect)) localConnections = accessor _localConnections (\conns st -> st { _localConnections = conns }) -localProcessWithId :: LocalProcessId -> Accessor LocalNodeState (Maybe LocalProcess)+localProcessWithId :: LocalProcessId -> Accessor ValidLocalNodeState (Maybe LocalProcess) localProcessWithId lpid = localProcesses >>> DAC.mapMaybe lpid -localConnectionBetween :: Identifier -> Identifier -> Accessor LocalNodeState (Maybe (NT.Connection, ImplicitReconnect))-localConnectionBetween from to = localConnections >>> DAC.mapMaybe (from, to)+localConnectionBetween :: Identifier -> Identifier -> Accessor ValidLocalNodeState (Maybe (NT.Connection, ImplicitReconnect))+localConnectionBetween from' to' = localConnections >>> DAC.mapMaybe (from', to')  monitorCounter :: Accessor LocalProcessState Int32 monitorCounter = accessor _monitorCounter (\cnt st -> st { _monitorCounter = cnt })@@ -648,4 +881,3 @@ {-# INLINE forever' #-} forever' :: Monad m => m a -> m b forever' a = let a' = a >> a' in a'-
src/Control/Distributed/Process/Internal/WeakTQueue.hs view
@@ -1,10 +1,12 @@+{-# LANGUAGE CPP  #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE MagicHash, UnboxedTuples #-} -- | Clone of Control.Concurrent.STM.TQueue with support for mkWeakTQueue -- -- Not all functionality from the original module is available: unGetTQueue, -- peekTQueue and tryPeekTQueue are missing. In order to implement these we'd -- need to be able to touch# the write end of the queue inside unGetTQueue, but -- that means we need a version of touch# that works within the STM monad.-{-# LANGUAGE MagicHash, UnboxedTuples #-} module Control.Distributed.Process.Internal.WeakTQueue (   -- * Original functionality   TQueue,@@ -21,8 +23,8 @@ import Prelude hiding (read) import GHC.Conc import Data.Typeable (Typeable)-import GHC.IO (IO(IO))-import GHC.Prim (mkWeak#)+import GHC.IO (IO(IO), unIO)+import GHC.Exts (mkWeak#) import GHC.Weak (Weak(Weak))  --------------------------------------------------------------------------------@@ -98,4 +100,4 @@  mkWeakTQueue :: TQueue a -> IO () -> IO (Weak (TQueue a)) mkWeakTQueue q@(TQueue _read (TVar write#)) f = IO $ \s ->-  case mkWeak# write# q f s of (# s', w #) -> (# s', Weak w #)+  case mkWeak# write# q (unIO f) s of (# s', w #) -> (# s', Weak w #)
+ src/Control/Distributed/Process/Management.hs view
@@ -0,0 +1,509 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE PatternGuards              #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE UndecidableInstances       #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Management+-- Copyright   :  (c) Well-Typed / Tim Watson+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- [Management Extensions API]+--+-- This module presents an API for creating /Management Agents/:+-- special processes that are capable of receiving and responding to+-- a node's internal system events. These /system events/ are delivered by+-- the management event bus: An internal subsystem maintained for each+-- running node, to which all agents are automatically subscribed.+--+-- /Agents/ are defined in terms of /event sinks/, taking a particular+-- @Serializable@ type and evaluating to an action in the 'MxAgent' monad in+-- response. Each 'MxSink' evaluates to an 'MxAction' that specifies whether+-- the agent should continue processing it's inputs or stop. If the type of a+-- message cannot be matched to any of the agent's sinks, it will be discarded.+-- A sink can also deliberately skip processing a message, deferring to the+-- remaining handlers. This is the /only/ way that more than one event sink+-- can handle the same data type, since otherwise the first /type match/ will+-- /win/ every time a message arrives. See 'mxSkip' for details.+--+-- Various events are published to the management event bus automatically,+-- the full list of which can be found in the definition of the 'MxEvent' data+-- type. Additionally, clients of the /Management API/ can publish arbitrary+-- @Serializable@ data to the event bus using 'mxNotify'. All running agents+-- receive all events (from the primary event bus to which they're subscribed).+--+-- Agent processes are automatically registered on the local node, and can+-- receive messages via their mailbox just like ordinary processes. Unlike+-- ordinary @Process@ code however, it is unnecessary (though possible) for+-- agents to use the base @expect@ and @receiveX@ primitives to do this, since+-- the management infrastructure will continuously read from both the primary+-- event bus /and/ the process' own mailbox. Messages are transparently passed+-- to the agent's event sinks from both sources, so an agent need only concern+-- itself with how to respond to its inputs.+--+-- Some agents may wish to prioritise messages from their mailbox over traffic+-- on the management event bus, or vice versa. The 'mxReceive' and+-- 'mxReceiveChan' API calls do this for the mailbox and event bus,+-- respectively. The /prioritisation/ these APIs offer is simply that the chosen+-- data stream will be checked first. No blocking will occur if the chosen+-- (prioritised) source is devoid of input messages, instead the agent handling+-- code will revert to switching between the alternatives in /round-robin/ as+-- usual. If messages exist in one or more channels, they will be consumed as+-- soon as they're available, priority is effectively a hint about which+-- channel to consume from, should messages be available in both.+--+-- Prioritisation then, is a /hint/ about the preference of data source from+-- which the next input should be chosen. No guarantee can be made that the+-- chosen source will in fact be selected at runtime.+--+-- [Management API Semantics]+--+-- The management API provides /no guarantees whatsoever/, viz:+--+--  * The ordering of messages delivered to the event bus.+--+--  * The order in which agents will be executed.+--+--  * Whether messages will be taken from the mailbox first, or the event bus.+--+-- Since the event bus uses STM broadcast channels to communicate with agents,+-- no message written to the bus successfully can be lost.+--+-- Agents can also receive messages via their mailboxes - these are subject to+-- the same guarantees as all inter-process message sending.+--+-- Messages dispatched on an STM broadcast channel (i.e., management event bus)+-- are guaranteed to be delivered with the same FIFO ordering guarantees that+-- exist between two communicating processes, such that communication from the+-- node controller's threads (i.e., MxEvent's) will never be re-ordered, but+-- messages dispatched to the event bus by other processes (including, but not+-- limited to agents) are only guaranteed to be ordered between one sender and+-- one receiver.+--+-- No guarantee exists for the ordering in which messages sent to an agent's+-- mailbox will be delivered, vs messages dispatched via the event bus.+--+-- Because of the above, there are no ordering guarantees for messages sent+-- between agents, or for processes to agents, except for those that apply to+-- messages sent between regular processes, since agents are+-- implemented as such.+--+-- The event bus is serial and single threaded. Anything that is published by+-- the node controller will be seen in FIFO order. There are no ordering+-- guarantees pertaining to entries published to the event bus by other+-- processes or agents.+--+-- It should not be possible to see, for example, an @MxReceived@ before the+-- corresponding @MxSent@ event, since the places where we issue the @MxSent@+-- write directly to the event bus (using STM) in the calling (green) thread,+-- before dispatching instructions to the node controller to perform the+-- necessary routing to deliver the message to a process (or registered name,+-- or typed channel) locally or remotely.+--+-- [Management Data API]+--+-- Both management agents and clients of the API have access to a variety of+-- data storage capabilities, to facilitate publishing and consuming useful+-- system information. Agents maintain their own internal state privately (via a+-- state transformer - see 'mxGetLocal' et al), however it is possible for+-- agents to share additional data with each other (and the outside world)+-- using whatever mechanism the user wishes, e.g., acidstate, or shared memory+-- primitives.+--+-- [Defining Agents]+--+-- New agents are defined with 'mxAgent' and require a unique 'MxAgentId', an+-- initial state - 'MxAgent' runs in a state transformer - and a list of the+-- agent's event sinks. Each 'MxSink' is defined in terms of a specific+-- @Serializable@ type, via the 'mxSink' function, binding the event handler+-- expression to inputs of only that type.+--+-- Apart from modifying its own local state, an agent can execute arbitrary+-- @Process a@ code via lifting (see 'liftMX') and even publish its own messages+-- back to the primary event bus (see 'mxBroadcast').+--+-- Since messages are delivered to agents from both the management event bus and+-- the agent processes mailbox, agents (i.e., event sinks) will generally have+-- no idea as to their origin. An agent can, however, choose to prioritise the+-- choice of input (source) each time one of its event sinks runs. The /standard/+-- way for an event sink to indicate that the agent is ready for its next input+-- is to evaluate 'mxReady'. When this happens, the management infrastructure+-- will obtain data from the event bus and process' mailbox in a round robbin+-- fashion, i.e., one after the other, changing each time.+--+-- [Example Code]+--+-- What follows is a grossly over-simplified example of a management agent that+-- provides a basic name monitoring facility. Whenever a process name is+-- registered or unregistered, clients are informed of the fact.+--+-- > -- simple notification data type+-- >+-- > data Registration = Reg { added  :: Bool+-- >                         , procId :: ProcessId+-- >                         , name   :: String+-- >                         }+-- >+-- > -- start a /name monitoring agent/+-- > nameMonitorAgent = do+-- >   mxAgent (MxAgentId "name-monitor") Set.empty [+-- >         (mxSink $ \(pid :: ProcessId) -> do+-- >            mxUpdateState $ Set.insert pid+-- >            mxReady)+-- >       , (mxSink $+-- >             let act =+-- >                   case ev of+-- >                     (MxRegistered   p n) -> notify True  n p+-- >                     (MxUnRegistered p n) -> notify False n p+-- >                     _                    -> return ()+-- >             act >> mxReady)+-- >     ]+-- >   where+-- >     notify a n p = do+-- >       Foldable.mapM_ (liftMX . deliver (Reg a n p)) =<< mxGetLocal+-- >+--+-- The client interface (for sending their pid) can take one of two forms:+--+-- > monitorNames = getSelfPid >>= nsend "name-monitor"+-- > monitorNames2 = getSelfPid >>= mxNotify+--+-- [Performance, Stablity and Scalability]+--+-- /Management Agents/ offer numerous advantages over regular processes:+-- broadcast communication with them can have a lower latency, they offer+-- simplified messgage (i.e., input type) handling and they have access to+-- internal system information that would be otherwise unobtainable.+--+-- Do not be tempted to implement everything (e.g., the kitchen sink) using the+-- management API though. There are overheads associated with management agents+-- which is why they're presented as tools for consuming low level system+-- information, instead of as /application level/ development tools.+--+-- Agents that rely heavily on a busy mailbox can cause the management event+-- bus to backlog un-GC'ed data, leading to increased heap space. Producers that+-- do not take care to avoid passing unevaluated thunks to the API can crash+-- /all/ the agents in the system. Agents are not monitored or managed in any+-- way, and those that crash will not be restarted.+--+-- The management event bus can receive a great deal of traffic. Every time+-- a message is sent and/or received, an event is passed to the agent controller+-- and broadcast to all agents (plus the trace controller, if tracing is enabled+-- for the node). This is already a significant overhead - though profiling and+-- benchmarks have demonstrated that it does not adversely affect performance+-- if few agents are installed. Agents will typically use more cycles than plain+-- processes, since they perform additional work: selecting input data from both+-- the event bus /and/ their own mailboxes, plus searching through the set of+-- event sinks (for each agent) to determine the right handler for the event.+--+-- [Architecture Overview]+--+-- The architecture of the management event bus is internal and subject to+-- change without prior notice. The description that follows is provided for+-- informational purposes only.+--+-- When a node initially starts, two special, internal system processes are+-- started to support the management infrastructure. The first, known as the+-- /trace controller/, is responsible for consuming 'MxEvent's and forwarding+-- them to the configured tracer - see "Control.Distributed.Process.Debug" for+-- further details. The second is the /management agent controller/, and is the+-- primary worker process underpinning the management infrastructure. All+-- published management events are routed to this process, which places them+-- onto a system wide /event bus/ and additionally passes them directly to the+-- /trace controller/.+--+-- There are several reasons for segregating the tracing and management control+-- planes in this fashion. Tracing can be enabled or disabled by clients, whilst+-- the management event bus cannot, since in addition to providing+-- runtime instrumentation, its intended use-cases include node monitoring, peer+-- discovery (via topology providing backends) and other essential system+-- services that require knowledge of otherwise hidden system internals. Tracing+-- is also subject to /trace flags/ that limit the specific 'MxEvent's delivered+-- to trace clients - an overhead/complexity not shared by management agents.+-- Finally, tracing and management agents are implemented using completely+-- different signalling techniques - more on this later - which would introduce+-- considerable complexity if the shared the same /event loop/.+--+-- The management control plane is driven by a shared broadcast channel, which+-- is written to by the agent controller and subscribed to by all agent+-- processes. Agents are spawned as regular processes, whose primary+-- implementation (i.e., /server loop/) is responsible for consuming+-- messages from both the broadcast channel and their own mailbox. Once+-- consumed, messages are applied to the agent's /event sinks/ until one+-- matches the input, at which point it is applied and the loop continues.+-- The implementation chooses from the event bus and the mailbox in a+-- round-robin fashion, until a message is received. This polling activity would+-- lead to management agents consuming considerable system resources if left+-- unchecked, therefore the implementation will poll for a limitted number of+-- retries, after which it will perform a blocking read on the event bus.+--+-----------------------------------------------------------------------------+module Control.Distributed.Process.Management+  (+    MxEvent(..)+    -- * Firing Arbitrary /Mx Events/+  , mxNotify+    -- * Constructing Mx Agents+  , MxAction()+  , MxAgentId(..)+  , MxAgent()+  , mxAgent+  , mxAgentWithFinalize+  , MxSink()+  , mxSink+  , mxGetId+  , mxDeactivate+  , mxReady+  , mxSkip+  , mxReceive+  , mxReceiveChan+  , mxBroadcast+  , mxSetLocal+  , mxGetLocal+  , mxUpdateLocal+  , liftMX+  ) where++import Control.Applicative+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TChan+  ( readTChan+  , writeTChan+  , TChan+  )+import Control.Distributed.Process.Internal.Primitives+  ( receiveWait+  , matchAny+  , matchSTM+  , unwrapMessage+  , register+  , whereis+  , die+  )+import Control.Distributed.Process.Internal.Types+  ( Process+  , ProcessId+  , Message+  , LocalProcess(..)+  , LocalNode(..)+  , MxEventBus(..)+  , unsafeCreateUnencodedMessage+  )+import Control.Distributed.Process.Management.Internal.Bus (publishEvent)+import Control.Distributed.Process.Management.Internal.Types+  ( MxAgentId(..)+  , MxAgent(..)+  , MxAction(..)+  , ChannelSelector(..)+  , MxAgentState(..)+  , MxSink+  , MxEvent(..)+  )+import Control.Distributed.Process.Serializable (Serializable)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ask)+import Control.Monad.Catch (onException)+import qualified Control.Monad.State as ST+  ( get+  , modify+  , lift+  , runStateT+  )+import Prelude++-- | Publishes an arbitrary @Serializable@ message to the management event bus.+-- Note that /no attempt is made to force the argument/, therefore it is very+-- important that you do not pass unevaluated thunks that might crash the+-- receiving process via this API, since /all/ registered agents will gain+-- access to the data structure once it is broadcast by the agent controller.+mxNotify :: (Serializable a) => a -> Process ()+mxNotify msg = do+  bus <- localEventBus . processNode <$> ask+  liftIO $ publishEvent bus $ unsafeCreateUnencodedMessage msg++--------------------------------------------------------------------------------+-- API for writing user defined management extensions (i.e., agents)          --+--------------------------------------------------------------------------------++-- | Return the 'MxAgentId' for the currently executing agent.+--+mxGetId :: MxAgent s MxAgentId+mxGetId = ST.get >>= return . mxAgentId++-- | The 'MxAgent' version of 'mxNotify'.+--+mxBroadcast :: (Serializable m) => m -> MxAgent s ()+mxBroadcast msg = do+  state <- ST.get+  liftMX $ liftIO $ atomically $ do+    writeTChan (mxBus state) (unsafeCreateUnencodedMessage msg)++-- | Gracefully terminate an agent.+--+mxDeactivate :: forall s. String -> MxAgent s MxAction+mxDeactivate = return . MxAgentDeactivate++-- | Continue executing (i.e., receiving and processing messages).+--+mxReady :: forall s. MxAgent s MxAction+mxReady = return MxAgentReady++-- | Causes the currently executing /event sink/ to be skipped.+-- The remaining declared event sinks will be evaluated to find+-- a matching handler. Can be used to allow multiple event sinks+-- to process data of the same type.+--+mxSkip :: forall s. MxAgent s MxAction+mxSkip = return MxAgentSkip++-- | Continue exeucting, prioritising inputs from the process' own+-- /mailbox/ ahead of data from the management event bus.+--+mxReceive :: forall s. MxAgent s MxAction+mxReceive = return $ MxAgentPrioritise Mailbox++-- | Continue exeucting, prioritising inputs from the management event bus+-- over the process' own /mailbox/.+--+mxReceiveChan :: forall s. MxAgent s MxAction+mxReceiveChan = return $ MxAgentPrioritise InputChan++-- | Lift a @Process@ action.+--+liftMX :: Process a -> MxAgent s a+liftMX p = MxAgent $ ST.lift p++-- | Set the agent's local state.+--+mxSetLocal :: s -> MxAgent s ()+mxSetLocal s = ST.modify $ \st -> st { mxLocalState = s }++-- | Update the agent's local state.+--+mxUpdateLocal :: (s -> s) -> MxAgent s ()+mxUpdateLocal f = ST.modify $ \st -> st { mxLocalState = (f $ mxLocalState st) }++-- | Fetch the agent's local state.+--+mxGetLocal :: MxAgent s s+mxGetLocal = ST.get >>= return . mxLocalState++-- | Create an 'MxSink' from an expression taking a @Serializable@ type @m@,+-- that yields an 'MxAction' in the 'MxAgent' monad.+--+mxSink :: forall s m . (Serializable m)+       => (m -> MxAgent s MxAction)+       -> MxSink s+mxSink act msg = do+  msg' <- liftMX $ (unwrapMessage msg :: Process (Maybe m))+  case msg' of+    Nothing -> return Nothing+    Just m  -> do+      r <- act m+      case r of+        MxAgentSkip -> return Nothing+        _           -> return $ Just r++-- private ADT: a linked list of event sinks+data MxPipeline s =+  MxPipeline+  {+    current  :: !(MxSink s)+  , next     :: !(MxPipeline s)+  } | MxStop++-- | Activates a new agent.+--+mxAgent :: MxAgentId -> s -> [MxSink s] -> Process ProcessId+mxAgent mxId st hs = mxAgentWithFinalize mxId st hs $ return ()++-- | Activates a new agent. This variant takes a /finalizer/ expression,+-- that is run once the agent shuts down (even in case of failure/exceptions).+-- The /finalizer/ expression runs in the mx monad -  @MxAgent s ()@ - such+-- that the agent's internal state remains accessible to the shutdown/cleanup+-- code.+--+mxAgentWithFinalize :: MxAgentId+        -> s+        -> [MxSink s]+        -> MxAgent s ()+        -> Process ProcessId+mxAgentWithFinalize mxId initState handlers dtor = do+    let name = agentId mxId+    existing <- whereis name+    case existing of+      Just _  -> die "DuplicateAgentId"  -- TODO: better error handling policy+      Nothing -> do+        node <- processNode <$> ask+        pid <- liftIO $ mxNew (localEventBus node) $ start+        register name pid+        return pid+  where+    start (sendTChan, recvTChan) = do+      let nState = MxAgentState mxId sendTChan initState+      runAgent dtor handlers InputChan recvTChan nState++    runAgent :: MxAgent s ()+             -> [MxSink s]+             -> ChannelSelector+             -> TChan Message+             -> MxAgentState s+             -> Process ()+    runAgent eh hs cs c s =+      runAgentWithFinalizer eh hs cs c s+        `onException` runAgentFinalizer eh s++    runAgentWithFinalizer :: MxAgent s ()+                          -> [MxSink s]+                          -> ChannelSelector+                          -> TChan Message+                          -> MxAgentState s+                          -> Process ()+    runAgentWithFinalizer eh' hs' cs' c' s' = do+      msg <- getNextInput cs' c'+      (action, state) <- runPipeline msg s' $ pipeline hs'+      case action of+        MxAgentReady               -> runAgent eh' hs' InputChan c' state+        MxAgentPrioritise priority -> runAgent eh' hs' priority  c' state+        MxAgentDeactivate _        -> runAgentFinalizer eh' state+        MxAgentSkip                -> error "IllegalState"+--      MxAgentBecome h'           -> runAgent h' c state++    getNextInput sel chan =+      let matches =+            case sel of+              Mailbox   -> [ matchAny return+                           , matchSTM (readTChan chan) return]+              InputChan -> [ matchSTM (readTChan chan) return+                           , matchAny return]+      in receiveWait matches++    runAgentFinalizer :: MxAgent s () -> MxAgentState s -> Process ()+    runAgentFinalizer f s = ST.runStateT (unAgent f) s >>= return . fst++    pipeline :: forall s . [MxSink s] -> MxPipeline s+    pipeline []           = MxStop+    pipeline (sink:sinks) = MxPipeline sink (pipeline sinks)++    runPipeline :: forall s .+                   Message+                -> MxAgentState s+                -> MxPipeline s+                -> Process (MxAction, MxAgentState s)+    runPipeline _   state MxStop         = return (MxAgentReady, state)+    runPipeline msg state MxPipeline{..} = do+      let act = current msg+      (pass, state') <- ST.runStateT (unAgent act) state+      case pass of+        Nothing     -> runPipeline msg state next+        Just result -> return (result, state')
+ src/Control/Distributed/Process/Management/Internal/Agent.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE RecordWildCards #-}++module Control.Distributed.Process.Management.Internal.Agent where++import Control.Applicative+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TChan+  ( TChan+  , newBroadcastTChanIO+  , readTChan+  , writeTChan+  , dupTChan+  )+import Control.Distributed.Process.Internal.Primitives+  ( receiveWait+  , matchAny+  , die+  , catches+  , Handler(..)+  )+import Control.Distributed.Process.Internal.CQueue+  ( enqueueSTM+  , CQueue+  )+import Control.Distributed.Process.Management.Internal.Types+  ( Fork+  )+import Control.Distributed.Process.Management.Internal.Trace.Tracer+  ( traceController+  )+import Control.Distributed.Process.Internal.Types+  ( Process+  , Message+  , Tracer(..)+  , LocalProcess(..)+  , ProcessId+  , forever'+  )+import Control.Exception (AsyncException(ThreadKilled), SomeException)+import Control.Monad (void)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ask)+import GHC.Weak (Weak, deRefWeak)+import Prelude++--------------------------------------------------------------------------------+-- Agent Controller Implementation                                            --+--------------------------------------------------------------------------------++-- | A triple containing a configured tracer, weak pointer to the+-- agent controller's mailbox (CQueue) and an expression used to+-- instantiate new agents on the current node.+type AgentConfig =+  (Tracer, Weak (CQueue Message),+   (((TChan Message, TChan Message) -> Process ()) -> IO ProcessId))++-- | Starts a management agent for the current node. The agent process+-- must not crash or be killed, so we generally avoid publishing its+-- @ProcessId@ where possible.+--+-- Our process is also responsible for forwarding messages to the trace+-- controller, since having two /special processes/ handled via the+-- @LocalNode@ would be inelegant. We forward messages directly to the+-- trace controller's message queue, just as the @MxEventBus@ that's+-- set up on the @LocalNode@ forwards messages directly to us. This+-- optimises the code path for tracing and avoids overloading the node+-- node controller's internal control plane with additional routing, at the+-- cost of a little more complexity and two cases where we break+-- encapsulation.+--+mxAgentController :: Fork+                  -> MVar AgentConfig+                  -> Process ()+mxAgentController forkProcess mv = do+    trc <- liftIO $ startTracing forkProcess+    sigbus <- liftIO $ newBroadcastTChanIO+    liftIO $ startDeadLetterQueue sigbus+    weakQueue <- processWeakQ <$> ask+    liftIO $ putMVar mv (trc, weakQueue, mxStartAgent forkProcess sigbus)+    go sigbus trc+  where+    go bus tracer = forever' $ do+      void $ receiveWait [+          -- This is exactly what it appears to be: a "catch all" handler.+          -- Since mxNotify can potentially pass an unevaluated thunk to+          -- our mailbox, the dequeue (i.e., matchMessage) can fail and+          -- crash this process, which we DO NOT want. Alternatively,+          -- we handle IO exceptions here explicitly, since we don't want+          -- this process to ever crash, and the assumption we therefore+          -- make is thus:+          --+          -- 1. only ThreadKilled can tell this process to terminate+          -- 2. all other exceptions are invalid and should be ignored+          --+          -- The outcome of course, is that /bad/ calls to mxNotify+          -- (e.g., passing unevaluated thunks that will crash when+          -- they're eventually forced) are thus silently ignored.+          --+          matchAny (liftIO . broadcast bus tracer)+        ] `catches` [Handler (\ThreadKilled -> die "Killed"),+                     Handler (\(_ :: SomeException) -> return ())]++    broadcast :: TChan Message -> Tracer -> Message -> IO ()+    broadcast ch tr msg = do+      tmQueue <- tracerQueue tr+      atomicBroadcast ch tmQueue msg++    tracerQueue :: Tracer -> IO (Maybe (CQueue Message))+    tracerQueue (Tracer _ wQ) = deRefWeak wQ++    atomicBroadcast :: TChan Message+                    -> Maybe (CQueue Message)+                    -> Message -> IO ()+    atomicBroadcast ch Nothing  msg = liftIO $ atomically $ writeTChan ch msg+    atomicBroadcast ch (Just q) msg = do+      -- liftIO $ putStrLn $ "broadcasting " ++ (show msg)+      liftIO $ atomically $ enqueueSTM q msg >> writeTChan ch msg++-- | Forks a new process in which an mxAgent is run.+--+mxStartAgent :: Fork+             -> TChan Message+             -> ((TChan Message, TChan Message) -> Process ())+             -> IO ProcessId+mxStartAgent fork chan handler = do+  chan' <- atomically (dupTChan chan)+  let proc = handler (chan, chan')+  fork proc++-- | Start the tracer controller.+--+startTracing :: Fork -> IO Tracer+startTracing forkProcess = do+  mv  <- newEmptyMVar+  pid <- forkProcess $ traceController mv+  wQ  <- liftIO $ takeMVar mv+  return $ Tracer pid wQ++-- | Start a dead letter (agent) queue.+--+-- If no agents are registered on the system, the management+-- event bus will fill up and its data won't be GC'ed until someone+-- comes along and reads from the broadcast channel (via dupTChan+-- of course). This is effectively a leak, so to mitigate it, we+-- start a /dead letter queue/ that drains the event bus continuously,+-- thus ensuring if there are no other consumers that we won't use+-- up heap space unnecessarily.+--+startDeadLetterQueue :: TChan Message+                     -> IO ()+startDeadLetterQueue sigbus = do+  chan' <- atomically (dupTChan sigbus)+  void $ forkIO $ forever' $ do+    void $ atomically $ readTChan chan'
+ src/Control/Distributed/Process/Management/Internal/Bus.hs view
@@ -0,0 +1,21 @@+-- | Interface to the management event bus.+module Control.Distributed.Process.Management.Internal.Bus+  ( publishEvent+  ) where++import Control.Distributed.Process.Internal.CQueue+  ( enqueue+  )+import Control.Distributed.Process.Internal.Types+  ( MxEventBus(..)+  , Message+  )+import Data.Foldable (forM_)+import System.Mem.Weak (deRefWeak)++publishEvent :: MxEventBus -> Message -> IO ()+publishEvent MxEventBusInitialising _     = return ()+publishEvent (MxEventBus _ _ wqRef _) msg =  do+  mQueue <- deRefWeak wqRef+  forM_ mQueue $ \queue -> enqueue queue msg+
+ src/Control/Distributed/Process/Management/Internal/Trace/Primitives.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TypeSynonymInstances  #-}+-- | Keeps the tracing API calls separate from the Tracer implementation,+-- which allows us to avoid a nasty import cycle between tracing and+-- the messaging primitives that rely on it, and also between the node+-- controller (which requires access to the tracing related elements of+-- our RemoteTable) and the Debug module, which requires @forkProcess@.+-- This module is also used by the management agent, which relies on the+-- tracing infrastructure's messaging fabric.+module Control.Distributed.Process.Management.Internal.Trace.Primitives+  ( -- * Sending Trace Data+    traceLog+  , traceLogFmt+  , traceMessage+    -- * Configuring A Tracer+  , defaultTraceFlags+  , enableTrace+  , enableTraceAsync+  , disableTrace+  , disableTraceAsync+  , getTraceFlags+  , setTraceFlags+  , setTraceFlagsAsync+  , traceOnly+  , traceOn+  , traceOff+  , withLocalTracer+  , withRegisteredTracer+  ) where++import Control.Applicative+import Control.Distributed.Process.Internal.Primitives+  ( whereis+  , newChan+  , receiveChan+  , die+  )+import Control.Distributed.Process.Management.Internal.Trace.Types+  ( TraceArg(..)+  , TraceFlags(..)+  , TraceOk(..)+  , TraceSubject(..)+  , defaultTraceFlags+  )+import qualified Control.Distributed.Process.Management.Internal.Trace.Types as Tracer+  ( traceLog+  , traceLogFmt+  , traceMessage+  , enableTrace+  , enableTraceSync+  , disableTrace+  , disableTraceSync+  , setTraceFlags+  , setTraceFlagsSync+  , getTraceFlags+  , getCurrentTraceClient+  )+import Control.Distributed.Process.Internal.Types+  ( Process+  , ProcessId+  , LocalProcess(..)+  , LocalNode(localEventBus)+  , SendPort+  , MxEventBus(..)+  )+import Control.Distributed.Process.Serializable+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ask)++import qualified Data.Set as Set (fromList)+import Prelude++--------------------------------------------------------------------------------+-- Main API                                                                   --+--------------------------------------------------------------------------------++-- | Converts a list of identifiers (that can be+-- mapped to process ids), to a 'TraceSubject'.+class Traceable a where+  uod :: [a] -> TraceSubject++instance Traceable ProcessId where+  uod = TraceProcs . Set.fromList++instance Traceable String where+  uod = TraceNames . Set.fromList++-- | Turn tracing for for a subset of trace targets.+traceOnly :: Traceable a => [a] -> Maybe TraceSubject+traceOnly = Just . uod++-- | Trace all targets.+traceOn :: Maybe TraceSubject+traceOn = Just TraceAll++-- | Trace no targets.+traceOff :: Maybe TraceSubject+traceOff = Nothing++-- | Enable tracing to the supplied process.+enableTraceAsync :: ProcessId -> Process ()+enableTraceAsync pid = withLocalTracer $ \t -> liftIO $ Tracer.enableTrace t pid++-- TODO: refactor _Sync versions of trace configuration functions...++-- | Enable tracing to the supplied process and wait for a @TraceOk@+-- response from the trace coordinator process.+enableTrace :: ProcessId -> Process ()+enableTrace pid =+  withLocalTracerSync $ \t sp -> Tracer.enableTraceSync t sp pid++-- | Disable the currently configured trace.+disableTraceAsync :: Process ()+disableTraceAsync = withLocalTracer $ \t -> liftIO $ Tracer.disableTrace t++-- | Disable the currently configured trace and wait for a @TraceOk@+-- response from the trace coordinator process.+disableTrace :: Process ()+disableTrace =+  withLocalTracerSync $ \t sp -> Tracer.disableTraceSync t sp++getTraceFlags :: Process TraceFlags+getTraceFlags = do+  (sp, rp) <- newChan+  withLocalTracer $ \t -> liftIO $ Tracer.getTraceFlags t sp+  receiveChan rp++-- | Set the given flags for the current tracer.+setTraceFlagsAsync :: TraceFlags -> Process ()+setTraceFlagsAsync f = withLocalTracer $ \t -> liftIO $ Tracer.setTraceFlags t f++-- | Set the given flags for the current tracer and wait for a @TraceOk@+-- response from the trace coordinator process.+setTraceFlags :: TraceFlags -> Process ()+setTraceFlags f =+  withLocalTracerSync $ \t sp -> Tracer.setTraceFlagsSync t sp f++-- | Send a log message to the internal tracing facility. If tracing is+-- enabled, this will create a custom trace log event.+--+traceLog :: String -> Process ()+traceLog s = withLocalTracer $ \t -> liftIO $ Tracer.traceLog t s++-- | Send a log message to the internal tracing facility, using the given+-- list of printable 'TraceArg's interspersed with the preceding delimiter.+--+traceLogFmt :: String -> [TraceArg] -> Process ()+traceLogFmt d ls = withLocalTracer $ \t -> liftIO $ Tracer.traceLogFmt t d ls++-- | Send an arbitrary 'Message' to the tracer process.+traceMessage :: Serializable m => m -> Process ()+traceMessage msg = withLocalTracer $ \t -> liftIO $ Tracer.traceMessage t msg++withLocalTracer :: (MxEventBus -> Process ()) -> Process ()+withLocalTracer act = do+  node <- processNode <$> ask+  act (localEventBus node)++withLocalTracerSync :: (MxEventBus -> SendPort TraceOk -> IO ()) -> Process ()+withLocalTracerSync act = do+  (sp, rp) <- newChan+  withLocalTracer $ \t -> liftIO $ (act t sp)+  TraceOk <- receiveChan rp+  return ()++withRegisteredTracer :: (ProcessId -> Process a) -> Process a+withRegisteredTracer act = do+  (sp, rp) <- newChan+  withLocalTracer $ \t -> liftIO $ Tracer.getCurrentTraceClient t sp+  currentTracer <- receiveChan rp+  case currentTracer of+    Nothing  -> do mTP <- whereis "tracer.initial"+                   -- NB: this should NOT ever happen, but forcing pattern matches+                   --     is not considered cool in later versions of MonadFail+                   case mTP of+                     Just p' -> act p'+                     Nothing -> die $ "System Invariant Violation: Tracer Process "+                                   ++ "Name Not Found (whereis tracer.initial)"+    (Just p) -> act p
+ src/Control/Distributed/Process/Management/Internal/Trace/Remote.hs view
@@ -0,0 +1,61 @@+module Control.Distributed.Process.Management.Internal.Trace.Remote+  ( -- * Configuring A Remote Tracer+    setTraceFlagsRemote+  , startTraceRelay+    -- * Remote Table+  , remoteTable+  ) where++import Control.Distributed.Process.Internal.Closure.BuiltIn+  ( cpEnableTraceRemote+  )+import Control.Distributed.Process.Internal.Primitives+  ( getSelfPid+  , relay+  , nsendRemote+  )+import Control.Distributed.Process.Management.Internal.Trace.Types+  ( TraceFlags(..)+  , TraceOk(..)+  )+import Control.Distributed.Process.Management.Internal.Trace.Primitives+  ( withRegisteredTracer+  , enableTrace+  )+import Control.Distributed.Process.Internal.Spawn+  ( spawn+  )+import Control.Distributed.Process.Internal.Types+  ( Process+  , ProcessId+  , SendPort+  , NodeId+  )+import Control.Distributed.Static+  ( RemoteTable+  , registerStatic+  )+import Data.Rank1Dynamic (toDynamic)++-- | Remote Table.+remoteTable :: RemoteTable -> RemoteTable+remoteTable = registerStatic "$enableTraceRemote" (toDynamic enableTraceRemote)++enableTraceRemote :: ProcessId -> Process ()+enableTraceRemote pid =+  getSelfPid >>= enableTrace >> relay pid++-- | Starts a /trace relay/ process on the remote node, which forwards all trace+-- events to the registered tracer on /this/ (the calling process') node.+startTraceRelay :: NodeId -> Process ProcessId+startTraceRelay nodeId = do+  withRegisteredTracer $ \pid ->+    spawn nodeId $ cpEnableTraceRemote pid++-- | Set the given flags for a remote node (asynchronous).+setTraceFlagsRemote :: TraceFlags -> NodeId -> Process ()+setTraceFlagsRemote flags node = do+  nsendRemote node+              "trace.controller"+              ((Nothing :: Maybe (SendPort TraceOk)), flags)+
+ src/Control/Distributed/Process/Management/Internal/Trace/Tracer.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE CPP  #-}+{-# LANGUAGE ScopedTypeVariables  #-}+-- | Tracing/Debugging support - Trace Implementation+module Control.Distributed.Process.Management.Internal.Trace.Tracer+  ( -- * API for the Management Agent+    traceController+    -- * Built in tracers+  , defaultTracer+  , systemLoggerTracer+  , logfileTracer+  , eventLogTracer+  ) where++import Control.Applicative+import Control.Concurrent.Chan (writeChan)+import Control.Concurrent.MVar+  ( MVar+  , putMVar+  )+import Control.Distributed.Process.Internal.CQueue+  ( CQueue+  )+import Control.Distributed.Process.Internal.Primitives+  ( die+  , receiveWait+  , forward+  , sendChan+  , match+  , matchAny+  , matchIf+  , handleMessage+  , matchUnknown+  )+import Control.Distributed.Process.Management.Internal.Types+  ( MxEvent(..)+  , Addressable(..)+  )+import Control.Distributed.Process.Management.Internal.Trace.Types+  ( SetTrace(..)+  , TraceSubject(..)+  , TraceFlags(..)+  , TraceOk(..)+  , defaultTraceFlags+  )+import Control.Distributed.Process.Management.Internal.Trace.Primitives+  ( traceOn )+import Control.Distributed.Process.Internal.Types+  ( LocalNode(..)+  , NCMsg(..)+  , ProcessId+  , Process+  , LocalProcess(..)+  , Identifier(..)+  , ProcessSignal(NamedSend)+  , Message+  , SendPort+  , forever'+  , nullProcessId+  , createUnencodedMessage+  )++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ask)+import Control.Monad.Catch+  ( catch+  , finally+  )++import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import qualified Data.Map as Map++import Data.Maybe (fromMaybe)+import Data.Time.Clock (getCurrentTime)+import Data.Time.Format (formatTime)+import Debug.Trace (traceEventIO)+import Prelude++import System.Environment (getEnv)+import System.IO+  ( Handle+  , IOMode(AppendMode)+  , BufferMode(..)+  , openFile+  , hClose+  , hPutStrLn+  , hSetBuffering+  )+import Data.Time.Format (defaultTimeLocale)+import System.Mem.Weak+  ( Weak+  )++data TracerState =+  TracerST+  {+    client   :: !(Maybe ProcessId)+  , flags    :: !TraceFlags+  , regNames :: !(Map ProcessId (Set String))+  }++--------------------------------------------------------------------------------+-- Trace Handlers                                                             --+--------------------------------------------------------------------------------++defaultTracer :: Process ()+defaultTracer =+  catch (checkEnv "DISTRIBUTED_PROCESS_TRACE_FILE" >>= logfileTracer)+        (\(_ :: IOError) -> defaultTracerAux)++defaultTracerAux :: Process ()+defaultTracerAux =+  catch (checkEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" >> systemLoggerTracer)+        (\(_ :: IOError) -> defaultEventLogTracer)++-- TODO: it would be /nice/ if we had some way of checking the runtime+-- options to see if +RTS -v (or similar) has been given...+defaultEventLogTracer :: Process ()+defaultEventLogTracer =+  catch (checkEnv "DISTRIBUTED_PROCESS_TRACE_EVENTLOG" >> eventLogTracer)+        (\(_ :: IOError) -> nullTracer)++checkEnv :: String -> Process String+checkEnv s = liftIO $ getEnv s++-- This trace client is (intentionally) a noop - it simply provides+-- an intial client for the trace controller to talk to, until some+-- other (hopefully more useful) client is installed over the top of+-- it. This is the default trace client.+nullTracer :: Process ()+nullTracer =+  forever' $ receiveWait [ matchUnknown (return ()) ]++systemLoggerTracer :: Process ()+systemLoggerTracer = do+  node <- processNode <$> ask+  let tr = sendTraceLog node+  forever' $ receiveWait [ matchAny (\m -> handleMessage m tr) ]+  where+    sendTraceLog :: LocalNode -> MxEvent -> Process ()+    sendTraceLog node ev = do+      now <- liftIO $ getCurrentTime+      msg <- return $ (formatTime defaultTimeLocale "%c" now, buildTxt ev)+      emptyPid <- return $ (nullProcessId (localNodeId node))+      traceMsg <- return $ NCMsg {+                             ctrlMsgSender = ProcessIdentifier (emptyPid)+                           , ctrlMsgSignal = (NamedSend "trace.logger"+                                                 (createUnencodedMessage msg))+                           }+      liftIO $ writeChan (localCtrlChan node) traceMsg++    buildTxt :: MxEvent -> String+    buildTxt (MxLog msg) = msg+    buildTxt ev          = show ev++eventLogTracer :: Process ()+eventLogTracer =+  -- NB: when the GHC event log supports tracing arbitrary (ish) data, we will+  -- almost certainly use *that* facility independently of whether or not there+  -- is a tracer process installed. This is just a stop gap until then.+  forever' $ receiveWait [ matchAny (\m -> handleMessage m writeTrace) ]+  where+    writeTrace :: MxEvent -> Process ()+    writeTrace ev = liftIO $ traceEventIO (show ev)++logfileTracer :: FilePath -> Process ()+logfileTracer p = do+  -- TODO: error handling if the handle cannot be opened+  h <- liftIO $ openFile p AppendMode+  liftIO $ hSetBuffering h LineBuffering+  logger h `finally` (liftIO $ hClose h)+  where+    logger :: Handle -> Process ()+    logger h' = forever' $ do+      receiveWait [+          matchIf (\ev -> case ev of+                            MxTraceDisable      -> True+                            (MxTraceTakeover _) -> True+                            _                   -> False)+                  (\_ -> (liftIO $ hClose h') >> die "trace stopped")+        , matchAny (\ev -> handleMessage ev (writeTrace h'))+        ]++    writeTrace :: Handle -> MxEvent -> Process ()+    writeTrace h ev = do+      liftIO $ do+        now <- getCurrentTime+        hPutStrLn h $ (formatTime defaultTimeLocale "%c - " now) ++ (show ev)++--------------------------------------------------------------------------------+-- Tracer Implementation                                                      --+--------------------------------------------------------------------------------++traceController :: MVar ((Weak (CQueue Message))) -> Process ()+traceController mv = do+    -- See the documentation for mxAgentController for a+    -- commentary that explains this breach of encapsulation+    weakQueue <- processWeakQ <$> ask+    liftIO $ putMVar mv weakQueue+    initState <- initialState+    traceLoop initState { client = Nothing }+  where+    traceLoop :: TracerState -> Process ()+    traceLoop st = do+      let client' = client st+      -- Trace events are forwarded to the enabled trace target.+      -- At some point in the future, we're going to start writing these custom+      -- events to the ghc eventlog, at which point this design might change.+      st' <- receiveWait [+          match (\(setResp, set :: SetTrace) -> do+                  -- We consider at most one trace client, which is a process.+                  -- Tracking multiple clients represents too high an overhead,+                  -- so we leave that kind of thing to our consumers (e.g., the+                  -- high level Debug client module) to figure out.+                  case set of+                    (TraceEnable pid) -> do+                      -- notify the previous tracer it has been replaced+                      sendTraceMsg client' (createUnencodedMessage (MxTraceTakeover pid))+                      sendOk setResp+                      return st { client = (Just pid) }+                    TraceDisable -> do+                      sendTraceMsg client' (createUnencodedMessage MxTraceDisable)+                      sendOk setResp+                      return st { client = Nothing })+        , match (\(confResp, flags') ->+                  sendOk confResp >> applyTraceFlags flags' st)+        , match (\chGetFlags -> sendChan chGetFlags (flags st) >> return st)+        , match (\chGetCurrent -> sendChan chGetCurrent (client st) >> return st)+          -- we dequeue incoming events even if we don't process them+        , matchAny (\ev ->+            handleMessage ev (handleTrace st ev) >>= return . fromMaybe st)+        ]+      traceLoop st'++    sendOk :: Maybe (SendPort TraceOk) -> Process ()+    sendOk Nothing   = return ()+    sendOk (Just sp) = sendChan sp TraceOk++    initialState :: Process TracerState+    initialState = do+      flags' <- checkEnvFlags+      return $ TracerST { client   = Nothing+                        , flags    = flags'+                        , regNames = Map.empty+                        }++    checkEnvFlags :: Process TraceFlags+    checkEnvFlags =+      catch (checkEnv "DISTRIBUTED_PROCESS_TRACE_FLAGS" >>= return . parseFlags)+            (\(_ :: IOError) -> return defaultTraceFlags)++    parseFlags :: String -> TraceFlags+    parseFlags s = parseFlags' s defaultTraceFlags+      where parseFlags' :: String -> TraceFlags -> TraceFlags+            parseFlags' [] parsedFlags = parsedFlags+            parseFlags' (x:xs) parsedFlags+              | x == 'p'  = parseFlags' xs parsedFlags { traceSpawned = traceOn }+              | x == 'n'  = parseFlags' xs parsedFlags { traceRegistered = traceOn }+              | x == 'u'  = parseFlags' xs parsedFlags { traceUnregistered = traceOn }+              | x == 'd'  = parseFlags' xs parsedFlags { traceDied = traceOn }+              | x == 's'  = parseFlags' xs parsedFlags { traceSend = traceOn }+              | x == 'r'  = parseFlags' xs parsedFlags { traceRecv = traceOn }+              | x == 'l'  = parseFlags' xs parsedFlags { traceNodes = True }+              | otherwise = parseFlags' xs parsedFlags++applyTraceFlags :: TraceFlags -> TracerState -> Process TracerState+applyTraceFlags flags' state = return state { flags = flags' }++handleTrace :: TracerState -> Message -> MxEvent -> Process TracerState+handleTrace st msg ev@(MxRegistered p n) =+  let regNames' =+        Map.insertWith (\_ ns -> Set.insert n ns) p+                       (Set.singleton n)+                       (regNames st)+  in do+    traceEv ev msg (traceRegistered (flags st)) st+    return st { regNames = regNames' }+handleTrace st msg ev@(MxUnRegistered p n) =+  let f ns = case ns of+               Nothing  -> Nothing+               Just ns' -> Just (Set.delete n ns')+      regNames' = Map.alter f p (regNames st)+  in do+    traceEv ev msg (traceUnregistered (flags st)) st+    return st { regNames = regNames' }+handleTrace st msg ev@(MxSpawned  _)   = do+  traceEv ev msg (traceSpawned (flags st)) st >> return st+handleTrace st msg ev@(MxProcessDied _ _)     = do+  traceEv ev msg (traceDied (flags st)) st >> return st+handleTrace st msg ev@(MxSent _ _ _)   =+  traceEv ev msg (traceSend (flags st)) st >> return st+handleTrace st msg ev@(MxReceived _ _) =+  traceEv ev msg (traceRecv (flags st)) st >> return st+handleTrace st msg ev = do+  case ev of+    (MxNodeDied _ _) ->+      case (traceNodes (flags st)) of+        True  -> sendTrace st ev msg+        False -> return ()+    (MxUser _) -> sendTrace st ev msg+    (MxLog _)  -> sendTrace st ev msg+    _ ->+      case (traceConnections (flags st)) of+        True  -> sendTrace st ev msg+        False -> return ()+  return st++traceEv :: MxEvent+        -> Message+        -> Maybe TraceSubject+        -> TracerState+        -> Process ()+traceEv _  _   Nothing                  _  = return ()+traceEv ev msg (Just TraceAll)          st = sendTrace st ev msg+traceEv ev msg (Just (TraceProcs pids)) st = do+  node <- processNode <$> ask+  let p = case resolveToPid ev of+            Nothing  -> (nullProcessId (localNodeId node))+            Just pid -> pid+  case (Set.member p pids) of+    True  -> sendTrace st ev msg+    False -> return ()+traceEv ev msg (Just (TraceNames names)) st = do+  -- if we have recorded regnames for p, then we forward the trace iif+  -- there are overlapping trace targets+  node <- processNode <$> ask+  let p = case resolveToPid ev of+            Nothing  -> (nullProcessId (localNodeId node))+            Just pid -> pid+  case (Map.lookup p (regNames st)) of+    Nothing -> return ()+    Just ns -> if (Set.null (Set.intersection ns names))+                 then return ()+                 else sendTrace st ev msg++sendTrace :: TracerState -> MxEvent -> Message -> Process ()+sendTrace st ev msg = do+  let c = client st+  if c == (resolveToPid ev)  -- we do not send the tracer events about itself...+     then return ()+     else sendTraceMsg c msg++sendTraceMsg :: Maybe ProcessId -> Message -> Process ()+sendTraceMsg Nothing  _   = return ()+sendTraceMsg (Just p) msg = (flip forward) p msg
+ src/Control/Distributed/Process/Management/Internal/Trace/Types.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE GADTs  #-}+{-# LANGUAGE DeriveGeneric  #-}++-- | Tracing/Debugging support - Types+module Control.Distributed.Process.Management.Internal.Trace.Types+  ( SetTrace(..)+  , TraceSubject(..)+  , TraceFlags(..)+  , TraceArg(..)+  , TraceOk(..)+  , traceLog+  , traceLogFmt+  , traceEvent+  , traceMessage+  , defaultTraceFlags+  , enableTrace+  , enableTraceSync+  , disableTrace+  , disableTraceSync+  , getTraceFlags+  , setTraceFlags+  , setTraceFlagsSync+  , getCurrentTraceClient+  ) where++import Control.Distributed.Process.Internal.Types+  ( MxEventBus(..)+  , ProcessId+  , SendPort+  , unsafeCreateUnencodedMessage+  )+import Control.Distributed.Process.Management.Internal.Bus+  ( publishEvent+  )+import Control.Distributed.Process.Management.Internal.Types+  ( MxEvent(..)+  )+import Control.Distributed.Process.Serializable+import Data.Binary+import Data.List (intersperse)+import Data.Set (Set)+import Data.Typeable+import GHC.Generics++--------------------------------------------------------------------------------+-- Types                                                                      --+--------------------------------------------------------------------------------++data SetTrace = TraceEnable !ProcessId | TraceDisable+  deriving (Typeable, Generic, Eq, Show)+instance Binary SetTrace where++-- | Defines which processes will be traced by a given 'TraceFlag',+-- either by name, or @ProcessId@. Choosing @TraceAll@ is /by far/+-- the most efficient approach, as the tracer process therefore+-- avoids deciding whether or not a trace event is viable.+--+data TraceSubject =+    TraceAll                     -- enable tracing for all running processes+  | TraceProcs !(Set ProcessId)  -- enable tracing for a set of processes+  | TraceNames !(Set String)     -- enable tracing for a set of named/registered processes+  deriving (Typeable, Generic, Show)+instance Binary TraceSubject where++-- | Defines /what/ will be traced. Flags that control tracing of+-- @Process@ events, take a 'TraceSubject' controlling which processes+-- should generate trace events in the target process.+data TraceFlags = TraceFlags {+    traceSpawned      :: !(Maybe TraceSubject) -- filter process spawned tracing+  , traceDied         :: !(Maybe TraceSubject) -- filter process died tracing+  , traceRegistered   :: !(Maybe TraceSubject) -- filter process registration tracing+  , traceUnregistered :: !(Maybe TraceSubject) -- filter process un-registration+  , traceSend         :: !(Maybe TraceSubject) -- filter process/message tracing by sender+  , traceRecv         :: !(Maybe TraceSubject) -- filter process/message tracing by receiver+  , traceNodes        :: !Bool                 -- enable node status trace events+  , traceConnections  :: !Bool                 -- enable connection status trace events+  } deriving (Typeable, Generic, Show)+instance Binary TraceFlags where++defaultTraceFlags :: TraceFlags+defaultTraceFlags =+  TraceFlags {+    traceSpawned      = Nothing+  , traceDied         = Nothing+  , traceRegistered   = Nothing+  , traceUnregistered = Nothing+  , traceSend         = Nothing+  , traceRecv         = Nothing+  , traceNodes        = False+  , traceConnections  = False+  }++data TraceArg =+    TraceStr String+  | forall a. (Show a) => Trace a++-- | A generic 'ok' response from the trace coordinator.+data TraceOk = TraceOk+  deriving (Typeable, Generic)+instance Binary TraceOk where++--------------------------------------------------------------------------------+-- Internal/Common API                                                        --+--------------------------------------------------------------------------------++traceLog :: MxEventBus -> String -> IO ()+traceLog tr s = publishEvent tr (unsafeCreateUnencodedMessage $ MxLog s)++traceLogFmt :: MxEventBus+            -> String+            -> [TraceArg]+            -> IO ()+traceLogFmt t d ls =+  traceLog t $ concat (intersperse d (map toS ls))+  where toS :: TraceArg -> String+        toS (TraceStr s) = s+        toS (Trace    a) = show a++traceEvent :: MxEventBus -> MxEvent -> IO ()+traceEvent tr ev = publishEvent tr (unsafeCreateUnencodedMessage ev)++traceMessage :: Serializable m => MxEventBus -> m -> IO ()+traceMessage tr msg = traceEvent tr (MxUser (unsafeCreateUnencodedMessage msg))++enableTrace :: MxEventBus -> ProcessId -> IO ()+enableTrace t p =+  publishEvent t (unsafeCreateUnencodedMessage ((Nothing :: Maybe (SendPort TraceOk)),+                                                (TraceEnable p)))++enableTraceSync :: MxEventBus -> SendPort TraceOk -> ProcessId -> IO ()+enableTraceSync t s p =+  publishEvent t (unsafeCreateUnencodedMessage (Just s, TraceEnable p))++disableTrace :: MxEventBus -> IO ()+disableTrace t =+  publishEvent t (unsafeCreateUnencodedMessage ((Nothing :: Maybe (SendPort TraceOk)),+                                     TraceDisable))++disableTraceSync :: MxEventBus -> SendPort TraceOk -> IO ()+disableTraceSync t s =+  publishEvent t (unsafeCreateUnencodedMessage ((Just s), TraceDisable))++setTraceFlags :: MxEventBus -> TraceFlags -> IO ()+setTraceFlags t f =+  publishEvent t (unsafeCreateUnencodedMessage ((Nothing :: Maybe (SendPort TraceOk)), f))++setTraceFlagsSync :: MxEventBus -> SendPort TraceOk -> TraceFlags -> IO ()+setTraceFlagsSync t s f =+  publishEvent t (unsafeCreateUnencodedMessage ((Just s), f))++getTraceFlags :: MxEventBus -> SendPort TraceFlags -> IO ()+getTraceFlags t s = publishEvent t (unsafeCreateUnencodedMessage s)++getCurrentTraceClient :: MxEventBus -> SendPort (Maybe ProcessId) -> IO ()+getCurrentTraceClient t s = publishEvent t (unsafeCreateUnencodedMessage s)
+ src/Control/Distributed/Process/Management/Internal/Types.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE DeriveGeneric   #-}+module Control.Distributed.Process.Management.Internal.Types+  ( MxAgentId(..)+  , MxAgentState(..)+  , MxAgent(..)+  , MxAction(..)+  , ChannelSelector(..)+  , Fork+  , MxSink+  , MxEvent(..)+  , Addressable(..)+  ) where++import Control.Concurrent.STM+  ( TChan+  )+import Control.Distributed.Process.Internal.Types+  ( Process+  , ProcessId+  , SendPortId+  , Message+  , DiedReason+  , NodeId+  )+import Control.Monad.IO.Class (MonadIO)+import qualified Control.Monad.State as ST+  ( MonadState+  , StateT+  )+import Control.Monad.Fix (MonadFix)+import Data.Binary+import Data.Typeable (Typeable)+import GHC.Generics+import Network.Transport+  ( ConnectionId+  , EndPointAddress+  )++-- | This is the /default/ management event, fired for various internal+-- events around the NT connection and Process lifecycle. All published+-- events that conform to this type, are eligible for tracing - i.e.,+-- they will be delivered to the trace controller.+--+data MxEvent =+    MxSpawned          ProcessId+    -- ^ fired whenever a local process is spawned+  | MxRegistered       ProcessId    String+    -- ^ fired whenever a process/name is registered (locally)+  | MxUnRegistered     ProcessId    String+    -- ^ fired whenever a process/name is unregistered (locally)+  | MxProcessDied      ProcessId    DiedReason+    -- ^ fired whenever a process dies+  | MxNodeDied         NodeId       DiedReason+    -- ^ fired whenever a node /dies/ (i.e., the connection is broken/disconnected)+  | MxSent             ProcessId    ProcessId Message+    -- ^ fired whenever a message is sent from a local process+  | MxSentToName       String       ProcessId Message+    -- ^ fired whenever a named send occurs+  | MxSentToPort       ProcessId    SendPortId Message+    -- ^ fired whenever a sendChan occurs+  | MxReceived         ProcessId    Message+    -- ^ fired whenever a message is received by a local process+  | MxReceivedPort     SendPortId   Message+    -- ^ fired whenever a message is received via a typed channel+  | MxConnected        ConnectionId EndPointAddress+    -- ^ fired when a network-transport connection is first established+  | MxDisconnected     ConnectionId EndPointAddress+    -- ^ fired when a network-transport connection is broken/disconnected+  | MxUser             Message+    -- ^ a user defined trace event+  | MxLog              String+    -- ^ a /logging/ event - used for debugging purposes only+  | MxTraceTakeover    ProcessId+    -- ^ notifies a trace listener that all subsequent traces will be sent to /pid/+  | MxTraceDisable+    -- ^ notifies a trace listener that it has been disabled/removed+    deriving (Typeable, Generic, Show)++instance Binary MxEvent where++-- | The class of things that we might be able to resolve to+-- a @ProcessId@ (or not).+class Addressable a where+  resolveToPid :: a -> Maybe ProcessId++instance Addressable MxEvent where+  resolveToPid (MxSpawned     p)     = Just p+  resolveToPid (MxProcessDied p _)   = Just p+  resolveToPid (MxSent        _ p _) = Just p+  resolveToPid (MxReceived    p _)   = Just p+  resolveToPid _                     = Nothing++-- | Gross though it is, this synonym represents a function+-- used to forking new processes, which has to be passed as a HOF+-- when calling mxAgentController, since there's no other way to+-- avoid a circular dependency with Node.hs+type Fork = (Process () -> IO ProcessId)++-- | A newtype wrapper for an agent id (which is a string).+newtype MxAgentId = MxAgentId { agentId :: String }+  deriving (Typeable, Binary, Eq, Ord)++data MxAgentState s = MxAgentState+                      {+                        mxAgentId     :: !MxAgentId+                      , mxBus         :: !(TChan Message)+                      , mxLocalState  :: !s+                      }++-- | Monad for management agents.+--+newtype MxAgent s a =+  MxAgent+  {+    unAgent :: ST.StateT (MxAgentState s) Process a+  } deriving ( Functor+             , Monad+             , MonadIO+             , MonadFix+             , ST.MonadState (MxAgentState s)+             , Typeable+             , Applicative+             )++data ChannelSelector = InputChan | Mailbox++-- | Represents the actions a management agent can take+-- when evaluating an /event sink/.+--+data MxAction =+    MxAgentDeactivate !String+  | MxAgentPrioritise !ChannelSelector+  | MxAgentReady+  | MxAgentSkip++-- | Type of a management agent's event sink.+type MxSink s = Message -> MxAgent s (Maybe MxAction)
src/Control/Distributed/Process/Node.hs view
@@ -1,3 +1,12 @@+{-# LANGUAGE CPP  #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE RankNTypes  #-}+{-# LANGUAGE BangPatterns  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MagicHash #-}+ -- | Local nodes -- module Control.Distributed.Process.Node@@ -12,10 +21,6 @@  -- TODO: Calls to 'sendBinary' and co (by the NC) may stall the node controller. -#if ! MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif- import System.IO (fixIO, hPutStrLn, stderr) import System.Mem.Weak (Weak, deRefWeak) import qualified Data.ByteString.Lazy as BSL (fromChunks)@@ -25,43 +30,64 @@   ( empty   , toList   , fromList-  , filter+  , partition   , partitionWithKey   , elems+  , size   , filterWithKey   , foldlWithKey   )+import Data.Time.Format (formatTime)+import Data.Time.Format (defaultTimeLocale) import Data.Set (Set) import qualified Data.Set as Set   ( empty   , insert   , delete+  , map   , member   , toList+  , union   ) import Data.Foldable (forM_)-import Data.Maybe (isJust, isNothing, catMaybes)+import Data.Maybe (isJust, fromJust, isNothing, catMaybes) import Data.Typeable (Typeable) import Control.Category ((>>>))-import Control.Applicative ((<$>))-import Control.Monad (void, when)+import Control.Applicative+import Control.Monad (void, when, join) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State.Strict (MonadState, StateT, evalStateT, gets) import qualified Control.Monad.State.Strict as StateT (get, put) import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)-import Control.Exception (throwIO, SomeException, Exception, throwTo)-import qualified Control.Exception as Exception (catch)-import Control.Concurrent (forkIO)+import Control.Exception+  ( throwIO+  , SomeException+  , Exception+  , throwTo+  , uninterruptibleMask_+  , getMaskingState+  , MaskingState(..)+  )+import qualified Control.Exception as Exception+  ( Handler(..)+  , catch+  , catches+  , finally+  )+import Control.Concurrent (forkIO, killThread)+import Control.Distributed.Process.Internal.BiMultiMap (BiMultiMap)+import qualified Control.Distributed.Process.Internal.BiMultiMap as BiMultiMap import Control.Distributed.Process.Internal.StrictMVar   ( newMVar   , withMVar+  , modifyMVarMasked   , modifyMVar-  , modifyMVar_   , newEmptyMVar   , putMVar   , takeMVar   ) import Control.Concurrent.Chan (newChan, writeChan, readChan)+import qualified Control.Concurrent.MVar as MVar (newEmptyMVar, takeMVar) import Control.Concurrent.STM   ( atomically   )@@ -70,6 +96,7 @@   , enqueue   , newCQueue   , mkWeakCQueue+  , queueSize   ) import qualified Network.Transport as NT   ( Transport@@ -81,8 +108,8 @@   , TransportError(..)   , address   , closeEndPoint-  , ConnectionId   , Connection+  , ConnectionId   , close   , EndPointAddress   , Reliability(ReliableOrdered)@@ -99,8 +126,11 @@   , LocalProcessId(..)   , ProcessId(..)   , LocalNode(..)-  , Tracer(InactiveTracer)+  , MxEventBus(..)   , LocalNodeState(..)+  , ValidLocalNodeState(..)+  , withValidLocalState+  , modifyValidLocalState   , LocalProcess(..)   , LocalProcessState(..)   , Process(..)@@ -110,9 +140,11 @@   , localPidCounter   , localPidUnique   , localProcessWithId+  , localProcesses   , localConnections   , forever'   , MonitorRef(..)+  , NodeClosedException(..)   , ProcessMonitorNotification(..)   , NodeMonitorNotification(..)   , PortMonitorNotification(..)@@ -126,58 +158,84 @@   , DidUnlinkPort(..)   , SpawnRef   , DidSpawn(..)-  , Message+  , Message(..)   , TypedChannel(..)   , Identifier(..)   , nodeOf   , ProcessInfo(..)   , ProcessInfoNone(..)+  , NodeStats(..)   , SendPortId(..)   , typedChannelWithId   , RegisterReply(..)   , WhereIsReply(..)-  , messageToPayload   , payloadToMessage-  , createMessage+  , createUnencodedMessage+  , unsafeCreateUnencodedMessage   , runLocalProcess   , firstNonReservedProcessId-  , ImplicitReconnect(WithImplicitReconnect, NoImplicitReconnect)+  , ImplicitReconnect(WithImplicitReconnect)   )-import Control.Distributed.Process.Internal.Trace+import Control.Distributed.Process.Management.Internal.Agent+  ( mxAgentController+  )+import Control.Distributed.Process.Management.Internal.Types+  ( MxEvent(..)+  )+import qualified Control.Distributed.Process.Management.Internal.Trace.Remote as Trace+  ( remoteTable+  )+import Control.Distributed.Process.Management.Internal.Trace.Tracer+  ( defaultTracer+  )+import Control.Distributed.Process.Management.Internal.Trace.Types   ( TraceArg(..)-  , traceFormat-  , startTracing-  , stopTracer+  , traceEvent+  , traceLogFmt+  , enableTrace   ) import Control.Distributed.Process.Serializable (Serializable) import Control.Distributed.Process.Internal.Messaging   ( sendBinary-  , sendMessage-  , sendPayload   , closeImplicitReconnections   , impliesDeathOf   ) import Control.Distributed.Process.Internal.Primitives   ( register-  , finally   , receiveWait   , match   , sendChan+  , unwrapMessage+  , SayMessage(..)   )-import Control.Distributed.Process.Internal.Types (SendPort)+import Control.Distributed.Process.Internal.Types (SendPort, Tracer(..)) import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn (remoteTable)-import Control.Distributed.Process.Internal.WeakTQueue (writeTQueue)+import Control.Distributed.Process.Internal.WeakTQueue (TQueue, writeTQueue) import qualified Control.Distributed.Process.Internal.StrictContainerAccessors as DAC   ( mapMaybe   , mapDefault   )+import Control.Monad.Catch (try)+import GHC.IO (IO(..), unsafeUnmask)+import GHC.Base ( maskAsyncExceptions# ) +import Unsafe.Coerce+import Prelude++-- Remove these definitions when the fix for+-- https://ghc.haskell.org/trac/ghc/ticket/10149+-- is included in all supported compilers:+block :: IO a -> IO a+block (IO io) = IO $ maskAsyncExceptions# io+unblock :: IO a -> IO a+unblock = unsafeUnmask+ -------------------------------------------------------------------------------- -- Initialization                                                             -- --------------------------------------------------------------------------------  initRemoteTable :: RemoteTable-initRemoteTable = BuiltIn.remoteTable Static.initRemoteTable+initRemoteTable = Trace.remoteTable $ BuiltIn.remoteTable Static.initRemoteTable  -- | Initialize a new local node. newLocalNode :: NT.Transport -> RemoteTable -> IO LocalNode@@ -193,68 +251,133 @@ -- | Create a new local node (without any service processes running) createBareLocalNode :: NT.EndPoint -> RemoteTable -> IO LocalNode createBareLocalNode endPoint rtable = do-  unq <- randomIO-  state <- newMVar LocalNodeState-    { _localProcesses   = Map.empty-    , _localPidCounter  = firstNonReservedProcessId-    , _localPidUnique   = unq-    , _localConnections = Map.empty-    }-  ctrlChan <- newChan-  let node = LocalNode { localNodeId   = NodeId $ NT.address endPoint-                       , localEndPoint = endPoint-                       , localState    = state-                       , localCtrlChan = ctrlChan-                       , localTracer   = InactiveTracer-                       , remoteTable   = rtable-                       }-  tracedNode <- startTracing node-  void . forkIO $ runNodeController tracedNode-  void . forkIO $ handleIncomingMessages tracedNode-  return tracedNode+    unq <- randomIO+    state <- newMVar $ LocalNodeValid $ ValidLocalNodeState+      { _localProcesses   = Map.empty+      , _localPidCounter  = firstNonReservedProcessId+      , _localPidUnique   = unq+      , _localConnections = Map.empty+      }+    ctrlChan <- newChan+    let node = LocalNode { localNodeId   = NodeId $ NT.address endPoint+                         , localEndPoint = endPoint+                         , localState    = state+                         , localCtrlChan = ctrlChan+                         , localEventBus = MxEventBusInitialising+                         , remoteTable   = rtable+                         }+    tracedNode <- startMxAgent node +    -- Once the NC terminates, the endpoint isn't much use,+    void $ forkIO $ Exception.finally (runNodeController tracedNode)+                                      (NT.closeEndPoint (localEndPoint node))++    -- whilst a closed/failing endpoint will terminate the NC+    void $ forkIO $ Exception.finally (handleIncomingMessages tracedNode)+                                      (stopNC node)++    return tracedNode+  where+    stopNC node =+       writeChan (localCtrlChan node) NCMsg+            { ctrlMsgSender = NodeIdentifier (localNodeId node)+            , ctrlMsgSignal = SigShutdown+            }++startMxAgent :: LocalNode -> IO LocalNode+startMxAgent node = do+  -- see note [tracer/forkProcess races]+  let fork = forkProcess node+  mv <- MVar.newEmptyMVar+  pid <- fork $ mxAgentController fork mv+  (tracer', wqRef, mxNew') <- MVar.takeMVar mv+  return node { localEventBus = (MxEventBus pid tracer' wqRef mxNew') }++startDefaultTracer :: LocalNode -> IO ()+startDefaultTracer node' = do+  let t = localEventBus node'+  case t of+    MxEventBus _ (Tracer pid _) _ _ -> do+      runProcess node' $ register "trace.controller" pid+      pid' <- forkProcess node' defaultTracer+      enableTrace (localEventBus node') pid'+      runProcess node' $ register "tracer.initial" pid'+    _ -> return ()++-- TODO: we need a better mechanism for defining and registering services+ -- | Start and register the service processes on a node--- (for now, this is only the logger) startServiceProcesses :: LocalNode -> IO () startServiceProcesses node = do+  -- tracing /spawns/ relies on the tracer being enabled, but we start+  -- the default tracer first, even though it might @nsend@ to the logger+  -- before /that/ process has started - this is a totally harmless race+  -- however, so we deliberably ignore it+  startDefaultTracer node   logger <- forkProcess node loop-  runProcess node $ register "logger" logger+  runProcess node $ do+    register "logger" logger+    -- The trace.logger is used for tracing to the console to avoid feedback+    -- loops during tracing if the user reregisters the "logger" with a custom+    -- process which uses 'send' or other primitives which are traced.+    register "trace.logger" logger  where-  loop = do-    receiveWait-      [ match $ \((time, pid, string) ::(String, ProcessId, String)) -> do-          liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string-          loop-      , match $ \((time, string) :: (String, String)) -> do-          -- this is a 'trace' message from the local node tracer-          liftIO . hPutStrLn stderr $ time ++ " [trace] " ++ string-          loop-      , match $ \(ch :: SendPort ()) -> -- a shutdown request-          sendChan ch ()-      ]+   loop = do+     receiveWait+       [ match $ \(SayMessage time pid string) -> do+           let time' = formatTime defaultTimeLocale "%c" time+           liftIO . hPutStrLn stderr $ time' ++ " " ++ show pid ++ ": " ++ string+           loop+       , match $ \((time, string) :: (String, String)) -> do+           -- this is a 'trace' message from the local node tracer+           liftIO . hPutStrLn stderr $ time ++ " [trace] " ++ string+           loop+       , match $ \(ch :: SendPort ()) -> -- a shutdown request+           sendChan ch ()+       ] --- | Force-close a local node------ TODO: for now we just close the associated endpoint+-- | Force-close a local node, killing all processes on that node. closeLocalNode :: LocalNode -> IO ()-closeLocalNode node =+closeLocalNode node = do+  -- Kill processes after refilling the mvar. Otherwise, there is potential for+  -- deadlock as a dying process tries to get the mvar while masking exceptions+  -- uninterruptibly.+  join $ modifyMVar (localState node) $ \st -> case st of+    LocalNodeValid vst -> do+      return ( LocalNodeClosed+             , forM_ (vst ^. localProcesses) $ \lproc ->+                 -- Semantics of 'throwTo' guarantee that target thread will get+                 -- delivered an exception. Therefore, target thread will be+                 -- killed eventually and that's as good as we can do. No need+                 -- to wait for thread to actually finish dying.+                 killThread (processThread lproc)+             )+    LocalNodeClosed -> return (LocalNodeClosed, return ())+  -- This call will have the effect of shutting down the NC as well (see+  -- 'createBareLocalNode').   NT.closeEndPoint (localEndPoint node)  -- | Run a process on a local node and wait for it to finish runProcess :: LocalNode -> Process () -> IO () runProcess node proc = do   done <- newEmptyMVar-  void $ forkProcess node (proc `finally` liftIO (putMVar done ()))-  takeMVar done+  -- TODO; When forkProcess inherits the masking state, protect the forked+  -- thread against async exceptions that could occur before 'try' is evaluated.+  void $ forkProcess node $ try proc >>= liftIO . putMVar done+  takeMVar done >>= either (throwIO :: SomeException -> IO a) return  -- | Spawn a new process on a local node forkProcess :: LocalNode -> Process () -> IO ProcessId-forkProcess node proc = modifyMVar (localState node) startProcess+forkProcess node proc = do+    ms <- getMaskingState+    modifyMVarMasked (localState node) (startProcess ms)   where-    startProcess :: LocalNodeState -> IO (LocalNodeState, ProcessId)-    startProcess st = do-      let lpid  = LocalProcessId { lpidCounter = st ^. localPidCounter-                                 , lpidUnique  = st ^. localPidUnique+    startProcess :: MaskingState+                 -> LocalNodeState+                 -> IO (LocalNodeState, ProcessId)+    startProcess ms (LocalNodeValid vst) = do+      let lpid  = LocalProcessId { lpidCounter = vst ^. localPidCounter+                                 , lpidUnique  = vst ^. localPidUnique                                  }       let pid   = ProcessId { processNodeId  = localNodeId node                             , processLocalId = lpid@@ -274,44 +397,82 @@                                  , processThread = tid                                  , processNode   = node                                  }-        tid' <- forkIO $ do-          reason <- Exception.catch-            (runLocalProcess lproc proc >> return DiedNormal)-            (return . DiedException . (show :: SomeException -> String))+        -- Rewrite this code when this is fixed:+        -- https://ghc.haskell.org/trac/ghc/ticket/10149+        let unmask = case ms of+              Unmasked              -> unblock+              MaskedInterruptible   -> block+              MaskedUninterruptible -> id+        tid' <- uninterruptibleMask_ $ forkIO $ do+          reason <- Exception.catches+            (unmask $ runLocalProcess lproc proc >> return DiedNormal)+            [ (Exception.Handler (\ex@(ProcessExitException from msg) -> do+                 mMsg <- unwrapMessage msg :: IO (Maybe String)+                 case mMsg of+                   Nothing -> return $ DiedException $ show ex+                   Just m  -> return $ DiedException ("exit-from=" ++ (show from) ++ ",reason=" ++ m)))+            , (Exception.Handler+                (return . DiedException . (show :: SomeException -> String)))]            -- [Unified: Table 4, rules termination and exiting]-          modifyMVar_ (localState node) (cleanupProcess pid)+          mconns <- modifyValidLocalState node (cleanupProcess pid)+          -- XXX: Revisit after agreeing on the bigger picture for the semantics+          -- of transport operations.+          -- https://github.com/haskell-distributed/distributed-process/issues/204+          forM_ mconns $ forkIO . mapM_ NT.close+           writeChan (localCtrlChan node) NCMsg             { ctrlMsgSender = ProcessIdentifier pid             , ctrlMsgSignal = Died (ProcessIdentifier pid) reason             }         return (tid', lproc) +      -- see note [tracer/forkProcess races]+      trace node (MxSpawned pid)+       if lpidCounter lpid == maxBound         then do+          -- TODO: this doesn't look right at all - how do we know+          -- that newUnique represents a process id that is available!?           newUnique <- randomIO-          return ( (localProcessWithId lpid ^= Just lproc)+          return ( LocalNodeValid+                 $ (localProcessWithId lpid ^= Just lproc)                  . (localPidCounter ^= firstNonReservedProcessId)                  . (localPidUnique ^= newUnique)-                 $ st+                 $ vst                  , pid                  )         else-          return ( (localProcessWithId lpid ^= Just lproc)+          return ( LocalNodeValid+                 $ (localProcessWithId lpid ^= Just lproc)                  . (localPidCounter ^: (+ 1))-                 $ st+                 $ vst                  , pid                  )+    startProcess _ LocalNodeClosed =+      throwIO $ NodeClosedException $ localNodeId node -    cleanupProcess :: ProcessId -> LocalNodeState -> IO LocalNodeState-    cleanupProcess pid st = do+    cleanupProcess :: ProcessId+                   -> ValidLocalNodeState+                   -> IO (ValidLocalNodeState, [NT.Connection])+    cleanupProcess pid vst = do       let pid' = ProcessIdentifier pid-      let (affected, unaffected) = Map.partitionWithKey (\(fr, _to) !_v -> impliesDeathOf pid' fr) (st ^. localConnections)-      mapM_ (NT.close . fst) (Map.elems affected)-      return $ (localProcessWithId (processLocalId pid) ^= Nothing)-             . (localConnections ^= unaffected)-             $ st+      let (affected, unaffected) = Map.partitionWithKey (\(fr, _to) !_v -> impliesDeathOf pid' fr) (vst ^. localConnections)+      return ( (localProcessWithId (processLocalId pid) ^= Nothing)+               . (localConnections ^= unaffected)+               $ vst+             , map fst $ Map.elems affected+             ) +-- note [tracer/forkProcess races]+--+-- Our startTracing function uses forkProcess to start the trace controller+-- process, and of course forkProcess attempts to call traceEvent once the+-- process has started. This is harmless, as the localEventBus is not updated+-- until /after/ the initial forkProcess completes, so the first call to+-- traceEvent behaves as if tracing were disabled (i.e., it is ignored).+--+ -------------------------------------------------------------------------------- -- Handle incoming messages                                                   -- --------------------------------------------------------------------------------@@ -320,8 +481,8 @@  data IncomingTarget =     Uninit-  | ToProc (Weak (CQueue Message))-  | ToChan TypedChannel+  | ToProc ProcessId (Weak (CQueue Message))+  | ToChan SendPortId TypedChannel   | ToNode  data ConnectionState = ConnectionState {@@ -348,6 +509,7 @@  handleIncomingMessages :: LocalNode -> IO () handleIncomingMessages node = go initConnectionState+   `Exception.catch` \(NodeClosedException _) -> return ()   where     go :: ConnectionState -> IO ()     go !st = do@@ -355,28 +517,37 @@       case event of         NT.ConnectionOpened cid rel theirAddr ->           if rel == NT.ReliableOrdered-            then go ( (incomingAt cid ^= Just (theirAddr, Uninit))+            then+              trace node (MxConnected cid theirAddr)+              >> go (+                      (incomingAt cid ^= Just (theirAddr, Uninit))                     . (incomingFrom theirAddr ^: Set.insert cid)                     $ st                     )-            else invalidRequest cid st+            else invalidRequest cid st $+                  "attempt to connect with unsupported reliability " ++ show rel         NT.Received cid payload ->           case st ^. incomingAt cid of-            Just (_, ToProc weakQueue) -> do+            Just (_, ToProc pid weakQueue) -> do               mQueue <- deRefWeak weakQueue               forM_ mQueue $ \queue -> do                 -- TODO: if we find that the queue is Nothing, should we remove                 -- it from the NC state? (and same for channels, below)                 let msg = payloadToMessage payload                 enqueue queue msg -- 'enqueue' is strict+                trace node (MxReceived pid msg)               go st-            Just (_, ToChan (TypedChannel chan')) -> do+            Just (_, ToChan chId (TypedChannel chan')) -> do               mChan <- deRefWeak chan'               -- If mChan is Nothing, the process has given up the read end of               -- the channel and we simply ignore the incoming message-              forM_ mChan $ \chan -> atomically $-                -- We make sure the message is fully decoded when it is enqueued-                writeTQueue chan $! decode (BSL.fromChunks payload)+              forM_ mChan $ \chan -> do+                msg' <- atomically $ do+                  msg <- return $! decode (BSL.fromChunks payload)+                  -- We make sure the message is fully decoded when it is enqueued+                  writeTQueue chan msg+                  return msg+                trace node $ MxReceivedPort chId $ unsafeCreateUnencodedMessage msg'               go st             Just (_, ToNode) -> do               let ctrlMsg = decode . BSL.fromChunks $ payload@@ -386,37 +557,49 @@               case decode (BSL.fromChunks payload) of                 ProcessIdentifier pid -> do                   let lpid = processLocalId pid-                  mProc <- withMVar state $ return . (^. localProcessWithId lpid)+                  mProc <- withValidLocalState node $ return . (^. localProcessWithId lpid)                   case mProc of                     Just proc ->-                      go (incomingAt cid ^= Just (src, ToProc (processWeakQ proc)) $ st)+                      go (incomingAt cid ^= Just (src, ToProc pid (processWeakQ proc)) $ st)                     Nothing ->-                      invalidRequest cid st+                      -- incoming attempt to connect to unknown process - might+                      -- be dead already+                      go (incomingAt cid ^= Nothing $ st)                 SendPortIdentifier chId -> do                   let lcid = sendPortLocalId chId                       lpid = processLocalId (sendPortProcessId chId)-                  mProc <- withMVar state $ return . (^. localProcessWithId lpid)+                  mProc <- withValidLocalState node $ return . (^. localProcessWithId lpid)                   case mProc of                     Just proc -> do                       mChannel <- withMVar (processState proc) $ return . (^. typedChannelWithId lcid)                       case mChannel of                         Just channel ->-                          go (incomingAt cid ^= Just (src, ToChan channel) $ st)+                          go (incomingAt cid ^= Just (src, ToChan chId channel) $ st)                         Nothing ->-                          invalidRequest cid st+                          invalidRequest cid st $+                            "incoming attempt to connect to unknown channel of"+                            ++ " process " ++ show (sendPortProcessId chId)                     Nothing ->-                      invalidRequest cid st+                      -- incoming attempt to connect to channel of unknown+                      -- process - might be dead already+                      go (incomingAt cid ^= Nothing $ st)                 NodeIdentifier nid ->                   if nid == localNodeId node                     then go (incomingAt cid ^= Just (src, ToNode) $ st)-                    else invalidRequest cid st+                    else invalidRequest cid st $+                           "incoming attempt to connect to a different node -"+                           ++ " I'm " ++ show (localNodeId node)+                           ++ " but the remote peer wants to connect to "+                           ++  show nid             Nothing ->               invalidRequest cid st+                "message received from an unknown connection"         NT.ConnectionClosed cid ->           case st ^. incomingAt cid of             Nothing ->-              invalidRequest cid st-            Just (src, _) ->+              invalidRequest cid st "closed unknown connection"+            Just (src, _) -> do+              trace node (MxDisconnected cid src)               go ( (incomingAt cid ^= Nothing)                  . (incomingFrom src ^: Set.delete cid)                  $ st@@ -435,32 +618,30 @@              $ st              )         NT.ErrorEvent (NT.TransportError NT.EventEndPointFailed str) ->-          fatal $ "Cloud Haskell fatal error: end point failed: " ++ str+          fail $ "Cloud Haskell fatal error: end point failed: " ++ str         NT.ErrorEvent (NT.TransportError NT.EventTransportFailed str) ->-          fatal $ "Cloud Haskell fatal error: transport failed: " ++ str+          fail $ "Cloud Haskell fatal error: transport failed: " ++ str         NT.EndPointClosed ->-          stopTracer (localTracer node) >> return ()+          return ()         NT.ReceivedMulticast _ _ ->           -- If we received a multicast message, something went horribly wrong           -- and we just give up-          fatal "Cloud Haskell fatal error: received unexpected multicast"--    fatal :: String -> IO ()-    fatal msg = stopTracer (localTracer node) >> fail msg+          fail "Cloud Haskell fatal error: received unexpected multicast" -    invalidRequest :: NT.ConnectionId -> ConnectionState -> IO ()-    invalidRequest cid st = do+    invalidRequest :: NT.ConnectionId -> ConnectionState -> String -> IO ()+    invalidRequest cid st msg = do       -- TODO: We should treat this as a fatal error on the part of the remote       -- node. That is, we should report the remote node as having died, and we       -- should close incoming connections (this requires a Transport layer       -- extension).-      traceEventFmtIO node "" [(TraceStr "[network] invalid request: "),-                               (Trace cid)]+      traceEventFmtIO node "" [ TraceStr $ " [network] invalid request"+                                           ++ " (" ++ msg ++ "): "+                              , (Trace cid)+                              ]       go ( incomingAt cid ^= Nothing          $ st          ) -    state    = localState node     endpoint = localEndPoint node     ctrlChan = localCtrlChan node @@ -469,8 +650,9 @@ --------------------------------------------------------------------------------  runNodeController :: LocalNode -> IO ()-runNodeController =-  runReaderT (evalStateT (unNC nodeController) initNCState)+runNodeController node =+  runReaderT (evalStateT (unNC nodeController) initNCState) node+   `Exception.catch` \(NodeClosedException _) -> return ()  -------------------------------------------------------------------------------- -- Internal data types                                                        --@@ -478,20 +660,26 @@  data NCState = NCState   {  -- Mapping from remote processes to linked local processes-    _links    :: !(Map Identifier (Set ProcessId))+    _links    :: !(BiMultiMap Identifier ProcessId ())      -- Mapping from remote processes to monitoring local processes-  , _monitors :: !(Map Identifier (Set (ProcessId, MonitorRef)))+  , _monitors :: !(BiMultiMap Identifier ProcessId MonitorRef)      -- Process registry: names and where they live, mapped to the PIDs   , _registeredHere :: !(Map String ProcessId)   , _registeredOnNodes :: !(Map ProcessId [(NodeId,Int)])   }  newtype NC a = NC { unNC :: StateT NCState (ReaderT LocalNode IO) a }-  deriving (Functor, Monad, MonadIO, MonadState NCState, MonadReader LocalNode)+  deriving ( Applicative+           , Functor+           , Monad+           , MonadIO+           , MonadState NCState+           , MonadReader LocalNode+           )  initNCState :: NCState-initNCState = NCState { _links    = Map.empty-                      , _monitors = Map.empty+initNCState = NCState { _links    = BiMultiMap.empty+                      , _monitors = BiMultiMap.empty                       , _registeredHere = Map.empty                       , _registeredOnNodes = Map.empty                       }@@ -507,35 +695,61 @@   show (ProcessKillException pid reason) =     "killed-by=" ++ show pid ++ ",reason=" ++ reason +ncSendToProcess :: ProcessId -> Message -> NC ()+ncSendToProcess = ncSendToProcessAndTrace True++ncSendToProcessAndTrace :: Bool -> ProcessId -> Message -> NC ()+ncSendToProcessAndTrace shouldTrace pid msg = do+    node <- ask+    if processNodeId pid == localNodeId node+      then ncEffectLocalSendAndTrace shouldTrace node pid msg+      else liftIO $ sendBinary node+             (NodeIdentifier $ localNodeId node)+             (NodeIdentifier $ processNodeId pid)+             WithImplicitReconnect+             NCMsg { ctrlMsgSender = NodeIdentifier $ localNodeId node+                   , ctrlMsgSignal = UnreliableSend (processLocalId pid) msg+                   }++ncSendToNode :: NodeId -> NCMsg -> NC ()+ncSendToNode to msg = do+    node <- ask+    liftIO $ if to == localNodeId node+      then writeChan (localCtrlChan node) $! msg+      else sendBinary node+             (NodeIdentifier $ localNodeId node)+             (NodeIdentifier to)+             WithImplicitReconnect+             msg+ -------------------------------------------------------------------------------- -- Tracing/Debugging                                                          -- -------------------------------------------------------------------------------- --- [Issue #104]+-- [Issue #104 / DP-13]  traceNotifyDied :: LocalNode -> Identifier -> DiedReason -> NC () traceNotifyDied node ident reason =-  case reason of-    DiedNormal -> return ()-    _ -> traceNcEventFmt node " "-                         [(TraceStr "[node-controller]"),-                          (Trace ident),-                          (Trace reason)]--traceNcEventFmt :: LocalNode -> String -> [TraceArg] -> NC ()-traceNcEventFmt node fmt args =-  liftIO $ traceEventFmtIO node fmt args+  -- TODO: sendPortDied notifications+  liftIO $ withLocalTracer node $ \t ->+    case ident of+      (NodeIdentifier nid)    -> traceEvent t (MxNodeDied nid reason)+      (ProcessIdentifier pid) -> traceEvent t (MxProcessDied pid reason)+      _                       -> return ()  traceEventFmtIO :: LocalNode                 -> String                 -> [TraceArg]                 -> IO () traceEventFmtIO node fmt args =-  withLocalTracer node $ \t -> traceFormat t fmt args+  withLocalTracer node $ \t -> traceLogFmt t fmt args -withLocalTracer :: LocalNode -> (Tracer -> IO ()) -> IO ()-withLocalTracer node act = act (localTracer node)+trace :: LocalNode -> MxEvent -> IO ()+trace node ev = withLocalTracer node $ \t -> traceEvent t ev +withLocalTracer :: LocalNode -> (MxEventBus -> IO ()) -> IO ()+withLocalTracer node act = act (localEventBus node)+ -------------------------------------------------------------------------------- -- Core functionality                                                         -- --------------------------------------------------------------------------------@@ -550,11 +764,7 @@     -- [Unified: Table 7, rule nc_forward]     case destNid (ctrlMsgSignal msg) of       Just nid' | nid' /= localNodeId node ->-        liftIO $ sendBinary node-                            (ctrlMsgSender msg)-                            (NodeIdentifier nid')-                            WithImplicitReconnect-                            msg+        ncSendToNode nid' msg       _ ->         return () @@ -575,14 +785,26 @@         ncEffectRegister from label atnode pid force       NCMsg (ProcessIdentifier from) (WhereIs label) ->         ncEffectWhereIs from label-      NCMsg from (NamedSend label msg') ->-        ncEffectNamedSend from label msg'+      NCMsg _ (NamedSend label msg') ->+        ncEffectNamedSend label msg'+      NCMsg _ (UnreliableSend lpid msg') ->+        ncEffectLocalSend node (ProcessId (localNodeId node) lpid) msg'+      NCMsg _ (LocalSend to msg') ->+        ncEffectLocalSend node to msg'+      NCMsg _ (LocalPortSend to msg') ->+        ncEffectLocalPortSend to msg'       NCMsg (ProcessIdentifier from) (Kill to reason) ->         ncEffectKill from to reason       NCMsg (ProcessIdentifier from) (Exit to reason) ->         ncEffectExit from to reason       NCMsg (ProcessIdentifier from) (GetInfo pid) ->         ncEffectGetInfo from pid+      NCMsg _ SigShutdown ->+        liftIO $ do+          NT.closeEndPoint (localEndPoint node)+            `Exception.finally` throwIO (NodeClosedException $ localNodeId node)+      NCMsg (ProcessIdentifier from) (GetNodeStats nid) ->+        ncEffectGetNodeStats from nid       unexpected ->         error $ "nodeController: unexpected message " ++ show unexpected @@ -600,22 +822,18 @@   case (shouldLink, isLocal node (ProcessIdentifier from)) of     (True, _) ->  -- [Unified: first rule]       case mRef of-        Just ref -> modify' $ monitorsFor them ^: Set.insert (from, ref)-        Nothing  -> modify' $ linksFor them ^: Set.insert from+        Just ref -> modify' $ monitors ^: BiMultiMap.insert them from ref+        Nothing  -> modify' $ links ^: BiMultiMap.insert them from ()     (False, True) -> -- [Unified: second rule]       notifyDied from them DiedUnknownId mRef     (False, False) -> -- [Unified: third rule]       -- TODO: this is the right sender according to the Unified semantics,       -- but perhaps having 'them' as the sender would make more sense       -- (see also: notifyDied)-      liftIO $ sendBinary node-                          (NodeIdentifier $ localNodeId node)-                          (NodeIdentifier $ processNodeId from)-                          WithImplicitReconnect-        NCMsg-          { ctrlMsgSender = NodeIdentifier (localNodeId node)-          , ctrlMsgSignal = Died them DiedUnknownId-          }+      ncSendToNode (processNodeId from) $ NCMsg+        { ctrlMsgSender = NodeIdentifier (localNodeId node)+        , ctrlMsgSignal = Died them DiedUnknownId+        }  -- [Unified: Table 11] ncEffectUnlink :: ProcessId -> Identifier -> NC ()@@ -629,7 +847,7 @@         postAsMessage from $ DidUnlinkNode nid       SendPortIdentifier cid ->         postAsMessage from $ DidUnlinkPort cid-  modify' $ linksFor them ^: Set.delete from+  modify' $ links ^: BiMultiMap.delete them from ()  -- [Unified: Table 11] ncEffectUnmonitor :: ProcessId -> MonitorRef -> NC ()@@ -637,7 +855,7 @@   node <- ask   when (isLocal node (ProcessIdentifier from)) $     postAsMessage from $ DidUnmonitor ref-  modify' $ monitorsFor (monitorRefIdent ref) ^: Set.delete (from, ref)+  modify' $ monitors ^: BiMultiMap.delete (monitorRefIdent ref) from ref  -- [Unified: Table 12] ncEffectDied :: Identifier -> DiedReason -> NC ()@@ -652,7 +870,7 @@   let localOnly = case ident of NodeIdentifier _ -> True ; _ -> False    forM_ (Map.toList affectedLinks) $ \(them, uss) ->-    forM_ uss $ \us ->+    forM_ uss $ \(us, _) ->       when (localOnly <= isLocal node (ProcessIdentifier us)) $         notifyDied us them reason Nothing @@ -661,30 +879,51 @@       when (localOnly <= isLocal node (ProcessIdentifier us)) $         notifyDied us them reason (Just ref) -  modify' $ (links ^= unaffectedLinks) . (monitors ^= unaffectedMons)+  -- Notify remote nodes that the process died so it can be removed from monitor+  -- lists.+  mapM_ (forwardDeath node) $+    [ nid | ProcessIdentifier pid <- [ident]+          , i <- Set.toList $ Set.union+             (Set.map fst $ BiMultiMap.lookupBy2nd pid unaffectedLinks)+             (Set.map fst $ BiMultiMap.lookupBy2nd pid unaffectedMons)+          , let nid = nodeOf i+          , nid /= localNodeId node+    ] -  modify' $ registeredHere ^: Map.filter (\pid -> not $ ident `impliesDeathOf` ProcessIdentifier pid)+  -- Delete monitors in the local node.+  let deleteDeads :: (Ord a, Ord v)+                  => BiMultiMap a ProcessId v -> BiMultiMap a ProcessId v+      deleteDeads = case ident of+                      -- deleteAllBy2nd is faster than partitionWithKeyBy2nd+                      ProcessIdentifier pid -> BiMultiMap.deleteAllBy2nd pid+                      _ -> snd . BiMultiMap.partitionWithKeyBy2nd+                        (\pid _ -> ident `impliesDeathOf` ProcessIdentifier pid)+      unaffectedLinks' = deleteDeads unaffectedLinks+      unaffectedMons' = deleteDeads unaffectedMons +  modify' $ (links ^= unaffectedLinks') . (monitors ^= unaffectedMons')++  -- we now consider all labels for this identifier unregistered+  let toDrop pid = not $ ident `impliesDeathOf` ProcessIdentifier pid+  (keepNames, dropNames) <- Map.partition toDrop <$> gets (^. registeredHere)+  mapM_ (\(p, l) -> liftIO $ trace node (MxUnRegistered l p)) (Map.toList dropNames)+  modify' $ registeredHere ^= keepNames+   remaining <- fmap Map.toList (gets (^. registeredOnNodes)) >>=       mapM (\(pid,nidlist) ->         case ident `impliesDeathOf` ProcessIdentifier pid of            True ->               do forM_ nidlist $ \(nid,_) ->                    when (not $ isLocal node (NodeIdentifier nid))-                      (forwardNameDeath node nid)+                      (forwardDeath node nid)                  return Nothing            False -> return $ Just (pid,nidlist)  )   modify' $ registeredOnNodes ^= (Map.fromList (catMaybes remaining))     where-       forwardNameDeath node nid =-                   liftIO $ sendBinary node-                             (NodeIdentifier $ localNodeId node)-                             (NodeIdentifier $ nid)-                             WithImplicitReconnect-                             NCMsg-                             { ctrlMsgSender = NodeIdentifier (localNodeId node)-                             , ctrlMsgSignal = Died ident reason-                             }+       forwardDeath node nid = ncSendToNode nid+           NCMsg { ctrlMsgSender = NodeIdentifier (localNodeId node)+                 , ctrlMsgSignal = Died ident reason+                 }  -- [Unified: Table 13] ncEffectSpawn :: ProcessId -> Closure (Process ()) -> SpawnRef -> NC ()@@ -692,16 +931,13 @@   mProc <- unClosure cProc   -- If the closure does not exist, we spawn a process that throws an exception   -- This allows the remote node to find out what's happening+  -- TODO:   let proc = case mProc of                Left err -> fail $ "Error: Could not resolve closure: " ++ err                Right p  -> p   node <- ask   pid' <- liftIO $ forkProcess node proc-  liftIO $ sendMessage node-                       (NodeIdentifier (localNodeId node))-                       (ProcessIdentifier pid)-                       WithImplicitReconnect-                       (DidSpawn ref pid')+  ncSendToProcess pid $ unsafeCreateUnencodedMessage $ DidSpawn ref pid'  -- Unified semantics does not explicitly describe how to implement 'register', -- but mentions it's "very similar to nsend" (Table 14)@@ -719,14 +955,19 @@               return $ (isNothing currentVal /= reregistration) &&                 (not (isLocal node (ProcessIdentifier thepid) ) || isvalidlocal )   if isLocal node (NodeIdentifier atnode)-     then do when (isOk) $+     then do when isOk $                do modify' $ registeredHereFor label ^= mPid                   updateRemote node currentVal mPid-             liftIO $ sendMessage node-                       (NodeIdentifier (localNodeId node))-                       (ProcessIdentifier from)-                       WithImplicitReconnect-                       (RegisterReply label isOk)+                  case mPid of+                    (Just p) -> do+                      if reregistration+                        then liftIO $ trace node (MxUnRegistered (fromJust currentVal) label)+                        else return ()+                      liftIO $ trace node (MxRegistered p label)+                    Nothing  -> liftIO $ trace node (MxUnRegistered (fromJust currentVal) label)+             newVal <- gets (^. registeredHereFor label)+             ncSendToProcess from $ unsafeCreateUnencodedMessage $+               RegisterReply label isOk newVal      else let operation =                  case reregistration of                     True -> flip decList@@ -744,6 +985,7 @@             updateRemote _ _ _ = return ()             maybeify f Nothing = unmaybeify $ f []             maybeify f (Just x) = unmaybeify $ f x+             unmaybeify [] = Nothing             unmaybeify x = Just x             incList [] tag = [(tag,1)]@@ -755,40 +997,62 @@             decList (x:xs) tag = x:decList xs tag             forward node to reg =               when (not $ isLocal node (NodeIdentifier to)) $-                    liftIO $ sendBinary node-                                        (ProcessIdentifier from)-                                        (NodeIdentifier to)-                                        WithImplicitReconnect-                                        NCMsg-                                         { ctrlMsgSender = ProcessIdentifier from-                                         , ctrlMsgSignal = reg-                                         }+                ncSendToNode to $ NCMsg { ctrlMsgSender = ProcessIdentifier from+                                        , ctrlMsgSignal = reg+                                        }   -- Unified semantics does not explicitly describe 'whereis' ncEffectWhereIs :: ProcessId -> String -> NC () ncEffectWhereIs from label = do-  node <- ask   mPid <- gets (^. registeredHereFor label)-  liftIO $ sendMessage node-                       (NodeIdentifier (localNodeId node))-                       (ProcessIdentifier from)-                       WithImplicitReconnect-                       (WhereIsReply label mPid)+  ncSendToProcess from $ unsafeCreateUnencodedMessage $ WhereIsReply label mPid  -- [Unified: Table 14]-ncEffectNamedSend :: Identifier -> String -> Message -> NC ()-ncEffectNamedSend from label msg = do-  node <- ask+ncEffectNamedSend :: String -> Message -> NC ()+ncEffectNamedSend label msg = do   mPid <- gets (^. registeredHereFor label)   -- If mPid is Nothing, we just ignore the named send (as per Table 14)-  forM_ mPid $ \pid ->-    liftIO $ sendPayload node-                         from-                         (ProcessIdentifier pid)-                         NoImplicitReconnect-                         (messageToPayload msg)+  forM_ mPid $ \to ->+    -- If this is a trace message we don't trace it to avoid entering a loop+    -- where trace messages produce more trace messages.+    ncSendToProcessAndTrace (label /= "trace.logger") to msg +-- [Issue #DP-20]+ncEffectLocalSend :: LocalNode -> ProcessId -> Message -> NC ()+ncEffectLocalSend = ncEffectLocalSendAndTrace True++ncEffectLocalSendAndTrace :: Bool -> LocalNode -> ProcessId -> Message -> NC ()+ncEffectLocalSendAndTrace shouldTrace node to msg =+  liftIO $ withLocalProc node to $ \p -> do+    enqueue (processQueue p) msg+    when shouldTrace $ trace node (MxReceived to msg)++-- [Issue #DP-20]+ncEffectLocalPortSend :: SendPortId -> Message -> NC ()+ncEffectLocalPortSend from msg = do+  node <- ask+  let pid = sendPortProcessId from+      cid = sendPortLocalId   from+  liftIO $ withLocalProc node pid $ \proc -> do+    mChan <- withMVar (processState proc) $ return . (^. typedChannelWithId cid)+    case mChan of+      -- in the unlikely event we know nothing about this channel id,+      -- there's little to be done - perhaps some logging/tracing though...+      Nothing -> return ()+      Just (TypedChannel chan') -> do+        -- If ch is Nothing, the process has given up the read end of+        -- the channel and we simply ignore the incoming message - this+        ch <- deRefWeak chan'+        forM_ ch $ \chan -> deliverChan node from msg chan+  where deliverChan :: forall a . LocalNode -> SendPortId -> Message -> TQueue a -> IO ()+        deliverChan n p (UnencodedMessage _ raw) chan' = do+            atomically $ writeTQueue chan' ((unsafeCoerce raw) :: a)+            trace n (MxReceivedPort p $ unsafeCreateUnencodedMessage raw)+        deliverChan _ _ (EncodedMessage   _ _) _ =+            -- this will not happen unless someone screws with Primitives.hs+            error "invalid local channel delivery"+ -- [Issue #69] ncEffectKill :: ProcessId -> ProcessId -> String -> NC () ncEffectKill from to reason = do@@ -810,46 +1074,56 @@       them = (ProcessIdentifier pid)   in do   node <- ask-  mProc <- liftIO $-            withMVar (localState node) $ return . (^. localProcessWithId lpid)+  mProc <- liftIO $ withValidLocalState node+                  $ return . (^. localProcessWithId lpid)   case mProc of     Nothing   -> dispatch (isLocal node (ProcessIdentifier from))-                          from node (ProcessInfoNone DiedUnknownId)-    Just _    -> do-      itsLinks    <- gets (^. linksFor    them)-      itsMons     <- gets (^. monitorsFor them)+                          from (ProcessInfoNone DiedUnknownId)+    Just proc -> do+      itsLinks    <- Set.map fst . BiMultiMap.lookupBy1st them <$>+                       gets (^. links)+      itsMons     <- BiMultiMap.lookupBy1st them <$> gets (^. monitors)       registered  <- gets (^. registeredHere)+      size        <- liftIO $ queueSize $ processQueue $ proc        let reg = registeredNames registered       dispatch (isLocal node (ProcessIdentifier from))                from-               node                ProcessInfo {                    infoNode               = (processNodeId pid)                  , infoRegisteredNames    = reg-                   -- we cannot populate this field-                 , infoMessageQueueLength = Nothing-                 , infoMonitors       = Set.toList itsMons-                 , infoLinks          = Set.toList itsLinks+                 , infoMessageQueueLength = size+                 , infoMonitors           = Set.toList itsMons+                 , infoLinks              = Set.toList itsLinks                  }-  where dispatch :: (Serializable a, Show a)+  where dispatch :: (Serializable a)                  => Bool                  -> ProcessId-                 -> LocalNode                  -> a                  -> NC ()-        dispatch True  dest _    pInfo = postAsMessage dest $ pInfo-        dispatch False dest node pInfo = do-            liftIO $ sendMessage node-                                 (NodeIdentifier (localNodeId node))-                                 (ProcessIdentifier dest)-                                 WithImplicitReconnect-                                 pInfo+        dispatch True  dest pInfo = postAsMessage dest $ pInfo+        dispatch False dest pInfo =+          ncSendToProcess dest $ unsafeCreateUnencodedMessage pInfo          registeredNames = Map.foldlWithKey (\ks k v -> if v == pid                                                  then (k:ks)                                                  else ks) [] +ncEffectGetNodeStats :: ProcessId -> NodeId -> NC ()+ncEffectGetNodeStats from _nid = do+  node <- ask+  ncState <- StateT.get+  nodeState <- liftIO $ withValidLocalState node return+  let stats =+        NodeStats {+            nodeStatsNode = localNodeId node+          , nodeStatsRegisteredNames = Map.size $ ncState ^. registeredHere+          , nodeStatsMonitors = BiMultiMap.size $ ncState ^. monitors+          , nodeStatsLinks = BiMultiMap.size $ ncState ^. links+          , nodeStatsProcesses = Map.size (nodeState ^. localProcesses)+          }+  postAsMessage from stats+ -------------------------------------------------------------------------------- -- Auxiliary                                                                  -- --------------------------------------------------------------------------------@@ -876,32 +1150,33 @@       throwException dest $ PortLinkException pid reason     (False, _, _) ->       -- The change in sender comes from [Unified: Table 10]-      liftIO $ sendBinary node-                          (NodeIdentifier $ localNodeId node)-                          (NodeIdentifier $ processNodeId dest)-                          WithImplicitReconnect-        NCMsg-          { ctrlMsgSender = NodeIdentifier (localNodeId node)-          , ctrlMsgSignal = Died src reason-          }+      ncSendToNode (processNodeId dest) $ NCMsg+        { ctrlMsgSender = NodeIdentifier (localNodeId node)+        , ctrlMsgSignal = Died src reason+        }  -- | [Unified: Table 8] destNid :: ProcessSignal -> Maybe NodeId-destNid (Link ident)        = Just $ nodeOf ident-destNid (Unlink ident)      = Just $ nodeOf ident-destNid (Monitor ref)       = Just $ nodeOf (monitorRefIdent ref)-destNid (Unmonitor ref)     = Just $ nodeOf (monitorRefIdent ref)-destNid (Spawn _ _)         = Nothing-destNid (Register _ _ _ _)  = Nothing-destNid (WhereIs _)         = Nothing-destNid (NamedSend _ _)     = Nothing+destNid (Link ident)          = Just $ nodeOf ident+destNid (Unlink ident)        = Just $ nodeOf ident+destNid (Monitor ref)         = Just $ nodeOf (monitorRefIdent ref)+destNid (Unmonitor ref)       = Just $ nodeOf (monitorRefIdent ref)+destNid (Spawn _ _)           = Nothing+destNid (Register _ _ _ _)    = Nothing+destNid (WhereIs _)           = Nothing+destNid (NamedSend _ _)       = Nothing+destNid (UnreliableSend _ _)  = Nothing -- We don't need to forward 'Died' signals; if monitoring/linking is setup, -- then when a local process dies the monitoring/linking machinery will take -- care of notifying remote nodes-destNid (Died _ _)          = Nothing-destNid (Kill pid _)        = Just $ processNodeId pid-destNid (Exit pid _)        = Just $ processNodeId pid-destNid (GetInfo pid)       = Just $ processNodeId pid+destNid (Died _ _)            = Nothing+destNid (Kill pid _)          = Just $ processNodeId pid+destNid (Exit pid _)          = Just $ processNodeId pid+destNid (GetInfo pid)         = Just $ processNodeId pid+destNid (GetNodeStats nid)    = Just nid+destNid (LocalSend pid _)     = Just $ processNodeId pid+destNid (LocalPortSend cid _) = Just $ processNodeId (sendPortProcessId cid)+destNid (SigShutdown)       = Nothing  -- | Check if a process is local to our own node isLocal :: LocalNode -> Identifier -> Bool@@ -917,7 +1192,7 @@ isValidLocalIdentifier :: Identifier -> NC Bool isValidLocalIdentifier ident = do   node <- ask-  liftIO . withMVar (localState node) $ \nSt ->+  liftIO . withValidLocalState node $ \nSt ->     case ident of       NodeIdentifier nid ->         return $ nid == localNodeId node@@ -938,34 +1213,37 @@ --------------------------------------------------------------------------------  postAsMessage :: Serializable a => ProcessId -> a -> NC ()-postAsMessage pid = postMessage pid . createMessage+postAsMessage pid = postMessage pid . createUnencodedMessage  postMessage :: ProcessId -> Message -> NC () postMessage pid msg = do-  withLocalProc pid $ \p -> enqueue (processQueue p) msg+  node <- ask+  liftIO $ withLocalProc node pid $ \p -> enqueue (processQueue p) msg  throwException :: Exception e => ProcessId -> e -> NC ()-throwException pid e = withLocalProc pid $ \p ->-  throwTo (processThread p) e--withLocalProc :: ProcessId -> (LocalProcess -> IO ()) -> NC ()-withLocalProc pid p = do+throwException pid e = do   node <- ask-  liftIO $ do-    -- By [Unified: table 6, rule missing_process] messages to dead processes-    -- can silently be dropped-    let lpid = processLocalId pid-    mProc <- withMVar (localState node) $ return . (^. localProcessWithId lpid)-    forM_ mProc p+  -- throwTo blocks until the exception is received by the target thread.+  -- We cannot easily make it happen asynchronpusly because then 'unlink'+  -- semantics would break.+  liftIO $ withLocalProc node pid $ \p -> throwTo (processThread p) e +withLocalProc :: LocalNode -> ProcessId -> (LocalProcess -> IO ()) -> IO ()+withLocalProc node pid p =+  -- By [Unified: table 6, rule missing_process] messages to dead processes+  -- can silently be dropped+  let lpid = processLocalId pid in do+  join $ withValidLocalState node $ \vst ->+    return $ forM_ (vst ^. localProcessWithId lpid) p+ -------------------------------------------------------------------------------- -- Accessors                                                                  -- -------------------------------------------------------------------------------- -links :: Accessor NCState (Map Identifier (Set ProcessId))+links :: Accessor NCState (BiMultiMap Identifier ProcessId ()) links = accessor _links (\ls st -> st { _links = ls }) -monitors :: Accessor NCState (Map Identifier (Set (ProcessId, MonitorRef)))+monitors :: Accessor NCState (BiMultiMap Identifier ProcessId MonitorRef) monitors = accessor _monitors (\ms st -> st { _monitors = ms })  registeredHere :: Accessor NCState (Map String ProcessId)@@ -974,12 +1252,6 @@ registeredOnNodes :: Accessor NCState (Map ProcessId [(NodeId, Int)]) registeredOnNodes = accessor _registeredOnNodes (\ry st -> st { _registeredOnNodes = ry }) -linksFor :: Identifier -> Accessor NCState (Set ProcessId)-linksFor ident = links >>> DAC.mapDefault Set.empty ident--monitorsFor :: Identifier -> Accessor NCState (Set (ProcessId, MonitorRef))-monitorsFor ident = monitors >>> DAC.mapDefault Set.empty ident- registeredHereFor :: String -> Accessor NCState (Maybe ProcessId) registeredHereFor ident = registeredHere >>> DAC.mapMaybe ident @@ -1006,10 +1278,12 @@ -- * the notifications for typed channels to that process. -- -- See https://github.com/haskell/containers/issues/14 for the bang on _v.-splitNotif :: Identifier-           -> Map Identifier a-           -> (Map Identifier a, Map Identifier a)-splitNotif ident = Map.partitionWithKey (\k !_v -> ident `impliesDeathOf` k)+splitNotif :: (Ord a, Ord v)+           => Identifier+           -> BiMultiMap Identifier a v+           -> (Map Identifier (Set (a,v)), BiMultiMap Identifier a v)+splitNotif ident =+    BiMultiMap.partitionWithKeyBy1st (\k !_v -> ident `impliesDeathOf` k)  -------------------------------------------------------------------------------- -- Auxiliary                                                                  --
src/Control/Distributed/Process/Serializable.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE ConstraintKinds  #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE GADTs  #-} module Control.Distributed.Process.Serializable   ( Serializable   , encodeFingerprint@@ -7,31 +13,35 @@   , Fingerprint   , showFingerprint   , SerializableDict(SerializableDict)+  , TypeableDict(TypeableDict)   ) where  import Data.Binary (Binary)-import Data.Typeable (Typeable(..))-import Data.Typeable.Internal (TypeRep(TypeRep))++import Data.Typeable (Typeable, typeRepFingerprint, typeOf)+ import Numeric (showHex) import Control.Exception (throw) import GHC.Fingerprint.Type (Fingerprint(..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import qualified Data.ByteString.Internal as BSI ( unsafeCreate-                                                 , inlinePerformIO-                                                 , toForeignPtr-                                                 )+import qualified Data.ByteString.Internal as BSI ( unsafeCreate, toForeignPtr ) import Foreign.Storable (pokeByteOff, peekByteOff, sizeOf) import Foreign.ForeignPtr (withForeignPtr)+import System.IO.Unsafe (unsafePerformIO)  -- | Reification of 'Serializable' (see "Control.Distributed.Process.Closure") data SerializableDict a where     SerializableDict :: Serializable a => SerializableDict a   deriving (Typeable) +-- | Reification of 'Typeable'.+data TypeableDict a where+    TypeableDict :: Typeable a => TypeableDict a+  deriving (Typeable)+ -- | Objects that can be sent across the network-class (Binary a, Typeable a) => Serializable a-instance (Binary a, Typeable a) => Serializable a+type Serializable a = (Binary a, Typeable a)  -- | Encode type representation as a bytestring encodeFingerprint :: Fingerprint -> ByteString@@ -45,7 +55,7 @@ decodeFingerprint bs   | BS.length bs /= sizeOfFingerprint =       throw $ userError "decodeFingerprint: Invalid length"-  | otherwise = BSI.inlinePerformIO $ do+  | otherwise = unsafePerformIO $ do       let (fp, offset, _) = BSI.toForeignPtr bs       withForeignPtr fp $ \p -> peekByteOff p offset @@ -55,7 +65,7 @@  -- | The fingerprint of the typeRep of the argument fingerprint :: Typeable a => a -> Fingerprint-fingerprint a = let TypeRep fp _ _ = typeOf a in fp+fingerprint = typeRepFingerprint . typeOf  -- | Show fingerprint (for debugging purposes) showFingerprint :: Fingerprint -> ShowS
+ src/Control/Distributed/Process/UnsafePrimitives.hs view
@@ -0,0 +1,201 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.UnsafePrimitives+-- Copyright   :  (c) Well-Typed / Tim Watson+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- [Unsafe Variants of Cloud Haskell's Messaging Primitives]+--+-- Cloud Haskell's semantics do not mention evaluation/strictness properties+-- at all; Only the promise (or lack) of signal/message delivery between+-- processes is considered. For practical purposes, Cloud Haskell optimises+-- communication between (intra-node) local processes by skipping the+-- network-transport layer. In order to ensure the same strictness semantics+-- however, messages /still/ undergo binary serialisation before (internal)+-- transmission takes place. Thus we ensure that in both (the local and remote)+-- cases, message payloads are fully evaluated. Whilst this provides the user+-- with /unsurprising/ behaviour, the resulting performance overhead is quite+-- severe. Communicating data between Haskell threads /without/ forcing binary+-- serialisation reduces (intra-node, inter-process) communication overheads+-- by several orders of magnitude.+--+-- This module provides variants of Cloud Haskell's messaging primitives+-- ('send', 'sendChan', 'nsend' and 'wrapMessage') which do /not/ force binary+-- serialisation in the local case, thereby offering superior intra-node+-- messaging performance. The /catch/ is that any evaluation problems lurking+-- within the passed data structure (e.g., fields set to @undefined@ and so on)+-- will show up in the receiver rather than in the caller (as they would with+-- the /normal/ strategy).+--+-- Use of the functions in this module can potentially change the runtime+-- behaviour of your application. In addition, messages passed between Cloud+-- Haskell processes are written to a tracing infrastructure on the local node,+-- to provide improved introspection and debugging facilities for complex actor+-- based systems. This module makes no attempt to force evaluation in these+-- cases either, thus evaluation problems in passed data structures could not+-- only crash your processes, but could also bring down critical internal+-- services on which the node relies to function correctly.+--+-- If you wish to repudiate such issues, you are advised to consider the use+-- of NFSerialisable in the distributed-process-extras package, which type+-- class brings NFData into scope along with Serializable, such that we can+-- force evaluation. Intended for use with modules such as this one, this+-- approach guarantees correct evaluatedness in terms of @NFData@. Please note+-- however, that we /cannot/ guarantee that an @NFData@ instance will behave the+-- same way as a @Binary@ one with regards evaluation, so it is still possible+-- to introduce unexpected behaviour by using /unsafe/ primitives in this way.+--+-- You have been warned!+--+-- This module is exported so that you can replace the use of Cloud Haskell's+-- /safe/ messaging primitives. If you want to use both variants, then you can+-- take advantage of qualified imports, however "Control.Distributed.Process"+-- also re-exports these functions under different names, using the @unsafe@+-- prefix.+--+module Control.Distributed.Process.UnsafePrimitives+  ( -- * Unsafe Basic Messaging+    send+  , sendChan+  , nsend+  , nsendRemote+  , usend+  , wrapMessage+  ) where++import Control.Distributed.Process.Internal.Messaging+  ( sendMessage+  , sendBinary+  , sendCtrlMsg+  )+import Control.Distributed.Process.Management.Internal.Types+  ( MxEvent(..)+  )+import Control.Distributed.Process.Management.Internal.Trace.Types+  ( traceEvent+  )+import Control.Distributed.Process.Internal.Types+  ( ProcessId(..)+  , NodeId(..)+  , LocalNode(..)+  , LocalProcess(..)+  , Process(..)+  , SendPort(..)+  , ProcessSignal(..)+  , Identifier(..)+  , ImplicitReconnect(..)+  , SendPortId(..)+  , Message+  , createMessage+  , sendPortProcessId+  , unsafeCreateUnencodedMessage+  )+import Control.Distributed.Process.Serializable (Serializable)++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ask)++-- | Named send to a process in the local registry (asynchronous)+nsend :: Serializable a => String -> a -> Process ()+nsend label msg = do+  proc <- ask+  let us = processId proc+  let msg' = wrapMessage msg+  -- see [note: tracing]+  liftIO $ traceEvent (localEventBus (processNode proc))+                      (MxSentToName label us msg')+  sendCtrlMsg Nothing (NamedSend label msg')++-- | Named send to a process in a remote registry (asynchronous)+nsendRemote :: Serializable a => NodeId -> String -> a -> Process ()+nsendRemote nid label msg = do+  proc <- ask+  let us = processId proc+  let node = processNode proc+  if localNodeId node == nid+    then nsend label msg+    else+      let lbl = label ++ "@" ++ show nid in do+        -- see [note: tracing] NB: this is a remote call to another NC...+        liftIO $ traceEvent (localEventBus node)+                            (MxSentToName lbl us (wrapMessage msg))+        sendCtrlMsg (Just nid) (NamedSend label (createMessage msg))++-- | Send a message+send :: Serializable a => ProcessId -> a -> Process ()+send them msg = do+  proc <- ask+  let node     = localNodeId (processNode proc)+      destNode = (processNodeId them)+      us       = (processId proc)+      msg'     = wrapMessage msg in do+    -- see [note: tracing]+    liftIO $ traceEvent (localEventBus (processNode proc))+                        (MxSent them us msg')+    if destNode == node+      then sendCtrlMsg Nothing $ LocalSend them msg'+      else liftIO $ sendMessage (processNode proc)+                                (ProcessIdentifier (processId proc))+                                (ProcessIdentifier them)+                                NoImplicitReconnect+                                msg++-- | Send a message unreliably.+--+-- Unlike 'send', this function is insensitive to 'reconnect'. It will+-- try to send the message regardless of the history of connection failures+-- between the nodes.+--+-- Message passing with 'usend' is ordered for a given sender and receiver+-- if the messages arrive at all.+--+usend :: Serializable a => ProcessId -> a -> Process ()+usend them msg = do+    proc <- ask+    let there = processNodeId them+    let (us, node) = (processId proc, processNode proc)+    let msg' = wrapMessage msg+    -- see [note: tracing]+    liftIO $ traceEvent (localEventBus node) (MxSent them us msg')+    if localNodeId (processNode proc) == there+      then sendCtrlMsg Nothing $ LocalSend them msg'+      else sendCtrlMsg (Just there) $ UnreliableSend (processLocalId them)+                                                     (createMessage msg)++-- [note: tracing]+-- Note that tracing writes to the local node's control channel, and this+-- module explicitly specifies to its clients that it does unsafe message+-- encoding. The same is true for the messages it puts onto the Management+-- event bus, however we do *not* want unevaluated thunks hitting the event+-- bus control thread. Hence the word /Unsafe/ in this module's name!+--++-- | Send a message on a typed channel+sendChan :: Serializable a => SendPort a -> a -> Process ()+sendChan (SendPort cid) msg = do+  proc <- ask+  let+    node = processNode proc+    pid  = processId proc+    us   = localNodeId node+    them = processNodeId (sendPortProcessId cid)+    msg' = wrapMessage msg+  liftIO $ traceEvent (localEventBus node) (MxSentToPort pid cid msg')+  if them == us+    then unsafeSendChanLocal cid msg' -- NB: we wrap to P.Message !!!+    else liftIO $ sendBinary node+                             (ProcessIdentifier pid)+                             (SendPortIdentifier cid)+                             NoImplicitReconnect+                             msg+  where+    unsafeSendChanLocal :: SendPortId -> Message -> Process ()+    unsafeSendChanLocal p m = sendCtrlMsg Nothing $ LocalPortSend p m++-- | Create an unencoded @Message@ for any @Serializable@ type.+wrapMessage :: Serializable a => a -> Message+wrapMessage = unsafeCreateUnencodedMessage
− tests/TestCH.hs 
@@ -1,1184 +0,0 @@-module Main where--#if ! MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif--import Data.Binary (Binary(..))-import Data.Typeable (Typeable)-import Data.Foldable (forM_)-import Control.Concurrent (forkIO, threadDelay, myThreadId, throwTo, ThreadId)-import Control.Concurrent.MVar-  ( MVar-  , newEmptyMVar-  , putMVar-  , takeMVar-  , readMVar-  )-import Control.Monad (replicateM_, replicateM, forever)-import Control.Exception (SomeException, throwIO)-import qualified Control.Exception as Ex (catch)-import Control.Applicative ((<$>), (<*>), pure, (<|>))-import qualified Network.Transport as NT (Transport, closeEndPoint)-import Network.Socket (sClose)-import Network.Transport.TCP-  ( createTransportExposeInternals-  , TransportInternals(socketBetween)-  , defaultTCPParameters-  )-import Control.Distributed.Process-import Control.Distributed.Process.Internal.Types-  ( NodeId(nodeAddress)-  , LocalNode(localEndPoint)-  , ProcessExitException(..)-  , nullProcessId-  )-import Control.Distributed.Process.Node-import Control.Distributed.Process.Serializable (Serializable)--import Test.HUnit (Assertion)-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.HUnit (testCase)--newtype Ping = Ping ProcessId-  deriving (Typeable, Binary, Show)--newtype Pong = Pong ProcessId-  deriving (Typeable, Binary, Show)------------------------------------------------------------------------------------- Supporting definitions                                                     --------------------------------------------------------------------------------------- | Like fork, but throw exceptions in the child thread to the parent-forkTry :: IO () -> IO ThreadId-forkTry p = do-  tid <- myThreadId-  forkIO $ Ex.catch p (\e -> throwTo tid (e :: SomeException))---- | The ping server from the paper-ping :: Process ()-ping = do-  Pong partner <- expect-  self <- getSelfPid-  send partner (Ping self)-  ping---- | Quick and dirty synchronous version of whereisRemoteAsync-whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)-whereisRemote nid string = do-  whereisRemoteAsync nid string-  WhereIsReply _ mPid <- expect-  return mPid--data Add       = Add    ProcessId Double Double deriving (Typeable)-data Divide    = Divide ProcessId Double Double deriving (Typeable)-data DivByZero = DivByZero deriving (Typeable)--instance Binary Add where-  put (Add pid x y) = put pid >> put x >> put y-  get = Add <$> get <*> get <*> get--instance Binary Divide where-  put (Divide pid x y) = put pid >> put x >> put y-  get = Divide <$> get <*> get <*> get--instance Binary DivByZero where-  put DivByZero = return ()-  get = return DivByZero---- The math server from the paper-math :: Process ()-math = do-  receiveWait-    [ match (\(Add pid x y) -> send pid (x + y))-    , matchIf (\(Divide _   _ y) -> y /= 0)-              (\(Divide pid x y) -> send pid (x / y))-    , match (\(Divide pid _ _) -> send pid DivByZero)-    ]-  math---- | Monitor or link to a remote node-monitorOrLink :: Bool            -- ^ 'True' for monitor, 'False' for link-              -> ProcessId       -- Process to monitor/link to-              -> Maybe (MVar ()) -- MVar to signal on once the monitor has been set up-              -> Process (Maybe MonitorRef)-monitorOrLink mOrL pid mSignal = do-  result <- if mOrL then Just <$> monitor pid-                    else link pid >> return Nothing-  -- Monitor is asynchronous, which usually does not matter but if we want a-  -- *specific* signal then it does. Therefore we wait an arbitrary delay and-  -- hope that this means the monitor has been set up-  forM_ mSignal $ \signal -> liftIO . forkIO $ threadDelay 100000 >> putMVar signal ()-  return result--monitorTestProcess :: ProcessId       -- Process to monitor/link to-                   -> Bool            -- 'True' for monitor, 'False' for link-                   -> Bool            -- Should we unmonitor?-                   -> DiedReason      -- Expected cause of death-                   -> Maybe (MVar ()) -- Signal for 'monitor set up'-                   -> MVar ()         -- Signal for successful termination-                   -> Process ()-monitorTestProcess theirAddr mOrL un reason monitorSetup done =-  catch (do mRef <- monitorOrLink mOrL theirAddr monitorSetup-            case (un, mRef) of-              (True, Nothing) -> do-                unlink theirAddr-                liftIO $ putMVar done ()-              (True, Just ref) -> do-                unmonitor ref-                liftIO $ putMVar done ()-              (False, ref) -> do-                ProcessMonitorNotification ref' pid reason' <- expect-                True <- return $ Just ref' == ref && pid == theirAddr && mOrL && reason == reason'-                liftIO $ putMVar done ()-        )-        (\(ProcessLinkException pid reason') -> do-            True <- return $ pid == theirAddr && not mOrL && not un && reason == reason'-            liftIO $ putMVar done ()-        )------------------------------------------------------------------------------------- The tests proper                                                           --------------------------------------------------------------------------------------- | Basic ping test-testPing :: NT.Transport -> Assertion-testPing transport = do-  serverAddr <- newEmptyMVar-  clientDone <- newEmptyMVar--  -- Server-  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    addr <- forkProcess localNode ping-    putMVar serverAddr addr--  -- Client-  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    pingServer <- readMVar serverAddr--    let numPings = 10000--    runProcess localNode $ do-      pid <- getSelfPid-      replicateM_ numPings $ do-        send pingServer (Pong pid)-        Ping _ <- expect-        return ()--    putMVar clientDone ()--  takeMVar clientDone---- | Monitor a process on an unreachable node-testMonitorUnreachable :: NT.Transport -> Bool -> Bool -> Assertion-testMonitorUnreachable transport mOrL un = do-  deadProcess <- newEmptyMVar-  done <- newEmptyMVar--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    addr <- forkProcess localNode . liftIO $ threadDelay 1000000-    closeLocalNode localNode-    putMVar deadProcess addr--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    theirAddr <- readMVar deadProcess-    runProcess localNode $-      monitorTestProcess theirAddr mOrL un DiedDisconnect Nothing done--  takeMVar done---- | Monitor a process which terminates normally-testMonitorNormalTermination :: NT.Transport -> Bool -> Bool -> Assertion-testMonitorNormalTermination transport mOrL un = do-  monitorSetup <- newEmptyMVar-  monitoredProcess <- newEmptyMVar-  done <- newEmptyMVar--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    addr <- forkProcess localNode $-      liftIO $ readMVar monitorSetup-    putMVar monitoredProcess addr--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    theirAddr <- readMVar monitoredProcess-    runProcess localNode $-      monitorTestProcess theirAddr mOrL un DiedNormal (Just monitorSetup) done--  takeMVar done---- | Monitor a process which terminates abnormally-testMonitorAbnormalTermination :: NT.Transport -> Bool -> Bool -> Assertion-testMonitorAbnormalTermination transport mOrL un = do-  monitorSetup <- newEmptyMVar-  monitoredProcess <- newEmptyMVar-  done <- newEmptyMVar--  let err = userError "Abnormal termination"--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    addr <- forkProcess localNode . liftIO $ do-      readMVar monitorSetup-      throwIO err-    putMVar monitoredProcess addr--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    theirAddr <- readMVar monitoredProcess-    runProcess localNode $-      monitorTestProcess theirAddr mOrL un (DiedException (show err)) (Just monitorSetup) done--  takeMVar done---- | Monitor a local process that is already dead-testMonitorLocalDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion-testMonitorLocalDeadProcess transport mOrL un = do-  processDead <- newEmptyMVar-  processAddr <- newEmptyMVar-  localNode <- newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  forkIO $ do-    addr <- forkProcess localNode . liftIO $ putMVar processDead ()-    putMVar processAddr addr--  forkIO $ do-    theirAddr <- readMVar processAddr-    readMVar processDead-    runProcess localNode $ do-      monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done--  takeMVar done---- | Monitor a remote process that is already dead-testMonitorRemoteDeadProcess :: NT.Transport -> Bool -> Bool -> Assertion-testMonitorRemoteDeadProcess transport mOrL un = do-  processDead <- newEmptyMVar-  processAddr <- newEmptyMVar-  done <- newEmptyMVar--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    addr <- forkProcess localNode . liftIO $ putMVar processDead ()-    putMVar processAddr addr--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    theirAddr <- readMVar processAddr-    readMVar processDead-    runProcess localNode $ do-      monitorTestProcess theirAddr mOrL un DiedUnknownId Nothing done--  takeMVar done---- | Monitor a process that becomes disconnected-testMonitorDisconnect :: NT.Transport -> Bool -> Bool -> Assertion-testMonitorDisconnect transport mOrL un = do-  processAddr <- newEmptyMVar-  monitorSetup <- newEmptyMVar-  done <- newEmptyMVar--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    addr <- forkProcess localNode . liftIO $ threadDelay 1000000-    putMVar processAddr addr-    readMVar monitorSetup-    NT.closeEndPoint (localEndPoint localNode)--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    theirAddr <- readMVar processAddr-    runProcess localNode $ do-      monitorTestProcess theirAddr mOrL un DiedDisconnect (Just monitorSetup) done--  takeMVar done---- | Test the math server (i.e., receiveWait)-testMath :: NT.Transport -> Assertion-testMath transport = do-  serverAddr <- newEmptyMVar-  clientDone <- newEmptyMVar--  -- Server-  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    addr <- forkProcess localNode math-    putMVar serverAddr addr--  -- Client-  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    mathServer <- readMVar serverAddr--    runProcess localNode $ do-      pid <- getSelfPid-      send mathServer (Add pid 1 2)-      3 <- expect :: Process Double-      send mathServer (Divide pid 8 2)-      4 <- expect :: Process Double-      send mathServer (Divide pid 8 0)-      DivByZero <- expect-      liftIO $ putMVar clientDone ()--  takeMVar clientDone---- | Send first message (i.e. connect) to an already terminated process--- (without monitoring); then send another message to a second process on--- the same remote node (we're checking that the remote node did not die)-testSendToTerminated :: NT.Transport -> Assertion-testSendToTerminated transport = do-  serverAddr1 <- newEmptyMVar-  serverAddr2 <- newEmptyMVar-  clientDone <- newEmptyMVar--  forkIO $ do-    terminated <- newEmptyMVar-    localNode <- newLocalNode transport initRemoteTable-    addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()-    addr2 <- forkProcess localNode $ ping-    readMVar terminated-    putMVar serverAddr1 addr1-    putMVar serverAddr2 addr2--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    server1 <- readMVar serverAddr1-    server2 <- readMVar serverAddr2-    runProcess localNode $ do-      pid <- getSelfPid-      send server1 "Hi"-      send server2 (Pong pid)-      Ping pid' <- expect-      True <- return $ pid' == server2-      liftIO $ putMVar clientDone ()--  takeMVar clientDone---- | Test (non-zero) timeout-testTimeout :: NT.Transport -> Assertion-testTimeout transport = do-  localNode <- newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  runProcess localNode $ do-    Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]-    liftIO $ putMVar done ()--  takeMVar done---- | Test zero timeout-testTimeout0 :: NT.Transport -> Assertion-testTimeout0 transport = do-  serverAddr <- newEmptyMVar-  clientDone <- newEmptyMVar-  messagesSent <- newEmptyMVar--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    addr <- forkProcess localNode $ do-      liftIO $ readMVar messagesSent >> threadDelay 1000000-      -- Variation on the venerable ping server which uses a zero timeout-      -- Since we wait for all messages to be sent before doing this receive,-      -- we should nevertheless find the right message immediately-      Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]-      self <- getSelfPid-      send partner (Ping self)-    putMVar serverAddr addr--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    server <- readMVar serverAddr-    runProcess localNode $ do-      pid <- getSelfPid-      -- Send a bunch of messages. A large number of messages that the server-      -- is not interested in, and then a single message that it wants-      replicateM_ 10000 $ send server "Irrelevant message"-      send server (Pong pid)-      liftIO $ putMVar messagesSent ()-      Ping _ <- expect-      liftIO $ putMVar clientDone ()--  takeMVar clientDone---- | Test typed channels-testTypedChannels :: NT.Transport -> Assertion-testTypedChannels transport = do-  serverChannel <- newEmptyMVar :: IO (MVar (SendPort (SendPort Bool, Int)))-  clientDone <- newEmptyMVar--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    forkProcess localNode $ do-      (serverSendPort, rport) <- newChan-      liftIO $ putMVar serverChannel serverSendPort-      (clientSendPort, i) <- receiveChan rport-      sendChan clientSendPort (even i)-    return ()--  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    serverSendPort <- readMVar serverChannel-    runProcess localNode $ do-      (clientSendPort, rport) <- newChan-      sendChan serverSendPort (clientSendPort, 5)-      False <- receiveChan rport-      liftIO $ putMVar clientDone ()--  takeMVar clientDone---- | Test merging receive ports-testMergeChannels :: NT.Transport -> Assertion-testMergeChannels transport = do-    localNode <- newLocalNode transport initRemoteTable-    testFlat localNode True          "aaabbbccc"-    testFlat localNode False         "abcabcabc"-    testNested localNode True True   "aaabbbcccdddeeefffggghhhiii"-    testNested localNode True False  "adgadgadgbehbehbehcficficfi"-    testNested localNode False True  "abcabcabcdefdefdefghighighi"-    testNested localNode False False "adgbehcfiadgbehcfiadgbehcfi"-    testBlocked localNode True-    testBlocked localNode False-  where-    -- Single layer of merging-    testFlat :: LocalNode -> Bool -> String -> IO ()-    testFlat localNode biased expected = do-      done <- newEmptyMVar-      forkProcess localNode $ do-        rs  <- mapM charChannel "abc"-        m   <- mergePorts biased rs-        xs  <- replicateM 9 $ receiveChan m-        True <- return $ xs == expected-        liftIO $ putMVar done ()-      takeMVar done--    -- Two layers of merging-    testNested :: LocalNode -> Bool -> Bool -> String -> IO ()-    testNested localNode biasedInner biasedOuter expected = do-      done <- newEmptyMVar-      forkProcess localNode $ do-        rss  <- mapM (mapM charChannel) ["abc", "def", "ghi"]-        ms   <- mapM (mergePorts biasedInner) rss-        m    <- mergePorts biasedOuter ms-        xs   <- replicateM (9 * 3) $ receiveChan m-        True <- return $ xs == expected-        liftIO $ putMVar done ()-      takeMVar done--    -- Test that if no messages are (immediately) available, the scheduler makes no difference-    testBlocked :: LocalNode -> Bool -> IO ()-    testBlocked localNode biased = do-      vs <- replicateM 3 newEmptyMVar-      done <- newEmptyMVar--      forkProcess localNode $ do-        [sa, sb, sc] <- liftIO $ mapM readMVar vs-        mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)-          [ -- a, b, c-            (sa, 'a')-          , (sb, 'b')-          , (sc, 'c')-            -- a, c, b-          , (sa, 'a')-          , (sc, 'c')-          , (sb, 'b')-            -- b, a, c-          , (sb, 'b')-          , (sa, 'a')-          , (sc, 'c')-            -- b, c, a-          , (sb, 'b')-          , (sc, 'c')-          , (sa, 'a')-            -- c, a, b-          , (sc, 'c')-          , (sa, 'a')-          , (sb, 'b')-            -- c, b, a-          , (sc, 'c')-          , (sb, 'b')-          , (sa, 'a')-          ]--      forkProcess localNode $ do-        (ss, rs) <- unzip <$> replicateM 3 newChan-        liftIO $ mapM_ (uncurry putMVar) $ zip vs ss-        m  <- mergePorts biased rs-        xs <- replicateM (6 * 3) $ receiveChan m-        True <- return $ xs == "abcacbbacbcacabcba"-        liftIO $ putMVar done ()--      takeMVar done--    mergePorts :: Serializable a => Bool -> [ReceivePort a] -> Process (ReceivePort a)-    mergePorts True  = mergePortsBiased-    mergePorts False = mergePortsRR--    charChannel :: Char -> Process (ReceivePort Char)-    charChannel c = do-      (sport, rport) <- newChan-      replicateM_ 3 $ sendChan sport c-      liftIO $ threadDelay 10000 -- Make sure messages have been sent-      return rport--testTerminate :: NT.Transport -> Assertion-testTerminate transport = do-  localNode <- newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  pid <- forkProcess localNode $ do-    liftIO $ threadDelay 100000-    terminate--  runProcess localNode $ do-    ref <- monitor pid-    ProcessMonitorNotification ref' pid' (DiedException ex) <- expect-    True <- return $ ref == ref' && pid == pid' && ex == show ProcessTerminationException-    liftIO $ putMVar done ()--  takeMVar done--testMonitorNode :: NT.Transport -> Assertion-testMonitorNode transport = do-  [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  closeLocalNode node1--  runProcess node2 $ do-    ref <- monitorNode (localNodeId node1)-    NodeMonitorNotification ref' nid DiedDisconnect <- expect-    True <- return $ ref == ref' && nid == localNodeId node1-    liftIO $ putMVar done ()--  takeMVar done--testMonitorChannel :: NT.Transport -> Assertion-testMonitorChannel transport = do-    [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable-    gotNotification <- newEmptyMVar--    pid <- forkProcess node1 $ do-      sport <- expect :: Process (SendPort ())-      ref <- monitorPort sport-      PortMonitorNotification ref' port' reason <- expect-      -- reason might be DiedUnknownId if the receive port is GCed before the-      -- monitor is established (TODO: not sure that this is reasonable)-      return $ ref' == ref && port' == sendPortId sport && (reason == DiedNormal || reason == DiedUnknownId)-      liftIO $ putMVar gotNotification ()--    runProcess node2 $ do-      (sport, _) <- newChan :: Process (SendPort (), ReceivePort ())-      send pid sport-      liftIO $ threadDelay 100000--    takeMVar gotNotification--testRegistry :: NT.Transport -> Assertion-testRegistry transport = do-  node <- newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  pingServer <- forkProcess node ping--  runProcess node $ do-    register "ping" pingServer-    Just pid <- whereis "ping"-    True <- return $ pingServer == pid-    us <- getSelfPid-    nsend "ping" (Pong us)-    Ping pid' <- expect-    True <- return $ pingServer == pid'-    liftIO $ putMVar done ()--  takeMVar done--testRemoteRegistry :: NT.Transport -> Assertion-testRemoteRegistry transport = do-  node1 <- newLocalNode transport initRemoteTable-  node2 <- newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  pingServer <- forkProcess node1 ping--  runProcess node2 $ do-    let nid1 = localNodeId node1-    registerRemoteAsync nid1 "ping" pingServer-    receiveWait [-       matchIf (\(RegisterReply label' _) -> "ping" == label')-               (\(RegisterReply _ _) -> return ()) ]--    Just pid <- whereisRemote nid1 "ping"-    True <- return $ pingServer == pid-    us <- getSelfPid-    nsendRemote nid1 "ping" (Pong us)-    Ping pid' <- expect-    True <- return $ pingServer == pid'-    liftIO $ putMVar done ()--  takeMVar done--testSpawnLocal :: NT.Transport -> Assertion-testSpawnLocal transport = do-  node <- newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  runProcess node $ do-    us <- getSelfPid--    pid <- spawnLocal $ do-      sport <- expect-      sendChan sport (1234 :: Int)--    sport <- spawnChannelLocal $ \rport -> do-      (1234 :: Int) <- receiveChan rport-      send us ()--    send pid sport-    () <- expect-    liftIO $ putMVar done ()--  takeMVar done--testReconnect :: NT.Transport -> TransportInternals -> Assertion-testReconnect transport transportInternals = do-  [node1, node2] <- replicateM 2 $ newLocalNode transport initRemoteTable-  let nid1 = localNodeId node1-      nid2 = localNodeId node2-  processA <- newEmptyMVar-  [sendTestOk, registerTestOk] <- replicateM 2 newEmptyMVar--  forkProcess node1 $ do-    us <- getSelfPid-    liftIO $ putMVar processA us-    msg1 <- expect-    msg2 <- expect-    True <- return $ msg1 == "message 1" && msg2 == "message 3"-    liftIO $ putMVar sendTestOk ()--  forkProcess node2 $ do-    {--     - Make sure there is no implicit reconnect on normal message sending-     -}--    them <- liftIO $ readMVar processA-    send them "message 1" >> liftIO (threadDelay 100000)--    -- Simulate network failure-    liftIO $ do-      sock <- socketBetween transportInternals (nodeAddress nid1) (nodeAddress nid2)-      sClose sock-      threadDelay 10000--    -- Should not arrive-    send them "message 2"--    -- Should arrive-    reconnect them-    send them "message 3"--    liftIO $ takeMVar sendTestOk--    {--     - Test that there *is* implicit reconnect on node controller messages-     -}--    us <- getSelfPid-    registerRemoteAsync nid1 "a" us -- registerRemote is asynchronous-    receiveWait [-        matchIf (\(RegisterReply label' _) -> "a" == label')-                (\(RegisterReply _ _) -> return ()) ]--    Just _  <- whereisRemote nid1 "a"---    -- Simulate network failure-    liftIO $ do-      sock <- socketBetween transportInternals (nodeAddress nid1) (nodeAddress nid2)-      sClose sock-      threadDelay 10000--    -- This will happen due to implicit reconnect-    registerRemoteAsync nid1 "b" us-    receiveWait [-        matchIf (\(RegisterReply label' _) -> "b" == label')-                (\(RegisterReply _ _) -> return ()) ]--    -- Should happen-    registerRemoteAsync nid1 "c" us-    receiveWait [-        matchIf (\(RegisterReply label' _) -> "c" == label')-                (\(RegisterReply _ _) -> return ()) ]--    -- Check-    Nothing  <- whereisRemote nid1 "a"  -- this will fail because the name is removed when the node is disconnected-    Just _  <- whereisRemote nid1 "b"  -- this will suceed because the value is set after thereconnect-    Just _  <- whereisRemote nid1 "c"--    liftIO $ putMVar registerTestOk ()--  takeMVar registerTestOk---- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server--- in between-testMatchAny :: NT.Transport -> Assertion-testMatchAny transport = do-  proxyAddr <- newEmptyMVar-  clientDone <- newEmptyMVar--  -- Math server-  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    mathServer <- forkProcess localNode math-    proxyServer <- forkProcess localNode $ forever $ do-      msg <- receiveWait [ matchAny return ]-      forward msg mathServer-    putMVar proxyAddr proxyServer--  -- Client-  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    mathServer <- readMVar proxyAddr--    runProcess localNode $ do-      pid <- getSelfPid-      send mathServer (Add pid 1 2)-      3 <- expect :: Process Double-      send mathServer (Divide pid 8 2)-      4 <- expect :: Process Double-      send mathServer (Divide pid 8 0)-      DivByZero <- expect-      liftIO $ putMVar clientDone ()--  takeMVar clientDone---- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server--- in between, however we block 'Divide' requests ....-testMatchAnyHandle :: NT.Transport -> Assertion-testMatchAnyHandle transport = do-  proxyAddr <- newEmptyMVar-  clientDone <- newEmptyMVar--  -- Math server-  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    mathServer <- forkProcess localNode math-    proxyServer <- forkProcess localNode $ forever $ do-        receiveWait [-            matchAny (maybeForward mathServer)-          ]-    putMVar proxyAddr proxyServer--  -- Client-  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    mathServer <- readMVar proxyAddr--    runProcess localNode $ do-      pid <- getSelfPid-      send mathServer (Add pid 1 2)-      3 <- expect :: Process Double-      send mathServer (Divide pid 8 2)-      Nothing <- (expectTimeout 100000) :: Process (Maybe Double)-      liftIO $ putMVar clientDone ()--  takeMVar clientDone-  where maybeForward :: ProcessId -> AbstractMessage -> Process (Maybe ())-        maybeForward s msg =-            maybeHandleMessage msg (\m@(Add _ _ _) -> send s m)--testMatchAnyNoHandle :: NT.Transport -> Assertion-testMatchAnyNoHandle transport = do-  addr <- newEmptyMVar-  clientDone <- newEmptyMVar-  serverDone <- newEmptyMVar--  -- Math server-  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    server <- forkProcess localNode $ forever $ do-        receiveWait [-          matchAnyIf-            -- the condition has type `Add -> Bool`-            (\(Add _ _ _) -> True)-            -- the match `AbstractMessage -> Process ()` will succeed!-            (\m -> do-              -- `String -> Process ()` does *not* match the input types however-              r <- (maybeHandleMessage m (\(_ :: String) -> die "NONSENSE" ))-              case r of-                Nothing -> return ()-                Just _  -> die "NONSENSE")-          ]-        -- we *must* have removed the message from our mailbox though!!!-        Nothing <- receiveTimeout 100000 [ match (\(Add _ _ _) -> return ()) ]-        liftIO $ putMVar serverDone ()-    putMVar addr server--  -- Client-  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    server <- readMVar addr--    runProcess localNode $ do-      pid <- getSelfPid-      send server (Add pid 1 2)-      -- we only care about the client having sent a message, so we're done-      liftIO $ putMVar clientDone ()--  takeMVar clientDone-  takeMVar serverDone---- | Test 'matchAnyIf'. We provide an /echo/ server, but it ignores requests--- unless the text body @/= "bar"@ - this case should time out rather than--- removing the message from the process mailbox.-testMatchAnyIf :: NT.Transport -> Assertion-testMatchAnyIf transport = do-  echoAddr <- newEmptyMVar-  clientDone <- newEmptyMVar--  -- echo server-  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    echoServer <- forkProcess localNode $ forever $ do-        receiveWait [-            matchAnyIf (\(_ :: ProcessId, (s :: String)) -> s /= "bar")-                       handleMessage-          ]-    putMVar echoAddr echoServer--  -- Client-  forkIO $ do-    localNode <- newLocalNode transport initRemoteTable-    server <- readMVar echoAddr--    runProcess localNode $ do-      pid <- getSelfPid-      send server (pid, "foo")-      "foo" <- expect-      send server (pid, "baz")-      "baz" <- expect-      send server (pid, "bar")-      Nothing <- (expectTimeout 100000) :: Process (Maybe Double)-      liftIO $ putMVar clientDone ()--  takeMVar clientDone-  where handleMessage :: AbstractMessage -> Process (Maybe ())-        handleMessage msg =-          maybeHandleMessage msg (\(pid :: ProcessId, (m :: String))-                                  -> do { send pid m; return () })---- Test 'receiveChanTimeout'-testReceiveChanTimeout :: NT.Transport -> Assertion-testReceiveChanTimeout transport = do-  done <- newEmptyMVar-  sendPort <- newEmptyMVar--  forkTry $ do-    localNode <- newLocalNode transport initRemoteTable-    runProcess localNode $ do-      -- Create a typed channel-      (sp, rp) <- newChan :: Process (SendPort Bool, ReceivePort Bool)-      liftIO $ putMVar sendPort sp--      -- Wait for a message with a delay. No message arrives, we should get Nothing after 1 second-      Nothing <- receiveChanTimeout 1000000 rp--      -- Wait for a message with a delay again. Now a message arrives after 0.5 seconds-      Just True <- receiveChanTimeout 1000000 rp--      -- Wait for a message with zero timeout: non-blocking check. No message is available, we get Nothing-      Nothing <- receiveChanTimeout 0 rp--      -- Again, but now there is a message available-      liftIO $ threadDelay 1000000-      Just False <- receiveChanTimeout 0 rp--      liftIO $ putMVar done ()--  forkTry $ do-    localNode <- newLocalNode transport initRemoteTable-    runProcess localNode $ do-      sp <- liftIO $ readMVar sendPort--      liftIO $ threadDelay 1500000-      sendChan sp True--      liftIO $ threadDelay 500000-      sendChan sp False--  takeMVar done---- | Test Functor, Applicative, Alternative and Monad instances for ReceiveChan-testReceiveChanFeatures :: NT.Transport -> Assertion-testReceiveChanFeatures transport = do-  done <- newEmptyMVar--  forkTry $ do-    localNode <- newLocalNode transport initRemoteTable-    runProcess localNode $ do-      (spInt,  rpInt)  <- newChan :: Process (SendPort Int, ReceivePort Int)-      (spBool, rpBool) <- newChan :: Process (SendPort Bool, ReceivePort Bool)--      -- Test Functor instance--      sendChan spInt 2-      sendChan spBool False--      rp1 <- mergePortsBiased [even <$> rpInt, rpBool]--      True <- receiveChan rp1-      False <- receiveChan rp1--      -- Test Applicative instance--      sendChan spInt 3-      sendChan spInt 4--      let rp2 = pure (+) <*> rpInt <*> rpInt--      7 <- receiveChan rp2--      -- Test Alternative instance--      sendChan spInt 3-      sendChan spBool True--      let rp3 = (even <$> rpInt) <|> rpBool--      False <- receiveChan rp3-      True <- receiveChan rp3--      -- Test Monad instance--      sendChan spBool True-      sendChan spBool False-      sendChan spInt 5--      let rp4 :: ReceivePort Int-          rp4 = do b <- rpBool-                   if b-                     then rpInt-                     else return 7--      5 <- receiveChan rp4-      7 <- receiveChan rp4--      liftIO $ putMVar done ()--  takeMVar done--testKillLocal :: NT.Transport -> Assertion-testKillLocal transport = do-  localNode <- newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  pid <- forkProcess localNode $ do-    liftIO $ threadDelay 1000000--  runProcess localNode $ do-    ref <- monitor pid-    us <- getSelfPid-    kill pid "TestKill"-    ProcessMonitorNotification ref' pid' (DiedException ex) <- expect-    True <- return $ ref == ref' && pid == pid' && ex == "killed-by=" ++ show us ++ ",reason=TestKill"-    liftIO $ putMVar done ()--  takeMVar done--testKillRemote :: NT.Transport -> Assertion-testKillRemote transport = do-  node1 <- newLocalNode transport initRemoteTable-  node2 <- newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  pid <- forkProcess node1 $ do-    liftIO $ threadDelay 1000000--  runProcess node2 $ do-    ref <- monitor pid-    us <- getSelfPid-    kill pid "TestKill"-    ProcessMonitorNotification ref' pid' (DiedException reason) <- expect-    True <- return $ ref == ref' && pid == pid' && reason == "killed-by=" ++ show us ++ ",reason=TestKill"-    liftIO $ putMVar done ()--  takeMVar done--testCatchesExit :: NT.Transport -> Assertion-testCatchesExit transport = do-  localNode <- newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  _ <- forkProcess localNode $ do-      (die ("foobar", 123 :: Int))-      `catchesExit` [-           (\_ m -> maybeHandleMessage m (\(_ :: String) -> return ()))-         , (\_ m -> maybeHandleMessage m (\(_ :: Maybe Int) -> return ()))-         , (\_ m -> maybeHandleMessage m (\(_ :: String, _ :: Int)-                    -> (liftIO $ putMVar done ()) >> return ()))-         ]--  takeMVar done--testCatches :: NT.Transport -> Assertion-testCatches transport = do-  localNode <- newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  _ <- forkProcess localNode $ do-    node <- getSelfNode-    (liftIO $ throwIO (ProcessLinkException (nullProcessId node) DiedNormal))-    `catches` [-        Handler (\(ProcessLinkException _ _) -> liftIO $ putMVar done ())-      ]--  takeMVar done--testDie :: NT.Transport -> Assertion-testDie transport = do-  localNode <- newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  _ <- forkProcess localNode $ do-      (die ("foobar", 123 :: Int))-      `catchExit` \_from reason -> do-        -- TODO: should verify that 'from' has the right value-        True <- return $ reason == ("foobar", 123 :: Int)-        liftIO $ putMVar done ()--  takeMVar done--testPrettyExit :: NT.Transport -> Assertion-testPrettyExit transport = do-  localNode <- newLocalNode transport initRemoteTable-  done <- newEmptyMVar--  _ <- forkProcess localNode $ do-      (die "timeout")-      `catch` \ex@(ProcessExitException from _) ->-        let expected = "exit-from=" ++ (show from)-        in do-          True <- return $ (show ex) == expected-          liftIO $ putMVar done ()--  takeMVar done--testExitLocal :: NT.Transport -> Assertion-testExitLocal transport = do-  localNode <- newLocalNode transport initRemoteTable-  supervisedDone <- newEmptyMVar-  supervisorDone <- newEmptyMVar--  pid <- forkProcess localNode $ do-    (liftIO $ threadDelay 100000)-      `catchExit` \_from reason -> do-        -- TODO: should verify that 'from' has the right value-        True <- return $ reason == "TestExit"-        liftIO $ putMVar supervisedDone ()--  runProcess localNode $ do-    ref <- monitor pid-    exit pid "TestExit"-    -- This time the client catches the exception, so it dies normally-    ProcessMonitorNotification ref' pid' DiedNormal <- expect-    True <- return $ ref == ref' && pid == pid'-    liftIO $ putMVar supervisorDone ()--  takeMVar supervisedDone-  takeMVar supervisorDone--testExitRemote :: NT.Transport -> Assertion-testExitRemote transport = do-  node1 <- newLocalNode transport initRemoteTable-  node2 <- newLocalNode transport initRemoteTable-  supervisedDone <- newEmptyMVar-  supervisorDone <- newEmptyMVar--  pid <- forkProcess node1 $ do-    (liftIO $ threadDelay 100000)-      `catchExit` \_from reason -> do-        -- TODO: should verify that 'from' has the right value-        True <- return $ reason == "TestExit"-        liftIO $ putMVar supervisedDone ()--  runProcess node2 $ do-    ref <- monitor pid-    exit pid "TestExit"-    ProcessMonitorNotification ref' pid' DiedNormal <- expect-    True <- return $ ref == ref' && pid == pid'-    liftIO $ putMVar supervisorDone ()--  takeMVar supervisedDone-  takeMVar supervisorDone--tests :: (NT.Transport, TransportInternals)  -> [Test]-tests (transport, transportInternals) = [-    testGroup "Basic features" [-        testCase "Ping"                (testPing                transport)-      , testCase "Math"                (testMath                transport)-      , testCase "Timeout"             (testTimeout             transport)-      , testCase "Timeout0"            (testTimeout0            transport)-      , testCase "SendToTerminated"    (testSendToTerminated    transport)-      , testCase "TypedChannnels"      (testTypedChannels       transport)-      , testCase "MergeChannels"       (testMergeChannels       transport)-      , testCase "Terminate"           (testTerminate           transport)-      , testCase "Registry"            (testRegistry            transport)-      , testCase "RemoteRegistry"      (testRemoteRegistry      transport)-      , testCase "SpawnLocal"          (testSpawnLocal          transport)-      , testCase "MatchAny"            (testMatchAny            transport)-      , testCase "MatchAnyHandle"      (testMatchAnyHandle      transport)-      , testCase "MatchAnyNoHandle"    (testMatchAnyNoHandle    transport)-      , testCase "MatchAnyIf"          (testMatchAnyIf          transport)-      , testCase "ReceiveChanTimeout"  (testReceiveChanTimeout  transport)-      , testCase "ReceiveChanFeatures" (testReceiveChanFeatures transport)-      , testCase "KillLocal"           (testKillLocal           transport)-      , testCase "KillRemote"          (testKillRemote          transport)-      , testCase "Die"                 (testDie                 transport)-      , testCase "PrettyExit"          (testPrettyExit          transport)-      , testCase "CatchesExit"         (testCatchesExit         transport)-      , testCase "Catches"             (testCatches             transport)-      , testCase "ExitLocal"           (testExitLocal           transport)-      , testCase "ExitRemote"          (testExitRemote          transport)-      ]-  , testGroup "Monitoring and Linking" [-      -- Monitoring processes-      ---      -- The "missing" combinations in the list below don't make much sense, as-      -- we cannot guarantee that the monitor reply or link exception will not-      -- happen before the unmonitor or unlink-      testCase "MonitorUnreachable"           (testMonitorUnreachable         transport True  False)-    , testCase "MonitorNormalTermination"     (testMonitorNormalTermination   transport True  False)-    , testCase "MonitorAbnormalTermination"   (testMonitorAbnormalTermination transport True  False)-    , testCase "MonitorLocalDeadProcess"      (testMonitorLocalDeadProcess    transport True  False)-    , testCase "MonitorRemoteDeadProcess"     (testMonitorRemoteDeadProcess   transport True  False)-    , testCase "MonitorDisconnect"            (testMonitorDisconnect          transport True  False)-    , testCase "LinkUnreachable"              (testMonitorUnreachable         transport False False)-    , testCase "LinkNormalTermination"        (testMonitorNormalTermination   transport False False)-    , testCase "LinkAbnormalTermination"      (testMonitorAbnormalTermination transport False False)-    , testCase "LinkLocalDeadProcess"         (testMonitorLocalDeadProcess    transport False False)-    , testCase "LinkRemoteDeadProcess"        (testMonitorRemoteDeadProcess   transport False False)-    , testCase "LinkDisconnect"               (testMonitorDisconnect          transport False False)-    , testCase "UnmonitorNormalTermination"   (testMonitorNormalTermination   transport True  True)-    , testCase "UnmonitorAbnormalTermination" (testMonitorAbnormalTermination transport True  True)-    , testCase "UnmonitorDisconnect"          (testMonitorDisconnect          transport True  True)-    , testCase "UnlinkNormalTermination"      (testMonitorNormalTermination   transport False True)-    , testCase "UnlinkAbnormalTermination"    (testMonitorAbnormalTermination transport False True)-    , testCase "UnlinkDisconnect"             (testMonitorDisconnect          transport False True)-      -- Monitoring nodes and channels-    , testCase "MonitorNode"                  (testMonitorNode                transport)-    , testCase "MonitorChannel"               (testMonitorChannel             transport)-      -- Reconnect-    , testCase "Reconnect"                    (testReconnect                  transport transportInternals)-    ]-  ]--main :: IO ()-main = do-  Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters-  defaultMain (tests transport)
− tests/TestClosure.hs 
@@ -1,480 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Main where--import Data.ByteString.Lazy (empty)-import Data.Typeable (Typeable)-import Control.Monad (join, replicateM, forever, replicateM_, void)-import Control.Exception (IOException, throw)-import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.MVar-  ( MVar-  , newEmptyMVar-  , readMVar-  , takeMVar-  , putMVar-  , modifyMVar_-  , newMVar-  )-import Control.Applicative ((<$>))-import System.Random (randomIO)-import Network.Transport (Transport)-import Network.Transport.TCP-  ( createTransportExposeInternals-  , defaultTCPParameters-  , TransportInternals(socketBetween)-  )-import Network.Socket (sClose)-import Control.Distributed.Process-import Control.Distributed.Process.Closure-import Control.Distributed.Process.Node-import Control.Distributed.Process.Internal.Types (NodeId(nodeAddress))-import Control.Distributed.Static (staticLabel, staticClosure)--import Test.HUnit (Assertion)-import Test.Framework (Test, defaultMain)-import Test.Framework.Providers.HUnit (testCase)------------------------------------------------------------------------------------- Supporting definitions                                                     -------------------------------------------------------------------------------------quintuple :: a -> b -> c -> d -> e -> (a, b, c, d, e)-quintuple a b c d e = (a, b, c, d, e)--sdictInt :: SerializableDict Int-sdictInt = SerializableDict--factorial :: Int -> Process Int-factorial 0 = return 1-factorial n = (n *) <$> factorial (n - 1)--addInt :: Int -> Int -> Int-addInt x y = x + y--putInt :: Int -> MVar Int -> IO ()-putInt = flip putMVar--sendPid :: ProcessId -> Process ()-sendPid toPid = do-  fromPid <- getSelfPid-  send toPid fromPid--wait :: Int -> Process ()-wait = liftIO . threadDelay--isPrime :: Integer -> Process Bool-isPrime n = return . (n `elem`) . takeWhile (<= n) . sieve $ [2..]-  where-    sieve :: [Integer] -> [Integer]-    sieve (p : xs) = p : sieve [x | x <- xs, x `mod` p > 0]-    sieve [] = error "Uh oh -- we've run out of primes"---- | First argument indicates empty closure environment-typedPingServer :: () -> ReceivePort (SendPort ()) -> Process ()-typedPingServer () rport = forever $ do-  sport <- receiveChan rport-  sendChan sport ()--signal :: ProcessId -> Process ()-signal pid = send pid ()--remotable [ 'factorial-          , 'addInt-          , 'putInt-          , 'sendPid-          , 'sdictInt-          , 'wait-          , 'typedPingServer-          , 'isPrime-          , 'quintuple-          , 'signal-          ]--randomElement :: [a] -> IO a-randomElement xs = do-  ix <- randomIO-  return (xs !! (ix `mod` length xs))--remotableDecl [-    [d| dfib :: ([NodeId], SendPort Integer, Integer) -> Process () ;-        dfib (_, reply, 0) = sendChan reply 0-        dfib (_, reply, 1) = sendChan reply 1-        dfib (nids, reply, n) = do-          nid1 <- liftIO $ randomElement nids-          nid2 <- liftIO $ randomElement nids-          (sport, rport) <- newChan-          spawn nid1 $ $(mkClosure 'dfib) (nids, sport, n - 2)-          spawn nid2 $ $(mkClosure 'dfib) (nids, sport, n - 1)-          n1 <- receiveChan rport-          n2 <- receiveChan rport-          sendChan reply $ n1 + n2-      |]-  ]---- Just try creating a static polymorphic value-staticQuintuple :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e)-                => Static (a -> b -> c -> d -> e -> (a, b, c, d, e))-staticQuintuple = $(mkStatic 'quintuple)--factorialClosure :: Int -> Closure (Process Int)-factorialClosure = $(mkClosure 'factorial)--addIntClosure :: Int -> Closure (Int -> Int)-addIntClosure = $(mkClosure 'addInt)--putIntClosure :: Int -> Closure (MVar Int -> IO ())-putIntClosure = $(mkClosure 'putInt)--sendPidClosure :: ProcessId -> Closure (Process ())-sendPidClosure = $(mkClosure 'sendPid)--sendFac :: Int -> ProcessId -> Closure (Process ())-sendFac n pid = factorialClosure n `bindCP` cpSend $(mkStatic 'sdictInt) pid--factorialOf :: Closure (Int -> Process Int)-factorialOf = staticClosure $(mkStatic 'factorial)--factorial' :: Int -> Closure (Process Int)-factorial' n = returnCP $(mkStatic 'sdictInt) n `bindCP` factorialOf--waitClosure :: Int -> Closure (Process ())-waitClosure = $(mkClosure 'wait)--simulateNetworkFailure :: TransportInternals -> NodeId -> NodeId -> Process ()-simulateNetworkFailure transportInternals fr to = liftIO $ do-  threadDelay 10000-  sock <- socketBetween transportInternals (nodeAddress fr) (nodeAddress to)-  sClose sock-  threadDelay 10000------------------------------------------------------------------------------------- The tests proper                                                           -------------------------------------------------------------------------------------testUnclosure :: Transport -> RemoteTable -> Assertion-testUnclosure transport rtable = do-  node <- newLocalNode transport rtable-  done <- newEmptyMVar-  forkProcess node $ do-    120 <- join . unClosure $ factorialClosure 5-    liftIO $ putMVar done ()-  takeMVar done--testBind :: Transport -> RemoteTable -> Assertion-testBind transport rtable = do-  node <- newLocalNode transport rtable-  done <- newEmptyMVar-  runProcess node $ do-    us <- getSelfPid-    join . unClosure $ sendFac 6 us-    (720 :: Int) <- expect-    liftIO $ putMVar done ()-  takeMVar done--testSendPureClosure :: Transport -> RemoteTable -> Assertion-testSendPureClosure transport rtable = do-  serverAddr <- newEmptyMVar-  serverDone <- newEmptyMVar--  forkIO $ do-    node <- newLocalNode transport rtable-    addr <- forkProcess node $ do-      cl <- expect-      fn <- unClosure cl :: Process (Int -> Int)-      13 <- return $ fn 6-      liftIO $ putMVar serverDone ()-    putMVar serverAddr addr--  forkIO $ do-    node <- newLocalNode transport rtable-    theirAddr <- readMVar serverAddr-    runProcess node $ send theirAddr (addIntClosure 7)--  takeMVar serverDone--testSendIOClosure :: Transport -> RemoteTable -> Assertion-testSendIOClosure transport rtable = do-  serverAddr <- newEmptyMVar-  serverDone <- newEmptyMVar--  forkIO $ do-    node <- newLocalNode transport rtable-    addr <- forkProcess node $ do-      cl <- expect-      io <- unClosure cl :: Process (MVar Int -> IO ())-      liftIO $ do-        someMVar <- newEmptyMVar-        io someMVar-        5 <- readMVar someMVar-        putMVar serverDone ()-    putMVar serverAddr addr--  forkIO $ do-    node <- newLocalNode transport rtable-    theirAddr <- readMVar serverAddr-    runProcess node $ send theirAddr (putIntClosure 5)--  takeMVar serverDone--testSendProcClosure :: Transport -> RemoteTable -> Assertion-testSendProcClosure transport rtable = do-  serverAddr <- newEmptyMVar-  clientDone <- newEmptyMVar--  forkIO $ do-    node <- newLocalNode transport rtable-    addr <- forkProcess node $ do-      cl <- expect-      pr <- unClosure cl :: Process (Int -> Process ())-      pr 5-    putMVar serverAddr addr--  forkIO $ do-    node <- newLocalNode transport rtable-    theirAddr <- readMVar serverAddr-    runProcess node $ do-      pid <- getSelfPid-      send theirAddr (cpSend $(mkStatic 'sdictInt) pid)-      5 <- expect :: Process Int-      liftIO $ putMVar clientDone ()--  takeMVar clientDone--testSpawn :: Transport -> RemoteTable -> Assertion-testSpawn transport rtable = do-  serverNodeAddr <- newEmptyMVar-  clientDone <- newEmptyMVar--  forkIO $ do-    node <- newLocalNode transport rtable-    putMVar serverNodeAddr (localNodeId node)--  forkIO $ do-    node <- newLocalNode transport rtable-    nid <- readMVar serverNodeAddr-    runProcess node $ do-      pid   <- getSelfPid-      pid'  <- spawn nid (sendPidClosure pid)-      pid'' <- expect-      True <- return $ pid' == pid''-      liftIO $ putMVar clientDone ()--  takeMVar clientDone--testCall :: Transport -> RemoteTable -> Assertion-testCall transport rtable = do-  serverNodeAddr <- newEmptyMVar-  clientDone <- newEmptyMVar--  forkIO $ do-    node <- newLocalNode transport rtable-    putMVar serverNodeAddr (localNodeId node)--  forkIO $ do-    node <- newLocalNode transport rtable-    nid <- readMVar serverNodeAddr-    runProcess node $ do-      (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorialClosure 5)-      liftIO $ putMVar clientDone ()--  takeMVar clientDone--testCallBind :: Transport -> RemoteTable -> Assertion-testCallBind transport rtable = do-  serverNodeAddr <- newEmptyMVar-  clientDone <- newEmptyMVar--  forkIO $ do-    node <- newLocalNode transport rtable-    putMVar serverNodeAddr (localNodeId node)--  forkIO $ do-    node <- newLocalNode transport rtable-    nid <- readMVar serverNodeAddr-    runProcess node $ do-      (120 :: Int) <- call $(mkStatic 'sdictInt) nid (factorial' 5)-      liftIO $ putMVar clientDone ()--  takeMVar clientDone--testSeq :: Transport -> RemoteTable -> Assertion-testSeq transport rtable = do-  node <- newLocalNode transport rtable-  done <- newEmptyMVar-  runProcess node $ do-    us <- getSelfPid-    join . unClosure $ sendFac 5 us `seqCP` sendFac 6 us-    120 :: Int <- expect-    720 :: Int <- expect-    liftIO $ putMVar done ()-  takeMVar done---- Test 'spawnSupervised'------ Set up a supervisor, spawn a child, then have a third process monitor the--- child. The supervisor then throws an exception, the child dies because it--- was linked to the supervisor, and the third process notices that the child--- dies.-testSpawnSupervised :: Transport -> RemoteTable -> Assertion-testSpawnSupervised transport rtable = do-    [node1, node2]       <- replicateM 2 $ newLocalNode transport rtable-    [superPid, childPid] <- replicateM 2 $ newEmptyMVar-    thirdProcessDone     <- newEmptyMVar--    forkProcess node1 $ do-      us <- getSelfPid-      liftIO $ putMVar superPid us-      (child, _ref) <- spawnSupervised (localNodeId node2) (waitClosure 1000000)-      liftIO $ do-        putMVar childPid child-        threadDelay 500000 -- Give the child a chance to link to us-        throw supervisorDeath--    forkProcess node2 $ do-      [super, child] <- liftIO $ mapM readMVar [superPid, childPid]-      ref <- monitor child-      ProcessMonitorNotification ref' pid' (DiedException e) <- expect-      True <- return $ ref' == ref-                    && pid' == child-                    && e == show (ProcessLinkException super (DiedException (show supervisorDeath)))-      liftIO $ putMVar thirdProcessDone ()--    takeMVar thirdProcessDone-  where-    supervisorDeath :: IOException-    supervisorDeath = userError "Supervisor died"--testSpawnInvalid :: Transport -> RemoteTable -> Assertion-testSpawnInvalid transport rtable = do-  node <- newLocalNode transport rtable-  done <- newEmptyMVar-  forkProcess node $ do-    (pid, ref) <- spawnMonitor (localNodeId node) (closure (staticLabel "ThisDoesNotExist") empty)-    ProcessMonitorNotification ref' pid' _reason <- expect-    -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure-    True <- return $ ref' == ref && pid == pid'-    liftIO $ putMVar done ()-  takeMVar done--testClosureExpect :: Transport -> RemoteTable -> Assertion-testClosureExpect transport rtable = do-  node <- newLocalNode transport rtable-  done <- newEmptyMVar-  runProcess node $ do-    nodeId <- getSelfNode-    us     <- getSelfPid-    them   <- spawn nodeId $ cpExpect $(mkStatic 'sdictInt) `bindCP` cpSend $(mkStatic 'sdictInt) us-    send them (1234 :: Int)-    (1234 :: Int) <- expect-    liftIO $ putMVar done ()-  takeMVar done--testSpawnChannel :: Transport -> RemoteTable -> Assertion-testSpawnChannel transport rtable = do-  done <- newEmptyMVar-  [node1, node2] <- replicateM 2 $ newLocalNode transport rtable--  forkProcess node1 $ do-    pingServer <- spawnChannel-                    (sdictSendPort sdictUnit)-                    (localNodeId node2)-                    ($(mkClosure 'typedPingServer) ())-    (sendReply, receiveReply) <- newChan-    sendChan pingServer sendReply-    receiveChan receiveReply-    liftIO $ putMVar done ()--  takeMVar done--testTDict :: Transport -> RemoteTable -> Assertion-testTDict transport rtable = do-  done <- newEmptyMVar-  [node1, node2] <- replicateM 2 $ newLocalNode transport rtable-  forkProcess node1 $ do-    True <- call $(functionTDict 'isPrime) (localNodeId node2) ($(mkClosure 'isPrime) (79 :: Integer))-    liftIO $ putMVar done ()-  takeMVar done--testFib :: Transport -> RemoteTable -> Assertion-testFib transport rtable = do-  nodes <- replicateM 4 $ newLocalNode transport rtable-  done <- newEmptyMVar--  forkProcess (head nodes) $ do-    (sport, rport) <- newChan-    spawnLocal $ dfib (map localNodeId nodes, sport, 10)-    55 <- receiveChan rport :: Process Integer-    liftIO $ putMVar done ()--  takeMVar done--testSpawnReconnect :: Transport -> RemoteTable -> TransportInternals -> Assertion-testSpawnReconnect transport rtable transportInternals = do-  [node1, node2] <- replicateM 2 $ newLocalNode transport rtable-  let nid1 = localNodeId node1-      nid2 = localNodeId node2-  done <- newEmptyMVar-  iv <- newMVar (0 :: Int)--  incr <- forkProcess node1 $ forever $ do-    () <- expect-    liftIO $ modifyMVar_ iv (return . (+ 1))--  forkProcess node2 $ do-    _pid1 <- spawn nid1 ($(mkClosure 'signal) incr)-    simulateNetworkFailure transportInternals nid2 nid1-    _pid2 <- spawn nid1 ($(mkClosure 'signal) incr)-    _pid3 <- spawn nid1 ($(mkClosure 'signal) incr)--    liftIO $ threadDelay 100000--    count <- liftIO $ takeMVar iv-    True <- return $ count == 2 || count == 3 -- It depends on which message we get first in 'spawn'--    liftIO $ putMVar done ()--  takeMVar done---- | 'spawn' used to ave a race condition which would be triggered if the--- spawning process terminates immediately after spawning-testSpawnTerminate :: Transport -> RemoteTable -> Assertion-testSpawnTerminate transport rtable = do-  slave  <- newLocalNode transport rtable-  master <- newLocalNode transport rtable-  masterDone <- newEmptyMVar--  runProcess master $ do-    us <- getSelfPid-    replicateM_ 1000 . spawnLocal . void . spawn (localNodeId slave) $ $(mkClosure 'signal) us-    replicateM_ 1000 $ (expect :: Process ())-    liftIO $ putMVar masterDone ()--  takeMVar masterDone--tests :: (Transport, TransportInternals) -> RemoteTable -> [Test]-tests (transport, transportInternals) rtable = [-    testCase "Unclosure"       (testUnclosure       transport rtable)-  , testCase "Bind"            (testBind            transport rtable)-  , testCase "SendPureClosure" (testSendPureClosure transport rtable)-  , testCase "SendIOClosure"   (testSendIOClosure   transport rtable)-  , testCase "SendProcClosure" (testSendProcClosure transport rtable)-  , testCase "Spawn"           (testSpawn           transport rtable)-  , testCase "Call"            (testCall            transport rtable)-  , testCase "CallBind"        (testCallBind        transport rtable)-  , testCase "Seq"             (testSeq             transport rtable)-  , testCase "SpawnSupervised" (testSpawnSupervised transport rtable)-  , testCase "SpawnInvalid"    (testSpawnInvalid    transport rtable)-  , testCase "ClosureExpect"   (testClosureExpect   transport rtable)-  , testCase "SpawnChannel"    (testSpawnChannel    transport rtable)-  , testCase "TDict"           (testTDict           transport rtable)-  , testCase "Fib"             (testFib             transport rtable)-  , testCase "SpawnTerminate"  (testSpawnTerminate  transport rtable)-  , testCase "SpawnReconnect"  (testSpawnReconnect  transport rtable transportInternals)-  ]---main :: IO ()-main = do-  Right transport <- createTransportExposeInternals "127.0.0.1" "8080" defaultTCPParameters-  let rtable = __remoteTable . __remoteTableDecl $ initRemoteTable-  defaultMain (tests transport rtable)
− tests/TestStats.hs 
@@ -1,162 +0,0 @@-{-# LANGUAGE DeriveDataTypeable        #-}-{-# OPTIONS_GHC -fno-warn-orphans      #-}-module Main where--import Control.Concurrent.MVar-  ( MVar-  , newEmptyMVar-  , putMVar-  , takeMVar-  )-import Control.Distributed.Process-import Control.Distributed.Process.Node-  ( forkProcess-  , newLocalNode-  , initRemoteTable-  , closeLocalNode-  , LocalNode)-import Data.Binary()-import Data.Typeable()-import Network.Transport.TCP-import Prelude hiding (catch, log)-import Test.Framework-  ( Test-  , defaultMain-  , testGroup-  )-import Test.HUnit (Assertion)-import Test.HUnit.Base (assertBool)-import Test.Framework.Providers.HUnit (testCase)---- these utilities have been cribbed from distributed-process-platform--- we should really find a way to share them...---- | A mutable cell containing a test result.-type TestResult a = MVar a--delayedAssertion :: (Eq a) => String -> LocalNode -> a ->-                    (TestResult a -> Process ()) -> Assertion-delayedAssertion note localNode expected testProc = do-  result <- newEmptyMVar-  _ <- forkProcess localNode $ testProc result-  assertComplete note result expected--assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()-assertComplete msg mv a = do-  b <- takeMVar mv-  assertBool msg (a == b)--stash :: TestResult a -> a -> Process ()-stash mvar x = liftIO $ putMVar mvar x----------testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()-testLocalDeadProcessInfo result = do-  pid <- spawnLocal $ do "finish" <- expect; return ()-  mref <- monitor pid-  send pid "finish"-  _ <- receiveWait [-      matchIf (\(ProcessMonitorNotification ref' pid' r) ->-                    ref' == mref && pid' == pid && r == DiedNormal)-              (\p -> return p)-    ]-  getProcessInfo pid >>= stash result--testLocalLiveProcessInfo :: TestResult Bool -> Process ()-testLocalLiveProcessInfo result = do-  self <- getSelfPid-  node <- getSelfNode-  register "foobar" self--  mon <- liftIO $ newEmptyMVar-  -- TODO: we can't get the mailbox's length-  -- mapM (send self) ["hello", "there", "mr", "process"]-  pid <- spawnLocal $ do-       link self-       mRef <- monitor self-       stash mon mRef-       "die" <- expect-       return ()--  monRef <- liftIO $ takeMVar mon--  mpInfo <- getProcessInfo self-  case mpInfo of-    Nothing -> stash result False-    Just p  -> verifyPInfo p pid monRef node-  where verifyPInfo :: ProcessInfo-                    -> ProcessId-                    -> MonitorRef-                    -> NodeId-                    -> Process ()-        verifyPInfo pInfo pid mref node =-          stash result $ infoNode pInfo     == node           &&-                         infoLinks pInfo    == [pid]          &&-                         infoMonitors pInfo == [(pid, mref)]  &&---                         infoMessageQueueLength pInfo == Just 4 &&-                         infoRegisteredNames pInfo == ["foobar"]--testRemoteLiveProcessInfo :: LocalNode -> Assertion-testRemoteLiveProcessInfo node1 = do-  serverAddr <- liftIO $ newEmptyMVar :: IO (MVar ProcessId)-  liftIO $ launchRemote serverAddr-  serverPid <- liftIO $ takeMVar serverAddr-  withActiveRemote node1 $ \result -> do-    self <- getSelfPid-    link serverPid-    -- our send op shouldn't overtake link or monitor requests AFAICT-    -- so a little table tennis should get us synchronised properly-    send serverPid (self, "ping")-    "pong" <- expect-    pInfo <- getProcessInfo serverPid-    stash result $ pInfo /= Nothing-  where -    launchRemote :: MVar ProcessId -> IO ()-    launchRemote locMV = do-        node2 <- liftIO $ mkNode "8082"-        _ <- liftIO $ forkProcess node2 $ do-            self <- getSelfPid-            liftIO $ putMVar locMV self-            _ <- receiveWait [-                  match (\(pid, "ping") -> send pid "pong") -                ]-            "stop" <- expect-            return ()-        return ()--    withActiveRemote :: LocalNode-                     -> ((TestResult Bool -> Process ()) -> Assertion)-    withActiveRemote n = do-      a <- delayedAssertion "getProcessInfo remotePid failed" n True-      return a--tests :: LocalNode -> IO [Test]-tests node1 = do-  return [-    testGroup "Process Info" [-        testCase "testLocalDeadProcessInfo"-            (delayedAssertion-             "expected dead process-info to be ProcessInfoNone"-             node1 (Nothing) testLocalDeadProcessInfo)-      , testCase "testLocalLiveProcessInfo"-            (delayedAssertion-             "expected process-info to be correctly populated"-             node1 True testLocalLiveProcessInfo)-      , testCase "testRemoveLiveProcessInfo"-                 (testRemoteLiveProcessInfo node1)-    ] ]--mkNode :: String -> IO LocalNode-mkNode port = do-  Right (transport1, _) <- createTransportExposeInternals-                                    "127.0.0.1" port defaultTCPParameters-  newLocalNode transport1 initRemoteTable--main :: IO ()-main = do-  node1 <- mkNode "8081"-  testData <- tests node1-  defaultMain testData-  closeLocalNode node1-  return ()