git.iko.soy/distributed-process
on master help sign in
Deal with spawning invalid closures
commit464c6bae52c1d7724fe01c612b9dd8d3d34774df authorEdsko de Vries <edsko@edsko.net> dateFri 29 Jun 2012, 11:05 (14 years ago) parenta0c7adc
4 files changed+49−16
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process.hs+4 distributed-process/src/Control/Distributed/Process/Internal/Process/Primitives.hs+20 distributed-process/src/Control/Distributed/Process/Node.hs+12−16 distributed-process/tests/TestClosure.hs+13
distributed-process/src/Control/Distributed/Process.hs+4
@@ -59,6 +59,8 @@ module Control.Distributed.Process
5959 , expectTimeout
6060 , spawnAsync
6161 , spawnSupervised
62+ , spawnLink
63+ , spawnMonitor
6264 , DidSpawn(..)
6365 ) where
6466
@@ -127,6 +129,8 @@ import Control.Distributed.Process.Internal.Process.Primitives
127129 , catch
128130 , expectTimeout
129131 , spawnAsync
132+ , spawnLink
133+ , spawnMonitor
130134 )
131135import Control.Distributed.Process.Internal.Closure (resolveClosure)
132136
distributed-process/src/Control/Distributed/Process/Internal/Process/Primitives.hs+20
@@ -34,6 +34,8 @@ module Control.Distributed.Process.Internal.Process.Primitives
3434 , catch
3535 , expectTimeout
3636 , spawnAsync
37+ , spawnLink
38+ , spawnMonitor
3739 ) where
3840
3941import Prelude hiding (catch)
@@ -289,6 +291,24 @@ spawnAsync nid proc = do
289291 sendCtrlMsg (Just nid) $ Spawn proc spawnRef
290292 return spawnRef
291293
294+-- | Spawn a process and link to it
295+--
296+-- Note that this is just the sequential composition of 'spawn' and 'link'.
297+-- (The "Unified" semantics that underlies Cloud Haskell does not even support
298+-- a synchronous link operation)
299+spawnLink :: NodeId -> Closure (Process ()) -> Process ProcessId
300+spawnLink nid proc = do
301+ pid <- spawn nid proc
302+ link pid
303+ return pid
304+
305+-- | Like 'spawnLink', but monitor the spawned process
306+spawnMonitor :: NodeId -> Closure (Process ()) -> Process (ProcessId, MonitorRef)
307+spawnMonitor nid proc = do
308+ pid <- spawn nid proc
309+ ref <- monitor pid
310+ return (pid, ref)
311+
292312--------------------------------------------------------------------------------
293313-- Auxiliary functions --
294314--------------------------------------------------------------------------------
distributed-process/src/Control/Distributed/Process/Node.hs+12−16
@@ -18,7 +18,7 @@ import qualified Data.List as List (delete)
1818import Data.Set (Set)
1919import qualified Data.Set as Set (empty, insert, delete, member)
2020import Data.Foldable (forM_)
21−import Data.Maybe (isJust)
21+import Data.Maybe (isJust, fromMaybe)
2222import Data.Typeable (Typeable)
2323import Control.Category ((>>>))
2424import Control.Applicative ((<$>))
@@ -450,15 +450,12 @@ ncEffectProcessDied pid reason = do
450450ncEffectSpawn :: ProcessId -> Closure (Process ()) -> SpawnRef -> NC ()
451451ncEffectSpawn pid cProc ref = do
452452 mProc <- unClosure cProc
453− case mProc of
454− Just proc -> do
455− node <- ncMsg getLocalNode
456− pid' <- liftIO $ forkProcess node proc
457− ncMsg $ sendMessage (ProcessIdentifier pid) (DidSpawn ref pid')
458− Nothing ->
459− -- TODO: what should we do when unClosure returns Nothing?
460− liftIO . putStrLn $ "Error: closure " ++ show cProc ++ " not found"
461−
453+ -- If the closure does not exist, we spawn a process that throws an exception
454+ -- This allows the remote node to find out what's happening
455+ let proc = fromMaybe (fail $ "Error: unknown closure " ++ show cProc) mProc
456+ node <- ncMsg getLocalNode
457+ pid' <- liftIO $ forkProcess node proc
458+ ncMsg $ sendMessage (ProcessIdentifier pid) (DidSpawn ref pid')
462459
463460--------------------------------------------------------------------------------
464461-- Auxiliary --
@@ -494,12 +491,11 @@ destNid (Monitor pid _) =
494491 Just . processNodeId $ pid
495492destNid (Unmonitor ref) =
496493 Just . processNodeId . monitorRefPid $ ref
497−destNid (Died (NodeIdentifier _) _) =
498− Nothing
499−destNid (Died (ProcessIdentifier _pid) _) =
500− fail "destNid: TODO"
501−destNid (Died (ChannelIdentifier _cid) _) =
502− fail "destNid: TODO"
494+-- We don't need to forward 'Died' signals; if monitoring/linking is setup,
495+-- then when a local process dies the monitoring/linking machinery will take
496+-- care of notifying remote nodes
497+destNid (Died _ _) =
498+ Nothing
503499destNid (Spawn _ _) =
504500 Nothing
505501
distributed-process/tests/TestClosure.hs+13
@@ -1,5 +1,6 @@
11module Main where
22
3+import qualified Data.ByteString.Lazy as BSL (empty)
34import Control.Monad (join, replicateM)
45import Control.Monad.IO.Class (liftIO)
56import Control.Exception (IOException, throw)
@@ -11,6 +12,7 @@ import Network.Transport.TCP (createTransport, defaultTCPParameters)
1112import Control.Distributed.Process
1213import Control.Distributed.Process.Closure
1314import Control.Distributed.Process.Node
15+import Control.Distributed.Process.Internal.Types (Closure(..), Static(..), StaticLabel(..))
1416import TestAuxiliary
1517
1618serializableDictInt :: SerializableDict Int
@@ -244,6 +246,16 @@ testSpawnSupervised transport rtable = do
244246 supervisorDeath :: IOException
245247 supervisorDeath = userError "Supervisor died"
246248
249+testSpawnInvalid :: Transport -> RemoteTable -> IO ()
250+testSpawnInvalid transport rtable = do
251+ node <- newLocalNode transport rtable
252+ runProcess node $ do
253+ (pid, ref) <- spawnMonitor (localNodeId node) (Closure (Static (UserStatic "ThisDoesNotExist")) BSL.empty)
254+ MonitorNotification ref' pid' _reason <- expect
255+ -- Depending on the exact interleaving, reason might be NoProc or the exception thrown by the absence of the static closure
256+ True <- return $ ref' == ref && pid == pid'
257+ return ()
258+
247259main :: IO ()
248260main = do
249261 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
@@ -259,4 +271,5 @@ main = do
259271 , ("Seq", testSeq transport rtable)
260272 , ("Apply", testApply transport rtable)
261273 , ("SpawnSupervised", testSpawnSupervised transport rtable)
274+ , ("SpawnInvalid", testSpawnInvalid transport rtable)
262275 ]