git.iko.soy/distributed-process
on 42ba2b9 help sign in
distributed-process/src/Control/Distributed/Process/Internal/Trace.hs
122 lines 3.6 kB history raw
1-- | Simple (internal) system logging/tracing support.
2module Control.Distributed.Process.Internal.Trace
3 ( Tracer
4 , TraceArg(..)
5 , trace
6 , traceFormat
7 , startTracing
8 , stopTracer
9 ) where
11import Control.Concurrent (forkIO)
12import Control.Concurrent.Chan (writeChan)
13import Control.Concurrent.STM
14 ( TQueue
15 , newTQueueIO
16 , readTQueue
17 , writeTQueue
18 , atomically
19 )
20import Control.Distributed.Process.Internal.Types
21 ( Tracer(..)
22 , LocalNode(..)
23 , NCMsg(..)
24 , Identifier(ProcessIdentifier)
25 , ProcessSignal(NamedSend)
26 , forever'
27 , nullProcessId
28 , createMessage
29 )
30import Control.Exception
31 ( catch
32 , throwTo
33 , SomeException
34 , AsyncException(ThreadKilled)
35 )
36import Data.List (intersperse)
37import Data.Time.Clock (getCurrentTime)
38import Data.Time.Format (formatTime)
39import Debug.Trace (traceEventIO)
41import Prelude hiding (catch)
43import System.Environment (getEnv)
44import System.IO
45 ( Handle
46 , IOMode(AppendMode)
47 , BufferMode(..)
48 , openFile
49 , hClose
50 , hPutStrLn
51 , hSetBuffering
52 )
53import System.Locale (defaultTimeLocale)
55data TraceArg =
56 TraceStr String
57 | forall a. (Show a) => Trace a
59startTracing :: LocalNode -> IO LocalNode
60startTracing node = do
61 tracer <- defaultTracer node
62 return node { localTracer = tracer }
64defaultTracer :: LocalNode -> IO Tracer
65defaultTracer node = do
66 catch (getEnv "DISTRIBUTED_PROCESS_TRACE_FILE" >>= logfileTracer)
67 (\(_ :: IOError) -> defaultTracerAux node)
69defaultTracerAux :: LocalNode -> IO Tracer
70defaultTracerAux node = do
71 catch (getEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" >> procTracer node)
72 (\(_ :: IOError) -> return (EventLogTracer traceEventIO))
73 where procTracer :: LocalNode -> IO Tracer
74 procTracer n = return $ (LocalNodeTracer n)
76logfileTracer :: FilePath -> IO Tracer
77logfileTracer p = do
78 q <- newTQueueIO
79 h <- openFile p AppendMode
80 hSetBuffering h LineBuffering
81 tid <- forkIO $ logger h q `catch` (\(_ :: SomeException) ->
82 hClose h >> return ())
83 return $ LogFileTracer tid q h
84 where logger :: Handle -> TQueue String -> IO ()
85 logger h q' = forever' $ do
86 msg <- atomically $ readTQueue q'
87 now <- getCurrentTime
88 hPutStrLn h $ msg ++ (formatTime defaultTimeLocale " - %c" now)
90-- TODO: compatibility layer for GHC/base versions (e.g., where's killThread?)
92stopTracer :: Tracer -> IO () -- overzealous but harmless duplication of hClose
93stopTracer (LogFileTracer tid _ h) = throwTo tid ThreadKilled >> hClose h
94stopTracer _ = return ()
96trace :: Tracer -> String -> IO ()
97trace (LogFileTracer _ q _) msg = atomically $ writeTQueue q msg
98trace (LocalNodeTracer n) msg = sendTraceMsg n msg
99trace (EventLogTracer t) msg = t msg
100trace InactiveTracer _ = return ()
102traceFormat :: Tracer
103 -> String
104 -> [TraceArg]
105 -> IO ()
106traceFormat t d ls =
107 trace t $ concat (intersperse d (map toS ls))
108 where toS :: TraceArg -> String
109 toS (TraceStr s) = s
110 toS (Trace a) = show a
112sendTraceMsg :: LocalNode -> String -> IO ()
113sendTraceMsg node string = do
114 now <- getCurrentTime
115 msg <- return $ (formatTime defaultTimeLocale "%c" now, string)
116 emptyPid <- return $ (nullProcessId (localNodeId node))
117 traceMsg <- return $ NCMsg {
118 ctrlMsgSender = ProcessIdentifier (emptyPid)
119 , ctrlMsgSignal = (NamedSend "logger" (createMessage msg))
120 }
121 writeChan (localCtrlChan node) traceMsg