Skip to content
Browse files

deal with handles explicitly when tracing to a file

  • Loading branch information...
1 parent 927d2bc commit b49566ae93a5d35e28c1c4b64e4aae4b86e578c6 @hyperthunk hyperthunk committed Jan 25, 2013
View
45 distributed-process/src/Control/Distributed/Process/Internal/Trace.hs
@@ -16,9 +16,19 @@ import Control.Concurrent.STM
, writeTQueue
, atomically
)
-import Control.Distributed.Process.Internal.Types (forever', Tracer(..))
-import Control.Exception (catch, throwTo, AsyncException(ThreadKilled))
+import Control.Distributed.Process.Internal.Types
+ ( forever'
+ , Tracer(..)
+ )
+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)
@@ -27,9 +37,13 @@ import System.Environment (getEnv)
import System.IO
( Handle
, IOMode(AppendMode)
- , withFile
- , hPutStr
+ , BufferMode(..)
+ , openFile
+ , hClose
+ , hPutStrLn
+ , hSetBuffering
)
+import System.Locale (defaultTimeLocale)
defaultTracer :: IO Tracer
defaultTracer = do
@@ -39,23 +53,26 @@ defaultTracer = do
logfileTracer :: FilePath -> IO Tracer
logfileTracer p = do
q <- newTQueueIO
- tid <- forkIO $ withFile p AppendMode (\h -> logger h q)
- return $ LogFileTracer tid q
+ 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'
- hPutStr h msg
- logger h q'
+ now <- getCurrentTime
+ hPutStrLn h $ msg ++ (formatTime defaultTimeLocale " - %c" now)
--- TODO: compatibility layer (conditional compilation?) for GHC/base versions
+-- TODO: compatibility layer for GHC/base versions (e.g., where's killThread?)
-stopTracer :: Tracer -> IO ()
-stopTracer (LogFileTracer tid _) = throwTo tid ThreadKilled -- cf killThread
-stopTracer _ = return ()
+stopTracer :: Tracer -> IO () -- overzealous but harmless duplication of hClose
+stopTracer (LogFileTracer tid _ h) = throwTo tid ThreadKilled >> hClose h
+stopTracer _ = return ()
trace :: Tracer -> String -> IO ()
-trace (LogFileTracer _ q) msg = atomically $ writeTQueue q msg
-trace (EventLogTracer t) msg = t msg
+trace (LogFileTracer _ q _) msg = atomically $ writeTQueue q msg
+trace (EventLogTracer t) msg = t msg
traceFormat :: Tracer
-> String
View
5 distributed-process/src/Control/Distributed/Process/Internal/Types.hs
@@ -110,6 +110,7 @@ import Control.Distributed.Process.Internal.StrictMVar (StrictMVar)
import Control.Distributed.Process.Internal.WeakTQueue (TQueue)
import Control.Distributed.Static (RemoteTable, Closure)
import qualified Control.Distributed.Process.Internal.StrictContainerAccessors as DAC (mapMaybe)
+import System.IO (Handle)
--------------------------------------------------------------------------------
-- Node and process identifiers --
@@ -181,8 +182,8 @@ nullProcessId nid =
-- | Required for system tracing in the node controller
data Tracer =
- LogFileTracer ThreadId (STM.TQueue String)
- | EventLogTracer (String -> IO ())
+ LogFileTracer !ThreadId !(STM.TQueue String) !Handle
+ | EventLogTracer !(String -> IO ())
-- | Local nodes
data LocalNode = LocalNode

0 comments on commit b49566a

Please sign in to comment.
Something went wrong with that request. Please try again.