git.iko.soy/distributed-process
on master help sign in
tracers are set on startup and immutable thereafter
commit96f28d36f34eab8be8d6489417ad8fed38097584 authorTim Watson <tim@rabbitmq.com> dateThu 24 Jan 2013, 22:57 (14 years ago) parenta05fd81
4 files changed+129−80
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+12 distributed-process/src/Control/Distributed/Process/Internal/Trace.hs+26−29 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+37−28 distributed-process/src/Control/Distributed/Process/Node.hs+54−23
distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs+12
@@ -83,6 +83,8 @@ module Control.Distributed.Process.Internal.Primitives
8383 -- * Reconnecting
8484 , reconnect
8585 , reconnectPort
86+ -- * Tracing/Debugging
87+ , trace
8688 ) where
8789
8890#if ! MIN_VERSION_base(4,6,0)
@@ -168,6 +170,7 @@ import Control.Distributed.Process.Internal.Messaging
168170 , sendPayload
169171 , disconnect
170172 )
173+import qualified Control.Distributed.Process.Internal.Trace as Trace
171174import Control.Distributed.Process.Internal.WeakTQueue
172175 ( newTQueueIO
173176 , readTQueue
@@ -892,6 +895,15 @@ reconnectPort them = do
892895 node <- processNode <$> ask
893896 liftIO $ disconnect node (ProcessIdentifier us) (SendPortIdentifier (sendPortId them))
894897
898+--------------------------------------------------------------------------------
899+-- Debugging/Tracing --
900+--------------------------------------------------------------------------------
901+
902+trace :: String -> Process ()
903+trace s = do
904+ node <- processNode <$> ask
905+ liftIO $ Trace.trace (localTracer node) s
906+
895907--------------------------------------------------------------------------------
896908-- Auxiliary functions --
897909--------------------------------------------------------------------------------
distributed-process/src/Control/Distributed/Process/Internal/Trace.hs+26−29
@@ -3,16 +3,12 @@ module Control.Distributed.Process.Internal.Trace
33 ( Tracer
44 , trace
55 , traceFormat
6− , startEventlogTracer
7− , startLogfileTracer
86 , defaultTracer
7+ , logfileTracer
98 , stopTracer
109 ) where
1110
12−import Control.Concurrent
13− ( ThreadId
14− , forkIO
15− )
11+import Control.Concurrent (forkIO)
1612import Control.Concurrent.STM
1713 ( TQueue
1814 , newTQueueIO
@@ -20,25 +16,28 @@ import Control.Concurrent.STM
2016 , writeTQueue
2117 , atomically
2218 )
23−import Control.Distributed.Process.Internal.Types (forever')
24−import Control.Exception
25−import Data.List (foldl')
19+import Control.Distributed.Process.Internal.Types (forever', Tracer(..))
20+import Control.Exception (catch, throwTo, AsyncException(ThreadKilled))
21+import Data.List (intersperse)
2622import Debug.Trace (traceEventIO)
27−import System.IO
2823
29−data Tracer =
30− LogFileTracer ThreadId (TQueue String)
31− | EventLogTracer (String -> IO ())
32− | NoOpTracer
24+import Prelude hiding (catch)
3325
34−defaultTracer :: IO Tracer
35−defaultTracer = return NoOpTracer
26+import System.Environment (getEnv)
27+import System.IO
28+ ( Handle
29+ , IOMode(AppendMode)
30+ , withFile
31+ , hPutStr
32+ )
3633
37−startEventlogTracer :: IO Tracer
38−startEventlogTracer = return $ EventLogTracer traceEventIO
34+defaultTracer :: IO Tracer
35+defaultTracer = do
36+ catch (getEnv "DISTRIBUTED_PROCESS_TRACE_FILE" >>= logfileTracer)
37+ (\(_ :: IOError) -> return (EventLogTracer traceEventIO))
3938
40−startLogfileTracer :: FilePath -> IO Tracer
41−startLogfileTracer p = do
39+logfileTracer :: FilePath -> IO Tracer
40+logfileTracer p = do
4241 q <- newTQueueIO
4342 tid <- forkIO $ withFile p AppendMode (\h -> logger h q)
4443 return $ LogFileTracer tid q
@@ -48,21 +47,19 @@ startLogfileTracer p = do
4847 hPutStr h msg
4948 logger h q'
5049
50+-- TODO: compatibility layer (conditional compilation?) for GHC/base versions
51+
5152stopTracer :: Tracer -> IO ()
52−stopTracer (LogFileTracer tid _) = throwTo tid ThreadKilled
53+stopTracer (LogFileTracer tid _) = throwTo tid ThreadKilled -- cf killThread
5354stopTracer _ = return ()
5455
5556trace :: Tracer -> String -> IO ()
5657trace (LogFileTracer _ q) msg = atomically $ writeTQueue q msg
5758trace (EventLogTracer t) msg = t msg
58−trace NoOpTracer _ = return ()
5959
60−traceFormat :: (Show a)
61− => Tracer
62− -> (String -> String -> String)
63− -> [a]
60+traceFormat :: Tracer
61+ -> String
62+ -> [String]
6463 -> IO ()
65−traceFormat NoOpTracer _ _ = return ()
66−traceFormat t f xs =
67− trace t $ foldl' (\e a -> ((show e) `f` (show a))) "" xs
64+traceFormat t d ls = trace t $ concat (intersperse d ls)
6865
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+37−28
@@ -14,6 +14,7 @@ module Control.Distributed.Process.Internal.Types
1414 , nullProcessId
1515 -- * Local nodes and processes
1616 , LocalNode(..)
17+ , Tracer(..)
1718 , LocalNodeState(..)
1819 , LocalProcess(..)
1920 , LocalProcessState(..)
@@ -90,6 +91,7 @@ import Control.Exception (Exception)
9091import Control.Concurrent (ThreadId)
9192import Control.Concurrent.Chan (Chan)
9293import Control.Concurrent.STM (STM)
94+import qualified Control.Concurrent.STM as STM (TQueue)
9395import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
9496import Control.Applicative (Applicative, Alternative, (<$>), (<*>))
9597import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)
@@ -177,19 +179,26 @@ nullProcessId nid =
177179-- Local nodes and processes --
178180--------------------------------------------------------------------------------
179181
182+-- | Required for system tracing in the node controller
183+data Tracer =
184+ LogFileTracer ThreadId (STM.TQueue String)
185+ | EventLogTracer (String -> IO ())
186+
180187-- | Local nodes
181188data LocalNode = LocalNode
182189 { -- | 'NodeId' of the node
183− localNodeId :: !NodeId
190+ localNodeId :: !NodeId
184191 -- | The network endpoint associated with this node
185− , localEndPoint :: !NT.EndPoint
192+ , localEndPoint :: !NT.EndPoint
186193 -- | Local node state
187− , localState :: !(StrictMVar LocalNodeState)
194+ , localState :: !(StrictMVar LocalNodeState)
188195 -- | Channel for the node controller
189− , localCtrlChan :: !(Chan NCMsg)
196+ , localCtrlChan :: !(Chan NCMsg)
197+ -- | Current active system debug/trace log
198+ , localTracer :: !Tracer
190199 -- | Runtime lookup table for supporting closures
191200 -- TODO: this should be part of the CH state, not the local endpoint state
192− , remoteTable :: !RemoteTable
201+ , remoteTable :: !RemoteTable
193202 }
194203
195204data ImplicitReconnect = WithImplicitReconnect | NoImplicitReconnect
@@ -434,7 +443,7 @@ data WhereIsReply = WhereIsReply String (Maybe ProcessId)
434443data RegisterReply = RegisterReply String Bool
435444 deriving (Show, Typeable)
436445
437−-- | Provide information about a running process
446+-- | Provide information about a running process
438447data ProcessInfo = ProcessInfo {
439448 infoNode :: NodeId
440449 , infoRegisteredNames :: [String]
@@ -443,21 +452,9 @@ data ProcessInfo = ProcessInfo {
443452 , infoLinks :: [ProcessId]
444453 } deriving (Show, Eq, Typeable)
445454
446−instance Binary ProcessInfo where
447− get = ProcessInfo <$> get <*> get <*> get <*> get <*> get
448− put pInfo = put (infoNode pInfo)
449− >> put (infoRegisteredNames pInfo)
450− >> put (infoMessageQueueLength pInfo)
451− >> put (infoMonitors pInfo)
452− >> put (infoLinks pInfo)
453−
454455data ProcessInfoNone = ProcessInfoNone DiedReason
455456 deriving (Show, Typeable)
456457
457−instance Binary ProcessInfoNone where
458− get = ProcessInfoNone <$> get
459− put (ProcessInfoNone r) = put r
460−
461458--------------------------------------------------------------------------------
462459-- Node controller internal data types --
463460--------------------------------------------------------------------------------
@@ -533,16 +530,16 @@ instance Binary ProcessSignal where
533530 get = do
534531 header <- getWord8
535532 case header of
536− 0 -> Link <$> get
537− 1 -> Unlink <$> get
538− 2 -> Monitor <$> get
539− 3 -> Unmonitor <$> get
540− 4 -> Died <$> get <*> get
541− 5 -> Spawn <$> get <*> get
542− 6 -> WhereIs <$> get
543− 7 -> Register <$> get <*> get <*> get <*> get
544− 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)
545− 9 -> Kill <$> get <*> get
533+ 0 -> Link <$> get
534+ 1 -> Unlink <$> get
535+ 2 -> Monitor <$> get
536+ 3 -> Unmonitor <$> get
537+ 4 -> Died <$> get <*> get
538+ 5 -> Spawn <$> get <*> get
539+ 6 -> WhereIs <$> get
540+ 7 -> Register <$> get <*> get <*> get <*> get
541+ 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)
542+ 9 -> Kill <$> get <*> get
546543 10 -> Exit <$> get <*> (payloadToMessage <$> get)
547544 30 -> GetInfo <$> get
548545 _ -> fail "ProcessSignal.get: invalid"
@@ -591,6 +588,18 @@ instance Binary RegisterReply where
591588 put (RegisterReply label ok) = put label >> put ok
592589 get = RegisterReply <$> get <*> get
593590
591+instance Binary ProcessInfo where
592+ get = ProcessInfo <$> get <*> get <*> get <*> get <*> get
593+ put pInfo = put (infoNode pInfo)
594+ >> put (infoRegisteredNames pInfo)
595+ >> put (infoMessageQueueLength pInfo)
596+ >> put (infoMonitors pInfo)
597+ >> put (infoLinks pInfo)
598+
599+instance Binary ProcessInfoNone where
600+ get = ProcessInfoNone <$> get
601+ put (ProcessInfoNone r) = put r
602+
594603--------------------------------------------------------------------------------
595604-- Accessors --
596605--------------------------------------------------------------------------------
distributed-process/src/Control/Distributed/Process/Node.hs+54−23
@@ -42,7 +42,6 @@ import qualified Data.Set as Set
4242import Data.Foldable (forM_)
4343import Data.Maybe (isJust, isNothing, catMaybes)
4444import Data.Typeable (Typeable)
45−import Debug.Trace
4645import Control.Category ((>>>))
4746import Control.Applicative ((<$>))
4847import Control.Monad (void, when)
@@ -63,7 +62,9 @@ import Control.Distributed.Process.Internal.StrictMVar
6362 , takeMVar
6463 )
6564import Control.Concurrent.Chan (newChan, writeChan, readChan)
66−import Control.Concurrent.STM (atomically)
65+import Control.Concurrent.STM
66+ ( atomically
67+ )
6768import Control.Distributed.Process.Internal.CQueue
6869 ( CQueue
6970 , enqueue
@@ -98,6 +99,7 @@ import Control.Distributed.Process.Internal.Types
9899 , LocalProcessId(..)
99100 , ProcessId(..)
100101 , LocalNode(..)
102+ , Tracer
101103 , LocalNodeState(..)
102104 , LocalProcess(..)
103105 , LocalProcessState(..)
@@ -141,6 +143,12 @@ import Control.Distributed.Process.Internal.Types
141143 , firstNonReservedProcessId
142144 , ImplicitReconnect(WithImplicitReconnect, NoImplicitReconnect)
143145 )
146+import Control.Distributed.Process.Internal.Trace
147+ ( trace
148+ , traceFormat
149+ , defaultTracer
150+ , stopTracer
151+ )
144152import Control.Distributed.Process.Serializable (Serializable)
145153import Control.Distributed.Process.Internal.Messaging
146154 ( sendBinary
@@ -192,11 +200,13 @@ createBareLocalNode endPoint rtable = do
192200 , _localPidUnique = unq
193201 , _localConnections = Map.empty
194202 }
203+ tracer <- defaultTracer
195204 ctrlChan <- newChan
196205 let node = LocalNode { localNodeId = NodeId $ NT.address endPoint
197206 , localEndPoint = endPoint
198207 , localState = state
199208 , localCtrlChan = ctrlChan
209+ , localTracer = tracer
200210 , remoteTable = rtable
201211 }
202212 void . forkIO $ runNodeController node
@@ -219,13 +229,6 @@ startServiceProcesses node = do
219229 sendChan ch ()
220230 ]
221231
222−-- | Send a message to the GHC event log
223−logEvent :: String -> IO ()
224−logEvent = traceEventIO
225−
226−logExit :: ProcessId -> DiedReason -> IO ()
227−logExit p r = logEvent $ (show p) ++ " exited: " ++ (show r)
228−
229232-- | Force-close a local node
230233--
231234-- TODO: for now we just close the associated endpoint
@@ -272,9 +275,6 @@ forkProcess node proc = modifyMVar (localState node) startProcess
272275 (runLocalProcess lproc proc >> return DiedNormal)
273276 (return . DiedException . (show :: SomeException -> String))
274277
275− -- [Issue #104]
276− logExit pid reason
277−
278278 -- [Unified: Table 4, rules termination and exiting]
279279 modifyMVar_ (localState node) (cleanupProcess pid)
280280 writeChan (localCtrlChan node) NCMsg
@@ -442,11 +442,12 @@ handleIncomingMessages node = go initConnectionState
442442 fail "Cloud Haskell fatal error: received unexpected multicast"
443443
444444 invalidRequest :: NT.ConnectionId -> ConnectionState -> IO ()
445− invalidRequest cid st =
445+ invalidRequest cid st = do
446446 -- TODO: We should treat this as a fatal error on the part of the remote
447447 -- node. That is, we should report the remote node as having died, and we
448448 -- should close incoming connections (this requires a Transport layer
449449 -- extension).
450+ traceEventFmtIO node "" ["[network] invalid request: ", (show cid)]
450451 go ( incomingAt cid ^= Nothing
451452 $ st
452453 )
@@ -498,6 +499,36 @@ instance Show ProcessKillException where
498499 show (ProcessKillException pid reason) =
499500 "killed-by=" ++ show pid ++ ",reason=" ++ reason
500501
502+--------------------------------------------------------------------------------
503+-- Tracing/Debugging --
504+--------------------------------------------------------------------------------
505+
506+-- [Issue #104]
507+
508+traceNotifyDied :: LocalNode -> Identifier -> DiedReason -> NC ()
509+traceNotifyDied node ident reason =
510+ traceNcEventFmt node " " ["[node-controller]", (show ident), (show reason)]
511+
512+traceNcEvent :: LocalNode -> String -> NC ()
513+traceNcEvent node msg = liftIO $ traceEventIO node msg
514+
515+traceNcEventFmt :: LocalNode -> String -> [String] -> NC ()
516+traceNcEventFmt node fmt args =
517+ liftIO $ traceEventFmtIO node fmt args
518+
519+traceEventIO :: LocalNode -> String -> IO ()
520+traceEventIO node msg = withLocalTracer node $ \t -> trace t msg
521+
522+traceEventFmtIO :: LocalNode
523+ -> String
524+ -> [String]
525+ -> IO ()
526+traceEventFmtIO node fmt args =
527+ withLocalTracer node $ \t -> traceFormat t fmt args
528+
529+withLocalTracer :: LocalNode -> (Tracer -> IO ()) -> IO ()
530+withLocalTracer node act = act (localTracer node)
531+
501532--------------------------------------------------------------------------------
502533-- Core functionality --
503534--------------------------------------------------------------------------------
@@ -605,6 +636,7 @@ ncEffectUnmonitor from ref = do
605636ncEffectDied :: Identifier -> DiedReason -> NC ()
606637ncEffectDied ident reason = do
607638 node <- ask
639+ traceNotifyDied node ident reason
608640 (affectedLinks, unaffectedLinks) <- gets (splitNotif ident . (^. links))
609641 (affectedMons, unaffectedMons) <- gets (splitNotif ident . (^. monitors))
610642
@@ -647,7 +679,6 @@ ncEffectDied ident reason = do
647679 , ctrlMsgSignal = Died ident reason
648680 }
649681
650−
651682-- [Unified: Table 13]
652683ncEffectSpawn :: ProcessId -> Closure (Process ()) -> SpawnRef -> NC ()
653684ncEffectSpawn pid cProc ref = do
@@ -849,18 +880,18 @@ notifyDied dest src reason mRef = do
849880
850881-- | [Unified: Table 8]
851882destNid :: ProcessSignal -> Maybe NodeId
852−destNid (Link ident) = Just $ nodeOf ident
853−destNid (Unlink ident) = Just $ nodeOf ident
854−destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)
855−destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)
856−destNid (Spawn _ _) = Nothing
857−destNid (Register _ _ _ _) = Nothing
858−destNid (WhereIs _) = Nothing
859−destNid (NamedSend _ _) = Nothing
883+destNid (Link ident) = Just $ nodeOf ident
884+destNid (Unlink ident) = Just $ nodeOf ident
885+destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)
886+destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)
887+destNid (Spawn _ _) = Nothing
888+destNid (Register _ _ _ _) = Nothing
889+destNid (WhereIs _) = Nothing
890+destNid (NamedSend _ _) = Nothing
860891-- We don't need to forward 'Died' signals; if monitoring/linking is setup,
861892-- then when a local process dies the monitoring/linking machinery will take
862893-- care of notifying remote nodes
863−destNid (Died _ _) = Nothing
894+destNid (Died _ _) = Nothing
864895destNid (Kill pid _) = Just $ processNodeId pid
865896destNid (Exit pid _) = Just $ processNodeId pid
866897destNid (GetInfo pid) = Just $ processNodeId pid