Skip to content

Commit 96f28d3

Browse files
author
Tim Watson
committed
tracers are set on startup and immutable thereafter
1 parent a05fd81 commit 96f28d3

File tree

4 files changed

+129
-80
lines changed

4 files changed

+129
-80
lines changed

‎distributed-process/src/Control/Distributed/Process/Internal/Primitives.hs

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -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
171174
import 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

Lines changed: 26 additions & 29 deletions
Original file line numberDiff line numberDiff line change
@@ -3,42 +3,41 @@ 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)
1612
import Control.Concurrent.STM
1713
( TQueue
1814
, newTQueueIO
1915
, readTQueue
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)
2622
import 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+
5152
stopTracer :: Tracer -> IO ()
52-
stopTracer (LogFileTracer tid _) = throwTo tid ThreadKilled
53+
stopTracer (LogFileTracer tid _) = throwTo tid ThreadKilled -- cf killThread
5354
stopTracer _ = return ()
5455

5556
trace :: Tracer -> String -> IO ()
5657
trace (LogFileTracer _ q) msg = atomically $ writeTQueue q msg
5758
trace (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

Lines changed: 37 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -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)
9091
import Control.Concurrent (ThreadId)
9192
import Control.Concurrent.Chan (Chan)
9293
import Control.Concurrent.STM (STM)
94+
import qualified Control.Concurrent.STM as STM (TQueue)
9395
import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)
9496
import Control.Applicative (Applicative, Alternative, (<$>), (<*>))
9597
import 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
181188
data 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

195204
data ImplicitReconnect = WithImplicitReconnect | NoImplicitReconnect
@@ -434,7 +443,7 @@ data WhereIsReply = WhereIsReply String (Maybe ProcessId)
434443
data RegisterReply = RegisterReply String Bool
435444
deriving (Show, Typeable)
436445

437-
-- | Provide information about a running process
446+
-- | Provide information about a running process
438447
data 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-
454455
data 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
--------------------------------------------------------------------------------

0 commit comments

Comments
 (0)