96f28d3 · distributed-process

git.iko.soy/distributed-process

on master help sign in

tracers are set on startup and immutable thereafter

96f28d3Tim Watson14 years ago

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

compare with master

unifiedsplit

@@ -83,6 +83,8 @@ module Control.Distributed.Process.Internal.Primitives

83 -- * Reconnecting

84 , reconnect

85 , reconnectPort

86+ -- * Tracing/Debugging

87+ , trace

86 ) where

88 ) where

88#if ! MIN_VERSION_base(4,6,0)

90#if ! MIN_VERSION_base(4,6,0)

@@ -168,6 +170,7 @@ import Control.Distributed.Process.Internal.Messaging

168 , sendPayload

170 , sendPayload

169 , disconnect

171 , disconnect

170 )

172 )

173+import qualified Control.Distributed.Process.Internal.Trace as Trace

171import Control.Distributed.Process.Internal.WeakTQueue

174import Control.Distributed.Process.Internal.WeakTQueue

172 ( newTQueueIO

175 ( newTQueueIO

173 , readTQueue

176 , readTQueue

@@ -892,6 +895,15 @@ reconnectPort them = do

892 node <- processNode <$> ask

895 node <- processNode <$> ask

893 liftIO $ disconnect node (ProcessIdentifier us) (SendPortIdentifier (sendPortId them))

896 liftIO $ disconnect node (ProcessIdentifier us) (SendPortIdentifier (sendPortId them))

894

897

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+

895--------------------------------------------------------------------------------

907--------------------------------------------------------------------------------

896-- Auxiliary functions --

908-- Auxiliary functions --

897--------------------------------------------------------------------------------

909--------------------------------------------------------------------------------

distributed-process/src/Control/Distributed/Process/Internal/Trace.hs+26−29

@@ -3,16 +3,12 @@ module Control.Distributed.Process.Internal.Trace

3 ( Tracer

4 , trace

5 , traceFormat

6− , startEventlogTracer

7− , startLogfileTracer

8 , defaultTracer

6 , defaultTracer

7+ , logfileTracer

9 , stopTracer

8 , stopTracer

10 ) where

9 ) where

12−import Control.Concurrent

11+import Control.Concurrent (forkIO)

13− ( ThreadId

14− , forkIO

15− )

16import Control.Concurrent.STM

12import Control.Concurrent.STM

17 ( TQueue

13 ( TQueue

18 , newTQueueIO

14 , newTQueueIO

@@ -20,25 +16,28 @@ import Control.Concurrent.STM

20 , writeTQueue

16 , writeTQueue

21 , atomically

17 , atomically

22 )

18 )

23−import Control.Distributed.Process.Internal.Types (forever')

19+import Control.Distributed.Process.Internal.Types (forever', Tracer(..))

24−import Control.Exception

20+import Control.Exception (catch, throwTo, AsyncException(ThreadKilled))

25−import Data.List (foldl')

21+import Data.List (intersperse)

26import Debug.Trace (traceEventIO)

22import Debug.Trace (traceEventIO)

27−import System.IO

29−data Tracer =

24+import Prelude hiding (catch)

30− LogFileTracer ThreadId (TQueue String)

31− | EventLogTracer (String -> IO ())

32− | NoOpTracer

34−defaultTracer :: IO Tracer

26+import System.Environment (getEnv)

35−defaultTracer = return NoOpTracer

27+import System.IO

28+ ( Handle

29+ , IOMode(AppendMode)

30+ , withFile

31+ , hPutStr

32+ )

37−startEventlogTracer :: IO Tracer

34+defaultTracer :: IO Tracer

35+defaultTracer = do

36+ catch (getEnv "DISTRIBUTED_PROCESS_TRACE_FILE" >>= logfileTracer)

38−startEventlogTracer = return $ EventLogTracer traceEventIO

37+ (\(_ :: IOError) -> return (EventLogTracer traceEventIO))

40−startLogfileTracer :: FilePath -> IO Tracer

39+logfileTracer :: FilePath -> IO Tracer

41−startLogfileTracer p = do

40+logfileTracer p = do

42 q <- newTQueueIO

41 q <- newTQueueIO

43 tid <- forkIO $ withFile p AppendMode (\h -> logger h q)

42 tid <- forkIO $ withFile p AppendMode (\h -> logger h q)

44 return $ LogFileTracer tid q

43 return $ LogFileTracer tid q

@@ -48,21 +47,19 @@ startLogfileTracer p = do

48 hPutStr h msg

47 hPutStr h msg

49 logger h q'

48 logger h q'

50+-- TODO: compatibility layer (conditional compilation?) for GHC/base versions

51+

51stopTracer :: Tracer -> IO ()

52stopTracer :: Tracer -> IO ()

52−stopTracer (LogFileTracer tid _) = throwTo tid ThreadKilled

53+stopTracer (LogFileTracer tid _) = throwTo tid ThreadKilled -- cf killThread

53stopTracer _ = return ()

54stopTracer _ = return ()

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

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

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

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

57trace (EventLogTracer t) msg = t msg

58trace (EventLogTracer t) msg = t msg

58−trace NoOpTracer _ = return ()

60−traceFormat :: (Show a)

60+traceFormat :: Tracer

61− => Tracer

62− -> (String -> String -> String)

61+ -> String

63− -> [a]

62+ -> [String]

64 -> IO ()

63 -> IO ()

65−traceFormat NoOpTracer _ _ = return ()

64+traceFormat t d ls = trace t $ concat (intersperse d ls)

66−traceFormat t f xs =

67− trace t $ foldl' (\e a -> ((show e) `f` (show a))) "" xs

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+37−28

@@ -14,6 +14,7 @@ module Control.Distributed.Process.Internal.Types

14 , nullProcessId

15 -- * Local nodes and processes

16 , LocalNode(..)

17+ , Tracer(..)

17 , LocalNodeState(..)

18 , LocalNodeState(..)

18 , LocalProcess(..)

19 , LocalProcess(..)

19 , LocalProcessState(..)

20 , LocalProcessState(..)

@@ -90,6 +91,7 @@ import Control.Exception (Exception)

90import Control.Concurrent (ThreadId)

91import Control.Concurrent (ThreadId)

91import Control.Concurrent.Chan (Chan)

92import Control.Concurrent.Chan (Chan)

92import Control.Concurrent.STM (STM)

93import Control.Concurrent.STM (STM)

94+import qualified Control.Concurrent.STM as STM (TQueue)

93import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)

95import qualified Network.Transport as NT (EndPoint, EndPointAddress, Connection)

94import Control.Applicative (Applicative, Alternative, (<$>), (<*>))

96import Control.Applicative (Applicative, Alternative, (<$>), (<*>))

95import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)

97import Control.Monad.Reader (MonadReader(..), ReaderT, runReaderT)

@@ -177,19 +179,26 @@ nullProcessId nid =

177-- Local nodes and processes --

179-- Local nodes and processes --

178--------------------------------------------------------------------------------

180--------------------------------------------------------------------------------

179

181

182+-- | Required for system tracing in the node controller

183+data Tracer =

184+ LogFileTracer ThreadId (STM.TQueue String)

185+ | EventLogTracer (String -> IO ())

186+

180-- | Local nodes

187-- | Local nodes

181data LocalNode = LocalNode

188data LocalNode = LocalNode

182 { -- | 'NodeId' of the node

189 { -- | 'NodeId' of the node

183− localNodeId :: !NodeId

190+ localNodeId :: !NodeId

184 -- | The network endpoint associated with this node

191 -- | The network endpoint associated with this node

185− , localEndPoint :: !NT.EndPoint

192+ , localEndPoint :: !NT.EndPoint

186 -- | Local node state

193 -- | Local node state

187− , localState :: !(StrictMVar LocalNodeState)

194+ , localState :: !(StrictMVar LocalNodeState)

188 -- | Channel for the node controller

195 -- | Channel for the node controller

189− , localCtrlChan :: !(Chan NCMsg)

196+ , localCtrlChan :: !(Chan NCMsg)

197+ -- | Current active system debug/trace log

198+ , localTracer :: !Tracer

190 -- | Runtime lookup table for supporting closures

199 -- | Runtime lookup table for supporting closures

191 -- TODO: this should be part of the CH state, not the local endpoint state

200 -- TODO: this should be part of the CH state, not the local endpoint state

192− , remoteTable :: !RemoteTable

201+ , remoteTable :: !RemoteTable

193 }

202 }

194

203

195data ImplicitReconnect = WithImplicitReconnect | NoImplicitReconnect

204data ImplicitReconnect = WithImplicitReconnect | NoImplicitReconnect

@@ -434,7 +443,7 @@ data WhereIsReply = WhereIsReply String (Maybe ProcessId)

434data RegisterReply = RegisterReply String Bool

443data RegisterReply = RegisterReply String Bool

435 deriving (Show, Typeable)

444 deriving (Show, Typeable)

436

445

437−-- | Provide information about a running process

446+-- | Provide information about a running process

438data ProcessInfo = ProcessInfo {

447data ProcessInfo = ProcessInfo {

439 infoNode :: NodeId

448 infoNode :: NodeId

440 , infoRegisteredNames :: [String]

449 , infoRegisteredNames :: [String]

@@ -443,21 +452,9 @@ data ProcessInfo = ProcessInfo {

443 , infoLinks :: [ProcessId]

452 , infoLinks :: [ProcessId]

444 } deriving (Show, Eq, Typeable)

453 } deriving (Show, Eq, Typeable)

445

454

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−

454data ProcessInfoNone = ProcessInfoNone DiedReason

455data ProcessInfoNone = ProcessInfoNone DiedReason

455 deriving (Show, Typeable)

456 deriving (Show, Typeable)

456

457

457−instance Binary ProcessInfoNone where

458− get = ProcessInfoNone <$> get

459− put (ProcessInfoNone r) = put r

460−

461--------------------------------------------------------------------------------

458--------------------------------------------------------------------------------

462-- Node controller internal data types --

459-- Node controller internal data types --

463--------------------------------------------------------------------------------

460--------------------------------------------------------------------------------

@@ -533,16 +530,16 @@ instance Binary ProcessSignal where

533 get = do

530 get = do

534 header <- getWord8

531 header <- getWord8

535 case header of

532 case header of

536− 0 -> Link <$> get

533+ 0 -> Link <$> get

537− 1 -> Unlink <$> get

534+ 1 -> Unlink <$> get

538− 2 -> Monitor <$> get

535+ 2 -> Monitor <$> get

539− 3 -> Unmonitor <$> get

536+ 3 -> Unmonitor <$> get

540− 4 -> Died <$> get <*> get

537+ 4 -> Died <$> get <*> get

541− 5 -> Spawn <$> get <*> get

538+ 5 -> Spawn <$> get <*> get

542− 6 -> WhereIs <$> get

539+ 6 -> WhereIs <$> get

543− 7 -> Register <$> get <*> get <*> get <*> get

540+ 7 -> Register <$> get <*> get <*> get <*> get

544− 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)

541+ 8 -> NamedSend <$> get <*> (payloadToMessage <$> get)

545− 9 -> Kill <$> get <*> get

542+ 9 -> Kill <$> get <*> get

546 10 -> Exit <$> get <*> (payloadToMessage <$> get)

543 10 -> Exit <$> get <*> (payloadToMessage <$> get)

547 30 -> GetInfo <$> get

544 30 -> GetInfo <$> get

548 _ -> fail "ProcessSignal.get: invalid"

545 _ -> fail "ProcessSignal.get: invalid"

@@ -591,6 +588,18 @@ instance Binary RegisterReply where

591 put (RegisterReply label ok) = put label >> put ok

588 put (RegisterReply label ok) = put label >> put ok

592 get = RegisterReply <$> get <*> get

589 get = RegisterReply <$> get <*> get

593

590

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+

594--------------------------------------------------------------------------------

603--------------------------------------------------------------------------------

595-- Accessors --

604-- Accessors --

596--------------------------------------------------------------------------------

605--------------------------------------------------------------------------------

distributed-process/src/Control/Distributed/Process/Node.hs+54−23

@@ -42,7 +42,6 @@ import qualified Data.Set as Set

42import Data.Foldable (forM_)

43import Data.Maybe (isJust, isNothing, catMaybes)

44import Data.Typeable (Typeable)

45−import Debug.Trace

46import Control.Category ((>>>))

45import Control.Category ((>>>))

47import Control.Applicative ((<$>))

46import Control.Applicative ((<$>))

48import Control.Monad (void, when)

47import Control.Monad (void, when)

@@ -63,7 +62,9 @@ import Control.Distributed.Process.Internal.StrictMVar

63 , takeMVar

62 , takeMVar

64 )

63 )

65import Control.Concurrent.Chan (newChan, writeChan, readChan)

64import Control.Concurrent.Chan (newChan, writeChan, readChan)

66−import Control.Concurrent.STM (atomically)

65+import Control.Concurrent.STM

66+ ( atomically

67+ )

67import Control.Distributed.Process.Internal.CQueue

68import Control.Distributed.Process.Internal.CQueue

68 ( CQueue

69 ( CQueue

69 , enqueue

70 , enqueue

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

98 , LocalProcessId(..)

99 , LocalProcessId(..)

99 , ProcessId(..)

100 , ProcessId(..)

100 , LocalNode(..)

101 , LocalNode(..)

102+ , Tracer

101 , LocalNodeState(..)

103 , LocalNodeState(..)

102 , LocalProcess(..)

104 , LocalProcess(..)

103 , LocalProcessState(..)

105 , LocalProcessState(..)

@@ -141,6 +143,12 @@ import Control.Distributed.Process.Internal.Types

141 , firstNonReservedProcessId

143 , firstNonReservedProcessId

142 , ImplicitReconnect(WithImplicitReconnect, NoImplicitReconnect)

144 , ImplicitReconnect(WithImplicitReconnect, NoImplicitReconnect)

143 )

145 )

146+import Control.Distributed.Process.Internal.Trace

147+ ( trace

148+ , traceFormat

149+ , defaultTracer

150+ , stopTracer

151+ )

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

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

145import Control.Distributed.Process.Internal.Messaging

153import Control.Distributed.Process.Internal.Messaging

146 ( sendBinary

154 ( sendBinary

@@ -192,11 +200,13 @@ createBareLocalNode endPoint rtable = do

192 , _localPidUnique = unq

200 , _localPidUnique = unq

193 , _localConnections = Map.empty

201 , _localConnections = Map.empty

194 }

202 }

203+ tracer <- defaultTracer

195 ctrlChan <- newChan

204 ctrlChan <- newChan

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

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

197 , localEndPoint = endPoint

206 , localEndPoint = endPoint

198 , localState = state

207 , localState = state

199 , localCtrlChan = ctrlChan

208 , localCtrlChan = ctrlChan

209+ , localTracer = tracer

200 , remoteTable = rtable

210 , remoteTable = rtable

201 }

211 }

202 void . forkIO $ runNodeController node

212 void . forkIO $ runNodeController node

@@ -219,13 +229,6 @@ startServiceProcesses node = do

219 sendChan ch ()

229 sendChan ch ()

220 ]

230 ]

221

231

222−-- | Send a message to the GHC event log

223−logEvent :: String -> IO ()

224−logEvent = traceEventIO

225−

226−logExit :: ProcessId -> DiedReason -> IO ()

227−logExit p r = logEvent $ (show p) ++ " exited: " ++ (show r)

228−

229-- | Force-close a local node

232-- | Force-close a local node

230--

233--

231-- TODO: for now we just close the associated endpoint

234-- TODO: for now we just close the associated endpoint

@@ -272,9 +275,6 @@ forkProcess node proc = modifyMVar (localState node) startProcess

272 (runLocalProcess lproc proc >> return DiedNormal)

275 (runLocalProcess lproc proc >> return DiedNormal)

273 (return . DiedException . (show :: SomeException -> String))

276 (return . DiedException . (show :: SomeException -> String))

274

277

275− -- [Issue #104]

276− logExit pid reason

277−

278 -- [Unified: Table 4, rules termination and exiting]

279 modifyMVar_ (localState node) (cleanupProcess pid)

280 writeChan (localCtrlChan node) NCMsg

@@ -442,11 +442,12 @@ handleIncomingMessages node = go initConnectionState

442 fail "Cloud Haskell fatal error: received unexpected multicast"

443

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

445− invalidRequest cid st =

445+ invalidRequest cid st = do

446 -- TODO: We should treat this as a fatal error on the part of the remote

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

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

449 -- extension).

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

450 go ( incomingAt cid ^= Nothing

451 go ( incomingAt cid ^= Nothing

451 $ st

452 $ st

452 )

453 )

@@ -498,6 +499,36 @@ instance Show ProcessKillException where

498 show (ProcessKillException pid reason) =

499 show (ProcessKillException pid reason) =

499 "killed-by=" ++ show pid ++ ",reason=" ++ reason

500 "killed-by=" ++ show pid ++ ",reason=" ++ reason

500

501

502+--------------------------------------------------------------------------------

503+-- Tracing/Debugging --

504+--------------------------------------------------------------------------------

505+

506+-- [Issue #104]

507+

508+traceNotifyDied :: LocalNode -> Identifier -> DiedReason -> NC ()

509+traceNotifyDied node ident reason =

510+ traceNcEventFmt node " " ["[node-controller]", (show ident), (show reason)]

511+

512+traceNcEvent :: LocalNode -> String -> NC ()

513+traceNcEvent node msg = liftIO $ traceEventIO node msg

514+

515+traceNcEventFmt :: LocalNode -> String -> [String] -> NC ()

516+traceNcEventFmt node fmt args =

517+ liftIO $ traceEventFmtIO node fmt args

518+

519+traceEventIO :: LocalNode -> String -> IO ()

520+traceEventIO node msg = withLocalTracer node $ \t -> trace t msg

521+

522+traceEventFmtIO :: LocalNode

523+ -> String

524+ -> [String]

525+ -> IO ()

526+traceEventFmtIO node fmt args =

527+ withLocalTracer node $ \t -> traceFormat t fmt args

528+

529+withLocalTracer :: LocalNode -> (Tracer -> IO ()) -> IO ()

530+withLocalTracer node act = act (localTracer node)

531+

501--------------------------------------------------------------------------------

532--------------------------------------------------------------------------------

502-- Core functionality --

533-- Core functionality --

503--------------------------------------------------------------------------------

534--------------------------------------------------------------------------------

@@ -605,6 +636,7 @@ ncEffectUnmonitor from ref = do

605ncEffectDied :: Identifier -> DiedReason -> NC ()

636ncEffectDied :: Identifier -> DiedReason -> NC ()

606ncEffectDied ident reason = do

637ncEffectDied ident reason = do

607 node <- ask

638 node <- ask

639+ traceNotifyDied node ident reason

608 (affectedLinks, unaffectedLinks) <- gets (splitNotif ident . (^. links))

640 (affectedLinks, unaffectedLinks) <- gets (splitNotif ident . (^. links))

609 (affectedMons, unaffectedMons) <- gets (splitNotif ident . (^. monitors))

641 (affectedMons, unaffectedMons) <- gets (splitNotif ident . (^. monitors))

610

642

@@ -647,7 +679,6 @@ ncEffectDied ident reason = do

647 , ctrlMsgSignal = Died ident reason

679 , ctrlMsgSignal = Died ident reason

648 }

680 }

649

681

650−

651-- [Unified: Table 13]

682-- [Unified: Table 13]

652ncEffectSpawn :: ProcessId -> Closure (Process ()) -> SpawnRef -> NC ()

683ncEffectSpawn :: ProcessId -> Closure (Process ()) -> SpawnRef -> NC ()

653ncEffectSpawn pid cProc ref = do

684ncEffectSpawn pid cProc ref = do

@@ -849,18 +880,18 @@ notifyDied dest src reason mRef = do

849

880

850-- | [Unified: Table 8]

881-- | [Unified: Table 8]

851destNid :: ProcessSignal -> Maybe NodeId

882destNid :: ProcessSignal -> Maybe NodeId

852−destNid (Link ident) = Just $ nodeOf ident

883+destNid (Link ident) = Just $ nodeOf ident

853−destNid (Unlink ident) = Just $ nodeOf ident

884+destNid (Unlink ident) = Just $ nodeOf ident

854−destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)

885+destNid (Monitor ref) = Just $ nodeOf (monitorRefIdent ref)

855−destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)

886+destNid (Unmonitor ref) = Just $ nodeOf (monitorRefIdent ref)

856−destNid (Spawn _ _) = Nothing

887+destNid (Spawn _ _) = Nothing

857−destNid (Register _ _ _ _) = Nothing

888+destNid (Register _ _ _ _) = Nothing

858−destNid (WhereIs _) = Nothing

889+destNid (WhereIs _) = Nothing

859−destNid (NamedSend _ _) = Nothing

890+destNid (NamedSend _ _) = Nothing

860-- We don't need to forward 'Died' signals; if monitoring/linking is setup,

891-- We don't need to forward 'Died' signals; if monitoring/linking is setup,

861-- then when a local process dies the monitoring/linking machinery will take

892-- then when a local process dies the monitoring/linking machinery will take

862-- care of notifying remote nodes

893-- care of notifying remote nodes

863−destNid (Died _ _) = Nothing

894+destNid (Died _ _) = Nothing

864destNid (Kill pid _) = Just $ processNodeId pid

895destNid (Kill pid _) = Just $ processNodeId pid

865destNid (Exit pid _) = Just $ processNodeId pid

896destNid (Exit pid _) = Just $ processNodeId pid

866destNid (GetInfo pid) = Just $ processNodeId pid

897destNid (GetInfo pid) = Just $ processNodeId pid