diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/distributed-process-platform.cabal b/distributed-process-platform.cabal new file mode 100644 --- /dev/null +++ b/distributed-process-platform.cabal @@ -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 + diff --git a/regressions/LeakByteStrings.hs b/regressions/LeakByteStrings.hs new file mode 100644 --- /dev/null +++ b/regressions/LeakByteStrings.hs @@ -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) + ] + } + diff --git a/src/Control/Concurrent/Utils.hs b/src/Control/Concurrent/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Utils.hs @@ -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) diff --git a/src/Control/Distributed/Process/Platform.hs b/src/Control/Distributed/Process/Platform.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform.hs @@ -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 + diff --git a/src/Control/Distributed/Process/Platform/Async.hs b/src/Control/Distributed/Process/Platform/Async.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Async.hs @@ -0,0 +1,256 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Platform.Async +-- Copyright : (c) Tim Watson 2012 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- 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 + diff --git a/src/Control/Distributed/Process/Platform/Async/AsyncChan.hs b/src/Control/Distributed/Process/Platform/Async/AsyncChan.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Async/AsyncChan.hs @@ -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 +-- 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 diff --git a/src/Control/Distributed/Process/Platform/Async/AsyncSTM.hs b/src/Control/Distributed/Process/Platform/Async/AsyncSTM.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Async/AsyncSTM.hs @@ -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 +-- 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 + diff --git a/src/Control/Distributed/Process/Platform/Async/Types.hs b/src/Control/Distributed/Process/Platform/Async/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Async/Types.hs @@ -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) + diff --git a/src/Control/Distributed/Process/Platform/Call.hs b/src/Control/Distributed/Process/Platform/Call.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Call.hs @@ -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 () diff --git a/src/Control/Distributed/Process/Platform/Execution.hs b/src/Control/Distributed/Process/Platform/Execution.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Execution.hs @@ -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 +-- 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 + +-} + + diff --git a/src/Control/Distributed/Process/Platform/Execution/EventManager.hs b/src/Control/Distributed/Process/Platform/Execution/EventManager.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Execution/EventManager.hs @@ -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 +-- 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 + diff --git a/src/Control/Distributed/Process/Platform/Execution/Exchange.hs b/src/Control/Distributed/Process/Platform/Execution/Exchange.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Execution/Exchange.hs @@ -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 +-- 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 + ) + diff --git a/src/Control/Distributed/Process/Platform/Execution/Exchange/Broadcast.hs b/src/Control/Distributed/Process/Platform/Execution/Exchange/Broadcast.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Execution/Exchange/Broadcast.hs @@ -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 }) + diff --git a/src/Control/Distributed/Process/Platform/Execution/Exchange/Internal.hs b/src/Control/Distributed/Process/Platform/Execution/Exchange/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Execution/Exchange/Internal.hs @@ -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 } + diff --git a/src/Control/Distributed/Process/Platform/Execution/Exchange/Router.hs b/src/Control/Distributed/Process/Platform/Execution/Exchange/Router.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Execution/Exchange/Router.hs @@ -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' } + diff --git a/src/Control/Distributed/Process/Platform/Execution/Mailbox.hs b/src/Control/Distributed/Process/Platform/Execution/Mailbox.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Execution/Mailbox.hs @@ -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 +-- 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 + diff --git a/src/Control/Distributed/Process/Platform/Internal/Containers/MultiMap.hs b/src/Control/Distributed/Process/Platform/Internal/Containers/MultiMap.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Internal/Containers/MultiMap.hs @@ -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 #-} + diff --git a/src/Control/Distributed/Process/Platform/Internal/Primitives.hs b/src/Control/Distributed/Process/Platform/Internal/Primitives.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Internal/Primitives.hs @@ -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)))) + diff --git a/src/Control/Distributed/Process/Platform/Internal/Queue/PriorityQ.hs b/src/Control/Distributed/Process/Platform/Internal/Queue/PriorityQ.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Internal/Queue/PriorityQ.hs @@ -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 + diff --git a/src/Control/Distributed/Process/Platform/Internal/Queue/SeqQ.hs b/src/Control/Distributed/Process/Platform/Internal/Queue/SeqQ.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Internal/Queue/SeqQ.hs @@ -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 +-- 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 + diff --git a/src/Control/Distributed/Process/Platform/Internal/Types.hs b/src/Control/Distributed/Process/Platform/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Internal/Types.hs @@ -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 diff --git a/src/Control/Distributed/Process/Platform/Internal/Unsafe.hs b/src/Control/Distributed/Process/Platform/Internal/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Internal/Unsafe.hs @@ -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") + diff --git a/src/Control/Distributed/Process/Platform/ManagedProcess.hs b/src/Control/Distributed/Process/Platform/ManagedProcess.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/ManagedProcess.hs @@ -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 +-- 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 - . +-- +-- 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 + diff --git a/src/Control/Distributed/Process/Platform/ManagedProcess/Client.hs b/src/Control/Distributed/Process/Platform/ManagedProcess/Client.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/ManagedProcess/Client.hs @@ -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 +-- 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) ] + diff --git a/src/Control/Distributed/Process/Platform/ManagedProcess/Internal/GenProcess.hs b/src/Control/Distributed/Process/Platform/ManagedProcess/Internal/GenProcess.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/ManagedProcess/Internal/GenProcess.hs @@ -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) + diff --git a/src/Control/Distributed/Process/Platform/ManagedProcess/Internal/Types.hs b/src/Control/Distributed/Process/Platform/ManagedProcess/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/ManagedProcess/Internal/Types.hs @@ -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) + diff --git a/src/Control/Distributed/Process/Platform/ManagedProcess/Server.hs b/src/Control/Distributed/Process/Platform/ManagedProcess/Server.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/ManagedProcess/Server.hs @@ -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 +-- 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 + diff --git a/src/Control/Distributed/Process/Platform/ManagedProcess/Server/Priority.hs b/src/Control/Distributed/Process/Platform/ManagedProcess/Server/Priority.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/ManagedProcess/Server/Priority.hs @@ -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 + diff --git a/src/Control/Distributed/Process/Platform/ManagedProcess/Server/Restricted.hs b/src/Control/Distributed/Process/Platform/ManagedProcess/Server/Restricted.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/ManagedProcess/Server/Restricted.hs @@ -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 +-- 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 + diff --git a/src/Control/Distributed/Process/Platform/ManagedProcess/UnsafeClient.hs b/src/Control/Distributed/Process/Platform/ManagedProcess/UnsafeClient.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/ManagedProcess/UnsafeClient.hs @@ -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 +-- 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) ] + diff --git a/src/Control/Distributed/Process/Platform/Service.hs b/src/Control/Distributed/Process/Platform/Service.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Service.hs @@ -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 +-- 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 diff --git a/src/Control/Distributed/Process/Platform/Service/Monitoring.hs b/src/Control/Distributed/Process/Platform/Service/Monitoring.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Service/Monitoring.hs @@ -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 +-- 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 + diff --git a/src/Control/Distributed/Process/Platform/Service/Registry.hs b/src/Control/Distributed/Process/Platform/Service/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Service/Registry.hs @@ -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 +-- 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 }) + diff --git a/src/Control/Distributed/Process/Platform/Service/SystemLog.hs b/src/Control/Distributed/Process/Platform/Service/SystemLog.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Service/SystemLog.hs @@ -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 +-- 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' }) + diff --git a/src/Control/Distributed/Process/Platform/Supervisor.hs b/src/Control/Distributed/Process/Platform/Supervisor.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Supervisor.hs @@ -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 +-- 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 }) diff --git a/src/Control/Distributed/Process/Platform/Supervisor/Types.hs b/src/Control/Distributed/Process/Platform/Supervisor/Types.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Supervisor/Types.hs @@ -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 +-- 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 diff --git a/src/Control/Distributed/Process/Platform/Task.hs b/src/Control/Distributed/Process/Platform/Task.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Task.hs @@ -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 +-- 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 diff --git a/src/Control/Distributed/Process/Platform/Task/Queue/BlockingQueue.hs b/src/Control/Distributed/Process/Platform/Task/Queue/BlockingQueue.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Task/Queue/BlockingQueue.hs @@ -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 +-- 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 + diff --git a/src/Control/Distributed/Process/Platform/Test.hs b/src/Control/Distributed/Process/Platform/Test.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Test.hs @@ -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)) diff --git a/src/Control/Distributed/Process/Platform/Time.hs b/src/Control/Distributed/Process/Platform/Time.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Time.hs @@ -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" + diff --git a/src/Control/Distributed/Process/Platform/Timer.hs b/src/Control/Distributed/Process/Platform/Timer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/Timer.hs @@ -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 +-- 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 diff --git a/src/Control/Distributed/Process/Platform/UnsafePrimitives.hs b/src/Control/Distributed/Process/Platform/UnsafePrimitives.hs new file mode 100644 --- /dev/null +++ b/src/Control/Distributed/Process/Platform/UnsafePrimitives.hs @@ -0,0 +1,63 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Distributed.Process.Platform.UnsafePrimitives +-- Copyright : (c) Tim Watson 2013 +-- License : BSD3 (see the file LICENSE) +-- +-- Maintainer : Tim Watson +-- 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 + diff --git a/tests/TestAsync.hs b/tests/TestAsync.hs new file mode 100644 --- /dev/null +++ b/tests/TestAsync.hs @@ -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 diff --git a/tests/TestExchange.hs b/tests/TestExchange.hs new file mode 100644 --- /dev/null +++ b/tests/TestExchange.hs @@ -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 + diff --git a/tests/TestLog.hs b/tests/TestLog.hs new file mode 100644 --- /dev/null +++ b/tests/TestLog.hs @@ -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 + diff --git a/tests/TestMailbox.hs b/tests/TestMailbox.hs new file mode 100644 --- /dev/null +++ b/tests/TestMailbox.hs @@ -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 + diff --git a/tests/TestManagedProcess.hs b/tests/TestManagedProcess.hs new file mode 100644 --- /dev/null +++ b/tests/TestManagedProcess.hs @@ -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 + diff --git a/tests/TestPrimitives.hs b/tests/TestPrimitives.hs new file mode 100644 --- /dev/null +++ b/tests/TestPrimitives.hs @@ -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 diff --git a/tests/TestPrioritisedProcess.hs b/tests/TestPrioritisedProcess.hs new file mode 100644 --- /dev/null +++ b/tests/TestPrioritisedProcess.hs @@ -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 + + diff --git a/tests/TestQueues.hs b/tests/TestQueues.hs new file mode 100644 --- /dev/null +++ b/tests/TestQueues.hs @@ -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 + diff --git a/tests/TestRegistry.hs b/tests/TestRegistry.hs new file mode 100644 --- /dev/null +++ b/tests/TestRegistry.hs @@ -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 + diff --git a/tests/TestSupervisor.hs b/tests/TestSupervisor.hs new file mode 100644 --- /dev/null +++ b/tests/TestSupervisor.hs @@ -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 + diff --git a/tests/TestTaskQueues.hs b/tests/TestTaskQueues.hs new file mode 100644 --- /dev/null +++ b/tests/TestTaskQueues.hs @@ -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 + diff --git a/tests/TestTimer.hs b/tests/TestTimer.hs new file mode 100644 --- /dev/null +++ b/tests/TestTimer.hs @@ -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