├── .ghci ├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── CONTRIBUTING.md ├── LICENCE ├── NOTES ├── README.md ├── Setup.lhs ├── benchmarks ├── dtp-benchmarks.cabal └── src │ └── CounterServer.hs ├── distributed-process-client-server.cabal ├── src └── Control │ └── Distributed │ └── Process │ ├── ManagedProcess.hs │ └── ManagedProcess │ ├── Client.hs │ ├── Internal │ ├── GenProcess.hs │ ├── PriorityQueue.hs │ └── Types.hs │ ├── Server.hs │ ├── Server │ ├── Gen.hs │ ├── Priority.hs │ └── Restricted.hs │ ├── Timer.hs │ └── UnsafeClient.hs ├── stack.yaml └── tests ├── Counter.hs ├── ManagedProcessCommon.hs ├── MathsDemo.hs ├── SafeCounter.hs ├── TestManagedProcess.hs ├── TestPrioritisedProcess.hs └── TestUtils.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc -itests 2 | 3 | :def hoogle \x -> return $ ":!hoogle " ++ x 4 | 5 | :def doc \x -> return $ ":!hoogle --info \"" ++ x ++ "\"" 6 | 7 | :set -w -fwarn-unused-binds -fwarn-unused-imports 8 | 9 | :load tests/Main.hs -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | .stack* 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | sudo: false 4 | 5 | matrix: 6 | include: 7 | - env: ARGS="--resolver nightly" COVER="" GHCVER=latest 8 | addons: {apt: {packages: [libgmp-dev]}} 9 | 10 | cache: 11 | directories: 12 | - $HOME/.stack 13 | - $HOME/.local 14 | 15 | before_install: 16 | - export PATH=$HOME/.local/bin:$HOME/.cabal/bin:$PATH 17 | - mkdir -p ~/.local/bin 18 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 19 | - stack --version 20 | 21 | install: 22 | - stack ${ARGS} setup --no-terminal 23 | 24 | script: 25 | - case "$COVER" in 26 | true) 27 | stack ${ARGS} test --coverage --no-terminal; 28 | ./coverage.sh; 29 | ;; 30 | *) 31 | stack ${ARGS} test --test-arguments='--plain' 32 | ;; 33 | esac 34 | 35 | notifications: 36 | slack: 37 | secure: g0NP1tkOe3+kI6O0Q1mgT/jPaLjxQ31J26MWouicu2F1Y3p73qTvv/QsOkafRMZDn07HlzgviCP25r7Ytg32pUAFvOh4U4MT2MpO0jUVVGPi4ZiwB+W5AH+HlDtJSickeSZ0AjXZSaGv8nQNegWkeaLQgLBIzrTHU8s0Y9K+whQ= 38 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change Log 2 | 3 | ## [v0.2.5.1](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.2.5.1) (2018-06-14) 4 | [Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.2.3...v0.2.5.1) 5 | 6 | * Update version bounds. 7 | * Support exceptions-0.10. 8 | 9 | 10 | ## [v0.2.3](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.2.3) (2017-03-28) 11 | [Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.2.2...v0.2.3) 12 | 13 | ## [v0.2.2](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.2.2) (2017-03-27) 14 | [Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.2.1...v0.2.2) 15 | 16 | ## [v0.2.1](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.2.1) (2017-03-22) 17 | [Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.2.0...v0.2.1) 18 | 19 | **Merged pull requests:** 20 | 21 | - Implement ProcessBecome [\#18](https://github.com/haskell-distributed/distributed-process-client-server/pull/18) ([hyperthunk](https://github.com/hyperthunk)) 22 | - Safe Handler Execution [\#17](https://github.com/haskell-distributed/distributed-process-client-server/pull/17) ([hyperthunk](https://github.com/hyperthunk)) 23 | 24 | ## [v0.2.0](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.2.0) (2017-03-13) 25 | [Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.1.3.2...v0.2.0) 26 | 27 | **Closed issues:** 28 | 29 | - Read external input vectors in the prioritised mailbox drain loop [\#15](https://github.com/haskell-distributed/distributed-process-client-server/issues/15) 30 | - Compiler should enforce rules for prioritised processes [\#13](https://github.com/haskell-distributed/distributed-process-client-server/issues/13) 31 | - Prioritised process mailbox handling can block indefinitely [\#12](https://github.com/haskell-distributed/distributed-process-client-server/issues/12) 32 | - `handleExternal` support [\#9](https://github.com/haskell-distributed/distributed-process-client-server/issues/9) 33 | - `safeCall` and `tryCall` can fail if `resolve` throws [\#8](https://github.com/haskell-distributed/distributed-process-client-server/issues/8) 34 | - Someone on IRC claims we are leaking file descriptors [\#7](https://github.com/haskell-distributed/distributed-process-client-server/issues/7) 35 | - Support GHC 8 [\#5](https://github.com/haskell-distributed/distributed-process-client-server/issues/5) 36 | 37 | **Merged pull requests:** 38 | 39 | - Re-implement Prioritised Managed Processes [\#16](https://github.com/haskell-distributed/distributed-process-client-server/pull/16) ([hyperthunk](https://github.com/hyperthunk)) 40 | - Update bounds & stackify [\#11](https://github.com/haskell-distributed/distributed-process-client-server/pull/11) ([hyperthunk](https://github.com/hyperthunk)) 41 | - Handle arbitrary STM actions [\#10](https://github.com/haskell-distributed/distributed-process-client-server/pull/10) ([hyperthunk](https://github.com/hyperthunk)) 42 | - Bump upper bounds on time and binary [\#6](https://github.com/haskell-distributed/distributed-process-client-server/pull/6) ([3noch](https://github.com/3noch)) 43 | - make adjustments for GHC 8 support [\#4](https://github.com/haskell-distributed/distributed-process-client-server/pull/4) ([agentm](https://github.com/agentm)) 44 | - Stick state argument to request and unify types across the handlers. [\#3](https://github.com/haskell-distributed/distributed-process-client-server/pull/3) ([wiz](https://github.com/wiz)) 45 | 46 | ## [v0.1.3.2](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.1.3.2) (2016-02-16) 47 | [Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.1.3.1...v0.1.3.2) 48 | 49 | ## [v0.1.3.1](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.1.3.1) (2015-09-29) 50 | [Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.1.2...v0.1.3.1) 51 | 52 | **Merged pull requests:** 53 | 54 | - Add compatibility with ghc-7.10 [\#1](https://github.com/haskell-distributed/distributed-process-client-server/pull/1) ([qnikst](https://github.com/qnikst)) 55 | 56 | ## [v0.1.2](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.1.2) (2014-12-25) 57 | [Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.1.1...v0.1.2) 58 | 59 | ## [v0.1.1](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.1.1) (2014-12-17) 60 | [Full Changelog](https://github.com/haskell-distributed/distributed-process-client-server/compare/v0.1.0...v0.1.1) 61 | 62 | ## [v0.1.0](https://github.com/haskell-distributed/distributed-process-client-server/tree/v0.1.0) (2014-05-30) 63 | 64 | 65 | \* *This Change Log was automatically generated by [github_changelog_generator](https://github.com/skywinder/Github-Changelog-Generator)* 66 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md. 2 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | Copyright Tim Watson, 2012-2013. 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of the author nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /NOTES: -------------------------------------------------------------------------------- 1 | MAJOR TODOs (in no particular order) 2 | 3 | - implement Observable for Mailbox 4 | - implement PCopy / pcopy :: PCopy a -> Process () and precv :: Process (Maybe (PCopy a)) 5 | - provide InputChannel for PCopy data, i.e.: 6 | 7 | data InputChannel a = ReadChan (ReceivePort a) | ReadSTM (STM a) 8 | 9 | read (ReadChan rp) = expectChan rp 10 | read (ReadSTM stm) = liftIO $ atomically stm 11 | 12 | offer 13 | 14 | - implement RoundRobinRouter, ContentBasedRouter 15 | - finish off ResourcePool 16 | - double check we're using NFSerializable where possible/necessary 17 | 18 | - implement LocalRegistry (?) 19 | - possibly rationalise Registry with LocalRegistry (?) 20 | - Health checks for services 21 | - Service Monitoring 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # distributed-process-client-server (archive) 2 | 3 | ## :warning: This package is now developed here: https://github.com/haskell-distributed/distributed-process :warning: 4 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /benchmarks/dtp-benchmarks.cabal: -------------------------------------------------------------------------------- 1 | name: dtp-benchmarks 2 | version: 0 3 | build-type: Simple 4 | 5 | cabal-version: >=1.8 6 | 7 | executable dtp-benchmark 8 | main-is: CallServer.hs 9 | ghc-options: -Wall -O2 10 | build-depends: 11 | base, 12 | bytestring, 13 | criterion, 14 | distributed-process-platform 15 | 16 | -------------------------------------------------------------------------------- /benchmarks/src/CounterServer.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | import Blaze.ByteString.Builder (toLazyByteString) 4 | import Blaze.ByteString.Builder.Char.Utf8 (fromString) 5 | import Control.DeepSeq (NFData(rnf)) 6 | import Criterion.Main 7 | import qualified Data.ByteString.Lazy as BL 8 | import qualified Data.ByteString.Lazy.Internal as BL 9 | 10 | main :: IO () 11 | main = do 12 | defaultMain [ 13 | --bgroup "call" [ 14 | -- bench "incrementCount" $ nf undefined 15 | -- bench "resetCount" $ nf undefined 16 | --] 17 | ] 18 | -------------------------------------------------------------------------------- /distributed-process-client-server.cabal: -------------------------------------------------------------------------------- 1 | name: distributed-process-client-server 2 | version: 0.2.5.1 3 | cabal-version: >=1.8 4 | build-type: Simple 5 | license: BSD3 6 | license-file: LICENCE 7 | stability: experimental 8 | Copyright: Tim Watson 2012 - 2017 9 | Author: Tim Watson 10 | Maintainer: Tim Watson 11 | Homepage: http://github.com/haskell-distributed/distributed-process-client-server 12 | Bug-Reports: http://github.com/haskell-distributed/distributed-process-client-server/issues 13 | synopsis: The Cloud Haskell Application Platform 14 | description: Modelled after Erlang OTP's gen_server, this framework provides similar 15 | facilities for Cloud Haskell, grouping essential practices for client/server 16 | development into a set of modules and standards designed to help you build 17 | concurrent, distributed applications with relative ease. 18 | category: Control 19 | Tested-With: GHC==8.2.2 20 | data-dir: "" 21 | 22 | source-repository head 23 | type: git 24 | location: https://github.com/haskell-distributed/distributed-process-client-server 25 | 26 | library 27 | build-depends: 28 | base >= 4.8.2.0 && < 5, 29 | distributed-process >= 0.6.6 && < 0.8, 30 | distributed-process-extras >= 0.3.1 && < 0.4, 31 | distributed-process-async >= 0.2.4 && < 0.3, 32 | binary >= 0.6.3.0 && < 0.9, 33 | deepseq >= 1.3.0.1 && < 1.6, 34 | mtl, 35 | containers >= 0.4 && < 0.6, 36 | hashable >= 1.2.0.5 && < 1.3, 37 | unordered-containers >= 0.2.3.0 && < 0.3, 38 | fingertree < 0.2, 39 | stm >= 2.4 && < 2.5, 40 | time > 1.4 && < 1.9.2, 41 | transformers, 42 | exceptions >= 0.5 && < 0.11 43 | if impl(ghc <= 7.5) 44 | Build-Depends: template-haskell == 2.7.0.0, 45 | derive == 2.5.5, 46 | uniplate == 1.6.12, 47 | ghc-prim 48 | extensions: CPP 49 | hs-source-dirs: src 50 | ghc-options: -Wall 51 | exposed-modules: 52 | Control.Distributed.Process.ManagedProcess, 53 | Control.Distributed.Process.ManagedProcess.Client, 54 | Control.Distributed.Process.ManagedProcess.UnsafeClient, 55 | Control.Distributed.Process.ManagedProcess.Server, 56 | Control.Distributed.Process.ManagedProcess.Server.Priority, 57 | Control.Distributed.Process.ManagedProcess.Server.Restricted, 58 | Control.Distributed.Process.ManagedProcess.Server.Gen, 59 | Control.Distributed.Process.ManagedProcess.Timer, 60 | Control.Distributed.Process.ManagedProcess.Internal.Types, 61 | Control.Distributed.Process.ManagedProcess.Internal.GenProcess 62 | other-modules: Control.Distributed.Process.ManagedProcess.Internal.PriorityQueue 63 | 64 | test-suite ManagedProcessTests 65 | type: exitcode-stdio-1.0 66 | x-uses-tf: true 67 | build-depends: 68 | base >= 4.4 && < 5, 69 | ansi-terminal >= 0.5 && < 0.9, 70 | containers, 71 | distributed-process, 72 | distributed-process-extras, 73 | distributed-process-async, 74 | distributed-process-client-server, 75 | distributed-process-systest >= 0.1.1, 76 | network-transport >= 0.4 && < 0.7, 77 | mtl, 78 | fingertree, 79 | network-transport-tcp >= 0.6 && < 0.7, 80 | binary >= 0.6.3.0 && < 0.9, 81 | deepseq, 82 | network >= 2.3 && < 2.7, 83 | HUnit >= 1.2 && < 2, 84 | stm, 85 | test-framework >= 0.6 && < 0.9, 86 | test-framework-hunit, 87 | transformers, 88 | rematch >= 0.2.0.0, 89 | ghc-prim, 90 | exceptions 91 | other-modules: Counter, 92 | ManagedProcessCommon, 93 | MathsDemo, 94 | SafeCounter, 95 | TestUtils 96 | hs-source-dirs: 97 | tests 98 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind 99 | extensions: CPP 100 | main-is: TestManagedProcess.hs 101 | 102 | test-suite PrioritisedProcessTests 103 | type: exitcode-stdio-1.0 104 | x-uses-tf: true 105 | build-depends: 106 | base >= 4.4 && < 5, 107 | ansi-terminal, 108 | containers, 109 | distributed-process, 110 | distributed-process-extras, 111 | distributed-process-async, 112 | distributed-process-client-server, 113 | distributed-process-systest >= 0.1.1, 114 | network-transport, 115 | mtl, 116 | fingertree, 117 | network-transport-tcp, 118 | binary, 119 | deepseq, 120 | network, 121 | HUnit, 122 | stm, 123 | test-framework, 124 | test-framework-hunit, 125 | transformers, 126 | rematch, 127 | ghc-prim, 128 | exceptions 129 | other-modules: ManagedProcessCommon, 130 | TestUtils 131 | hs-source-dirs: 132 | tests 133 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind 134 | extensions: CPP 135 | main-is: TestPrioritisedProcess.hs 136 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/ManagedProcess/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Control.Distributed.Process.ManagedProcess.Client 7 | -- Copyright : (c) Tim Watson 2012 - 2017 8 | -- License : BSD3 (see the file LICENSE) 9 | -- 10 | -- Maintainer : Tim Watson 11 | -- Stability : experimental 12 | -- Portability : non-portable (requires concurrency) 13 | -- 14 | -- The Client Portion of the /Managed Process/ API. 15 | ----------------------------------------------------------------------------- 16 | 17 | module Control.Distributed.Process.ManagedProcess.Client 18 | ( -- * API for client interactions with the process 19 | sendControlMessage 20 | , shutdown 21 | , call 22 | , safeCall 23 | , tryCall 24 | , callTimeout 25 | , flushPendingCalls 26 | , callAsync 27 | , cast 28 | , callChan 29 | , syncCallChan 30 | , syncSafeCallChan 31 | , callSTM 32 | ) where 33 | 34 | import Control.Concurrent.STM (atomically, STM) 35 | import Control.Distributed.Process hiding (call, finally) 36 | import Control.Distributed.Process.Serializable 37 | import Control.Distributed.Process.Async hiding (check) 38 | import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (liftIO) 39 | import qualified Control.Distributed.Process.ManagedProcess.Internal.Types as T 40 | import Control.Distributed.Process.Extras.Internal.Types (resolveOrDie) 41 | import Control.Distributed.Process.Extras hiding (monitor, sendChan) 42 | import Control.Distributed.Process.Extras.Time 43 | import Control.Monad.Catch (finally) 44 | import Data.Maybe (fromJust) 45 | 46 | import Prelude hiding (init) 47 | 48 | -- | Send a control message over a 'ControlPort'. 49 | -- 50 | sendControlMessage :: Serializable m => ControlPort m -> m -> Process () 51 | sendControlMessage cp m = sendChan (unPort cp) (CastMessage m) 52 | 53 | -- | Send a signal instructing the process to terminate. The /receive loop/ which 54 | -- manages the process mailbox will prioritise @Shutdown@ signals higher than 55 | -- any other incoming messages, but the server might be busy (i.e., still in the 56 | -- process of excuting a handler) at the time of sending however, so the caller 57 | -- should not make any assumptions about the timeliness with which the shutdown 58 | -- signal will be handled. If responsiveness is important, a better approach 59 | -- might be to send an /exit signal/ with 'Shutdown' as the reason. An exit 60 | -- signal will interrupt any operation currently underway and force the running 61 | -- process to clean up and terminate. 62 | shutdown :: ProcessId -> Process () 63 | shutdown pid = cast pid Shutdown 64 | 65 | -- | Make a synchronous call - will block until a reply is received. 66 | -- The calling process will exit with 'ExitReason' if the calls fails. 67 | -- 68 | -- __NOTE: this function does not catch exceptions!__ 69 | -- 70 | call :: forall s a b . (Addressable s, Serializable a, Serializable b) 71 | => s -> a -> Process b 72 | call sid msg = initCall sid msg >>= waitResponse Nothing >>= decodeResult 73 | where decodeResult (Just (Right r)) = return r 74 | decodeResult (Just (Left err)) = die err 75 | decodeResult Nothing {- the impossible happened -} = terminate 76 | 77 | -- | Safe version of 'call' that returns information about the error 78 | -- if the operation fails. If the calling process dies (that is, forces itself 79 | -- to exit such that an exit signal arises with @ExitOther String@) then 80 | -- evaluation will return @Left exitReason@ and the explanation will be 81 | -- stashed away as @(ExitOther String)@. 82 | -- 83 | -- __NOTE: this function does not catch exceptions!__ 84 | -- 85 | -- The /safety/ of the name, comes from carefully handling situations in which 86 | -- the server dies while we're waiting for a reply. Notably, exit signals from 87 | -- other processes, kill signals, and both synchronous and asynchronous 88 | -- exceptions can still terminate the caller abruptly. To avoid this consider 89 | -- masking or evaluating within your own exception handling code. 90 | -- 91 | safeCall :: forall s a b . (Addressable s, Serializable a, Serializable b) 92 | => s -> a -> Process (Either ExitReason b) 93 | safeCall s m = do 94 | us <- getSelfPid 95 | (fmap fromJust (initCall s m >>= waitResponse Nothing) :: Process (Either ExitReason b)) 96 | `catchesExit` [(\pid msg -> handleMessageIf msg (weFailed pid us) 97 | (return . Left))] 98 | where 99 | weFailed a b (ExitOther _) = a == b 100 | weFailed _ _ _ = False 101 | 102 | -- | Version of 'safeCall' that returns 'Nothing' if the operation fails. If 103 | -- you need information about *why* a call has failed then you should use 104 | -- 'safeCall' or combine @catchExit@ and @call@ instead. 105 | -- 106 | -- __NOTE: this function does not catch exceptions!__ 107 | -- 108 | -- In fact, this API handles fewer exceptions than it's relative, "safeCall". 109 | -- Notably, exit signals, kill signals, and both synchronous and asynchronous 110 | -- exceptions can still terminate the caller abruptly. To avoid this consider 111 | -- masking or evaluating within your own exception handling code (as mentioned 112 | -- above). 113 | -- 114 | tryCall :: forall s a b . (Addressable s, Serializable a, Serializable b) 115 | => s -> a -> Process (Maybe b) 116 | tryCall s m = initCall s m >>= waitResponse Nothing >>= decodeResult 117 | where decodeResult (Just (Right r)) = return $ Just r 118 | decodeResult _ = return Nothing 119 | 120 | -- | Make a synchronous call, but timeout and return @Nothing@ if a reply 121 | -- is not received within the specified time interval. 122 | -- 123 | -- If the result of the call is a failure (or the call was cancelled) then 124 | -- the calling process will exit, with the 'ExitReason' given as the reason. 125 | -- If the call times out however, the semantics on the server side are 126 | -- undefined, i.e., the server may or may not successfully process the 127 | -- request and may (or may not) send a response at a later time. From the 128 | -- callers perspective, this is somewhat troublesome, since the call result 129 | -- cannot be decoded directly. In this case, the "flushPendingCalls" API /may/ 130 | -- be used to attempt to receive the message later on, however this makes 131 | -- /no attempt whatsoever/ to guarantee /which/ call response will in fact 132 | -- be returned to the caller. In those semantics are unsuited to your 133 | -- application, you might choose to @exit@ or @die@ in case of a timeout, 134 | -- or alternatively, use the 'callAsync' API and associated @waitTimeout@ 135 | -- function (in the /Async API/), which takes a re-usable handle on which 136 | -- to wait (with timeouts) multiple times. 137 | -- 138 | callTimeout :: forall s a b . (Addressable s, Serializable a, Serializable b) 139 | => s -> a -> TimeInterval -> Process (Maybe b) 140 | callTimeout s m d = initCall s m >>= waitResponse (Just d) >>= decodeResult 141 | where decodeResult :: (Serializable b) 142 | => Maybe (Either ExitReason b) 143 | -> Process (Maybe b) 144 | decodeResult Nothing = return Nothing 145 | decodeResult (Just (Right result)) = return $ Just result 146 | decodeResult (Just (Left reason)) = die reason 147 | 148 | -- | Attempt to flush out any pending call responses. 149 | flushPendingCalls :: forall b . (Serializable b) 150 | => TimeInterval 151 | -> (b -> Process b) 152 | -> Process (Maybe b) 153 | flushPendingCalls d proc = 154 | receiveTimeout (asTimeout d) [ 155 | match (\(CallResponse (m :: b) _) -> proc m) 156 | ] 157 | 158 | -- | Invokes 'call' /out of band/, and returns an /async handle/. 159 | -- 160 | callAsync :: forall s a b . (Addressable s, Serializable a, Serializable b) 161 | => s -> a -> Process (Async b) 162 | callAsync server msg = async $ task $ call server msg 163 | 164 | -- | Sends a /cast/ message to the server identified by @server@. The server 165 | -- will not send a response. Like Cloud Haskell's 'send' primitive, cast is 166 | -- fully asynchronous and /never fails/ - therefore 'cast'ing to a non-existent 167 | -- (e.g., dead) server process will not generate an error. 168 | -- 169 | cast :: forall a m . (Addressable a, Serializable m) 170 | => a -> m -> Process () 171 | cast server msg = sendTo server (CastMessage msg :: T.Message m ()) 172 | 173 | -- | Sends a /channel/ message to the server and returns a @ReceivePort@ on 174 | -- which the reponse can be delivered, if the server so chooses (i.e., the 175 | -- might ignore the request or crash). 176 | callChan :: forall s a b . (Addressable s, Serializable a, Serializable b) 177 | => s -> a -> Process (ReceivePort b) 178 | callChan server msg = do 179 | (sp, rp) <- newChan 180 | sendTo server (ChanMessage msg sp :: T.Message a b) 181 | return rp 182 | 183 | -- | A synchronous version of 'callChan'. 184 | syncCallChan :: forall s a b . (Addressable s, Serializable a, Serializable b) 185 | => s -> a -> Process b 186 | syncCallChan server msg = do 187 | r <- syncSafeCallChan server msg 188 | case r of 189 | Left e -> die e 190 | Right r' -> return r' 191 | 192 | -- | A safe version of 'syncCallChan', which returns @Left ExitReason@ if the 193 | -- call fails. 194 | syncSafeCallChan :: forall s a b . (Addressable s, Serializable a, Serializable b) 195 | => s -> a -> Process (Either ExitReason b) 196 | syncSafeCallChan server msg = do 197 | rp <- callChan server msg 198 | awaitResponse server [ matchChan rp (return . Right) ] 199 | 200 | -- | Manages an rpc-style interaction with a server process, using @STM@ actions 201 | -- to read/write data. The server process is monitored for the duration of the 202 | -- /call/. The stm write expression is passed the input, and the read expression 203 | -- is evaluated and the result given as @Right b@ or @Left ExitReason@ if a 204 | -- monitor signal is detected whilst waiting. 205 | -- 206 | -- Note that the caller will exit (with @ExitOther String@) if the server 207 | -- address is un-resolvable. 208 | -- 209 | -- A note about scheduling and timing guarantees (or lack thereof): It is not 210 | -- possibly to guarantee the contents of @ExitReason@ in cases where this API 211 | -- fails due to server exits/crashes. We establish a monitor prior to evaluating 212 | -- the stm writer action, however @monitor@ is asychronous and we've no way to 213 | -- know whether or not the scheduler will allow monitor establishment to proceed 214 | -- first, or the stm transaction. As a result, assuming that your server process 215 | -- can die/fail/exit on evaluating the read end of the STM write we perform here 216 | -- (and we assume this is very likely, since we apply no safety rules and do not 217 | -- even worry about serializing thunks passed from the client's thread), it is 218 | -- just as likely that in the case of failure you will see a reason such as 219 | -- @ExitOther "DiedUnknownId"@ due to the server process crashing before the node 220 | -- controller can establish a monitor. 221 | -- 222 | -- As unpleasant as this is, there's little we can do about it without making 223 | -- false assumptions about the runtime. Cloud Haskell's semantics guarantee us 224 | -- only that we will see /some/ monitor signal in the event of a failure here. 225 | -- To provide a more robust error handling, you can catch/trap failures in the 226 | -- server process and return a wrapper reponse datum here instead. This will 227 | -- /still/ be subject to the failure modes described above in cases where the 228 | -- server process exits abnormally, but that will at least allow the caller to 229 | -- differentiate between expected and exceptional failure conditions. 230 | -- 231 | callSTM :: forall s a b . (Addressable s) 232 | => s 233 | -> (a -> STM ()) 234 | -> STM b 235 | -> a 236 | -> Process (Either ExitReason b) 237 | callSTM server writeAction readAction input = do 238 | -- NB: we must establish the monitor before writing, to ensure we have 239 | -- a valid ref such that server failure gets reported properly 240 | pid <- resolveOrDie server "callSTM: unresolveable address " 241 | mRef <- monitor pid 242 | 243 | liftIO $ atomically $ writeAction input 244 | 245 | finally (receiveWait [ matchRef mRef 246 | , matchSTM readAction (return . Right) 247 | ]) 248 | (unmonitor mRef) 249 | 250 | where 251 | matchRef :: MonitorRef -> Match (Either ExitReason b) 252 | matchRef r = matchIf (\(ProcessMonitorNotification r' _ _) -> r == r') 253 | (\(ProcessMonitorNotification _ _ d) -> 254 | return (Left (ExitOther (show d)))) 255 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/ManagedProcess/Internal/PriorityQueue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Control.Distributed.Process.ManagedProcess.Internal.PriorityQueue where 3 | 4 | -- NB: we might try this with a skewed binomial heap at some point, 5 | -- but for now, we'll use this module from the fingertree package 6 | import qualified Data.PriorityQueue.FingerTree as PQ 7 | import qualified Data.Foldable as F (toList) 8 | import Data.PriorityQueue.FingerTree (PQueue) 9 | 10 | newtype PriorityQ k a = PriorityQ { q :: PQueue k a } 11 | 12 | {-# INLINE empty #-} 13 | empty :: Ord k => PriorityQ k v 14 | empty = PriorityQ $ PQ.empty 15 | 16 | {-# INLINE isEmpty #-} 17 | isEmpty :: Ord k => PriorityQ k v -> Bool 18 | isEmpty = PQ.null . q 19 | 20 | {-# INLINE singleton #-} 21 | singleton :: Ord k => k -> a -> PriorityQ k a 22 | singleton !k !v = PriorityQ $ PQ.singleton k v 23 | 24 | {-# INLINE enqueue #-} 25 | enqueue :: Ord k => k -> v -> PriorityQ k v -> PriorityQ k v 26 | enqueue !k !v p = PriorityQ (PQ.add k v $ q p) 27 | 28 | {-# INLINE dequeue #-} 29 | dequeue :: Ord k => PriorityQ k v -> Maybe (v, PriorityQ k v) 30 | dequeue p = maybe Nothing (\(v, pq') -> Just (v, pq')) $ 31 | case (PQ.minView (q p)) of 32 | Nothing -> Nothing 33 | Just (v, q') -> Just (v, PriorityQ $ q') 34 | 35 | {-# INLINE peek #-} 36 | peek :: Ord k => PriorityQ k v -> Maybe v 37 | peek p = maybe Nothing (\(v, _) -> Just v) $ dequeue p 38 | 39 | {-# INLINE toList #-} 40 | toList :: Ord k => PriorityQ k a -> [a] 41 | toList = F.toList . q 42 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/ManagedProcess/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE LiberalTypeSynonyms #-} 9 | {-# LANGUAGE Rank2Types #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | {-# LANGUAGE FunctionalDependencies #-} 15 | 16 | -- | Types used throughout the ManagedProcess framework 17 | module Control.Distributed.Process.ManagedProcess.Internal.Types 18 | ( -- * Exported data types 19 | InitResult(..) 20 | , GenProcess() 21 | , runProcess 22 | , lift 23 | , liftIO 24 | , ProcessState(..) 25 | , State 26 | , Queue 27 | , Limit 28 | , Condition(..) 29 | , ProcessAction(..) 30 | , ProcessReply(..) 31 | , Action 32 | , Reply 33 | , ActionHandler 34 | , CallHandler 35 | , CastHandler 36 | , StatelessHandler 37 | , DeferredCallHandler 38 | , StatelessCallHandler 39 | , InfoHandler 40 | , ChannelHandler 41 | , StatelessChannelHandler 42 | , InitHandler 43 | , ShutdownHandler 44 | , ExitState(..) 45 | , isCleanShutdown 46 | , exitState 47 | , TimeoutHandler 48 | , UnhandledMessagePolicy(..) 49 | , ProcessDefinition(..) 50 | , Priority(..) 51 | , DispatchPriority(..) 52 | , DispatchFilter(..) 53 | , Filter(..) 54 | -- , Check(..) 55 | , PrioritisedProcessDefinition(..) 56 | , RecvTimeoutPolicy(..) 57 | , ControlChannel(..) 58 | , newControlChan 59 | , ControlPort(..) 60 | , channelControlPort 61 | , Dispatcher(..) 62 | , ExternDispatcher(..) 63 | , DeferredDispatcher(..) 64 | , ExitSignalDispatcher(..) 65 | , MessageMatcher(..) 66 | , ExternMatcher(..) 67 | , Message(..) 68 | , CallResponse(..) 69 | , CallId 70 | , CallRef(..) 71 | , CallRejected(..) 72 | , makeRef 73 | , caller 74 | , rejectToCaller 75 | , recipient 76 | , tag 77 | , initCall 78 | , unsafeInitCall 79 | , waitResponse 80 | ) where 81 | 82 | import Control.Concurrent.STM (STM) 83 | import Control.Distributed.Process hiding (Message, mask, finally, liftIO) 84 | import qualified Control.Distributed.Process as P (Message, liftIO) 85 | import Control.Distributed.Process.Serializable 86 | import Control.Distributed.Process.Extras 87 | ( Recipient(..) 88 | , ExitReason(..) 89 | , Addressable 90 | , Resolvable(..) 91 | , Routable(..) 92 | , NFSerializable 93 | ) 94 | import Control.Distributed.Process.ManagedProcess.Internal.PriorityQueue 95 | ( PriorityQ 96 | ) 97 | import Control.Distributed.Process.Extras.Internal.Types 98 | ( resolveOrDie 99 | ) 100 | import Control.Distributed.Process.Extras.Time 101 | import Control.Distributed.Process.ManagedProcess.Timer (Timer, TimerKey) 102 | import Control.DeepSeq (NFData(..)) 103 | import Control.Monad.Fix (MonadFix) 104 | import Control.Monad.Catch 105 | ( catch 106 | , throwM 107 | , uninterruptibleMask 108 | , mask 109 | , finally 110 | , MonadThrow 111 | , MonadCatch 112 | , MonadMask(..) 113 | ) 114 | import qualified Control.Monad.Catch as Catch 115 | ( catch 116 | , throwM 117 | ) 118 | import Control.Monad.IO.Class (MonadIO) 119 | import qualified Control.Monad.State.Strict as ST 120 | ( MonadState 121 | , StateT 122 | , get 123 | , lift 124 | , runStateT 125 | ) 126 | import Data.Binary hiding (decode) 127 | import Data.Map.Strict (Map) 128 | import Data.Typeable (Typeable) 129 | import Data.IORef (IORef) 130 | import Prelude hiding (init) 131 | import GHC.Generics 132 | 133 | -------------------------------------------------------------------------------- 134 | -- API -- 135 | -------------------------------------------------------------------------------- 136 | 137 | -- | wrapper for a @MonitorRef@ 138 | type CallId = MonitorRef 139 | 140 | -- | Wraps a consumer of the call API 141 | newtype CallRef a = CallRef { unCaller :: (Recipient, CallId) } 142 | deriving (Eq, Show, Typeable, Generic) 143 | 144 | -- | Retrieve the @Recipient@ for a @CallRef@. 145 | recipient :: CallRef a -> Recipient 146 | recipient = fst . unCaller 147 | 148 | -- | Retrieve the @CallId@ for a @CallRef@. 149 | tag :: CallRef a -> CallId 150 | tag = snd . unCaller 151 | 152 | instance Binary (CallRef a) where 153 | instance NFData (CallRef a) where rnf (CallRef x) = rnf x `seq` () 154 | 155 | -- | Creates a @CallRef@ for the given @Recipient@ and @CallId@ 156 | makeRef :: Recipient -> CallId -> CallRef a 157 | makeRef r c = CallRef (r, c) 158 | 159 | -- | @Message@ type used internally by the call, cast, and rpcChan APIs. 160 | data Message a b = 161 | CastMessage a 162 | | CallMessage a (CallRef b) 163 | | ChanMessage a (SendPort b) 164 | deriving (Typeable, Generic) 165 | 166 | -- | Retrieve the @Recipient@ from a @Message@. If the supplied message is 167 | -- a /cast/ or /chan/ message will evaluate to @Nothing@, otherwise @Just ref@. 168 | caller :: forall a b . Message a b -> Maybe Recipient 169 | caller (CallMessage _ ref) = Just $ recipient ref 170 | caller _ = Nothing 171 | 172 | -- | Reject a /call/ message with the supplied string. Sends @CallRejected@ to 173 | -- the recipient if the input is a @CallMessage@, otherwise has no side effects. 174 | rejectToCaller :: forall a b . 175 | Message a b -> String -> Process () 176 | rejectToCaller (CallMessage _ ref) m = sendTo ref (CallRejected m (tag ref)) 177 | rejectToCaller _ _ = return () 178 | 179 | instance (Serializable a, Serializable b) => Binary (Message a b) where 180 | instance (NFSerializable a, NFSerializable b) => NFData (Message a b) where 181 | rnf (CastMessage a) = rnf a `seq` () 182 | rnf (CallMessage a b) = rnf a `seq` rnf b `seq` () 183 | rnf (ChanMessage a b) = rnf a `seq` rnf b `seq` () 184 | deriving instance (Eq a, Eq b) => Eq (Message a b) 185 | deriving instance (Show a, Show b) => Show (Message a b) 186 | 187 | -- | Response type for the call API 188 | data CallResponse a = CallResponse a CallId 189 | deriving (Typeable, Generic) 190 | 191 | instance Serializable a => Binary (CallResponse a) 192 | instance NFSerializable a => NFData (CallResponse a) where 193 | rnf (CallResponse a c) = rnf a `seq` rnf c `seq` () 194 | deriving instance Eq a => Eq (CallResponse a) 195 | deriving instance Show a => Show (CallResponse a) 196 | 197 | -- | Sent to a consumer of the /call/ API when a server filter expression 198 | -- explicitly rejects an incoming call message. 199 | data CallRejected = CallRejected String CallId 200 | deriving (Typeable, Generic, Show, Eq) 201 | instance Binary CallRejected where 202 | instance NFData CallRejected where 203 | 204 | instance Resolvable (CallRef a) where 205 | resolve (CallRef (r, _)) = resolve r 206 | 207 | instance Routable (CallRef a) where 208 | sendTo (CallRef (c, _)) = sendTo c 209 | unsafeSendTo (CallRef (c, _)) = unsafeSendTo c 210 | 211 | -- | Return type for and 'InitHandler' expression. 212 | data InitResult s = 213 | InitOk s Delay {- 214 | ^ a successful initialisation, initial state and timeout -} 215 | | InitStop String {- 216 | ^ failed initialisation and the reason, this will result in an error -} 217 | | InitIgnore {- 218 | ^ the process has decided not to continue starting - this is not an error -} 219 | deriving (Typeable) 220 | 221 | -- | Represent a max-backlog from RecvTimeoutPolicy 222 | type Limit = Maybe Int 223 | 224 | -- | Internal priority queue, used by prioritised processes. 225 | type Queue = PriorityQ Int P.Message 226 | 227 | -- | Map from @TimerKey@ to @(Timer, Message)@. 228 | type TimerMap = Map TimerKey (Timer, P.Message) 229 | 230 | -- | Internal state of a prioritised process loop. 231 | data ProcessState s = ProcessState { timeoutSpec :: RecvTimeoutPolicy 232 | , procDef :: ProcessDefinition s 233 | , procPrio :: [DispatchPriority s] 234 | , procFilters :: [DispatchFilter s] 235 | , usrTimeout :: Delay 236 | , sysTimeout :: Timer 237 | , usrTimers :: TimerMap 238 | , internalQ :: Queue 239 | , procState :: s 240 | } 241 | 242 | -- | Prioritised process state, held as an @IORef@. 243 | type State s = IORef (ProcessState s) 244 | 245 | -- | StateT based monad for prioritised process loops. 246 | newtype GenProcess s a = GenProcess { 247 | unManaged :: ST.StateT (State s) Process a 248 | } 249 | deriving ( Functor 250 | , Monad 251 | , ST.MonadState (State s) 252 | , MonadIO 253 | , MonadFix 254 | , Typeable 255 | , Applicative 256 | ) 257 | 258 | instance forall s . MonadThrow (GenProcess s) where 259 | throwM = lift . Catch.throwM 260 | 261 | instance forall s . MonadCatch (GenProcess s) where 262 | catch p h = do 263 | pSt <- ST.get 264 | -- we can throw away our state since it is always accessed via an IORef 265 | (a, _) <- lift $ Catch.catch (runProcess pSt p) (runProcess pSt . h) 266 | return a 267 | 268 | instance forall s . MonadMask (GenProcess s) where 269 | mask p = do 270 | pSt <- ST.get 271 | lift $ mask $ \restore -> do 272 | (a, _) <- runProcess pSt (p (liftRestore restore)) 273 | return a 274 | where 275 | liftRestore restoreP = \p2 -> do 276 | ourSTate <- ST.get 277 | (a', _) <- lift $ restoreP $ runProcess ourSTate p2 278 | return a' 279 | 280 | uninterruptibleMask p = do 281 | pSt <- ST.get 282 | (a, _) <- lift $ uninterruptibleMask $ \restore -> 283 | runProcess pSt (p (liftRestore restore)) 284 | return a 285 | where 286 | liftRestore restoreP = \p2 -> do 287 | ourSTate <- ST.get 288 | (a', _) <- lift $ restoreP $ runProcess ourSTate p2 289 | return a' 290 | 291 | #if MIN_VERSION_exceptions(0,10,0) 292 | generalBracket acquire release inner = GenProcess $ 293 | generalBracket (unManaged acquire) 294 | (\a e -> unManaged $ release a e) 295 | (unManaged . inner) 296 | #endif 297 | 298 | -- | Run an action in the @GenProcess@ monad. 299 | runProcess :: State s -> GenProcess s a -> Process (a, State s) 300 | runProcess state proc = ST.runStateT (unManaged proc) state 301 | 302 | -- | Lift an action in the @Process@ monad to @GenProcess@. 303 | lift :: Process a -> GenProcess s a 304 | lift p = GenProcess $ ST.lift p 305 | 306 | -- | Lift an IO action directly into @GenProcess@, @liftIO = lift . Process.LiftIO@. 307 | liftIO :: IO a -> GenProcess s a 308 | liftIO = lift . P.liftIO 309 | 310 | -- | The action taken by a process after a handler has run and its updated state. 311 | -- See "Control.Distributed.Process.ManagedProcess.Server.continue" 312 | -- "Control.Distributed.Process.ManagedProcess.Server.timeoutAfter" 313 | -- "Control.Distributed.Process.ManagedProcess.Server.hibernate" 314 | -- "Control.Distributed.Process.ManagedProcess.Server.stop" 315 | -- "Control.Distributed.Process.ManagedProcess.Server.stopWith" 316 | -- 317 | -- Also see "Control.Distributed.Process.Management.Priority.act" and 318 | -- "Control.Distributed.Process.ManagedProcess.Priority.runAfter". 319 | -- 320 | -- And other actions. This type should not be used directly. 321 | data ProcessAction s = 322 | ProcessSkip 323 | | ProcessActivity (GenProcess s ()) -- ^ run the given activity 324 | | ProcessExpression (GenProcess s (ProcessAction s)) -- ^ evaluate an expression 325 | | ProcessContinue s -- ^ continue with (possibly new) state 326 | | ProcessTimeout Delay s -- ^ timeout if no messages are received 327 | | ProcessHibernate TimeInterval s -- ^ hibernate for /delay/ 328 | | ProcessStop ExitReason -- ^ stop the process, giving @ExitReason@ 329 | | ProcessStopping s ExitReason -- ^ stop the process with @ExitReason@, with updated state 330 | | ProcessBecome (ProcessDefinition s) s -- ^ changes the current process definition 331 | 332 | -- | Returned from handlers for the synchronous 'call' protocol, encapsulates 333 | -- the reply data /and/ the action to take after sending the reply. A handler 334 | -- can return @NoReply@ if they wish to ignore the call. 335 | data ProcessReply r s = 336 | ProcessReply r (ProcessAction s) 337 | | ProcessReject String (ProcessAction s) -- TODO: can we use a functional dependency here? 338 | | NoReply (ProcessAction s) 339 | 340 | -- | Wraps a predicate that is used to determine whether or not a handler 341 | -- is valid based on some combination of the current process state, the 342 | -- type and/or value of the input message or both. 343 | data Condition s m = 344 | Condition (s -> m -> Bool) -- ^ predicated on the process state /and/ the message 345 | | State (s -> Bool) -- ^ predicated on the process state only 346 | | Input (m -> Bool) -- ^ predicated on the input message only 347 | 348 | {- 349 | 350 | class Check c s m | s m -> c where 351 | -- data Checker c :: * -> * -> * 352 | -- apply :: s -> m -> Checker c s m -> Bool 353 | apply :: s -> m -> c -> Bool 354 | 355 | instance Check (Condition s m) s m where 356 | -- data Checker (Condition s m) s m = CheckCond (Condition s m) 357 | apply s m (Condition f) = f s m 358 | apply s _ (State f) = f s 359 | apply _ m (Input f) = f m 360 | 361 | instance Check (s -> m -> Bool) s m where 362 | -- data Checker (s -> m -> Bool) s m = CheckF (s -> m -> Bool) 363 | apply s m f = f s m 364 | -} 365 | 366 | -- | Informs a /shutdown handler/ of whether it is running due to a clean 367 | -- shutdown, or in response to an unhandled exception. 368 | data ExitState s = CleanShutdown s -- ^ given when an ordered shutdown is underway 369 | | LastKnown s {- 370 | ^ given due to an unhandled exception, passing the last known state -} 371 | 372 | -- | @True@ if the @ExitState@ is @CleanShutdown@, otherwise @False@. 373 | isCleanShutdown :: ExitState s -> Bool 374 | isCleanShutdown (CleanShutdown _) = True 375 | isCleanShutdown _ = False 376 | 377 | -- | Evaluates to the @s@ state datum in the given @ExitState@. 378 | exitState :: ExitState s -> s 379 | exitState (CleanShutdown s) = s 380 | exitState (LastKnown s) = s 381 | 382 | -- | An action (server state transition) in the @Process@ monad 383 | type Action s = Process (ProcessAction s) 384 | 385 | -- | An action (server state transition) causing a reply to a caller, in the 386 | -- @Process@ monad 387 | type Reply b s = Process (ProcessReply b s) 388 | 389 | -- | An expression used to handle a message 390 | type ActionHandler s a = s -> a -> Action s 391 | 392 | -- | An expression used to handle a message and providing a reply 393 | type CallHandler s a b = s -> a -> Reply b s 394 | 395 | -- | An expression used to ignore server state during handling 396 | type StatelessHandler s a = a -> (s -> Action s) 397 | 398 | -- | An expression used to handle a /call/ message where the reply is deferred 399 | -- via the 'CallRef' 400 | type DeferredCallHandler s a b = CallRef b -> CallHandler s a b 401 | 402 | -- | An expression used to handle a /call/ message ignoring server state 403 | type StatelessCallHandler s a b = CallRef b -> a -> Reply b s 404 | 405 | -- | An expression used to handle a /cast/ message 406 | type CastHandler s a = ActionHandler s a 407 | 408 | -- | An expression used to handle an /info/ message 409 | type InfoHandler s a = ActionHandler s a 410 | 411 | -- | An expression used to handle a /channel/ message 412 | type ChannelHandler s a b = SendPort b -> ActionHandler s a 413 | 414 | -- | An expression used to handle a /channel/ message in a stateless process 415 | type StatelessChannelHandler s a b = SendPort b -> StatelessHandler s a 416 | 417 | -- | An expression used to initialise a process with its state 418 | type InitHandler a s = a -> Process (InitResult s) 419 | 420 | -- | An expression used to handle process termination 421 | type ShutdownHandler s = ExitState s -> ExitReason -> Process () 422 | 423 | -- | An expression used to handle process timeouts 424 | type TimeoutHandler s = ActionHandler s Delay 425 | 426 | -- dispatching to implementation callbacks 427 | 428 | -- | Provides a means for servers to listen on a separate, typed /control/ 429 | -- channel, thereby segregating the channel from their regular 430 | -- (and potentially busy) mailbox. 431 | newtype ControlChannel m = 432 | ControlChannel { 433 | unControl :: (SendPort (Message m ()), ReceivePort (Message m ())) 434 | } 435 | 436 | -- | Creates a new 'ControlChannel'. 437 | newControlChan :: (Serializable m) => Process (ControlChannel m) 438 | newControlChan = fmap ControlChannel newChan 439 | 440 | -- | The writable end of a 'ControlChannel'. 441 | -- 442 | newtype ControlPort m = 443 | ControlPort { 444 | unPort :: SendPort (Message m ()) 445 | } deriving (Show) 446 | deriving instance (Serializable m) => Binary (ControlPort m) 447 | instance Eq (ControlPort m) where 448 | a == b = unPort a == unPort b 449 | 450 | -- | Obtain an opaque expression for communicating with a 'ControlChannel'. 451 | -- 452 | channelControlPort :: ControlChannel m 453 | -> ControlPort m 454 | channelControlPort cc = ControlPort $ fst $ unControl cc 455 | 456 | -- | Given as the result of evaluating a "DispatchFilter". This type is intended 457 | -- for internal use. For an API for working with filters, 458 | -- see "Control.Distributed.Process.ManagedProcess.Priority". 459 | data Filter s = FilterOk s 460 | | FilterSafe s 461 | | forall m . (Show m) => FilterReject m s 462 | | FilterSkip s 463 | | FilterStop s ExitReason 464 | 465 | -- | Provides dispatch from a variety of inputs to a typed filter handler. 466 | data DispatchFilter s = 467 | forall a b . (Serializable a, Serializable b) => 468 | FilterApi 469 | { 470 | apiFilter :: s -> Message a b -> Process (Filter s) 471 | } 472 | | forall a . (Serializable a) => 473 | FilterAny 474 | { 475 | anyFilter :: s -> a -> Process (Filter s) 476 | } 477 | | FilterRaw 478 | { 479 | rawFilter :: s -> P.Message -> Process (Maybe (Filter s)) 480 | } 481 | | FilterState 482 | { 483 | stateFilter :: s -> Process (Maybe (Filter s)) 484 | } 485 | 486 | -- | Provides dispatch from cast and call messages to a typed handler. 487 | data Dispatcher s = 488 | forall a b . (Serializable a, Serializable b) => 489 | Dispatch 490 | { 491 | dispatch :: s -> Message a b -> Process (ProcessAction s) 492 | } 493 | | forall a b . (Serializable a, Serializable b) => 494 | DispatchIf 495 | { 496 | dispatch :: s -> Message a b -> Process (ProcessAction s) 497 | , dispatchIf :: s -> Message a b -> Bool 498 | } 499 | 500 | -- | Provides dispatch for channels and STM actions 501 | data ExternDispatcher s = 502 | forall a b . (Serializable a, Serializable b) => 503 | DispatchCC -- control channel dispatch 504 | { 505 | channel :: ReceivePort (Message a b) 506 | , dispatchChan :: s -> Message a b -> Process (ProcessAction s) 507 | } 508 | | forall a . (Serializable a) => 509 | DispatchSTM -- arbitrary STM actions 510 | { 511 | stmAction :: STM a 512 | , dispatchStm :: s -> a -> Process (ProcessAction s) 513 | , matchStm :: Match P.Message 514 | , matchAnyStm :: forall m . (P.Message -> m) -> Match m 515 | } 516 | 517 | -- | Provides dispatch for any input, returns 'Nothing' for unhandled messages. 518 | data DeferredDispatcher s = 519 | DeferredDispatcher 520 | { 521 | dispatchInfo :: s 522 | -> P.Message 523 | -> Process (Maybe (ProcessAction s)) 524 | } 525 | 526 | -- | Provides dispatch for any exit signal - returns 'Nothing' for unhandled exceptions 527 | data ExitSignalDispatcher s = 528 | ExitSignalDispatcher 529 | { 530 | dispatchExit :: s 531 | -> ProcessId 532 | -> P.Message 533 | -> Process (Maybe (ProcessAction s)) 534 | } 535 | 536 | -- | Defines the means of dispatching inbound messages to a handler 537 | class MessageMatcher d where 538 | matchDispatch :: UnhandledMessagePolicy -> s -> d s -> Match (ProcessAction s) 539 | 540 | instance MessageMatcher Dispatcher where 541 | matchDispatch _ s (Dispatch d) = match (d s) 542 | matchDispatch _ s (DispatchIf d cond) = matchIf (cond s) (d s) 543 | 544 | instance MessageMatcher ExternDispatcher where 545 | matchDispatch _ s (DispatchCC c d) = matchChan c (d s) 546 | matchDispatch _ s (DispatchSTM c d _ _) = matchSTM c (d s) 547 | 548 | -- | Defines the means of dispatching messages from external channels (e.g. 549 | -- those defined in terms of "ControlChannel", and STM actions) to a handler. 550 | class ExternMatcher d where 551 | matchExtern :: UnhandledMessagePolicy -> s -> d s -> Match P.Message 552 | 553 | matchMapExtern :: forall m s . UnhandledMessagePolicy 554 | -> s -> (P.Message -> m) -> d s -> Match m 555 | 556 | instance ExternMatcher ExternDispatcher where 557 | matchExtern _ _ (DispatchCC c _) = matchChan c (return . unsafeWrapMessage) 558 | matchExtern _ _ (DispatchSTM _ _ m _) = m 559 | 560 | matchMapExtern _ _ f (DispatchCC c _) = matchChan c (return . f . unsafeWrapMessage) 561 | matchMapExtern _ _ f (DispatchSTM _ _ _ p) = p f 562 | 563 | -- | Priority of a message, encoded as an @Int@ 564 | newtype Priority a = Priority { getPrio :: Int } 565 | 566 | -- | Dispatcher for prioritised handlers 567 | data DispatchPriority s = 568 | PrioritiseCall 569 | { 570 | prioritise :: s -> P.Message -> Process (Maybe (Int, P.Message)) 571 | } 572 | | PrioritiseCast 573 | { 574 | prioritise :: s -> P.Message -> Process (Maybe (Int, P.Message)) 575 | } 576 | | PrioritiseInfo 577 | { 578 | prioritise :: s -> P.Message -> Process (Maybe (Int, P.Message)) 579 | } 580 | 581 | -- | For a 'PrioritisedProcessDefinition', this policy determines for how long 582 | -- the /receive loop/ should continue draining the process' mailbox before 583 | -- processing its received mail (in priority order). 584 | -- 585 | -- If a prioritised /managed process/ is receiving a lot of messages (into its 586 | -- /real/ mailbox), the server might never get around to actually processing its 587 | -- inputs. This (mandatory) policy provides a guarantee that eventually (i.e., 588 | -- after a specified number of received messages or time interval), the server 589 | -- will stop removing messages from its mailbox and process those it has already 590 | -- received. 591 | -- 592 | data RecvTimeoutPolicy = RecvMaxBacklog Int | RecvTimer TimeInterval 593 | deriving (Typeable) 594 | 595 | -- | A @ProcessDefinition@ decorated with @DispatchPriority@ for certain 596 | -- input domains. 597 | data PrioritisedProcessDefinition s = 598 | PrioritisedProcessDefinition 599 | { 600 | processDef :: ProcessDefinition s 601 | , priorities :: [DispatchPriority s] 602 | , filters :: [DispatchFilter s] 603 | , recvTimeout :: RecvTimeoutPolicy 604 | } 605 | 606 | -- | Policy for handling unexpected messages, i.e., messages which are not 607 | -- sent using the 'call' or 'cast' APIs, and which are not handled by any of the 608 | -- 'handleInfo' handlers. 609 | data UnhandledMessagePolicy = 610 | Terminate -- ^ stop immediately, giving @ExitOther "UnhandledInput"@ as the reason 611 | | DeadLetter ProcessId -- ^ forward the message to the given recipient 612 | | Log -- ^ log messages, then behave identically to @Drop@ 613 | | Drop -- ^ dequeue and then drop/ignore the message 614 | deriving (Show, Eq) 615 | 616 | -- | Stores the functions that determine runtime behaviour in response to 617 | -- incoming messages and a policy for responding to unhandled messages. 618 | data ProcessDefinition s = ProcessDefinition { 619 | apiHandlers :: [Dispatcher s] -- ^ functions that handle call/cast messages 620 | , infoHandlers :: [DeferredDispatcher s] -- ^ functions that handle non call/cast messages 621 | , externHandlers :: [ExternDispatcher s] -- ^ functions that handle control channel and STM inputs 622 | , exitHandlers :: [ExitSignalDispatcher s] -- ^ functions that handle exit signals 623 | , timeoutHandler :: TimeoutHandler s -- ^ a function that handles timeouts 624 | , shutdownHandler :: ShutdownHandler s -- ^ a function that is run just before the process exits 625 | , unhandledMessagePolicy :: UnhandledMessagePolicy -- ^ how to deal with unhandled messages 626 | } 627 | 628 | -- note [rpc calls] 629 | -- One problem with using plain expect/receive primitives to perform a 630 | -- synchronous (round trip) call is that a reply matching the expected type 631 | -- could come from anywhere! The Call.hs module uses a unique integer tag to 632 | -- distinguish between inputs but this is easy to forge, and forces all callers 633 | -- to maintain a tag pool, which is quite onerous. 634 | -- 635 | -- Here, we use a private (internal) tag based on a 'MonitorRef', which is 636 | -- guaranteed to be unique per calling process (in the absence of mallicious 637 | -- peers). This is handled throughout the roundtrip, such that the reply will 638 | -- either contain the CallId (i.e., the ame 'MonitorRef' with which we're 639 | -- tracking the server process) or we'll see the server die. 640 | -- 641 | -- Of course, the downside to all this is that the monitoring and receiving 642 | -- clutters up your mailbox, and if your mailbox is extremely full, could 643 | -- incur delays in delivery. The callAsync function provides a neat 644 | -- work-around for that, relying on the insulation provided by Async. 645 | 646 | -- TODO: Generify this /call/ API and use it in Call.hs to avoid tagging 647 | 648 | -- TODO: the code below should be moved elsewhere. Maybe to Client.hs? 649 | 650 | -- | The send part of the /call/ client-server interaction. The resulting 651 | -- "CallRef" can be used to identify the corrolary response message (if one is 652 | -- sent by the server), and is unique to this /call-reply/ pair. 653 | initCall :: forall s a b . (Addressable s, Serializable a, Serializable b) 654 | => s -> a -> Process (CallRef b) 655 | initCall sid msg = do 656 | pid <- resolveOrDie sid "initCall: unresolveable address " 657 | mRef <- monitor pid 658 | self <- getSelfPid 659 | let cRef = makeRef (Pid self) mRef in do 660 | sendTo pid (CallMessage msg cRef :: Message a b) 661 | return cRef 662 | 663 | -- | Version of @initCall@ that utilises "unsafeSendTo". 664 | unsafeInitCall :: forall s a b . ( Addressable s 665 | , NFSerializable a 666 | , NFSerializable b 667 | ) 668 | => s -> a -> Process (CallRef b) 669 | unsafeInitCall sid msg = do 670 | pid <- resolveOrDie sid "unsafeInitCall: unresolveable address " 671 | mRef <- monitor pid 672 | self <- getSelfPid 673 | let cRef = makeRef (Pid self) mRef in do 674 | unsafeSendTo pid (CallMessage msg cRef :: Message a b) 675 | return cRef 676 | 677 | -- | Wait on the server's response after an "initCall" has been previously been sent. 678 | -- 679 | -- This function does /not/ trap asynchronous exceptions. 680 | waitResponse :: forall b. (Serializable b) 681 | => Maybe TimeInterval 682 | -> CallRef b 683 | -> Process (Maybe (Either ExitReason b)) 684 | waitResponse mTimeout cRef = 685 | let (_, mRef) = unCaller cRef 686 | matchers = [ matchIf (\((CallResponse _ ref) :: CallResponse b) -> ref == mRef) 687 | (\((CallResponse m _) :: CallResponse b) -> return (Right m)) 688 | , matchIf (\((CallRejected _ ref)) -> ref == mRef) 689 | (\(CallRejected s _) -> return (Left $ ExitOther $ s)) 690 | , matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mRef) 691 | (\(ProcessMonitorNotification _ _ r) -> return (Left (err r))) 692 | ] 693 | err r = ExitOther $ show r in 694 | case mTimeout of 695 | (Just ti) -> finally (receiveTimeout (asTimeout ti) matchers) (unmonitor mRef) 696 | Nothing -> finally (fmap Just (receiveWait matchers)) (unmonitor mRef) 697 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/ManagedProcess/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE PatternGuards #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Control.Distributed.Process.ManagedProcess.Server 8 | -- Copyright : (c) Tim Watson 2012 - 2017 9 | -- License : BSD3 (see the file LICENSE) 10 | -- 11 | -- Maintainer : Tim Watson 12 | -- Stability : experimental 13 | -- Portability : non-portable (requires concurrency) 14 | -- 15 | -- The Server Portion of the /Managed Process/ API. 16 | ----------------------------------------------------------------------------- 17 | 18 | module Control.Distributed.Process.ManagedProcess.Server 19 | ( -- * Server actions 20 | condition 21 | , state 22 | , input 23 | , reply 24 | , replyWith 25 | , noReply 26 | , continue 27 | , timeoutAfter 28 | , hibernate 29 | , stop 30 | , stopWith 31 | , replyTo 32 | , replyChan 33 | , reject 34 | , rejectWith 35 | , become 36 | -- * Stateless actions 37 | , noReply_ 38 | , haltNoReply_ 39 | , continue_ 40 | , timeoutAfter_ 41 | , hibernate_ 42 | , stop_ 43 | -- * Server handler/callback creation 44 | , handleCall 45 | , handleCallIf 46 | , handleCallFrom 47 | , handleCallFromIf 48 | , handleRpcChan 49 | , handleRpcChanIf 50 | , handleCast 51 | , handleCastIf 52 | , handleInfo 53 | , handleRaw 54 | , handleDispatch 55 | , handleDispatchIf 56 | , handleExit 57 | , handleExitIf 58 | -- * Stateless handlers 59 | , action 60 | , handleCall_ 61 | , handleCallIf_ 62 | , handleCallFrom_ 63 | , handleCallFromIf_ 64 | , handleRpcChan_ 65 | , handleRpcChanIf_ 66 | , handleCast_ 67 | , handleCastIf_ 68 | -- * Working with Control Channels 69 | , handleControlChan 70 | , handleControlChan_ 71 | -- * Working with external/STM actions 72 | , handleExternal 73 | , handleExternal_ 74 | , handleCallExternal 75 | ) where 76 | 77 | import Control.Concurrent.STM (STM, atomically) 78 | import Control.Distributed.Process hiding (call, Message) 79 | import qualified Control.Distributed.Process as P (Message) 80 | import Control.Distributed.Process.Serializable 81 | import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (liftIO, lift) 82 | import Control.Distributed.Process.Extras 83 | ( ExitReason(..) 84 | , Routable(..) 85 | ) 86 | import Control.Distributed.Process.Extras.Time 87 | import Prelude hiding (init) 88 | 89 | -------------------------------------------------------------------------------- 90 | -- Producing ProcessAction and ProcessReply from inside handler expressions -- 91 | -------------------------------------------------------------------------------- 92 | 93 | -- note [Message type]: Since we own both client and server portions of the 94 | -- codebase, we know for certain which types will be passed to which kinds 95 | -- of handler, so the catch-all cases that @die $ "THIS_CAN_NEVER_HAPPEN"@ and 96 | -- such, are relatively sane despite appearances! 97 | 98 | -- | Creates a 'Condition' from a function that takes a process state @a@ and 99 | -- an input message @b@ and returns a 'Bool' indicating whether the associated 100 | -- handler should run. 101 | -- 102 | condition :: forall a b. (Serializable a, Serializable b) 103 | => (a -> b -> Bool) 104 | -> Condition a b 105 | condition = Condition 106 | 107 | -- | Create a 'Condition' from a function that takes a process state @a@ and 108 | -- returns a 'Bool' indicating whether the associated handler should run. 109 | -- 110 | state :: forall s m. (Serializable m) => (s -> Bool) -> Condition s m 111 | state = State 112 | 113 | -- | Creates a 'Condition' from a function that takes an input message @m@ and 114 | -- returns a 'Bool' indicating whether the associated handler should run. 115 | -- 116 | input :: forall s m. (Serializable m) => (m -> Bool) -> Condition s m 117 | input = Input 118 | 119 | -- | Reject the message we're currently handling. 120 | reject :: forall r s . s -> String -> Reply r s 121 | reject st rs = continue st >>= return . ProcessReject rs 122 | 123 | -- | Reject the message we're currently handling, giving an explicit reason. 124 | rejectWith :: forall r m s . (Show r) => s -> r -> Reply m s 125 | rejectWith st rs = reject st (show rs) 126 | 127 | -- | Instructs the process to send a reply and continue running. 128 | reply :: (Serializable r) => r -> s -> Reply r s 129 | reply r s = continue s >>= replyWith r 130 | 131 | -- | Instructs the process to send a reply /and/ evaluate the 'ProcessAction'. 132 | replyWith :: (Serializable r) 133 | => r 134 | -> ProcessAction s 135 | -> Reply r s 136 | replyWith r s = return $ ProcessReply r s 137 | 138 | -- | Instructs the process to skip sending a reply /and/ evaluate a 'ProcessAction' 139 | noReply :: (Serializable r) => ProcessAction s -> Reply r s 140 | noReply = return . NoReply 141 | 142 | -- | Continue without giving a reply to the caller - equivalent to 'continue', 143 | -- but usable in a callback passed to the 'handleCall' family of functions. 144 | noReply_ :: forall s r . (Serializable r) => s -> Reply r s 145 | noReply_ s = continue s >>= noReply 146 | 147 | -- | Halt process execution during a call handler, without paying any attention 148 | -- to the expected return type. 149 | haltNoReply_ :: Serializable r => ExitReason -> Reply r s 150 | haltNoReply_ r = stop r >>= noReply 151 | 152 | -- | Instructs the process to continue running and receiving messages. 153 | continue :: s -> Action s 154 | continue = return . ProcessContinue 155 | 156 | -- | Version of 'continue' that can be used in handlers that ignore process state. 157 | -- 158 | continue_ :: (s -> Action s) 159 | continue_ = return . ProcessContinue 160 | 161 | -- | Instructs the process loop to wait for incoming messages until 'Delay' 162 | -- is exceeded. If no messages are handled during this period, the /timeout/ 163 | -- handler will be called. Note that this alters the process timeout permanently 164 | -- such that the given @Delay@ will remain in use until changed. 165 | -- 166 | -- Note that @timeoutAfter NoDelay@ will cause the timeout handler to execute 167 | -- immediately if no messages are present in the process' mailbox. 168 | -- 169 | timeoutAfter :: Delay -> s -> Action s 170 | timeoutAfter d s = return $ ProcessTimeout d s 171 | 172 | -- | Version of 'timeoutAfter' that can be used in handlers that ignore process state. 173 | -- 174 | -- > action (\(TimeoutPlease duration) -> timeoutAfter_ duration) 175 | -- 176 | timeoutAfter_ :: StatelessHandler s Delay 177 | timeoutAfter_ d = return . ProcessTimeout d 178 | 179 | -- | Instructs the process to /hibernate/ for the given 'TimeInterval'. Note 180 | -- that no messages will be removed from the mailbox until after hibernation has 181 | -- ceased. This is equivalent to calling @threadDelay@. 182 | -- 183 | hibernate :: TimeInterval -> s -> Process (ProcessAction s) 184 | hibernate d s = return $ ProcessHibernate d s 185 | 186 | -- | Version of 'hibernate' that can be used in handlers that ignore process state. 187 | -- 188 | -- > action (\(HibernatePlease delay) -> hibernate_ delay) 189 | -- 190 | hibernate_ :: StatelessHandler s TimeInterval 191 | hibernate_ d = return . ProcessHibernate d 192 | 193 | -- | The server loop will execute against the supplied 'ProcessDefinition', allowing 194 | -- the process to change its behaviour (in terms of message handlers, exit handling, 195 | -- termination, unhandled message policy, etc) 196 | become :: forall s . ProcessDefinition s -> s -> Action s 197 | become def st = return $ ProcessBecome def st 198 | 199 | -- | Instructs the process to terminate, giving the supplied reason. If a valid 200 | -- 'shutdownHandler' is installed, it will be called with the 'ExitReason' 201 | -- returned from this call, along with the process state. 202 | stop :: ExitReason -> Action s 203 | stop r = return $ ProcessStop r 204 | 205 | -- | As 'stop', but provides an updated state for the shutdown handler. 206 | stopWith :: s -> ExitReason -> Action s 207 | stopWith s r = return $ ProcessStopping s r 208 | 209 | -- | Version of 'stop' that can be used in handlers that ignore process state. 210 | -- 211 | -- > action (\ClientError -> stop_ ExitNormal) 212 | -- 213 | stop_ :: StatelessHandler s ExitReason 214 | stop_ r _ = stop r 215 | 216 | -- | Sends a reply explicitly to a caller. 217 | -- 218 | -- > replyTo = sendTo 219 | -- 220 | replyTo :: (Serializable m) => CallRef m -> m -> Process () 221 | replyTo cRef@(CallRef (_, tag)) msg = sendTo cRef $ CallResponse msg tag 222 | 223 | -- | Sends a reply to a 'SendPort' (for use in 'handleRpcChan' et al). 224 | -- 225 | -- > replyChan = sendChan 226 | -- 227 | replyChan :: (Serializable m) => SendPort m -> m -> Process () 228 | replyChan = sendChan 229 | 230 | -------------------------------------------------------------------------------- 231 | -- Wrapping handler expressions in Dispatcher and DeferredDispatcher -- 232 | -------------------------------------------------------------------------------- 233 | 234 | -- | Constructs a 'call' handler from a function in the 'Process' monad. 235 | -- The handler expression returns the reply, and the action will be 236 | -- set to 'continue'. 237 | -- 238 | -- > handleCall_ = handleCallIf_ $ input (const True) 239 | -- 240 | handleCall_ :: (Serializable a, Serializable b) 241 | => (a -> Process b) 242 | -> Dispatcher s 243 | handleCall_ = handleCallIf_ $ input (const True) 244 | 245 | -- | Constructs a 'call' handler from an ordinary function in the 'Process' 246 | -- monad. This variant ignores the state argument present in 'handleCall' and 247 | -- 'handleCallIf' and is therefore useful in a stateless server. Messges are 248 | -- only dispatched to the handler if the supplied condition evaluates to @True@ 249 | -- 250 | -- See 'handleCall' 251 | handleCallIf_ :: forall s a b . (Serializable a, Serializable b) 252 | => Condition s a -- ^ predicate that must be satisfied for the handler to run 253 | -> (a -> Process b) -- ^ a function from an input message to a reply 254 | -> Dispatcher s 255 | handleCallIf_ cond handler 256 | = DispatchIf { 257 | dispatch = \s (CallMessage p c) -> handler p >>= mkCallReply c s 258 | , dispatchIf = checkCall cond 259 | } 260 | where 261 | -- handling 'reply-to' in the main process loop is awkward at best, 262 | -- so we handle it here instead and return the 'action' to the loop 263 | mkCallReply :: (Serializable b) 264 | => CallRef b 265 | -> s 266 | -> b 267 | -> Process (ProcessAction s) 268 | mkCallReply c s m = 269 | let (c', t) = unCaller c 270 | in sendTo c' (CallResponse m t) >> continue s 271 | 272 | -- | Constructs a 'call' handler from a function in the 'Process' monad. 273 | -- > handleCall = handleCallIf (const True) 274 | -- 275 | handleCall :: (Serializable a, Serializable b) 276 | => CallHandler s a b 277 | -> Dispatcher s 278 | handleCall = handleCallIf $ state (const True) 279 | 280 | -- | Constructs a 'call' handler from an ordinary function in the 'Process' 281 | -- monad. Given a function @f :: (s -> a -> Process (ProcessReply b s))@, 282 | -- the expression @handleCall f@ will yield a "Dispatcher" for inclusion 283 | -- in a 'Behaviour' specification for the /GenProcess/. Messages are only 284 | -- dispatched to the handler if the supplied condition evaluates to @True@. 285 | -- 286 | handleCallIf :: forall s a b . (Serializable a, Serializable b) 287 | => Condition s a -- ^ predicate that must be satisfied for the handler to run 288 | -> CallHandler s a b 289 | -- ^ a reply yielding function over the process state and input message 290 | -> Dispatcher s 291 | handleCallIf cond handler 292 | = DispatchIf 293 | { dispatch = \s (CallMessage p c) -> handler s p >>= mkReply c 294 | , dispatchIf = checkCall cond 295 | } 296 | 297 | -- | A variant of 'handleCallFrom_' that ignores the state argument. 298 | -- 299 | handleCallFrom_ :: forall s a b . (Serializable a, Serializable b) 300 | => StatelessCallHandler s a b 301 | -> Dispatcher s 302 | handleCallFrom_ = handleCallFromIf_ $ input (const True) 303 | 304 | -- | A variant of 'handleCallFromIf' that ignores the state argument. 305 | -- 306 | handleCallFromIf_ :: forall s a b . (Serializable a, Serializable b) 307 | => Condition s a 308 | -> StatelessCallHandler s a b 309 | -> Dispatcher s 310 | handleCallFromIf_ cond handler = 311 | DispatchIf { 312 | dispatch = \_ (CallMessage p c) -> handler c p >>= mkReply c 313 | , dispatchIf = checkCall cond 314 | } 315 | 316 | -- | As 'handleCall' but passes the 'CallRef' to the handler function. 317 | -- This can be useful if you wish to /reply later/ to the caller by, e.g., 318 | -- spawning a process to do some work and have it @replyTo caller response@ 319 | -- out of band. In this case the callback can pass the 'CallRef' to the 320 | -- worker (or stash it away itself) and return 'noReply'. 321 | -- 322 | handleCallFrom :: forall s a b . (Serializable a, Serializable b) 323 | => DeferredCallHandler s a b 324 | -> Dispatcher s 325 | handleCallFrom = handleCallFromIf $ state (const True) 326 | 327 | -- | As 'handleCallFrom' but only runs the handler if the supplied 'Condition' 328 | -- evaluates to @True@. 329 | -- 330 | handleCallFromIf :: forall s a b . (Serializable a, Serializable b) 331 | => Condition s a -- ^ predicate that must be satisfied for the handler to run 332 | -> DeferredCallHandler s a b 333 | -- ^ a reply yielding function over the process state, sender and input message 334 | -> Dispatcher s 335 | handleCallFromIf cond handler 336 | = DispatchIf { 337 | dispatch = \s (CallMessage p c) -> handler c s p >>= mkReply c 338 | , dispatchIf = checkCall cond 339 | } 340 | 341 | -- | Creates a handler for a /typed channel/ RPC style interaction. The 342 | -- handler takes a @SendPort b@ to reply to, the initial input and evaluates 343 | -- to a 'ProcessAction'. It is the handler code's responsibility to send the 344 | -- reply to the @SendPort@. 345 | -- 346 | handleRpcChan :: forall s a b . (Serializable a, Serializable b) 347 | => ChannelHandler s a b 348 | -> Dispatcher s 349 | handleRpcChan = handleRpcChanIf $ input (const True) 350 | 351 | -- | As 'handleRpcChan', but only evaluates the handler if the supplied 352 | -- condition is met. 353 | -- 354 | handleRpcChanIf :: forall s a b . (Serializable a, Serializable b) 355 | => Condition s a 356 | -> ChannelHandler s a b 357 | -> Dispatcher s 358 | handleRpcChanIf cond handler 359 | = DispatchIf { 360 | dispatch = \s (ChanMessage p c) -> handler c s p 361 | , dispatchIf = checkRpc cond 362 | } 363 | 364 | -- | A variant of 'handleRpcChan' that ignores the state argument. 365 | -- 366 | handleRpcChan_ :: forall s a b . (Serializable a, Serializable b) 367 | => StatelessChannelHandler s a b 368 | -- (SendPort b -> a -> (s -> Action s)) 369 | -> Dispatcher s 370 | handleRpcChan_ = handleRpcChanIf_ $ input (const True) 371 | 372 | -- | A variant of 'handleRpcChanIf' that ignores the state argument. 373 | -- 374 | handleRpcChanIf_ :: forall s a b . (Serializable a, Serializable b) 375 | => Condition s a 376 | -> StatelessChannelHandler s a b 377 | -> Dispatcher s 378 | handleRpcChanIf_ c h 379 | = DispatchIf { dispatch = \s ((ChanMessage m p) :: Message a b) -> h p m s 380 | , dispatchIf = checkRpc c 381 | } 382 | 383 | -- | Constructs a 'cast' handler from an ordinary function in the 'Process' 384 | -- monad. 385 | -- > handleCast = handleCastIf (const True) 386 | -- 387 | handleCast :: (Serializable a) 388 | => CastHandler s a 389 | -> Dispatcher s 390 | handleCast = handleCastIf $ input (const True) 391 | 392 | -- | Constructs a 'cast' handler from an ordinary function in the 'Process' 393 | -- monad. Given a function @f :: (s -> a -> Process (ProcessAction s))@, 394 | -- the expression @handleCall f@ will yield a 'Dispatcher' for inclusion 395 | -- in a 'Behaviour' specification for the /GenProcess/. 396 | -- 397 | handleCastIf :: forall s a . (Serializable a) 398 | => Condition s a -- ^ predicate that must be satisfied for the handler to run 399 | -> CastHandler s a 400 | -- ^ an action yielding function over the process state and input message 401 | -> Dispatcher s 402 | handleCastIf cond h 403 | = DispatchIf { 404 | dispatch = \s ((CastMessage p) :: Message a ()) -> h s p 405 | , dispatchIf = checkCast cond 406 | } 407 | 408 | -- | Creates a generic input handler for @STM@ actions, from an ordinary 409 | -- function in the 'Process' monad. The @STM a@ action tells the server how 410 | -- to read inputs, which when presented are passed to the handler in the same 411 | -- manner as @handleInfo@ messages would be. 412 | -- 413 | -- Note that messages sent to the server's mailbox will never match this 414 | -- handler, only data arriving via the @STM a@ action will. 415 | -- 416 | -- Notably, this kind of handler can be used to pass non-serialisable data to 417 | -- a server process. In such situations, the programmer is responsible for 418 | -- managing the underlying @STM@ infrastructure, and the server simply composes 419 | -- the @STM a@ action with the other reads on its mailbox, using the underlying 420 | -- @matchSTM@ API from distributed-process. 421 | -- 422 | -- NB: this function cannot be used with a prioristised process definition. 423 | -- 424 | handleExternal :: forall s a . (Serializable a) 425 | => STM a 426 | -> ActionHandler s a 427 | -> ExternDispatcher s 428 | handleExternal a h = 429 | let matchMsg' = matchSTM a (\(m :: r) -> return $ unsafeWrapMessage m) 430 | matchAny' f = matchSTM a (\(m :: r) -> return $ f (unsafeWrapMessage m)) in 431 | DispatchSTM 432 | { stmAction = a 433 | , dispatchStm = h 434 | , matchStm = matchMsg' 435 | , matchAnyStm = matchAny' 436 | } 437 | 438 | -- | Version of @handleExternal@ that ignores state. 439 | handleExternal_ :: forall s a . (Serializable a) 440 | => STM a 441 | -> StatelessHandler s a 442 | -> ExternDispatcher s 443 | handleExternal_ a h = handleExternal a (flip h) 444 | 445 | -- | Handle @call@ style API interactions using arbitrary /STM/ actions. 446 | -- 447 | -- The usual @CallHandler@ is preceded by an stm action that, when evaluated, 448 | -- yields a value, and a second expression that is used to send a reply back 449 | -- to the /caller/. The corrolary client API is /callSTM/. 450 | -- 451 | handleCallExternal :: forall s r w . (Serializable r) 452 | => STM r 453 | -> (w -> STM ()) 454 | -> CallHandler s r w 455 | -> ExternDispatcher s 456 | handleCallExternal reader writer handler = 457 | let matchMsg' = matchSTM reader (\(m :: r) -> return $ unsafeWrapMessage m) 458 | matchAny' f = matchSTM reader (\(m :: r) -> return $ f $ unsafeWrapMessage m) in 459 | DispatchSTM 460 | { stmAction = reader 461 | , dispatchStm = doStmReply handler 462 | , matchStm = matchMsg' 463 | , matchAnyStm = matchAny' 464 | } 465 | where 466 | doStmReply d s m = d s m >>= doXfmReply writer 467 | 468 | doXfmReply _ (NoReply a) = return a 469 | doXfmReply _ (ProcessReject _ a) = return a 470 | doXfmReply w (ProcessReply r' a) = liftIO (atomically $ w r') >> return a 471 | 472 | -- | Constructs a /control channel/ handler from a function in the 473 | -- 'Process' monad. The handler expression returns no reply, and the 474 | -- /control message/ is treated in the same fashion as a 'cast'. 475 | -- 476 | -- > handleControlChan = handleControlChanIf $ input (const True) 477 | -- 478 | handleControlChan :: forall s a . (Serializable a) 479 | => ControlChannel a -- ^ the receiving end of the control channel 480 | -> ActionHandler s a 481 | -- ^ an action yielding function over the process state and input message 482 | -> ExternDispatcher s 483 | handleControlChan chan h 484 | = DispatchCC { channel = snd $ unControl chan 485 | , dispatchChan = \s ((CastMessage p) :: Message a ()) -> h s p 486 | } 487 | 488 | -- | Version of 'handleControlChan' that ignores the server state. 489 | -- 490 | handleControlChan_ :: forall s a. (Serializable a) 491 | => ControlChannel a 492 | -> StatelessHandler s a 493 | -> ExternDispatcher s 494 | handleControlChan_ chan h 495 | = DispatchCC { channel = snd $ unControl chan 496 | , dispatchChan = \s ((CastMessage p) :: Message a ()) -> h p s 497 | } 498 | 499 | -- | Version of 'handleCast' that ignores the server state. 500 | -- 501 | handleCast_ :: (Serializable a) 502 | => StatelessHandler s a 503 | -> Dispatcher s 504 | handleCast_ = handleCastIf_ $ input (const True) 505 | 506 | -- | Version of 'handleCastIf' that ignores the server state. 507 | -- 508 | handleCastIf_ :: forall s a . (Serializable a) 509 | => Condition s a -- ^ predicate that must be satisfied for the handler to run 510 | -> StatelessHandler s a 511 | -- ^ a function from the input message to a /stateless action/, cf 'continue_' 512 | -> Dispatcher s 513 | handleCastIf_ cond h 514 | = DispatchIf { dispatch = \s ((CastMessage p) :: Message a ()) -> h p $ s 515 | , dispatchIf = checkCast cond 516 | } 517 | 518 | -- | Constructs an /action/ handler. Like 'handleDispatch' this can handle both 519 | -- 'cast' and 'call' messages, but you won't know which you're dealing with. 520 | -- This can be useful where certain inputs require a definite action, such as 521 | -- stopping the server, without concern for the state (e.g., when stopping we 522 | -- need only decide to stop, as the terminate handler can deal with state 523 | -- cleanup etc). For example: 524 | -- 525 | -- @action (\MyCriticalSignal -> stop_ ExitNormal)@ 526 | -- 527 | action :: forall s a . (Serializable a) 528 | => StatelessHandler s a 529 | -- ^ a function from the input message to a /stateless action/, cf 'continue_' 530 | -> Dispatcher s 531 | action h = handleDispatch perform 532 | where perform :: ActionHandler s a 533 | perform s a = let f = h a in f s 534 | 535 | -- | Constructs a handler for both /call/ and /cast/ messages. 536 | -- @handleDispatch = handleDispatchIf (const True)@ 537 | -- 538 | handleDispatch :: forall s a . (Serializable a) 539 | => ActionHandler s a 540 | -> Dispatcher s 541 | handleDispatch = handleDispatchIf $ input (const True) 542 | 543 | -- | Constructs a handler for both /call/ and /cast/ messages. Messages are only 544 | -- dispatched to the handler if the supplied condition evaluates to @True@. 545 | -- Handlers defined in this way have no access to the call context (if one 546 | -- exists) and cannot therefore reply to calls. 547 | -- 548 | handleDispatchIf :: forall s a . (Serializable a) 549 | => Condition s a 550 | -> ActionHandler s a 551 | -> Dispatcher s 552 | handleDispatchIf cond handler = DispatchIf { 553 | dispatch = doHandle handler 554 | , dispatchIf = check cond 555 | } 556 | where doHandle :: (Serializable a) 557 | => ActionHandler s a 558 | -> s 559 | -> Message a () 560 | -> Process (ProcessAction s) 561 | doHandle h s msg = 562 | case msg of 563 | (CallMessage p _) -> h s p 564 | (CastMessage p) -> h s p 565 | (ChanMessage p _) -> h s p 566 | 567 | -- | Creates a generic input handler (i.e., for received messages that are /not/ 568 | -- sent using the 'cast' or 'call' APIs) from an ordinary function in the 569 | -- 'Process' monad. 570 | handleInfo :: forall s a. (Serializable a) 571 | => ActionHandler s a 572 | -> DeferredDispatcher s 573 | handleInfo h = DeferredDispatcher { dispatchInfo = doHandleInfo h } 574 | where 575 | doHandleInfo :: forall s2 a2. (Serializable a2) 576 | => ActionHandler s2 a2 577 | -> s2 578 | -> P.Message 579 | -> Process (Maybe (ProcessAction s2)) 580 | doHandleInfo h' s msg = handleMessage msg (h' s) 581 | 582 | -- | Handle completely /raw/ input messages. 583 | -- 584 | handleRaw :: forall s. ActionHandler s P.Message 585 | -> DeferredDispatcher s 586 | handleRaw h = DeferredDispatcher { dispatchInfo = doHandle h } 587 | where 588 | doHandle h' s msg = fmap Just (h' s msg) 589 | 590 | -- | Creates an /exit handler/ scoped to the execution of any and all the 591 | -- registered call, cast and info handlers for the process. 592 | handleExit :: forall s a. (Serializable a) 593 | => (ProcessId -> ActionHandler s a) 594 | -> ExitSignalDispatcher s 595 | handleExit h = ExitSignalDispatcher { dispatchExit = doHandleExit h } 596 | where 597 | doHandleExit :: (ProcessId -> ActionHandler s a) 598 | -> s 599 | -> ProcessId 600 | -> P.Message 601 | -> Process (Maybe (ProcessAction s)) 602 | doHandleExit h' s p msg = handleMessage msg (h' p s) 603 | 604 | -- | Conditional version of @handleExit@ 605 | handleExitIf :: forall s a . (Serializable a) 606 | => (s -> a -> Bool) 607 | -> (ProcessId -> ActionHandler s a) 608 | -> ExitSignalDispatcher s 609 | handleExitIf c h = ExitSignalDispatcher { dispatchExit = doHandleExit c h } 610 | where 611 | doHandleExit :: (s -> a -> Bool) 612 | -> (ProcessId -> ActionHandler s a) 613 | -> s 614 | -> ProcessId 615 | -> P.Message 616 | -> Process (Maybe (ProcessAction s)) 617 | doHandleExit c' h' s p msg = handleMessageIf msg (c' s) (h' p s) 618 | 619 | -- handling 'reply-to' in the main process loop is awkward at best, 620 | -- so we handle it here instead and return the 'action' to the loop 621 | mkReply :: (Serializable b) 622 | => CallRef b 623 | -> ProcessReply b s 624 | -> Process (ProcessAction s) 625 | mkReply cRef act 626 | | (NoReply a) <- act = return a 627 | | (CallRef (_, tg')) <- cRef 628 | , (ProcessReply r' a) <- act = sendTo cRef (CallResponse r' tg') >> return a 629 | | (CallRef (_, ct')) <- cRef 630 | , (ProcessReject r' a) <- act = sendTo cRef (CallRejected r' ct') >> return a 631 | | otherwise = die $ ExitOther "mkReply.InvalidState" 632 | 633 | -- these functions are the inverse of 'condition', 'state' and 'input' 634 | 635 | check :: forall s m a . (Serializable m) 636 | => Condition s m 637 | -> s 638 | -> Message m a 639 | -> Bool 640 | check (Condition c) st msg = c st $ decode msg 641 | check (State c) st _ = c st 642 | check (Input c) _ msg = c $ decode msg 643 | 644 | checkRpc :: forall s m a . (Serializable m) 645 | => Condition s m 646 | -> s 647 | -> Message m a 648 | -> Bool 649 | checkRpc cond st msg@(ChanMessage _ _) = check cond st msg 650 | checkRpc _ _ _ = False 651 | 652 | checkCall :: forall s m a . (Serializable m) 653 | => Condition s m 654 | -> s 655 | -> Message m a 656 | -> Bool 657 | checkCall cond st msg@(CallMessage _ _) = check cond st msg 658 | checkCall _ _ _ = False 659 | 660 | checkCast :: forall s m . (Serializable m) 661 | => Condition s m 662 | -> s 663 | -> Message m () 664 | -> Bool 665 | checkCast cond st msg@(CastMessage _) = check cond st msg 666 | checkCast _ _ _ = False 667 | 668 | decode :: Message a b -> a 669 | decode (CallMessage a _) = a 670 | decode (CastMessage a) = a 671 | decode (ChanMessage a _) = a 672 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/ManagedProcess/Server/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE PatternGuards #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE EmptyDataDecls #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE AllowAmbiguousTypes #-} 8 | 9 | ----------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Control.Distributed.Process.ManagedProcess.Server.Priority 12 | -- Copyright : (c) Tim Watson 2012 - 2017 13 | -- License : BSD3 (see the file LICENSE) 14 | -- 15 | -- Maintainer : Tim Watson 16 | -- Stability : experimental 17 | -- Portability : non-portable (requires concurrency) 18 | -- 19 | -- The Server Portion of the /Managed Process/ API, as presented by the 20 | -- 'GenProcess' monad. These functions are generally intended for internal 21 | -- use, but the API is relatively stable and therefore they have been re-exported 22 | -- here for general use. Note that if you modify a process' internal state 23 | -- (especially that of the internal priority queue) then you are responsible for 24 | -- any alteratoin that makes to the semantics of your processes behaviour. 25 | -- 26 | -- See "Control.Distributed.Process.ManagedProcess.Internal.GenProcess" 27 | ----------------------------------------------------------------------------- 28 | module Control.Distributed.Process.ManagedProcess.Server.Gen 29 | ( -- * Server actions 30 | reply 31 | , replyWith 32 | , noReply 33 | , continue 34 | , timeoutAfter 35 | , hibernate 36 | , stop 37 | , reject 38 | , rejectWith 39 | , become 40 | , haltNoReply 41 | , lift 42 | , Gen.recvLoop 43 | , Gen.precvLoop 44 | , Gen.currentTimeout 45 | , Gen.systemTimeout 46 | , Gen.drainTimeout 47 | , Gen.processState 48 | , Gen.processDefinition 49 | , Gen.processFilters 50 | , Gen.processUnhandledMsgPolicy 51 | , Gen.processQueue 52 | , Gen.gets 53 | , Gen.getAndModifyState 54 | , Gen.modifyState 55 | , Gen.setUserTimeout 56 | , Gen.setProcessState 57 | , GenProcess 58 | , Gen.peek 59 | , Gen.push 60 | , Gen.enqueue 61 | , Gen.dequeue 62 | , Gen.addUserTimer 63 | , Gen.removeUserTimer 64 | , Gen.eval 65 | , Gen.act 66 | , Gen.runAfter 67 | , Gen.evalAfter 68 | ) where 69 | 70 | import Control.Distributed.Process.Extras 71 | ( ExitReason 72 | ) 73 | import Control.Distributed.Process.Extras.Time 74 | ( TimeInterval 75 | , Delay 76 | ) 77 | import Control.Distributed.Process.ManagedProcess.Internal.Types 78 | ( lift 79 | , ProcessAction(..) 80 | , GenProcess 81 | , ProcessReply(..) 82 | , ProcessDefinition 83 | ) 84 | import qualified Control.Distributed.Process.ManagedProcess.Internal.GenProcess as Gen 85 | ( recvLoop 86 | , precvLoop 87 | , currentTimeout 88 | , systemTimeout 89 | , drainTimeout 90 | , processState 91 | , processDefinition 92 | , processFilters 93 | , processUnhandledMsgPolicy 94 | , processQueue 95 | , gets 96 | , getAndModifyState 97 | , modifyState 98 | , setUserTimeout 99 | , setProcessState 100 | , GenProcess 101 | , peek 102 | , push 103 | , enqueue 104 | , dequeue 105 | , addUserTimer 106 | , removeUserTimer 107 | , eval 108 | , act 109 | , runAfter 110 | , evalAfter 111 | ) 112 | import Control.Distributed.Process.ManagedProcess.Internal.GenProcess 113 | ( processState 114 | ) 115 | import qualified Control.Distributed.Process.ManagedProcess.Server as Server 116 | ( replyWith 117 | , continue 118 | ) 119 | import Control.Distributed.Process.Serializable (Serializable) 120 | 121 | -- | Reject the message we're currently handling. 122 | reject :: forall r s . String -> GenProcess s (ProcessReply r s) 123 | reject rs = processState >>= \st -> lift $ Server.continue st >>= return . ProcessReject rs 124 | 125 | -- | Reject the message we're currently handling, giving an explicit reason. 126 | rejectWith :: forall r m s . (Show r) => r -> GenProcess s (ProcessReply m s) 127 | rejectWith rs = reject (show rs) 128 | 129 | -- | Instructs the process to send a reply and continue running. 130 | reply :: forall r s . (Serializable r) => r -> GenProcess s (ProcessReply r s) 131 | reply r = processState >>= \s -> lift $ Server.continue s >>= Server.replyWith r 132 | 133 | -- | Instructs the process to send a reply /and/ evaluate the 'ProcessAction'. 134 | replyWith :: forall r s . (Serializable r) 135 | => r 136 | -> ProcessAction s 137 | -> GenProcess s (ProcessReply r s) 138 | replyWith r s = return $ ProcessReply r s 139 | 140 | -- | Instructs the process to skip sending a reply /and/ evaluate a 'ProcessAction' 141 | noReply :: (Serializable r) => ProcessAction s -> GenProcess s (ProcessReply r s) 142 | noReply = return . NoReply 143 | 144 | -- | Halt process execution during a call handler, without paying any attention 145 | -- to the expected return type. 146 | haltNoReply :: forall s r . Serializable r => ExitReason -> GenProcess s (ProcessReply r s) 147 | haltNoReply r = stop r >>= noReply 148 | 149 | -- | Instructs the process to continue running and receiving messages. 150 | continue :: GenProcess s (ProcessAction s) 151 | continue = processState >>= return . ProcessContinue 152 | 153 | -- | Instructs the process loop to wait for incoming messages until 'Delay' 154 | -- is exceeded. If no messages are handled during this period, the /timeout/ 155 | -- handler will be called. Note that this alters the process timeout permanently 156 | -- such that the given @Delay@ will remain in use until changed. 157 | -- 158 | -- Note that @timeoutAfter NoDelay@ will cause the timeout handler to execute 159 | -- immediately if no messages are present in the process' mailbox. 160 | -- 161 | timeoutAfter :: Delay -> GenProcess s (ProcessAction s) 162 | timeoutAfter d = processState >>= \s -> return $ ProcessTimeout d s 163 | 164 | -- | Instructs the process to /hibernate/ for the given 'TimeInterval'. Note 165 | -- that no messages will be removed from the mailbox until after hibernation has 166 | -- ceased. This is equivalent to calling @threadDelay@. 167 | -- 168 | hibernate :: TimeInterval -> GenProcess s (ProcessAction s) 169 | hibernate d = processState >>= \s -> return $ ProcessHibernate d s 170 | 171 | -- | The server loop will execute against the supplied 'ProcessDefinition', allowing 172 | -- the process to change its behaviour (in terms of message handlers, exit handling, 173 | -- termination, unhandled message policy, etc) 174 | become :: forall s . ProcessDefinition s -> GenProcess s (ProcessAction s) 175 | become def = processState >>= \st -> return $ ProcessBecome def st 176 | 177 | -- | Instructs the process to terminate, giving the supplied reason. If a valid 178 | -- 'shutdownHandler' is installed, it will be called with the 'ExitReason' 179 | -- returned from this call, along with the process state. 180 | stop :: ExitReason -> GenProcess s (ProcessAction s) 181 | stop r = return $ ProcessStop r 182 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/ManagedProcess/Server/Priority.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE PatternGuards #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE EmptyDataDecls #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE AllowAmbiguousTypes #-} 8 | 9 | ----------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Control.Distributed.Process.ManagedProcess.Server.Priority 12 | -- Copyright : (c) Tim Watson 2012 - 2017 13 | -- License : BSD3 (see the file LICENSE) 14 | -- 15 | -- Maintainer : Tim Watson 16 | -- Stability : experimental 17 | -- Portability : non-portable (requires concurrency) 18 | -- 19 | -- The Prioritised Server portion of the /Managed Process/ API. 20 | ----------------------------------------------------------------------------- 21 | module Control.Distributed.Process.ManagedProcess.Server.Priority 22 | ( -- * Prioritising API Handlers 23 | prioritiseCall 24 | , prioritiseCall_ 25 | , prioritiseCast 26 | , prioritiseCast_ 27 | , prioritiseInfo 28 | , prioritiseInfo_ 29 | , setPriority 30 | -- * Creating Filters 31 | , check 32 | , raw 33 | , raw_ 34 | , api 35 | , api_ 36 | , info 37 | , info_ 38 | , refuse 39 | , reject 40 | , rejectApi 41 | , store 42 | , storeM 43 | , crash 44 | , ensure 45 | , ensureM 46 | , Filter() 47 | , DispatchFilter() 48 | , safe 49 | , apiSafe 50 | , safely 51 | , Message() 52 | , evalAfter 53 | , currentTimeout 54 | , processState 55 | , processDefinition 56 | , processFilters 57 | , processUnhandledMsgPolicy 58 | , setUserTimeout 59 | , setProcessState 60 | , GenProcess 61 | , peek 62 | , push 63 | , addUserTimer 64 | , act 65 | , runAfter 66 | ) where 67 | 68 | import Control.Distributed.Process hiding (call, Message) 69 | import qualified Control.Distributed.Process as P (Message) 70 | import Control.Distributed.Process.Extras 71 | ( ExitReason(..) 72 | ) 73 | import Control.Distributed.Process.ManagedProcess.Internal.GenProcess 74 | ( addUserTimer 75 | , currentTimeout 76 | , processState 77 | , processDefinition 78 | , processFilters 79 | , processUnhandledMsgPolicy 80 | , setUserTimeout 81 | , setProcessState 82 | , GenProcess 83 | , peek 84 | , push 85 | , evalAfter 86 | , act 87 | , runAfter 88 | ) 89 | import Control.Distributed.Process.ManagedProcess.Internal.Types 90 | import Control.Distributed.Process.Serializable 91 | import Prelude hiding (init) 92 | 93 | -- | Sent to a caller in cases where the server is rejecting an API input and 94 | -- a @Recipient@ is available (i.e. a /call/ message handling filter). 95 | data RejectedByServer = RejectedByServer deriving (Show) 96 | 97 | -- | Represents a pair of expressions that can be used to define a @DispatchFilter@. 98 | data FilterHandler s = 99 | forall m . (Serializable m) => 100 | HandlePure 101 | { 102 | pureCheck :: s -> m -> Process Bool 103 | , handler :: s -> m -> Process (Filter s) 104 | } -- ^ A pure handler, usable where the target handler is based on @handleInfo@ 105 | | forall m b . (Serializable m, Serializable b) => 106 | HandleApi 107 | { 108 | apiCheck :: s -> m -> Process Bool 109 | , apiHandler :: s -> Message m b -> Process (Filter s) 110 | } -- ^ An API handler, usable where the target handler is based on @handle{Call, Cast, RpcChan}@ 111 | | HandleRaw 112 | { 113 | rawCheck :: s -> P.Message -> Process Bool 114 | , rawHandler :: s -> P.Message -> Process (Maybe (Filter s)) 115 | } -- ^ A raw handler, usable where the target handler is based on @handleRaw@ 116 | | HandleState { stateHandler :: s -> Process (Maybe (Filter s)) } 117 | | HandleSafe 118 | { 119 | safeCheck :: s -> P.Message -> Process Bool 120 | } -- ^ A safe wrapper 121 | 122 | {- 123 | check :: forall c s m . (Check c s m) 124 | => c -> (s -> Process (Filter s)) -> s -> m -> Process (Filter s) 125 | -} 126 | 127 | -- | Create a filter from a @FilterHandler@. 128 | check :: forall s . FilterHandler s -> DispatchFilter s 129 | check h 130 | | HandlePure{..} <- h = FilterAny $ \s m -> pureCheck s m >>= procUnless s m handler 131 | | HandleRaw{..} <- h = FilterRaw $ \s m -> do 132 | c <- rawCheck s m 133 | if c then return $ Just $ FilterOk s 134 | else rawHandler s m 135 | | HandleState{..} <- h = FilterState stateHandler 136 | | HandleApi{..} <- h = FilterApi $ \s m@(CallMessage m' _) -> do 137 | c <- apiCheck s m' 138 | if c then return $ FilterOk s 139 | else apiHandler s m 140 | | HandleSafe{..} <- h = FilterRaw $ \s m -> do 141 | c <- safeCheck s m 142 | let ctr = if c then FilterSafe else FilterOk 143 | return $ Just $ ctr s 144 | 145 | where 146 | procUnless s _ _ True = return $ FilterOk s 147 | procUnless s m h' False = h' s m 148 | 149 | -- | A raw filter (targetting raw messages). 150 | raw :: forall s . 151 | (s -> P.Message -> Process Bool) 152 | -> (s -> P.Message -> Process (Maybe (Filter s))) 153 | -> FilterHandler s 154 | raw = HandleRaw 155 | 156 | -- | A raw filter that ignores the server state in its condition expression. 157 | raw_ :: forall s . 158 | (P.Message -> Process Bool) 159 | -> (s -> P.Message -> Process (Maybe (Filter s))) 160 | -> FilterHandler s 161 | raw_ c h = raw (const $ c) h 162 | 163 | -- | An API filter (targetting /call/, /cast/, and /chan/ messages). 164 | api :: forall s m b . (Serializable m, Serializable b) 165 | => (s -> m -> Process Bool) 166 | -> (s -> Message m b -> Process (Filter s)) 167 | -> FilterHandler s 168 | api = HandleApi 169 | 170 | -- | An API filter that ignores the server state in its condition expression. 171 | api_ :: forall m b s . (Serializable m, Serializable b) 172 | => (m -> Process Bool) 173 | -> (s -> Message m b -> Process (Filter s)) 174 | -> FilterHandler s 175 | api_ c h = api (const $ c) h 176 | 177 | -- | An info filter (targetting info messages of a specific type) 178 | info :: forall s m . (Serializable m) 179 | => (s -> m -> Process Bool) 180 | -> (s -> m -> Process (Filter s)) 181 | -> FilterHandler s 182 | info = HandlePure 183 | 184 | -- | An info filter that ignores the server state in its condition expression. 185 | info_ :: forall s m . (Serializable m) 186 | => (m -> Process Bool) 187 | -> (s -> m -> Process (Filter s)) 188 | -> FilterHandler s 189 | info_ c h = info (const $ c) h 190 | 191 | -- | As 'safe', but as applied to api messages (i.e. those originating from 192 | -- call as cast client interactions). 193 | apiSafe :: forall s m b . (Serializable m, Serializable b) 194 | => (s -> m -> Maybe b -> Bool) 195 | -> DispatchFilter s 196 | apiSafe c = check $ HandleSafe (go c) 197 | where 198 | go c' s (i :: P.Message) = do 199 | m <- unwrapMessage i :: Process (Maybe (Message m b)) 200 | case m of 201 | Just (CallMessage m' _) -> return $ c' s m' Nothing 202 | Just (CastMessage m') -> return $ c' s m' Nothing 203 | Just (ChanMessage m' _) -> return $ c' s m' Nothing 204 | Nothing -> return False 205 | 206 | -- | Given a check expression, if it evaluates to @True@ for some input, 207 | -- then do not dequeue the message until after any matching handlers have 208 | -- successfully run, or the the unhandled message policy is chosen if none match. 209 | -- Thus, if an exit signal (async exception) terminates execution of a handler, and we 210 | -- have an installed exit handler which allows the process to continue running, 211 | -- we will retry the input in question since it has not been fully dequeued prior 212 | -- to the exit signal arriving. 213 | safe :: forall s m . (Serializable m) 214 | => (s -> m -> Bool) 215 | -> DispatchFilter s 216 | safe c = check $ HandleSafe (go c) 217 | where 218 | go c' s (i :: P.Message) = do 219 | m <- unwrapMessage i :: Process (Maybe m) 220 | case m of 221 | Just m' -> return $ c' s m' 222 | Nothing -> return False 223 | 224 | -- | As 'safe', but matches on a raw message. 225 | safely :: forall s . (s -> P.Message -> Bool) -> DispatchFilter s 226 | safely c = check $ HandleSafe $ \s m -> return (c s m) 227 | 228 | -- | Create a filter expression that will reject all messages of a specific type. 229 | reject :: forall s m r . (Show r) 230 | => r -> s -> m -> Process (Filter s) 231 | reject r = \s _ -> do return $ FilterReject (show r) s 232 | 233 | -- | Create a filter expression that will crash (i.e. stop) the server. 234 | crash :: forall s . s -> ExitReason -> Process (Filter s) 235 | crash s r = return $ FilterStop s r 236 | 237 | -- | A version of @reject@ that deals with API messages (i.e. /call/, /cast/, etc) 238 | -- and in the case of a /call/ interaction, will reject the messages and reply to 239 | -- the sender accordingly (with @CallRejected@). 240 | rejectApi :: forall s m b r . (Show r, Serializable m, Serializable b) 241 | => r -> s -> Message m b -> Process (Filter s) 242 | rejectApi r = \s m -> do let r' = show r 243 | rejectToCaller m r' 244 | return $ FilterSkip s 245 | 246 | -- | Modify the server state every time a message is recieved. 247 | store :: (s -> s) -> DispatchFilter s 248 | store f = FilterState $ return . Just . FilterOk . f 249 | 250 | -- | Motify the server state when messages of a certain type arrive... 251 | storeM :: forall s m . (Serializable m) 252 | => (s -> m -> Process s) 253 | -> DispatchFilter s 254 | storeM proc = check $ HandlePure (\_ _ -> return True) 255 | (\s m -> proc s m >>= return . FilterOk) 256 | 257 | -- | Refuse messages for which the given expression evaluates to @True@. 258 | refuse :: forall s m . (Serializable m) 259 | => (m -> Bool) 260 | -> DispatchFilter s 261 | refuse c = check $ info (const $ \m -> return $ c m) (reject RejectedByServer) 262 | 263 | {- 264 | apiCheck :: forall s m r . (Serializable m, Serializable r) 265 | => (s -> Message m r -> Bool) 266 | -> (s -> Message m r -> Process (Filter s)) 267 | -> DispatchFilter s 268 | apiCheck c h = checkM (\s m -> return $ c s m) h 269 | -} 270 | 271 | -- | Ensure that the server state is consistent with the given expression each 272 | -- time a message arrives/is processed. If the expression evaluates to @True@ 273 | -- then the filter will evaluate to "FilterOk", otherwise "FilterStop" (which 274 | -- will cause the server loop to stop with @ExitOther filterFail@). 275 | ensure :: forall s . (s -> Bool) -> DispatchFilter s 276 | ensure c = 277 | check $ HandleState { stateHandler = (\s -> if c s 278 | then return $ Just $ FilterOk s 279 | else return $ Just $ FilterStop s filterFail) 280 | } 281 | -- | As @ensure@ but runs in the @Process@ monad, and matches only inputs of type @m@. 282 | ensureM :: forall s m . (Serializable m) => (s -> m -> Process Bool) -> DispatchFilter s 283 | ensureM c = 284 | check $ HandlePure { pureCheck = c 285 | , handler = (\s _ -> return $ FilterStop s filterFail) :: s -> m -> Process (Filter s) 286 | } 287 | 288 | -- TODO: add the type rep for a more descriptive failure message 289 | 290 | filterFail :: ExitReason 291 | filterFail = ExitOther "Control.Distributed.Process.ManagedProcess.Priority:FilterFailed" 292 | 293 | -- | Sets an explicit priority from 1..100. Values > 100 are rounded to 100, 294 | -- and values < 1 are set to 0. 295 | setPriority :: Int -> Priority m 296 | setPriority n 297 | | n < 1 = Priority 0 298 | | n > 100 = Priority 100 299 | | otherwise = Priority n 300 | 301 | -- | Prioritise a call handler, ignoring the server's state 302 | prioritiseCall_ :: forall s a b . (Serializable a, Serializable b) 303 | => (a -> Priority b) 304 | -> DispatchPriority s 305 | prioritiseCall_ h = prioritiseCall (const h) 306 | 307 | -- | Prioritise a call handler 308 | prioritiseCall :: forall s a b . (Serializable a, Serializable b) 309 | => (s -> a -> Priority b) 310 | -> DispatchPriority s 311 | prioritiseCall h = PrioritiseCall (unCall . h) 312 | where 313 | unCall :: (a -> Priority b) -> P.Message -> Process (Maybe (Int, P.Message)) 314 | unCall h' m = fmap (matchPrioritise m h') (unwrapMessage m) 315 | 316 | matchPrioritise :: P.Message 317 | -> (a -> Priority b) 318 | -> Maybe (Message a b) 319 | -> Maybe (Int, P.Message) 320 | matchPrioritise msg p msgIn 321 | | (Just a@(CallMessage m _)) <- msgIn 322 | , True <- isEncoded msg = Just (getPrio $ p m, wrapMessage a) 323 | | (Just (CallMessage m _)) <- msgIn 324 | , False <- isEncoded msg = Just (getPrio $ p m, msg) 325 | | otherwise = Nothing 326 | 327 | -- | Prioritise a cast handler, ignoring the server's state 328 | prioritiseCast_ :: forall s a . (Serializable a) 329 | => (a -> Priority ()) 330 | -> DispatchPriority s 331 | prioritiseCast_ h = prioritiseCast (const h) 332 | 333 | -- | Prioritise a cast handler 334 | prioritiseCast :: forall s a . (Serializable a) 335 | => (s -> a -> Priority ()) 336 | -> DispatchPriority s 337 | prioritiseCast h = PrioritiseCast (unCast . h) 338 | where 339 | unCast :: (a -> Priority ()) -> P.Message -> Process (Maybe (Int, P.Message)) 340 | unCast h' m = fmap (matchPrioritise m h') (unwrapMessage m) 341 | 342 | matchPrioritise :: P.Message 343 | -> (a -> Priority ()) 344 | -> Maybe (Message a ()) 345 | -> Maybe (Int, P.Message) 346 | matchPrioritise msg p msgIn 347 | | (Just a@(CastMessage m)) <- msgIn 348 | , True <- isEncoded msg = Just (getPrio $ p m, wrapMessage a) 349 | | (Just (CastMessage m)) <- msgIn 350 | , False <- isEncoded msg = Just (getPrio $ p m, msg) 351 | | otherwise = Nothing 352 | 353 | -- | Prioritise an info handler, ignoring the server's state 354 | prioritiseInfo_ :: forall s a . (Serializable a) 355 | => (a -> Priority ()) 356 | -> DispatchPriority s 357 | prioritiseInfo_ h = prioritiseInfo (const h) 358 | 359 | -- | Prioritise an info handler 360 | prioritiseInfo :: forall s a . (Serializable a) 361 | => (s -> a -> Priority ()) 362 | -> DispatchPriority s 363 | prioritiseInfo h = PrioritiseInfo (unMsg . h) 364 | where 365 | unMsg :: (a -> Priority ()) -> P.Message -> Process (Maybe (Int, P.Message)) 366 | unMsg h' m = fmap (matchPrioritise m h') (unwrapMessage m) 367 | 368 | matchPrioritise :: P.Message 369 | -> (a -> Priority ()) 370 | -> Maybe a 371 | -> Maybe (Int, P.Message) 372 | matchPrioritise msg p msgIn 373 | | (Just m') <- msgIn 374 | , True <- isEncoded msg = Just (getPrio $ p m', wrapMessage m') 375 | | (Just m') <- msgIn 376 | , False <- isEncoded msg = Just (getPrio $ p m', msg) 377 | | otherwise = Nothing 378 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/ManagedProcess/Server/Restricted.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Control.Distributed.Process.ManagedProcess.Server.Restricted 9 | -- Copyright : (c) Tim Watson 2012 - 2017 10 | -- License : BSD3 (see the file LICENSE) 11 | -- 12 | -- Maintainer : Tim Watson 13 | -- Stability : experimental 14 | -- Portability : non-portable (requires concurrency) 15 | -- 16 | -- A /safe/ variant of the Server Portion of the /Managed Process/ API. Most 17 | -- of these operations have the same names as similar operations in the impure 18 | -- @Server@ module (re-exported by the primary API in @ManagedProcess@). To 19 | -- remove the ambiguity, some combination of either qualification and/or the 20 | -- @hiding@ clause will be required. 21 | -- 22 | -- [Restricted Server Callbacks] 23 | -- 24 | -- The idea behind this module is to provide /safe/ callbacks, i.e., server 25 | -- code that is free from side effects. This safety is enforced by the type 26 | -- system via the @RestrictedProcess@ monad. A StateT interface is provided 27 | -- for code running in the @RestrictedProcess@ monad, so that server side 28 | -- state can be managed safely without resorting to IO (or code running in 29 | -- the @Process@ monad). 30 | -- 31 | ----------------------------------------------------------------------------- 32 | 33 | module Control.Distributed.Process.ManagedProcess.Server.Restricted 34 | ( -- * Exported Types 35 | RestrictedProcess 36 | , Result(..) 37 | , RestrictedAction(..) 38 | -- * Creating call/cast protocol handlers 39 | , handleCall 40 | , handleCallIf 41 | , handleCast 42 | , handleCastIf 43 | , handleInfo 44 | , handleExit 45 | , handleTimeout 46 | -- * Handling Process State 47 | , putState 48 | , getState 49 | , modifyState 50 | -- * Handling responses/transitions 51 | , reply 52 | , noReply 53 | , haltNoReply 54 | , continue 55 | , timeoutAfter 56 | , hibernate 57 | , stop 58 | -- * Utilities 59 | , say 60 | ) where 61 | 62 | import Control.Distributed.Process hiding (call, say) 63 | import qualified Control.Distributed.Process as P (say) 64 | import Control.Distributed.Process.Extras 65 | (ExitReason(..)) 66 | import Control.Distributed.Process.ManagedProcess.Internal.Types hiding (lift) 67 | import qualified Control.Distributed.Process.ManagedProcess.Server as Server 68 | import Control.Distributed.Process.Extras.Time 69 | import Control.Distributed.Process.Serializable 70 | import Prelude hiding (init) 71 | 72 | import Control.Monad.IO.Class (MonadIO) 73 | import qualified Control.Monad.State as ST 74 | ( MonadState 75 | , StateT 76 | , get 77 | , lift 78 | , modify 79 | , put 80 | , runStateT 81 | ) 82 | 83 | import Data.Typeable 84 | 85 | -- | Restricted (i.e., pure, free from side effects) execution 86 | -- environment for call/cast/info handlers to execute in. 87 | -- 88 | newtype RestrictedProcess s a = RestrictedProcess { 89 | unRestricted :: ST.StateT s Process a 90 | } 91 | deriving (Functor, Monad, ST.MonadState s, MonadIO, Typeable, Applicative) 92 | 93 | -- | The result of a 'call' handler's execution. 94 | data Result a = 95 | Reply a -- ^ reply with the given term 96 | | Timeout Delay a -- ^ reply with the given term and enter timeout 97 | | Hibernate TimeInterval a -- ^ reply with the given term and hibernate 98 | | Stop ExitReason -- ^ stop the process with the given reason 99 | deriving (Typeable) 100 | 101 | -- | The result of a safe 'cast' handler's execution. 102 | data RestrictedAction = 103 | RestrictedContinue -- ^ continue executing 104 | | RestrictedTimeout Delay -- ^ timeout if no messages are received 105 | | RestrictedHibernate TimeInterval -- ^ hibernate (i.e., sleep) 106 | | RestrictedStop ExitReason -- ^ stop/terminate the server process 107 | 108 | -------------------------------------------------------------------------------- 109 | -- Handling state in RestrictedProcess execution environments -- 110 | -------------------------------------------------------------------------------- 111 | 112 | -- | Log a trace message using the underlying Process's @say@ 113 | say :: String -> RestrictedProcess s () 114 | say = lift . P.say 115 | 116 | -- | Get the current process state 117 | getState :: RestrictedProcess s s 118 | getState = ST.get 119 | 120 | -- | Put a new process state state 121 | putState :: s -> RestrictedProcess s () 122 | putState = ST.put 123 | 124 | -- | Apply the given expression to the current process state 125 | modifyState :: (s -> s) -> RestrictedProcess s () 126 | modifyState = ST.modify 127 | 128 | -------------------------------------------------------------------------------- 129 | -- Generating replies and state transitions inside RestrictedProcess -- 130 | -------------------------------------------------------------------------------- 131 | 132 | -- | Instructs the process to send a reply and continue running. 133 | reply :: forall s r . (Serializable r) => r -> RestrictedProcess s (Result r) 134 | reply = return . Reply 135 | 136 | -- | Continue without giving a reply to the caller - equivalent to 'continue', 137 | -- but usable in a callback passed to the 'handleCall' family of functions. 138 | noReply :: forall s r . (Serializable r) 139 | => Result r 140 | -> RestrictedProcess s (Result r) 141 | noReply = return 142 | 143 | -- | Halt process execution during a call handler, without paying any attention 144 | -- to the expected return type. 145 | haltNoReply :: forall s r . (Serializable r) 146 | => ExitReason 147 | -> RestrictedProcess s (Result r) 148 | haltNoReply r = noReply (Stop r) 149 | 150 | -- | Instructs the process to continue running and receiving messages. 151 | continue :: forall s . RestrictedProcess s RestrictedAction 152 | continue = return RestrictedContinue 153 | 154 | -- | Instructs the process loop to wait for incoming messages until 'Delay' 155 | -- is exceeded. If no messages are handled during this period, the /timeout/ 156 | -- handler will be called. Note that this alters the process timeout permanently 157 | -- such that the given @Delay@ will remain in use until changed. 158 | timeoutAfter :: forall s. Delay -> RestrictedProcess s RestrictedAction 159 | timeoutAfter d = return $ RestrictedTimeout d 160 | 161 | -- | Instructs the process to /hibernate/ for the given 'TimeInterval'. Note 162 | -- that no messages will be removed from the mailbox until after hibernation has 163 | -- ceased. This is equivalent to evaluating @liftIO . threadDelay@. 164 | -- 165 | hibernate :: forall s. TimeInterval -> RestrictedProcess s RestrictedAction 166 | hibernate d = return $ RestrictedHibernate d 167 | 168 | -- | Instructs the process to terminate, giving the supplied reason. If a valid 169 | -- 'shutdownHandler' is installed, it will be called with the 'ExitReason' 170 | -- returned from this call, along with the process state. 171 | stop :: forall s. ExitReason -> RestrictedProcess s RestrictedAction 172 | stop r = return $ RestrictedStop r 173 | 174 | -------------------------------------------------------------------------------- 175 | -- Wrapping handler expressions in Dispatcher and DeferredDispatcher -- 176 | -------------------------------------------------------------------------------- 177 | 178 | -- | A version of "Control.Distributed.Process.ManagedProcess.Server.handleCall" 179 | -- that takes a handler which executes in 'RestrictedProcess'. 180 | -- 181 | handleCall :: forall s a b . (Serializable a, Serializable b) 182 | => (a -> RestrictedProcess s (Result b)) 183 | -> Dispatcher s 184 | handleCall = handleCallIf $ Server.state (const True) 185 | 186 | -- | A version of "Control.Distributed.Process.ManagedProcess.Server.handleCallIf" 187 | -- that takes a handler which executes in 'RestrictedProcess'. 188 | -- 189 | handleCallIf :: forall s a b . (Serializable a, Serializable b) 190 | => Condition s a 191 | -> (a -> RestrictedProcess s (Result b)) 192 | -> Dispatcher s 193 | handleCallIf cond h = Server.handleCallIf cond (wrapCall h) 194 | 195 | -- | A version of "Control.Distributed.Process.ManagedProcess.Server.handleCast" 196 | -- that takes a handler which executes in 'RestrictedProcess'. 197 | -- 198 | handleCast :: forall s a . (Serializable a) 199 | => (a -> RestrictedProcess s RestrictedAction) 200 | -> Dispatcher s 201 | handleCast = handleCastIf (Server.state (const True)) 202 | 203 | -- | A version of "Control.Distributed.Process.ManagedProcess.Server.handleCastIf" 204 | -- that takes a handler which executes in 'RestrictedProcess'. 205 | -- 206 | handleCastIf :: forall s a . (Serializable a) 207 | => Condition s a -- ^ predicate that must be satisfied for the handler to run 208 | -> (a -> RestrictedProcess s RestrictedAction) 209 | -- ^ an action yielding function over the process state and input message 210 | -> Dispatcher s 211 | handleCastIf cond h = Server.handleCastIf cond (wrapHandler h) 212 | 213 | -- | A version of "Control.Distributed.Process.ManagedProcess.Server.handleInfo" 214 | -- that takes a handler which executes in 'RestrictedProcess'. 215 | -- 216 | handleInfo :: forall s a. (Serializable a) 217 | => (a -> RestrictedProcess s RestrictedAction) 218 | -> DeferredDispatcher s 219 | -- cast and info look the same to a restricted process 220 | handleInfo h = Server.handleInfo (wrapHandler h) 221 | 222 | -- | Handle exit signals 223 | handleExit :: forall s a. (Serializable a) 224 | => (a -> RestrictedProcess s RestrictedAction) 225 | -> ExitSignalDispatcher s 226 | handleExit h = Server.handleExit $ \_ s a -> wrapHandler h s a 227 | 228 | -- | Handle timeouts 229 | handleTimeout :: forall s . (Delay -> RestrictedProcess s RestrictedAction) 230 | -> TimeoutHandler s 231 | handleTimeout h = \s d -> do 232 | (r, s') <- runRestricted s (h d) 233 | case r of 234 | RestrictedContinue -> Server.continue s' 235 | (RestrictedTimeout i) -> Server.timeoutAfter i s' 236 | (RestrictedHibernate i) -> Server.hibernate i s' 237 | (RestrictedStop r') -> Server.stop r' 238 | 239 | -------------------------------------------------------------------------------- 240 | -- Implementation -- 241 | -------------------------------------------------------------------------------- 242 | 243 | wrapHandler :: forall s a . (Serializable a) 244 | => (a -> RestrictedProcess s RestrictedAction) 245 | -> ActionHandler s a 246 | wrapHandler h s a = do 247 | (r, s') <- runRestricted s (h a) 248 | case r of 249 | RestrictedContinue -> Server.continue s' 250 | (RestrictedTimeout i) -> Server.timeoutAfter i s' 251 | (RestrictedHibernate i) -> Server.hibernate i s' 252 | (RestrictedStop r') -> Server.stop r' 253 | 254 | wrapCall :: forall s a b . (Serializable a, Serializable b) 255 | => (a -> RestrictedProcess s (Result b)) 256 | -> CallHandler s a b 257 | wrapCall h s a = do 258 | (r, s') <- runRestricted s (h a) 259 | case r of 260 | (Reply r') -> Server.reply r' s' 261 | (Timeout i r') -> Server.timeoutAfter i s' >>= Server.replyWith r' 262 | (Hibernate i r') -> Server.hibernate i s' >>= Server.replyWith r' 263 | (Stop r'' ) -> Server.stop r'' >>= Server.noReply 264 | 265 | runRestricted :: s -> RestrictedProcess s a -> Process (a, s) 266 | runRestricted state proc = ST.runStateT (unRestricted proc) state 267 | 268 | -- | TODO MonadTrans instance? lift :: (Monad m) => m a -> t m a 269 | lift :: Process a -> RestrictedProcess s a 270 | lift p = RestrictedProcess $ ST.lift p 271 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/ManagedProcess/Timer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE PatternGuards #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE DeriveDataTypeable #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Control.Distributed.Process.ManagedProcess.Timer 11 | -- Copyright : (c) Tim Watson 2017 12 | -- License : BSD3 (see the file LICENSE) 13 | -- 14 | -- Maintainer : Tim Watson 15 | -- Stability : experimental 16 | -- Portability : non-portable (requires concurrency) 17 | -- 18 | -- This module provides a wrap around a simple 'Timer' that can be started, 19 | -- stopped, reset, cleared, and read. A convenient function is provided for 20 | -- creating a @Match@ expression for the timer. 21 | -- 22 | -- [Notes] 23 | -- 24 | -- The timers defined in this module are based on a @TVar Bool@. When the 25 | -- client program is @-threaded@ (i.e. @rtsSupportsBoundThreads == True@), then 26 | -- the timers are set using @registerDelay@, which is very efficient and relies 27 | -- only no the RTS IO Manager. When we're not @-threaded@, we fall back to using 28 | -- "Control.Distributed.Process.Extras.Timer" to set the @TVar@, which has much 29 | -- the same effect, but requires us to spawn a process to handle setting the 30 | -- @TVar@ - a process which could theoretically die before setting the variable. 31 | -- 32 | module Control.Distributed.Process.ManagedProcess.Timer 33 | ( Timer(timerDelay) 34 | , TimerKey 35 | , delayTimer 36 | , startTimer 37 | , stopTimer 38 | , resetTimer 39 | , clearTimer 40 | , matchTimeout 41 | , matchKey 42 | , matchRun 43 | , isActive 44 | , readTimer 45 | , TimedOut(..) 46 | ) where 47 | 48 | import Control.Concurrent (rtsSupportsBoundThreads) 49 | import Control.Concurrent.STM hiding (check) 50 | import Control.Distributed.Process 51 | ( matchSTM 52 | , Process 53 | , ProcessId 54 | , Match 55 | , Message 56 | , liftIO 57 | ) 58 | import qualified Control.Distributed.Process as P 59 | ( liftIO 60 | ) 61 | import Control.Distributed.Process.Extras.Time (asTimeout, Delay(..)) 62 | import Control.Distributed.Process.Extras.Timer 63 | ( cancelTimer 64 | , runAfter 65 | , TimerRef 66 | ) 67 | import Data.Binary (Binary) 68 | import Data.Maybe (isJust, fromJust) 69 | import Data.Typeable (Typeable) 70 | import GHC.Conc (registerDelay) 71 | import GHC.Generics 72 | 73 | -------------------------------------------------------------------------------- 74 | -- Timeout Management -- 75 | -------------------------------------------------------------------------------- 76 | 77 | -- | A key for storing timers in prioritised process backing state. 78 | type TimerKey = Int 79 | 80 | -- | Used during STM reads on Timers and to implement blocking. Since timers 81 | -- can be associated with a "TimerKey", the second constructor for this type 82 | -- yields a key indicating whic "Timer" it refers to. Note that the user is 83 | -- responsible for establishing and maintaining the mapping between @Timer@s 84 | -- and their keys. 85 | data TimedOut = TimedOut | Yield TimerKey 86 | deriving (Eq, Show, Typeable, Generic) 87 | instance Binary TimedOut where 88 | 89 | -- | We hold timers in 2 states, each described by a Delay. 90 | -- isActive = isJust . mtSignal 91 | -- the TimerRef is optional since we only use the Timer module from extras 92 | -- when we're unable to registerDelay (i.e. not running under -threaded) 93 | data Timer = Timer { timerDelay :: Delay 94 | , mtPidRef :: Maybe TimerRef 95 | , mtSignal :: Maybe (TVar Bool) 96 | } 97 | 98 | -- | @True@ if a @Timer@ is currently active. 99 | isActive :: Timer -> Bool 100 | isActive = isJust . mtSignal 101 | 102 | -- | Creates a default @Timer@ which is inactive. 103 | delayTimer :: Delay -> Timer 104 | delayTimer d = Timer d noPid noTVar 105 | where 106 | noPid = Nothing :: Maybe ProcessId 107 | noTVar = Nothing :: Maybe (TVar Bool) 108 | 109 | -- | Starts a @Timer@ 110 | -- Will use the GHC @registerDelay@ API if @rtsSupportsBoundThreads == True@ 111 | startTimer :: Delay -> Process Timer 112 | startTimer d 113 | | Delay t <- d = establishTimer t 114 | | otherwise = return $ delayTimer d 115 | where 116 | establishTimer t' 117 | | rtsSupportsBoundThreads = do sig <- liftIO $ registerDelay (asTimeout t') 118 | return Timer { timerDelay = d 119 | , mtPidRef = Nothing 120 | , mtSignal = Just sig 121 | } 122 | | otherwise = do 123 | tSig <- liftIO $ newTVarIO False 124 | -- NB: runAfter spawns a process, which is defined in terms of 125 | -- expectTimeout (asTimeout t) :: Process (Maybe CancelTimer) 126 | -- 127 | tRef <- runAfter t' $ P.liftIO $ atomically $ writeTVar tSig True 128 | return Timer { timerDelay = d 129 | , mtPidRef = Just tRef 130 | , mtSignal = Just tSig 131 | } 132 | 133 | -- | Stops a previously started @Timer@. Has no effect if the @Timer@ is inactive. 134 | stopTimer :: Timer -> Process Timer 135 | stopTimer t@Timer{..} = do 136 | clearTimer mtPidRef 137 | return t { mtPidRef = Nothing 138 | , mtSignal = Nothing 139 | } 140 | 141 | -- | Clears and restarts a @Timer@. 142 | resetTimer :: Timer -> Delay -> Process Timer 143 | resetTimer Timer{..} d = clearTimer mtPidRef >> startTimer d 144 | 145 | -- | Clears/cancels a running timer. Has no effect if the @Timer@ is inactive. 146 | clearTimer :: Maybe TimerRef -> Process () 147 | clearTimer ref 148 | | isJust ref = cancelTimer (fromJust ref) 149 | | otherwise = return () 150 | 151 | -- | Creates a @Match@ for a given timer, for use with Cloud Haskell's messaging 152 | -- primitives for selective receives. 153 | matchTimeout :: Timer -> [Match (Either TimedOut Message)] 154 | matchTimeout t@Timer{..} 155 | | isActive t = [ matchSTM (readTimer $ fromJust mtSignal) 156 | (return . Left) ] 157 | | otherwise = [] 158 | 159 | -- | Create a match expression for a given @Timer@. When the timer expires 160 | -- (i.e. the "TVar Bool" is set to @True@), the "Match" will return @Yield i@, 161 | -- where @i@ is the given "TimerKey". 162 | matchKey :: TimerKey -> Timer -> [Match (Either TimedOut Message)] 163 | matchKey i t@Timer{..} 164 | | isActive t = [matchSTM (readTVar (fromJust mtSignal) >>= \expired -> 165 | if expired then return (Yield i) else retry) 166 | (return . Left)] 167 | | otherwise = [] 168 | 169 | -- | As "matchKey", but instead of a returning @Yield i@, the generated "Match" 170 | -- handler evaluates the first argument - and expression from "TimerKey" to 171 | -- @Process Message@ - to determine its result. 172 | matchRun :: (TimerKey -> Process Message) 173 | -> TimerKey 174 | -> Timer 175 | -> [Match Message] 176 | matchRun f k t@Timer{..} 177 | | isActive t = [matchSTM (readTVar (fromJust mtSignal) >>= \expired -> 178 | if expired then return k else retry) f] 179 | | otherwise = [] 180 | 181 | -- | Reads a given @TVar Bool@ for a timer, and returns @STM TimedOut@ once the 182 | -- variable is set to true. Will @retry@ in the meanwhile. 183 | readTimer :: TVar Bool -> STM TimedOut 184 | readTimer t = do 185 | expired <- readTVar t 186 | if expired then return TimedOut 187 | else retry 188 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/ManagedProcess/UnsafeClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE LiberalTypeSynonyms #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Control.Distributed.Process.ManagedProcess.UnsafeClient 8 | -- Copyright : (c) Tim Watson 2012 - 2017 9 | -- License : BSD3 (see the file LICENSE) 10 | -- 11 | -- Maintainer : Tim Watson 12 | -- Stability : experimental 13 | -- Portability : non-portable (requires concurrency) 14 | -- 15 | -- Unsafe variant of the /Managed Process Client API/. This module implements 16 | -- the client portion of a Managed Process using the unsafe variants of cloud 17 | -- haskell's messaging primitives. It relies on the -extras implementation of 18 | -- @UnsafePrimitives@, which forces evaluation for types that provide an 19 | -- @NFData@ instance. Direct use of the underlying unsafe primitives (from 20 | -- the distributed-process library) without @NFData@ instances is unsupported. 21 | -- 22 | -- IMPORTANT NOTE: As per the platform documentation, it is not possible to 23 | -- /guarantee/ that an @NFData@ instance will force evaluation in the same way 24 | -- that a @Binary@ instance would (when encoding to a byte string). Please read 25 | -- the unsafe primitives documentation carefully and make sure you know what 26 | -- you're doing. You have been warned. 27 | -- 28 | -- See "Control.Distributed.Process.Extras". 29 | -- See "Control.Distributed.Process.Extras.UnsafePrimitives". 30 | -- See "Control.Distributed.Process.UnsafePrimitives". 31 | ----------------------------------------------------------------------------- 32 | 33 | -- TODO: This module is basically cut+paste duplicaton of the /safe/ Client - fix 34 | -- Caveats... we've got to support two different type constraints, somehow, so 35 | -- that the correct implementation gets used depending on whether or not we're 36 | -- passing NFData or just Binary instances... 37 | 38 | module Control.Distributed.Process.ManagedProcess.UnsafeClient 39 | ( -- * Unsafe variants of the Client API 40 | sendControlMessage 41 | , shutdown 42 | , call 43 | , safeCall 44 | , tryCall 45 | , callTimeout 46 | , flushPendingCalls 47 | , callAsync 48 | , cast 49 | , callChan 50 | , syncCallChan 51 | , syncSafeCallChan 52 | ) where 53 | 54 | import Control.Distributed.Process 55 | ( Process 56 | , ProcessId 57 | , ReceivePort 58 | , newChan 59 | , matchChan 60 | , match 61 | , die 62 | , terminate 63 | , receiveTimeout 64 | , unsafeSendChan 65 | , getSelfPid 66 | , catchesExit 67 | , handleMessageIf 68 | ) 69 | import Control.Distributed.Process.Async 70 | ( Async 71 | , async 72 | , task 73 | ) 74 | import Control.Distributed.Process.Extras 75 | ( awaitResponse 76 | , Addressable 77 | , Routable(..) 78 | , NFSerializable 79 | , ExitReason(..) 80 | , Shutdown(..) 81 | ) 82 | import Control.Distributed.Process.ManagedProcess.Internal.Types 83 | ( Message(CastMessage, ChanMessage) 84 | , CallResponse(..) 85 | , ControlPort(..) 86 | , unsafeInitCall 87 | , waitResponse 88 | ) 89 | import Control.Distributed.Process.Extras.Time 90 | ( TimeInterval 91 | , asTimeout 92 | ) 93 | import Control.Distributed.Process.Serializable hiding (SerializableDict) 94 | import Data.Maybe (fromJust) 95 | 96 | -- | Send a control message over a 'ControlPort'. This version of 97 | -- @shutdown@ uses /unsafe primitives/. 98 | -- 99 | sendControlMessage :: Serializable m => ControlPort m -> m -> Process () 100 | sendControlMessage cp m = unsafeSendChan (unPort cp) (CastMessage m) 101 | 102 | -- | Send a signal instructing the process to terminate. This version of 103 | -- @shutdown@ uses /unsafe primitives/. 104 | shutdown :: ProcessId -> Process () 105 | shutdown pid = cast pid Shutdown 106 | 107 | -- | Make a synchronous call - uses /unsafe primitives/. 108 | call :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 109 | => s -> a -> Process b 110 | call sid msg = unsafeInitCall sid msg >>= waitResponse Nothing >>= decodeResult 111 | where decodeResult (Just (Right r)) = return r 112 | decodeResult (Just (Left err)) = die err 113 | decodeResult Nothing {- the impossible happened -} = terminate 114 | 115 | -- | Safe version of 'call' that returns information about the error 116 | -- if the operation fails - uses /unsafe primitives/. 117 | safeCall :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 118 | => s -> a -> Process (Either ExitReason b) 119 | safeCall s m = do 120 | us <- getSelfPid 121 | (fmap fromJust (unsafeInitCall s m >>= waitResponse Nothing) :: Process (Either ExitReason b)) 122 | `catchesExit` [\pid msg -> handleMessageIf msg (weFailed pid us) 123 | (return . Left)] 124 | 125 | where 126 | 127 | weFailed a b (ExitOther _) = a == b 128 | weFailed _ _ _ = False 129 | 130 | -- | Version of 'safeCall' that returns 'Nothing' if the operation fails. 131 | -- Uses /unsafe primitives/. 132 | tryCall :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 133 | => s -> a -> Process (Maybe b) 134 | tryCall s m = unsafeInitCall s m >>= waitResponse Nothing >>= decodeResult 135 | where decodeResult (Just (Right r)) = return $ Just r 136 | decodeResult _ = return Nothing 137 | 138 | -- | Make a synchronous call, but timeout and return @Nothing@ if a reply 139 | -- is not received within the specified time interval - uses /unsafe primitives/. 140 | -- 141 | callTimeout :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 142 | => s -> a -> TimeInterval -> Process (Maybe b) 143 | callTimeout s m d = unsafeInitCall s m >>= waitResponse (Just d) >>= decodeResult 144 | where decodeResult :: (NFSerializable b) 145 | => Maybe (Either ExitReason b) 146 | -> Process (Maybe b) 147 | decodeResult Nothing = return Nothing 148 | decodeResult (Just (Right result)) = return $ Just result 149 | decodeResult (Just (Left reason)) = die reason 150 | 151 | -- | Block for @TimeInterval@ waiting for any matching @CallResponse@ 152 | flushPendingCalls :: forall b . (NFSerializable b) 153 | => TimeInterval 154 | -> (b -> Process b) 155 | -> Process (Maybe b) 156 | flushPendingCalls d proc = 157 | receiveTimeout (asTimeout d) [ 158 | match (\(CallResponse (m :: b) _) -> proc m) 159 | ] 160 | 161 | -- | Invokes 'call' /out of band/, and returns an "async handle." 162 | -- Uses /unsafe primitives/. 163 | -- 164 | callAsync :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 165 | => s -> a -> Process (Async b) 166 | callAsync server msg = async $ task $ call server msg 167 | 168 | -- | Sends a /cast/ message to the server identified by @server@ - uses /unsafe primitives/. 169 | -- 170 | cast :: forall a m . (Addressable a, NFSerializable m) 171 | => a -> m -> Process () 172 | cast server msg = unsafeSendTo server ((CastMessage msg) :: Message m ()) 173 | 174 | -- | Sends a /channel/ message to the server and returns a @ReceivePort@ - uses /unsafe primitives/. 175 | callChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 176 | => s -> a -> Process (ReceivePort b) 177 | callChan server msg = do 178 | (sp, rp) <- newChan 179 | unsafeSendTo server ((ChanMessage msg sp) :: Message a b) 180 | return rp 181 | 182 | -- | A synchronous version of 'callChan'. 183 | syncCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 184 | => s -> a -> Process b 185 | syncCallChan server msg = do 186 | r <- syncSafeCallChan server msg 187 | case r of 188 | Left e -> die e 189 | Right r' -> return r' 190 | 191 | -- | A safe version of 'syncCallChan', which returns @Left ExitReason@ if the 192 | -- call fails. 193 | syncSafeCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 194 | => s -> a -> Process (Either ExitReason b) 195 | syncSafeCallChan server msg = do 196 | rp <- callChan server msg 197 | awaitResponse server [ matchChan rp (return . Right) ] 198 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.13 2 | 3 | packages: 4 | - '.' 5 | - location: 6 | git: https://github.com/haskell-distributed/distributed-process-systest.git 7 | commit: b4a6b646adb6c81725ddac4babcfc21b86944d98 8 | extra-dep: true 9 | 10 | extra-deps: 11 | - ansi-terminal-0.6.3.1 12 | - network-transport-0.5.2 # missing snapshot 13 | - network-transport-tcp-0.6.0 # missing snapshot 14 | - network-transport-inmemory-0.5.1 # snapshot 0.5.2 in lts-7.18 15 | - distributed-process-0.7.4 # missing snapshot 16 | - rematch-0.2.0.0 17 | - distributed-process-extras-0.3.5 18 | - distributed-process-async-0.2.6 19 | - exceptions-0.10.0 20 | -------------------------------------------------------------------------------- /tests/Counter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE BangPatterns #-} 6 | 7 | module Counter 8 | ( startCounter, 9 | getCount, 10 | incCount, 11 | resetCount, 12 | wait, 13 | waitTimeout 14 | ) where 15 | 16 | import Control.Distributed.Process hiding (call) 17 | import Control.Distributed.Process.Async 18 | import Control.Distributed.Process.Extras 19 | import Control.Distributed.Process.Extras.Time 20 | import Control.Distributed.Process.ManagedProcess 21 | import Data.Binary 22 | import Data.Typeable (Typeable) 23 | 24 | import GHC.Generics 25 | 26 | -------------------------------------------------------------------------------- 27 | -- Types -- 28 | -------------------------------------------------------------------------------- 29 | 30 | -- Call and Cast request types. Response types are unnecessary as the GenProcess 31 | -- API uses the Async API, which in turn guarantees that an async handle can 32 | -- /only/ give back a reply for that *specific* request through the use of an 33 | -- anonymous middle-man (as the sender and receiver in our case). 34 | 35 | data Increment = Increment 36 | deriving (Typeable, Generic, Eq, Show) 37 | instance Binary Increment where 38 | 39 | data Fetch = Fetch 40 | deriving (Typeable, Generic, Eq, Show) 41 | instance Binary Fetch where 42 | 43 | data Reset = Reset 44 | deriving (Typeable, Generic, Eq, Show) 45 | instance Binary Reset where 46 | 47 | type State = Int 48 | 49 | -------------------------------------------------------------------------------- 50 | -- API -- 51 | -------------------------------------------------------------------------------- 52 | 53 | -- | Increment count 54 | incCount :: ProcessId -> Process Int 55 | incCount sid = call sid Increment 56 | 57 | -- | Get the current count - this is replicating what 'call' actually does 58 | getCount :: ProcessId -> Process Int 59 | getCount sid = call sid Fetch 60 | 61 | -- | Reset the current count 62 | resetCount :: ProcessId -> Process () 63 | resetCount sid = cast sid Reset 64 | 65 | -- | Start a counter server 66 | startCounter :: Int -> Process ProcessId 67 | startCounter startCount = 68 | let server = serverDefinition 69 | in spawnLocal $ serve startCount init' server 70 | where init' :: InitHandler Int Int 71 | init' count = return $ InitOk count Infinity 72 | 73 | -------------------------------------------------------------------------------- 74 | -- Implementation -- 75 | -------------------------------------------------------------------------------- 76 | 77 | serverDefinition :: ProcessDefinition State 78 | serverDefinition = defaultProcess { 79 | apiHandlers = [ 80 | handleCallIf (condition (\count Increment -> count >= 10))-- invariant 81 | (\_ (_ :: Increment) -> haltMaxCount) 82 | 83 | , handleCall handleIncrement 84 | , handleCall (\count Fetch -> reply count count) 85 | , handleCast (\_ Reset -> continue 0) 86 | ] 87 | } :: ProcessDefinition State 88 | 89 | haltMaxCount :: Reply Int State 90 | haltMaxCount = haltNoReply_ (ExitOther "Count > 10") 91 | 92 | handleIncrement :: CallHandler State Increment Int 93 | handleIncrement count Increment = 94 | let next = count + 1 in continue next >>= replyWith next 95 | -------------------------------------------------------------------------------- /tests/ManagedProcessCommon.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module ManagedProcessCommon where 6 | 7 | import Control.Concurrent.MVar (MVar) 8 | import Control.Concurrent.STM.TQueue 9 | ( newTQueueIO 10 | , readTQueue 11 | , writeTQueue 12 | , TQueue 13 | ) 14 | import Control.Distributed.Process hiding (call, send) 15 | import Control.Distributed.Process.Extras hiding (monitor) 16 | import qualified Control.Distributed.Process as P 17 | import Control.Distributed.Process.SysTest.Utils 18 | import Control.Distributed.Process.Extras.Time 19 | import Control.Distributed.Process.Extras.Timer 20 | import Control.Distributed.Process.Async 21 | import Control.Distributed.Process.ManagedProcess 22 | import qualified Control.Distributed.Process.ManagedProcess.UnsafeClient as Unsafe 23 | import Control.Distributed.Process.Serializable() 24 | 25 | #if ! MIN_VERSION_base(4,6,0) 26 | import Prelude hiding (catch) 27 | #endif 28 | 29 | import TestUtils 30 | 31 | type Launcher a = a -> Process (ProcessId, MVar ExitReason) 32 | 33 | explodingTestProcess :: ProcessId -> ProcessDefinition () 34 | explodingTestProcess pid = 35 | statelessProcess { 36 | apiHandlers = [ 37 | handleCall_ (\(s :: String) -> 38 | (die s) :: Process String) 39 | , handleCast (\_ (i :: Int) -> 40 | getSelfPid >>= \p -> die (p, i)) 41 | ] 42 | , exitHandlers = [ 43 | handleExit (\_ s (m :: String) -> do send pid (m :: String) 44 | continue s) 45 | , handleExit (\_ s m@((_ :: ProcessId), 46 | (_ :: Int)) -> P.send pid m >> continue s) 47 | ] 48 | } 49 | 50 | standardTestServer :: UnhandledMessagePolicy -> ProcessDefinition () 51 | standardTestServer policy = 52 | statelessProcess { 53 | apiHandlers = [ 54 | -- note: state is passed here, as a 'stateless' process is 55 | -- in fact process definition whose state is () 56 | 57 | handleCastIf (input (\msg -> msg == "stop")) 58 | (\_ _ -> stop ExitNormal) 59 | 60 | , handleCall (\s' (m :: String) -> reply m s') 61 | , handleCall_ (\(n :: Int) -> return (n * 2)) -- "stateless" 62 | 63 | , handleCall (\s' (_ :: Delay) -> (reject s' "invalid-call") :: Reply () ()) 64 | 65 | , handleCast (\s' ("ping", pid :: ProcessId) -> 66 | send pid "pong" >> continue s') 67 | , handleCastIf_ (input (\(c :: String, _ :: Delay) -> c == "timeout")) 68 | (\("timeout", d) -> timeoutAfter_ d) 69 | 70 | , handleCast_ (\("hibernate", d :: TimeInterval) -> hibernate_ d) 71 | ] 72 | , unhandledMessagePolicy = policy 73 | , timeoutHandler = \_ _ -> stop $ ExitOther "timeout" 74 | } 75 | 76 | wrap :: (Process (ProcessId, MVar ExitReason)) -> Launcher a 77 | wrap it = \_ -> do it 78 | 79 | data StmServer = StmServer { serverPid :: ProcessId 80 | , writerChan :: TQueue String 81 | , readerChan :: TQueue String 82 | } 83 | 84 | instance Resolvable StmServer where 85 | resolve = return . Just . serverPid 86 | 87 | echoStm :: StmServer -> String -> Process (Either ExitReason String) 88 | echoStm StmServer{..} = callSTM serverPid 89 | (writeTQueue writerChan) 90 | (readTQueue readerChan) 91 | 92 | launchEchoServer :: CallHandler () String String -> Process StmServer 93 | launchEchoServer handler = do 94 | (inQ, replyQ) <- liftIO $ do 95 | cIn <- newTQueueIO 96 | cOut <- newTQueueIO 97 | return (cIn, cOut) 98 | 99 | let procDef = statelessProcess { 100 | externHandlers = [ 101 | handleCallExternal 102 | (readTQueue inQ) 103 | (writeTQueue replyQ) 104 | handler 105 | ] 106 | } 107 | 108 | pid <- spawnLocal $ serve () (statelessInit Infinity) procDef 109 | return $ StmServer pid inQ replyQ 110 | 111 | deferredResponseServer :: Process ProcessId 112 | deferredResponseServer = 113 | let procDef = defaultProcess { 114 | apiHandlers = [ 115 | handleCallFrom (\r s (m :: String) -> noReply_ ((r, m):s) ) 116 | ] 117 | , infoHandlers = [ 118 | handleInfo (\s () -> (mapM_ (\t -> replyTo (fst t) (snd t)) s) >> continue []) 119 | ] 120 | } :: ProcessDefinition [(CallRef String, String)] 121 | in spawnLocal $ serve [] (\s -> return $ InitOk s Infinity) procDef 122 | 123 | -- common test cases 124 | 125 | testDeferredCallResponse :: TestResult (AsyncResult String) -> Process () 126 | testDeferredCallResponse result = do 127 | pid <- deferredResponseServer 128 | r <- async $ task $ (call pid "Hello There" :: Process String) 129 | 130 | sleep $ seconds 2 131 | AsyncPending <- poll r 132 | 133 | send pid () 134 | wait r >>= stash result 135 | 136 | testBasicCall :: Launcher () -> TestResult (Maybe String) -> Process () 137 | testBasicCall launch result = do 138 | (pid, _) <- launch () 139 | callTimeout pid "foo" (within 5 Seconds) >>= stash result 140 | 141 | testUnsafeBasicCall :: Launcher () -> TestResult (Maybe String) -> Process () 142 | testUnsafeBasicCall launch result = do 143 | (pid, _) <- launch () 144 | Unsafe.callTimeout pid "foo" (within 5 Seconds) >>= stash result 145 | 146 | testBasicCall_ :: Launcher () -> TestResult (Maybe Int) -> Process () 147 | testBasicCall_ launch result = do 148 | (pid, _) <- launch () 149 | callTimeout pid (2 :: Int) (within 5 Seconds) >>= stash result 150 | 151 | testUnsafeBasicCall_ :: Launcher () -> TestResult (Maybe Int) -> Process () 152 | testUnsafeBasicCall_ launch result = do 153 | (pid, _) <- launch () 154 | Unsafe.callTimeout pid (2 :: Int) (within 5 Seconds) >>= stash result 155 | 156 | testBasicCast :: Launcher () -> TestResult (Maybe String) -> Process () 157 | testBasicCast launch result = do 158 | self <- getSelfPid 159 | (pid, _) <- launch () 160 | cast pid ("ping", self) 161 | expectTimeout (after 3 Seconds) >>= stash result 162 | 163 | testUnsafeBasicCast :: Launcher () -> TestResult (Maybe String) -> Process () 164 | testUnsafeBasicCast launch result = do 165 | self <- getSelfPid 166 | (pid, _) <- launch () 167 | Unsafe.cast pid ("ping", self) 168 | expectTimeout (after 3 Seconds) >>= stash result 169 | 170 | testControlledTimeout :: Launcher () -> TestResult (Maybe ExitReason) -> Process () 171 | testControlledTimeout launch result = do 172 | (pid, exitReason) <- launch () 173 | cast pid ("timeout", Delay $ within 1 Seconds) 174 | waitForExit exitReason >>= stash result 175 | 176 | testUnsafeControlledTimeout :: Launcher () -> TestResult (Maybe ExitReason) -> Process () 177 | testUnsafeControlledTimeout launch result = do 178 | (pid, exitReason) <- launch () 179 | Unsafe.cast pid ("timeout", Delay $ within 1 Seconds) 180 | waitForExit exitReason >>= stash result 181 | 182 | testTerminatePolicy :: Launcher () -> TestResult (Maybe ExitReason) -> Process () 183 | testTerminatePolicy launch result = do 184 | (pid, exitReason) <- launch () 185 | send pid ("UNSOLICITED_MAIL", 500 :: Int) 186 | waitForExit exitReason >>= stash result 187 | 188 | testUnsafeTerminatePolicy :: Launcher () -> TestResult (Maybe ExitReason) -> Process () 189 | testUnsafeTerminatePolicy launch result = do 190 | (pid, exitReason) <- launch () 191 | send pid ("UNSOLICITED_MAIL", 500 :: Int) 192 | waitForExit exitReason >>= stash result 193 | 194 | testDropPolicy :: Launcher () -> TestResult (Maybe ExitReason) -> Process () 195 | testDropPolicy launch result = do 196 | (pid, exitReason) <- launch () 197 | 198 | send pid ("UNSOLICITED_MAIL", 500 :: Int) 199 | 200 | sleep $ milliSeconds 250 201 | mref <- monitor pid 202 | 203 | cast pid "stop" 204 | 205 | r <- receiveTimeout (after 10 Seconds) [ 206 | matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref) 207 | (\(ProcessMonitorNotification _ _ r) -> 208 | case r of 209 | DiedUnknownId -> stash result Nothing 210 | _ -> waitForExit exitReason >>= stash result) 211 | ] 212 | case r of 213 | Nothing -> stash result Nothing 214 | _ -> return () 215 | 216 | testUnsafeDropPolicy :: Launcher () -> TestResult (Maybe ExitReason) -> Process () 217 | testUnsafeDropPolicy launch result = do 218 | (pid, exitReason) <- launch () 219 | 220 | send pid ("UNSOLICITED_MAIL", 500 :: Int) 221 | 222 | sleep $ milliSeconds 250 223 | mref <- monitor pid 224 | 225 | Unsafe.cast pid "stop" 226 | 227 | r <- receiveTimeout (after 10 Seconds) [ 228 | matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref) 229 | (\(ProcessMonitorNotification _ _ r) -> 230 | case r of 231 | DiedUnknownId -> stash result Nothing 232 | _ -> waitForExit exitReason >>= stash result) 233 | ] 234 | case r of 235 | Nothing -> stash result Nothing 236 | _ -> return () 237 | 238 | testDeadLetterPolicy :: Launcher ProcessId 239 | -> TestResult (Maybe (String, Int)) 240 | -> Process () 241 | testDeadLetterPolicy launch result = do 242 | self <- getSelfPid 243 | (pid, _) <- launch self 244 | 245 | send pid ("UNSOLICITED_MAIL", 500 :: Int) 246 | cast pid "stop" 247 | 248 | receiveTimeout 249 | (after 5 Seconds) 250 | [ match (\m@(_ :: String, _ :: Int) -> return m) ] >>= stash result 251 | 252 | testUnsafeDeadLetterPolicy :: Launcher ProcessId 253 | -> TestResult (Maybe (String, Int)) 254 | -> Process () 255 | testUnsafeDeadLetterPolicy launch result = do 256 | self <- getSelfPid 257 | (pid, _) <- launch self 258 | 259 | send pid ("UNSOLICITED_MAIL", 500 :: Int) 260 | Unsafe.cast pid "stop" 261 | 262 | receiveTimeout 263 | (after 5 Seconds) 264 | [ match (\m@(_ :: String, _ :: Int) -> return m) ] >>= stash result 265 | 266 | testHibernation :: Launcher () -> TestResult Bool -> Process () 267 | testHibernation launch result = do 268 | (pid, _) <- launch () 269 | mref <- monitor pid 270 | 271 | cast pid ("hibernate", (within 3 Seconds)) 272 | cast pid "stop" 273 | 274 | -- the process mustn't stop whilst it's supposed to be hibernating 275 | r <- receiveTimeout (after 2 Seconds) [ 276 | matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref) 277 | (\_ -> return ()) 278 | ] 279 | case r of 280 | Nothing -> kill pid "done" >> stash result True 281 | Just _ -> stash result False 282 | 283 | testUnsafeHibernation :: Launcher () -> TestResult Bool -> Process () 284 | testUnsafeHibernation launch result = do 285 | (pid, _) <- launch () 286 | mref <- monitor pid 287 | 288 | Unsafe.cast pid ("hibernate", (within 3 Seconds)) 289 | Unsafe.cast pid "stop" 290 | 291 | -- the process mustn't stop whilst it's supposed to be hibernating 292 | r <- receiveTimeout (after 2 Seconds) [ 293 | matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref) 294 | (\_ -> return ()) 295 | ] 296 | case r of 297 | Nothing -> kill pid "done" >> stash result True 298 | Just _ -> stash result False 299 | 300 | testKillMidCall :: Launcher () -> TestResult Bool -> Process () 301 | testKillMidCall launch result = do 302 | (pid, _) <- launch () 303 | cast pid ("hibernate", (within 3 Seconds)) 304 | callAsync pid "hello-world" >>= cancelWait >>= unpack result pid 305 | where unpack :: TestResult Bool -> ProcessId -> AsyncResult () -> Process () 306 | unpack res sid AsyncCancelled = kill sid "stop" >> stash res True 307 | unpack res sid _ = kill sid "stop" >> stash res False 308 | 309 | testUnsafeKillMidCall :: Launcher () -> TestResult Bool -> Process () 310 | testUnsafeKillMidCall launch result = do 311 | (pid, _) <- launch () 312 | Unsafe.cast pid ("hibernate", (within 3 Seconds)) 313 | Unsafe.callAsync pid "hello-world" >>= cancelWait >>= unpack result pid 314 | where unpack :: TestResult Bool -> ProcessId -> AsyncResult () -> Process () 315 | unpack res sid AsyncCancelled = kill sid "stop" >> stash res True 316 | unpack res sid _ = kill sid "stop" >> stash res False 317 | 318 | testSimpleErrorHandling :: Launcher ProcessId 319 | -> TestResult (Maybe ExitReason) 320 | -> Process () 321 | testSimpleErrorHandling launch result = do 322 | self <- getSelfPid 323 | (pid, exitReason) <- launch self 324 | register "SUT" pid 325 | sleep $ seconds 2 326 | 327 | -- this should be *altered* because of the exit handler 328 | Nothing <- callTimeout pid "foobar" (within 1 Seconds) :: Process (Maybe String) 329 | 330 | Right _ <- awaitResponse pid [ 331 | matchIf (\(s :: String) -> s == "foobar") 332 | (\s -> return (Right s) :: Process (Either ExitReason String)) 333 | ] 334 | 335 | shutdown pid 336 | waitForExit exitReason >>= stash result 337 | 338 | testUnsafeSimpleErrorHandling :: Launcher ProcessId 339 | -> TestResult (Maybe ExitReason) 340 | -> Process () 341 | testUnsafeSimpleErrorHandling launch result = do 342 | self <- getSelfPid 343 | (pid, exitReason) <- launch self 344 | 345 | -- this should be *altered* because of the exit handler 346 | Nothing <- Unsafe.callTimeout pid "foobar" (within 1 Seconds) :: Process (Maybe String) 347 | "foobar" <- expect 348 | 349 | Unsafe.shutdown pid 350 | waitForExit exitReason >>= stash result 351 | 352 | testAlternativeErrorHandling :: Launcher ProcessId 353 | -> TestResult (Maybe ExitReason) 354 | -> Process () 355 | testAlternativeErrorHandling launch result = do 356 | self <- getSelfPid 357 | (pid, exitReason) <- launch self 358 | 359 | -- this should be ignored/altered because of the second exit handler 360 | cast pid (42 :: Int) 361 | (Just True) <- receiveTimeout (after 2 Seconds) [ 362 | matchIf (\((p :: ProcessId), (i :: Int)) -> p == pid && i == 42) 363 | (\_ -> return True) 364 | ] 365 | 366 | shutdown pid 367 | waitForExit exitReason >>= stash result 368 | 369 | testUnsafeAlternativeErrorHandling :: Launcher ProcessId 370 | -> TestResult (Maybe ExitReason) 371 | -> Process () 372 | testUnsafeAlternativeErrorHandling launch result = do 373 | self <- getSelfPid 374 | (pid, exitReason) <- launch self 375 | 376 | -- this should be ignored/altered because of the second exit handler 377 | Unsafe.cast pid (42 :: Int) 378 | (Just True) <- receiveTimeout (after 2 Seconds) [ 379 | matchIf (\((p :: ProcessId), (i :: Int)) -> p == pid && i == 42) 380 | (\_ -> return True) 381 | ] 382 | 383 | Unsafe.shutdown pid 384 | waitForExit exitReason >>= stash result 385 | 386 | testServerRejectsMessage :: Launcher ProcessId 387 | -> TestResult ExitReason 388 | -> Process () 389 | testServerRejectsMessage launch result = do 390 | self <- getSelfPid 391 | (pid, _) <- launch self 392 | 393 | -- server is configured to reject (m :: Delay) 394 | Left res <- safeCall pid Infinity :: Process (Either ExitReason ()) 395 | stash result res 396 | -------------------------------------------------------------------------------- /tests/MathsDemo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module MathsDemo 4 | ( add 5 | , divide 6 | , launchMathServer 7 | , DivByZero(..) 8 | , Add(..) 9 | ) where 10 | 11 | import Control.Distributed.Process hiding (call) 12 | import Control.Distributed.Process.Extras 13 | import Control.Distributed.Process.Extras.Time 14 | import Control.Distributed.Process.ManagedProcess 15 | 16 | import Data.Binary (Binary(..)) 17 | import Data.Typeable (Typeable) 18 | 19 | data Add = Add Double Double deriving (Typeable) 20 | data Divide = Divide Double Double deriving (Typeable) 21 | data DivByZero = DivByZero deriving (Typeable, Eq) 22 | 23 | instance Binary Add where 24 | put (Add x y) = put x >> put y 25 | get = Add <$> get <*> get 26 | 27 | instance Binary Divide where 28 | put (Divide x y) = put x >> put y 29 | get = Divide <$> get <*> get 30 | 31 | instance Binary DivByZero where 32 | put DivByZero = return () 33 | get = return DivByZero 34 | 35 | -- public API 36 | 37 | add :: ProcessId -> Double -> Double -> Process Double 38 | add sid x y = call sid (Add x y) 39 | 40 | divide :: ProcessId -> Double -> Double 41 | -> Process (Either DivByZero Double) 42 | divide sid x y = call sid (Divide x y ) 43 | 44 | launchMathServer :: Process ProcessId 45 | launchMathServer = 46 | let server = statelessProcess { 47 | apiHandlers = [ 48 | handleCall_ (\(Add x y) -> return (x + y)) 49 | , handleCallIf_ (input (\(Divide _ y) -> y /= 0)) handleDivide 50 | , handleCall_ (\(Divide _ _) -> divByZero) 51 | , action (\("stop") -> stop_ ExitNormal) 52 | ] 53 | } 54 | in spawnLocal $ serve () (statelessInit Infinity) server 55 | where handleDivide :: Divide -> Process (Either DivByZero Double) 56 | handleDivide (Divide x y) = return $ Right $ x / y 57 | 58 | divByZero :: Process (Either DivByZero Double) 59 | divByZero = return $ Left DivByZero 60 | -------------------------------------------------------------------------------- /tests/SafeCounter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | 7 | module SafeCounter 8 | ( startCounter, 9 | getCount, 10 | getCountAsync, 11 | incCount, 12 | resetCount, 13 | wait, 14 | waitTimeout, 15 | Fetch(..), 16 | Increment(..), 17 | Reset(..) 18 | ) where 19 | 20 | import Control.Distributed.Process hiding (call, say) 21 | import Control.Distributed.Process.Extras 22 | import Control.Distributed.Process.Async 23 | import Control.Distributed.Process.ManagedProcess 24 | ( ProcessDefinition(..) 25 | , InitHandler 26 | , InitResult(..) 27 | , defaultProcess 28 | , condition 29 | ) 30 | import qualified Control.Distributed.Process.ManagedProcess as ManagedProcess (serve) 31 | import Control.Distributed.Process.ManagedProcess.Client 32 | import Control.Distributed.Process.ManagedProcess.Server.Restricted 33 | import Control.Distributed.Process.Extras.Time 34 | import Control.Distributed.Process.Serializable 35 | import Data.Binary 36 | import Data.Typeable (Typeable) 37 | import GHC.Generics 38 | 39 | -------------------------------------------------------------------------------- 40 | -- Types -- 41 | -------------------------------------------------------------------------------- 42 | 43 | data Increment = Increment 44 | deriving (Show, Typeable, Generic) 45 | instance Binary Increment where 46 | 47 | data Fetch = Fetch 48 | deriving (Show, Typeable, Generic) 49 | instance Binary Fetch where 50 | 51 | data Reset = Reset deriving (Show, Typeable, Generic) 52 | instance Binary Reset where 53 | 54 | -------------------------------------------------------------------------------- 55 | -- API -- 56 | -------------------------------------------------------------------------------- 57 | 58 | -- | Increment count 59 | incCount :: ProcessId -> Process Int 60 | incCount sid = call sid Increment 61 | 62 | -- | Get the current count 63 | getCount :: ProcessId -> Process Int 64 | getCount sid = call sid Fetch 65 | 66 | -- | Get the current count asynchronously 67 | getCountAsync :: ProcessId -> Process (Async Int) 68 | getCountAsync sid = callAsync sid Fetch 69 | 70 | -- | Reset the current count 71 | resetCount :: ProcessId -> Process () 72 | resetCount sid = cast sid Reset 73 | 74 | -- | Start a counter server 75 | startCounter :: Int -> Process ProcessId 76 | startCounter startCount = 77 | let server = serverDefinition 78 | in spawnLocal $ ManagedProcess.serve startCount init' server 79 | where init' :: InitHandler Int Int 80 | init' count = return $ InitOk count Infinity 81 | 82 | -------------------------------------------------------------------------------- 83 | -- Implementation -- 84 | -------------------------------------------------------------------------------- 85 | 86 | serverDefinition :: ProcessDefinition Int 87 | serverDefinition = defaultProcess { 88 | apiHandlers = [ 89 | handleCallIf 90 | (condition (\count Increment -> count >= 10)) -- invariant 91 | (\Increment -> halt :: RestrictedProcess Int (Result Int)) 92 | 93 | , handleCall handleIncrement 94 | , handleCall (\Fetch -> getState >>= reply) 95 | , handleCast (\Reset -> putState (0 :: Int) >> continue) 96 | ] 97 | } :: ProcessDefinition Int 98 | 99 | halt :: forall s r . Serializable r => RestrictedProcess s (Result r) 100 | halt = haltNoReply (ExitOther "Count > 10") 101 | 102 | handleIncrement :: Increment -> RestrictedProcess Int (Result Int) 103 | handleIncrement _ = modifyState (+1) >> getState >>= reply 104 | 105 | -------------------------------------------------------------------------------- /tests/TestManagedProcess.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module Main where 5 | 6 | import Control.Concurrent.STM (atomically) 7 | import Control.Concurrent.STM.TQueue 8 | ( newTQueueIO 9 | , readTQueue 10 | , writeTQueue 11 | ) 12 | import Control.Concurrent.MVar 13 | import Control.Exception (SomeException) 14 | import Control.Distributed.Process hiding (call, catch) 15 | import Control.Distributed.Process.Async (AsyncResult(AsyncDone)) 16 | import Control.Distributed.Process.Node 17 | import Control.Distributed.Process.Extras hiding (__remoteTable, monitor, send, nsend) 18 | import Control.Distributed.Process.ManagedProcess 19 | import Control.Distributed.Process.SysTest.Utils 20 | import Control.Distributed.Process.Extras.Time 21 | import Control.Distributed.Process.Serializable() 22 | 23 | import MathsDemo 24 | import Counter 25 | import qualified SafeCounter as SafeCounter 26 | 27 | #if ! MIN_VERSION_base(4,6,0) 28 | import Prelude hiding (catch) 29 | #endif 30 | 31 | import Test.Framework (Test, testGroup) 32 | import Test.Framework.Providers.HUnit (testCase) 33 | import TestUtils 34 | import ManagedProcessCommon 35 | 36 | import qualified Network.Transport as NT 37 | import Control.Monad (void) 38 | import Control.Monad.Catch (catch) 39 | 40 | -- utilities 41 | 42 | server :: Process (ProcessId, MVar ExitReason) 43 | server = mkServer Terminate 44 | 45 | mkServer :: UnhandledMessagePolicy 46 | -> Process (ProcessId, MVar ExitReason) 47 | mkServer policy = 48 | let s = standardTestServer policy 49 | in do 50 | exitReason <- liftIO newEmptyMVar 51 | pid <- spawnLocal $ 52 | catch ((serve () (statelessInit Infinity) s >> stash exitReason ExitNormal) 53 | `catchesExit` [ 54 | (\_ msg -> do 55 | mEx <- unwrapMessage msg :: Process (Maybe ExitReason) 56 | case mEx of 57 | Nothing -> return Nothing 58 | Just r -> fmap Just (stash exitReason r) 59 | ) 60 | ]) 61 | (\(e :: SomeException) -> stash exitReason $ ExitOther (show e)) 62 | return (pid, exitReason) 63 | 64 | explodingServer :: ProcessId 65 | -> Process (ProcessId, MVar ExitReason) 66 | explodingServer pid = 67 | let srv = explodingTestProcess pid 68 | in do 69 | exitReason <- liftIO newEmptyMVar 70 | spid <- spawnLocal $ 71 | catch (serve () (statelessInit Infinity) srv >> stash exitReason ExitNormal) 72 | (\(e :: SomeException) -> stash exitReason $ ExitOther (show e)) 73 | return (spid, exitReason) 74 | 75 | testCallReturnTypeMismatchHandling :: TestResult Bool -> Process () 76 | testCallReturnTypeMismatchHandling result = 77 | let procDef = statelessProcess { 78 | apiHandlers = [ 79 | handleCall (\s (m :: String) -> reply m s) 80 | ] 81 | , unhandledMessagePolicy = Terminate 82 | } in do 83 | pid <- spawnLocal $ serve () (statelessInit Infinity) procDef 84 | res <- safeCall pid "hello buddy" :: Process (Either ExitReason ()) 85 | case res of 86 | Left (ExitOther _) -> stash result True 87 | _ -> stash result False 88 | 89 | testChannelBasedService :: TestResult Bool -> Process () 90 | testChannelBasedService result = 91 | let procDef = statelessProcess { 92 | apiHandlers = [ 93 | handleRpcChan (\p s (m :: String) -> 94 | replyChan p m >> continue s) 95 | ] 96 | } in do 97 | pid <- spawnLocal $ serve () (statelessInit Infinity) procDef 98 | echo <- syncCallChan pid "hello" 99 | stash result (echo == "hello") 100 | kill pid "done" 101 | 102 | testExternalService :: TestResult Bool -> Process () 103 | testExternalService result = do 104 | inChan <- liftIO newTQueueIO 105 | replyQ <- liftIO newTQueueIO 106 | let procDef = statelessProcess { 107 | externHandlers = [ 108 | handleExternal 109 | (readTQueue inChan) 110 | (\s (m :: String) -> do 111 | liftIO $ atomically $ writeTQueue replyQ m 112 | continue s) 113 | ] 114 | } 115 | let txt = "hello 2-way stm foo" 116 | pid <- spawnLocal $ serve () (statelessInit Infinity) procDef 117 | echoTxt <- liftIO $ do 118 | -- firstly we write something that the server can receive 119 | atomically $ writeTQueue inChan txt 120 | -- then sit and wait for it to write something back to us 121 | atomically $ readTQueue replyQ 122 | 123 | stash result (echoTxt == txt) 124 | kill pid "done" 125 | 126 | testExternalCall :: TestResult Bool -> Process () 127 | testExternalCall result = do 128 | let txt = "hello stm-call foo" 129 | srv <- launchEchoServer (\st (msg :: String) -> reply msg st) 130 | echoStm srv txt >>= stash result . (== Right txt) 131 | killProc srv "done" 132 | 133 | testExternalCallHaltingServer :: TestResult Bool -> Process () 134 | testExternalCallHaltingServer result = do 135 | let msg = "foo bar baz" 136 | srv <- launchEchoServer (\_ (_ :: String) -> haltNoReply_ ExitNormal) 137 | echoReply <- echoStm srv msg 138 | case echoReply of 139 | -- sadly, we cannot guarantee that our monitor will be set up fast 140 | -- enough, as per the documentation! 141 | Left (ExitOther reason) -> stash result $ reason `elem` [ "DiedUnknownId" 142 | , "DiedNormal" 143 | ] 144 | (Left ExitNormal) -> stash result False 145 | (Left ExitShutdown) -> stash result False 146 | (Right _) -> stash result False 147 | 148 | -- MathDemo tests 149 | 150 | testAdd :: TestResult Double -> Process () 151 | testAdd result = do 152 | pid <- launchMathServer 153 | add pid 10 10 >>= stash result 154 | kill pid "done" 155 | 156 | testBadAdd :: TestResult Bool -> Process () 157 | testBadAdd result = do 158 | pid <- launchMathServer 159 | res <- safeCall pid (Add 10 10) :: Process (Either ExitReason Int) 160 | stash result (res == (Left $ ExitOther $ "DiedException \"exit-from=" ++ (show pid) ++ "\"")) 161 | 162 | testDivByZero :: TestResult (Either DivByZero Double) -> Process () 163 | testDivByZero result = do 164 | pid <- launchMathServer 165 | divide pid 125 0 >>= stash result 166 | kill pid "done" 167 | 168 | -- SafeCounter tests 169 | 170 | testSafeCounterCurrentState :: ProcessId -> TestResult Int -> Process () 171 | testSafeCounterCurrentState pid result = 172 | SafeCounter.getCount pid >>= stash result 173 | 174 | testSafeCounterIncrement :: ProcessId -> TestResult Int -> Process () 175 | testSafeCounterIncrement pid result = do 176 | 5 <- SafeCounter.getCount pid 177 | SafeCounter.resetCount pid 178 | 1 <- SafeCounter.incCount pid 179 | 2 <- SafeCounter.incCount pid 180 | SafeCounter.getCount pid >>= stash result 181 | 182 | -- Counter tests 183 | 184 | testCounterCurrentState :: TestResult Int -> Process () 185 | testCounterCurrentState result = do 186 | pid <- Counter.startCounter 5 187 | getCount pid >>= stash result 188 | 189 | testCounterIncrement :: TestResult Bool -> Process () 190 | testCounterIncrement result = do 191 | pid <- Counter.startCounter 1 192 | n <- getCount pid 193 | 2 <- incCount pid 194 | 3 <- incCount pid 195 | getCount pid >>= \n' -> stash result (n' == (n + 2)) 196 | 197 | testCounterExceedsLimit :: TestResult Bool -> Process () 198 | testCounterExceedsLimit result = do 199 | pid <- Counter.startCounter 1 200 | mref <- monitor pid 201 | 202 | -- exceed the limit 203 | 9 `times` (void $ incCount pid) 204 | 205 | -- this time we should fail 206 | _ <- (incCount pid) 207 | `catchExit` \_ (_ :: ExitReason) -> return 0 208 | 209 | r <- receiveWait [ 210 | matchIf (\(ProcessMonitorNotification ref _ _) -> ref == mref) 211 | (\(ProcessMonitorNotification _ _ r') -> return r') 212 | ] 213 | stash result (r /= DiedNormal) 214 | 215 | tests :: NT.Transport -> IO [Test] 216 | tests transport = do 217 | localNode <- newLocalNode transport initRemoteTable 218 | scpid <- newEmptyMVar 219 | _ <- forkProcess localNode $ SafeCounter.startCounter 5 >>= stash scpid 220 | safeCounter <- takeMVar scpid 221 | return [ 222 | testGroup "Basic Client/Server Functionality" [ 223 | testCase "basic call with explicit server reply" 224 | (delayedAssertion 225 | "expected a response from the server" 226 | localNode (Just "foo") (testBasicCall $ wrap server)) 227 | , testCase "basic (unsafe) call with explicit server reply" 228 | (delayedAssertion 229 | "expected a response from the server" 230 | localNode (Just "foo") (testUnsafeBasicCall $ wrap server)) 231 | , testCase "basic call with implicit server reply" 232 | (delayedAssertion 233 | "expected n * 2 back from the server" 234 | localNode (Just 4) (testBasicCall_ $ wrap server)) 235 | , testCase "basic (unsafe) call with implicit server reply" 236 | (delayedAssertion 237 | "expected n * 2 back from the server" 238 | localNode (Just 4) (testUnsafeBasicCall_ $ wrap server)) 239 | , testCase "basic deferred call handling" 240 | (delayedAssertion "expected a response sent via replyTo" 241 | localNode (AsyncDone "Hello There") testDeferredCallResponse) 242 | , testCase "basic cast with manual send and explicit server continue" 243 | (delayedAssertion 244 | "expected pong back from the server" 245 | localNode (Just "pong") (testBasicCast $ wrap server)) 246 | , testCase "basic (unsafe) cast with manual send and explicit server continue" 247 | (delayedAssertion 248 | "expected pong back from the server" 249 | localNode (Just "pong") (testUnsafeBasicCast $ wrap server)) 250 | , testCase "basic channel based rpc" 251 | (delayedAssertion 252 | "expected response back from the server" 253 | localNode True testChannelBasedService) 254 | ] 255 | , testGroup "Unhandled Message Policies" [ 256 | testCase "unhandled input when policy = Terminate" 257 | (delayedAssertion 258 | "expected the server to stop upon receiving unhandled input" 259 | localNode (Just $ ExitOther "UnhandledInput") 260 | (testTerminatePolicy $ wrap server)) 261 | , testCase "(unsafe) unhandled input when policy = Terminate" 262 | (delayedAssertion 263 | "expected the server to stop upon receiving unhandled input" 264 | localNode (Just $ ExitOther "UnhandledInput") 265 | (testUnsafeTerminatePolicy $ wrap server)) 266 | , testCase "unhandled input when policy = Drop" 267 | (delayedAssertion 268 | "expected the server to ignore unhandled input and exit normally" 269 | localNode Nothing (testDropPolicy $ wrap (mkServer Drop))) 270 | , testCase "(unsafe) unhandled input when policy = Drop" 271 | (delayedAssertion 272 | "expected the server to ignore unhandled input and exit normally" 273 | localNode Nothing (testUnsafeDropPolicy $ wrap (mkServer Drop))) 274 | , testCase "unhandled input when policy = DeadLetter" 275 | (delayedAssertion 276 | "expected the server to forward unhandled messages" 277 | localNode (Just ("UNSOLICITED_MAIL", 500 :: Int)) 278 | (testDeadLetterPolicy $ \p -> mkServer (DeadLetter p))) 279 | , testCase "(unsafe) unhandled input when policy = DeadLetter" 280 | (delayedAssertion 281 | "expected the server to forward unhandled messages" 282 | localNode (Just ("UNSOLICITED_MAIL", 500 :: Int)) 283 | (testUnsafeDeadLetterPolicy $ \p -> mkServer (DeadLetter p))) 284 | , testCase "incoming messages are ignored whilst hibernating" 285 | (delayedAssertion 286 | "expected the server to remain in hibernation" 287 | localNode True (testHibernation $ wrap server)) 288 | , testCase "(unsafe) incoming messages are ignored whilst hibernating" 289 | (delayedAssertion 290 | "expected the server to remain in hibernation" 291 | localNode True (testUnsafeHibernation $ wrap server)) 292 | ] 293 | , testGroup "Server Exit Handling" [ 294 | testCase "simple exit handling" 295 | (delayedAssertion "expected handler to catch exception and continue" 296 | localNode Nothing (testSimpleErrorHandling $ explodingServer)) 297 | , testCase "(unsafe) simple exit handling" 298 | (delayedAssertion "expected handler to catch exception and continue" 299 | localNode Nothing (testUnsafeSimpleErrorHandling $ explodingServer)) 300 | , testCase "alternative exit handlers" 301 | (delayedAssertion "expected handler to catch exception and continue" 302 | localNode Nothing (testAlternativeErrorHandling $ explodingServer)) 303 | , testCase "(unsafe) alternative exit handlers" 304 | (delayedAssertion "expected handler to catch exception and continue" 305 | localNode Nothing (testUnsafeAlternativeErrorHandling $ explodingServer)) 306 | ] 307 | , testGroup "Advanced Server Interactions" [ 308 | testCase "taking arbitrary STM actions" 309 | (delayedAssertion 310 | "expected the server to read the STM queue and reply using STM" 311 | localNode True testExternalService) 312 | , testCase "using callSTM to manage non-CH interactions" 313 | (delayedAssertion 314 | "expected the server to reply back via the TQueue" 315 | localNode True testExternalCall) 316 | , testCase "getting error data back from callSTM" 317 | (delayedAssertion 318 | "expected the server to exit with ExitNormal" 319 | localNode True testExternalCallHaltingServer) 320 | , testCase "long running call cancellation" 321 | (delayedAssertion "expected to get AsyncCancelled" 322 | localNode True (testKillMidCall $ wrap server)) 323 | , testCase "(unsafe) long running call cancellation" 324 | (delayedAssertion "expected to get AsyncCancelled" 325 | localNode True (testUnsafeKillMidCall $ wrap server)) 326 | , testCase "server rejects call" 327 | (delayedAssertion "expected server to send CallRejected" 328 | localNode (ExitOther "invalid-call") (testServerRejectsMessage $ wrap server)) 329 | , testCase "invalid return type handling" 330 | (delayedAssertion 331 | "expected response to fail on runtime type verification" 332 | localNode True testCallReturnTypeMismatchHandling) 333 | , testCase "cast and explicit server timeout" 334 | (delayedAssertion 335 | "expected the server to stop after the timeout" 336 | localNode (Just $ ExitOther "timeout") (testControlledTimeout $ wrap server)) 337 | , testCase "(unsafe) cast and explicit server timeout" 338 | (delayedAssertion 339 | "expected the server to stop after the timeout" 340 | localNode (Just $ ExitOther "timeout") (testUnsafeControlledTimeout $ wrap server)) 341 | ] 342 | , testGroup "math server examples" [ 343 | testCase "error (Left) returned from x / 0" 344 | (delayedAssertion 345 | "expected the server to return DivByZero" 346 | localNode (Left DivByZero) testDivByZero) 347 | , testCase "10 + 10 = 20" 348 | (delayedAssertion 349 | "expected the server to return DivByZero" 350 | localNode 20 testAdd) 351 | , testCase "10 + 10 does not evaluate to 10 :: Int at all!" 352 | (delayedAssertion 353 | "expected the server to return ExitOther..." 354 | localNode True testBadAdd) 355 | ] 356 | , testGroup "counter server examples" [ 357 | testCase "initial counter state = 5" 358 | (delayedAssertion 359 | "expected the server to return the initial state of 5" 360 | localNode 5 testCounterCurrentState) 361 | , testCase "increment counter twice" 362 | (delayedAssertion 363 | "expected the server to return the incremented state as 7" 364 | localNode True testCounterIncrement) 365 | , testCase "exceed counter limits" 366 | (delayedAssertion 367 | "expected the server to terminate once the limit was exceeded" 368 | localNode True testCounterExceedsLimit) 369 | ] 370 | , testGroup "safe counter examples" [ 371 | testCase "initial counter state = 5" 372 | (delayedAssertion 373 | "expected the server to return the initial state of 5" 374 | localNode 5 (testSafeCounterCurrentState safeCounter)) 375 | , testCase "increment counter twice" 376 | (delayedAssertion 377 | "expected the server to return the incremented state as 7" 378 | localNode 2 (testSafeCounterIncrement safeCounter)) 379 | ] 380 | ] 381 | 382 | main :: IO () 383 | main = testMain $ tests 384 | -------------------------------------------------------------------------------- /tests/TestPrioritisedProcess.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | 5 | module Main where 6 | 7 | import Control.Concurrent.MVar 8 | import Control.Concurrent.STM.TQueue 9 | ( newTQueueIO 10 | , readTQueue 11 | , writeTQueue 12 | ) 13 | import Control.Exception (SomeException) 14 | import Control.DeepSeq (NFData) 15 | import Control.Distributed.Process hiding (call, send, catch, sendChan, wrapMessage) 16 | import Control.Distributed.Process.Node 17 | import Control.Distributed.Process.Extras hiding (__remoteTable, monitor) 18 | import Control.Distributed.Process.Async hiding (check) 19 | import Control.Distributed.Process.ManagedProcess hiding (reject, Message) 20 | import qualified Control.Distributed.Process.ManagedProcess.Server.Priority as P (Message) 21 | import Control.Distributed.Process.ManagedProcess.Server.Priority hiding (Message) 22 | import qualified Control.Distributed.Process.ManagedProcess.Server.Gen as Gen 23 | ( dequeue 24 | , continue 25 | , lift 26 | ) 27 | import Control.Distributed.Process.SysTest.Utils 28 | import Control.Distributed.Process.Extras.Time 29 | import Control.Distributed.Process.Extras.Timer hiding (runAfter) 30 | import Control.Distributed.Process.Serializable() 31 | import Control.Monad 32 | import Control.Monad.Catch (catch) 33 | 34 | import Data.Binary 35 | import Data.Either (rights) 36 | import Data.List (isInfixOf) 37 | import Data.Maybe (isNothing, isJust) 38 | import Data.Typeable (Typeable) 39 | 40 | #if ! MIN_VERSION_base(4,6,0) 41 | import Prelude hiding (catch) 42 | #endif 43 | 44 | import Test.Framework (Test, testGroup) 45 | import Test.Framework.Providers.HUnit (testCase) 46 | import TestUtils 47 | import ManagedProcessCommon 48 | 49 | import qualified Network.Transport as NT 50 | 51 | import GHC.Generics (Generic) 52 | 53 | -- utilities 54 | 55 | server :: Process (ProcessId, (MVar ExitReason)) 56 | server = mkServer Terminate 57 | 58 | mkServer :: UnhandledMessagePolicy 59 | -> Process (ProcessId, (MVar ExitReason)) 60 | mkServer policy = 61 | let s = standardTestServer policy 62 | p = s `prioritised` ([] :: [DispatchPriority ()]) 63 | in do 64 | exitReason <- liftIO $ newEmptyMVar 65 | pid <- spawnLocal $ do 66 | catch ((pserve () (statelessInit Infinity) p >> stash exitReason ExitNormal) 67 | `catchesExit` [ 68 | (\_ msg -> do 69 | mEx <- unwrapMessage msg :: Process (Maybe ExitReason) 70 | case mEx of 71 | Nothing -> return Nothing 72 | Just r -> stash exitReason r >>= return . Just 73 | ) 74 | ]) 75 | (\(e :: SomeException) -> stash exitReason $ ExitOther (show e)) 76 | return (pid, exitReason) 77 | 78 | explodingServer :: ProcessId 79 | -> Process (ProcessId, MVar ExitReason) 80 | explodingServer pid = 81 | let srv = explodingTestProcess pid 82 | pSrv = srv `prioritised` ([] :: [DispatchPriority s]) 83 | in do 84 | exitReason <- liftIO newEmptyMVar 85 | spid <- spawnLocal $ do 86 | catch (pserve () (statelessInit Infinity) pSrv >> stash exitReason ExitNormal) 87 | (\(e :: SomeException) -> do 88 | -- say "died in handler..." 89 | stash exitReason $ ExitOther (show e)) 90 | return (spid, exitReason) 91 | 92 | data GetState = GetState 93 | deriving (Typeable, Generic, Show, Eq) 94 | instance Binary GetState where 95 | instance NFData GetState where 96 | 97 | data MyAlarmSignal = MyAlarmSignal 98 | deriving (Typeable, Generic, Show, Eq) 99 | instance Binary MyAlarmSignal where 100 | instance NFData MyAlarmSignal where 101 | 102 | mkPrioritisedServer :: Process ProcessId 103 | mkPrioritisedServer = 104 | let p = procDef `prioritised` ([ 105 | prioritiseInfo_ (\MyAlarmSignal -> setPriority 10) 106 | , prioritiseCast_ (\(_ :: String) -> setPriority 2) 107 | , prioritiseCall_ (\(cmd :: String) -> (setPriority (length cmd)) :: Priority ()) 108 | ] :: [DispatchPriority [Either MyAlarmSignal String]] 109 | ) :: PrioritisedProcessDefinition [(Either MyAlarmSignal String)] 110 | in spawnLocal $ pserve () (initWait Infinity) p 111 | where 112 | initWait :: Delay 113 | -> InitHandler () [Either MyAlarmSignal String] 114 | initWait d () = do 115 | () <- expect 116 | return $ InitOk [] d 117 | 118 | procDef :: ProcessDefinition [(Either MyAlarmSignal String)] 119 | procDef = 120 | defaultProcess { 121 | apiHandlers = [ 122 | handleCall (\s GetState -> reply (reverse s) s) 123 | , handleCall (\s (cmd :: String) -> reply () ((Right cmd):s)) 124 | , handleCast (\s (cmd :: String) -> continue ((Right cmd):s)) 125 | ] 126 | , infoHandlers = [ 127 | handleInfo (\s (sig :: MyAlarmSignal) -> continue ((Left sig):s)) 128 | ] 129 | , unhandledMessagePolicy = Drop 130 | , timeoutHandler = \_ _ -> stop $ ExitOther "timeout" 131 | } :: ProcessDefinition [(Either MyAlarmSignal String)] 132 | 133 | mkOverflowHandlingServer :: (PrioritisedProcessDefinition Int -> 134 | PrioritisedProcessDefinition Int) 135 | -> Process ProcessId 136 | mkOverflowHandlingServer modIt = 137 | let p = procDef `prioritised` ([ 138 | prioritiseCall_ (\GetState -> setPriority 99 :: Priority Int) 139 | , prioritiseCast_ (\(_ :: String) -> setPriority 1) 140 | ] :: [DispatchPriority Int] 141 | ) :: PrioritisedProcessDefinition Int 142 | in spawnLocal $ pserve () (initWait Infinity) (modIt p) 143 | where 144 | initWait :: Delay 145 | -> InitHandler () Int 146 | initWait d () = return $ InitOk 0 d 147 | 148 | procDef :: ProcessDefinition Int 149 | procDef = 150 | defaultProcess { 151 | apiHandlers = [ 152 | handleCall (\s GetState -> reply s s) 153 | , handleCast (\s (_ :: String) -> continue $ s + 1) 154 | ] 155 | } :: ProcessDefinition Int 156 | 157 | launchStmServer :: CallHandler () String String -> Process StmServer 158 | launchStmServer handler = do 159 | (inQ, replyQ) <- liftIO $ do 160 | cIn <- newTQueueIO 161 | cOut <- newTQueueIO 162 | return (cIn, cOut) 163 | 164 | let procDef = statelessProcess { 165 | externHandlers = [ 166 | handleCallExternal 167 | (readTQueue inQ) 168 | (writeTQueue replyQ) 169 | handler 170 | ] 171 | , apiHandlers = [ 172 | action (\() -> stop_ ExitNormal) 173 | ] 174 | } 175 | 176 | let p = procDef `prioritised` ([ 177 | prioritiseCast_ (\() -> setPriority 99 :: Priority ()) 178 | , prioritiseCast_ (\(_ :: String) -> setPriority 100) 179 | ] :: [DispatchPriority ()] 180 | ) :: PrioritisedProcessDefinition () 181 | 182 | pid <- spawnLocal $ pserve () (statelessInit Infinity) p 183 | return $ StmServer pid inQ replyQ 184 | 185 | launchStmOverloadServer :: Process (ProcessId, ControlPort String) 186 | launchStmOverloadServer = do 187 | cc <- newControlChan :: Process (ControlChannel String) 188 | let cp = channelControlPort cc 189 | 190 | let procDef = statelessProcess { 191 | externHandlers = [ 192 | handleControlChan_ cc (\(_ :: String) -> continue_) 193 | ] 194 | , apiHandlers = [ 195 | handleCast (\s sp -> sendChan sp () >> continue s) 196 | ] 197 | } 198 | 199 | let p = procDef `prioritised` ([ 200 | prioritiseCast_ (\() -> setPriority 99 :: Priority ()) 201 | ] :: [DispatchPriority ()] 202 | ) :: PrioritisedProcessDefinition () 203 | 204 | pid <- spawnLocal $ pserve () (statelessInit Infinity) p 205 | return (pid, cp) 206 | 207 | data Foo = Foo deriving (Show) 208 | 209 | launchFilteredServer :: ProcessId -> Process (ProcessId, ControlPort (SendPort Int)) 210 | launchFilteredServer us = do 211 | cc <- newControlChan :: Process (ControlChannel (SendPort Int)) 212 | let cp = channelControlPort cc 213 | 214 | let procDef = defaultProcess { 215 | externHandlers = [ 216 | handleControlChan cc (\s (p :: SendPort Int) -> sendChan p s >> continue s) 217 | ] 218 | , apiHandlers = [ 219 | handleCast (\s sp -> sendChan sp () >> continue s) 220 | , handleCall_ (\(s :: String) -> return s) 221 | , handleCall_ (\(i :: Int) -> return i) 222 | ] 223 | , unhandledMessagePolicy = DeadLetter us 224 | } :: ProcessDefinition Int 225 | 226 | let p = procDef `prioritised` ([ 227 | prioritiseCast_ (\() -> setPriority 1 :: Priority ()) 228 | , prioritiseCall_ (\(_ :: String) -> setPriority 100 :: Priority String) 229 | ] :: [DispatchPriority Int] 230 | ) :: PrioritisedProcessDefinition Int 231 | 232 | let rejectUnchecked = 233 | rejectApi Foo :: Int -> P.Message String String -> Process (Filter Int) 234 | 235 | let p' = p { 236 | filters = [ 237 | store (+1) 238 | , ensure (>0) -- a bit pointless, but we're just checking the API 239 | 240 | , check $ api_ (\(s :: String) -> return $ "checked-" `isInfixOf` s) rejectUnchecked 241 | , check $ info (\_ (_ :: MonitorRef, _ :: ProcessId) -> return False) $ reject Foo 242 | , refuse ((> 10) :: Int -> Bool) 243 | ] 244 | } 245 | 246 | pid <- spawnLocal $ pserve 0 (\c -> return $ InitOk c Infinity) p' 247 | return (pid, cp) 248 | 249 | testStupidInfiniteLoop :: TestResult Bool -> Process () 250 | testStupidInfiniteLoop result = do 251 | let def = statelessProcess { 252 | apiHandlers = [ 253 | handleCast (\_ sp -> eval $ do q <- processQueue 254 | m <- Gen.dequeue 255 | Gen.lift $ sendChan sp (length q, m) 256 | Gen.continue) 257 | ] 258 | , infoHandlers = [ 259 | handleInfo (\_ (m :: String) -> eval $ do enqueue (wrapMessage m) 260 | Gen.continue) 261 | ] 262 | } :: ProcessDefinition () 263 | 264 | let prio = def `prioritised` [] 265 | pid <- spawnLocal $ pserve () (statelessInit Infinity) prio 266 | 267 | -- this message should create an infinite loop 268 | send pid "fooboo" 269 | 270 | (sp, rp) <- newChan :: Process (SendPort (Int, Maybe Message), ReceivePort (Int, Maybe Message)) 271 | 272 | cast pid sp 273 | (i, m) <- receiveChan rp 274 | 275 | cast pid sp 276 | (i', m') <- receiveChan rp 277 | 278 | stash result $ (i == 1 && isJust m && i' == 0 && isNothing m') 279 | 280 | testFilteringBehavior :: TestResult Bool -> Process () 281 | testFilteringBehavior result = do 282 | us <- getSelfPid 283 | (sp, rp) <- newChan 284 | (pid, cp) <- launchFilteredServer us 285 | mRef <- monitor pid 286 | 287 | sendControlMessage cp sp 288 | 289 | r <- receiveChan rp :: Process Int 290 | when (r > 1) $ stash result False >> die "we're done..." 291 | 292 | Left _ <- safeCall pid "bad-input" :: Process (Either ExitReason String) 293 | 294 | send pid (mRef, us) -- server doesn't like this, dead letters it... 295 | -- back to us 296 | void $ receiveWait [ matchIf (\(m, p) -> m == mRef && p == us) return ] 297 | 298 | sendControlMessage cp sp 299 | 300 | r2 <- receiveChan rp :: Process Int 301 | when (r2 < 3) $ stash result False >> die "we're done again..." 302 | 303 | -- server also doesn't like this, and sends it right back (via \DeadLetter us/) 304 | send pid (25 :: Int) 305 | 306 | m <- receiveWait [ matchIf (== 25) return ] :: Process Int 307 | stash result $ m == 25 308 | kill pid "done" 309 | 310 | testServerSwap :: TestResult Bool -> Process () 311 | testServerSwap result = do 312 | us <- getSelfPid 313 | let def2 = statelessProcess { apiHandlers = [ handleCast (\s (i :: Int) -> send us (i, i+1) >> continue s) 314 | , handleCall_ (\(i :: Int) -> return (i * 5)) 315 | ] 316 | , unhandledMessagePolicy = Drop -- otherwise `call` would fail 317 | } 318 | let def = statelessProcess 319 | { apiHandlers = [ handleCall_ (\(m :: String) -> return m) ] 320 | , infoHandlers = [ handleInfo (\s () -> become def2 s) ] 321 | } `prioritised` [] 322 | 323 | pid <- spawnLocal $ pserve () (statelessInit Infinity) def 324 | 325 | m1 <- call pid "hello there" 326 | let a1 = m1 == "hello there" 327 | 328 | send pid () --changeover 329 | 330 | m2 <- callTimeout pid "are you there?" (seconds 5) :: Process (Maybe String) 331 | let a2 = isNothing m2 332 | 333 | cast pid (45 :: Int) 334 | res <- receiveWait [ matchIf (\(i :: Int) -> i == 45) (return . Left) 335 | , match (\(_ :: Int, j :: Int) -> return $ Right j) ] 336 | 337 | let a3 = res == (Right 46) 338 | 339 | m4 <- call pid (20 :: Int) :: Process Int 340 | let a4 = m4 == 100 341 | 342 | stash result $ a1 && a2 && a3 && a4 343 | 344 | testSafeExecutionContext :: TestResult Bool -> Process () 345 | testSafeExecutionContext result = do 346 | let t = (asTimeout $ seconds 5) 347 | (sigSp, rp) <- newChan 348 | (wp, lp) <- newChan 349 | let def = statelessProcess 350 | { apiHandlers = [ handleCall_ (\(m :: String) -> stranded rp wp Nothing >> return m) ] 351 | , infoHandlers = [ handleInfo (\s (m :: String) -> stranded rp wp (Just m) >> continue s) ] 352 | , exitHandlers = [ handleExit (\_ s (_ :: String) -> continue s) ] 353 | } `prioritised` [] 354 | 355 | let spec = def { filters = [ 356 | safe (\_ (_ :: String) -> True) 357 | , apiSafe (\_ (_ :: String) (_ :: Maybe String) -> True) 358 | ] 359 | } 360 | 361 | pid <- spawnLocal $ pserve () (statelessInit Infinity) spec 362 | send pid "hello" -- pid can't process this as it's stuck waiting on rp 363 | 364 | sleep $ seconds 3 365 | exit pid "ooops" -- now we force an exit signal once the receiveWait finishes 366 | sendChan sigSp () -- and allow the receiveWait to complete 367 | send pid "hi again" 368 | 369 | -- at this point, "hello" should still be in the backing queue/mailbox 370 | sleep $ seconds 3 371 | 372 | -- We should still be seeing "hello", since the 'safe' block saved us from 373 | -- losing a message when we handled and swallowed the exit signal. 374 | -- We should not see "hi again" until after "hello" has been processed 375 | h <- receiveChanTimeout t lp 376 | -- say $ "first response: " ++ (show h) 377 | let a1 = h == (Just "hello") 378 | 379 | sleep $ seconds 3 380 | 381 | -- now we should have "hi again" waiting in the mailbox... 382 | sendChan sigSp () -- we must release the handler a second time... 383 | h2 <- receiveChanTimeout t lp 384 | -- say $ "second response: " ++ (show h2) 385 | let a2 = h2 == (Just "hi again") 386 | 387 | void $ spawnLocal $ call pid "reply-please" >>= sendChan wp 388 | 389 | -- the call handler should be stuck waiting on rp 390 | Nothing <- receiveChanTimeout (asTimeout $ seconds 2) lp 391 | 392 | -- now let's force an exit, then release the handler to see if it runs again... 393 | exit pid "ooops2" 394 | 395 | sleep $ seconds 2 396 | sendChan sigSp () 397 | 398 | h3 <- receiveChanTimeout t lp 399 | -- say $ "third response: " ++ (show h3) 400 | let a3 = h3 == (Just "reply-please") 401 | 402 | stash result $ a1 && a2 && a3 403 | 404 | where 405 | 406 | stranded :: ReceivePort () -> SendPort String -> Maybe String -> Process () 407 | stranded gate chan str = do 408 | -- say $ "stranded with " ++ (show str) 409 | void $ receiveWait [ matchChan gate return ] 410 | sleep $ seconds 1 411 | case str of 412 | Nothing -> return () 413 | Just s -> sendChan chan s 414 | 415 | testExternalTimedOverflowHandling :: TestResult Bool -> Process () 416 | testExternalTimedOverflowHandling result = do 417 | (pid, cp) <- launchStmOverloadServer -- default 10k mailbox drain limit 418 | wrk <- spawnLocal $ mapM_ (sendControlMessage cp . show) ([1..500000] :: [Int]) 419 | 420 | sleep $ milliSeconds 250 -- give the worker time to start spamming the server... 421 | 422 | (sp, rp) <- newChan 423 | cast pid sp -- tell the server we're expecting a reply 424 | 425 | -- it might take "a while" for us to get through the first 10k messages 426 | -- from our chatty friend wrk, before we finally get our control message seen 427 | -- by the reader/listener loop, and in fact timing wise we don't even know when 428 | -- our message will arrive, since we're racing with wrk to communicate with 429 | -- the server. It's important therefore to give sufficient time for the right 430 | -- conditions to occur so that our message is finally received and processed, 431 | -- yet we don't want to lock up the build for 10-20 mins either. This value 432 | -- of 30 seconds seems like a reasonable compromise. 433 | answer <- receiveChanTimeout (asTimeout $ seconds 30) rp 434 | 435 | stash result $ answer == Just () 436 | kill wrk "done" 437 | kill pid "done" 438 | 439 | testExternalCall :: TestResult Bool -> Process () 440 | testExternalCall result = do 441 | let txt = "hello stm-call foo" 442 | srv <- launchStmServer (\st (msg :: String) -> reply msg st) 443 | echoStm srv txt >>= stash result . (== Right txt) 444 | killProc srv "done" 445 | 446 | testTimedOverflowHandling :: TestResult Bool -> Process () 447 | testTimedOverflowHandling result = do 448 | pid <- mkOverflowHandlingServer (\s -> s { recvTimeout = RecvTimer $ within 3 Seconds }) 449 | wrk <- spawnLocal $ mapM_ (cast pid . show) ([1..500000] :: [Int]) 450 | 451 | sleep $ seconds 1 -- give the worker time to start spamming us... 452 | cast pid "abc" -- just getting in line here... 453 | 454 | st <- call pid GetState :: Process Int 455 | -- the result of GetState is a list of messages in reverse insertion order 456 | stash result $ st > 0 457 | kill wrk "done" 458 | kill pid "done" 459 | 460 | testOverflowHandling :: TestResult Bool -> Process () 461 | testOverflowHandling result = do 462 | pid <- mkOverflowHandlingServer (\s -> s { recvTimeout = RecvMaxBacklog 100 }) 463 | wrk <- spawnLocal $ mapM_ (cast pid . show) ([1..50000] :: [Int]) 464 | 465 | sleep $ seconds 1 466 | cast pid "abc" -- just getting in line here... 467 | 468 | st <- call pid GetState :: Process Int 469 | -- the result of GetState is a list of messages in reverse insertion order 470 | stash result $ st > 0 471 | kill wrk "done" 472 | kill pid "done" 473 | 474 | testInfoPrioritisation :: TestResult Bool -> Process () 475 | testInfoPrioritisation result = do 476 | pid <- mkPrioritisedServer 477 | -- the server (pid) is configured to wait for () during its init 478 | -- so we can fill up its mailbox with String messages, and verify 479 | -- that the alarm signal (which is prioritised *above* these) 480 | -- actually gets processed first despite the delivery order 481 | cast pid "hello" 482 | cast pid "prioritised" 483 | cast pid "world" 484 | -- note that these have to be a "bare send" 485 | send pid MyAlarmSignal 486 | -- tell the server it can move out of init and start processing messages 487 | send pid () 488 | st <- call pid GetState :: Process [Either MyAlarmSignal String] 489 | -- the result of GetState is a list of messages in reverse insertion order 490 | case head st of 491 | Left MyAlarmSignal -> stash result True 492 | _ -> stash result False 493 | 494 | testUserTimerHandling :: TestResult Bool -> Process () 495 | testUserTimerHandling result = do 496 | us <- getSelfPid 497 | let p = (procDef us) `prioritised` ([ 498 | prioritiseInfo_ (\MyAlarmSignal -> setPriority 100) 499 | ] :: [DispatchPriority ()] 500 | ) :: PrioritisedProcessDefinition () 501 | pid <- spawnLocal $ pserve () (statelessInit Infinity) p 502 | cast pid () 503 | expect >>= stash result . (== MyAlarmSignal) 504 | kill pid "goodbye..." 505 | 506 | where 507 | 508 | procDef :: ProcessId -> ProcessDefinition () 509 | procDef us = 510 | statelessProcess { 511 | apiHandlers = [ 512 | handleCast (\s () -> evalAfter (seconds 5) MyAlarmSignal s) 513 | ] 514 | , infoHandlers = [ 515 | handleInfo (\s (sig :: MyAlarmSignal) -> send us sig >> continue s) 516 | ] 517 | , unhandledMessagePolicy = Drop 518 | } :: ProcessDefinition () 519 | 520 | 521 | testCallPrioritisation :: TestResult Bool -> Process () 522 | testCallPrioritisation result = do 523 | pid <- mkPrioritisedServer 524 | asyncRefs <- (mapM (callAsync pid) 525 | ["first", "the longest", "commands", "we do prioritise"]) 526 | :: Process [Async ()] 527 | -- NB: This sleep is really important - the `init' function is waiting 528 | -- (selectively) on the () signal to go, and if it receives this *before* 529 | -- the async worker has had a chance to deliver the longest string message, 530 | -- our test will fail. Such races are /normal/ given that the async worker 531 | -- runs in another process and delivery order between multiple processes 532 | -- is undefined (and in practise, partially depenendent on the scheduler) 533 | sleep $ seconds 1 534 | send pid () 535 | _ <- mapM wait asyncRefs :: Process [AsyncResult ()] 536 | st <- call pid GetState :: Process [Either MyAlarmSignal String] 537 | let ms = rights st 538 | stash result $ ms == ["we do prioritise", "the longest", "commands", "first"] 539 | 540 | tests :: NT.Transport -> IO [Test] 541 | tests transport = do 542 | localNode <- newLocalNode transport initRemoteTable 543 | return [ 544 | testGroup "basic server functionality matches un-prioritised processes" [ 545 | testCase "basic call with explicit server reply" 546 | (delayedAssertion 547 | "expected a response from the server" 548 | localNode (Just "foo") (testBasicCall $ wrap server)) 549 | , testCase "basic call with implicit server reply" 550 | (delayedAssertion 551 | "expected n * 2 back from the server" 552 | localNode (Just 4) (testBasicCall_ $ wrap server)) 553 | , testCase "basic deferred call handling" 554 | (delayedAssertion "expected a response sent via replyTo" 555 | localNode (AsyncDone "Hello There") testDeferredCallResponse) 556 | , testCase "basic cast with manual send and explicit server continue" 557 | (delayedAssertion 558 | "expected pong back from the server" 559 | localNode (Just "pong") (testBasicCast $ wrap server)) 560 | , testCase "cast and explicit server timeout" 561 | (delayedAssertion 562 | "expected the server to stop after the timeout" 563 | localNode (Just $ ExitOther "timeout") (testControlledTimeout $ wrap server)) 564 | , testCase "unhandled input when policy = Terminate" 565 | (delayedAssertion 566 | "expected the server to stop upon receiving unhandled input" 567 | localNode (Just $ ExitOther "UnhandledInput") 568 | (testTerminatePolicy $ wrap server)) 569 | , testCase "unhandled input when policy = Drop" 570 | (delayedAssertion 571 | "expected the server to ignore unhandled input and exit normally" 572 | localNode Nothing (testDropPolicy $ wrap (mkServer Drop))) 573 | , testCase "unhandled input when policy = DeadLetter" 574 | (delayedAssertion 575 | "expected the server to forward unhandled messages" 576 | localNode (Just ("UNSOLICITED_MAIL", 500 :: Int)) 577 | (testDeadLetterPolicy $ \p -> mkServer (DeadLetter p))) 578 | , testCase "incoming messages are ignored whilst hibernating" 579 | (delayedAssertion 580 | "expected the server to remain in hibernation" 581 | localNode True (testHibernation $ wrap server)) 582 | , testCase "long running call cancellation" 583 | (delayedAssertion "expected to get AsyncCancelled" 584 | localNode True (testKillMidCall $ wrap server)) 585 | , testCase "server rejects call" 586 | (delayedAssertion "expected server to send CallRejected" 587 | localNode (ExitOther "invalid-call") (testServerRejectsMessage $ wrap server)) 588 | , testCase "simple exit handling" 589 | (delayedAssertion "expected handler to catch exception and continue" 590 | localNode Nothing (testSimpleErrorHandling $ explodingServer)) 591 | , testCase "alternative exit handlers" 592 | (delayedAssertion "expected handler to catch exception and continue" 593 | localNode Nothing (testAlternativeErrorHandling $ explodingServer)) 594 | ] 595 | , testGroup "Prioritised Mailbox Handling" [ 596 | testCase "Info Message Prioritisation" 597 | (delayedAssertion "expected the info handler to be prioritised" 598 | localNode True testInfoPrioritisation) 599 | , testCase "Call Message Prioritisation" 600 | (delayedAssertion "expected the longest strings to be prioritised" 601 | localNode True testCallPrioritisation) 602 | , testCase "Size-Based Mailbox Overload Management" 603 | (delayedAssertion "expected the server loop to stop reading the mailbox" 604 | localNode True testOverflowHandling) 605 | , testCase "Timeout-Based Mailbox Overload Management" 606 | (delayedAssertion "expected the server loop to stop reading the mailbox" 607 | localNode True testTimedOverflowHandling) 608 | ] 609 | , testGroup "Advanced Server Interactions" [ 610 | testCase "using callSTM to manage non-CH interactions" 611 | (delayedAssertion 612 | "expected the server to reply back via the TQueue" 613 | localNode True testExternalCall) 614 | , testCase "Timeout-Based Overload Management with Control Channels" 615 | (delayedAssertion "expected the server loop to reply" 616 | localNode True testExternalTimedOverflowHandling) 617 | , testCase "Complex pre/before filters" 618 | (delayedAssertion "expected verifiable filter actions" 619 | localNode True testFilteringBehavior) 620 | , testCase "Firing internal timeouts" 621 | (delayedAssertion "expected our info handler to run after the timeout" 622 | localNode True testUserTimerHandling) 623 | , testCase "Creating 'Safe' Handlers" 624 | (delayedAssertion "expected our handler to run on the old message" 625 | localNode True testSafeExecutionContext) 626 | , testCase "Swapping ProcessDefinitions at runtime" 627 | (delayedAssertion "expected our handler to exist in the new handler list" 628 | localNode True testServerSwap) 629 | , testCase "Accessing the internal process implementation" 630 | (delayedAssertion "it should allow us to modify the internal q" 631 | localNode True testStupidInfiniteLoop) 632 | ] 633 | ] 634 | 635 | main :: IO () 636 | main = testMain $ tests 637 | -------------------------------------------------------------------------------- /tests/TestUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | module TestUtils 6 | ( testMain 7 | , mkNode 8 | , waitForExit 9 | ) where 10 | 11 | import Control.Concurrent.MVar 12 | ( MVar 13 | , takeMVar 14 | ) 15 | 16 | import Control.Distributed.Process 17 | import Control.Distributed.Process.Node 18 | import Control.Distributed.Process.Extras 19 | import Control.Distributed.Process.Extras.Time 20 | import Control.Distributed.Process.Extras.Timer 21 | import Test.Framework (Test, defaultMain) 22 | 23 | import Network.Transport.TCP 24 | import qualified Network.Transport as NT 25 | 26 | waitForExit :: MVar ExitReason 27 | -> Process (Maybe ExitReason) 28 | waitForExit exitReason = do 29 | -- we *might* end up blocked here, so ensure the test doesn't jam up! 30 | self <- getSelfPid 31 | tref <- killAfter (within 10 Seconds) self "testcast timed out" 32 | tr <- liftIO $ takeMVar exitReason 33 | cancelTimer tref 34 | case tr of 35 | ExitNormal -> return Nothing 36 | other -> return $ Just other 37 | 38 | mkNode :: String -> IO LocalNode 39 | mkNode port = do 40 | Right (transport1, _) <- createTransportExposeInternals 41 | "127.0.0.1" port ("127.0.0.1",) defaultTCPParameters 42 | newLocalNode transport1 initRemoteTable 43 | 44 | -- | Given a @builder@ function, make and run a test suite on a single transport 45 | testMain :: (NT.Transport -> IO [Test]) -> IO () 46 | testMain builder = do 47 | Right (transport, _) <- createTransportExposeInternals 48 | "127.0.0.1" "0" ("127.0.0.1",) defaultTCPParameters 49 | testData <- builder transport 50 | defaultMain testData 51 | --------------------------------------------------------------------------------