3178dec · distributed-process

git.iko.soy/distributed-process

on master help sign in

Expose wrapMessageLocal and handle TraceEvLog properly

3178decTim Watson13 years ago

src/Control/Distributed/Process/Internal/Primitives.hs+11−13

compare with master

unifiedsplit

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

27 , matchMessage

28 , matchMessageIf

29 , wrapMessage

30− , wrapMessageLocal

31 , unwrapMessage

30 , unwrapMessage

32 , handleMessage

31 , handleMessage

33 , forward

32 , forward

@@ -393,27 +392,26 @@ forward msg them = do

393

392

394

393

395-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are

394-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are

396−-- 'Serializable' - like the datum they contain - but remember that deserializing

395+-- 'Serializable' - like the datum they contain - but also note, deserialising

397-- a 'Message' will yield a 'Message', not the type within it! To obtain the

396-- a 'Message' will yield a 'Message', not the type within it! To obtain the

398-- wrapped datum, use 'unwrapMessage' or 'handleMessage' with a specific type.

397-- wrapped datum, use 'unwrapMessage' or 'handleMessage' with a specific type.

399--

398--

400-- @

399-- @

401-- do

400-- do

402−-- self <- getSelfPid

401+-- self <- getSelfPid

403−-- send self (wrapMessage "blah")

402+-- send self (wrapMessage "blah")

404−-- Nothing <- expectTimeout 1000000 :: Process (Maybe String)

403+-- Nothing <- expectTimeout 1000000 :: Process (Maybe String)

405−-- (Just m) <- expectTimeout 1000000 :: Process (Maybe Message)

404+-- (Just m) <- expectTimeout 1000000 :: Process (Maybe Message)

406−-- (Just "blah") <- unwrapMessage m :: Process (Maybe String)

405+-- (Just "blah") <- unwrapMessage m :: Process (Maybe String)

407-- @

406-- @

408--

407--

409wrapMessage :: Serializable a => a -> Message

408wrapMessage :: Serializable a => a -> Message

410−wrapMessage = createMessage

409+wrapMessage = createUnencodedMessage -- see [note Serializable UnencodedMessage]

411

410

412−-- | Like 'wrapMessage', but produces a 'Message' that is only usable in the

411+-- [note Serializable UnencodedMessage]

413−-- local node. This is primarily useful when consuming the tracing and debugging

412+-- if we attempt to serialise an UnencodedMessage, it will be converted to an

414−-- APIs in "Control.Distributed.Process.Debug".

413+-- EncodedMessage first, so we're ok here. See 'messageToPayload' in

415−wrapMessageLocal :: Serializable a => a -> Message

414+-- Primitives.hs for the gory details

416−wrapMessageLocal = createUnencodedMessage

417

415

418-- | Attempt to unwrap a raw 'Message'.

416-- | Attempt to unwrap a raw 'Message'.

419-- If the type of the decoded message payload matches the expected type, the

417-- If the type of the decoded message payload matches the expected type, the

src/Control/Distributed/Process/Internal/Trace/Tracer.hs+9−3

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

29 , matchAny

30 , matchIf

31 , handleMessage

32+ , unwrapMessage

32 , matchUnknown

33 , matchUnknown

33 )

34 )

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

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

@@ -134,7 +135,8 @@ systemLoggerTracer = do

134 sendTraceMsg :: LocalNode -> TraceEvent -> Process ()

135 sendTraceMsg :: LocalNode -> TraceEvent -> Process ()

135 sendTraceMsg node ev = do

136 sendTraceMsg node ev = do

136 now <- liftIO $ getCurrentTime

137 now <- liftIO $ getCurrentTime

138+ txt <- buildTxt ev

137− msg <- return $ (formatTime defaultTimeLocale "%c" now, (show ev))

139+ msg <- return $ (formatTime defaultTimeLocale "%c" now, txt)

138 emptyPid <- return $ (nullProcessId (localNodeId node))

140 emptyPid <- return $ (nullProcessId (localNodeId node))

139 traceMsg <- return $ NCMsg {

141 traceMsg <- return $ NCMsg {

140 ctrlMsgSender = ProcessIdentifier (emptyPid)

142 ctrlMsgSender = ProcessIdentifier (emptyPid)

@@ -143,6 +145,10 @@ systemLoggerTracer = do

143 }

145 }

144 liftIO $ writeChan (localCtrlChan node) traceMsg

146 liftIO $ writeChan (localCtrlChan node) traceMsg

145

147

148+ buildTxt :: TraceEvent -> Process String

149+ buildTxt (TraceEvLog msg) = return msg

150+ buildTxt ev = return $ show ev

151+

146eventLogTracer :: Process ()

152eventLogTracer :: Process ()

147eventLogTracer =

153eventLogTracer =

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

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

@@ -304,8 +310,8 @@ handleTrace st msg ev = do

304 case (traceNodes (flags st)) of

310 case (traceNodes (flags st)) of

305 True -> sendTrace st msg

311 True -> sendTrace st msg

306 False -> return ()

312 False -> return ()

307− (TraceEvUser _) -> do

313+ (TraceEvUser _) -> sendTrace st msg

308− sendTrace st msg

314+ (TraceEvLog _) -> sendTrace st msg

309 _ ->

315 _ ->

310 case (traceConnections (flags st)) of

316 case (traceConnections (flags st)) of

311 True -> sendTrace st msg

317 True -> sendTrace st msg

src/Control/Distributed/Process/Internal/Trace/Types.hs+1−1

@@ -146,7 +146,7 @@ data TraceOk = TraceOk

146--------------------------------------------------------------------------------

147

148traceLog :: Tracer -> String -> IO ()

149−traceLog tr s = traceMessage tr (TraceEvLog s)

149+traceLog tr s = traceIt tr (createUnencodedMessage $ TraceEvLog s)

150

151traceLogFmt :: Tracer

152 -> String