Skip to content

Commit b9b4aaa

Browse files
edskoedsko
committed
Bump to 0.2.2/Exception handling/fix runProcess
runProcess only marked the process as finished if the process completed successfully; if the process threw an exception, a 'blocked indefinitely on MVar' exception would be thrown
1 parent e06c6bf commit b9b4aaa

File tree

5 files changed

+72
-12
lines changed

5 files changed

+72
-12
lines changed

‎distributed-process/ChangeLog

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,9 @@
1+
2012-07-31 Edsko de Vries <edsko@well-typed.com> 0.2.2.0
2+
3+
* Add exception handling primitives
4+
* Fix runProcess: if the process threw an exception, a 'waiting indefinitely on
5+
MVar' exception would be thrown.
6+
17
2012-07-21 Edsko de Vries <edsko@well-typed.com> 0.2.1.4
28

39
* Bugfix in the node controller

‎distributed-process/distributed-process.cabal

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
Name: distributed-process
2-
Version: 0.2.1.4
2+
Version: 0.2.2.0
33
Cabal-Version: >=1.8
44
Build-Type: Simple
55
License: BSD3

‎distributed-process/src/Control/Distributed/Process.hs

Lines changed: 14 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -80,8 +80,14 @@ module Control.Distributed.Process
8080
, whereisRemoteAsync
8181
, nsendRemote
8282
, WhereIsReply(..)
83-
-- * Auxiliary API
83+
-- * Exception handling
8484
, catch
85+
, mask
86+
, onException
87+
, bracket
88+
, bracket_
89+
, finally
90+
-- * Auxiliary API
8591
, expectTimeout
8692
, spawnAsync
8793
, spawnSupervised
@@ -190,8 +196,14 @@ import Control.Distributed.Process.Internal.Primitives
190196
, nsendRemote
191197
-- Closures
192198
, unClosure
193-
-- Auxiliary API
199+
-- Exception handling
194200
, catch
201+
, mask
202+
, onException
203+
, bracket
204+
, bracket_
205+
, finally
206+
-- Auxiliary API
195207
, expectTimeout
196208
, spawnAsync
197209
)

‎distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs

Lines changed: 49 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -43,8 +43,14 @@ module Control.Distributed.Process.Internal.Primitives
4343
, nsendRemote
4444
-- * Closures
4545
, unClosure
46-
-- * Auxiliary API
46+
-- * Exception handling
4747
, catch
48+
, mask
49+
, onException
50+
, bracket
51+
, bracket_
52+
, finally
53+
-- * Auxiliary API
4854
, expectTimeout
4955
, spawnAsync
5056
, linkNode
@@ -67,8 +73,8 @@ import System.Locale (defaultTimeLocale)
6773
import Control.Monad.Reader (ask)
6874
import Control.Monad.IO.Class (MonadIO, liftIO)
6975
import Control.Applicative ((<$>))
70-
import Control.Exception (Exception, throw)
71-
import qualified Control.Exception as Ex (catch)
76+
import Control.Exception (Exception, throw, throwIO, SomeException)
77+
import qualified Control.Exception as Ex (catch, mask)
7278
import Control.Concurrent.MVar (modifyMVar)
7379
import Control.Concurrent.Chan (writeChan)
7480
import Control.Concurrent.STM
@@ -258,7 +264,7 @@ instance Exception ProcessTerminationException
258264

259265
-- | Terminate (throws a ProcessTerminationException)
260266
terminate :: Process a
261-
terminate = liftIO $ throw ProcessTerminationException
267+
terminate = liftIO $ throwIO ProcessTerminationException
262268

263269
-- | Our own process ID
264270
getSelfPid :: Process ProcessId
@@ -317,15 +323,51 @@ unmonitor ref = do
317323
]
318324

319325
--------------------------------------------------------------------------------
320-
-- Auxiliary API --
326+
-- Exception handling --
321327
--------------------------------------------------------------------------------
322328

323-
-- | Catch exceptions within a process
329+
-- | Lift 'Control.Exception.catch'
324330
catch :: Exception e => Process a -> (e -> Process a) -> Process a
325331
catch p h = do
326332
lproc <- ask
327333
liftIO $ Ex.catch (runLocalProcess lproc p) (runLocalProcess lproc . h)
328334

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+
329371
-- | Like 'expect' but with a timeout
330372
expectTimeout :: forall a. Serializable a => Int -> Process (Maybe a)
331373
expectTimeout timeout = receiveTimeout timeout [match return]
@@ -464,7 +506,7 @@ unClosure :: forall a. Typeable a => Closure a -> Process a
464506
unClosure (Closure (Static label) env) = do
465507
rtable <- remoteTable . processNode <$> ask
466508
case resolveClosure rtable label env of
467-
Nothing -> throw . userError $ "Unregistered closure " ++ show label
509+
Nothing -> error $ "Unregistered closure " ++ show label
468510
Just dyn -> return $ fromDyn dyn (throw (typeError dyn))
469511
where
470512
typeError dyn = userError $ "lookupStatic type error: "

‎distributed-process/src/Control/Distributed/Process/Node.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -121,7 +121,7 @@ import Control.Distributed.Process.Internal.Node
121121
, sendMessage
122122
, sendPayload
123123
)
124-
import Control.Distributed.Process.Internal.Primitives (expect, register)
124+
import Control.Distributed.Process.Internal.Primitives (expect, register, finally)
125125
import qualified Control.Distributed.Process.Internal.Closure.Static as Static (__remoteTable)
126126
import qualified Control.Distributed.Process.Internal.Closure.CP as CP (__remoteTable)
127127

@@ -189,7 +189,7 @@ closeLocalNode node =
189189
runProcess :: LocalNode -> Process () -> IO ()
190190
runProcess node proc = do
191191
done <- newEmptyMVar
192-
void $ forkProcess node (proc >> liftIO (putMVar done ()))
192+
void $ forkProcess node (proc `finally` liftIO (putMVar done ()))
193193
takeMVar done
194194

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

0 commit comments

Comments
 (0)