Permalink
Browse files

tracers are set on startup and immutable thereafter

  • Loading branch information...
1 parent a05fd81 commit 96f28d36f34eab8be8d6489417ad8fed38097584 @hyperthunk hyperthunk committed Jan 24, 2013
@@ -83,6 +83,8 @@ module Control.Distributed.Process.Internal.Primitives
-- * Reconnecting
, reconnect
, reconnectPort
+ -- * Tracing/Debugging
+ , trace
) where
#if ! MIN_VERSION_base(4,6,0)
@@ -168,6 +170,7 @@ import Control.Distributed.Process.Internal.Messaging
, sendPayload
, disconnect
)
+import qualified Control.Distributed.Process.Internal.Trace as Trace
import Control.Distributed.Process.Internal.WeakTQueue
( newTQueueIO
, readTQueue
@@ -893,6 +896,15 @@ reconnectPort them = do
liftIO $ disconnect node (ProcessIdentifier us) (SendPortIdentifier (sendPortId them))
--------------------------------------------------------------------------------
+-- Debugging/Tracing --
+--------------------------------------------------------------------------------
+
+trace :: String -> Process ()
+trace s = do
+ node <- processNode <$> ask
+ liftIO $ Trace.trace (localTracer node) s
+
+--------------------------------------------------------------------------------
-- Auxiliary functions --
--------------------------------------------------------------------------------
@@ -3,42 +3,41 @@ module Control.Distributed.Process.Internal.Trace
( Tracer
, trace
, traceFormat
- , startEventlogTracer
- , startLogfileTracer
, defaultTracer
+ , logfileTracer
, stopTracer
) where
-import Control.Concurrent
- ( ThreadId
- , forkIO
- )
+import Control.Concurrent (forkIO)
import Control.Concurrent.STM
( TQueue
, newTQueueIO
, readTQueue
, writeTQueue
, atomically
)
-import Control.Distributed.Process.Internal.Types (forever')
-import Control.Exception
-import Data.List (foldl')
+import Control.Distributed.Process.Internal.Types (forever', Tracer(..))
+import Control.Exception (catch, throwTo, AsyncException(ThreadKilled))
+import Data.List (intersperse)
import Debug.Trace (traceEventIO)
-import System.IO
-data Tracer =
- LogFileTracer ThreadId (TQueue String)
- | EventLogTracer (String -> IO ())
- | NoOpTracer
+import Prelude hiding (catch)
-defaultTracer :: IO Tracer
-defaultTracer = return NoOpTracer
+import System.Environment (getEnv)
+import System.IO
+ ( Handle
+ , IOMode(AppendMode)
+ , withFile
+ , hPutStr
+ )
-startEventlogTracer :: IO Tracer
-startEventlogTracer = return $ EventLogTracer traceEventIO
+defaultTracer :: IO Tracer
+defaultTracer = do
+ catch (getEnv "DISTRIBUTED_PROCESS_TRACE_FILE" >>= logfileTracer)
+ (\(_ :: IOError) -> return (EventLogTracer traceEventIO))
-startLogfileTracer :: FilePath -> IO Tracer
-startLogfileTracer p = do
+logfileTracer :: FilePath -> IO Tracer
+logfileTracer p = do
q <- newTQueueIO
tid <- forkIO $ withFile p AppendMode (\h -> logger h q)
return $ LogFileTracer tid q
@@ -48,21 +47,19 @@ startLogfileTracer p = do
hPutStr h msg
logger h q'
+-- TODO: compatibility layer (conditional compilation?) for GHC/base versions
+
stopTracer :: Tracer -> IO ()
-stopTracer (LogFileTracer tid _) = throwTo tid ThreadKilled
+stopTracer (LogFileTracer tid _) = throwTo tid ThreadKilled -- cf killThread
stopTracer _ = return ()
trace :: Tracer -> String -> IO ()
trace (LogFileTracer _ q) msg = atomically $ writeTQueue q msg
trace (EventLogTracer t) msg = t msg
-trace NoOpTracer _ = return ()
-traceFormat :: (Show a)
- => Tracer
- -> (String -> String -> String)
- -> [a]
+traceFormat :: Tracer
+ -> String
+ -> [String]
-> IO ()
-traceFormat NoOpTracer _ _ = return ()
-traceFormat t f xs =
- trace t $ foldl' (\e a -> ((show e) `f` (show a))) "" xs
+traceFormat t d ls = trace t $ concat (intersperse d ls)
@@ -14,6 +14,7 @@ module Control.Distributed.Process.Internal.Types
, nullProcessId
-- * Local nodes and processes
, LocalNode(..)
+ , Tracer(..)
, LocalNodeState(..)
, LocalProcess(..)
, LocalProcessState(..)
@@ -90,6 +91,7 @@ import Control.Exception (Exception)
import Control.Concurrent (ThreadId)
import Control.Concurrent.Chan (Chan)
import Control.Concurrent.STM (STM)
+import qualified Control.Concurrent.STM as STM (TQueue)
import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
import Control.Applicative (Applicative, Alternative, (<$>), (<*>))
import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)
@@ -177,19 +179,26 @@ nullProcessId nid =
-- Local nodes and processes --
--------------------------------------------------------------------------------
+-- | Required for system tracing in the node controller
+data Tracer =
+ LogFileTracer ThreadId (STM.TQueue String)
+ | EventLogTracer (String -> IO ())
+
-- | Local nodes
data LocalNode = LocalNode
{ -- | 'NodeId' of the node
- localNodeId :: !NodeId
+ localNodeId :: !NodeId
-- | The network endpoint associated with this node
- , localEndPoint :: !NT.EndPoint
+ , localEndPoint :: !NT.EndPoint
-- | Local node state
- , localState :: !(StrictMVar LocalNodeState)
+ , localState :: !(StrictMVar LocalNodeState)
-- | Channel for the node controller
- , localCtrlChan :: !(Chan NCMsg)
+ , localCtrlChan :: !(Chan NCMsg)
+ -- | Current active system debug/trace log
+ , localTracer :: !Tracer
-- | Runtime lookup table for supporting closures
-- TODO: this should be part of the CH state, not the local endpoint state
- , remoteTable :: !RemoteTable
+ , remoteTable :: !RemoteTable
}
data ImplicitReconnect = WithImplicitReconnect | NoImplicitReconnect
@@ -434,7 +443,7 @@ data WhereIsReply = WhereIsReply String (Maybe ProcessId)
data RegisterReply = RegisterReply String Bool
deriving (Show, Typeable)
--- | Provide information about a running process
+-- | Provide information about a running process
data ProcessInfo = ProcessInfo {
infoNode :: NodeId
, infoRegisteredNames :: [String]
@@ -443,21 +452,9 @@ data ProcessInfo = ProcessInfo {
, infoLinks :: [ProcessId]
} deriving (Show, Eq, Typeable)
-instance Binary ProcessInfo where
- get = ProcessInfo <$> get <*> get <*> get <*> get <*> get
- put pInfo = put (infoNode pInfo)
- >> put (infoRegisteredNames pInfo)
- >> put (infoMessageQueueLength pInfo)
- >> put (infoMonitors pInfo)
- >> put (infoLinks pInfo)
-
data ProcessInfoNone = ProcessInfoNone DiedReason
deriving (Show, Typeable)
-instance Binary ProcessInfoNone where
- get = ProcessInfoNone <$> get
- put (ProcessInfoNone r) = put r
-
--------------------------------------------------------------------------------
-- Node controller internal data types --
--------------------------------------------------------------------------------
@@ -533,16 +530,16 @@ instance Binary ProcessSignal where
get = do
header <- getWord8
case header of
- 0 -> Link <$> get
- 1 -> Unlink <$> get
- 2 -> Monitor <$> get
- 3 -> Unmonitor <$> get
- 4 -> Died <$> get <*> get
- 5 -> Spawn <$> get <*> get
- 6 -> WhereIs <$> get
- 7 -> Register <$> get <*> get <*> get <*> get
- 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)
- 9 -> Kill <$> get <*> get
+ 0 -> Link <$> get
+ 1 -> Unlink <$> get
+ 2 -> Monitor <$> get
+ 3 -> Unmonitor <$> get
+ 4 -> Died <$> get <*> get
+ 5 -> Spawn <$> get <*> get
+ 6 -> WhereIs <$> get
+ 7 -> Register <$> get <*> get <*> get <*> get
+ 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)
+ 9 -> Kill <$> get <*> get
10 -> Exit <$> get <*> (payloadToMessage <$> get)
30 -> GetInfo <$> get
_ -> fail "ProcessSignal.get: invalid"
@@ -591,6 +588,18 @@ instance Binary RegisterReply where
put (RegisterReply label ok) = put label >> put ok
get = RegisterReply <$> get <*> get
+instance Binary ProcessInfo where
+ get = ProcessInfo <$> get <*> get <*> get <*> get <*> get
+ put pInfo = put (infoNode pInfo)
+ >> put (infoRegisteredNames pInfo)
+ >> put (infoMessageQueueLength pInfo)
+ >> put (infoMonitors pInfo)
+ >> put (infoLinks pInfo)
+
+instance Binary ProcessInfoNone where
+ get = ProcessInfoNone <$> get
+ put (ProcessInfoNone r) = put r
+
--------------------------------------------------------------------------------
-- Accessors --
--------------------------------------------------------------------------------
Oops, something went wrong.

0 comments on commit 96f28d3

Please sign in to comment.