deal with handles explicitly when tracing to a file

Tim Watson · Tim Watson · commit b49566ae93a5 · 2013-01-26T17:02:00.000Z
diff --git a/distributed-process/src/Control/Distributed/Process/Internal/Trace.hs b/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
diff --git a/distributed-process/src/Control/Distributed/Process/Internal/Types.hs b/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
