1520aa5 · distributed-process

git.iko.soy/distributed-process

on master help sign in

Refactor Debug API and add a test suite

1520aa5Tim Watson14 years ago

distributed-process.cabal+24

compare with master

unifiedsplit

@@ -157,6 +157,30 @@ Test-Suite TestStats

157 ghc-options: -Wall -debug -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

158 HS-Source-Dirs: tests

159

160+Test-Suite TestTracing

161+ Type: exitcode-stdio-1.0

162+ Main-Is: TestTracing.hs

163+ Build-Depends: base >= 4.4 && < 5,

164+ random >= 1.0 && < 1.1,

165+ ansi-terminal >= 0.5 && < 0.6,

166+ containers >= 0.4 && < 0.6,

167+ stm >= 2.4 && < 2.5,

168+ distributed-process,

169+ network-transport >= 0.3 && < 0.4,

170+ network-transport-tcp >= 0.3 && < 0.4,

171+ binary >= 0.5 && < 0.7,

172+ network >= 2.3 && < 2.5,

173+ HUnit >= 1.2 && < 1.3,

174+ test-framework >= 0.6 && < 0.9,

175+ test-framework-hunit >= 0.2.0 && < 0.4,

176+ unix >= 2.5.0.0

177+ Extensions: CPP,

178+ ScopedTypeVariables,

179+ DeriveDataTypeable,

180+ GeneralizedNewtypeDeriving

181+ ghc-options: -Wall -debug -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind

182+ HS-Source-Dirs: tests

183+

160

184

161Executable distributed-process-throughput

185Executable distributed-process-throughput

162 if flag(benchmarks)

186 if flag(benchmarks)

src/Control/Distributed/Process/Debug.hs+119−26

@@ -88,9 +88,14 @@ module Control.Distributed.Process.Debug

88 , TraceFlags(..)

89 , TraceSubject(..)

90 -- * Configuring Tracing

91+ , isTracingEnabled

91 , enableTrace

92 , enableTrace

93+ , enableTraceAsync

92 , disableTrace

94 , disableTrace

95+ , disableTraceAsync

96+ , withTracer

93 , setTraceFlags

97 , setTraceFlags

98+ , setTraceFlagsAsync

94 , defaultTraceFlags

99 , defaultTraceFlags

95 -- * Debugging

100 -- * Debugging

96 , startTracer

101 , startTracer

@@ -113,9 +118,16 @@ import Control.Distributed.Process.Internal.Primitives

113 , die

118 , die

114 , getSelfPid

119 , getSelfPid

115 , reregister

120 , reregister

116− , register

117 , whereis

121 , whereis

118 , send

122 , send

123+ , newChan

124+ , sendChan

125+ , receiveChan

126+ , receiveWait

127+ , matchIf

128+ , finally

129+ , try

130+ , monitor

119 )

131 )

120import Control.Distributed.Process.Internal.Types

132import Control.Distributed.Process.Internal.Types

121 ( Tracer(..)

133 ( Tracer(..)

@@ -123,12 +135,15 @@ import Control.Distributed.Process.Internal.Types

123 , ProcessId

135 , ProcessId

124 , Process

136 , Process

125 , LocalProcess(..)

137 , LocalProcess(..)

138+ , SendPort(..)

139+ , ProcessMonitorNotification(..)

126 )

140 )

127import Control.Distributed.Process.Internal.Trace.Types

141import Control.Distributed.Process.Internal.Trace.Types

128 ( TraceArg(..)

142 ( TraceArg(..)

129 , TraceEvent(..)

143 , TraceEvent(..)

130 , TraceFlags(..)

144 , TraceFlags(..)

131 , TraceSubject(..)

145 , TraceSubject(..)

146+ , TraceOk(..)

132 , defaultTraceFlags

147 , defaultTraceFlags

133 )

148 )

134import Control.Distributed.Process.Internal.Trace.Tracer

149import Control.Distributed.Process.Internal.Trace.Tracer

@@ -141,17 +156,27 @@ import qualified Control.Distributed.Process.Internal.Trace.Primitives as Tracer

141 , traceLogFmt

156 , traceLogFmt

142 , traceMessage

157 , traceMessage

143 , enableTrace

158 , enableTrace

159+ , enableTraceSync

144 , disableTrace

160 , disableTrace

161+ , disableTraceSync

145 , setTraceFlags

162 , setTraceFlags

163+ , setTraceFlagsSync

146 )

164 )

147import Control.Distributed.Process.Node

165import Control.Distributed.Process.Node

148import Control.Distributed.Process.Serializable

166import Control.Distributed.Process.Serializable

149

167

168+import Control.Exception (SomeException)

169+

150import Control.Monad.IO.Class (liftIO)

170import Control.Monad.IO.Class (liftIO)

151import Control.Monad.Reader (ask)

171import Control.Monad.Reader (ask)

152

172

153import Data.Binary()

173import Data.Binary()

154

174

175+#if ! MIN_VERSION_base(4,6,0)

176+import Prelude hiding (catch)

177+#endif

178+

179+

155--------------------------------------------------------------------------------

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

156-- Debugging/Tracing API --

181-- Debugging/Tracing API --

157--------------------------------------------------------------------------------

182--------------------------------------------------------------------------------

@@ -161,24 +186,56 @@ import Data.Binary()

161-- the registered tracer with the supplied handler, allowing the user to layer

186-- the registered tracer with the supplied handler, allowing the user to layer

162-- multiple tracers on top of one another, with trace events forwarded down

187-- multiple tracers on top of one another, with trace events forwarded down

163-- through all the layers in turn. Once the top layer is stopped, it will

188-- through all the layers in turn. Once the top layer is stopped, it will

164−-- reregister the original tracer pid before terminating. If no tracer is

189+-- reregister the original (prior) tracer pid before terminating.

165−-- currently registered, this function will have no effect.

166−startTracer :: (TraceEvent -> Process ()) -> Process ()

190+startTracer :: (TraceEvent -> Process ()) -> Process ProcessId

191+startTracer handler = do

192+ (sp, rp) <- newChan

167−startTracer handler = withRegisteredTracer $ \pid -> do

193+ withRegisteredTracer $ \pid -> do

168− node <- processNode <$> ask

194+ node <- processNode <$> ask

169− newPid <- liftIO $ forkProcess node $ do

195+ newPid <- liftIO $ forkProcess node $ do

196+ -- TODO: we ensure that the original

197+ -- tracer is re-registered, but it is

198+ -- possible this could lead to races

199+ -- if multiple tracers crash in very

200+ -- close succession, due to scheduling

170− finally (mkProxy pid handler)

201+ finally (traceProxy pid handler)

171− (reregister "tracer" pid)

202+ (resetTracer pid)

172− enableTrace newPid

203+ enableTrace newPid

204+ sendChan sp newPid

205+ receiveChan rp

206+

207+-- | Evaluate @proc@ with tracing enabled via @handler@, and immediately

208+-- disable tracing thereafter, before giving the result (or exception

209+-- in case of failure).

210+withTracer :: forall a.

211+ (TraceEvent -> Process ())

212+ -> Process a

213+ -> Process (Either SomeException a)

214+withTracer handler proc = do

215+ tracer <- startTracer handler

216+ finally (try proc)

217+ (stopTracing tracer)

173 where

218 where

219+ stopTracing :: ProcessId -> Process ()

220+ stopTracing tracer = do

221+ ref <- monitor tracer

222+ stopTracer

223+ receiveWait [

224+ matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')

225+ (\_ -> return ())

226+ ]

227+

174− mkProxy :: ProcessId -> (TraceEvent -> Process ()) -> Process ()

228+traceProxy :: ProcessId -> (TraceEvent -> Process ()) -> Process ()

175− mkProxy pid act = do

229+traceProxy pid act = do

176− getSelfPid >>= register "tracer"

230+ getSelfPid >>= reregister "tracer" -- registration is synchronous

177− proxy pid $ \(ev :: TraceEvent) ->

231+ proxy pid $ \(ev :: TraceEvent) ->

178− case ev of

232+ case ev of

179− (TraceEvTakeover _) -> die "finished"

233+ (TraceEvTakeover _) -> die "takeover"

180− TraceEvDisable -> die "stop"

234+ TraceEvDisable -> die "disabled"

181− _ -> act ev >> return True

235+ _ -> act ev >> return True

236+

237+resetTracer :: ProcessId -> Process ()

238+resetTracer pid = enableTrace pid

182

239

183-- | Stops a user supplied tracer started with 'startTracer'.

240-- | Stops a user supplied tracer started with 'startTracer'.

184-- Note that only one tracer process can be active at any given time.

241-- Note that only one tracer process can be active at any given time.

@@ -190,7 +247,7 @@ startTracer handler = withRegisteredTracer $ \pid -> do

190-- This function will never stop the system tracer (i.e., the tracer

247-- This function will never stop the system tracer (i.e., the tracer

191-- initially started when the node is created), therefore once all user

248-- initially started when the node is created), therefore once all user

192-- supplied tracers (i.e., processes started via 'startTracer') have exited,

249-- supplied tracers (i.e., processes started via 'startTracer') have exited,

193−-- subsequent calls to this function have no effect.

250+-- subsequent calls to this function will have no effect.

194--

251--

195-- If tracing is support disabled for the node, this function will also

252-- If tracing is support disabled for the node, this function will also

196-- have no effect.

253-- have no effect.

@@ -209,22 +266,57 @@ stopTracer = withLocalTracer $ \t ->

209

266

210withRegisteredTracer :: (ProcessId -> Process ()) -> Process ()

267withRegisteredTracer :: (ProcessId -> Process ()) -> Process ()

211withRegisteredTracer act = do

268withRegisteredTracer act = do

212− t <- whereis "tracer"

269+ currentTracer <- whereis "tracer"

213− case t of

270+ case currentTracer of

214− Nothing -> return ()

271+ Nothing -> do { (Just p') <- whereis "tracer.initial"; act p' }

215− Just pid -> act pid

272+ (Just p) -> act p

273+

274+-- | Determine whether or not tracing has been enabled.

275+isTracingEnabled :: Process Bool

276+isTracingEnabled = do

277+ node <- processNode <$> ask

278+ case (localTracer node) of

279+ (ActiveTracer _ _) -> return True

280+ _ -> return False

216

281

217-- | Enable tracing to the supplied process.

282-- | Enable tracing to the supplied process.

283+enableTraceAsync :: ProcessId -> Process ()

284+enableTraceAsync pid = withLocalTracer $ \t -> liftIO $ Tracer.enableTrace t pid

285+

286+-- TODO: refactor _Sync versions of trace configuration functions...

287+

288+-- | Enable tracing to the supplied process and wait for a @TraceOk@

289+-- response from the trace coordinator process.

218enableTrace :: ProcessId -> Process ()

290enableTrace :: ProcessId -> Process ()

219−enableTrace pid = withLocalTracer $ \t -> liftIO $ Tracer.enableTrace t pid

291+enableTrace pid =

292+ withLocalTracerSync $ \t sp -> Tracer.enableTraceSync t sp pid

220

293

221-- | Disable the currently configured trace.

294-- | Disable the currently configured trace.

295+disableTraceAsync :: Process ()

296+disableTraceAsync = withLocalTracer $ \t -> liftIO $ Tracer.disableTrace t

297+

298+-- | Disable the currently configured trace and wait for a @TraceOk@

299+-- response from the trace coordinator process.

222disableTrace :: Process ()

300disableTrace :: Process ()

223−disableTrace = withLocalTracer $ \t -> liftIO $ Tracer.disableTrace t

301+disableTrace =

302+ withLocalTracerSync $ \t sp -> Tracer.disableTraceSync t sp

224

303

225-- | Set the given flags for the current tracer.

304-- | Set the given flags for the current tracer.

305+setTraceFlagsAsync :: TraceFlags -> Process ()

306+setTraceFlagsAsync f = withLocalTracer $ \t -> liftIO $ Tracer.setTraceFlags t f

307+

308+-- | Set the given flags for the current tracer and wait for a @TraceOk@

309+-- response from the trace coordinator process.

226setTraceFlags :: TraceFlags -> Process ()

310setTraceFlags :: TraceFlags -> Process ()

311+setTraceFlags f =

312+ withLocalTracerSync $ \t sp -> Tracer.setTraceFlagsSync t sp f

313+

314+withLocalTracerSync :: (Tracer -> SendPort TraceOk -> IO ()) -> Process ()

315+withLocalTracerSync act = do

316+ (sp, rp) <- newChan

227−setTraceFlags f = withLocalTracer $ \t -> liftIO $ Tracer.setTraceFlags t f

317+ withLocalTracer $ \t -> liftIO $ (act t sp)

318+ TraceOk <- receiveChan rp

319+ return ()

228

320

229-- | Send a log message to the internal tracing facility. If tracing is

321-- | Send a log message to the internal tracing facility. If tracing is

230-- enabled, this will create a custom trace log event.

322-- enabled, this will create a custom trace log event.

@@ -246,3 +338,4 @@ withLocalTracer :: (Tracer -> Process ()) -> Process ()

246withLocalTracer act = do

338withLocalTracer act = do

247 node <- processNode <$> ask

339 node <- processNode <$> ask

248 act (localTracer node)

340 act (localTracer node)

341+

src/Control/Distributed/Process/Internal/Trace/Primitives.hs+26−4

@@ -12,8 +12,11 @@ module Control.Distributed.Process.Internal.Trace.Primitives

12 -- * Configuring A Tracer

13 , defaultTraceFlags

14 , enableTrace

15+ , enableTraceSync

15 , disableTrace

16 , disableTrace

17+ , disableTraceSync

16 , setTraceFlags

18 , setTraceFlags

19+ , setTraceFlagsSync

17 ) where

20 ) where

19import Control.Distributed.Process.Internal.CQueue (enqueue)

22import Control.Distributed.Process.Internal.CQueue (enqueue)

@@ -22,12 +25,14 @@ import Control.Distributed.Process.Internal.Trace.Types

22 , TraceEvent(..)

25 , TraceEvent(..)

23 , SetTrace(..)

26 , SetTrace(..)

24 , TraceFlags(..)

27 , TraceFlags(..)

28+ , TraceOk(..)

25 , defaultTraceFlags

29 , defaultTraceFlags

26 )

30 )

27import Control.Distributed.Process.Internal.Types

31import Control.Distributed.Process.Internal.Types

28 ( Tracer(..)

32 ( Tracer(..)

29 , ProcessId

33 , ProcessId

30 , Message

34 , Message

35+ , SendPort

31 , createUnencodedMessage

36 , createUnencodedMessage

32 )

37 )

33import Control.Distributed.Process.Serializable

38import Control.Distributed.Process.Serializable

@@ -59,17 +64,34 @@ traceMessage :: Serializable m => Tracer -> m -> IO ()

59traceMessage tr msg = traceEvent tr (TraceEvUser (createUnencodedMessage msg))

64traceMessage tr msg = traceEvent tr (TraceEvUser (createUnencodedMessage msg))

61enableTrace :: Tracer -> ProcessId -> IO ()

66enableTrace :: Tracer -> ProcessId -> IO ()

67+enableTrace t p =

68+ traceIt t (createUnencodedMessage ((Nothing :: Maybe (SendPort TraceOk)),

69+ (TraceEnable p)))

70+

71+enableTraceSync :: Tracer -> SendPort TraceOk -> ProcessId -> IO ()

72+enableTraceSync t s p =

62−enableTrace t p = traceIt t (createUnencodedMessage (TraceEnable p))

73+ traceIt t (createUnencodedMessage ((Just s), (TraceEnable p)))

64disableTrace :: Tracer -> IO ()

75disableTrace :: Tracer -> IO ()

76+disableTrace t =

77+ traceIt t (createUnencodedMessage ((Nothing :: Maybe (SendPort TraceOk)),

78+ TraceDisable))

79+

80+disableTraceSync :: Tracer -> SendPort TraceOk -> IO ()

81+disableTraceSync t s =

65−disableTrace t = traceIt t (createUnencodedMessage TraceDisable)

82+ traceIt t (createUnencodedMessage ((Just s), TraceDisable))

67setTraceFlags :: Tracer -> TraceFlags -> IO ()

84setTraceFlags :: Tracer -> TraceFlags -> IO ()

85+setTraceFlags t f =

86+ traceIt t (createUnencodedMessage ((Nothing :: Maybe (SendPort TraceOk)), f))

87+

88+setTraceFlagsSync :: Tracer -> SendPort TraceOk -> TraceFlags -> IO ()

89+setTraceFlagsSync t s f =

68−setTraceFlags t f = traceIt t (createUnencodedMessage f)

90+ traceIt t (createUnencodedMessage ((Just s), f))

70traceIt :: Tracer -> Message -> IO ()

92traceIt :: Tracer -> Message -> IO ()

71traceIt InactiveTracer _ = return ()

93traceIt InactiveTracer _ = return ()

72traceIt (ActiveTracer _ wqRef) msg = do

94traceIt (ActiveTracer _ wqRef) msg = do

73 mQueue <- deRefWeak wqRef

95 mQueue <- deRefWeak wqRef

74 forM_ mQueue $ \queue -> enqueue queue msg

96 forM_ mQueue $ \queue -> enqueue queue msg

75−

97+

src/Control/Distributed/Process/Internal/Trace/Tracer.hs+20−10

@@ -22,10 +22,12 @@ import Control.Distributed.Process.Internal.Primitives

22 ( catch

23 , receiveWait

24 , forward

25+ , sendChan

25 , match

26 , match

26 , matchAny

27 , matchAny

27 , matchAnyIf

28 , matchAnyIf

28 , handleMessage

29 , handleMessage

30+ , reregister

29 )

31 )

30import Control.Distributed.Process.Internal.Trace.Types

32import Control.Distributed.Process.Internal.Trace.Types

31 ( TraceEvent(..)

33 ( TraceEvent(..)

@@ -33,6 +35,7 @@ import Control.Distributed.Process.Internal.Trace.Types

33 , Addressable(..)

35 , Addressable(..)

34 , TraceSubject(..)

36 , TraceSubject(..)

35 , TraceFlags(..)

37 , TraceFlags(..)

38+ , TraceOk(..)

36 , defaultTraceFlags

39 , defaultTraceFlags

37 )

40 )

38import Control.Distributed.Process.Internal.Types

41import Control.Distributed.Process.Internal.Types

@@ -44,6 +47,7 @@ import Control.Distributed.Process.Internal.Types

44 , Identifier(..)

47 , Identifier(..)

45 , ProcessSignal(NamedSend)

48 , ProcessSignal(NamedSend)

46 , Message

49 , Message

50+ , SendPort

47 , forever'

51 , forever'

48 , nullProcessId

52 , nullProcessId

49 , createUnencodedMessage

53 , createUnencodedMessage

@@ -125,7 +129,6 @@ systemLoggerTracer = do

125

129

126eventLogTracer :: Process ()

130eventLogTracer :: Process ()

127eventLogTracer = do

131eventLogTracer = do

128− liftIO $ traceEventIO "starting event log tracer"

129 -- NB: when the GHC event log supports tracing arbitrary (ish) data, we will

132 -- NB: when the GHC event log supports tracing arbitrary (ish) data, we will

130 -- almost certainly use *that* facility independently of whether or not there

133 -- almost certainly use *that* facility independently of whether or not there

131 -- is a tracer process installed. This is just a stop gap until then.

134 -- is a tracer process installed. This is just a stop gap until then.

@@ -177,22 +180,29 @@ traceController mv = do

177 -- events to the ghc eventlog, at which point this design might change.

180 -- events to the ghc eventlog, at which point this design might change.

178 st' <- receiveWait [

181 st' <- receiveWait [

179 -- we notify the previous tracer process that it has been replaced

182 -- we notify the previous tracer process that it has been replaced

180− match (\(set :: SetTrace) ->

183+ match (\(setResp, set :: SetTrace) -> do

181 -- We allow at most one trace target, which is a process id.

184 -- We allow at most one trace target, which is a process id.

182 case set of

185 case set of

183 (TraceEnable pid) -> do

186 (TraceEnable pid) -> do

184 sendTrace st (createUnencodedMessage (TraceEvTakeover pid))

187 sendTrace st (createUnencodedMessage (TraceEvTakeover pid))

188+ reregister "tracer" pid

189+ sendOk setResp

185 return st { sendTrace = (mkSender pid) }

190 return st { sendTrace = (mkSender pid) }

186 TraceDisable -> do

191 TraceDisable -> do

187 sendTrace st (createUnencodedMessage TraceEvDisable)

192 sendTrace st (createUnencodedMessage TraceEvDisable)

188− return st { sendTrace = (\_ -> return ()) })

193+ sendOk setResp >> return st { sendTrace = (\_ -> return ()) })

194+ , match (\(confResp, flags') ->

189− , match (\flags' -> applyTraceFlags flags' st)

195+ sendOk confResp >> applyTraceFlags flags' st) -- setTraceFlags

190− -- we dequeue incoming messages even if we don't process them

196+ -- we dequeue incoming events even if we don't process them

191 , matchAny (\ev ->

197 , matchAny (\ev ->

192− handleMessage ev (handleTrace st ev) >>= return . fromMaybe st)

198+ handleMessage ev (handleTrace st ev) >>= return . fromMaybe st)

193 ]

199 ]

194 traceLoop st'

200 traceLoop st'

195

201

202+ sendOk :: Maybe (SendPort TraceOk) -> Process ()

203+ sendOk Nothing = return ()

204+ sendOk (Just sp) = sendChan sp TraceOk

205+

196 mkSender :: ProcessId -> (Message -> Process ())

206 mkSender :: ProcessId -> (Message -> Process ())

197 mkSender pid = (flip forward) pid

207 mkSender pid = (flip forward) pid

198

208

@@ -236,9 +246,9 @@ handleTrace st _ (TraceEvUnRegistered p n) =

236 Just ns' -> Just (Set.delete n ns')

246 Just ns' -> Just (Set.delete n ns')

237 regNames' = Map.alter f p (regNames st)

247 regNames' = Map.alter f p (regNames st)

238 in return st { regNames = regNames' }

248 in return st { regNames = regNames' }

239−handleTrace st msg ev@(TraceEvSpawned _) =

249+handleTrace st msg ev@(TraceEvSpawned _) = do

240 traceEv ev msg (traceSpawned (flags st)) st >> return st

250 traceEv ev msg (traceSpawned (flags st)) st >> return st

241−handleTrace st msg ev@(TraceEvDied _ _) =

251+handleTrace st msg ev@(TraceEvDied _ _) = do

242 traceEv ev msg (traceDied (flags st)) st >> return st

252 traceEv ev msg (traceDied (flags st)) st >> return st

243handleTrace st msg ev@(TraceEvSent _ _ _) =

253handleTrace st msg ev@(TraceEvSent _ _ _) =

244 traceEv ev msg (traceSend (flags st)) st >> return st

254 traceEv ev msg (traceSend (flags st)) st >> return st

@@ -263,8 +273,8 @@ traceEv :: TraceEvent

263 -> Maybe TraceSubject

273 -> Maybe TraceSubject

264 -> TracerState

274 -> TracerState

265 -> Process ()

275 -> Process ()

266−traceEv _ _ Nothing _ = return ()

276+traceEv _ _ Nothing _ = return ()

267−traceEv _ msg (Just TraceAll) st = (sendTrace st) msg

277+traceEv _ msg (Just TraceAll) st = (sendTrace st) msg

268traceEv ev msg (Just (TraceProcs pids)) st = do

278traceEv ev msg (Just (TraceProcs pids)) st = do

269 node <- processNode <$> ask

279 node <- processNode <$> ask

270 let p = case resolveToPid ev of

280 let p = case resolveToPid ev of

src/Control/Distributed/Process/Internal/Trace/Types.hs+9

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

8 , TraceFlags(..)

9 , defaultTraceFlags

10 , TraceArg(..)

11+ , TraceOk(..)

11 ) where

12 ) where

13import Control.Applicative ((<$>), (<*>))

14import Control.Applicative ((<$>), (<*>))

@@ -111,6 +112,10 @@ data TraceArg =

111 TraceStr String

112 TraceStr String

112 | forall a. (Show a) => Trace a

113 | forall a. (Show a) => Trace a

113

114

115+-- | A generic 'ok' response from the trace coordinator.

116+data TraceOk = TraceOk

117+ deriving (Typeable)

118+

114--------------------------------------------------------------------------------

119--------------------------------------------------------------------------------

115-- Binary Instances --

120-- Binary Instances --

116--------------------------------------------------------------------------------

121--------------------------------------------------------------------------------

@@ -176,3 +181,7 @@ instance Binary TraceFlags where

176 put (TraceFlags s d m r n c) = put s >> put d >> put m >> put r >> put n >> put c

181 put (TraceFlags s d m r n c) = put s >> put d >> put m >> put r >> put n >> put c

177 get = TraceFlags <$> get <*> get <*> get <*> get <*> get <*> get

182 get = TraceFlags <$> get <*> get <*> get <*> get <*> get <*> get

178

183

184+instance Binary TraceOk where

185+ put _ = return ()

186+ get = return TraceOk

187+

tests/TestTracing.hsnew file+123

@@ -0,0 +1,123 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# OPTIONS_GHC -fno-warn-orphans #-}

3+module Main where

5+import Control.Concurrent.MVar

6+ ( MVar

7+ , newEmptyMVar

8+ , putMVar

9+ , takeMVar

10+ )

11+import Control.Distributed.Process

12+import Control.Distributed.Process.Debug

13+import Control.Distributed.Process.Node

14+ ( forkProcess

15+ , newLocalNode

16+ , initRemoteTable

17+ , closeLocalNode

18+ , LocalNode)

19+import Control.Exception as Ex (catch)

20+import Data.Binary()

21+import Data.Typeable()

22+import Network.Transport.TCP

23+import Prelude hiding (catch, log)

24+import Test.Framework

25+ ( Test

26+ , defaultMain

27+ , testGroup

28+ )

29+import Test.HUnit (Assertion)

30+import Test.HUnit.Base (assertBool)

31+import Test.Framework.Providers.HUnit (testCase)

32+

33+import System.Environment (getEnv)

34+import System.Posix.Env

35+ ( setEnv

36+ )

37+

38+-- these utilities have been cribbed from distributed-process-platform

39+-- we should really find a way to share them...

40+

41+-- | A mutable cell containing a test result.

42+type TestResult a = MVar a

43+

44+delayedAssertion :: (Eq a) => String -> LocalNode -> a ->

45+ (TestResult a -> Process ()) -> Assertion

46+delayedAssertion note localNode expected testProc = do

47+ result <- newEmptyMVar

48+ _ <- forkProcess localNode $ testProc result

49+ assertComplete note result expected

50+

51+assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()

52+assertComplete msg mv a = do

53+ b <- takeMVar mv

54+ assertBool msg (a == b)

55+

56+stash :: TestResult a -> a -> Process ()

57+stash mvar x = liftIO $ putMVar mvar x

58+

59+------

60+

61+testSpawnTracing :: TestResult Bool -> Process ()

62+testSpawnTracing result = do

63+ setTraceFlags defaultTraceFlags {

64+ traceSpawned = (Just TraceAll)

65+ , traceDied = (Just TraceAll)

66+ }

67+

68+ evSpawned <- liftIO $ newEmptyMVar

69+ evDied <- liftIO $ newEmptyMVar

70+ startTracer $ \ev -> do

71+ case ev of

72+ (TraceEvSpawned p) -> liftIO $ putMVar evSpawned p

73+ (TraceEvDied p r) -> liftIO $ putMVar evDied (p, r)

74+ _ -> return ()

75+

76+ (sp, rp) <- newChan

77+ pid <- spawnLocal $ do

78+ sendChan sp ()

79+ () <- receiveChan rp

80+

81+ tracedAlive <- liftIO $ takeMVar evSpawned

82+ (tracedDead, tracedReason) <- liftIO $ takeMVar evDied

83+

84+ stopTracer

85+ stash result (tracedAlive == pid &&

86+ tracedDead == pid &&

87+ tracedReason == DiedNormal)

88+

89+tests :: LocalNode -> IO [Test]

90+tests node1 = do

91+ enabled <- checkTraceEnabled

92+ case enabled of

93+ True ->

94+ return [

95+ testGroup "Process Info" [

96+ testCase "Test Spawn Tracing"

97+ (delayedAssertion

98+ "expected dead process-info to be ProcessInfoNone"

99+ node1 True testSpawnTracing)

100+ ] ]

101+ False ->

102+ return []

103+

104+checkTraceEnabled :: IO Bool

105+checkTraceEnabled =

106+ Ex.catch (getEnv "DISTRIBUTED_PROCESS_TRACE_ENABLED" >> return True)

107+ (\(_ :: IOError) -> return False)

108+

109+

110+mkNode :: String -> IO LocalNode

111+mkNode port = do

112+ Right (transport1, _) <- createTransportExposeInternals

113+ "127.0.0.1" port defaultTCPParameters

114+ newLocalNode transport1 initRemoteTable

115+

116+main :: IO ()

117+main = do

118+ setEnv "DISTRIBUTED_PROCESS_TRACE_ENABLED" "true" True

119+ node1 <- mkNode "8081"

120+ testData <- tests node1

121+ defaultMain testData

122+ closeLocalNode node1

123+ return ()