git.iko.soy/distributed-process
on master help sign in
trace to the event log *or* to a file handle
d2d38f2Tim Watson
distributed-process/src/Control/Distributed/Process/Internal/Trace.hs+34−20
compare with master
unifiedsplit
@@ -1,10 +1,12 @@
1−
1+-- | Simple (internal) system logging/tracing support.
2module Control.Distributed.Process.Internal.Trace
2module Control.Distributed.Process.Internal.Trace
3 ( Tracer
3 ( Tracer
4− , trace -- :: String -> IO ()
4+ , trace
5− , traceFormat -- :: (Show a) => (a -> a -> String) -> [a] -> IO ()
5+ , traceFormat
6− , eventlog
6+ , startEventlogTracer
7− , console
7+ , startLogfileTracer
8+ , defaultTracer
9+ , stopTracer
8 ) where
10 ) where
9
11
10import Control.Concurrent
12import Control.Concurrent
@@ -18,36 +20,48 @@ import Control.Concurrent.STM
18 , writeTQueue
20 , writeTQueue
19 , atomically
21 , atomically
20 )
22 )
23+import Control.Distributed.Process.Internal.Types (forever')
24+import Control.Exception
21import Data.List (foldl')
25import Data.List (foldl')
22−import Debug.Trace
26+import Debug.Trace (traceEventIO)
23− ( traceEventIO
27+import System.IO
24− )
25
28
26data Tracer =
29data Tracer =
27− ConsoleTracer ThreadId (TQueue String)
30+ LogFileTracer ThreadId (TQueue String)
28 | EventLogTracer (String -> IO ())
31 | EventLogTracer (String -> IO ())
32+ | NoOpTracer
29
33
30−eventlog :: IO Tracer
34+defaultTracer :: IO Tracer
31−eventlog = return $ EventLogTracer traceEventIO
35+defaultTracer = return NoOpTracer
32
36
33−console :: IO Tracer
37+startEventlogTracer :: IO Tracer
34−console = do
38+startEventlogTracer = return $ EventLogTracer traceEventIO
39+
40+startLogfileTracer :: FilePath -> IO Tracer
41+startLogfileTracer p = do
35− q <- newTQueueIO
42+ q <- newTQueueIO
36− tid <- forkIO $ logger q
43+ tid <- forkIO $ withFile p AppendMode (\h -> logger h q)
37− return $ ConsoleTracer tid q
44+ return $ LogFileTracer tid q
38− where logger q' = do
45+ where logger :: Handle -> TQueue String -> IO ()
46+ logger h q' = forever' $ do
39 msg <- atomically $ readTQueue q'
47 msg <- atomically $ readTQueue q'
40− putStrLn msg
48+ hPutStr h msg
41− logger q'
49+ logger h q'
50+
51+stopTracer :: Tracer -> IO ()
52+stopTracer (LogFileTracer tid _) = throwTo tid ThreadKilled
53+stopTracer _ = return ()
42
54
43trace :: Tracer -> String -> IO ()
55trace :: Tracer -> String -> IO ()
44−trace (ConsoleTracer _ q) msg = atomically $ writeTQueue q msg
56+trace (LogFileTracer _ q) msg = atomically $ writeTQueue q msg
45trace (EventLogTracer t) msg = t msg
57trace (EventLogTracer t) msg = t msg
58+trace NoOpTracer _ = return ()
46
59
47traceFormat :: (Show a)
60traceFormat :: (Show a)
48 => Tracer
61 => Tracer
49 -> (String -> String -> String)
62 -> (String -> String -> String)
50 -> [a]
63 -> [a]
51 -> IO ()
64 -> IO ()
65+traceFormat NoOpTracer _ _ = return ()
52traceFormat t f xs =
66traceFormat t f xs =
53 trace t $ foldl' (\e a -> ((show e) `f` (show a))) "" xs
67 trace t $ foldl' (\e a -> ((show e) `f` (show a))) "" xs