packages feed

distributed-process-platform (empty) → 0.1.0

raw patch · 56 files changed

+15742/−0 lines, 56 filesdep +HUnitdep +QuickCheckdep +ansi-terminalsetup-changed

Dependencies added: HUnit, QuickCheck, ansi-terminal, base, binary, bytestring, containers, data-accessor, deepseq, derive, directory, distributed-process, distributed-process-platform, distributed-static, fingertree, ghc-prim, hashable, mtl, network, network-transport, network-transport-tcp, old-locale, rematch, stm, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2, time, transformers, uniplate, unordered-containers

Files

+ LICENCE view
@@ -0,0 +1,30 @@+Copyright Tim Watson, 2012-2013.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the author nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ distributed-process-platform.cabal view
@@ -0,0 +1,496 @@+name:           distributed-process-platform+version:        0.1.0+cabal-version:  >=1.8+build-type:     Simple+license:        BSD3+license-file:   LICENCE+stability:      experimental+Copyright:      Tim Watson 2012 - 2013+Author:         Tim Watson+Maintainer:     watson.timothy@gmail.com+Stability:      experimental+Homepage:       http://github.com/haskell-distributed/distributed-process-platform+Bug-Reports:    http://github.com/haskell-distributed/distributed-process-platform/issues+synopsis:       The Cloud Haskell Application Platform+description:    Modelled after Erlang's OTP, this framework provides similar+                facilities for Cloud Haskell, grouping essential practices+                into a set of modules and standards designed to help you build+                concurrent, distributed applications with relative ease.+category:       Control+tested-with:    GHC == 7.4.2 GHC == 7.6.2+data-dir:       ""++source-repository head+  type:      git+  location:  https://github.com/haskell-distributed/distributed-process-platform++flag perf+  description: Build with profiling enabled+  default: False++library+  build-depends:+                   base >= 4.4 && < 5,+                   data-accessor >= 0.2.2.3,+                   distributed-process >= 0.5.0 && < 0.6,+                   binary >= 0.6.3.0 && < 0.8,+                   deepseq >= 1.3.0.1 && < 1.4,+                   mtl,+                   containers >= 0.4 && < 0.6,+                   hashable >= 1.2.0.5 && < 1.3,+                   unordered-containers >= 0.2.3.0 && < 0.3,+                   fingertree == 0.0.1.1,+                   stm >= 2.4 && < 2.5,+                   time > 1.4 && < 1.5,+                   transformers+  if impl(ghc <= 7.5) +    Build-Depends:   template-haskell == 2.7.0.0,+                     derive == 2.5.5,+                     uniplate == 1.6.12,+                     ghc-prim+  extensions:      CPP+  hs-source-dirs:   src+  ghc-options:      -Wall+  exposed-modules:+                   Control.Distributed.Process.Platform,+                   Control.Distributed.Process.Platform.Async,+                   Control.Distributed.Process.Platform.Async.AsyncChan,+                   Control.Distributed.Process.Platform.Async.AsyncSTM,+                   Control.Distributed.Process.Platform.Call,+                   Control.Distributed.Process.Platform.Execution,+                   Control.Distributed.Process.Platform.Execution.EventManager,+                   Control.Distributed.Process.Platform.Execution.Exchange,+                   Control.Distributed.Process.Platform.Execution.Mailbox,+                   Control.Distributed.Process.Platform.ManagedProcess,+                   Control.Distributed.Process.Platform.ManagedProcess.Client,+                   Control.Distributed.Process.Platform.ManagedProcess.UnsafeClient,+                   Control.Distributed.Process.Platform.ManagedProcess.Server,+                   Control.Distributed.Process.Platform.ManagedProcess.Server.Priority,+                   Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted,+                   Control.Distributed.Process.Platform.Service,+                   Control.Distributed.Process.Platform.Service.Monitoring,+                   Control.Distributed.Process.Platform.Service.Registry,+                   Control.Distributed.Process.Platform.Service.SystemLog,+                   Control.Distributed.Process.Platform.Supervisor,+                   Control.Distributed.Process.Platform.Task,+                   Control.Distributed.Process.Platform.Task.Queue.BlockingQueue,+                   Control.Distributed.Process.Platform.Test,+                   Control.Distributed.Process.Platform.Time,+                   Control.Distributed.Process.Platform.Timer,+                   Control.Distributed.Process.Platform.UnsafePrimitives,+                   Control.Concurrent.Utils+  other-modules:+                   Control.Distributed.Process.Platform.Internal.Containers.MultiMap,+                   Control.Distributed.Process.Platform.Async.Types,+                   Control.Distributed.Process.Platform.Execution.Exchange.Broadcast,+                   Control.Distributed.Process.Platform.Execution.Exchange.Internal,+                   Control.Distributed.Process.Platform.Execution.Exchange.Router,+                   Control.Distributed.Process.Platform.Internal.Primitives,+                   Control.Distributed.Process.Platform.Internal.Types,+                   Control.Distributed.Process.Platform.Internal.Queue.SeqQ,+                   Control.Distributed.Process.Platform.Internal.Queue.PriorityQ+                   Control.Distributed.Process.Platform.Internal.Unsafe,+                   Control.Distributed.Process.Platform.ManagedProcess.Internal.Types,+                   Control.Distributed.Process.Platform.ManagedProcess.Internal.GenProcess,+                   Control.Distributed.Process.Platform.Supervisor.Types+++test-suite TimerTests+  type:            exitcode-stdio-1.0+  x-uses-tf:       true+  build-depends:+                   base >= 4.4 && < 5,+                   ansi-terminal >= 0.5 && < 0.6,+                   distributed-process >= 0.5.0 && < 0.6,+                   distributed-process-platform,+                   binary >= 0.6.3.0 && < 0.8,+                   deepseq >= 1.3.0.1 && < 1.4,+                   containers >= 0.4 && < 0.6,+                   network-transport >= 0.4 && < 0.5,+                   mtl,+                   network-transport-tcp >= 0.4 && < 0.5,+                   network >= 2.3 && < 2.5,+                   HUnit >= 1.2 && < 2,+                   stm >= 2.3 && < 2.5,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   rematch >= 0.2.0.0,+                   transformers+  hs-source-dirs:+                   tests+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind+  extensions:      CPP,+                   FlexibleInstances     +  main-is:         TestTimer.hs++test-suite PrimitivesTests+  type:            exitcode-stdio-1.0+  x-uses-tf:       true+  build-depends:+                   base >= 4.4 && < 5,+                   ansi-terminal >= 0.5 && < 0.6,+                   distributed-process >= 0.5.0 && < 0.6,+                   distributed-process-platform,+                   network-transport >= 0.4 && < 0.5,+                   mtl,+                   containers >= 0.4 && < 0.6,+                   network-transport-tcp >= 0.4 && < 0.5,+                   binary >= 0.6.3.0 && < 0.8,+                   deepseq >= 1.3.0.1 && < 1.4,+                   network >= 2.3 && < 2.5,+                   HUnit >= 1.2 && < 2,+                   stm >= 2.3 && < 2.5,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   rematch >= 0.2.0.0,+                   transformers+  hs-source-dirs:+                   tests+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind+  extensions:      CPP+  main-is:         TestPrimitives.hs++test-suite AsyncTests+  type:            exitcode-stdio-1.0+  x-uses-tf:       true+  build-depends:+                   base >= 4.4 && < 5,+                   ansi-terminal >= 0.5 && < 0.6,+                   distributed-process >= 0.5.0 && < 0.6,+                   distributed-process-platform,+                   network-transport >= 0.4 && < 0.5,+                   mtl,+                   network-transport-tcp >= 0.4 && < 0.5,+                   binary >= 0.6.3.0 && < 0.8,+                   deepseq >= 1.3.0.1 && < 1.4,+                   network >= 2.3 && < 2.5,+                   HUnit >= 1.2 && < 2,+                   stm >= 2.3 && < 2.5,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   rematch >= 0.2.0.0,+                   transformers+  hs-source-dirs:+                   tests+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind+  extensions:      CPP+  main-is:         TestAsync.hs++test-suite ManagedProcessTests+  type:            exitcode-stdio-1.0+  x-uses-tf:       true+  build-depends:+                   base >= 4.4 && < 5,+                   ansi-terminal >= 0.5 && < 0.6,+                   containers,+                   distributed-process >= 0.5.0 && < 0.6,+                   distributed-process-platform,+                   network-transport >= 0.4 && < 0.5,+                   mtl,+                   fingertree == 0.0.1.1,+                   network-transport-tcp >= 0.4 && < 0.5,+                   binary >= 0.6.3.0 && < 0.8,+                   deepseq >= 1.3.0.1 && < 1.4,+                   network >= 2.3 && < 2.5,+                   HUnit >= 1.2 && < 2,+                   stm >= 2.3 && < 2.5,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   transformers,+                   rematch >= 0.2.0.0,+                   ghc-prim+  hs-source-dirs:+                   tests+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind+  extensions:      CPP+  main-is:         TestManagedProcess.hs++test-suite PrioritisedProcessTests+  type:            exitcode-stdio-1.0+  x-uses-tf:       true+  build-depends:+                   base >= 4.4 && < 5,+                   ansi-terminal >= 0.5 && < 0.6,+                   containers,+                   distributed-process >= 0.5.0 && < 0.6,+                   distributed-process-platform,+                   network-transport >= 0.4 && < 0.5,+                   mtl,+                   fingertree == 0.0.1.1,+                   network-transport-tcp >= 0.4 && < 0.5,+                   binary >= 0.6.3.0 && < 0.8,+                   deepseq >= 1.3.0.1 && < 1.4,+                   network >= 2.3 && < 2.5,+                   HUnit >= 1.2 && < 2,+                   stm >= 2.3 && < 2.5,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   transformers,+                   rematch >= 0.2.0.0,+                   ghc-prim+  hs-source-dirs:+                   tests+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind+  extensions:      CPP+  main-is:         TestPrioritisedProcess.hs++test-suite SupervisorTests+  type:            exitcode-stdio-1.0+  build-depends:+                   base >= 4.4 && < 5,+                   ansi-terminal >= 0.5 && < 0.6,+                   containers,+                   unordered-containers,+                   hashable,+                   distributed-process >= 0.5.0 && < 0.6,+                   distributed-process-platform,+                   distributed-static,+                   bytestring,+                   data-accessor,+                   fingertree == 0.0.1.1,+                   network-transport >= 0.4 && < 0.5,+                   mtl,+                   network-transport-tcp >= 0.4 && < 0.5,+                   binary >= 0.6.3.0 && < 0.8,+                   deepseq >= 1.3.0.1 && < 1.4,+                   network >= 2.3 && < 2.5,+                   HUnit >= 1.2 && < 2,+                   stm >= 2.3 && < 2.5,+                   time > 1.4 && < 1.5,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   transformers,+                   rematch >= 0.2.0.0,+                   ghc-prim+  hs-source-dirs:+                   tests+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog+  extensions:      CPP+  main-is:         TestSupervisor.hs++test-suite RegistryTests+  type:            exitcode-stdio-1.0+--  x-uses-tf:       true+  build-depends:+                   base >= 4.4 && < 5,+                   ansi-terminal >= 0.5 && < 0.6,+                   containers,+                   hashable,+                   unordered-containers,+                   distributed-process >= 0.5.0 && < 0.6,+                   distributed-process-platform,+                   distributed-static,+                   bytestring,+                   data-accessor,+                   fingertree == 0.0.1.1,+                   network-transport >= 0.4 && < 0.5,+                   deepseq >= 1.3.0.1 && < 1.4,+                   mtl,+                   network-transport-tcp >= 0.4 && < 0.5,+                   binary >= 0.6.3.0 && < 0.8,+                   network >= 2.3 && < 2.5,+                   HUnit >= 1.2 && < 2,+                   stm >= 2.3 && < 2.5,+                   time > 1.4 && < 1.5,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   transformers,+                   rematch >= 0.2.0.0,+                   ghc-prim+  hs-source-dirs:+                   tests+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog+  extensions:      CPP+  main-is:         TestRegistry.hs++test-suite TaskQueueTests+  type:            exitcode-stdio-1.0+--  x-uses-tf:       true+  build-depends:+                   base >= 4.4 && < 5,+                   ansi-terminal >= 0.5 && < 0.6,+                   containers,+                   hashable,+                   unordered-containers >= 0.2.3.0 && < 0.3,+                   distributed-process >= 0.5.0 && < 0.6,+                   distributed-process-platform,+                   distributed-static,+                   bytestring,+                   data-accessor,+                   fingertree == 0.0.1.1,+                   network-transport >= 0.4 && < 0.5,+                   deepseq >= 1.3.0.1 && < 1.4,+                   mtl,+                   network-transport-tcp >= 0.4 && < 0.5,+                   binary >= 0.6.3.0 && < 0.8,+                   network >= 2.3 && < 2.5,+                   HUnit >= 1.2 && < 2,+                   stm >= 2.3 && < 2.5,+                   time > 1.4 && < 1.5,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   QuickCheck >= 2.4,+                   test-framework-quickcheck2,+                   transformers,+                   rematch >= 0.2.0.0,+                   ghc-prim+  hs-source-dirs:+                   tests+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog+  extensions:      CPP+  main-is:         TestTaskQueues.hs++test-suite LoggerTests+  type:            exitcode-stdio-1.0+--  x-uses-tf:       true+  build-depends:+                   base >= 4.4 && < 5,+                   ansi-terminal >= 0.5 && < 0.6,+                   containers,+                   hashable,+                   unordered-containers >= 0.2.3.0 && < 0.3,+                   distributed-process >= 0.5.0 && < 0.6,+                   distributed-process-platform,+                   distributed-static,+                   bytestring,+                   data-accessor,+                   fingertree == 0.0.1.1,+                   network-transport >= 0.4 && < 0.5,+                   deepseq >= 1.3.0.1 && < 1.4,+                   mtl,+                   network-transport-tcp >= 0.4 && < 0.5,+                   binary >= 0.6.3.0 && < 0.8,+                   network >= 2.3 && < 2.5,+                   HUnit >= 1.2 && < 2,+                   stm >= 2.3 && < 2.5,+                   time > 1.4 && < 1.5,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   transformers,+                   rematch >= 0.2.0.0,+                   ghc-prim+  hs-source-dirs:+                   tests+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog+  extensions:      CPP+  main-is:         TestLog.hs++test-suite ExchangeTests+  type:            exitcode-stdio-1.0+--  x-uses-tf:       true+  build-depends:+                   base >= 4.4 && < 5,+                   ansi-terminal >= 0.5 && < 0.6,+                   containers,+                   hashable,+                   unordered-containers >= 0.2.3.0 && < 0.3,+                   distributed-process >= 0.5.0 && < 0.6,+                   distributed-process-platform,+                   distributed-static,+                   bytestring,+                   data-accessor,+                   fingertree == 0.0.1.1,+                   network-transport >= 0.4 && < 0.5,+                   deepseq >= 1.3.0.1 && < 1.4,+                   mtl,+                   network-transport-tcp >= 0.4 && < 0.5,+                   binary >= 0.6.3.0 && < 0.8,+                   network >= 2.3 && < 2.5,+                   HUnit >= 1.2 && < 2,+                   stm >= 2.3 && < 2.5,+                   time > 1.4 && < 1.5,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   QuickCheck >= 2.4,+                   test-framework-quickcheck2,+                   transformers,+                   rematch >= 0.2.0.0,+                   ghc-prim+  hs-source-dirs:+                   tests+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog+  extensions:      CPP+  main-is:         TestExchange.hs++test-suite MailboxTests+  type:            exitcode-stdio-1.0+--  x-uses-tf:       true+  build-depends:+                   base >= 4.4 && < 5,+                   ansi-terminal >= 0.5 && < 0.6,+                   containers,+                   hashable,+                   unordered-containers >= 0.2.3.0 && < 0.3,+                   distributed-process >= 0.5.0 && < 0.6,+                   distributed-process-platform,+                   distributed-static,+                   bytestring,+                   data-accessor,+                   fingertree == 0.0.1.1,+                   network-transport >= 0.4 && < 0.5,+                   deepseq >= 1.3.0.1 && < 1.4,+                   mtl,+                   network-transport-tcp >= 0.4 && < 0.5,+                   binary >= 0.6.3.0 && < 0.8,+                   network >= 2.3 && < 2.5,+                   HUnit >= 1.2 && < 2,+                   stm >= 2.3 && < 2.5,+                   time > 1.4 && < 1.5,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   QuickCheck >= 2.4,+                   test-framework-quickcheck2,+                   transformers,+                   rematch >= 0.2.0.0,+                   ghc-prim+  hs-source-dirs:+                   tests+  ghc-options:     -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog+  extensions:      CPP+  main-is:         TestMailbox.hs++test-suite InternalQueueTests+  type:            exitcode-stdio-1.0+  x-uses-tf:       true+  build-depends:+                   base >= 4.4 && < 5,+                   ansi-terminal >= 0.5 && < 0.6,+                   containers,+                   data-accessor,+                   fingertree == 0.0.1.1,+                   HUnit >= 1.2 && < 2,+                   test-framework >= 0.6 && < 0.9,+                   test-framework-hunit,+                   QuickCheck >= 2.4,+                   test-framework-quickcheck2,+                   rematch >= 0.2.0.0,+                   ghc-prim+  hs-source-dirs:+                   src,+                   tests+  ghc-options:     -Wall -rtsopts+  extensions:      CPP+  main-is:         TestQueues.hs+  cpp-options:     -DTESTING++Executable leaks+  if flag(perf)+    Build-Depends:   base >= 4.4 && < 5,+                     containers,+                     directory,+                     network-transport-tcp,+                     distributed-process,+                     old-locale,+                     time,+                     distributed-process-platform,+                     network-transport-tcp >= 0.4 && < 0.5,+                     bytestring >= 0.9 && < 0.11,+                     binary > 0.6.2.0 && < 0.8,+                     deepseq >= 1.3.0.1 && < 1.4+  else+    buildable: False+  Main-Is:           regressions/LeakByteStrings.hs+--  Main-Is:           regressions/HRoqLeak.hs+  ghc-options:       -threaded -prof -auto-all -rtsopts+  Extensions:        ScopedTypeVariables+
+ regressions/LeakByteStrings.hs view
@@ -0,0 +1,106 @@+module Main where++import Control.Concurrent (threadDelay)+import Control.Distributed.Process hiding (call)+import Control.Distributed.Process.Node+import Control.Distributed.Process.Platform.Async.AsyncChan hiding (worker)+import qualified Control.Distributed.Process.Platform.Async.AsyncChan as C (worker)+import Control.Distributed.Process.Platform.ManagedProcess hiding+  (call, callAsync, shutdown, runProcess)+import qualified Control.Distributed.Process.Platform.ManagedProcess as P (call, shutdown)+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Platform.Timer+import Control.Exception (SomeException)+import Network.Transport.TCP (createTransportExposeInternals, defaultTCPParameters)+import Prelude hiding (catch)++import Data.Time.Clock (getCurrentTime)+import Data.Time.Format (formatTime)+import System.Locale (defaultTimeLocale)++{-# INLINE forever' #-}+forever' :: Monad m => m a -> m b+forever' a = let a' = a >> a' in a'++main :: IO ()+main = do+  node <- startLocalNode+  runProcess node $ doWork True False+  runProcess node $ doWork False False+--  runProcess node $ doWork True False++--  runProcess node worker+--  runProcess node $ do+--    sleep $ seconds 10+--    say "done...."+  threadDelay $ (1*1000000)+  closeLocalNode node+  return ()++worker :: Process ()+worker = do+  server <- startGenServer+  _      <- monitor server++  mapM_ (\(n :: Int) -> (P.call server ("bar" ++ (show n))) :: Process String) [1..800]++  -- sleep $ seconds 3+  -- P.shutdown server+  -- receiveWait [ match (\(ProcessMonitorNotification _ _ _) -> return ()) ]++  say "server is idle now..."+  sleep $ seconds 5++doWork :: Bool -> Bool -> Process ()+doWork useAsync killServer =+  let call' = case useAsync of+               True  -> callAsync+               False -> call+  in do+    server <- spawnLocal $ forever' $ do+      receiveWait [ match (\(pid, _ :: String) -> send pid ()) ]++    mapM_ (\(n :: Int) -> (call' server (show n)) :: Process ()  ) [1..800]+    sleep $ seconds 4+    say "done"+    case killServer of+      True -> kill server "stop"+      False -> return ()+    sleep $ seconds 1++startLocalNode :: IO LocalNode+startLocalNode = do+  Right (transport,_) <- createTransportExposeInternals "127.0.0.1"+                                                        "8081"+                                                        defaultTCPParameters+  node <- newLocalNode transport initRemoteTable+  return node++callAsync :: ProcessId -> String -> Process ()+callAsync pid s = do+  asyncRef <- async $ AsyncTask $ call pid s+  (AsyncDone _) <- wait asyncRef+  return ()++call :: ProcessId -> String -> Process ()+call pid s = do+    self <- getSelfPid+    send pid (self, s)+    expect :: Process ()++startGenServer :: Process ProcessId+startGenServer = do+  sid <- spawnLocal $  do+      catch (start () (statelessInit Infinity) serverDefinition >> return ())+            (\(e :: SomeException) -> say $ "failed with " ++ (show e))+  return sid++serverDefinition :: ProcessDefinition ()+serverDefinition =+  statelessProcess {+     apiHandlers = [+          handleCall_ (\(s :: String) -> return s)+        , handleCast  (\s (_ :: String) -> continue s)+        ]+  }+
+ src/Control/Concurrent/Utils.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}++module Control.Concurrent.Utils+  ( Lock()+  , Exclusive(..)+  , Synchronised(..)+  , withLock+  ) where++import Control.Distributed.Process+  ( Process+  )+import qualified Control.Distributed.Process as Process (catch)+import Control.Exception (SomeException, throw)+import qualified Control.Exception as Exception (catch)+import Control.Concurrent.MVar+  ( MVar+  , tryPutMVar+  , newMVar+  , takeMVar+  )+import Control.Monad.IO.Class (MonadIO, liftIO)++newtype Lock = Lock { mvar :: MVar () }++class Exclusive a where+  new          :: IO a+  acquire      :: (MonadIO m) => a -> m ()+  release      :: (MonadIO m) => a -> m ()++instance Exclusive Lock where+  new       = return . Lock =<< newMVar ()+  acquire   = liftIO . takeMVar . mvar+  release l = liftIO (tryPutMVar (mvar l) ()) >> return ()++class Synchronised e m where+  synchronised :: (Exclusive e, Monad m) => e -> m b -> m b++  synchronized :: (Exclusive e, Monad m) => e -> m b -> m b+  synchronized = synchronised++instance Synchronised Lock IO where+  synchronised = withLock++instance Synchronised Lock Process where+  synchronised = withLockP++withLockP :: (Exclusive e) => e -> Process a -> Process a+withLockP excl act = do+  Process.catch (do { liftIO $ acquire excl+                    ; result <- act+                    ; liftIO $ release excl+                    ; return result+                    })+                (\(e :: SomeException) -> (liftIO $ release excl) >> throw e)++withLock :: (Exclusive e) => e -> IO a -> IO a+withLock excl act = do+  Exception.catch (do { acquire excl+                      ; result <- act+                      ; release excl+                      ; return result+                      })+                  (\(e :: SomeException) -> release excl >> throw e)
+ src/Control/Distributed/Process/Platform.hs view
@@ -0,0 +1,117 @@+{- | [Cloud Haskell Platform]++[Evaluation Strategies and Support for NFData]++When sending messages to a local process (i.e., intra-node), the default+approach is to encode (i.e., serialise) the message /anyway/, just to+ensure that no unevaluated thunks are passed to the receiver.+In distributed-process, you must explicitly choose to use /unsafe/ primitives+that do nothing to ensure evaluation, since this might cause an error in the+receiver which would be difficult to debug. Using @NFData@, it is possible+to force evaluation, but there is no way to ensure that both the @NFData@+and @Binary@ instances do so in the same way (i.e., to the same depth, etc)+therefore automatic use of @NFData@ is not possible in distributed-process.++By contrast, distributed-process-platform makes extensive use of @NFData@+to force evaluation (and avoid serialisation overheads during intra-node+communication), via the @NFSerializable@ type class. This does nothing to+fix the potential disparity between @NFData@ and @Binary@ instances, so you+should verify that your data is being handled as expected (e.g., by sticking+to strict fields, or some such) and bear in mind that things could go wrong.++The @UnsafePrimitives@ module in /this/ library will force evaluation before+calling the @UnsafePrimitives@ in distributed-process, which - if you've+vetted everything correctly - should provide a bit more safety, whilst still+keeping performance at an acceptable level.++Users of the various service and utility models (such as @ManagedProcess@ and+the @Service@ and @Task@ APIs) should consult the sub-system specific+documentation for instructions on how to utilise these features.++IMPORTANT NOTICE: Despite the apparent safety of forcing evaluation before+sending, we /still/ cannot make any actual guarantees about the evaluation+semantics of these operations, and therefore the /unsafe/ moniker will remain+in place, in one form or another, for all functions and modules that use them.++[Error/Exception Handling]++It is /important/ not to be too general when catching exceptions in+cloud haskell application, because asynchonous exceptions provide cloud haskell+with its process termination mechanism. Two exception types in particular,+signal the instigator's intention to stop a process immediately, which are+raised (i.e., thrown) in response to the @kill@ and @exit@ primitives provided+by the base distributed-process package.++You should generally try to keep exception handling code to the lowest (i.e.,+most specific) scope possible. If you wish to trap @exit@ signals, use the+various flavours of @catchExit@ primitive from distributed-process.++-}+module Control.Distributed.Process.Platform+  (+    -- * Exported Types+    Addressable+  , Resolvable(..)+  , Routable(..)+  , Linkable(..)+  , Killable(..)+  , NFSerializable+  , Recipient(..)+  , ExitReason(..)+  , Channel+  , Tag+  , TagPool++    -- * Primitives overriding those in distributed-process+  , monitor+  , module Control.Distributed.Process.Platform.UnsafePrimitives++    -- * Utilities and Extended Primitives+  , spawnSignalled+  , spawnLinkLocal+  , spawnMonitorLocal+  , linkOnFailure+  , times+  , isProcessAlive+  , matchCond+  , deliver+  , awaitExit+  , awaitResponse++    -- * Call/Tagging support+  , newTagPool+  , getTag++    -- * Registration and Process Lookup+  , whereisOrStart+  , whereisOrStartRemote++    -- remote call table+  , __remoteTable+  ) where++import Control.Distributed.Process (RemoteTable)+import Control.Distributed.Process.Platform.Internal.Types+  ( NFSerializable+  , Recipient(..)+  , ExitReason(..)+  , Tag+  , TagPool+  , Channel+  , newTagPool+  , getTag+  )+import Control.Distributed.Process.Platform.UnsafePrimitives+import Control.Distributed.Process.Platform.Internal.Primitives hiding (__remoteTable)+import qualified Control.Distributed.Process.Platform.Internal.Primitives (__remoteTable)+import qualified Control.Distributed.Process.Platform.Internal.Types      (__remoteTable)+import qualified Control.Distributed.Process.Platform.Execution.Mailbox (__remoteTable)++-- remote table++__remoteTable :: RemoteTable -> RemoteTable+__remoteTable =+  Control.Distributed.Process.Platform.Execution.Mailbox.__remoteTable .+  Control.Distributed.Process.Platform.Internal.Primitives.__remoteTable .+  Control.Distributed.Process.Platform.Internal.Types.__remoteTable+
+ src/Control/Distributed/Process/Platform/Async.hs view
@@ -0,0 +1,256 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Async+-- Copyright   :  (c) Tim Watson 2012+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- The /async/ APIs provided by distributed-process-platform provide means+-- for spawning asynchronous operations, waiting for their results, cancelling+-- them and various other utilities. The two primary implementation are+-- @AsyncChan@ which provides a handle which is scoped to the calling process,+-- and @AsyncSTM@, whose async mechanism can be used by (i.e., shared across)+-- multiple local processes, though its handles cannot be serialised.+--+-- Both abstractions can run asynchronous operations on remote nodes. The STM+-- based implementation provides a slightly richer API. The API defined in+-- /this/ module only supports a subset of operations on async handles,+-- and (specifically) does not support mixing handles initialised via+-- different implementations.+--+-- [Asynchronous Operations]+--+-- There is an implicit contract for async workers; Workers must exit+-- normally (i.e., should not call the 'exit', 'die' or 'terminate'+-- Cloud Haskell primitives), otherwise the 'AsyncResult' will end up being+-- @AsyncFailed DiedException@ instead of containing the result.+--+-- See "Control.Distributed.Process.Platform.Async.AsyncSTM",+-- "Control.Distributed.Process.Platform.Async.AsyncChan",+-- "Control.Distributed.Platform.Task",+-- "Control.Distributed.Platform.Task.Execution".+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Async+ ( -- * Exported Types+    Async(..)+  , AsyncRef+  , AsyncTask(..)+  , AsyncResult(..)+  -- * Spawning asynchronous operations+  , async+  , asyncLinked+  , asyncSTM+  , asyncLinkedSTM+  , asyncChan+  , asyncLinkedChan+  , task+  , remoteTask+  , monitorAsync+  -- * Cancelling asynchronous operations+  , cancel+  , cancelWait+  , cancelWith+  , cancelKill+    -- * Querying for results+  , poll+  , check+  , wait+    -- * Waiting with timeouts+  , waitTimeout+  , waitCancelTimeout+  , waitCheckTimeout+  ) where++import Control.Distributed.Process+import Control.Distributed.Process.Serializable+  ( Serializable+  , SerializableDict+  )+import Control.Distributed.Process.Platform.Async.Types+  ( Async(..)+  , AsyncRef+  , AsyncTask(..)+  , AsyncResult(..)+  )+import qualified Control.Distributed.Process.Platform.Async.AsyncSTM as AsyncSTM+import qualified Control.Distributed.Process.Platform.Async.AsyncChan as AsyncChan+import Control.Distributed.Process.Platform.Time+import Data.Maybe+  ( fromMaybe+  )++--------------------------------------------------------------------------------+-- API                                                                        --+--------------------------------------------------------------------------------++-- | Spawn an 'AsyncTask' and return the 'Async' handle to it.+-- See 'asyncSTM'.+async :: (Serializable a) => Process a -> Process (Async a)+async t = asyncSTM (AsyncTask t)++-- | Spawn an 'AsyncTask' (linked to the calling process) and+-- return the 'Async' handle to it.+-- See 'asyncSTM'.+asyncLinked :: (Serializable a) => Process a -> Process (Async a)+asyncLinked p = AsyncSTM.newAsync AsyncSTM.asyncLinked (AsyncTask p)++-- | Spawn an 'AsyncTask' and return the 'Async' handle to it.+-- Uses the STM implementation, whose handles can be read by other+-- processes, though they're not @Serializable@.+--+-- See 'Control.Distributed.Process.Platform.Async.AsyncSTM'.+asyncSTM :: (Serializable a) => AsyncTask a -> Process (Async a)+asyncSTM = AsyncSTM.newAsync AsyncSTM.async++-- | Spawn an 'AsyncTask' (linked to the calling process) and return the+-- 'Async' handle to it. Uses the STM based implementation, whose handles+-- can be read by other processes, though they're not @Serializable@.+--+-- See 'Control.Distributed.Process.Platform.Async.AsyncSTM'.+asyncLinkedSTM :: (Serializable a) => AsyncTask a -> Process (Async a)+asyncLinkedSTM = AsyncSTM.newAsync AsyncSTM.asyncLinked++-- | Spawn an 'AsyncTask' and return the 'Async' handle to it.+-- Uses a channel based implementation, whose handles can only be read once,+-- and only by the calling process.+--+-- See 'Control.Distributed.Process.Platform.Async.AsyncChan'.+asyncChan :: (Serializable a) => AsyncTask a -> Process (Async a)+asyncChan = AsyncChan.newAsync AsyncChan.async++-- | Linked version of 'asyncChan'.+--+-- See 'Control.Distributed.Process.Platform.Async.AsyncChan'.+asyncLinkedChan :: (Serializable a) => AsyncTask a -> Process (Async a)+asyncLinkedChan = AsyncChan.newAsync AsyncChan.asyncLinked++-- | Wraps a regular @Process a@ as an 'AsyncTask'.+task :: Process a -> AsyncTask a+task = AsyncTask++-- | Wraps the components required and builds a remote 'AsyncTask'.+remoteTask :: Static (SerializableDict a)+              -> NodeId+              -> Closure (Process a)+              -> AsyncTask a+remoteTask = AsyncRemoteTask++-- | Given an 'Async' handle, monitor the worker process.+monitorAsync :: Async a -> Process MonitorRef+monitorAsync = monitor . asyncWorker++-- | Check whether an 'Async' handle has completed yet. The status of the+-- action is encoded in the returned 'AsyncResult'. If the action has not+-- completed, the result will be 'AsyncPending', or one of the other+-- constructors otherwise. This function does not block waiting for the result.+-- Use 'wait' or 'waitTimeout' if you need blocking/waiting semantics.+{-# INLINE poll #-}+poll :: (Serializable a) => Async a -> Process (AsyncResult a)+poll = hPoll++-- | Like 'poll' but returns 'Nothing' if @(poll hAsync) == AsyncPending@.+-- See 'poll'.+check :: (Serializable a) => Async a -> Process (Maybe (AsyncResult a))+check hAsync = poll hAsync >>= \r -> case r of+  AsyncPending -> return Nothing+  ar           -> return (Just ar)++-- | Wait for an asynchronous operation to complete or timeout. This variant+-- returns the 'AsyncResult' itself, which will be 'AsyncPending' if the+-- result has not been made available, otherwise one of the other constructors.+{-# INLINE waitCheckTimeout #-}+waitCheckTimeout :: (Serializable a) =>+                    TimeInterval -> Async a -> Process (AsyncResult a)+waitCheckTimeout t hAsync =+  waitTimeout t hAsync >>= return . fromMaybe (AsyncPending)++-- | Wait for an asynchronous action to complete, and return its+-- value. The result (which can include failure and/or cancellation) is+-- encoded by the 'AsyncResult' type.+{-# INLINE wait #-}+wait :: Async a -> Process (AsyncResult a)+wait = hWait++-- | Wait for an asynchronous operation to complete or timeout. Returns+-- @Nothing@ if the 'AsyncResult' does not change from @AsyncPending@ within+-- the specified delay, otherwise @Just asyncResult@ is returned. If you want+-- to wait/block on the 'AsyncResult' without the indirection of @Maybe@ then+-- consider using 'wait' or 'waitCheckTimeout' instead.+{-# INLINE waitTimeout #-}+waitTimeout :: (Serializable a) =>+               TimeInterval -> Async a -> Process (Maybe (AsyncResult a))+waitTimeout = flip hWaitTimeout++-- | Wait for an asynchronous operation to complete or timeout. If it times out,+-- then 'cancelWait' the async handle instead.+--+waitCancelTimeout :: (Serializable a)+                  => TimeInterval+                  -> Async a+                  -> Process (AsyncResult a)+waitCancelTimeout t hAsync = do+  r <- waitTimeout t hAsync+  case r of+    Nothing -> cancelWait hAsync+    Just ar -> return ar++-- | Cancel an asynchronous operation. Cancellation is asynchronous in nature.+-- To wait for cancellation to complete, use 'cancelWait' instead. The notes+-- about the asynchronous nature of 'cancelWait' apply here also.+--+-- See 'Control.Distributed.Process'+{-# INLINE cancel #-}+cancel :: Async a -> Process ()+cancel = hCancel++-- | Cancel an asynchronous operation and wait for the cancellation to complete.+-- Because of the asynchronous nature of message passing, the instruction to+-- cancel will race with the asynchronous worker, so it is /entirely possible/+-- that the 'AsyncResult' returned will not necessarily be 'AsyncCancelled'. For+-- example, the worker may complete its task after this function is called, but+-- before the cancellation instruction is acted upon.+--+-- If you wish to stop an asychronous operation /immediately/ (with caveats)+-- then consider using 'cancelWith' or 'cancelKill' instead.+--+{-# INLINE cancelWait #-}+cancelWait :: (Serializable a) => Async a -> Process (AsyncResult a)+cancelWait hAsync = cancel hAsync >> wait hAsync++-- | Cancel an asynchronous operation immediately.+-- This operation is performed by sending an /exit signal/ to the asynchronous+-- worker, which leads to the following semantics:+--+--     1. If the worker already completed, this function has no effect.+--+--     2. The worker might complete after this call, but before the signal arrives.+--+--     3. The worker might ignore the exit signal using @catchExit@.+--+-- In case of (3), this function has no effect. You should use 'cancel'+-- if you need to guarantee that the asynchronous task is unable to ignore+-- the cancellation instruction.+--+-- You should also consider that when sending exit signals to a process, the+-- definition of 'immediately' is somewhat vague and a scheduler might take+-- time to handle the request, which can lead to situations similar to (1) as+-- listed above, if the scheduler to which the calling process' thread is bound+-- decides to GC whilst another scheduler on which the worker is running is able+-- to continue.+--+-- See 'Control.Distributed.Process.exit'+{-# INLINE cancelWith #-}+cancelWith :: (Serializable b) => b -> Async a -> Process ()+cancelWith reason = (flip exit) reason . asyncWorker++-- | Like 'cancelWith' but sends a @kill@ instruction instead of an exit signal.+--+-- See 'Control.Distributed.Process.kill'+{-# INLINE cancelKill #-}+cancelKill :: String -> Async a -> Process ()+cancelKill reason = (flip kill) reason . asyncWorker+
+ src/Control/Distributed/Process/Platform/Async/AsyncChan.hs view
@@ -0,0 +1,318 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE StandaloneDeriving        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Async.AsyncChan+-- Copyright   :  (c) Tim Watson 2012+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- This module provides a set of operations for spawning Process operations+-- and waiting for their results.  It is a thin layer over the basic+-- concurrency operations provided by "Control.Distributed.Process".+-- The main feature it provides is a pre-canned set of APIs for waiting on the+-- result of one or more asynchronously running (and potentially distributed)+-- processes.+--+-- The async handles returned by this module cannot be used by processes other+-- than the caller of 'async', and are not 'Serializable'. Specifically, calls+-- that block until an async worker completes (i.e., all variants of 'wait')+-- will /never return/ if called from a different process. For example:+--+-- > h <- newEmptyMVar+-- > outer <- spawnLocal $ async runMyAsyncTask >>= liftIO $ putMVar h+-- > hAsync <- liftIO $ takeMVar h+-- > say "the next expression will never complete, because hAsync belongs to 'outer'"+-- > wait hAsync+--+-- As with "Control.Distributed.Platform.Async.AsyncSTM", workers can be+-- started on a local or remote node.+--+-- See "Control.Distributed.Platform.Async".+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Async.AsyncChan+  ( -- * Exported types+    AsyncRef+  , AsyncTask(..)+  , AsyncChan(worker)+  , AsyncResult(..)+  , Async(asyncWorker)+    -- * Spawning asynchronous operations+  , async+  , asyncLinked+  , newAsync+    -- * Cancelling asynchronous operations+  , cancel+  , cancelWait+  , cancelWith+  , cancelKill+    -- * Querying for results+  , poll+  , check+  , wait+  , waitAny+  , waitAnyCancel+    -- * Waiting with timeouts+  , waitAnyTimeout+  , waitTimeout+  , waitCancelTimeout+  , waitCheckTimeout+  ) where++import Control.Distributed.Process+import Control.Distributed.Process.Platform.Async.Types+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Platform.Internal.Types+import Control.Distributed.Process.Serializable+import Data.Maybe+  ( fromMaybe+  )++-- | Private channel used to synchronise task results+type InternalChannel a = (SendPort (AsyncResult a), ReceivePort (AsyncResult a))++--------------------------------------------------------------------------------+-- Cloud Haskell Typed Channel Async API                                      --+--------------------------------------------------------------------------------++-- | A handle for an asynchronous action spawned by 'async'.+-- Asynchronous actions are run in a separate process, and+-- operations are provided for waiting for asynchronous actions to+-- complete and obtaining their results (see e.g. 'wait').+--+-- Handles of this type cannot cross remote boundaries. Furthermore, handles+-- of this type /must not/ be passed to functions in this module by processes+-- other than the caller of 'async' - that is, this module provides asynchronous+-- actions whose results are accessible *only* by the initiating process. This+-- limitation is imposed becuase of the use of typed channels, for which the+-- @ReceivePort@ component is effectively /thread local/.+--+-- See 'async'+data AsyncChan a = AsyncChan {+    worker    :: AsyncRef+  , insulator :: AsyncRef+  , channel   :: (InternalChannel a)+  }++-- | Create a new 'AsyncChan' and wrap it in an 'Async' record.+--+-- Used by "Control.Distributed.Process.Platform.Async".+newAsync :: (Serializable a)+         => (AsyncTask a -> Process (AsyncChan a))+         -> AsyncTask a -> Process (Async a)+newAsync new t = do+  hAsync <- new t+  return Async {+      hPoll = poll hAsync+    , hWait = wait hAsync+    , hWaitTimeout = (flip waitTimeout) hAsync+    , hCancel = cancel hAsync+    , asyncWorker = worker hAsync+    }++-- | Spawns an asynchronous action in a new process.+-- We ensure that if the caller's process exits, that the worker is killed.+-- Because an @AsyncChan@ can only be used by the initial caller's process, if+-- that process dies then the result (if any) is discarded. If a process other+-- than the initial caller attempts to obtain the result of an asynchronous+-- action, the behaviour is undefined. It is /highly likely/ that such a+-- process will block indefinitely, quite possible that such behaviour could lead+-- to deadlock and almost certain that resource starvation will occur. /Do Not/+-- share the handles returned by this function across multiple processes.+--+-- If you need to spawn an asynchronous operation whose handle can be shared by+-- multiple processes then use the 'AsyncSTM' module instead.+--+-- There is currently a contract for async workers, that they should+-- exit normally (i.e., they should not call the @exit@ or @kill@ with their own+-- 'ProcessId' nor use the @terminate@ primitive to cease functining), otherwise+-- the 'AsyncResult' will end up being @AsyncFailed DiedException@ instead of+-- containing the desired result.+--+async :: (Serializable a) => AsyncTask a -> Process (AsyncChan a)+async = asyncDo True++-- | For *AsyncChan*, 'async' already ensures an @AsyncChan@ is+-- never left running unintentionally. This function is provided for compatibility+-- with other /async/ implementations that may offer different semantics for+-- @async@ with regards linking.+--+-- @asyncLinked = async@+--+asyncLinked :: (Serializable a) => AsyncTask a -> Process (AsyncChan a)+asyncLinked = async++asyncDo :: (Serializable a) => Bool -> AsyncTask a -> Process (AsyncChan a)+asyncDo shouldLink (AsyncRemoteTask d n c) =+  let proc = call d n c in asyncDo shouldLink AsyncTask { asyncTask = proc }+asyncDo shouldLink (AsyncTask proc) = do+    (wpid, gpid, chan) <- spawnWorkers proc shouldLink+    return AsyncChan {+        worker    = wpid+      , insulator = gpid+      , channel   = chan+      }++-- private API+spawnWorkers :: (Serializable a)+             => Process a+             -> Bool+             -> Process (AsyncRef, AsyncRef, InternalChannel a)+spawnWorkers task shouldLink = do+    root <- getSelfPid+    chan <- newChan++    -- listener/response proxy+    insulatorPid <- spawnLocal $ do+        workerPid <- spawnLocal $ do+            () <- expect+            r <- task+            sendChan (fst chan) (AsyncDone r)++        send root workerPid   -- let the parent process know the worker pid++        wref <- monitor workerPid+        rref <- case shouldLink of+                    True  -> monitor root >>= return . Just+                    False -> return Nothing+        finally (pollUntilExit workerPid chan)+                (unmonitor wref >>+                    return (maybe (return ()) unmonitor rref))++    workerPid <- expect+    send workerPid ()+    return (workerPid, insulatorPid, chan)+  where+    -- blocking receive until we see an input message+    pollUntilExit :: (Serializable a)+                  => ProcessId+                  -> (SendPort (AsyncResult a), ReceivePort (AsyncResult a))+                  -> Process ()+    pollUntilExit wpid (replyTo, _) = do+      r <- receiveWait [+          match (\(ProcessMonitorNotification _ pid' r) ->+                return (Right (pid', r)))+        , match (\c@(CancelWait) -> kill wpid "cancel" >> return (Left c))+        ]+      case r of+          Left  CancelWait -> sendChan replyTo AsyncCancelled+          Right (fpid, d)+            | fpid == wpid -> case d of+                                  DiedNormal -> return ()+                                  _          -> sendChan replyTo (AsyncFailed d)+            | otherwise    -> kill wpid "linkFailed"++-- | Check whether an 'AsyncChan' has completed yet.+--+-- See "Control.Distributed.Process.Platform.Async".+poll :: (Serializable a) => AsyncChan a -> Process (AsyncResult a)+poll hAsync = do+  r <- receiveChanTimeout 0 $ snd (channel hAsync)+  return $ fromMaybe (AsyncPending) r++-- | Like 'poll' but returns 'Nothing' if @(poll hAsync) == AsyncPending@.+--+-- See "Control.Distributed.Process.Platform.Async".+check :: (Serializable a) => AsyncChan a -> Process (Maybe (AsyncResult a))+check hAsync = poll hAsync >>= \r -> case r of+  AsyncPending -> return Nothing+  ar           -> return (Just ar)++-- | Wait for an asynchronous operation to complete or timeout.+--+-- See "Control.Distributed.Process.Platform.Async".+waitCheckTimeout :: (Serializable a) =>+                    TimeInterval -> AsyncChan a -> Process (AsyncResult a)+waitCheckTimeout t hAsync =+  waitTimeout t hAsync >>= return . fromMaybe (AsyncPending)++-- | Wait for an asynchronous action to complete, and return its+-- value. The outcome of the action is encoded as an 'AsyncResult'.+--+-- See "Control.Distributed.Process.Platform.Async".+wait :: (Serializable a) => AsyncChan a -> Process (AsyncResult a)+wait hAsync = receiveChan $ snd (channel hAsync)++-- | Wait for an asynchronous operation to complete or timeout.+--+-- See "Control.Distributed.Process.Platform.Async".+waitTimeout :: (Serializable a) =>+               TimeInterval -> AsyncChan a -> Process (Maybe (AsyncResult a))+waitTimeout t hAsync =+  receiveChanTimeout (asTimeout t) $ snd (channel hAsync)++-- | Wait for an asynchronous operation to complete or timeout. If it times out,+-- then 'cancelWait' the async handle instead.+--+waitCancelTimeout :: (Serializable a)+                  => TimeInterval+                  -> AsyncChan a+                  -> Process (AsyncResult a)+waitCancelTimeout t hAsync = do+  r <- waitTimeout t hAsync+  case r of+    Nothing -> cancelWait hAsync+    Just ar -> return ar++-- | Wait for any of the supplied @AsyncChans@s to complete. If multiple+-- 'Async's complete, then the value returned corresponds to the first+-- completed 'Async' in the list. Only /unread/ 'Async's are of value here,+-- because 'AsyncChan' does not hold on to its result after it has been read!+--+-- This function is analagous to the @mergePortsBiased@ primitive.+--+-- See "Control.Distibuted.Process.mergePortsBiased".+waitAny :: (Serializable a)+        => [AsyncChan a]+        -> Process (AsyncResult a)+waitAny asyncs =+  let ports = map (snd . channel) asyncs in recv ports+  where recv :: (Serializable a) => [ReceivePort a] -> Process a+        recv ps = mergePortsBiased ps >>= receiveChan++-- | Like 'waitAny', but also cancels the other asynchronous+-- operations as soon as one has completed.+--+waitAnyCancel :: (Serializable a)+              => [AsyncChan a] -> Process (AsyncResult a)+waitAnyCancel asyncs =+  waitAny asyncs `finally` mapM_ cancel asyncs++-- | Like 'waitAny' but times out after the specified delay.+waitAnyTimeout :: (Serializable a)+               => TimeInterval+               -> [AsyncChan a]+               -> Process (Maybe (AsyncResult a))+waitAnyTimeout delay asyncs =+  let ports = map (snd . channel) asyncs+  in mergePortsBiased ports >>= receiveChanTimeout (asTimeout delay)++-- | Cancel an asynchronous operation. Cancellation is asynchronous in nature.+--+-- See "Control.Distributed.Process.Platform.Async".+cancel :: AsyncChan a -> Process ()+cancel (AsyncChan _ g _) = send g CancelWait++-- | Cancel an asynchronous operation and wait for the cancellation to complete.+--+-- See "Control.Distributed.Process.Platform.Async".+cancelWait :: (Serializable a) => AsyncChan a -> Process (AsyncResult a)+cancelWait hAsync = cancel hAsync >> wait hAsync++-- | Cancel an asynchronous operation immediately.+--+-- See "Control.Distributed.Process.Platform.Async".+cancelWith :: (Serializable b) => b -> AsyncChan a -> Process ()+cancelWith reason = (flip exit) reason . worker++-- | Like 'cancelWith' but sends a @kill@ instruction instead of an exit.+--+-- See "Control.Distributed.Process.Platform.Async".+cancelKill :: String -> AsyncChan a -> Process ()+cancelKill reason = (flip kill) reason . worker
+ src/Control/Distributed/Process/Platform/Async/AsyncSTM.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE CPP                 #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Async.AsyncSTM+-- Copyright   :  (c) Tim Watson 2012 - 2013, (c) Simon Marlow 2012+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- This module provides a set of operations for spawning Process operations+-- and waiting for their results.  It is a thin layer over the basic+-- concurrency operations provided by "Control.Distributed.Process".+--+-- The difference between 'Control.Distributed.Platform.Async.AsyncSTM' and+-- 'Control.Distributed.Platform.Async.AsyncChan' is that handles of the+-- former (i.e., returned by /this/ module) can be used by processes other+-- than the caller of 'async', though they're still not 'Serializable'.+--+-- As with "Control.Distributed.Platform.Async.AsyncChan", workers can be+-- started on a local or remote node.+--+-- Portions of this file are derived from the @Control.Concurrent.Async@+-- module, from the @async@ package written by Simon Marlow.+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Async.AsyncSTM+  ( -- * Exported types+    AsyncRef+  , AsyncTask(..)+  , AsyncSTM(_asyncWorker)+  , AsyncResult(..)+  , Async(asyncWorker)+    -- * Spawning asynchronous operations+  , async+  , asyncLinked+  , newAsync+    -- * Cancelling asynchronous operations+  , cancel+  , cancelWait+  , cancelWith+  , cancelKill+    -- * Querying for results+  , poll+  , check+  , wait+  , waitAny+    -- * Waiting with timeouts+  , waitAnyTimeout+  , waitTimeout+  , waitCheckTimeout+    -- * STM versions+  , pollSTM+  , waitTimeoutSTM+  , waitAnyCancel+  , waitEither+  , waitEither_+  , waitBoth+  ) where++#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif++import Control.Applicative+import Control.Concurrent.STM hiding (check)+import Control.Distributed.Process+import Control.Distributed.Process.Serializable+import Control.Distributed.Process.Platform.Async.Types+import Control.Distributed.Process.Platform.Internal.Types+  ( CancelWait(..)+  , Channel+  )+import Control.Distributed.Process.Platform.Time+  ( asTimeout+  , TimeInterval+  )+import Control.Monad+import Data.Maybe+  ( fromMaybe+  )++import System.Timeout (timeout)++--------------------------------------------------------------------------------+-- Cloud Haskell STM Async Process API                                        --+--------------------------------------------------------------------------------++-- | An handle for an asynchronous action spawned by 'async'.+-- Asynchronous operations are run in a separate process, and+-- operations are provided for waiting for asynchronous actions to+-- complete and obtaining their results (see e.g. 'wait').+--+-- Handles of this type cannot cross remote boundaries, nor are they+-- @Serializable@.+data AsyncSTM a = AsyncSTM {+    _asyncWorker  :: AsyncRef+  , _asyncMonitor :: AsyncRef+  , _asyncWait    :: STM (AsyncResult a)+  }++instance Eq (AsyncSTM a) where+  AsyncSTM a b _ == AsyncSTM c d _  =  a == c && b == d++-- | Create a new 'AsyncSTM' and wrap it in an 'Async' record.+--+-- Used by 'Control.Distributed.Process.Platform.Async'.+newAsync :: (Serializable a)+         => (AsyncTask a -> Process (AsyncSTM a))+         -> AsyncTask a -> Process (Async a)+newAsync new t = do+  hAsync <- new t+  return Async {+      hPoll = poll hAsync+    , hWait = wait hAsync+    , hWaitTimeout = (flip waitTimeout) hAsync+    , hCancel = cancel hAsync+    , asyncWorker = _asyncWorker hAsync+    }++-- | Spawns an asynchronous action in a new process.+--+async :: (Serializable a) => AsyncTask a -> Process (AsyncSTM a)+async = asyncDo False++-- | This is a useful variant of 'async' that ensures an @AsyncChan@ is+-- never left running unintentionally. We ensure that if the caller's process+-- exits, that the worker is killed. Because an @AsyncChan@ can only be used+-- by the initial caller's process, if that process dies then the result+-- (if any) is discarded.+--+asyncLinked :: (Serializable a) => AsyncTask a -> Process (AsyncSTM a)+asyncLinked = asyncDo True++-- private API+asyncDo :: (Serializable a) => Bool -> AsyncTask a -> Process (AsyncSTM a)+asyncDo shouldLink (AsyncRemoteTask d n c) =+  let proc = call d n c in asyncDo shouldLink AsyncTask { asyncTask = proc }+asyncDo shouldLink (AsyncTask proc) = do+    root <- getSelfPid+    result <- liftIO $ newEmptyTMVarIO+    sigStart <- liftIO $ newEmptyTMVarIO+    (sp, rp) <- newChan++    -- listener/response proxy+    insulator <- spawnLocal $ do+        worker <- spawnLocal $ do+            liftIO $ atomically $ takeTMVar sigStart+            r <- proc+            void $ liftIO $ atomically $ putTMVar result (AsyncDone r)++        sendChan sp worker  -- let the parent process know the worker pid++        wref <- monitor worker+        rref <- case shouldLink of+                    True  -> monitor root >>= return . Just+                    False -> return Nothing+        finally (pollUntilExit worker result)+                (unmonitor wref >>+                    return (maybe (return ()) unmonitor rref))++    workerPid <- receiveChan rp+    liftIO $ atomically $ putTMVar sigStart ()++    return AsyncSTM {+          _asyncWorker  = workerPid+        , _asyncMonitor = insulator+        , _asyncWait    = (readTMVar result)+        }++  where+    pollUntilExit :: (Serializable a)+                  => ProcessId+                  -> TMVar (AsyncResult a)+                  -> Process ()+    pollUntilExit wpid result' = do+      r <- receiveWait [+          match (\c@(CancelWait) -> kill wpid "cancel" >> return (Left c))+        , match (\(ProcessMonitorNotification _ pid' r) ->+                  return (Right (pid', r)))+        ]+      case r of+          Left CancelWait+            -> liftIO $ atomically $ putTMVar result' AsyncCancelled+          Right (fpid, d)+            | fpid == wpid+              -> case d of+                     DiedNormal -> return ()+                     _          -> liftIO $ atomically $ putTMVar result' (AsyncFailed d)+            | otherwise -> kill wpid "linkFailed"++-- | Check whether an 'AsyncSTM' has completed yet.+--+-- See "Control.Distributed.Process.Platform.Async".+poll :: (Serializable a) => AsyncSTM a -> Process (AsyncResult a)+poll hAsync = do+  r <- liftIO $ atomically $ pollSTM hAsync+  return $ fromMaybe (AsyncPending) r++-- | Like 'poll' but returns 'Nothing' if @(poll hAsync) == AsyncPending@.+--+-- See "Control.Distributed.Process.Platform.Async".+check :: (Serializable a) => AsyncSTM a -> Process (Maybe (AsyncResult a))+check hAsync = poll hAsync >>= \r -> case r of+  AsyncPending -> return Nothing+  ar           -> return (Just ar)++-- | Wait for an asynchronous operation to complete or timeout.+--+-- See "Control.Distributed.Process.Platform.Async".+waitCheckTimeout :: (Serializable a) =>+                    TimeInterval -> AsyncSTM a -> Process (AsyncResult a)+waitCheckTimeout t hAsync =+  waitTimeout t hAsync >>= return . fromMaybe (AsyncPending)++-- | Wait for an asynchronous action to complete, and return its+-- value. The result (which can include failure and/or cancellation) is+-- encoded by the 'AsyncResult' type.+--+-- @wait = liftIO . atomically . waitSTM@+--+-- See "Control.Distributed.Process.Platform.Async".+{-# INLINE wait #-}+wait :: AsyncSTM a -> Process (AsyncResult a)+wait = liftIO . atomically . waitSTM++-- | Wait for an asynchronous operation to complete or timeout.+--+-- See "Control.Distributed.Process.Platform.Async".+waitTimeout :: (Serializable a) =>+               TimeInterval -> AsyncSTM a -> Process (Maybe (AsyncResult a))+waitTimeout t hAsync = do+  -- This is not the most efficient thing to do, but it's the most erlang-ish.+  (sp, rp) <- newChan :: (Serializable a) => Process (Channel (AsyncResult a))+  pid <- spawnLocal $ wait hAsync >>= sendChan sp+  receiveChanTimeout (asTimeout t) rp `finally` kill pid "timeout"++-- | As 'waitTimeout' but uses STM directly, which might be more efficient.+waitTimeoutSTM :: (Serializable a)+                 => TimeInterval+                 -> AsyncSTM a+                 -> Process (Maybe (AsyncResult a))+waitTimeoutSTM t hAsync =+  let t' = (asTimeout t)+  in liftIO $ timeout t' $ atomically $ waitSTM hAsync++-- | Wait for any of the supplied @AsyncSTM@s to complete. If multiple+-- 'Async's complete, then the value returned corresponds to the first+-- completed 'Async' in the list.+--+-- NB: Unlike @AsyncChan@, 'AsyncSTM' does not discard its 'AsyncResult' once+-- read, therefore the semantics of this function are different to the+-- former. Specifically, if @asyncs = [a1, a2, a3]@ and @(AsyncDone _) = a1@+-- then the remaining @a2, a3@ will never be returned by 'waitAny'.+--+waitAny :: (Serializable a)+        => [AsyncSTM a]+        -> Process (AsyncSTM a, AsyncResult a)+waitAny asyncs = do+  r <- liftIO $ waitAnySTM asyncs+  return r++-- | Like 'waitAny', but also cancels the other asynchronous+-- operations as soon as one has completed.+--+waitAnyCancel :: (Serializable a)+              => [AsyncSTM a] -> Process (AsyncSTM a, AsyncResult a)+waitAnyCancel asyncs =+  waitAny asyncs `finally` mapM_ cancel asyncs++-- | Wait for the first of two @AsyncSTM@s to finish.+--+waitEither :: AsyncSTM a+              -> AsyncSTM b+              -> Process (Either (AsyncResult a) (AsyncResult b))+waitEither left right =+  liftIO $ atomically $+    (Left  <$> waitSTM left)+      `orElse`+    (Right <$> waitSTM right)++-- | Like 'waitEither', but the result is ignored.+--+waitEither_ :: AsyncSTM a -> AsyncSTM b -> Process ()+waitEither_ left right =+  liftIO $ atomically $+    (void $ waitSTM left)+      `orElse`+    (void $ waitSTM right)++-- | Waits for both @AsyncSTM@s to finish.+--+waitBoth :: AsyncSTM a+            -> AsyncSTM b+            -> Process ((AsyncResult a), (AsyncResult b))+waitBoth left right =+  liftIO $ atomically $ do+    a <- waitSTM left+           `orElse`+         (waitSTM right >> retry)+    b <- waitSTM right+    return (a,b)++-- | Like 'waitAny' but times out after the specified delay.+waitAnyTimeout :: (Serializable a)+               => TimeInterval+               -> [AsyncSTM a]+               -> Process (Maybe (AsyncResult a))+waitAnyTimeout delay asyncs =+  let t' = asTimeout delay+  in liftIO $ timeout t' $ do+    r <- waitAnySTM asyncs+    return $ snd r++-- | Cancel an asynchronous operation.+--+-- See "Control.Distributed.Process.Platform.Async".+cancel :: AsyncSTM a -> Process ()+cancel (AsyncSTM _ g _) = send g CancelWait++-- | Cancel an asynchronous operation and wait for the cancellation to complete.+--+-- See "Control.Distributed.Process.Platform.Async".+cancelWait :: (Serializable a) => AsyncSTM a -> Process (AsyncResult a)+cancelWait hAsync = cancel hAsync >> wait hAsync++-- | Cancel an asynchronous operation immediately.+--+-- See "Control.Distributed.Process.Platform.Async".+cancelWith :: (Serializable b) => b -> AsyncSTM a -> Process ()+cancelWith reason = (flip exit) reason . _asyncWorker++-- | Like 'cancelWith' but sends a @kill@ instruction instead of an exit.+--+-- See 'Control.Distributed.Process.Platform.Async'.+cancelKill :: String -> AsyncSTM a -> Process ()+cancelKill reason = (flip kill) reason . _asyncWorker++--------------------------------------------------------------------------------+-- STM Specific API                                                           --+--------------------------------------------------------------------------------++-- | STM version of 'waitAny'.+waitAnySTM :: [AsyncSTM a] -> IO (AsyncSTM a, AsyncResult a)+waitAnySTM asyncs =+  atomically $+    foldr orElse retry $+      map (\a -> do r <- waitSTM a; return (a, r)) asyncs++-- | A version of 'wait' that can be used inside an STM transaction.+--+waitSTM :: AsyncSTM a -> STM (AsyncResult a)+waitSTM (AsyncSTM _ _ w) = w++-- | A version of 'poll' that can be used inside an STM transaction.+--+{-# INLINE pollSTM #-}+pollSTM :: AsyncSTM a -> STM (Maybe (AsyncResult a))+pollSTM (AsyncSTM _ _ w) = (Just <$> w) `orElse` return Nothing+
+ src/Control/Distributed/Process/Platform/Async/Types.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveGeneric             #-}++-- | shared, internal types for the Async package+module Control.Distributed.Process.Platform.Async.Types+ ( -- * Exported types+    Async(..)+  , AsyncRef+  , AsyncTask(..)+  , AsyncResult(..)+  ) where++import Control.Distributed.Process+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Serializable+  ( Serializable+  , SerializableDict+  )+import Data.Binary+import Data.Typeable (Typeable)++import GHC.Generics++-- | An opaque handle that refers to an asynchronous operation.+data Async a = Async {+    hPoll        :: Process (AsyncResult a)+  , hWait        :: Process (AsyncResult a)+  , hWaitTimeout :: TimeInterval -> Process (Maybe (AsyncResult a))+  , hCancel      :: Process ()+  , asyncWorker  :: ProcessId+  }++-- | A reference to an asynchronous action+type AsyncRef = ProcessId++-- | A task to be performed asynchronously.+data AsyncTask a =+    AsyncTask {+        asyncTask :: Process a -- ^ the task to be performed+      }+  | AsyncRemoteTask {+        asyncTaskDict :: Static (SerializableDict a)+          -- ^ the serializable dict required to spawn a remote process+      , asyncTaskNode :: NodeId+          -- ^ the node on which to spawn the asynchronous task+      , asyncTaskProc :: Closure (Process a)+          -- ^ the task to be performed, wrapped in a closure environment+      }++-- | Represents the result of an asynchronous action, which can be in one of+-- several states at any given time.+data AsyncResult a =+    AsyncDone a                 -- ^ a completed action and its result+  | AsyncFailed DiedReason      -- ^ a failed action and the failure reason+  | AsyncLinkFailed DiedReason  -- ^ a link failure and the reason+  | AsyncCancelled              -- ^ a cancelled action+  | AsyncPending                -- ^ a pending action (that is still running)+    deriving (Typeable, Generic)++instance Serializable a => Binary (AsyncResult a) where++deriving instance Eq a => Eq (AsyncResult a)+deriving instance Show a => Show (AsyncResult a)+
+ src/Control/Distributed/Process/Platform/Call.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Call+-- Copyright   :  (c) Parallel Scientific (Jeff Epstein) 2012+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainers :  Jeff Epstein, Tim Watson+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- This module provides a facility for Remote Procedure Call (rpc) style+-- interactions with Cloud Haskell processes.+--+-- Clients make synchronous calls to a running process (i.e., server) using the+-- 'callAt', 'callTimeout' and 'multicall' functions. Processes acting as the+-- server are constructed using Cloud Haskell's 'receive' family of primitives+-- and the 'callResponse' family of functions in this module.+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Call+  ( -- client API+    callAt+  , callTimeout+  , multicall+    -- server API+  , callResponse+  , callResponseIf+  , callResponseDefer+  , callResponseDeferIf+  , callForward+  , callResponseAsync+  ) where++import Control.Distributed.Process+import Control.Distributed.Process.Serializable (Serializable)+import Control.Monad (forM, forM_, join)+import Data.List (delete)+import qualified Data.Map as M+import Data.Maybe (listToMaybe)+import Data.Binary (Binary,get,put)+import Data.Typeable (Typeable)++import Control.Distributed.Process.Platform hiding (monitor, send)+import Control.Distributed.Process.Platform.Time++----------------------------------------------+-- * Multicall+----------------------------------------------++-- | Sends a message of type a to the given process, to be handled by a+-- corresponding callResponse... function, which will send back a message of+-- type b. The tag is per-process unique identifier of the transaction. If the+-- timeout expires or the target process dies, Nothing will be returned.+callTimeout :: (Serializable a, Serializable b)+            => ProcessId -> a -> Tag -> Timeout -> Process (Maybe b)+callTimeout pid msg tag time =+  do res <- multicall [pid] msg tag time+     return $ join (listToMaybe res)++-- | Like 'callTimeout', but with no timeout.+-- Returns Nothing if the target process dies.+callAt :: (Serializable a, Serializable b)+       => ProcessId -> a -> Tag -> Process (Maybe b)+callAt pid msg tag = callTimeout pid msg tag infiniteWait++-- | Like 'callTimeout', but sends the message to multiple+-- recipients and collects the results.+multicall :: forall a b.(Serializable a, Serializable b)+             => [ProcessId] -> a -> Tag -> Timeout -> Process [Maybe b]+multicall nodes msg tag time =+  do caller <- getSelfPid+     receiver <- spawnLocal $+         do receiver_pid <- getSelfPid+            mon_caller <- monitor caller+            () <- expect+            monitortags <- forM nodes monitor+            forM_ nodes $ \node -> send node (Multicall, node,+                                              receiver_pid, tag, msg)+            maybeTimeout time tag receiver_pid+            results <- recv nodes monitortags mon_caller+            send caller (MulticallResponse,tag,results)+     mon_receiver <- monitor receiver+     send receiver ()+     receiveWait [+         matchIf (\(MulticallResponse,mtag,_) -> mtag == tag)+                 (\(MulticallResponse,_,val) -> return val),+         matchIf (\(ProcessMonitorNotification ref _pid reason)+                  -> ref == mon_receiver && reason /= DiedNormal)+                 (\_ -> error "multicall: unexpected termination of worker")+       ]+  where+    recv nodes' monitortags mon_caller = do+      resultmap <- recv1 mon_caller+                         (nodes', monitortags, M.empty) :: Process (M.Map ProcessId b)+      return $ ordered nodes' resultmap++    ordered []     _ = []+    ordered (x:xs) m = M.lookup x m : ordered xs m++    recv1 _   ([],_,results) = return results+    recv1 _   (_,[],results) = return results+    recv1 ref (nodesleft,monitortagsleft,results) =+          receiveWait [+              matchIf (\(ProcessMonitorNotification ref' _ _)+                         -> ref' == ref)+                      (\_ -> return Nothing)+            , matchIf (\(ProcessMonitorNotification ref' pid reason) ->+                      ref' `elem` monitortagsleft &&+                      pid `elem` nodesleft+                      && reason /= DiedNormal)+                      (\(ProcessMonitorNotification ref' pid _reason) ->+                        return $ Just (delete pid nodesleft,+                                       delete ref' monitortagsleft, results))+            , matchIf (\(MulticallResponse, mtag, _, _) -> mtag == tag)+                      (\(MulticallResponse, _, responder, msgx) ->+                        return $ Just (delete responder nodesleft,+                                       monitortagsleft,+                                       M.insert responder (msgx :: b) results))+            , matchIf (\(TimeoutNotification mtag) -> mtag == tag )+                      (\_ -> return Nothing)+          ]+          >>= maybe (return results) (recv1 ref)++data MulticallResponseType a =+         MulticallAccept+       | MulticallForward ProcessId a+       | MulticallReject deriving Eq++callResponseImpl :: (Serializable a,Serializable b)+                 => (a -> MulticallResponseType c) ->+                    (a -> (b -> Process())-> Process c) -> Match c+callResponseImpl cond proc =+  matchIf (\(Multicall,_responder,_,_,msg) ->+            case cond msg of+              MulticallReject -> False+              _               -> True)+          (\wholemsg@(Multicall,responder,sender,tag,msg) ->+            case cond msg of+              -- TODO: sender should get a ProcessMonitorNotification if+              -- our target dies, or we should link to it (?)+              MulticallForward target ret -> send target wholemsg >> return ret+              -- TODO: use `die Reason` when issue #110 is resolved+              MulticallReject -> error "multicallResponseImpl: Indecisive condition"+              MulticallAccept ->+                let resultSender tosend =+                      send sender (MulticallResponse,+                                   tag::Tag,+                                   responder::ProcessId,+                                   tosend)+                in proc msg resultSender)++-- | Produces a Match that can be used with the 'receiveWait' family of+-- message-receiving functions. @callResponse@ will respond to a message of+-- type a sent by 'callTimeout', and will respond with a value of type b.+callResponse :: (Serializable a,Serializable b)+                => (a -> Process (b,c)) -> Match c+callResponse = callResponseIf (const True)++callResponseDeferIf  :: (Serializable a,Serializable b)+                     => (a -> Bool)+                     -> (a -> (b -> Process()) -> Process c)+                     -> Match c+callResponseDeferIf cond =+  callResponseImpl (\msg ->+                     if cond msg+                     then MulticallAccept+                     else MulticallReject)++callResponseDefer  :: (Serializable a,Serializable b)+                   => (a -> (b -> Process())-> Process c) -> Match c+callResponseDefer = callResponseDeferIf (const True)++-- | Produces a Match that can be used with the 'receiveWait' family of+-- message-receiving functions. When calllForward receives a message of type+-- from from 'callTimeout' (and similar), it will forward the message to another+-- process, who will be responsible for responding to it. It is the user's+-- responsibility to ensure that the forwarding process is linked to the+-- destination process, so that if it fails, the sender will be notified.+callForward :: Serializable a => (a -> (ProcessId, c)) -> Match c+callForward proc =+   callResponseImpl+     (\msg -> let (pid, ret) = proc msg+              in MulticallForward pid ret )+     (\_ sender ->+       (sender::(() -> Process ())) `mention`+          error "multicallForward: Indecisive condition")++-- | The message handling code is started in a separate thread. It's not+-- automatically linked to the calling thread, so if you want it to be+-- terminated when the message handling thread dies, you'll need to call+-- link yourself.+callResponseAsync :: (Serializable a,Serializable b)+                  => (a -> Maybe c) -> (a -> Process b) -> Match c+callResponseAsync cond proc =+   callResponseImpl+         (\msg ->+            case cond msg of+              Nothing -> MulticallReject+              Just _ -> MulticallAccept)+         (\msg sender ->+            do _ <- spawnLocal $ -- TODO linkOnFailure to spawned procss+                 do val <- proc msg+                    sender val+               case cond msg of+                 Nothing -> error "multicallResponseAsync: Indecisive condition"+                 Just ret -> return ret )++callResponseIf :: (Serializable a,Serializable b)+               => (a -> Bool) -> (a -> Process (b,c)) -> Match c+callResponseIf cond proc =+    callResponseImpl+             (\msg ->+                 case cond msg of+                   True -> MulticallAccept+                   False -> MulticallReject)+             (\msg sender ->+                 do (tosend,toreturn) <- proc msg+                    sender tosend+                    return toreturn)++maybeTimeout :: Timeout -> Tag -> ProcessId -> Process ()+maybeTimeout Nothing _ _ = return ()+maybeTimeout (Just time) tag p = timeout time tag p++----------------------------------------------+-- * Private types+----------------------------------------------++mention :: a -> b -> b+mention _a b = b++data Multicall = Multicall+       deriving (Typeable)+instance Binary Multicall where+       get = return Multicall+       put _ = return ()+data MulticallResponse = MulticallResponse+       deriving (Typeable)+instance Binary MulticallResponse where+       get = return MulticallResponse+       put _ = return ()
+ src/Control/Distributed/Process/Platform/Execution.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Execution+-- Copyright   :  (c) Tim Watson 2013 - 2014+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- [Inter-Process Traffic Management]+--+-- The /Execution Framework/ provides tools for load regulation, workload+-- shedding and remote hand-off. The currently implementation provides only+-- a subset of the plumbing required, comprising tools for event management,+-- mailbox buffering and message routing.+--+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Execution+  ( -- * Mailbox Buffering+    module Control.Distributed.Process.Platform.Execution.Mailbox+    -- * Message Exchanges+  , module Control.Distributed.Process.Platform.Execution.Exchange+  ) where++import Control.Distributed.Process.Platform.Execution.Exchange hiding (startSupervised)+import Control.Distributed.Process.Platform.Execution.Mailbox hiding (startSupervised, post)++{-++Load regulation requires that we apply limits to various parts of the system.+The manner in which they're applied may vary, but the mechanisms are limited+to:++1. rejecting the activity/request+2. accepting the activity immediately+3. blocking some or all requestors+4. blocking some (or all) activities+5. terminiating some (or all) activities++-}++
+ src/Control/Distributed/Process/Platform/Execution/EventManager.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE ImpredicativeTypes        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Execution.EventManager+-- 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)+--+-- [Overview]+--+-- The /EventManager/ is a parallel/concurrent event handling tool, built on+-- top of the /Exchange API/. Arbitrary events are published to the event+-- manager using 'notify', and are broadcast simulataneously to a set of+-- registered /event handlers/.+--+-- [Defining and Registering Event Handlers]+--+-- Event handlers are defined as @Serializable m => s -> m -> Process s@,+-- i.e., an expression taking an initial state, an arbitrary @Serializable@+-- event/message and performing an action in the @Process@ monad that evaluates+-- to a new state.+--+-- See "Control.Distributed.Process.Platform.Execution.Exchange".+--+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Execution.EventManager+  ( EventManager+  , start+  , startSupervised+  , startSupervisedRef+  , notify+  , addHandler+  , addMessageHandler+  ) where++import Control.Distributed.Process hiding (Message, link)+import qualified Control.Distributed.Process as P (Message)+import Control.Distributed.Process.Platform.Execution.Exchange+  ( Exchange+  , Message(..)+  , post+  , broadcastExchange+  , broadcastExchangeT+  , broadcastClient+  )+import qualified Control.Distributed.Process.Platform.Execution.Exchange as Exchange+  ( startSupervised+  )+import Control.Distributed.Process.Platform.Internal.Primitives+import Control.Distributed.Process.Platform.Internal.Unsafe+  ( InputStream+  , matchInputStream+  )+import Control.Distributed.Process.Platform.Supervisor (SupervisorPid)+import Control.Distributed.Process.Serializable hiding (SerializableDict)+import Data.Binary+import Data.Typeable (Typeable)+import GHC.Generics++{- notes++Event manager is implemented over a simple BroadcastExchange. We eschew the+complexities of identifying handlers and allowing them to be removed/deleted+or monitored, since we avoid running them in the exchange process. Instead,+each handler runs as an independent process, leaving handler management up+to the user and allowing all the usual process managemnet techniques (e.g.,+registration, supervision, etc) to be utilised instead.++-}++-- | Opaque handle to an Event Manager.+--+newtype EventManager = EventManager { ex :: Exchange }+  deriving (Typeable, Generic)+instance Binary EventManager where++instance Resolvable EventManager where+  resolve = resolve . ex++-- | Start a new /Event Manager/ process and return an opaque handle+-- to it.+start :: Process EventManager+start = broadcastExchange >>= return . EventManager++startSupervised :: SupervisorPid -> Process EventManager+startSupervised sPid = do+  ex <- broadcastExchangeT >>= \t -> Exchange.startSupervised t sPid+  return $ EventManager ex++startSupervisedRef :: SupervisorPid -> Process (ProcessId, P.Message)+startSupervisedRef sPid = do+  ex <- startSupervised sPid+  Just pid <- resolve ex+  return (pid, unsafeWrapMessage ex)++-- | Broadcast an event to all registered handlers.+notify :: Serializable a => EventManager -> a -> Process ()+notify em msg = post (ex em) msg++-- | Add a new event handler. The handler runs in its own process,+-- which is spawned locally on behalf of the caller.+addHandler :: forall s a. Serializable a+           => EventManager+           -> (s -> a -> Process s)+           -> Process s+           -> Process ProcessId+addHandler m h s =+  spawnLocal $ newHandler (ex m) (\s' m' -> handleMessage m' (h s')) s++-- | As 'addHandler', but operates over a raw @Control.Distributed.Process.Message@.+addMessageHandler :: forall s.+                     EventManager+                  -> (s -> P.Message -> Process (Maybe s))+                  -> Process s+                  -> Process ProcessId+addMessageHandler m h s = spawnLocal $ newHandler (ex m) h s++newHandler :: forall s .+              Exchange+           -> (s -> P.Message -> Process (Maybe s))+           -> Process s+           -> Process ()+newHandler ex handler initState = do+  linkTo ex+  is <- broadcastClient ex+  listen is handler =<< initState++listen :: forall s . InputStream Message+       -> (s -> P.Message -> Process (Maybe s))+       -> s+       -> Process ()+listen inStream handler state = do+  receiveWait [ matchInputStream inStream ] >>= handleEvent inStream handler state+  where+    handleEvent is h s p = do+      r <- h s (payload p)+      let s2 = case r of+                 Nothing -> s+                 Just s' -> s'+      listen is h s2+
+ src/Control/Distributed/Process/Platform/Execution/Exchange.hs view
@@ -0,0 +1,149 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Execution.Exchange+-- Copyright   :  (c) Tim Watson 2012 - 2014+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- [Message Exchanges]+--+-- The concept of a /message exchange/ is borrowed from the world of+-- messaging and enterprise integration. The /exchange/ acts like a kind of+-- mailbox, accepting inputs from /producers/ and forwarding these messages+-- to one or more /consumers/, depending on the implementation's semantics.+--+-- This module provides some basic types of message exchange and exposes an API+-- for defining your own custom /exchange types/.+--+-- [Broadcast Exchanges]+--+-- The broadcast exchange type, started via 'broadcastExchange', forward their+-- inputs to all registered consumers (as the name suggests). This exchange type+-- is highly optimised for local (intra-node) traffic and provides two different+-- kinds of client binding, one which causes messages to be delivered directly+-- to the client's mailbox (viz 'bindToBroadcaster'), the other providing a+-- separate stream of messages that can be obtained using the @expect@ and+-- @receiveX@ family of messaging primitives (and thus composed with other forms+-- of input selection, such as typed channels and selective reads on the process+-- mailbox).+--+-- /Important:/ When a @ProcessId@ is registered via 'bindToBroadcaster', only+-- the payload of the 'Message' (i.e., the underlying @Serializable@ datum) is+-- forwarded to the consumer, /not/ the whole 'Message' itself.+--+-- [Router Exchanges]+--+-- The /router/ API provides a means to selectively route messages to one or+-- more clients, depending on the content of the 'Message'. Two modes of binding+-- (and client selection) are provided out of the box, one of which matches the+-- message 'key', the second of which matches on a name and value from the+-- 'headers'. Alternative mechanisms for content based routing can be derived+-- by modifying the 'BindingSelector' expression passed to 'router'+--+-- See 'messageKeyRouter' and 'headerContentRouter' for the built-in routing+-- exchanges, and 'router' for the extensible routing API.+--+-- [Custom Exchange Types]+--+-- Both the /broadcast/ and /router/ exchanges are implemented as custom+-- /exchange types/. The mechanism for defining custom exchange behaviours+-- such as these is very simple. Raw exchanges are started by evaluating+-- 'startExchange' with a specific 'ExchangeType' record. This type is+-- parameterised by the internal /state/ it holds, and defines two API callbacks+-- in its 'configureEx' and 'routeEx' fields. The former is evaluated whenever a+-- client process evaluates 'configureExchange', the latter whenever a client+-- evaluates 'post' or 'postMessage'. The 'configureEx' callback takes a raw+-- @Message@ (from "Control.Distributed.Process") and is responsible for+-- decoding the message and updating its own state (if required). It is via+-- this callback that custom exchange types can receive information about+-- clients and handle it in their own way. The 'routeEx' callback is evaluated+-- with the exchange type's own internal state and the 'Message' originally+-- sent to the exchange process (via 'post') and is responsible for delivering+-- the message to its clients in whatever way makes sense for that exchange+-- type.+--+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Execution.Exchange+  ( -- * Fundamental API+    Exchange()+  , Message(..)+    -- * Starting/Running an Exchange+  , startExchange+  , startSupervised+  , startSupervisedRef+  , runExchange+    -- * Client Facing API+  , post+  , postMessage+  , configureExchange+  , createMessage+    -- * Broadcast Exchange+  , broadcastExchange+  , broadcastExchangeT+  , broadcastClient+  , bindToBroadcaster+  , BroadcastExchange+    -- * Routing (Content Based)+  , HeaderName+  , Binding(..)+  , Bindable+  , BindingSelector+  , RelayType(..)+    -- * Starting a Router+  , router+  , supervisedRouter+    -- * Routing (Publishing) API+  , route+  , routeMessage+    -- * Routing via message/binding keys+  , messageKeyRouter+  , bindKey+    -- * Routing via message headers+  , headerContentRouter+  , bindHeader+    -- * Defining Custom Exchange Types+  , ExchangeType(..)+  , applyHandlers+  ) where++import Control.Distributed.Process.Platform.Execution.Exchange.Broadcast+  ( broadcastExchange+  , broadcastExchangeT+  , broadcastClient+  , bindToBroadcaster+  , BroadcastExchange+  )+import Control.Distributed.Process.Platform.Execution.Exchange.Internal+  ( Exchange()+  , Message(..)+  , ExchangeType(..)+  , startExchange+  , startSupervised+  , startSupervisedRef+  , runExchange+  , post+  , postMessage+  , configureExchange+  , createMessage+  , applyHandlers+  )+import Control.Distributed.Process.Platform.Execution.Exchange.Router+  ( HeaderName+  , Binding(..)+  , Bindable+  , BindingSelector+  , RelayType(..)+  , router+  , supervisedRouter+  , route+  , routeMessage+  , messageKeyRouter+  , bindKey+  , headerContentRouter+  , bindHeader+  )+
+ src/Control/Distributed/Process/Platform/Execution/Exchange/Broadcast.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE EmptyDataDecls        #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE ImpredicativeTypes    #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | An exchange type that broadcasts all incomings 'Post' messages.+module Control.Distributed.Process.Platform.Execution.Exchange.Broadcast+  (+    broadcastExchange+  , broadcastExchangeT+  , broadcastClient+  , bindToBroadcaster+  , BroadcastExchange+  ) where++import Control.Concurrent.STM (STM, atomically)+import Control.Concurrent.STM.TChan+  ( TChan+  , newBroadcastTChanIO+  , dupTChan+  , readTChan+  , writeTChan+  )+import Control.DeepSeq (NFData)+import Control.Distributed.Process+  ( Process+  , MonitorRef+  , ProcessMonitorNotification(..)+  , ProcessId+  , SendPort+  , processNodeId+  , getSelfPid+  , getSelfNode+  , liftIO+  , newChan+  , sendChan+  , unsafeSend+  , unsafeSendChan+  , receiveWait+  , match+  , matchIf+  , die+  , handleMessage+  , Match+  )+import qualified Control.Distributed.Process as P+import Control.Distributed.Process.Serializable()+import Control.Distributed.Process.Platform.Execution.Exchange.Internal+  ( startExchange+  , configureExchange+  , Message(..)+  , Exchange(..)+  , ExchangeType(..)+  , applyHandlers+  )+import Control.Distributed.Process.Platform.Internal.Types+  ( Channel+  , ServerDisconnected(..)+  )+import Control.Distributed.Process.Platform.Internal.Unsafe -- see [note: pcopy]+  ( PCopy+  , pCopy+  , pUnwrap+  , matchChanP+  , InputStream(Null)+  , newInputStream+  )+import Control.Distributed.Process.Platform.Supervisor (SupervisorPid)+import Control.Monad (forM_, void)+import Data.Accessor+  ( Accessor+  , accessor+  , (^:)+  )+import Data.Binary+import qualified Data.Foldable as Foldable (toList)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Typeable (Typeable)+import GHC.Generics++-- newtype RoutingTable r =+--  RoutingTable { routes :: (Map String (Map ProcessId r)) }++-- [note: BindSTM, BindPort and safety]+-- We keep these two /bind types/ separate, since only one of them+-- is truly serializable. The risk of unifying them is that at some+-- later time a maintainer might not realise that BindSTM cannot be+-- sent over the wire due to our use of PCopy.+--++data BindPort = BindPort { portClient :: !ProcessId+                         , portSend   :: !(SendPort Message)+                         } deriving (Typeable, Generic)+instance Binary BindPort where+instance NFData BindPort where++data BindSTM =+    BindSTM  { stmClient :: !ProcessId+             , stmSend   :: !(SendPort (PCopy (InputStream Message)))+             } deriving (Typeable)+{-  | forall r. (Routable r) =>+    BindR    { client :: !ProcessId+             , key    :: !String+             , chanC  :: !r+             }+  deriving (Typeable, Generic)+-}++data OutputStream =+    WriteChan (SendPort Message)+  | WriteSTM  (Message -> STM ())+--  | WriteP    ProcessId+  | NoWrite+  deriving (Typeable)++data Binding = Binding { outputStream :: !OutputStream+                       , inputStream  :: !(InputStream Message)+                       }+             | PidBinding !ProcessId+  deriving (Typeable)++data BindOk = BindOk+  deriving (Typeable, Generic)+instance Binary BindOk where+instance NFData BindOk where++data BindFail = BindFail !String+  deriving (Typeable, Generic)+instance Binary BindFail where+instance NFData BindFail where++data BindPlease = BindPlease+  deriving (Typeable, Generic)+instance Binary BindPlease where+instance NFData BindPlease where++type BroadcastClients = Map ProcessId Binding+data BroadcastEx =+  BroadcastEx { _routingTable   :: !BroadcastClients+              , channel         :: !(TChan Message)+              }++type BroadcastExchange = ExchangeType BroadcastEx++--------------------------------------------------------------------------------+-- Starting/Running the Exchange                                              --+--------------------------------------------------------------------------------++-- | Start a new /broadcast exchange/ and return a handle to the exchange.+broadcastExchange :: Process Exchange+broadcastExchange = broadcastExchangeT >>= startExchange++-- | The 'ExchangeType' of a broadcast exchange. Can be combined with the+-- @startSupervisedRef@ and @startSupervised@ APIs.+--+broadcastExchangeT :: Process BroadcastExchange+broadcastExchangeT = do+  ch <- liftIO newBroadcastTChanIO+  return $ ExchangeType { name        = "BroadcastExchange"+                        , state       = BroadcastEx Map.empty ch+                        , configureEx = apiConfigure+                        , routeEx     = apiRoute+                        }++--------------------------------------------------------------------------------+-- Client Facing API                                                          --+--------------------------------------------------------------------------------++-- | Create a binding to the given /broadcast exchange/ for the calling process+-- and return an 'InputStream' that can be used in the @expect@ and+-- @receiveWait@ family of messaging primitives. This form of client interaction+-- helps avoid cluttering the caller's mailbox with 'Message' data, since the+-- 'InputChannel' provides a separate input stream (in a similar fashion to+-- a typed channel).+-- Example:+--+-- > is <- broadcastClient ex+-- > msg <- receiveWait [ matchInputStream is ]+-- > handleMessage (payload msg)+--+broadcastClient :: Exchange -> Process (InputStream Message)+broadcastClient ex@Exchange{..} = do+  myNode <- getSelfNode+  us     <- getSelfPid+  if processNodeId pid == myNode -- see [note: pcopy]+     then do (sp, rp) <- newChan+             configureExchange ex $ pCopy (BindSTM us sp)+             mRef <- P.monitor pid+             P.finally (receiveWait [ matchChanP rp+                                    , handleServerFailure mRef ])+                       (P.unmonitor mRef)+     else do (sp, rp) <- newChan :: Process (Channel Message)+             configureExchange ex $ BindPort us sp+             mRef <- P.monitor pid+             P.finally (receiveWait [+                           match (\(_ :: BindOk)   -> return $ newInputStream $ Left rp)+                         , match (\(f :: BindFail) -> die f)+                         , handleServerFailure mRef+                         ])+                       (P.unmonitor mRef)++-- | Bind the calling process to the given /broadcast exchange/. For each+-- 'Message' the exchange receives, /only the payload will be sent/+-- to the calling process' mailbox.+--+-- Example:+--+-- (producer)+-- > post ex "Hello"+--+-- (consumer)+-- > bindToBroadcaster ex+-- > expect >>= liftIO . putStrLn+--+bindToBroadcaster :: Exchange -> Process ()+bindToBroadcaster ex@Exchange{..} = do+  us <- getSelfPid+  configureExchange ex $ (BindPlease, us)++--------------------------------------------------------------------------------+-- Exchage Definition/State & API Handlers                                    --+--------------------------------------------------------------------------------++apiRoute :: BroadcastEx -> Message -> Process BroadcastEx+apiRoute ex@BroadcastEx{..} msg = do+  liftIO $ atomically $ writeTChan channel msg+  forM_ (Foldable.toList _routingTable) $ routeToClient msg+  return ex+  where+    routeToClient m (PidBinding p)  = P.forward (payload m) p+    routeToClient m b@(Binding _ _) = writeToStream (outputStream b) m++-- TODO: implement unbind!!?++apiConfigure :: BroadcastEx -> P.Message -> Process BroadcastEx+apiConfigure ex msg = do+  -- for unsafe / non-serializable message passing hacks, see [note: pcopy]+  applyHandlers ex msg $ [ \m -> handleMessage m (handleBindPort ex)+                         , \m -> handleBindSTM ex m+                         , \m -> handleMessage m (handleBindPlease ex)+                         , \m -> handleMessage m (handleMonitorSignal ex)+                         , (const $ return $ Just ex)+                         ]+  where+    handleBindPlease ex' (BindPlease, p) = do+      case lookupBinding ex' p of+        Nothing -> return $ (routingTable ^: Map.insert p (PidBinding p)) ex'+        Just _  -> return ex'++    handleMonitorSignal bx (ProcessMonitorNotification _ p _) =+      return $ (routingTable ^: Map.delete p) bx++    handleBindSTM ex'@BroadcastEx{..} msg' = do+      bind' <- pUnwrap msg' :: Process (Maybe BindSTM) -- see [note: pcopy]+      case bind' of+        Nothing -> return Nothing+        Just s  -> do+          let binding = lookupBinding ex' (stmClient s)+          case binding of+            Nothing -> createBinding ex' s >>= \ex'' -> handleBindSTM ex'' msg'+            Just b  -> sendBinding (stmSend s) b >> return (Just ex')++    createBinding bEx'@BroadcastEx{..} BindSTM{..} = do+      void $ P.monitor stmClient+      nch <- liftIO $ atomically $ dupTChan channel+      let istr = newInputStream $ Right (readTChan nch)+      let ostr = NoWrite -- we write to our own channel, not the broadcast+      let bnd = Binding ostr istr+      return $ (routingTable ^: Map.insert stmClient bnd) bEx'++    sendBinding sp' bs = unsafeSendChan sp' $ pCopy (inputStream bs)++    handleBindPort :: BroadcastEx -> BindPort -> Process BroadcastEx+    handleBindPort x@BroadcastEx{..} BindPort{..} = do+      let binding = lookupBinding x portClient+      case binding of+        Just _  -> unsafeSend portClient (BindFail "DuplicateBinding") >> return x+        Nothing -> do+          let istr = Null+          let ostr = WriteChan portSend+          let bound = Binding ostr istr+          void $ P.monitor portClient+          unsafeSend portClient BindOk+          return $ (routingTable ^: Map.insert portClient bound) x++    lookupBinding BroadcastEx{..} k = Map.lookup k $ _routingTable++{- [note: pcopy]++We rely on risky techniques here, in order to allow for sharing useful+data that is not really serializable. For Cloud Haskell generally, this is+a bad idea, since we want message passing to work both locally and in a+distributed setting. In this case however, what we're really attempting is+an optimisation, since we only use unsafe PCopy based techniques when dealing+with exchange clients residing on our (local) node.++The PCopy mechanism is defined in the (aptly named) "Unsafe" module.++-}++-- TODO: move handleServerFailure into Primitives.hs++writeToStream :: OutputStream -> Message -> Process ()+writeToStream (WriteChan sp) = sendChan sp  -- see [note: safe remote send]+writeToStream (WriteSTM stm) = liftIO . atomically . stm+writeToStream NoWrite        = const $ return ()+{-# INLINE writeToStream #-}++{- [note: safe remote send]++Although we go to great lengths here to avoid serialization and/or copying+overheads, there are some activities for which we prefer to play it safe.+Chief among these is delivering messages to remote clients. Thankfully, our+unsafe @sendChan@ primitive will crash the caller/sender if there are any+encoding problems, however it is only because we /know/ for certain that+our recipient is remote, that we've chosen to write via a SendPort in the+first place! It makes sense therefore, to use the safe @sendChan@ operation+here, since for a remote call we /cannot/ avoid the overhead of serialization+anyway.++-}++handleServerFailure :: MonitorRef -> Match (InputStream Message)+handleServerFailure mRef =+  matchIf (\(ProcessMonitorNotification r _ _) -> r == mRef)+          (\(ProcessMonitorNotification _ _ d) -> die $ ServerDisconnected d)++routingTable :: Accessor BroadcastEx BroadcastClients+routingTable = accessor _routingTable (\r e -> e { _routingTable = r })+
+ src/Control/Distributed/Process/Platform/Execution/Exchange/Internal.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE EmptyDataDecls        #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE ImpredicativeTypes    #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | Internal Exchange Implementation+module Control.Distributed.Process.Platform.Execution.Exchange.Internal+  ( Exchange(..)+  , Message(..)+  , ExchangeType(..)+  , startExchange+  , startSupervised+  , startSupervisedRef+  , runExchange+  , post+  , postMessage+  , configureExchange+  , createMessage+  , applyHandlers+  ) where++import Control.Concurrent.MVar (MVar, takeMVar, putMVar, newEmptyMVar)+import Control.DeepSeq (NFData)+import Control.Distributed.Process+  ( Process+  , ProcessMonitorNotification(..)+  , ProcessId+  , liftIO+  , spawnLocal+  , unsafeWrapMessage+  )+import qualified Control.Distributed.Process as P (Message, link)+import Control.Distributed.Process.Serializable hiding (SerializableDict)+import Control.Distributed.Process.Platform.Internal.Types+  ( Resolvable(..)+  )+import Control.Distributed.Process.Platform.Internal.Primitives+  ( Linkable(..)+  )+import Control.Distributed.Process.Platform.ManagedProcess+  ( channelControlPort+  , handleControlChan+  , handleInfo+  , handleRaw+  , continue+  , defaultProcess+  , InitHandler+  , InitResult(..)+  , ProcessAction+  , ProcessDefinition(..)+  , ControlChannel+  , ControlPort+  )+import qualified Control.Distributed.Process.Platform.ManagedProcess as MP+  ( chanServe+  )+import Control.Distributed.Process.Platform.ManagedProcess.UnsafeClient+  ( sendControlMessage+  )+import Control.Distributed.Process.Platform.Supervisor (SupervisorPid)+import Control.Distributed.Process.Platform.Time (Delay(Infinity))+import Data.Binary+import Data.Typeable (Typeable)+import GHC.Generics+import Prelude hiding (drop)++{- [design notes]++Messages are sent to exchanges and forwarded to clients. An exchange+is parameterised by its routing mechanism, which is responsible for+maintaining its own client state and selecting the clients to which+messages are forwarded.++-}++-- | Opaque handle to an exchange.+--+data Exchange = Exchange { pid   :: !ProcessId+                         , cchan :: !(ControlPort ControlMessage)+                         , xType :: !String+                         } deriving (Typeable, Generic, Eq)+instance Binary Exchange where+instance Show Exchange where+  show Exchange{..} = (xType ++ ":" ++ (show pid))++instance Resolvable Exchange where+  resolve = return . Just . pid++{-+instance Observable Exchange MonitorRef ProcessMonitorNotification where+  observe   = P.monitor . pid+  unobserve = P.unmonitor+  observableFrom ref (ProcessMonitorNotification ref' _ r) =+    return $ if ref' == ref then Just r else Nothing+-}++instance Linkable Exchange where+  linkTo = P.link . pid++-- we communicate with exchanges using control channels+sendCtrlMsg :: Exchange -> ControlMessage -> Process ()+sendCtrlMsg Exchange{..} = sendControlMessage cchan++-- | Messages sent to an exchange can optionally provide a routing+-- key and a list of (key, value) headers in addition to the underlying+-- payload.+data Message =+  Message { key     :: !String  -- ^ a /routing key/ for the payload+          , headers :: ![(String, String)] -- ^ arbitrary key-value headers+          , payload :: !P.Message  -- ^ the underlying @Message@ payload+          } deriving (Typeable, Generic, Show)+instance Binary Message where+instance NFData Message where++data ControlMessage =+    Configure !P.Message+  | Post      !Message+    deriving (Typeable, Generic)+instance Binary ControlMessage where+instance NFData ControlMessage where++-- | Different exchange types are defined using record syntax.+-- The 'configureEx' and 'routeEx' API functions are called during the exchange+-- lifecycle when incoming traffic arrives. Configuration messages are+-- completely arbitrary types and the exchange type author is entirely+-- responsible for decoding them. Messages posted to the exchange (see the+-- 'Message' data type) are passed to the 'routeEx' API function along with the+-- exchange type's own internal state. Both API functions return a new+-- (potentially updated) state and run in the @Process@ monad.+--+data ExchangeType s =+  ExchangeType { name        :: String+               , state       :: s+               , configureEx :: s -> P.Message -> Process s+               , routeEx     :: s -> Message -> Process s+               }++--------------------------------------------------------------------------------+-- Starting/Running an Exchange                                               --+--------------------------------------------------------------------------------++-- | Starts an /exchange process/ with the given 'ExchangeType'.+startExchange :: forall s. ExchangeType s -> Process Exchange+startExchange = doStart Nothing++-- | Starts an exchange as part of a supervision tree.+--+-- Example:+-- > childSpec = toChildStart $ startSupervisedRef exType+--+startSupervisedRef :: forall s . ExchangeType s+                   -> SupervisorPid+                   -> Process (ProcessId, P.Message)+startSupervisedRef t s = do+  ex <- startSupervised t s+  return (pid ex, unsafeWrapMessage ex)++-- | Starts an exchange as part of a supervision tree.+--+-- Example:+-- > childSpec = toChildStart $ startSupervised exType+--+startSupervised :: forall s . ExchangeType s+                -> SupervisorPid+                -> Process Exchange+startSupervised t s = doStart (Just s) t++doStart :: Maybe SupervisorPid -> ExchangeType s -> Process Exchange+doStart mSp t = do+  cchan <- liftIO $ newEmptyMVar+  spawnLocal (maybeLink mSp >> runExchange t cchan) >>= \pid -> do+    cc <- liftIO $ takeMVar cchan+    return $ Exchange pid cc (name t)+  where+    maybeLink Nothing   = return ()+    maybeLink (Just p') = P.link p'++runExchange :: forall s.+               ExchangeType s+            -> MVar (ControlPort ControlMessage)+            -> Process ()+runExchange t tc = MP.chanServe t exInit (processDefinition t tc)++exInit :: forall s. InitHandler (ExchangeType s) (ExchangeType s)+exInit t = return $ InitOk t Infinity++--------------------------------------------------------------------------------+-- Client Facing API                                                          --+--------------------------------------------------------------------------------++-- | Posts an arbitrary 'Serializable' datum to an /exchange/. The raw datum is+-- wrapped in the 'Message' data type, with its 'key' set to @""@ and its+-- 'headers' to @[]@.+post :: Serializable a => Exchange -> a -> Process ()+post ex msg = postMessage ex $ Message "" [] (unsafeWrapMessage msg)++-- | Posts a 'Message' to an /exchange/.+postMessage :: Exchange -> Message -> Process ()+postMessage ex msg = msg `seq` sendCtrlMsg ex $ Post msg++-- | Sends an arbitrary 'Serializable' datum to an /exchange/, for use as a+-- configuration change - see 'configureEx' for details.+configureExchange :: Serializable m => Exchange -> m -> Process ()+configureExchange e m = sendCtrlMsg e $ Configure (unsafeWrapMessage m)++-- | Utility for creating a 'Message' datum from its 'key', 'headers' and+-- 'payload'.+createMessage :: Serializable m => String -> [(String, String)] -> m -> Message+createMessage k h m = Message k h $ unsafeWrapMessage m++-- | Utility for custom exchange type authors - evaluates a set of primitive+-- message handlers from left to right, returning the first which evaluates+-- to @Just a@, or the initial @e@ value if all the handlers yield @Nothing@.+applyHandlers :: a+              -> P.Message+              -> [P.Message -> Process (Maybe a)]+              -> Process a+applyHandlers e _ []     = return e+applyHandlers e m (f:fs) = do+  r <- f m+  case r of+    Nothing -> applyHandlers e m fs+    Just r' -> return r'++--------------------------------------------------------------------------------+-- Process Definition/State & API Handlers                                    --+--------------------------------------------------------------------------------++processDefinition :: forall s.+                     ExchangeType s+                  -> MVar (ControlPort ControlMessage)+                  -> ControlChannel ControlMessage+                  -> Process (ProcessDefinition (ExchangeType s))+processDefinition _ tc cc = do+  liftIO $ putMVar tc $ channelControlPort cc+  return $+    defaultProcess {+        apiHandlers  = [ handleControlChan cc handleControlMessage ]+      , infoHandlers = [ handleInfo handleMonitor+                       , handleRaw convertToCC+                       ]+      } :: Process (ProcessDefinition (ExchangeType s))++handleMonitor :: forall s.+                 ExchangeType s+              -> ProcessMonitorNotification+              -> Process (ProcessAction (ExchangeType s))+handleMonitor ex m = do+  handleControlMessage ex (Configure (unsafeWrapMessage m))++convertToCC :: forall s.+               ExchangeType s+            -> P.Message+            -> Process (ProcessAction (ExchangeType s))+convertToCC ex msg = do+  liftIO $ putStrLn "convert to cc"+  handleControlMessage ex (Post $ Message "" [] msg)++handleControlMessage :: forall s.+                        ExchangeType s+                     -> ControlMessage+                     -> Process (ProcessAction (ExchangeType s))+handleControlMessage ex@ExchangeType{..} cm =+  let action = case cm of+                 Configure msg -> configureEx state msg+                 Post      msg -> routeEx     state msg+  in action >>= \s -> continue $ ex { state = s }+
+ src/Control/Distributed/Process/Platform/Execution/Exchange/Router.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE EmptyDataDecls        #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE ImpredicativeTypes    #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | A simple API for /routing/, using a custom exchange type.+module Control.Distributed.Process.Platform.Execution.Exchange.Router+  ( -- * Types+    HeaderName+  , Binding(..)+  , Bindable+  , BindingSelector+  , RelayType(..)+    -- * Starting a Router+  , router+  , supervisedRouter+  , supervisedRouterRef+    -- * Client (Publishing) API+  , route+  , routeMessage+    -- * Routing via message/binding keys+  , messageKeyRouter+  , bindKey+    -- * Routing via message headers+  , headerContentRouter+  , bindHeader+  ) where++import Control.DeepSeq (NFData)+import Control.Distributed.Process+  ( Process+  , ProcessMonitorNotification(..)+  , ProcessId+  , monitor+  , handleMessage+  , unsafeWrapMessage+  )+import qualified Control.Distributed.Process as P+import Control.Distributed.Process.Serializable (Serializable)+import Control.Distributed.Process.Platform.Execution.Exchange.Internal+  ( startExchange+  , startSupervised+  , configureExchange+  , Message(..)+  , Exchange+  , ExchangeType(..)+  , post+  , postMessage+  , applyHandlers+  )+import Control.Distributed.Process.Platform.Internal.Primitives+  ( deliver+  , Resolvable(..)+  )+import Control.Distributed.Process.Platform.Supervisor (SupervisorPid)+import Data.Binary+import Data.Foldable (forM_)+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.HashSet (HashSet)+import qualified Data.HashSet as Set+import Data.Typeable (Typeable)+import GHC.Generics++type HeaderName = String++-- | The binding key used by the built-in key and header based+-- routers.+data Binding =+    BindKey    { bindingKey :: !String }+  | BindHeader { bindingKey :: !String+               , headerName :: !HeaderName+               }+  | BindNone+  deriving (Typeable, Generic, Eq, Show)+instance Binary Binding where+instance NFData Binding where+instance Hashable Binding where++-- | Things that can be used as binding keys in a router.+class (Hashable k, Eq k, Serializable k) => Bindable k+instance (Hashable k, Eq k, Serializable k) => Bindable k++-- | Used to convert a 'Message' into a 'Bindable' routing key.+type BindingSelector k = (Message -> Process k)++-- | Given to a /router/ to indicate whether clients should+-- receive 'Message' payloads only, or the whole 'Message' object+-- itself.+data RelayType = PayloadOnly | WholeMessage++data State k = State { bindings  :: !(HashMap k (HashSet ProcessId))+                     , selector  :: !(BindingSelector k)+                     , relayType :: !RelayType+                     }++type Router k = ExchangeType (State k)++--------------------------------------------------------------------------------+-- Starting/Running the Exchange                                              --+--------------------------------------------------------------------------------++-- | A router that matches on a 'Message' 'key'. To bind a client @Process@ to+-- such an exchange, use the 'bindKey' function.+messageKeyRouter :: RelayType -> Process Exchange+messageKeyRouter t = router t matchOnKey -- (return . BindKey . key)+  where+    matchOnKey :: Message -> Process Binding+    matchOnKey m = return $ BindKey (key m)++-- | A router that matches on a specific (named) header. To bind a client+-- @Process@ to such an exchange, use the 'bindHeader' function.+headerContentRouter :: RelayType -> HeaderName -> Process Exchange+headerContentRouter t n = router t (checkHeaders n)+  where+    checkHeaders hn Message{..} = do+      case Map.lookup hn (Map.fromList headers) of+        Nothing -> return BindNone+        Just hv -> return $ BindHeader hn hv++-- | Defines a /router/ exchange. The 'BindingSelector' is used to construct+-- a binding (i.e., an instance of the 'Bindable' type @k@) for each incoming+-- 'Message'. Such bindings are matched against bindings stored in the exchange.+-- Clients of a /router/ exchange are identified by a binding, mapped to+-- one or more 'ProcessId's.+--+-- The format of the bindings, nature of their storage and mechanism for+-- submitting new bindings is implementation dependent (i.e., will vary by+-- exchange type). For example, the 'messageKeyRouter' and 'headerContentRouter'+-- implementations both use the 'Binding' data type, which can represent a+-- 'Message' key or a 'HeaderName' and content. As with all custom exchange+-- types, bindings should be submitted by evaluating 'configureExchange' with+-- a suitable data type.+--+router :: (Bindable k) => RelayType -> BindingSelector k -> Process Exchange+router t s = routerT t s >>= startExchange++supervisedRouterRef :: Bindable k+                    => RelayType+                    -> BindingSelector k+                    -> SupervisorPid+                    -> Process (ProcessId, P.Message)+supervisedRouterRef t sel spid = do+  ex <- supervisedRouter t sel spid+  Just pid <- resolve ex+  return (pid, unsafeWrapMessage ex)++-- | Defines a /router/ that can be used in a supervision tree.+supervisedRouter :: Bindable k+                 => RelayType+                 -> BindingSelector k+                 -> SupervisorPid+                 -> Process Exchange+supervisedRouter t sel spid =+  routerT t sel >>= \t' -> startSupervised t' spid++routerT :: Bindable k+        => RelayType+        -> BindingSelector k+        -> Process (Router k)+routerT t s = do+  return $ ExchangeType { name        = "Router"+                        , state       = State Map.empty s t+                        , configureEx = apiConfigure+                        , routeEx     = apiRoute+                        }++--------------------------------------------------------------------------------+-- Client Facing API                                                          --+--------------------------------------------------------------------------------++-- | Add a binding (for the calling process) to a 'messageKeyRouter' exchange.+bindKey :: String -> Exchange -> Process ()+bindKey k ex = do+  self <- P.getSelfPid+  configureExchange ex (self, BindKey k)++-- | Add a binding (for the calling process) to a 'headerContentRouter' exchange.+bindHeader :: HeaderName -> String -> Exchange -> Process ()+bindHeader n v ex = do+  self <- P.getSelfPid+  configureExchange ex (self, BindHeader v n)++-- | Send a 'Serializable' message to the supplied 'Exchange'. The given datum+-- will be converted to a 'Message', with the 'key' set to @""@ and the+-- 'headers' to @[]@.+--+-- The routing behaviour will be dependent on the choice of 'BindingSelector'+-- given when initialising the /router/.+route :: Serializable m => Exchange -> m -> Process ()+route = post++-- | Send a 'Message' to the supplied 'Exchange'.+-- The routing behaviour will be dependent on the choice of 'BindingSelector'+-- given when initialising the /router/.+routeMessage :: Exchange -> Message -> Process ()+routeMessage = postMessage++--------------------------------------------------------------------------------+-- Exchage Definition/State & API Handlers                                    --+--------------------------------------------------------------------------------++apiRoute :: forall k. Bindable k+         => State k+         -> Message+         -> Process (State k)+apiRoute st@State{..} msg = do+  binding <- selector msg+  case Map.lookup binding bindings of+    Nothing -> return st+    Just bs -> forM_ bs (fwd relayType msg) >> return st+  where+    fwd WholeMessage m = deliver m+    fwd PayloadOnly  m = P.forward (payload m)++-- TODO: implement 'unbind' ???+-- TODO: apiConfigure currently leaks memory if clients die (we don't cleanup)++apiConfigure :: forall k. Bindable k+             => State k+             -> P.Message+             -> Process (State k)+apiConfigure st msg = do+  applyHandlers st msg $ [ \m -> handleMessage m (createBinding st)+                         , \m -> handleMessage m (handleMonitorSignal st)+                         ]+  where+    createBinding s@State{..} (pid, bind) = do+      case Map.lookup bind bindings of+        Nothing -> do _ <- monitor pid+                      return $ s { bindings = newBind bind pid bindings }+        Just ps -> return $ s { bindings = addBind bind pid bindings ps }++    newBind b p bs = Map.insert b (Set.singleton p) bs+    addBind b' p' bs' ps = Map.insert b' (Set.insert p' ps) bs'++    handleMonitorSignal s@State{..} (ProcessMonitorNotification _ p _) =+      let bs  = bindings+          bs' = Map.foldlWithKey' (\a k v -> Map.insert k (Set.delete p v) a) bs bs+      in return $ s { bindings = bs' }+
+ src/Control/Distributed/Process/Platform/Execution/Mailbox.hs view
@@ -0,0 +1,744 @@+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE PatternGuards        #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE EmptyDataDecls       #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE ImpredicativeTypes   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Execution.Mailbox+-- Copyright   :  (c) Tim Watson 2012 - 2013+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- Generic process that acts as an external mailbox and message buffer.+--+-- [Overview]+--+-- For use when rate limiting is not possible (or desired), this module+-- provides a /buffer process/ that receives mail via its 'post' API, buffers+-- the received messages and delivers them when its /owning process/ asks for+-- them. A mailbox has to be started with a maximum buffer size - the so called+-- /limit/ - and will discard messages once its internal storage reaches this+-- user defined threshold.+--+-- The usual behaviour of the /buffer process/ is to accumulate messages in+-- its internal memory. When a client evaluates 'notify', the buffer will+-- send a 'NewMail' message to the (real) mailbox of its owning process as+-- soon as it has any message(s) ready to deliver. If the buffer already+-- contains undelivered mail, the 'NewMail' message will be dispatched+-- immediately.+--+-- When the owning process wishes to receive mail, evaluating 'deliver' (from+-- any process) will cause the buffer to send its owner a 'Delivery' message+-- containing the accumulated messages and additional information about the+-- number of messages it is delivering, the number of messages dropped since+-- the last delivery and a handle for the mailbox (so that processes can have+-- multiple mailboxes if required, and distinguish between them).+--+-- [Overflow Handling]+--+-- A mailbox handles overflow - when the number of messages it is holding+-- reaches the limit - differently depending on the 'BufferType' selected+-- when it starts. The @Queue@ buffer will, once the limit is reached, drop+-- older messages first (i.e., the head of the queue) to make space for+-- newer ones. The @Ring@ buffer works similarly, but blocks new messages+-- so as to preserve existing ones instead. Finally, the @Stack@ buffer will+-- drop the last (i.e., most recently received) message to make room for new+-- mail.+--+-- Mailboxes can be /resized/ by evaluating 'resize' with a new value for the+-- limit. If the new limit is older that the current/previous one, messages+-- are dropped as though the mailbox had previously seen a volume of mail+-- equal to the difference (in size) between the limits. In this situation,+-- the @Queue@ will drop as many older messages as neccessary to come within+-- the limit, whilst the other two buffer types will drop as many newer messages+-- as needed.+--+-- [Ordering Guarantees]+--+-- When messages are delivered to the owner, they arrive as a list of raw+-- @Message@ entries, given in descending age order (i.e., eldest first).+-- Whilst this approximates the FIFO ordering a process' mailbox would usually+-- offer, the @Stack@ buffer will appear to offer no ordering at all, since+-- it always deletes the most recent message(s). The @Queue@ and @Ring@ buffers+-- will maintain a more queue-like (i.e., FIFO) view of received messages,+-- with the obvious constraint the newer or older data might have been deleted.+--+-- [Post API and Relaying]+--+-- For messages to be properly handled by the mailbox, they can either be sent+-- via the 'post' API or directly to the 'Mailbox'. Messages sent directly to+-- the mailbox will still be handled via the internal buffers and subjected to+-- the mailbox limits. The 'post' API is really just a means to ensure that+-- the conversion from @Serializable a -> Message@ is done in the caller's+-- process and uses the safe @wrapMessage@ variant.+--+-- [Acknowledgements]+--+-- This API is based on the work of Erlang programmers Fred Hebert and+-- Geoff Cant, its design closely mirroring that of the the /pobox/ library+-- application.+--+-----------------------------------------------------------------------------+module Control.Distributed.Process.Platform.Execution.Mailbox+  (+    -- * Creating, Starting, Configuring and Running a Mailbox+    Mailbox()+  , startMailbox+  , startSupervised+  , startSupervisedMailbox+  , createMailbox+  , resize+  , statistics+  , monitor+  , Limit+  , BufferType(..)+  , MailboxStats(..)+    -- * Posting Mail+  , post+    -- * Obtaining Mail and Notifications+  , notify+  , deliver+  , active+  , NewMail(..)+  , Delivery(..)+  , FilterResult(..)+  , acceptEverything+  , acceptMatching+    -- * Remote Table+  , __remoteTable+  ) where++import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TChan+  ( TChan+  , newBroadcastTChanIO+  , dupTChan+  , readTChan+  , writeTChan+  )+import Control.Distributed.Process hiding (call, monitor)+import qualified Control.Distributed.Process as P (monitor)+import Control.Distributed.Process.Closure+  ( remotable+  , mkStaticClosure+  )+import Control.Distributed.Process.Serializable hiding (SerializableDict)+import Control.Distributed.Process.Platform.Internal.Types+  ( ExitReason(..)+  , Resolvable(..)+  , Routable(..)+  , Linkable(..)+  )+import Control.Distributed.Process.Platform.ManagedProcess+  ( call+  , sendControlMessage+  , channelControlPort+  , handleControlChan+  , handleInfo+  , handleRaw+  , continue+  , defaultProcess+  , UnhandledMessagePolicy(..)+  , InitHandler+  , InitResult(..)+  , ProcessAction+  , ProcessDefinition(..)+  , ControlChannel+  , ControlPort+  )+import qualified Control.Distributed.Process.Platform.ManagedProcess as MP+  ( chanServe+  )+import Control.Distributed.Process.Platform.ManagedProcess.Server+  ( stop+  )+import Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted as Restricted+  ( getState+  , Result+  , RestrictedProcess+  )+import qualified Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted as Restricted+  ( handleCall+  , reply+  )+import Control.Distributed.Process.Platform.Supervisor (SupervisorPid)+import Control.Distributed.Process.Platform.Time+import Control.Exception (SomeException)+import Data.Accessor+  ( Accessor+  , accessor+  , (^:)+  , (.>)+  , (^=)+  , (^.)+  )+import Data.Binary+import qualified Data.Foldable as Foldable+import Data.Sequence+  ( Seq+  , ViewL(EmptyL, (:<))+  , ViewR(EmptyR, (:>))+  , (<|)+  , (|>)+  )+import qualified Data.Sequence as Seq+import Data.Typeable (Typeable)++import GHC.Generics++#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch, drop)+#else+import Prelude hiding (drop)+#endif++--------------------------------------------------------------------------------+-- Types                                                                      --+--------------------------------------------------------------------------------++-- external client/configuration API++-- | Opaque handle to a mailbox.+--+data Mailbox = Mailbox { pid   :: !ProcessId+                       , cchan :: !(ControlPort ControlMessage)+                       } deriving (Typeable, Generic, Eq)+instance Binary Mailbox where+instance Show Mailbox where+  show = ("Mailbox:" ++) . show . pid++instance Linkable Mailbox where+  linkTo = link . pid++instance Resolvable Mailbox where+  resolve = return . Just . pid++instance Routable Mailbox where+  sendTo       = post+  unsafeSendTo = post++sendCtrlMsg :: Mailbox+            -> ControlMessage+            -> Process ()+sendCtrlMsg Mailbox{..} = sendControlMessage cchan++-- | Describes the different types of buffer.+--+data BufferType =+    Queue -- ^ FIFO buffer, limiter drops the eldest message (queue head)+  | Stack -- ^ unordered buffer, limiter drops the newest (top) message+  | Ring  -- ^ FIFO buffer, limiter refuses (i.e., drops) new messages+  deriving (Typeable, Eq, Show)++-- TODO: re-implement this process in terms of a limiter expression, i.e.,+--+-- data Limit s = Accept s | Block s+--+-- limit :: forall s. Closure (Message {- new mail -} -> Process (Limit s))++-- | Represents the maximum number of messages the internal buffer can hold.+--+type Limit = Integer++-- | A @Closure@ used to filter messages in /active/ mode.+--+type Filter = Closure (Message -> Process FilterResult)++-- | Marker message indicating to the owning process that mail has arrived.+--+data NewMail = NewMail !Mailbox !Integer+  deriving (Typeable, Generic, Show)+instance Binary NewMail where++-- | Mail delivery.+--+data Delivery = Delivery { box          :: Mailbox -- ^ handle to the sending mailbox+                         , messages     :: [Message] -- ^ list of raw messages+                         , count        :: Integer -- ^ number of messages delivered+                         , totalDropped :: Integer -- ^ total dropped/skipped messages+                         }+  deriving (Typeable, Generic)+instance Binary Delivery where++-- TODO: keep running totals and send them with the stats...++-- | Bundle of statistics data, available on request via+-- the 'mailboxStats' API call.+--+data MailboxStats =+  MailboxStats { pendingMessages :: Integer+               , droppedMessages :: Integer+               , currentLimit    :: Limit+               , owningProcess   :: ProcessId+               } deriving (Typeable, Generic, Show)+instance Binary MailboxStats where++-- internal APIs++data Post = Post !Message+  deriving (Typeable, Generic)+instance Binary Post where++data StatsReq = StatsReq+  deriving (Typeable, Generic)+instance Binary StatsReq where++data FilterResult = Keep | Skip | Send+  deriving (Typeable, Generic)+instance Binary FilterResult++data Mode =+    Active !Filter -- ^ Send all buffered messages (or wait until one arrives)+  | Notify  -- ^ Send a notification once messages are ready to be received+  | Passive -- ^ Accumulate messages in the buffer, dropping them if necessary+  deriving (Typeable, Generic)+instance Binary Mode where+instance Show Mode where+  show (Active _) = "Active"+  show Notify     = "Notify"+  show Passive    = "Passive"++data ControlMessage =+    Resize !Integer+  | SetActiveMode !Mode+  deriving (Typeable, Generic)+instance Binary ControlMessage where++class Buffered a where+  tag    :: a -> BufferType+  push   :: Message -> a -> a+  pop    :: a -> Maybe (Message, a)+  adjust :: Limit -> a -> a+  drop   :: Integer -> a -> a++data BufferState =+  BufferState { _mode    :: Mode+              , _bufferT :: BufferType+              , _limit   :: Limit+              , _size    :: Integer+              , _dropped :: Integer+              , _owner   :: ProcessId+              , ctrlChan :: ControlPort ControlMessage+              }++defaultState :: BufferType+             -> Limit+             -> ProcessId+             -> ControlPort ControlMessage+             -> BufferState+defaultState bufferT limit' pid cc =+  BufferState { _mode    = Passive+              , _bufferT = bufferT+              , _limit   = limit'+              , _size    = 0+              , _dropped = 0+              , _owner   = pid+              , ctrlChan = cc+              }++data State = State { _buffer :: Seq Message+                   , _state  :: BufferState+                   }++instance Buffered State where+  tag q  = _bufferT $ _state q++  -- see note [buffer enqueue/dequeue semantics]+  push m = (state .> size ^: (+1)) . (buffer ^: (m <|))++  -- see note [buffer enqueue/dequeue semantics]+  pop q = maybe Nothing+                (\(s' :> a) -> Just (a, ( (buffer ^= s')+                                        . (state .> size ^: (1-))+                                        $ q))) $ getR (q ^. buffer)++  adjust sz q = (state .> limit ^= sz) $ maybeDrop+    where+      maybeDrop+        | size' <- (q ^. state ^. size),+          size' > sz = (state .> size ^= sz) $ drop (size' - sz) q+        | otherwise  = q++  -- see note [buffer drop semantics]+  drop n q+    | n > 1     = drop (n - 1) $ drop 1 q+    | isQueue q = dropR q+    | otherwise = dropL q+    where+      dropR q' = maybe q' (\(s' :> _) -> dropOne q' s') $ getR (q' ^. buffer)+      dropL q' = maybe q' (\(_ :< s') -> dropOne q' s') $ getL (q' ^. buffer)+      dropOne q' s = ( (buffer ^= s)+                     . (state .> size ^: (\n' -> n' - 1))+                     . (state .> dropped ^: (+1))+                     $ q' )++{- note [buffer enqueue/dequeue semantics]+If we choose to add a message to the buffer, it is always+added to the left hand side of the sequence. This gives+FIFO (enqueue to tail) semantics for queues, LIFO (push+new head) semantics for stacks when dropping messages - note+that dequeueing will always take the eldest (RHS) message,+regardless of the buffer type - and queue-like semantics for+the ring buffer.++We /always/ take the eldest message each time we dequeue,+in an attempt to maintain something approaching FIFO order+when processing the mailbox, for all data structures. Where+we do not achieve this is dropping messages, since the different+buffer types drop messages either on the right (eldest) or left+(youngest).++-- note [buffer drop semantics]++The "stack buffer", when full, only ever attempts to drop the+youngest (leftmost) message, such that it guarantees no ordering+at all, but that is enforced by the code calling 'drop' rather+than the data structure itself. The ring buffer behaves similarly,+since it rejects new messages altogether, which in practise means+dropping from the LHS.++-}++--------------------------------------------------------------------------------+-- Starting/Running a Mailbox                                                 --+--------------------------------------------------------------------------------++-- | Start a mailbox for the calling process.+--+-- > create = getSelfPid >>= start+--+createMailbox :: BufferType -> Limit -> Process Mailbox+createMailbox buffT maxSz =+  getSelfPid >>= \self -> startMailbox self buffT maxSz++-- | Start a mailbox for the supplied @ProcessId@.+--+-- > start = spawnLocal $ run+--+startMailbox :: ProcessId -> BufferType -> Limit -> Process Mailbox+startMailbox = doStartMailbox Nothing++-- | As 'startMailbox', but suitable for use in supervisor child specs.+-- This variant is for use when you want to access to the underlying+-- 'Mailbox' handle in your supervised child refs. See supervisor's+-- @ChildRef@ data type for more information.+--+-- Example:+-- > childSpec = toChildStart $ startSupervised pid bufferType mboxLimit+--+-- See "Control.Distributed.Process.Platform.Supervisor"+--+startSupervised :: ProcessId+                -> BufferType+                -> Limit+                -> SupervisorPid+                -> Process (ProcessId, Message)+startSupervised p b l s = do+  mb <- startSupervisedMailbox p b l s+  return (pid mb, unsafeWrapMessage mb)++-- | As 'startMailbox', but suitable for use in supervisor child specs.+--+-- Example:+-- > childSpec = toChildStart $ startSupervisedMailbox pid bufferType mboxLimit+--+-- See "Control.Distributed.Process.Platform.Supervisor"+--+startSupervisedMailbox :: ProcessId+                       -> BufferType+                       -> Limit+                       -> SupervisorPid+                       -> Process Mailbox+startSupervisedMailbox p b l s = doStartMailbox (Just s) p b l++doStartMailbox :: Maybe SupervisorPid+               -> ProcessId+               -> BufferType+               -> Limit+               -> Process Mailbox+doStartMailbox mSp p b l = do+  bchan <- liftIO $ newBroadcastTChanIO+  rchan <- liftIO $ atomically $ dupTChan bchan+  spawnLocal (maybeLink mSp >> runMailbox bchan p b l) >>= \pid -> do+    cc <- liftIO $ atomically $ readTChan rchan+    return $ Mailbox pid cc+  where+    maybeLink Nothing   = return ()+    maybeLink (Just p') = link p'++-- | Run the mailbox server loop.+--+runMailbox :: TChan (ControlPort ControlMessage)+           -> ProcessId+           -> BufferType+           -> Limit+           -> Process ()+runMailbox tc pid buffT maxSz = do+  link pid+  tc' <- liftIO $ atomically $ dupTChan tc+  MP.chanServe (pid, buffT, maxSz) (mboxInit tc') (processDefinition pid tc)++--------------------------------------------------------------------------------+-- Mailbox Initialisation/Startup                                             --+--------------------------------------------------------------------------------++mboxInit :: TChan (ControlPort ControlMessage)+         -> InitHandler (ProcessId, BufferType, Limit) State+mboxInit tc (pid, buffT, maxSz) = do+  cc <- liftIO $ atomically $ readTChan tc+  return $ InitOk (State Seq.empty $ defaultState buffT maxSz pid cc) Infinity++--------------------------------------------------------------------------------+-- Client Facing API                                                          --+--------------------------------------------------------------------------------++-- | Monitor a mailbox.+--+monitor :: Mailbox -> Process MonitorRef+monitor = P.monitor . pid++-- | Instructs the mailbox to send a 'NewMail' signal as soon as any mail is+-- available for delivery. Once the signal is sent, it will not be resent, even+-- when further mail arrives, until 'notify' is called again.+--+-- NB: signals are /only/ delivered to the mailbox's owning process.+--+notify :: Mailbox -> Process ()+notify mb = sendCtrlMsg mb $ SetActiveMode Notify++-- | Instructs the mailbox to send a 'Delivery' as soon as any mail is+-- available, or immediately (if the buffer already contains data).+--+-- NB: signals are /only/ delivered to the mailbox's owning process.+--+active :: Mailbox -> Filter -> Process ()+active mb f = sendCtrlMsg mb $ SetActiveMode $ Active f++-- | Alters the mailbox's /limit/ - this might cause messages to be dropped!+--+resize :: Mailbox -> Integer -> Process ()+resize mb sz = sendCtrlMsg mb $ Resize sz++-- | Posts a message to someone's mailbox.+--+post :: Serializable a => Mailbox -> a -> Process ()+post Mailbox{..} m = send pid (Post $ wrapMessage m)++-- | Obtain statistics (from/to anywhere) about a mailbox.+--+statistics :: Mailbox -> Process MailboxStats+statistics mb = call mb StatsReq++--------------------------------------------------------------------------------+-- PRIVATE Filter Implementation(s)                                           --+--------------------------------------------------------------------------------++everything :: Message -> Process FilterResult+everything _ = return Keep++matching :: Closure (Message -> Process FilterResult)+         -> Message+         -> Process FilterResult+matching predicate msg = do+  pred' <- unClosure predicate :: Process (Message -> Process FilterResult)+  res   <- handleMessage msg pred'+  case res of+    Nothing -> return Skip+    Just fr -> return fr++--------------------------------------------------------------------------------+-- Process Definition/State & API Handlers                                    --+--------------------------------------------------------------------------------++processDefinition :: ProcessId+                  -> TChan (ControlPort ControlMessage)+                  -> ControlChannel ControlMessage+                  -> Process (ProcessDefinition State)+processDefinition pid tc cc = do+  liftIO $ atomically $ writeTChan tc $ channelControlPort cc+  return $ defaultProcess { apiHandlers = [+                               handleControlChan     cc handleControlMessages+                             , Restricted.handleCall handleGetStats+                             ]+                          , infoHandlers = [ handleInfo handlePost+                                           , handleRaw  handleRawInputs ]+                          , unhandledMessagePolicy = DeadLetter pid+                          } :: Process (ProcessDefinition State)++handleControlMessages :: State+                      -> ControlMessage+                      -> Process (ProcessAction State)+handleControlMessages st cm+  | (SetActiveMode new) <- cm = activateMode st new+  | (Resize sz')        <- cm = continue $ adjust sz' st+  | otherwise                 = stop $ ExitOther "IllegalState"+  where+    activateMode :: State -> Mode -> Process (ProcessAction State)+    activateMode st' new+      | sz <- (st ^. state ^. size)+      , sz == 0           = continue $ updated st' new+      | otherwise         = do+          let updated' = updated st' new+          case new of+            Notify     -> sendNotification updated' >> continue updated'+            (Active _) -> sendMail updated' >>= continue+            Passive    -> {- shouldn't happen! -} die $ "IllegalState"++    updated s m = (state .> mode ^= m) s++handleGetStats :: StatsReq -> RestrictedProcess State (Result MailboxStats)+handleGetStats _ = Restricted.reply . (^. stats) =<< getState++handleRawInputs :: State -> Message -> Process (ProcessAction State)+handleRawInputs st msg = handlePost st (Post msg)++handlePost :: State -> Post -> Process (ProcessAction State)+handlePost st (Post msg) = do+  let st' = insert msg st+  continue . (state .> mode ^= Passive) =<< forwardIfNecessary st'+  where+    forwardIfNecessary s+      | Notify   <- currentMode = sendNotification s >> return s+      | Active _ <- currentMode = sendMail s+      | otherwise               = return s++    currentMode = st ^. state ^. mode++--------------------------------------------------------------------------------+-- Accessors, State/Stats Management & Utilities                              --+--------------------------------------------------------------------------------++sendNotification :: State -> Process ()+sendNotification st = do+    pid <- getSelfPid+    send ownerPid $ NewMail (Mailbox pid cchan) pending+  where+    ownerPid = st ^. state ^. owner+    pending  = st ^. state ^. size+    cchan    = ctrlChan (st ^. state)++type Count = Integer+type Skipped = Integer++sendMail :: State -> Process State+sendMail st = do+    let Active f = st ^. state ^. mode+    unCl <- catch (unClosure f >>= return . Just)+                  (\(_ :: SomeException) -> return Nothing)+    case unCl of+      Nothing -> return st -- TODO: Logging!?+      Just f' -> do+        (st', cnt, skipped, msgs) <- applyFilter f' st+        us <- getSelfPid+        send ownerPid $ Delivery { box          = Mailbox us (ctrlChan $ st ^. state)+                                 , messages     = Foldable.toList msgs+                                 , count        = cnt+                                 , totalDropped = skipped + droppedMsgs+                                 }+        return $ ( (state .> dropped ^= 0)+                 . (state .> size ^: ((cnt + skipped) -))+                 $ st' )+  where+    applyFilter f s = filterMessages f (s, 0, 0, Seq.empty)++    filterMessages :: (Message -> Process FilterResult)+                   -> (State, Count, Skipped, Seq Message)+                   -> Process (State, Count, Skipped, Seq Message)+    filterMessages f accIn@(buff, cnt, drp, acc) = do+      case pop buff of+        Nothing         -> return accIn+        Just (m, buff') -> do+          res <- f m+          case res of+            Keep -> filterMessages f (buff', cnt + 1, drp, acc |> m)+            Skip -> filterMessages f (buff', cnt, drp + 1, acc)+            Send -> return accIn++    ownerPid    = st ^. state ^. owner+    droppedMsgs = st ^. state ^. dropped++insert :: Message -> State -> State+insert msg st@(State _ BufferState{..}) =+  if _size /= _limit+     then push msg st+     else case _bufferT of+            Ring -> (state .> dropped ^: (+1)) st+            _    -> push msg $ drop 1 st++isQueue :: State -> Bool+isQueue = (== Queue) . _bufferT . _state++isStack :: State -> Bool+isStack = (== Stack) . _bufferT . _state++getR :: Seq a -> Maybe (ViewR a)+getR s =+  case Seq.viewr s of+    EmptyR -> Nothing+    a      -> Just a++getL :: Seq a -> Maybe (ViewL a)+getL s =+  case Seq.viewl s of+    EmptyL -> Nothing+    a      -> Just a++mode :: Accessor BufferState Mode+mode = accessor _mode (\m st -> st { _mode = m })++bufferType :: Accessor BufferState BufferType+bufferType = accessor _bufferT (\t st -> st { _bufferT = t })++limit :: Accessor BufferState Limit+limit = accessor _limit (\l st -> st { _limit = l })++size :: Accessor BufferState Integer+size = accessor _size (\s st -> st { _size = s })++dropped :: Accessor BufferState Integer+dropped = accessor _dropped (\d st -> st { _dropped = d })++owner :: Accessor BufferState ProcessId+owner = accessor _owner (\o st -> st { _owner = o })++buffer :: Accessor State (Seq Message)+buffer = accessor _buffer (\b qb -> qb { _buffer = b })++state :: Accessor State BufferState+state = accessor _state (\s qb -> qb { _state = s })++stats :: Accessor State MailboxStats+stats = accessor getStats (\_ s -> s) -- TODO: use a READ ONLY accessor for this+  where+    getStats (State _ (BufferState _ _ lm sz dr op _)) = MailboxStats sz dr lm op++$(remotable ['everything, 'matching])++-- | A /do-nothing/ filter that accepts all messages (i.e., returns @Keep@+-- for any input).+acceptEverything :: Closure (Message -> Process FilterResult)+acceptEverything = $(mkStaticClosure 'everything)++-- | A filter that takes a @Closure (Message -> Process FilterResult)@ holding+-- the filter function and applies it remotely (i.e., in the mailbox's own+-- managed process).+--+acceptMatching :: Closure (Closure (Message -> Process FilterResult)+                           -> Message -> Process FilterResult)+acceptMatching = $(mkStaticClosure 'matching)++-- | Instructs the mailbox to deliver all pending messages to the owner.+--+deliver :: Mailbox -> Process ()+deliver mb = active mb acceptEverything+
+ src/Control/Distributed/Process/Platform/Internal/Containers/MultiMap.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE UndecidableInstances       #-}++module Control.Distributed.Process.Platform.Internal.Containers.MultiMap+  ( MultiMap+  , Insertable+  , empty+  , insert+  , member+  , lookup+  , filter+  , filterWithKey+  , toList+  ) where++import qualified Data.Foldable as Foldable++import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.HashSet (HashSet)+import qualified Data.HashSet as Set+import Data.Foldable (Foldable(..))+import Prelude hiding (lookup, filter, pred)++-- | Class of things that can be inserted in a map or+-- a set (of mapped values), for which instances of+-- @Eq@ and @Hashable@ must be present.+--+class (Eq a, Hashable a) => Insertable a+instance (Eq a, Hashable a) => Insertable a++-- | Opaque type of MultiMaps.+data MultiMap k v = M { hmap :: !(HashMap k (HashSet v)) }++-- instance Foldable++instance Foldable (MultiMap k) where+  foldr f = foldrWithKey (const f)++empty :: MultiMap k v+empty = M $ Map.empty++insert :: forall k v. (Insertable k, Insertable v)+       => k -> v -> MultiMap k v -> MultiMap k v+insert k' v' M{..} =+  case Map.lookup k' hmap of+    Nothing -> M $ Map.insert k' (Set.singleton v') hmap+    Just s  -> M $ Map.insert k' (Set.insert v' s) hmap+{-# INLINE insert #-}++member :: (Insertable k) => k -> MultiMap k a -> Bool+member k = Map.member k . hmap++lookup :: (Insertable k) => k -> MultiMap k v -> Maybe [v]+lookup k M{..} = maybe Nothing (Just . Foldable.toList) $ Map.lookup k hmap+{-# INLINE lookup #-}++filter :: forall k v. (Insertable k)+       => (v -> Bool)+       -> MultiMap k v+       -> MultiMap k v+filter p M{..} = M $ Map.foldlWithKey' (matchOn p) hmap hmap+  where+    matchOn pred acc key valueSet =+      Map.insert key (Set.filter pred valueSet) acc+{-# INLINE filter #-}++filterWithKey :: forall k v. (Insertable k)+              => (k -> v -> Bool)+              -> MultiMap k v+              -> MultiMap k v+filterWithKey p M{..} = M $ Map.foldlWithKey' (matchOn p) hmap hmap+  where+    matchOn pred acc key valueSet =+      Map.insert key (Set.filter (pred key) valueSet) acc+{-# INLINE filterWithKey #-}++-- | /O(n)/ Reduce this map by applying a binary operator to all+-- elements, using the given starting value (typically the+-- right-identity of the operator).+foldrWithKey :: (k -> v -> a -> a) -> a -> MultiMap k v -> a+foldrWithKey f a M{..} =+  let wrap = \k' v' acc' -> f k' v' acc'+  in Map.foldrWithKey (\k v acc -> Set.foldr (wrap k) acc v) a hmap+{-# INLINE foldrWithKey #-}++toList :: MultiMap k v -> [(k, v)]+toList M{..} = Map.foldlWithKey' explode [] hmap+  where+    explode xs k vs = Set.foldl' (\ys v -> ((k, v):ys)) xs vs+{-# INLINE toList #-}+
+ src/Control/Distributed/Process/Platform/Internal/Primitives.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances     #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Internal.Primitives+-- Copyright   :  (c) Tim Watson 2013, Parallel Scientific (Jeff Epstein) 2012+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainers :  Jeff Epstein, Tim Watson+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- This module provides a set of additional primitives that add functionality+-- to the basic Cloud Haskell APIs.+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Internal.Primitives+  ( -- * General Purpose Process Addressing+    Addressable+  , Routable(..)+  , Resolvable(..)+  , Linkable(..)+  , Killable(..)++    -- * Spawning and Linking+  , spawnSignalled+  , spawnLinkLocal+  , spawnMonitorLocal+  , linkOnFailure++    -- * Registered Processes+  , whereisRemote+  , whereisOrStart+  , whereisOrStartRemote++    -- * Selective Receive/Matching+  , matchCond+  , awaitResponse++    -- * General Utilities+  , times+  , monitor+  , awaitExit+  , isProcessAlive+  , forever'+  , deliver++    -- * Remote Table+  , __remoteTable+  ) where++import Control.Concurrent (myThreadId, throwTo)+import Control.Distributed.Process hiding (monitor)+import qualified Control.Distributed.Process as P (monitor)+import Control.Distributed.Process.Closure (seqCP, remotable, mkClosure)+import Control.Distributed.Process.Serializable (Serializable)+import Control.Distributed.Process.Platform.Internal.Types+  ( Addressable+  , Linkable(..)+  , Killable(..)+  , Resolvable(..)+  , Routable(..)+  , RegisterSelf(..)+  , ExitReason(ExitOther)+  , whereisRemote+  )+import Control.Monad (void)+import Data.Maybe (isJust, fromJust)++-- utility++-- | Monitor any @Resolvable@ object.+--+monitor :: Resolvable a => a -> Process (Maybe MonitorRef)+monitor addr = do+  mPid <- resolve addr+  case mPid of+    Nothing -> return Nothing+    Just p  -> return . Just =<< P.monitor p++awaitExit :: Resolvable a => a -> Process ()+awaitExit addr = do+  mPid <- resolve addr+  case mPid of+    Nothing -> return ()+    Just p  -> do+      mRef <- P.monitor p+      receiveWait [+          matchIf (\(ProcessMonitorNotification r p' _) -> r == mRef && p == p')+                  (\_ -> return ())+        ]++deliver :: (Addressable a, Serializable m) => m -> a -> Process ()+deliver = flip sendTo++isProcessAlive :: ProcessId -> Process Bool+isProcessAlive pid = getProcessInfo pid >>= \info -> return $ info /= Nothing++-- | Apply the supplied expression /n/ times+times :: Int -> Process () -> Process ()+n `times` proc = runP proc n+  where runP :: Process () -> Int -> Process ()+        runP _ 0 = return ()+        runP p n' = p >> runP p (n' - 1)++-- | Like 'Control.Monad.forever' but sans space leak+forever' :: Monad m => m a -> m b+forever' a = let a' = a >> a' in a'+{-# INLINE forever' #-}++-- spawning, linking and generic server startup++-- | Spawn a new (local) process. This variant takes an initialisation+-- action and a secondary expression from the result of the initialisation+-- to @Process ()@. The spawn operation synchronises on the completion of the+-- @before@ action, such that the calling process is guaranteed to only see+-- the newly spawned @ProcessId@ once the initialisation has successfully+-- completed.+spawnSignalled :: Process a -> (a -> Process ()) -> Process ProcessId+spawnSignalled before after = do+  (sigStart, recvStart) <- newChan+  (pid, mRef) <- spawnMonitorLocal $ do+    initProc <- before+    sendChan sigStart ()+    after initProc+  receiveWait [+      matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)+              (\(ProcessMonitorNotification _ _ dr) -> die $ ExitOther (show dr))+    , matchChan recvStart (\() -> return pid)+    ]++-- | Node local version of 'Control.Distributed.Process.spawnLink'.+-- 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)+spawnLinkLocal :: Process () -> Process ProcessId+spawnLinkLocal p = do+  pid <- spawnLocal p+  link pid+  return pid++-- | Like 'spawnLinkLocal', but monitors the spawned process.+--+spawnMonitorLocal :: Process () -> Process (ProcessId, MonitorRef)+spawnMonitorLocal p = do+  pid <- spawnLocal p+  ref <- P.monitor pid+  return (pid, ref)++-- | CH's 'link' primitive, unlike Erlang's, will trigger when the target+-- process dies for any reason. This function has semantics like Erlang's:+-- it will trigger 'ProcessLinkException' only when the target dies abnormally.+--+linkOnFailure :: ProcessId -> Process ()+linkOnFailure them = do+  us <- getSelfPid+  tid <- liftIO $ myThreadId+  void $ spawnLocal $ do+    callerRef <- P.monitor us+    calleeRef <- P.monitor them+    reason <- receiveWait [+             matchIf (\(ProcessMonitorNotification mRef _ _) ->+                       mRef == callerRef) -- nothing left to do+                     (\_ -> return DiedNormal)+           , matchIf (\(ProcessMonitorNotification mRef' _ _) ->+                       mRef' == calleeRef)+                     (\(ProcessMonitorNotification _ _ r') -> return r')+         ]+    case reason of+      DiedNormal -> return ()+      _ -> liftIO $ throwTo tid (ProcessLinkException us reason)++-- | Returns the pid of the process that has been registered+-- under the given name. This refers to a local, per-node registration,+-- not @global@ registration. If that name is unregistered, a process+-- is started. This is a handy way to start per-node named servers.+--+whereisOrStart :: String -> Process () -> Process ProcessId+whereisOrStart name proc =+  do mpid <- whereis name+     case mpid of+       Just pid -> return pid+       Nothing ->+         do caller <- getSelfPid+            pid <- spawnLocal $+                 do self <- getSelfPid+                    register name self+                    send caller (RegisterSelf,self)+                    () <- expect+                    proc+            ref <- P.monitor pid+            ret <- receiveWait+               [ matchIf (\(ProcessMonitorNotification aref _ _) -> ref == aref)+                         (\(ProcessMonitorNotification _ _ _) -> return Nothing),+                 matchIf (\(RegisterSelf,apid) -> apid == pid)+                         (\(RegisterSelf,_) -> return $ Just pid)+               ]+            case ret of+              Nothing -> whereisOrStart name proc+              Just somepid ->+                do unmonitor ref+                   send somepid ()+                   return somepid++registerSelf :: (String, ProcessId) -> Process ()+registerSelf (name,target) =+  do self <- getSelfPid+     register name self+     send target (RegisterSelf, self)+     () <- expect+     return ()++$(remotable ['registerSelf])++-- | A remote equivalent of 'whereisOrStart'. It deals with the+-- node registry on the given node, and the process, if it needs to be started,+-- will run on that node. If the node is inaccessible, Nothing will be returned.+--+whereisOrStartRemote :: NodeId -> String -> Closure (Process ()) -> Process (Maybe ProcessId)+whereisOrStartRemote nid name proc =+     do mRef <- monitorNode nid+        whereisRemoteAsync nid name+        res <- receiveWait+          [ matchIf (\(WhereIsReply label _) -> label == name)+                    (\(WhereIsReply _ mPid) -> return (Just mPid)),+            matchIf (\(NodeMonitorNotification aref _ _) -> aref == mRef)+                    (\(NodeMonitorNotification _ _ _) -> return Nothing)+          ]+        case res of+           Nothing -> return Nothing+           Just (Just pid) -> unmonitor mRef >> return (Just pid)+           Just Nothing ->+              do self <- getSelfPid+                 sRef <- spawnAsync nid ($(mkClosure 'registerSelf) (name,self) `seqCP` proc)+                 ret <- receiveWait [+                      matchIf (\(NodeMonitorNotification ref _ _) -> ref == mRef)+                              (\(NodeMonitorNotification _ _ _) -> return Nothing),+                      matchIf (\(DidSpawn ref _) -> ref==sRef )+                              (\(DidSpawn _ pid) ->+                                  do pRef <- P.monitor pid+                                     receiveWait+                                       [ matchIf (\(RegisterSelf, apid) -> apid == pid)+                                                 (\(RegisterSelf, _) -> do unmonitor pRef+                                                                           send pid ()+                                                                           return $ Just pid),+                                         matchIf (\(NodeMonitorNotification aref _ _) -> aref == mRef)+                                                 (\(NodeMonitorNotification _aref _ _) -> return Nothing),+                                         matchIf (\(ProcessMonitorNotification ref _ _) -> ref==pRef)+                                                 (\(ProcessMonitorNotification _ _ _) -> return Nothing)+                                       ] )+                      ]+                 unmonitor mRef+                 case ret of+                   Nothing -> whereisOrStartRemote nid name proc+                   Just pid -> return $ Just pid++-- advanced messaging/matching++-- | An alternative to 'matchIf' that allows both predicate and action+-- to be expressed in one parameter.+matchCond :: (Serializable a) => (a -> Maybe (Process b)) -> Match b+matchCond cond =+   let v n = (isJust n, fromJust n)+       res = v . cond+    in matchIf (fst . res) (snd . res)++-- | Safe (i.e., monitored) waiting on an expected response/message.+awaitResponse :: Addressable a+              => a+              -> [Match (Either ExitReason b)]+              -> Process (Either ExitReason b)+awaitResponse addr matches = do+  mPid <- resolve addr+  case mPid of+    Nothing -> return $ Left $ ExitOther "UnresolvedAddress"+    Just p  -> do+      mRef <- P.monitor p+      receiveWait ((matchRef mRef):matches)+  where+    matchRef :: MonitorRef -> Match (Either ExitReason b)+    matchRef r = matchIf (\(ProcessMonitorNotification r' _ _) -> r == r')+                         (\(ProcessMonitorNotification _ _ d) -> do+                             return (Left (ExitOther (show d))))+
+ src/Control/Distributed/Process/Platform/Internal/Queue/PriorityQ.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE BangPatterns       #-}+{-# LANGUAGE StandaloneDeriving #-}+module Control.Distributed.Process.Platform.Internal.Queue.PriorityQ where++-- NB: we might try this with a skewed binomial heap at some point,+-- but for now, we'll use this module from the fingertree package+import qualified Data.PriorityQueue.FingerTree as PQ+import Data.PriorityQueue.FingerTree (PQueue)++newtype PriorityQ k a = PriorityQ { q :: PQueue k a }++{-# INLINE empty #-}+empty :: Ord k => PriorityQ k v+empty = PriorityQ $ PQ.empty++{-# INLINE isEmpty #-}+isEmpty :: Ord k => PriorityQ k v -> Bool+isEmpty = PQ.null . q++{-# INLINE singleton #-}+singleton :: Ord k => k -> a -> PriorityQ k a+singleton !k !v = PriorityQ $ PQ.singleton k v++{-# INLINE enqueue #-}+enqueue :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v+enqueue !k !v p = PriorityQ (PQ.add k v $ q p)++{-# INLINE dequeue #-}+dequeue :: Ord k => PriorityQ k v -> Maybe (v, PriorityQ k v)+dequeue p = maybe Nothing (\(v, pq') -> Just (v, pq')) $+              case (PQ.minView (q p)) of+                Nothing     -> Nothing+                Just (v, q') -> Just (v, PriorityQ $ q')++{-# INLINE peek #-}+peek :: Ord k => PriorityQ k v -> Maybe v+peek p = maybe Nothing (\(v, _) -> Just v) $ dequeue p+
+ src/Control/Distributed/Process/Platform/Internal/Queue/SeqQ.hs view
@@ -0,0 +1,66 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Internal.Queue.SeqQ+-- Copyright   :  (c) Tim Watson 2012 - 2013+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+--+-- A simple FIFO queue implementation backed by @Data.Sequence@.+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Internal.Queue.SeqQ+  ( SeqQ+  , empty+  , isEmpty+  , singleton+  , enqueue+  , dequeue+  , peek+  )+  where++import Data.Sequence+  ( Seq+  , ViewR(..)+  , (<|)+  , viewr+  )+import qualified Data.Sequence as Seq (empty, singleton, null)++newtype SeqQ a = SeqQ { q :: Seq a }+  deriving (Show)++instance Eq a => Eq (SeqQ a) where+  a == b = (q a) == (q b)++{-# INLINE empty #-}+empty :: SeqQ a+empty = SeqQ Seq.empty++isEmpty :: SeqQ a -> Bool+isEmpty = Seq.null . q++{-# INLINE singleton #-}+singleton :: a -> SeqQ a+singleton = SeqQ . Seq.singleton++{-# INLINE enqueue #-}+enqueue :: SeqQ a -> a -> SeqQ a+enqueue s a = SeqQ $ a <| q s++{-# INLINE dequeue #-}+dequeue :: SeqQ a -> Maybe (a, SeqQ a)+dequeue s = maybe Nothing (\(s' :> a) -> Just (a, SeqQ s')) $ getR s++{-# INLINE peek #-}+peek :: SeqQ a -> Maybe a+peek s = maybe Nothing (\(_ :> a) -> Just a) $ getR s++getR :: SeqQ a -> Maybe (ViewR a)+getR s =+  case (viewr (q s)) of+    EmptyR -> Nothing+    a      -> Just a+
+ src/Control/Distributed/Process/Platform/Internal/Types.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE DeriveDataTypeable     #-}+{-# LANGUAGE DeriveGeneric          #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE TemplateHaskell        #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE OverlappingInstances   #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}++-- | Types used throughout the Platform+--+module Control.Distributed.Process.Platform.Internal.Types+  ( -- * Tagging+    Tag+  , TagPool+  , newTagPool+  , getTag+    -- * Addressing+  , Linkable(..)+  , Killable(..)+  , Resolvable(..)+  , Routable(..)+  , Addressable+  , sendToRecipient+  , Recipient(..)+  , RegisterSelf(..)+    -- * Interactions+  , whereisRemote+  , resolveOrDie+  , CancelWait(..)+  , Channel+  , Shutdown(..)+  , ExitReason(..)+  , ServerDisconnected(..)+  , NFSerializable+    -- remote table+  , __remoteTable+  ) where++import Control.Concurrent.MVar+  ( MVar+  , newMVar+  , modifyMVar+  )+import Control.DeepSeq (NFData, ($!!))+import Control.Distributed.Process hiding (send)+import qualified Control.Distributed.Process as P+  ( send+  , unsafeSend+  , unsafeNSend+  )+import Control.Distributed.Process.Closure+  ( remotable+  , mkClosure+  , functionTDict+  )+import Control.Distributed.Process.Serializable++import Data.Binary+import Data.Typeable (Typeable)+import GHC.Generics++--------------------------------------------------------------------------------+-- API                                                                        --+--------------------------------------------------------------------------------++-- | Introduces a class that brings NFData into scope along with Serializable,+-- such that we can force evaluation. Intended for use with the UnsafePrimitives+-- module (which wraps "Control.Distributed.Process.UnsafePrimitives"), and+-- guarantees evaluatedness in terms of @NFData@. Please note 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.+--+class (NFData a, Serializable a) => NFSerializable a+instance (NFData a, Serializable a) => NFSerializable a++-- | Tags provide uniqueness for messages, so that they can be+-- matched with their response.+type Tag = Int++-- | Generates unique 'Tag' for messages and response pairs.+-- Each process that depends, directly or indirectly, on+-- the call mechanisms in "Control.Distributed.Process.Global.Call"+-- should have at most one TagPool on which to draw unique message+-- tags.+type TagPool = MVar Tag++-- | Create a new per-process source of unique+-- message identifiers.+newTagPool :: Process TagPool+newTagPool = liftIO $ newMVar 0++-- | Extract a new identifier from a 'TagPool'.+getTag :: TagPool -> Process Tag+getTag tp = liftIO $ modifyMVar tp (\tag -> return (tag+1,tag))++-- | Wait cancellation message.+data CancelWait = CancelWait+    deriving (Eq, Show, Typeable, Generic)+instance Binary CancelWait where+instance NFData CancelWait where++-- | Simple representation of a channel.+type Channel a = (SendPort a, ReceivePort a)++-- | Used internally in whereisOrStart. Sent as (RegisterSelf,ProcessId).+data RegisterSelf = RegisterSelf+  deriving (Typeable, Generic)+instance Binary RegisterSelf where+instance NFData RegisterSelf where++-- | A ubiquitous /shutdown signal/ that can be used+-- to maintain a consistent shutdown/stop protocol for+-- any process that wishes to handle it.+data Shutdown = Shutdown+  deriving (Typeable, Generic, Show, Eq)+instance Binary Shutdown where+instance NFData Shutdown where++-- | Provides a /reason/ for process termination.+data ExitReason =+    ExitNormal        -- ^ indicates normal exit+  | ExitShutdown      -- ^ normal response to a 'Shutdown'+  | ExitOther !String -- ^ abnormal (error) shutdown+  deriving (Typeable, Generic, Eq, Show)+instance Binary ExitReason where+instance NFData ExitReason where++-- | A simple means of mapping to a receiver.+data Recipient =+    Pid !ProcessId+  | Registered !String+  | RemoteRegistered !String !NodeId+--  | ProcReg !ProcessId !String+--  | RemoteProcReg NodeId String+--  | GlobalReg String+  deriving (Typeable, Generic, Show, Eq)+instance Binary Recipient where++-- useful exit reasons++-- | Given when a server is unobtainable.+data ServerDisconnected = ServerDisconnected !DiedReason+  deriving (Typeable, Generic)+instance Binary ServerDisconnected where+instance NFData ServerDisconnected where++$(remotable ['whereis])++-- | A synchronous version of 'whereis', this relies on 'call'+-- to perform the relevant monitoring of the remote node.+whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)+whereisRemote node name =+  call $(functionTDict 'whereis) node ($(mkClosure 'whereis) name)++sendToRecipient :: (Serializable m) => Recipient -> m -> Process ()+sendToRecipient (Pid p) m                = P.send p m+sendToRecipient (Registered s) m         = nsend s m+sendToRecipient (RemoteRegistered s n) m = nsendRemote n s m++unsafeSendToRecipient :: (NFSerializable m) => Recipient -> m -> Process ()+unsafeSendToRecipient (Pid p) m                = P.unsafeSend p $!! m+unsafeSendToRecipient (Registered s) m         = P.unsafeNSend s $!! m+unsafeSendToRecipient (RemoteRegistered s n) m = nsendRemote n s m++baseAddressableErrorMessage :: (Routable a) => a -> String+baseAddressableErrorMessage _ = "CannotResolveAddressable"++-- | Class of things to which a @Process@ can /link/ itself.+class Linkable a where+  -- | Create a /link/ with the supplied object.+  linkTo :: a -> Process ()++-- | Class of things that can be resolved to a 'ProcessId'.+--+class Resolvable a where+  -- | Resolve the reference to a process id, or @Nothing@ if resolution fails+  resolve :: a -> Process (Maybe ProcessId)++-- | Class of things that can be killed (or instructed to exit).+class Killable a where+  killProc :: a -> String -> Process ()+  exitProc :: (Serializable m) => a -> m -> Process ()++instance Killable ProcessId where+  killProc = kill+  exitProc = exit++instance Resolvable r => Killable r where+  killProc r s = resolve r >>= maybe (return ()) (flip kill $ s)+  exitProc r m = resolve r >>= maybe (return ()) (flip exit $ m)++-- | Provides a unified API for addressing processes.+--+class Routable a where+  -- | Send a message to the target asynchronously+  sendTo  :: (Serializable m) => a -> m -> Process ()++  -- | Send some @NFData@ message to the target asynchronously,+  -- forcing evaluation (i.e., @deepseq@) beforehand.+  unsafeSendTo :: (NFSerializable m) => a -> m -> Process ()++  -- | Unresolvable @Addressable@ Message+  unresolvableMessage :: a -> String+  unresolvableMessage = baseAddressableErrorMessage++instance (Resolvable a) => Routable a where+  sendTo a m = do+    mPid <- resolve a+    maybe (die (unresolvableMessage a))+          (\p -> P.send p m)+          mPid++  unsafeSendTo a m = do+    mPid <- resolve a+    maybe (die (unresolvableMessage a))+          (\p -> P.unsafeSend p $!! m)+          mPid++  -- | Unresolvable Addressable Message+  unresolvableMessage = baseAddressableErrorMessage++instance Resolvable Recipient where+  resolve (Pid                p) = return (Just p)+  resolve (Registered         n) = whereis n+  resolve (RemoteRegistered s n) = whereisRemote n s++instance Routable Recipient where+  sendTo = sendToRecipient+  unsafeSendTo = unsafeSendToRecipient++  unresolvableMessage (Pid                p) = unresolvableMessage p+  unresolvableMessage (Registered         n) = unresolvableMessage n+  unresolvableMessage (RemoteRegistered s n) = unresolvableMessage (n, s)++instance Resolvable ProcessId where+  resolve p = return (Just p)++instance Routable ProcessId where+  sendTo                 = P.send+  unsafeSendTo pid msg   = P.unsafeSend pid $!! msg+  unresolvableMessage p  = "CannotResolvePid[" ++ (show p) ++ "]"++instance Resolvable String where+  resolve = whereis++instance Routable String where+  sendTo                = nsend+  unsafeSendTo name msg = P.unsafeNSend name $!! msg+  unresolvableMessage s = "CannotResolveRegisteredName[" ++ s ++ "]"++instance Resolvable (NodeId, String) where+  resolve (nid, pname) = whereisRemote nid pname++instance Routable (NodeId, String) where+  sendTo  (nid, pname) msg   = nsendRemote nid pname msg+  unsafeSendTo               = sendTo -- because serialisation *must* take place+  unresolvableMessage (n, s) =+    "CannotResolveRemoteRegisteredName[name: " ++ s ++ ", node: " ++ (show n) ++ "]"++instance Routable (Message -> Process ()) where+  sendTo f       = f . wrapMessage+  unsafeSendTo f = f . unsafeWrapMessage++class (Resolvable a, Routable a) => Addressable a+instance (Resolvable a, Routable a) => Addressable a++-- TODO: this probably belongs somewhere other than in ..Types.+-- | resolve the Resolvable or die with specified msg plus details of what didn't resolve+resolveOrDie  :: (Routable a, Resolvable a) => a -> String -> Process ProcessId+resolveOrDie resolvable failureMsg = do+  result <- resolve resolvable+  case result of+    Nothing -> die $ failureMsg ++ " " ++ unresolvableMessage resolvable+    Just pid -> return pid
+ src/Control/Distributed/Process/Platform/Internal/Unsafe.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}++-- | If you don't know exactly what this module is for and precisely+-- how to use the types within, you should move on, quickly!+--+module Control.Distributed.Process.Platform.Internal.Unsafe+  ( -- * Copying non-serializable data+    PCopy()+  , pCopy+  , matchP+  , matchChanP+  , pUnwrap+    -- * Arbitrary (unmanaged) message streams+  , InputStream(Null)+  , newInputStream+  , matchInputStream+  , readInputStream+  , InvalidBinaryShim(..)+  ) where++import Control.Concurrent.STM (STM, atomically)+import Control.Distributed.Process+  ( matchAny+  , matchChan+  , matchSTM+  , match+  , handleMessage+  , receiveChan+  , liftIO+  , die+  , Match+  , ReceivePort+  , Message+  , Process+  )+import Control.Distributed.Process.Serializable (Serializable)+import Data.Binary+import Control.DeepSeq (NFData)+import Data.Typeable (Typeable)+import GHC.Generics++data InvalidBinaryShim = InvalidBinaryShim+  deriving (Typeable, Show, Eq)++-- NB: PCopy is a shim, allowing us to copy a pointer to otherwise+-- non-serializable data directly to another local process'+-- mailbox with no serialisation or even deepseq evaluation+-- required. We disallow remote queries (i.e., from other nodes)+-- and thus the Binary instance below is never used (though it's+-- required by the type system) and will in fact generate errors if+-- you attempt to use it at runtime. In other words, if you attempt+-- to make a @Message@ out of this, you'd better make sure you're+-- calling @unsafeCreateUnencodedMessage@, otherwise /BOOM/! You have+-- been warned.+--+data PCopy a = PCopy !a+  deriving (Typeable, Generic)+instance (NFData a) => NFData (PCopy a) where++instance (Typeable a) => Binary (PCopy a) where+  put _ = error "InvalidBinaryShim"+  get   = error "InvalidBinaryShim"++-- | Wrap any @Typeable@ datum in a @PCopy@. We hide the constructor to+-- discourage arbitrary uses of the type, since @PCopy@ is a specialised+-- and potentially dangerous construct.+pCopy :: (Typeable a) => a -> PCopy a+pCopy = PCopy++-- | Matches on @PCopy m@ and returns the /m/ within.+-- This potentially allows us to bypass serialization (and the type constraints+-- it enforces) for local message passing (i.e., with @UnencodedMessage@ data),+-- since PCopy is just a shim.+matchP :: (Typeable m) => Match (Maybe m)+matchP = matchAny pUnwrap++-- | Given a raw @Message@, attempt to unwrap a @Typeable@ datum from+-- an enclosing @PCopy@ wrapper.+pUnwrap :: (Typeable m) => Message -> Process (Maybe m)+pUnwrap m = handleMessage m (\(PCopy m' :: PCopy m) -> return m')++-- | Matches on a @TypedChannel (PCopy a)@.+matchChanP :: (Typeable m) => ReceivePort (PCopy m) -> Match m+matchChanP rp = matchChan rp (\(PCopy m' :: PCopy m) -> return m')++-- | A generic input channel that can be read from in the same fashion+-- as a typed channel (i.e., @ReceivePort@). To read from an input stream+-- in isolation, see 'readInputStream'. To compose an 'InputStream' with+-- reads on a process' mailbox (and/or typed channels), see 'matchInputStream'.+--+data InputStream a = ReadChan (ReceivePort a) | ReadSTM (STM a) | Null+  deriving (Typeable)++data NullInputStream = NullInputStream+  deriving (Typeable, Generic, Show, Eq)+instance Binary NullInputStream where+instance NFData NullInputStream where++-- [note: InputStream]+-- InputStream wraps either a ReceivePort or an arbitrary STM action. Used+-- internally when we want to allow internal clients to completely bypass+-- regular messaging primitives (which is rare but occaisionally useful),+-- the type (only, minus its constructors) is exposed to users of some+-- @Exchange@ APIs.++-- | Create a new 'InputStream'.+newInputStream :: forall a. (Typeable a)+               => Either (ReceivePort a) (STM a)+               -> InputStream a+newInputStream (Left rp)   = ReadChan rp+newInputStream (Right stm) = ReadSTM stm++-- | Read from an 'InputStream'. This is a blocking operation.+readInputStream :: (Serializable a) => InputStream a -> Process a+readInputStream (ReadChan rp) = receiveChan rp+readInputStream (ReadSTM stm) = liftIO $ atomically stm+readInputStream Null          = die $ NullInputStream++-- | Constructs a @Match@ for a given 'InputChannel'.+matchInputStream :: InputStream a -> Match a+matchInputStream (ReadChan rp) = matchChan rp return+matchInputStream (ReadSTM stm) = matchSTM stm return+matchInputStream Null          = match (\NullInputStream -> do+                                           error "NullInputStream")+
+ src/Control/Distributed/Process/Platform/ManagedProcess.hs view
@@ -0,0 +1,525 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE RecordWildCards            #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.ManagedProcess+-- Copyright   :  (c) Tim Watson 2012+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- This module provides a high(er) level API for building complex @Process@+-- implementations by abstracting out the management of the process' mailbox,+-- reply/response handling, timeouts, process hiberation, error handling+-- and shutdown/stop procedures. It is modelled along similar lines to OTP's+-- gen_server API - <http://www.erlang.org/doc/man/gen_server.html>.+--+-- In particular, a /managed process/ will interoperate cleanly with the+-- "Control.Distributed.Process.Platform.Supervisor" API.+--+-- [API Overview]+--+-- Once started, a /managed process/ will consume messages from its mailbox and+-- pass them on to user defined /handlers/ based on the types received (mapped+-- to those accepted by the handlers) and optionally by also evaluating user+-- supplied predicates to determine which handler(s) should run.+-- Each handler returns a 'ProcessAction' which specifies how we should proceed.+-- If none of the handlers is able to process a message (because their types are+-- incompatible), then the 'unhandledMessagePolicy' will be applied.+--+-- The 'ProcessAction' type defines the ways in which our process can respond+-- to its inputs, whether by continuing to read incoming messages, setting an+-- optional timeout, sleeping for a while or stopping. The optional timeout+-- behaves a little differently to the other process actions. If no messages+-- are received within the specified time span, a user defined 'timeoutHandler'+-- will be called in order to determine the next action.+--+-- The 'ProcessDefinition' type also defines a @shutdownHandler@,+-- which is called whenever the process exits, whether because a callback has+-- returned 'stop' as the next action, or as the result of unhandled exit signal+-- or similar asynchronous exceptions thrown in (or to) the process itself.+--+-- The other handlers are split into two groups: /apiHandlers/ and /infoHandlers/.+-- The former contains handlers for the 'cast' and 'call' protocols, whilst the+-- latter contains handlers that deal with input messages which are not sent+-- via these API calls (i.e., messages sent using bare 'send' or signals put+-- into the process mailbox by the node controller, such as+-- 'ProcessMonitorNotification' and the like).+--+-- [The Cast/Call Protocol]+--+-- Deliberate interactions with a /managed process/ usually fall into one of+-- two categories. A 'cast' interaction involves a client sending a message+-- asynchronously and the server handling this input. No reply is sent to+-- the client. On the other hand, a 'call' is a /remote procedure call/,+-- where the client sends a message and waits for a reply from the server.+--+-- All expressions given to @apiHandlers@ have to conform to the /cast|call/+-- protocol. The protocol (messaging) implementation is hidden from the user;+-- API functions for creating user defined @apiHandlers@ are given instead,+-- which take expressions (i.e., a function or lambda expression) and create the+-- appropriate @Dispatcher@ for handling the cast (or call).+--+-- These cast/call protocols are for dealing with /expected/ inputs. They+-- will usually form the explicit public API for the process, and be exposed by+-- providing module level functions that defer to the cast/call API, giving+-- the author an opportunity to enforce the correct types. For+-- example:+--+-- @+-- {- Ask the server to add two numbers -}+-- add :: ProcessId -> Double -> Double -> Double+-- add pid x y = call pid (Add x y)+-- @+--+-- Note here that the return type from the call is /inferred/ and will not be+-- enforced by the type system. If the server sent a different type back in+-- the reply, then the caller might be blocked indefinitely! In fact, the+-- result of mis-matching the expected return type (in the client facing API)+-- with the actual type returned by the server is more severe in practise.+-- The underlying types that implement the /call/ protocol carry information+-- about the expected return type. If there is a mismatch between the input and+-- output types that the client API uses and those which the server declares it+-- can handle, then the message will be considered unroutable - no handler will+-- be executed against it and the unhandled message policy will be applied. You+-- should, therefore, take great care to align these types since the default+-- unhandled message policy is to terminate the server! That might seem pretty+-- extreme, but you can alter the unhandled message policy and/or use the+-- various overloaded versions of the call API in order to detect errors on the+-- server such as this.+--+-- The cost of potential type mismatches between the client and server is the+-- main disadvantage of this looser coupling between them. This mechanism does+-- however, allow servers to handle a variety of messages without specifying the+-- entire protocol to be supported in excruciating detail.+--+-- [Handling Unexpected/Info Messages]+--+-- An explicit protocol for communicating with the process can be+-- configured using 'cast' and 'call', but it is not possible to prevent+-- other kinds of messages from being sent to the process mailbox. When+-- any message arrives for which there are no handlers able to process+-- its content, the 'UnhandledMessagePolicy' will be applied. Sometimes+-- it is desireable to process incoming messages which aren't part of the+-- protocol, rather than let the policy deal with them. This is particularly+-- true when incoming messages are important to the process, but their point+-- of origin is outside the author's control. Handling /signals/ such as+-- 'ProcessMonitorNotification' is a typical example of this:+--+-- > handleInfo_ (\(ProcessMonitorNotification _ _ r) -> say $ show r >> continue_)+--+-- [Handling Process State]+--+-- The 'ProcessDefinition' is parameterised by the type of state it maintains.+-- A process that has no state will have the type @ProcessDefinition ()@ and can+-- be bootstrapped by evaluating 'statelessProcess'.+--+-- All call/cast handlers come in two flavours, those which take the process+-- state as an input and those which do not. Handlers that ignore the process+-- state have to return a function that takes the state and returns the required+-- action. Versions of the various action generating functions ending in an+-- underscore are provided to simplify this:+--+-- @+--   statelessProcess {+--       apiHandlers = [+--         handleCall_   (\\(n :: Int) -> return (n * 2))+--       , handleCastIf_ (\\(c :: String, _ :: Delay) -> c == \"timeout\")+--                       (\\(\"timeout\", (d :: Delay)) -> timeoutAfter_ d)+--       ]+--     , timeoutHandler = \\_ _ -> stop $ ExitOther \"timeout\"+--   }+-- @+--+-- [Avoiding Side Effects]+--+-- If you wish to only write side-effect free code in your server definition,+-- then there is an explicit API for doing so. Instead of using the handlers+-- definition functions in this module, import the /pure/ server module instead,+-- which provides a StateT based monad for building referentially transparent+-- callbacks.+--+-- See "Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted" for+-- details and API documentation.+--+-- [Handling Errors]+--+-- Error handling appears in several contexts and process definitions can+-- hook into these with relative ease. Only process failures as a result of+-- asynchronous exceptions are supported by the API, which provides several+-- scopes for error handling.+--+-- Catching exceptions inside handler functions is no different to ordinary+-- exception handling in monadic code.+--+-- @+--   handleCall (\\x y ->+--                catch (hereBeDragons x y)+--                      (\\(e :: SmaugTheTerribleException) ->+--                           return (Left (show e))))+-- @+--+-- The caveats mentioned in "Control.Distributed.Process.Platform" about+-- exit signal handling obviously apply here as well.+--+-- [Structured Exit Handling]+--+-- Because "Control.Distributed.Process.ProcessExitException" is a ubiquitous+-- signalling mechanism in Cloud Haskell, it is treated unlike other+-- asynchronous exceptions. The 'ProcessDefinition' 'exitHandlers' field+-- accepts a list of handlers that, for a specific exit reason, can decide+-- how the process should respond. If none of these handlers matches the+-- type of @reason@ then the process will exit with @DiedException why@. In+-- addition, a private /exit handler/ is installed for exit signals where+-- @reason :: ExitReason@, which is a form of /exit signal/ used explicitly+-- by the supervision APIs. This behaviour, which cannot be overriden, is to+-- gracefully shut down the process, calling the @shutdownHandler@ as usual,+-- before stopping with @reason@ given as the final outcome.+--+-- /Example: handling custom data is @ProcessExitException@/+--+-- > handleExit  (\state from (sigExit :: SomeExitData) -> continue s)+--+-- Under some circumstances, handling exit signals is perfectly legitimate.+-- Handling of /other/ forms of asynchronous exception (e.g., exceptions not+-- generated by an /exit/ signal) is not supported by this API. Cloud Haskell's+-- primitives for exception handling /will/ work normally in managed process+-- callbacks however.+--+-- If any asynchronous exception goes unhandled, the process will immediately+-- exit without running the @shutdownHandler@. It is very important to note+-- that in Cloud Haskell, link failures generate asynchronous exceptions in+-- the target and these will NOT be caught by the API and will therefore+-- cause the process to exit /without running the termination handler/+-- callback. If your termination handler is set up to do important work+-- (such as resource cleanup) then you should avoid linking you process+-- and use monitors instead.+--+-- [Prioritised Mailboxes]+--+-- Many processes need to prioritise certain classes of message over others,+-- so two subsets of the API are given to supporting those cases.+--+-- A 'PrioritisedProcessDefintion' combines the usual 'ProcessDefintion' -+-- containing the cast/call API, error, termination and info handlers - with a+-- list of 'Priority' entries, which are used at runtime to prioritise the+-- server's inputs. Note that it is only messages which are prioritised; The+-- server's various handlers are still evaluated in insertion order.+--+-- Prioritisation does not guarantee that a prioritised message/type will be+-- processed before other traffic - indeed doing so in a multi-threaded runtime+-- would be very hard - but in the absence of races between multiple processes,+-- if two messages are both present in the process' own mailbox, they will be+-- applied to the ProcessDefinition's handler's in priority order. This is+-- achieved by draining the real mailbox into a priority queue and processing+-- each message in turn.+--+-- A prioritised process must be configured with a 'Priority' list to be of+-- any use. Creating a prioritised process without any priorities would be a+-- big waste of computational resources, and it is worth thinking carefully+-- about whether or not prioritisation is truly necessary in your design before+-- choosing to use it.+--+-- Using a prioritised process is as simple as calling 'pserve' instead of+-- 'serve', and passing an initialised 'PrioritisedProcessDefinition'.+--+-- [Control Channels]+--+-- For advanced users and those requiring very low latency, a prioritised+-- process definition might not be suitable, since it performs considerable+-- work /behind the scenes/. There are also designs that need to segregate a+-- process' /control plane/ from other kinds of traffic it is expected to+-- receive. For such use cases, a /control channel/ may prove a better choice,+-- since typed channels are already prioritised during the mailbox scans that+-- the base @receiveWait@ and @receiveTimeout@ primitives from+-- distribute-process provides.+--+-- In order to utilise a /control channel/ in a server, it must be passed to the+-- corresponding 'handleControlChan' function (or its stateless variant). The+-- control channel is created by evaluating 'newControlChan', in the same way+-- that we create regular typed channels.+--+-- In order for clients to communicate with a server via its control channel+-- however, they must pass a handle to a 'ControlPort', which can be obtained by+-- evaluating 'channelControlPort' on the 'ControlChannel'. A 'ControlPort' is+-- @Serializable@, so they can alternatively be sent to other processes.+--+-- /Control channel/ traffic will only be prioritised over other traffic if the+-- handlers using it are present before others (e.g., @handleInfo, handleCast@,+-- etc) in the process definition. It is not possible to combine prioritised+-- processes with /control channels/. Attempting to do so will satisfy the+-- compiler, but crash with a runtime error once you attempt to evaluate the+-- prioritised server loop (i.e., 'pserve').+--+-- Since the primary purpose of control channels is to simplify and optimise+-- client-server communication over a single channel, this module provides an+-- alternate server loop in the form of 'chanServe'. Instead of passing an+-- initialised 'ProcessDefinition', this API takes an expression from a+-- 'ControlChannel' to 'ProcessDefinition', operating in the 'Process' monad.+-- Providing the opaque reference in this fashion is useful, since the type of+-- messages the control channel carries will not correlate directly to the+-- inter-process traffic we use internally.+--+-- Although control channels are intended for use as a single control plane+-- (via 'chanServe'), it /is/ possible to use them as a more strictly typed+-- communications backbone, since they do enforce absolute type safety in client+-- code, being bound to a particular type on creation. For rpc (i.e., 'call')+-- interaction however, it is not possible to have the server reply to a control+-- channel, since they're a /one way pipe/. It is possible to alleviate this+-- situation by passing a request type than contains a typed channel bound to+-- the expected reply type, enabling client and server to match on both the input+-- and output types as specifically as possible. Note that this still does not+-- guarantee an agreement on types between all parties at runtime however.+--+-- An example of how to do this follows:+--+-- > data Request = Request String (SendPort String)+-- >   deriving (Typeable, Generic)+-- > instance Binary Request where+-- >+-- > -- note that our initial caller needs an mvar to obtain the control port...+-- > echoServer :: MVar (ControlPort Request) -> Process ()+-- > echoServer mv = do+-- >   cc <- newControlChan :: Process (ControlChannel Request)+-- >   liftIO $ putMVar mv $ channelControlPort cc+-- >   let s = statelessProcess {+-- >       apiHandlers = [+-- >            handleControlChan_ cc (\(Request m sp) -> sendChan sp m >> continue_)+-- >          ]+-- >     }+-- >   serve () (statelessInit Infinity) s+-- >+-- > echoClient :: String -> ControlPort Request -> Process String+-- > echoClient str cp = do+-- >   (sp, rp) <- newChan+-- >   sendControlMessage cp $ Request str sp+-- >   receiveChan rp+--+-- [Performance Considerations]+--+-- The various server loops are fairly optimised, but there /is/ a definite+-- cost associated with scanning the mailbox to match on protocol messages,+-- plus additional costs in space and time due to mapping over all available+-- /info handlers/ for non-protocol (i.e., neither /call/ nor /cast/) messages.+-- These are exacerbated significantly when using prioritisation, whilst using+-- a single control channel is very fast and carries little overhead.+--+-- From the client perspective, it's important to remember that the /call/+-- protocol will wait for a reply in most cases, triggering a full O(n) scan of+-- the caller's mailbox. If the mailbox is extremely full and calls are+-- regularly made, this may have a significant impact on the caller. The+-- @callChan@ family of client API functions can alleviate this, by using (and+-- matching on) a private typed channel instead, but the server must be written+-- to accomodate this. Similar gains can be had using a /control channel/ and+-- providing a typed reply channel in the request data, however the 'call'+-- mechanism does not support this notion, so not only are we unable+-- to use the various /reply/ functions, client code should also consider+-- monitoring the server's pid and handling server failures whilst waiting on+--+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.ManagedProcess+  ( -- * Starting/Running server processes+    InitResult(..)+  , InitHandler+  , serve+  , pserve+  , chanServe+  , runProcess+  , prioritised+    -- * Client interactions+  , module Control.Distributed.Process.Platform.ManagedProcess.Client+    -- * Defining server processes+  , ProcessDefinition(..)+  , PrioritisedProcessDefinition(..)+  , RecvTimeoutPolicy(..)+  , Priority(..)+  , DispatchPriority()+  , Dispatcher()+  , DeferredDispatcher()+  , ShutdownHandler+  , TimeoutHandler+  , ProcessAction(..)+  , ProcessReply+  , Condition+  , CallHandler+  , CastHandler+  , UnhandledMessagePolicy(..)+  , CallRef+  , ControlChannel()+  , ControlPort()+  , defaultProcess+  , defaultProcessWithPriorities+  , statelessProcess+  , statelessInit+    -- * Server side callbacks+  , handleCall+  , handleCallIf+  , handleCallFrom+  , handleCallFromIf+  , handleCast+  , handleCastIf+  , handleInfo+  , handleRaw+  , handleRpcChan+  , handleRpcChanIf+  , action+  , handleDispatch+  , handleExit+    -- * Stateless callbacks+  , handleCall_+  , handleCallFrom_+  , handleCallIf_+  , handleCallFromIf_+  , handleCast_+  , handleCastIf_+  , handleRpcChan_+  , handleRpcChanIf_+    -- * Control channels+  , newControlChan+  , channelControlPort+  , handleControlChan+  , handleControlChan_+    -- * Prioritised mailboxes+  , module Control.Distributed.Process.Platform.ManagedProcess.Server.Priority+    -- * Constructing handler results+  , condition+  , state+  , input+  , reply+  , replyWith+  , noReply+  , noReply_+  , haltNoReply_+  , continue+  , continue_+  , timeoutAfter+  , timeoutAfter_+  , hibernate+  , hibernate_+  , stop+  , stopWith+  , stop_+  , replyTo+  , replyChan+  ) where++import Control.Distributed.Process hiding (call, Message)+import Control.Distributed.Process.Platform.ManagedProcess.Client+import Control.Distributed.Process.Platform.ManagedProcess.Server+import Control.Distributed.Process.Platform.ManagedProcess.Server.Priority+import Control.Distributed.Process.Platform.ManagedProcess.Internal.GenProcess+import Control.Distributed.Process.Platform.ManagedProcess.Internal.Types+import Control.Distributed.Process.Platform.Internal.Types (ExitReason(..))+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Serializable+import Prelude hiding (init)++-- TODO: automatic registration++-- | Starts the /message handling loop/ for a managed process configured with+-- the supplied process definition, after calling the init handler with its+-- initial arguments. Note that this function does not return until the server+-- exits.+serve :: a+      -> InitHandler a s+      -> ProcessDefinition s+      -> Process ()+serve argv init def = runProcess (recvLoop def) argv init++-- | Starts the /message handling loop/ for a prioritised managed process,+-- configured with the supplied process definition, after calling the init+-- handler with its initial arguments. Note that this function does not return+-- until the server exits.+pserve :: a+       -> InitHandler a s+       -> PrioritisedProcessDefinition s+       -> Process ()+pserve argv init def = runProcess (precvLoop def) argv init++-- | Starts the /message handling loop/ for a managed process, configured with+-- a typed /control channel/. The caller supplied expression is evaluated with+-- an opaque reference to the channel, which must be passed when calling+-- @handleControlChan@. The meaning and behaviour of the init handler and+-- initial arguments are the same as those given to 'serve'. Note that this+-- function does not return until the server exits.+--+chanServe :: (Serializable b)+          => a+          -> InitHandler a s+          -> (ControlChannel b -> Process (ProcessDefinition s))+          -> Process ()+chanServe argv init mkDef = do+  pDef <- mkDef . ControlChannel =<< newChan+  runProcess (recvLoop pDef) argv init++-- | Wraps any /process loop/ and ensures that it adheres to the+-- managed process start/stop semantics, i.e., evaluating the+-- @InitHandler@ with an initial state and delay will either+-- @die@ due to @InitStop@, exit silently (due to @InitIgnore@)+-- or evaluate the process' @loop@. The supplied @loop@ must evaluate+-- to @ExitNormal@, otherwise the calling processing will @die@ with+-- whatever @ExitReason@ is given.+--+runProcess :: (s -> Delay -> Process ExitReason)+           -> a+           -> InitHandler a s+           -> Process ()+runProcess loop args init = do+  ir <- init args+  case ir of+    InitOk s d -> loop s d >>= checkExitType+    InitStop s -> die $ ExitOther s+    InitIgnore -> return ()+  where+    checkExitType :: ExitReason -> Process ()+    checkExitType ExitNormal = return ()+    checkExitType other      = die other++-- | A default 'ProcessDefinition', with no api, info or exit handler.+-- The default 'timeoutHandler' simply continues, the 'shutdownHandler'+-- is a no-op and the 'unhandledMessagePolicy' is @Terminate@.+defaultProcess :: ProcessDefinition s+defaultProcess = ProcessDefinition {+    apiHandlers      = []+  , infoHandlers     = []+  , exitHandlers     = []+  , timeoutHandler   = \s _ -> continue s+  , shutdownHandler  = \_ _ -> return ()+  , unhandledMessagePolicy = Terminate+  } :: ProcessDefinition s++-- | Turns a standard 'ProcessDefinition' into a 'PrioritisedProcessDefinition',+-- by virtue of the supplied list of 'DispatchPriority' expressions.+--+prioritised :: ProcessDefinition s+            -> [DispatchPriority s]+            -> PrioritisedProcessDefinition s+prioritised def ps = PrioritisedProcessDefinition def ps defaultRecvTimeoutPolicy++-- | Sets the default 'recvTimeoutPolicy', which gives up after 10k reads.+defaultRecvTimeoutPolicy :: RecvTimeoutPolicy+defaultRecvTimeoutPolicy = RecvCounter 10000++-- | Creates a default 'PrioritisedProcessDefinition' from a list of+-- 'DispatchPriority'. See 'defaultProcess' for the underlying definition.+defaultProcessWithPriorities :: [DispatchPriority s] -> PrioritisedProcessDefinition s+defaultProcessWithPriorities dps = prioritised defaultProcess dps++-- | A basic, stateless 'ProcessDefinition'. See 'defaultProcess' for the+-- default field values.+statelessProcess :: ProcessDefinition ()+statelessProcess = defaultProcess :: ProcessDefinition ()++-- | A default, state /unaware/ 'InitHandler' that can be used with+-- 'statelessProcess'. This simply returns @InitOk@ with the empty+-- state (i.e., unit) and the given 'Delay'.+statelessInit :: Delay -> InitHandler () ()+statelessInit d () = return $ InitOk () d+
+ src/Control/Distributed/Process/Platform/ManagedProcess/Client.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE ScopedTypeVariables        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.ManagedProcess.Client+-- Copyright   :  (c) Tim Watson 2012 - 2013+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- The Client Portion of the /Managed Process/ API.+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.ManagedProcess.Client+  ( -- * API for client interactions with the process+    sendControlMessage+  , shutdown+  , call+  , safeCall+  , tryCall+  , callTimeout+  , flushPendingCalls+  , callAsync+  , cast+  , callChan+  , syncCallChan+  , syncSafeCallChan+  ) where++import Control.Distributed.Process hiding (call)+import Control.Distributed.Process.Serializable+import Control.Distributed.Process.Platform.Async hiding (check)+import Control.Distributed.Process.Platform.ManagedProcess.Internal.Types+import qualified Control.Distributed.Process.Platform.ManagedProcess.Internal.Types as T+import Control.Distributed.Process.Platform.Internal.Primitives hiding (monitor)+import Control.Distributed.Process.Platform.Internal.Types+  ( ExitReason(..)+  , Shutdown(..)+  )+import Control.Distributed.Process.Platform.Time+import Data.Maybe (fromJust)++import Prelude hiding (init)++-- | Send a control message over a 'ControlPort'.+--+sendControlMessage :: Serializable m => ControlPort m -> m -> Process ()+sendControlMessage cp m = sendChan (unPort cp) (CastMessage m)++-- | Send a signal instructing the process to terminate. The /receive loop/ which+-- manages the process mailbox will prioritise @Shutdown@ signals higher than+-- any other incoming messages, but the server might be busy (i.e., still in the+-- process of excuting a handler) at the time of sending however, so the caller+-- should not make any assumptions about the timeliness with which the shutdown+-- signal will be handled. If responsiveness is important, a better approach+-- might be to send an /exit signal/ with 'Shutdown' as the reason. An exit+-- signal will interrupt any operation currently underway and force the running+-- process to clean up and terminate.+shutdown :: ProcessId -> Process ()+shutdown pid = cast pid Shutdown++-- | Make a synchronous call - will block until a reply is received.+-- The calling process will exit with 'ExitReason' if the calls fails.+call :: forall s a b . (Addressable s, Serializable a, Serializable b)+                 => s -> a -> Process b+call sid msg = initCall sid msg >>= waitResponse Nothing >>= decodeResult+  where decodeResult (Just (Right r))  = return r+        decodeResult (Just (Left err)) = die err+        decodeResult Nothing {- the impossible happened -} = terminate++-- | Safe version of 'call' that returns information about the error+-- if the operation fails. If an error occurs then the explanation will be+-- will be stashed away as @(ExitOther String)@.+safeCall :: forall s a b . (Addressable s, Serializable a, Serializable b)+                 => s -> a -> Process (Either ExitReason b)+safeCall s m = initCall s m >>= waitResponse Nothing >>= return . fromJust++-- | Version of 'safeCall' that returns 'Nothing' if the operation fails. If+-- you need information about *why* a call has failed then you should use+-- 'safeCall' or combine @catchExit@ and @call@ instead.+tryCall :: forall s a b . (Addressable s, Serializable a, Serializable b)+                 => s -> a -> Process (Maybe b)+tryCall s m = initCall s m >>= waitResponse Nothing >>= decodeResult+  where decodeResult (Just (Right r)) = return $ Just r+        decodeResult _                = return Nothing++-- | Make a synchronous call, but timeout and return @Nothing@ if a reply+-- is not received within the specified time interval.+--+-- If the result of the call is a failure (or the call was cancelled) then+-- the calling process will exit, with the 'ExitReason' given as the reason.+-- If the call times out however, the semantics on the server side are+-- undefined, i.e., the server may or may not successfully process the+-- request and may (or may not) send a response at a later time. From the+-- callers perspective, this is somewhat troublesome, since the call result+-- cannot be decoded directly. In this case, the 'flushPendingCalls' API /may/+-- be used to attempt to receive the message later on, however this makes+-- /no attempt whatsoever/ to guarantee /which/ call response will in fact+-- be returned to the caller. In those semantics are unsuited to your+-- application, you might choose to @exit@ or @die@ in case of a timeout,+-- or alternatively, use the 'callAsync' API and associated @waitTimeout@+-- function (in the /Async API/), which takes a re-usable handle on which+-- to wait (with timeouts) multiple times.+--+callTimeout :: forall s a b . (Addressable s, Serializable a, Serializable b)+                 => s -> a -> TimeInterval -> Process (Maybe b)+callTimeout s m d = initCall s m >>= waitResponse (Just d) >>= decodeResult+  where decodeResult :: (Serializable b)+               => Maybe (Either ExitReason b)+               -> Process (Maybe b)+        decodeResult Nothing               = return Nothing+        decodeResult (Just (Right result)) = return $ Just result+        decodeResult (Just (Left reason))  = die reason++flushPendingCalls :: forall b . (Serializable b)+                  => TimeInterval+                  -> (b -> Process b)+                  -> Process (Maybe b)+flushPendingCalls d proc = do+  receiveTimeout (asTimeout d) [+      match (\(CallResponse (m :: b) _) -> proc m)+    ]++-- | Invokes 'call' /out of band/, and returns an /async handle/.+--+-- See "Control.Distributed.Process.Platform.Async".+--+callAsync :: forall s a b . (Addressable s, Serializable a, Serializable b)+          => s -> a -> Process (Async b)+callAsync server msg = async $ call server msg++-- | Sends a /cast/ message to the server identified by @server@. The server+-- will not send a response. Like Cloud Haskell's 'send' primitive, cast is+-- fully asynchronous and /never fails/ - therefore 'cast'ing to a non-existent+-- (e.g., dead) server process will not generate an error.+--+cast :: forall a m . (Addressable a, Serializable m)+                 => a -> m -> Process ()+cast server msg = sendTo server ((CastMessage msg) :: T.Message m ())++-- | Sends a /channel/ message to the server and returns a @ReceivePort@ on+-- which the reponse can be delivered, if the server so chooses (i.e., the+-- might ignore the request or crash).+callChan :: forall s a b . (Addressable s, Serializable a, Serializable b)+         => s -> a -> Process (ReceivePort b)+callChan server msg = do+  (sp, rp) <- newChan+  sendTo server ((ChanMessage msg sp) :: T.Message a b)+  return rp++-- | A synchronous version of 'callChan'.+syncCallChan :: forall s a b . (Addressable s, Serializable a, Serializable b)+         => s -> a -> Process b+syncCallChan server msg = do+  r <- syncSafeCallChan server msg+  case r of+    Left e   -> die e+    Right r' -> return r'++-- | A safe version of 'syncCallChan', which returns @Left ExitReason@ if the+-- call fails.+syncSafeCallChan :: forall s a b . (Addressable s, Serializable a, Serializable b)+            => s -> a -> Process (Either ExitReason b)+syncSafeCallChan server msg = do+  rp <- callChan server msg+  awaitResponse server [ matchChan rp (return . Right) ]+
+ src/Control/Distributed/Process/Platform/ManagedProcess/Internal/GenProcess.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE PatternGuards              #-}++-- | This is the @Process@ implementation of a /managed process/+module Control.Distributed.Process.Platform.ManagedProcess.Internal.GenProcess+  (recvLoop, precvLoop) where++import Control.Applicative ((<$>))+import Control.Concurrent (threadDelay)+import Control.Concurrent.STM hiding (check)+import Control.Distributed.Process hiding (call, Message)+import qualified Control.Distributed.Process as P (Message)+import Control.Distributed.Process.Platform.ManagedProcess.Server+import Control.Distributed.Process.Platform.ManagedProcess.Internal.Types+import Control.Distributed.Process.Platform.Internal.Queue.PriorityQ+  ( PriorityQ+  , enqueue+  , dequeue+  )+import qualified Control.Distributed.Process.Platform.Internal.Queue.PriorityQ as PriorityQ+  ( empty+  )+import Control.Distributed.Process.Platform.Internal.Types+  ( ExitReason(..)+  , Shutdown(..)+  )+import qualified Control.Distributed.Process.Platform.Service.SystemLog as Log+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Platform.Timer+  ( cancelTimer+  , runAfter+  , TimerRef+  )+import Control.Monad (void)+import Prelude hiding (init)++--------------------------------------------------------------------------------+-- Priority Mailbox Handling                                                  --+--------------------------------------------------------------------------------++type Queue = PriorityQ Int P.Message+type TimeoutSpec = (Delay, Maybe (TimerRef, (STM ())))+data TimeoutAction s = Stop s ExitReason | Go Delay s++precvLoop :: PrioritisedProcessDefinition s -> s -> Delay -> Process ExitReason+precvLoop ppDef pState recvDelay = do+    void $ verify $ processDef ppDef+    tref <- startTimer recvDelay+    recvQueue ppDef pState tref $ PriorityQ.empty+  where+    verify pDef = mapM_ disallowCC $ apiHandlers pDef++    disallowCC (DispatchCC _ _) = die $ ExitOther "IllegalControlChannel"+    disallowCC _                = return ()++recvQueue :: PrioritisedProcessDefinition s+          -> s+          -> TimeoutSpec+          -> Queue+          -> Process ExitReason+recvQueue p s t q =+  let pDef = processDef p+      ps   = priorities p+  in do (ac, d, q') <- catchExit (processNext pDef ps s t q)+                                 (\_ (r :: ExitReason) ->+                                   return (ProcessStop r, Infinity, q))+        nextAction ac d q'+  where+    nextAction ac d q'+      | ProcessContinue  s'    <- ac = recvQueueAux p (priorities p) s' d  q'+      | ProcessTimeout   t' s' <- ac = recvQueueAux p (priorities p) s' t' q'+      | ProcessHibernate d' s' <- ac = block d' >> recvQueueAux p (priorities p) s' d q'+      | ProcessStop      r     <- ac = (shutdownHandler $ processDef p) s r >> return r+      | ProcessStopping  s' r  <- ac = (shutdownHandler $ processDef p) s' r >> return r+      | otherwise {- compiler foo -} = die "IllegalState"++    recvQueueAux ppDef prioritizers pState delay queue =+      let ex = (trapExit:(exitHandlers $ processDef ppDef))+          eh = map (\d' -> (dispatchExit d') pState) ex+      in (do t' <- startTimer delay+             mq <- drainMessageQueue pState prioritizers queue+             recvQueue ppDef pState t' mq)+         `catchExit`+         (\pid (reason :: ExitReason) -> do+             let pd = processDef ppDef+             let ps = pState+             let pq = queue+             let em = unsafeWrapMessage reason+             (a, d, q') <- findExitHandlerOrStop pd ps pq eh pid em+             nextAction a d q')++    findExitHandlerOrStop :: ProcessDefinition s+                          -> s+                          -> Queue+                          -> [ProcessId -> P.Message -> Process (Maybe (ProcessAction s))]+                          -> ProcessId+                          -> P.Message+                          -> Process (ProcessAction s, Delay, Queue)+    findExitHandlerOrStop _ _ pq [] _ er = do+      mEr <- unwrapMessage er :: Process (Maybe ExitReason)+      case mEr of+        Nothing -> die "InvalidExitHandler"  -- TODO: better error message?+        Just er' -> return (ProcessStop er', Infinity, pq)+    findExitHandlerOrStop pd ps pq (eh:ehs) pid er = do+      mAct <- eh pid er+      case mAct of+        Nothing -> findExitHandlerOrStop pd ps pq ehs pid er+        Just pa -> return (pa, Infinity, pq)++    processNext def ps' pState tSpec queue =+      let ex = (trapExit:(exitHandlers def))+          h  = timeoutHandler def in do+        -- as a side effect, this check will cancel the timer+        timedOut <- checkTimer pState tSpec h+        case timedOut of+          Stop s' r -> return $ (ProcessStopping s' r, (fst tSpec), queue)+          Go t' s'  -> do+            -- checkTimer could've run our timeoutHandler, which changes "s"+            case (dequeue queue) of+              Nothing -> do+                -- if the internal queue is empty, we fall back to reading the+                -- actual mailbox, however if /that/ times out, then we need+                -- to let the timeout handler kick in again and make a decision+                drainOrTimeout s' t' queue ps' h+              Just (m', q') -> do+                act <- catchesExit (processApply def s' m')+                                   (map (\d' -> (dispatchExit d') s') ex)+                return (act, t', q')++    processApply def pState msg =+      let pol          = unhandledMessagePolicy def+          apiMatchers  = map (dynHandleMessage pol pState) (apiHandlers def)+          infoMatchers = map (dynHandleMessage pol pState) (infoHandlers def)+          shutdown'    = dynHandleMessage pol pState shutdownHandler'+          ms'          = (shutdown':apiMatchers) ++ infoMatchers+      in processApplyAux ms' pol pState msg++    processApplyAux []     p' s' m' = applyPolicy p' s' m'+    processApplyAux (h:hs) p' s' m' = do+      attempt <- h m'+      case attempt of+        Nothing  -> processApplyAux hs p' s' m'+        Just act -> return act++    drainOrTimeout pState delay queue ps' h = do+      let matches = [ matchMessage return ]+          recv    = case delay of+                      Infinity -> receiveWait matches >>= return . Just+                      NoDelay  -> receiveTimeout 0 matches+                      Delay i  -> receiveTimeout (asTimeout i) matches in do+        r <- recv+        case r of+          Nothing -> h pState delay >>= \act -> return $ (act, delay, queue)+          Just m  -> do+            queue' <- enqueueMessage pState ps' m queue+            -- Returning @ProcessContinue@ simply causes the main loop to go+            -- into 'recvQueueAux', which ends up in 'drainMessageQueue'.+            -- In other words, we continue draining the /real/ mailbox.+            return $ (ProcessContinue pState, delay, queue')++drainMessageQueue :: s -> [DispatchPriority s] -> Queue -> Process Queue+drainMessageQueue pState priorities' queue = do+  m <- receiveTimeout 0 [ matchMessage return ]+  case m of+    Nothing -> return queue+    Just m' -> do+      queue' <- enqueueMessage pState priorities' m' queue+      drainMessageQueue pState priorities' queue'++enqueueMessage :: s+               -> [DispatchPriority s]+               -> P.Message+               -> Queue+               -> Process Queue+enqueueMessage _ []     m' q = return $ enqueue (-1 :: Int) m' q+enqueueMessage s (p:ps) m' q = let checkPrio = prioritise p s in do+  checkPrio m' >>= maybeEnqueue s m' q ps+  where+    maybeEnqueue :: s+                 -> P.Message+                 -> Queue+                 -> [DispatchPriority s]+                 -> Maybe (Int, P.Message)+                 -> Process Queue+    maybeEnqueue s' msg q' ps' Nothing       = enqueueMessage s' ps' msg q'+    maybeEnqueue _  _   q' _   (Just (i, m)) = return $ enqueue (i * (-1 :: Int)) m q'++--------------------------------------------------------------------------------+-- Ordinary/Blocking Mailbox Handling                                         --+--------------------------------------------------------------------------------++recvLoop :: ProcessDefinition s -> s -> Delay -> Process ExitReason+recvLoop pDef pState recvDelay =+  let p             = unhandledMessagePolicy pDef+      handleTimeout = timeoutHandler pDef+      handleStop    = shutdownHandler pDef+      shutdown'     = matchDispatch p pState shutdownHandler'+      matchers      = map (matchDispatch p pState) (apiHandlers pDef)+      ex'           = (trapExit:(exitHandlers pDef))+      ms' = (shutdown':matchers) ++ matchAux p pState (infoHandlers pDef)+  in do+    ac <- catchesExit (processReceive ms' handleTimeout pState recvDelay)+                      (map (\d' -> (dispatchExit d') pState) ex')+    case ac of+        (ProcessContinue s')     -> recvLoop pDef s' recvDelay+        (ProcessTimeout t' s')   -> recvLoop pDef s' t'+        (ProcessHibernate d' s') -> block d' >> recvLoop pDef s' recvDelay+        (ProcessStop r) -> handleStop pState r >> return (r :: ExitReason)+        (ProcessStopping s' r)   -> handleStop s' r >> return (r :: ExitReason)+  where+    matchAux :: UnhandledMessagePolicy+             -> s+             -> [DeferredDispatcher s]+             -> [Match (ProcessAction s)]+    matchAux p ps ds = [matchAny (auxHandler (applyPolicy p ps) ps ds)]++    auxHandler :: (P.Message -> Process (ProcessAction s))+               -> s+               -> [DeferredDispatcher s]+               -> P.Message+               -> Process (ProcessAction s)+    auxHandler policy _  [] msg = policy msg+    auxHandler policy st (d:ds :: [DeferredDispatcher s]) msg+      | length ds > 0  = let dh = dispatchInfo d in do+        -- NB: we *do not* want to terminate/dead-letter messages until+        -- we've exhausted all the possible info handlers+        m <- dh st msg+        case m of+          Nothing  -> auxHandler policy st ds msg+          Just act -> return act+        -- but here we *do* let the policy kick in+      | otherwise = let dh = dispatchInfo d in do+        m <- dh st msg+        case m of+          Nothing  -> policy msg+          Just act -> return act++    processReceive :: [Match (ProcessAction s)]+                   -> TimeoutHandler s+                   -> s+                   -> Delay+                   -> Process (ProcessAction s)+    processReceive ms handleTimeout st d = do+      next <- recv ms d+      case next of+        Nothing -> handleTimeout st d+        Just pa -> return pa++    recv :: [Match (ProcessAction s)]+         -> Delay+         -> Process (Maybe (ProcessAction s))+    recv matches d' =+      case d' of+        Infinity -> receiveWait matches >>= return . Just+        NoDelay  -> receiveTimeout 0 matches+        Delay t' -> receiveTimeout (asTimeout t') matches++--------------------------------------------------------------------------------+-- Simulated Receive Timeouts                                                 --+--------------------------------------------------------------------------------++startTimer :: Delay -> Process TimeoutSpec+startTimer d+  | Delay t <- d = do sig <- liftIO $ newEmptyTMVarIO+                      tref <- runAfter t $ liftIO $ atomically $ putTMVar sig ()+                      return (d, Just (tref, (readTMVar sig)))+  | otherwise    = return (d, Nothing)++checkTimer :: s+           -> TimeoutSpec+           -> TimeoutHandler s+           -> Process (TimeoutAction s)+checkTimer pState spec handler = let delay = fst spec in do+  timedOut <- pollTimer spec  -- this will cancel the timer+  case timedOut of+    False -> go spec pState+    True  -> do+      act <- handler pState delay+      case act of+        ProcessTimeout   t' s' -> return $ Go t' s'+        ProcessStop      r     -> return $ Stop pState r+        ProcessStopping  s' r  -> return $ Stop s' r+        ProcessHibernate d' s' -> block d' >> go spec s'+        ProcessContinue  s'    -> go spec s'+  where+    go d s = return $ Go (fst d) s++pollTimer :: TimeoutSpec -> Process Bool+pollTimer (_, Nothing         ) = return False+pollTimer (_, Just (tref, sig)) = do+  cancelTimer tref  -- cancelling a dead/completed timer is a no-op+  gotSignal <- liftIO $ atomically $ pollSTM sig+  return $ maybe False (const True) gotSignal+  where+    pollSTM :: (STM ()) -> STM (Maybe ())+    pollSTM sig' = (Just <$> sig') `orElse` return Nothing++--------------------------------------------------------------------------------+-- Utilities                                                                  --+--------------------------------------------------------------------------------++-- an explicit 'cast' giving 'Shutdown' will stop the server gracefully+shutdownHandler' :: Dispatcher s+shutdownHandler' = handleCast (\_ Shutdown -> stop $ ExitNormal)++-- @(ProcessExitException from ExitShutdown)@ will stop the server gracefully+trapExit :: ExitSignalDispatcher s+trapExit = handleExit (\_ _ (r :: ExitReason) -> stop r)++block :: TimeInterval -> Process ()+block i = liftIO $ threadDelay (asTimeout i)++applyPolicy :: UnhandledMessagePolicy+            -> s+            -> P.Message+            -> Process (ProcessAction s)+applyPolicy p s m =+  case p of+    Terminate      -> stop $ ExitOther "UnhandledInput"+    DeadLetter pid -> forward m pid >> continue s+    Drop           -> continue s+    Log            -> logIt >> continue s+  where+    logIt =+      Log.report Log.info Log.logChannel $ "Unhandled Gen Input Message: " ++ (show m)+
+ src/Control/Distributed/Process/Platform/ManagedProcess/Internal/Types.hs view
@@ -0,0 +1,413 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | Types used throughout the ManagedProcess framework+module Control.Distributed.Process.Platform.ManagedProcess.Internal.Types+  ( -- * Exported data types+    InitResult(..)+  , Condition(..)+  , ProcessAction(..)+  , ProcessReply(..)+  , CallHandler+  , CastHandler+  , DeferredCallHandler+  , StatelessCallHandler+  , InfoHandler+  , ChannelHandler+  , StatelessChannelHandler+  , InitHandler+  , ShutdownHandler+  , TimeoutHandler+  , UnhandledMessagePolicy(..)+  , ProcessDefinition(..)+  , Priority(..)+  , DispatchPriority(..)+  , PrioritisedProcessDefinition(..)+  , RecvTimeoutPolicy(..)+  , ControlChannel(..)+  , newControlChan+  , ControlPort(..)+  , channelControlPort+  , Dispatcher(..)+  , DeferredDispatcher(..)+  , ExitSignalDispatcher(..)+  , MessageMatcher(..)+  , DynMessageHandler(..)+  , Message(..)+  , CallResponse(..)+  , CallId+  , CallRef(..)+  , makeRef+  , initCall+  , unsafeInitCall+  , waitResponse+  ) where++import Control.Distributed.Process hiding (Message)+import qualified Control.Distributed.Process as P (Message)+import Control.Distributed.Process.Serializable+import Control.Distributed.Process.Platform.Internal.Types+  ( Recipient(..)+  , ExitReason(..)+  , Addressable+  , Resolvable(..)+  , Routable(..)+  , NFSerializable+  , resolveOrDie+  )+import Control.Distributed.Process.Platform.Time+import Control.DeepSeq (NFData)+import Data.Binary hiding (decode)+import Data.Typeable (Typeable)++import Prelude hiding (init)++import GHC.Generics++--------------------------------------------------------------------------------+-- API                                                                        --+--------------------------------------------------------------------------------++type CallId = MonitorRef++newtype CallRef a = CallRef { unCaller :: (Recipient, CallId) }+  deriving (Eq, Show, Typeable, Generic)+instance Serializable a => Binary (CallRef a) where+instance NFData a => NFData (CallRef a) where++makeRef :: forall a . (Serializable a) => Recipient -> CallId -> CallRef a+makeRef r c = CallRef (r, c)++instance Resolvable (CallRef a) where+  resolve (CallRef (r, _)) = resolve r++instance Routable (CallRef a) where+  sendTo  (CallRef (client, tag)) msg = sendTo client (CallResponse msg tag)+  unsafeSendTo (CallRef (c, tag)) msg = unsafeSendTo c (CallResponse msg tag)++data Message a b =+    CastMessage a+  | CallMessage a (CallRef b)+  | ChanMessage a (SendPort b)+  deriving (Typeable, Generic)++instance (Serializable a, Serializable b) => Binary (Message a b) where+instance (NFSerializable a, NFSerializable b) => NFData (Message a b) where+deriving instance (Eq a, Eq b) => Eq (Message a b)+deriving instance (Show a, Show b) => Show (Message a b)++data CallResponse a = CallResponse a CallId+  deriving (Typeable, Generic)++instance Serializable a => Binary (CallResponse a)+instance NFSerializable a => NFData (CallResponse a)+deriving instance Eq a => Eq (CallResponse a)+deriving instance Show a => Show (CallResponse a)++-- | Return type for and 'InitHandler' expression.+data InitResult s =+    InitOk s Delay {-+        ^ a successful initialisation, initial state and timeout -}+  | InitStop String {-+        ^ failed initialisation and the reason, this will result in an error -}+  | InitIgnore {-+        ^ the process has decided not to continue starting - this is not an error -}+  deriving (Typeable)++-- | The action taken by a process after a handler has run and its updated state.+-- See 'continue'+--     'timeoutAfter'+--     'hibernate'+--     'stop'+--     'stopWith'+--+data ProcessAction s =+    ProcessContinue  s              -- ^ continue with (possibly new) state+  | ProcessTimeout   Delay        s -- ^ timeout if no messages are received+  | ProcessHibernate TimeInterval s -- ^ hibernate for /delay/+  | ProcessStop      ExitReason     -- ^ stop the process, giving @ExitReason@+  | ProcessStopping  s ExitReason   -- ^ stop the process with @ExitReason@, with updated state++-- | Returned from handlers for the synchronous 'call' protocol, encapsulates+-- the reply data /and/ the action to take after sending the reply. A handler+-- can return @NoReply@ if they wish to ignore the call.+data ProcessReply r s =+    ProcessReply r (ProcessAction s)+  | NoReply (ProcessAction s)++-- | Wraps a predicate that is used to determine whether or not a handler+-- is valid based on some combination of the current process state, the+-- type and/or value of the input message or both.+data Condition s m =+    Condition (s -> m -> Bool)  -- ^ predicated on the process state /and/ the message+  | State     (s -> Bool)       -- ^ predicated on the process state only+  | Input     (m -> Bool)       -- ^ predicated on the input message only++-- | An expression used to handle a /call/ message.+type CallHandler s a b = s -> a -> Process (ProcessReply b s)++-- | An expression used to handle a /call/ message where the reply is deferred+-- via the 'CallRef'.+type DeferredCallHandler s a b = s -> CallRef b -> a -> Process (ProcessReply b s)++-- | An expression used to handle a /call/ message in a stateless process.+type StatelessCallHandler a b = a -> CallRef b -> Process (ProcessReply b ())++-- | An expression used to handle a /cast/ message.+type CastHandler s a = s -> a -> Process (ProcessAction s)++-- | An expression used to handle an /info/ message.+type InfoHandler s a = s -> a -> Process (ProcessAction s)++-- | An expression used to handle a /channel/ message.+type ChannelHandler s a b = s -> SendPort b -> a -> Process (ProcessAction s)++-- | An expression used to handle a /channel/ message in a stateless process.+type StatelessChannelHandler a b = SendPort b -> a -> Process (ProcessAction ())++-- | An expression used to initialise a process with its state.+type InitHandler a s = a -> Process (InitResult s)++-- | An expression used to handle process termination.+type ShutdownHandler s = s -> ExitReason -> Process ()++-- | An expression used to handle process timeouts.+type TimeoutHandler s = s -> Delay -> Process (ProcessAction s)++-- dispatching to implementation callbacks++-- TODO: Now that we've got matchSTM available, we can have two kinds of CC.+-- The easiest approach would be to add an StmControlChannel newtype, since+-- that can't be Serializable (and will have to rely on PCopy for delivery).+-- Rather than write stmChanServe in terms of creating that channel object+-- ourselves (which is necessary for the TypedChannel based approach we+-- currently offer), I think it should accept the (STM a) "read" action and+-- leave the PCopy based delivery nonsense to the user, since we don't want+-- to /encourage/ that sort of thing outside of this codebase.++{-++data InputChannelDispatcher =+  InputChannelDispatcher { chan :: InputChannel s+                         , dispatch :: s -> Message a b -> Process (ProcessAction s)+                         }++instance MessageMatcher Dispatcher where+  matchDispatch _ _ (DispatchInputChannelDispatcher c d) = matchInputChan (d s)+-}++-- | Provides a means for servers to listen on a separate, typed /control/+-- channel, thereby segregating the channel from their regular+-- (and potentially busy) mailbox.+newtype ControlChannel m =+  ControlChannel {+      unControl :: (SendPort (Message m ()), ReceivePort (Message m ()))+    }++-- | Creates a new 'ControlChannel'.+newControlChan :: (Serializable m) => Process (ControlChannel m)+newControlChan = newChan >>= return . ControlChannel++-- | The writable end of a 'ControlChannel'.+--+newtype ControlPort m =+  ControlPort {+      unPort :: SendPort (Message m ())+    } deriving (Show)+deriving instance (Serializable m) => Binary (ControlPort m)+instance Eq (ControlPort m) where+  a == b = unPort a == unPort b++-- | Obtain an opaque expression for communicating with a 'ControlChannel'.+--+channelControlPort :: (Serializable m)+                   => ControlChannel m+                   -> ControlPort m+channelControlPort cc = ControlPort $ fst $ unControl cc++-- | Provides dispatch from cast and call messages to a typed handler.+data Dispatcher s =+    forall a b . (Serializable a, Serializable b) =>+    Dispatch+    {+      dispatch :: s -> Message a b -> Process (ProcessAction s)+    }+  | forall a b . (Serializable a, Serializable b) =>+    DispatchIf+    {+      dispatch   :: s -> Message a b -> Process (ProcessAction s)+    , dispatchIf :: s -> Message a b -> Bool+    }+  | forall a b . (Serializable a, Serializable b) =>+    DispatchCC  -- control channel dispatch+    {+      channel  :: ReceivePort (Message a b)+    , dispatch :: s -> Message a b -> Process (ProcessAction s)+    }++-- | Provides dispatch for any input, returns 'Nothing' for unhandled messages.+data DeferredDispatcher s =+  DeferredDispatcher+  {+    dispatchInfo :: s+                 -> P.Message+                 -> Process (Maybe (ProcessAction s))+  }++-- | Provides dispatch for any exit signal - returns 'Nothing' for unhandled exceptions+data ExitSignalDispatcher s =+  ExitSignalDispatcher+  {+    dispatchExit :: s+                 -> ProcessId+                 -> P.Message+                 -> Process (Maybe (ProcessAction s))+  }++class MessageMatcher d where+  matchDispatch :: UnhandledMessagePolicy -> s -> d s -> Match (ProcessAction s)++instance MessageMatcher Dispatcher where+  matchDispatch _ s (Dispatch   d)      = match (d s)+  matchDispatch _ s (DispatchIf d cond) = matchIf (cond s) (d s)+  matchDispatch _ s (DispatchCC c d)    = matchChan c (d s)++class DynMessageHandler d where+  dynHandleMessage :: UnhandledMessagePolicy+                   -> s+                   -> d s+                   -> P.Message+                   -> Process (Maybe (ProcessAction s))++instance DynMessageHandler Dispatcher where+  dynHandleMessage _ s (Dispatch   d)   msg = handleMessage   msg (d s)+  dynHandleMessage _ s (DispatchIf d c) msg = handleMessageIf msg (c s) (d s)+  dynHandleMessage _ _ (DispatchCC _ _) _   = error "ThisCanNeverHappen"++instance DynMessageHandler DeferredDispatcher where+  dynHandleMessage _ s (DeferredDispatcher d) = d s++newtype Priority a = Priority { getPrio :: Int }++data DispatchPriority s =+    PrioritiseCall+    {+      prioritise :: s -> P.Message -> Process (Maybe (Int, P.Message))+    }+  | PrioritiseCast+    {+      prioritise :: s -> P.Message -> Process (Maybe (Int, P.Message))+    }+  | PrioritiseInfo+    {+      prioritise :: s -> P.Message -> Process (Maybe (Int, P.Message))+    }++-- | For a 'PrioritisedProcessDefinition', this policy determines for how long+-- the /receive loop/ should continue draining the process' mailbox before+-- processing its received mail (in priority order).+--+-- If a prioritised /managed process/ is receiving a lot of messages (into its+-- /real/ mailbox), the server might never get around to actually processing its+-- inputs. This (mandatory) policy provides a guarantee that eventually (i.e.,+-- after a specified number of received messages or time interval), the server+-- will stop removing messages from its mailbox and process those it has already+-- received.+--+data RecvTimeoutPolicy = RecvCounter Int | RecvTimer TimeInterval+  deriving (Typeable)++-- | A @ProcessDefinition@ decorated with @DispatchPriority@ for certain+-- input domains.+data PrioritisedProcessDefinition s =+  PrioritisedProcessDefinition+  {+    processDef  :: ProcessDefinition s+  , priorities  :: [DispatchPriority s]+  , recvTimeout :: RecvTimeoutPolicy+  }++-- | Policy for handling unexpected messages, i.e., messages which are not+-- sent using the 'call' or 'cast' APIs, and which are not handled by any of the+-- 'handleInfo' handlers.+data UnhandledMessagePolicy =+    Terminate  -- ^ stop immediately, giving @ExitOther "UnhandledInput"@ as the reason+  | DeadLetter ProcessId -- ^ forward the message to the given recipient+  | Log                  -- ^ log messages, then behave identically to @Drop@+  | Drop                 -- ^ dequeue and then drop/ignore the message++-- | Stores the functions that determine runtime behaviour in response to+-- incoming messages and a policy for responding to unhandled messages.+data ProcessDefinition s = ProcessDefinition {+    apiHandlers  :: [Dispatcher s]     -- ^ functions that handle call/cast messages+  , infoHandlers :: [DeferredDispatcher s] -- ^ functions that handle non call/cast messages+  , exitHandlers :: [ExitSignalDispatcher s] -- ^ functions that handle exit signals+  , timeoutHandler :: TimeoutHandler s   -- ^ a function that handles timeouts+  , shutdownHandler :: ShutdownHandler s -- ^ a function that is run just before the process exits+  , unhandledMessagePolicy :: UnhandledMessagePolicy -- ^ how to deal with unhandled messages+  }++-- note [rpc calls]+-- One problem with using plain expect/receive primitives to perform a+-- synchronous (round trip) call is that a reply matching the expected type+-- could come from anywhere! The Call.hs module uses a unique integer tag to+-- distinguish between inputs but this is easy to forge, and forces all callers+-- to maintain a tag pool, which is quite onerous.+--+-- Here, we use a private (internal) tag based on a 'MonitorRef', which is+-- guaranteed to be unique per calling process (in the absence of mallicious+-- peers). This is handled throughout the roundtrip, such that the reply will+-- either contain the CallId (i.e., the ame 'MonitorRef' with which we're+-- tracking the server process) or we'll see the server die.+--+-- Of course, the downside to all this is that the monitoring and receiving+-- clutters up your mailbox, and if your mailbox is extremely full, could+-- incur delays in delivery. The callAsync function provides a neat+-- work-around for that, relying on the insulation provided by Async.++-- TODO: Generify this /call/ API and use it in Call.hs to avoid tagging++-- TODO: the code below should be moved elsewhere. Maybe to Client.hs?+initCall :: forall s a b . (Addressable s, Serializable a, Serializable b)+         => s -> a -> Process (CallRef b)+initCall sid msg = do+  pid <- resolveOrDie sid "initCall: unresolveable address "+  mRef <- monitor pid+  self <- getSelfPid+  let cRef = makeRef (Pid self) mRef in do+    sendTo pid (CallMessage msg cRef :: Message a b)+    return cRef++unsafeInitCall :: forall s a b . (Addressable s,+                                  NFSerializable a, NFSerializable b)+         => s -> a -> Process (CallRef b)+unsafeInitCall sid msg = do+  pid <- resolveOrDie sid "unsafeInitCall: unresolveable address "+  mRef <- monitor pid+  self <- getSelfPid+  let cRef = makeRef (Pid self) mRef in do+    unsafeSendTo pid (CallMessage msg cRef  :: Message a b)+    return cRef++waitResponse :: forall b. (Serializable b)+             => Maybe TimeInterval+             -> CallRef b+             -> Process (Maybe (Either ExitReason b))+waitResponse mTimeout cRef =+  let (_, mRef) = unCaller cRef+      matchers  = [ matchIf (\((CallResponse _ ref) :: CallResponse b) -> ref == mRef)+                            (\((CallResponse m _) :: CallResponse b) -> return (Right m))+                  , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef)+                      (\(ProcessMonitorNotification _ _ r) -> return (Left (err r)))+                  ]+      err r     = ExitOther $ show r in+    case mTimeout of+      (Just ti) -> finally (receiveTimeout (asTimeout ti) matchers) (unmonitor mRef)+      Nothing   -> finally (receiveWait matchers >>= return . Just) (unmonitor mRef)+
+ src/Control/Distributed/Process/Platform/ManagedProcess/Server.hs view
@@ -0,0 +1,600 @@+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE ScopedTypeVariables        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.ManagedProcess.Server+-- Copyright   :  (c) Tim Watson 2012 - 2013+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- The Server Portion of the /Managed Process/ API.+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.ManagedProcess.Server+  ( -- * Server actions+    condition+  , state+  , input+  , reply+  , replyWith+  , noReply+  , continue+  , timeoutAfter+  , hibernate+  , stop+  , stopWith+  , replyTo+  , replyChan+    -- * Stateless actions+  , noReply_+  , haltNoReply_+  , continue_+  , timeoutAfter_+  , hibernate_+  , stop_+    -- * Server handler/callback creation+  , handleCall+  , handleCallIf+  , handleCallFrom+  , handleCallFromIf+  , handleRpcChan+  , handleRpcChanIf+  , handleCast+  , handleCastIf+  , handleInfo+  , handleRaw+  , handleDispatch+  , handleDispatchIf+  , handleExit+  , handleExitIf+    -- * Stateless handlers+  , action+  , handleCall_+  , handleCallIf_+  , handleCallFrom_+  , handleCallFromIf_+  , handleRpcChan_+  , handleRpcChanIf_+  , handleCast_+  , handleCastIf_+    -- * Working with Control Channels+  , handleControlChan+  , handleControlChan_+  ) where++import Control.Distributed.Process hiding (call, Message)+import qualified Control.Distributed.Process as P (Message)+import Control.Distributed.Process.Serializable+import Control.Distributed.Process.Platform.ManagedProcess.Internal.Types+import Control.Distributed.Process.Platform.Internal.Types+  ( ExitReason(..)+  , Routable(..)+  )+import Control.Distributed.Process.Platform.Time+import Prelude hiding (init)++--------------------------------------------------------------------------------+-- Producing ProcessAction and ProcessReply from inside handler expressions   --+--------------------------------------------------------------------------------++-- | Creates a 'Condition' from a function that takes a process state @a@ and+-- an input message @b@ and returns a 'Bool' indicating whether the associated+-- handler should run.+--+condition :: forall a b. (Serializable a, Serializable b)+          => (a -> b -> Bool)+          -> Condition a b+condition = Condition++-- | Create a 'Condition' from a function that takes a process state @a@ and+-- returns a 'Bool' indicating whether the associated handler should run.+--+state :: forall s m. (Serializable m) => (s -> Bool) -> Condition s m+state = State++-- | Creates a 'Condition' from a function that takes an input message @m@ and+-- returns a 'Bool' indicating whether the associated handler should run.+--+input :: forall s m. (Serializable m) => (m -> Bool) -> Condition s m+input = Input++-- | Instructs the process to send a reply and continue running.+reply :: (Serializable r) => r -> s -> Process (ProcessReply r s)+reply r s = continue s >>= replyWith r++-- | Instructs the process to send a reply /and/ evaluate the 'ProcessAction'.+replyWith :: (Serializable r)+          => r+          -> ProcessAction s+          -> Process (ProcessReply r s)+replyWith r s = return $ ProcessReply r s++-- | Instructs the process to skip sending a reply /and/ evaluate a 'ProcessAction'+noReply :: (Serializable r) => ProcessAction s -> Process (ProcessReply r s)+noReply = return . NoReply++-- | Continue without giving a reply to the caller - equivalent to 'continue',+-- but usable in a callback passed to the 'handleCall' family of functions.+noReply_ :: forall s r . (Serializable r) => s -> Process (ProcessReply r s)+noReply_ s = continue s >>= noReply++-- | Halt process execution during a call handler, without paying any attention+-- to the expected return type.+haltNoReply_ :: Serializable r => ExitReason -> Process (ProcessReply r s)+haltNoReply_ r = stop r >>= noReply++-- | Instructs the process to continue running and receiving messages.+continue :: s -> Process (ProcessAction s)+continue = return . ProcessContinue++-- | Version of 'continue' that can be used in handlers that ignore process state.+--+continue_ :: (s -> Process (ProcessAction s))+continue_ = return . ProcessContinue++-- | Instructs the process loop to wait for incoming messages until 'Delay'+-- is exceeded. If no messages are handled during this period, the /timeout/+-- handler will be called. Note that this alters the process timeout permanently+-- such that the given @Delay@ will remain in use until changed.+timeoutAfter :: Delay -> s -> Process (ProcessAction s)+timeoutAfter d s = return $ ProcessTimeout d s++-- | Version of 'timeoutAfter' that can be used in handlers that ignore process state.+--+-- > action (\(TimeoutPlease duration) -> timeoutAfter_ duration)+--+timeoutAfter_ :: Delay -> (s -> Process (ProcessAction s))+timeoutAfter_ d = return . ProcessTimeout d++-- | Instructs the process to /hibernate/ for the given 'TimeInterval'. Note+-- that no messages will be removed from the mailbox until after hibernation has+-- ceased. This is equivalent to calling @threadDelay@.+--+hibernate :: TimeInterval -> s -> Process (ProcessAction s)+hibernate d s = return $ ProcessHibernate d s++-- | Version of 'hibernate' that can be used in handlers that ignore process state.+--+-- > action (\(HibernatePlease delay) -> hibernate_ delay)+--+hibernate_ :: TimeInterval -> (s -> Process (ProcessAction s))+hibernate_ d = return . ProcessHibernate d++-- | Instructs the process to terminate, giving the supplied reason. If a valid+-- 'shutdownHandler' is installed, it will be called with the 'ExitReason'+-- returned from this call, along with the process state.+stop :: ExitReason -> Process (ProcessAction s)+stop r = return $ ProcessStop r++-- | As 'stop', but provides an updated state for the shutdown handler.+stopWith :: s -> ExitReason -> Process (ProcessAction s)+stopWith s r = return $ ProcessStopping s r++-- | Version of 'stop' that can be used in handlers that ignore process state.+--+-- > action (\ClientError -> stop_ ExitNormal)+--+stop_ :: ExitReason -> (s -> Process (ProcessAction s))+stop_ r _ = stop r++-- | Sends a reply explicitly to a caller.+--+-- > replyTo = sendTo+--+replyTo :: (Serializable m) => CallRef m -> m -> Process ()+replyTo = sendTo++-- | Sends a reply to a 'SendPort' (for use in 'handleRpcChan' et al).+--+-- > replyChan = sendChan+--+replyChan :: (Serializable m) => SendPort m -> m -> Process ()+replyChan = sendChan++--------------------------------------------------------------------------------+-- Wrapping handler expressions in Dispatcher and DeferredDispatcher          --+--------------------------------------------------------------------------------++-- | Constructs a 'call' handler from a function in the 'Process' monad.+-- The handler expression returns the reply, and the action will be+-- set to 'continue'.+--+-- > handleCall_ = handleCallIf_ $ input (const True)+--+handleCall_ :: (Serializable a, Serializable b)+           => (a -> Process b)+           -> Dispatcher s+handleCall_ = handleCallIf_ $ input (const True)++-- | Constructs a 'call' handler from an ordinary function in the 'Process'+-- monad. This variant ignores the state argument present in 'handleCall' and+-- 'handleCallIf' and is therefore useful in a stateless server. Messges are+-- only dispatched to the handler if the supplied condition evaluates to @True@+--+-- See 'handleCall'+handleCallIf_ :: forall s a b . (Serializable a, Serializable b)+    => Condition s a -- ^ predicate that must be satisfied for the handler to run+    -> (a -> Process b) -- ^ a function from an input message to a reply+    -> Dispatcher s+handleCallIf_ cond handler+  = DispatchIf {+      dispatch   = doHandle handler+    , dispatchIf = checkCall cond+    }+  where doHandle :: (Serializable a, Serializable b)+                 => (a -> Process b)+                 -> s+                 -> Message a b+                 -> Process (ProcessAction s)+        doHandle h s (CallMessage p c) = (h p) >>= mkCallReply c s+        doHandle _ _ _ = die "CALL_HANDLER_TYPE_MISMATCH" -- note [Message type]++        -- handling 'reply-to' in the main process loop is awkward at best,+        -- so we handle it here instead and return the 'action' to the loop+        mkCallReply :: (Serializable b)+                    => CallRef b+                    -> s+                    -> b+                    -> Process (ProcessAction s)+        mkCallReply c s m =+          let (c', t) = unCaller c+          in sendTo c' (CallResponse m t) >> continue s++-- | Constructs a 'call' handler from a function in the 'Process' monad.+-- > handleCall = handleCallIf (const True)+--+handleCall :: (Serializable a, Serializable b)+           => (s -> a -> Process (ProcessReply b s))+           -> Dispatcher s+handleCall = handleCallIf $ state (const True)++-- | Constructs a 'call' handler from an ordinary function in the 'Process'+-- monad. Given a function @f :: (s -> a -> Process (ProcessReply b s))@,+-- the expression @handleCall f@ will yield a 'Dispatcher' for inclusion+-- in a 'Behaviour' specification for the /GenProcess/. Messages are only+-- dispatched to the handler if the supplied condition evaluates to @True@.+--+handleCallIf :: forall s a b . (Serializable a, Serializable b)+    => Condition s a -- ^ predicate that must be satisfied for the handler to run+    -> (s -> a -> Process (ProcessReply b s))+        -- ^ a reply yielding function over the process state and input message+    -> Dispatcher s+handleCallIf cond handler+  = DispatchIf {+      dispatch   = doHandle handler+    , dispatchIf = checkCall cond+    }+  where doHandle :: (Serializable a, Serializable b)+                 => (s -> a -> Process (ProcessReply b s))+                 -> s+                 -> Message a b+                 -> Process (ProcessAction s)+        doHandle h s (CallMessage p c) = (h s p) >>= mkReply c+        doHandle _ _ _ = die "CALL_HANDLER_TYPE_MISMATCH" -- note [Message type]++-- | A variant of 'handleCallFrom_' that ignores the state argument.+--+handleCallFrom_ :: forall s a b . (Serializable a, Serializable b)+                => (CallRef b -> a -> Process (ProcessReply b s))+                -> Dispatcher s+handleCallFrom_ = handleCallFromIf_ $ input (const True)++-- | A variant of 'handleCallFromIf' that ignores the state argument.+--+handleCallFromIf_ :: forall s a b . (Serializable a, Serializable b)+                  => (Condition s a)+                  -> (CallRef b -> a -> Process (ProcessReply b s))+                  -> Dispatcher s+handleCallFromIf_ c h =+  DispatchIf {+      dispatch   = doHandle h+    , dispatchIf = checkCall c+    }+  where doHandle :: (Serializable a, Serializable b)+                 => (CallRef b -> a -> Process (ProcessReply b s))+                 -> s+                 -> Message a b+                 -> Process (ProcessAction s)+        doHandle h' _ (CallMessage p c') = (h' c' p) >>= mkReply c'+        doHandle _  _ _ = die "CALL_HANDLER_TYPE_MISMATCH" -- note [Message type]++-- | As 'handleCall' but passes the 'CallRef' to the handler function.+-- This can be useful if you wish to /reply later/ to the caller by, e.g.,+-- spawning a process to do some work and have it @replyTo caller response@+-- out of band. In this case the callback can pass the 'CallRef' to the+-- worker (or stash it away itself) and return 'noReply'.+--+handleCallFrom :: forall s a b . (Serializable a, Serializable b)+           => (s -> CallRef b -> a -> Process (ProcessReply b s))+           -> Dispatcher s+handleCallFrom = handleCallFromIf $ state (const True)++-- | As 'handleCallFrom' but only runs the handler if the supplied 'Condition'+-- evaluates to @True@.+--+handleCallFromIf :: forall s a b . (Serializable a, Serializable b)+    => Condition s a -- ^ predicate that must be satisfied for the handler to run+    -> (s -> CallRef b -> a -> Process (ProcessReply b s))+        -- ^ a reply yielding function over the process state, sender and input message+    -> Dispatcher s+handleCallFromIf cond handler+  = DispatchIf {+      dispatch   = doHandle handler+    , dispatchIf = checkCall cond+    }+  where doHandle :: (Serializable a, Serializable b)+                 => (s -> CallRef b -> a -> Process (ProcessReply b s))+                 -> s+                 -> Message a b+                 -> Process (ProcessAction s)+        doHandle h s (CallMessage p c) = (h s c p) >>= mkReply c+        doHandle _ _ _ = die "CALL_HANDLER_TYPE_MISMATCH" -- note [Message type]++-- | Creates a handler for a /typed channel/ RPC style interaction. The+-- handler takes a @SendPort b@ to reply to, the initial input and evaluates+-- to a 'ProcessAction'. It is the handler code's responsibility to send the+-- reply to the @SendPort@.+--+handleRpcChan :: forall s a b . (Serializable a, Serializable b)+              => (s -> SendPort b -> a -> Process (ProcessAction s))+              -> Dispatcher s+handleRpcChan = handleRpcChanIf $ input (const True)++-- | As 'handleRpcChan', but only evaluates the handler if the supplied+-- condition is met.+--+handleRpcChanIf :: forall s a b . (Serializable a, Serializable b)+                => Condition s a+                -> (s -> SendPort b -> a -> Process (ProcessAction s))+                -> Dispatcher s+handleRpcChanIf c h+  = DispatchIf {+      dispatch   = doHandle h+    , dispatchIf = checkRpc c+    }+  where doHandle :: (Serializable a, Serializable b)+                 => (s -> SendPort b -> a -> Process (ProcessAction s))+                 -> s+                 -> Message a b+                 -> Process (ProcessAction s)+        doHandle h' s (ChanMessage p c') = h' s c' p+        doHandle _  _ _ = die "RPC_HANDLER_TYPE_MISMATCH" -- node [Message type]++-- | A variant of 'handleRpcChan' that ignores the state argument.+--+handleRpcChan_ :: forall a b . (Serializable a, Serializable b)+                  => (SendPort b -> a -> Process (ProcessAction ()))+                  -> Dispatcher ()+handleRpcChan_ h = handleRpcChan (\() -> h)++-- | A variant of 'handleRpcChanIf' that ignores the state argument.+--+handleRpcChanIf_ :: forall a b . (Serializable a, Serializable b)+                 => Condition () a+                 -> (SendPort b -> a -> Process (ProcessAction ()))+                 -> Dispatcher ()+handleRpcChanIf_ c h = handleRpcChanIf c (\() -> h)++-- | Constructs a 'cast' handler from an ordinary function in the 'Process'+-- monad.+-- > handleCast = handleCastIf (const True)+--+handleCast :: (Serializable a)+           => (s -> a -> Process (ProcessAction s))+           -> Dispatcher s+handleCast = handleCastIf $ input (const True)++-- | Constructs a 'cast' handler from an ordinary function in the 'Process'+-- monad. Given a function @f :: (s -> a -> Process (ProcessAction s))@,+-- the expression @handleCall f@ will yield a 'Dispatcher' for inclusion+-- in a 'Behaviour' specification for the /GenProcess/.+--+handleCastIf :: forall s a . (Serializable a)+    => Condition s a -- ^ predicate that must be satisfied for the handler to run+    -> (s -> a -> Process (ProcessAction s))+       -- ^ an action yielding function over the process state and input message+    -> Dispatcher s+handleCastIf cond h+  = DispatchIf {+      dispatch   = (\s ((CastMessage p) :: Message a ()) -> h s p)+    , dispatchIf = checkCast cond+    }++-- | Constructs a /control channel/ handler from a function in the+-- 'Process' monad. The handler expression returns no reply, and the+-- /control message/ is treated in the same fashion as a 'cast'.+--+-- > handleControlChan = handleControlChanIf $ input (const True)+--+handleControlChan :: forall s a . (Serializable a)+    => ControlChannel a -- ^ the receiving end of the control channel+    -> (s -> a -> Process (ProcessAction s))+       -- ^ an action yielding function over the process state and input message+    -> Dispatcher s+handleControlChan chan h+  = DispatchCC { channel  = snd $ unControl chan+               , dispatch = (\s ((CastMessage p) :: Message a ()) -> h s p)+               }++-- | Version of 'handleControlChan' that ignores the server state.+--+handleControlChan_ :: forall s a. (Serializable a)+           => ControlChannel a+           -> (a -> (s -> Process (ProcessAction s)))+           -> Dispatcher s+handleControlChan_ chan h+  = DispatchCC { channel    = snd $ unControl chan+               , dispatch   = (\s ((CastMessage p) :: Message a ()) -> h p $ s)+               }++-- | Version of 'handleCast' that ignores the server state.+--+handleCast_ :: (Serializable a)+            => (a -> (s -> Process (ProcessAction s))) -> Dispatcher s+handleCast_ = handleCastIf_ $ input (const True)++-- | Version of 'handleCastIf' that ignores the server state.+--+handleCastIf_ :: forall s a . (Serializable a)+    => Condition s a -- ^ predicate that must be satisfied for the handler to run+    -> (a -> (s -> Process (ProcessAction s)))+        -- ^ a function from the input message to a /stateless action/, cf 'continue_'+    -> Dispatcher s+handleCastIf_ cond h+  = DispatchIf { dispatch   = (\s ((CastMessage p) :: Message a ()) -> h p $ s)+               , dispatchIf = checkCast cond+               }++-- | Constructs an /action/ handler. Like 'handleDispatch' this can handle both+-- 'cast' and 'call' messages, but you won't know which you're dealing with.+-- This can be useful where certain inputs require a definite action, such as+-- stopping the server, without concern for the state (e.g., when stopping we+-- need only decide to stop, as the terminate handler can deal with state+-- cleanup etc). For example:+--+-- @action (\MyCriticalSignal -> stop_ ExitNormal)@+--+action :: forall s a . (Serializable a)+    => (a -> (s -> Process (ProcessAction s)))+          -- ^ a function from the input message to a /stateless action/, cf 'continue_'+    -> Dispatcher s+action h = handleDispatch perform+  where perform :: (s -> a -> Process (ProcessAction s))+        perform s a = let f = h a in f s++-- | Constructs a handler for both /call/ and /cast/ messages.+-- @handleDispatch = handleDispatchIf (const True)@+--+handleDispatch :: forall s a . (Serializable a)+               => (s -> a -> Process (ProcessAction s))+               -> Dispatcher s+handleDispatch = handleDispatchIf $ input (const True)++-- | Constructs a handler for both /call/ and /cast/ messages. Messages are only+-- dispatched to the handler if the supplied condition evaluates to @True@.+-- Handlers defined in this way have no access to the call context (if one+-- exists) and cannot therefore reply to calls.+--+handleDispatchIf :: forall s a . (Serializable a)+                 => Condition s a+                 -> (s -> a -> Process (ProcessAction s))+                 -> Dispatcher s+handleDispatchIf cond handler = DispatchIf {+      dispatch = doHandle handler+    , dispatchIf = check cond+    }+  where doHandle :: (Serializable a)+                 => (s -> a -> Process (ProcessAction s))+                 -> s+                 -> Message a ()+                 -> Process (ProcessAction s)+        doHandle h s msg =+            case msg of+                (CallMessage p _) -> (h s p)+                (CastMessage p)   -> (h s p)+                (ChanMessage p _) -> (h s p)++-- | Creates a generic input handler (i.e., for received messages that are /not/+-- sent using the 'cast' or 'call' APIs) from an ordinary function in the+-- 'Process' monad.+handleInfo :: forall s a. (Serializable a)+           => (s -> a -> Process (ProcessAction s))+           -> DeferredDispatcher s+handleInfo h = DeferredDispatcher { dispatchInfo = doHandleInfo h }+  where+    doHandleInfo :: forall s2 a2. (Serializable a2)+                             => (s2 -> a2 -> Process (ProcessAction s2))+                             -> s2+                             -> P.Message+                             -> Process (Maybe (ProcessAction s2))+    doHandleInfo h' s msg = handleMessage msg (h' s)++-- | Handle completely /raw/ input messages.+--+handleRaw :: forall s. (s -> P.Message -> Process (ProcessAction s))+          -> DeferredDispatcher s+handleRaw h = DeferredDispatcher { dispatchInfo = doHandle h }+  where+    doHandle h' s msg = h' s msg >>= return . Just++-- | Creates an /exit handler/ scoped to the execution of any and all the+-- registered call, cast and info handlers for the process.+handleExit :: forall s a. (Serializable a)+           => (s -> ProcessId -> a -> Process (ProcessAction s))+           -> ExitSignalDispatcher s+handleExit h = ExitSignalDispatcher { dispatchExit = doHandleExit h }+  where+    doHandleExit :: (s -> ProcessId -> a -> Process (ProcessAction s))+                 -> s+                 -> ProcessId+                 -> P.Message+                 -> Process (Maybe (ProcessAction s))+    doHandleExit h' s p msg = handleMessage msg (h' s p)++handleExitIf :: forall s a . (Serializable a)+             => (s -> a -> Bool)+             -> (s -> ProcessId -> a -> Process (ProcessAction s))+             -> ExitSignalDispatcher s+handleExitIf c h = ExitSignalDispatcher { dispatchExit = doHandleExit c h }+  where+    doHandleExit :: (s -> a -> Bool)+                 -> (s -> ProcessId -> a -> Process (ProcessAction s))+                 -> s+                 -> ProcessId+                 -> P.Message+                 -> Process (Maybe (ProcessAction s))+    doHandleExit c' h' s p msg = handleMessageIf msg (c' s) (h' s p)++-- handling 'reply-to' in the main process loop is awkward at best,+-- so we handle it here instead and return the 'action' to the loop+mkReply :: (Serializable b)+        => CallRef b+        -> ProcessReply b s+        -> Process (ProcessAction s)+mkReply _ (NoReply a)         = return a+mkReply c (ProcessReply r' a) = sendTo c r' >> return a++-- these functions are the inverse of 'condition', 'state' and 'input'++check :: forall s m a . (Serializable m)+            => Condition s m+            -> s+            -> Message m a+            -> Bool+check (Condition c) st msg = c st $ decode msg+check (State     c) st _   = c st+check (Input     c) _  msg = c $ decode msg++checkRpc :: forall s m a . (Serializable m)+            => Condition s m+            -> s+            -> Message m a+            -> Bool+checkRpc cond st msg@(ChanMessage _ _) = check cond st msg+checkRpc _    _  _                     = False++checkCall :: forall s m a . (Serializable m)+             => Condition s m+             -> s+             -> Message m a+             -> Bool+checkCall cond st msg@(CallMessage _ _) = check cond st msg+checkCall _    _  _                     = False++checkCast :: forall s m . (Serializable m)+             => Condition s m+             -> s+             -> Message m ()+             -> Bool+checkCast cond st msg@(CastMessage _) = check cond st msg+checkCast _    _     _                = False++decode :: Message a b -> a+decode (CallMessage a _) = a+decode (CastMessage a)   = a+decode (ChanMessage a _) = a+
+ src/Control/Distributed/Process/Platform/ManagedProcess/Server/Priority.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE PatternGuards              #-}++module Control.Distributed.Process.Platform.ManagedProcess.Server.Priority+  ( prioritiseCall+  , prioritiseCall_+  , prioritiseCast+  , prioritiseCast_+  , prioritiseInfo+  , prioritiseInfo_+  , setPriority+  ) where++import Control.Distributed.Process hiding (call, Message)+import qualified Control.Distributed.Process as P (Message)+import Control.Distributed.Process.Platform.ManagedProcess.Internal.Types+import Control.Distributed.Process.Serializable+import Prelude hiding (init)++setPriority :: Int -> Priority m+setPriority = Priority++prioritiseCall_ :: forall s a b . (Serializable a, Serializable b)+                => (a -> Priority b)+                -> DispatchPriority s+prioritiseCall_ h = prioritiseCall (\_ -> h)++prioritiseCall :: forall s a b . (Serializable a, Serializable b)+               => (s -> a -> Priority b)+               -> DispatchPriority s+prioritiseCall h = PrioritiseCall (\s -> unCall $ h s)+  where+    unCall :: (a -> Priority b) -> P.Message -> Process (Maybe (Int, P.Message))+    unCall h' m = unwrapMessage m >>= return . matchPrioritise m h'++    matchPrioritise :: P.Message+                    -> (a -> Priority b)+                    -> Maybe (Message a b)+                    -> Maybe (Int, P.Message)+    matchPrioritise msg p msgIn+      | (Just a@(CallMessage m _)) <- msgIn+      , True  <- isEncoded msg = Just (getPrio $ p m, wrapMessage a)+      | (Just   (CallMessage m _)) <- msgIn+      , False <- isEncoded msg = Just (getPrio $ p m, msg)+      | otherwise              = Nothing++prioritiseCast_ :: forall s a . (Serializable a)+                => (a -> Priority ())+                -> DispatchPriority s+prioritiseCast_ h = prioritiseCast (\_ -> h)++prioritiseCast :: forall s a . (Serializable a)+               => (s -> a -> Priority ())+               -> DispatchPriority s+prioritiseCast h = PrioritiseCast (\s -> unCast $ h s)+  where+    unCast :: (a -> Priority ()) -> P.Message -> Process (Maybe (Int, P.Message))+    unCast h' m = unwrapMessage m >>= return . matchPrioritise m h'++    matchPrioritise :: P.Message+                    -> (a -> Priority ())+                    -> Maybe (Message a ())+                    -> Maybe (Int, P.Message)+    matchPrioritise msg p msgIn+      | (Just a@(CastMessage m)) <- msgIn+      , True  <- isEncoded msg = Just (getPrio $ p m, wrapMessage a)+      | (Just   (CastMessage m)) <- msgIn+      , False <- isEncoded msg = Just (getPrio $ p m, msg)+      | otherwise              = Nothing++prioritiseInfo_ :: forall s a . (Serializable a)+                => (a -> Priority ())+                -> DispatchPriority s+prioritiseInfo_ h = prioritiseInfo (\_ -> h)++prioritiseInfo :: forall s a . (Serializable a)+               => (s -> a -> Priority ())+               -> DispatchPriority s+prioritiseInfo h = PrioritiseInfo (\s -> unMsg $ h s)+  where+    unMsg :: (a -> Priority ()) -> P.Message -> Process (Maybe (Int, P.Message))+    unMsg h' m = unwrapMessage m >>= return . matchPrioritise m h'++    matchPrioritise :: P.Message+                    -> (a -> Priority ())+                    -> Maybe a+                    -> Maybe (Int, P.Message)+    matchPrioritise msg p msgIn+      | (Just m') <- msgIn+      , True <- isEncoded msg  = Just (getPrio $ p m', wrapMessage m')+      | (Just m') <- msgIn+      , False <- isEncoded msg = Just (getPrio $ p m', msg)+      | otherwise              = Nothing+
+ src/Control/Distributed/Process/Platform/ManagedProcess/Server/Restricted.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted+-- Copyright   :  (c) Tim Watson 2012 - 2013+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- A /safe/ variant of the Server Portion of the /Managed Process/ API. Most+-- of these operations have the same names as similar operations in the impure+-- @Server@ module (re-exported by the primary API in @ManagedProcess@). To+-- remove the ambiguity, some combination of either qualification and/or the+-- @hiding@ clause will be required.+--+-- [Restricted Server Callbacks]+--+-- The idea behind this module is to provide /safe/ callbacks, i.e., server+-- code that is free from side effects. This safety is enforced by the type+-- system via the @RestrictedProcess@ monad. A StateT interface is provided+-- for code running in the @RestrictedProcess@ monad, so that server side+-- state can be managed safely without resorting to IO (or code running in+-- the @Process@ monad).+--+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted+  ( -- * Exported Types+    RestrictedProcess+  , Result(..)+  , RestrictedAction(..)+    -- * Creating call/cast protocol handlers+  , handleCall+  , handleCallIf+  , handleCast+  , handleCastIf+  , handleInfo+  , handleExit+  , handleTimeout+    -- * Handling Process State+  , putState+  , getState+  , modifyState+    -- * Handling responses/transitions+  , reply+  , noReply+  , haltNoReply+  , continue+  , timeoutAfter+  , hibernate+  , stop+    -- * Utilities+  , say+  ) where++import Control.Applicative (Applicative)+import Control.Distributed.Process hiding (call, say)+import qualified Control.Distributed.Process as P (say)+import Control.Distributed.Process.Platform.Internal.Types+  (ExitReason(..))+import Control.Distributed.Process.Platform.ManagedProcess.Internal.Types+import qualified Control.Distributed.Process.Platform.ManagedProcess.Server as Server+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Serializable+import Prelude hiding (init)++import Control.Monad.IO.Class (MonadIO)+import qualified Control.Monad.State as ST+  ( MonadState+  , MonadTrans+  , StateT+  , get+  , lift+  , modify+  , put+  , runStateT+  )++import Data.Typeable++-- | Restricted (i.e., pure, free from side effects) execution+-- environment for call/cast/info handlers to execute in.+--+newtype RestrictedProcess s a = RestrictedProcess {+    unRestricted :: ST.StateT s Process a+  }+  deriving (Functor, Monad, ST.MonadState s, MonadIO, Typeable, Applicative)++-- | The result of a 'call' handler's execution.+data Result a =+    Reply     a              -- ^ reply with the given term+  | Timeout   Delay a        -- ^ reply with the given term and enter timeout+  | Hibernate TimeInterval a -- ^ reply with the given term and hibernate+  | Stop      ExitReason     -- ^ stop the process with the given reason+  deriving (Typeable)++-- | The result of a safe 'cast' handler's execution.+data RestrictedAction =+    RestrictedContinue               -- ^ continue executing+  | RestrictedTimeout   Delay        -- ^ timeout if no messages are received+  | RestrictedHibernate TimeInterval -- ^ hibernate (i.e., sleep)+  | RestrictedStop      ExitReason   -- ^ stop/terminate the server process++--------------------------------------------------------------------------------+-- Handling state in RestrictedProcess execution environments                 --+--------------------------------------------------------------------------------++-- | Log a trace message using the underlying Process's @say@+say :: String -> RestrictedProcess s ()+say msg = lift . P.say $ msg++-- | Get the current process state+getState :: RestrictedProcess s s+getState = ST.get++-- | Put a new process state state+putState :: s -> RestrictedProcess s ()+putState = ST.put++-- | Apply the given expression to the current process state+modifyState :: (s -> s) -> RestrictedProcess s ()+modifyState = ST.modify++--------------------------------------------------------------------------------+-- Generating replies and state transitions inside RestrictedProcess          --+--------------------------------------------------------------------------------++-- | Instructs the process to send a reply and continue running.+reply :: forall s r . (Serializable r) => r -> RestrictedProcess s (Result r)+reply = return . Reply++-- | Continue without giving a reply to the caller - equivalent to 'continue',+-- but usable in a callback passed to the 'handleCall' family of functions.+noReply :: forall s r . (Serializable r)+           => Result r+           -> RestrictedProcess s (Result r)+noReply r = return r++-- | Halt process execution during a call handler, without paying any attention+-- to the expected return type.+haltNoReply :: forall s r . (Serializable r)+           => ExitReason+           -> RestrictedProcess s (Result r)+haltNoReply r = noReply (Stop r)++-- | Instructs the process to continue running and receiving messages.+continue :: forall s . RestrictedProcess s RestrictedAction+continue = return RestrictedContinue++-- | Instructs the process loop to wait for incoming messages until 'Delay'+-- is exceeded. If no messages are handled during this period, the /timeout/+-- handler will be called. Note that this alters the process timeout permanently+-- such that the given @Delay@ will remain in use until changed.+timeoutAfter :: forall s. Delay -> RestrictedProcess s RestrictedAction+timeoutAfter d = return $ RestrictedTimeout d++-- | Instructs the process to /hibernate/ for the given 'TimeInterval'. Note+-- that no messages will be removed from the mailbox until after hibernation has+-- ceased. This is equivalent to evaluating @liftIO . threadDelay@.+--+hibernate :: forall s. TimeInterval -> RestrictedProcess s RestrictedAction+hibernate d = return $ RestrictedHibernate d++-- | Instructs the process to terminate, giving the supplied reason. If a valid+-- 'shutdownHandler' is installed, it will be called with the 'ExitReason'+-- returned from this call, along with the process state.+stop :: forall s. ExitReason -> RestrictedProcess s RestrictedAction+stop r = return $ RestrictedStop r++--------------------------------------------------------------------------------+-- Wrapping handler expressions in Dispatcher and DeferredDispatcher          --+--------------------------------------------------------------------------------++-- | A version of "Control.Distributed.Process.Platform.ManagedProcess.Server.handleCall"+-- that takes a handler which executes in 'RestrictedProcess'.+--+handleCall :: forall s a b . (Serializable a, Serializable b)+           => (a -> RestrictedProcess s (Result b))+           -> Dispatcher s+handleCall = handleCallIf $ Server.state (const True)++-- | A version of "Control.Distributed.Process.Platform.ManagedProcess.Server.handleCallIf"+-- that takes a handler which executes in 'RestrictedProcess'.+--+handleCallIf :: forall s a b . (Serializable a, Serializable b)+             => (Condition s a)+             -> (a -> RestrictedProcess s (Result b))+             -> Dispatcher s+handleCallIf cond h = Server.handleCallIf cond (wrapCall h)++-- | A version of "Control.Distributed.Process.Platform.ManagedProcess.Server.handleCast"+-- that takes a handler which executes in 'RestrictedProcess'.+--+handleCast :: forall s a . (Serializable a)+           => (a -> RestrictedProcess s RestrictedAction)+           -> Dispatcher s+handleCast = handleCastIf (Server.state (const True))++-- | A version of "Control.Distributed.Process.Platform.ManagedProcess.Server.handleCastIf"+-- that takes a handler which executes in 'RestrictedProcess'.+--+handleCastIf :: forall s a . (Serializable a)+                => Condition s a -- ^ predicate that must be satisfied for the handler to run+                -> (a -> RestrictedProcess s RestrictedAction)+                -- ^ an action yielding function over the process state and input message+                -> Dispatcher s+handleCastIf cond h = Server.handleCastIf cond (wrapHandler h)++-- | A version of "Control.Distributed.Process.Platform.ManagedProcess.Server.handleInfo"+-- that takes a handler which executes in 'RestrictedProcess'.+--+handleInfo :: forall s a. (Serializable a)+           => (a -> RestrictedProcess s RestrictedAction)+           -> DeferredDispatcher s+-- cast and info look the same to a restricted process+handleInfo h = Server.handleInfo (wrapHandler h)++handleExit :: forall s a. (Serializable a)+           => (a -> RestrictedProcess s RestrictedAction)+           -> ExitSignalDispatcher s+handleExit h = Server.handleExit $ \s _ a -> (wrapHandler h) s a++handleTimeout :: forall s . (Delay -> RestrictedProcess s RestrictedAction)+                         -> TimeoutHandler s+handleTimeout h = \s d -> do+  (r, s') <- runRestricted s (h d)+  case r of+    RestrictedContinue       -> Server.continue s'+    (RestrictedTimeout   i)  -> Server.timeoutAfter i s'+    (RestrictedHibernate i)  -> Server.hibernate    i s'+    (RestrictedStop      r') -> Server.stop r'++--------------------------------------------------------------------------------+-- Implementation                                                             --+--------------------------------------------------------------------------------++wrapHandler :: forall s a . (Serializable a)+            => (a -> RestrictedProcess s RestrictedAction)+            -> s+            -> a+            -> Process (ProcessAction s)+wrapHandler h s a = do+  (r, s') <- runRestricted s (h a)+  case r of+    RestrictedContinue       -> Server.continue s'+    (RestrictedTimeout   i)  -> Server.timeoutAfter i s'+    (RestrictedHibernate i)  -> Server.hibernate    i s'+    (RestrictedStop      r') -> Server.stop r'++wrapCall :: forall s a b . (Serializable a, Serializable b)+            => (a -> RestrictedProcess s (Result b))+            -> s+            -> a+            -> Process (ProcessReply b s)+wrapCall h s a = do+  (r, s') <- runRestricted s (h a)+  case r of+    (Reply       r') -> Server.reply r' s'+    (Timeout   i r') -> Server.timeoutAfter i s' >>= Server.replyWith r'+    (Hibernate i r') -> Server.hibernate    i s' >>= Server.replyWith r'+    (Stop      r'' ) -> Server.stop r''          >>= Server.noReply++runRestricted :: s -> RestrictedProcess s a -> Process (a, s)+runRestricted state proc = ST.runStateT (unRestricted proc) state++-- | TODO MonadTrans instance? lift :: (Monad m) => m a -> t m a+lift :: Process a -> RestrictedProcess s a+lift p = RestrictedProcess $ ST.lift p+
+ src/Control/Distributed/Process/Platform/ManagedProcess/UnsafeClient.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE ScopedTypeVariables        #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.ManagedProcess.UnsafeClient+-- Copyright   :  (c) Tim Watson 2012 - 2013+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- Unsafe variant of the /Managed Process Client API/. This module implements+-- the client portion of a Managed Process using the unsafe variants of cloud+-- haskell's messaging primitives. It relies on the Platform implementation of+-- @UnsafePrimitives@, which forces evaluation for types that provide an+-- @NFData@ instance. Direct use of the underlying unsafe primitives (from+-- the distributed-process library) without @NFData@ instances is unsupported.+--+-- IMPORTANT NOTE: As per the platform documentation, it is not possible to+-- /guarantee/ that an @NFData@ instance will force evaluation in the same way+-- that a @Binary@ instance would (when encoding to a byte string). Please read+-- the unsafe primitives documentation carefully and make sure you know what+-- you're doing. You have been warned.+--+-- See "Control.Distributed.Process.Platform".+-- See "Control.Distributed.Process.Platform.UnsafePrimitives".+-- See "Control.Distributed.Process.UnsafePrimitives".+-----------------------------------------------------------------------------++-- TODO: This module is basically cut+paste duplicaton of the /safe/ Client - fix+-- Caveats... we've got to support two different type constraints, somehow, so+-- that the correct implementation gets used depending on whether or not we're+-- passing NFData or just Binary instances...++module Control.Distributed.Process.Platform.ManagedProcess.UnsafeClient+  ( -- * Unsafe variants of the Client API+    sendControlMessage+  , shutdown+  , call+  , safeCall+  , tryCall+  , callTimeout+  , flushPendingCalls+  , callAsync+  , cast+  , callChan+  , syncCallChan+  , syncSafeCallChan+  ) where++import Control.Distributed.Process+  ( Process+  , ProcessId+  , ReceivePort+  , newChan+  , matchChan+  , match+  , die+  , terminate+  , receiveTimeout+  , unsafeSendChan+  )+import Control.Distributed.Process.Platform.Async+  ( Async+  , async+  )+import Control.Distributed.Process.Platform.Internal.Primitives+  ( awaitResponse+  )+import Control.Distributed.Process.Platform.Internal.Types+  ( Addressable+  , Routable(..)+  , NFSerializable+  , ExitReason+  , Shutdown(..)+  )+import Control.Distributed.Process.Platform.ManagedProcess.Internal.Types+  ( Message(CastMessage, ChanMessage)+  , CallResponse(..)+  , ControlPort(..)+  , unsafeInitCall+  , waitResponse+  )+import Control.Distributed.Process.Platform.Time+  ( TimeInterval+  , asTimeout+  )+import Control.Distributed.Process.Serializable hiding (SerializableDict)+import Data.Maybe (fromJust)++-- | Send a control message over a 'ControlPort'. This version of+-- @shutdown@ uses /unsafe primitives/.+--+sendControlMessage :: Serializable m => ControlPort m -> m -> Process ()+sendControlMessage cp m = unsafeSendChan (unPort cp) (CastMessage m)++-- | Send a signal instructing the process to terminate. This version of+-- @shutdown@ uses /unsafe primitives/.+shutdown :: ProcessId -> Process ()+shutdown pid = cast pid Shutdown++-- | Make a synchronous call - uses /unsafe primitives/.+call :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)+                 => s -> a -> Process b+call sid msg = unsafeInitCall sid msg >>= waitResponse Nothing >>= decodeResult+  where decodeResult (Just (Right r))  = return r+        decodeResult (Just (Left err)) = die err+        decodeResult Nothing {- the impossible happened -} = terminate++-- | Safe version of 'call' that returns information about the error+-- if the operation fails - uses /unsafe primitives/.+safeCall :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)+                 => s -> a -> Process (Either ExitReason b)+safeCall s m = unsafeInitCall s m >>= waitResponse Nothing >>= return . fromJust++-- | Version of 'safeCall' that returns 'Nothing' if the operation fails.+--  Uses /unsafe primitives/.+tryCall :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)+                 => s -> a -> Process (Maybe b)+tryCall s m = unsafeInitCall s m >>= waitResponse Nothing >>= decodeResult+  where decodeResult (Just (Right r)) = return $ Just r+        decodeResult _                = return Nothing++-- | Make a synchronous call, but timeout and return @Nothing@ if a reply+-- is not received within the specified time interval  - uses /unsafe primitives/.+--+callTimeout :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)+                 => s -> a -> TimeInterval -> Process (Maybe b)+callTimeout s m d = unsafeInitCall s m >>= waitResponse (Just d) >>= decodeResult+  where decodeResult :: (NFSerializable b)+               => Maybe (Either ExitReason b)+               -> Process (Maybe b)+        decodeResult Nothing               = return Nothing+        decodeResult (Just (Right result)) = return $ Just result+        decodeResult (Just (Left reason))  = die reason++flushPendingCalls :: forall b . (NFSerializable b)+                  => TimeInterval+                  -> (b -> Process b)+                  -> Process (Maybe b)+flushPendingCalls d proc = do+  receiveTimeout (asTimeout d) [+      match (\(CallResponse (m :: b) _) -> proc m)+    ]++-- | Invokes 'call' /out of band/, and returns an "async handle."+-- Uses /unsafe primitives/.+--+callAsync :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)+          => s -> a -> Process (Async b)+callAsync server msg = async $ call server msg++-- | Sends a /cast/ message to the server identified by @server@ - uses /unsafe primitives/.+--+cast :: forall a m . (Addressable a, NFSerializable m)+                 => a -> m -> Process ()+cast server msg = unsafeSendTo server ((CastMessage msg) :: Message m ())++-- | Sends a /channel/ message to the server and returns a @ReceivePort@ - uses /unsafe primitives/.+callChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)+         => s -> a -> Process (ReceivePort b)+callChan server msg = do+  (sp, rp) <- newChan+  unsafeSendTo server ((ChanMessage msg sp) :: Message a b)+  return rp++syncCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)+         => s -> a -> Process b+syncCallChan server msg = do+  r <- syncSafeCallChan server msg+  case r of+    Left e   -> die e+    Right r' -> return r'++syncSafeCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b)+            => s -> a -> Process (Either ExitReason b)+syncSafeCallChan server msg = do+  rp <- callChan server msg+  awaitResponse server [ matchChan rp (return . Right) ]+
+ src/Control/Distributed/Process/Platform/Service.hs view
@@ -0,0 +1,37 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Service+-- Copyright   :  (c) Tim Watson 2013 - 2014+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- The /Service Framework/ is intended to provide a /service or component oriented/+-- API for developing cloud haskell applications. Ultimately, we aim to provide+-- a declarative mechanism for defining service components and their dependent+-- services/sub-systems so we can automatically derive an appropriate supervision+-- tree. This work is incomplete.+--+-- Access to services, both internally and from remote peers, should take place+-- via the /Registry/ module, with several different kinds of registry defined+-- per node plus user defined registries running where applicable. Again, this+-- is a work in progress, though the service registry capability is available+-- in the current release.+--+-- The service API also aims to provide some built in capabilities for common+-- tasks such as monitoring, management and logging. An extension of the base+-- Management (Mx) API that covers /ManagedProcess/ and /Supervision/ trees will+-- be also be added here in a future release.+--+-----------------------------------------------------------------------------+module Control.Distributed.Process.Platform.Service+  ( -- * Monitoring Nodes+    module Control.Distributed.Process.Platform.Service.Monitoring+    -- * Service Registry+  , module Control.Distributed.Process.Platform.Service.Registry+  ) where++import Control.Distributed.Process.Platform.Service.Monitoring+import Control.Distributed.Process.Platform.Service.Registry
+ src/Control/Distributed/Process/Platform/Service/Monitoring.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Service.Monitoring+-- Copyright   :  (c) Tim Watson 2013 - 2014+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- This module provides a primitive node monitoring capability, implemented as+-- a /distributed-process Management Agent/. Once the 'nodeMonitor' agent is+-- started, calling 'monitorNodes' will ensure that whenever the local node+-- detects a new network-transport connection (from another cloud haskell node),+-- the caller will receive a 'NodeUp' message in its mailbox. If a node+-- disconnects, a corollary 'NodeDown' message will be delivered as well.+--+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Service.Monitoring+  (+    NodeUp(..)+  , NodeDown(..)+  , nodeMonitorAgentId+  , nodeMonitor+  , monitorNodes+  , unmonitorNodes+  ) where++import Control.DeepSeq (NFData)+import Control.Distributed.Process  -- NB: requires NodeId(..) to be exported!+import Control.Distributed.Process.Management+  ( MxEvent(MxConnected, MxDisconnected)+  , MxAgentId(..)+  , mxAgent+  , mxSink+  , mxReady+  , liftMX+  , mxGetLocal+  , mxSetLocal+  , mxNotify+  )+import Control.Distributed.Process.Platform (deliver)+import Data.Binary+import qualified Data.Foldable as Foldable+import Data.HashSet (HashSet)+import qualified Data.HashSet as Set++import Data.Typeable (Typeable)+import GHC.Generics++data Register = Register !ProcessId+  deriving (Typeable, Generic)+instance Binary Register where+instance NFData Register where++data UnRegister = UnRegister !ProcessId+  deriving (Typeable, Generic)+instance Binary UnRegister where+instance NFData UnRegister where++-- | Sent to subscribing processes when a connection+-- (from a remote node) is detected.+--+data NodeUp = NodeUp !NodeId+  deriving (Typeable, Generic, Show)+instance Binary NodeUp where+instance NFData NodeUp where++-- | Sent to subscribing processes when a dis-connection+-- (from a remote node) is detected.+--+data NodeDown = NodeDown !NodeId+  deriving (Typeable, Generic, Show)+instance Binary NodeDown where+instance NFData NodeDown where++-- | The @MxAgentId@ for the node monitoring agent.+nodeMonitorAgentId :: MxAgentId+nodeMonitorAgentId = MxAgentId "service.monitoring.nodes"++-- | Start monitoring node connection/disconnection events. When a+-- connection event occurs, the calling process will receive a message+-- @NodeUp NodeId@ in its mailbox. When a disconnect occurs, the+-- corollary @NodeDown NodeId@ message will be delivered instead.+--+-- No guaranatee is made about the timeliness of the delivery, nor can+-- the receiver expect that the node (for which it is being notified)+-- is still up/connected or down/disconnected at the point when it receives+-- a message from the node monitoring agent.+--+monitorNodes :: Process ()+monitorNodes = do+  us <- getSelfPid+  mxNotify $ Register us++-- | Stop monitoring node connection/disconnection events. This does not+-- flush the caller's mailbox, nor does it guarantee that any/all node+-- up/down notifications will have been delivered before it is evaluated.+--+unmonitorNodes :: Process ()+unmonitorNodes = do+  us <- getSelfPid+  mxNotify $ UnRegister us++-- | Starts the node monitoring agent. No call to @monitorNodes@ and+-- @unmonitorNodes@ will have any effect unless the agent is already+-- running. Note that we make /no guarantees what-so-ever/ about the+-- timeliness or ordering semantics of node monitoring notifications.+--+nodeMonitor :: Process ProcessId+nodeMonitor = do+  mxAgent nodeMonitorAgentId initState [+        (mxSink $ \(Register pid) -> do+            mxSetLocal . Set.insert pid =<< mxGetLocal+            mxReady)+      , (mxSink $ \(UnRegister pid) -> do+            mxSetLocal . Set.delete pid =<< mxGetLocal+            mxReady)+      , (mxSink $ \ev -> do+            let act =+                  case ev of+                    (MxConnected    _ ep) -> notify $ nodeUp ep+                    (MxDisconnected _ ep) -> notify $ nodeDown ep+                    _                     -> return ()+            act >> mxReady)+    ]+  where+    initState :: HashSet ProcessId+    initState = Set.empty++    notify msg = Foldable.mapM_ (liftMX . deliver msg) =<< mxGetLocal++    nodeUp = NodeUp . NodeId+    nodeDown = NodeDown . NodeId+
+ src/Control/Distributed/Process/Platform/Service/Registry.hs view
@@ -0,0 +1,1076 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE PatternGuards              #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE MultiParamTypeClasses      #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Service.Registry+-- Copyright   :  (c) Tim Watson 2012 - 2013+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- The module provides an extended process registry, offering slightly altered+-- semantics to the built in @register@ and @unregister@ primitives and a richer+-- set of features:+--+-- * Associate (unique) keys with a process /or/ (unique key per-process) values+-- * Use any 'Keyable' algebraic data type as keys+-- * Query for process with matching keys / values / properties+-- * Atomically /give away/ names+-- * Forceibly re-allocate names to/from a third party+--+-- [Subscribing To Registry Events]+--+-- It is possible to monitor a registry for changes and be informed whenever+-- changes take place. All subscriptions are /key based/, which means that+-- you can subscribe to name or property changes for any process, so that any+-- property changes matching the key you've subscribed to will trigger a+-- notification (i.e., regardless of the process to which the property belongs).+--+-- The different types of event are defined by the 'KeyUpdateEvent' type.+--+-- Processes subscribe to registry events using @monitorName@ or its counterpart+-- @monitorProperty@. If the operation succeeds, this will evaluate to an+-- opaque /reference/ that can be used when subsequently handling incoming+-- notifications, which will be delivered to the subscriber's mailbox as+-- @RegistryKeyMonitorNotification keyIdentity opaqueRef event@, where @event@+-- has the type 'KeyUpdateEvent'.+--+-- Subscribers can filter the types of event they receive by using the lower+-- level @monitor@ function (defined in /this/ module - not the one defined+-- in distributed-process' @Primitives@) and passing a list of filtering+-- 'KeyUpdateEventMask'. Without these filters in place, a monitor event will+-- be fired for /every/ pertinent change.+--+-----------------------------------------------------------------------------+module Control.Distributed.Process.Platform.Service.Registry+  ( -- * Registry Keys+    KeyType(..)+  , Key(..)+  , Keyable+    -- * Defining / Starting A Registry+  , Registry(..)+  , start+  , run+    -- * Registration / Unregistration+  , addName+  , addProperty+  , registerName+  , registerValue+  , giveAwayName+  , RegisterKeyReply(..)+  , unregisterName+  , UnregisterKeyReply(..)+    -- * Queries / Lookups+  , lookupName+  , lookupProperty+  , registeredNames+  , foldNames+  , SearchHandle()+  , member+  , queryNames+  , findByProperty+  , findByPropertyValue+    -- * Monitoring / Waiting+  , monitor+  , monitorName+  , monitorProp+  , unmonitor+  , await+  , awaitTimeout+  , AwaitResult(..)+  , KeyUpdateEventMask(..)+  , KeyUpdateEvent(..)+  , RegKeyMonitorRef+  , RegistryKeyMonitorNotification(RegistryKeyMonitorNotification)+  ) where++{- DESIGN NOTES+This registry is a single process, parameterised by the types of key and+property value it can manage. It is, of course, possible to start multiple+registries and inter-connect them via registration, with one another.++The /Service/ API is intended to be a declarative layer in which you define+the managed processes that make up your services, and each /Service Component/+is registered and supervised appropriately for you, with the correct restart+strategies and start order calculated and so on. The registry is not only a+service locator, but provides the /wait for these dependencies to start first/+bit of the puzzle.++At some point, we'd like to offer a shared memory based registry, created on+behalf of a particular subsystem (i.e., some service or service group) and+passed implicitly using a reader monad or some such. This would allow multiple+processes to interact with the registry using STM (or perhaps a simple RWLock)+and could facilitate reduced contention.++Even for the singleton-process based registry (i.e., this one) we /might/ also+be better off separating the monitoring (or at least the notifications) from+the registration/mapping parts into separate processes.+-}++import Control.Distributed.Process hiding (call, monitor, unmonitor, mask)+import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe (send)+import qualified Control.Distributed.Process as P (monitor)+import Control.Distributed.Process.Serializable+import Control.Distributed.Process.Platform.Internal.Primitives hiding (monitor)+import qualified Control.Distributed.Process.Platform.Internal.Primitives as PL+  ( monitor+  )+import Control.Distributed.Process.Platform.ManagedProcess+  ( call+  , cast+  , handleInfo+  , reply+  , continue+  , input+  , defaultProcess+  , prioritised+  , InitResult(..)+  , ProcessAction+  , ProcessReply+  , ProcessDefinition(..)+  , PrioritisedProcessDefinition(..)+  , DispatchPriority+  , CallRef+  )+import qualified Control.Distributed.Process.Platform.ManagedProcess as MP+  ( pserve+  )+import Control.Distributed.Process.Platform.ManagedProcess.Server+  ( handleCallIf+  , handleCallFrom+  , handleCallFromIf+  , handleCast+  )+import Control.Distributed.Process.Platform.ManagedProcess.Server.Priority+  ( prioritiseInfo_+  , setPriority+  )+import Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted+  ( RestrictedProcess+  , Result+  , getState+  )+import qualified Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted as Restricted+  ( handleCall+  , reply+  )+import Control.Distributed.Process.Platform.Time+import Control.Monad (forM_, void)+import Data.Accessor+  ( Accessor+  , accessor+  , (^:)+  , (^=)+  , (^.)+  )+import Data.Binary+import Data.Foldable (Foldable)+import qualified Data.Foldable as Foldable+import Data.Maybe (fromJust, isJust)+import Data.Hashable+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Control.Distributed.Process.Platform.Internal.Containers.MultiMap (MultiMap)+import qualified Control.Distributed.Process.Platform.Internal.Containers.MultiMap as MultiMap+import Data.HashSet (HashSet)+import qualified Data.HashSet as Set+import Data.Typeable (Typeable)++import GHC.Generics++--------------------------------------------------------------------------------+-- Types                                                                      --+--------------------------------------------------------------------------------++-- | Describes how a key will be used - for storing names or properties.+data KeyType =+    KeyTypeAlias    -- ^ the key will refer to a name (i.e., named process)+  | KeyTypeProperty -- ^ the key will refer to a (per-process) property+  deriving (Typeable, Generic, Show, Eq)+instance Binary KeyType where+instance Hashable KeyType where++-- | A registered key. Keys can be mapped to names or (process-local) properties+-- in the registry. The 'keyIdentity' holds the key's value (e.g., a string or+-- similar simple data type, which must provide a 'Keyable' instance), whilst+-- the 'keyType' and 'keyScope' describe the key's intended use and ownership.+data Key a =+    Key+    { keyIdentity :: !a+    , keyType     :: !KeyType+    , keyScope    :: !(Maybe ProcessId)+    }+  deriving (Typeable, Generic, Show, Eq)+instance (Serializable a) => Binary (Key a) where+instance (Hashable a) => Hashable (Key a) where++-- | The 'Keyable' class describes types that can be used as registry keys.+-- The constraints ensure that the key can be stored and compared appropriately.+class (Show a, Eq a, Hashable a, Serializable a) => Keyable a+instance (Show a, Eq a, Hashable a, Serializable a) => Keyable a++-- | A phantom type, used to parameterise registry startup+-- with the required key and value types.+data Registry k v = Registry { registryPid :: ProcessId }+  deriving (Typeable, Generic, Show, Eq)+instance (Keyable k, Serializable v) => Binary (Registry k v) where++instance Resolvable (Registry k v) where+  resolve = return . Just . registryPid++instance Linkable (Registry k v) where+  linkTo = link . registryPid++-- Internal/Private Request/Response Types++data LookupKeyReq k = LookupKeyReq !(Key k)+  deriving (Typeable, Generic)+instance (Serializable k) => Binary (LookupKeyReq k) where++data LookupPropReq k = PropReq (Key k)+  deriving (Typeable, Generic)+instance (Serializable k) => Binary (LookupPropReq k) where++data LookupPropReply =+    PropFound !Message+  | PropNotFound+  deriving (Typeable, Generic)+instance Binary LookupPropReply where++data InvalidPropertyType = InvalidPropertyType+  deriving (Typeable, Generic, Show, Eq)+instance Binary InvalidPropertyType where++data RegNamesReq = RegNamesReq !ProcessId+  deriving (Typeable, Generic)+instance Binary RegNamesReq where++data UnregisterKeyReq k = UnregisterKeyReq !(Key k)+  deriving (Typeable, Generic)+instance (Serializable k) => Binary (UnregisterKeyReq k) where++-- | The result of an un-registration attempt.+data UnregisterKeyReply =+    UnregisterOk -- ^ The given key was successfully unregistered+  | UnregisterInvalidKey -- ^ The given key was invalid and could not be unregistered+  | UnregisterKeyNotFound -- ^ The given key was not found (i.e., was not registered)+  deriving (Typeable, Generic, Eq, Show)+instance Binary UnregisterKeyReply where++-- Types used in (setting up and interacting with) key monitors++-- | Used to describe a subset of monitoring events to listen for.+data KeyUpdateEventMask =+    OnKeyRegistered      -- ^ receive an event when a key is registered+  | OnKeyUnregistered    -- ^ receive an event when a key is unregistered+  | OnKeyOwnershipChange -- ^ receive an event when a key's owner changes+  | OnKeyLeaseExpiry     -- ^ receive an event when a key's lease expires+  deriving (Typeable, Generic, Eq, Show)+instance Binary KeyUpdateEventMask where+instance Hashable KeyUpdateEventMask where++-- | An opaque reference used for matching monitoring events. See+-- 'RegistryKeyMonitorNotification' for more details.+newtype RegKeyMonitorRef =+  RegKeyMonitorRef { unRef :: (ProcessId, Integer) }+  deriving (Typeable, Generic, Eq, Show)+instance Binary RegKeyMonitorRef where+instance Hashable RegKeyMonitorRef where++instance Resolvable RegKeyMonitorRef where+  resolve = return . Just . fst . unRef++-- | Provides information about a key monitoring event.+data KeyUpdateEvent =+    KeyRegistered+    {+      owner :: !ProcessId+    }+  | KeyUnregistered+  | KeyLeaseExpired+  | KeyOwnerDied+    {+      diedReason :: !DiedReason+    }+  | KeyOwnerChanged+    {+      previousOwner :: !ProcessId+    , newOwner      :: !ProcessId+    }+  deriving (Typeable, Generic, Eq, Show)+instance Binary KeyUpdateEvent where++-- | This message is delivered to processes which are monioring a+-- registry key. The opaque monitor reference will match (i.e., be equal+-- to) the reference returned from the @monitor@ function, which the+-- 'KeyUpdateEvent' describes the change that took place.+data RegistryKeyMonitorNotification k =+  RegistryKeyMonitorNotification !k !RegKeyMonitorRef !KeyUpdateEvent !ProcessId+  deriving (Typeable, Generic)+instance (Keyable k) => Binary (RegistryKeyMonitorNotification k) where+deriving instance (Keyable k) => Eq (RegistryKeyMonitorNotification k)+deriving instance (Keyable k) => Show (RegistryKeyMonitorNotification k)++data RegisterKeyReq k = RegisterKeyReq !(Key k)+  deriving (Typeable, Generic)+instance (Serializable k) => Binary (RegisterKeyReq k) where++-- | The (return) value of an attempted registration.+data RegisterKeyReply =+    RegisteredOk      -- ^ The given key was registered successfully+  | AlreadyRegistered -- ^ The key was already registered+  deriving (Typeable, Generic, Eq, Show)+instance Binary RegisterKeyReply where++-- | A cast message used to atomically give a name/key away to another process.+data GiveAwayName k = GiveAwayName !ProcessId !(Key k)+  deriving (Typeable, Generic)+instance (Keyable k) => Binary (GiveAwayName k) where+deriving instance (Keyable k) => Eq (GiveAwayName k)+deriving instance (Keyable k) => Show (GiveAwayName k)++data MonitorReq k = MonitorReq !(Key k) !(Maybe [KeyUpdateEventMask])+  deriving (Typeable, Generic)+instance (Keyable k) => Binary (MonitorReq k) where++data UnmonitorReq = UnmonitorReq !RegKeyMonitorRef+  deriving (Typeable, Generic)+instance Binary UnmonitorReq where++-- | The result of an @await@ operation.+data AwaitResult k =+    RegisteredName     !ProcessId !k   -- ^ The name was registered+  | ServerUnreachable  !DiedReason     -- ^ The server was unreachable (or died)+  | AwaitTimeout                       -- ^ The operation timed out+  deriving (Typeable, Generic, Eq, Show)+instance (Keyable k) => Binary (AwaitResult k) where++-- Server state++-- On the server, a monitor reference consists of the actual+-- RegKeyMonitorRef which we can 'sendTo' /and/ the which+-- the client matches on, plus an optional list of event masks+data KMRef = KMRef { ref  :: !RegKeyMonitorRef+                   , mask :: !(Maybe [KeyUpdateEventMask])+                     -- use Nothing to monitor every event+                   }+  deriving (Typeable, Generic, Show)+instance Hashable KMRef where+-- instance Binary KMRef where+instance Eq KMRef where+  (KMRef a _) == (KMRef b _) = a == b++data State k v =+  State+  {+    _names          :: !(HashMap k ProcessId)+  , _properties     :: !(HashMap (ProcessId, k) v)+  , _monitors       :: !(MultiMap k KMRef)+  , _registeredPids :: !(HashSet ProcessId)+  , _listeningPids  :: !(HashSet ProcessId)+  , _monitorIdCount :: !Integer+  }+  deriving (Typeable, Generic)++-- Types used in \direct/ queries++-- TODO: enforce QueryDirect's usage over only local channels++data QueryDirect = QueryDirectNames | QueryDirectProperties | QueryDirectValues+  deriving (Typeable, Generic)+instance Binary QueryDirect where++-- NB: SHashMap is basically a shim, allowing us to copy a+-- pointer to our HashMap directly to the querying process'+-- mailbox with no serialisation or even deepseq evaluation+-- required. We disallow remote queries (i.e., from other nodes)+-- and thus the Binary instance below is never used (though it's+-- required by the type system) and will in fact generate errors if+-- you attempt to use it at runtime.+data SHashMap k v = SHashMap [(k, v)] (HashMap k v)+  deriving (Typeable, Generic)++instance (Keyable k, Serializable v) =>+         Binary (SHashMap k v) where+  put = error "AttemptedToUseBinaryShim"+  get = error "AttemptedToUseBinaryShim"+{- a real instance could look something like this:++  put (SHashMap _ hmap) = put (toList hmap)+  get = do+    hm <- get :: Get [(k, v)]+    return $ SHashMap [] (fromList hm)+-}++newtype SearchHandle k v = RS { getRS :: HashMap k v }+  deriving (Typeable)++instance (Keyable k) => Functor (SearchHandle k) where+  fmap f (RS m) = RS $ Map.map f m+instance (Keyable k) => Foldable (SearchHandle k) where+  foldr f acc = Foldable.foldr f acc . getRS+-- TODO: add Functor and Traversable instances++--------------------------------------------------------------------------------+-- Starting / Running A Registry                                              --+--------------------------------------------------------------------------------++start :: forall k v. (Keyable k, Serializable v)+      => Process (Registry k v)+start = return . Registry =<< spawnLocal (run (undefined :: Registry k v))++run :: forall k v. (Keyable k, Serializable v)+    => Registry k v+    -> Process ()+run _ =+  MP.pserve () (const $ return $ InitOk initState Infinity) serverDefinition+  where+    initState = State { _names          = Map.empty+                      , _properties     = Map.empty+                      , _monitors       = MultiMap.empty+                      , _registeredPids = Set.empty+                      , _listeningPids  = Set.empty+                      , _monitorIdCount = (1 :: Integer)+                      } :: State k v++--------------------------------------------------------------------------------+-- Client Facing API                                                          --+--------------------------------------------------------------------------------++-- -- | Sends a message to the process, or processes, corresponding to @key@.+-- -- If Key belongs to a unique object (name or aggregated counter), this+-- -- function will send a message to the corresponding process, or fail if there+-- -- is no such process. If Key is for a non-unique object type (counter or+-- -- property), Msg will be send to all processes that have such an object.+-- --+-- dispatch svr ky msg = undefined+--   -- TODO: do a local-lookup and then sendTo the target++-- | Associate the calling process with the given (unique) key.+addName :: forall k v. (Keyable k)+        => Registry k v+        -> k+        -> Process RegisterKeyReply+addName s n = getSelfPid >>= registerName s n++-- | Atomically transfer a (registered) name to another process. Has no effect+-- if the name does is not registered to the calling process!+--+giveAwayName :: forall k v . (Keyable k)+             => Registry k v+             -> k+             -> ProcessId+             -> Process ()+giveAwayName s n p = do+  us <- getSelfPid+  cast s $ GiveAwayName p $ Key n KeyTypeAlias (Just us)++-- | Associate the given (non-unique) property with the current process.+-- If the property already exists, it will be overwritten with the new value.+addProperty :: (Keyable k, Serializable v)+            => Registry k v -> k -> v -> Process RegisterKeyReply+addProperty s k v = do+  call s $ (RegisterKeyReq (Key k KeyTypeProperty $ Nothing), v)++-- | Register the item at the given address.+registerName :: forall k v . (Keyable k)+             => Registry k v -> k -> ProcessId -> Process RegisterKeyReply+registerName s n p = do+  call s $ RegisterKeyReq (Key n KeyTypeAlias $ Just p)++-- | Register an item at the given address and associate it with a value.+-- If the property already exists, it will be overwritten with the new value.+registerValue :: (Resolvable b, Keyable k, Serializable v)+              => Registry k v -> b -> k -> v -> Process RegisterKeyReply+registerValue s t n v = do+  Just p <- resolve t+  call s $ (RegisterKeyReq (Key n KeyTypeProperty $ Just p), v)++-- | Un-register a (unique) name for the calling process.+unregisterName :: forall k v . (Keyable k)+               => Registry k v+               -> k+               -> Process UnregisterKeyReply+unregisterName s n = do+  self <- getSelfPid+  call s $ UnregisterKeyReq (Key n KeyTypeAlias $ Just self)++-- | Lookup the process identified by the supplied key. Evaluates to+-- @Nothing@ if the key is not registered.+lookupName :: forall k v . (Keyable k)+           => Registry k v+           -> k+           -> Process (Maybe ProcessId)+lookupName s n = call s $ LookupKeyReq (Key n KeyTypeAlias Nothing)++-- | Lookup the value of a named property for the calling process. Evaluates to+-- @Nothing@ if the property (key) is not registered. If the assignment to a+-- value of type @v@ does not correspond to the type of properties stored by+-- the registry, the calling process will exit with the reason set to+-- @InvalidPropertyType@.+lookupProperty :: (Keyable k, Serializable v)+               => Registry k v+               -> k+               -> Process (Maybe v)+lookupProperty s n = do+  us <- getSelfPid+  res <- call s $ PropReq (Key n KeyTypeProperty (Just us))+  case res of+    PropNotFound  -> return Nothing+    PropFound msg -> do+      val <- unwrapMessage msg+      if (isJust val)+        then return val+        else die InvalidPropertyType++-- | Obtain a list of all registered keys.+registeredNames :: forall k v . (Keyable k)+                => Registry k v+                -> ProcessId+                -> Process [k]+registeredNames s p = call s $ RegNamesReq p++-- | Monitor changes to the supplied name.+--+monitorName :: forall k v. (Keyable k)+            => Registry k v -> k -> Process RegKeyMonitorRef+monitorName svr name = do+  let key' = Key { keyIdentity = name+                 , keyScope    = Nothing+                 , keyType     = KeyTypeAlias+                 }+  monitor svr key' Nothing++-- | Monitor changes to the supplied (property) key.+--+monitorProp :: forall k v. (Keyable k)+            => Registry k v -> k -> ProcessId -> Process RegKeyMonitorRef+monitorProp svr key pid = do+  let key' = Key { keyIdentity = key+                 , keyScope    = Just pid+                 , keyType     = KeyTypeProperty+                 }+  monitor svr key' Nothing++-- | Low level monitor operation. For the given key, set up a monitor+-- filtered by any 'KeyUpdateEventMask' entries that are supplied.+monitor :: forall k v. (Keyable k)+        => Registry k v+        -> Key k+        -> Maybe [KeyUpdateEventMask]+        -> Process RegKeyMonitorRef+monitor svr key' mask' = call svr $ MonitorReq key' mask'++-- | Remove a previously set monitor.+--+unmonitor :: forall k v. (Keyable k)+          => Registry k v+          -> RegKeyMonitorRef+          -> Process ()+unmonitor s = call s . UnmonitorReq++-- | Await registration of a given key. This function will subsequently+-- block the evaluating process until the key is registered and a registration+-- event is dispatched to the caller's mailbox.+--+await :: forall k v. (Keyable k)+      => Registry k v+      -> k+      -> Process (AwaitResult k)+await a k = awaitTimeout a Infinity k++-- | Await registration of a given key, but give up and return @AwaitTimeout@+-- if registration does not take place within the specified time period (@delay@).+awaitTimeout :: forall k v. (Keyable k)+             => Registry k v+             -> Delay+             -> k+             -> Process (AwaitResult k)+awaitTimeout a d k = do+    p <- forceResolve a+    Just mRef <- PL.monitor p+    kRef <- monitor a (Key k KeyTypeAlias Nothing) (Just [OnKeyRegistered])+    let matches' = matches mRef kRef k+    let recv = case d of+                 Infinity -> receiveWait matches' >>= return . Just+                 Delay t  -> receiveTimeout (asTimeout t) matches'+                 NoDelay  -> receiveTimeout 0 matches'+    recv >>= return . maybe AwaitTimeout id+  where+    forceResolve addr = do+      mPid <- resolve addr+      case mPid of+        Nothing -> die "InvalidAddressable"+        Just p  -> return p++    matches mr kr k' = [+        matchIf (\(RegistryKeyMonitorNotification mk' kRef' ev' _) ->+                      (matchEv ev' && kRef' == kr && mk' == k'))+                (\(RegistryKeyMonitorNotification _ _ (KeyRegistered pid) _) ->+                  return $ RegisteredName pid k')+      , matchIf (\(ProcessMonitorNotification mRef' _ _) -> mRef' == mr)+                (\(ProcessMonitorNotification _ _ dr) ->+                  return $ ServerUnreachable dr)+      ]++    matchEv ev' = case ev' of+                    KeyRegistered _ -> True+                    _               -> False++-- Local (non-serialised) shared data access. See note [sharing] below.++findByProperty :: forall k v. (Keyable k)+               => Registry k v+               -> k+               -> Process [ProcessId]+findByProperty r key = do+    let pid = registryPid r+    self <- getSelfPid+    withMonitor pid $ do+      cast r $ (self, QueryDirectProperties)+      answer <- receiveWait [+          match (\(SHashMap _ m :: SHashMap ProcessId [k]) -> return $ Just m)+        , matchIf (\(ProcessMonitorNotification _ p _) -> p == pid)+                  (\_ -> return Nothing)+        , matchAny (\_ -> return Nothing)+        ]+      case answer of+        Nothing -> die "DisconnectedFromServer"+        Just m  -> return $ Map.foldlWithKey' matchKey [] m+  where+    matchKey ps p ks+      | key `elem` ks = p:ps+      | otherwise     = ps++findByPropertyValue :: (Keyable k, Serializable v, Eq v)+                    => Registry k v+                    -> k+                    -> v+                    -> Process [ProcessId]+findByPropertyValue r key val = do+    let pid = registryPid r+    self <- getSelfPid+    withMonitor pid $ do+      cast r $ (self, QueryDirectValues)+      answer <- receiveWait [+          match (\(SHashMap _ m :: SHashMap ProcessId [(k, v)]) -> return $ Just m)+        , matchIf (\(ProcessMonitorNotification _ p _) -> p == pid)+                  (\_ -> return Nothing)+        , matchAny (\_ -> return Nothing) -- TODO: logging?+        ]+      case answer of+        Nothing -> die "DisconnectedFromServer"+        Just m  -> return $ Map.foldlWithKey' matchKey [] m+  where+    matchKey ps p ks+      | (key, val) `elem` ks = p:ps+      | otherwise            = ps++-- TODO: move to UnsafePrimitives over a passed {Send|Receive}Port here, and+-- avoid interfering with the caller's mailbox.++-- | Monadic left fold over all registered names/keys. The fold takes place+-- in the evaluating process.+foldNames :: forall b k v . Keyable k+          => Registry k v+          -> b+          -> (b -> (k, ProcessId) -> Process b)+          -> Process b+foldNames pid acc fn = do+  self <- getSelfPid+  -- TODO: monitor @pid@ and die if necessary!!!+  cast pid $ (self, QueryDirectNames)+  -- Although we incur the cost of scanning our mailbox here (which we could+  -- avoid by spawning an intermediary perhaps), the message is delivered to+  -- us without any copying or serialisation overheads.+  SHashMap _ m <- expect :: Process (SHashMap k ProcessId)+  Foldable.foldlM fn acc (Map.toList m)++-- | Evaluate a query on a 'SearchHandle', in the calling process.+queryNames :: forall b k v . Keyable k+       => Registry k v+       -> (SearchHandle k ProcessId -> Process b)+       -> Process b+queryNames pid fn = do+  self <- getSelfPid+  cast pid $ (self, QueryDirectNames)+  SHashMap _ m <- expect :: Process (SHashMap k ProcessId)+  fn (RS m)++-- | Tests whether or not the supplied key is registered, evaluated in the+-- calling process.+member :: (Keyable k, Serializable v)+       => k+       -> SearchHandle k v+       -> Bool+member k = Map.member k . getRS++-- note [sharing]:+-- We use the base library's UnsafePrimitives for these fold/query operations,+-- to pass a pointer to our internal HashMaps for read-only operations. There+-- is a potential cost to the caller, if their mailbox is full - we should move+-- to use unsafe channel's for this at some point.+--++--------------------------------------------------------------------------------+-- Server Process                                                             --+--------------------------------------------------------------------------------++serverDefinition :: forall k v. (Keyable k, Serializable v)+                 => PrioritisedProcessDefinition (State k v)+serverDefinition = prioritised processDefinition regPriorities+  where+    regPriorities :: [DispatchPriority (State k v)]+    regPriorities = [+        prioritiseInfo_ (\(ProcessMonitorNotification _ _ _) -> setPriority 100)+      ]++processDefinition :: forall k v. (Keyable k, Serializable v)+                  => ProcessDefinition (State k v)+processDefinition =+  defaultProcess+  {+    apiHandlers =+       [+         handleCallIf+              (input ((\(RegisterKeyReq (Key{..} :: Key k)) ->+                        keyType == KeyTypeAlias && (isJust keyScope))))+              handleRegisterName+       , handleCallIf+              (input ((\((RegisterKeyReq (Key{..} :: Key k)), _ :: v) ->+                        keyType == KeyTypeProperty && (isJust keyScope))))+              handleRegisterProperty+       , handleCallFromIf+              (input ((\((RegisterKeyReq (Key{..} :: Key k)), _ :: v) ->+                        keyType == KeyTypeProperty && (not $ isJust keyScope))))+              handleRegisterPropertyCR+       , handleCast handleGiveAwayName+       , handleCallIf+              (input ((\(LookupKeyReq (Key{..} :: Key k)) ->+                        keyType == KeyTypeAlias)))+              (\state (LookupKeyReq key') -> reply (findName key' state) state)+       , handleCallIf+              (input ((\(PropReq (Key{..} :: Key k)) ->+                        keyType == KeyTypeProperty && (isJust keyScope))))+              handleLookupProperty+       , handleCallIf+              (input ((\(UnregisterKeyReq (Key{..} :: Key k)) ->+                        keyType == KeyTypeAlias && (isJust keyScope))))+              handleUnregisterName+       , handleCallFrom handleMonitorReq+       , handleCallFrom handleUnmonitorReq+       , Restricted.handleCall handleRegNamesLookup+       , handleCast handleQuery+       ]+  , infoHandlers = [handleInfo handleMonitorSignal]+  } :: ProcessDefinition (State k v)++handleQuery :: forall k v. (Keyable k, Serializable v)+            => State k v+            -> (ProcessId, QueryDirect)+            -> Process (ProcessAction (State k v))+handleQuery st@State{..} (pid, qd) = do+    case qd of+      QueryDirectNames      -> Unsafe.send pid shmNames+      QueryDirectProperties -> Unsafe.send pid shmProps+      QueryDirectValues     -> Unsafe.send pid shmVals+    continue st+  where+    shmNames = SHashMap [] $ st ^. names+    shmProps = SHashMap [] xfmProps+    shmVals  = SHashMap [] xfmVals++    -- since we currently have to fold over our properties in order+    -- answer remote queries, the sharing we do here seems a bit pointless,+    -- however we'll be moving to a shared memory based registry soon++    xfmProps = Map.foldlWithKey' convProps Map.empty (st ^. properties)+    xfmVals  = Map.foldlWithKey' convVals Map.empty (st ^. properties)++    convProps m (p, k) _ =+      case Map.lookup p m of+        Nothing -> Map.insert p [k] m+        Just ks -> Map.insert p (k:ks) m++    convVals m (p, k) v =+      case Map.lookup p m of+        Nothing -> Map.insert p [(k, v)] m+        Just ks -> Map.insert p ((k, v):ks) m++handleRegisterName :: forall k v. (Keyable k, Serializable v)+                   => State k v+                   -> RegisterKeyReq k+                   -> Process (ProcessReply RegisterKeyReply (State k v))+handleRegisterName state (RegisterKeyReq Key{..}) = do+  let found = Map.lookup keyIdentity (state ^. names)+  case found of+    Nothing -> do+      let pid  = fromJust keyScope+      let refs = state ^. registeredPids+      refs' <- ensureMonitored pid refs+      notifySubscribers keyIdentity state (KeyRegistered pid)+      reply RegisteredOk $ ( (names ^: Map.insert keyIdentity pid)+                           . (registeredPids ^= refs')+                           $ state)+    Just pid ->+      if (pid == (fromJust keyScope))+         then reply RegisteredOk      state+         else reply AlreadyRegistered state++handleRegisterPropertyCR :: forall k v. (Keyable k, Serializable v)+                         => State k v+                         -> CallRef (RegisterKeyReply)+                         -> (RegisterKeyReq k, v)+                         -> Process (ProcessReply RegisterKeyReply (State k v))+handleRegisterPropertyCR st cr req = do+  pid <- resolve cr+  doRegisterProperty (fromJust pid) st req++handleRegisterProperty :: forall k v. (Keyable k, Serializable v)+                       => State k v+                       -> (RegisterKeyReq k, v)+                       -> Process (ProcessReply RegisterKeyReply (State k v))+handleRegisterProperty state req@((RegisterKeyReq Key{..}), _) = do+  doRegisterProperty (fromJust keyScope) state req++doRegisterProperty :: forall k v. (Keyable k, Serializable v)+                       => ProcessId+                       -> State k v+                       -> (RegisterKeyReq k, v)+                       -> Process (ProcessReply RegisterKeyReply (State k v))+doRegisterProperty scope state ((RegisterKeyReq Key{..}), v) = do+  void $ P.monitor scope+  notifySubscribers keyIdentity state (KeyRegistered scope)+  reply RegisteredOk $ ( (properties ^: Map.insert (scope, keyIdentity) v)+                       $ state )++handleLookupProperty :: forall k v. (Keyable k, Serializable v)+                     => State k v+                     -> LookupPropReq k+                     -> Process (ProcessReply LookupPropReply (State k v))+handleLookupProperty state (PropReq Key{..}) = do+  let entry = Map.lookup (fromJust keyScope, keyIdentity) (state ^. properties)+  case entry of+    Nothing -> reply PropNotFound state+    Just p  -> reply (PropFound (wrapMessage p)) state++handleUnregisterName :: forall k v. (Keyable k, Serializable v)+                     => State k v+                     -> UnregisterKeyReq k+                     -> Process (ProcessReply UnregisterKeyReply (State k v))+handleUnregisterName state (UnregisterKeyReq Key{..}) = do+  let entry = Map.lookup keyIdentity (state ^. names)+  case entry of+    Nothing  -> reply UnregisterKeyNotFound state+    Just pid ->+      case (pid /= (fromJust keyScope)) of+        True  -> reply UnregisterInvalidKey state+        False -> do+          notifySubscribers keyIdentity state KeyUnregistered+          let state' = ( (names ^: Map.delete keyIdentity)+                       . (monitors ^: MultiMap.filterWithKey (\k' _ -> k' /= keyIdentity))+                       $ state)+          reply UnregisterOk $ state'++handleGiveAwayName :: forall k v. (Keyable k, Serializable v)+                   => State k v+                   -> GiveAwayName k+                   -> Process (ProcessAction (State k v))+handleGiveAwayName state (GiveAwayName newPid Key{..}) = do+  maybe (continue state) giveAway $ Map.lookup keyIdentity (state ^. names)+  where+    giveAway pid = do+      let scope = fromJust keyScope+      case (pid == scope) of+        False -> continue state+        True -> do+          let state' = ((names ^: Map.insert keyIdentity newPid) $ state)+          notifySubscribers keyIdentity state (KeyOwnerChanged pid newPid)+          continue state'++handleMonitorReq :: forall k v. (Keyable k, Serializable v)+                 => State k v+                 -> CallRef RegKeyMonitorRef+                 -> MonitorReq k+                 -> Process (ProcessReply RegKeyMonitorRef (State k v))+handleMonitorReq state cRef (MonitorReq Key{..} mask') = do+  let mRefId = (state ^. monitorIdCount) + 1+  Just caller <- resolve cRef+  let mRef  = RegKeyMonitorRef (caller, mRefId)+  let kmRef = KMRef mRef mask'+  let refs = state ^. listeningPids+  refs' <- ensureMonitored caller refs+  fireEventForPreRegisteredKey state keyIdentity keyScope kmRef+  reply mRef $ ( (monitors ^: MultiMap.insert keyIdentity kmRef)+               . (listeningPids ^= refs')+               . (monitorIdCount ^= mRefId)+               $ state+               )+  where+    fireEventForPreRegisteredKey st kId kScope KMRef{..} = do+      let evMask = maybe [] id mask+      case (keyType, elem OnKeyRegistered evMask) of+        (KeyTypeAlias, True) -> do+          let found = Map.lookup kId (st ^. names)+          fireEvent found kId ref+        (KeyTypeProperty, _) -> do+          self <- getSelfPid+          let scope = maybe self id kScope+          let found = Map.lookup (scope, kId) (st ^. properties)+          case found of+            Nothing -> return () -- TODO: logging or some such!?+            Just _  -> fireEvent (Just scope) kId ref+        _ -> return ()++    fireEvent fnd kId' ref' = do+      case fnd of+        Nothing -> return ()+        Just p  -> do+          us <- getSelfPid+          sendTo ref' $ (RegistryKeyMonitorNotification kId'+                         ref'+                         (KeyRegistered p)+                         us)++handleUnmonitorReq :: forall k v. (Keyable k, Serializable v)+                 => State k v+                 -> CallRef ()+                 -> UnmonitorReq+                 -> Process (ProcessReply () (State k v))+handleUnmonitorReq state _cRef (UnmonitorReq ref') = do+  let pid = fst $ unRef ref'+  reply () $ ( (monitors ^: MultiMap.filter ((/= ref') . ref))+             . (listeningPids ^: Set.delete pid)+             $ state+             )++handleRegNamesLookup :: forall k v. (Keyable k, Serializable v)+                     => RegNamesReq+                     -> RestrictedProcess (State k v) (Result [k])+handleRegNamesLookup (RegNamesReq p) = do+  state <- getState+  Restricted.reply $ Map.foldlWithKey' (acc p) [] (state ^. names)+  where+    acc pid ns n pid'+      | pid == pid' = (n:ns)+      | otherwise   = ns++handleMonitorSignal :: forall k v. (Keyable k, Serializable v)+                    => State k v+                    -> ProcessMonitorNotification+                    -> Process (ProcessAction (State k v))+handleMonitorSignal state@State{..} (ProcessMonitorNotification _ pid diedReason) =+  do let state' = removeActiveSubscriptions pid state+     (deadNames, deadProps) <- notifyListeners state' pid diedReason+     continue $ ( (names ^= Map.difference _names deadNames)+                . (properties ^= Map.difference _properties deadProps)+                $ state)+  where+    removeActiveSubscriptions p s =+      let subscriptions = (state ^. listeningPids) in+      case (Set.member p subscriptions) of+        False -> s+        True  -> ( (listeningPids ^: Set.delete p)+                   -- delete any monitors this (now dead) process held+                 . (monitors ^: MultiMap.filter ((/= p) . fst . unRef . ref))+                 $ s)++    notifyListeners :: State k v+                    -> ProcessId+                    -> DiedReason+                    -> Process (HashMap k ProcessId, HashMap (ProcessId, k) v)+    notifyListeners st pid' dr = do+      let diedNames = Map.filter (== pid') (st ^. names)+      let diedProps = Map.filterWithKey (\(p, _) _ -> p == pid')+                                        (st ^. properties)+      let nameSubs  = MultiMap.filterWithKey (\k _ -> Map.member k diedNames)+                                             (st ^. monitors)+      let propSubs  = MultiMap.filterWithKey (\k _ -> Map.member (pid', k) diedProps)+                                             (st ^. monitors)+      forM_ (MultiMap.toList nameSubs) $ \(kIdent, KMRef{..}) -> do+        let kEvDied = KeyOwnerDied { diedReason = dr }+        let mRef    = RegistryKeyMonitorNotification kIdent ref+        us <- getSelfPid+        case mask of+          Nothing    -> sendTo ref (mRef kEvDied us)+          Just mask' -> do+            case (elem OnKeyOwnershipChange mask') of+              True  -> sendTo ref (mRef kEvDied us)+              False -> do+                if (elem OnKeyUnregistered mask')+                  then sendTo ref (mRef KeyUnregistered us)+                  else return ()+      forM_ (MultiMap.toList propSubs) (notifyPropSubscribers dr)+      return (diedNames, diedProps)++    notifyPropSubscribers dr' (kIdent, KMRef{..}) = do+      let died  = maybe False (elem OnKeyOwnershipChange) mask+      let event = case died of+                    True  -> KeyOwnerDied { diedReason = dr' }+                    False -> KeyUnregistered+      getSelfPid >>= sendTo ref . RegistryKeyMonitorNotification kIdent ref event++ensureMonitored :: ProcessId -> HashSet ProcessId -> Process (HashSet ProcessId)+ensureMonitored pid refs = do+  case (Set.member pid refs) of+    True  -> return refs+    False -> P.monitor pid >> return (Set.insert pid refs)++notifySubscribers :: forall k v. (Keyable k, Serializable v)+                  => k+                  -> State k v+                  -> KeyUpdateEvent+                  -> Process ()+notifySubscribers k st ev = do+  let subscribers = MultiMap.filterWithKey (\k' _ -> k' == k) (st ^. monitors)+  forM_ (MultiMap.toList subscribers) $ \(_, KMRef{..}) -> do+    if (maybe True (elem (maskFor ev)) mask)+      then getSelfPid >>= sendTo ref . RegistryKeyMonitorNotification k ref ev+      else {- (liftIO $ putStrLn "no mask") >> -} return ()++--------------------------------------------------------------------------------+-- Utilities / Accessors                                                      --+--------------------------------------------------------------------------------++maskFor :: KeyUpdateEvent -> KeyUpdateEventMask+maskFor (KeyRegistered _)     = OnKeyRegistered+maskFor KeyUnregistered       = OnKeyUnregistered+maskFor (KeyOwnerDied   _)    = OnKeyOwnershipChange+maskFor (KeyOwnerChanged _ _) = OnKeyOwnershipChange+maskFor KeyLeaseExpired       = OnKeyLeaseExpiry++findName :: forall k v. (Keyable k, Serializable v)+         => Key k+         -> State k v+         -> Maybe ProcessId+findName Key{..} state = Map.lookup keyIdentity (state ^. names)++names :: forall k v. Accessor (State k v) (HashMap k ProcessId)+names = accessor _names (\n' st -> st { _names = n' })++properties :: forall k v. Accessor (State k v) (HashMap (ProcessId, k) v)+properties = accessor _properties (\ps st -> st { _properties = ps })++monitors :: forall k v. Accessor (State k v) (MultiMap k KMRef)+monitors = accessor _monitors (\ms st -> st { _monitors = ms })++registeredPids :: forall k v. Accessor (State k v) (HashSet ProcessId)+registeredPids = accessor _registeredPids (\mp st -> st { _registeredPids = mp })++listeningPids :: forall k v. Accessor (State k v) (HashSet ProcessId)+listeningPids = accessor _listeningPids (\lp st -> st { _listeningPids = lp })++monitorIdCount :: forall k v. Accessor (State k v) Integer+monitorIdCount = accessor _monitorIdCount (\i st -> st { _monitorIdCount = i })+
+ src/Control/Distributed/Process/Platform/Service/SystemLog.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE PatternGuards        #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Service.SystemLog+-- Copyright   :  (c) Tim Watson 2013 - 2014+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- This module provides a general purpose logging facility, implemented as a+-- distributed-process /Management Agent/. To start the logging agent on a+-- running node, evaluate 'systemLog' with the relevant expressions to handle+-- logging textual messages, a cleanup operation (if required), initial log+-- level and a formatting expression.+--+-- We export a working example in the form of 'systemLogFile', which logs+-- to a text file using buffered I/O. Its implementation is very simple, and+-- should serve as a demonstration of how to use the API:+--+-- > systemLogFile :: FilePath -> LogLevel -> LogFormat -> Process ProcessId+-- > systemLogFile path lvl fmt = do+-- >   h <- liftIO $ openFile path AppendMode+-- >   liftIO $ hSetBuffering h LineBuffering+-- >   systemLog (liftIO . hPutStrLn h) (liftIO (hClose h)) lvl fmt+--+-----------------------------------------------------------------------------++-- TODO - REWRITE THIS WITHOUT USING THE MX API, SINCE THAT's POINTLESS>>>>>>>.++module Control.Distributed.Process.Platform.Service.SystemLog+  ( -- * Types exposed by this module+    LogLevel(..)+  , LogFormat+  , LogClient+  , LogChan+  , LogText(..)+  , ToLog(..)+  , Logger(..)+    -- * Mx Agent Configuration / Startup+  , mxLogId+  , systemLog+  , client+  , logChannel+  , addFormatter+    -- * systemLogFile+  , systemLogFile+    -- * Logging Messages+  , report+  , debug+  , info+  , notice+  , warning+  , error+  , critical+  , alert+  , emergency+  , sendLog+  ) where++import Control.DeepSeq (NFData)+import Control.Distributed.Process+import Control.Distributed.Process.Management+  ( MxEvent(MxConnected, MxDisconnected, MxLog, MxUser)+  , MxAgentId(..)+  , mxAgentWithFinalize+  , mxSink+  , mxReady+  , mxReceive+  , liftMX+  , mxGetLocal+  , mxSetLocal+  , mxUpdateLocal+  , mxNotify+  )+import Control.Distributed.Process.Platform.Internal.Types+  ( Resolvable(..)+  , Routable(..)+  )+import Control.Distributed.Process.Serializable+import Control.Exception (SomeException)+import Data.Accessor+  ( Accessor+  , accessor+  , (^:)+  , (^=)+  , (^.)+  )+import Data.Binary+import Data.Typeable (Typeable)+import GHC.Generics++#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch, error, Read)+#else+import Prelude hiding (error, Read)+#endif++import System.IO+  ( IOMode(AppendMode)+  , BufferMode(..)+  , openFile+  , hClose+  , hPutStrLn+  , hSetBuffering+  )+import Text.Read (Read)++data LogLevel =+    Debug+  | Info+  | Notice+  | Warning+  | Error+  | Critical+  | Alert+  | Emergency+  deriving (Typeable, Generic, Eq,+            Read, Show, Ord, Enum)+instance Binary LogLevel where++data SetLevel = SetLevel !LogLevel+  deriving (Typeable, Generic)+instance Binary SetLevel where+instance NFData SetLevel where++data AddFormatter = AddFormatter !(Closure (Message -> Process (Maybe String)))+  deriving (Typeable, Generic)+instance Binary AddFormatter where+instance NFData AddFormatter where++data LogState =+  LogState { output      :: !(String -> Process ())+           , cleanup     :: !(Process ())+           , _level      :: !LogLevel+           , _format     :: !(String -> Process String)+           , _formatters :: ![Message -> Process (Maybe String)]+           }++data LogMessage =+    LogMessage !String  !LogLevel+  | LogData    !Message !LogLevel+  deriving (Typeable, Generic, Show)+instance Binary LogMessage where+instance NFData LogMessage where++type LogFormat = String -> Process String++type LogChan = ()+instance Routable LogChan where+  sendTo       _ = mxNotify+  unsafeSendTo _ = mxNotify++data LogText = LogText { txt :: !String }++newtype LogClient = LogClient { agent :: ProcessId }+instance Resolvable LogClient where+  resolve = return . Just . agent++class ToLog m where+  toLog :: m -> Process (LogLevel -> LogMessage)++instance ToLog LogText where+  toLog = return . LogMessage . txt++instance (Serializable a) => ToLog a where+  toLog = return . LogData . unsafeWrapMessage++instance ToLog Message where+  toLog = return . LogData++class Logger a where+  logMessage :: a -> LogMessage -> Process ()++instance Logger LogClient where+  logMessage = sendTo++instance Logger LogChan where+  logMessage _ = mxNotify++logProcessName :: String+logProcessName = "service.systemlog"++mxLogId :: MxAgentId+mxLogId = MxAgentId logProcessName++logChannel :: LogChan+logChannel = ()++report :: (Logger l)+       => (l -> LogText -> Process ())+       -> l+       -> String+       -> Process ()+report f l = f l . LogText++client :: Process (Maybe LogClient)+client = resolve logProcessName >>= return . maybe Nothing (Just . LogClient)++debug :: (Logger l, ToLog m) => l -> m -> Process ()+debug l m = sendLog l m Debug++info :: (Logger l, ToLog m) => l -> m -> Process ()+info l m = sendLog l m Info++notice :: (Logger l, ToLog m) => l -> m -> Process ()+notice l m = sendLog l m Notice++warning :: (Logger l, ToLog m) => l -> m -> Process ()+warning l m = sendLog l m Warning++error :: (Logger l, ToLog m) => l -> m -> Process ()+error l m = sendLog l m Error++critical :: (Logger l, ToLog m) => l -> m -> Process ()+critical l m = sendLog l m Critical++alert :: (Logger l, ToLog m) => l -> m -> Process ()+alert l m = sendLog l m Alert++emergency :: (Logger l, ToLog m) => l -> m -> Process ()+emergency l m = sendLog l m Emergency++sendLog :: (Logger l, ToLog m) => l -> m -> LogLevel -> Process ()+sendLog a m lv = toLog m >>= \m' -> logMessage a $ m' lv++addFormatter :: (Routable r)+             => r+             -> Closure (Message -> Process (Maybe String))+             -> Process ()+addFormatter r clj = sendTo r $ AddFormatter clj++-- | Start a system logger that writes to a file.+--+-- This is a /very basic/ file logging facility, that uses /regular/ buffered+-- file I/O (i.e., @System.IO.hPutStrLn@ et al) under the covers. The handle+-- is closed appropriately if/when the logging process terminates.+--+-- See @Control.Distributed.Process.Management.mxAgentWithFinalize@ for futher+-- details about management agents that use finalizers.+--+systemLogFile :: FilePath -> LogLevel -> LogFormat -> Process ProcessId+systemLogFile path lvl fmt = do+  h <- liftIO $ openFile path AppendMode+  liftIO $ hSetBuffering h LineBuffering+  systemLog (liftIO . hPutStrLn h) (liftIO (hClose h)) lvl fmt++-- | Start a /system logger/ process as a management agent.+--+systemLog :: (String -> Process ()) -- ^ This expression does the actual logging+          -> (Process ())  -- ^ An expression used to clean up any residual state+          -> LogLevel      -- ^ The initial 'LogLevel' to use+          -> LogFormat     -- ^ An expression used to format logging messages/text+          -> Process ProcessId+systemLog o c l f = go $ LogState o c l f defaultFormatters+  where+    go :: LogState -> Process ProcessId+    go st = do+      mxAgentWithFinalize mxLogId st [+            -- these are the messages we're /really/ interested in+            (mxSink $ \(m :: LogMessage) -> do+                case m of+                  (LogMessage msg lvl) -> do+                    mxGetLocal >>= outputMin lvl msg >> mxReceive+                  (LogData dat lvl) -> handleRawMsg dat lvl)++            -- complex messages rely on properly registered formatters+          , (mxSink $ \(ev :: MxEvent) -> do+                case ev of+                  (MxUser msg) -> handleRawMsg msg Debug+                  -- we treat trace/log events like regular log events at+                  -- a Debug level (only)+                  (MxLog  str) -> mxGetLocal >>= outputMin Debug str >> mxReceive+                  _            -> handleEvent ev >> mxReceive)++            -- command message handling+          , (mxSink $ \(SetLevel lvl) ->+                mxGetLocal >>= mxSetLocal . (level ^= lvl) >> mxReceive)+          , (mxSink $ \(AddFormatter f') -> do+                fmt <- liftMX $ catch (unClosure f' >>= return . Just)+                                      (\(_ :: SomeException) -> return Nothing)+                case fmt of+                  Nothing -> mxReady+                  Just mf -> do+                    mxUpdateLocal (formatters ^: (mf:))+                    mxReceive)+        ] runCleanup++    runCleanup = liftMX . cleanup =<< mxGetLocal++    handleRawMsg dat' lvl' = do+      st <- mxGetLocal+      msg <- formatMsg dat' st+      case msg of+        Just str -> outputMin lvl' str st >> mxReceive+        Nothing  -> mxReceive  -- we cannot format a Message, so we ignore it++    handleEvent (MxConnected    _ ep) = do+          mxGetLocal >>= outputMin Notice+                                   ("Endpoint: " ++ (show ep) ++ " Disconnected")+    handleEvent (MxDisconnected _ ep) = do+          mxGetLocal >>= outputMin Notice+                                   ("Endpoint " ++ (show ep) ++ " Connected")+    handleEvent _                     = return ()++    formatMsg m st = let fms = st ^. formatters in formatMsg' m fms++    formatMsg' _ []     = return Nothing+    formatMsg' m (f':fs) = do+      res <- liftMX $ f' m+      case res of+        ok@(Just _) -> return ok+        Nothing     -> formatMsg' m fs++    outputMin minLvl msgData st =+      case minLvl >= (st ^. level) of+        True  -> liftMX $ ((st ^. format) msgData >>= (output st))+        False -> return ()++    defaultFormatters = [basicDataFormat]++basicDataFormat :: Message -> Process (Maybe String)+basicDataFormat = unwrapMessage++level :: Accessor LogState LogLevel+level = accessor _level (\l s -> s { _level = l })++format :: Accessor LogState LogFormat+format = accessor _format (\f s -> s { _format = f })++formatters :: Accessor LogState [Message -> Process (Maybe String)]+formatters = accessor _formatters (\n' st -> st { _formatters = n' })+
+ src/Control/Distributed/Process/Platform/Supervisor.hs view
@@ -0,0 +1,1621 @@+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE PatternGuards             #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE OverlappingInstances      #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Supervisor+-- Copyright   :  (c) Tim Watson 2012 - 2013+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- This module implements a process which supervises a set of other+-- processes, referred to as its children. These /child processes/ can be+-- either workers (i.e., processes that do something useful in your application)+-- or other supervisors. In this way, supervisors may be used to build a+-- hierarchical process structure called a supervision tree, which provides+-- a convenient structure for building fault tolerant software.+--+-- Unless otherwise stated, all functions in this module will cause the calling+-- process to exit unless the specified supervisor process exists.+--+-- [Supervision Principles]+--+-- A supervisor is responsible for starting, stopping and monitoring its child+-- processes so as to keep them alive by restarting them when necessary.+--+-- The supervisors children are defined as a list of child specifications+-- (see 'ChildSpec'). When a supervisor is started, its children are started+-- in left-to-right (insertion order) according to this list. When a supervisor+-- stops (or exits for any reason), it will terminate its children in reverse+-- (i.e., from right-to-left of insertion) order. Child specs can be added to+-- the supervisor after it has started, either on the left or right of the+-- existing list of children.+--+-- When the supervisor spawns its child processes, they are always linked to+-- their parent (i.e., the supervisor), therefore even if the supervisor is+-- terminated abruptly by an asynchronous exception, the children will still be+-- taken down with it, though somewhat less ceremoniously in that case.+--+-- [Restart Strategies]+--+-- Supervisors are initialised with a 'RestartStrategy', which describes how+-- the supervisor should respond to a child that exits and should be restarted+-- (see below for the rules governing child restart eligibility). Each restart+-- strategy comprises a 'RestartMode' and 'RestartLimit', which govern how+-- the restart should be handled, and the point at which the supervisor+-- should give up and terminate itself respectively.+--+-- With the exception of the @RestartOne@ strategy, which indicates that the+-- supervisor will restart /only/ the one individual failing child, each+-- strategy describes a way to select the set of children that should be+-- restarted if /any/ child fails. The @RestartAll@ strategy, as its name+-- suggests, selects /all/ children, whilst the @RestartLeft@ and @RestartRight@+-- strategies select /all/ children to the left or right of the failed child,+-- in insertion (i.e., startup) order.+--+-- Note that a /branch/ restart will only occur if the child that exited is+-- meant to be restarted. Since @Temporary@ children are never restarted and+-- @Transient@ children are /not/ restarted if they exit normally, in both these+-- circumstances we leave the remaining supervised children alone. Otherwise,+-- the failing child is /always/ included in the /branch/ to be restarted.+--+-- For a hypothetical set of children @a@ through @d@, the following pseudocode+-- demonstrates how the restart strategies work.+--+-- > let children = [a..d]+-- > let failure = c+-- > restartsFor RestartOne   children failure = [c]+-- > restartsFor RestartAll   children failure = [a,b,c,d]+-- > restartsFor RestartLeft  children failure = [a,b,c]+-- > restartsFor RestartRight children failure = [c,d]+--+-- [Branch Restarts]+--+-- We refer to a restart (strategy) that involves a set of children as a+-- /branch restart/ from now on. The behaviour of branch restarts can be further+-- refined by the 'RestartMode' with which a 'RestartStrategy' is parameterised.+-- The @RestartEach@ mode treats each child sequentially, first stopping the+-- respective child process and then restarting it. Each child is stopped and+-- started fully before moving on to the next, as the following imaginary+-- example demonstrates for children @[a,b,c]@:+--+-- > stop  a+-- > start a+-- > stop  b+-- > start b+-- > stop  c+-- > start c+--+-- By contrast, @RestartInOrder@ will first run through the selected list of+-- children, stopping them. Then, once all the children have been stopped, it+-- will make a second pass, to handle (re)starting them. No child is started+-- until all children have been stopped, as the following imaginary example+-- demonstrates:+--+-- > stop  a+-- > stop  b+-- > stop  c+-- > start a+-- > start b+-- > start c+--+-- Both the previous examples have shown children being stopped and started+-- from left to right, but that is up to the user. The 'RestartMode' data+-- type's constructors take a 'RestartOrder', which determines whether the+-- selected children will be processed from @LeftToRight@ or @RightToLeft@.+--+-- Sometimes it is desireable to stop children in one order and start them+-- in the opposite. This is typically the case when children are in some+-- way dependent on one another, such that restarting them in the wrong order+-- might cause the system to misbehave. For this scenarios, there is another+-- 'RestartMode' that will shut children down in the given order, but then+-- restarts them in the reverse. Using @RestartRevOrder@ mode, if we have+-- children @[a,b,c]@ such that @b@ depends on @a@ and @c@ on @b@, we can stop+-- them in the reverse of their startup order, but restart them the other way+-- around like so:+--+-- > RestartRevOrder RightToLeft+--+-- The effect will be thus:+--+-- > stop  c+-- > stop  b+-- > stop  a+-- > start a+-- > start b+-- > start c+--+-- [Restart Intensity Limits]+--+-- If a child process repeatedly crashes during (or shortly after) starting,+-- it is possible for the supervisor to get stuck in an endless loop of+-- restarts. In order prevent this, each restart strategy is parameterised+-- with a 'RestartLimit' that caps the number of restarts allowed within a+-- specific time period. If the supervisor exceeds this limit, it will stop,+-- terminating all its children (in left-to-right order) and exit with the+-- reason @ExitOther "ReachedMaxRestartIntensity"@.+--+-- The 'MaxRestarts' type is a positive integer, and together with a specified+-- @TimeInterval@ forms the 'RestartLimit' to which the supervisor will adhere.+-- Since a great many children can be restarted in close succession when+-- a /branch restart/ occurs (as a result of @RestartAll@, @RestartLeft@ or+-- @RestartRight@ being triggered), the supervisor will track the operation+-- as a single restart attempt, since otherwise it would likely exceed its+-- maximum restart intensity too quickly.+--+-- [Child Restart and Termination Policies]+--+-- When the supervisor detects that a child has died, the 'RestartPolicy'+-- configured in the child specification is used to determin what to do. If+-- the this is set to @Permanent@, then the child is always restarted.+-- If it is @Temporary@, then the child is never restarted and the child+-- specification is removed from the supervisor. A @Transient@ child will+-- be restarted only if it terminates /abnormally/, otherwise it is left+-- inactive (but its specification is left in place). Finally, an @Intrinsic@+-- child is treated like a @Transient@ one, except that if /this/ kind of child+-- exits /normally/, then the supervisor will also exit normally.+--+-- When the supervisor does terminate a child, the 'ChildTerminationPolicy'+-- provided with the 'ChildSpec' determines how the supervisor should go+-- about doing so. If this is @TerminateImmediately@, then the child will+-- be killed without further notice, which means the child will /not/ have+-- an opportunity to clean up any internal state and/or release any held+-- resources. If the policy is @TerminateTimeout delay@ however, the child+-- will be sent an /exit signal/ instead, i.e., the supervisor will cause+-- the child to exit via @exit childPid ExitShutdown@, and then will wait+-- until the given @delay@ for the child to exit normally. If this does not+-- happen within the given delay, the supervisor will revert to the more+-- aggressive @TerminateImmediately@ policy and try again. Any errors that+-- occur during a timed-out shutdown will be logged, however exit reasons+-- resulting from @TerminateImmediately@ are ignored.+--+-- [Creating Child Specs]+--+-- The 'ToChildStart' typeclass simplifies the process of defining a 'ChildStart'+-- providing three default instances from which a 'ChildStart' datum can be+-- generated. The first, takes a @Closure (Process ())@, where the enclosed+-- action (in the @Process@ monad) is the actual (long running) code that we+-- wish to supervise. In the case of a /managed process/, this is usually the+-- server loop, constructed by evaluating some variant of @ManagedProcess.serve@.+--+-- The other two instances provide a means for starting children without having+-- to provide a @Closure@. Both instances wrap the supplied @Process@ action in+-- some necessary boilerplate code, which handles spawning a new process and+-- communicating its @ProcessId@ to the supervisor. The instance for+-- @Addressable a => SupervisorPid -> Process a@ is special however, since this+-- API is intended for uses where the typical interactions with a process take+-- place via an opaque handle, for which an instance of the @Addressable@+-- typeclass is provided. This latter approach requires the expression which is+-- responsible for yielding the @Addressable@ handle to handling linking the+-- target process with the supervisor, since we have delegated responsibility+-- for spawning the new process and cannot perform the link oepration ourselves.+--+-- [Supervision Trees & Supervisor Termination]+--+-- To create a supervision tree, one simply adds supervisors below one another+-- as children, setting the @childType@ field of their 'ChildSpec' to+-- @Supervisor@ instead of @Worker@. Supervision tree can be arbitrarilly+-- deep, and it is for this reason that we recommend giving a @Supervisor@ child+-- an arbitrary length of time to stop, by setting the delay to @Infinity@+-- or a very large @TimeInterval@.+--+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Supervisor+  ( -- * Defining and Running a Supervisor+    ChildSpec(..)+  , ChildKey+  , ChildType(..)+  , ChildTerminationPolicy(..)+  , ChildStart(..)+  , RegisteredName(LocalName, CustomRegister)+  , RestartPolicy(..)+--  , ChildRestart(..)+  , ChildRef(..)+  , isRunning+  , isRestarting+  , Child+  , StaticLabel+  , SupervisorPid+  , ChildPid+  , StarterPid+  , ToChildStart(..)+  , start+  , run+    -- * Limits and Defaults+  , MaxRestarts+  , maxRestarts+  , RestartLimit(..)+  , limit+  , defaultLimits+  , RestartMode(..)+  , RestartOrder(..)+  , RestartStrategy(..)+  , ShutdownMode(..)+  , restartOne+  , restartAll+  , restartLeft+  , restartRight+    -- * Adding and Removing Children+  , addChild+  , AddChildResult(..)+  , StartChildResult(..)+  , startChild+  , startNewChild+  , terminateChild+  , TerminateChildResult(..)+  , deleteChild+  , DeleteChildResult(..)+  , restartChild+  , RestartChildResult(..)+    -- * Normative Shutdown+  , shutdown+  , shutdownAndWait+    -- * Queries and Statistics+  , lookupChild+  , listChildren+  , SupervisorStats(..)+  , statistics+    -- * Additional (Misc) Types+  , StartFailure(..)+  , ChildInitFailure(..)+  ) where++import Control.DeepSeq (NFData)++import Control.Distributed.Process.Platform.Supervisor.Types+import Control.Distributed.Process hiding (call)+import Control.Distributed.Process.Serializable()+import Control.Distributed.Process.Platform.Internal.Primitives hiding (monitor)+import Control.Distributed.Process.Platform.Internal.Types+  ( ExitReason(..)+  )+import Control.Distributed.Process.Platform.ManagedProcess+  ( handleCall+  , handleInfo+  , reply+  , continue+  , stop+  , stopWith+  , input+  , defaultProcess+  , prioritised+  , InitHandler+  , InitResult(..)+  , ProcessAction+  , ProcessReply+  , ProcessDefinition(..)+  , PrioritisedProcessDefinition(..)+  , Priority(..)+  , DispatchPriority+  , UnhandledMessagePolicy(Drop)+  )+import qualified Control.Distributed.Process.Platform.ManagedProcess.UnsafeClient as Unsafe+  ( call+  , cast+  )+import qualified Control.Distributed.Process.Platform.ManagedProcess as MP+  ( pserve+  )+import Control.Distributed.Process.Platform.ManagedProcess.Server.Priority+  ( prioritiseCast_+  , prioritiseCall_+  , prioritiseInfo_+  , setPriority+  )+import Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted+  ( RestrictedProcess+  , Result+  , RestrictedAction+  , getState+  , putState+  )+import qualified Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted as Restricted+  ( handleCallIf+  , handleCall+  , handleCast+  , reply+  , continue+  )+-- import Control.Distributed.Process.Platform.ManagedProcess.Server.Unsafe+-- import Control.Distributed.Process.Platform.ManagedProcess.Server+import Control.Distributed.Process.Platform.Service.SystemLog+  ( LogClient+  , LogChan+  , LogText+  , Logger(..)+  )+import qualified Control.Distributed.Process.Platform.Service.SystemLog as Log+import Control.Distributed.Process.Platform.Time+import Control.Exception (SomeException, throwIO)++import Control.Monad.Error++import Data.Accessor+  ( Accessor+  , accessor+  , (^:)+  , (.>)+  , (^=)+  , (^.)+  )+import Data.Binary+import Data.Foldable (find, foldlM, toList)+import Data.List (foldl')+import qualified Data.List as List (delete)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Sequence+  ( Seq+  , ViewL(EmptyL, (:<))+  , ViewR(EmptyR, (:>))+  , (<|)+  , (|>)+  , (><)+  , filter)+import qualified Data.Sequence as Seq+import Data.Time.Clock+  ( NominalDiffTime+  , UTCTime+  , getCurrentTime+  , diffUTCTime+  )+import Data.Typeable (Typeable)++#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch, filter, init, rem)+#else+import Prelude hiding (filter, init, rem)+#endif++import GHC.Generics++--------------------------------------------------------------------------------+-- Types                                                                      --+--------------------------------------------------------------------------------++-- TODO: ToChildStart belongs with rest of types in+-- Control.Distributed.Process.Platform.Supervisor.Types++-- | A type that can be converted to a 'ChildStart'.+class ToChildStart a where+  toChildStart :: a -> Process ChildStart++instance ToChildStart (Closure (Process ())) where+  toChildStart = return . RunClosure++instance ToChildStart (Closure (SupervisorPid -> Process (ChildPid, Message))) where+  toChildStart = return . CreateHandle+++-- StarterProcess variants of ChildStart++expectTriple :: Process (SupervisorPid, ChildKey, SendPort ChildPid)+expectTriple = expect++instance ToChildStart (Process ()) where+  toChildStart proc = do+      starterPid <- spawnLocal $ do+        -- note [linking]: the first time we see the supervisor's pid,+        -- we must link to it, but only once, otherwise we simply waste+        -- time and resources creating duplicate links+        (supervisor, _, sendPidPort) <- expectTriple+        link supervisor+        spawnIt proc supervisor sendPidPort+        tcsProcLoop proc+      return (StarterProcess starterPid)+    where+      tcsProcLoop :: Process () -> Process ()+      tcsProcLoop p = forever' $ do+        (supervisor, _, sendPidPort) <- expectTriple+        spawnIt p supervisor sendPidPort++      spawnIt :: Process ()+              -> SupervisorPid+              -> SendPort ChildPid+              -> Process ()+      spawnIt proc' supervisor sendPidPort = do+        supervisedPid <- spawnLocal $ do+          link supervisor+          self <- getSelfPid+          (proc' `catches` [ Handler $ filterInitFailures supervisor self+                           , Handler $ logFailure supervisor self ])+            `catchesExit` [\_ m -> handleMessageIf m (== ExitShutdown)+                                                    (\_ -> return ())]+        sendChan sendPidPort supervisedPid++instance (Resolvable a) => ToChildStart (SupervisorPid -> Process a) where+  toChildStart proc = do+      starterPid <- spawnLocal $ do+        -- see note [linking] in the previous instance (above)+        (supervisor, _, sendPidPort) <- expectTriple+        link supervisor+        injectIt proc supervisor sendPidPort >> injectorLoop proc+      return $ StarterProcess starterPid+    where+      injectorLoop :: Resolvable a+                   => (SupervisorPid -> Process a)+                   -> Process ()+      injectorLoop p = forever' $ do+        (supervisor, _, sendPidPort) <- expectTriple+        injectIt p supervisor sendPidPort++      injectIt :: Resolvable a+               => (SupervisorPid -> Process a)+               -> SupervisorPid+               -> SendPort ChildPid+               -> Process ()+      injectIt proc' supervisor sendPidPort = do+        addr <- proc' supervisor+        mPid <- resolve addr+        case mPid of+          Nothing -> die "UnresolvableAddress in startChild instance"+          Just p  -> sendChan sendPidPort p++-- internal APIs. The corresponding XxxResult types are in+-- Control.Distributed.Process.Platform.Supervisor.Types++data DeleteChild = DeleteChild !ChildKey+  deriving (Typeable, Generic)+instance Binary DeleteChild where+instance NFData DeleteChild where++data FindReq = FindReq ChildKey+    deriving (Typeable, Generic)+instance Binary FindReq where+instance NFData FindReq where++data StatsReq = StatsReq+    deriving (Typeable, Generic)+instance Binary StatsReq where+instance NFData StatsReq where++data ListReq = ListReq+    deriving (Typeable, Generic)+instance Binary ListReq where+instance NFData ListReq where++type ImmediateStart = Bool++data AddChildReq = AddChild !ImmediateStart !ChildSpec+    deriving (Typeable, Generic, Show)+instance Binary AddChildReq where+instance NFData AddChildReq where++data AddChildRes = Exists ChildRef | Added State++data StartChildReq = StartChild !ChildKey+  deriving (Typeable, Generic)+instance Binary StartChildReq where+instance NFData StartChildReq where++data RestartChildReq = RestartChildReq !ChildKey+  deriving (Typeable, Generic, Show, Eq)+instance Binary RestartChildReq where+instance NFData RestartChildReq where++{-+data DelayedRestartReq = DelayedRestartReq !ChildKey !DiedReason+  deriving (Typeable, Generic, Show, Eq)+instance Binary DelayedRestartReq where+-}++data TerminateChildReq = TerminateChildReq !ChildKey+  deriving (Typeable, Generic, Show, Eq)+instance Binary TerminateChildReq where+instance NFData TerminateChildReq where++data IgnoreChildReq = IgnoreChildReq !ChildPid+  deriving (Typeable, Generic)+instance Binary IgnoreChildReq where+instance NFData IgnoreChildReq where++type ChildSpecs = Seq Child+type Prefix = ChildSpecs+type Suffix = ChildSpecs++data StatsType = Active | Specified++data LogSink = LogProcess !LogClient | LogChan++instance Logger LogSink where+  logMessage LogChan              = logMessage Log.logChannel+  logMessage (LogProcess client') = logMessage client'++data State = State {+    _specs           :: ChildSpecs+  , _active          :: Map ChildPid ChildKey+  , _strategy        :: RestartStrategy+  , _restartPeriod   :: NominalDiffTime+  , _restarts        :: [UTCTime]+  , _stats           :: SupervisorStats+  , _logger          :: LogSink+  , shutdownStrategy :: ShutdownMode+  }++--------------------------------------------------------------------------------+-- Starting/Running Supervisor                                                --+--------------------------------------------------------------------------------++-- | Start a supervisor (process), running the supplied children and restart+-- strategy.+--+-- > start = spawnLocal . run+--+start :: RestartStrategy -> ShutdownMode -> [ChildSpec] -> Process SupervisorPid+start rs ss cs = spawnLocal $ run rs ss cs++-- | Run the supplied children using the provided restart strategy.+--+run :: RestartStrategy -> ShutdownMode -> [ChildSpec] -> Process ()+run rs ss specs' = MP.pserve (rs, ss, specs') supInit serverDefinition++--------------------------------------------------------------------------------+-- Client Facing API                                                          --+--------------------------------------------------------------------------------++-- | Obtain statistics about a running supervisor.+--+statistics :: Addressable a => a -> Process (SupervisorStats)+statistics = (flip Unsafe.call) StatsReq++-- | Lookup a possibly supervised child, given its 'ChildKey'.+--+lookupChild :: Addressable a => a -> ChildKey -> Process (Maybe (ChildRef, ChildSpec))+lookupChild addr key = Unsafe.call addr $ FindReq key++-- | List all know (i.e., configured) children.+--+listChildren :: Addressable a => a -> Process [Child]+listChildren addr = Unsafe.call addr ListReq++-- | Add a new child.+--+addChild :: Addressable a => a -> ChildSpec -> Process AddChildResult+addChild addr spec = Unsafe.call addr $ AddChild False spec++-- | Start an existing (configured) child. The 'ChildSpec' must already be+-- present (see 'addChild'), otherwise the operation will fail.+--+startChild :: Addressable a => a -> ChildKey -> Process StartChildResult+startChild addr key = Unsafe.call addr $ StartChild key++-- | Atomically add and start a new child spec. Will fail if a child with+-- the given key is already present.+--+startNewChild :: Addressable a+           => a+           -> ChildSpec+           -> Process AddChildResult+startNewChild addr spec = Unsafe.call addr $ AddChild True spec++-- | Delete a supervised child. The child must already be stopped (see+-- 'terminateChild').+--+deleteChild :: Addressable a => a -> ChildKey -> Process DeleteChildResult+deleteChild sid childKey = Unsafe.call sid $ DeleteChild childKey++-- | Terminate a running child.+--+terminateChild :: Addressable a+               => a+               -> ChildKey+               -> Process TerminateChildResult+terminateChild sid = Unsafe.call sid . TerminateChildReq++-- | Forcibly restart a running child.+--+restartChild :: Addressable a+             => a+             -> ChildKey+             -> Process RestartChildResult+restartChild sid = Unsafe.call sid . RestartChildReq++-- | Gracefully terminate a running supervisor. Returns immediately if the+-- /address/ cannot be resolved.+--+shutdown :: Resolvable a => a -> Process ()+shutdown sid = do+  mPid <- resolve sid+  case mPid of+    Nothing -> return ()+    Just p  -> exit p ExitShutdown++-- | As 'shutdown', but waits until the supervisor process has exited, at which+-- point the caller can be sure that all children have also stopped. Returns+-- immediately if the /address/ cannot be resolved.+--+shutdownAndWait :: Resolvable a => a -> Process ()+shutdownAndWait sid = do+  mPid <- resolve sid+  case mPid of+    Nothing -> return ()+    Just p  -> withMonitor p $ do+      shutdown p+      receiveWait [ matchIf (\(ProcessMonitorNotification _ p' _) -> p' == p)+                            (\_ -> return ())+                  ]++--------------------------------------------------------------------------------+-- Server Initialisation/Startup                                              --+--------------------------------------------------------------------------------++supInit :: InitHandler (RestartStrategy, ShutdownMode, [ChildSpec]) State+supInit (strategy', shutdown', specs') = do+  logClient <- Log.client+  let client' = case logClient of+                  Nothing -> LogChan+                  Just c  -> LogProcess c+  let initState = ( ( -- as a NominalDiffTime (in seconds)+                      restartPeriod ^= configuredRestartPeriod+                    )+                  . (strategy ^= strategy')+                  . (logger   ^= client')+                  $ emptyState shutdown'+                  )+  -- TODO: should we return Ignore, as per OTP's supervisor, if no child starts?+  catch (foldlM initChild initState specs' >>= return . (flip InitOk) Infinity)+        (\(e :: SomeException) -> do+          sup <- getSelfPid+          logEntry Log.error $+            mkReport "Could not init supervisor " sup "noproc" (show e)+          return $ InitStop (show e))+  where+    initChild :: State -> ChildSpec -> Process State+    initChild st ch =+      case (findChild (childKey ch) st) of+        Just (ref, _) -> die $ StartFailureDuplicateChild ref+        Nothing       -> tryStartChild ch >>= initialised st ch++    configuredRestartPeriod =+      let maxT' = maxT (intensity strategy')+          tI    = asTimeout maxT'+          tMs   = (fromIntegral tI * (0.000001 :: Float))+      in fromRational (toRational tMs) :: NominalDiffTime++initialised :: State+            -> ChildSpec+            -> Either StartFailure ChildRef+            -> Process State+initialised _     _    (Left  err) = liftIO $ throwIO $ ChildInitFailure (show err)+initialised state spec (Right ref) = do+  mPid <- resolve ref+  case mPid of+    Nothing  -> die $ (childKey spec) ++ ": InvalidChildRef"+    Just childPid -> do+      return $ ( (active ^: Map.insert childPid chId)+               . (specs  ^: (|> (ref, spec)))+               $ bumpStats Active chType (+1) state+               )+  where chId   = childKey spec+        chType = childType spec++--------------------------------------------------------------------------------+-- Server Definition/State                                                    --+--------------------------------------------------------------------------------++emptyState :: ShutdownMode -> State+emptyState strat = State {+    _specs           = Seq.empty+  , _active          = Map.empty+  , _strategy        = restartAll+  , _restartPeriod   = (fromIntegral (0 :: Integer)) :: NominalDiffTime+  , _restarts        = []+  , _stats           = emptyStats+  , _logger          = LogChan+  , shutdownStrategy = strat+  }++emptyStats :: SupervisorStats+emptyStats = SupervisorStats {+    _children          = 0+  , _workers           = 0+  , _supervisors       = 0+  , _running           = 0+  , _activeSupervisors = 0+  , _activeWorkers     = 0+  , totalRestarts      = 0+--  , avgRestartFrequency   = 0+  }++serverDefinition :: PrioritisedProcessDefinition State+serverDefinition = prioritised processDefinition supPriorities+  where+    supPriorities :: [DispatchPriority State]+    supPriorities = [+        prioritiseCast_ (\(IgnoreChildReq _)                 -> setPriority 100)+      , prioritiseInfo_ (\(ProcessMonitorNotification _ _ _) -> setPriority 99 )+--      , prioritiseCast_ (\(DelayedRestartReq _ _)            -> setPriority 80 )+      , prioritiseCall_ (\(_ :: FindReq) ->+                          (setPriority 10) :: Priority (Maybe (ChildRef, ChildSpec)))+      ]++processDefinition :: ProcessDefinition State+processDefinition =+  defaultProcess {+    apiHandlers = [+       Restricted.handleCast   handleIgnore+       -- adding, removing and (optionally) starting new child specs+     , handleCall              handleTerminateChild+--     , handleCast              handleDelayedRestart+     , Restricted.handleCall   handleDeleteChild+     , Restricted.handleCallIf (input (\(AddChild immediate _) -> not immediate))+                               handleAddChild+     , handleCall              handleStartNewChild+     , handleCall              handleStartChild+     , handleCall              handleRestartChild+       -- stats/info+     , Restricted.handleCall   handleLookupChild+     , Restricted.handleCall   handleListChildren+     , Restricted.handleCall   handleGetStats+     ]+  , infoHandlers = [handleInfo handleMonitorSignal]+  , shutdownHandler = handleShutdown+  , unhandledMessagePolicy = Drop+  } :: ProcessDefinition State++--------------------------------------------------------------------------------+-- API Handlers                                                               --+--------------------------------------------------------------------------------++handleLookupChild :: FindReq+                  -> RestrictedProcess State (Result (Maybe (ChildRef, ChildSpec)))+handleLookupChild (FindReq key) = getState >>= Restricted.reply . findChild key++handleListChildren :: ListReq+                   -> RestrictedProcess State (Result [Child])+handleListChildren _ = getState >>= Restricted.reply . toList . (^. specs)++handleAddChild :: AddChildReq+               -> RestrictedProcess State (Result AddChildResult)+handleAddChild req = getState >>= return . doAddChild req True >>= doReply+  where doReply :: AddChildRes -> RestrictedProcess State (Result AddChildResult)+        doReply (Added  s) = putState s >> Restricted.reply (ChildAdded ChildStopped)+        doReply (Exists e) = Restricted.reply (ChildFailedToStart $ StartFailureDuplicateChild e)++handleIgnore :: IgnoreChildReq+                     -> RestrictedProcess State RestrictedAction+handleIgnore (IgnoreChildReq childPid) = do+  {- not only must we take this child out of the `active' field,+     we also delete the child spec if it's restart type is Temporary,+     since restarting Temporary children is dis-allowed -}+  state <- getState+  let (cId, active') =+        Map.updateLookupWithKey (\_ _ -> Nothing) childPid $ state ^. active+  case cId of+    Nothing -> Restricted.continue+    Just c  -> do+      putState $ ( (active ^= active')+                 . (resetChildIgnored c)+                 $ state+                 )+      Restricted.continue+  where+    resetChildIgnored :: ChildKey -> State -> State+    resetChildIgnored key state =+      maybe state id $ updateChild key (setChildStopped True) state++handleDeleteChild :: DeleteChild+                  -> RestrictedProcess State (Result DeleteChildResult)+handleDeleteChild (DeleteChild k) = getState >>= handleDelete k+  where+    handleDelete :: ChildKey+                 -> State+                 -> RestrictedProcess State (Result DeleteChildResult)+    handleDelete key state =+      let (prefix, suffix) = Seq.breakl ((== key) . childKey . snd) $ state ^. specs+      in case (Seq.viewl suffix) of+           EmptyL             -> Restricted.reply ChildNotFound+           child :< remaining -> tryDeleteChild child prefix remaining state++    tryDeleteChild (ref, spec) pfx sfx st+      | ref == ChildStopped = do+          putState $ ( (specs ^= pfx >< sfx)+                     $ bumpStats Specified (childType spec) decrement st+                     )+          Restricted.reply ChildDeleted+      | otherwise = Restricted.reply $ ChildNotStopped ref++handleStartChild :: State+                 -> StartChildReq+                 -> Process (ProcessReply StartChildResult State)+handleStartChild state (StartChild key) =+  let child = findChild key state in+  case child of+    Nothing ->+      reply ChildStartUnknownId state+    Just (ref@(ChildRunning _), _) ->+      reply (ChildStartFailed (StartFailureAlreadyRunning ref)) state+    Just (ref@(ChildRunningExtra _ _), _) ->+      reply (ChildStartFailed (StartFailureAlreadyRunning ref)) state+    Just (ref@(ChildRestarting _), _) ->+      reply (ChildStartFailed (StartFailureAlreadyRunning ref)) state+    Just (_, spec) -> do+      started <- doStartChild spec state+      case started of+        Left err         -> reply (ChildStartFailed err) state+        Right (ref, st') -> reply (ChildStartOk ref) st'++handleStartNewChild :: State+                 -> AddChildReq+                 -> Process (ProcessReply AddChildResult State)+handleStartNewChild state req@(AddChild _ spec) =+  let added = doAddChild req False state in+  case added of+    Exists e -> reply (ChildFailedToStart $ StartFailureDuplicateChild e) state+    Added  _ -> attemptStart state spec+  where+    attemptStart st ch = do+      started <- tryStartChild ch+      case started of+        Left err  -> reply (ChildFailedToStart err) $ removeChild spec st -- TODO: document this!+        Right ref -> do+          let st' = ( (specs ^: (|> (ref, spec)))+                    $ bumpStats Specified (childType spec) (+1) st+                    )+            in reply (ChildAdded ref) $ markActive st' ref ch++handleRestartChild :: State+                   -> RestartChildReq+                   -> Process (ProcessReply RestartChildResult State)+handleRestartChild state (RestartChildReq key) =+  let child = findChild key state in+  case child of+    Nothing ->+      reply ChildRestartUnknownId state+    Just (ref@(ChildRunning _), _) ->+      reply (ChildRestartFailed (StartFailureAlreadyRunning ref)) state+    Just (ref@(ChildRunningExtra _ _), _) ->+      reply (ChildRestartFailed (StartFailureAlreadyRunning ref)) state+    Just (ref@(ChildRestarting _), _) ->+      reply (ChildRestartFailed (StartFailureAlreadyRunning ref)) state+    Just (_, spec) -> do+      started <- doStartChild spec state+      case started of+        Left err         -> reply (ChildRestartFailed err) state+        Right (ref, st') -> reply (ChildRestartOk ref) st'++{-+handleDelayedRestart :: State+                     -> DelayedRestartReq+                     -> Process (ProcessAction State)+handleDelayedRestart state (DelayedRestartReq key reason) =+  let child = findChild key state in+  case child of+    Nothing ->+      continue state -- a child could've been terminated and removed by now+    Just ((ChildRestarting childPid), spec) -> do+      -- TODO: we ignore the unnecessary .active re-assignments in+      -- tryRestartChild, in order to keep the code simple - it would be good to+      -- clean this up so we don't have to though...+      tryRestartChild childPid state (state ^. active) spec reason+-}++handleTerminateChild :: State+                     -> TerminateChildReq+                     -> Process (ProcessReply TerminateChildResult State)+handleTerminateChild state (TerminateChildReq key) =+  let child = findChild key state in+  case child of+    Nothing ->+      reply TerminateChildUnknownId state+    Just (ChildStopped, _) ->+      reply TerminateChildOk state+    Just (ref, spec) ->+      reply TerminateChildOk =<< doTerminateChild ref spec state++handleGetStats :: StatsReq+               -> RestrictedProcess State (Result SupervisorStats)+handleGetStats _ = Restricted.reply . (^. stats) =<< getState++--------------------------------------------------------------------------------+-- Child Monitoring                                                           --+--------------------------------------------------------------------------------++handleMonitorSignal :: State+                    -> ProcessMonitorNotification+                    -> Process (ProcessAction State)+handleMonitorSignal state (ProcessMonitorNotification _ childPid reason) = do+  let (cId, active') =+        Map.updateLookupWithKey (\_ _ -> Nothing) childPid $ state ^. active+  let mSpec =+        case cId of+          Nothing -> Nothing+          Just c  -> fmap snd $ findChild c state+  case mSpec of+    Nothing   -> continue $ (active ^= active') state+    Just spec -> tryRestart childPid state active' spec reason++--------------------------------------------------------------------------------+-- Child Monitoring                                                           --+--------------------------------------------------------------------------------++handleShutdown :: State -> ExitReason -> Process ()+handleShutdown state (ExitOther reason) = terminateChildren state >> die reason+handleShutdown state _                  = terminateChildren state++--------------------------------------------------------------------------------+-- Child Start/Restart Handling                                               --+--------------------------------------------------------------------------------++tryRestart :: ChildPid+           -> State+           -> Map ChildPid ChildKey+           -> ChildSpec+           -> DiedReason+           -> Process (ProcessAction State)+tryRestart childPid state active' spec reason = do+  sup <- getSelfPid+  logEntry Log.debug $ do+    mkReport "tryRestart" sup (childKey spec) (show reason)+  case state ^. strategy of+    RestartOne _ -> tryRestartChild childPid state active' spec reason+    strat        -> do+      case (childRestart spec, isNormal reason) of+        (Intrinsic, True) -> stopWith newState ExitNormal+        (Transient, True) -> continue newState+        (Temporary, _)    -> continue removeTemp+        _                 -> tryRestartBranch strat spec reason $ newState+  where+    newState = (active ^= active') state++    removeTemp = removeChild spec $ newState++    isNormal (DiedException _) = False+    isNormal _                 = True++tryRestartBranch :: RestartStrategy+                 -> ChildSpec+                 -> DiedReason+                 -> State+                 -> Process (ProcessAction State)+tryRestartBranch rs sp dr st = -- TODO: use DiedReason for logging...+  let mode' = mode rs+      tree' = case rs of+                RestartAll   _ _ -> childSpecs+                RestartLeft  _ _ -> subTreeL+                RestartRight _ _ -> subTreeR+                _                  -> error "IllegalState"+      proc  = case mode' of+                RestartEach     _ -> stopStart+                RestartInOrder  _ -> restartL+                RestartRevOrder _ -> reverseRestart+      dir'  = order mode' in do+    proc tree' dir'+  where+    stopStart :: ChildSpecs -> RestartOrder -> Process (ProcessAction State)+    stopStart tree order' = do+      let tree' = case order' of+                    LeftToRight -> tree+                    RightToLeft -> Seq.reverse tree+      state <- addRestart activeState+      case state of+        Nothing  -> die errorMaxIntensityReached+        Just st' -> apply (foldlM stopStartIt st' tree')++    reverseRestart :: ChildSpecs+                   -> RestartOrder+                   -> Process (ProcessAction State)+    reverseRestart tree LeftToRight = restartL tree RightToLeft -- force re-order+    reverseRestart tree dir@(RightToLeft) = restartL (Seq.reverse tree) dir++    -- TODO: rename me for heaven's sake - this ISN'T a left biased traversal after all!+    restartL :: ChildSpecs -> RestartOrder -> Process (ProcessAction State)+    restartL tree ro = do+      let rev   = (ro == RightToLeft)+      let tree' = case rev of+                    False -> tree+                    True  -> Seq.reverse tree+      state <- addRestart activeState+      case state of+        Nothing -> die errorMaxIntensityReached+        Just st' -> foldlM stopIt st' tree >>= \s -> do+                     apply $ foldlM startIt s tree'++    stopStartIt :: State -> Child -> Process State+    stopStartIt s ch@(cr, cs) = doTerminateChild cr cs s >>= (flip startIt) ch++    stopIt :: State -> Child -> Process State+    stopIt s (cr, cs) = doTerminateChild cr cs s++    startIt :: State -> Child -> Process State+    startIt s (_, cs)+      | isTemporary (childRestart cs) = return $ removeChild cs s+      | otherwise                     = ensureActive cs =<< doStartChild cs s++    -- Note that ensureActive will kill this (supervisor) process if+    -- doStartChild fails, simply because the /only/ failure that can+    -- come out of that function (as `Left err') is *bad closure* and+    -- that should have either been picked up during init (i.e., caused+    -- the super to refuse to start) or been removed during `startChild'+    -- or later on. Any other kind of failure will crop up (once we've+    -- finished the restart sequence) as a monitor signal.+    ensureActive :: ChildSpec+                 -> Either StartFailure (ChildRef, State)+                 -> Process State+    ensureActive cs it+      | (Right (ref, st')) <- it = return $ markActive st' ref cs+      | (Left err) <- it = die $ ExitOther $ (childKey cs) ++ ": " ++ (show err)+      | otherwise = error "IllegalState"++    apply :: (Process State) -> Process (ProcessAction State)+    apply proc = do+      catchExit (proc >>= continue) (\(_ :: ProcessId) -> stop)++    activeState = maybe st id $ updateChild (childKey sp)+                                            (setChildStopped False) st++    subTreeL :: ChildSpecs+    subTreeL =+      let (prefix, suffix) = splitTree Seq.breakl+      in case (Seq.viewl suffix) of+           child :< _ -> prefix |> child+           EmptyL     -> prefix++    subTreeR :: ChildSpecs+    subTreeR =+      let (prefix, suffix) = splitTree Seq.breakr+      in case (Seq.viewr suffix) of+           _ :> child -> child <| prefix+           EmptyR     -> prefix++    splitTree splitWith = splitWith ((== childKey sp) . childKey . snd) childSpecs++    childSpecs :: ChildSpecs+    childSpecs =+      let cs  = activeState ^. specs+          ck  = childKey sp+          rs' = childRestart sp+      in case (isTransient rs', isTemporary rs', dr) of+           (True, _, DiedNormal) -> filter ((/= ck) . childKey . snd) cs+           (_, True, _)          -> filter ((/= ck) . childKey . snd) cs+           _                     -> cs++{-  restartParallel :: ChildSpecs+                    -> RestartOrder+                    -> Process (ProcessAction State)+    restartParallel tree order = do+      liftIO $ putStrLn "handling parallel restart"+      let tree'    = case order of+                       LeftToRight -> tree+                       RightToLeft -> Seq.reverse tree++      -- TODO: THIS IS INCORRECT... currently (below), we terminate+      -- the branch in parallel, but wait on all the exits and then+      -- restart sequentially (based on 'order'). That's not what the+      -- 'RestartParallel' mode advertised, but more importantly, it's+      -- not clear what the semantics for error handling (viz restart errors)+      -- should actually be.++      asyncs <- forM (toList tree') $ \ch -> async $ asyncTerminate ch+      (_errs, st') <- foldlM collectExits ([], activeState) asyncs+      -- TODO: report errs+      apply $ foldlM startIt st' tree'+      where+        asyncTerminate :: Child -> Process (Maybe (ChildKey, ChildPid))+        asyncTerminate (cr, cs) = do+          mPid <- resolve cr+          case mPid of+            Nothing  -> return Nothing+            Just childPid -> do+              void $ doTerminateChild cr cs activeState+              return $ Just (childKey cs, childPid)++        collectExits :: ([ExitReason], State)+                     -> Async (Maybe (ChildKey, ChildPid))+                     -> Process ([ExitReason], State)+        collectExits (errs, state) hAsync = do+          -- we perform a blocking wait on each handle, since we'll+          -- always wait until the last shutdown has occurred anyway+          asyncResult <- wait hAsync+          let res = mergeState asyncResult state+          case res of+            Left err -> return ((err:errs), state)+            Right st -> return (errs, st)++        mergeState :: AsyncResult (Maybe (ChildKey, ChildPid))+                   -> State+                   -> Either ExitReason State+        mergeState (AsyncDone Nothing)           state = Right state+        mergeState (AsyncDone (Just (key, childPid))) state = Right $ mergeIt key childPid state+        mergeState (AsyncFailed r)               _     = Left $ ExitOther (show r)+        mergeState (AsyncLinkFailed r)           _     = Left $ ExitOther (show r)+        mergeState _                             _     = Left $ ExitOther "IllegalState"++        mergeIt :: ChildKey -> ChildPid -> State -> State+        mergeIt key childPid state =+          -- TODO: lookup the old ref -> childPid and delete from the active map+          ( (active ^: Map.delete childPid)+          $ maybe state id (updateChild key (setChildStopped False) state)+          )+    -}++tryRestartChild :: ChildPid+                -> State+                -> Map ChildPid ChildKey+                -> ChildSpec+                -> DiedReason+                -> Process (ProcessAction State)+tryRestartChild childPid st active' spec reason+  | DiedNormal <- reason+  , True       <- isTransient (childRestart spec) = continue childDown+  | True       <- isTemporary (childRestart spec) = continue childRemoved+  | DiedNormal <- reason+  , True       <- isIntrinsic (childRestart spec) = stopWith updateStopped ExitNormal+  | otherwise     = doRestartChild childPid spec reason st+  where+    childDown     = (active ^= active') $ updateStopped+    childRemoved  = (active ^= active') $ removeChild spec st+    updateStopped = maybe st id $ updateChild chKey (setChildStopped False) st+    chKey         = childKey spec++doRestartChild :: ChildPid -> ChildSpec -> DiedReason -> State -> Process (ProcessAction State)+doRestartChild _ spec _ state = do -- TODO: use ChildPid and DiedReason to log+  state' <- addRestart state+  case state' of+    Nothing -> die errorMaxIntensityReached+--      case restartPolicy of+--        Restart _            -> die errorMaxIntensityReached+--        DelayedRestart _ del -> doRestartDelay oldPid del spec reason state+    Just st -> do+      start' <- doStartChild spec st+      case start' of+        Right (ref, st') -> continue $ markActive st' ref spec+        Left err -> do+          -- All child failures are handled via monitor signals, apart from+          -- BadClosure and UnresolvableAddress from the StarterProcess+          -- variants of ChildStart, which both come back from+          -- doStartChild as (Left err).+          sup <- getSelfPid+          if isTemporary (childRestart spec)+             then do+               logEntry Log.warning $+                 mkReport "Error in temporary child" sup (childKey spec) (show err)+               continue $ ( (active ^: Map.filter (/= chKey))+                   . (bumpStats Active chType decrement)+                   . (bumpStats Specified chType decrement)+                   $ removeChild spec st)+             else do+               logEntry Log.error $+                 mkReport "Unrecoverable error in child. Stopping supervisor"+                 sup (childKey spec) (show err)+               stopWith st $ ExitOther $ "Unrecoverable error in child " ++ (childKey spec)++  where+    chKey  = childKey spec+    chType = childType spec++{-+doRestartDelay :: ChildPid+               -> TimeInterval+               -> ChildSpec+               -> DiedReason+               -> State+               -> Process State+doRestartDelay oldPid rDelay spec reason state = do+  self <- getSelfPid+  _ <- runAfter rDelay $ MP.cast self (DelayedRestartReq (childKey spec) reason)+  return $ ( (active ^: Map.filter (/= chKey))+           . (bumpStats Active chType decrement)+           $ maybe state id (updateChild chKey (setChildRestarting oldPid) state)+           )+  where+    chKey  = childKey spec+    chType = childType spec+-}++addRestart :: State -> Process (Maybe State)+addRestart state = do+  now <- liftIO $ getCurrentTime+  let acc = foldl' (accRestarts now) [] (now:restarted)+  case length acc of+    n | n > maxAttempts -> return Nothing+    _                   -> return $ Just $ (restarts ^= acc) $ state+  where+    maxAttempts  = maxNumberOfRestarts $ maxR $ maxIntensity+    slot         = state ^. restartPeriod+    restarted    = state ^. restarts+    maxIntensity = state ^. strategy .> restartIntensity++    accRestarts :: UTCTime -> [UTCTime] -> UTCTime -> [UTCTime]+    accRestarts now' acc r =+      let diff = diffUTCTime now' r in+      if diff > slot then acc else (r:acc)++doStartChild :: ChildSpec+             -> State+             -> Process (Either StartFailure (ChildRef, State))+doStartChild spec st = do+  restart <- tryStartChild spec+  case restart of+    Left f  -> return $ Left f+    Right p -> do+      let mState = updateChild chKey (chRunning p) st+      case mState of+        -- TODO: better error message if the child is unrecognised+        Nothing -> die $ "InternalError in doStartChild " ++ show spec+        Just s' -> return $ Right $ (p, markActive s' p spec)+  where+    chKey = childKey spec++    chRunning :: ChildRef -> Child -> Prefix -> Suffix -> State -> Maybe State+    chRunning newRef (_, chSpec) prefix suffix st' =+      Just $ ( (specs ^= prefix >< ((newRef, chSpec) <| suffix))+             $ bumpStats Active (childType spec) (+1) st'+             )++tryStartChild :: ChildSpec+              -> Process (Either StartFailure ChildRef)+tryStartChild ChildSpec{..} =+    case childStart of+      RunClosure proc -> do+        -- TODO: cache your closures!!!+        mProc <- catch (unClosure proc >>= return . Right)+                       (\(e :: SomeException) -> return $ Left (show e))+        case mProc of+          Left err -> logStartFailure $ StartFailureBadClosure err+          Right p  -> wrapClosure childRegName p >>= return . Right+      CreateHandle fn -> do+        mFn <- catch (unClosure fn >>= return . Right)+                     (\(e :: SomeException) -> return $ Left (show e))+        case mFn of+          Left err  -> logStartFailure $ StartFailureBadClosure err+          Right fn' -> do+            wrapHandle childRegName fn' >>= return . Right+      StarterProcess starterPid ->+          wrapRestarterProcess childRegName starterPid+  where+    logStartFailure sf = do+      sup <- getSelfPid+      logEntry Log.error $ mkReport "Child Start Error" sup childKey (show sf)+      return $ Left sf++    wrapClosure :: Maybe RegisteredName+                -> Process ()+                -> Process ChildRef+    wrapClosure regName proc = do+      supervisor <- getSelfPid+      childPid <- spawnLocal $ do+        self <- getSelfPid+        link supervisor -- die if our parent dies+        maybeRegister regName self+        () <- expect    -- wait for a start signal (pid is still private)+        -- we translate `ExitShutdown' into a /normal/ exit+        (proc `catches` [ Handler $ filterInitFailures supervisor self+                        , Handler $ logFailure supervisor self ])+          `catchesExit` [+            (\_ m -> handleMessageIf m (== ExitShutdown)+                                       (\_ -> return ()))]+      void $ monitor childPid+      send childPid ()+      return $ ChildRunning childPid++    wrapHandle :: Maybe RegisteredName+               -> (SupervisorPid -> Process (ChildPid, Message))+               -> Process ChildRef+    wrapHandle regName proc = do+      super <- getSelfPid+      (childPid, msg) <- proc super+      maybeRegister regName childPid+      void $ monitor childPid+      return $ ChildRunningExtra childPid msg++    wrapRestarterProcess :: Maybe RegisteredName+                         -> StarterPid+                         -> Process (Either StartFailure ChildRef)+    wrapRestarterProcess regName starterPid = do+      sup <- getSelfPid+      (sendPid, recvPid) <- newChan+      ref <- monitor starterPid+      send starterPid (sup, childKey, sendPid)+      ePid <- receiveWait [+                -- TODO: tighten up this contract to correct for erroneous mail+                matchChan recvPid (\(pid :: ChildPid) -> return $ Right pid)+              , matchIf (\(ProcessMonitorNotification mref _ dr) ->+                           mref == ref && dr /= DiedNormal)+                        (\(ProcessMonitorNotification _ _ dr) ->+                           return $ Left dr)+              ] `finally` (unmonitor ref)+      case ePid of+        Right pid -> do+          maybeRegister regName pid+          void $ monitor pid+          return $ Right $ ChildRunning pid+        Left dr -> return $ Left $ StartFailureDied dr+++    maybeRegister :: Maybe RegisteredName -> ChildPid -> Process ()+    maybeRegister Nothing                         _     = return ()+    maybeRegister (Just (LocalName n))            pid   = register n pid+    maybeRegister (Just (GlobalName _))           _     = return ()+    maybeRegister (Just (CustomRegister clj))     pid   = do+        -- TODO: cache your closures!!!+        mProc <- catch (unClosure clj >>= return . Right)+                       (\(e :: SomeException) -> return $ Left (show e))+        case mProc of+          Left err -> die $ ExitOther (show err)+          Right p  -> p pid++filterInitFailures :: SupervisorPid+                   -> ChildPid+                   -> ChildInitFailure+                   -> Process ()+filterInitFailures sup childPid ex = do+  case ex of+    ChildInitFailure _ -> do+      -- This is used as a `catches` handler in multiple places+      -- and matches first before the other handlers that+      -- would call logFailure.+      -- We log here to avoid silent failure in those cases.+      logEntry Log.error $ mkReport "ChildInitFailure" sup (show childPid) (show ex)+      liftIO $ throwIO ex+    ChildInitIgnore    -> Unsafe.cast sup $ IgnoreChildReq childPid++--------------------------------------------------------------------------------+-- Child Termination/Shutdown                                                 --+--------------------------------------------------------------------------------++terminateChildren :: State -> Process ()+terminateChildren state = do+  case (shutdownStrategy state) of+    ParallelShutdown -> do+      let allChildren = toList $ state ^. specs+      terminatorPids <- forM allChildren $ \ch -> do+        pid <- spawnLocal $ void $ syncTerminate ch $ (active ^= Map.empty) state+        void $ monitor pid+        return pid+      terminationErrors <- collectExits [] terminatorPids+      -- it seems these would also be logged individually in doTerminateChild+      case terminationErrors of+        [] -> return ()+        _ -> do+          sup <- getSelfPid+          void $ logEntry Log.error $+            mkReport "Errors in terminateChildren / ParallelShutdown"+            sup "n/a" (show terminationErrors)+    SequentialShutdown ord -> do+      let specs'      = state ^. specs+      let allChildren = case ord of+                          RightToLeft -> Seq.reverse specs'+                          LeftToRight -> specs'+      void $ foldlM (flip syncTerminate) state (toList allChildren)+  where+    syncTerminate :: Child -> State -> Process State+    syncTerminate (cr, cs) state' = doTerminateChild cr cs state'++    collectExits :: [(ProcessId, DiedReason)]+                 -> [ChildPid]+                 -> Process [(ProcessId, DiedReason)]+    collectExits errors []   = return errors+    collectExits errors pids = do+      (pid, reason) <- receiveWait [+          match (\(ProcessMonitorNotification _ pid' reason') -> do+                    return (pid', reason'))+        ]+      let remaining = List.delete pid pids+      case reason of+        DiedNormal -> collectExits errors                 remaining+        _          -> collectExits ((pid, reason):errors) remaining++doTerminateChild :: ChildRef -> ChildSpec -> State -> Process State+doTerminateChild ref spec state = do+  mPid <- resolve ref+  case mPid of+    Nothing  -> return state -- an already dead child is not an error+    Just pid -> do+      stopped <- childShutdown (childStop spec) pid state+      state' <- shutdownComplete state pid stopped+      return $ ( (active ^: Map.delete pid)+               $ state'+               )+  where+    shutdownComplete :: State -> ChildPid -> DiedReason -> Process State+    shutdownComplete _      _   DiedNormal        = return $ updateStopped+    shutdownComplete state' pid (r :: DiedReason) = do+      logShutdown (state' ^. logger) chKey pid r >> return state'++    chKey         = childKey spec+    updateStopped = maybe state id $ updateChild chKey (setChildStopped False) state++childShutdown :: ChildTerminationPolicy+              -> ChildPid+              -> State+              -> Process DiedReason+childShutdown policy childPid st = do+  case policy of+    (TerminateTimeout t) -> exit childPid ExitShutdown >> await childPid t st+    -- we ignore DiedReason for brutal kills+    TerminateImmediately -> do+      kill childPid "TerminatedBySupervisor"+      void $ await childPid Infinity st+      return DiedNormal+  where+    await :: ChildPid -> Delay -> State -> Process DiedReason+    await childPid' delay state = do+      let monitored = (Map.member childPid' $ state ^. active)+      let recv = case delay of+                   Infinity -> receiveWait (matches childPid') >>= return . Just+                   NoDelay  -> receiveTimeout 0 (matches childPid')+                   Delay t  -> receiveTimeout (asTimeout t) (matches childPid')+      -- We require and additional monitor here when child shutdown occurs+      -- during a restart which was triggered by the /old/ monitor signal.+      let recv' =  if monitored then recv else withMonitor childPid' recv+      recv' >>= maybe (childShutdown TerminateImmediately childPid' state) return++    matches :: ChildPid -> [Match DiedReason]+    matches p = [+          matchIf (\(ProcessMonitorNotification _ p' _) -> p == p')+                  (\(ProcessMonitorNotification _ _ r) -> return r)+        ]++--------------------------------------------------------------------------------+-- Loging/Reporting                                                          --+--------------------------------------------------------------------------------++errorMaxIntensityReached :: ExitReason+errorMaxIntensityReached = ExitOther "ReachedMaxRestartIntensity"++logShutdown :: LogSink -> ChildKey -> ChildPid -> DiedReason -> Process ()+logShutdown log' child childPid reason = do+    sup <- getSelfPid+    Log.info log' $ mkReport banner sup (show childPid) shutdownReason+  where+    banner         = "Child Shutdown Complete"+    shutdownReason = (show reason) ++ ", child-key: " ++ child++logFailure :: SupervisorPid -> ChildPid -> SomeException -> Process ()+logFailure sup childPid ex = do+  logEntry Log.notice $ mkReport "Detected Child Exit" sup (show childPid) (show ex)+  liftIO $ throwIO ex++logEntry :: (LogChan -> LogText -> Process ()) -> String -> Process ()+logEntry lg = Log.report lg Log.logChannel++mkReport :: String -> SupervisorPid -> String -> String -> String+mkReport b s c r = foldl' (\x xs -> xs ++ " " ++ x) "" items+  where+    items :: [String]+    items = [ "[" ++ s' ++ "]" | s' <- [ b+                                       , "supervisor: " ++ show s+                                       , "child: " ++ c+                                       , "reason: " ++ r] ]++--------------------------------------------------------------------------------+-- Accessors and State/Stats Utilities                                        --+--------------------------------------------------------------------------------++type Ignored = Bool++-- TODO: test that setChildStopped does not re-order the 'specs sequence++setChildStopped ::  Ignored -> Child -> Prefix -> Suffix -> State -> Maybe State+setChildStopped ignored child prefix remaining st =+  let spec   = snd child+      rType  = childRestart spec+      newRef = if ignored then ChildStartIgnored else ChildStopped+  in case isTemporary rType of+    True  -> Just $ (specs ^= prefix >< remaining) $ st+    False -> Just $ (specs ^= prefix >< ((newRef, spec) <| remaining)) st++{-+setChildRestarting :: ChildPid -> Child -> Prefix -> Suffix -> State -> Maybe State+setChildRestarting oldPid child prefix remaining st =+  let spec   = snd child+      newRef = ChildRestarting oldPid+  in Just $ (specs ^= prefix >< ((newRef, spec) <| remaining)) st+-}++doAddChild :: AddChildReq -> Bool -> State -> AddChildRes+doAddChild (AddChild _ spec) update st =+  let chType = childType spec+  in case (findChild (childKey spec) st) of+       Just (ref, _) -> Exists ref+       Nothing ->+         case update of+           True  -> Added $ ( (specs ^: (|> (ChildStopped, spec)))+                           $ bumpStats Specified chType (+1) st+                           )+           False -> Added st++updateChild :: ChildKey+            -> (Child -> Prefix -> Suffix -> State -> Maybe State)+            -> State+            -> Maybe State+updateChild key updateFn state =+  let (prefix, suffix) = Seq.breakl ((== key) . childKey . snd) $ state ^. specs+  in case (Seq.viewl suffix) of+    EmptyL             -> Nothing+    child :< remaining -> updateFn child prefix remaining state++removeChild :: ChildSpec -> State -> State+removeChild spec state =+  let k = childKey spec+  in specs ^: filter ((/= k) . childKey . snd) $ state++-- DO NOT call this function unless you've verified the ChildRef first.+markActive :: State -> ChildRef -> ChildSpec -> State+markActive state ref spec =+  case ref of+    ChildRunning (pid :: ChildPid)   -> inserted pid+    ChildRunningExtra pid _         -> inserted pid+    _                               -> error $ "InternalError"+  where+    inserted pid' = active ^: Map.insert pid' (childKey spec) $ state++decrement :: Int -> Int+decrement n = n - 1++-- this is O(n) in the worst case, which is a bit naff, but we+-- can optimise it later with a different data structure, if required+findChild :: ChildKey -> State -> Maybe (ChildRef, ChildSpec)+findChild key st = find ((== key) . childKey . snd) $ st ^. specs++bumpStats :: StatsType -> ChildType -> (Int -> Int) -> State -> State+bumpStats Specified Supervisor fn st = (bump fn) . (stats .> supervisors ^: fn) $ st+bumpStats Specified Worker     fn st = (bump fn) . (stats .> workers ^: fn) $ st+bumpStats Active    Worker     fn st = (stats .> running ^: fn) . (stats .> activeWorkers ^: fn) $ st+bumpStats Active    Supervisor fn st = (stats .> running ^: fn) . (stats .> activeSupervisors ^: fn) $ st++bump :: (Int -> Int) -> State -> State+bump with' = stats .> children ^: with'++isTemporary :: RestartPolicy -> Bool+isTemporary = (== Temporary)++isTransient :: RestartPolicy -> Bool+isTransient = (== Transient)++isIntrinsic :: RestartPolicy -> Bool+isIntrinsic = (== Intrinsic)++active :: Accessor State (Map ChildPid ChildKey)+active = accessor _active (\act' st -> st { _active = act' })++strategy :: Accessor State RestartStrategy+strategy = accessor _strategy (\s st -> st { _strategy = s })++restartIntensity :: Accessor RestartStrategy RestartLimit+restartIntensity = accessor intensity (\i l -> l { intensity = i })++restartPeriod :: Accessor State NominalDiffTime+restartPeriod = accessor _restartPeriod (\p st -> st { _restartPeriod = p })++restarts :: Accessor State [UTCTime]+restarts = accessor _restarts (\r st -> st { _restarts = r })++specs :: Accessor State ChildSpecs+specs = accessor _specs (\sp' st -> st { _specs = sp' })++stats :: Accessor State SupervisorStats+stats = accessor _stats (\st' st -> st { _stats = st' })++logger :: Accessor State LogSink+logger = accessor _logger (\l st -> st { _logger = l })++children :: Accessor SupervisorStats Int+children = accessor _children (\c st -> st { _children = c })++workers :: Accessor SupervisorStats Int+workers = accessor _workers (\c st -> st { _workers = c })++running :: Accessor SupervisorStats Int+running = accessor _running (\r st -> st { _running = r })++supervisors :: Accessor SupervisorStats Int+supervisors = accessor _supervisors (\c st -> st { _supervisors = c })++activeWorkers :: Accessor SupervisorStats Int+activeWorkers = accessor _activeWorkers (\c st -> st { _activeWorkers = c })++activeSupervisors :: Accessor SupervisorStats Int+activeSupervisors = accessor _activeSupervisors (\c st -> st { _activeSupervisors = c })
+ src/Control/Distributed/Process/Platform/Supervisor/Types.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE DeriveGeneric  #-}+{-# LANGUAGE DeriveDataTypeable  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Supervisor.Types+-- Copyright   :  (c) Tim Watson 2012+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Supervisor.Types+  ( -- * Defining and Running a Supervisor+    ChildSpec(..)+  , ChildKey+  , ChildType(..)+  , ChildTerminationPolicy(..)+  , ChildStart(..)+  , RegisteredName(LocalName, GlobalName, CustomRegister)+  , RestartPolicy(..)+  , ChildRef(..)+  , isRunning+  , isRestarting+  , Child+  , StaticLabel+  , SupervisorPid+  , ChildPid+  , StarterPid+    -- * Limits and Defaults+  , MaxRestarts(..)+  , maxRestarts+  , RestartLimit(..)+  , limit+  , defaultLimits+  , RestartMode(..)+  , RestartOrder(..)+  , RestartStrategy(..)+  , ShutdownMode(..)+  , restartOne+  , restartAll+  , restartLeft+  , restartRight+    -- * Adding and Removing Children+  , AddChildResult(..)+  , StartChildResult(..)+  , TerminateChildResult(..)+  , DeleteChildResult(..)+  , RestartChildResult(..)+    -- * Additional (Misc) Types+  , SupervisorStats(..)+  , StartFailure(..)+  , ChildInitFailure(..)+  ) where++import GHC.Generics+import Data.Typeable (Typeable)+import Data.Binary++import Control.DeepSeq (NFData)+import Control.Distributed.Process hiding (call)+import Control.Distributed.Process.Serializable()+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Platform.Internal.Primitives hiding (monitor)+import Control.Exception (Exception)++-- aliases for api documentation purposes+type SupervisorPid = ProcessId+type ChildPid = ProcessId+type StarterPid = ProcessId++newtype MaxRestarts = MaxR { maxNumberOfRestarts :: Int }+  deriving (Typeable, Generic, Show)+instance Binary MaxRestarts where+instance NFData MaxRestarts where++-- | Smart constructor for @MaxRestarts@. The maximum+-- restart count must be a positive integer.+maxRestarts :: Int -> MaxRestarts+maxRestarts r | r >= 0    = MaxR r+              | otherwise = error "MaxR must be >= 0"++-- | A compulsary limit on the number of restarts that a supervisor will+-- tolerate before it terminates all child processes and then itself.+-- If > @MaxRestarts@ occur within the specified @TimeInterval@, termination+-- will occur. This prevents the supervisor from entering an infinite loop of+-- child process terminations and restarts.+--+data RestartLimit =+  RestartLimit+  { maxR :: !MaxRestarts+  , maxT :: !TimeInterval+  }+  deriving (Typeable, Generic, Show)+instance Binary RestartLimit where+instance NFData RestartLimit where++limit :: MaxRestarts -> TimeInterval -> RestartLimit+limit mr = RestartLimit mr++defaultLimits :: RestartLimit+defaultLimits = limit (MaxR 1) (seconds 1)++data RestartOrder = LeftToRight | RightToLeft+  deriving (Typeable, Generic, Eq, Show)+instance Binary RestartOrder where+instance NFData RestartOrder where++-- TODO: rename these, somehow...+data RestartMode =+    RestartEach     { order :: !RestartOrder }+    {- ^ stop then start each child sequentially, i.e., @foldlM stopThenStart children@ -}+  | RestartInOrder  { order :: !RestartOrder }+    {- ^ stop all children first, then restart them sequentially -}+  | RestartRevOrder { order :: !RestartOrder }+    {- ^ stop all children in the given order, but start them in reverse -}+  deriving (Typeable, Generic, Show, Eq)+instance Binary RestartMode where+instance NFData RestartMode where++data ShutdownMode = SequentialShutdown !RestartOrder+                      | ParallelShutdown+  deriving (Typeable, Generic, Show, Eq)+instance Binary ShutdownMode where+instance NFData ShutdownMode where++-- | Strategy used by a supervisor to handle child restarts, whether due to+-- unexpected child failure or explicit restart requests from a client.+--+-- Some terminology: We refer to child processes managed by the same supervisor+-- as /siblings/. When restarting a child process, the 'RestartNone' policy+-- indicates that sibling processes should be left alone, whilst the 'RestartAll'+-- policy will cause /all/ children to be restarted (in the same order they were+-- started).+--+-- The other two restart strategies refer to /prior/ and /subsequent/+-- siblings, which describe's those children's configured position+-- (i.e., insertion order). These latter modes allow one to control the order+-- in which siblings are restarted, and to exclude some siblings from the restart+-- without having to resort to grouping them using a child supervisor.+--+data RestartStrategy =+    RestartOne+    { intensity        :: !RestartLimit+    } -- ^ restart only the failed child process+  | RestartAll+    { intensity        :: !RestartLimit+    , mode             :: !RestartMode+    } -- ^ also restart all siblings+  | RestartLeft+    { intensity        :: !RestartLimit+    , mode             :: !RestartMode+    } -- ^ restart prior siblings (i.e., prior /start order/)+  | RestartRight+    { intensity        :: !RestartLimit+    , mode             :: !RestartMode+    } -- ^ restart subsequent siblings (i.e., subsequent /start order/)+  deriving (Typeable, Generic, Show)+instance Binary RestartStrategy where+instance NFData RestartStrategy where++-- | Provides a default 'RestartStrategy' for @RestartOne@.+-- > restartOne = RestartOne defaultLimits+--+restartOne :: RestartStrategy+restartOne = RestartOne defaultLimits++-- | Provides a default 'RestartStrategy' for @RestartAll@.+-- > restartOne = RestartAll defaultLimits (RestartEach LeftToRight)+--+restartAll :: RestartStrategy+restartAll = RestartAll defaultLimits (RestartEach LeftToRight)++-- | Provides a default 'RestartStrategy' for @RestartLeft@.+-- > restartOne = RestartLeft defaultLimits (RestartEach LeftToRight)+--+restartLeft :: RestartStrategy+restartLeft = RestartLeft defaultLimits (RestartEach LeftToRight)++-- | Provides a default 'RestartStrategy' for @RestartRight@.+-- > restartOne = RestartRight defaultLimits (RestartEach LeftToRight)+--+restartRight :: RestartStrategy+restartRight = RestartRight defaultLimits (RestartEach LeftToRight)++-- | Identifies a child process by name.+type ChildKey = String++-- | A reference to a (possibly running) child.+data ChildRef =+    ChildRunning !ChildPid     -- ^ a reference to the (currently running) child+  | ChildRunningExtra !ChildPid !Message -- ^ also a currently running child, with /extra/ child info+  | ChildRestarting !ChildPid  -- ^ a reference to the /old/ (previous) child (now restarting)+  | ChildStopped               -- ^ indicates the child is not currently running+  | ChildStartIgnored          -- ^ a non-temporary child exited with 'ChildInitIgnore'+  deriving (Typeable, Generic, Show)+instance Binary ChildRef where+instance NFData ChildRef where++instance Eq ChildRef where+  ChildRunning      p1   == ChildRunning      p2   = p1 == p2+  ChildRunningExtra p1 _ == ChildRunningExtra p2 _ = p1 == p2+  ChildRestarting   p1   == ChildRestarting   p2   = p1 == p2+  ChildStopped           == ChildStopped           = True+  ChildStartIgnored      == ChildStartIgnored      = True+  _                      == _                      = False++isRunning :: ChildRef -> Bool+isRunning (ChildRunning _)        = True+isRunning (ChildRunningExtra _ _) = True+isRunning _                       = False++isRestarting :: ChildRef -> Bool+isRestarting (ChildRestarting _) = True+isRestarting _                   = False++instance Resolvable ChildRef where+  resolve (ChildRunning pid)        = return $ Just pid+  resolve (ChildRunningExtra pid _) = return $ Just pid+  resolve _                         = return Nothing++-- these look a bit odd, but we basically want to avoid resolving+-- or sending to (ChildRestarting oldPid)+instance Routable ChildRef where+  sendTo (ChildRunning addr) = sendTo addr+  sendTo _                   = error "invalid address for child process"++  unsafeSendTo (ChildRunning ch) = unsafeSendTo ch+  unsafeSendTo _                 = error "invalid address for child process"++-- | Specifies whether the child is another supervisor, or a worker.+data ChildType = Worker | Supervisor+  deriving (Typeable, Generic, Show, Eq)+instance Binary ChildType where+instance NFData ChildType where++-- | Describes when a terminated child process should be restarted.+data RestartPolicy =+    Permanent  -- ^ a permanent child will always be restarted+  | Temporary  -- ^ a temporary child will /never/ be restarted+  | Transient  -- ^ A transient child will be restarted only if it terminates abnormally+  | Intrinsic  -- ^ as 'Transient', but if the child exits normally, the supervisor also exits normally+  deriving (Typeable, Generic, Eq, Show)+instance Binary RestartPolicy where+instance NFData RestartPolicy where++data ChildTerminationPolicy =+    TerminateTimeout !Delay+  | TerminateImmediately+  deriving (Typeable, Generic, Eq, Show)+instance Binary ChildTerminationPolicy where+instance NFData ChildTerminationPolicy where++data RegisteredName =+    LocalName          !String+  | GlobalName         !String+  | CustomRegister     !(Closure (ChildPid -> Process ()))+  deriving (Typeable, Generic)+instance Binary RegisteredName where+instance NFData RegisteredName where++instance Show RegisteredName where+  show (CustomRegister _) = "Custom Register"+  show (LocalName      n) = n+  show (GlobalName     n) = "global::" ++ n++data ChildStart =+    RunClosure !(Closure (Process ()))+  | CreateHandle !(Closure (SupervisorPid -> Process (ChildPid, Message)))+  | StarterProcess !StarterPid+  deriving (Typeable, Generic, Show)+instance Binary ChildStart where+instance NFData ChildStart  where++-- | Specification for a child process. The child must be uniquely identified+-- by it's @childKey@ within the supervisor. The supervisor will start the child+-- itself, therefore @childRun@ should contain the child process' implementation+-- e.g., if the child is a long running server, this would be the server /loop/,+-- as with e.g., @ManagedProces.start@.+data ChildSpec = ChildSpec {+    childKey     :: !ChildKey+  , childType    :: !ChildType+  , childRestart :: !RestartPolicy+  , childStop    :: !ChildTerminationPolicy+  , childStart   :: !ChildStart+  , childRegName :: !(Maybe RegisteredName)+  } deriving (Typeable, Generic, Show)+instance Binary ChildSpec where+instance NFData ChildSpec where+++data ChildInitFailure =+    ChildInitFailure !String+  | ChildInitIgnore+  deriving (Typeable, Generic, Show)+instance Exception ChildInitFailure where++data SupervisorStats = SupervisorStats {+    _children          :: Int+  , _supervisors       :: Int+  , _workers           :: Int+  , _running           :: Int+  , _activeSupervisors :: Int+  , _activeWorkers     :: Int+  -- TODO: usage/restart/freq stats+  , totalRestarts      :: Int+  } deriving (Typeable, Generic, Show)+instance Binary SupervisorStats where+instance NFData SupervisorStats where++-- | Static labels (in the remote table) are strings.+type StaticLabel = String++-- | Provides failure information when (re-)start failure is indicated.+data StartFailure =+    StartFailureDuplicateChild !ChildRef -- ^ a child with this 'ChildKey' already exists+  | StartFailureAlreadyRunning !ChildRef -- ^ the child is already up and running+  | StartFailureBadClosure !StaticLabel  -- ^ a closure cannot be resolved+  | StartFailureDied !DiedReason         -- ^ a child died (almost) immediately on starting+  deriving (Typeable, Generic, Show, Eq)+instance Binary StartFailure where+instance NFData StartFailure where++-- | The result of a call to 'removeChild'.+data DeleteChildResult =+    ChildDeleted              -- ^ the child specification was successfully removed+  | ChildNotFound             -- ^ the child specification was not found+  | ChildNotStopped !ChildRef -- ^ the child was not removed, as it was not stopped.+  deriving (Typeable, Generic, Show, Eq)+instance Binary DeleteChildResult where+instance NFData DeleteChildResult where++type Child = (ChildRef, ChildSpec)++-- exported result types of internal APIs++data AddChildResult =+    ChildAdded         !ChildRef+  | ChildFailedToStart !StartFailure+  deriving (Typeable, Generic, Show, Eq)+instance Binary AddChildResult where+instance NFData AddChildResult where++data StartChildResult =+    ChildStartOk        !ChildRef+  | ChildStartFailed    !StartFailure+  | ChildStartUnknownId+  | ChildStartInitIgnored+  deriving (Typeable, Generic, Show, Eq)+instance Binary StartChildResult where+instance NFData StartChildResult where++data RestartChildResult =+    ChildRestartOk     !ChildRef+  | ChildRestartFailed !StartFailure+  | ChildRestartUnknownId+  | ChildRestartIgnored+  deriving (Typeable, Generic, Show, Eq)++instance Binary RestartChildResult where+instance NFData RestartChildResult where++data TerminateChildResult =+    TerminateChildOk+  | TerminateChildUnknownId+  deriving (Typeable, Generic, Show, Eq)+instance Binary TerminateChildResult where+instance NFData TerminateChildResult where
+ src/Control/Distributed/Process/Platform/Task.hs view
@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Task+-- Copyright   :  (c) Tim Watson 2013 - 2014+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- The /Task Framework/ intends to provide tools for task management, work+-- scheduling and distributed task coordination. These capabilities build on the+-- /Execution Framework/ as well as other tools and libraries. The framework is+-- currently a work in progress. The current release includes a simple bounded+-- blocking queue implementation only, as an example of the kind of capability+-- and API that we intend to produce.+--+-- The /Task Framework/ will be broken down by the task scheduling and management+-- algorithms it provides, e.g., at a low level providing work queues, worker pools+-- and the like, whilst at a high level allowing the user to choose between work+-- stealing, sharing, distributed coordination, user defined sensor based bounds/limits+-- and so on.+--+-----------------------------------------------------------------------------+module Control.Distributed.Process.Platform.Task+  ( -- * Task Queues+    module Control.Distributed.Process.Platform.Task.Queue.BlockingQueue+  ) where++import Control.Distributed.Process.Platform.Task.Queue.BlockingQueue
+ src/Control/Distributed/Process/Platform/Task/Queue/BlockingQueue.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE DeriveGeneric             #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Task.Queue.BlockingQueue+-- Copyright   :  (c) Tim Watson 2012 - 2013+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- A simple bounded (size) task queue, which accepts requests and blocks the+-- sender until they're completed. The size limit is applied to the number+-- of concurrent tasks that are allowed to execute - if the limit is 3, then+-- the first three tasks will be executed immediately, but further tasks will+-- then be queued (internally) until one or more tasks completes and+-- the number of active/running tasks falls within the concurrency limit.+--+-- Note that the process calling 'executeTask' will be blocked for _at least_+-- the duration of the task itself, regardless of whether or not the queue has+-- reached its concurrency limit. This provides a simple means to prevent work+-- from being submitted faster than the server can handle, at the expense of+-- flexible scheduling.+--+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Task.Queue.BlockingQueue+  ( BlockingQueue()+  , SizeLimit+  , BlockingQueueStats(..)+  , start+  , pool+  , executeTask+  , stats+  ) where++import Control.Distributed.Process hiding (call)+import Control.Distributed.Process.Closure()+import Control.Distributed.Process.Platform+import Control.Distributed.Process.Platform.Async+import Control.Distributed.Process.Platform.ManagedProcess+import qualified Control.Distributed.Process.Platform.ManagedProcess as ManagedProcess+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Serializable+import Data.Binary+import Data.List+  ( deleteBy+  , find+  )+import Data.Sequence+  ( Seq+  , ViewR(..)+  , (<|)+  , viewr+  )+import qualified Data.Sequence as Seq (empty, length)+import Data.Typeable++import GHC.Generics (Generic)++-- | Limit for the number of concurrent tasks.+--+type SizeLimit = Int++data GetStats = GetStats+  deriving (Typeable, Generic)+instance Binary GetStats where++data BlockingQueueStats = BlockingQueueStats {+    maxJobs    :: Int+  , activeJobs :: Int+  , queuedJobs :: Int+  } deriving (Typeable, Generic)++instance Binary BlockingQueueStats where++data BlockingQueue a = BlockingQueue {+    poolSize :: SizeLimit+  , active   :: [(MonitorRef, CallRef (Either ExitReason a), Async a)]+  , accepted :: Seq (CallRef (Either ExitReason a), Closure (Process a))+  } deriving (Typeable)++-- Client facing API++-- | Start a queue with an upper bound on the # of concurrent tasks.+--+start :: forall a . (Serializable a)+         => Process (InitResult (BlockingQueue a))+         -> Process ()+start init' = ManagedProcess.serve () (\() -> init') poolServer+  where poolServer =+          defaultProcess {+              apiHandlers = [+                 handleCallFrom (\s f (p :: Closure (Process a)) -> storeTask s f p)+               , handleCall poolStatsRequest+               ]+            , infoHandlers = [ handleInfo taskComplete ]+            } :: ProcessDefinition (BlockingQueue a)++-- | Define a pool of a given size.+--+pool :: forall a . Serializable a+     => SizeLimit+     -> Process (InitResult (BlockingQueue a))+pool sz' = return $ InitOk (BlockingQueue sz' [] Seq.empty) Infinity++-- | Enqueue a task in the pool and block until it is complete.+--+executeTask :: forall s a . (Addressable s, Serializable a)+            => s+            -> Closure (Process a)+            -> Process (Either ExitReason a)+executeTask sid t = call sid t++-- | Fetch statistics for a queue.+--+stats :: forall s . Addressable s => s -> Process (Maybe BlockingQueueStats)+stats sid = tryCall sid GetStats++-- internal / server-side API++poolStatsRequest :: (Serializable a)+                 => BlockingQueue a+                 -> GetStats+                 -> Process (ProcessReply BlockingQueueStats (BlockingQueue a))+poolStatsRequest st GetStats =+  let sz = poolSize st+      ac = length (active st)+      pj = Seq.length (accepted st)+  in reply (BlockingQueueStats sz ac pj) st++storeTask :: Serializable a+          => BlockingQueue a+          -> CallRef (Either ExitReason a)+          -> Closure (Process a)+          -> Process (ProcessReply (Either ExitReason a) (BlockingQueue a))+storeTask s r c = acceptTask s r c >>= noReply_++acceptTask :: Serializable a+           => BlockingQueue a+           -> CallRef (Either ExitReason a)+           -> Closure (Process a)+           -> Process (BlockingQueue a)+acceptTask s@(BlockingQueue sz' runQueue taskQueue) from task' =+  let currentSz = length runQueue+  in case currentSz >= sz' of+    True  -> do+      return $ s { accepted = enqueue taskQueue (from, task') }+    False -> do+      proc <- unClosure task'+      asyncHandle <- async proc+      ref <- monitorAsync asyncHandle+      taskEntry <- return (ref, from, asyncHandle)+      return s { active = (taskEntry:runQueue) }++-- a worker has exited, process the AsyncResult and send a reply to the+-- waiting client (who is still stuck in 'call' awaiting a response).+taskComplete :: forall a . Serializable a+             => BlockingQueue a+             -> ProcessMonitorNotification+             -> Process (ProcessAction (BlockingQueue a))+taskComplete s@(BlockingQueue _ runQ _)+             (ProcessMonitorNotification ref _ _) =+  let worker = findWorker ref runQ in+  case worker of+    Just t@(_, c, h) -> wait h >>= respond c >> bump s t >>= continue+    Nothing          -> continue s++  where+    respond :: CallRef (Either ExitReason a)+            -> AsyncResult a+            -> Process ()+    respond c (AsyncDone       r) = replyTo c ((Right r) :: (Either ExitReason a))+    respond c (AsyncFailed     d) = replyTo c ((Left (ExitOther $ show d))  :: (Either ExitReason a))+    respond c (AsyncLinkFailed d) = replyTo c ((Left (ExitOther $ show d))  :: (Either ExitReason a))+    respond _      _              = die $ ExitOther "IllegalState"++    bump :: BlockingQueue a+         -> (MonitorRef, CallRef (Either ExitReason a), Async a)+         -> Process (BlockingQueue a)+    bump st@(BlockingQueue _ runQueue acc) worker =+      let runQ2 = deleteFromRunQueue worker runQueue+          accQ  = dequeue acc in+      case accQ of+        Nothing            -> return st { active = runQ2 }+        Just ((tr,tc), ts) -> acceptTask (st { accepted = ts, active = runQ2 }) tr tc++findWorker :: MonitorRef+           -> [(MonitorRef, CallRef (Either ExitReason a), Async a)]+           -> Maybe (MonitorRef, CallRef (Either ExitReason a), Async a)+findWorker key = find (\(ref,_,_) -> ref == key)++deleteFromRunQueue :: (MonitorRef, CallRef (Either ExitReason a), Async a)+                   -> [(MonitorRef, CallRef (Either ExitReason a), Async a)]+                   -> [(MonitorRef, CallRef (Either ExitReason a), Async a)]+deleteFromRunQueue c@(p, _, _) runQ = deleteBy (\_ (b, _, _) -> b == p) c runQ++{-# INLINE enqueue #-}+enqueue :: Seq a -> a -> Seq a+enqueue s a = a <| s++{-# INLINE dequeue #-}+dequeue :: Seq a -> Maybe (a, Seq a)+dequeue s = maybe Nothing (\(s' :> a) -> Just (a, s')) $ getR s++getR :: Seq a -> Maybe (ViewR a)+getR s =+  case (viewr s) of+    EmptyR -> Nothing+    a      -> Just a+
+ src/Control/Distributed/Process/Platform/Test.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE CPP                #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Test+-- Copyright   :  (c) Tim Watson, Jeff Epstein 2013+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- This module provides basic building blocks for testing Cloud Haskell programs.+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Test+  ( TestResult+  , noop+  , stash+  -- ping !+  , Ping(Ping)+  , ping+  -- test process utilities+  , TestProcessControl+  , startTestProcess+  , runTestProcess+  , testProcessGo+  , testProcessStop+  , testProcessReport+  -- runners+  , tryRunProcess+  , tryForkProcess+  ) where++import Control.Concurrent+  ( myThreadId+  , throwTo+  )+import Control.Concurrent.MVar+  ( MVar+  , putMVar+  )+import Control.DeepSeq (NFData)+import Control.Distributed.Process+import Control.Distributed.Process.Node+import Control.Distributed.Process.Serializable()+import Control.Exception (SomeException)+import Data.Binary+import Data.Typeable (Typeable)+#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif++import GHC.Generics++-- | A mutable cell containing a test result.+type TestResult a = MVar a++-- | A simple @Ping@ signal+data Ping = Ping+    deriving (Typeable, Generic, Eq, Show)+instance Binary Ping where+instance NFData Ping where++ping :: ProcessId -> Process ()+ping pid = send pid Ping++-- | Control signals used to manage /test processes/+data TestProcessControl = Stop | Go | Report ProcessId+    deriving (Typeable, Generic)++instance Binary TestProcessControl where++-- | Starts a test process on the local node.+startTestProcess :: Process () -> Process ProcessId+startTestProcess proc =+  spawnLocal $ do+    getSelfPid >>= register "test-process"+    runTestProcess proc++-- | Runs a /test process/ around the supplied @proc@, which is executed+-- whenever the outer process loop receives a 'Go' signal.+runTestProcess :: Process () -> Process ()+runTestProcess proc = do+  ctl <- expect+  case ctl of+    Stop     -> return ()+    Go       -> proc >> runTestProcess proc+    Report p -> receiveWait [matchAny (\m -> forward m p)] >> runTestProcess proc++-- | Tell a /test process/ to continue executing+testProcessGo :: ProcessId -> Process ()+testProcessGo pid = send pid Go++-- | Tell a /test process/ to stop (i.e., 'terminate')+testProcessStop :: ProcessId -> Process ()+testProcessStop pid = send pid Stop++-- | Tell a /test process/ to send a report (message)+-- back to the calling process+testProcessReport :: ProcessId -> Process ()+testProcessReport pid = do+  self <- getSelfPid+  send pid $ Report self++-- | Does exactly what it says on the tin, doing so in the @Process@ monad.+noop :: Process ()+noop = return ()++-- | Stashes a value in our 'TestResult' using @putMVar@+stash :: TestResult a -> a -> Process ()+stash mvar x = liftIO $ putMVar mvar x++tryRunProcess :: LocalNode -> Process () -> IO ()+tryRunProcess node p = do+  tid <- liftIO myThreadId+  runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))++tryForkProcess :: LocalNode -> Process () -> IO ProcessId+tryForkProcess node p = do+  tid <- liftIO myThreadId+  forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))
+ src/Control/Distributed/Process/Platform/Time.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveGeneric       #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Time+-- Copyright   :  (c) Tim Watson, Jeff Epstein, Alan Zimmerman+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- This module provides facilities for working with time delays and timeouts.+-- The type 'Timeout' and the 'timeout' family of functions provide mechanisms+-- for working with @threadDelay@-like behaviour that operates on microsecond+-- values.+--+-- The 'TimeInterval' and 'TimeUnit' related functions provide an abstraction+-- for working with various time intervals, whilst the 'Delay' type provides a+-- corrolary to 'timeout' that works with these.+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Time+  ( -- * Time interval handling+    microSeconds+  , milliSeconds+  , seconds+  , minutes+  , hours+  , asTimeout+  , after+  , within+  , timeToMicros+  , TimeInterval+  , TimeUnit(..)+  , Delay(..)++  -- * Conversion To/From NominalDiffTime+  , timeIntervalToDiffTime+  , diffTimeToTimeInterval+  , diffTimeToDelay+  , delayToDiffTime+  , microsecondsToNominalDiffTime++    -- * (Legacy) Timeout Handling+  , Timeout+  , TimeoutNotification(..)+  , timeout+  , infiniteWait+  , noWait+  ) where++import Control.Concurrent (threadDelay)+import Control.DeepSeq (NFData)+import Control.Distributed.Process+import Control.Distributed.Process.Platform.Internal.Types+import Control.Monad (void)+import Data.Binary+import Data.Ratio ((%))+import Data.Time.Clock+import Data.Typeable (Typeable)++import GHC.Generics++--------------------------------------------------------------------------------+-- API                                                                        --+--------------------------------------------------------------------------------++-- | Defines the time unit for a Timeout value+data TimeUnit = Days | Hours | Minutes | Seconds | Millis | Micros+    deriving (Typeable, Generic, Eq, Show)++instance Binary TimeUnit where+instance NFData TimeUnit where++-- | A time interval.+data TimeInterval = TimeInterval TimeUnit Int+    deriving (Typeable, Generic, Eq, Show)++instance Binary TimeInterval where+instance NFData TimeInterval where++-- | Represents either a delay of 'TimeInterval', an infinite wait or no delay+-- (i.e., non-blocking).+data Delay = Delay TimeInterval | Infinity | NoDelay+    deriving (Typeable, Generic, Eq, Show)++instance Binary Delay where+instance NFData Delay where++-- | Represents a /timeout/ in terms of microseconds, where 'Nothing' stands for+-- infinity and @Just 0@, no-delay.+type Timeout = Maybe Int++-- | Send to a process when a timeout expires.+data TimeoutNotification = TimeoutNotification Tag+       deriving (Typeable)++instance Binary TimeoutNotification where+  get = fmap TimeoutNotification $ get+  put (TimeoutNotification n) = put n++-- time interval/unit handling++-- | converts the supplied @TimeInterval@ to microseconds+asTimeout :: TimeInterval -> Int+asTimeout (TimeInterval u v) = timeToMicros u v++-- | Convenience for making timeouts; e.g.,+--+-- > receiveTimeout (after 3 Seconds) [ match (\"ok" -> return ()) ]+--+after :: Int -> TimeUnit -> Int+after n m = timeToMicros m n++-- | Convenience for making 'TimeInterval'; e.g.,+--+-- > let ti = within 5 Seconds in .....+--+within :: Int -> TimeUnit -> TimeInterval+within n m = TimeInterval m n++-- | given a number, produces a @TimeInterval@ of microseconds+microSeconds :: Int -> TimeInterval+microSeconds = TimeInterval Micros++-- | given a number, produces a @TimeInterval@ of milliseconds+milliSeconds :: Int -> TimeInterval+milliSeconds = TimeInterval Millis++-- | given a number, produces a @TimeInterval@ of seconds+seconds :: Int -> TimeInterval+seconds = TimeInterval Seconds++-- | given a number, produces a @TimeInterval@ of minutes+minutes :: Int -> TimeInterval+minutes = TimeInterval Minutes++-- | given a number, produces a @TimeInterval@ of hours+hours :: Int -> TimeInterval+hours = TimeInterval Hours++-- TODO: is timeToMicros efficient enough?++-- | converts the supplied @TimeUnit@ to microseconds+{-# INLINE timeToMicros #-}+timeToMicros :: TimeUnit -> Int -> Int+timeToMicros Micros  us   = us+timeToMicros Millis  ms   = ms  * (10 ^ (3 :: Int)) -- (1000µs == 1ms)+timeToMicros Seconds secs = timeToMicros Millis  (secs * milliSecondsPerSecond)+timeToMicros Minutes mins = timeToMicros Seconds (mins * secondsPerMinute)+timeToMicros Hours   hrs  = timeToMicros Minutes (hrs  * minutesPerHour)+timeToMicros Days    days = timeToMicros Hours   (days * hoursPerDay)++{-# INLINE hoursPerDay #-}+hoursPerDay :: Int+hoursPerDay = 60++{-# INLINE minutesPerHour #-}+minutesPerHour :: Int+minutesPerHour = 60++{-# INLINE secondsPerMinute #-}+secondsPerMinute :: Int+secondsPerMinute = 60++{-# INLINE milliSecondsPerSecond #-}+milliSecondsPerSecond :: Int+milliSecondsPerSecond = 1000++{-# INLINE microSecondsPerSecond #-}+microSecondsPerSecond :: Int+microSecondsPerSecond = 1000000++-- timeouts/delays (microseconds)++-- | Constructs an inifinite 'Timeout'.+infiniteWait :: Timeout+infiniteWait = Nothing++-- | Constructs a no-wait 'Timeout'+noWait :: Timeout+noWait = Just 0++-- | Sends the calling process @TimeoutNotification tag@ after @time@ microseconds+timeout :: Int -> Tag -> ProcessId -> Process ()+timeout time tag p =+  void $ spawnLocal $+               do liftIO $ threadDelay time+                  send p (TimeoutNotification tag)++-- Converting to/from Data.Time.Clock NominalDiffTime++-- | given a @TimeInterval@, provide an equivalent @NominalDiffTim@+timeIntervalToDiffTime :: TimeInterval -> NominalDiffTime+timeIntervalToDiffTime ti = microsecondsToNominalDiffTime (fromIntegral $ asTimeout ti)++-- | given a @NominalDiffTim@@, provide an equivalent @TimeInterval@+diffTimeToTimeInterval :: NominalDiffTime -> TimeInterval+diffTimeToTimeInterval dt = microSeconds $ (fromIntegral (round (dt * 1000000) :: Integer))++-- | given a @Delay@, provide an equivalent @NominalDiffTim@+delayToDiffTime :: Delay -> NominalDiffTime+delayToDiffTime (Delay ti) = timeIntervalToDiffTime ti+delayToDiffTime Infinity   = error "trying to convert Delay.Infinity to a NominalDiffTime"+delayToDiffTime (NoDelay)  = microsecondsToNominalDiffTime 0++-- | given a @NominalDiffTim@@, provide an equivalent @Delay@+diffTimeToDelay :: NominalDiffTime -> Delay+diffTimeToDelay dt = Delay $ diffTimeToTimeInterval dt++-- | Create a 'NominalDiffTime' from a number of microseconds.+microsecondsToNominalDiffTime :: Integer -> NominalDiffTime+microsecondsToNominalDiffTime x = fromRational (x % (fromIntegral microSecondsPerSecond))++-- tenYearsAsMicroSeconds :: Integer+-- tenYearsAsMicroSeconds = 10 * 365 * 24 * 60 * 60 * 1000000++-- | Allow @(+)@ and @(-)@ operations on @TimeInterval@s+instance Num TimeInterval where+  t1 + t2 = microSeconds $ asTimeout t1 + asTimeout t2+  t1 - t2 = microSeconds $ asTimeout t1 - asTimeout t2+  _ * _ = error "trying to multiply two TimeIntervals"+  abs t = microSeconds $ abs (asTimeout t)+  signum t = if (asTimeout t) == 0+              then 0+              else if (asTimeout t) < 0 then -1+                                        else 1+  fromInteger _ = error "trying to call fromInteger for a TimeInterval. Cannot guess units"++-- | Allow @(+)@ and @(-)@ operations on @Delay@s+instance Num Delay where+  NoDelay     + x          = x+  Infinity    + _          = Infinity+  x           + NoDelay    = x+  _           + Infinity   = Infinity+  (Delay t1 ) + (Delay t2) = Delay (t1 + t2)++  NoDelay     - x          = x+  Infinity    - _          = Infinity+  x           - NoDelay    = x+  _           - Infinity   = Infinity+  (Delay t1 ) - (Delay t2) = Delay (t1 - t2)++  _ * _ = error "trying to multiply two Delays"++  abs NoDelay   = NoDelay+  abs Infinity  = Infinity+  abs (Delay t) = Delay (abs t)++  signum (NoDelay) = 0+  signum Infinity  = 1+  signum (Delay t) = Delay (signum t)++  fromInteger 0 = NoDelay+  fromInteger _ = error "trying to call fromInteger for a Delay. Cannot guess units"+
+ src/Control/Distributed/Process/Platform/Timer.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE PatternGuards      #-}+{-# LANGUAGE TemplateHaskell    #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.Timer+-- Copyright   :  (c) Tim Watson 2012+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- Provides an API for running code or sending messages, either after some+-- initial delay or periodically, and for cancelling, re-setting and/or+-- flushing pending /timers/.+-----------------------------------------------------------------------------++module Control.Distributed.Process.Platform.Timer+  (+    TimerRef+  , Tick(Tick)+  , sleep+  , sleepFor+  , sendAfter+  , runAfter+  , exitAfter+  , killAfter+  , startTimer+  , ticker+  , periodically+  , resetTimer+  , cancelTimer+  , flushTimer+  ) where++import Control.DeepSeq (NFData)+import Control.Distributed.Process hiding (send)+import Control.Distributed.Process.Serializable+import Control.Distributed.Process.Platform.UnsafePrimitives (send)+import Control.Distributed.Process.Platform.Internal.Types (NFSerializable)+import Control.Distributed.Process.Platform.Time+import Data.Binary+import Data.Typeable (Typeable)+import Prelude hiding (init)++import GHC.Generics++-- | an opaque reference to a timer+type TimerRef = ProcessId++-- | cancellation message sent to timers+data TimerConfig = Reset | Cancel+    deriving (Typeable, Generic, Eq, Show)+instance Binary TimerConfig where+instance NFData TimerConfig where++-- | represents a 'tick' event that timers can generate+data Tick = Tick+    deriving (Typeable, Generic, Eq, Show)+instance Binary Tick where+instance NFData Tick where++data SleepingPill = SleepingPill+    deriving (Typeable, Generic, Eq, Show)+instance Binary SleepingPill where+instance NFData SleepingPill where++--------------------------------------------------------------------------------+-- API                                                                        --+--------------------------------------------------------------------------------++-- | blocks the calling Process for the specified TimeInterval. Note that this+-- function assumes that a blocking receive is the most efficient approach to+-- acheiving this, however the runtime semantics (particularly with regards+-- scheduling) should not differ from threadDelay in practise.+sleep :: TimeInterval -> Process ()+sleep t =+  let ms = asTimeout t in do+  _ <- receiveTimeout ms [matchIf (\SleepingPill -> True)+                                  (\_ -> return ())]+  return ()++-- | Literate way of saying @sleepFor 3 Seconds@.+sleepFor :: Int -> TimeUnit -> Process ()+sleepFor i u = sleep (within i u)++-- | starts a timer which sends the supplied message to the destination+-- process after the specified time interval.+sendAfter :: (NFSerializable a)+          => TimeInterval+          -> ProcessId+          -> a+          -> Process TimerRef+sendAfter t pid msg = runAfter t proc+  where proc = do { send pid msg }++-- | runs the supplied process action(s) after @t@ has elapsed+runAfter :: TimeInterval -> Process () -> Process TimerRef+runAfter t p = spawnLocal $ runTimer t p True++-- | calls @exit pid reason@ after @t@ has elapsed+exitAfter :: (Serializable a)+             => TimeInterval+             -> ProcessId+             -> a+             -> Process TimerRef+exitAfter delay pid reason = runAfter delay $ exit pid reason++-- | kills the specified process after @t@ has elapsed+killAfter :: TimeInterval -> ProcessId -> String -> Process TimerRef+killAfter delay pid why = runAfter delay $ kill pid why++-- | starts a timer that repeatedly sends the supplied message to the destination+-- process each time the specified time interval elapses. To stop messages from+-- being sent in future, 'cancelTimer' can be called.+startTimer :: (NFSerializable a)+           => TimeInterval+           -> ProcessId+           -> a+           -> Process TimerRef+startTimer t pid msg = periodically t (send pid msg)++-- | runs the supplied process action(s) repeatedly at intervals of @t@+periodically :: TimeInterval -> Process () -> Process TimerRef+periodically t p = spawnLocal $ runTimer t p False++-- | resets a running timer. Note: Cancelling a timer does not guarantee that+-- all its messages are prevented from being delivered to the target process.+-- Also note that resetting an ongoing timer (started using the 'startTimer' or+-- 'periodically' functions) will only cause the current elapsed period to time+-- out, after which the timer will continue running. To stop a long-running+-- timer permanently, you should use 'cancelTimer' instead.+resetTimer :: TimerRef -> Process ()+resetTimer = (flip send) Reset++-- | permanently cancels a timer+cancelTimer :: TimerRef -> Process ()+cancelTimer = (flip send) Cancel++-- | cancels a running timer and flushes any viable timer messages from the+-- process' message queue. This function should only be called by the process+-- expecting to receive the timer's messages!+flushTimer :: (Serializable a, Eq a) => TimerRef -> a -> Delay -> Process ()+flushTimer ref ignore t = do+    mRef <- monitor ref+    cancelTimer ref+    performFlush mRef t+    return ()+  where performFlush mRef Infinity  = receiveWait $ filters mRef+        performFlush mRef NoDelay   = performFlush mRef (Delay $ microSeconds 0)+        performFlush mRef (Delay i) = receiveTimeout (asTimeout i) (filters mRef) >> return ()+        filters mRef = [+                matchIf (\x -> x == ignore)+                        (\_ -> return ())+              , matchIf (\(ProcessMonitorNotification mRef' _ _) -> mRef == mRef')+                        (\_ -> return ()) ]++-- | sets up a timer that sends 'Tick' repeatedly at intervals of @t@+ticker :: TimeInterval -> ProcessId -> Process TimerRef+ticker t pid = startTimer t pid Tick++--------------------------------------------------------------------------------+-- Implementation                                                             --+--------------------------------------------------------------------------------++-- runs the timer process+runTimer :: TimeInterval -> Process () -> Bool -> Process ()+runTimer t proc cancelOnReset = do+    cancel <- expectTimeout (asTimeout t)+    -- say $ "cancel = " ++ (show cancel) ++ "\n"+    case cancel of+        Nothing     -> runProc cancelOnReset+        Just Cancel -> return ()+        Just Reset  -> if cancelOnReset then return ()+                                        else runTimer t proc cancelOnReset+  where runProc True  = proc+        runProc False = proc >> runTimer t proc cancelOnReset
+ src/Control/Distributed/Process/Platform/UnsafePrimitives.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Distributed.Process.Platform.UnsafePrimitives+-- Copyright   :  (c) Tim Watson 2013+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Tim Watson <watson.timothy@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires concurrency)+--+-- [Unsafe Messaging Primitives Using NFData]+--+-- This module mirrors "Control.Distributed.Process.UnsafePrimitives", but+-- attempts to provide a bit more safety by forcing evaluation before sending.+-- This is handled using @NFData@, by means of the @NFSerializable@ type class.+--+-- Note that we /still/ cannot guarantee that both the @NFData@ and @Binary@+-- instances will evaluate your data the same way, therefore these primitives+-- still have certain risks and potential side effects. Use with caution.+--+-----------------------------------------------------------------------------+module Control.Distributed.Process.Platform.UnsafePrimitives+  ( send+  , nsend+  , sendToAddr+  , sendChan+  , wrapMessage+  ) where++import Control.DeepSeq (($!!))+import Control.Distributed.Process+  ( Process+  , ProcessId+  , SendPort+  , Message+  )+import Control.Distributed.Process.Platform.Internal.Types+  ( NFSerializable+  , Addressable+  , Resolvable(..)+  )+import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe++send :: NFSerializable m => ProcessId -> m -> Process ()+send pid msg = Unsafe.send pid $!! msg++nsend :: NFSerializable a => String -> a -> Process ()+nsend name msg = Unsafe.nsend name $!! msg++sendToAddr :: (Addressable a, NFSerializable m) => a -> m -> Process ()+sendToAddr addr msg = do+  mPid <- resolve addr+  case mPid of+    Nothing -> return ()+    Just p  -> send p msg++sendChan :: (NFSerializable m) => SendPort m -> m -> Process ()+sendChan port msg = Unsafe.sendChan port $!! msg++-- | Create an unencoded @Message@ for any @Serializable@ type.+wrapMessage :: NFSerializable a => a -> Message+wrapMessage msg = Unsafe.wrapMessage $!! msg+
+ tests/TestAsync.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE ScopedTypeVariables       #-}++module Main where++import Control.Concurrent.MVar (MVar, takeMVar, newEmptyMVar)+import Control.Distributed.Process+import Control.Distributed.Process.Node+import Control.Distributed.Process.Platform.Async+import Control.Distributed.Process.Platform.Test+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Platform.Timer++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import qualified Network.Transport as NT+import TestAsyncChan (asyncChanTests)+import TestAsyncSTM (asyncStmTests)+import TestUtils++testAsyncPoll :: TestResult (AsyncResult ()) -> Process ()+testAsyncPoll result = do+    hAsync <- async $ do "go" <- expect; say "running" >> return ()+    ar <- poll hAsync+    case ar of+      AsyncPending ->+        send (asyncWorker hAsync) "go" >> wait hAsync >>= stash result+      _ -> stash result ar >> return ()++testAsyncCancel :: TestResult (AsyncResult ()) -> Process ()+testAsyncCancel result = do+    hAsync <- async $ runTestProcess $ say "running" >> return ()+    sleep $ milliSeconds 100++    p <- poll hAsync -- nasty kind of assertion: use assertEquals?+    case p of+        AsyncPending -> cancel hAsync >> wait hAsync >>= stash result+        _            -> say (show p) >> stash result p++testAsyncCancelWait :: TestResult (Maybe (AsyncResult ())) -> Process ()+testAsyncCancelWait result = do+    testPid <- getSelfPid+    p <- spawnLocal $ do+      hAsync <- async $ runTestProcess $ sleep $ seconds 60+      sleep $ milliSeconds 100++      send testPid "running"++      AsyncPending <- poll hAsync+      cancelWait hAsync >>= send testPid++    "running" <- expect+    d <- expectTimeout (asTimeout $ seconds 5)+    case d of+        Nothing -> kill p "timed out" >> stash result Nothing+        Just ar -> stash result (Just ar)++testAsyncWaitTimeout :: TestResult (Maybe (AsyncResult ())) -> Process ()+testAsyncWaitTimeout result =+    let delay = seconds 1+    in do+    hAsync <- async $ sleep $ seconds 20+    waitTimeout delay hAsync >>= stash result+    cancelWait hAsync >> return ()++testAsyncWaitTimeoutCompletes :: TestResult (Maybe (AsyncResult ()))+                              -> Process ()+testAsyncWaitTimeoutCompletes result =+    let delay = seconds 1+    in do+    hAsync <- async $ sleep $ seconds 20+    waitTimeout delay hAsync >>= stash result+    cancelWait hAsync >> return ()++testAsyncLinked :: TestResult Bool -> Process ()+testAsyncLinked result = do+    mv :: MVar (Async ()) <- liftIO $ newEmptyMVar+    pid <- spawnLocal $ do+        -- NB: async == asyncLinked for AsyncChan+        h <- asyncLinked $ do+            "waiting" <- expect+            return ()+        stash mv h+        "sleeping" <- expect+        return ()++    hAsync <- liftIO $ takeMVar mv++    mref <- monitor $ asyncWorker hAsync+    exit pid "stop"++    _ <- receiveTimeout (after 5 Seconds) [+              matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref')+                      (\_ -> return ())+            ]++    -- since the initial caller died and we used 'asyncLinked', the async should+    -- pick up on the exit signal and set the result accordingly. trying to match+    -- on 'DiedException String' is pointless though, as the *string* is highly+    -- context dependent.+    r <- waitTimeout (within 3 Seconds) hAsync+    case r of+        Nothing -> stash result True+        Just _  -> stash result False++testAsyncCancelWith :: TestResult Bool -> Process ()+testAsyncCancelWith result = do+  p1 <- async $ do { s :: String <- expect; return s }+  cancelWith "foo" p1+  AsyncFailed (DiedException _) <- wait p1+  stash result True++allAsyncTests :: NT.Transport -> IO [Test]+allAsyncTests transport = do+  chanTestGroup <- asyncChanTests transport+  stmTestGroup  <- asyncStmTests transport+  localNode <- newLocalNode transport initRemoteTable+  return [+       testGroup "Async Channel" chanTestGroup+     , testGroup "Async STM"     stmTestGroup+     , testGroup "Async Common API" [+          testCase "Async Common API cancel"+            (delayedAssertion+             "expected async task to have been cancelled"+             localNode (AsyncCancelled) testAsyncCancel)+        , testCase "Async Common API poll"+            (delayedAssertion+             "expected poll to return a valid AsyncResult"+             localNode (AsyncDone ()) testAsyncPoll)+        , testCase "Async Common API cancelWait"+            (delayedAssertion+             "expected cancelWait to complete some time"+             localNode (Just AsyncCancelled) testAsyncCancelWait)+        , testCase "Async Common API waitTimeout"+            (delayedAssertion+             "expected waitTimeout to return Nothing when it times out"+             localNode (Nothing) testAsyncWaitTimeout)+        , testCase "Async Common API waitTimeout completion"+            (delayedAssertion+             "expected waitTimeout to return a value"+             localNode Nothing testAsyncWaitTimeoutCompletes)+        , testCase "Async Common API asyncLinked"+            (delayedAssertion+             "expected linked process to die with originator"+             localNode True testAsyncLinked)+        , testCase "Async Common API cancelWith"+            (delayedAssertion+             "expected the worker to have been killed with the given signal"+             localNode True testAsyncCancelWith)+     ] ]++main :: IO ()+main = testMain $ allAsyncTests
+ tests/TestExchange.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Main where++import Control.Distributed.Process+import Control.Distributed.Process.Node+import Control.Distributed.Process.Platform+  ( Resolvable(..)+  , Channel+  , spawnSignalled+  )+import qualified Control.Distributed.Process.Platform (__remoteTable)+import Control.Distributed.Process.Platform.Execution.EventManager hiding (start)+import Control.Distributed.Process.Platform.Execution.Exchange+import qualified Control.Distributed.Process.Platform.Execution.EventManager as EventManager+  ( start+  )+import Control.Distributed.Process.Platform.Test+import Control.Monad (void, forM, forever)+import Control.Rematch (equalTo)++#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch, drop)+#else+import Prelude hiding (drop)+#endif+import qualified Network.Transport as NT+import Test.Framework as TF (testGroup, Test)+import Test.Framework.Providers.HUnit+import TestUtils++testKeyBasedRouting :: TestResult Bool -> Process ()+testKeyBasedRouting result = do+  (sp, rp) <- newChan :: Process (Channel Int)+  rex <- messageKeyRouter PayloadOnly++  -- Since the /router/ doesn't offer a syncrhonous start+  -- option, we use spawnSignalled to get the same effect,+  -- making it more likely (though it's not guaranteed) that+  -- the spawned process will be bound to the routing exchange+  -- prior to our evaluating 'routeMessage' below.+  void $ spawnSignalled (bindKey "foobar" rex) $ const $ do+    receiveWait [ match (\(s :: Int) -> sendChan sp s) ]++  routeMessage rex (createMessage "foobar" [] (123 :: Int))+  stash result . (== (123 :: Int)) =<< receiveChan rp++testMultipleRoutes :: TestResult () -> Process ()+testMultipleRoutes result = do+  stash result ()    -- we don't rely on the test result for assertions...+  (sp, rp) <- newChan+  rex <- messageKeyRouter PayloadOnly+  let recv = receiveWait [+          match (\(s :: String) -> getSelfPid >>= \us -> sendChan sp (us, Left s))+        , match (\(i :: Int) -> getSelfPid >>= \us -> sendChan sp (us, Right i))+        ]++  us <- getSelfPid+  p1 <- spawnSignalled (link us >> bindKey "abc" rex) (const $ forever recv)+  p2 <- spawnSignalled (link us >> bindKey "def" rex) (const $ forever recv)+  p3 <- spawnSignalled (link us >> bindKey "abc" rex) (const $ forever recv)++  -- publish 2 messages with the routing-key set to 'abc'+  routeMessage rex (createMessage "abc" [] "Hello")+  routeMessage rex (createMessage "abc" [] (123 :: Int))++  -- route another message with the 'abc' value a header (should be ignored)+  routeMessage rex (createMessage "" [("abc", "abc")] "Goodbye")++  received <- forM (replicate (2 * 3) us) (const $ receiveChanTimeout 1000 rp)++  -- all bindings for 'abc' fired correctly+  received `shouldContain` Just (p1, Left "Hello")+  received `shouldContain` Just (p3, Left "Hello")+  received `shouldContain` Just (p1, Right (123 :: Int))+  received `shouldContain` Just (p3, Right (123 :: Int))++  -- however the bindings for 'def' never fired+  received `shouldContain` Nothing+  received `shouldNotContain` Just (p2, Left "Hello")+  received `shouldNotContain` Just (p2, Right (123 :: Int))++  -- none of the bindings should have examined the headers!+  received `shouldNotContain` Just (p1, Left "Goodbye")+  received `shouldNotContain` Just (p2, Left "Goodbye")+  received `shouldNotContain` Just (p3, Left "Goodbye")++testHeaderBasedRouting :: TestResult () -> Process ()+testHeaderBasedRouting result = do+  stash result ()  -- we don't rely on the test result for assertions...+  (sp, rp) <- newChan+  rex <- headerContentRouter PayloadOnly "x-name"+  let recv = const $ forever $ receiveWait [+          match (\(s :: String) -> getSelfPid >>= \us -> sendChan sp (us, Left s))+        , match (\(i :: Int) -> getSelfPid >>= \us -> sendChan sp (us, Right i))+        ]++  us <- getSelfPid+  p1 <- spawnSignalled (link us >> bindHeader "x-name" "yellow" rex) recv+  p2 <- spawnSignalled (link us >> bindHeader "x-name" "red"    rex) recv+  _  <- spawnSignalled (link us >> bindHeader "x-type" "fast"   rex) recv++  -- publish 2 messages with the routing-key set to 'abc'+  routeMessage rex (createMessage "" [("x-name", "yellow")] "Hello")+  routeMessage rex (createMessage "" [("x-name", "yellow")] (123 :: Int))+  routeMessage rex (createMessage "" [("x-name", "red")]    (456 :: Int))+  routeMessage rex (createMessage "" [("x-name", "red")]    (789 :: Int))+  routeMessage rex (createMessage "" [("x-type", "fast")]   "Goodbye")++  -- route another message with the 'abc' value a header (should be ignored)+  routeMessage rex (createMessage "" [("abc", "abc")] "FooBar")++  received <- forM (replicate 5 us) (const $ receiveChanTimeout 1000 rp)++  -- all bindings fired correctly+  received `shouldContain` Just (p1, Left "Hello")+  received `shouldContain` Just (p1, Right (123 :: Int))+  received `shouldContain` Just (p2, Right (456 :: Int))+  received `shouldContain` Just (p2, Right (789 :: Int))+  received `shouldContain` Nothing++  -- simple check that no other bindings have fired+  length received `shouldBe` equalTo (5 :: Int)++testSimpleEventHandling :: TestResult Bool -> Process ()+testSimpleEventHandling result = do+  (sp, rp) <- newChan+  (sigStart, recvStart) <- newChan+  em <- EventManager.start+  Just pid <- resolve em+  void $ monitor pid++  -- Note that in our init (state) function, we write a "start signal"+  -- here; Without a start signal, the message sent to the event manager+  -- (via notify) would race with the addHandler registration.+  pid' <- addHandler em (myHandler sp) (sendChan sigStart ())+  link pid'++  () <- receiveChan recvStart++  notify em ("hello", "event", "manager") -- cast message+  r <- receiveTimeout 100000000 [+      matchChan rp return+    , match (\(ProcessMonitorNotification _ _ _) -> die "ServerDied")+    ]+  case r of+    Just ("hello", "event", "manager") -> stash result True+    _                                  -> stash result False++myHandler :: SendPort (String, String, String)+          -> ()+          -> (String, String, String)+          -> Process ()+myHandler sp s m@(_, _, _) = sendChan sp m >> return s++myRemoteTable :: RemoteTable+myRemoteTable =+  Control.Distributed.Process.Platform.__remoteTable initRemoteTable++tests :: NT.Transport  -> IO [Test]+tests transport = do+  localNode <- newLocalNode transport myRemoteTable+  return [+        testGroup "Event Manager"+        [+          testCase "Simple Event Handlers"+          (delayedAssertion "Expected the handler to run"+           localNode True testSimpleEventHandling)+        ]++      , testGroup "Router"+        [+          testCase "Direct Key Routing"+          (delayedAssertion "Expected the sole matching route to run"+           localNode True testKeyBasedRouting)+        , testCase "Key Based Selective Routing"+          (delayedAssertion "Expected only the matching routes to run"+           localNode () testMultipleRoutes)+        , testCase "Header Based Selective Routing"+          (delayedAssertion "Expected only the matching routes to run"+           localNode () testHeaderBasedRouting)+        ]+    ]++main :: IO ()+main = testMain $ tests+
+ tests/TestLog.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++-- import Control.Exception (SomeException)+import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, newEmptyMVar)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TChan+import Control.Distributed.Process hiding (monitor)+import Control.Distributed.Process.Closure (remotable, mkStaticClosure)+import Control.Distributed.Process.Node+import Control.Distributed.Process.Platform hiding (__remoteTable)+import qualified Control.Distributed.Process.Platform.Service.SystemLog as Log (Logger, error)+import Control.Distributed.Process.Platform.Service.SystemLog hiding (Logger, error)+import Control.Distributed.Process.Platform.Test+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Platform.Timer+import Control.Monad (void)+import Data.List (delete)++#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch, drop, Read)+#else+import Prelude hiding (drop, read, Read)+#endif++import Test.Framework as TF (testGroup, Test)+import Test.Framework.Providers.HUnit+import TestUtils++import GHC.Read+import Text.ParserCombinators.ReadP as P+import Text.ParserCombinators.ReadPrec++import qualified Network.Transport as NT++logLevelFormatter :: Message -> Process (Maybe String)+logLevelFormatter m = handleMessage m showLevel+  where+    showLevel :: LogLevel -> Process String+    showLevel = return . show++$(remotable ['logLevelFormatter])++logFormat :: Closure (Message -> Process (Maybe String))+logFormat = $(mkStaticClosure 'logLevelFormatter)++testLoggingProcess :: Process (ProcessId, TChan String)+testLoggingProcess = do+  chan <- liftIO $ newTChanIO+  let cleanup  = return ()+  let format   = return+  pid <- systemLog (writeLog chan) cleanup Debug format+  addFormatter pid logFormat+  sleep $ seconds 1+  return (pid, chan)+  where+    writeLog chan = liftIO . atomically . writeTChan chan++testLogLevels :: (Log.Logger logger, ToLog tL)+              => MVar ()+              -> TChan String+              -> logger+              -> LogLevel+              -> LogLevel+              -> (LogLevel -> tL)+              -> TestResult Bool+              -> Process ()+testLogLevels lck chan logger from to fn result = do+  void $ liftIO $ takeMVar lck+  let lvls = enumFromTo from to+  logIt logger fn lvls+  testHarness lvls chan result+  liftIO $ putMVar lck ()+  where+    logIt _  _ []     = return ()+    logIt lc f (l:ls) = sendLog lc (f l) l >> logIt lc f ls++testHarness :: [LogLevel]+            -> TChan String+            -> TestResult Bool+            -> Process ()+testHarness []     chan result = do+  liftIO (atomically (isEmptyTChan chan)) >>= stash result+testHarness levels chan result = do+  msg <- liftIO $ atomically $ readTChan chan+  -- liftIO $ putStrLn $ "testHarness handling " ++ msg+  let item = readEither msg+  case item of+    Right i -> testHarness (delete i levels) chan result+    Left  _ -> testHarness levels            chan result+  where+    readEither :: String -> Either String LogLevel+    readEither s =+      case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of+        [x] -> Right x+        _   -> Left "read: ambiguous parse"++    read' =+      do x <- readPrec+         lift P.skipSpaces+         return x++tests :: NT.Transport  -> IO [Test]+tests transport = do+  let ch = logChannel+  localNode <- newLocalNode transport $ __remoteTable initRemoteTable+  lock <- newMVar ()+  ex <- newEmptyMVar+  void $ forkProcess localNode $ do (_, chan) <- testLoggingProcess+                                    liftIO $ putMVar ex chan+  chan <- takeMVar ex+  return [+      testGroup "Log Reports / LogText"+        (map (mkTestCase lock chan ch simpleShowToLog localNode) (enumFromTo Debug Emergency))+    , testGroup "Logging Raw Messages"+        (map (mkTestCase lock chan ch messageToLog localNode) (enumFromTo Debug Emergency))+    , testGroup "Custom Formatters"+        (map (mkTestCase lock chan ch messageRaw localNode) (enumFromTo Debug Emergency))+    ]+  where+    mkTestCase lck chan ch' rdr ln lvl = do+      let l = show lvl+      testCase l (delayedAssertion ("Expected up to " ++ l)+                  ln True $ testLogLevels lck chan ch' Debug lvl rdr)++    simpleShowToLog = (LogText . show)+    messageToLog    = unsafeWrapMessage . show+    messageRaw      = unsafeWrapMessage++main :: IO ()+main = testMain $ tests+
+ tests/TestMailbox.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Control.Distributed.Process hiding (monitor)+import Control.Distributed.Process.Node+import Control.Distributed.Process.Platform+  ( Resolvable(..)+  )++import qualified Control.Distributed.Process.Platform (__remoteTable)+import Control.Distributed.Process.Platform.Execution.Mailbox+import Control.Distributed.Process.Platform.Test+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Platform.Timer+import Control.Monad (forM_)++import Control.Rematch (equalTo)++#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch, drop)+#else+import Prelude hiding (drop)+#endif++import Data.Maybe (catMaybes)++import Test.Framework as TF (testGroup, Test)+import Test.Framework.Providers.HUnit+import TestUtils+import qualified MailboxTestFilters (__remoteTable)+import MailboxTestFilters (myFilter, intFilter)++import qualified Network.Transport as NT++-- TODO: This whole test suite would be much better off using QuickCheck.+-- The test-framework driver however, doesn't have the API support we'd need+-- to wire in our tests, so we'll have to write a compatibility layer.+-- That should probably go into (or beneath) the C.D.P.P.Test module.++allBuffersShouldRespectFIFOOrdering :: BufferType -> TestResult Bool -> Process ()+allBuffersShouldRespectFIFOOrdering buffT result = do+  let [a, b, c] = ["a", "b", "c"]+  mbox <- createAndSend buffT [a, b, c]+  active mbox acceptEverything+  Just Delivery { messages = msgs } <- receiveTimeout (after 2 Seconds)+                                                         [ match return ]+  let [ma', mb', mc'] = msgs+  Just a' <- unwrapMessage ma' :: Process (Maybe String)+  Just b' <- unwrapMessage mb' :: Process (Maybe String)+  Just c' <- unwrapMessage mc' :: Process (Maybe String)+  let values = [a', b', c']+  stash result $ values == [a, b, c]+--  if values /= [a, b, c]+--     then liftIO $ putStrLn $ "unexpected " ++ ((show buffT) ++ (" values: " ++ (show values)))+--     else return ()++resizeShouldRespectOrdering :: BufferType+           -> TestResult [String]+           -> Process ()+resizeShouldRespectOrdering buffT result = do+  let [a, b, c, d, e] = ["a", "b", "c", "d", "e"]+  mbox <- createAndSend buffT [a, b, c, d, e]+  resize mbox (3 :: Integer)++  active mbox acceptEverything+  Just Delivery{ messages = msgs } <- receiveTimeout (after 2 Seconds) [ match return ]++  let [mc', md', me'] = msgs+  Just c' <- unwrapMessage mc' :: Process (Maybe String)+  Just d' <- unwrapMessage md' :: Process (Maybe String)+  Just e' <- unwrapMessage me' :: Process (Maybe String)+  let values = [c', d', e']+  stash result $ values++bufferLimiting :: BufferType -> TestResult (Integer, [Maybe String]) -> Process ()+bufferLimiting buffT result = do+  let msgs = ["a", "b", "c", "d", "e", "f", "g"]+  mbox <- createMailboxAndPost buffT 4 msgs++  MailboxStats{ pendingMessages = pending'+              , droppedMessages = dropped'+              , currentLimit    = limit' } <- statistics mbox+  pending' `shouldBe` equalTo 4+  dropped' `shouldBe` equalTo 3+  limit'   `shouldBe` equalTo 4++  active mbox acceptEverything+  Just Delivery{ messages = recvd+               , totalDropped = skipped } <- receiveTimeout (after 5 Seconds)+                                                            [ match return ]+  seen <- mapM unwrapMessage recvd+  stash result (skipped, seen)++mailboxIsInitiallyPassive :: TestResult Bool -> Process ()+mailboxIsInitiallyPassive result = do+  mbox <- createMailbox Stack (6 :: Integer)+  mapM_ (post mbox) ([1..5] :: [Int])+  Nothing <- receiveTimeout (after 3 Seconds) [ matchAny return ]+  notify mbox+  inbound <- receiveTimeout (after 3 Seconds) [ match return ]+  case inbound of+    Just (NewMail _ _) -> stash result True+    Nothing            -> stash result False++complexMailboxFiltering :: (String, Int, Bool)+                        -> TestResult (String, Int, Bool)+                        -> Process ()+complexMailboxFiltering inputs@(s', i', b') result = do+  mbox <- createMailbox Stack (10 :: Integer)+  post mbox s'+  post mbox i'+  post mbox b'+  waitForMailboxReady mbox 3++  active mbox $ myFilter inputs+  Just Delivery{ messages = [m1, m2, m3]+               , totalDropped = _ } <- receiveTimeout (after 5 Seconds)+                                                      [ match return ]+  Just s <- unwrapMessage m1 :: Process (Maybe String)+  Just i <- unwrapMessage m2 :: Process (Maybe Int)+  Just b <- unwrapMessage m3 :: Process (Maybe Bool)+  stash result $ (s, i, b)++dropDuringFiltering :: TestResult Bool -> Process ()+dropDuringFiltering result = do+  let rng = [1..50] :: [Int]+  mbox <- createMailbox Stack (50 :: Integer)+  mapM_ (post mbox) rng++  waitForMailboxReady mbox 50+  active mbox $ intFilter++  Just Delivery{ messages = msgs } <- receiveTimeout (after 5 Seconds)+                                                     [ match return ]+  seen <- mapM unwrapMessage msgs+  stash result $ (catMaybes seen) == (filter even rng)++mailboxHandleReUse :: TestResult Bool -> Process ()+mailboxHandleReUse result = do+  mbox <- createMailbox Queue (1 :: Limit)+  post mbox "abc"++  notify mbox+  Just (NewMail mbox' _) <- receiveTimeout (after 2 Seconds)+                                           [ match return ]+  deliver mbox'+  _ <- expect :: Process Delivery+  stash result True++createAndSend :: BufferType -> [String] -> Process Mailbox+createAndSend buffT msgs = createMailboxAndPost buffT 10 msgs++createMailboxAndPost :: BufferType -> Limit -> [String] -> Process Mailbox+createMailboxAndPost buffT maxSz msgs = do+  (cc, cp) <- newChan+  mbox <- createMailbox buffT maxSz+  spawnLocal $ mapM_ (post mbox) msgs >> sendChan cc ()+  () <- receiveChan cp+  waitForMailboxReady mbox $ min (toInteger (length msgs)) maxSz+  return mbox++waitForMailboxReady :: Mailbox -> Integer -> Process ()+waitForMailboxReady mbox sz = do+  sleep $ seconds 1+  notify mbox+  m <- receiveWait [+            matchIf (\(NewMail mbox' sz') -> mbox == mbox' && sz' >= sz)+                    (\_ -> return True)+          , match (\(NewMail _ _) -> return False)+          , matchAny (\_ -> return False)+          ]+  case m of+    True  -> return ()+    False -> waitForMailboxReady mbox sz++myRemoteTable :: RemoteTable+myRemoteTable =+  Control.Distributed.Process.Platform.__remoteTable $+  MailboxTestFilters.__remoteTable initRemoteTable++tests :: NT.Transport  -> IO [Test]+tests transport = do+  {- verboseCheckWithResult stdArgs -}+  localNode <- newLocalNode transport myRemoteTable+  return [+        testGroup "Dequeue/Pop Ordering"+        [+          testCase "Queue Ordering"+          (delayedAssertion+           "Expected the Queue to offer FIFO ordering"+           localNode True (allBuffersShouldRespectFIFOOrdering Queue))+        , testCase "Stack Ordering"+          (delayedAssertion+           "Expected the Queue to offer FIFO ordering"+           localNode True (allBuffersShouldRespectFIFOOrdering Stack))+        , testCase "Ring Ordering"+           (delayedAssertion+            "Expected the Queue to offer FIFO ordering"+            localNode True (allBuffersShouldRespectFIFOOrdering Ring))+        ]+      , testGroup "Resize & Ordering"+        [+          testCase "Queue Drops Eldest"+          (delayedAssertion+           "expected c, d, e"+           localNode ["c", "d", "e"] $ resizeShouldRespectOrdering Queue)+        , testCase "Stack Drops Youngest"+          (delayedAssertion+           "expected a, b, c"+           localNode ["a", "b", "c"] $ resizeShouldRespectOrdering Stack)+        , testCase "Ring Drops Youngest"+          (delayedAssertion+           "expected a, b, c"+           localNode ["a", "b", "c"] $ resizeShouldRespectOrdering Ring)+        ]+      , testGroup "Buffer Limits & Discarded Messages"+        [+          testCase "Queue Drops Eldest and Enqueues New"+          (delayedAssertion+           "expected d, e, f, g"+           localNode ((3 :: Integer), map Just ["d", "e", "f", "g"]) $ bufferLimiting Queue)+        , testCase "Stack Drops Youngest And Pushes New"+          (delayedAssertion+           "expected a, b, c, g"+           localNode ((3 :: Integer), map Just ["a", "b", "c", "g"]) $ bufferLimiting Stack)+        , testCase "Ring Rejects New Entries"+          (delayedAssertion+           "expected a, b, c, d"+           localNode ((3 :: Integer), map Just ["a", "b", "c", "d"]) $ bufferLimiting Ring)+        ]+      , testGroup "Notification, Activation and Delivery"+        [+          testCase "Mailbox is initially Passive"+           (delayedAssertion+            "Expected the Mailbox to remain passive until told otherwise"+            localNode True mailboxIsInitiallyPassive)+        , testCase "Mailbox Notifications include usable control channel"+           (delayedAssertion+            "Expected traffic to be relayed directly to us"+            localNode True mailboxHandleReUse)+        , testCase "Complex Filtering Rules"+           (delayedAssertion+            "Expected the relevant filters to accept our data"+            localNode inputs (complexMailboxFiltering inputs))+        , testCase "Filter out unwanted messages"+           (delayedAssertion+            "Expected only even numbers to be sent delivered"+            localNode True dropDuringFiltering)+        ]+    ]+  where+    inputs = ("hello", 10 :: Int, True)++main :: IO ()+main = testMain $ tests+
+ tests/TestManagedProcess.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE TemplateHaskell     #-}++module Main where++import Control.Concurrent.MVar+import Control.Exception (SomeException)+import Control.Distributed.Process hiding (call)+import Control.Distributed.Process.Node+import Control.Distributed.Process.Platform hiding (__remoteTable, monitor, send, nsend)+import Control.Distributed.Process.Platform.ManagedProcess+import Control.Distributed.Process.Platform.Test+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Serializable()++import MathsDemo+import Counter+import qualified SafeCounter as SafeCounter++#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import TestUtils+import ManagedProcessCommon++import qualified Network.Transport as NT+import Control.Monad (void)++-- utilities++server :: Process (ProcessId, (MVar ExitReason))+server = mkServer Terminate++mkServer :: UnhandledMessagePolicy+         -> Process (ProcessId, (MVar ExitReason))+mkServer policy =+  let s = standardTestServer policy+  in do+    exitReason <- liftIO $ newEmptyMVar+    pid <- spawnLocal $ do+       catch  ((serve () (statelessInit Infinity) s >> stash exitReason ExitNormal)+                `catchesExit` [+                    (\_ msg -> do+                      mEx <- unwrapMessage msg :: Process (Maybe ExitReason)+                      case mEx of+                        Nothing -> return Nothing+                        Just r  -> stash exitReason r >>= return . Just+                    )+                 ])+              (\(e :: SomeException) -> stash exitReason $ ExitOther (show e))+    return (pid, exitReason)++explodingServer :: ProcessId+                -> Process (ProcessId, MVar ExitReason)+explodingServer pid =+  let srv = explodingTestProcess pid+  in do+    exitReason <- liftIO $ newEmptyMVar+    spid <- spawnLocal $ do+       catch  (serve () (statelessInit Infinity) srv >> stash exitReason ExitNormal)+              (\(e :: SomeException) -> stash exitReason $ ExitOther (show e))+    return (spid, exitReason)++testCallReturnTypeMismatchHandling :: TestResult Bool -> Process ()+testCallReturnTypeMismatchHandling result =+  let procDef = statelessProcess {+                    apiHandlers = [+                      handleCall (\s (m :: String) -> reply m s)+                    ]+                    , unhandledMessagePolicy = Terminate+                    } in do+    pid <- spawnLocal $ serve () (statelessInit Infinity) procDef+    res <- safeCall pid "hello buddy" :: Process (Either ExitReason ())+    case res of+      Left  (ExitOther _) -> stash result True+      _                   -> stash result False++testChannelBasedService :: TestResult Bool -> Process ()+testChannelBasedService result =+  let procDef = statelessProcess {+                    apiHandlers = [+                      handleRpcChan (\s p (m :: String) ->+                                   replyChan p m >> continue s)+                    ]+                    } in do+    pid <- spawnLocal $ serve () (statelessInit Infinity) procDef+    echo <- syncCallChan pid "hello"+    stash result (echo == "hello")+    kill pid "done"++-- MathDemo tests++testAdd :: ProcessId -> TestResult Double -> Process ()+testAdd pid result = add pid 10 10 >>= stash result++testBadAdd :: ProcessId -> TestResult (Either ExitReason Int) -> Process ()+testBadAdd pid result = safeCall pid (Add 10 10) >>= stash result++testDivByZero :: ProcessId -> TestResult (Either DivByZero Double) -> Process ()+testDivByZero pid result = divide pid 125 0 >>= stash result++-- SafeCounter tests++testSafeCounterCurrentState :: ProcessId -> TestResult Int -> Process ()+testSafeCounterCurrentState pid result =+  SafeCounter.getCount pid >>= stash result++testSafeCounterIncrement :: ProcessId -> TestResult Int -> Process ()+testSafeCounterIncrement pid result = do+  5 <- SafeCounter.getCount pid+  SafeCounter.resetCount pid+  1 <- SafeCounter.incCount pid+  2 <- SafeCounter.incCount pid+  SafeCounter.getCount pid >>= stash result++-- Counter tests++testCounterCurrentState :: TestResult Int -> Process ()+testCounterCurrentState result = do+  pid <- Counter.startCounter 5+  getCount pid >>= stash result++testCounterIncrement :: TestResult Bool -> Process ()+testCounterIncrement result = do+  pid <- Counter.startCounter 1+  n <- getCount pid+  2 <- incCount pid+  3 <- incCount pid+  getCount pid >>= \n' -> stash result (n' == (n + 2))++testCounterExceedsLimit :: TestResult Bool -> Process ()+testCounterExceedsLimit result = do+  pid <- Counter.startCounter 1+  mref <- monitor pid++  -- exceed the limit+  9 `times` (void $ incCount pid)++  -- this time we should fail+  _ <- (incCount pid)+         `catchExit` \_ (_ :: ExitReason) -> return 0++  r <- receiveWait [+      matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref)+              (\(ProcessMonitorNotification _ _ r') -> return r')+    ]+  stash result (r /= DiedNormal)++tests :: NT.Transport  -> IO [Test]+tests transport = do+  localNode <- newLocalNode transport initRemoteTable+  mpid <- newEmptyMVar+  _ <- forkProcess localNode $ launchMathServer >>= stash mpid+  pid <- takeMVar mpid+  scpid <- newEmptyMVar+  _ <- forkProcess localNode $ SafeCounter.startCounter 5 >>= stash scpid+  safeCounter <- takeMVar scpid+  return [+        testGroup "basic server functionality" [+            testCase "basic call with explicit server reply"+            (delayedAssertion+             "expected a response from the server"+             localNode (Just "foo") (testBasicCall $ wrap server))+          , testCase "basic (unsafe) call with explicit server reply"+            (delayedAssertion+             "expected a response from the server"+             localNode (Just "foo") (testUnsafeBasicCall $ wrap server))+          , testCase "basic call with implicit server reply"+            (delayedAssertion+             "expected n * 2 back from the server"+             localNode (Just 4) (testBasicCall_ $ wrap server))+          , testCase "basic (unsafe) call with implicit server reply"+            (delayedAssertion+             "expected n * 2 back from the server"+             localNode (Just 4) (testUnsafeBasicCall_ $ wrap server))+          , testCase "basic cast with manual send and explicit server continue"+            (delayedAssertion+             "expected pong back from the server"+             localNode (Just "pong") (testBasicCast $ wrap server))+          , testCase "basic (unsafe) cast with manual send and explicit server continue"+            (delayedAssertion+             "expected pong back from the server"+             localNode (Just "pong") (testUnsafeBasicCast $ wrap server))+          , testCase "cast and explicit server timeout"+            (delayedAssertion+             "expected the server to stop after the timeout"+             localNode (Just $ ExitOther "timeout") (testControlledTimeout $ wrap server))+          , testCase "(unsafe) cast and explicit server timeout"+            (delayedAssertion+             "expected the server to stop after the timeout"+             localNode (Just $ ExitOther "timeout") (testUnsafeControlledTimeout $ wrap server))+          , testCase "unhandled input when policy = Terminate"+            (delayedAssertion+             "expected the server to stop upon receiving unhandled input"+             localNode (Just $ ExitOther "UnhandledInput")+             (testTerminatePolicy $ wrap server))+          , testCase "(unsafe) unhandled input when policy = Terminate"+            (delayedAssertion+             "expected the server to stop upon receiving unhandled input"+             localNode (Just $ ExitOther "UnhandledInput")+             (testUnsafeTerminatePolicy $ wrap server))+          , testCase "unhandled input when policy = Drop"+            (delayedAssertion+             "expected the server to ignore unhandled input and exit normally"+             localNode Nothing (testDropPolicy $ wrap (mkServer Drop)))+          , testCase "(unsafe) unhandled input when policy = Drop"+            (delayedAssertion+             "expected the server to ignore unhandled input and exit normally"+             localNode Nothing (testUnsafeDropPolicy $ wrap (mkServer Drop)))+          , testCase "unhandled input when policy = DeadLetter"+            (delayedAssertion+             "expected the server to forward unhandled messages"+             localNode (Just ("UNSOLICITED_MAIL", 500 :: Int))+             (testDeadLetterPolicy $ \p -> mkServer (DeadLetter p)))+          , testCase "(unsafe) unhandled input when policy = DeadLetter"+            (delayedAssertion+             "expected the server to forward unhandled messages"+             localNode (Just ("UNSOLICITED_MAIL", 500 :: Int))+             (testUnsafeDeadLetterPolicy $ \p -> mkServer (DeadLetter p)))+          , testCase "incoming messages are ignored whilst hibernating"+            (delayedAssertion+             "expected the server to remain in hibernation"+             localNode True (testHibernation $ wrap server))+          , testCase "(unsafe) incoming messages are ignored whilst hibernating"+            (delayedAssertion+             "expected the server to remain in hibernation"+             localNode True (testUnsafeHibernation $ wrap server))+          , testCase "long running call cancellation"+            (delayedAssertion "expected to get AsyncCancelled"+             localNode True (testKillMidCall $ wrap server))+          , testCase "(unsafe) long running call cancellation"+            (delayedAssertion "expected to get AsyncCancelled"+             localNode True (testUnsafeKillMidCall $ wrap server))+          , testCase "simple exit handling"+            (delayedAssertion "expected handler to catch exception and continue"+             localNode Nothing (testSimpleErrorHandling $ explodingServer))+          , testCase "(unsafe) simple exit handling"+            (delayedAssertion "expected handler to catch exception and continue"+             localNode Nothing (testUnsafeSimpleErrorHandling $ explodingServer))+          , testCase "alternative exit handlers"+            (delayedAssertion "expected handler to catch exception and continue"+             localNode Nothing (testAlternativeErrorHandling $ explodingServer))+          , testCase "(unsafe) alternative exit handlers"+            (delayedAssertion "expected handler to catch exception and continue"+             localNode Nothing (testUnsafeAlternativeErrorHandling $ explodingServer))+          ]+        , testGroup "math server examples" [+            testCase "error (Left) returned from x / 0"+              (delayedAssertion+               "expected the server to return DivByZero"+               localNode (Left DivByZero) (testDivByZero pid))+          , testCase "10 + 10 = 20"+              (delayedAssertion+               "expected the server to return DivByZero"+               localNode 20 (testAdd pid))+          , testCase "10 + 10 does not evaluate to 10 :: Int at all!"+            (delayedAssertion+             "expected the server to return ExitOther..."+             localNode+             (Left $ ExitOther $ "DiedException \"exit-from=" ++ (show pid) ++ "\"")+             (testBadAdd pid))+          ]+        , testGroup "counter server examples" [+            testCase "initial counter state = 5"+              (delayedAssertion+               "expected the server to return the initial state of 5"+               localNode 5 testCounterCurrentState)+          , testCase "increment counter twice"+              (delayedAssertion+               "expected the server to return the incremented state as 7"+               localNode True testCounterIncrement)+          , testCase "exceed counter limits"+            (delayedAssertion+             "expected the server to terminate once the limit was exceeded"+             localNode True testCounterExceedsLimit)+          ]+        , testGroup "safe counter examples" [+            testCase "initial counter state = 5"+              (delayedAssertion+               "expected the server to return the initial state of 5"+               localNode 5 (testSafeCounterCurrentState safeCounter))+          , testCase "increment counter twice"+              (delayedAssertion+               "expected the server to return the incremented state as 7"+               localNode 2 (testSafeCounterIncrement safeCounter))+          ]+      ]++main :: IO ()+main = testMain $ tests+
+ tests/TestPrimitives.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE TemplateHaskell           #-}++module Main where++import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)+import Control.Distributed.Process+import Control.Distributed.Process.Node+import Control.Distributed.Process.Serializable()++import Control.Distributed.Process.Platform hiding (__remoteTable, monitor, send)+import qualified Control.Distributed.Process.Platform (__remoteTable)+import Control.Distributed.Process.Platform.Call+import Control.Distributed.Process.Platform.Service.Monitoring+import Control.Distributed.Process.Platform.Time+import Control.Monad (void)+import Control.Rematch hiding (match)+import qualified Network.Transport as NT (Transport)+import Network.Transport.TCP()+#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif++import Test.HUnit (Assertion)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)++import Control.Distributed.Process.Platform.Test+import TestUtils++testLinkingWithNormalExits :: TestResult DiedReason -> Process ()+testLinkingWithNormalExits result = do+  testPid <- getSelfPid+  pid <- spawnLocal $ do+    worker <- spawnLocal $ do+      "finish" <- expect+      return ()+    linkOnFailure worker+    send testPid worker+    () <- expect+    return ()++  workerPid <- expect :: Process ProcessId+  ref <- monitor workerPid++  send workerPid "finish"+  receiveWait [+      matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')+              (\_ -> return ())+    ]++  -- by now, the worker is gone, so we can check that the+  -- insulator is still alive and well and that it exits normally+  -- when asked to do so+  ref2 <- monitor pid+  send pid ()++  r <- receiveWait [+      matchIf (\(ProcessMonitorNotification ref2' _ _) -> ref2 == ref2')+              (\(ProcessMonitorNotification _ _ reason) -> return reason)+    ]+  stash result r++testLinkingWithAbnormalExits :: TestResult (Maybe Bool) -> Process ()+testLinkingWithAbnormalExits result = do+  testPid <- getSelfPid+  pid <- spawnLocal $ do+    worker <- spawnLocal $ do+      "finish" <- expect+      return ()++    linkOnFailure worker+    send testPid worker+    () <- expect+    return ()++  workerPid <- expect :: Process ProcessId++  ref <- monitor pid+  kill workerPid "finish"  -- note the use of 'kill' instead of send+  r <- receiveTimeout (asTimeout $ seconds 20) [+      matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')+              (\(ProcessMonitorNotification _ _ reason) -> return reason)+    ]+  case r of+    Just (DiedException _) -> stash result $ Just True+    (Just _)               -> stash result $ Just False+    Nothing                -> stash result Nothing++testMonitorNodeDeath :: NT.Transport -> TestResult () -> Process ()+testMonitorNodeDeath transport result = do+  void $ nodeMonitor >> monitorNodes   -- start node monitoring++  nid1 <- getSelfNode+  nid2 <- liftIO $ newEmptyMVar+  nid3 <- liftIO $ newEmptyMVar++  node2 <- liftIO $ newLocalNode transport initRemoteTable+  node3 <- liftIO $ newLocalNode transport initRemoteTable++  -- sending to (nodeId, "ignored") is a short cut to force a connection+  liftIO $ tryForkProcess node2 $ ensureNodeRunning nid2 (nid1, "ignored")+  liftIO $ tryForkProcess node3 $ ensureNodeRunning nid3 (nid1, "ignored")++  NodeUp _ <- expect+  NodeUp _ <- expect++  void $ liftIO $ closeLocalNode node2+  void $ liftIO $ closeLocalNode node3++  NodeDown n1 <- expect+  NodeDown n2 <- expect++  mn1 <- liftIO $ takeMVar nid2+  mn2 <- liftIO $ takeMVar nid3++  [mn1, mn2] `shouldContain` n1+  [mn1, mn2] `shouldContain` n2++  nid4 <- liftIO $ newEmptyMVar+  node4 <- liftIO $ newLocalNode transport initRemoteTable+  void $ liftIO $ runProcess node4 $ do+    us <- getSelfNode+    liftIO $ putMVar nid4 us+    monitorNode nid1 >> return ()++  mn3 <- liftIO $ takeMVar nid4+  NodeUp n3 <- expect+  mn3 `shouldBe` (equalTo n3)++  liftIO $ closeLocalNode node4+  stash result ()++  where+    ensureNodeRunning mvar nid = do+      us <- getSelfNode+      liftIO $ putMVar mvar us+      sendTo nid "connected"++myRemoteTable :: RemoteTable+myRemoteTable = Control.Distributed.Process.Platform.__remoteTable initRemoteTable++multicallTest :: NT.Transport -> Assertion+multicallTest transport =+  do node1 <- newLocalNode transport myRemoteTable+     tryRunProcess node1 $+       do pid1 <- whereisOrStart "server1" server1+          _ <- whereisOrStart "server2" server2+          pid2 <- whereisOrStart "server2" server2+          tag <- newTagPool++          -- First test: expect positives answers from both processes+          tag1 <- getTag tag+          result1 <- multicall [pid1,pid2] mystr tag1 infiniteWait+          case result1 of+            [Just reversed, Just doubled] |+                 reversed == reverse mystr && doubled == mystr ++ mystr -> return ()+            _ -> error "Unmatched"++          -- Second test: First process works, second thread throws an exception+          tag2 <- getTag tag+          [Just 10, Nothing] <- multicall [pid1,pid2] (5::Int) tag2 infiniteWait :: Process [Maybe Int]++          -- Third test: First process exceeds time limit, second process is still dead+          tag3 <- getTag tag+          [Nothing, Nothing] <- multicall [pid1,pid2] (23::Int) tag3 (Just 1000000) :: Process [Maybe Int]+          return ()+    where server1 = receiveWait [callResponse (\str -> mention (str::String) (return (reverse str,())))]  >>+                    receiveWait [callResponse (\i -> mention (i::Int) (return (i*2,())))] >>+                    receiveWait [callResponse (\i -> liftIO (threadDelay 2000000) >> mention (i::Int) (return (i*10,())))]+          server2 = receiveWait [callResponse (\str -> mention (str::String) (return (str++str,())))] >>+                    receiveWait [callResponse (\i -> error "barf" >> mention (i::Int) (return (i :: Int,())))]+          mystr = "hello"+          mention :: a -> b -> b+          mention _a b = b++++--------------------------------------------------------------------------------+-- Utilities and Plumbing                                                     --+--------------------------------------------------------------------------------++tests :: NT.Transport -> LocalNode  -> [Test]+tests transport localNode = [+    testGroup "Linking Tests" [+        testCase "testLinkingWithNormalExits"+                 (delayedAssertion+                  "normal exit should not terminate the caller"+                  localNode DiedNormal testLinkingWithNormalExits)+      , testCase "testLinkingWithAbnormalExits"+                 (delayedAssertion+                  "abnormal exit should terminate the caller"+                  localNode (Just True) testLinkingWithAbnormalExits)+      ],+    testGroup "Call/RPC" [+        testCase "multicallTest" (multicallTest transport)+      ],+    testGroup "Node Monitoring" [+        testCase "Death Notifications"+         (delayedAssertion+          "subscribers should both have received NodeDown twice"+          localNode () (testMonitorNodeDeath transport))+      ]+  ]++primitivesTests :: NT.Transport -> IO [Test]+primitivesTests transport = do+  localNode <- newLocalNode transport initRemoteTable+  let testData = tests transport localNode+  return testData++main :: IO ()+main = testMain $ primitivesTests
+ tests/TestPrioritisedProcess.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE DeriveGeneric       #-}++-- NB: this module contains tests for the GenProcess /and/ GenServer API.++module Main where++import Control.Concurrent.MVar+import Control.Exception (SomeException)+import Control.DeepSeq (NFData)+import Control.Distributed.Process hiding (call, send)+import Control.Distributed.Process.Node+import Control.Distributed.Process.Platform hiding (__remoteTable)+import Control.Distributed.Process.Platform.Async+import Control.Distributed.Process.Platform.ManagedProcess+import Control.Distributed.Process.Platform.Test+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Platform.Timer+import Control.Distributed.Process.Serializable()++import Data.Binary+import Data.Either (rights)+import Data.Typeable (Typeable)++#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import TestUtils+import ManagedProcessCommon++import qualified Network.Transport as NT++import GHC.Generics (Generic)++-- utilities++server :: Process (ProcessId, (MVar ExitReason))+server = mkServer Terminate++mkServer :: UnhandledMessagePolicy+         -> Process (ProcessId, (MVar ExitReason))+mkServer policy =+  let s = standardTestServer policy+      p = s `prioritised` ([] :: [DispatchPriority ()])+  in do+    exitReason <- liftIO $ newEmptyMVar+    pid <- spawnLocal $ do+       catch  ((pserve () (statelessInit Infinity) p >> stash exitReason ExitNormal)+                `catchesExit` [+                    (\_ msg -> do+                      mEx <- unwrapMessage msg :: Process (Maybe ExitReason)+                      case mEx of+                        Nothing -> return Nothing+                        Just r  -> stash exitReason r >>= return . Just+                    )+                 ])+              (\(e :: SomeException) -> stash exitReason $ ExitOther (show e))+    return (pid, exitReason)++explodingServer :: ProcessId+                -> Process (ProcessId, MVar ExitReason)+explodingServer pid =+  let srv = explodingTestProcess pid+      pSrv = srv `prioritised` ([] :: [DispatchPriority s])+  in do+    exitReason <- liftIO $ newEmptyMVar+    spid <- spawnLocal $ do+       catch  (pserve () (statelessInit Infinity) pSrv >> stash exitReason ExitNormal)+              (\(e :: SomeException) -> stash exitReason $ ExitOther (show e))+    return (spid, exitReason)++data GetState = GetState+  deriving (Typeable, Generic, Show, Eq)+instance Binary GetState where+instance NFData GetState where++data MyAlarmSignal = MyAlarmSignal+  deriving (Typeable, Generic, Show, Eq)+instance Binary MyAlarmSignal where+instance NFData MyAlarmSignal where++mkPrioritisedServer :: Process ProcessId+mkPrioritisedServer =+  let p = procDef `prioritised` ([+               prioritiseInfo_ (\MyAlarmSignal   -> setPriority 10)+             , prioritiseCast_ (\(_ :: String)   -> setPriority 2)+             , prioritiseCall_ (\(cmd :: String) -> (setPriority (length cmd)) :: Priority ())+             ] :: [DispatchPriority [Either MyAlarmSignal String]]+          ) :: PrioritisedProcessDefinition [(Either MyAlarmSignal String)]+  in spawnLocal $ pserve () (initWait Infinity) p+  where+    initWait :: Delay+             -> InitHandler () [Either MyAlarmSignal String]+    initWait d () = do+      () <- expect+      return $ InitOk [] d++    procDef :: ProcessDefinition [(Either MyAlarmSignal String)]+    procDef =+      defaultProcess {+            apiHandlers = [+               handleCall (\s GetState -> reply (reverse s) s)+             , handleCall (\s (cmd :: String) -> reply () ((Right cmd):s))+             , handleCast (\s (cmd :: String) -> continue ((Right cmd):s))+            ]+          , infoHandlers = [+               handleInfo (\s (sig :: MyAlarmSignal) -> continue ((Left sig):s))+            ]+          , unhandledMessagePolicy = Drop+          , timeoutHandler         = \_ _ -> stop $ ExitOther "timeout"+          } :: ProcessDefinition [(Either MyAlarmSignal String)]++-- test cases++testInfoPrioritisation :: TestResult Bool -> Process ()+testInfoPrioritisation result = do+  pid <- mkPrioritisedServer+  -- the server (pid) is configured to wait for () during its init+  -- so we can fill up its mailbox with String messages, and verify+  -- that the alarm signal (which is prioritised *above* these)+  -- actually gets processed first despite the delivery order+  cast pid "hello"+  cast pid "prioritised"+  cast pid "world"+  -- note that these have to be a "bare send"+  send pid MyAlarmSignal+  -- tell the server it can move out of init and start processing messages+  send pid ()+  st <- call pid GetState :: Process [Either MyAlarmSignal String]+  -- the result of GetState is a list of messages in reverse insertion order+  case head st of+    Left MyAlarmSignal -> stash result True+    _ -> stash result False++testCallPrioritisation :: TestResult Bool -> Process ()+testCallPrioritisation result = do+  pid <- mkPrioritisedServer+  asyncRefs <- (mapM (callAsync pid)+                    ["first", "the longest", "commands", "we do prioritise"])+                 :: Process [Async ()]+  -- NB: This sleep is really important - the `init' function is waiting+  -- (selectively) on the () signal to go, and if it receives this *before*+  -- the async worker has had a chance to deliver the longest string message,+  -- our test will fail. Such races are /normal/ given that the async worker+  -- runs in another process and delivery order between multiple processes+  -- is undefined (and in practise, paritally depenendent on the scheduler)+  sleep $ seconds 1+  send pid ()+  mapM wait asyncRefs :: Process [AsyncResult ()]+  st <- call pid GetState :: Process [Either MyAlarmSignal String]+  let ms = rights st+  stash result $ ms == ["we do prioritise", "the longest", "commands", "first"]++tests :: NT.Transport  -> IO [Test]+tests transport = do+  localNode <- newLocalNode transport initRemoteTable+  return [+        testGroup "basic server functionality matches un-prioritised processes" [+            testCase "basic call with explicit server reply"+            (delayedAssertion+             "expected a response from the server"+             localNode (Just "foo") (testBasicCall $ wrap server))+          , testCase "basic call with implicit server reply"+            (delayedAssertion+             "expected n * 2 back from the server"+             localNode (Just 4) (testBasicCall_ $ wrap server))+          , testCase "basic cast with manual send and explicit server continue"+            (delayedAssertion+             "expected pong back from the server"+             localNode (Just "pong") (testBasicCast $ wrap server))+          , testCase "cast and explicit server timeout"+            (delayedAssertion+             "expected the server to stop after the timeout"+             localNode (Just $ ExitOther "timeout") (testControlledTimeout $ wrap server))+          , testCase "unhandled input when policy = Terminate"+            (delayedAssertion+             "expected the server to stop upon receiving unhandled input"+             localNode (Just $ ExitOther "UnhandledInput")+             (testTerminatePolicy $ wrap server))+          , testCase "unhandled input when policy = Drop"+            (delayedAssertion+             "expected the server to ignore unhandled input and exit normally"+             localNode Nothing (testDropPolicy $ wrap (mkServer Drop)))+          , testCase "unhandled input when policy = DeadLetter"+            (delayedAssertion+             "expected the server to forward unhandled messages"+             localNode (Just ("UNSOLICITED_MAIL", 500 :: Int))+             (testDeadLetterPolicy $ \p -> mkServer (DeadLetter p)))+          , testCase "incoming messages are ignored whilst hibernating"+            (delayedAssertion+             "expected the server to remain in hibernation"+             localNode True (testHibernation $ wrap server))+          , testCase "long running call cancellation"+            (delayedAssertion "expected to get AsyncCancelled"+             localNode True (testKillMidCall $ wrap server))+          , testCase "simple exit handling"+            (delayedAssertion "expected handler to catch exception and continue"+             localNode Nothing (testSimpleErrorHandling $ explodingServer))+          , testCase "alternative exit handlers"+            (delayedAssertion "expected handler to catch exception and continue"+             localNode Nothing (testAlternativeErrorHandling $ explodingServer))+          ]+      , testGroup "Prioritised Mailbox Handling" [+            testCase "Info Message Prioritisation"+            (delayedAssertion "expected the info handler to be prioritised"+             localNode True testInfoPrioritisation)+          , testCase "Call Message Prioritisation"+            (delayedAssertion "expected the longest strings to be prioritised"+             localNode True testCallPrioritisation)+          ]+      ]++main :: IO ()+main = testMain $ tests++
+ tests/TestQueues.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE PatternGuards  #-}+module Main where++import qualified Control.Distributed.Process.Platform.Internal.Queue.SeqQ as FIFO+import Control.Distributed.Process.Platform.Internal.Queue.SeqQ ( SeqQ )+import qualified Control.Distributed.Process.Platform.Internal.Queue.PriorityQ as PQ++import Control.Rematch hiding (on)+import Control.Rematch.Run+import Data.Function (on)+import Data.List+import Test.Framework as TF (defaultMain, testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.HUnit (Assertion, assertFailure)++import Prelude++expectThat :: a -> Matcher a -> Assertion+expectThat a matcher = case res of+  MatchSuccess -> return ()+  (MatchFailure msg) -> assertFailure msg+  where res = runMatch matcher a++-- NB: these tests/properties are not meant to be complete, but rather+-- they exercise the small number of behaviours that we actually use!++-- TODO: some laziness vs. strictness tests, with error/exception checking++prop_pq_ordering :: [Int] -> Bool+prop_pq_ordering xs =+    let xs' = map (\x -> (x, show x)) xs+        q   = foldl (\q' x -> PQ.enqueue (fst x) (snd x) q') PQ.empty xs'+        ys  = drain q []+        zs  = [snd x | x <- reverse $ sortBy (compare `on` fst) xs']+        -- the sorted list should match the stuff we drained back out+    in zs == ys+  where+    drain q xs'+      | True <- PQ.isEmpty q = xs'+      | otherwise =+          let Just (x, q') = PQ.dequeue q in drain q' (x:xs')++prop_fifo_enqueue :: Int -> Int -> Int -> Bool+prop_fifo_enqueue a b c =+  let q1           = foldl FIFO.enqueue FIFO.empty [a,b,c]+      Just (a', q2) = FIFO.dequeue q1+      Just (b', q3) = FIFO.dequeue q2+      Just (c', q4) = FIFO.dequeue q3+      Nothing       = FIFO.dequeue q4+  in q4 `seq` [a',b',c'] == [a,b,c]  -- why seq here? to shut the compiler up.++prop_enqueue_empty :: String -> Bool+prop_enqueue_empty s =+  let q            = FIFO.enqueue FIFO.empty s+      Just (_, q') = FIFO.dequeue q+  in (FIFO.isEmpty q') == ((FIFO.isEmpty q) == False)++tests :: [TF.Test]+tests = [+     testGroup "Priority Queue Tests" [+        -- testCase "New Queue Should Be Empty"+        --   (expect (PQ.isEmpty $ PQ.empty) $ equalTo True),+        -- testCase "Singleton Queue Should Contain One Element"+        --   (expect (PQ.dequeue $ (PQ.singleton 1 "hello") :: PriorityQ Int String) $+        --      equalTo $ (Just ("hello", PQ.empty)) :: Maybe (PriorityQ Int String)),+        -- testCase "Dequeue Empty Queue Should Be Nothing"+        --   (expect (Q.isEmpty $ PQ.dequeue $+        --              (PQ.empty :: PriorityQ Int ())) $ equalTo True),+        testProperty "Enqueue/Dequeue should respect Priority order"+            prop_pq_ordering+     ],+     testGroup "FIFO Queue Tests" [+        testCase "New Queue Should Be Empty"+          (expectThat (FIFO.isEmpty $ FIFO.empty) $ equalTo True),+        testCase "Singleton Queue Should Contain One Element"+          (expectThat (FIFO.dequeue $ FIFO.singleton "hello") $+             equalTo $ Just ("hello", FIFO.empty)),+        testCase "Dequeue Empty Queue Should Be Nothing"+          (expectThat (FIFO.dequeue $ (FIFO.empty :: SeqQ ())) $+            is (Nothing :: Maybe ((), SeqQ ()))),+        testProperty "Enqueue/Dequeue should respect FIFO order"+            prop_fifo_enqueue,+        testProperty "Enqueue/Dequeue should respect isEmpty"+            prop_enqueue_empty+     ]+   ]++main :: IO ()+main = defaultMain tests+
+ tests/TestRegistry.hs view
@@ -0,0 +1,534 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE TemplateHaskell     #-}++module Main where++import Control.Concurrent.MVar (newEmptyMVar, takeMVar)+import Control.Concurrent.Utils (Lock, Exclusive(..), Synchronised(..))+import Control.Distributed.Process+import Control.Distributed.Process.Node+import Control.Distributed.Process.Platform+  ( awaitExit+  , spawnSignalled+  , Killable(..)+  )+import Control.Distributed.Process.Platform.Service.Registry+  ( Registry(..)+  , KeyUpdateEvent(..)+  , RegistryKeyMonitorNotification(..)+  , addName+  , addProperty+  , giveAwayName+  , registerName+  , registerValue+  , unregisterName+  , lookupName+  , lookupProperty+  , registeredNames+  , foldNames+  , queryNames+  , findByProperty+  , findByPropertyValue+  , awaitTimeout+  , await+  , SearchHandle+  , AwaitResult(..)+  , RegisterKeyReply(..)+  , UnregisterKeyReply(..)+  )+import qualified Control.Distributed.Process.Platform.Service.Registry as Registry+import Control.Distributed.Process.Platform.Test+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Platform.Timer (sleep)+import Control.Monad (void, forM_, forM)+import Control.Rematch+  ( equalTo+  )++import qualified Data.Foldable as Foldable+import qualified Data.List as List++#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif++import Test.HUnit (Assertion, assertFailure)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import TestUtils++import qualified Network.Transport as NT++myRegistry :: Process (Registry String ())+myRegistry = Registry.start++counterReg :: Process (Registry String Int)+counterReg = Registry.start++withRegistry :: LocalNode+             -> (Registry String () -> Process ())+             -> Assertion+withRegistry node proc = do+  runProcess node $ do+    reg' <- myRegistry+    (proc reg') `finally` (killProc reg' "goodbye")++testAddLocalName :: TestResult RegisterKeyReply -> Process ()+testAddLocalName result = do+  reg <- myRegistry+  stash result =<< addName reg "foobar"++testAddLocalProperty :: TestResult (Maybe Int) -> Process ()+testAddLocalProperty result = do+  reg <- counterReg+  addProperty reg "chickens" (42 :: Int)+  stash result =<< lookupProperty reg "chickens"++testAddRemoteProperty :: TestResult Int -> Process ()+testAddRemoteProperty result = do+  reg <- counterReg+  p <- spawnLocal $ do+    pid <- expect+    Just i <- lookupProperty reg "ducks" :: Process (Maybe Int)+    send pid i+  RegisteredOk <- registerValue reg p "ducks" (39 :: Int)+  getSelfPid >>= send p+  expect >>= stash result++testFindByPropertySet :: TestResult Bool -> Process ()+testFindByPropertySet result = do+  reg <- counterReg+  p1 <- spawnLocal $ addProperty reg "animals" (1 :: Int) >> expect >>= return+  p2 <- spawnLocal $ addProperty reg "animals" (1 :: Int) >> expect >>= return+  sleep $ seconds 1+  found <- findByProperty reg "animals"+  found `shouldContain` p1+  found `shouldContain` p2+  notFound <- findByProperty reg "foobar"+  stash result $ length notFound == 0++testFindByPropertyValueSet :: TestResult Bool -> Process ()+testFindByPropertyValueSet result = do+  us <- getSelfPid+  reg <- counterReg+  p1 <- spawnLocal $ link us >> addProperty reg "animals" (1 :: Int) >> expect >>= return+  _  <- spawnLocal $ link us >> addProperty reg "animals" (2 :: Int) >> expect >>= return+  p3 <- spawnLocal $ link us >> addProperty reg "animals" (1 :: Int) >> expect >>= return+  _  <- spawnLocal $ link us >> addProperty reg "ducks"   (1 :: Int) >> expect >>= return++  sleep $ seconds 1+  found <- findByPropertyValue reg "animals" (1 :: Int)+  found `shouldContain` p1+  found `shouldContain` p3+  stash result $ length found == 2++testCheckLocalName :: Registry String () -> Process ()+testCheckLocalName reg = do+  void $ addName reg "fwibble"+  fwibble <- lookupName reg "fwibble"+  selfPid <- getSelfPid+  fwibble `shouldBe` equalTo (Just selfPid)++testGiveAwayName :: Registry String () -> Process ()+testGiveAwayName reg = do+  testPid <- getSelfPid+  void $ addName reg "cat"+  pid <- spawnLocal $ link testPid >> (expect :: Process ())+  giveAwayName reg "cat" pid+  cat <- lookupName reg "cat"+  cat `shouldBe` equalTo (Just pid)++testMultipleRegistrations :: Registry String () -> Process ()+testMultipleRegistrations reg = do+  self <- getSelfPid+  forM_ names (addName reg)+  forM_ names $ \name -> do+    found <- lookupName reg name+    found `shouldBe` equalTo (Just self)+  where+    names = ["foo", "bar", "baz"]++testDuplicateRegistrations :: Registry String () -> Process ()+testDuplicateRegistrations reg = do+  void $ addName reg "foobar"+  RegisteredOk <- addName reg "foobar"+  pid <- spawnLocal $ (expect :: Process ()) >>= return+  result <- registerName reg "foobar" pid+  result `shouldBe` equalTo AlreadyRegistered++testUnregisterName :: Registry String () -> Process ()+testUnregisterName reg = do+  self <- getSelfPid+  void $ addName reg "fwibble"+  void $ addName reg "fwobble"+  Just self' <- lookupName reg "fwibble"+  self' `shouldBe` equalTo self+  unreg <- unregisterName reg "fwibble"+  unregFwibble <- lookupName reg "fwibble"+  unreg `shouldBe` equalTo UnregisterOk+  -- fwibble is gone...+  unregFwibble `shouldBe` equalTo Nothing+  -- but fwobble is still registered+  fwobble <- lookupName reg "fwobble"+  fwobble `shouldBe` equalTo (Just self)++testUnregisterUnknownName :: Registry String () -> Process ()+testUnregisterUnknownName reg = do+  result <- unregisterName reg "no.such.name"+  result `shouldBe` equalTo UnregisterKeyNotFound++testUnregisterAnothersName :: Registry String () -> Process ()+testUnregisterAnothersName reg = do+  (sp, rp) <- newChan+  pid <- spawnLocal $ do+    void $ addName reg "proc.name"+    sendChan sp ()+    (expect :: Process ()) >>= return+  () <- receiveChan rp+  found <- lookupName reg "proc.name"+  found `shouldBe` equalTo (Just pid)+  unreg <- unregisterName reg "proc.name"+  unreg `shouldBe` equalTo UnregisterInvalidKey++testProcessDeathHandling :: Registry String () -> Process ()+testProcessDeathHandling reg = do+  (sp, rp) <- newChan+  pid <- spawnLocal $ do+    void $ addName reg "proc.name.1"+    void $ addName reg "proc.name.2"+    sendChan sp ()+    (expect :: Process ()) >>= return+  () <- receiveChan rp+  void $ monitor pid+  regNames <- registeredNames reg pid+  regNames `shouldContain` "proc.name.1"+  regNames `shouldContain` "proc.name.2"+  send pid ()+  receiveWait [+      match (\(ProcessMonitorNotification _ _ _) -> return ())+    ]+  forM_ [1..2 :: Int] $ \n -> do+    let name = "proc.name." ++ (show n)+    found <- lookupName reg name+    found `shouldBe` equalTo Nothing+  regNames' <- registeredNames reg pid+  regNames' `shouldBe` equalTo ([] :: [String])++testLocalRegNamesFold :: Registry String () -> Process ()+testLocalRegNamesFold reg = do+  parent <- getSelfPid+  forM_ [1..1000] $ \(i :: Int) -> spawnLocal $ do+    send parent i+    addName reg (show i) >> expect :: Process ()+  waitForTestRegistrations+  ns <- foldNames reg [] $ \acc (n, _) -> return ((read n :: Int):acc)+  (List.sort ns) `shouldBe` equalTo [1..1000]+  where+    waitForTestRegistrations = do+      void $ receiveWait [ matchIf (\(i :: Int) -> i == 1000) (\_ -> return ()) ]+      sleep $ milliSeconds 150++testLocalQueryNamesFold :: Registry String () -> Process ()+testLocalQueryNamesFold reg = do+  pids <- forM [1..1000] $ \(i :: Int) -> spawnLocal $ do+    addName reg (show i) >> expect :: Process ()+  waitRegs reg 1000+  ns <- queryNames reg $ \(sh :: SearchHandle String ProcessId) -> do+    return $ Foldable.foldl (\acc pid -> (pid:acc)) [] sh+  (List.sort ns) `shouldBe` equalTo pids+  where+    waitRegs :: Registry String () -> Int -> Process ()+    waitRegs _    0 = return ()+    waitRegs reg' n = await reg' (show n) >> waitRegs reg' (n - 1)++testMonitorName :: Registry String () -> Process ()+testMonitorName reg = do+  (sp, rp) <- newChan+  pid <- spawnLocal $ do+    void $ addName reg "proc.name.1"+    void $ addName reg "proc.name.2"+    sendChan sp ()+    (expect :: Process ()) >>= return+  () <- receiveChan rp+  mRef <- Registry.monitorName reg "proc.name.2"+  send pid ()+  res <- receiveTimeout (after 2 Seconds) [+      matchIf (\(RegistryKeyMonitorNotification k ref _ _) ->+                k == "proc.name.2" && ref == mRef)+              (\(RegistryKeyMonitorNotification _ _ ev _) -> return ev)+    ]+  res `shouldBe` equalTo (Just (KeyOwnerDied DiedNormal))++testMonitorNameChange :: Registry String () -> Process ()+testMonitorNameChange reg = do+  let k = "proc.name.foo"++  lock <- liftIO $ new :: Process Lock+  acquire lock+  testPid <- getSelfPid++  pid <- spawnSignalled (addName reg k) $ const $ do+    link testPid+    synchronised lock $ giveAwayName reg k testPid+    expect >>= return++  -- at this point, we know the child has grabbed the name k for itself+  mRef <- Registry.monitorName reg k+  release lock++  ev <- receiveWait [ matchIf (\(RegistryKeyMonitorNotification k' ref _ _) ->+                                  k' == k && ref == mRef)+                                (\(RegistryKeyMonitorNotification _ _ ev' _) ->+                                  return ev') ]+  ev `shouldBe` equalTo (KeyOwnerChanged pid testPid)++testUnmonitor :: TestResult Bool -> Process ()+testUnmonitor result = do+  let k = "chickens"+  let name = "poultry"++  reg <- counterReg+  (sp, rp) <- newChan++  pid <- spawnLocal $ do+    void $ addProperty reg k (42 :: Int)+    addName reg name+    sendChan sp ()+    expect >>= return++  () <- receiveChan rp+  mRef <- Registry.monitorProp reg k pid++  void $ receiveWait [+      matchIf (\(RegistryKeyMonitorNotification k' ref ev _) ->+                k' == k && ref == mRef && ev == (KeyRegistered pid))+              return+    ]++  Registry.unmonitor reg mRef+  kill pid "goodbye!"+  awaitExit pid++  Nothing <- lookupName reg name+  t <- receiveTimeout (after 1 Seconds) [+           matchIf (\(RegistryKeyMonitorNotification k' ref ev _) ->+                    k' == k && ref == mRef && ev == (KeyRegistered pid))+                   return+         ]+  t `shouldBe` (equalTo Nothing)+  stash result True++testMonitorPropertyChanged :: TestResult Bool -> Process ()+testMonitorPropertyChanged result = do+  let k = "chickens"+  let name = "poultry"++  lock <- liftIO $ new :: Process Lock+  reg <- counterReg++  -- yes, using the lock here without exception handling is risky...+  acquire lock++  pid <- spawnSignalled (addProperty reg k (42 :: Int)) $ const $ do+    addName reg name+    synchronised lock $ addProperty reg k (45 :: Int)+    expect >>= return++  -- at this point, the worker has already registered 42 (since we used+  -- spawnSignalled to start it) and is waiting for us to unlock...+  mRef <- Registry.monitorProp reg k pid++  -- we /must/ receive a monitor notification first, for the pre-existing+  -- key and only then will we let the worker move on and update the value+  void $ receiveWait [+      matchIf (\(RegistryKeyMonitorNotification k' ref ev _) ->+                k' == k && ref == mRef && ev == (KeyRegistered pid))+              return+    ]++  release lock++  kr <- receiveTimeout 1000000 [+      matchIf (\(RegistryKeyMonitorNotification k' ref ev _) ->+                k' == k && ref == mRef && ev == (KeyRegistered pid))+              return+    ]++  stash result (kr /= Nothing)++testMonitorPropertyOwnerDied :: Registry String () -> Process ()+testMonitorPropertyOwnerDied reg = do+  let k = "foo.bar"+  pid <- spawnSignalled (addProperty reg k ()) $ const $ do+    expect >>= return++  mRef <- Registry.monitorProp reg k pid+  kill pid "goodbye!"++  -- we /must/ receive a monitor notification first, for the pre-existing+  -- key and only then will we let the worker move on and update the value+  r <- receiveTimeout 1000000 [+      matchIf (\(RegistryKeyMonitorNotification k' ref ev _) ->+                k' == k && ref == mRef && ev /= (KeyRegistered pid))+              (\(RegistryKeyMonitorNotification _ _ ev _) ->+                return ev)+    ]+  case r of+    Just (KeyOwnerDied (DiedException _)) -> return ()+    _ -> (liftIO $ putStrLn (show r)) >> return ()++-- testMonitorLeaseExpired :: ProcessId -> Process ()++-- testMonitorPropertyLeaseExpired :: ProcessId -> Process ()++testMonitorUnregistration :: Registry String () -> Process ()+testMonitorUnregistration reg = do+  (sp, rp) <- newChan+  pid <- spawnLocal $ do+    void $ addName reg "proc.1"+    sendChan sp ()+    expect :: Process ()+    void $ unregisterName reg "proc.1"+    sendChan sp ()+    (expect :: Process ()) >>= return+  () <- receiveChan rp+  mRef <- Registry.monitorName reg "proc.1"+  send pid ()+  () <- receiveChan rp+  res <- receiveTimeout (after 2 Seconds) [+      matchIf (\(RegistryKeyMonitorNotification k ref _ _) ->+                k == "proc.1" && ref == mRef)+              (\(RegistryKeyMonitorNotification _ _ ev _) -> return ev)+    ]+  res `shouldBe` equalTo (Just KeyUnregistered)++testMonitorRegistration :: Registry String () -> Process ()+testMonitorRegistration reg = do+  kRef <- Registry.monitorName reg "my.proc"+  pid <- spawnSignalled (addName reg "my.proc") $ const expect+  res <- receiveTimeout (after 5 Seconds) [+      matchIf (\(RegistryKeyMonitorNotification k ref _ _) ->+                k == "my.proc" && ref == kRef)+              (\(RegistryKeyMonitorNotification _ _ ev _) -> return ev)+    ]+  res `shouldBe` equalTo (Just (KeyRegistered pid))++testAwaitRegistration :: Registry String () -> Process ()+testAwaitRegistration reg = do+  pid <- spawnLocal $ do+    void $ addName reg "foo.bar"+    expect :: Process ()+  res <- awaitTimeout reg (Delay $ within 5 Seconds) "foo.bar"+  res `shouldBe` equalTo (RegisteredName pid "foo.bar")++testAwaitRegistrationNoTimeout :: Registry String () -> Process ()+testAwaitRegistrationNoTimeout reg = do+  parent <- getSelfPid+  barrier <- liftIO $ newEmptyMVar+  void $ spawnLocal $ do+    res <- await reg "baz.bog"+    case res of+      RegisteredName _ "baz.bog" -> stash barrier ()+      _ -> kill parent "BANG!"+  void $ addName reg "baz.bog"+  liftIO $ takeMVar barrier >>= return++testAwaitServerDied :: Registry String () -> Process ()+testAwaitServerDied reg = do+  result <- liftIO $ newEmptyMVar+  _ <- spawnLocal $ await reg "bobobob" >>= stash result+  sleep $ milliSeconds 250+  killProc reg "bye!"+  res <- liftIO $ takeMVar result+  case res of+    ServerUnreachable (DiedException _) -> return ()+    _ -> liftIO $ assertFailure (show res)++tests :: NT.Transport  -> IO [Test]+tests transport = do+  localNode <- newLocalNode transport initRemoteTable+  let testProc = withRegistry localNode+  return [+        testGroup "Name Registration/Unregistration"+        [+          testCase "Simple Registration"+           (delayedAssertion+            "expected the server to return the incremented state as 7"+            localNode RegisteredOk testAddLocalName)+        , testCase "Give Away Name"+           (testProc testGiveAwayName)+        , testCase "Verified Registration"+           (testProc testCheckLocalName)+        , testCase "Single Process, Multiple Registered Names"+           (testProc testMultipleRegistrations)+        , testCase "Duplicate Registration Fails"+           (testProc testDuplicateRegistrations)+        , testCase "Unregister Own Name"+           (testProc testUnregisterName)+        , testCase "Unregister Unknown Name"+           (testProc testUnregisterUnknownName)+        , testCase "Unregister Someone Else's Name"+           (testProc testUnregisterAnothersName)+        ]+      , testGroup "Properties"+        [+          testCase "Simple Property Registration"+           (delayedAssertion+            "expected the server to return the property value 42"+            localNode (Just 42) testAddLocalProperty)+        , testCase "Remote Property Registration"+           (delayedAssertion+            "expected the server to return the property value 39"+            localNode 39 testAddRemoteProperty)+        ]+      , testGroup "Queries"+        [+          testCase "Folding Over Registered Names (Locally)"+           (testProc testLocalRegNamesFold)+        , testCase "Querying Registered Names (Locally)"+           (testProc testLocalQueryNamesFold)+        , testCase "Querying Process Where Property Exists (Locally)"+           (delayedAssertion+            "expected the server to return only the relevant processes"+            localNode True testFindByPropertySet)+        , testCase "Querying Process Where Property Is Set To Specific Value (Locally)"+           (delayedAssertion+            "expected the server to return only the relevant processes"+            localNode True testFindByPropertyValueSet)+        ]+      , testGroup "Named Process Monitoring/Tracking"+        [+          testCase "Process Death Results In Unregistration"+           (testProc testProcessDeathHandling)+        , testCase "Monitoring Name Changes"+           (testProc testMonitorName)+        , testCase "Monitoring Name Changes (KeyOwnerChanged)"+           (testProc testMonitorNameChange)+        , testCase "Unmonitoring (Ignoring) Changes"+          (delayedAssertion+           "expected no further notifications after 'unmonitor' was called"+           localNode True testUnmonitor)+        , testCase "Monitoring Property Changes/Updates"+          (delayedAssertion+           "expected the server to send additional notifications for each change"+           localNode True testMonitorPropertyChanged)+        , testCase "Monitoring Property Owner Death"+           (testProc testMonitorPropertyOwnerDied)+        , testCase "Monitoring Registration"+           (testProc testMonitorRegistration)+        , testCase "Awaiting Registration"+           (testProc testAwaitRegistration)+        , testCase "Await without timeout"+           (testProc testAwaitRegistrationNoTimeout)+        , testCase "Server Died During Await"+           (testProc testAwaitServerDied)+        , testCase "Monitoring Unregistration"+           (testProc testMonitorUnregistration)+        ]+    ]++main :: IO ()+main = testMain $ tests+
+ tests/TestSupervisor.hs view
@@ -0,0 +1,1368 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}++-- NOTICE: Some of these tests are /unsafe/, and will fail intermittently, since+-- they rely on ordering constraints which the Cloud Haskell runtime does not+-- guarantee.++module Main where++import Control.Concurrent.MVar+  ( MVar+  , newMVar+  , putMVar+  , takeMVar+  )+import qualified Control.Exception as Ex+import Control.Exception (throwIO)+import Control.Distributed.Process hiding (call, monitor)+import Control.Distributed.Process.Closure+import Control.Distributed.Process.Node+import Control.Distributed.Process.Platform hiding (__remoteTable, send, sendChan)+-- import Control.Distributed.Process.Platform as Alt (monitor)+import Control.Distributed.Process.Platform.Test+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Platform.Timer+import Control.Distributed.Process.Platform.Supervisor hiding (start, shutdown)+import qualified Control.Distributed.Process.Platform.Supervisor as Supervisor+import Control.Distributed.Process.Platform.ManagedProcess.Client (shutdown)+import Control.Distributed.Process.Serializable()++import Control.Distributed.Static (staticLabel)+import Control.Monad (void, forM_, forM)+import Control.Rematch+  ( equalTo+  , is+  , isNot+  , isNothing+  , isJust+  )++import Data.ByteString.Lazy (empty)+import Data.Maybe (catMaybes)++#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif++import Test.HUnit (Assertion, assertFailure)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import TestUtils hiding (waitForExit)+import qualified Network.Transport as NT++-- test utilities++expectedExitReason :: ProcessId -> String+expectedExitReason sup = "killed-by=" ++ (show sup) +++                         ",reason=TerminatedBySupervisor"++defaultWorker :: ChildStart -> ChildSpec+defaultWorker clj =+  ChildSpec+  {+    childKey     = ""+  , childType    = Worker+  , childRestart = Temporary+  , childStop    = TerminateImmediately+  , childStart   = clj+  , childRegName = Nothing+  }++tempWorker :: ChildStart -> ChildSpec+tempWorker clj =+  (defaultWorker clj)+  {+    childKey     = "temp-worker"+  , childRestart = Temporary+  }++transientWorker :: ChildStart -> ChildSpec+transientWorker clj =+  (defaultWorker clj)+  {+    childKey     = "transient-worker"+  , childRestart = Transient+  }++intrinsicWorker :: ChildStart -> ChildSpec+intrinsicWorker clj =+  (defaultWorker clj)+  {+    childKey     = "intrinsic-worker"+  , childRestart = Intrinsic+  }++permChild :: ChildStart -> ChildSpec+permChild clj =+  (defaultWorker clj)+  {+    childKey     = "perm-child"+  , childRestart = Permanent+  }++ensureProcessIsAlive :: ProcessId -> Process ()+ensureProcessIsAlive pid = do+  result <- isProcessAlive pid+  expectThat result $ is True++runInTestContext :: LocalNode+                 -> MVar ()+                 -> RestartStrategy+                 -> [ChildSpec]+                 -> (ProcessId -> Process ())+                 -> Assertion+runInTestContext node lock rs cs proc = do+  Ex.bracket (takeMVar lock) (putMVar lock) $ \() -> runProcess node $ do+    sup <- Supervisor.start rs ParallelShutdown cs+    (proc sup) `finally` (exit sup ExitShutdown)++verifyChildWasRestarted :: ChildKey -> ProcessId -> ProcessId -> Process ()+verifyChildWasRestarted key pid sup = do+  void $ waitForExit pid+  cSpec <- lookupChild sup key+  -- TODO: handle (ChildRestarting _) too!+  case cSpec of+    Just (ref, _) -> do Just pid' <- resolve ref+                        expectThat pid' $ isNot $ equalTo pid+    _             -> do+      liftIO $ assertFailure $ "unexpected child ref: " ++ (show (key, cSpec))++verifyChildWasNotRestarted :: ChildKey -> ProcessId -> ProcessId -> Process ()+verifyChildWasNotRestarted key pid sup = do+  void $ waitForExit pid+  cSpec <- lookupChild sup key+  case cSpec of+    Just (ChildStopped, _) -> return ()+    _ -> liftIO $ assertFailure $ "unexpected child ref: " ++ (show (key, cSpec))++verifyTempChildWasRemoved :: ProcessId -> ProcessId -> Process ()+verifyTempChildWasRemoved pid sup = do+  void $ waitForExit pid+  sleepFor 500 Millis+  cSpec <- lookupChild sup "temp-worker"+  expectThat cSpec isNothing++waitForExit :: ProcessId -> Process DiedReason+waitForExit pid = do+  monitor pid >>= waitForDown++waitForDown :: Maybe MonitorRef -> Process DiedReason+waitForDown Nothing    = error "invalid mref"+waitForDown (Just ref) =+  receiveWait [ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')+                        (\(ProcessMonitorNotification _ _ dr) -> return dr) ]++drainChildren :: [Child] -> ProcessId -> Process ()+drainChildren children expected = do+  -- Receive all pids then verify they arrived in the correct order.+  -- Any out-of-order messages (such as ProcessMonitorNotification) will+  -- violate the invariant asserted below, and fail the test case+  pids <- forM children $ \_ -> expect :: Process ProcessId+  let first' = head pids+  Just exp' <- resolve expected+  -- however... we do allow for the scheduler and accept `head $ tail pids` in+  -- lieu of the correct result, since when there are multiple senders we have+  -- no causal guarantees+  if first' /= exp'+     then let second' = head $ tail pids in second' `shouldBe` equalTo exp'+     else first' `shouldBe` equalTo exp'++exitIgnore :: Process ()+exitIgnore = liftIO $ throwIO ChildInitIgnore++noOp :: Process ()+noOp = return ()++blockIndefinitely :: Process ()+blockIndefinitely = runTestProcess noOp++notifyMe :: ProcessId -> Process ()+notifyMe me = getSelfPid >>= send me >> obedient++sleepy :: Process ()+sleepy = (sleepFor 5 Minutes)+           `catchExit` (\_ (_ :: ExitReason) -> return ()) >> sleepy++obedient :: Process ()+obedient = (sleepFor 5 Minutes)+           {- supervisor inserts handlers that act like we wrote:+             `catchExit` (\_ (r :: ExitReason) -> do+                             case r of+                               ExitShutdown -> return ()+                               _ -> die r)+           -}++$(remotable [ 'exitIgnore+            , 'noOp+            , 'blockIndefinitely+            , 'sleepy+            , 'obedient+            , 'notifyMe])++-- test cases start here...++normalStartStop :: ProcessId -> Process ()+normalStartStop sup = do+  ensureProcessIsAlive sup+  void $ monitor sup+  shutdown sup+  sup `shouldExitWith` DiedNormal++sequentialShutdown :: TestResult (Maybe ()) -> Process ()+sequentialShutdown result = do+  (sp, rp) <- newChan+  (sg, rg) <- newChan+  core' <- toChildStart $ runCore sp+  app'  <- toChildStart $ runApp sg+  let core = (permChild core') { childRegName = Just (LocalName "core")+                               , childStop = TerminateTimeout (Delay $ within 2 Seconds)+                               , childKey  = "child-1"+                               }+  let app  = (permChild app')  { childRegName = Just (LocalName "app")+                               , childStop = TerminateTimeout (Delay $ within 2 Seconds)+                               , childKey  = "child-2"+                               }++  sup <- Supervisor.start restartRight+                          (SequentialShutdown RightToLeft)+                          [core, app]++  () <- receiveChan rg+  exit sup ExitShutdown+  res <- receiveChanTimeout (asTimeout $ seconds 2) rp++--  whereis "core" >>= liftIO . putStrLn . ("core :" ++) . show+--  whereis "app"  >>= liftIO . putStrLn . ("app :" ++) . show++  sleepFor 1 Seconds+  stash result res++  where+    runCore :: SendPort () -> Process ()+    runCore sp = (expect >>= say) `catchExit` (\_ ExitShutdown -> sendChan sp ())++    runApp :: SendPort () -> Process ()+    runApp sg = do+      Just pid <- whereis "core"+      link pid  -- if the real "core" exits first, we go too+      sendChan sg ()+      expect >>= say++configuredTemporaryChildExitsWithIgnore ::+     ChildStart+  -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)+  -> Assertion+configuredTemporaryChildExitsWithIgnore cs withSupervisor =+  let spec = tempWorker cs in do+    withSupervisor restartOne [spec] verifyExit+  where+    verifyExit :: ProcessId -> Process ()+    verifyExit sup = do+--      sa <- isProcessAlive sup+      child <- lookupChild sup "temp-worker"+      case child of+        Nothing       -> return () -- the child exited and was removed ok+        Just (ref, _) -> do+          Just pid <- resolve ref+          verifyTempChildWasRemoved pid sup++configuredNonTemporaryChildExitsWithIgnore ::+      ChildStart+   -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)+   -> Assertion+configuredNonTemporaryChildExitsWithIgnore cs withSupervisor =+  let spec = transientWorker cs in do+    withSupervisor restartOne [spec] $ verifyExit spec+  where+    verifyExit :: ChildSpec -> ProcessId -> Process ()+    verifyExit spec sup = do+      sleep $ milliSeconds 100  -- make sure our super has seen the EXIT signal+      child <- lookupChild sup (childKey spec)+      case child of+        Nothing           -> liftIO $ assertFailure $ "lost non-temp spec!"+        Just (ref, spec') -> do+          rRef <- resolve ref+          maybe (return DiedNormal) waitForExit rRef+          cSpec <- lookupChild sup (childKey spec')+          case cSpec of+            Just (ChildStartIgnored, _) -> return ()+            _                           -> do+              liftIO $ assertFailure $ "unexpected lookup: " ++ (show cSpec)++startTemporaryChildExitsWithIgnore :: ChildStart -> ProcessId -> Process ()+startTemporaryChildExitsWithIgnore cs sup =+  -- if a temporary child exits with "ignore" then we must+  -- have deleted its specification from the supervisor+  let spec = tempWorker cs in do+    ChildAdded ref <- startNewChild sup spec+    Just pid <- resolve ref+    verifyTempChildWasRemoved pid sup++startNonTemporaryChildExitsWithIgnore :: ChildStart -> ProcessId -> Process ()+startNonTemporaryChildExitsWithIgnore cs sup =+  let spec = transientWorker cs in do+    ChildAdded ref <- startNewChild sup spec+    Just pid <- resolve ref+    void $ waitForExit pid+    sleep $ milliSeconds 250+    cSpec <- lookupChild sup (childKey spec)+    case cSpec of+      Just (ChildStartIgnored, _) -> return ()+      _                      -> do+        liftIO $ assertFailure $ "unexpected lookup: " ++ (show cSpec)++addChildWithoutRestart :: ChildStart -> ProcessId -> Process ()+addChildWithoutRestart cs sup =+  let spec = transientWorker cs in do+    response <- addChild sup spec+    response `shouldBe` equalTo (ChildAdded ChildStopped)++addChildThenStart :: ChildStart -> ProcessId -> Process ()+addChildThenStart cs sup =+  let spec = transientWorker cs in do+    (ChildAdded _) <- addChild sup spec+    response <- startChild sup (childKey spec)+    case response of+      ChildStartOk (ChildRunning pid) -> do+        alive <- isProcessAlive pid+        alive `shouldBe` equalTo True+      _ -> do+        liftIO $ putStrLn (show response)+        die "Ooops"++startUnknownChild :: ChildStart -> ProcessId -> Process ()+startUnknownChild cs sup = do+  response <- startChild sup (childKey (transientWorker cs))+  response `shouldBe` equalTo ChildStartUnknownId++setupChild :: ChildStart -> ProcessId -> Process (ChildRef, ChildSpec)+setupChild cs sup = do+  let spec = transientWorker cs+  response <- addChild sup spec+  response `shouldBe` equalTo (ChildAdded ChildStopped)+  Just child <- lookupChild sup "transient-worker"+  return child++addDuplicateChild :: ChildStart -> ProcessId -> Process ()+addDuplicateChild cs sup = do+  (ref, spec) <- setupChild cs sup+  dup <- addChild sup spec+  dup `shouldBe` equalTo (ChildFailedToStart $ StartFailureDuplicateChild ref)++startDuplicateChild :: ChildStart -> ProcessId -> Process ()+startDuplicateChild cs sup = do+  (ref, spec) <- setupChild cs sup+  dup <- startNewChild sup spec+  dup `shouldBe` equalTo (ChildFailedToStart $ StartFailureDuplicateChild ref)++startBadClosure :: ChildStart -> ProcessId -> Process ()+startBadClosure cs sup = do+  let spec = tempWorker cs+  child <- startNewChild sup spec+  child `shouldBe` equalTo+    (ChildFailedToStart $ StartFailureBadClosure+       "user error (Could not resolve closure: Invalid static label 'non-existing')")++-- configuredBadClosure withSupervisor = do+--   let spec = permChild (closure (staticLabel "non-existing") empty)+--   -- we make sure we don't hit the supervisor's limits+--   let strategy = RestartOne $ limit (maxRestarts 500000000) (milliSeconds 1)+--   withSupervisor strategy [spec] $ \sup -> do+-- --    ref <- monitor sup+--     children <- (listChildren sup)+--     let specs = map fst children+--     expectThat specs $ equalTo []++deleteExistingChild :: ChildStart -> ProcessId -> Process ()+deleteExistingChild cs sup = do+  let spec = transientWorker cs+  (ChildAdded ref) <- startNewChild sup spec+  result <- deleteChild sup "transient-worker"+  result `shouldBe` equalTo (ChildNotStopped ref)++deleteStoppedTempChild :: ChildStart -> ProcessId -> Process ()+deleteStoppedTempChild cs sup = do+  let spec = tempWorker cs+  ChildAdded ref <- startNewChild sup spec+  Just pid <- resolve ref+  testProcessStop pid+  -- child needs to be stopped+  waitForExit pid+  result <- deleteChild sup (childKey spec)+  result `shouldBe` equalTo ChildNotFound++deleteStoppedChild :: ChildStart -> ProcessId -> Process ()+deleteStoppedChild cs sup = do+  let spec = transientWorker cs+  ChildAdded ref <- startNewChild sup spec+  Just pid <- resolve ref+  testProcessStop pid+  -- child needs to be stopped+  waitForExit pid+  result <- deleteChild sup (childKey spec)+  result `shouldBe` equalTo ChildDeleted++permanentChildrenAlwaysRestart :: ChildStart -> ProcessId -> Process ()+permanentChildrenAlwaysRestart cs sup = do+  let spec = permChild cs+  (ChildAdded ref) <- startNewChild sup spec+  Just pid <- resolve ref+  testProcessStop pid  -- a normal stop should *still* trigger a restart+  verifyChildWasRestarted (childKey spec) pid sup++temporaryChildrenNeverRestart :: ChildStart -> ProcessId -> Process ()+temporaryChildrenNeverRestart cs sup = do+  let spec = tempWorker cs+  (ChildAdded ref) <- startNewChild sup spec+  Just pid <- resolve ref+  kill pid "bye bye"+  verifyTempChildWasRemoved pid sup++transientChildrenNormalExit :: ChildStart -> ProcessId -> Process ()+transientChildrenNormalExit cs sup = do+  let spec = transientWorker cs+  (ChildAdded ref) <- startNewChild sup spec+  Just pid <- resolve ref+  testProcessStop pid+  verifyChildWasNotRestarted (childKey spec) pid sup++transientChildrenAbnormalExit :: ChildStart -> ProcessId -> Process ()+transientChildrenAbnormalExit cs sup = do+  let spec = transientWorker cs+  (ChildAdded ref) <- startNewChild sup spec+  Just pid <- resolve ref+  kill pid "bye bye"+  verifyChildWasRestarted (childKey spec) pid sup++transientChildrenExitShutdown :: ChildStart -> ProcessId -> Process ()+transientChildrenExitShutdown cs sup = do+  let spec = transientWorker cs+  (ChildAdded ref) <- startNewChild sup spec+  Just pid <- resolve ref+  exit pid ExitShutdown+  verifyChildWasNotRestarted (childKey spec) pid sup++intrinsicChildrenAbnormalExit :: ChildStart -> ProcessId -> Process ()+intrinsicChildrenAbnormalExit cs sup = do+  let spec = intrinsicWorker cs+  ChildAdded ref <- startNewChild sup spec+  Just pid <- resolve ref+  kill pid "bye bye"+  verifyChildWasRestarted (childKey spec) pid sup++intrinsicChildrenNormalExit :: ChildStart -> ProcessId -> Process ()+intrinsicChildrenNormalExit cs sup = do+  let spec = intrinsicWorker cs+  ChildAdded ref <- startNewChild sup spec+  Just pid <- resolve ref+  testProcessStop pid+  reason <- waitForExit sup+  expectThat reason $ equalTo DiedNormal++explicitRestartRunningChild :: ChildStart -> ProcessId -> Process ()+explicitRestartRunningChild cs sup = do+  let spec = tempWorker cs+  ChildAdded ref <- startNewChild sup spec+  result <- restartChild sup (childKey spec)+  expectThat result $ equalTo $ ChildRestartFailed (StartFailureAlreadyRunning ref)++explicitRestartUnknownChild :: ProcessId -> Process ()+explicitRestartUnknownChild sup = do+  result <- restartChild sup "unknown-id"+  expectThat result $ equalTo ChildRestartUnknownId++explicitRestartRestartingChild :: ChildStart -> ProcessId -> Process ()+explicitRestartRestartingChild cs sup = do+  let spec = permChild cs+  ChildAdded _ <- startNewChild sup spec+  -- TODO: we've seen a few explosions here (presumably of the supervisor?)+  -- expecially when running with +RTS -N1 - it's possible that there's a bug+  -- tucked away that we haven't cracked just yet+  restarted <- (restartChild sup (childKey spec))+                 `catchExit` (\_ (r :: ExitReason) -> (liftIO $ putStrLn (show r)) >>+                                                      die r)+  -- this is highly timing dependent, so we have to allow for both+  -- possible outcomes - on a dual core machine, the first clause+  -- will match approx. 1 / 200 times when running with +RTS -N+  case restarted of+    ChildRestartFailed (StartFailureAlreadyRunning (ChildRestarting _)) -> return ()+    ChildRestartFailed (StartFailureAlreadyRunning (ChildRunning _)) -> return ()+    other -> liftIO $ assertFailure $ "unexpected result: " ++ (show other)++explicitRestartStoppedChild :: ChildStart -> ProcessId -> Process ()+explicitRestartStoppedChild cs sup = do+  let spec = transientWorker cs+  let key = childKey spec+  ChildAdded ref <- startNewChild sup spec+  void $ terminateChild sup key+  restarted <- restartChild sup key+  sleepFor 500 Millis+  Just (ref', _) <- lookupChild sup key+  expectThat ref $ isNot $ equalTo ref'+  case restarted of+    ChildRestartOk (ChildRunning _) -> return ()+    _ -> liftIO $ assertFailure $ "unexpected termination: " ++ (show restarted)++terminateChildImmediately :: ChildStart -> ProcessId -> Process ()+terminateChildImmediately cs sup = do+  let spec = tempWorker cs+  ChildAdded ref <- startNewChild sup spec+--  Just pid <- resolve ref+  mRef <- monitor ref+  void $ terminateChild sup (childKey spec)+  reason <- waitForDown mRef+  expectThat reason $ equalTo $ DiedException (expectedExitReason sup)++terminatingChildExceedsDelay :: ProcessId -> Process ()+terminatingChildExceedsDelay sup = do+  let spec = (tempWorker (RunClosure $(mkStaticClosure 'sleepy)))+             { childStop = TerminateTimeout (Delay $ within 1 Seconds) }+  ChildAdded ref <- startNewChild sup spec+-- Just pid <- resolve ref+  mRef <- monitor ref+  void $ terminateChild sup (childKey spec)+  reason <- waitForDown mRef+  expectThat reason $ equalTo $ DiedException (expectedExitReason sup)++terminatingChildObeysDelay :: ProcessId -> Process ()+terminatingChildObeysDelay sup = do+  let spec = (tempWorker (RunClosure $(mkStaticClosure 'obedient)))+             { childStop = TerminateTimeout (Delay $ within 1 Seconds) }+  ChildAdded child <- startNewChild sup spec+  Just pid <- resolve child+  testProcessGo pid+  void $ monitor pid+  void $ terminateChild sup (childKey spec)+  child `shouldExitWith` DiedNormal++restartAfterThreeAttempts ::+     ChildStart+  -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)+  -> Assertion+restartAfterThreeAttempts cs withSupervisor = do+  let spec = permChild cs+  let strategy = RestartOne $ limit (maxRestarts 500) (seconds 2)+  withSupervisor strategy [spec] $ \sup -> do+    mapM_ (\_ -> do+      [(childRef, _)] <- listChildren sup+      Just pid <- resolve childRef+      ref <- monitor pid+      testProcessStop pid+      void $ waitForDown ref) [1..3 :: Int]+    [(_, _)] <- listChildren sup+    return ()++{-+delayedRestartAfterThreeAttempts ::+     (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)+  -> Assertion+delayedRestartAfterThreeAttempts withSupervisor = do+  let restartPolicy = DelayedRestart Permanent (within 1 Seconds)+  let spec = (permChild $(mkStaticClosure 'blockIndefinitely))+             { childRestart = restartPolicy }+  let strategy = RestartOne $ limit (maxRestarts 2) (seconds 1)+  withSupervisor strategy [spec] $ \sup -> do+    mapM_ (\_ -> do+      [(childRef, _)] <- listChildren sup+      Just pid <- resolve childRef+      ref <- monitor pid+      testProcessStop pid+      void $ waitForDown ref) [1..3 :: Int]+    Just (ref, _) <- lookupChild sup $ childKey spec+    case ref of+      ChildRestarting _ -> return ()+      _ -> liftIO $ assertFailure $ "Unexpected ChildRef: " ++ (show ref)+    sleep $ seconds 2+    [(ref', _)] <- listChildren sup+    liftIO $ putStrLn $ "it is: " ++ (show ref')+    Just pid <- resolve ref'+    mRef <- monitor pid+    testProcessStop pid+    void $ waitForDown mRef+-}++permanentChildExceedsRestartsIntensity ::+     ChildStart+  -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)+  -> Assertion+permanentChildExceedsRestartsIntensity cs withSupervisor = do+  let spec = permChild cs  -- child that exits immediately+  let strategy = RestartOne $ limit (maxRestarts 50) (seconds 2)+  withSupervisor strategy [spec] $ \sup -> do+    ref <- monitor sup+    -- if the supervisor dies whilst the call is in-flight,+    -- *this* process will exit, therefore we handle that exit reason+    void $ ((startNewChild sup spec >> return ())+             `catchExit` (\_ (_ :: ExitReason) -> return ()))+    reason <- waitForDown ref+    expectThat reason $ equalTo $+                      DiedException $ "exit-from=" ++ (show sup) +++                                      ",reason=ReachedMaxRestartIntensity"++terminateChildIgnoresSiblings ::+     ChildStart+  -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)+  -> Assertion+terminateChildIgnoresSiblings cs withSupervisor = do+  let templ = permChild cs+  let specs = [templ { childKey = (show i) } | i <- [1..3 :: Int]]+  withSupervisor restartAll specs $ \sup -> do+    let toStop = childKey $ head specs+    Just (ref, _) <- lookupChild sup toStop+    mRef <- monitor ref+    terminateChild sup toStop+    waitForDown mRef+    children <- listChildren sup+    forM_ (tail $ map fst children) $ \cRef -> do+      maybe (error "invalid ref") ensureProcessIsAlive =<< resolve cRef++restartAllWithLeftToRightSeqRestarts ::+     ChildStart+  -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)+  -> Assertion+restartAllWithLeftToRightSeqRestarts cs withSupervisor = do+  let templ = permChild cs+  let specs = [templ { childKey = (show i) } | i <- [1..100 :: Int]]+  withSupervisor restartAll specs $ \sup -> do+    let toStop = childKey $ head specs+    Just (ref, _) <- lookupChild sup toStop+    children <- listChildren sup+    Just pid <- resolve ref+    kill pid "goodbye"+    forM_ (map fst children) $ \cRef -> do+      mRef <- monitor cRef+      waitForDown mRef+    forM_ (map snd children) $ \cSpec -> do+      Just (ref', _) <- lookupChild sup (childKey cSpec)+      maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref'++restartLeftWithLeftToRightSeqRestarts ::+     ChildStart+  -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)+  -> Assertion+restartLeftWithLeftToRightSeqRestarts cs withSupervisor = do+  let templ = permChild cs+  let specs = [templ { childKey = (show i) } | i <- [1..500 :: Int]]+  withSupervisor restartLeft specs $ \sup -> do+    let (toRestart, _notToRestart) = splitAt 100 specs+    let toStop = childKey $ last toRestart+    Just (ref, _) <- lookupChild sup toStop+    Just pid <- resolve ref+    children <- listChildren sup+    let (children', survivors) = splitAt 100 children+    kill pid "goodbye"+    forM_ (map fst children') $ \cRef -> do+      mRef <- monitor cRef+      waitForDown mRef+    forM_ (map snd children') $ \cSpec -> do+      Just (ref', _) <- lookupChild sup (childKey cSpec)+      maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref'+    resolved <- forM (map fst survivors) resolve+    let possibleBadRestarts = catMaybes resolved+    r <- receiveTimeout (after 1 Seconds) [+        match (\(ProcessMonitorNotification _ pid' _) -> do+          case (elem pid' possibleBadRestarts) of+            True  -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid'+            False -> return ())+      ]+    expectThat r isNothing++restartRightWithLeftToRightSeqRestarts ::+     ChildStart+  -> (RestartStrategy -> [ChildSpec] -> (ProcessId -> Process ()) -> Assertion)+  -> Assertion+restartRightWithLeftToRightSeqRestarts cs withSupervisor = do+  let templ = permChild cs+  let specs = [templ { childKey = (show i) } | i <- [1..50 :: Int]]+  withSupervisor restartRight specs $ \sup -> do+    let (_notToRestart, toRestart) = splitAt 40 specs+    let toStop = childKey $ head toRestart+    Just (ref, _) <- lookupChild sup toStop+    Just pid <- resolve ref+    children <- listChildren sup+    let (survivors, children') = splitAt 40 children+    kill pid "goodbye"+    forM_ (map fst children') $ \cRef -> do+      mRef <- monitor cRef+      waitForDown mRef+    forM_ (map snd children') $ \cSpec -> do+      Just (ref', _) <- lookupChild sup (childKey cSpec)+      maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref'+    resolved <- forM (map fst survivors) resolve+    let possibleBadRestarts = catMaybes resolved+    r <- receiveTimeout (after 1 Seconds) [+        match (\(ProcessMonitorNotification _ pid' _) -> do+          case (elem pid' possibleBadRestarts) of+            True  -> liftIO $ assertFailure $ "unexpected exit from " ++ show pid'+            False -> return ())+      ]+    expectThat r isNothing++restartAllWithLeftToRightRestarts :: ProcessId -> Process ()+restartAllWithLeftToRightRestarts sup = do+  self <- getSelfPid+  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)+  let specs = [templ { childKey = (show i) } | i <- [1..100 :: Int]]+  -- add the specs one by one+  forM_ specs $ \s -> void $ startNewChild sup s+  -- assert that we saw the startup sequence working...+  children <- listChildren sup+  drainAllChildren children+  let toStop = childKey $ head specs+  Just (ref, _) <- lookupChild sup toStop+  Just pid <- resolve ref+  kill pid "goodbye"+  -- wait for all the exit signals, so we know the children are restarting+  forM_ (map fst children) $ \cRef -> do+    Just mRef <- monitor cRef+    receiveWait [+        matchIf (\(ProcessMonitorNotification ref' _ _) -> ref' == mRef)+                (\_ -> return ())+        -- we should NOT see *any* process signalling that it has started+        -- whilst waiting for all the children to be terminated+      , match (\(pid' :: ProcessId) -> do+            liftIO $ assertFailure $ "unexpected signal from " ++ (show pid'))+      ]+  -- Now assert that all the children were restarted in the same order.+  -- THIS is the bit that is technically unsafe, though it's also unlikely+  -- to change, since the architecture of the node controller is pivotal to CH+  children' <- listChildren sup+  drainAllChildren children'+  let [c1, c2] = [map fst cs | cs <- [children, children']]+  forM_ (zip c1 c2) $ \(p1, p2) -> expectThat p1 $ isNot $ equalTo p2+  where+    drainAllChildren children = do+      -- Receive all pids then verify they arrived in the correct order.+      -- Any out-of-order messages (such as ProcessMonitorNotification) will+      -- violate the invariant asserted below, and fail the test case+      pids <- forM children $ \_ -> expect :: Process ProcessId+      forM_ pids ensureProcessIsAlive++restartAllWithRightToLeftSeqRestarts :: ProcessId -> Process ()+restartAllWithRightToLeftSeqRestarts sup = do+  self <- getSelfPid+  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)+  let specs = [templ { childKey = (show i) } | i <- [1..100 :: Int]]+  -- add the specs one by one+  forM_ specs $ \s -> do+    ChildAdded ref <- startNewChild sup s+    maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref+  -- assert that we saw the startup sequence working...+  let toStop = childKey $ head specs+  Just (ref, _) <- lookupChild sup toStop+  Just pid <- resolve ref+  children <- listChildren sup+  drainChildren children pid+  kill pid "fooboo"+  -- wait for all the exit signals, so we know the children are restarting+  forM_ (map fst children) $ \cRef -> do+    Just mRef <- monitor cRef+    receiveWait [+        matchIf (\(ProcessMonitorNotification ref' _ _) -> ref' == mRef)+                (\_ -> return ())+      ]+  -- ensure that both ends of the pids we've seen are in the right order...+  -- in this case, we expect the last child to be the first notification,+  -- since they were started in right to left order+  children' <- listChildren sup+  let (ref', _) = last children'+  Just pid' <- resolve ref'+  drainChildren children' pid'++expectLeftToRightRestarts :: ProcessId -> Process ()+expectLeftToRightRestarts sup = do+  self <- getSelfPid+  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)+  let specs = [templ { childKey = (show i) } | i <- [1..100 :: Int]]+  -- add the specs one by one+  forM_ specs $ \s -> do+    ChildAdded c <- startNewChild sup s+    Just p <- resolve c+    p' <- expect+    p' `shouldBe` equalTo p+  -- assert that we saw the startup sequence working...+  let toStop = childKey $ head specs+  Just (ref, _) <- lookupChild sup toStop+  Just pid <- resolve ref+  children <- listChildren sup+  -- wait for all the exit signals and ensure they arrive in RightToLeft order+  refs <- forM children $ \(ch, _) -> monitor ch >>= \r -> return (ch, r)+  kill pid "fooboo"+  initRes <- receiveTimeout+               (asTimeout $ seconds 1)+               [ matchIf+                 (\(ProcessMonitorNotification r _ _) -> (Just r) == (snd $ head refs))+                 (\sig@(ProcessMonitorNotification _ _ _) -> return sig) ]+  expectThat initRes $ isJust+  forM_ (reverse (filter ((/= ref) .fst ) refs)) $ \(_, Just mRef) -> do+    (ProcessMonitorNotification ref' _ _) <- expect+    if ref' == mRef then (return ()) else (die "unexpected monitor signal")+  -- in this case, we expect the first child to be the first notification,+  -- since they were started in left to right order+  children' <- listChildren sup+  let (ref', _) = head children'+  Just pid' <- resolve ref'+  drainChildren children' pid'++expectRightToLeftRestarts :: ProcessId -> Process ()+expectRightToLeftRestarts sup = do+  self <- getSelfPid+  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)+  let specs = [templ { childKey = (show i) } | i <- [1..10 :: Int]]+  -- add the specs one by one+  forM_ specs $ \s -> do+    ChildAdded ref <- startNewChild sup s+    maybe (error "invalid ref") ensureProcessIsAlive =<< resolve ref+  -- assert that we saw the startup sequence working...+  let toStop = childKey $ head specs+  Just (ref, _) <- lookupChild sup toStop+  Just pid <- resolve ref+  children <- listChildren sup+  drainChildren children pid+  kill pid "fooboo"+  -- wait for all the exit signals, so we know the children are restarting+  forM_ (map fst children) $ \cRef -> do+    Just mRef <- monitor cRef+    receiveWait [+        matchIf (\(ProcessMonitorNotification ref' _ _) -> ref' == mRef)+                (\_ -> return ())+        -- we should NOT see *any* process signalling that it has started+        -- whilst waiting for all the children to be terminated+      , match (\(pid' :: ProcessId) -> do+            liftIO $ assertFailure $ "unexpected signal from " ++ (show pid'))+      ]+  -- ensure that both ends of the pids we've seen are in the right order...+  -- in this case, we expect the last child to be the first notification,+  -- since they were started in right to left order+  children' <- listChildren sup+  let (ref', _) = last children'+  Just pid' <- resolve ref'+  drainChildren children' pid'++restartLeftWhenLeftmostChildDies :: ChildStart -> ProcessId -> Process ()+restartLeftWhenLeftmostChildDies cs sup = do+  let spec = permChild cs+  (ChildAdded ref) <- startNewChild sup spec+  (ChildAdded ref2) <- startNewChild sup $ spec { childKey = "child2" }+  Just pid <- resolve ref+  Just pid2 <- resolve ref2+  testProcessStop pid  -- a normal stop should *still* trigger a restart+  verifyChildWasRestarted (childKey spec) pid sup+  Just (ref3, _) <- lookupChild sup "child2"+  Just pid2' <- resolve ref3+  pid2 `shouldBe` equalTo pid2'++restartWithoutTempChildren :: ChildStart -> ProcessId -> Process ()+restartWithoutTempChildren cs sup = do+  (ChildAdded refTrans) <- startNewChild sup $ transientWorker cs+  (ChildAdded _)        <- startNewChild sup $ tempWorker cs+  (ChildAdded refPerm)  <- startNewChild sup $ permChild cs+  Just pid2 <- resolve refTrans+  Just pid3 <- resolve refPerm++  kill pid2 "foobar"+  void $ waitForExit pid2 -- this wait reduces the likelihood of a race in the test+  Nothing <- lookupChild sup "temp-worker"+  verifyChildWasRestarted "transient-worker" pid2 sup+  verifyChildWasRestarted "perm-child"       pid3 sup++restartRightWhenRightmostChildDies :: ChildStart -> ProcessId -> Process ()+restartRightWhenRightmostChildDies cs sup = do+  let spec = permChild cs+  (ChildAdded ref2) <- startNewChild sup $ spec { childKey = "child2" }+  (ChildAdded ref) <- startNewChild sup $ spec { childKey = "child1" }+  [ch1, ch2] <- listChildren sup+  (fst ch1) `shouldBe` equalTo ref2+  (fst ch2) `shouldBe` equalTo ref+  Just pid <- resolve ref+  Just pid2 <- resolve ref2+  -- ref (and therefore pid) is 'rightmost' now+  testProcessStop pid  -- a normal stop should *still* trigger a restart+  verifyChildWasRestarted "child1" pid sup+  Just (ref3, _) <- lookupChild sup "child2"+  Just pid2' <- resolve ref3+  pid2 `shouldBe` equalTo pid2'++restartLeftWithLeftToRightRestarts :: ProcessId -> Process ()+restartLeftWithLeftToRightRestarts sup = do+  self <- getSelfPid+  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)+  let specs = [templ { childKey = (show i) } | i <- [1..20 :: Int]]+  forM_ specs $ \s -> void $ startNewChild sup s+  -- assert that we saw the startup sequence working...+  let toStart = childKey $ head specs+  Just (ref, _) <- lookupChild sup toStart+  Just pid <- resolve ref+  children <- listChildren sup+  drainChildren children pid+  let (toRestart, _) = splitAt 7 specs+  let toStop = childKey $ last toRestart+  Just (ref', _) <- lookupChild sup toStop+  Just stopPid <- resolve ref'+  kill stopPid "goodbye"+  -- wait for all the exit signals, so we know the children are restarting+  forM_ (map fst (fst $ splitAt 7 children)) $ \cRef -> do+    mRef <- monitor cRef+    waitForDown mRef+  children' <- listChildren sup+  let (restarted, notRestarted) = splitAt 7 children'+  -- another (technically) unsafe check+  let firstRestart = childKey $ snd $ head restarted+  Just (rRef, _) <- lookupChild sup firstRestart+  Just fPid <- resolve rRef+  drainChildren restarted fPid+  let [c1, c2] = [map fst cs | cs <- [(snd $ splitAt 7 children), notRestarted]]+  forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2++restartRightWithLeftToRightRestarts :: ProcessId -> Process ()+restartRightWithLeftToRightRestarts sup = do+  self <- getSelfPid+  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)+  let specs = [templ { childKey = (show i) } | i <- [1..20 :: Int]]+  forM_ specs $ \s -> void $ startNewChild sup s+  -- assert that we saw the startup sequence working...+  let toStart = childKey $ head specs+  Just (ref, _) <- lookupChild sup toStart+  Just pid <- resolve ref+  children <- listChildren sup+  drainChildren children pid+  let (_, toRestart) = splitAt 3 specs+  let toStop = childKey $ head toRestart+  Just (ref', _) <- lookupChild sup toStop+  Just stopPid <- resolve ref'+  kill stopPid "goodbye"+  -- wait for all the exit signals, so we know the children are restarting+  forM_ (map fst (snd $ splitAt 3 children)) $ \cRef -> do+    mRef <- monitor cRef+    waitForDown mRef+  children' <- listChildren sup+  let (notRestarted, restarted) = splitAt 3 children'+  -- another (technically) unsafe check+  let firstRestart = childKey $ snd $ head restarted+  Just (rRef, _) <- lookupChild sup firstRestart+  Just fPid <- resolve rRef+  drainChildren restarted fPid+  let [c1, c2] = [map fst cs | cs <- [(fst $ splitAt 3 children), notRestarted]]+  forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2++restartRightWithRightToLeftRestarts :: ProcessId -> Process ()+restartRightWithRightToLeftRestarts sup = do+  self <- getSelfPid+  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)+  let specs = [templ { childKey = (show i) } | i <- [1..20 :: Int]]+  forM_ specs $ \s -> void $ startNewChild sup s+  -- assert that we saw the startup sequence working...+  let toStart = childKey $ head specs+  Just (ref, _) <- lookupChild sup toStart+  Just pid <- resolve ref+  children <- listChildren sup+  drainChildren children pid+  let (_, toRestart) = splitAt 3 specs+  let toStop = childKey $ head toRestart+  Just (ref', _) <- lookupChild sup toStop+  Just stopPid <- resolve ref'+  kill stopPid "goodbye"+  -- wait for all the exit signals, so we know the children are restarting+  forM_ (map fst (snd $ splitAt 3 children)) $ \cRef -> do+    mRef <- monitor cRef+    waitForDown mRef+  children' <- listChildren sup+  let (notRestarted, restarted) = splitAt 3 children'+  -- another (technically) unsafe check+  let firstRestart = childKey $ snd $ last restarted+  Just (rRef, _) <- lookupChild sup firstRestart+  Just fPid <- resolve rRef+  drainChildren restarted fPid+  let [c1, c2] = [map fst cs | cs <- [(fst $ splitAt 3 children), notRestarted]]+  forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2++restartLeftWithRightToLeftRestarts :: ProcessId -> Process ()+restartLeftWithRightToLeftRestarts sup = do+  self <- getSelfPid+  let templ = permChild $ RunClosure ($(mkClosure 'notifyMe) self)+  let specs = [templ { childKey = (show i) } | i <- [1..20 :: Int]]+  forM_ specs $ \s -> void $ startNewChild sup s+  -- assert that we saw the startup sequence working...+  let toStart = childKey $ head specs+  Just (ref, _) <- lookupChild sup toStart+  Just pid <- resolve ref+  children <- listChildren sup+  drainChildren children pid+  let (toRestart, _) = splitAt 7 specs+  let (restarts, toSurvive) = splitAt 7 children+  let toStop = childKey $ last toRestart+  Just (ref', _) <- lookupChild sup toStop+  Just stopPid <- resolve ref'+  kill stopPid "goodbye"+  -- wait for all the exit signals, so we know the children are restarting+  forM_ (map fst restarts) $ \cRef -> do+    mRef <- monitor cRef+    waitForDown mRef+  children' <- listChildren sup+  let (restarted, notRestarted) = splitAt 7 children'+  -- another (technically) unsafe check+  let firstRestart = childKey $ snd $ last restarted+  Just (rRef, _) <- lookupChild sup firstRestart+  Just fPid <- resolve rRef+  drainChildren (reverse restarted) fPid+  let [c1, c2] = [map fst cs | cs <- [toSurvive, notRestarted]]+  forM_ (zip c1 c2) $ \(p1, p2) -> p1 `shouldBe` equalTo p2++localChildStartLinking :: TestResult Bool -> Process ()+localChildStartLinking result = do+    s1 <- toChildStart procExpect+    s2 <- toChildStart procLinkExpect+    pid <- Supervisor.start restartOne ParallelShutdown [ (tempWorker s1) { childKey = "w1" }+                                                        , (tempWorker s2) { childKey = "w2" } ]+    [(r1, _), (r2, _)] <- listChildren pid+    Just p1 <- resolve r1+    Just p2 <- resolve r2+    monitor p1+    monitor p2+    shutdownAndWait pid+    waitForChildShutdown [p1, p2]+    stash result True+  where+    procExpect :: Process ()+    procExpect = expect >>= return++    procLinkExpect :: SupervisorPid -> Process ProcessId+    procLinkExpect p = spawnLocal $ link p >> procExpect++    waitForChildShutdown []   = return ()+    waitForChildShutdown pids = do+      p <- receiveWait [+               match (\(ProcessMonitorNotification _ p _) -> return p)+             ]+      waitForChildShutdown $ filter (/= p) pids++-- remote table definition and main++myRemoteTable :: RemoteTable+myRemoteTable = Main.__remoteTable initRemoteTable++withClosure :: (ChildStart -> ProcessId -> Process ())+            -> (Closure (Process ()))+            -> ProcessId -> Process ()+withClosure fn clj supervisor = do+  cs <- toChildStart clj+  fn cs supervisor++withChan :: (ChildStart -> ProcessId -> Process ())+         -> Process ()+         -> ProcessId+         -> Process ()+withChan fn proc supervisor = do+    cs <- toChildStart proc+    fn cs supervisor++tests :: NT.Transport -> IO [Test]+tests transport = do+  putStrLn $ concat [ "NOTICE: Branch Tests (Relying on Non-Guaranteed Message Order) "+                    , "Can Fail Intermittently"]+  localNode <- newLocalNode transport myRemoteTable+  singleTestLock <- newMVar ()+  let withSupervisor = runInTestContext localNode singleTestLock+  return+    [ testGroup "Supervisor Processes"+      [+          testGroup "Starting And Adding Children"+          [+              testCase "Normal (Managed Process) Supervisor Start Stop"+                (withSupervisor restartOne [] normalStartStop)+            , testGroup "Specified By Closure"+              [+                testCase "Add Child Without Starting"+                    (withSupervisor restartOne []+                          (withClosure addChildWithoutRestart+                           $(mkStaticClosure 'blockIndefinitely)))+              , testCase "Start Previously Added Child"+                    (withSupervisor restartOne []+                          (withClosure addChildThenStart+                           $(mkStaticClosure 'blockIndefinitely)))+              , testCase "Start Unknown Child"+                    (withSupervisor restartOne []+                          (withClosure startUnknownChild+                           $(mkStaticClosure 'blockIndefinitely)))+              , testCase "Add Duplicate Child"+                    (withSupervisor restartOne []+                          (withClosure addDuplicateChild+                             $(mkStaticClosure 'blockIndefinitely)))+              , testCase "Start Duplicate Child"+                    (withSupervisor restartOne []+                          (withClosure startDuplicateChild+                             $(mkStaticClosure 'blockIndefinitely)))+              , testCase "Started Temporary Child Exits With Ignore"+                    (withSupervisor restartOne []+                          (withClosure startTemporaryChildExitsWithIgnore+                             $(mkStaticClosure 'exitIgnore)))+              , testCase "Configured Temporary Child Exits With Ignore"+                    (configuredTemporaryChildExitsWithIgnore+                     (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor)+              , testCase "Start Bad Closure"+                    (withSupervisor restartOne []+                     (withClosure startBadClosure+                      (closure (staticLabel "non-existing") empty)))+              , testCase "Configured Bad Closure"+                    (configuredTemporaryChildExitsWithIgnore+                     (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor)+              , testCase "Started Non-Temporary Child Exits With Ignore"+                    (withSupervisor restartOne [] $+                     (withClosure startNonTemporaryChildExitsWithIgnore+                      $(mkStaticClosure 'exitIgnore)))+              , testCase "Configured Non-Temporary Child Exits With Ignore"+                    (configuredNonTemporaryChildExitsWithIgnore+                     (RunClosure $(mkStaticClosure 'exitIgnore)) withSupervisor)+              ]+            , testGroup "Specified By Delegate/Restarter"+              [+                testCase "Add Child Without Starting (Chan)"+                  (withSupervisor restartOne []+                   (withChan addChildWithoutRestart blockIndefinitely))+              , testCase "Start Previously Added Child"+                  (withSupervisor restartOne []+                   (withChan addChildThenStart blockIndefinitely))+              , testCase "Start Unknown Child"+                  (withSupervisor restartOne []+                   (withChan startUnknownChild blockIndefinitely))+              , testCase "Add Duplicate Child (Chan)"+                  (withSupervisor restartOne []+                   (withChan addDuplicateChild blockIndefinitely))+              , testCase "Start Duplicate Child (Chan)"+                  (withSupervisor restartOne []+                   (withChan startDuplicateChild blockIndefinitely))+              , testCase "Started Temporary Child Exits With Ignore (Chan)"+                  (withSupervisor restartOne []+                   (withChan startTemporaryChildExitsWithIgnore exitIgnore))+              , testCase "Started Non-Temporary Child Exits With Ignore (Chan)"+                  (withSupervisor restartOne [] $+                   (withChan startNonTemporaryChildExitsWithIgnore exitIgnore))+              ]+          ]+        , testGroup "Stopping And Deleting Children"+          [+            testCase "Delete Existing Child Fails"+                (withSupervisor restartOne []+                    (withClosure deleteExistingChild+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "Delete Stopped Temporary Child (Doesn't Exist)"+                (withSupervisor restartOne []+                    (withClosure deleteStoppedTempChild+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "Delete Stopped Child Succeeds"+                (withSupervisor restartOne []+                    (withClosure deleteStoppedChild+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "Restart Minus Dropped (Temp) Child"+                (withSupervisor restartAll []+                    (withClosure restartWithoutTempChildren+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "Sequential Shutdown Ordering"+             (delayedAssertion+              "expected the shutdown order to hold"+              localNode (Just ()) sequentialShutdown)+          ]+        , testGroup "Stopping and Restarting Children"+          [+            testCase "Permanent Children Always Restart (Closure)"+                (withSupervisor restartOne []+                    (withClosure permanentChildrenAlwaysRestart+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "Permanent Children Always Restart (Chan)"+                (withSupervisor restartOne []+                    (withChan permanentChildrenAlwaysRestart blockIndefinitely))+          , testCase "Temporary Children Never Restart (Closure)"+                (withSupervisor restartOne []+                    (withClosure temporaryChildrenNeverRestart+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "Temporary Children Never Restart (Chan)"+                (withSupervisor restartOne []+                    (withChan temporaryChildrenNeverRestart blockIndefinitely))+          , testCase "Transient Children Do Not Restart When Exiting Normally (Closure)"+                (withSupervisor restartOne []+                    (withClosure transientChildrenNormalExit+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "Transient Children Do Not Restart When Exiting Normally (Chan)"+                (withSupervisor restartOne []+                    (withChan transientChildrenNormalExit blockIndefinitely))+          , testCase "Transient Children Do Restart When Exiting Abnormally (Closure)"+                (withSupervisor restartOne []+                    (withClosure transientChildrenAbnormalExit+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "Transient Children Do Restart When Exiting Abnormally (Chan)"+                (withSupervisor restartOne []+                    (withChan transientChildrenAbnormalExit blockIndefinitely))+          , testCase "ExitShutdown Is Considered Normal (Closure)"+                (withSupervisor restartOne []+                    (withClosure transientChildrenExitShutdown+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "ExitShutdown Is Considered Normal (Chan)"+                (withSupervisor restartOne []+                    (withChan transientChildrenExitShutdown blockIndefinitely))+          , testCase "Intrinsic Children Do Restart When Exiting Abnormally (Closure)"+                (withSupervisor restartOne []+                    (withClosure intrinsicChildrenAbnormalExit+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "Intrinsic Children Do Restart When Exiting Abnormally (Chan)"+                (withSupervisor restartOne []+                    (withChan intrinsicChildrenAbnormalExit blockIndefinitely))+          , testCase (concat [ "Intrinsic Children Cause Supervisor Exits "+                             , "When Exiting Normally (Closure)"])+                (withSupervisor restartOne []+                    (withClosure intrinsicChildrenNormalExit+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase (concat [ "Intrinsic Children Cause Supervisor Exits "+                             , "When Exiting Normally (Chan)"])+                (withSupervisor restartOne []+                    (withChan intrinsicChildrenNormalExit blockIndefinitely))+          , testCase "Explicit Restart Of Running Child Fails (Closure)"+                (withSupervisor restartOne []+                    (withClosure explicitRestartRunningChild+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "Explicit Restart Of Running Child Fails (Chan)"+                (withSupervisor restartOne []+                    (withChan explicitRestartRunningChild blockIndefinitely))+          , testCase "Explicit Restart Of Unknown Child Fails"+                (withSupervisor restartOne [] explicitRestartUnknownChild)+          , testCase "Explicit Restart Whilst Child Restarting Fails (Closure)"+                (withSupervisor+                 (RestartOne (limit (maxRestarts 500000000) (milliSeconds 1))) []+                 (withClosure explicitRestartRestartingChild $(mkStaticClosure 'noOp)))+          , testCase "Explicit Restart Whilst Child Restarting Fails (Chan)"+                (withSupervisor+                 (RestartOne (limit (maxRestarts 500000000) (milliSeconds 1))) []+                 (withChan explicitRestartRestartingChild noOp))+          , testCase "Explicit Restart Stopped Child (Closure)"+                (withSupervisor restartOne []+                    (withClosure explicitRestartStoppedChild+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "Explicit Restart Stopped Child (Chan)"+                (withSupervisor restartOne []+                    (withChan explicitRestartStoppedChild blockIndefinitely))+          , testCase "Immediate Child Termination (Brutal Kill) (Closure)"+                (withSupervisor restartOne []+                    (withClosure terminateChildImmediately+                                 $(mkStaticClosure 'blockIndefinitely)))+          , testCase "Immediate Child Termination (Brutal Kill) (Chan)"+                (withSupervisor restartOne []+                    (withChan terminateChildImmediately blockIndefinitely))+          -- TODO: Chan tests+          , testCase "Child Termination Exceeds Timeout/Delay (Becomes Brutal Kill)"+                (withSupervisor restartOne [] terminatingChildExceedsDelay)+          , testCase "Child Termination Within Timeout/Delay"+                (withSupervisor restartOne [] terminatingChildObeysDelay)+          ]+          -- TODO: test for init failures (expecting $ ChildInitFailed r)+        , testGroup "Branch Restarts"+          [+            testGroup "Restart All"+            [+              testCase "Terminate Child Ignores Siblings"+                  (terminateChildIgnoresSiblings+                   (RunClosure $(mkStaticClosure 'blockIndefinitely))+                   withSupervisor)+            , testCase "Restart All, Left To Right (Sequential) Restarts"+                  (restartAllWithLeftToRightSeqRestarts+                   (RunClosure $(mkStaticClosure 'blockIndefinitely))+                   withSupervisor)+            , testCase "Restart All, Right To Left (Sequential) Restarts"+                  (withSupervisor+                   (RestartAll defaultLimits (RestartEach RightToLeft)) []+                    restartAllWithRightToLeftSeqRestarts)+            , testCase "Restart All, Left To Right Stop, Left To Right Start"+                  (withSupervisor+                   (RestartAll defaultLimits (RestartInOrder LeftToRight)) []+                    restartAllWithLeftToRightRestarts)+            , testCase "Restart All, Right To Left Stop, Right To Left Start"+                  (withSupervisor+                   (RestartAll defaultLimits (RestartInOrder RightToLeft)) []+                    expectRightToLeftRestarts)+            , testCase "Restart All, Left To Right Stop, Reverse Start"+                  (withSupervisor+                   (RestartAll defaultLimits (RestartRevOrder LeftToRight)) []+                    expectRightToLeftRestarts)+            , testCase "Restart All, Right To Left Stop, Reverse Start"+                  (withSupervisor+                   (RestartAll defaultLimits (RestartRevOrder RightToLeft)) []+                    expectLeftToRightRestarts)+            ],+            testGroup "Restart Left"+            [+              testCase "Restart Left, Left To Right (Sequential) Restarts"+                  (restartLeftWithLeftToRightSeqRestarts+                   (RunClosure $(mkStaticClosure 'blockIndefinitely))+                   withSupervisor)+            , testCase "Restart Left, Leftmost Child Dies"+                  (withSupervisor restartLeft [] $+                    restartLeftWhenLeftmostChildDies+                    (RunClosure $(mkStaticClosure 'blockIndefinitely)))+            , testCase "Restart Left, Left To Right Stop, Left To Right Start"+                  (withSupervisor+                   (RestartLeft defaultLimits (RestartInOrder LeftToRight)) []+                    restartLeftWithLeftToRightRestarts)+            , testCase "Restart Left, Right To Left Stop, Right To Left Start"+                  (withSupervisor+                   (RestartLeft defaultLimits (RestartInOrder RightToLeft)) []+                    restartLeftWithRightToLeftRestarts)+            , testCase "Restart Left, Left To Right Stop, Reverse Start"+                  (withSupervisor+                   (RestartLeft defaultLimits (RestartRevOrder LeftToRight)) []+                    restartLeftWithRightToLeftRestarts)+            , testCase "Restart Left, Right To Left Stop, Reverse Start"+                  (withSupervisor+                   (RestartLeft defaultLimits (RestartRevOrder RightToLeft)) []+                    restartLeftWithLeftToRightRestarts)+            ],+            testGroup "Restart Right"+            [+              testCase "Restart Right, Left To Right (Sequential) Restarts"+                  (restartRightWithLeftToRightSeqRestarts+                   (RunClosure $(mkStaticClosure 'blockIndefinitely))+                   withSupervisor)+            , testCase "Restart Right, Rightmost Child Dies"+                  (withSupervisor restartRight [] $+                    restartRightWhenRightmostChildDies+                    (RunClosure $(mkStaticClosure 'blockIndefinitely)))+            , testCase "Restart Right, Left To Right Stop, Left To Right Start"+                  (withSupervisor+                   (RestartRight defaultLimits (RestartInOrder LeftToRight)) []+                    restartRightWithLeftToRightRestarts)+            , testCase "Restart Right, Right To Left Stop, Right To Left Start"+                  (withSupervisor+                   (RestartRight defaultLimits (RestartInOrder RightToLeft)) []+                    restartRightWithRightToLeftRestarts)+            , testCase "Restart Right, Left To Right Stop, Reverse Start"+                  (withSupervisor+                   (RestartRight defaultLimits (RestartRevOrder LeftToRight)) []+                    restartRightWithRightToLeftRestarts)+            , testCase "Restart Right, Right To Left Stop, Reverse Start"+                  (withSupervisor+                   (RestartRight defaultLimits (RestartRevOrder RightToLeft)) []+                    restartRightWithLeftToRightRestarts)+            ]+            ]+        , testGroup "Restart Intensity"+          [+            testCase "Three Attempts Before Successful Restart"+                (restartAfterThreeAttempts+                 (RunClosure $(mkStaticClosure 'blockIndefinitely)) withSupervisor)+          , testCase "Permanent Child Exceeds Restart Limits"+                (permanentChildExceedsRestartsIntensity+                 (RunClosure $(mkStaticClosure 'noOp)) withSupervisor)+--          , testCase "Permanent Child Delayed Restart"+--                (delayedRestartAfterThreeAttempts withSupervisor)+          ]+        , testGroup "ToChildStart Link Setup"+          [+            testCase "Both Local Process Instances Link Appropriately"+             (delayedAssertion+              "expected the server to return the task outcome"+              localNode True localChildStartLinking)+          ]+      ]+    ]++main :: IO ()+main = testMain $ tests+
+ tests/TestTaskQueues.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE TemplateHaskell     #-}++module Main where++import Control.Distributed.Process hiding (call)+import Control.Distributed.Process.Closure+import Control.Distributed.Process.Node+import Control.Distributed.Process.Platform hiding (__remoteTable, monitor,+                                                    send, nsend, sendChan)+import Control.Distributed.Process.Platform.Async+import Control.Distributed.Process.Platform.ManagedProcess+import Control.Distributed.Process.Platform.Test+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process.Platform.Timer+import Control.Distributed.Process.Serializable()++import Control.Distributed.Process.Platform.Task.Queue.BlockingQueue hiding (start)+import qualified Control.Distributed.Process.Platform.Task.Queue.BlockingQueue as Pool (start)++#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import TestUtils++import qualified Network.Transport as NT++-- utilities++sampleTask :: (TimeInterval, String) -> Process String+sampleTask (t, s) = sleep t >> return s++namedTask :: (String, String) -> Process String+namedTask (name, result) = do+  self <- getSelfPid+  register name self+  () <- expect+  return result++crashingTask :: SendPort ProcessId -> Process String+crashingTask sp = getSelfPid >>= sendChan sp >> die "Boom"++$(remotable ['sampleTask, 'namedTask, 'crashingTask])++-- SimplePool tests++startPool :: SizeLimit -> Process ProcessId+startPool sz = spawnLocal $ do+  Pool.start (pool sz :: Process (InitResult (BlockingQueue String)))++testSimplePoolJobBlocksCaller :: TestResult (AsyncResult (Either ExitReason String))+                              -> Process ()+testSimplePoolJobBlocksCaller result = do+  pid <- startPool 1+  -- we do a non-blocking test first+  job <- return $ ($(mkClosure 'sampleTask) (seconds 2, "foobar"))+  callAsync pid job >>= wait >>= stash result++testJobQueueSizeLimiting ::+    TestResult (Maybe (AsyncResult (Either ExitReason String)),+                Maybe (AsyncResult (Either ExitReason String)))+                         -> Process ()+testJobQueueSizeLimiting result = do+  pid <- startPool 1+  job1 <- return $ ($(mkClosure 'namedTask) ("job1", "foo"))+  job2 <- return $ ($(mkClosure 'namedTask) ("job2", "bar"))+  h1 <- callAsync pid job1 :: Process (Async (Either ExitReason String))+  h2 <- callAsync pid job2 :: Process (Async (Either ExitReason String))++  -- despite the fact that we tell job2 to proceed first,+  -- the size limit (of 1) will ensure that only job1 can+  -- proceed successfully!+  nsend "job2" ()+  AsyncPending <- poll h2+  Nothing <- whereis "job2"++  -- we can get here *very* fast, so give the registration time to kick in+  sleep $ milliSeconds 250+  j1p <- whereis "job1"+  case j1p of+    Nothing -> die $ "timing is out - job1 isn't registered yet"+    Just p  -> send p ()++  -- once job1 completes, we *should* be able to proceed with job2+  -- but we allow a little time for things to catch up+  sleep $ milliSeconds 250+  nsend "job2" ()++  r2 <- waitTimeout (within 2 Seconds) h2+  r1 <- waitTimeout (within 2 Seconds) h1+  stash result (r1, r2)++testExecutionErrors :: TestResult Bool -> Process ()+testExecutionErrors result = do+    pid <- startPool 1+    (sp, rp) <- newChan :: Process (SendPort ProcessId,+                                    ReceivePort ProcessId)+    job <- return $ ($(mkClosure 'crashingTask) sp)+    res <- executeTask pid job+    rpid <- receiveChan rp+--  liftIO $ putStrLn (show res)+    stash result (expectedErrorMessage rpid == res)+  where+    expectedErrorMessage p =+      Left $ ExitOther $ "DiedException \"exit-from=" ++ (show p) ++ ",reason=Boom\""++myRemoteTable :: RemoteTable+myRemoteTable = Main.__remoteTable initRemoteTable++tests :: NT.Transport  -> IO [Test]+tests transport = do+  localNode <- newLocalNode transport myRemoteTable+  return [+    testGroup "Task Execution And Prioritisation" [+         testCase "Each execution blocks the submitter"+         (delayedAssertion+          "expected the server to return the task outcome"+          localNode (AsyncDone (Right "foobar")) testSimplePoolJobBlocksCaller)+       , testCase "Only 'max' tasks can proceed at any time"+         (delayedAssertion+          "expected the server to block the second job until the first was released"+          localNode+          (Just (AsyncDone (Right "foo")),+           Just (AsyncDone (Right "bar"))) testJobQueueSizeLimiting)+       , testCase "Crashing Tasks are Reported Properly"+         (delayedAssertion+          "expected the server to report an error"+          localNode True testExecutionErrors)+       ]+    ]++main :: IO ()+main = testMain $ tests+
+ tests/TestTimer.hs view
@@ -0,0 +1,182 @@+module Main where++#if ! MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif+import Control.Monad (forever)+import Control.Concurrent.MVar+  ( newEmptyMVar+  , putMVar+  , takeMVar+  , withMVar+  )+import qualified Network.Transport as NT (Transport)+import Network.Transport.TCP()+import Control.Distributed.Process.Platform.Time+import Control.Distributed.Process+import Control.Distributed.Process.Node+import Control.Distributed.Process.Serializable()+import Control.Distributed.Process.Platform.Timer++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)++import Control.Distributed.Process.Platform.Test+import TestUtils++testSendAfter :: TestResult Bool -> Process ()+testSendAfter result =+  let delay = seconds 1 in do+  sleep $ seconds 10+  pid <- getSelfPid+  _ <- sendAfter delay pid Ping+  hdInbox <- receiveTimeout (asTimeout (seconds 2)) [+                      match (\m@(Ping) -> return m)+                    ]+  case hdInbox of+      Just Ping -> stash result True+      Nothing   -> stash result False++testRunAfter :: TestResult Bool -> Process ()+testRunAfter result =+  let delay = seconds 2 in do++  parentPid <- getSelfPid+  _ <- spawnLocal $ do+    _ <- runAfter delay $ send parentPid Ping+    return ()++  msg <- expectTimeout ((asTimeout delay) * 4)+  case msg of+      Just Ping -> stash result True+      Nothing   -> stash result False+  return ()++testCancelTimer :: TestResult Bool -> Process ()+testCancelTimer result = do+  let delay = milliSeconds 50+  pid <- periodically delay noop+  ref <- monitor pid++  sleep $ seconds 1+  cancelTimer pid++  _ <- receiveWait [+          match (\(ProcessMonitorNotification ref' pid' _) ->+                  stash result $ ref == ref' && pid == pid')+        ]++  return ()++testPeriodicSend :: TestResult Bool -> Process ()+testPeriodicSend result = do+  let delay = milliSeconds 100+  self <- getSelfPid+  ref <- ticker delay self+  listener 0 ref+  liftIO $ putMVar result True+  where listener :: Int -> TimerRef -> Process ()+        listener n tRef | n > 10    = cancelTimer tRef+                        | otherwise = waitOne >> listener (n + 1) tRef+        -- get a single tick, blocking indefinitely+        waitOne :: Process ()+        waitOne = do+            Tick <- expect+            return ()++testTimerReset :: TestResult Int -> Process ()+testTimerReset result = do+  let delay = seconds 10+  counter <- liftIO $ newEmptyMVar++  listenerPid <- spawnLocal $ do+      stash counter 0+      -- we continually listen for 'ticks' and increment counter for each+      forever $ do+        Tick <- expect+        liftIO $ withMVar counter (\n -> (return (n + 1)))++  -- this ticker will 'fire' every 10 seconds+  ref <- ticker delay listenerPid++  sleep $ seconds 2+  resetTimer ref++  -- at this point, the timer should be back to roughly a 5 second count down+  -- so our few remaining cycles no ticks ought to make it to the listener+  -- therefore we kill off the timer and the listener now and take the count+  cancelTimer ref+  kill listenerPid "stop!"++  -- how many 'ticks' did the listener observer? (hopefully none!)+  count <- liftIO $ takeMVar counter+  liftIO $ putMVar result count++testTimerFlush :: TestResult Bool -> Process ()+testTimerFlush result = do+  let delay = seconds 1+  self <- getSelfPid+  ref  <- ticker delay self++  -- sleep so we *should* have a message in our 'mailbox'+  sleep $ milliSeconds 2++  -- flush it out if it's there+  flushTimer ref Tick (Delay $ seconds 3)++  m <- expectTimeout 10+  case m of+      Nothing   -> stash result True+      Just Tick -> stash result False++testSleep :: TestResult Bool -> Process ()+testSleep r = do+  sleep $ seconds 20+  stash r True++--------------------------------------------------------------------------------+-- Utilities and Plumbing                                                     --+--------------------------------------------------------------------------------++tests :: LocalNode  -> [Test]+tests localNode = [+    testGroup "Timer Tests" [+        testCase "testSendAfter"+                 (delayedAssertion+                  "expected Ping within 1 second"+                  localNode True testSendAfter)+      , testCase "testRunAfter"+                 (delayedAssertion+                  "expecting run (which pings parent) within 2 seconds"+                  localNode True testRunAfter)+      , testCase "testCancelTimer"+                 (delayedAssertion+                  "expected cancelTimer to exit the timer process normally"+                  localNode True testCancelTimer)+      , testCase "testPeriodicSend"+                 (delayedAssertion+                  "expected ten Ticks to have been sent before exiting"+                  localNode True testPeriodicSend)+      , testCase "testTimerReset"+                 (delayedAssertion+                  "expected no Ticks to have been sent before resetting"+                  localNode 0 testTimerReset)+      , testCase "testTimerFlush"+                 (delayedAssertion+                  "expected all Ticks to have been flushed"+                  localNode True testTimerFlush)+      , testCase "testSleep"+                 (delayedAssertion+                  "why am I not seeing a delay!?"+                  localNode True testTimerFlush)+      ]+  ]++timerTests :: NT.Transport -> IO [Test]+timerTests transport = do+  localNode <- newLocalNode transport initRemoteTable+  let testData = tests localNode+  return testData++main :: IO ()+main = testMain $ timerTests