git.iko.soy/distributed-process
on master help sign in
allow tracing to utilise the built in logger process
commit628f4964873f035736ad12d68b1be2692678ad7d authorTim Watson <tim@rabbitmq.com> dateFri 25 Jan 2013, 11:04 (14 years ago) parent5377327
3 files changed+78−32
compare with master
unifiedsplit
distributed-process/src/Control/Distributed/Process/Internal/Trace.hs+48−8 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+4−2 distributed-process/src/Control/Distributed/Process/Node.hs+26−22
distributed-process/src/Control/Distributed/Process/Internal/Trace.hs+48−8
@@ -1,14 +1,15 @@
11-- | Simple (internal) system logging/tracing support.
22module Control.Distributed.Process.Internal.Trace
33 ( Tracer
4+ , TraceArg(..)
45 , trace
56 , traceFormat
6− , defaultTracer
7− , logfileTracer
7+ , startTracing
88 , stopTracer
99 ) where
1010
1111import Control.Concurrent (forkIO)
12+import Control.Concurrent.Chan (writeChan)
1213import Control.Concurrent.STM
1314 ( TQueue
1415 , newTQueueIO
@@ -17,8 +18,14 @@ import Control.Concurrent.STM
1718 , atomically
1819 )
1920import Control.Distributed.Process.Internal.Types
20− ( forever'
21− , Tracer(..)
21+ ( Tracer(..)
22+ , LocalNode(..)
23+ , NCMsg(..)
24+ , Identifier(ProcessIdentifier)
25+ , ProcessSignal(NamedSend)
26+ , forever'
27+ , nullProcessId
28+ , createMessage
2229 )
2330import Control.Exception
2431 ( catch
@@ -45,10 +52,26 @@ import System.IO
4552 )
4653import System.Locale (defaultTimeLocale)
4754
48−defaultTracer :: IO Tracer
49−defaultTracer = do
55+data TraceArg =
56+ TraceStr String
57+ | forall a. (Show a) => Trace a
58+
59+startTracing :: LocalNode -> IO LocalNode
60+startTracing node = do
61+ tracer <- defaultTracer node
62+ return node { localTracer = tracer }
63+
64+defaultTracer :: LocalNode -> IO Tracer
65+defaultTracer node = do
5066 catch (getEnv "DISTRIBUTED_PROCESS_TRACE_FILE" >>= logfileTracer)
67+ (\(_ :: IOError) -> defaultTracerAux node)
68+
69+defaultTracerAux :: LocalNode -> IO Tracer
70+defaultTracerAux node = do
71+ catch (getEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" >> procTracer node)
5172 (\(_ :: IOError) -> return (EventLogTracer traceEventIO))
73+ where procTracer :: LocalNode -> IO Tracer
74+ procTracer n = return $ (LocalNodeTracer n)
5275
5376logfileTracer :: FilePath -> IO Tracer
5477logfileTracer p = do
@@ -72,11 +95,28 @@ stopTracer _ = return ()
7295
7396trace :: Tracer -> String -> IO ()
7497trace (LogFileTracer _ q _) msg = atomically $ writeTQueue q msg
98+trace (LocalNodeTracer n) msg = sendTraceMsg n msg
7599trace (EventLogTracer t) msg = t msg
100+trace InactiveTracer _ = return ()
76101
77102traceFormat :: Tracer
78103 -> String
79− -> [String]
104+ -> [TraceArg]
80105 -> IO ()
81−traceFormat t d ls = trace t $ concat (intersperse d ls)
106+traceFormat t d ls =
107+ trace t $ concat (intersperse d (map toS ls))
108+ where toS :: TraceArg -> String
109+ toS (TraceStr s) = s
110+ toS (Trace a) = show a
111+
112+sendTraceMsg :: LocalNode -> String -> IO ()
113+sendTraceMsg node string = do
114+ now <- getCurrentTime
115+ msg <- return $ (formatTime defaultTimeLocale "%c" now, string)
116+ emptyPid <- return $ (nullProcessId (localNodeId node))
117+ traceMsg <- return $ NCMsg {
118+ ctrlMsgSender = ProcessIdentifier (emptyPid)
119+ , ctrlMsgSignal = (NamedSend "logger" (createMessage msg))
120+ }
121+ writeChan (localCtrlChan node) traceMsg
82122
distributed-process/src/Control/Distributed/Process/Internal/Types.hs+4−2
@@ -182,8 +182,10 @@ nullProcessId nid =
182182
183183-- | Required for system tracing in the node controller
184184data Tracer =
185− LogFileTracer !ThreadId !(STM.TQueue String) !Handle
186− | EventLogTracer !(String -> IO ())
185+ LogFileTracer !ThreadId !(STM.TQueue String) !Handle
186+ | EventLogTracer !(String -> IO ())
187+ | LocalNodeTracer !LocalNode
188+ | InactiveTracer -- NB: never used, this is required to initialize LocalNode
187189
188190-- | Local nodes
189191data LocalNode = LocalNode
distributed-process/src/Control/Distributed/Process/Node.hs+26−22
@@ -99,7 +99,7 @@ import Control.Distributed.Process.Internal.Types
9999 , LocalProcessId(..)
100100 , ProcessId(..)
101101 , LocalNode(..)
102− , Tracer
102+ , Tracer(InactiveTracer)
103103 , LocalNodeState(..)
104104 , LocalProcess(..)
105105 , LocalProcessState(..)
@@ -144,9 +144,9 @@ import Control.Distributed.Process.Internal.Types
144144 , ImplicitReconnect(WithImplicitReconnect, NoImplicitReconnect)
145145 )
146146import Control.Distributed.Process.Internal.Trace
147− ( trace
147+ ( TraceArg(..)
148148 , traceFormat
149− , defaultTracer
149+ , startTracing
150150 , stopTracer
151151 )
152152import Control.Distributed.Process.Serializable (Serializable)
@@ -200,18 +200,18 @@ createBareLocalNode endPoint rtable = do
200200 , _localPidUnique = unq
201201 , _localConnections = Map.empty
202202 }
203− tracer <- defaultTracer
204203 ctrlChan <- newChan
205204 let node = LocalNode { localNodeId = NodeId $ NT.address endPoint
206205 , localEndPoint = endPoint
207206 , localState = state
208207 , localCtrlChan = ctrlChan
209− , localTracer = tracer
208+ , localTracer = InactiveTracer
210209 , remoteTable = rtable
211210 }
212− void . forkIO $ runNodeController node
213− void . forkIO $ handleIncomingMessages node
214− return node
211+ tracedNode <- startTracing node
212+ void . forkIO $ runNodeController tracedNode
213+ void . forkIO $ handleIncomingMessages tracedNode
214+ return tracedNode
215215
216216-- | Start and register the service processes on a node
217217-- (for now, this is only the logger)
@@ -225,6 +225,10 @@ startServiceProcesses node = do
225225 [ match $ \((time, pid, string) ::(String, ProcessId, String)) -> do
226226 liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string
227227 loop
228+ , match $ \((time, string) :: (String, String)) -> do
229+ -- this is a 'trace' message from the local node tracer
230+ liftIO . hPutStrLn stderr $ time ++ " [trace] " ++ string
231+ loop
228232 , match $ \(ch :: SendPort ()) -> -- a shutdown request
229233 sendChan ch ()
230234 ]
@@ -431,15 +435,18 @@ handleIncomingMessages node = go initConnectionState
431435 $ st
432436 )
433437 NT.ErrorEvent (NT.TransportError NT.EventEndPointFailed str) ->
434− fail $ "Cloud Haskell fatal error: end point failed: " ++ str
438+ fatal $ "Cloud Haskell fatal error: end point failed: " ++ str
435439 NT.ErrorEvent (NT.TransportError NT.EventTransportFailed str) ->
436− fail $ "Cloud Haskell fatal error: transport failed: " ++ str
440+ fatal $ "Cloud Haskell fatal error: transport failed: " ++ str
437441 NT.EndPointClosed ->
438− return ()
442+ stopTracer (localTracer node) >> return ()
439443 NT.ReceivedMulticast _ _ ->
440444 -- If we received a multicast message, something went horribly wrong
441445 -- and we just give up
442− fail "Cloud Haskell fatal error: received unexpected multicast"
446+ fatal "Cloud Haskell fatal error: received unexpected multicast"
447+
448+ fatal :: String -> IO ()
449+ fatal msg = stopTracer (localTracer node) >> fail msg
443450
444451 invalidRequest :: NT.ConnectionId -> ConnectionState -> IO ()
445452 invalidRequest cid st = do
@@ -447,7 +454,8 @@ handleIncomingMessages node = go initConnectionState
447454 -- node. That is, we should report the remote node as having died, and we
448455 -- should close incoming connections (this requires a Transport layer
449456 -- extension).
450− traceEventFmtIO node "" ["[network] invalid request: ", (show cid)]
457+ traceEventFmtIO node "" [(TraceStr "[network] invalid request: "),
458+ (Trace cid)]
451459 go ( incomingAt cid ^= Nothing
452460 $ st
453461 )
@@ -510,21 +518,17 @@ traceNotifyDied node ident reason =
510518 case reason of
511519 DiedNormal -> return ()
512520 _ -> traceNcEventFmt node " "
513− ["[node-controller]", (show ident), (show reason)]
521+ [(TraceStr "[node-controller]"),
522+ (Trace ident),
523+ (Trace reason)]
514524
515−traceNcEvent :: LocalNode -> String -> NC ()
516−traceNcEvent node msg = liftIO $ traceEventIO node msg
517−
518−traceNcEventFmt :: LocalNode -> String -> [String] -> NC ()
525+traceNcEventFmt :: LocalNode -> String -> [TraceArg] -> NC ()
519526traceNcEventFmt node fmt args =
520527 liftIO $ traceEventFmtIO node fmt args
521528
522−traceEventIO :: LocalNode -> String -> IO ()
523−traceEventIO node msg = withLocalTracer node $ \t -> trace t msg
524−
525529traceEventFmtIO :: LocalNode
526530 -> String
527− -> [String]
531+ -> [TraceArg]
528532 -> IO ()
529533traceEventFmtIO node fmt args =
530534 withLocalTracer node $ \t -> traceFormat t fmt args