@@ -1,10 +1,12 @@
1−
1+-- | Simple (internal) system logging/tracing support.
22module Control.Distributed.Process.Internal.Trace
33 ( Tracer
4− , trace -- :: String -> IO ()
5− , traceFormat -- :: (Show a) => (a -> a -> String) -> [a] -> IO ()
6− , eventlog
7− , console
4+ , trace
5+ , traceFormat
6+ , startEventlogTracer
7+ , startLogfileTracer
8+ , defaultTracer
9+ , stopTracer
810 ) where
911
1012import Control.Concurrent
@@ -18,36 +20,48 @@ import Control.Concurrent.STM
1820 , writeTQueue
1921 , atomically
2022 )
23+import Control.Distributed.Process.Internal.Types (forever')
24+import Control.Exception
2125import Data.List (foldl')
22−import Debug.Trace
23− ( traceEventIO
24− )
26+import Debug.Trace (traceEventIO)
27+import System.IO
2528
2629data Tracer =
27− ConsoleTracer ThreadId (TQueue String)
30+ LogFileTracer ThreadId (TQueue String)
2831 | EventLogTracer (String -> IO ())
32+ | NoOpTracer
2933
30−eventlog :: IO Tracer
31−eventlog = return $ EventLogTracer traceEventIO
34+defaultTracer :: IO Tracer
35+defaultTracer = return NoOpTracer
3236
33−console :: IO Tracer
34−console = do
35− q <- newTQueueIO
36− tid <- forkIO $ logger q
37− return $ ConsoleTracer tid q
38− where logger q' = do
37+startEventlogTracer :: IO Tracer
38+startEventlogTracer = return $ EventLogTracer traceEventIO
39+
40+startLogfileTracer :: FilePath -> IO Tracer
41+startLogfileTracer p = do
42+ q <- newTQueueIO
43+ tid <- forkIO $ withFile p AppendMode (\h -> logger h q)
44+ return $ LogFileTracer tid q
45+ where logger :: Handle -> TQueue String -> IO ()
46+ logger h q' = forever' $ do
3947 msg <- atomically $ readTQueue q'
40− putStrLn msg
41− logger q'
48+ hPutStr h msg
49+ logger h q'
50+
51+stopTracer :: Tracer -> IO ()
52+stopTracer (LogFileTracer tid _) = throwTo tid ThreadKilled
53+stopTracer _ = return ()
4254
4355trace :: Tracer -> String -> IO ()
44−trace (ConsoleTracer _ q) msg = atomically $ writeTQueue q msg
56+trace (LogFileTracer _ q) msg = atomically $ writeTQueue q msg
4557trace (EventLogTracer t) msg = t msg
58+trace NoOpTracer _ = return ()
4659
4760traceFormat :: (Show a)
4861 => Tracer
4962 -> (String -> String -> String)
5063 -> [a]
5164 -> IO ()
65+traceFormat NoOpTracer _ _ = return ()
5266traceFormat t f xs =
5367 trace t $ foldl' (\e a -> ((show e) `f` (show a))) "" xs