628f496 · distributed-process

git.iko.soy/distributed-process

on master help sign in

allow tracing to utilise the built in logger process

628f496Tim Watson14 years ago

distributed-process/src/Control/Distributed/Process/Internal/Trace.hs+48−8

compare with master

unifiedsplit

@@ -1,14 +1,15 @@

1-- | Simple (internal) system logging/tracing support.

2module Control.Distributed.Process.Internal.Trace

3 ( Tracer

4+ , TraceArg(..)

4 , trace

5 , trace

5 , traceFormat

6 , traceFormat

6− , defaultTracer

7+ , startTracing

7− , logfileTracer

8 , stopTracer

9 ) where

11import Control.Concurrent (forkIO)

12+import Control.Concurrent.Chan (writeChan)

12import Control.Concurrent.STM

13import Control.Concurrent.STM

13 ( TQueue

14 ( TQueue

14 , newTQueueIO

15 , newTQueueIO

@@ -17,8 +18,14 @@ import Control.Concurrent.STM

17 , atomically

18 , atomically

18 )

19 )

19import Control.Distributed.Process.Internal.Types

20import Control.Distributed.Process.Internal.Types

21+ ( Tracer(..)

22+ , LocalNode(..)

23+ , NCMsg(..)

24+ , Identifier(ProcessIdentifier)

25+ , ProcessSignal(NamedSend)

20− ( forever'

26+ , forever'

21− , Tracer(..)

27+ , nullProcessId

28+ , createMessage

22 )

29 )

23import Control.Exception

30import Control.Exception

24 ( catch

31 ( catch

@@ -45,10 +52,26 @@ import System.IO

45 )

52 )

46import System.Locale (defaultTimeLocale)

53import System.Locale (defaultTimeLocale)

55+data TraceArg =

56+ TraceStr String

57+ | forall a. (Show a) => Trace a

58+

59+startTracing :: LocalNode -> IO LocalNode

60+startTracing node = do

48−defaultTracer :: IO Tracer

61+ tracer <- defaultTracer node

62+ return node { localTracer = tracer }

63+

64+defaultTracer :: LocalNode -> IO Tracer

49−defaultTracer = do

65+defaultTracer node = do

50 catch (getEnv "DISTRIBUTED_PROCESS_TRACE_FILE" >>= logfileTracer)

66 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)

51 (\(_ :: IOError) -> return (EventLogTracer traceEventIO))

72 (\(_ :: IOError) -> return (EventLogTracer traceEventIO))

73+ where procTracer :: LocalNode -> IO Tracer

74+ procTracer n = return $ (LocalNodeTracer n)

53logfileTracer :: FilePath -> IO Tracer

76logfileTracer :: FilePath -> IO Tracer

54logfileTracer p = do

77logfileTracer p = do

@@ -72,11 +95,28 @@ stopTracer _ = return ()

73trace :: Tracer -> String -> IO ()

96trace :: Tracer -> String -> IO ()

74trace (LogFileTracer _ q _) msg = atomically $ writeTQueue q msg

97trace (LogFileTracer _ q _) msg = atomically $ writeTQueue q msg

98+trace (LocalNodeTracer n) msg = sendTraceMsg n msg

75trace (EventLogTracer t) msg = t msg

99trace (EventLogTracer t) msg = t msg

100+trace InactiveTracer _ = return ()

101

77traceFormat :: Tracer

102traceFormat :: Tracer

78 -> String

103 -> String

79− -> [String]

104+ -> [TraceArg]

80 -> IO ()

105 -> IO ()

106+traceFormat t d ls =

81−traceFormat t d ls = trace t $ concat (intersperse 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

122

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+4−2

@@ -182,8 +182,10 @@ nullProcessId nid =

182

183-- | Required for system tracing in the node controller

184data Tracer =

185− LogFileTracer !ThreadId !(STM.TQueue String) !Handle

185+ LogFileTracer !ThreadId !(STM.TQueue String) !Handle

186− | EventLogTracer !(String -> IO ())

186+ | EventLogTracer !(String -> IO ())

187+ | LocalNodeTracer !LocalNode

188+ | InactiveTracer -- NB: never used, this is required to initialize LocalNode

187

189

188-- | Local nodes

190-- | Local nodes

189data LocalNode = LocalNode

191data LocalNode = LocalNode

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

@@ -99,7 +99,7 @@ import Control.Distributed.Process.Internal.Types

99 , LocalProcessId(..)

100 , ProcessId(..)

101 , LocalNode(..)

102− , Tracer

102+ , Tracer(InactiveTracer)

103 , LocalNodeState(..)

104 , LocalProcess(..)

105 , LocalProcessState(..)

@@ -144,9 +144,9 @@ import Control.Distributed.Process.Internal.Types

144 , ImplicitReconnect(WithImplicitReconnect, NoImplicitReconnect)

145 )

146import Control.Distributed.Process.Internal.Trace

147− ( trace

147+ ( TraceArg(..)

148 , traceFormat

149− , defaultTracer

149+ , startTracing

150 , stopTracer

151 )

152import Control.Distributed.Process.Serializable (Serializable)

@@ -200,18 +200,18 @@ createBareLocalNode endPoint rtable = do

200 , _localPidUnique = unq

201 , _localConnections = Map.empty

202 }

203− tracer <- defaultTracer

204 ctrlChan <- newChan

203 ctrlChan <- newChan

205 let node = LocalNode { localNodeId = NodeId $ NT.address endPoint

204 let node = LocalNode { localNodeId = NodeId $ NT.address endPoint

206 , localEndPoint = endPoint

205 , localEndPoint = endPoint

207 , localState = state

206 , localState = state

208 , localCtrlChan = ctrlChan

207 , localCtrlChan = ctrlChan

209− , localTracer = tracer

208+ , localTracer = InactiveTracer

210 , remoteTable = rtable

209 , remoteTable = rtable

211 }

210 }

211+ tracedNode <- startTracing node

212− void . forkIO $ runNodeController node

212+ void . forkIO $ runNodeController tracedNode

213− void . forkIO $ handleIncomingMessages node

213+ void . forkIO $ handleIncomingMessages tracedNode

214− return node

214+ return tracedNode

215

216-- | Start and register the service processes on a node

217-- (for now, this is only the logger)

@@ -225,6 +225,10 @@ startServiceProcesses node = do

225 [ match $ \((time, pid, string) ::(String, ProcessId, String)) -> do

226 liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string

227 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

228 , match $ \(ch :: SendPort ()) -> -- a shutdown request

232 , match $ \(ch :: SendPort ()) -> -- a shutdown request

229 sendChan ch ()

233 sendChan ch ()

230 ]

234 ]

@@ -431,15 +435,18 @@ handleIncomingMessages node = go initConnectionState

431 $ st

435 $ st

432 )

436 )

433 NT.ErrorEvent (NT.TransportError NT.EventEndPointFailed str) ->

437 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

435 NT.ErrorEvent (NT.TransportError NT.EventTransportFailed str) ->

439 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

437 NT.EndPointClosed ->

441 NT.EndPointClosed ->

438− return ()

442+ stopTracer (localTracer node) >> return ()

439 NT.ReceivedMulticast _ _ ->

443 NT.ReceivedMulticast _ _ ->

440 -- If we received a multicast message, something went horribly wrong

444 -- If we received a multicast message, something went horribly wrong

441 -- and we just give up

445 -- 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

443

450

444 invalidRequest :: NT.ConnectionId -> ConnectionState -> IO ()

451 invalidRequest :: NT.ConnectionId -> ConnectionState -> IO ()

445 invalidRequest cid st = do

452 invalidRequest cid st = do

@@ -447,7 +454,8 @@ handleIncomingMessages node = go initConnectionState

447 -- node. That is, we should report the remote node as having died, and we

454 -- node. That is, we should report the remote node as having died, and we

448 -- should close incoming connections (this requires a Transport layer

455 -- should close incoming connections (this requires a Transport layer

449 -- extension).

456 -- extension).

450− traceEventFmtIO node "" ["[network] invalid request: ", (show cid)]

457+ traceEventFmtIO node "" [(TraceStr "[network] invalid request: "),

458+ (Trace cid)]

451 go ( incomingAt cid ^= Nothing

459 go ( incomingAt cid ^= Nothing

452 $ st

460 $ st

453 )

461 )

@@ -510,21 +518,17 @@ traceNotifyDied node ident reason =

510 case reason of

518 case reason of

511 DiedNormal -> return ()

519 DiedNormal -> return ()

512 _ -> traceNcEventFmt node " "

520 _ -> traceNcEventFmt node " "

513− ["[node-controller]", (show ident), (show reason)]

521+ [(TraceStr "[node-controller]"),

522+ (Trace ident),

523+ (Trace reason)]

514

524

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 ()

519traceNcEventFmt node fmt args =

526traceNcEventFmt node fmt args =

520 liftIO $ traceEventFmtIO node fmt args

527 liftIO $ traceEventFmtIO node fmt args

521

528

522−traceEventIO :: LocalNode -> String -> IO ()

523−traceEventIO node msg = withLocalTracer node $ \t -> trace t msg

524−

525traceEventFmtIO :: LocalNode

529traceEventFmtIO :: LocalNode

526 -> String

530 -> String

527− -> [String]

531+ -> [TraceArg]

528 -> IO ()

532 -> IO ()

529traceEventFmtIO node fmt args =

533traceEventFmtIO node fmt args =

530 withLocalTracer node $ \t -> traceFormat t fmt args

534 withLocalTracer node $ \t -> traceFormat t fmt args