b3fa53c · distributed-process

git.iko.soy/distributed-process

on master help sign in

Begin to tease out an API for scoped tracing

b3fa53cTim Watson14 years ago

src/Control/Distributed/Process/Debug.hs+49−19

compare with master

unifiedsplit

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

94 , disableTrace

95 , disableTraceAsync

96 , withTracer

97+ , withFlags

98+ , getTraceFlags

97 , setTraceFlags

99 , setTraceFlags

98 , setTraceFlagsAsync

100 , setTraceFlagsAsync

99 , defaultTraceFlags

101 , defaultTraceFlags

102+ , Tracer.traceOn

103+ , Tracer.traceOnly

104+ , Tracer.traceOff

100 -- * Debugging

105 -- * Debugging

101 , startTracer

106 , startTracer

102 , stopTracer

107 , stopTracer

@@ -128,6 +133,7 @@ import Control.Distributed.Process.Internal.Primitives

128 , finally

133 , finally

129 , try

134 , try

130 , monitor

135 , monitor

136+ , say

131 )

137 )

132import Control.Distributed.Process.Internal.Types

138import Control.Distributed.Process.Internal.Types

133 ( Tracer(..)

139 ( Tracer(..)

@@ -161,6 +167,10 @@ import qualified Control.Distributed.Process.Internal.Trace.Primitives as Tracer

161 , disableTraceSync

167 , disableTraceSync

162 , setTraceFlags

168 , setTraceFlags

163 , setTraceFlagsSync

169 , setTraceFlagsSync

170+ , getTraceFlags

171+ , traceOn

172+ , traceOff

173+ , traceOnly

164 )

174 )

165import Control.Distributed.Process.Node

175import Control.Distributed.Process.Node

166import Control.Distributed.Process.Serializable

176import Control.Distributed.Process.Serializable

@@ -189,7 +199,6 @@ import Prelude hiding (catch)

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

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

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

200startTracer :: (TraceEvent -> Process ()) -> Process ProcessId

191startTracer handler = do

201startTracer handler = do

192− (sp, rp) <- newChan

193 withRegisteredTracer $ \pid -> do

202 withRegisteredTracer $ \pid -> do

194 node <- processNode <$> ask

203 node <- processNode <$> ask

195 newPid <- liftIO $ forkProcess node $ do

204 newPid <- liftIO $ forkProcess node $ do

@@ -200,9 +209,8 @@ startTracer handler = do

200 -- close succession, due to scheduling

209 -- close succession, due to scheduling

201 finally (traceProxy pid handler)

210 finally (traceProxy pid handler)

202 (resetTracer pid)

211 (resetTracer pid)

203− enableTrace newPid

212+ enableTrace newPid -- invokes sync + registration

204− sendChan sp newPid

213+ return newPid

205− receiveChan rp

206

214

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

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

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

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

@@ -212,22 +220,38 @@ withTracer :: forall a.

212 -> Process a

220 -> Process a

213 -> Process (Either SomeException a)

221 -> Process (Either SomeException a)

214withTracer handler proc = do

222withTracer handler proc = do

223+ say "starting new tracer"

215 tracer <- startTracer handler

224 tracer <- startTracer handler

216− finally (try proc)

225+ finally (try ((say "evaluating tracer proc...") >> proc))

217 (stopTracing tracer)

226 (stopTracing tracer)

218 where

227 where

219 stopTracing :: ProcessId -> Process ()

228 stopTracing :: ProcessId -> Process ()

220 stopTracing tracer = do

229 stopTracing tracer = do

230+ say "stopping tracer"

221 ref <- monitor tracer

231 ref <- monitor tracer

222 stopTracer

232 stopTracer

223 receiveWait [

233 receiveWait [

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

234 matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')

225 (\_ -> return ())

235 (\_ -> return ())

226 ]

236 ]

237+ say "stopped..."

238+

239+-- | Evaluate @proc@ with the supplied flags enabled. Any previously set

240+-- flags are restored immediately afterwards.

241+withFlags :: forall a.

242+ TraceFlags

243+ -> Process a

244+ -> Process (Either SomeException a)

245+withFlags flags proc = do

246+ (sp, rp) <- newChan

247+ withLocalTracer $ \t -> liftIO $ Tracer.getTraceFlags t sp

248+ oldFlags <- receiveChan rp

249+ finally (setTraceFlags flags >> try proc)

250+ (setTraceFlags oldFlags >> say "exit withFlags")

227

251

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

252traceProxy :: ProcessId -> (TraceEvent -> Process ()) -> Process ()

229traceProxy pid act = do

253traceProxy pid act = do

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

254+ say "tracing has started"

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

255 proxy pid $ \(ev :: TraceEvent) ->

232 case ev of

256 case ev of

233 (TraceEvTakeover _) -> die "takeover"

257 (TraceEvTakeover _) -> die "takeover"

@@ -235,7 +259,9 @@ traceProxy pid act = do

235 _ -> act ev >> return True

259 _ -> act ev >> return True

236

260

237resetTracer :: ProcessId -> Process ()

261resetTracer :: ProcessId -> Process ()

262+resetTracer pid = do

263+ say $ "resetting trace to " ++ (show pid)

238−resetTracer pid = enableTrace pid

264+ enableTrace pid

239

265

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

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

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

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

@@ -252,19 +278,17 @@ resetTracer pid = enableTrace pid

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

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

253-- have no effect.

279-- have no effect.

254stopTracer :: Process ()

280stopTracer :: Process ()

255−stopTracer = withLocalTracer $ \t ->

281+stopTracer =

256− case t of

257− InactiveTracer -> return ()

258− (ActiveTracer _ _) -> withRegisteredTracer $ \pid -> do

282+ withRegisteredTracer $ \pid -> do

259− -- we need to avoid killing the initial (base) tracer, as

283+ -- we need to avoid killing the initial (base) tracer, as

260− -- nothing we rely on having exactly 1 registered tracer

284+ -- nothing we rely on having exactly 1 registered tracer

261− -- process at all times!

285+ -- process at all times!

262− basePid <- whereis "tracer.initial"

286+ basePid <- whereis "tracer.initial"

263− case basePid == (Just pid) of

287+ case basePid == (Just pid) of

264− True -> return ()

288+ True -> return ()

265− False -> send pid TraceEvDisable

289+ False -> send pid TraceEvDisable

266

290

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

291+withRegisteredTracer :: (ProcessId -> Process a) -> Process a

268withRegisteredTracer act = do

292withRegisteredTracer act = do

269 currentTracer <- whereis "tracer"

293 currentTracer <- whereis "tracer"

270 case currentTracer of

294 case currentTracer of

@@ -301,6 +325,12 @@ disableTrace :: Process ()

301disableTrace =

325disableTrace =

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

326 withLocalTracerSync $ \t sp -> Tracer.disableTraceSync t sp

303

327

328+getTraceFlags :: Process TraceFlags

329+getTraceFlags = do

330+ (sp, rp) <- newChan

331+ withLocalTracer $ \t -> liftIO $ Tracer.getTraceFlags t sp

332+ receiveChan rp

333+

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

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

305setTraceFlagsAsync :: TraceFlags -> Process ()

335setTraceFlagsAsync :: TraceFlags -> Process ()

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

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

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

@@ -525,10 +525,12 @@ proxy :: Serializable a => ProcessId -> (a -> Process Bool) -> Process ()

525proxy pid proc = do

526 receiveWait [

527 matchAny (\m -> do

528+ say "handling proxied message..."

528 next <- handleMessage m proc

529 next <- handleMessage m proc

529 case next of

530 case next of

530− Just True -> forward m pid

531+ Just True -> say ("forwarding msg to " ++ (show pid)) >> forward m pid

531− _ -> return ())

532+ Just False -> say "ignoring explicitly ignored msg"

533+ Nothing -> say "ignoring unroutable msg")

532 ]

534 ]

533 proxy pid proc

535 proxy pid proc

534

536

src/Control/Distributed/Process/Internal/Trace/Primitives.hs+29

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

15 , enableTraceSync

16 , disableTrace

17 , disableTraceSync

18+ , getTraceFlags

18 , setTraceFlags

19 , setTraceFlags

19 , setTraceFlagsSync

20 , setTraceFlagsSync

21+ , traceOnly

22+ , traceOn

23+ , traceOff

20 ) where

24 ) where

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

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

@@ -26,6 +30,7 @@ import Control.Distributed.Process.Internal.Trace.Types

26 , SetTrace(..)

30 , SetTrace(..)

27 , TraceFlags(..)

31 , TraceFlags(..)

28 , TraceOk(..)

32 , TraceOk(..)

33+ , TraceSubject(..)

29 , defaultTraceFlags

34 , defaultTraceFlags

30 )

35 )

31import Control.Distributed.Process.Internal.Types

36import Control.Distributed.Process.Internal.Types

@@ -38,6 +43,7 @@ import Control.Distributed.Process.Internal.Types

38import Control.Distributed.Process.Serializable

43import Control.Distributed.Process.Serializable

39import Data.Foldable (forM_)

44import Data.Foldable (forM_)

40import Data.List (intersperse)

45import Data.List (intersperse)

46+import qualified Data.Set as Set (fromList)

41import System.Mem.Weak (deRefWeak)

47import System.Mem.Weak (deRefWeak)

43--------------------------------------------------------------------------------

49--------------------------------------------------------------------------------

@@ -89,6 +95,29 @@ setTraceFlagsSync :: Tracer -> SendPort TraceOk -> TraceFlags -> IO ()

89setTraceFlagsSync t s f =

95setTraceFlagsSync t s f =

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

96 traceIt t (createUnencodedMessage ((Just s), f))

98+getTraceFlags :: Tracer -> SendPort TraceFlags -> IO ()

99+getTraceFlags t s = traceIt t (createUnencodedMessage s)

100+

101+-- aux API and utilities

102+

103+class Traceable a where

104+ uod :: [a] -> TraceSubject

105+

106+instance Traceable ProcessId where

107+ uod = TraceProcs . Set.fromList

108+

109+instance Traceable String where

110+ uod = TraceNames . Set.fromList

111+

112+traceOnly :: Traceable a => [a] -> Maybe TraceSubject

113+traceOnly = Just . uod

114+

115+traceOn :: Maybe TraceSubject

116+traceOn = Just TraceAll

117+

118+traceOff :: Maybe TraceSubject

119+traceOff = Nothing

120+

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

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

93traceIt InactiveTracer _ = return ()

122traceIt InactiveTracer _ = return ()

94traceIt (ActiveTracer _ wqRef) msg = do

123traceIt (ActiveTracer _ wqRef) msg = do

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

@@ -27,7 +27,7 @@ import Control.Distributed.Process.Internal.Primitives

27 , matchAny

28 , matchAnyIf

29 , handleMessage

30− , reregister

30+ , reregister, say

31 )

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

33 ( TraceEvent(..)

@@ -190,12 +190,14 @@ traceController mv = do

190 return st { sendTrace = (mkSender pid) }

191 TraceDisable -> do

192 sendTrace st (createUnencodedMessage TraceEvDisable)

193+ sendOk setResp

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

194+ return st { sendTrace = (\_ -> return ()) })

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

195 , match (\(confResp, flags') ->

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

196+ sendOk confResp >> applyTraceFlags flags' st)

197+ , match (\chGetFlags -> sendChan chGetFlags (flags st) >> return st)

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

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

197 , matchAny (\ev ->

199 , matchAny (\ev ->

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

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

199 ]

201 ]

200 traceLoop st'

202 traceLoop st'

201

203

@@ -204,7 +206,9 @@ traceController mv = do

204 sendOk (Just sp) = sendChan sp TraceOk

206 sendOk (Just sp) = sendChan sp TraceOk

205

207

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

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

209+ mkSender pid = \m -> do

210+ say ("sending " ++ (show m) ++ " to " ++ (show pid))

207− mkSender pid = (flip forward) pid

211+ (flip forward) pid m

208

212

209 initialState :: TracerState

213 initialState :: TracerState

210 initialState =

214 initialState =

@@ -260,7 +264,7 @@ handleTrace st msg ev = do

260 case (traceNodes (flags st)) of

264 case (traceNodes (flags st)) of

261 True -> (sendTrace st) msg

265 True -> (sendTrace st) msg

262 False -> return ()

266 False -> return ()

263− (TraceEvUser _) ->

267+ (TraceEvUser _) -> do

264 (sendTrace st) msg

268 (sendTrace st) msg

265 _ ->

269 _ ->

266 case (traceConnections (flags st)) of

270 case (traceConnections (flags st)) of

tests/TestTracing.hs+122−4

@@ -82,10 +82,115 @@ testSpawnTracing result = do

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

84 stopTracer

85+ setTraceFlags defaultTraceFlags

85 stash result (tracedAlive == pid &&

86 stash result (tracedAlive == pid &&

86 tracedDead == pid &&

87 tracedDead == pid &&

87 tracedReason == DiedNormal)

88 tracedReason == DiedNormal)

90+testTraceRecvExplicitPid :: TestResult Bool -> Process ()

91+testTraceRecvExplicitPid result = do

92+ say "testTraceRecvExplicitPid"

93+ pid <- spawnLocal $ do

94+ self <- getSelfPid

95+ expect >>= (flip sendChan) self

96+ withFlags defaultTraceFlags {

97+ traceRecv = traceOnly [pid]

98+ } $ do

99+ withTracer

100+ (\ev ->

101+ case ev of

102+ (TraceEvReceived pid' _) -> stash result (pid == pid')

103+ _ -> return ()) $ do

104+ (sp, rp) <- newChan

105+ send pid sp

106+ p <- receiveChan rp

107+ res <- liftIO $ takeMVar result

108+ stash result (res && (p == pid))

109+ say "Explicit done!!!"

110+ return ()

111+

112+testTraceRecvNamedPid :: TestResult Bool -> Process ()

113+testTraceRecvNamedPid result = do

114+ say "testTraceRecvNamedPid"

115+ pid <- spawnLocal $ do

116+ self <- getSelfPid

117+ register "foobar" self

118+ expect >>= (flip sendChan) self

119+ withFlags defaultTraceFlags {

120+ traceRecv = traceOnly ["foobar"]

121+ } $ do

122+ withTracer

123+ (\ev ->

124+ case ev of

125+ (TraceEvReceived pid' _) -> stash result (pid == pid')

126+ _ -> return ()) $ do

127+ (sp, rp) <- newChan

128+ send pid sp

129+ p <- receiveChan rp

130+ res <- liftIO $ takeMVar result

131+ stash result (res && (p == pid))

132+ return ()

133+

134+data TraceWhat = User | Die | Rec

135+ deriving (Show)

136+

137+testTraceLayering :: TestResult () -> Process ()

138+testTraceLayering result = do

139+ pid <- spawnLocal $ do

140+ getSelfPid >>= register "foobar"

141+ say "registered - waiting for 'hello'"

142+ "hello" <- expect

143+ say "received 'hello' - waiting for () go"

144+ p <- expect

145+ say "pid received - sending trace msg"

146+ traceMessage ("traceMsg", 123 :: Int)

147+ say "sending reply"

148+ send p ()

149+ () <- expect

150+ return ()

151+ withFlags defaultTraceFlags {

152+ traceDied = traceOnly ["foobar"]

153+ , traceRecv = traceOnly [pid]

154+ } $ doTest pid result

155+ return ()

156+ where

157+ doTest :: ProcessId -> MVar () -> Process ()

158+ doTest pid result' = do

159+ go Die $ do

160+ go Rec $ do

161+ say "sending 'hello'"

162+ send pid "hello"

163+ go User $ do

164+ getSelfPid >>= send pid

165+ () <- expect

166+ say "received reply, returning to rec block"

167+ return ()

168+ liftIO $ putMVar result' ()

169+

170+ go :: TraceWhat -> Process () -> Process ()

171+ go what proc = do {

172+ say ("tracing " ++ (show what))

173+ ; mv <- liftIO $ newEmptyMVar

174+ ; r <- (withTracer

175+ (\ev ->

176+ case (matchTest what ev) of

177+ True -> do

178+ say ("matched " ++ (show ev))

179+ liftIO $ putMVar mv ()

180+ False -> say ("ignoring " ++ (show ev))) $ do

181+ say ("in block for " ++ (show what))

182+ proc)

183+ ; case r of

184+ Left e -> say "whoops"

185+ Right _ -> say "ok!" >> (liftIO $ takeMVar mv)

186+ }

187+

188+ matchTest :: TraceWhat -> TraceEvent -> Bool

189+ matchTest User (TraceEvUser _) = True

190+ matchTest Die (TraceEvDied _ _) = True

191+ matchTest Rec (TraceEvReceived _ _) = True

192+ matchTest _ _ = False

193+

89tests :: LocalNode -> IO [Test]

194tests :: LocalNode -> IO [Test]

90tests node1 = do

195tests node1 = do

91 enabled <- checkTraceEnabled

196 enabled <- checkTraceEnabled

@@ -94,10 +199,22 @@ tests node1 = do

94 return [

199 return [

95 testGroup "Process Info" [

200 testGroup "Process Info" [

96 testCase "Test Spawn Tracing"

201 testCase "Test Spawn Tracing"

97− (delayedAssertion

202+ (delayedAssertion

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

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

99− node1 True testSpawnTracing)

204+ node1 True testSpawnTracing)

205+ , testCase "Test Recv Tracing (Explicit Pid)"

206+ (delayedAssertion

207+ "expected a recv trace for the supplied pid"

208+ node1 True testTraceRecvExplicitPid)

209+ , testCase "Test Recv Tracing (Named Pid)"

210+ (delayedAssertion

211+ "expected a recv trace for the process registered as 'foobar'"

212+ node1 True testTraceRecvNamedPid)

213+ , testCase "Test Trace Layering"

214+ (delayedAssertion

215+ "expected blah"

216+ node1 () testTraceLayering)

100− ] ]

217+ ] ]

101 False ->

218 False ->

102 return []

219 return []

103

220

@@ -121,3 +238,4 @@ main = do

121 defaultMain testData

238 defaultMain testData

122 closeLocalNode node1

239 closeLocalNode node1

123 return ()

240 return ()

241+