├── .ghci ├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── CONTRIBUTING.md ├── LICENCE ├── NOTES ├── README.md ├── REPOS ├── Setup.lhs ├── distributed-process-async.cabal ├── profiling ├── configure.sh └── run.sh ├── src └── Control │ └── Distributed │ └── Process │ ├── Async.hs │ └── Async │ └── Internal │ └── Types.hs ├── stack-ghc-9.4.5.yaml ├── stack-ghc-9.8.2.yaml ├── stack.yaml ├── test-report.hs └── tests └── TestAsync.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc -itests 2 | 3 | :def hoogle \x -> return $ ":!hoogle " ++ x 4 | 5 | :def doc \x -> return $ ":!hoogle --info \"" ++ x ++ "\"" 6 | 7 | :set -w -fwarn-unused-binds -fwarn-unused-imports 8 | 9 | :load tests/Main.hs -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | .stack* 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | sudo: false 4 | 5 | matrix: 6 | include: 7 | - env: ARGS="--resolver nightly" COVER="" GHCVER=latest 8 | addons: {apt: {packages: [libgmp-dev]}} 9 | 10 | cache: 11 | directories: 12 | - $HOME/.stack 13 | - $HOME/.local 14 | 15 | before_install: 16 | - export PATH=$HOME/.local/bin:$HOME/.cabal/bin:$PATH 17 | - mkdir -p ~/.local/bin 18 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 19 | - stack --version 20 | 21 | install: 22 | - stack ${ARGS} setup --no-terminal 23 | 24 | script: 25 | - stack ${ARGS} test --test-arguments='--plain' 26 | 27 | notifications: 28 | slack: 29 | secure: g0NP1tkOe3+kI6O0Q1mgT/jPaLjxQ31J26MWouicu2F1Y3p73qTvv/QsOkafRMZDn07HlzgviCP25r7Ytg32pUAFvOh4U4MT2MpO0jUVVGPi4ZiwB+W5AH+HlDtJSickeSZ0AjXZSaGv8nQNegWkeaLQgLBIzrTHU8s0Y9K+whQ= 30 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2024-03-25 David Simmons-Duffin 0.2.7 2 | 3 | * Bump dependencies to build with ghc-9.8. 4 | 5 | 2018-06-14 Alexander Vershilov 0.2.6 6 | 7 | * Update dependency bounds 8 | * Export all documented functions (Issue #9) 9 | 10 | 2016-02-16 Facundo Domínguez 0.2.3 11 | 12 | * Update dependency bounds. 13 | 14 | # HEAD 15 | 16 | * Added initial GenServer module 17 | * Added Timer Module 18 | * Moved time functions into Time.hs 19 | * Added Async API 20 | * Added GenProcess API (subsumes lower level GenServer API) 21 | 22 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | See https://github.com/haskell-distributed/cloud-haskell/blob/master/CONTRIBUTING.md. 2 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | Copyright Tim Watson, 2012-2013. 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of the author nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /NOTES: -------------------------------------------------------------------------------- 1 | MAJOR TODOs (in no particular order) 2 | 3 | - implement Observable for Mailbox 4 | - implement PCopy / pcopy :: PCopy a -> Process () and precv :: Process (Maybe (PCopy a)) 5 | - provide InputChannel for PCopy data, i.e.: 6 | 7 | data InputChannel a = ReadChan (ReceivePort a) | ReadSTM (STM a) 8 | 9 | read (ReadChan rp) = expectChan rp 10 | read (ReadSTM stm) = liftIO $ atomically stm 11 | 12 | offer 13 | 14 | - implement RoundRobinRouter, ContentBasedRouter 15 | - finish off ResourcePool 16 | - double check we're using NFSerializable where possible/necessary 17 | 18 | - implement LocalRegistry (?) 19 | - possibly rationalise Registry with LocalRegistry (?) 20 | - Health checks for services 21 | - Service Monitoring 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # distributed-process-async (archive) 2 | 3 | ## :warning: This package is now developed here: https://github.com/haskell-distributed/distributed-process :warning: 4 | -------------------------------------------------------------------------------- /REPOS: -------------------------------------------------------------------------------- 1 | rank1dynamic 2 | distributed-static 3 | network-transport 4 | network-transport-tcp 5 | distributed-process 6 | distributed-process-extras 7 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /distributed-process-async.cabal: -------------------------------------------------------------------------------- 1 | name: distributed-process-async 2 | version: 0.2.7 3 | cabal-version: >=1.10 4 | build-type: Simple 5 | license: BSD3 6 | license-file: LICENCE 7 | stability: experimental 8 | Copyright: Tim Watson 2012 - 2016 9 | Author: Tim Watson 10 | Maintainer: Tim Watson 11 | Homepage: http://github.com/haskell-distributed/distributed-process-async 12 | Bug-Reports: http://github.com/haskell-distributed/distributed-process-async/issues 13 | synopsis: Cloud Haskell Async API 14 | description: This package provides a higher-level interface over Processes, in which an Async a is a 15 | concurrent, possibly distributed Process that will eventually deliver a value of type a. 16 | The package provides ways to create Async computations, wait for their results, and cancel them. 17 | category: Control 18 | tested-with: GHC == 7.8.4 GHC == 7.10.3 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/haskell-distributed/distributed-process-async 23 | 24 | library 25 | build-depends: 26 | base >= 4.4 && < 5, 27 | data-accessor >= 0.2.2.3, 28 | distributed-process >= 0.6.1 && < 0.8, 29 | exceptions >= 0.8.2.1 && < 1.0, 30 | binary >= 0.6.3.0 && < 0.9, 31 | deepseq >= 1.3.0.1 && < 1.6, 32 | mtl, 33 | containers >= 0.4 && < 0.7, 34 | hashable >= 1.2.0.5 && < 1.5, 35 | unordered-containers >= 0.2.3.0 && < 0.3, 36 | fingertree < 0.2, 37 | stm >= 2.4 && < 2.6, 38 | time >= 1.8.0.2, 39 | transformers 40 | default-extensions: CPP 41 | InstanceSigs 42 | hs-source-dirs: src 43 | default-language: Haskell2010 44 | ghc-options: -Wall 45 | exposed-modules: 46 | Control.Distributed.Process.Async 47 | other-modules: 48 | Control.Distributed.Process.Async.Internal.Types 49 | 50 | test-suite AsyncTests 51 | type: exitcode-stdio-1.0 52 | x-uses-tf: true 53 | build-depends: 54 | base >= 4.4 && < 5, 55 | ansi-terminal >= 0.5 && < 0.9, 56 | distributed-process, 57 | distributed-process-async, 58 | distributed-process-systest >= 0.2.0, 59 | exceptions >= 0.8.2.1 && < 1.0, 60 | network >= 2.5 && < 2.7, 61 | network-transport >= 0.4 && < 0.6, 62 | network-transport-tcp >= 0.6 && < 0.9, 63 | binary >= 0.6.3.0 && < 0.9, 64 | deepseq >= 1.3.0.1 && < 1.6, 65 | -- HUnit >= 1.2 && < 2, 66 | stm >= 2.3 && < 2.5, 67 | test-framework >= 0.6 && < 0.9, 68 | test-framework-hunit, 69 | rematch >= 0.2.0.0, 70 | transformers 71 | hs-source-dirs: 72 | tests 73 | default-language: Haskell2010 74 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind 75 | default-extensions: CPP 76 | main-is: TestAsync.hs 77 | -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Async.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Control.Distributed.Process.Async 4 | -- Copyright : (c) Tim Watson 2012 5 | -- License : BSD3 (see the file LICENSE) 6 | -- 7 | -- Maintainer : Tim Watson 8 | -- Stability : experimental 9 | -- Portability : non-portable (requires concurrency) 10 | -- 11 | -- This API provides a means for spawning asynchronous operations, waiting 12 | -- for their results, cancelling them and various other utilities. 13 | -- Asynchronous operations can be executed on remote nodes. 14 | -- 15 | -- [Asynchronous Operations] 16 | -- 17 | -- There is an implicit contract for async workers; Workers must exit 18 | -- normally (i.e., should not call the 'exit', 'die' or 'terminate' 19 | -- Cloud Haskell primitives), otherwise the 'AsyncResult' will end up being 20 | -- @AsyncFailed DiedException@ instead of containing the result. 21 | -- 22 | -- Portions of this file are derived from the @Control.Concurrent.Async@ 23 | -- module, from the @async@ package written by Simon Marlow. 24 | ----------------------------------------------------------------------------- 25 | 26 | module Control.Distributed.Process.Async 27 | ( -- * Exported types 28 | AsyncRef 29 | , AsyncTask(..) 30 | , Async 31 | , AsyncResult(..) 32 | -- * Spawning asynchronous operations 33 | , async 34 | , asyncLinked 35 | , task 36 | , remoteTask 37 | , monitorAsync 38 | , asyncWorker 39 | -- * Cancelling asynchronous operations 40 | , cancel 41 | , cancelWait 42 | , cancelWith 43 | , cancelKill 44 | -- * Querying for results 45 | , poll 46 | , check 47 | , wait 48 | , waitAny 49 | -- * Waiting with timeouts 50 | , waitAnyTimeout 51 | , waitTimeout 52 | , waitCancelTimeout 53 | , waitCheckTimeout 54 | -- * STM versions 55 | , pollSTM 56 | , waitSTM 57 | , waitAnySTM 58 | , waitAnyCancel 59 | , waitEither 60 | , waitEither_ 61 | , waitBoth 62 | ) where 63 | 64 | import Control.Applicative 65 | import Control.Concurrent.STM hiding (check) 66 | import Control.Distributed.Process hiding (catch, finally) 67 | import Control.Distributed.Process.Serializable 68 | import Control.Distributed.Process.Async.Internal.Types 69 | import Control.Monad 70 | import Control.Monad.Catch (finally) 71 | import Data.Maybe 72 | ( fromMaybe 73 | ) 74 | 75 | import System.Timeout (timeout) 76 | import Prelude 77 | 78 | -- | Wraps a regular @Process a@ as an 'AsyncTask'. 79 | task :: Process a -> AsyncTask a 80 | task = AsyncTask 81 | 82 | -- | Wraps the components required and builds a remote 'AsyncTask'. 83 | remoteTask :: Static (SerializableDict a) 84 | -> NodeId 85 | -> Closure (Process a) 86 | -> AsyncTask a 87 | remoteTask = AsyncRemoteTask 88 | 89 | -- | Given an 'Async' handle, monitor the worker process. 90 | monitorAsync :: Async a -> Process MonitorRef 91 | monitorAsync = monitor . _asyncWorker 92 | 93 | -- | Spawns an asynchronous action and returns a handle to it, 94 | -- which can be used to obtain its status and/or result or interact 95 | -- with it (using the API exposed by this module). 96 | -- 97 | async :: (Serializable a) => AsyncTask a -> Process (Async a) 98 | async = asyncDo False 99 | 100 | -- | Provides the pid of the worker process performing the async operation. 101 | asyncWorker :: Async a -> ProcessId 102 | asyncWorker = _asyncWorker 103 | 104 | -- | This is a useful variant of 'async' that ensures an @Async@ task is 105 | -- never left running unintentionally. We ensure that if the caller's process 106 | -- exits, that the worker is killed. 107 | -- 108 | -- There is currently a contract for async workers, that they should 109 | -- exit normally (i.e., they should not call the @exit@ or @kill@ with their own 110 | -- 'ProcessId' nor use the @terminate@ primitive to cease functining), otherwise 111 | -- the 'AsyncResult' will end up being @AsyncFailed DiedException@ instead of 112 | -- containing the desired result. 113 | -- 114 | asyncLinked :: (Serializable a) => AsyncTask a -> Process (Async a) 115 | asyncLinked = asyncDo True 116 | 117 | -- private API 118 | asyncDo :: (Serializable a) => Bool -> AsyncTask a -> Process (Async a) 119 | asyncDo shouldLink (AsyncRemoteTask d n c) = 120 | asyncDo shouldLink $ AsyncTask $ call d n c 121 | asyncDo shouldLink (AsyncTask proc) = do 122 | root <- getSelfPid 123 | result <- liftIO newEmptyTMVarIO 124 | sigStart <- liftIO newEmptyTMVarIO 125 | (sp, rp) <- newChan 126 | 127 | -- listener/response proxy 128 | insulator <- spawnLocal $ do 129 | worker <- spawnLocal $ do 130 | liftIO $ atomically $ takeTMVar sigStart 131 | r <- proc 132 | void $ liftIO $ atomically $ putTMVar result (AsyncDone r) 133 | 134 | sendChan sp worker -- let the parent process know the worker pid 135 | 136 | wref <- monitor worker 137 | rref <- if shouldLink then fmap Just (monitor root) else return Nothing 138 | finally (pollUntilExit worker result) 139 | (unmonitor wref >> 140 | return (maybe (return ()) unmonitor rref)) 141 | 142 | workerPid <- receiveChan rp 143 | liftIO $ atomically $ putTMVar sigStart () 144 | 145 | return Async { _asyncWorker = workerPid 146 | , _asyncMonitor = insulator 147 | , _asyncWait = readTMVar result 148 | } 149 | 150 | where 151 | pollUntilExit :: (Serializable a) 152 | => ProcessId 153 | -> TMVar (AsyncResult a) 154 | -> Process () 155 | pollUntilExit wpid result' = do 156 | r <- receiveWait [ 157 | match (\c@CancelWait -> kill wpid "cancel" >> return (Left c)) 158 | , match (\(ProcessMonitorNotification _ pid' r) -> 159 | return (Right (pid', r))) 160 | ] 161 | case r of 162 | Left CancelWait 163 | -> liftIO $ atomically $ putTMVar result' AsyncCancelled 164 | Right (fpid, d) 165 | | fpid == wpid -> case d of 166 | DiedNormal -> return () 167 | _ -> liftIO $ atomically $ void $ 168 | tryPutTMVar result' (AsyncFailed d) 169 | | otherwise -> do 170 | kill wpid "linkFailed" 171 | receiveWait 172 | [ matchIf (\(ProcessMonitorNotification _ pid' _) -> 173 | pid' == wpid 174 | ) $ \_ -> return () 175 | ] 176 | liftIO $ atomically $ void $ 177 | tryPutTMVar result' (AsyncLinkFailed d) 178 | 179 | -- | Check whether an 'Async' has completed yet. 180 | poll :: (Serializable a) => Async a -> Process (AsyncResult a) 181 | poll hAsync = do 182 | r <- liftIO $ atomically $ pollSTM hAsync 183 | return $ fromMaybe AsyncPending r 184 | 185 | -- | Like 'poll' but returns 'Nothing' if @(poll hAsync) == AsyncPending@. 186 | check :: (Serializable a) => Async a -> Process (Maybe (AsyncResult a)) 187 | check hAsync = poll hAsync >>= \r -> case r of 188 | AsyncPending -> return Nothing 189 | ar -> return (Just ar) 190 | 191 | -- | Wait for an asynchronous operation to complete or timeout. 192 | waitCheckTimeout :: (Serializable a) => 193 | Int -> Async a -> Process (AsyncResult a) 194 | waitCheckTimeout t hAsync = 195 | fmap (fromMaybe AsyncPending) (waitTimeout t hAsync) 196 | 197 | -- | Wait for an asynchronous action to complete, and return its 198 | -- value. The result (which can include failure and/or cancellation) is 199 | -- encoded by the 'AsyncResult' type. 200 | -- 201 | -- @wait = liftIO . atomically . waitSTM@ 202 | -- 203 | {-# INLINE wait #-} 204 | wait :: Async a -> Process (AsyncResult a) 205 | wait = liftIO . atomically . waitSTM 206 | 207 | -- | Wait for an asynchronous operation to complete or timeout. 208 | waitTimeout :: (Serializable a) => 209 | Int -> Async a -> Process (Maybe (AsyncResult a)) 210 | waitTimeout t hAsync = 211 | liftIO $ timeout t $ atomically $ waitSTM hAsync 212 | 213 | -- | Wait for an asynchronous operation to complete or timeout. 214 | -- If it times out, then 'cancelWait' the async handle. 215 | -- 216 | waitCancelTimeout :: (Serializable a) 217 | => Int 218 | -> Async a 219 | -> Process (AsyncResult a) 220 | waitCancelTimeout t hAsync = do 221 | r <- waitTimeout t hAsync 222 | case r of 223 | Nothing -> cancelWait hAsync 224 | Just ar -> return ar 225 | 226 | -- | Wait for any of the supplied @Async@s to complete. If multiple 227 | -- 'Async's complete, then the value returned corresponds to the first 228 | -- completed 'Async' in the list. 229 | -- 230 | -- NB: Unlike @AsyncChan@, 'Async' does not discard its 'AsyncResult' once 231 | -- read, therefore the semantics of this function are different to the 232 | -- former. Specifically, if @asyncs = [a1, a2, a3]@ and @(AsyncDone _) = a1@ 233 | -- then the remaining @a2, a3@ will never be returned by 'waitAny'. 234 | -- 235 | waitAny :: (Serializable a) 236 | => [Async a] 237 | -> Process (Async a, AsyncResult a) 238 | waitAny asyncs = liftIO $ waitAnySTM asyncs 239 | 240 | -- | Like 'waitAny', but also cancels the other asynchronous 241 | -- operations as soon as one has completed. 242 | -- 243 | waitAnyCancel :: (Serializable a) 244 | => [Async a] -> Process (Async a, AsyncResult a) 245 | waitAnyCancel asyncs = 246 | waitAny asyncs `finally` mapM_ cancel asyncs 247 | 248 | -- | Wait for the first of two @Async@s to finish. 249 | -- 250 | waitEither :: Async a 251 | -> Async b 252 | -> Process (Either (AsyncResult a) (AsyncResult b)) 253 | waitEither left right = 254 | liftIO $ atomically $ 255 | (Left <$> waitSTM left) 256 | `orElse` 257 | (Right <$> waitSTM right) 258 | 259 | -- | Like 'waitEither', but the result is ignored. 260 | -- 261 | waitEither_ :: Async a -> Async b -> Process () 262 | waitEither_ left right = 263 | liftIO $ atomically $ 264 | (void $ waitSTM left) 265 | `orElse` 266 | (void $ waitSTM right) 267 | 268 | -- | Waits for both @Async@s to finish. 269 | -- 270 | waitBoth :: Async a 271 | -> Async b 272 | -> Process (AsyncResult a, AsyncResult b) 273 | waitBoth left right = 274 | liftIO $ atomically $ do 275 | a <- waitSTM left 276 | `orElse` 277 | (waitSTM right >> retry) 278 | b <- waitSTM right 279 | return (a,b) 280 | 281 | -- | Like 'waitAny' but times out after the specified delay. 282 | waitAnyTimeout :: (Serializable a) 283 | => Int 284 | -> [Async a] 285 | -> Process (Maybe (AsyncResult a)) 286 | waitAnyTimeout delay asyncs = 287 | liftIO $ timeout delay $ do 288 | r <- waitAnySTM asyncs 289 | return $ snd r 290 | 291 | -- | Cancel an asynchronous operation. 292 | cancel :: Async a -> Process () 293 | cancel (Async _ g _) = send g CancelWait 294 | 295 | -- | Cancel an asynchronous operation and wait for the cancellation to complete. 296 | cancelWait :: (Serializable a) => Async a -> Process (AsyncResult a) 297 | cancelWait hAsync = cancel hAsync >> wait hAsync 298 | 299 | -- | Cancel an asynchronous operation immediately. 300 | cancelWith :: (Serializable b) => b -> Async a -> Process () 301 | cancelWith reason hAsync = exit (_asyncWorker hAsync) reason 302 | 303 | -- | Like 'cancelWith' but sends a @kill@ instruction instead of an exit. 304 | cancelKill :: String -> Async a -> Process () 305 | cancelKill reason hAsync = kill (_asyncWorker hAsync) reason 306 | 307 | -------------------------------------------------------------------------------- 308 | -- STM Specific API -- 309 | -------------------------------------------------------------------------------- 310 | 311 | -- | STM version of 'waitAny'. 312 | waitAnySTM :: [Async a] -> IO (Async a, AsyncResult a) 313 | waitAnySTM asyncs = 314 | atomically $ 315 | foldr orElse retry $ 316 | map (\a -> do r <- waitSTM a; return (a, r)) asyncs 317 | 318 | -- | A version of 'wait' that can be used inside an STM transaction. 319 | -- 320 | waitSTM :: Async a -> STM (AsyncResult a) 321 | waitSTM (Async _ _ w) = w 322 | 323 | -- | A version of 'poll' that can be used inside an STM transaction. 324 | -- 325 | {-# INLINE pollSTM #-} 326 | pollSTM :: Async a -> STM (Maybe (AsyncResult a)) 327 | pollSTM (Async _ _ w) = (Just <$> w) `orElse` return Nothing 328 | -------------------------------------------------------------------------------- /src/Control/Distributed/Process/Async/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ExistentialQuantification #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | {-# LANGUAGE DeriveFunctor #-} 8 | 9 | -- | shared, internal types for the Async package 10 | module Control.Distributed.Process.Async.Internal.Types 11 | ( -- * Exported types 12 | Async(..) 13 | , AsyncRef 14 | , AsyncTask(..) 15 | , AsyncResult(..) 16 | , CancelWait(..) 17 | ) where 18 | 19 | import Control.Concurrent.STM 20 | import Control.Distributed.Process 21 | import Control.Distributed.Process.Serializable 22 | ( Serializable 23 | , SerializableDict 24 | ) 25 | import Data.Binary 26 | import Data.Typeable (Typeable) 27 | 28 | import GHC.Generics 29 | 30 | -- | A reference to an asynchronous action 31 | type AsyncRef = ProcessId 32 | 33 | -- | An handle for an asynchronous action spawned by 'async'. 34 | -- Asynchronous operations are run in a separate process, and 35 | -- operations are provided for waiting for asynchronous actions to 36 | -- complete and obtaining their results (see e.g. 'wait'). 37 | -- 38 | -- Handles of this type cannot cross remote boundaries, nor are they 39 | -- @Serializable@. 40 | data Async a = Async { 41 | _asyncWorker :: AsyncRef 42 | , _asyncMonitor :: AsyncRef 43 | , _asyncWait :: STM (AsyncResult a) 44 | } deriving (Functor) 45 | 46 | instance Eq (Async a) where 47 | Async a b _ == Async c d _ = a == c && b == d 48 | 49 | instance Ord (Async a) where 50 | compare (Async a b _) (Async c d _) = a `compare` c <> b `compare` d 51 | 52 | -- | A task to be performed asynchronously. 53 | data AsyncTask a = 54 | AsyncTask { 55 | asyncTask :: Process a -- ^ the task to be performed 56 | } 57 | | AsyncRemoteTask { 58 | asyncTaskDict :: Static (SerializableDict a) 59 | -- ^ the serializable dict required to spawn a remote process 60 | , asyncTaskNode :: NodeId 61 | -- ^ the node on which to spawn the asynchronous task 62 | , asyncTaskProc :: Closure (Process a) 63 | -- ^ the task to be performed, wrapped in a closure environment 64 | } 65 | 66 | -- | Represents the result of an asynchronous action, which can be in one of 67 | -- several states at any given time. 68 | data AsyncResult a = 69 | AsyncDone a -- ^ a completed action and its result 70 | | AsyncFailed DiedReason -- ^ a failed action and the failure reason 71 | | AsyncLinkFailed DiedReason -- ^ a link failure and the reason 72 | | AsyncCancelled -- ^ a cancelled action 73 | | AsyncPending -- ^ a pending action (that is still running) 74 | deriving (Typeable, Generic, Functor) 75 | 76 | 77 | instance Serializable a => Binary (AsyncResult a) where 78 | 79 | deriving instance Eq a => Eq (AsyncResult a) 80 | deriving instance Show a => Show (AsyncResult a) 81 | 82 | -- | A message to cancel Async operations 83 | data CancelWait = CancelWait 84 | deriving (Typeable, Generic) 85 | instance Binary CancelWait 86 | -------------------------------------------------------------------------------- /stack-ghc-9.4.5.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2023-05-02 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - git: https://github.com/haskell-distributed/distributed-process.git 6 | commit: f45c9d986edfb79669c54c646501b9448fc800e8 7 | - git: https://github.com/haskell-distributed/distributed-process-systest.git 8 | commit: d43a6ee475b1ea2d3c5edcf460517a948eba7a78 9 | - rematch-0.2.0.0 10 | - distributed-static-0.3.9@sha256:f5e781867eddec660cb3b39805c849e3f096b7da245d43a07d8529e3c92b3a27 11 | - network-transport-tcp-0.8.1 12 | flags: {} 13 | -------------------------------------------------------------------------------- /stack-ghc-9.8.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2024-03-24 # Use GHC 9.8.2 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - distributed-static-0.3.10 6 | - rematch-0.2.0.0 7 | - network-transport-0.5.7 8 | - network-transport-tcp-0.8.2 9 | - network-transport-inmemory-0.5.3 10 | - distributed-process-0.7.5 11 | flags: {} 12 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | stack-ghc-9.8.2.yaml -------------------------------------------------------------------------------- /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/TestAsync.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Main where 6 | 7 | import Control.Concurrent.MVar 8 | import Control.Distributed.Process 9 | import Control.Distributed.Process.Closure 10 | import Control.Distributed.Process.Node 11 | import Control.Distributed.Process.Serializable() 12 | import Control.Distributed.Process.Async 13 | import Control.Distributed.Process.SysTest.Utils 14 | import Control.Monad (replicateM_) 15 | import Data.Binary() 16 | import Data.Typeable() 17 | import Network.Transport.TCP 18 | import qualified Network.Transport as NT 19 | 20 | import Test.Framework (Test, testGroup, defaultMain) 21 | import Test.Framework.Providers.HUnit (testCase) 22 | 23 | testAsyncPoll :: TestResult (AsyncResult ()) -> Process () 24 | testAsyncPoll result = do 25 | hAsync <- async $ task $ do "go" <- expect; say "running" >> return () 26 | ar <- poll hAsync 27 | case ar of 28 | AsyncPending -> 29 | send (asyncWorker hAsync) "go" >> wait hAsync >>= stash result 30 | _ -> stash result ar >> return () 31 | 32 | -- Tests that an async action can be canceled. 33 | testAsyncCancel :: TestResult (AsyncResult ()) -> Process () 34 | testAsyncCancel result = do 35 | hAsync <- async $ task (expect :: Process ()) 36 | 37 | p <- poll hAsync 38 | case p of 39 | AsyncPending -> cancel hAsync >> wait hAsync >>= stash result 40 | _ -> say (show p) >> stash result p 41 | 42 | -- Tests that cancelWait completes when the worker dies. 43 | testAsyncCancelWait :: TestResult (Maybe (AsyncResult ())) -> Process () 44 | testAsyncCancelWait result = do 45 | hAsync <- async $ task (expect :: Process ()) 46 | 47 | AsyncPending <- poll hAsync 48 | cancelWait hAsync >>= stash result . Just 49 | 50 | -- Tests that waitTimeout completes when the timeout expires. 51 | testAsyncWaitTimeout :: TestResult (Maybe (AsyncResult ())) -> Process () 52 | testAsyncWaitTimeout result = do 53 | hAsync <- async $ task (expect :: Process ()) 54 | waitTimeout 100000 hAsync >>= stash result 55 | cancelWait hAsync >> return () 56 | 57 | -- Tests that an async action can be awaited to completion even with a timeout. 58 | testAsyncWaitTimeoutCompletes :: TestResult (Maybe (AsyncResult ())) 59 | -> Process () 60 | testAsyncWaitTimeoutCompletes result = do 61 | hAsync <- async $ task (expect :: Process ()) 62 | r <- waitTimeout 100000 hAsync 63 | case r of 64 | Nothing -> send (asyncWorker hAsync) () 65 | >> wait hAsync >>= stash result . Just 66 | Just _ -> cancelWait hAsync >> stash result Nothing 67 | 68 | -- Tests that a linked async action dies when the parent dies. 69 | testAsyncLinked :: TestResult Bool -> Process () 70 | testAsyncLinked result = do 71 | mv :: MVar (Async ()) <- liftIO newEmptyMVar 72 | pid <- spawnLocal $ do 73 | -- NB: async == asyncLinked for AsyncChan 74 | h <- asyncLinked $ task (expect :: Process ()) 75 | stash mv h 76 | expect 77 | 78 | hAsync <- liftIO $ takeMVar mv 79 | 80 | mref <- monitorAsync hAsync 81 | exit pid "stop" 82 | 83 | _ <- receiveWait [ 84 | matchIf (\(ProcessMonitorNotification mref' _ _) -> mref == mref') 85 | (\_ -> return ()) 86 | ] 87 | 88 | -- since the initial caller died and we used 'asyncLinked', the async should 89 | -- pick up on the exit signal and set the result accordingly. trying to match 90 | -- on 'DiedException String' is pointless though, as the *string* is highly 91 | -- context dependent. 92 | r <- wait hAsync 93 | case r of 94 | AsyncLinkFailed _ -> stash result True 95 | _ -> stash result False 96 | 97 | -- Tests that waitAny returns when any of the actions complete. 98 | testAsyncWaitAny :: TestResult [AsyncResult String] -> Process () 99 | testAsyncWaitAny result = do 100 | p1 <- async $ task expect 101 | p2 <- async $ task expect 102 | p3 <- async $ task expect 103 | send (asyncWorker p3) "c" 104 | r1 <- waitAny [p1, p2, p3] 105 | 106 | send (asyncWorker p1) "a" 107 | send (asyncWorker p2) "b" 108 | ref1 <- monitorAsync p1 109 | ref2 <- monitorAsync p2 110 | replicateM_ 2 $ receiveWait 111 | [ matchIf (\(ProcessMonitorNotification ref _ _) -> elem ref [ref1, ref2]) 112 | $ \_ -> return () 113 | ] 114 | 115 | r2 <- waitAny [p2, p3] 116 | r3 <- waitAny [p1, p2, p3] 117 | 118 | stash result $ map snd [r1, r2, r3] 119 | 120 | -- Tests that waitAnyTimeout returns when the timeout expires. 121 | testAsyncWaitAnyTimeout :: TestResult (Maybe (AsyncResult String)) -> Process () 122 | testAsyncWaitAnyTimeout result = do 123 | p1 <- asyncLinked $ task expect 124 | p2 <- asyncLinked $ task expect 125 | p3 <- asyncLinked $ task expect 126 | waitAnyTimeout 100000 [p1, p2, p3] >>= stash result 127 | 128 | -- Tests that cancelWith terminates the worker with the given reason. 129 | testAsyncCancelWith :: TestResult Bool -> Process () 130 | testAsyncCancelWith result = do 131 | p1 <- async $ task $ do { s :: String <- expect; return s } 132 | cancelWith "foo" p1 133 | AsyncFailed (DiedException _) <- wait p1 134 | stash result True 135 | 136 | -- Tests that waitCancelTimeout returns when the timeout expires. 137 | testAsyncWaitCancelTimeout :: TestResult (AsyncResult ()) -> Process () 138 | testAsyncWaitCancelTimeout result = do 139 | p1 <- async $ task expect 140 | waitCancelTimeout 1000000 p1 >>= stash result 141 | 142 | remotableDecl [ 143 | [d| fib :: (NodeId,Int) -> Process Integer ; 144 | fib (_,0) = return 0 145 | fib (_,1) = return 1 146 | fib (myNode,n) = do 147 | let tsk = remoteTask ($(functionTDict 'fib)) myNode ($(mkClosure 'fib) (myNode,n-2)) 148 | future <- async tsk 149 | y <- fib (myNode,n-1) 150 | (AsyncDone z) <- wait future 151 | return $ y + z 152 | |] 153 | ] 154 | 155 | -- Tests that wait returns when remote actions complete. 156 | testAsyncRecursive :: TestResult Integer -> Process () 157 | testAsyncRecursive result = do 158 | myNode <- getSelfNode 159 | fib (myNode,6) >>= stash result 160 | 161 | tests :: LocalNode -> [Test] 162 | tests localNode = [ 163 | testGroup "Handling async results with STM" [ 164 | testCase "testAsyncCancel" 165 | (delayedAssertion 166 | "expected async task to have been cancelled" 167 | localNode (AsyncCancelled) testAsyncCancel) 168 | , testCase "testAsyncPoll" 169 | (delayedAssertion 170 | "expected poll to return a valid AsyncResult" 171 | localNode (AsyncDone ()) testAsyncPoll) 172 | , testCase "testAsyncCancelWait" 173 | (delayedAssertion 174 | "expected cancelWait to complete some time" 175 | localNode (Just AsyncCancelled) testAsyncCancelWait) 176 | , testCase "testAsyncWaitTimeout" 177 | (delayedAssertion 178 | "expected waitTimeout to return Nothing when it times out" 179 | localNode (Nothing) testAsyncWaitTimeout) 180 | , testCase "testAsyncWaitTimeoutCompletes" 181 | (delayedAssertion 182 | "expected waitTimeout to return a value" 183 | localNode (Just (AsyncDone ())) testAsyncWaitTimeoutCompletes) 184 | , testCase "testAsyncLinked" 185 | (delayedAssertion 186 | "expected linked process to die with originator" 187 | localNode True testAsyncLinked) 188 | , testCase "testAsyncWaitAny" 189 | (delayedAssertion 190 | "expected waitAny to pick the first result each time" 191 | localNode [AsyncDone "c", 192 | AsyncDone "b", 193 | AsyncDone "a"] testAsyncWaitAny) 194 | , testCase "testAsyncWaitAnyTimeout" 195 | (delayedAssertion 196 | "expected waitAnyTimeout to handle pending results properly" 197 | localNode Nothing testAsyncWaitAnyTimeout) 198 | , testCase "testAsyncCancelWith" 199 | (delayedAssertion 200 | "expected the worker to have been killed with the given signal" 201 | localNode True testAsyncCancelWith) 202 | , testCase "testAsyncRecursive" 203 | (delayedAssertion 204 | "expected Fibonacci 6 to be evaluated, and value of 8 returned" 205 | localNode 8 testAsyncRecursive) 206 | , testCase "testAsyncWaitCancelTimeout" 207 | (delayedAssertion 208 | "expected waitCancelTimeout to return a value" 209 | localNode AsyncCancelled testAsyncWaitCancelTimeout) 210 | ] 211 | ] 212 | 213 | asyncStmTests :: NT.Transport -> IO [Test] 214 | asyncStmTests transport = do 215 | localNode <- newLocalNode transport $ __remoteTableDecl initRemoteTable 216 | let testData = tests localNode 217 | return testData 218 | 219 | -- | Given a @builder@ function, make and run a test suite on a single transport 220 | testMain :: (NT.Transport -> IO [Test]) -> IO () 221 | testMain builder = do 222 | Right (transport, _) <- createTransportExposeInternals "127.0.0.1" "0" (\sn -> ("127.0.0.1", sn)) defaultTCPParameters 223 | testData <- builder transport 224 | defaultMain testData 225 | 226 | main :: IO () 227 | main = testMain $ asyncStmTests 228 | --------------------------------------------------------------------------------