allow tracing to utilise the built in logger process

Tim Watson · Tim Watson · commit 628f4964873f · 2013-01-26T17:02:00.000Z
diff --git a/distributed-process/src/Control/Distributed/Process/Internal/Trace.hs b/distributed-process/src/Control/Distributed/Process/Internal/Trace.hs
@@ -1,14 +1,15 @@
 -- | Simple (internal) system logging/tracing support.
 module Control.Distributed.Process.Internal.Trace
   ( Tracer
+  , TraceArg(..)
   , trace
   , traceFormat
-  , defaultTracer
-  , logfileTracer
+  , startTracing
   , stopTracer
   ) where
 
 import Control.Concurrent (forkIO)
+import Control.Concurrent.Chan (writeChan)
 import Control.Concurrent.STM
   ( TQueue
   , newTQueueIO
@@ -17,8 +18,14 @@ import Control.Concurrent.STM
   , atomically
   )
 import Control.Distributed.Process.Internal.Types
-  ( forever'
-  , Tracer(..)
+  ( Tracer(..)
+  , LocalNode(..)
+  , NCMsg(..)
+  , Identifier(ProcessIdentifier)
+  , ProcessSignal(NamedSend)
+  , forever'
+  , nullProcessId
+  , createMessage
   )
 import Control.Exception
   ( catch
@@ -45,10 +52,26 @@ import System.IO
   )
 import System.Locale (defaultTimeLocale)
 
-defaultTracer :: IO Tracer
-defaultTracer = do
+data TraceArg = 
+    TraceStr String
+  | forall a. (Show a) => Trace a
+
+startTracing :: LocalNode -> IO LocalNode
+startTracing node = do
+  tracer <- defaultTracer node
+  return node { localTracer = tracer }
+
+defaultTracer :: LocalNode -> IO Tracer
+defaultTracer node = do
   catch (getEnv "DISTRIBUTED_PROCESS_TRACE_FILE" >>= logfileTracer)
+        (\(_ :: IOError) -> defaultTracerAux node)
+
+defaultTracerAux :: LocalNode -> IO Tracer
+defaultTracerAux node = do
+  catch (getEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" >> procTracer node)
         (\(_ :: IOError) -> return (EventLogTracer traceEventIO))
+  where procTracer :: LocalNode -> IO Tracer
+        procTracer n = return $ (LocalNodeTracer n)
 
 logfileTracer :: FilePath -> IO Tracer
 logfileTracer p = do
@@ -72,11 +95,28 @@ stopTracer _                       = return ()
 
 trace :: Tracer -> String -> IO ()
 trace (LogFileTracer _ q _) msg = atomically $ writeTQueue q msg
+trace (LocalNodeTracer n)   msg = sendTraceMsg n msg
 trace (EventLogTracer t)    msg = t msg
+trace InactiveTracer        _   = return ()
 
 traceFormat :: Tracer
             -> String
-            -> [String]
+            -> [TraceArg]
             -> IO ()
-traceFormat t d ls = trace t $ concat (intersperse d ls)
+traceFormat t d ls =
+    trace t $ concat (intersperse d (map toS ls))
+  where toS :: TraceArg -> String
+        toS (TraceStr s) = s
+        toS (Trace    a) = show a
+
+sendTraceMsg :: LocalNode -> String -> IO ()
+sendTraceMsg node string = do
+  now <- getCurrentTime
+  msg <- return $ (formatTime defaultTimeLocale "%c" now, string)
+  emptyPid <- return $ (nullProcessId (localNodeId node))
+  traceMsg <- return $ NCMsg {
+                         ctrlMsgSender = ProcessIdentifier (emptyPid)
+                       , ctrlMsgSignal = (NamedSend "logger" (createMessage msg))
+                       }
+  writeChan (localCtrlChan node) traceMsg
 
diff --git a/distributed-process/src/Control/Distributed/Process/Internal/Types.hs b/distributed-process/src/Control/Distributed/Process/Internal/Types.hs
@@ -182,8 +182,10 @@ nullProcessId nid =
 
 -- | Required for system tracing in the node controller
 data Tracer =
-    LogFileTracer !ThreadId !(STM.TQueue String) !Handle
-  | EventLogTracer !(String -> IO ())
+    LogFileTracer   !ThreadId !(STM.TQueue String) !Handle
+  | EventLogTracer  !(String -> IO ())
+  | LocalNodeTracer !LocalNode
+  | InactiveTracer  -- NB: never used, this is required to initialize LocalNode
 
 -- | Local nodes
 data LocalNode = LocalNode
diff --git a/distributed-process/src/Control/Distributed/Process/Node.hs b/distributed-process/src/Control/Distributed/Process/Node.hs
@@ -99,7 +99,7 @@ import Control.Distributed.Process.Internal.Types
   , LocalProcessId(..)
   , ProcessId(..)
   , LocalNode(..)
-  , Tracer
+  , Tracer(InactiveTracer)
   , LocalNodeState(..)
   , LocalProcess(..)
   , LocalProcessState(..)
@@ -144,9 +144,9 @@ import Control.Distributed.Process.Internal.Types
   , ImplicitReconnect(WithImplicitReconnect, NoImplicitReconnect)
   )
 import Control.Distributed.Process.Internal.Trace
-  ( trace
+  ( TraceArg(..)
   , traceFormat
-  , defaultTracer
+  , startTracing
   , stopTracer
   )
 import Control.Distributed.Process.Serializable (Serializable)
@@ -200,18 +200,18 @@ createBareLocalNode endPoint rtable = do
     , _localPidUnique   = unq
     , _localConnections = Map.empty
     }
-  tracer <- defaultTracer
   ctrlChan <- newChan
   let node = LocalNode { localNodeId   = NodeId $ NT.address endPoint
                        , localEndPoint = endPoint
                        , localState    = state
                        , localCtrlChan = ctrlChan
-                       , localTracer   = tracer
+                       , localTracer   = InactiveTracer
                        , remoteTable   = rtable
                        }
-  void . forkIO $ runNodeController node
-  void . forkIO $ handleIncomingMessages node
-  return node
+  tracedNode <- startTracing node
+  void . forkIO $ runNodeController tracedNode
+  void . forkIO $ handleIncomingMessages tracedNode
+  return tracedNode
 
 -- | Start and register the service processes on a node
 -- (for now, this is only the logger)
@@ -225,6 +225,10 @@ startServiceProcesses node = do
       [ match $ \((time, pid, string) ::(String, ProcessId, String)) -> do
           liftIO . hPutStrLn stderr $ time ++ " " ++ show pid ++ ": " ++ string
           loop
+      , match $ \((time, string) :: (String, String)) -> do
+          -- this is a 'trace' message from the local node tracer
+          liftIO . hPutStrLn stderr $ time ++ " [trace] " ++ string
+          loop
       , match $ \(ch :: SendPort ()) -> -- a shutdown request
           sendChan ch ()
       ]
@@ -431,23 +435,27 @@ handleIncomingMessages node = go initConnectionState
              $ st
              )
         NT.ErrorEvent (NT.TransportError NT.EventEndPointFailed str) ->
-          fail $ "Cloud Haskell fatal error: end point failed: " ++ str
+          fatal $ "Cloud Haskell fatal error: end point failed: " ++ str
         NT.ErrorEvent (NT.TransportError NT.EventTransportFailed str) ->
-          fail $ "Cloud Haskell fatal error: transport failed: " ++ str
+          fatal $ "Cloud Haskell fatal error: transport failed: " ++ str
         NT.EndPointClosed ->
-          return ()
+          stopTracer (localTracer node) >> return ()
         NT.ReceivedMulticast _ _ ->
           -- If we received a multicast message, something went horribly wrong
           -- and we just give up
-          fail "Cloud Haskell fatal error: received unexpected multicast"
+          fatal "Cloud Haskell fatal error: received unexpected multicast"
+
+    fatal :: String -> IO ()
+    fatal msg = stopTracer (localTracer node) >> fail msg
 
     invalidRequest :: NT.ConnectionId -> ConnectionState -> IO ()
     invalidRequest cid st = do
       -- TODO: We should treat this as a fatal error on the part of the remote
       -- node. That is, we should report the remote node as having died, and we
       -- should close incoming connections (this requires a Transport layer
       -- extension).
-      traceEventFmtIO node "" ["[network] invalid request: ", (show cid)]
+      traceEventFmtIO node "" [(TraceStr "[network] invalid request: "),
+                               (Trace cid)]
       go ( incomingAt cid ^= Nothing
          $ st
          )
@@ -510,21 +518,17 @@ traceNotifyDied node ident reason =
   case reason of
     DiedNormal -> return ()
     _ -> traceNcEventFmt node " "
-                         ["[node-controller]", (show ident), (show reason)]
+                         [(TraceStr "[node-controller]"),
+                          (Trace ident),
+                          (Trace reason)]
 
-traceNcEvent :: LocalNode -> String -> NC ()
-traceNcEvent node msg = liftIO $ traceEventIO node msg
-
-traceNcEventFmt :: LocalNode -> String -> [String] -> NC ()
+traceNcEventFmt :: LocalNode -> String -> [TraceArg] -> NC ()
 traceNcEventFmt node fmt args =
   liftIO $ traceEventFmtIO node fmt args
 
-traceEventIO :: LocalNode -> String -> IO ()
-traceEventIO node msg = withLocalTracer node $ \t -> trace t msg
-
 traceEventFmtIO :: LocalNode
                 -> String
-                -> [String]
+                -> [TraceArg]
                 -> IO ()
 traceEventFmtIO node fmt args =
   withLocalTracer node $ \t -> traceFormat t fmt args
