module Control.Distributed.Process.Internal.Trace
( Tracer
, TraceArg(..)
, trace
, traceFormat
, startTracing
, stopTracer
) where
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (writeChan)
import Control.Concurrent.STM
( TQueue
, newTQueueIO
, readTQueue
, writeTQueue
, atomically
)
import Control.Distributed.Process.Internal.Types
( Tracer(..)
, LocalNode(..)
, NCMsg(..)
, Identifier(ProcessIdentifier)
, ProcessSignal(NamedSend)
, forever'
, nullProcessId
, createMessage
)
import Control.Exception
( catch
, throwTo
, SomeException
, AsyncException(ThreadKilled)
)
import Data.List (intersperse)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime)
import Debug.Trace (traceEventIO)
import Prelude hiding (catch)
import System.Environment (getEnv)
import System.IO
( Handle
, IOMode(AppendMode)
, BufferMode(..)
, openFile
, hClose
, hPutStrLn
, hSetBuffering
)
import System.Locale (defaultTimeLocale)
data TraceArg =
TraceStr String
| forall a. (Show a) => Trace a
startTracing :: LocalNode -> IO LocalNode
startTracing node = do
tracer <- defaultTracer node
return node { localTracer = tracer }
defaultTracer :: LocalNode -> IO Tracer
defaultTracer node = do
catch (getEnv "DISTRIBUTED_PROCESS_TRACE_FILE" >>= logfileTracer)
(\(_ :: IOError) -> defaultTracerAux node)
defaultTracerAux :: LocalNode -> IO Tracer
defaultTracerAux node = do
catch (getEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" >> procTracer node)
(\(_ :: IOError) -> return (EventLogTracer traceEventIO))
where procTracer :: LocalNode -> IO Tracer
procTracer n = return $ (LocalNodeTracer n)
logfileTracer :: FilePath -> IO Tracer
logfileTracer p = do
q <- newTQueueIO
h <- openFile p AppendMode
hSetBuffering h LineBuffering
tid <- forkIO $ logger h q `catch` (\(_ :: SomeException) ->
hClose h >> return ())
return $ LogFileTracer tid q h
where logger :: Handle -> TQueue String -> IO ()
logger h q' = forever' $ do
msg <- atomically $ readTQueue q'
now <- getCurrentTime
hPutStrLn h $ msg ++ (formatTime defaultTimeLocale " - %c" now)
stopTracer :: Tracer -> IO ()
stopTracer (LogFileTracer tid _ h) = throwTo tid ThreadKilled >> hClose h
stopTracer _ = return ()
trace :: Tracer -> String -> IO ()
trace (LogFileTracer _ q _) msg = atomically $ writeTQueue q msg
trace (LocalNodeTracer n) msg = sendTraceMsg n msg
trace (EventLogTracer t) msg = t msg
trace InactiveTracer _ = return ()
traceFormat :: Tracer
-> String
-> [TraceArg]
-> IO ()
traceFormat t d ls =
trace t $ concat (intersperse d (map toS ls))
where toS :: TraceArg -> String
toS (TraceStr s) = s
toS (Trace a) = show a
sendTraceMsg :: LocalNode -> String -> IO ()
sendTraceMsg node string = do
now <- getCurrentTime
msg <- return $ (formatTime defaultTimeLocale "%c" now, string)
emptyPid <- return $ (nullProcessId (localNodeId node))
traceMsg <- return $ NCMsg {
ctrlMsgSender = ProcessIdentifier (emptyPid)
, ctrlMsgSignal = (NamedSend "logger" (createMessage msg))
}
writeChan (localCtrlChan node) traceMsg