├── .ghci ├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── CONTRIBUTING.md ├── LICENCE ├── NOTES ├── README.md ├── REPOS ├── Setup.lhs ├── benchmarks ├── dtp-benchmarks.cabal └── src │ └── CounterServer.hs ├── distributed-process-platform.cabal ├── profiling ├── configure.sh └── run.sh ├── regressions ├── HRoqLeak.hs └── LeakByteStrings.hs ├── src └── Control │ ├── Concurrent │ └── Utils.hs │ └── Distributed │ └── Process │ ├── Platform.hs │ └── Platform │ ├── Async.hs │ ├── Async │ ├── AsyncChan.hs │ ├── AsyncSTM.hs │ └── Types.hs │ ├── Call.hs │ ├── Execution.hs │ ├── Execution │ ├── EventManager.hs │ ├── Exchange.hs │ ├── Exchange │ │ ├── Broadcast.hs │ │ ├── Internal.hs │ │ └── Router.hs │ └── Mailbox.hs │ ├── Internal │ ├── Containers.hs │ ├── Containers │ │ └── MultiMap.hs │ ├── IdentityPool.hs │ ├── Primitives.hs │ ├── Queue │ │ ├── PriorityQ.hs │ │ └── SeqQ.hs │ ├── Types.hs │ └── Unsafe.hs │ ├── ManagedProcess.hs │ ├── ManagedProcess │ ├── Client.hs │ ├── Internal │ │ ├── GenProcess.hs │ │ └── Types.hs │ ├── Server.hs │ ├── Server │ │ ├── Priority.hs │ │ └── Restricted.hs │ └── UnsafeClient.hs │ ├── Service.hs │ ├── Service │ ├── Monitoring.hs │ ├── Registry.hs │ └── SystemLog.hs │ ├── Supervisor.hs │ ├── Supervisor │ └── Types.hs │ ├── Task.hs │ ├── Task │ └── Queue │ │ └── BlockingQueue.hs │ ├── Test.hs │ ├── Time.hs │ ├── Timer.hs │ └── UnsafePrimitives.hs ├── test-report.hs └── tests ├── Counter.hs ├── MailboxTestFilters.hs ├── ManagedProcessCommon.hs ├── MathsDemo.hs ├── SafeCounter.hs ├── TestAsync.hs ├── TestAsyncChan.hs ├── TestAsyncSTM.hs ├── TestExchange.hs ├── TestLog.hs ├── TestMailbox.hs ├── TestManagedProcess.hs ├── TestPrimitives.hs ├── TestPrioritisedProcess.hs ├── TestQueues.hs ├── TestRegistry.hs ├── TestSupervisor.hs ├── TestTaskQueues.hs ├── TestTimer.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: CABALVER=1.22 GHCVER=7.6.3 8 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.6.3], sources: [hvr-ghc]}} 9 | - env: CABALVER=1.22 GHCVER=7.8.4 10 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4], sources: [hvr-ghc]}} 11 | - env: CABALVER=1.22 GHCVER=7.10.2 12 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2],sources: [hvr-ghc]}} 13 | 14 | before_install: 15 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:~/.cabal/bin:$PATH 16 | - ghc --version 17 | - cabal --version 18 | - cabal update 19 | # workaround for https://ghc.haskell.org/trac/ghc/ticket/9221 20 | # taken from https://github.com/hvr/multi-ghc-travis/blob/0fa68f78c2b1b059f904c9abc85510a3bb4f57e2/README.md 21 | - sed -i 's/^jobs:/-- jobs:/' $HOME/.cabal/config 22 | 23 | install: 24 | - cabal install --jobs=2 --enable-tests --only-dependencies . 25 | 26 | script: 27 | - cabal configure --enable-tests 28 | - cabal test --show-details=streaming --test-options="--plain" 29 | 30 | notifications: 31 | email: 32 | recipients: 33 | - cloud.haskell@gmail.com 34 | irc: 35 | channels: 36 | - "irc.freenode.org#haskell-distributed" 37 | use_notice: true 38 | template: 39 | - "\x0313d-p-platform\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" 40 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # HEAD 2 | 3 | * Added initial GenServer module 4 | * Added Timer Module 5 | * Moved time functions into Time.hs 6 | * Added Async API 7 | * Added GenProcess API (subsumes lower level GenServer API) 8 | 9 | -------------------------------------------------------------------------------- /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 | # distribributed-process-platform 2 | [![travis](https://secure.travis-ci.org/haskell-distributed/distributed-process-platform.png)](http://travis-ci.org/haskell-distributed/distributed-process-platform) 3 | [![Release](https://img.shields.io/hackage/v/distributed-process-platform.svg)](https://hackage.haskell.org/package/distributed-process-platform) 4 | 5 | See http://haskell-distributed.github.com for documentation, user guides, 6 | tutorials and assistance. 7 | 8 | ## Getting Help / Raising Issues 9 | 10 | Please visit the [bug tracker](https://github.com/haskell-distributed/distributed-process-platform/issues) to submit issues. You can contact the distributed-haskell@googlegroups.com mailing list for help and comments. 11 | 12 | ## License 13 | 14 | This package is made available under a 3-clause BSD-style license. 15 | -------------------------------------------------------------------------------- /REPOS: -------------------------------------------------------------------------------- 1 | rank1dynamic 2 | distributed-static 3 | network-transport 4 | network-transport-tcp 5 | distributed-process 6 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /profiling/configure.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | cabal clean 3 | cabal configure --enable-library-profiling --enable-executable-profiling 4 | -------------------------------------------------------------------------------- /profiling/run.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | PROG=dtp 3 | VIEW=open 4 | FLAGS= 5 | DIST_DIR=./dist 6 | 7 | 8 | cabal build 9 | mkdir -p ${DIST_DIR}/profiling 10 | ( 11 | cd ${DIST_DIR}/profiling 12 | ../build/${PROG}/${PROG} ${FLAGS} +RTS -p -hc -s${PROG}.summary 13 | hp2ps ${PROG}.hp 14 | ) 15 | ${VIEW} ${DIST_DIR}/profiling/${PROG}.ps 16 | cat ${DIST_DIR}/profiling/${PROG}.summary -------------------------------------------------------------------------------- /regressions/HRoqLeak.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | import Control.Applicative ((<$>), (<*>)) 6 | import Control.Concurrent 7 | import Control.Distributed.Process hiding (call) 8 | import Control.Distributed.Process.Node 9 | import Control.Distributed.Process.Platform 10 | import Control.Distributed.Process.Platform.ManagedProcess hiding (runProcess) 11 | import Control.Exception as Exception 12 | import Data.List(elemIndices,isInfixOf) 13 | import System.Directory 14 | import System.IO 15 | import System.IO.Error 16 | import Control.Monad(when,replicateM,foldM,liftM3,liftM2,liftM) 17 | import Control.Distributed.Process.Platform.Time 18 | import Data.Binary 19 | import Data.DeriveTH 20 | import Data.Maybe 21 | import Data.Typeable (Typeable) 22 | import Network.Transport.TCP (createTransportExposeInternals, defaultTCPParameters) 23 | import qualified Data.ByteString.Lazy.Char8 as B 24 | import qualified Data.Map as Map 25 | import qualified Data.ByteString.Lazy as L 26 | 27 | -- --------------------------------------------------------------------- 28 | 29 | main = do 30 | -- EKG.forkServer "localhost" 8000 31 | 32 | node <- startLocalNode 33 | 34 | -- runProcess node worker 35 | runProcess node worker 36 | 37 | closeLocalNode node 38 | 39 | return () 40 | 41 | -- --------------------------------------------------------------------- 42 | 43 | worker :: Process () 44 | worker = do 45 | sid <- startHroqMnesia () 46 | logm "mnesia started" 47 | 48 | let table = TN "mnesiattest" 49 | 50 | -- create_table DiscCopies table RecordTypeQueueEntry 51 | 52 | -- wait_for_tables [table] Infinity 53 | 54 | -- ms2 <- get_state 55 | -- logm $ "mnesia state ms2:" ++ (show ms2) 56 | 57 | let qe = QE (QK "a") (qval $ "bar2") 58 | mapM_ (\n -> dirty_write_q sid table (QE (QK "a") (qval $ "bar" ++ (show n)))) [1..800] 59 | -- mapM_ (\n -> dirty_write_q table qe) [1..800] 60 | -- mapM_ (\n -> do_dirty_write_q s table qe) [1..800] 61 | 62 | liftIO $ threadDelay (5*1000000) -- 1 seconds 63 | 64 | say $ "mnesia blurble" 65 | 66 | liftIO $ threadDelay (2*60*1000000) 67 | -- liftIO $ threadDelay (10*60*1000000) -- Ten minutes 68 | return () 69 | 70 | -- --------------------------------------------------------------------- 71 | -- --------------------------------------------------------------------- 72 | 73 | startLocalNode :: IO LocalNode 74 | startLocalNode = do 75 | -- [role, host, port] <- getArgs 76 | let [role, host, port] = ["foo","127.0.0.1", "10519"] 77 | -- Right transport <- createTransport host port defaultTCPParameters 78 | Right (transport,_internals) <- createTransportExposeInternals host port defaultTCPParameters 79 | node <- newLocalNode transport initRemoteTable 80 | -- startLoggerProcess node 81 | return node 82 | 83 | logm = say 84 | 85 | -- --------------------------------------------------------------------- 86 | 87 | -- qval str = QV $ Map.fromList [(str,str)] 88 | qval str = QV str 89 | 90 | -- --------------------------------------------------------------------- 91 | 92 | data QKey = QK !String 93 | deriving (Typeable,Show,Read,Eq,Ord) 94 | 95 | instance Binary QKey where 96 | put (QK i) = put i 97 | get = do 98 | i <- get 99 | return $ QK i 100 | 101 | 102 | -- data QValue = QV !(Map.Map String String) 103 | data QValue = QV !String 104 | deriving (Typeable,Read,Show) 105 | data QEntry = QE !QKey -- ^Id 106 | !QValue -- ^payload 107 | deriving (Typeable,Read,Show) 108 | 109 | instance Binary QValue where 110 | put (QV v) = put v 111 | get = QV <$> get 112 | 113 | 114 | instance Binary QEntry where 115 | put (QE k v) = put k >> put v 116 | get = do 117 | k <- get 118 | v <- get 119 | return $ QE k v 120 | 121 | -- --------------------------------------------------------------------- 122 | 123 | startHroqMnesia :: a -> Process ProcessId 124 | startHroqMnesia initParams = do 125 | let server = serverDefinition 126 | sid <- spawnLocal $ start initParams initFunc server >> return () 127 | -- register hroqMnesiaName sid 128 | return sid 129 | 130 | data State = ST Int 131 | 132 | -- init callback 133 | initFunc :: InitHandler a State 134 | initFunc _ = do 135 | let s = ST 0 136 | return $ InitOk s Infinity 137 | 138 | -- , dirty_write_q 139 | data DirtyWriteQ = DirtyWriteQ !TableName !QEntry 140 | deriving (Typeable, Show) 141 | 142 | instance Binary DirtyWriteQ where 143 | put (DirtyWriteQ tn key) = put tn >> put key 144 | get = DirtyWriteQ <$> get <*> get 145 | 146 | 147 | -- , get_state 148 | data GetState = GetState 149 | deriving (Typeable,Show) 150 | 151 | instance Binary GetState where 152 | put GetState = putWord8 1 153 | get = do 154 | v <- getWord8 155 | case v of 156 | 1 -> return GetState 157 | 158 | -- --------------------------------------------------------------------- 159 | 160 | data TableName = TN !String 161 | deriving (Show,Read,Typeable,Eq,Ord) 162 | 163 | instance Binary TableName where 164 | put (TN s) = put s 165 | get = do 166 | s <- get 167 | return (TN s) 168 | 169 | -- ----------------------------------------------------------------------------- 170 | -- API 171 | 172 | dirty_write_q :: ProcessId -> TableName -> QEntry -> Process () 173 | dirty_write_q sid tablename val = call sid (DirtyWriteQ tablename val) 174 | 175 | -------------------------------------------------------------------------------- 176 | -- Implementation -- 177 | -------------------------------------------------------------------------------- 178 | 179 | serverDefinition :: ProcessDefinition State 180 | serverDefinition = defaultProcess { 181 | apiHandlers = [ 182 | handleCall handleDirtyWriteQ 183 | ] 184 | , infoHandlers = 185 | [ 186 | -- handleInfo_ (\(ProcessMonitorNotification _ _ r) -> logm $ show r >> continue_) 187 | handleInfo (\dict (ProcessMonitorNotification _ _ r) -> do {logm $ show r; continue dict }) 188 | ] 189 | , timeoutHandler = \_ _ -> stop $ TerminateOther "timeout az" 190 | , shutdownHandler = \_ reason -> do { logm $ "HroqMnesia shutdownHandler:" ++ (show reason) } 191 | } :: ProcessDefinition State 192 | 193 | -- --------------------------------------------------------------------- 194 | -- handlers 195 | 196 | handleDirtyWriteQ :: State -> DirtyWriteQ -> Process (ProcessReply State ()) 197 | handleDirtyWriteQ s (DirtyWriteQ tableName val) = do 198 | s' <- do_dirty_write_q s tableName val 199 | reply () s' 200 | 201 | -- --------------------------------------------------------------------- 202 | -- actual workers 203 | 204 | do_dirty_write_q :: 205 | State -> TableName -> QEntry -> Process State 206 | do_dirty_write_q s tableName record = do 207 | -- logm $ "dirty_write:" ++ (show (tableName,record)) 208 | liftIO $ defaultAppend (tableNameToFileName tableName) (encode record) 209 | 210 | -- let s' = insertEntryQ s tableName record 211 | -- return s' 212 | return s 213 | 214 | -- --------------------------------------------------------------------- 215 | 216 | directoryPrefix :: String 217 | directoryPrefix = ".hroqdata/" 218 | 219 | tableNameToFileName :: TableName -> FilePath 220 | tableNameToFileName (TN tableName) = directoryPrefix ++ tableName 221 | 222 | 223 | -- --------------------------------------------------------------------- 224 | 225 | defaultWrite :: FilePath -> B.ByteString -> IO () 226 | defaultWrite filename x = safeFileOp B.writeFile filename x 227 | 228 | defaultAppend :: FilePath -> B.ByteString -> IO () 229 | defaultAppend filename x = safeFileOp B.appendFile filename x 230 | 231 | -- --------------------------------------------------------------------- 232 | 233 | safeFileOp :: (FilePath -> B.ByteString -> IO ()) -> FilePath -> B.ByteString -> IO () 234 | safeFileOp op filename str= handle handler $ op filename str -- !> ("write "++filename) 235 | where 236 | handler e-- (e :: IOError) 237 | | isDoesNotExistError e=do 238 | createDirectoryIfMissing True $ take (1+(last $ elemIndices '/' filename)) filename --maybe the path does not exist 239 | safeFileOp op filename str 240 | 241 | | otherwise= if ("invalid" `isInfixOf` ioeGetErrorString e) 242 | then 243 | error $ "writeResource: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path" 244 | else do 245 | hPutStrLn stderr $ "defaultWriteResource: " ++ show e ++ " in file: " ++ filename ++ " retrying" 246 | safeFileOp op filename str 247 | 248 | 249 | -------------------------------------------------------------------------------- /regressions/LeakByteStrings.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent (threadDelay) 4 | import Control.Distributed.Process hiding (call) 5 | import Control.Distributed.Process.Node 6 | import Control.Distributed.Process.Platform.Async.AsyncChan hiding (worker) 7 | import qualified Control.Distributed.Process.Platform.Async.AsyncChan as C (worker) 8 | import Control.Distributed.Process.Platform.ManagedProcess hiding 9 | (call, callAsync, shutdown, runProcess) 10 | import qualified Control.Distributed.Process.Platform.ManagedProcess as P (call, shutdown) 11 | import Control.Distributed.Process.Platform.Time 12 | import Control.Distributed.Process.Platform.Timer 13 | import Control.Exception (SomeException) 14 | import Network.Transport.TCP (createTransportExposeInternals, defaultTCPParameters) 15 | import Prelude hiding (catch) 16 | 17 | import Data.Time.Clock (getCurrentTime) 18 | import Data.Time.Format (formatTime) 19 | import System.Locale (defaultTimeLocale) 20 | 21 | {-# INLINE forever' #-} 22 | forever' :: Monad m => m a -> m b 23 | forever' a = let a' = a >> a' in a' 24 | 25 | main :: IO () 26 | main = do 27 | node <- startLocalNode 28 | runProcess node $ doWork True False 29 | runProcess node $ doWork False False 30 | -- runProcess node $ doWork True False 31 | 32 | -- runProcess node worker 33 | -- runProcess node $ do 34 | -- sleep $ seconds 10 35 | -- say "done...." 36 | threadDelay $ (1*1000000) 37 | closeLocalNode node 38 | return () 39 | 40 | worker :: Process () 41 | worker = do 42 | server <- startGenServer 43 | _ <- monitor server 44 | 45 | mapM_ (\(n :: Int) -> (P.call server ("bar" ++ (show n))) :: Process String) [1..800] 46 | 47 | -- sleep $ seconds 3 48 | -- P.shutdown server 49 | -- receiveWait [ match (\(ProcessMonitorNotification _ _ _) -> return ()) ] 50 | 51 | say "server is idle now..." 52 | sleep $ seconds 5 53 | 54 | doWork :: Bool -> Bool -> Process () 55 | doWork useAsync killServer = 56 | let call' = case useAsync of 57 | True -> callAsync 58 | False -> call 59 | in do 60 | server <- spawnLocal $ forever' $ do 61 | receiveWait [ match (\(pid, _ :: String) -> send pid ()) ] 62 | 63 | mapM_ (\(n :: Int) -> (call' server (show n)) :: Process () ) [1..800] 64 | sleep $ seconds 4 65 | say "done" 66 | case killServer of 67 | True -> kill server "stop" 68 | False -> return () 69 | sleep $ seconds 1 70 | 71 | startLocalNode :: IO LocalNode 72 | startLocalNode = do 73 | Right (transport,_) <- createTransportExposeInternals "127.0.0.1" 74 | "8081" 75 | defaultTCPParameters 76 | node <- newLocalNode transport initRemoteTable 77 | return node 78 | 79 | callAsync :: ProcessId -> String -> Process () 80 | callAsync pid s = do 81 | asyncRef <- async $ AsyncTask $ call pid s 82 | (AsyncDone _) <- wait asyncRef 83 | return () 84 | 85 | call :: ProcessId -> String -> Process () 86 | call pid s = do 87 | self <- getSelfPid 88 | send pid (self, s) 89 | expect :: Process () 90 | 91 | startGenServer :: Process ProcessId 92 | startGenServer = do 93 | sid <- spawnLocal $ do 94 | catch (start () (statelessInit Infinity) serverDefinition >> return ()) 95 | (\(e :: SomeException) -> say $ "failed with " ++ (show e)) 96 | return sid 97 | 98 | serverDefinition :: ProcessDefinition () 99 | serverDefinition = 100 | statelessProcess { 101 | apiHandlers = [ 102 | handleCall_ (\(s :: String) -> return s) 103 | , handleCast (\s (_ :: String) -> continue s) 104 | ] 105 | } 106 | 107 | -------------------------------------------------------------------------------- /src/Control/Concurrent/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Control.Concurrent.Utils 5 | ( Lock() 6 | , Exclusive(..) 7 | , Synchronised(..) 8 | , withLock 9 | ) where 10 | 11 | import Control.Distributed.Process 12 | ( Process 13 | ) 14 | import qualified Control.Distributed.Process as Process (catch) 15 | import Control.Exception (SomeException, throw) 16 | import qualified Control.Exception as Exception (catch) 17 | import Control.Concurrent.MVar 18 | ( MVar 19 | , tryPutMVar 20 | , newMVar 21 | , takeMVar 22 | ) 23 | import Control.Monad.IO.Class (MonadIO, liftIO) 24 | 25 | newtype Lock = Lock { mvar :: MVar () } 26 | 27 | class Exclusive a where 28 | new :: IO a 29 | acquire :: (MonadIO m) => a -> m () 30 | release :: (MonadIO m) => a -> m () 31 | 32 | instance Exclusive Lock where 33 | new = return . Lock =<< newMVar () 34 | acquire = liftIO . takeMVar . mvar 35 | release l = liftIO (tryPutMVar (mvar l) ()) >> return () 36 | 37 | class Synchronised e m where 38 | synchronised :: (Exclusive e, Monad m) => e -> m b -> m b 39 | 40 | synchronized :: (Exclusive e, Monad m) => e -> m b -> m b 41 | synchronized = synchronised 42 | 43 | instance Synchronised Lock IO where 44 | synchronised = withLock 45 | 46 | instance Synchronised Lock Process where 47 | synchronised = withLockP 48 | 49 | withLockP :: (Exclusive e) => e -> Process a -> Process a 50 | withLockP excl act = do 51 | Process.catch (do { liftIO $ acquire excl 52 | ; result <- act 53 | ; liftIO $ release excl 54 | ; return result 55 | }) 56 | (\(e :: SomeException) -> (liftIO $ release excl) >> throw e) 57 | 58 | withLock :: (Exclusive e) => e -> IO a -> IO a 59 | withLock excl act = do 60 | Exception.catch (do { acquire excl 61 | ; result <- act 62 | ; release excl 63 | ; return result 64 | }) 65 | (\(e :: SomeException) -> release excl >> throw e) 66 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform.hs: -------------------------------------------------------------------------------- 1 | {- | [Cloud Haskell Platform] 2 | 3 | [Evaluation Strategies and Support for NFData] 4 | 5 | When sending messages to a local process (i.e., intra-node), the default 6 | approach is to encode (i.e., serialise) the message /anyway/, just to 7 | ensure that no unevaluated thunks are passed to the receiver. 8 | In distributed-process, you must explicitly choose to use /unsafe/ primitives 9 | that do nothing to ensure evaluation, since this might cause an error in the 10 | receiver which would be difficult to debug. Using @NFData@, it is possible 11 | to force evaluation, but there is no way to ensure that both the @NFData@ 12 | and @Binary@ instances do so in the same way (i.e., to the same depth, etc) 13 | therefore automatic use of @NFData@ is not possible in distributed-process. 14 | 15 | By contrast, distributed-process-platform makes extensive use of @NFData@ 16 | to force evaluation (and avoid serialisation overheads during intra-node 17 | communication), via the @NFSerializable@ type class. This does nothing to 18 | fix the potential disparity between @NFData@ and @Binary@ instances, so you 19 | should verify that your data is being handled as expected (e.g., by sticking 20 | to strict fields, or some such) and bear in mind that things could go wrong. 21 | 22 | The @UnsafePrimitives@ module in /this/ library will force evaluation before 23 | calling the @UnsafePrimitives@ in distributed-process, which - if you've 24 | vetted everything correctly - should provide a bit more safety, whilst still 25 | keeping performance at an acceptable level. 26 | 27 | Users of the various service and utility models (such as @ManagedProcess@ and 28 | the @Service@ and @Task@ APIs) should consult the sub-system specific 29 | documentation for instructions on how to utilise these features. 30 | 31 | IMPORTANT NOTICE: Despite the apparent safety of forcing evaluation before 32 | sending, we /still/ cannot make any actual guarantees about the evaluation 33 | semantics of these operations, and therefore the /unsafe/ moniker will remain 34 | in place, in one form or another, for all functions and modules that use them. 35 | 36 | [Error/Exception Handling] 37 | 38 | It is /important/ not to be too general when catching exceptions in 39 | cloud haskell application, because asynchonous exceptions provide cloud haskell 40 | with its process termination mechanism. Two exception types in particular, 41 | signal the instigator's intention to stop a process immediately, which are 42 | raised (i.e., thrown) in response to the @kill@ and @exit@ primitives provided 43 | by the base distributed-process package. 44 | 45 | You should generally try to keep exception handling code to the lowest (i.e., 46 | most specific) scope possible. If you wish to trap @exit@ signals, use the 47 | various flavours of @catchExit@ primitive from distributed-process. 48 | 49 | -} 50 | module Control.Distributed.Process.Platform 51 | ( 52 | -- * Exported Types 53 | Addressable 54 | , Resolvable(..) 55 | , Routable(..) 56 | , Linkable(..) 57 | , Killable(..) 58 | , NFSerializable 59 | , Recipient(..) 60 | , ExitReason(..) 61 | , Channel 62 | , Tag 63 | , TagPool 64 | 65 | -- * Primitives overriding those in distributed-process 66 | , monitor 67 | , module Control.Distributed.Process.Platform.UnsafePrimitives 68 | 69 | -- * Utilities and Extended Primitives 70 | , spawnSignalled 71 | , spawnLinkLocal 72 | , spawnMonitorLocal 73 | , linkOnFailure 74 | , times 75 | , isProcessAlive 76 | , matchCond 77 | , deliver 78 | , awaitExit 79 | , awaitResponse 80 | 81 | -- * Call/Tagging support 82 | , newTagPool 83 | , getTag 84 | 85 | -- * Registration and Process Lookup 86 | , whereisOrStart 87 | , whereisOrStartRemote 88 | 89 | -- remote call table 90 | , __remoteTable 91 | ) where 92 | 93 | import Control.Distributed.Process (RemoteTable) 94 | import Control.Distributed.Process.Platform.Internal.Types 95 | ( NFSerializable 96 | , Recipient(..) 97 | , ExitReason(..) 98 | , Tag 99 | , TagPool 100 | , Channel 101 | , newTagPool 102 | , getTag 103 | ) 104 | import Control.Distributed.Process.Platform.UnsafePrimitives 105 | import Control.Distributed.Process.Platform.Internal.Primitives hiding (__remoteTable) 106 | import qualified Control.Distributed.Process.Platform.Internal.Primitives (__remoteTable) 107 | import qualified Control.Distributed.Process.Platform.Internal.Types (__remoteTable) 108 | import qualified Control.Distributed.Process.Platform.Execution.Mailbox (__remoteTable) 109 | 110 | -- remote table 111 | 112 | __remoteTable :: RemoteTable -> RemoteTable 113 | __remoteTable = 114 | Control.Distributed.Process.Platform.Execution.Mailbox.__remoteTable . 115 | Control.Distributed.Process.Platform.Internal.Primitives.__remoteTable . 116 | Control.Distributed.Process.Platform.Internal.Types.__remoteTable 117 | 118 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Async/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ExistentialQuantification #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | 8 | -- | shared, internal types for the Async package 9 | module Control.Distributed.Process.Platform.Async.Types 10 | ( -- * Exported types 11 | Async(..) 12 | , AsyncRef 13 | , AsyncTask(..) 14 | , AsyncResult(..) 15 | ) where 16 | 17 | import Control.Distributed.Process 18 | import Control.Distributed.Process.Platform.Time 19 | import Control.Distributed.Process.Serializable 20 | ( Serializable 21 | , SerializableDict 22 | ) 23 | import Data.Binary 24 | import Data.Typeable (Typeable) 25 | 26 | import GHC.Generics 27 | 28 | -- | An opaque handle that refers to an asynchronous operation. 29 | data Async a = Async { 30 | hPoll :: Process (AsyncResult a) 31 | , hWait :: Process (AsyncResult a) 32 | , hWaitTimeout :: TimeInterval -> Process (Maybe (AsyncResult a)) 33 | , hCancel :: Process () 34 | , asyncWorker :: ProcessId 35 | } 36 | 37 | -- | A reference to an asynchronous action 38 | type AsyncRef = ProcessId 39 | 40 | -- | A task to be performed asynchronously. 41 | data AsyncTask a = 42 | AsyncTask { 43 | asyncTask :: Process a -- ^ the task to be performed 44 | } 45 | | AsyncRemoteTask { 46 | asyncTaskDict :: Static (SerializableDict a) 47 | -- ^ the serializable dict required to spawn a remote process 48 | , asyncTaskNode :: NodeId 49 | -- ^ the node on which to spawn the asynchronous task 50 | , asyncTaskProc :: Closure (Process a) 51 | -- ^ the task to be performed, wrapped in a closure environment 52 | } 53 | 54 | -- | Represents the result of an asynchronous action, which can be in one of 55 | -- several states at any given time. 56 | data AsyncResult a = 57 | AsyncDone a -- ^ a completed action and its result 58 | | AsyncFailed DiedReason -- ^ a failed action and the failure reason 59 | | AsyncLinkFailed DiedReason -- ^ a link failure and the reason 60 | | AsyncCancelled -- ^ a cancelled action 61 | | AsyncPending -- ^ a pending action (that is still running) 62 | deriving (Typeable, Generic) 63 | 64 | instance Serializable a => Binary (AsyncResult a) where 65 | 66 | deriving instance Eq a => Eq (AsyncResult a) 67 | deriving instance Show a => Show (AsyncResult a) 68 | 69 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Execution.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Distributed.Process.Platform.Execution 4 | -- Copyright : (c) Tim Watson 2013 - 2014 5 | -- License : BSD3 (see the file LICENSE) 6 | -- 7 | -- Maintainer : Tim Watson 8 | -- Stability : experimental 9 | -- Portability : non-portable (requires concurrency) 10 | -- 11 | -- [Inter-Process Traffic Management] 12 | -- 13 | -- The /Execution Framework/ provides tools for load regulation, workload 14 | -- shedding and remote hand-off. The currently implementation provides only 15 | -- a subset of the plumbing required, comprising tools for event management, 16 | -- mailbox buffering and message routing. 17 | -- 18 | ----------------------------------------------------------------------------- 19 | 20 | module Control.Distributed.Process.Platform.Execution 21 | ( -- * Mailbox Buffering 22 | module Control.Distributed.Process.Platform.Execution.Mailbox 23 | -- * Message Exchanges 24 | , module Control.Distributed.Process.Platform.Execution.Exchange 25 | ) where 26 | 27 | import Control.Distributed.Process.Platform.Execution.Exchange hiding (startSupervised) 28 | import Control.Distributed.Process.Platform.Execution.Mailbox hiding (startSupervised, post) 29 | 30 | {- 31 | 32 | Load regulation requires that we apply limits to various parts of the system. 33 | The manner in which they're applied may vary, but the mechanisms are limited 34 | to: 35 | 36 | 1. rejecting the activity/request 37 | 2. accepting the activity immediately 38 | 3. blocking some or all requestors 39 | 4. blocking some (or all) activities 40 | 5. terminiating some (or all) activities 41 | 42 | -} 43 | 44 | 45 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Execution/EventManager.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE ImpredicativeTypes #-} 9 | 10 | ----------------------------------------------------------------------------- 11 | -- | 12 | -- Module : Control.Distributed.Process.Platform.Execution.EventManager 13 | -- Copyright : (c) Well-Typed / Tim Watson 14 | -- License : BSD3 (see the file LICENSE) 15 | -- 16 | -- Maintainer : Tim Watson 17 | -- Stability : experimental 18 | -- Portability : non-portable (requires concurrency) 19 | -- 20 | -- [Overview] 21 | -- 22 | -- The /EventManager/ is a parallel/concurrent event handling tool, built on 23 | -- top of the /Exchange API/. Arbitrary events are published to the event 24 | -- manager using 'notify', and are broadcast simulataneously to a set of 25 | -- registered /event handlers/. 26 | -- 27 | -- [Defining and Registering Event Handlers] 28 | -- 29 | -- Event handlers are defined as @Serializable m => s -> m -> Process s@, 30 | -- i.e., an expression taking an initial state, an arbitrary @Serializable@ 31 | -- event/message and performing an action in the @Process@ monad that evaluates 32 | -- to a new state. 33 | -- 34 | -- See "Control.Distributed.Process.Platform.Execution.Exchange". 35 | -- 36 | ----------------------------------------------------------------------------- 37 | 38 | module Control.Distributed.Process.Platform.Execution.EventManager 39 | ( EventManager 40 | , start 41 | , startSupervised 42 | , startSupervisedRef 43 | , notify 44 | , addHandler 45 | , addMessageHandler 46 | ) where 47 | 48 | import Control.Distributed.Process hiding (Message, link) 49 | import qualified Control.Distributed.Process as P (Message) 50 | import Control.Distributed.Process.Platform.Execution.Exchange 51 | ( Exchange 52 | , Message(..) 53 | , post 54 | , broadcastExchange 55 | , broadcastExchangeT 56 | , broadcastClient 57 | ) 58 | import qualified Control.Distributed.Process.Platform.Execution.Exchange as Exchange 59 | ( startSupervised 60 | ) 61 | import Control.Distributed.Process.Platform.Internal.Primitives 62 | import Control.Distributed.Process.Platform.Internal.Unsafe 63 | ( InputStream 64 | , matchInputStream 65 | ) 66 | import Control.Distributed.Process.Platform.Supervisor (SupervisorPid) 67 | import Control.Distributed.Process.Serializable hiding (SerializableDict) 68 | import Data.Binary 69 | import Data.Typeable (Typeable) 70 | import GHC.Generics 71 | 72 | {- notes 73 | 74 | Event manager is implemented over a simple BroadcastExchange. We eschew the 75 | complexities of identifying handlers and allowing them to be removed/deleted 76 | or monitored, since we avoid running them in the exchange process. Instead, 77 | each handler runs as an independent process, leaving handler management up 78 | to the user and allowing all the usual process managemnet techniques (e.g., 79 | registration, supervision, etc) to be utilised instead. 80 | 81 | -} 82 | 83 | -- | Opaque handle to an Event Manager. 84 | -- 85 | newtype EventManager = EventManager { ex :: Exchange } 86 | deriving (Typeable, Generic) 87 | instance Binary EventManager where 88 | 89 | instance Resolvable EventManager where 90 | resolve = resolve . ex 91 | 92 | -- | Start a new /Event Manager/ process and return an opaque handle 93 | -- to it. 94 | start :: Process EventManager 95 | start = broadcastExchange >>= return . EventManager 96 | 97 | startSupervised :: SupervisorPid -> Process EventManager 98 | startSupervised sPid = do 99 | ex <- broadcastExchangeT >>= \t -> Exchange.startSupervised t sPid 100 | return $ EventManager ex 101 | 102 | startSupervisedRef :: SupervisorPid -> Process (ProcessId, P.Message) 103 | startSupervisedRef sPid = do 104 | ex <- startSupervised sPid 105 | Just pid <- resolve ex 106 | return (pid, unsafeWrapMessage ex) 107 | 108 | -- | Broadcast an event to all registered handlers. 109 | notify :: Serializable a => EventManager -> a -> Process () 110 | notify em msg = post (ex em) msg 111 | 112 | -- | Add a new event handler. The handler runs in its own process, 113 | -- which is spawned locally on behalf of the caller. 114 | addHandler :: forall s a. Serializable a 115 | => EventManager 116 | -> (s -> a -> Process s) 117 | -> Process s 118 | -> Process ProcessId 119 | addHandler m h s = 120 | spawnLocal $ newHandler (ex m) (\s' m' -> handleMessage m' (h s')) s 121 | 122 | -- | As 'addHandler', but operates over a raw @Control.Distributed.Process.Message@. 123 | addMessageHandler :: forall s. 124 | EventManager 125 | -> (s -> P.Message -> Process (Maybe s)) 126 | -> Process s 127 | -> Process ProcessId 128 | addMessageHandler m h s = spawnLocal $ newHandler (ex m) h s 129 | 130 | newHandler :: forall s . 131 | Exchange 132 | -> (s -> P.Message -> Process (Maybe s)) 133 | -> Process s 134 | -> Process () 135 | newHandler ex handler initState = do 136 | linkTo ex 137 | is <- broadcastClient ex 138 | listen is handler =<< initState 139 | 140 | listen :: forall s . InputStream Message 141 | -> (s -> P.Message -> Process (Maybe s)) 142 | -> s 143 | -> Process () 144 | listen inStream handler state = do 145 | receiveWait [ matchInputStream inStream ] >>= handleEvent inStream handler state 146 | where 147 | handleEvent is h s p = do 148 | r <- h s (payload p) 149 | let s2 = case r of 150 | Nothing -> s 151 | Just s' -> s' 152 | listen is h s2 153 | 154 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Execution/Exchange.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Distributed.Process.Platform.Execution.Exchange 4 | -- Copyright : (c) Tim Watson 2012 - 2014 5 | -- License : BSD3 (see the file LICENSE) 6 | -- 7 | -- Maintainer : Tim Watson 8 | -- Stability : experimental 9 | -- Portability : non-portable (requires concurrency) 10 | -- 11 | -- [Message Exchanges] 12 | -- 13 | -- The concept of a /message exchange/ is borrowed from the world of 14 | -- messaging and enterprise integration. The /exchange/ acts like a kind of 15 | -- mailbox, accepting inputs from /producers/ and forwarding these messages 16 | -- to one or more /consumers/, depending on the implementation's semantics. 17 | -- 18 | -- This module provides some basic types of message exchange and exposes an API 19 | -- for defining your own custom /exchange types/. 20 | -- 21 | -- [Broadcast Exchanges] 22 | -- 23 | -- The broadcast exchange type, started via 'broadcastExchange', forward their 24 | -- inputs to all registered consumers (as the name suggests). This exchange type 25 | -- is highly optimised for local (intra-node) traffic and provides two different 26 | -- kinds of client binding, one which causes messages to be delivered directly 27 | -- to the client's mailbox (viz 'bindToBroadcaster'), the other providing a 28 | -- separate stream of messages that can be obtained using the @expect@ and 29 | -- @receiveX@ family of messaging primitives (and thus composed with other forms 30 | -- of input selection, such as typed channels and selective reads on the process 31 | -- mailbox). 32 | -- 33 | -- /Important:/ When a @ProcessId@ is registered via 'bindToBroadcaster', only 34 | -- the payload of the 'Message' (i.e., the underlying @Serializable@ datum) is 35 | -- forwarded to the consumer, /not/ the whole 'Message' itself. 36 | -- 37 | -- [Router Exchanges] 38 | -- 39 | -- The /router/ API provides a means to selectively route messages to one or 40 | -- more clients, depending on the content of the 'Message'. Two modes of binding 41 | -- (and client selection) are provided out of the box, one of which matches the 42 | -- message 'key', the second of which matches on a name and value from the 43 | -- 'headers'. Alternative mechanisms for content based routing can be derived 44 | -- by modifying the 'BindingSelector' expression passed to 'router' 45 | -- 46 | -- See 'messageKeyRouter' and 'headerContentRouter' for the built-in routing 47 | -- exchanges, and 'router' for the extensible routing API. 48 | -- 49 | -- [Custom Exchange Types] 50 | -- 51 | -- Both the /broadcast/ and /router/ exchanges are implemented as custom 52 | -- /exchange types/. The mechanism for defining custom exchange behaviours 53 | -- such as these is very simple. Raw exchanges are started by evaluating 54 | -- 'startExchange' with a specific 'ExchangeType' record. This type is 55 | -- parameterised by the internal /state/ it holds, and defines two API callbacks 56 | -- in its 'configureEx' and 'routeEx' fields. The former is evaluated whenever a 57 | -- client process evaluates 'configureExchange', the latter whenever a client 58 | -- evaluates 'post' or 'postMessage'. The 'configureEx' callback takes a raw 59 | -- @Message@ (from "Control.Distributed.Process") and is responsible for 60 | -- decoding the message and updating its own state (if required). It is via 61 | -- this callback that custom exchange types can receive information about 62 | -- clients and handle it in their own way. The 'routeEx' callback is evaluated 63 | -- with the exchange type's own internal state and the 'Message' originally 64 | -- sent to the exchange process (via 'post') and is responsible for delivering 65 | -- the message to its clients in whatever way makes sense for that exchange 66 | -- type. 67 | -- 68 | ----------------------------------------------------------------------------- 69 | 70 | module Control.Distributed.Process.Platform.Execution.Exchange 71 | ( -- * Fundamental API 72 | Exchange() 73 | , Message(..) 74 | -- * Starting/Running an Exchange 75 | , startExchange 76 | , startSupervised 77 | , startSupervisedRef 78 | , runExchange 79 | -- * Client Facing API 80 | , post 81 | , postMessage 82 | , configureExchange 83 | , createMessage 84 | -- * Broadcast Exchange 85 | , broadcastExchange 86 | , broadcastExchangeT 87 | , broadcastClient 88 | , bindToBroadcaster 89 | , BroadcastExchange 90 | -- * Routing (Content Based) 91 | , HeaderName 92 | , Binding(..) 93 | , Bindable 94 | , BindingSelector 95 | , RelayType(..) 96 | -- * Starting a Router 97 | , router 98 | , supervisedRouter 99 | -- * Routing (Publishing) API 100 | , route 101 | , routeMessage 102 | -- * Routing via message/binding keys 103 | , messageKeyRouter 104 | , bindKey 105 | -- * Routing via message headers 106 | , headerContentRouter 107 | , bindHeader 108 | -- * Defining Custom Exchange Types 109 | , ExchangeType(..) 110 | , applyHandlers 111 | ) where 112 | 113 | import Control.Distributed.Process.Platform.Execution.Exchange.Broadcast 114 | ( broadcastExchange 115 | , broadcastExchangeT 116 | , broadcastClient 117 | , bindToBroadcaster 118 | , BroadcastExchange 119 | ) 120 | import Control.Distributed.Process.Platform.Execution.Exchange.Internal 121 | ( Exchange() 122 | , Message(..) 123 | , ExchangeType(..) 124 | , startExchange 125 | , startSupervised 126 | , startSupervisedRef 127 | , runExchange 128 | , post 129 | , postMessage 130 | , configureExchange 131 | , createMessage 132 | , applyHandlers 133 | ) 134 | import Control.Distributed.Process.Platform.Execution.Exchange.Router 135 | ( HeaderName 136 | , Binding(..) 137 | , Bindable 138 | , BindingSelector 139 | , RelayType(..) 140 | , router 141 | , supervisedRouter 142 | , route 143 | , routeMessage 144 | , messageKeyRouter 145 | , bindKey 146 | , headerContentRouter 147 | , bindHeader 148 | ) 149 | 150 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Execution/Exchange/Router.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE PatternGuards #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE EmptyDataDecls #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE ImpredicativeTypes #-} 11 | {-# LANGUAGE UndecidableInstances #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | 14 | -- | A simple API for /routing/, using a custom exchange type. 15 | module Control.Distributed.Process.Platform.Execution.Exchange.Router 16 | ( -- * Types 17 | HeaderName 18 | , Binding(..) 19 | , Bindable 20 | , BindingSelector 21 | , RelayType(..) 22 | -- * Starting a Router 23 | , router 24 | , supervisedRouter 25 | , supervisedRouterRef 26 | -- * Client (Publishing) API 27 | , route 28 | , routeMessage 29 | -- * Routing via message/binding keys 30 | , messageKeyRouter 31 | , bindKey 32 | -- * Routing via message headers 33 | , headerContentRouter 34 | , bindHeader 35 | ) where 36 | 37 | import Control.DeepSeq (NFData) 38 | import Control.Distributed.Process 39 | ( Process 40 | , ProcessMonitorNotification(..) 41 | , ProcessId 42 | , monitor 43 | , handleMessage 44 | , unsafeWrapMessage 45 | ) 46 | import qualified Control.Distributed.Process as P 47 | import Control.Distributed.Process.Serializable (Serializable) 48 | import Control.Distributed.Process.Platform.Execution.Exchange.Internal 49 | ( startExchange 50 | , startSupervised 51 | , configureExchange 52 | , Message(..) 53 | , Exchange 54 | , ExchangeType(..) 55 | , post 56 | , postMessage 57 | , applyHandlers 58 | ) 59 | import Control.Distributed.Process.Platform.Internal.Primitives 60 | ( deliver 61 | , Resolvable(..) 62 | ) 63 | import Control.Distributed.Process.Platform.Supervisor (SupervisorPid) 64 | import Data.Binary 65 | import Data.Foldable (forM_) 66 | import Data.Hashable 67 | import Data.HashMap.Strict (HashMap) 68 | import qualified Data.HashMap.Strict as Map 69 | import Data.HashSet (HashSet) 70 | import qualified Data.HashSet as Set 71 | import Data.Typeable (Typeable) 72 | import GHC.Generics 73 | 74 | type HeaderName = String 75 | 76 | -- | The binding key used by the built-in key and header based 77 | -- routers. 78 | data Binding = 79 | BindKey { bindingKey :: !String } 80 | | BindHeader { bindingKey :: !String 81 | , headerName :: !HeaderName 82 | } 83 | | BindNone 84 | deriving (Typeable, Generic, Eq, Show) 85 | instance Binary Binding where 86 | instance NFData Binding where 87 | instance Hashable Binding where 88 | 89 | -- | Things that can be used as binding keys in a router. 90 | class (Hashable k, Eq k, Serializable k) => Bindable k 91 | instance (Hashable k, Eq k, Serializable k) => Bindable k 92 | 93 | -- | Used to convert a 'Message' into a 'Bindable' routing key. 94 | type BindingSelector k = (Message -> Process k) 95 | 96 | -- | Given to a /router/ to indicate whether clients should 97 | -- receive 'Message' payloads only, or the whole 'Message' object 98 | -- itself. 99 | data RelayType = PayloadOnly | WholeMessage 100 | 101 | data State k = State { bindings :: !(HashMap k (HashSet ProcessId)) 102 | , selector :: !(BindingSelector k) 103 | , relayType :: !RelayType 104 | } 105 | 106 | type Router k = ExchangeType (State k) 107 | 108 | -------------------------------------------------------------------------------- 109 | -- Starting/Running the Exchange -- 110 | -------------------------------------------------------------------------------- 111 | 112 | -- | A router that matches on a 'Message' 'key'. To bind a client @Process@ to 113 | -- such an exchange, use the 'bindKey' function. 114 | messageKeyRouter :: RelayType -> Process Exchange 115 | messageKeyRouter t = router t matchOnKey -- (return . BindKey . key) 116 | where 117 | matchOnKey :: Message -> Process Binding 118 | matchOnKey m = return $ BindKey (key m) 119 | 120 | -- | A router that matches on a specific (named) header. To bind a client 121 | -- @Process@ to such an exchange, use the 'bindHeader' function. 122 | headerContentRouter :: RelayType -> HeaderName -> Process Exchange 123 | headerContentRouter t n = router t (checkHeaders n) 124 | where 125 | checkHeaders hn Message{..} = do 126 | case Map.lookup hn (Map.fromList headers) of 127 | Nothing -> return BindNone 128 | Just hv -> return $ BindHeader hn hv 129 | 130 | -- | Defines a /router/ exchange. The 'BindingSelector' is used to construct 131 | -- a binding (i.e., an instance of the 'Bindable' type @k@) for each incoming 132 | -- 'Message'. Such bindings are matched against bindings stored in the exchange. 133 | -- Clients of a /router/ exchange are identified by a binding, mapped to 134 | -- one or more 'ProcessId's. 135 | -- 136 | -- The format of the bindings, nature of their storage and mechanism for 137 | -- submitting new bindings is implementation dependent (i.e., will vary by 138 | -- exchange type). For example, the 'messageKeyRouter' and 'headerContentRouter' 139 | -- implementations both use the 'Binding' data type, which can represent a 140 | -- 'Message' key or a 'HeaderName' and content. As with all custom exchange 141 | -- types, bindings should be submitted by evaluating 'configureExchange' with 142 | -- a suitable data type. 143 | -- 144 | router :: (Bindable k) => RelayType -> BindingSelector k -> Process Exchange 145 | router t s = routerT t s >>= startExchange 146 | 147 | supervisedRouterRef :: Bindable k 148 | => RelayType 149 | -> BindingSelector k 150 | -> SupervisorPid 151 | -> Process (ProcessId, P.Message) 152 | supervisedRouterRef t sel spid = do 153 | ex <- supervisedRouter t sel spid 154 | Just pid <- resolve ex 155 | return (pid, unsafeWrapMessage ex) 156 | 157 | -- | Defines a /router/ that can be used in a supervision tree. 158 | supervisedRouter :: Bindable k 159 | => RelayType 160 | -> BindingSelector k 161 | -> SupervisorPid 162 | -> Process Exchange 163 | supervisedRouter t sel spid = 164 | routerT t sel >>= \t' -> startSupervised t' spid 165 | 166 | routerT :: Bindable k 167 | => RelayType 168 | -> BindingSelector k 169 | -> Process (Router k) 170 | routerT t s = do 171 | return $ ExchangeType { name = "Router" 172 | , state = State Map.empty s t 173 | , configureEx = apiConfigure 174 | , routeEx = apiRoute 175 | } 176 | 177 | -------------------------------------------------------------------------------- 178 | -- Client Facing API -- 179 | -------------------------------------------------------------------------------- 180 | 181 | -- | Add a binding (for the calling process) to a 'messageKeyRouter' exchange. 182 | bindKey :: String -> Exchange -> Process () 183 | bindKey k ex = do 184 | self <- P.getSelfPid 185 | configureExchange ex (self, BindKey k) 186 | 187 | -- | Add a binding (for the calling process) to a 'headerContentRouter' exchange. 188 | bindHeader :: HeaderName -> String -> Exchange -> Process () 189 | bindHeader n v ex = do 190 | self <- P.getSelfPid 191 | configureExchange ex (self, BindHeader v n) 192 | 193 | -- | Send a 'Serializable' message to the supplied 'Exchange'. The given datum 194 | -- will be converted to a 'Message', with the 'key' set to @""@ and the 195 | -- 'headers' to @[]@. 196 | -- 197 | -- The routing behaviour will be dependent on the choice of 'BindingSelector' 198 | -- given when initialising the /router/. 199 | route :: Serializable m => Exchange -> m -> Process () 200 | route = post 201 | 202 | -- | Send a 'Message' to the supplied 'Exchange'. 203 | -- The routing behaviour will be dependent on the choice of 'BindingSelector' 204 | -- given when initialising the /router/. 205 | routeMessage :: Exchange -> Message -> Process () 206 | routeMessage = postMessage 207 | 208 | -------------------------------------------------------------------------------- 209 | -- Exchage Definition/State & API Handlers -- 210 | -------------------------------------------------------------------------------- 211 | 212 | apiRoute :: forall k. Bindable k 213 | => State k 214 | -> Message 215 | -> Process (State k) 216 | apiRoute st@State{..} msg = do 217 | binding <- selector msg 218 | case Map.lookup binding bindings of 219 | Nothing -> return st 220 | Just bs -> forM_ bs (fwd relayType msg) >> return st 221 | where 222 | fwd WholeMessage m = deliver m 223 | fwd PayloadOnly m = P.forward (payload m) 224 | 225 | -- TODO: implement 'unbind' ??? 226 | -- TODO: apiConfigure currently leaks memory if clients die (we don't cleanup) 227 | 228 | apiConfigure :: forall k. Bindable k 229 | => State k 230 | -> P.Message 231 | -> Process (State k) 232 | apiConfigure st msg = do 233 | applyHandlers st msg $ [ \m -> handleMessage m (createBinding st) 234 | , \m -> handleMessage m (handleMonitorSignal st) 235 | ] 236 | where 237 | createBinding s@State{..} (pid, bind) = do 238 | case Map.lookup bind bindings of 239 | Nothing -> do _ <- monitor pid 240 | return $ s { bindings = newBind bind pid bindings } 241 | Just ps -> return $ s { bindings = addBind bind pid bindings ps } 242 | 243 | newBind b p bs = Map.insert b (Set.singleton p) bs 244 | addBind b' p' bs' ps = Map.insert b' (Set.insert p' ps) bs' 245 | 246 | handleMonitorSignal s@State{..} (ProcessMonitorNotification _ p _) = 247 | let bs = bindings 248 | bs' = Map.foldlWithKey' (\a k v -> Map.insert k (Set.delete p v) a) bs bs 249 | in return $ s { bindings = bs' } 250 | 251 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Internal/Containers.hs: -------------------------------------------------------------------------------- 1 | module Control.Distributed.Process.Internal.Containers where 2 | 3 | class (Eq k, Functor m) => Map m k | m -> k where 4 | empty :: m a 5 | member :: k -> m a -> Bool 6 | insert :: k -> a -> m a -> m a 7 | delete :: k -> m a -> m a 8 | lookup :: k -> m a -> a 9 | filter :: (a -> Bool) -> m a -> m a 10 | filterWithKey :: (k -> a -> Bool) -> m a -> m a 11 | 12 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Internal/Containers/MultiMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module Control.Distributed.Process.Platform.Internal.Containers.MultiMap 7 | ( MultiMap 8 | , Insertable 9 | , empty 10 | , insert 11 | , member 12 | , lookup 13 | , filter 14 | , filterWithKey 15 | , toList 16 | ) where 17 | 18 | import qualified Data.Foldable as Foldable 19 | 20 | import Data.Hashable 21 | import Data.HashMap.Strict (HashMap) 22 | import qualified Data.HashMap.Strict as Map 23 | import Data.HashSet (HashSet) 24 | import qualified Data.HashSet as Set 25 | import Data.Foldable (Foldable) 26 | import Prelude hiding (lookup, filter, pred) 27 | 28 | -- | Class of things that can be inserted in a map or 29 | -- a set (of mapped values), for which instances of 30 | -- @Eq@ and @Hashable@ must be present. 31 | -- 32 | class (Eq a, Hashable a) => Insertable a 33 | instance (Eq a, Hashable a) => Insertable a 34 | 35 | -- | Opaque type of MultiMaps. 36 | data MultiMap k v = M { hmap :: !(HashMap k (HashSet v)) } 37 | 38 | -- instance Foldable 39 | 40 | instance Foldable (MultiMap k) where 41 | foldr f = foldrWithKey (const f) 42 | 43 | empty :: MultiMap k v 44 | empty = M $ Map.empty 45 | 46 | insert :: forall k v. (Insertable k, Insertable v) 47 | => k -> v -> MultiMap k v -> MultiMap k v 48 | insert k' v' M{..} = 49 | case Map.lookup k' hmap of 50 | Nothing -> M $ Map.insert k' (Set.singleton v') hmap 51 | Just s -> M $ Map.insert k' (Set.insert v' s) hmap 52 | {-# INLINE insert #-} 53 | 54 | member :: (Insertable k) => k -> MultiMap k a -> Bool 55 | member k = Map.member k . hmap 56 | 57 | lookup :: (Insertable k) => k -> MultiMap k v -> Maybe [v] 58 | lookup k M{..} = maybe Nothing (Just . Foldable.toList) $ Map.lookup k hmap 59 | {-# INLINE lookup #-} 60 | 61 | filter :: forall k v. (Insertable k) 62 | => (v -> Bool) 63 | -> MultiMap k v 64 | -> MultiMap k v 65 | filter p M{..} = M $ Map.foldlWithKey' (matchOn p) hmap hmap 66 | where 67 | matchOn pred acc key valueSet = 68 | Map.insert key (Set.filter pred valueSet) acc 69 | {-# INLINE filter #-} 70 | 71 | filterWithKey :: forall k v. (Insertable k) 72 | => (k -> v -> Bool) 73 | -> MultiMap k v 74 | -> MultiMap k v 75 | filterWithKey p M{..} = M $ Map.foldlWithKey' (matchOn p) hmap hmap 76 | where 77 | matchOn pred acc key valueSet = 78 | Map.insert key (Set.filter (pred key) valueSet) acc 79 | {-# INLINE filterWithKey #-} 80 | 81 | -- | /O(n)/ Reduce this map by applying a binary operator to all 82 | -- elements, using the given starting value (typically the 83 | -- right-identity of the operator). 84 | foldrWithKey :: (k -> v -> a -> a) -> a -> MultiMap k v -> a 85 | foldrWithKey f a M{..} = 86 | let wrap = \k' v' acc' -> f k' v' acc' 87 | in Map.foldrWithKey (\k v acc -> Set.foldr (wrap k) acc v) a hmap 88 | {-# INLINE foldrWithKey #-} 89 | 90 | toList :: MultiMap k v -> [(k, v)] 91 | toList M{..} = Map.foldlWithKey' explode [] hmap 92 | where 93 | explode xs k vs = Set.foldl' (\ys v -> ((k, v):ys)) xs vs 94 | {-# INLINE toList #-} 95 | 96 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Internal/IdentityPool.hs: -------------------------------------------------------------------------------- 1 | module Control.Distributed.Process.Internal.IdentityPool where 2 | 3 | -- import Control.Concurrent.STM (atomically) 4 | -- import Control.Concurrent.STM.TChan (newTChanIO, readTChan, writeTChan) 5 | import Control.Distributed.Process.Platform.Internal.Queue.PriorityQ (PriorityQ) 6 | import qualified Control.Distributed.Process.Platform.Internal.Queue.PriorityQ as Queue 7 | 8 | data IdentityPool a = IDPool { reserved :: !a 9 | , returns :: PriorityQ a a 10 | } 11 | 12 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Internal/Queue/PriorityQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | module Control.Distributed.Process.Platform.Internal.Queue.PriorityQ where 4 | 5 | -- NB: we might try this with a skewed binomial heap at some point, 6 | -- but for now, we'll use this module from the fingertree package 7 | import qualified Data.PriorityQueue.FingerTree as PQ 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 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Internal/Queue/SeqQ.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Distributed.Process.Platform.Internal.Queue.SeqQ 4 | -- Copyright : (c) Tim Watson 2012 - 2013 5 | -- License : BSD3 (see the file LICENSE) 6 | -- 7 | -- Maintainer : Tim Watson 8 | -- Stability : experimental 9 | -- 10 | -- A simple FIFO queue implementation backed by @Data.Sequence@. 11 | ----------------------------------------------------------------------------- 12 | 13 | module Control.Distributed.Process.Platform.Internal.Queue.SeqQ 14 | ( SeqQ 15 | , empty 16 | , isEmpty 17 | , singleton 18 | , enqueue 19 | , dequeue 20 | , peek 21 | ) 22 | where 23 | 24 | import Data.Sequence 25 | ( Seq 26 | , ViewR(..) 27 | , (<|) 28 | , viewr 29 | ) 30 | import qualified Data.Sequence as Seq (empty, singleton, null) 31 | 32 | newtype SeqQ a = SeqQ { q :: Seq a } 33 | deriving (Show) 34 | 35 | instance Eq a => Eq (SeqQ a) where 36 | a == b = (q a) == (q b) 37 | 38 | {-# INLINE empty #-} 39 | empty :: SeqQ a 40 | empty = SeqQ Seq.empty 41 | 42 | isEmpty :: SeqQ a -> Bool 43 | isEmpty = Seq.null . q 44 | 45 | {-# INLINE singleton #-} 46 | singleton :: a -> SeqQ a 47 | singleton = SeqQ . Seq.singleton 48 | 49 | {-# INLINE enqueue #-} 50 | enqueue :: SeqQ a -> a -> SeqQ a 51 | enqueue s a = SeqQ $ a <| q s 52 | 53 | {-# INLINE dequeue #-} 54 | dequeue :: SeqQ a -> Maybe (a, SeqQ a) 55 | dequeue s = maybe Nothing (\(s' :> a) -> Just (a, SeqQ s')) $ getR s 56 | 57 | {-# INLINE peek #-} 58 | peek :: SeqQ a -> Maybe a 59 | peek s = maybe Nothing (\(_ :> a) -> Just a) $ getR s 60 | 61 | getR :: SeqQ a -> Maybe (ViewR a) 62 | getR s = 63 | case (viewr (q s)) of 64 | EmptyR -> Nothing 65 | a -> Just a 66 | 67 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# LANGUAGE OverlappingInstances #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | 11 | -- | Types used throughout the Platform 12 | -- 13 | module Control.Distributed.Process.Platform.Internal.Types 14 | ( -- * Tagging 15 | Tag 16 | , TagPool 17 | , newTagPool 18 | , getTag 19 | -- * Addressing 20 | , Linkable(..) 21 | , Killable(..) 22 | , Resolvable(..) 23 | , Routable(..) 24 | , Addressable 25 | , sendToRecipient 26 | , Recipient(..) 27 | , RegisterSelf(..) 28 | -- * Interactions 29 | , whereisRemote 30 | , resolveOrDie 31 | , CancelWait(..) 32 | , Channel 33 | , Shutdown(..) 34 | , ExitReason(..) 35 | , ServerDisconnected(..) 36 | , NFSerializable 37 | -- remote table 38 | , __remoteTable 39 | ) where 40 | 41 | import Control.Concurrent.MVar 42 | ( MVar 43 | , newMVar 44 | , modifyMVar 45 | ) 46 | import Control.DeepSeq (NFData, ($!!)) 47 | import Control.Distributed.Process hiding (send) 48 | import qualified Control.Distributed.Process as P 49 | ( send 50 | , unsafeSend 51 | , unsafeNSend 52 | ) 53 | import Control.Distributed.Process.Closure 54 | ( remotable 55 | , mkClosure 56 | , functionTDict 57 | ) 58 | import Control.Distributed.Process.Serializable 59 | 60 | import Data.Binary 61 | import Data.Typeable (Typeable) 62 | import GHC.Generics 63 | 64 | -------------------------------------------------------------------------------- 65 | -- API -- 66 | -------------------------------------------------------------------------------- 67 | 68 | -- | Introduces a class that brings NFData into scope along with Serializable, 69 | -- such that we can force evaluation. Intended for use with the UnsafePrimitives 70 | -- module (which wraps "Control.Distributed.Process.UnsafePrimitives"), and 71 | -- guarantees evaluatedness in terms of @NFData@. Please note that we /cannot/ 72 | -- guarantee that an @NFData@ instance will behave the same way as a @Binary@ 73 | -- one with regards evaluation, so it is still possible to introduce unexpected 74 | -- behaviour by using /unsafe/ primitives in this way. 75 | -- 76 | class (NFData a, Serializable a) => NFSerializable a 77 | instance (NFData a, Serializable a) => NFSerializable a 78 | 79 | -- | Tags provide uniqueness for messages, so that they can be 80 | -- matched with their response. 81 | type Tag = Int 82 | 83 | -- | Generates unique 'Tag' for messages and response pairs. 84 | -- Each process that depends, directly or indirectly, on 85 | -- the call mechanisms in "Control.Distributed.Process.Global.Call" 86 | -- should have at most one TagPool on which to draw unique message 87 | -- tags. 88 | type TagPool = MVar Tag 89 | 90 | -- | Create a new per-process source of unique 91 | -- message identifiers. 92 | newTagPool :: Process TagPool 93 | newTagPool = liftIO $ newMVar 0 94 | 95 | -- | Extract a new identifier from a 'TagPool'. 96 | getTag :: TagPool -> Process Tag 97 | getTag tp = liftIO $ modifyMVar tp (\tag -> return (tag+1,tag)) 98 | 99 | -- | Wait cancellation message. 100 | data CancelWait = CancelWait 101 | deriving (Eq, Show, Typeable, Generic) 102 | instance Binary CancelWait where 103 | instance NFData CancelWait where 104 | 105 | -- | Simple representation of a channel. 106 | type Channel a = (SendPort a, ReceivePort a) 107 | 108 | -- | Used internally in whereisOrStart. Sent as (RegisterSelf,ProcessId). 109 | data RegisterSelf = RegisterSelf 110 | deriving (Typeable, Generic) 111 | instance Binary RegisterSelf where 112 | instance NFData RegisterSelf where 113 | 114 | -- | A ubiquitous /shutdown signal/ that can be used 115 | -- to maintain a consistent shutdown/stop protocol for 116 | -- any process that wishes to handle it. 117 | data Shutdown = Shutdown 118 | deriving (Typeable, Generic, Show, Eq) 119 | instance Binary Shutdown where 120 | instance NFData Shutdown where 121 | 122 | -- | Provides a /reason/ for process termination. 123 | data ExitReason = 124 | ExitNormal -- ^ indicates normal exit 125 | | ExitShutdown -- ^ normal response to a 'Shutdown' 126 | | ExitOther !String -- ^ abnormal (error) shutdown 127 | deriving (Typeable, Generic, Eq, Show) 128 | instance Binary ExitReason where 129 | instance NFData ExitReason where 130 | 131 | -- | A simple means of mapping to a receiver. 132 | data Recipient = 133 | Pid !ProcessId 134 | | Registered !String 135 | | RemoteRegistered !String !NodeId 136 | -- | ProcReg !ProcessId !String 137 | -- | RemoteProcReg NodeId String 138 | -- | GlobalReg String 139 | deriving (Typeable, Generic, Show, Eq) 140 | instance Binary Recipient where 141 | instance NFData Recipient where 142 | 143 | -- useful exit reasons 144 | 145 | -- | Given when a server is unobtainable. 146 | data ServerDisconnected = ServerDisconnected !DiedReason 147 | deriving (Typeable, Generic) 148 | instance Binary ServerDisconnected where 149 | instance NFData ServerDisconnected where 150 | 151 | $(remotable ['whereis]) 152 | 153 | -- | A synchronous version of 'whereis', this relies on 'call' 154 | -- to perform the relevant monitoring of the remote node. 155 | whereisRemote :: NodeId -> String -> Process (Maybe ProcessId) 156 | whereisRemote node name = 157 | call $(functionTDict 'whereis) node ($(mkClosure 'whereis) name) 158 | 159 | sendToRecipient :: (Serializable m) => Recipient -> m -> Process () 160 | sendToRecipient (Pid p) m = P.send p m 161 | sendToRecipient (Registered s) m = nsend s m 162 | sendToRecipient (RemoteRegistered s n) m = nsendRemote n s m 163 | 164 | unsafeSendToRecipient :: (NFSerializable m) => Recipient -> m -> Process () 165 | unsafeSendToRecipient (Pid p) m = P.unsafeSend p $!! m 166 | unsafeSendToRecipient (Registered s) m = P.unsafeNSend s $!! m 167 | unsafeSendToRecipient (RemoteRegistered s n) m = nsendRemote n s m 168 | 169 | baseAddressableErrorMessage :: (Routable a) => a -> String 170 | baseAddressableErrorMessage _ = "CannotResolveAddressable" 171 | 172 | -- | Class of things to which a @Process@ can /link/ itself. 173 | class Linkable a where 174 | -- | Create a /link/ with the supplied object. 175 | linkTo :: a -> Process () 176 | 177 | -- | Class of things that can be resolved to a 'ProcessId'. 178 | -- 179 | class Resolvable a where 180 | -- | Resolve the reference to a process id, or @Nothing@ if resolution fails 181 | resolve :: a -> Process (Maybe ProcessId) 182 | 183 | -- | Class of things that can be killed (or instructed to exit). 184 | class Killable a where 185 | killProc :: a -> String -> Process () 186 | exitProc :: (Serializable m) => a -> m -> Process () 187 | 188 | instance Killable ProcessId where 189 | killProc = kill 190 | exitProc = exit 191 | 192 | instance Resolvable r => Killable r where 193 | killProc r s = resolve r >>= maybe (return ()) (flip kill $ s) 194 | exitProc r m = resolve r >>= maybe (return ()) (flip exit $ m) 195 | 196 | -- | Provides a unified API for addressing processes. 197 | -- 198 | class Routable a where 199 | -- | Send a message to the target asynchronously 200 | sendTo :: (Serializable m) => a -> m -> Process () 201 | 202 | -- | Send some @NFData@ message to the target asynchronously, 203 | -- forcing evaluation (i.e., @deepseq@) beforehand. 204 | unsafeSendTo :: (NFSerializable m) => a -> m -> Process () 205 | 206 | -- | Unresolvable @Addressable@ Message 207 | unresolvableMessage :: a -> String 208 | unresolvableMessage = baseAddressableErrorMessage 209 | 210 | instance (Resolvable a) => Routable a where 211 | sendTo a m = do 212 | mPid <- resolve a 213 | maybe (die (unresolvableMessage a)) 214 | (\p -> P.send p m) 215 | mPid 216 | 217 | unsafeSendTo a m = do 218 | mPid <- resolve a 219 | maybe (die (unresolvableMessage a)) 220 | (\p -> P.unsafeSend p $!! m) 221 | mPid 222 | 223 | -- | Unresolvable Addressable Message 224 | unresolvableMessage = baseAddressableErrorMessage 225 | 226 | instance Resolvable Recipient where 227 | resolve (Pid p) = return (Just p) 228 | resolve (Registered n) = whereis n 229 | resolve (RemoteRegistered s n) = whereisRemote n s 230 | 231 | instance Routable Recipient where 232 | sendTo = sendToRecipient 233 | unsafeSendTo = unsafeSendToRecipient 234 | 235 | unresolvableMessage (Pid p) = unresolvableMessage p 236 | unresolvableMessage (Registered n) = unresolvableMessage n 237 | unresolvableMessage (RemoteRegistered s n) = unresolvableMessage (n, s) 238 | 239 | instance Resolvable ProcessId where 240 | resolve p = return (Just p) 241 | 242 | instance Routable ProcessId where 243 | sendTo = P.send 244 | unsafeSendTo pid msg = P.unsafeSend pid $!! msg 245 | unresolvableMessage p = "CannotResolvePid[" ++ (show p) ++ "]" 246 | 247 | instance Resolvable String where 248 | resolve = whereis 249 | 250 | instance Routable String where 251 | sendTo = nsend 252 | unsafeSendTo name msg = P.unsafeNSend name $!! msg 253 | unresolvableMessage s = "CannotResolveRegisteredName[" ++ s ++ "]" 254 | 255 | instance Resolvable (NodeId, String) where 256 | resolve (nid, pname) = whereisRemote nid pname 257 | 258 | instance Routable (NodeId, String) where 259 | sendTo (nid, pname) msg = nsendRemote nid pname msg 260 | unsafeSendTo = sendTo -- because serialisation *must* take place 261 | unresolvableMessage (n, s) = 262 | "CannotResolveRemoteRegisteredName[name: " ++ s ++ ", node: " ++ (show n) ++ "]" 263 | 264 | instance Routable (Message -> Process ()) where 265 | sendTo f = f . wrapMessage 266 | unsafeSendTo f = f . unsafeWrapMessage 267 | 268 | class (Resolvable a, Routable a) => Addressable a 269 | instance (Resolvable a, Routable a) => Addressable a 270 | 271 | -- TODO: this probably belongs somewhere other than in ..Types. 272 | -- | resolve the Resolvable or die with specified msg plus details of what didn't resolve 273 | resolveOrDie :: (Routable a, Resolvable a) => a -> String -> Process ProcessId 274 | resolveOrDie resolvable failureMsg = do 275 | result <- resolve resolvable 276 | case result of 277 | Nothing -> die $ failureMsg ++ " " ++ unresolvableMessage resolvable 278 | Just pid -> return pid 279 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Internal/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | 6 | -- | If you don't know exactly what this module is for and precisely 7 | -- how to use the types within, you should move on, quickly! 8 | -- 9 | module Control.Distributed.Process.Platform.Internal.Unsafe 10 | ( -- * Copying non-serializable data 11 | PCopy() 12 | , pCopy 13 | , matchP 14 | , matchChanP 15 | , pUnwrap 16 | -- * Arbitrary (unmanaged) message streams 17 | , InputStream(Null) 18 | , newInputStream 19 | , matchInputStream 20 | , readInputStream 21 | , InvalidBinaryShim(..) 22 | ) where 23 | 24 | import Control.Concurrent.STM (STM, atomically) 25 | import Control.Distributed.Process 26 | ( matchAny 27 | , matchChan 28 | , matchSTM 29 | , match 30 | , handleMessage 31 | , receiveChan 32 | , liftIO 33 | , die 34 | , Match 35 | , ReceivePort 36 | , Message 37 | , Process 38 | ) 39 | import Control.Distributed.Process.Serializable (Serializable) 40 | import Data.Binary 41 | import Control.DeepSeq (NFData) 42 | import Data.Typeable (Typeable) 43 | import GHC.Generics 44 | 45 | data InvalidBinaryShim = InvalidBinaryShim 46 | deriving (Typeable, Show, Eq) 47 | 48 | -- NB: PCopy is a shim, allowing us to copy a pointer to otherwise 49 | -- non-serializable data directly to another local process' 50 | -- mailbox with no serialisation or even deepseq evaluation 51 | -- required. We disallow remote queries (i.e., from other nodes) 52 | -- and thus the Binary instance below is never used (though it's 53 | -- required by the type system) and will in fact generate errors if 54 | -- you attempt to use it at runtime. In other words, if you attempt 55 | -- to make a @Message@ out of this, you'd better make sure you're 56 | -- calling @unsafeCreateUnencodedMessage@, otherwise /BOOM/! You have 57 | -- been warned. 58 | -- 59 | data PCopy a = PCopy !a 60 | deriving (Typeable, Generic) 61 | instance (NFData a) => NFData (PCopy a) where 62 | 63 | instance (Typeable a) => Binary (PCopy a) where 64 | put _ = error "InvalidBinaryShim" 65 | get = error "InvalidBinaryShim" 66 | 67 | -- | Wrap any @Typeable@ datum in a @PCopy@. We hide the constructor to 68 | -- discourage arbitrary uses of the type, since @PCopy@ is a specialised 69 | -- and potentially dangerous construct. 70 | pCopy :: (Typeable a) => a -> PCopy a 71 | pCopy = PCopy 72 | 73 | -- | Matches on @PCopy m@ and returns the /m/ within. 74 | -- This potentially allows us to bypass serialization (and the type constraints 75 | -- it enforces) for local message passing (i.e., with @UnencodedMessage@ data), 76 | -- since PCopy is just a shim. 77 | matchP :: (Typeable m) => Match (Maybe m) 78 | matchP = matchAny pUnwrap 79 | 80 | -- | Given a raw @Message@, attempt to unwrap a @Typeable@ datum from 81 | -- an enclosing @PCopy@ wrapper. 82 | pUnwrap :: (Typeable m) => Message -> Process (Maybe m) 83 | pUnwrap m = handleMessage m (\(PCopy m' :: PCopy m) -> return m') 84 | 85 | -- | Matches on a @TypedChannel (PCopy a)@. 86 | matchChanP :: (Typeable m) => ReceivePort (PCopy m) -> Match m 87 | matchChanP rp = matchChan rp (\(PCopy m' :: PCopy m) -> return m') 88 | 89 | -- | A generic input channel that can be read from in the same fashion 90 | -- as a typed channel (i.e., @ReceivePort@). To read from an input stream 91 | -- in isolation, see 'readInputStream'. To compose an 'InputStream' with 92 | -- reads on a process' mailbox (and/or typed channels), see 'matchInputStream'. 93 | -- 94 | data InputStream a = ReadChan (ReceivePort a) | ReadSTM (STM a) | Null 95 | deriving (Typeable) 96 | 97 | data NullInputStream = NullInputStream 98 | deriving (Typeable, Generic, Show, Eq) 99 | instance Binary NullInputStream where 100 | instance NFData NullInputStream where 101 | 102 | -- [note: InputStream] 103 | -- InputStream wraps either a ReceivePort or an arbitrary STM action. Used 104 | -- internally when we want to allow internal clients to completely bypass 105 | -- regular messaging primitives (which is rare but occaisionally useful), 106 | -- the type (only, minus its constructors) is exposed to users of some 107 | -- @Exchange@ APIs. 108 | 109 | -- | Create a new 'InputStream'. 110 | newInputStream :: forall a. (Typeable a) 111 | => Either (ReceivePort a) (STM a) 112 | -> InputStream a 113 | newInputStream (Left rp) = ReadChan rp 114 | newInputStream (Right stm) = ReadSTM stm 115 | 116 | -- | Read from an 'InputStream'. This is a blocking operation. 117 | readInputStream :: (Serializable a) => InputStream a -> Process a 118 | readInputStream (ReadChan rp) = receiveChan rp 119 | readInputStream (ReadSTM stm) = liftIO $ atomically stm 120 | readInputStream Null = die $ NullInputStream 121 | 122 | -- | Constructs a @Match@ for a given 'InputChannel'. 123 | matchInputStream :: InputStream a -> Match a 124 | matchInputStream (ReadChan rp) = matchChan rp return 125 | matchInputStream (ReadSTM stm) = matchSTM stm return 126 | matchInputStream Null = match (\NullInputStream -> do 127 | error "NullInputStream") 128 | 129 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/ManagedProcess/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Control.Distributed.Process.Platform.ManagedProcess.Client 7 | -- Copyright : (c) Tim Watson 2012 - 2013 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.Platform.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 | ) where 32 | 33 | import Control.Distributed.Process hiding (call) 34 | import Control.Distributed.Process.Serializable 35 | import Control.Distributed.Process.Platform.Async hiding (check) 36 | import Control.Distributed.Process.Platform.ManagedProcess.Internal.Types 37 | import qualified Control.Distributed.Process.Platform.ManagedProcess.Internal.Types as T 38 | import Control.Distributed.Process.Platform.Internal.Primitives hiding (monitor) 39 | import Control.Distributed.Process.Platform.Internal.Types 40 | ( ExitReason(..) 41 | , Shutdown(..) 42 | ) 43 | import Control.Distributed.Process.Platform.Time 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 | call :: forall s a b . (Addressable s, Serializable a, Serializable b) 68 | => s -> a -> Process b 69 | call sid msg = initCall sid msg >>= waitResponse Nothing >>= decodeResult 70 | where decodeResult (Just (Right r)) = return r 71 | decodeResult (Just (Left err)) = die err 72 | decodeResult Nothing {- the impossible happened -} = terminate 73 | 74 | -- | Safe version of 'call' that returns information about the error 75 | -- if the operation fails. If an error occurs then the explanation will be 76 | -- will be stashed away as @(ExitOther String)@. 77 | safeCall :: forall s a b . (Addressable s, Serializable a, Serializable b) 78 | => s -> a -> Process (Either ExitReason b) 79 | safeCall s m = initCall s m >>= waitResponse Nothing >>= return . fromJust 80 | 81 | -- | Version of 'safeCall' that returns 'Nothing' if the operation fails. If 82 | -- you need information about *why* a call has failed then you should use 83 | -- 'safeCall' or combine @catchExit@ and @call@ instead. 84 | tryCall :: forall s a b . (Addressable s, Serializable a, Serializable b) 85 | => s -> a -> Process (Maybe b) 86 | tryCall s m = initCall s m >>= waitResponse Nothing >>= decodeResult 87 | where decodeResult (Just (Right r)) = return $ Just r 88 | decodeResult _ = return Nothing 89 | 90 | -- | Make a synchronous call, but timeout and return @Nothing@ if a reply 91 | -- is not received within the specified time interval. 92 | -- 93 | -- If the result of the call is a failure (or the call was cancelled) then 94 | -- the calling process will exit, with the 'ExitReason' given as the reason. 95 | -- If the call times out however, the semantics on the server side are 96 | -- undefined, i.e., the server may or may not successfully process the 97 | -- request and may (or may not) send a response at a later time. From the 98 | -- callers perspective, this is somewhat troublesome, since the call result 99 | -- cannot be decoded directly. In this case, the 'flushPendingCalls' API /may/ 100 | -- be used to attempt to receive the message later on, however this makes 101 | -- /no attempt whatsoever/ to guarantee /which/ call response will in fact 102 | -- be returned to the caller. In those semantics are unsuited to your 103 | -- application, you might choose to @exit@ or @die@ in case of a timeout, 104 | -- or alternatively, use the 'callAsync' API and associated @waitTimeout@ 105 | -- function (in the /Async API/), which takes a re-usable handle on which 106 | -- to wait (with timeouts) multiple times. 107 | -- 108 | callTimeout :: forall s a b . (Addressable s, Serializable a, Serializable b) 109 | => s -> a -> TimeInterval -> Process (Maybe b) 110 | callTimeout s m d = initCall s m >>= waitResponse (Just d) >>= decodeResult 111 | where decodeResult :: (Serializable b) 112 | => Maybe (Either ExitReason b) 113 | -> Process (Maybe b) 114 | decodeResult Nothing = return Nothing 115 | decodeResult (Just (Right result)) = return $ Just result 116 | decodeResult (Just (Left reason)) = die reason 117 | 118 | flushPendingCalls :: forall b . (Serializable b) 119 | => TimeInterval 120 | -> (b -> Process b) 121 | -> Process (Maybe b) 122 | flushPendingCalls d proc = do 123 | receiveTimeout (asTimeout d) [ 124 | match (\(CallResponse (m :: b) _) -> proc m) 125 | ] 126 | 127 | -- | Invokes 'call' /out of band/, and returns an /async handle/. 128 | -- 129 | -- See "Control.Distributed.Process.Platform.Async". 130 | -- 131 | callAsync :: forall s a b . (Addressable s, Serializable a, Serializable b) 132 | => s -> a -> Process (Async b) 133 | callAsync server msg = async $ call server msg 134 | 135 | -- | Sends a /cast/ message to the server identified by @server@. The server 136 | -- will not send a response. Like Cloud Haskell's 'send' primitive, cast is 137 | -- fully asynchronous and /never fails/ - therefore 'cast'ing to a non-existent 138 | -- (e.g., dead) server process will not generate an error. 139 | -- 140 | cast :: forall a m . (Addressable a, Serializable m) 141 | => a -> m -> Process () 142 | cast server msg = sendTo server ((CastMessage msg) :: T.Message m ()) 143 | 144 | -- | Sends a /channel/ message to the server and returns a @ReceivePort@ on 145 | -- which the reponse can be delivered, if the server so chooses (i.e., the 146 | -- might ignore the request or crash). 147 | callChan :: forall s a b . (Addressable s, Serializable a, Serializable b) 148 | => s -> a -> Process (ReceivePort b) 149 | callChan server msg = do 150 | (sp, rp) <- newChan 151 | sendTo server ((ChanMessage msg sp) :: T.Message a b) 152 | return rp 153 | 154 | -- | A synchronous version of 'callChan'. 155 | syncCallChan :: forall s a b . (Addressable s, Serializable a, Serializable b) 156 | => s -> a -> Process b 157 | syncCallChan server msg = do 158 | r <- syncSafeCallChan server msg 159 | case r of 160 | Left e -> die e 161 | Right r' -> return r' 162 | 163 | -- | A safe version of 'syncCallChan', which returns @Left ExitReason@ if the 164 | -- call fails. 165 | syncSafeCallChan :: forall s a b . (Addressable s, Serializable a, Serializable b) 166 | => s -> a -> Process (Either ExitReason b) 167 | syncSafeCallChan server msg = do 168 | rp <- callChan server msg 169 | awaitResponse server [ matchChan rp (return . Right) ] 170 | 171 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/ManagedProcess/Server/Priority.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE PatternGuards #-} 4 | 5 | module Control.Distributed.Process.Platform.ManagedProcess.Server.Priority 6 | ( prioritiseCall 7 | , prioritiseCall_ 8 | , prioritiseCast 9 | , prioritiseCast_ 10 | , prioritiseInfo 11 | , prioritiseInfo_ 12 | , setPriority 13 | ) where 14 | 15 | import Control.Distributed.Process hiding (call, Message) 16 | import qualified Control.Distributed.Process as P (Message) 17 | import Control.Distributed.Process.Platform.ManagedProcess.Internal.Types 18 | import Control.Distributed.Process.Serializable 19 | import Prelude hiding (init) 20 | 21 | setPriority :: Int -> Priority m 22 | setPriority = Priority 23 | 24 | prioritiseCall_ :: forall s a b . (Serializable a, Serializable b) 25 | => (a -> Priority b) 26 | -> DispatchPriority s 27 | prioritiseCall_ h = prioritiseCall (\_ -> h) 28 | 29 | prioritiseCall :: forall s a b . (Serializable a, Serializable b) 30 | => (s -> a -> Priority b) 31 | -> DispatchPriority s 32 | prioritiseCall h = PrioritiseCall (\s -> unCall $ h s) 33 | where 34 | unCall :: (a -> Priority b) -> P.Message -> Process (Maybe (Int, P.Message)) 35 | unCall h' m = unwrapMessage m >>= return . matchPrioritise m h' 36 | 37 | matchPrioritise :: P.Message 38 | -> (a -> Priority b) 39 | -> Maybe (Message a b) 40 | -> Maybe (Int, P.Message) 41 | matchPrioritise msg p msgIn 42 | | (Just a@(CallMessage m _)) <- msgIn 43 | , True <- isEncoded msg = Just (getPrio $ p m, wrapMessage a) 44 | | (Just (CallMessage m _)) <- msgIn 45 | , False <- isEncoded msg = Just (getPrio $ p m, msg) 46 | | otherwise = Nothing 47 | 48 | prioritiseCast_ :: forall s a . (Serializable a) 49 | => (a -> Priority ()) 50 | -> DispatchPriority s 51 | prioritiseCast_ h = prioritiseCast (\_ -> h) 52 | 53 | prioritiseCast :: forall s a . (Serializable a) 54 | => (s -> a -> Priority ()) 55 | -> DispatchPriority s 56 | prioritiseCast h = PrioritiseCast (\s -> unCast $ h s) 57 | where 58 | unCast :: (a -> Priority ()) -> P.Message -> Process (Maybe (Int, P.Message)) 59 | unCast h' m = unwrapMessage m >>= return . matchPrioritise m h' 60 | 61 | matchPrioritise :: P.Message 62 | -> (a -> Priority ()) 63 | -> Maybe (Message a ()) 64 | -> Maybe (Int, P.Message) 65 | matchPrioritise msg p msgIn 66 | | (Just a@(CastMessage m)) <- msgIn 67 | , True <- isEncoded msg = Just (getPrio $ p m, wrapMessage a) 68 | | (Just (CastMessage m)) <- msgIn 69 | , False <- isEncoded msg = Just (getPrio $ p m, msg) 70 | | otherwise = Nothing 71 | 72 | prioritiseInfo_ :: forall s a . (Serializable a) 73 | => (a -> Priority ()) 74 | -> DispatchPriority s 75 | prioritiseInfo_ h = prioritiseInfo (\_ -> h) 76 | 77 | prioritiseInfo :: forall s a . (Serializable a) 78 | => (s -> a -> Priority ()) 79 | -> DispatchPriority s 80 | prioritiseInfo h = PrioritiseInfo (\s -> unMsg $ h s) 81 | where 82 | unMsg :: (a -> Priority ()) -> P.Message -> Process (Maybe (Int, P.Message)) 83 | unMsg h' m = unwrapMessage m >>= return . matchPrioritise m h' 84 | 85 | matchPrioritise :: P.Message 86 | -> (a -> Priority ()) 87 | -> Maybe a 88 | -> Maybe (Int, P.Message) 89 | matchPrioritise msg p msgIn 90 | | (Just m') <- msgIn 91 | , True <- isEncoded msg = Just (getPrio $ p m', wrapMessage m') 92 | | (Just m') <- msgIn 93 | , False <- isEncoded msg = Just (getPrio $ p m', msg) 94 | | otherwise = Nothing 95 | 96 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/ManagedProcess/UnsafeClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Control.Distributed.Process.Platform.ManagedProcess.UnsafeClient 7 | -- Copyright : (c) Tim Watson 2012 - 2013 8 | -- License : BSD3 (see the file LICENSE) 9 | -- 10 | -- Maintainer : Tim Watson 11 | -- Stability : experimental 12 | -- Portability : non-portable (requires concurrency) 13 | -- 14 | -- Unsafe variant of the /Managed Process Client API/. This module implements 15 | -- the client portion of a Managed Process using the unsafe variants of cloud 16 | -- haskell's messaging primitives. It relies on the Platform implementation of 17 | -- @UnsafePrimitives@, which forces evaluation for types that provide an 18 | -- @NFData@ instance. Direct use of the underlying unsafe primitives (from 19 | -- the distributed-process library) without @NFData@ instances is unsupported. 20 | -- 21 | -- IMPORTANT NOTE: As per the platform documentation, it is not possible to 22 | -- /guarantee/ that an @NFData@ instance will force evaluation in the same way 23 | -- that a @Binary@ instance would (when encoding to a byte string). Please read 24 | -- the unsafe primitives documentation carefully and make sure you know what 25 | -- you're doing. You have been warned. 26 | -- 27 | -- See "Control.Distributed.Process.Platform". 28 | -- See "Control.Distributed.Process.Platform.UnsafePrimitives". 29 | -- See "Control.Distributed.Process.UnsafePrimitives". 30 | ----------------------------------------------------------------------------- 31 | 32 | -- TODO: This module is basically cut+paste duplicaton of the /safe/ Client - fix 33 | -- Caveats... we've got to support two different type constraints, somehow, so 34 | -- that the correct implementation gets used depending on whether or not we're 35 | -- passing NFData or just Binary instances... 36 | 37 | module Control.Distributed.Process.Platform.ManagedProcess.UnsafeClient 38 | ( -- * Unsafe variants of the Client API 39 | sendControlMessage 40 | , shutdown 41 | , call 42 | , safeCall 43 | , tryCall 44 | , callTimeout 45 | , flushPendingCalls 46 | , callAsync 47 | , cast 48 | , callChan 49 | , syncCallChan 50 | , syncSafeCallChan 51 | ) where 52 | 53 | import Control.Distributed.Process 54 | ( Process 55 | , ProcessId 56 | , ReceivePort 57 | , newChan 58 | , matchChan 59 | , match 60 | , die 61 | , terminate 62 | , receiveTimeout 63 | , unsafeSendChan 64 | ) 65 | import Control.Distributed.Process.Platform.Async 66 | ( Async 67 | , async 68 | ) 69 | import Control.Distributed.Process.Platform.Internal.Primitives 70 | ( awaitResponse 71 | ) 72 | import Control.Distributed.Process.Platform.Internal.Types 73 | ( Addressable 74 | , Routable(..) 75 | , NFSerializable 76 | , ExitReason 77 | , Shutdown(..) 78 | ) 79 | import Control.Distributed.Process.Platform.ManagedProcess.Internal.Types 80 | ( Message(CastMessage, ChanMessage) 81 | , CallResponse(..) 82 | , ControlPort(..) 83 | , unsafeInitCall 84 | , waitResponse 85 | ) 86 | import Control.Distributed.Process.Platform.Time 87 | ( TimeInterval 88 | , asTimeout 89 | ) 90 | import Control.Distributed.Process.Serializable hiding (SerializableDict) 91 | import Data.Maybe (fromJust) 92 | 93 | -- | Send a control message over a 'ControlPort'. This version of 94 | -- @shutdown@ uses /unsafe primitives/. 95 | -- 96 | sendControlMessage :: Serializable m => ControlPort m -> m -> Process () 97 | sendControlMessage cp m = unsafeSendChan (unPort cp) (CastMessage m) 98 | 99 | -- | Send a signal instructing the process to terminate. This version of 100 | -- @shutdown@ uses /unsafe primitives/. 101 | shutdown :: ProcessId -> Process () 102 | shutdown pid = cast pid Shutdown 103 | 104 | -- | Make a synchronous call - uses /unsafe primitives/. 105 | call :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 106 | => s -> a -> Process b 107 | call sid msg = unsafeInitCall sid msg >>= waitResponse Nothing >>= decodeResult 108 | where decodeResult (Just (Right r)) = return r 109 | decodeResult (Just (Left err)) = die err 110 | decodeResult Nothing {- the impossible happened -} = terminate 111 | 112 | -- | Safe version of 'call' that returns information about the error 113 | -- if the operation fails - uses /unsafe primitives/. 114 | safeCall :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 115 | => s -> a -> Process (Either ExitReason b) 116 | safeCall s m = unsafeInitCall s m >>= waitResponse Nothing >>= return . fromJust 117 | 118 | -- | Version of 'safeCall' that returns 'Nothing' if the operation fails. 119 | -- Uses /unsafe primitives/. 120 | tryCall :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 121 | => s -> a -> Process (Maybe b) 122 | tryCall s m = unsafeInitCall s m >>= waitResponse Nothing >>= decodeResult 123 | where decodeResult (Just (Right r)) = return $ Just r 124 | decodeResult _ = return Nothing 125 | 126 | -- | Make a synchronous call, but timeout and return @Nothing@ if a reply 127 | -- is not received within the specified time interval - uses /unsafe primitives/. 128 | -- 129 | callTimeout :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 130 | => s -> a -> TimeInterval -> Process (Maybe b) 131 | callTimeout s m d = unsafeInitCall s m >>= waitResponse (Just d) >>= decodeResult 132 | where decodeResult :: (NFSerializable b) 133 | => Maybe (Either ExitReason b) 134 | -> Process (Maybe b) 135 | decodeResult Nothing = return Nothing 136 | decodeResult (Just (Right result)) = return $ Just result 137 | decodeResult (Just (Left reason)) = die reason 138 | 139 | flushPendingCalls :: forall b . (NFSerializable b) 140 | => TimeInterval 141 | -> (b -> Process b) 142 | -> Process (Maybe b) 143 | flushPendingCalls d proc = do 144 | receiveTimeout (asTimeout d) [ 145 | match (\(CallResponse (m :: b) _) -> proc m) 146 | ] 147 | 148 | -- | Invokes 'call' /out of band/, and returns an "async handle." 149 | -- Uses /unsafe primitives/. 150 | -- 151 | callAsync :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 152 | => s -> a -> Process (Async b) 153 | callAsync server msg = async $ call server msg 154 | 155 | -- | Sends a /cast/ message to the server identified by @server@ - uses /unsafe primitives/. 156 | -- 157 | cast :: forall a m . (Addressable a, NFSerializable m) 158 | => a -> m -> Process () 159 | cast server msg = unsafeSendTo server ((CastMessage msg) :: Message m ()) 160 | 161 | -- | Sends a /channel/ message to the server and returns a @ReceivePort@ - uses /unsafe primitives/. 162 | callChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 163 | => s -> a -> Process (ReceivePort b) 164 | callChan server msg = do 165 | (sp, rp) <- newChan 166 | unsafeSendTo server ((ChanMessage msg sp) :: Message a b) 167 | return rp 168 | 169 | syncCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 170 | => s -> a -> Process b 171 | syncCallChan server msg = do 172 | r <- syncSafeCallChan server msg 173 | case r of 174 | Left e -> die e 175 | Right r' -> return r' 176 | 177 | syncSafeCallChan :: forall s a b . (Addressable s, NFSerializable a, NFSerializable b) 178 | => s -> a -> Process (Either ExitReason b) 179 | syncSafeCallChan server msg = do 180 | rp <- callChan server msg 181 | awaitResponse server [ matchChan rp (return . Right) ] 182 | 183 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Service.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Distributed.Process.Platform.Service 4 | -- Copyright : (c) Tim Watson 2013 - 2014 5 | -- License : BSD3 (see the file LICENSE) 6 | -- 7 | -- Maintainer : Tim Watson 8 | -- Stability : experimental 9 | -- Portability : non-portable (requires concurrency) 10 | -- 11 | -- The /Service Framework/ is intended to provide a /service or component oriented/ 12 | -- API for developing cloud haskell applications. Ultimately, we aim to provide 13 | -- a declarative mechanism for defining service components and their dependent 14 | -- services/sub-systems so we can automatically derive an appropriate supervision 15 | -- tree. This work is incomplete. 16 | -- 17 | -- Access to services, both internally and from remote peers, should take place 18 | -- via the /Registry/ module, with several different kinds of registry defined 19 | -- per node plus user defined registries running where applicable. Again, this 20 | -- is a work in progress, though the service registry capability is available 21 | -- in the current release. 22 | -- 23 | -- The service API also aims to provide some built in capabilities for common 24 | -- tasks such as monitoring, management and logging. An extension of the base 25 | -- Management (Mx) API that covers /ManagedProcess/ and /Supervision/ trees will 26 | -- be also be added here in a future release. 27 | -- 28 | ----------------------------------------------------------------------------- 29 | module Control.Distributed.Process.Platform.Service 30 | ( -- * Monitoring Nodes 31 | module Control.Distributed.Process.Platform.Service.Monitoring 32 | -- * Service Registry 33 | , module Control.Distributed.Process.Platform.Service.Registry 34 | ) where 35 | 36 | import Control.Distributed.Process.Platform.Service.Monitoring 37 | import Control.Distributed.Process.Platform.Service.Registry 38 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Service/Monitoring.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Control.Distributed.Process.Platform.Service.Monitoring 7 | -- Copyright : (c) Tim Watson 2013 - 2014 8 | -- License : BSD3 (see the file LICENSE) 9 | -- 10 | -- Maintainer : Tim Watson 11 | -- Stability : experimental 12 | -- Portability : non-portable (requires concurrency) 13 | -- 14 | -- This module provides a primitive node monitoring capability, implemented as 15 | -- a /distributed-process Management Agent/. Once the 'nodeMonitor' agent is 16 | -- started, calling 'monitorNodes' will ensure that whenever the local node 17 | -- detects a new network-transport connection (from another cloud haskell node), 18 | -- the caller will receive a 'NodeUp' message in its mailbox. If a node 19 | -- disconnects, a corollary 'NodeDown' message will be delivered as well. 20 | -- 21 | ----------------------------------------------------------------------------- 22 | 23 | module Control.Distributed.Process.Platform.Service.Monitoring 24 | ( 25 | NodeUp(..) 26 | , NodeDown(..) 27 | , nodeMonitorAgentId 28 | , nodeMonitor 29 | , monitorNodes 30 | , unmonitorNodes 31 | ) where 32 | 33 | import Control.DeepSeq (NFData) 34 | import Control.Distributed.Process -- NB: requires NodeId(..) to be exported! 35 | import Control.Distributed.Process.Management 36 | ( MxEvent(MxConnected, MxDisconnected) 37 | , MxAgentId(..) 38 | , mxAgent 39 | , mxSink 40 | , mxReady 41 | , liftMX 42 | , mxGetLocal 43 | , mxSetLocal 44 | , mxNotify 45 | ) 46 | import Control.Distributed.Process.Platform (deliver) 47 | import Data.Binary 48 | import qualified Data.Foldable as Foldable 49 | import Data.HashSet (HashSet) 50 | import qualified Data.HashSet as Set 51 | 52 | import Data.Typeable (Typeable) 53 | import GHC.Generics 54 | 55 | data Register = Register !ProcessId 56 | deriving (Typeable, Generic) 57 | instance Binary Register where 58 | instance NFData Register where 59 | 60 | data UnRegister = UnRegister !ProcessId 61 | deriving (Typeable, Generic) 62 | instance Binary UnRegister where 63 | instance NFData UnRegister where 64 | 65 | -- | Sent to subscribing processes when a connection 66 | -- (from a remote node) is detected. 67 | -- 68 | data NodeUp = NodeUp !NodeId 69 | deriving (Typeable, Generic, Show) 70 | instance Binary NodeUp where 71 | instance NFData NodeUp where 72 | 73 | -- | Sent to subscribing processes when a dis-connection 74 | -- (from a remote node) is detected. 75 | -- 76 | data NodeDown = NodeDown !NodeId 77 | deriving (Typeable, Generic, Show) 78 | instance Binary NodeDown where 79 | instance NFData NodeDown where 80 | 81 | -- | The @MxAgentId@ for the node monitoring agent. 82 | nodeMonitorAgentId :: MxAgentId 83 | nodeMonitorAgentId = MxAgentId "service.monitoring.nodes" 84 | 85 | -- | Start monitoring node connection/disconnection events. When a 86 | -- connection event occurs, the calling process will receive a message 87 | -- @NodeUp NodeId@ in its mailbox. When a disconnect occurs, the 88 | -- corollary @NodeDown NodeId@ message will be delivered instead. 89 | -- 90 | -- No guaranatee is made about the timeliness of the delivery, nor can 91 | -- the receiver expect that the node (for which it is being notified) 92 | -- is still up/connected or down/disconnected at the point when it receives 93 | -- a message from the node monitoring agent. 94 | -- 95 | monitorNodes :: Process () 96 | monitorNodes = do 97 | us <- getSelfPid 98 | mxNotify $ Register us 99 | 100 | -- | Stop monitoring node connection/disconnection events. This does not 101 | -- flush the caller's mailbox, nor does it guarantee that any/all node 102 | -- up/down notifications will have been delivered before it is evaluated. 103 | -- 104 | unmonitorNodes :: Process () 105 | unmonitorNodes = do 106 | us <- getSelfPid 107 | mxNotify $ UnRegister us 108 | 109 | -- | Starts the node monitoring agent. No call to @monitorNodes@ and 110 | -- @unmonitorNodes@ will have any effect unless the agent is already 111 | -- running. Note that we make /no guarantees what-so-ever/ about the 112 | -- timeliness or ordering semantics of node monitoring notifications. 113 | -- 114 | nodeMonitor :: Process ProcessId 115 | nodeMonitor = do 116 | mxAgent nodeMonitorAgentId initState [ 117 | (mxSink $ \(Register pid) -> do 118 | mxSetLocal . Set.insert pid =<< mxGetLocal 119 | mxReady) 120 | , (mxSink $ \(UnRegister pid) -> do 121 | mxSetLocal . Set.delete pid =<< mxGetLocal 122 | mxReady) 123 | , (mxSink $ \ev -> do 124 | let act = 125 | case ev of 126 | (MxConnected _ ep) -> notify $ nodeUp ep 127 | (MxDisconnected _ ep) -> notify $ nodeDown ep 128 | _ -> return () 129 | act >> mxReady) 130 | ] 131 | where 132 | initState :: HashSet ProcessId 133 | initState = Set.empty 134 | 135 | notify msg = Foldable.mapM_ (liftMX . deliver msg) =<< mxGetLocal 136 | 137 | nodeUp = NodeUp . NodeId 138 | nodeDown = NodeDown . NodeId 139 | 140 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Task.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Distributed.Process.Platform.Task 4 | -- Copyright : (c) Tim Watson 2013 - 2014 5 | -- License : BSD3 (see the file LICENSE) 6 | -- 7 | -- Maintainer : Tim Watson 8 | -- Stability : experimental 9 | -- Portability : non-portable (requires concurrency) 10 | -- 11 | -- The /Task Framework/ intends to provide tools for task management, work 12 | -- scheduling and distributed task coordination. These capabilities build on the 13 | -- /Execution Framework/ as well as other tools and libraries. The framework is 14 | -- currently a work in progress. The current release includes a simple bounded 15 | -- blocking queue implementation only, as an example of the kind of capability 16 | -- and API that we intend to produce. 17 | -- 18 | -- The /Task Framework/ will be broken down by the task scheduling and management 19 | -- algorithms it provides, e.g., at a low level providing work queues, worker pools 20 | -- and the like, whilst at a high level allowing the user to choose between work 21 | -- stealing, sharing, distributed coordination, user defined sensor based bounds/limits 22 | -- and so on. 23 | -- 24 | ----------------------------------------------------------------------------- 25 | module Control.Distributed.Process.Platform.Task 26 | ( -- * Task Queues 27 | module Control.Distributed.Process.Platform.Task.Queue.BlockingQueue 28 | ) where 29 | 30 | import Control.Distributed.Process.Platform.Task.Queue.BlockingQueue 31 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Task/Queue/BlockingQueue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | 7 | ----------------------------------------------------------------------------- 8 | -- | 9 | -- Module : Control.Distributed.Process.Platform.Task.Queue.BlockingQueue 10 | -- Copyright : (c) Tim Watson 2012 - 2013 11 | -- License : BSD3 (see the file LICENSE) 12 | -- 13 | -- Maintainer : Tim Watson 14 | -- Stability : experimental 15 | -- Portability : non-portable (requires concurrency) 16 | -- 17 | -- A simple bounded (size) task queue, which accepts requests and blocks the 18 | -- sender until they're completed. The size limit is applied to the number 19 | -- of concurrent tasks that are allowed to execute - if the limit is 3, then 20 | -- the first three tasks will be executed immediately, but further tasks will 21 | -- then be queued (internally) until one or more tasks completes and 22 | -- the number of active/running tasks falls within the concurrency limit. 23 | -- 24 | -- Note that the process calling 'executeTask' will be blocked for _at least_ 25 | -- the duration of the task itself, regardless of whether or not the queue has 26 | -- reached its concurrency limit. This provides a simple means to prevent work 27 | -- from being submitted faster than the server can handle, at the expense of 28 | -- flexible scheduling. 29 | -- 30 | ----------------------------------------------------------------------------- 31 | 32 | module Control.Distributed.Process.Platform.Task.Queue.BlockingQueue 33 | ( BlockingQueue() 34 | , SizeLimit 35 | , BlockingQueueStats(..) 36 | , start 37 | , pool 38 | , executeTask 39 | , stats 40 | ) where 41 | 42 | import Control.Distributed.Process hiding (call) 43 | import Control.Distributed.Process.Closure() 44 | import Control.Distributed.Process.Platform 45 | import Control.Distributed.Process.Platform.Async 46 | import Control.Distributed.Process.Platform.ManagedProcess 47 | import qualified Control.Distributed.Process.Platform.ManagedProcess as ManagedProcess 48 | import Control.Distributed.Process.Platform.Time 49 | import Control.Distributed.Process.Serializable 50 | import Data.Binary 51 | import Data.List 52 | ( deleteBy 53 | , find 54 | ) 55 | import Data.Sequence 56 | ( Seq 57 | , ViewR(..) 58 | , (<|) 59 | , viewr 60 | ) 61 | import qualified Data.Sequence as Seq (empty, length) 62 | import Data.Typeable 63 | 64 | import GHC.Generics (Generic) 65 | 66 | -- | Limit for the number of concurrent tasks. 67 | -- 68 | type SizeLimit = Int 69 | 70 | data GetStats = GetStats 71 | deriving (Typeable, Generic) 72 | instance Binary GetStats where 73 | 74 | data BlockingQueueStats = BlockingQueueStats { 75 | maxJobs :: Int 76 | , activeJobs :: Int 77 | , queuedJobs :: Int 78 | } deriving (Typeable, Generic) 79 | 80 | instance Binary BlockingQueueStats where 81 | 82 | data BlockingQueue a = BlockingQueue { 83 | poolSize :: SizeLimit 84 | , active :: [(MonitorRef, CallRef (Either ExitReason a), Async a)] 85 | , accepted :: Seq (CallRef (Either ExitReason a), Closure (Process a)) 86 | } deriving (Typeable) 87 | 88 | -- Client facing API 89 | 90 | -- | Start a queue with an upper bound on the # of concurrent tasks. 91 | -- 92 | start :: forall a . (Serializable a) 93 | => Process (InitResult (BlockingQueue a)) 94 | -> Process () 95 | start init' = ManagedProcess.serve () (\() -> init') poolServer 96 | where poolServer = 97 | defaultProcess { 98 | apiHandlers = [ 99 | handleCallFrom (\s f (p :: Closure (Process a)) -> storeTask s f p) 100 | , handleCall poolStatsRequest 101 | ] 102 | , infoHandlers = [ handleInfo taskComplete ] 103 | } :: ProcessDefinition (BlockingQueue a) 104 | 105 | -- | Define a pool of a given size. 106 | -- 107 | pool :: forall a . Serializable a 108 | => SizeLimit 109 | -> Process (InitResult (BlockingQueue a)) 110 | pool sz' = return $ InitOk (BlockingQueue sz' [] Seq.empty) Infinity 111 | 112 | -- | Enqueue a task in the pool and block until it is complete. 113 | -- 114 | executeTask :: forall s a . (Addressable s, Serializable a) 115 | => s 116 | -> Closure (Process a) 117 | -> Process (Either ExitReason a) 118 | executeTask sid t = call sid t 119 | 120 | -- | Fetch statistics for a queue. 121 | -- 122 | stats :: forall s . Addressable s => s -> Process (Maybe BlockingQueueStats) 123 | stats sid = tryCall sid GetStats 124 | 125 | -- internal / server-side API 126 | 127 | poolStatsRequest :: (Serializable a) 128 | => BlockingQueue a 129 | -> GetStats 130 | -> Process (ProcessReply BlockingQueueStats (BlockingQueue a)) 131 | poolStatsRequest st GetStats = 132 | let sz = poolSize st 133 | ac = length (active st) 134 | pj = Seq.length (accepted st) 135 | in reply (BlockingQueueStats sz ac pj) st 136 | 137 | storeTask :: Serializable a 138 | => BlockingQueue a 139 | -> CallRef (Either ExitReason a) 140 | -> Closure (Process a) 141 | -> Process (ProcessReply (Either ExitReason a) (BlockingQueue a)) 142 | storeTask s r c = acceptTask s r c >>= noReply_ 143 | 144 | acceptTask :: Serializable a 145 | => BlockingQueue a 146 | -> CallRef (Either ExitReason a) 147 | -> Closure (Process a) 148 | -> Process (BlockingQueue a) 149 | acceptTask s@(BlockingQueue sz' runQueue taskQueue) from task' = 150 | let currentSz = length runQueue 151 | in case currentSz >= sz' of 152 | True -> do 153 | return $ s { accepted = enqueue taskQueue (from, task') } 154 | False -> do 155 | proc <- unClosure task' 156 | asyncHandle <- async proc 157 | ref <- monitorAsync asyncHandle 158 | taskEntry <- return (ref, from, asyncHandle) 159 | return s { active = (taskEntry:runQueue) } 160 | 161 | -- a worker has exited, process the AsyncResult and send a reply to the 162 | -- waiting client (who is still stuck in 'call' awaiting a response). 163 | taskComplete :: forall a . Serializable a 164 | => BlockingQueue a 165 | -> ProcessMonitorNotification 166 | -> Process (ProcessAction (BlockingQueue a)) 167 | taskComplete s@(BlockingQueue _ runQ _) 168 | (ProcessMonitorNotification ref _ _) = 169 | let worker = findWorker ref runQ in 170 | case worker of 171 | Just t@(_, c, h) -> wait h >>= respond c >> bump s t >>= continue 172 | Nothing -> continue s 173 | 174 | where 175 | respond :: CallRef (Either ExitReason a) 176 | -> AsyncResult a 177 | -> Process () 178 | respond c (AsyncDone r) = replyTo c ((Right r) :: (Either ExitReason a)) 179 | respond c (AsyncFailed d) = replyTo c ((Left (ExitOther $ show d)) :: (Either ExitReason a)) 180 | respond c (AsyncLinkFailed d) = replyTo c ((Left (ExitOther $ show d)) :: (Either ExitReason a)) 181 | respond _ _ = die $ ExitOther "IllegalState" 182 | 183 | bump :: BlockingQueue a 184 | -> (MonitorRef, CallRef (Either ExitReason a), Async a) 185 | -> Process (BlockingQueue a) 186 | bump st@(BlockingQueue _ runQueue acc) worker = 187 | let runQ2 = deleteFromRunQueue worker runQueue 188 | accQ = dequeue acc in 189 | case accQ of 190 | Nothing -> return st { active = runQ2 } 191 | Just ((tr,tc), ts) -> acceptTask (st { accepted = ts, active = runQ2 }) tr tc 192 | 193 | findWorker :: MonitorRef 194 | -> [(MonitorRef, CallRef (Either ExitReason a), Async a)] 195 | -> Maybe (MonitorRef, CallRef (Either ExitReason a), Async a) 196 | findWorker key = find (\(ref,_,_) -> ref == key) 197 | 198 | deleteFromRunQueue :: (MonitorRef, CallRef (Either ExitReason a), Async a) 199 | -> [(MonitorRef, CallRef (Either ExitReason a), Async a)] 200 | -> [(MonitorRef, CallRef (Either ExitReason a), Async a)] 201 | deleteFromRunQueue c@(p, _, _) runQ = deleteBy (\_ (b, _, _) -> b == p) c runQ 202 | 203 | {-# INLINE enqueue #-} 204 | enqueue :: Seq a -> a -> Seq a 205 | enqueue s a = a <| s 206 | 207 | {-# INLINE dequeue #-} 208 | dequeue :: Seq a -> Maybe (a, Seq a) 209 | dequeue s = maybe Nothing (\(s' :> a) -> Just (a, s')) $ getR s 210 | 211 | getR :: Seq a -> Maybe (ViewR a) 212 | getR s = 213 | case (viewr s) of 214 | EmptyR -> Nothing 215 | a -> Just a 216 | 217 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE CPP #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Control.Distributed.Process.Platform.Test 9 | -- Copyright : (c) Tim Watson, Jeff Epstein 2013 10 | -- License : BSD3 (see the file LICENSE) 11 | -- 12 | -- Maintainer : Tim Watson 13 | -- Stability : experimental 14 | -- Portability : non-portable (requires concurrency) 15 | -- 16 | -- This module provides basic building blocks for testing Cloud Haskell programs. 17 | ----------------------------------------------------------------------------- 18 | 19 | module Control.Distributed.Process.Platform.Test 20 | ( TestResult 21 | , noop 22 | , stash 23 | -- ping ! 24 | , Ping(Ping) 25 | , ping 26 | -- test process utilities 27 | , TestProcessControl 28 | , startTestProcess 29 | , runTestProcess 30 | , testProcessGo 31 | , testProcessStop 32 | , testProcessReport 33 | -- runners 34 | , tryRunProcess 35 | , tryForkProcess 36 | ) where 37 | 38 | import Control.Concurrent 39 | ( myThreadId 40 | , throwTo 41 | ) 42 | import Control.Concurrent.MVar 43 | ( MVar 44 | , putMVar 45 | ) 46 | import Control.DeepSeq (NFData) 47 | import Control.Distributed.Process 48 | import Control.Distributed.Process.Node 49 | import Control.Distributed.Process.Serializable() 50 | import Control.Exception (SomeException) 51 | import Data.Binary 52 | import Data.Typeable (Typeable) 53 | #if ! MIN_VERSION_base(4,6,0) 54 | import Prelude hiding (catch) 55 | #endif 56 | 57 | import GHC.Generics 58 | 59 | -- | A mutable cell containing a test result. 60 | type TestResult a = MVar a 61 | 62 | -- | A simple @Ping@ signal 63 | data Ping = Ping 64 | deriving (Typeable, Generic, Eq, Show) 65 | instance Binary Ping where 66 | instance NFData Ping where 67 | 68 | ping :: ProcessId -> Process () 69 | ping pid = send pid Ping 70 | 71 | -- | Control signals used to manage /test processes/ 72 | data TestProcessControl = Stop | Go | Report ProcessId 73 | deriving (Typeable, Generic) 74 | 75 | instance Binary TestProcessControl where 76 | 77 | -- | Starts a test process on the local node. 78 | startTestProcess :: Process () -> Process ProcessId 79 | startTestProcess proc = 80 | spawnLocal $ do 81 | getSelfPid >>= register "test-process" 82 | runTestProcess proc 83 | 84 | -- | Runs a /test process/ around the supplied @proc@, which is executed 85 | -- whenever the outer process loop receives a 'Go' signal. 86 | runTestProcess :: Process () -> Process () 87 | runTestProcess proc = do 88 | ctl <- expect 89 | case ctl of 90 | Stop -> return () 91 | Go -> proc >> runTestProcess proc 92 | Report p -> receiveWait [matchAny (\m -> forward m p)] >> runTestProcess proc 93 | 94 | -- | Tell a /test process/ to continue executing 95 | testProcessGo :: ProcessId -> Process () 96 | testProcessGo pid = send pid Go 97 | 98 | -- | Tell a /test process/ to stop (i.e., 'terminate') 99 | testProcessStop :: ProcessId -> Process () 100 | testProcessStop pid = send pid Stop 101 | 102 | -- | Tell a /test process/ to send a report (message) 103 | -- back to the calling process 104 | testProcessReport :: ProcessId -> Process () 105 | testProcessReport pid = do 106 | self <- getSelfPid 107 | send pid $ Report self 108 | 109 | -- | Does exactly what it says on the tin, doing so in the @Process@ monad. 110 | noop :: Process () 111 | noop = return () 112 | 113 | -- | Stashes a value in our 'TestResult' using @putMVar@ 114 | stash :: TestResult a -> a -> Process () 115 | stash mvar x = liftIO $ putMVar mvar x 116 | 117 | tryRunProcess :: LocalNode -> Process () -> IO () 118 | tryRunProcess node p = do 119 | tid <- liftIO myThreadId 120 | runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException)) 121 | 122 | tryForkProcess :: LocalNode -> Process () -> IO ProcessId 123 | tryForkProcess node p = do 124 | tid <- liftIO myThreadId 125 | forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException)) 126 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Control.Distributed.Process.Platform.Time 7 | -- Copyright : (c) Tim Watson, Jeff Epstein, Alan Zimmerman 8 | -- License : BSD3 (see the file LICENSE) 9 | -- 10 | -- Maintainer : Tim Watson 11 | -- Stability : experimental 12 | -- Portability : non-portable (requires concurrency) 13 | -- 14 | -- This module provides facilities for working with time delays and timeouts. 15 | -- The type 'Timeout' and the 'timeout' family of functions provide mechanisms 16 | -- for working with @threadDelay@-like behaviour that operates on microsecond 17 | -- values. 18 | -- 19 | -- The 'TimeInterval' and 'TimeUnit' related functions provide an abstraction 20 | -- for working with various time intervals, whilst the 'Delay' type provides a 21 | -- corrolary to 'timeout' that works with these. 22 | ----------------------------------------------------------------------------- 23 | 24 | module Control.Distributed.Process.Platform.Time 25 | ( -- * Time interval handling 26 | microSeconds 27 | , milliSeconds 28 | , seconds 29 | , minutes 30 | , hours 31 | , asTimeout 32 | , after 33 | , within 34 | , timeToMicros 35 | , TimeInterval 36 | , TimeUnit(..) 37 | , Delay(..) 38 | 39 | -- * Conversion To/From NominalDiffTime 40 | , timeIntervalToDiffTime 41 | , diffTimeToTimeInterval 42 | , diffTimeToDelay 43 | , delayToDiffTime 44 | , microsecondsToNominalDiffTime 45 | 46 | -- * (Legacy) Timeout Handling 47 | , Timeout 48 | , TimeoutNotification(..) 49 | , timeout 50 | , infiniteWait 51 | , noWait 52 | ) where 53 | 54 | import Control.Concurrent (threadDelay) 55 | import Control.DeepSeq (NFData) 56 | import Control.Distributed.Process 57 | import Control.Distributed.Process.Platform.Internal.Types 58 | import Control.Monad (void) 59 | import Data.Binary 60 | import Data.Ratio ((%)) 61 | import Data.Time.Clock 62 | import Data.Typeable (Typeable) 63 | 64 | import GHC.Generics 65 | 66 | -------------------------------------------------------------------------------- 67 | -- API -- 68 | -------------------------------------------------------------------------------- 69 | 70 | -- | Defines the time unit for a Timeout value 71 | data TimeUnit = Days | Hours | Minutes | Seconds | Millis | Micros 72 | deriving (Typeable, Generic, Eq, Show) 73 | 74 | instance Binary TimeUnit where 75 | instance NFData TimeUnit where 76 | 77 | -- | A time interval. 78 | data TimeInterval = TimeInterval TimeUnit Int 79 | deriving (Typeable, Generic, Eq, Show) 80 | 81 | instance Binary TimeInterval where 82 | instance NFData TimeInterval where 83 | 84 | -- | Represents either a delay of 'TimeInterval', an infinite wait or no delay 85 | -- (i.e., non-blocking). 86 | data Delay = Delay TimeInterval | Infinity | NoDelay 87 | deriving (Typeable, Generic, Eq, Show) 88 | 89 | instance Binary Delay where 90 | instance NFData Delay where 91 | 92 | -- | Represents a /timeout/ in terms of microseconds, where 'Nothing' stands for 93 | -- infinity and @Just 0@, no-delay. 94 | type Timeout = Maybe Int 95 | 96 | -- | Send to a process when a timeout expires. 97 | data TimeoutNotification = TimeoutNotification Tag 98 | deriving (Typeable) 99 | 100 | instance Binary TimeoutNotification where 101 | get = fmap TimeoutNotification $ get 102 | put (TimeoutNotification n) = put n 103 | 104 | -- time interval/unit handling 105 | 106 | -- | converts the supplied @TimeInterval@ to microseconds 107 | asTimeout :: TimeInterval -> Int 108 | asTimeout (TimeInterval u v) = timeToMicros u v 109 | 110 | -- | Convenience for making timeouts; e.g., 111 | -- 112 | -- > receiveTimeout (after 3 Seconds) [ match (\"ok" -> return ()) ] 113 | -- 114 | after :: Int -> TimeUnit -> Int 115 | after n m = timeToMicros m n 116 | 117 | -- | Convenience for making 'TimeInterval'; e.g., 118 | -- 119 | -- > let ti = within 5 Seconds in ..... 120 | -- 121 | within :: Int -> TimeUnit -> TimeInterval 122 | within n m = TimeInterval m n 123 | 124 | -- | given a number, produces a @TimeInterval@ of microseconds 125 | microSeconds :: Int -> TimeInterval 126 | microSeconds = TimeInterval Micros 127 | 128 | -- | given a number, produces a @TimeInterval@ of milliseconds 129 | milliSeconds :: Int -> TimeInterval 130 | milliSeconds = TimeInterval Millis 131 | 132 | -- | given a number, produces a @TimeInterval@ of seconds 133 | seconds :: Int -> TimeInterval 134 | seconds = TimeInterval Seconds 135 | 136 | -- | given a number, produces a @TimeInterval@ of minutes 137 | minutes :: Int -> TimeInterval 138 | minutes = TimeInterval Minutes 139 | 140 | -- | given a number, produces a @TimeInterval@ of hours 141 | hours :: Int -> TimeInterval 142 | hours = TimeInterval Hours 143 | 144 | -- TODO: is timeToMicros efficient enough? 145 | 146 | -- | converts the supplied @TimeUnit@ to microseconds 147 | {-# INLINE timeToMicros #-} 148 | timeToMicros :: TimeUnit -> Int -> Int 149 | timeToMicros Micros us = us 150 | timeToMicros Millis ms = ms * (10 ^ (3 :: Int)) -- (1000µs == 1ms) 151 | timeToMicros Seconds secs = timeToMicros Millis (secs * milliSecondsPerSecond) 152 | timeToMicros Minutes mins = timeToMicros Seconds (mins * secondsPerMinute) 153 | timeToMicros Hours hrs = timeToMicros Minutes (hrs * minutesPerHour) 154 | timeToMicros Days days = timeToMicros Hours (days * hoursPerDay) 155 | 156 | {-# INLINE hoursPerDay #-} 157 | hoursPerDay :: Int 158 | hoursPerDay = 60 159 | 160 | {-# INLINE minutesPerHour #-} 161 | minutesPerHour :: Int 162 | minutesPerHour = 60 163 | 164 | {-# INLINE secondsPerMinute #-} 165 | secondsPerMinute :: Int 166 | secondsPerMinute = 60 167 | 168 | {-# INLINE milliSecondsPerSecond #-} 169 | milliSecondsPerSecond :: Int 170 | milliSecondsPerSecond = 1000 171 | 172 | {-# INLINE microSecondsPerSecond #-} 173 | microSecondsPerSecond :: Int 174 | microSecondsPerSecond = 1000000 175 | 176 | -- timeouts/delays (microseconds) 177 | 178 | -- | Constructs an inifinite 'Timeout'. 179 | infiniteWait :: Timeout 180 | infiniteWait = Nothing 181 | 182 | -- | Constructs a no-wait 'Timeout' 183 | noWait :: Timeout 184 | noWait = Just 0 185 | 186 | -- | Sends the calling process @TimeoutNotification tag@ after @time@ microseconds 187 | timeout :: Int -> Tag -> ProcessId -> Process () 188 | timeout time tag p = 189 | void $ spawnLocal $ 190 | do liftIO $ threadDelay time 191 | send p (TimeoutNotification tag) 192 | 193 | -- Converting to/from Data.Time.Clock NominalDiffTime 194 | 195 | -- | given a @TimeInterval@, provide an equivalent @NominalDiffTim@ 196 | timeIntervalToDiffTime :: TimeInterval -> NominalDiffTime 197 | timeIntervalToDiffTime ti = microsecondsToNominalDiffTime (fromIntegral $ asTimeout ti) 198 | 199 | -- | given a @NominalDiffTim@@, provide an equivalent @TimeInterval@ 200 | diffTimeToTimeInterval :: NominalDiffTime -> TimeInterval 201 | diffTimeToTimeInterval dt = microSeconds $ (fromIntegral (round (dt * 1000000) :: Integer)) 202 | 203 | -- | given a @Delay@, provide an equivalent @NominalDiffTim@ 204 | delayToDiffTime :: Delay -> NominalDiffTime 205 | delayToDiffTime (Delay ti) = timeIntervalToDiffTime ti 206 | delayToDiffTime Infinity = error "trying to convert Delay.Infinity to a NominalDiffTime" 207 | delayToDiffTime (NoDelay) = microsecondsToNominalDiffTime 0 208 | 209 | -- | given a @NominalDiffTim@@, provide an equivalent @Delay@ 210 | diffTimeToDelay :: NominalDiffTime -> Delay 211 | diffTimeToDelay dt = Delay $ diffTimeToTimeInterval dt 212 | 213 | -- | Create a 'NominalDiffTime' from a number of microseconds. 214 | microsecondsToNominalDiffTime :: Integer -> NominalDiffTime 215 | microsecondsToNominalDiffTime x = fromRational (x % (fromIntegral microSecondsPerSecond)) 216 | 217 | -- tenYearsAsMicroSeconds :: Integer 218 | -- tenYearsAsMicroSeconds = 10 * 365 * 24 * 60 * 60 * 1000000 219 | 220 | -- | Allow @(+)@ and @(-)@ operations on @TimeInterval@s 221 | instance Num TimeInterval where 222 | t1 + t2 = microSeconds $ asTimeout t1 + asTimeout t2 223 | t1 - t2 = microSeconds $ asTimeout t1 - asTimeout t2 224 | _ * _ = error "trying to multiply two TimeIntervals" 225 | abs t = microSeconds $ abs (asTimeout t) 226 | signum t = if (asTimeout t) == 0 227 | then 0 228 | else if (asTimeout t) < 0 then -1 229 | else 1 230 | fromInteger _ = error "trying to call fromInteger for a TimeInterval. Cannot guess units" 231 | 232 | -- | Allow @(+)@ and @(-)@ operations on @Delay@s 233 | instance Num Delay where 234 | NoDelay + x = x 235 | Infinity + _ = Infinity 236 | x + NoDelay = x 237 | _ + Infinity = Infinity 238 | (Delay t1 ) + (Delay t2) = Delay (t1 + t2) 239 | 240 | NoDelay - x = x 241 | Infinity - _ = Infinity 242 | x - NoDelay = x 243 | _ - Infinity = Infinity 244 | (Delay t1 ) - (Delay t2) = Delay (t1 - t2) 245 | 246 | _ * _ = error "trying to multiply two Delays" 247 | 248 | abs NoDelay = NoDelay 249 | abs Infinity = Infinity 250 | abs (Delay t) = Delay (abs t) 251 | 252 | signum (NoDelay) = 0 253 | signum Infinity = 1 254 | signum (Delay t) = Delay (signum t) 255 | 256 | fromInteger 0 = NoDelay 257 | fromInteger _ = error "trying to call fromInteger for a Delay. Cannot guess units" 258 | 259 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/Timer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE PatternGuards #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Control.Distributed.Process.Platform.Timer 9 | -- Copyright : (c) Tim Watson 2012 10 | -- License : BSD3 (see the file LICENSE) 11 | -- 12 | -- Maintainer : Tim Watson 13 | -- Stability : experimental 14 | -- Portability : non-portable (requires concurrency) 15 | -- 16 | -- Provides an API for running code or sending messages, either after some 17 | -- initial delay or periodically, and for cancelling, re-setting and/or 18 | -- flushing pending /timers/. 19 | ----------------------------------------------------------------------------- 20 | 21 | module Control.Distributed.Process.Platform.Timer 22 | ( 23 | TimerRef 24 | , Tick(Tick) 25 | , sleep 26 | , sleepFor 27 | , sendAfter 28 | , runAfter 29 | , exitAfter 30 | , killAfter 31 | , startTimer 32 | , ticker 33 | , periodically 34 | , resetTimer 35 | , cancelTimer 36 | , flushTimer 37 | ) where 38 | 39 | import Control.DeepSeq (NFData) 40 | import Control.Distributed.Process hiding (send) 41 | import Control.Distributed.Process.Serializable 42 | import Control.Distributed.Process.Platform.UnsafePrimitives (send) 43 | import Control.Distributed.Process.Platform.Internal.Types (NFSerializable) 44 | import Control.Distributed.Process.Platform.Time 45 | import Data.Binary 46 | import Data.Typeable (Typeable) 47 | import Prelude hiding (init) 48 | 49 | import GHC.Generics 50 | 51 | -- | an opaque reference to a timer 52 | type TimerRef = ProcessId 53 | 54 | -- | cancellation message sent to timers 55 | data TimerConfig = Reset | Cancel 56 | deriving (Typeable, Generic, Eq, Show) 57 | instance Binary TimerConfig where 58 | instance NFData TimerConfig where 59 | 60 | -- | represents a 'tick' event that timers can generate 61 | data Tick = Tick 62 | deriving (Typeable, Generic, Eq, Show) 63 | instance Binary Tick where 64 | instance NFData Tick where 65 | 66 | data SleepingPill = SleepingPill 67 | deriving (Typeable, Generic, Eq, Show) 68 | instance Binary SleepingPill where 69 | instance NFData SleepingPill where 70 | 71 | -------------------------------------------------------------------------------- 72 | -- API -- 73 | -------------------------------------------------------------------------------- 74 | 75 | -- | blocks the calling Process for the specified TimeInterval. Note that this 76 | -- function assumes that a blocking receive is the most efficient approach to 77 | -- acheiving this, however the runtime semantics (particularly with regards 78 | -- scheduling) should not differ from threadDelay in practise. 79 | sleep :: TimeInterval -> Process () 80 | sleep t = 81 | let ms = asTimeout t in do 82 | _ <- receiveTimeout ms [matchIf (\SleepingPill -> True) 83 | (\_ -> return ())] 84 | return () 85 | 86 | -- | Literate way of saying @sleepFor 3 Seconds@. 87 | sleepFor :: Int -> TimeUnit -> Process () 88 | sleepFor i u = sleep (within i u) 89 | 90 | -- | starts a timer which sends the supplied message to the destination 91 | -- process after the specified time interval. 92 | sendAfter :: (NFSerializable a) 93 | => TimeInterval 94 | -> ProcessId 95 | -> a 96 | -> Process TimerRef 97 | sendAfter t pid msg = runAfter t proc 98 | where proc = do { send pid msg } 99 | 100 | -- | runs the supplied process action(s) after @t@ has elapsed 101 | runAfter :: TimeInterval -> Process () -> Process TimerRef 102 | runAfter t p = spawnLocal $ runTimer t p True 103 | 104 | -- | calls @exit pid reason@ after @t@ has elapsed 105 | exitAfter :: (Serializable a) 106 | => TimeInterval 107 | -> ProcessId 108 | -> a 109 | -> Process TimerRef 110 | exitAfter delay pid reason = runAfter delay $ exit pid reason 111 | 112 | -- | kills the specified process after @t@ has elapsed 113 | killAfter :: TimeInterval -> ProcessId -> String -> Process TimerRef 114 | killAfter delay pid why = runAfter delay $ kill pid why 115 | 116 | -- | starts a timer that repeatedly sends the supplied message to the destination 117 | -- process each time the specified time interval elapses. To stop messages from 118 | -- being sent in future, 'cancelTimer' can be called. 119 | startTimer :: (NFSerializable a) 120 | => TimeInterval 121 | -> ProcessId 122 | -> a 123 | -> Process TimerRef 124 | startTimer t pid msg = periodically t (send pid msg) 125 | 126 | -- | runs the supplied process action(s) repeatedly at intervals of @t@ 127 | periodically :: TimeInterval -> Process () -> Process TimerRef 128 | periodically t p = spawnLocal $ runTimer t p False 129 | 130 | -- | resets a running timer. Note: Cancelling a timer does not guarantee that 131 | -- all its messages are prevented from being delivered to the target process. 132 | -- Also note that resetting an ongoing timer (started using the 'startTimer' or 133 | -- 'periodically' functions) will only cause the current elapsed period to time 134 | -- out, after which the timer will continue running. To stop a long-running 135 | -- timer permanently, you should use 'cancelTimer' instead. 136 | resetTimer :: TimerRef -> Process () 137 | resetTimer = (flip send) Reset 138 | 139 | -- | permanently cancels a timer 140 | cancelTimer :: TimerRef -> Process () 141 | cancelTimer = (flip send) Cancel 142 | 143 | -- | cancels a running timer and flushes any viable timer messages from the 144 | -- process' message queue. This function should only be called by the process 145 | -- expecting to receive the timer's messages! 146 | flushTimer :: (Serializable a, Eq a) => TimerRef -> a -> Delay -> Process () 147 | flushTimer ref ignore t = do 148 | mRef <- monitor ref 149 | cancelTimer ref 150 | performFlush mRef t 151 | return () 152 | where performFlush mRef Infinity = receiveWait $ filters mRef 153 | performFlush mRef NoDelay = performFlush mRef (Delay $ microSeconds 0) 154 | performFlush mRef (Delay i) = receiveTimeout (asTimeout i) (filters mRef) >> return () 155 | filters mRef = [ 156 | matchIf (\x -> x == ignore) 157 | (\_ -> return ()) 158 | , matchIf (\(ProcessMonitorNotification mRef' _ _) -> mRef == mRef') 159 | (\_ -> return ()) ] 160 | 161 | -- | sets up a timer that sends 'Tick' repeatedly at intervals of @t@ 162 | ticker :: TimeInterval -> ProcessId -> Process TimerRef 163 | ticker t pid = startTimer t pid Tick 164 | 165 | -------------------------------------------------------------------------------- 166 | -- Implementation -- 167 | -------------------------------------------------------------------------------- 168 | 169 | -- runs the timer process 170 | runTimer :: TimeInterval -> Process () -> Bool -> Process () 171 | runTimer t proc cancelOnReset = do 172 | cancel <- expectTimeout (asTimeout t) 173 | -- say $ "cancel = " ++ (show cancel) ++ "\n" 174 | case cancel of 175 | Nothing -> runProc cancelOnReset 176 | Just Cancel -> return () 177 | Just Reset -> if cancelOnReset then return () 178 | else runTimer t proc cancelOnReset 179 | where runProc True = proc 180 | runProc False = proc >> runTimer t proc cancelOnReset 181 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Platform/UnsafePrimitives.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Distributed.Process.Platform.UnsafePrimitives 4 | -- Copyright : (c) Tim Watson 2013 5 | -- License : BSD3 (see the file LICENSE) 6 | -- 7 | -- Maintainer : Tim Watson 8 | -- Stability : experimental 9 | -- Portability : non-portable (requires concurrency) 10 | -- 11 | -- [Unsafe Messaging Primitives Using NFData] 12 | -- 13 | -- This module mirrors "Control.Distributed.Process.UnsafePrimitives", but 14 | -- attempts to provide a bit more safety by forcing evaluation before sending. 15 | -- This is handled using @NFData@, by means of the @NFSerializable@ type class. 16 | -- 17 | -- Note that we /still/ cannot guarantee that both the @NFData@ and @Binary@ 18 | -- instances will evaluate your data the same way, therefore these primitives 19 | -- still have certain risks and potential side effects. Use with caution. 20 | -- 21 | ----------------------------------------------------------------------------- 22 | module Control.Distributed.Process.Platform.UnsafePrimitives 23 | ( send 24 | , nsend 25 | , sendToAddr 26 | , sendChan 27 | , wrapMessage 28 | ) where 29 | 30 | import Control.DeepSeq (($!!)) 31 | import Control.Distributed.Process 32 | ( Process 33 | , ProcessId 34 | , SendPort 35 | , Message 36 | ) 37 | import Control.Distributed.Process.Platform.Internal.Types 38 | ( NFSerializable 39 | , Addressable 40 | , Resolvable(..) 41 | ) 42 | import qualified Control.Distributed.Process.UnsafePrimitives as Unsafe 43 | 44 | send :: NFSerializable m => ProcessId -> m -> Process () 45 | send pid msg = Unsafe.send pid $!! msg 46 | 47 | nsend :: NFSerializable a => String -> a -> Process () 48 | nsend name msg = Unsafe.nsend name $!! msg 49 | 50 | sendToAddr :: (Addressable a, NFSerializable m) => a -> m -> Process () 51 | sendToAddr addr msg = do 52 | mPid <- resolve addr 53 | case mPid of 54 | Nothing -> return () 55 | Just p -> send p msg 56 | 57 | sendChan :: (NFSerializable m) => SendPort m -> m -> Process () 58 | sendChan port msg = Unsafe.sendChan port $!! msg 59 | 60 | -- | Create an unencoded @Message@ for any @Serializable@ type. 61 | wrapMessage :: NFSerializable a => a -> Message 62 | wrapMessage msg = Unsafe.wrapMessage $!! msg 63 | 64 | -------------------------------------------------------------------------------- /test-report.hs: -------------------------------------------------------------------------------- 1 | #! /bin/sh 2 | 3 | HPC_DIR=dist/hpc 4 | 5 | cabal-dev clean 6 | cabal-dev configure --enable-tests --enable-library-coverage 7 | cabal-dev build 8 | cabal-dev test 9 | 10 | open ${HPC_DIR}/html/*/hpc-index.html 11 | -------------------------------------------------------------------------------- /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.Platform 18 | import Control.Distributed.Process.Platform.Async 19 | import Control.Distributed.Process.Platform.ManagedProcess 20 | import Control.Distributed.Process.Platform.Time 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 :: Process (ProcessReply Int State) 90 | haltMaxCount = haltNoReply_ (ExitOther "Count > 10") 91 | 92 | handleIncrement :: State -> Increment -> Process (ProcessReply Int State) 93 | handleIncrement count Increment = 94 | let next = count + 1 in continue next >>= replyWith next 95 | 96 | -------------------------------------------------------------------------------- /tests/MailboxTestFilters.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module MailboxTestFilters where 5 | 6 | import Control.Distributed.Process 7 | import Control.Distributed.Process.Platform.Execution.Mailbox (FilterResult(..)) 8 | import Control.Monad (forM) 9 | 10 | #if ! MIN_VERSION_base(4,6,0) 11 | import Prelude hiding (catch, drop) 12 | #else 13 | import Prelude hiding (drop) 14 | #endif 15 | import Data.Maybe (catMaybes) 16 | import Control.Distributed.Process.Closure (remotable, mkClosure, mkStaticClosure) 17 | 18 | filterInputs :: (String, Int, Bool) -> Message -> Process FilterResult 19 | filterInputs (s, i, b) msg = do 20 | rs <- forM [ \m -> handleMessageIf m (\s' -> s' == s) (\_ -> return Keep) 21 | , \m -> handleMessageIf m (\i' -> i' == i) (\_ -> return Keep) 22 | , \m -> handleMessageIf m (\b' -> b' == b) (\_ -> return Keep) 23 | ] $ \h -> h msg 24 | if (length (catMaybes rs) > 0) 25 | then return Keep 26 | else return Skip 27 | 28 | filterEvens :: Message -> Process FilterResult 29 | filterEvens m = do 30 | matched <- handleMessage m (\(i :: Int) -> do 31 | if even i then return Keep else return Skip) 32 | case matched of 33 | Just fr -> return fr 34 | _ -> return Skip 35 | 36 | $(remotable ['filterInputs, 'filterEvens]) 37 | 38 | intFilter :: Closure (Message -> Process FilterResult) 39 | intFilter = $(mkStaticClosure 'filterEvens) 40 | 41 | myFilter :: (String, Int, Bool) -> Closure (Message -> Process FilterResult) 42 | myFilter = $(mkClosure 'filterInputs) 43 | 44 | -------------------------------------------------------------------------------- /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.Applicative 12 | import Control.Distributed.Process hiding (call) 13 | import Control.Distributed.Process.Platform 14 | import Control.Distributed.Process.Platform.ManagedProcess 15 | import Control.Distributed.Process.Platform.Time 16 | 17 | import Data.Binary (Binary(..)) 18 | import Data.Typeable (Typeable) 19 | 20 | data Add = Add Double Double deriving (Typeable) 21 | data Divide = Divide Double Double deriving (Typeable) 22 | data DivByZero = DivByZero deriving (Typeable, Eq) 23 | 24 | instance Binary Add where 25 | put (Add x y) = put x >> put y 26 | get = Add <$> get <*> get 27 | 28 | instance Binary Divide where 29 | put (Divide x y) = put x >> put y 30 | get = Divide <$> get <*> get 31 | 32 | instance Binary DivByZero where 33 | put DivByZero = return () 34 | get = return DivByZero 35 | 36 | -- public API 37 | 38 | add :: ProcessId -> Double -> Double -> Process Double 39 | add sid x y = call sid (Add x y) 40 | 41 | divide :: ProcessId -> Double -> Double 42 | -> Process (Either DivByZero Double) 43 | divide sid x y = call sid (Divide x y ) 44 | 45 | launchMathServer :: Process ProcessId 46 | launchMathServer = 47 | let server = statelessProcess { 48 | apiHandlers = [ 49 | handleCall_ (\(Add x y) -> return (x + y)) 50 | , handleCallIf_ (input (\(Divide _ y) -> y /= 0)) handleDivide 51 | , handleCall_ (\(Divide _ _) -> divByZero) 52 | , action (\("stop") -> stop_ ExitNormal) 53 | ] 54 | } 55 | in spawnLocal $ serve () (statelessInit Infinity) server 56 | where handleDivide :: Divide -> Process (Either DivByZero Double) 57 | handleDivide (Divide x y) = return $ Right $ x / y 58 | 59 | divByZero :: Process (Either DivByZero Double) 60 | divByZero = return $ Left DivByZero 61 | -------------------------------------------------------------------------------- /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.Platform 22 | import Control.Distributed.Process.Platform.Async 23 | import Control.Distributed.Process.Platform.ManagedProcess 24 | ( ProcessDefinition(..) 25 | , InitHandler 26 | , InitResult(..) 27 | , defaultProcess 28 | , condition 29 | ) 30 | import qualified Control.Distributed.Process.Platform.ManagedProcess as ManagedProcess (serve) 31 | import Control.Distributed.Process.Platform.ManagedProcess.Client 32 | import Control.Distributed.Process.Platform.ManagedProcess.Server.Restricted 33 | import Control.Distributed.Process.Platform.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/TestAsync.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | import Control.Concurrent.MVar (MVar, takeMVar, newEmptyMVar) 6 | import Control.Distributed.Process 7 | import Control.Distributed.Process.Node 8 | import Control.Distributed.Process.Platform.Async 9 | import Control.Distributed.Process.Platform.Test 10 | import Control.Distributed.Process.Platform.Time 11 | import Control.Distributed.Process.Platform.Timer 12 | 13 | import Test.Framework (Test, testGroup) 14 | import Test.Framework.Providers.HUnit (testCase) 15 | import qualified Network.Transport as NT 16 | import TestAsyncChan (asyncChanTests) 17 | import TestAsyncSTM (asyncStmTests) 18 | import TestUtils 19 | 20 | testAsyncPoll :: TestResult (AsyncResult ()) -> Process () 21 | testAsyncPoll result = do 22 | hAsync <- async $ do "go" <- expect; say "running" >> return () 23 | ar <- poll hAsync 24 | case ar of 25 | AsyncPending -> 26 | send (asyncWorker hAsync) "go" >> wait hAsync >>= stash result 27 | _ -> stash result ar >> return () 28 | 29 | testAsyncCancel :: TestResult (AsyncResult ()) -> Process () 30 | testAsyncCancel result = do 31 | hAsync <- async $ runTestProcess $ say "running" >> return () 32 | sleep $ milliSeconds 100 33 | 34 | p <- poll hAsync -- nasty kind of assertion: use assertEquals? 35 | case p of 36 | AsyncPending -> cancel hAsync >> wait hAsync >>= stash result 37 | _ -> say (show p) >> stash result p 38 | 39 | testAsyncCancelWait :: TestResult (Maybe (AsyncResult ())) -> Process () 40 | testAsyncCancelWait result = do 41 | testPid <- getSelfPid 42 | p <- spawnLocal $ do 43 | hAsync <- async $ runTestProcess $ sleep $ seconds 60 44 | sleep $ milliSeconds 100 45 | 46 | send testPid "running" 47 | 48 | AsyncPending <- poll hAsync 49 | cancelWait hAsync >>= send testPid 50 | 51 | "running" <- expect 52 | d <- expectTimeout (asTimeout $ seconds 5) 53 | case d of 54 | Nothing -> kill p "timed out" >> stash result Nothing 55 | Just ar -> stash result (Just ar) 56 | 57 | testAsyncWaitTimeout :: TestResult (Maybe (AsyncResult ())) -> Process () 58 | testAsyncWaitTimeout result = 59 | let delay = seconds 1 60 | in do 61 | hAsync <- async $ sleep $ seconds 20 62 | waitTimeout delay hAsync >>= stash result 63 | cancelWait hAsync >> return () 64 | 65 | testAsyncWaitTimeoutCompletes :: TestResult (Maybe (AsyncResult ())) 66 | -> Process () 67 | testAsyncWaitTimeoutCompletes result = 68 | let delay = seconds 1 69 | in do 70 | hAsync <- async $ sleep $ seconds 20 71 | waitTimeout delay hAsync >>= stash result 72 | cancelWait hAsync >> return () 73 | 74 | testAsyncLinked :: TestResult Bool -> Process () 75 | testAsyncLinked result = do 76 | mv :: MVar (Async ()) <- liftIO $ newEmptyMVar 77 | pid <- spawnLocal $ do 78 | -- NB: async == asyncLinked for AsyncChan 79 | h <- asyncLinked $ do 80 | "waiting" <- expect 81 | return () 82 | stash mv h 83 | "sleeping" <- expect 84 | return () 85 | 86 | hAsync <- liftIO $ takeMVar mv 87 | 88 | mref <- monitor $ asyncWorker hAsync 89 | exit pid "stop" 90 | 91 | _ <- receiveTimeout (after 5 Seconds) [ 92 | matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref') 93 | (\_ -> return ()) 94 | ] 95 | 96 | -- since the initial caller died and we used 'asyncLinked', the async should 97 | -- pick up on the exit signal and set the result accordingly. trying to match 98 | -- on 'DiedException String' is pointless though, as the *string* is highly 99 | -- context dependent. 100 | r <- waitTimeout (within 3 Seconds) hAsync 101 | case r of 102 | Nothing -> stash result True 103 | Just _ -> stash result False 104 | 105 | testAsyncCancelWith :: TestResult Bool -> Process () 106 | testAsyncCancelWith result = do 107 | p1 <- async $ do { s :: String <- expect; return s } 108 | cancelWith "foo" p1 109 | AsyncFailed (DiedException _) <- wait p1 110 | stash result True 111 | 112 | allAsyncTests :: NT.Transport -> IO [Test] 113 | allAsyncTests transport = do 114 | chanTestGroup <- asyncChanTests transport 115 | stmTestGroup <- asyncStmTests transport 116 | localNode <- newLocalNode transport initRemoteTable 117 | return [ 118 | testGroup "Async Channel" chanTestGroup 119 | , testGroup "Async STM" stmTestGroup 120 | , testGroup "Async Common API" [ 121 | testCase "Async Common API cancel" 122 | (delayedAssertion 123 | "expected async task to have been cancelled" 124 | localNode (AsyncCancelled) testAsyncCancel) 125 | , testCase "Async Common API poll" 126 | (delayedAssertion 127 | "expected poll to return a valid AsyncResult" 128 | localNode (AsyncDone ()) testAsyncPoll) 129 | , testCase "Async Common API cancelWait" 130 | (delayedAssertion 131 | "expected cancelWait to complete some time" 132 | localNode (Just AsyncCancelled) testAsyncCancelWait) 133 | , testCase "Async Common API waitTimeout" 134 | (delayedAssertion 135 | "expected waitTimeout to return Nothing when it times out" 136 | localNode (Nothing) testAsyncWaitTimeout) 137 | , testCase "Async Common API waitTimeout completion" 138 | (delayedAssertion 139 | "expected waitTimeout to return a value" 140 | localNode Nothing testAsyncWaitTimeoutCompletes) 141 | , testCase "Async Common API asyncLinked" 142 | (delayedAssertion 143 | "expected linked process to die with originator" 144 | localNode True testAsyncLinked) 145 | , testCase "Async Common API cancelWith" 146 | (delayedAssertion 147 | "expected the worker to have been killed with the given signal" 148 | localNode True testAsyncCancelWith) 149 | ] ] 150 | 151 | main :: IO () 152 | main = testMain $ allAsyncTests 153 | -------------------------------------------------------------------------------- /tests/TestAsyncChan.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module TestAsyncChan where 6 | 7 | import Control.Concurrent.MVar 8 | ( newEmptyMVar 9 | , takeMVar 10 | , MVar) 11 | import Control.Distributed.Process 12 | import Control.Distributed.Process.Node 13 | import Control.Distributed.Process.Serializable() 14 | import Control.Distributed.Process.Platform.Time 15 | import Control.Distributed.Process.Platform.Timer 16 | import Control.Distributed.Process.Platform.Async (task) 17 | import Control.Distributed.Process.Platform.Async.AsyncChan 18 | import Data.Binary() 19 | import Data.Typeable() 20 | import qualified Network.Transport as NT (Transport) 21 | #if ! MIN_VERSION_base(4,6,0) 22 | import Prelude hiding (catch) 23 | #endif 24 | 25 | import Test.Framework (Test, testGroup) 26 | import Test.Framework.Providers.HUnit (testCase) 27 | import Control.Distributed.Process.Platform.Test 28 | import TestUtils 29 | 30 | testAsyncPoll :: TestResult (AsyncResult ()) -> Process () 31 | testAsyncPoll result = do 32 | hAsync <- async $ task $ do "go" <- expect; say "running" >> return () 33 | ar <- poll hAsync 34 | case ar of 35 | AsyncPending -> 36 | send (worker hAsync) "go" >> wait hAsync >>= stash result 37 | _ -> stash result ar >> return () 38 | 39 | testAsyncCancel :: TestResult (AsyncResult ()) -> Process () 40 | testAsyncCancel result = do 41 | hAsync <- async $ task $ runTestProcess $ say "running" >> return () 42 | sleep $ milliSeconds 100 43 | 44 | p <- poll hAsync -- nasty kind of assertion: use assertEquals? 45 | case p of 46 | AsyncPending -> cancel hAsync >> wait hAsync >>= stash result 47 | _ -> say (show p) >> stash result p 48 | 49 | testAsyncCancelWait :: TestResult (Maybe (AsyncResult ())) -> Process () 50 | testAsyncCancelWait result = do 51 | testPid <- getSelfPid 52 | p <- spawnLocal $ do 53 | hAsync <- async $ task $ runTestProcess $ sleep $ seconds 60 54 | sleep $ milliSeconds 100 55 | 56 | send testPid "running" 57 | 58 | AsyncPending <- poll hAsync 59 | cancelWait hAsync >>= send testPid 60 | 61 | "running" <- expect 62 | d <- expectTimeout (asTimeout $ seconds 5) 63 | case d of 64 | Nothing -> kill p "timed out" >> stash result Nothing 65 | Just ar -> stash result (Just ar) 66 | 67 | testAsyncWaitTimeout :: TestResult (Maybe (AsyncResult ())) -> Process () 68 | testAsyncWaitTimeout result = 69 | let delay = seconds 1 70 | in do 71 | hAsync <- async $ task $ sleep $ seconds 20 72 | waitTimeout delay hAsync >>= stash result 73 | cancelWait hAsync >> return () 74 | 75 | testAsyncLinked :: TestResult Bool -> Process () 76 | testAsyncLinked result = do 77 | mv :: MVar (AsyncChan ()) <- liftIO $ newEmptyMVar 78 | pid <- spawnLocal $ do 79 | -- NB: async == asyncLinked for AsyncChan 80 | h <- async $ task $ do 81 | "waiting" <- expect 82 | return () 83 | stash mv h 84 | "sleeping" <- expect 85 | return () 86 | 87 | hAsync <- liftIO $ takeMVar mv 88 | 89 | mref <- monitor $ worker hAsync 90 | exit pid "stop" 91 | 92 | ProcessMonitorNotification mref' _ _ <- expect 93 | 94 | -- since the initial caller died and we used 'asyncLinked', the async should 95 | -- pick up on the exit signal and set the result accordingly, however the 96 | -- ReceivePort is no longer valid, so we can't wait on it! We have to ensure 97 | -- that the worker is really dead then.... 98 | stash result $ mref == mref' 99 | 100 | testAsyncWaitAny :: TestResult [AsyncResult String] -> Process () 101 | testAsyncWaitAny result = do 102 | p1 <- async $ task $ expect >>= return 103 | p2 <- async $ task $ expect >>= return 104 | p3 <- async $ task $ expect >>= return 105 | send (worker p3) "c" 106 | r1 <- waitAny [p1, p2, p3] 107 | send (worker p1) "a" 108 | r2 <- waitAny [p1, p2, p3] 109 | send (worker p2) "b" 110 | r3 <- waitAny [p1, p2, p3] 111 | stash result $ [r1, r2, r3] 112 | 113 | testAsyncWaitAnyTimeout :: TestResult (Maybe (AsyncResult String)) -> Process () 114 | testAsyncWaitAnyTimeout result = do 115 | p1 <- asyncLinked $ task $ expect >>= return 116 | p2 <- asyncLinked $ task $ expect >>= return 117 | p3 <- asyncLinked $ task $ expect >>= return 118 | waitAnyTimeout (seconds 1) [p1, p2, p3] >>= stash result 119 | 120 | testAsyncCancelWith :: TestResult Bool -> Process () 121 | testAsyncCancelWith result = do 122 | p1 <- async $ task $ do { s :: String <- expect; return s } 123 | cancelWith "foo" p1 124 | AsyncFailed (DiedException _) <- wait p1 125 | stash result True 126 | 127 | tests :: LocalNode -> [Test] 128 | tests localNode = [ 129 | testGroup "Handling async results" [ 130 | testCase "testAsyncCancel" 131 | (delayedAssertion 132 | "expected async task to have been cancelled" 133 | localNode (AsyncCancelled) testAsyncCancel) 134 | , testCase "testAsyncPoll" 135 | (delayedAssertion 136 | "expected poll to return a valid AsyncResult" 137 | localNode (AsyncDone ()) testAsyncPoll) 138 | , testCase "testAsyncCancelWait" 139 | (delayedAssertion 140 | "expected cancelWait to complete some time" 141 | localNode (Just AsyncCancelled) testAsyncCancelWait) 142 | , testCase "testAsyncWaitTimeout" 143 | (delayedAssertion 144 | "expected waitTimeout to return Nothing when it times out" 145 | localNode (Nothing) testAsyncWaitTimeout) 146 | , testCase "testAsyncLinked" 147 | (delayedAssertion 148 | "expected linked process to die with originator" 149 | localNode True testAsyncLinked) 150 | , testCase "testAsyncWaitAny" 151 | (delayedAssertion 152 | "expected waitAny to mimic mergePortsBiased" 153 | localNode [AsyncDone "c", 154 | AsyncDone "a", 155 | AsyncDone "b"] testAsyncWaitAny) 156 | , testCase "testAsyncWaitAnyTimeout" 157 | (delayedAssertion 158 | "expected waitAnyTimeout to handle idle channels properly" 159 | localNode Nothing testAsyncWaitAnyTimeout) 160 | , testCase "testAsyncCancelWith" 161 | (delayedAssertion 162 | "expected the worker to have been killed with the given signal" 163 | localNode True testAsyncCancelWith) 164 | ] 165 | ] 166 | 167 | asyncChanTests :: NT.Transport -> IO [Test] 168 | asyncChanTests transport = do 169 | localNode <- newLocalNode transport initRemoteTable 170 | let testData = tests localNode 171 | return testData 172 | -------------------------------------------------------------------------------- /tests/TestAsyncSTM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module TestAsyncSTM where 6 | 7 | import Control.Applicative 8 | import Control.Concurrent.MVar 9 | import Control.Distributed.Process 10 | import Control.Distributed.Process.Closure 11 | import Control.Distributed.Process.Node 12 | import Control.Distributed.Process.Serializable() 13 | import Control.Distributed.Process.Platform.Async (task,remoteTask) 14 | import Control.Distributed.Process.Platform.Async.AsyncSTM 15 | import Control.Distributed.Process.Platform.Test 16 | import Control.Distributed.Process.Platform.Time 17 | import Control.Distributed.Process.Platform.Timer 18 | 19 | import Data.Binary() 20 | import Data.Typeable() 21 | import qualified Network.Transport as NT (Transport) 22 | 23 | #if ! MIN_VERSION_base(4,6,0) 24 | import Prelude hiding (catch) 25 | #endif 26 | 27 | import Test.Framework (Test, testGroup) 28 | import Test.Framework.Providers.HUnit (testCase) 29 | import TestUtils 30 | 31 | testAsyncPoll :: TestResult (AsyncResult ()) -> Process () 32 | testAsyncPoll result = do 33 | hAsync <- async $ task $ do "go" <- expect; say "running" >> return () 34 | ar <- poll hAsync 35 | case ar of 36 | AsyncPending -> 37 | send (_asyncWorker hAsync) "go" >> wait hAsync >>= stash result 38 | _ -> stash result ar >> return () 39 | 40 | testAsyncCancel :: TestResult (AsyncResult ()) -> Process () 41 | testAsyncCancel result = do 42 | hAsync <- async $ task $ runTestProcess $ say "running" >> return () 43 | sleep $ milliSeconds 100 44 | 45 | p <- poll hAsync -- nasty kind of assertion: use assertEquals? 46 | case p of 47 | AsyncPending -> cancel hAsync >> wait hAsync >>= stash result 48 | _ -> say (show p) >> stash result p 49 | 50 | testAsyncCancelWait :: TestResult (Maybe (AsyncResult ())) -> Process () 51 | testAsyncCancelWait result = do 52 | testPid <- getSelfPid 53 | p <- spawnLocal $ do 54 | hAsync <- async $ task $ runTestProcess $ sleep $ seconds 60 55 | sleep $ milliSeconds 100 56 | 57 | send testPid "running" 58 | 59 | AsyncPending <- poll hAsync 60 | cancelWait hAsync >>= send testPid 61 | 62 | "running" <- expect 63 | d <- expectTimeout (asTimeout $ seconds 5) 64 | case d of 65 | Nothing -> kill p "timed out" >> stash result Nothing 66 | Just ar -> stash result (Just ar) 67 | 68 | testAsyncWaitTimeout :: TestResult (Maybe (AsyncResult ())) -> Process () 69 | testAsyncWaitTimeout result = 70 | let delay = seconds 1 71 | in do 72 | hAsync <- async $ task $ sleep $ seconds 20 73 | waitTimeout delay hAsync >>= stash result 74 | cancelWait hAsync >> return () 75 | 76 | testAsyncWaitTimeoutCompletes :: TestResult (Maybe (AsyncResult ())) 77 | -> Process () 78 | testAsyncWaitTimeoutCompletes result = 79 | let delay = seconds 1 80 | in do 81 | hAsync <- async $ task $ sleep $ seconds 20 82 | waitTimeout delay hAsync >>= stash result 83 | cancelWait hAsync >> return () 84 | 85 | testAsyncWaitTimeoutSTM :: TestResult (Maybe (AsyncResult ())) -> Process () 86 | testAsyncWaitTimeoutSTM result = 87 | let delay = seconds 1 88 | in do 89 | hAsync <- async $ task $ sleep $ seconds 20 90 | waitTimeoutSTM delay hAsync >>= stash result 91 | 92 | testAsyncWaitTimeoutCompletesSTM :: TestResult (Maybe (AsyncResult Int)) 93 | -> Process () 94 | testAsyncWaitTimeoutCompletesSTM result = 95 | let delay = seconds 1 in do 96 | 97 | hAsync <- async $ task $ do 98 | i <- expect 99 | return i 100 | 101 | r <- waitTimeoutSTM delay hAsync 102 | case r of 103 | Nothing -> send (_asyncWorker hAsync) (10 :: Int) 104 | >> wait hAsync >>= stash result . Just 105 | Just _ -> cancelWait hAsync >> stash result Nothing 106 | 107 | testAsyncLinked :: TestResult Bool -> Process () 108 | testAsyncLinked result = do 109 | mv :: MVar (AsyncSTM ()) <- liftIO $ newEmptyMVar 110 | pid <- spawnLocal $ do 111 | -- NB: async == asyncLinked for AsyncChan 112 | h <- asyncLinked $ task $ do 113 | "waiting" <- expect 114 | return () 115 | stash mv h 116 | "sleeping" <- expect 117 | return () 118 | 119 | hAsync <- liftIO $ takeMVar mv 120 | 121 | mref <- monitor $ _asyncWorker hAsync 122 | exit pid "stop" 123 | 124 | _ <- receiveTimeout (after 5 Seconds) [ 125 | matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref') 126 | (\_ -> return ()) 127 | ] 128 | 129 | -- since the initial caller died and we used 'asyncLinked', the async should 130 | -- pick up on the exit signal and set the result accordingly. trying to match 131 | -- on 'DiedException String' is pointless though, as the *string* is highly 132 | -- context dependent. 133 | r <- waitTimeoutSTM (within 3 Seconds) hAsync 134 | case r of 135 | Nothing -> stash result True 136 | Just _ -> stash result False 137 | 138 | testAsyncWaitAny :: TestResult [AsyncResult String] -> Process () 139 | testAsyncWaitAny result = do 140 | p1 <- async $ task $ expect >>= return 141 | p2 <- async $ task $ expect >>= return 142 | p3 <- async $ task $ expect >>= return 143 | send (_asyncWorker p3) "c" 144 | r1 <- waitAny [p1, p2, p3] 145 | 146 | send (_asyncWorker p1) "a" 147 | send (_asyncWorker p2) "b" 148 | sleep $ seconds 1 149 | 150 | r2 <- waitAny [p2, p3] 151 | r3 <- waitAny [p1, p2, p3] 152 | 153 | stash result $ map snd [r1, r2, r3] 154 | 155 | testAsyncWaitAnyTimeout :: TestResult (Maybe (AsyncResult String)) -> Process () 156 | testAsyncWaitAnyTimeout result = do 157 | p1 <- asyncLinked $ task $ expect >>= return 158 | p2 <- asyncLinked $ task $ expect >>= return 159 | p3 <- asyncLinked $ task $ expect >>= return 160 | waitAnyTimeout (seconds 1) [p1, p2, p3] >>= stash result 161 | 162 | testAsyncCancelWith :: TestResult Bool -> Process () 163 | testAsyncCancelWith result = do 164 | p1 <- async $ task $ do { s :: String <- expect; return s } 165 | cancelWith "foo" p1 166 | AsyncFailed (DiedException _) <- wait p1 167 | stash result True 168 | 169 | remotableDecl [ 170 | [d| fib :: (NodeId,Int) -> Process Integer ; 171 | fib (_,0) = return 0 172 | fib (_,1) = return 1 173 | fib (myNode,n) = do 174 | let tsk = remoteTask ($(functionTDict 'fib)) myNode ($(mkClosure 'fib) (myNode,n-2)) 175 | future <- async tsk 176 | y <- fib (myNode,n-1) 177 | (AsyncDone z) <- wait future 178 | return $ y + z 179 | |] 180 | ] 181 | testAsyncRecursive :: TestResult Integer -> Process () 182 | testAsyncRecursive result = do 183 | myNode <- processNodeId <$> getSelfPid 184 | fib (myNode,6) >>= stash result 185 | 186 | tests :: LocalNode -> [Test] 187 | tests localNode = [ 188 | testGroup "Handling async results with STM" [ 189 | testCase "testAsyncCancel" 190 | (delayedAssertion 191 | "expected async task to have been cancelled" 192 | localNode (AsyncCancelled) testAsyncCancel) 193 | , testCase "testAsyncPoll" 194 | (delayedAssertion 195 | "expected poll to return a valid AsyncResult" 196 | localNode (AsyncDone ()) testAsyncPoll) 197 | , testCase "testAsyncCancelWait" 198 | (delayedAssertion 199 | "expected cancelWait to complete some time" 200 | localNode (Just AsyncCancelled) testAsyncCancelWait) 201 | , testCase "testAsyncWaitTimeout" 202 | (delayedAssertion 203 | "expected waitTimeout to return Nothing when it times out" 204 | localNode (Nothing) testAsyncWaitTimeout) 205 | , testCase "testAsyncWaitTimeoutSTM" 206 | (delayedAssertion 207 | "expected waitTimeoutSTM to return Nothing when it times out" 208 | localNode (Nothing) testAsyncWaitTimeoutSTM) 209 | , testCase "testAsyncWaitTimeoutCompletes" 210 | (delayedAssertion 211 | "expected waitTimeout to return a value" 212 | localNode Nothing testAsyncWaitTimeoutCompletes) 213 | , testCase "testAsyncWaitTimeoutCompletesSTM" 214 | (delayedAssertion 215 | "expected waitTimeout to return a value" 216 | localNode (Just (AsyncDone 10)) testAsyncWaitTimeoutCompletesSTM) 217 | , testCase "testAsyncLinked" 218 | (delayedAssertion 219 | "expected linked process to die with originator" 220 | localNode True testAsyncLinked) 221 | , testCase "testAsyncWaitAny" 222 | (delayedAssertion 223 | "expected waitAny to pick the first result each time" 224 | localNode [AsyncDone "c", 225 | AsyncDone "b", 226 | AsyncDone "a"] testAsyncWaitAny) 227 | , testCase "testAsyncWaitAnyTimeout" 228 | (delayedAssertion 229 | "expected waitAnyTimeout to handle pending results properly" 230 | localNode Nothing testAsyncWaitAnyTimeout) 231 | , testCase "testAsyncCancelWith" 232 | (delayedAssertion 233 | "expected the worker to have been killed with the given signal" 234 | localNode True testAsyncCancelWith) 235 | , testCase "testAsyncRecursive" 236 | (delayedAssertion 237 | "expected Fibonacci 6 to be evaluated, and value of 8 returned" 238 | localNode 8 testAsyncRecursive) 239 | ] 240 | ] 241 | 242 | asyncStmTests :: NT.Transport -> IO [Test] 243 | asyncStmTests transport = do 244 | localNode <- newLocalNode transport $ __remoteTableDecl initRemoteTable 245 | let testData = tests localNode 246 | return testData 247 | -------------------------------------------------------------------------------- /tests/TestExchange.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | 6 | module Main where 7 | 8 | import Control.Distributed.Process 9 | import Control.Distributed.Process.Node 10 | import Control.Distributed.Process.Platform 11 | ( Resolvable(..) 12 | , Channel 13 | , spawnSignalled 14 | ) 15 | import qualified Control.Distributed.Process.Platform (__remoteTable) 16 | import Control.Distributed.Process.Platform.Execution.EventManager hiding (start) 17 | import Control.Distributed.Process.Platform.Execution.Exchange 18 | import qualified Control.Distributed.Process.Platform.Execution.EventManager as EventManager 19 | ( start 20 | ) 21 | import Control.Distributed.Process.Platform.Test 22 | import Control.Monad (void, forM, forever) 23 | import Control.Rematch (equalTo) 24 | 25 | #if ! MIN_VERSION_base(4,6,0) 26 | import Prelude hiding (catch, drop) 27 | #else 28 | import Prelude hiding (drop) 29 | #endif 30 | import qualified Network.Transport as NT 31 | import Test.Framework as TF (testGroup, Test) 32 | import Test.Framework.Providers.HUnit 33 | import TestUtils 34 | 35 | testKeyBasedRouting :: TestResult Bool -> Process () 36 | testKeyBasedRouting result = do 37 | (sp, rp) <- newChan :: Process (Channel Int) 38 | rex <- messageKeyRouter PayloadOnly 39 | 40 | -- Since the /router/ doesn't offer a syncrhonous start 41 | -- option, we use spawnSignalled to get the same effect, 42 | -- making it more likely (though it's not guaranteed) that 43 | -- the spawned process will be bound to the routing exchange 44 | -- prior to our evaluating 'routeMessage' below. 45 | void $ spawnSignalled (bindKey "foobar" rex) $ const $ do 46 | receiveWait [ match (\(s :: Int) -> sendChan sp s) ] 47 | 48 | routeMessage rex (createMessage "foobar" [] (123 :: Int)) 49 | stash result . (== (123 :: Int)) =<< receiveChan rp 50 | 51 | testMultipleRoutes :: TestResult () -> Process () 52 | testMultipleRoutes result = do 53 | stash result () -- we don't rely on the test result for assertions... 54 | (sp, rp) <- newChan 55 | rex <- messageKeyRouter PayloadOnly 56 | let recv = receiveWait [ 57 | match (\(s :: String) -> getSelfPid >>= \us -> sendChan sp (us, Left s)) 58 | , match (\(i :: Int) -> getSelfPid >>= \us -> sendChan sp (us, Right i)) 59 | ] 60 | 61 | us <- getSelfPid 62 | p1 <- spawnSignalled (link us >> bindKey "abc" rex) (const $ forever recv) 63 | p2 <- spawnSignalled (link us >> bindKey "def" rex) (const $ forever recv) 64 | p3 <- spawnSignalled (link us >> bindKey "abc" rex) (const $ forever recv) 65 | 66 | -- publish 2 messages with the routing-key set to 'abc' 67 | routeMessage rex (createMessage "abc" [] "Hello") 68 | routeMessage rex (createMessage "abc" [] (123 :: Int)) 69 | 70 | -- route another message with the 'abc' value a header (should be ignored) 71 | routeMessage rex (createMessage "" [("abc", "abc")] "Goodbye") 72 | 73 | received <- forM (replicate (2 * 3) us) (const $ receiveChanTimeout 1000 rp) 74 | 75 | -- all bindings for 'abc' fired correctly 76 | received `shouldContain` Just (p1, Left "Hello") 77 | received `shouldContain` Just (p3, Left "Hello") 78 | received `shouldContain` Just (p1, Right (123 :: Int)) 79 | received `shouldContain` Just (p3, Right (123 :: Int)) 80 | 81 | -- however the bindings for 'def' never fired 82 | received `shouldContain` Nothing 83 | received `shouldNotContain` Just (p2, Left "Hello") 84 | received `shouldNotContain` Just (p2, Right (123 :: Int)) 85 | 86 | -- none of the bindings should have examined the headers! 87 | received `shouldNotContain` Just (p1, Left "Goodbye") 88 | received `shouldNotContain` Just (p2, Left "Goodbye") 89 | received `shouldNotContain` Just (p3, Left "Goodbye") 90 | 91 | testHeaderBasedRouting :: TestResult () -> Process () 92 | testHeaderBasedRouting result = do 93 | stash result () -- we don't rely on the test result for assertions... 94 | (sp, rp) <- newChan 95 | rex <- headerContentRouter PayloadOnly "x-name" 96 | let recv = const $ forever $ receiveWait [ 97 | match (\(s :: String) -> getSelfPid >>= \us -> sendChan sp (us, Left s)) 98 | , match (\(i :: Int) -> getSelfPid >>= \us -> sendChan sp (us, Right i)) 99 | ] 100 | 101 | us <- getSelfPid 102 | p1 <- spawnSignalled (link us >> bindHeader "x-name" "yellow" rex) recv 103 | p2 <- spawnSignalled (link us >> bindHeader "x-name" "red" rex) recv 104 | _ <- spawnSignalled (link us >> bindHeader "x-type" "fast" rex) recv 105 | 106 | -- publish 2 messages with the routing-key set to 'abc' 107 | routeMessage rex (createMessage "" [("x-name", "yellow")] "Hello") 108 | routeMessage rex (createMessage "" [("x-name", "yellow")] (123 :: Int)) 109 | routeMessage rex (createMessage "" [("x-name", "red")] (456 :: Int)) 110 | routeMessage rex (createMessage "" [("x-name", "red")] (789 :: Int)) 111 | routeMessage rex (createMessage "" [("x-type", "fast")] "Goodbye") 112 | 113 | -- route another message with the 'abc' value a header (should be ignored) 114 | routeMessage rex (createMessage "" [("abc", "abc")] "FooBar") 115 | 116 | received <- forM (replicate 5 us) (const $ receiveChanTimeout 1000 rp) 117 | 118 | -- all bindings fired correctly 119 | received `shouldContain` Just (p1, Left "Hello") 120 | received `shouldContain` Just (p1, Right (123 :: Int)) 121 | received `shouldContain` Just (p2, Right (456 :: Int)) 122 | received `shouldContain` Just (p2, Right (789 :: Int)) 123 | received `shouldContain` Nothing 124 | 125 | -- simple check that no other bindings have fired 126 | length received `shouldBe` equalTo (5 :: Int) 127 | 128 | testSimpleEventHandling :: TestResult Bool -> Process () 129 | testSimpleEventHandling result = do 130 | (sp, rp) <- newChan 131 | (sigStart, recvStart) <- newChan 132 | em <- EventManager.start 133 | Just pid <- resolve em 134 | void $ monitor pid 135 | 136 | -- Note that in our init (state) function, we write a "start signal" 137 | -- here; Without a start signal, the message sent to the event manager 138 | -- (via notify) would race with the addHandler registration. 139 | pid' <- addHandler em (myHandler sp) (sendChan sigStart ()) 140 | link pid' 141 | 142 | () <- receiveChan recvStart 143 | 144 | notify em ("hello", "event", "manager") -- cast message 145 | r <- receiveTimeout 100000000 [ 146 | matchChan rp return 147 | , match (\(ProcessMonitorNotification _ _ _) -> die "ServerDied") 148 | ] 149 | case r of 150 | Just ("hello", "event", "manager") -> stash result True 151 | _ -> stash result False 152 | 153 | myHandler :: SendPort (String, String, String) 154 | -> () 155 | -> (String, String, String) 156 | -> Process () 157 | myHandler sp s m@(_, _, _) = sendChan sp m >> return s 158 | 159 | myRemoteTable :: RemoteTable 160 | myRemoteTable = 161 | Control.Distributed.Process.Platform.__remoteTable initRemoteTable 162 | 163 | tests :: NT.Transport -> IO [Test] 164 | tests transport = do 165 | localNode <- newLocalNode transport myRemoteTable 166 | return [ 167 | testGroup "Event Manager" 168 | [ 169 | testCase "Simple Event Handlers" 170 | (delayedAssertion "Expected the handler to run" 171 | localNode True testSimpleEventHandling) 172 | ] 173 | 174 | , testGroup "Router" 175 | [ 176 | testCase "Direct Key Routing" 177 | (delayedAssertion "Expected the sole matching route to run" 178 | localNode True testKeyBasedRouting) 179 | , testCase "Key Based Selective Routing" 180 | (delayedAssertion "Expected only the matching routes to run" 181 | localNode () testMultipleRoutes) 182 | , testCase "Header Based Selective Routing" 183 | (delayedAssertion "Expected only the matching routes to run" 184 | localNode () testHeaderBasedRouting) 185 | ] 186 | ] 187 | 188 | main :: IO () 189 | main = testMain $ tests 190 | 191 | -------------------------------------------------------------------------------- /tests/TestLog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Main where 5 | 6 | -- import Control.Exception (SomeException) 7 | import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar, newEmptyMVar) 8 | import Control.Concurrent.STM (atomically) 9 | import Control.Concurrent.STM.TChan 10 | import Control.Distributed.Process hiding (monitor) 11 | import Control.Distributed.Process.Closure (remotable, mkStaticClosure) 12 | import Control.Distributed.Process.Node 13 | import Control.Distributed.Process.Platform hiding (__remoteTable) 14 | import qualified Control.Distributed.Process.Platform.Service.SystemLog as Log (Logger, error) 15 | import Control.Distributed.Process.Platform.Service.SystemLog hiding (Logger, error) 16 | import Control.Distributed.Process.Platform.Test 17 | import Control.Distributed.Process.Platform.Time 18 | import Control.Distributed.Process.Platform.Timer 19 | import Control.Monad (void) 20 | import Data.List (delete) 21 | 22 | #if ! MIN_VERSION_base(4,6,0) 23 | import Prelude hiding (catch, drop, Read) 24 | #else 25 | import Prelude hiding (drop, read, Read) 26 | #endif 27 | 28 | import Test.Framework as TF (testGroup, Test) 29 | import Test.Framework.Providers.HUnit 30 | import TestUtils 31 | 32 | import GHC.Read 33 | import Text.ParserCombinators.ReadP as P 34 | import Text.ParserCombinators.ReadPrec 35 | 36 | import qualified Network.Transport as NT 37 | 38 | logLevelFormatter :: Message -> Process (Maybe String) 39 | logLevelFormatter m = handleMessage m showLevel 40 | where 41 | showLevel :: LogLevel -> Process String 42 | showLevel = return . show 43 | 44 | $(remotable ['logLevelFormatter]) 45 | 46 | logFormat :: Closure (Message -> Process (Maybe String)) 47 | logFormat = $(mkStaticClosure 'logLevelFormatter) 48 | 49 | testLoggingProcess :: Process (ProcessId, TChan String) 50 | testLoggingProcess = do 51 | chan <- liftIO $ newTChanIO 52 | let cleanup = return () 53 | let format = return 54 | pid <- systemLog (writeLog chan) cleanup Debug format 55 | addFormatter pid logFormat 56 | sleep $ seconds 1 57 | return (pid, chan) 58 | where 59 | writeLog chan = liftIO . atomically . writeTChan chan 60 | 61 | testLogLevels :: (Log.Logger logger, ToLog tL) 62 | => MVar () 63 | -> TChan String 64 | -> logger 65 | -> LogLevel 66 | -> LogLevel 67 | -> (LogLevel -> tL) 68 | -> TestResult Bool 69 | -> Process () 70 | testLogLevels lck chan logger from to fn result = do 71 | void $ liftIO $ takeMVar lck 72 | let lvls = enumFromTo from to 73 | logIt logger fn lvls 74 | testHarness lvls chan result 75 | liftIO $ putMVar lck () 76 | where 77 | logIt _ _ [] = return () 78 | logIt lc f (l:ls) = sendLog lc (f l) l >> logIt lc f ls 79 | 80 | testHarness :: [LogLevel] 81 | -> TChan String 82 | -> TestResult Bool 83 | -> Process () 84 | testHarness [] chan result = do 85 | liftIO (atomically (isEmptyTChan chan)) >>= stash result 86 | testHarness levels chan result = do 87 | msg <- liftIO $ atomically $ readTChan chan 88 | -- liftIO $ putStrLn $ "testHarness handling " ++ msg 89 | let item = readEither msg 90 | case item of 91 | Right i -> testHarness (delete i levels) chan result 92 | Left _ -> testHarness levels chan result 93 | where 94 | readEither :: String -> Either String LogLevel 95 | readEither s = 96 | case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of 97 | [x] -> Right x 98 | _ -> Left "read: ambiguous parse" 99 | 100 | read' = 101 | do x <- readPrec 102 | lift P.skipSpaces 103 | return x 104 | 105 | tests :: NT.Transport -> IO [Test] 106 | tests transport = do 107 | let ch = logChannel 108 | localNode <- newLocalNode transport $ __remoteTable initRemoteTable 109 | lock <- newMVar () 110 | ex <- newEmptyMVar 111 | void $ forkProcess localNode $ do (_, chan) <- testLoggingProcess 112 | liftIO $ putMVar ex chan 113 | chan <- takeMVar ex 114 | return [ 115 | testGroup "Log Reports / LogText" 116 | (map (mkTestCase lock chan ch simpleShowToLog localNode) (enumFromTo Debug Emergency)) 117 | , testGroup "Logging Raw Messages" 118 | (map (mkTestCase lock chan ch messageToLog localNode) (enumFromTo Debug Emergency)) 119 | , testGroup "Custom Formatters" 120 | (map (mkTestCase lock chan ch messageRaw localNode) (enumFromTo Debug Emergency)) 121 | ] 122 | where 123 | mkTestCase lck chan ch' rdr ln lvl = do 124 | let l = show lvl 125 | testCase l (delayedAssertion ("Expected up to " ++ l) 126 | ln True $ testLogLevels lck chan ch' Debug lvl rdr) 127 | 128 | simpleShowToLog = (LogText . show) 129 | messageToLog = unsafeWrapMessage . show 130 | messageRaw = unsafeWrapMessage 131 | 132 | main :: IO () 133 | main = testMain $ tests 134 | 135 | -------------------------------------------------------------------------------- /tests/TestPrimitives.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Main where 5 | 6 | import Control.Concurrent (threadDelay) 7 | import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) 8 | import Control.Distributed.Process 9 | import Control.Distributed.Process.Node 10 | import Control.Distributed.Process.Serializable() 11 | 12 | import Control.Distributed.Process.Platform hiding (__remoteTable, monitor, send) 13 | import qualified Control.Distributed.Process.Platform (__remoteTable) 14 | import Control.Distributed.Process.Platform.Call 15 | import Control.Distributed.Process.Platform.Service.Monitoring 16 | import Control.Distributed.Process.Platform.Time 17 | import Control.Monad (void) 18 | import Control.Rematch hiding (match) 19 | import qualified Network.Transport as NT (Transport) 20 | import Network.Transport.TCP() 21 | #if ! MIN_VERSION_base(4,6,0) 22 | import Prelude hiding (catch) 23 | #endif 24 | 25 | import Test.HUnit (Assertion) 26 | import Test.Framework (Test, testGroup) 27 | import Test.Framework.Providers.HUnit (testCase) 28 | 29 | import Control.Distributed.Process.Platform.Test 30 | import TestUtils 31 | 32 | testLinkingWithNormalExits :: TestResult DiedReason -> Process () 33 | testLinkingWithNormalExits result = do 34 | testPid <- getSelfPid 35 | pid <- spawnLocal $ do 36 | worker <- spawnLocal $ do 37 | "finish" <- expect 38 | return () 39 | linkOnFailure worker 40 | send testPid worker 41 | () <- expect 42 | return () 43 | 44 | workerPid <- expect :: Process ProcessId 45 | ref <- monitor workerPid 46 | 47 | send workerPid "finish" 48 | receiveWait [ 49 | matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref') 50 | (\_ -> return ()) 51 | ] 52 | 53 | -- by now, the worker is gone, so we can check that the 54 | -- insulator is still alive and well and that it exits normally 55 | -- when asked to do so 56 | ref2 <- monitor pid 57 | send pid () 58 | 59 | r <- receiveWait [ 60 | matchIf (\(ProcessMonitorNotification ref2' _ _) -> ref2 == ref2') 61 | (\(ProcessMonitorNotification _ _ reason) -> return reason) 62 | ] 63 | stash result r 64 | 65 | testLinkingWithAbnormalExits :: TestResult (Maybe Bool) -> Process () 66 | testLinkingWithAbnormalExits result = do 67 | testPid <- getSelfPid 68 | pid <- spawnLocal $ do 69 | worker <- spawnLocal $ do 70 | "finish" <- expect 71 | return () 72 | 73 | linkOnFailure worker 74 | send testPid worker 75 | () <- expect 76 | return () 77 | 78 | workerPid <- expect :: Process ProcessId 79 | 80 | ref <- monitor pid 81 | kill workerPid "finish" -- note the use of 'kill' instead of send 82 | r <- receiveTimeout (asTimeout $ seconds 20) [ 83 | matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref') 84 | (\(ProcessMonitorNotification _ _ reason) -> return reason) 85 | ] 86 | case r of 87 | Just (DiedException _) -> stash result $ Just True 88 | (Just _) -> stash result $ Just False 89 | Nothing -> stash result Nothing 90 | 91 | testMonitorNodeDeath :: NT.Transport -> TestResult () -> Process () 92 | testMonitorNodeDeath transport result = do 93 | void $ nodeMonitor >> monitorNodes -- start node monitoring 94 | 95 | nid1 <- getSelfNode 96 | nid2 <- liftIO $ newEmptyMVar 97 | nid3 <- liftIO $ newEmptyMVar 98 | 99 | node2 <- liftIO $ newLocalNode transport initRemoteTable 100 | node3 <- liftIO $ newLocalNode transport initRemoteTable 101 | 102 | -- sending to (nodeId, "ignored") is a short cut to force a connection 103 | liftIO $ tryForkProcess node2 $ ensureNodeRunning nid2 (nid1, "ignored") 104 | liftIO $ tryForkProcess node3 $ ensureNodeRunning nid3 (nid1, "ignored") 105 | 106 | NodeUp _ <- expect 107 | NodeUp _ <- expect 108 | 109 | void $ liftIO $ closeLocalNode node2 110 | void $ liftIO $ closeLocalNode node3 111 | 112 | NodeDown n1 <- expect 113 | NodeDown n2 <- expect 114 | 115 | mn1 <- liftIO $ takeMVar nid2 116 | mn2 <- liftIO $ takeMVar nid3 117 | 118 | [mn1, mn2] `shouldContain` n1 119 | [mn1, mn2] `shouldContain` n2 120 | 121 | nid4 <- liftIO $ newEmptyMVar 122 | node4 <- liftIO $ newLocalNode transport initRemoteTable 123 | void $ liftIO $ runProcess node4 $ do 124 | us <- getSelfNode 125 | liftIO $ putMVar nid4 us 126 | monitorNode nid1 >> return () 127 | 128 | mn3 <- liftIO $ takeMVar nid4 129 | NodeUp n3 <- expect 130 | mn3 `shouldBe` (equalTo n3) 131 | 132 | liftIO $ closeLocalNode node4 133 | stash result () 134 | 135 | where 136 | ensureNodeRunning mvar nid = do 137 | us <- getSelfNode 138 | liftIO $ putMVar mvar us 139 | sendTo nid "connected" 140 | 141 | myRemoteTable :: RemoteTable 142 | myRemoteTable = Control.Distributed.Process.Platform.__remoteTable initRemoteTable 143 | 144 | multicallTest :: NT.Transport -> Assertion 145 | multicallTest transport = 146 | do node1 <- newLocalNode transport myRemoteTable 147 | tryRunProcess node1 $ 148 | do pid1 <- whereisOrStart "server1" server1 149 | _ <- whereisOrStart "server2" server2 150 | pid2 <- whereisOrStart "server2" server2 151 | tag <- newTagPool 152 | 153 | -- First test: expect positives answers from both processes 154 | tag1 <- getTag tag 155 | result1 <- multicall [pid1,pid2] mystr tag1 infiniteWait 156 | case result1 of 157 | [Just reversed, Just doubled] | 158 | reversed == reverse mystr && doubled == mystr ++ mystr -> return () 159 | _ -> error "Unmatched" 160 | 161 | -- Second test: First process works, second thread throws an exception 162 | tag2 <- getTag tag 163 | [Just 10, Nothing] <- multicall [pid1,pid2] (5::Int) tag2 infiniteWait :: Process [Maybe Int] 164 | 165 | -- Third test: First process exceeds time limit, second process is still dead 166 | tag3 <- getTag tag 167 | [Nothing, Nothing] <- multicall [pid1,pid2] (23::Int) tag3 (Just 1000000) :: Process [Maybe Int] 168 | return () 169 | where server1 = receiveWait [callResponse (\str -> mention (str::String) (return (reverse str,())))] >> 170 | receiveWait [callResponse (\i -> mention (i::Int) (return (i*2,())))] >> 171 | receiveWait [callResponse (\i -> liftIO (threadDelay 2000000) >> mention (i::Int) (return (i*10,())))] 172 | server2 = receiveWait [callResponse (\str -> mention (str::String) (return (str++str,())))] >> 173 | receiveWait [callResponse (\i -> error "barf" >> mention (i::Int) (return (i :: Int,())))] 174 | mystr = "hello" 175 | mention :: a -> b -> b 176 | mention _a b = b 177 | 178 | 179 | 180 | -------------------------------------------------------------------------------- 181 | -- Utilities and Plumbing -- 182 | -------------------------------------------------------------------------------- 183 | 184 | tests :: NT.Transport -> LocalNode -> [Test] 185 | tests transport localNode = [ 186 | testGroup "Linking Tests" [ 187 | testCase "testLinkingWithNormalExits" 188 | (delayedAssertion 189 | "normal exit should not terminate the caller" 190 | localNode DiedNormal testLinkingWithNormalExits) 191 | , testCase "testLinkingWithAbnormalExits" 192 | (delayedAssertion 193 | "abnormal exit should terminate the caller" 194 | localNode (Just True) testLinkingWithAbnormalExits) 195 | ], 196 | testGroup "Call/RPC" [ 197 | testCase "multicallTest" (multicallTest transport) 198 | ], 199 | testGroup "Node Monitoring" [ 200 | testCase "Death Notifications" 201 | (delayedAssertion 202 | "subscribers should both have received NodeDown twice" 203 | localNode () (testMonitorNodeDeath transport)) 204 | ] 205 | ] 206 | 207 | primitivesTests :: NT.Transport -> IO [Test] 208 | primitivesTests transport = do 209 | localNode <- newLocalNode transport initRemoteTable 210 | let testData = tests transport localNode 211 | return testData 212 | 213 | main :: IO () 214 | main = testMain $ primitivesTests 215 | -------------------------------------------------------------------------------- /tests/TestPrioritisedProcess.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | 6 | -- NB: this module contains tests for the GenProcess /and/ GenServer API. 7 | 8 | module Main where 9 | 10 | import Control.Concurrent.MVar 11 | import Control.Exception (SomeException) 12 | import Control.DeepSeq (NFData) 13 | import Control.Distributed.Process hiding (call, send) 14 | import Control.Distributed.Process.Node 15 | import Control.Distributed.Process.Platform hiding (__remoteTable) 16 | import Control.Distributed.Process.Platform.Async 17 | import Control.Distributed.Process.Platform.ManagedProcess 18 | import Control.Distributed.Process.Platform.Test 19 | import Control.Distributed.Process.Platform.Time 20 | import Control.Distributed.Process.Platform.Timer 21 | import Control.Distributed.Process.Serializable() 22 | 23 | import Data.Binary 24 | import Data.Either (rights) 25 | import Data.Typeable (Typeable) 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 | 38 | import GHC.Generics (Generic) 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 | p = s `prioritised` ([] :: [DispatchPriority ()]) 50 | in do 51 | exitReason <- liftIO $ newEmptyMVar 52 | pid <- spawnLocal $ do 53 | catch ((pserve () (statelessInit Infinity) p >> stash exitReason ExitNormal) 54 | `catchesExit` [ 55 | (\_ msg -> do 56 | mEx <- unwrapMessage msg :: Process (Maybe ExitReason) 57 | case mEx of 58 | Nothing -> return Nothing 59 | Just r -> stash exitReason r >>= return . Just 60 | ) 61 | ]) 62 | (\(e :: SomeException) -> stash exitReason $ ExitOther (show e)) 63 | return (pid, exitReason) 64 | 65 | explodingServer :: ProcessId 66 | -> Process (ProcessId, MVar ExitReason) 67 | explodingServer pid = 68 | let srv = explodingTestProcess pid 69 | pSrv = srv `prioritised` ([] :: [DispatchPriority s]) 70 | in do 71 | exitReason <- liftIO $ newEmptyMVar 72 | spid <- spawnLocal $ do 73 | catch (pserve () (statelessInit Infinity) pSrv >> stash exitReason ExitNormal) 74 | (\(e :: SomeException) -> stash exitReason $ ExitOther (show e)) 75 | return (spid, exitReason) 76 | 77 | data GetState = GetState 78 | deriving (Typeable, Generic, Show, Eq) 79 | instance Binary GetState where 80 | instance NFData GetState where 81 | 82 | data MyAlarmSignal = MyAlarmSignal 83 | deriving (Typeable, Generic, Show, Eq) 84 | instance Binary MyAlarmSignal where 85 | instance NFData MyAlarmSignal where 86 | 87 | mkPrioritisedServer :: Process ProcessId 88 | mkPrioritisedServer = 89 | let p = procDef `prioritised` ([ 90 | prioritiseInfo_ (\MyAlarmSignal -> setPriority 10) 91 | , prioritiseCast_ (\(_ :: String) -> setPriority 2) 92 | , prioritiseCall_ (\(cmd :: String) -> (setPriority (length cmd)) :: Priority ()) 93 | ] :: [DispatchPriority [Either MyAlarmSignal String]] 94 | ) :: PrioritisedProcessDefinition [(Either MyAlarmSignal String)] 95 | in spawnLocal $ pserve () (initWait Infinity) p 96 | where 97 | initWait :: Delay 98 | -> InitHandler () [Either MyAlarmSignal String] 99 | initWait d () = do 100 | () <- expect 101 | return $ InitOk [] d 102 | 103 | procDef :: ProcessDefinition [(Either MyAlarmSignal String)] 104 | procDef = 105 | defaultProcess { 106 | apiHandlers = [ 107 | handleCall (\s GetState -> reply (reverse s) s) 108 | , handleCall (\s (cmd :: String) -> reply () ((Right cmd):s)) 109 | , handleCast (\s (cmd :: String) -> continue ((Right cmd):s)) 110 | ] 111 | , infoHandlers = [ 112 | handleInfo (\s (sig :: MyAlarmSignal) -> continue ((Left sig):s)) 113 | ] 114 | , unhandledMessagePolicy = Drop 115 | , timeoutHandler = \_ _ -> stop $ ExitOther "timeout" 116 | } :: ProcessDefinition [(Either MyAlarmSignal String)] 117 | 118 | -- test cases 119 | 120 | testInfoPrioritisation :: TestResult Bool -> Process () 121 | testInfoPrioritisation result = do 122 | pid <- mkPrioritisedServer 123 | -- the server (pid) is configured to wait for () during its init 124 | -- so we can fill up its mailbox with String messages, and verify 125 | -- that the alarm signal (which is prioritised *above* these) 126 | -- actually gets processed first despite the delivery order 127 | cast pid "hello" 128 | cast pid "prioritised" 129 | cast pid "world" 130 | -- note that these have to be a "bare send" 131 | send pid MyAlarmSignal 132 | -- tell the server it can move out of init and start processing messages 133 | send pid () 134 | st <- call pid GetState :: Process [Either MyAlarmSignal String] 135 | -- the result of GetState is a list of messages in reverse insertion order 136 | case head st of 137 | Left MyAlarmSignal -> stash result True 138 | _ -> stash result False 139 | 140 | testCallPrioritisation :: TestResult Bool -> Process () 141 | testCallPrioritisation result = do 142 | pid <- mkPrioritisedServer 143 | asyncRefs <- (mapM (callAsync pid) 144 | ["first", "the longest", "commands", "we do prioritise"]) 145 | :: Process [Async ()] 146 | -- NB: This sleep is really important - the `init' function is waiting 147 | -- (selectively) on the () signal to go, and if it receives this *before* 148 | -- the async worker has had a chance to deliver the longest string message, 149 | -- our test will fail. Such races are /normal/ given that the async worker 150 | -- runs in another process and delivery order between multiple processes 151 | -- is undefined (and in practise, paritally depenendent on the scheduler) 152 | sleep $ seconds 1 153 | send pid () 154 | mapM wait asyncRefs :: Process [AsyncResult ()] 155 | st <- call pid GetState :: Process [Either MyAlarmSignal String] 156 | let ms = rights st 157 | stash result $ ms == ["we do prioritise", "the longest", "commands", "first"] 158 | 159 | tests :: NT.Transport -> IO [Test] 160 | tests transport = do 161 | localNode <- newLocalNode transport initRemoteTable 162 | return [ 163 | testGroup "basic server functionality matches un-prioritised processes" [ 164 | testCase "basic call with explicit server reply" 165 | (delayedAssertion 166 | "expected a response from the server" 167 | localNode (Just "foo") (testBasicCall $ wrap server)) 168 | , testCase "basic call with implicit server reply" 169 | (delayedAssertion 170 | "expected n * 2 back from the server" 171 | localNode (Just 4) (testBasicCall_ $ wrap server)) 172 | , testCase "basic cast with manual send and explicit server continue" 173 | (delayedAssertion 174 | "expected pong back from the server" 175 | localNode (Just "pong") (testBasicCast $ wrap server)) 176 | , testCase "cast and explicit server timeout" 177 | (delayedAssertion 178 | "expected the server to stop after the timeout" 179 | localNode (Just $ ExitOther "timeout") (testControlledTimeout $ wrap server)) 180 | , testCase "unhandled input when policy = Terminate" 181 | (delayedAssertion 182 | "expected the server to stop upon receiving unhandled input" 183 | localNode (Just $ ExitOther "UnhandledInput") 184 | (testTerminatePolicy $ wrap server)) 185 | , testCase "unhandled input when policy = Drop" 186 | (delayedAssertion 187 | "expected the server to ignore unhandled input and exit normally" 188 | localNode Nothing (testDropPolicy $ wrap (mkServer Drop))) 189 | , testCase "unhandled input when policy = DeadLetter" 190 | (delayedAssertion 191 | "expected the server to forward unhandled messages" 192 | localNode (Just ("UNSOLICITED_MAIL", 500 :: Int)) 193 | (testDeadLetterPolicy $ \p -> mkServer (DeadLetter p))) 194 | , testCase "incoming messages are ignored whilst hibernating" 195 | (delayedAssertion 196 | "expected the server to remain in hibernation" 197 | localNode True (testHibernation $ wrap server)) 198 | , testCase "long running call cancellation" 199 | (delayedAssertion "expected to get AsyncCancelled" 200 | localNode True (testKillMidCall $ wrap server)) 201 | , testCase "simple exit handling" 202 | (delayedAssertion "expected handler to catch exception and continue" 203 | localNode Nothing (testSimpleErrorHandling $ explodingServer)) 204 | , testCase "alternative exit handlers" 205 | (delayedAssertion "expected handler to catch exception and continue" 206 | localNode Nothing (testAlternativeErrorHandling $ explodingServer)) 207 | ] 208 | , testGroup "Prioritised Mailbox Handling" [ 209 | testCase "Info Message Prioritisation" 210 | (delayedAssertion "expected the info handler to be prioritised" 211 | localNode True testInfoPrioritisation) 212 | , testCase "Call Message Prioritisation" 213 | (delayedAssertion "expected the longest strings to be prioritised" 214 | localNode True testCallPrioritisation) 215 | ] 216 | ] 217 | 218 | main :: IO () 219 | main = testMain $ tests 220 | 221 | 222 | -------------------------------------------------------------------------------- /tests/TestQueues.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | module Main where 3 | 4 | import qualified Control.Distributed.Process.Platform.Internal.Queue.SeqQ as FIFO 5 | import Control.Distributed.Process.Platform.Internal.Queue.SeqQ ( SeqQ ) 6 | import qualified Control.Distributed.Process.Platform.Internal.Queue.PriorityQ as PQ 7 | 8 | import Control.Rematch hiding (on) 9 | import Control.Rematch.Run 10 | import Data.Function (on) 11 | import Data.List 12 | import Test.Framework as TF (defaultMain, testGroup, Test) 13 | import Test.Framework.Providers.HUnit 14 | import Test.Framework.Providers.QuickCheck2 (testProperty) 15 | import Test.HUnit (Assertion, assertFailure) 16 | 17 | import Prelude 18 | 19 | expectThat :: a -> Matcher a -> Assertion 20 | expectThat a matcher = case res of 21 | MatchSuccess -> return () 22 | (MatchFailure msg) -> assertFailure msg 23 | where res = runMatch matcher a 24 | 25 | -- NB: these tests/properties are not meant to be complete, but rather 26 | -- they exercise the small number of behaviours that we actually use! 27 | 28 | -- TODO: some laziness vs. strictness tests, with error/exception checking 29 | 30 | prop_pq_ordering :: [Int] -> Bool 31 | prop_pq_ordering xs = 32 | let xs' = map (\x -> (x, show x)) xs 33 | q = foldl (\q' x -> PQ.enqueue (fst x) (snd x) q') PQ.empty xs' 34 | ys = drain q [] 35 | zs = [snd x | x <- reverse $ sortBy (compare `on` fst) xs'] 36 | -- the sorted list should match the stuff we drained back out 37 | in zs == ys 38 | where 39 | drain q xs' 40 | | True <- PQ.isEmpty q = xs' 41 | | otherwise = 42 | let Just (x, q') = PQ.dequeue q in drain q' (x:xs') 43 | 44 | prop_fifo_enqueue :: Int -> Int -> Int -> Bool 45 | prop_fifo_enqueue a b c = 46 | let q1 = foldl FIFO.enqueue FIFO.empty [a,b,c] 47 | Just (a', q2) = FIFO.dequeue q1 48 | Just (b', q3) = FIFO.dequeue q2 49 | Just (c', q4) = FIFO.dequeue q3 50 | Nothing = FIFO.dequeue q4 51 | in q4 `seq` [a',b',c'] == [a,b,c] -- why seq here? to shut the compiler up. 52 | 53 | prop_enqueue_empty :: String -> Bool 54 | prop_enqueue_empty s = 55 | let q = FIFO.enqueue FIFO.empty s 56 | Just (_, q') = FIFO.dequeue q 57 | in (FIFO.isEmpty q') == ((FIFO.isEmpty q) == False) 58 | 59 | tests :: [TF.Test] 60 | tests = [ 61 | testGroup "Priority Queue Tests" [ 62 | -- testCase "New Queue Should Be Empty" 63 | -- (expect (PQ.isEmpty $ PQ.empty) $ equalTo True), 64 | -- testCase "Singleton Queue Should Contain One Element" 65 | -- (expect (PQ.dequeue $ (PQ.singleton 1 "hello") :: PriorityQ Int String) $ 66 | -- equalTo $ (Just ("hello", PQ.empty)) :: Maybe (PriorityQ Int String)), 67 | -- testCase "Dequeue Empty Queue Should Be Nothing" 68 | -- (expect (Q.isEmpty $ PQ.dequeue $ 69 | -- (PQ.empty :: PriorityQ Int ())) $ equalTo True), 70 | testProperty "Enqueue/Dequeue should respect Priority order" 71 | prop_pq_ordering 72 | ], 73 | testGroup "FIFO Queue Tests" [ 74 | testCase "New Queue Should Be Empty" 75 | (expectThat (FIFO.isEmpty $ FIFO.empty) $ equalTo True), 76 | testCase "Singleton Queue Should Contain One Element" 77 | (expectThat (FIFO.dequeue $ FIFO.singleton "hello") $ 78 | equalTo $ Just ("hello", FIFO.empty)), 79 | testCase "Dequeue Empty Queue Should Be Nothing" 80 | (expectThat (FIFO.dequeue $ (FIFO.empty :: SeqQ ())) $ 81 | is (Nothing :: Maybe ((), SeqQ ()))), 82 | testProperty "Enqueue/Dequeue should respect FIFO order" 83 | prop_fifo_enqueue, 84 | testProperty "Enqueue/Dequeue should respect isEmpty" 85 | prop_enqueue_empty 86 | ] 87 | ] 88 | 89 | main :: IO () 90 | main = defaultMain tests 91 | 92 | -------------------------------------------------------------------------------- /tests/TestTaskQueues.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Main where 7 | 8 | import Control.Distributed.Process hiding (call) 9 | import Control.Distributed.Process.Closure 10 | import Control.Distributed.Process.Node 11 | import Control.Distributed.Process.Platform hiding (__remoteTable, monitor, 12 | send, nsend, sendChan) 13 | import Control.Distributed.Process.Platform.Async 14 | import Control.Distributed.Process.Platform.ManagedProcess 15 | import Control.Distributed.Process.Platform.Test 16 | import Control.Distributed.Process.Platform.Time 17 | import Control.Distributed.Process.Platform.Timer 18 | import Control.Distributed.Process.Serializable() 19 | 20 | import Control.Distributed.Process.Platform.Task.Queue.BlockingQueue hiding (start) 21 | import qualified Control.Distributed.Process.Platform.Task.Queue.BlockingQueue as Pool (start) 22 | 23 | #if ! MIN_VERSION_base(4,6,0) 24 | import Prelude hiding (catch) 25 | #endif 26 | 27 | import Test.Framework (Test, testGroup) 28 | import Test.Framework.Providers.HUnit (testCase) 29 | import TestUtils 30 | 31 | import qualified Network.Transport as NT 32 | 33 | -- utilities 34 | 35 | sampleTask :: (TimeInterval, String) -> Process String 36 | sampleTask (t, s) = sleep t >> return s 37 | 38 | namedTask :: (String, String) -> Process String 39 | namedTask (name, result) = do 40 | self <- getSelfPid 41 | register name self 42 | () <- expect 43 | return result 44 | 45 | crashingTask :: SendPort ProcessId -> Process String 46 | crashingTask sp = getSelfPid >>= sendChan sp >> die "Boom" 47 | 48 | $(remotable ['sampleTask, 'namedTask, 'crashingTask]) 49 | 50 | -- SimplePool tests 51 | 52 | startPool :: SizeLimit -> Process ProcessId 53 | startPool sz = spawnLocal $ do 54 | Pool.start (pool sz :: Process (InitResult (BlockingQueue String))) 55 | 56 | testSimplePoolJobBlocksCaller :: TestResult (AsyncResult (Either ExitReason String)) 57 | -> Process () 58 | testSimplePoolJobBlocksCaller result = do 59 | pid <- startPool 1 60 | -- we do a non-blocking test first 61 | job <- return $ ($(mkClosure 'sampleTask) (seconds 2, "foobar")) 62 | callAsync pid job >>= wait >>= stash result 63 | 64 | testJobQueueSizeLimiting :: 65 | TestResult (Maybe (AsyncResult (Either ExitReason String)), 66 | Maybe (AsyncResult (Either ExitReason String))) 67 | -> Process () 68 | testJobQueueSizeLimiting result = do 69 | pid <- startPool 1 70 | job1 <- return $ ($(mkClosure 'namedTask) ("job1", "foo")) 71 | job2 <- return $ ($(mkClosure 'namedTask) ("job2", "bar")) 72 | h1 <- callAsync pid job1 :: Process (Async (Either ExitReason String)) 73 | h2 <- callAsync pid job2 :: Process (Async (Either ExitReason String)) 74 | 75 | -- despite the fact that we tell job2 to proceed first, 76 | -- the size limit (of 1) will ensure that only job1 can 77 | -- proceed successfully! 78 | nsend "job2" () 79 | AsyncPending <- poll h2 80 | Nothing <- whereis "job2" 81 | 82 | -- we can get here *very* fast, so give the registration time to kick in 83 | sleep $ milliSeconds 250 84 | j1p <- whereis "job1" 85 | case j1p of 86 | Nothing -> die $ "timing is out - job1 isn't registered yet" 87 | Just p -> send p () 88 | 89 | -- once job1 completes, we *should* be able to proceed with job2 90 | -- but we allow a little time for things to catch up 91 | sleep $ milliSeconds 250 92 | nsend "job2" () 93 | 94 | r2 <- waitTimeout (within 2 Seconds) h2 95 | r1 <- waitTimeout (within 2 Seconds) h1 96 | stash result (r1, r2) 97 | 98 | testExecutionErrors :: TestResult Bool -> Process () 99 | testExecutionErrors result = do 100 | pid <- startPool 1 101 | (sp, rp) <- newChan :: Process (SendPort ProcessId, 102 | ReceivePort ProcessId) 103 | job <- return $ ($(mkClosure 'crashingTask) sp) 104 | res <- executeTask pid job 105 | rpid <- receiveChan rp 106 | -- liftIO $ putStrLn (show res) 107 | stash result (expectedErrorMessage rpid == res) 108 | where 109 | expectedErrorMessage p = 110 | Left $ ExitOther $ "DiedException \"exit-from=" ++ (show p) ++ ",reason=Boom\"" 111 | 112 | myRemoteTable :: RemoteTable 113 | myRemoteTable = Main.__remoteTable initRemoteTable 114 | 115 | tests :: NT.Transport -> IO [Test] 116 | tests transport = do 117 | localNode <- newLocalNode transport myRemoteTable 118 | return [ 119 | testGroup "Task Execution And Prioritisation" [ 120 | testCase "Each execution blocks the submitter" 121 | (delayedAssertion 122 | "expected the server to return the task outcome" 123 | localNode (AsyncDone (Right "foobar")) testSimplePoolJobBlocksCaller) 124 | , testCase "Only 'max' tasks can proceed at any time" 125 | (delayedAssertion 126 | "expected the server to block the second job until the first was released" 127 | localNode 128 | (Just (AsyncDone (Right "foo")), 129 | Just (AsyncDone (Right "bar"))) testJobQueueSizeLimiting) 130 | , testCase "Crashing Tasks are Reported Properly" 131 | (delayedAssertion 132 | "expected the server to report an error" 133 | localNode True testExecutionErrors) 134 | ] 135 | ] 136 | 137 | main :: IO () 138 | main = testMain $ tests 139 | 140 | -------------------------------------------------------------------------------- /tests/TestTimer.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | #if ! MIN_VERSION_base(4,6,0) 4 | import Prelude hiding (catch) 5 | #endif 6 | import Control.Monad (forever) 7 | import Control.Concurrent.MVar 8 | ( newEmptyMVar 9 | , putMVar 10 | , takeMVar 11 | , withMVar 12 | ) 13 | import qualified Network.Transport as NT (Transport) 14 | import Network.Transport.TCP() 15 | import Control.Distributed.Process.Platform.Time 16 | import Control.Distributed.Process 17 | import Control.Distributed.Process.Node 18 | import Control.Distributed.Process.Serializable() 19 | import Control.Distributed.Process.Platform.Timer 20 | 21 | import Test.Framework (Test, testGroup) 22 | import Test.Framework.Providers.HUnit (testCase) 23 | 24 | import Control.Distributed.Process.Platform.Test 25 | import TestUtils 26 | 27 | testSendAfter :: TestResult Bool -> Process () 28 | testSendAfter result = 29 | let delay = seconds 1 in do 30 | sleep $ seconds 10 31 | pid <- getSelfPid 32 | _ <- sendAfter delay pid Ping 33 | hdInbox <- receiveTimeout (asTimeout (seconds 2)) [ 34 | match (\m@(Ping) -> return m) 35 | ] 36 | case hdInbox of 37 | Just Ping -> stash result True 38 | Nothing -> stash result False 39 | 40 | testRunAfter :: TestResult Bool -> Process () 41 | testRunAfter result = 42 | let delay = seconds 2 in do 43 | 44 | parentPid <- getSelfPid 45 | _ <- spawnLocal $ do 46 | _ <- runAfter delay $ send parentPid Ping 47 | return () 48 | 49 | msg <- expectTimeout ((asTimeout delay) * 4) 50 | case msg of 51 | Just Ping -> stash result True 52 | Nothing -> stash result False 53 | return () 54 | 55 | testCancelTimer :: TestResult Bool -> Process () 56 | testCancelTimer result = do 57 | let delay = milliSeconds 50 58 | pid <- periodically delay noop 59 | ref <- monitor pid 60 | 61 | sleep $ seconds 1 62 | cancelTimer pid 63 | 64 | _ <- receiveWait [ 65 | match (\(ProcessMonitorNotification ref' pid' _) -> 66 | stash result $ ref == ref' && pid == pid') 67 | ] 68 | 69 | return () 70 | 71 | testPeriodicSend :: TestResult Bool -> Process () 72 | testPeriodicSend result = do 73 | let delay = milliSeconds 100 74 | self <- getSelfPid 75 | ref <- ticker delay self 76 | listener 0 ref 77 | liftIO $ putMVar result True 78 | where listener :: Int -> TimerRef -> Process () 79 | listener n tRef | n > 10 = cancelTimer tRef 80 | | otherwise = waitOne >> listener (n + 1) tRef 81 | -- get a single tick, blocking indefinitely 82 | waitOne :: Process () 83 | waitOne = do 84 | Tick <- expect 85 | return () 86 | 87 | testTimerReset :: TestResult Int -> Process () 88 | testTimerReset result = do 89 | let delay = seconds 10 90 | counter <- liftIO $ newEmptyMVar 91 | 92 | listenerPid <- spawnLocal $ do 93 | stash counter 0 94 | -- we continually listen for 'ticks' and increment counter for each 95 | forever $ do 96 | Tick <- expect 97 | liftIO $ withMVar counter (\n -> (return (n + 1))) 98 | 99 | -- this ticker will 'fire' every 10 seconds 100 | ref <- ticker delay listenerPid 101 | 102 | sleep $ seconds 2 103 | resetTimer ref 104 | 105 | -- at this point, the timer should be back to roughly a 5 second count down 106 | -- so our few remaining cycles no ticks ought to make it to the listener 107 | -- therefore we kill off the timer and the listener now and take the count 108 | cancelTimer ref 109 | kill listenerPid "stop!" 110 | 111 | -- how many 'ticks' did the listener observer? (hopefully none!) 112 | count <- liftIO $ takeMVar counter 113 | liftIO $ putMVar result count 114 | 115 | testTimerFlush :: TestResult Bool -> Process () 116 | testTimerFlush result = do 117 | let delay = seconds 1 118 | self <- getSelfPid 119 | ref <- ticker delay self 120 | 121 | -- sleep so we *should* have a message in our 'mailbox' 122 | sleep $ milliSeconds 2 123 | 124 | -- flush it out if it's there 125 | flushTimer ref Tick (Delay $ seconds 3) 126 | 127 | m <- expectTimeout 10 128 | case m of 129 | Nothing -> stash result True 130 | Just Tick -> stash result False 131 | 132 | testSleep :: TestResult Bool -> Process () 133 | testSleep r = do 134 | sleep $ seconds 20 135 | stash r True 136 | 137 | -------------------------------------------------------------------------------- 138 | -- Utilities and Plumbing -- 139 | -------------------------------------------------------------------------------- 140 | 141 | tests :: LocalNode -> [Test] 142 | tests localNode = [ 143 | testGroup "Timer Tests" [ 144 | testCase "testSendAfter" 145 | (delayedAssertion 146 | "expected Ping within 1 second" 147 | localNode True testSendAfter) 148 | , testCase "testRunAfter" 149 | (delayedAssertion 150 | "expecting run (which pings parent) within 2 seconds" 151 | localNode True testRunAfter) 152 | , testCase "testCancelTimer" 153 | (delayedAssertion 154 | "expected cancelTimer to exit the timer process normally" 155 | localNode True testCancelTimer) 156 | , testCase "testPeriodicSend" 157 | (delayedAssertion 158 | "expected ten Ticks to have been sent before exiting" 159 | localNode True testPeriodicSend) 160 | , testCase "testTimerReset" 161 | (delayedAssertion 162 | "expected no Ticks to have been sent before resetting" 163 | localNode 0 testTimerReset) 164 | , testCase "testTimerFlush" 165 | (delayedAssertion 166 | "expected all Ticks to have been flushed" 167 | localNode True testTimerFlush) 168 | , testCase "testSleep" 169 | (delayedAssertion 170 | "why am I not seeing a delay!?" 171 | localNode True testTimerFlush) 172 | ] 173 | ] 174 | 175 | timerTests :: NT.Transport -> IO [Test] 176 | timerTests transport = do 177 | localNode <- newLocalNode transport initRemoteTable 178 | let testData = tests localNode 179 | return testData 180 | 181 | main :: IO () 182 | main = testMain $ timerTests 183 | -------------------------------------------------------------------------------- /tests/TestUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module TestUtils 5 | ( TestResult 6 | -- ping ! 7 | , Ping(Ping) 8 | , ping 9 | , shouldBe 10 | , shouldMatch 11 | , shouldContain 12 | , shouldNotContain 13 | , shouldExitWith 14 | , expectThat 15 | -- test process utilities 16 | , TestProcessControl 17 | , startTestProcess 18 | , runTestProcess 19 | , testProcessGo 20 | , testProcessStop 21 | , testProcessReport 22 | , delayedAssertion 23 | , assertComplete 24 | , waitForExit 25 | -- logging 26 | , Logger() 27 | , newLogger 28 | , putLogMsg 29 | , stopLogger 30 | -- runners 31 | , mkNode 32 | , tryRunProcess 33 | , testMain 34 | ) where 35 | 36 | #if ! MIN_VERSION_base(4,6,0) 37 | import Prelude hiding (catch) 38 | #endif 39 | import Control.Concurrent 40 | ( ThreadId 41 | , myThreadId 42 | , forkIO 43 | ) 44 | import Control.Concurrent.STM 45 | ( TQueue 46 | , newTQueueIO 47 | , readTQueue 48 | , writeTQueue 49 | ) 50 | import Control.Concurrent.MVar 51 | ( MVar 52 | , newEmptyMVar 53 | , takeMVar 54 | ) 55 | 56 | import Control.Distributed.Process 57 | import Control.Distributed.Process.Node 58 | import Control.Distributed.Process.Serializable() 59 | import Control.Distributed.Process.Platform 60 | import Control.Distributed.Process.Platform.Test 61 | import Control.Distributed.Process.Platform.Time 62 | import Control.Distributed.Process.Platform.Timer 63 | import Control.Exception 64 | import Control.Monad (forever) 65 | import Control.Monad.STM (atomically) 66 | import Control.Rematch hiding (match) 67 | import Control.Rematch.Run 68 | import Test.HUnit (Assertion, assertFailure) 69 | import Test.HUnit.Base (assertBool) 70 | import Test.Framework (Test, defaultMain) 71 | 72 | import Network.Transport.TCP 73 | import qualified Network.Transport as NT 74 | 75 | --expect :: a -> Matcher a -> Process () 76 | --expect a m = liftIO $ Rematch.expect a m 77 | 78 | expectThat :: a -> Matcher a -> Process () 79 | expectThat a matcher = case res of 80 | MatchSuccess -> return () 81 | (MatchFailure msg) -> liftIO $ assertFailure msg 82 | where res = runMatch matcher a 83 | 84 | shouldBe :: a -> Matcher a -> Process () 85 | shouldBe = expectThat 86 | 87 | shouldContain :: (Show a, Eq a) => [a] -> a -> Process () 88 | shouldContain xs x = expectThat xs $ hasItem (equalTo x) 89 | 90 | shouldNotContain :: (Show a, Eq a) => [a] -> a -> Process () 91 | shouldNotContain xs x = expectThat xs $ isNot (hasItem (equalTo x)) 92 | 93 | shouldMatch :: a -> Matcher a -> Process () 94 | shouldMatch = expectThat 95 | 96 | shouldExitWith :: (Addressable a) => a -> DiedReason -> Process () 97 | shouldExitWith a r = do 98 | _ <- resolve a 99 | d <- receiveWait [ match (\(ProcessMonitorNotification _ _ r') -> return r') ] 100 | d `shouldBe` equalTo r 101 | 102 | waitForExit :: MVar ExitReason 103 | -> Process (Maybe ExitReason) 104 | waitForExit exitReason = do 105 | -- we *might* end up blocked here, so ensure the test doesn't jam up! 106 | self <- getSelfPid 107 | tref <- killAfter (within 10 Seconds) self "testcast timed out" 108 | tr <- liftIO $ takeMVar exitReason 109 | cancelTimer tref 110 | case tr of 111 | ExitNormal -> return Nothing 112 | other -> return $ Just other 113 | 114 | mkNode :: String -> IO LocalNode 115 | mkNode port = do 116 | Right (transport1, _) <- createTransportExposeInternals 117 | "127.0.0.1" port defaultTCPParameters 118 | newLocalNode transport1 initRemoteTable 119 | 120 | -- | Run the supplied @testProc@ using an @MVar@ to collect and assert 121 | -- against its result. Uses the supplied @note@ if the assertion fails. 122 | delayedAssertion :: (Eq a) => String -> LocalNode -> a -> 123 | (TestResult a -> Process ()) -> Assertion 124 | delayedAssertion note localNode expected testProc = do 125 | result <- newEmptyMVar 126 | _ <- forkProcess localNode $ testProc result 127 | assertComplete note result expected 128 | 129 | -- | Takes the value of @mv@ (using @takeMVar@) and asserts that it matches @a@ 130 | assertComplete :: (Eq a) => String -> MVar a -> a -> IO () 131 | assertComplete msg mv a = do 132 | b <- takeMVar mv 133 | assertBool msg (a == b) 134 | 135 | -- synchronised logging 136 | 137 | data Logger = Logger { _tid :: ThreadId, msgs :: TQueue String } 138 | 139 | -- | Create a new Logger. 140 | -- Logger uses a 'TQueue' to receive and process messages on a worker thread. 141 | newLogger :: IO Logger 142 | newLogger = do 143 | tid <- liftIO $ myThreadId 144 | q <- liftIO $ newTQueueIO 145 | _ <- forkIO $ logger q 146 | return $ Logger tid q 147 | where logger q' = forever $ do 148 | msg <- atomically $ readTQueue q' 149 | putStrLn msg 150 | 151 | -- | Send a message to the Logger 152 | putLogMsg :: Logger -> String -> Process () 153 | putLogMsg logger msg = liftIO $ atomically $ writeTQueue (msgs logger) msg 154 | 155 | -- | Stop the worker thread for the given Logger 156 | stopLogger :: Logger -> IO () 157 | stopLogger = (flip throwTo) ThreadKilled . _tid 158 | 159 | -- | Given a @builder@ function, make and run a test suite on a single transport 160 | testMain :: (NT.Transport -> IO [Test]) -> IO () 161 | testMain builder = do 162 | Right (transport, _) <- createTransportExposeInternals 163 | "127.0.0.1" "10501" defaultTCPParameters 164 | testData <- builder transport 165 | defaultMain testData 166 | --------------------------------------------------------------------------------