b9b4aaa · distributed-process

git.iko.soy/distributed-process

on master help sign in

Bump to 0.2.2/Exception handling/fix runProcess

b9b4aaaEdsko de Vries14 years ago

distributed-process/ChangeLog+6

compare with master

unifiedsplit

@@ -1,3 +1,9 @@

1+2012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0

3+* Add exception handling primitives

4+* Fix runProcess: if the process threw an exception, a 'waiting indefinitely on

5+MVar' exception would be thrown.

12012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4

72012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4

3* Bugfix in the node controller

9* Bugfix in the node controller

distributed-process/distributed-process.cabal+1−1

@@ -1,5 +1,5 @@

1Name: distributed-process

2−Version: 0.2.1.4

2+Version: 0.2.2.0

3Cabal-Version: >=1.8

4Build-Type: Simple

5License: BSD3

distributed-process/src/Control/Distributed/Process.hs+14−2

@@ -80,8 +80,14 @@ module Control.Distributed.Process

80 , whereisRemoteAsync

81 , nsendRemote

82 , WhereIsReply(..)

83− -- * Auxiliary API

83+ -- * Exception handling

84 , catch

85+ , mask

86+ , onException

87+ , bracket

88+ , bracket_

89+ , finally

90+ -- * Auxiliary API

85 , expectTimeout

91 , expectTimeout

86 , spawnAsync

92 , spawnAsync

87 , spawnSupervised

93 , spawnSupervised

@@ -190,8 +196,14 @@ import Control.Distributed.Process.Internal.Primitives

190 , nsendRemote

196 , nsendRemote

191 -- Closures

197 -- Closures

192 , unClosure

198 , unClosure

193− -- Auxiliary API

199+ -- Exception handling

194 , catch

200 , catch

201+ , mask

202+ , onException

203+ , bracket

204+ , bracket_

205+ , finally

206+ -- Auxiliary API

195 , expectTimeout

207 , expectTimeout

196 , spawnAsync

208 , spawnAsync

197 )

209 )

distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+49−7

@@ -43,8 +43,14 @@ module Control.Distributed.Process.Internal.Primitives

43 , nsendRemote

44 -- * Closures

45 , unClosure

46− -- * Auxiliary API

46+ -- * Exception handling

47 , catch

48+ , mask

49+ , onException

50+ , bracket

51+ , bracket_

52+ , finally

53+ -- * Auxiliary API

48 , expectTimeout

54 , expectTimeout

49 , spawnAsync

55 , spawnAsync

50 , linkNode

56 , linkNode

@@ -67,8 +73,8 @@ import System.Locale (defaultTimeLocale)

67import Control.Monad.Reader (ask)

73import Control.Monad.Reader (ask)

68import Control.Monad.IO.Class (MonadIO, liftIO)

74import Control.Monad.IO.Class (MonadIO, liftIO)

69import Control.Applicative ((<$>))

75import Control.Applicative ((<$>))

70−import Control.Exception (Exception, throw)

76+import Control.Exception (Exception, throw, throwIO, SomeException)

71−import qualified Control.Exception as Ex (catch)

77+import qualified Control.Exception as Ex (catch, mask)

72import Control.Concurrent.MVar (modifyMVar)

78import Control.Concurrent.MVar (modifyMVar)

73import Control.Concurrent.Chan (writeChan)

79import Control.Concurrent.Chan (writeChan)

74import Control.Concurrent.STM

80import Control.Concurrent.STM

@@ -258,7 +264,7 @@ instance Exception ProcessTerminationException

258

264

259-- | Terminate (throws a ProcessTerminationException)

265-- | Terminate (throws a ProcessTerminationException)

260terminate :: Process a

266terminate :: Process a

261−terminate = liftIO $ throw ProcessTerminationException

267+terminate = liftIO $ throwIO ProcessTerminationException

262

268

263-- | Our own process ID

269-- | Our own process ID

264getSelfPid :: Process ProcessId

270getSelfPid :: Process ProcessId

@@ -317,15 +323,51 @@ unmonitor ref = do

317 ]

323 ]

318

324

319--------------------------------------------------------------------------------

325--------------------------------------------------------------------------------

320−-- Auxiliary API --

326+-- Exception handling --

321--------------------------------------------------------------------------------

327--------------------------------------------------------------------------------

322

328

323−-- | Catch exceptions within a process

329+-- | Lift 'Control.Exception.catch'

324catch :: Exception e => Process a -> (e -> Process a) -> Process a

330catch :: Exception e => Process a -> (e -> Process a) -> Process a

325catch p h = do

331catch p h = do

326 lproc <- ask

332 lproc <- ask

327 liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)

333 liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)

328

334

335+-- | Lift 'Control.Exception.mask'

336+mask :: ((forall a. Process a -> Process a) -> Process b) -> Process b

337+mask p = do

338+ lproc <- ask

339+ liftIO $ Ex.mask $ \restore ->

340+ runLocalProcess lproc (p (liftRestore lproc restore))

341+ where

342+ liftRestore :: LocalProcess -> (forall a. IO a -> IO a) -> (forall a. Process a -> Process a)

343+ liftRestore lproc restoreIO = liftIO . restoreIO . runLocalProcess lproc

344+

345+-- | Lift 'Control.Exception.onException'

346+onException :: Process a -> Process b -> Process a

347+onException p what = p `catch` \e -> do _ <- what

348+ liftIO $ throwIO (e :: SomeException)

349+

350+-- | Lift 'Control.Exception.bracket'

351+bracket :: Process a -> (a -> Process b) -> (a -> Process c) -> Process c

352+bracket before after thing = do

353+ mask $ \restore -> do

354+ a <- before

355+ r <- restore (thing a) `onException` after a

356+ _ <- after a

357+ return r

358+

359+-- | Lift 'Control.Exception.bracket_'

360+bracket_ :: Process a -> Process b -> Process c -> Process c

361+bracket_ before after thing = bracket before (const after) (const thing)

362+

363+-- | Lift 'Control.Exception.finally'

364+finally :: Process a -> Process b -> Process a

365+finally a sequel = bracket_ (return ()) sequel a

366+

367+--------------------------------------------------------------------------------

368+-- Auxiliary API --

369+--------------------------------------------------------------------------------

370+

329-- | Like 'expect' but with a timeout

371-- | Like 'expect' but with a timeout

330expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)

372expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)

331expectTimeout timeout = receiveTimeout timeout [match return]

373expectTimeout timeout = receiveTimeout timeout [match return]

@@ -464,7 +506,7 @@ unClosure :: forall a. Typeable a => Closure a -> Process a

464unClosure (Closure (Static label) env) = do

506unClosure (Closure (Static label) env) = do

465 rtable <- remoteTable . processNode <$> ask

507 rtable <- remoteTable . processNode <$> ask

466 case resolveClosure rtable label env of

508 case resolveClosure rtable label env of

467− Nothing -> throw . userError $ "Unregistered closure " ++ show label

509+ Nothing -> error $ "Unregistered closure " ++ show label

468 Just dyn -> return $ fromDyn dyn (throw (typeError dyn))

510 Just dyn -> return $ fromDyn dyn (throw (typeError dyn))

469 where

511 where

470 typeError dyn = userError $ "lookupStatic type error: "

512 typeError dyn = userError $ "lookupStatic type error: "

distributed-process/src/Control/Distributed/Process/Node.hs+2−2

@@ -121,7 +121,7 @@ import Control.Distributed.Process.Internal.Node

121 , sendMessage

122 , sendPayload

123 )

124−import Control.Distributed.Process.Internal.Primitives (expect, register)

124+import Control.Distributed.Process.Internal.Primitives (expect, register, finally)

125import qualified Control.Distributed.Process.Internal.Closure.Static as Static (__remoteTable)

126import qualified Control.Distributed.Process.Internal.Closure.CP as CP (__remoteTable)

127

@@ -189,7 +189,7 @@ closeLocalNode node =

189runProcess :: LocalNode -> Process () -> IO ()

190runProcess node proc = do

191 done <- newEmptyMVar

192− void $ forkProcess node (proc >> liftIO (putMVar done ()))

192+ void $ forkProcess node (proc `finally` liftIO (putMVar done ()))

193 takeMVar done

194

195-- | Spawn a new process on a local node