simple-log 0.1.4 → 0.1.5

raw patch · 4 files changed

+57/−14 lines, 4 files

Files

• simple-log.cabal +7/−7
• src/System/Log/Base.hs +43/−5
• src/System/Log/Console.hs +4/−1
• src/System/Log/File.hs +3/−1

@@ -1,5 +1,5 @@ Name:                 simple-log
-Version:              0.1.4
+Version:              0.1.5
 Synopsis:             Simple log for Haskell
 Description:          Log library for Haskell with removing unnecessary traces
 License:              BSD3
@@ -17,14 +17,14 @@     base >= 4.0 && < 5,
     containers >= 0.3 && < 0.6,
     deepseq >= 1.3 && < 1.4,
-    time >= 1.3 && < 1.5,
-    text >= 0.11 && < 0.12,
-    old-locale >= 1.0 && < 1.1,
-    filepath >= 1.0 && < 1.4,
     directory >= 1.1 && < 1.3,
-    transformers >= 0.2 && < 0.4,
+    filepath >= 1.0 && < 1.4,
     MonadCatchIO-transformers >= 0.2 && < 0.4,
-    mtl >= 2.0 && < 2.2
+    mtl >= 2.0 && < 2.2,
+    old-locale >= 1.0 && < 1.1,
+    text >= 0.11 && < 0.12,
+    time >= 1.3 && < 1.5,
+    transformers >= 0.2 && < 0.4
   Exposed-Modules:
     System.Log
     System.Log.Base

@@ -29,6 +29,7 @@ import Control.DeepSeq
 import Control.Monad
 import Data.List
+import qualified Data.Map as M
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time
@@ -175,15 +176,41 @@ type RulesLoad = IO (IO Rules)
 
 -- | Create log
+--
+-- Messages from distinct threads are splitted in several chans, where they are processed, and then messages combined back and sent to log-thread
+--
 newLog :: RulesLoad -> [IO Logger] -> IO Log
 newLog _ [] = return noLog
 newLog rsInit ls = do
-    ch <- newChan
+    ch <- newChan :: IO (Chan (ThreadId, Command))
+    chOut <- newChan :: IO (Chan Message)
     cts <- getChanContents ch
+    msgs <- getChanContents chOut
     rs <- rsInit
     r <- rs
+
     let
-        msgs = flatten . rules r [] . entries $ cts
+        -- | Write commands from separate threads to separate channels
+        process :: M.Map ThreadId (Chan Command) -> (ThreadId, Command) -> IO (M.Map ThreadId (Chan Command))
+        process m (thId, cmd) = do
+            thChan <- maybe newThreadChan return $ M.lookup thId m
+            writeChan thChan cmd
+            return $ M.insert thId thChan m
+
+        -- | New chan for thread, accepts commands from thread, writes processed messages to log-thread
+        newThreadChan :: IO (Chan Command)
+        newThreadChan = do
+            thChan <- newChan
+            thCts <- getChanContents thChan
+            _ <- forkIO $ mapM_ (writeChan chOut) $ uncommand thCts
+            return thChan
+
+        -- | Convert commands to messages
+        uncommand :: [Command] -> [Message]
+        uncommand = flatten . rules r [] . entries
+
+        -- | Perform log
+        loggerLog' :: Logger -> Message -> IO ()
         loggerLog' l m = E.handle onError (m `deepseq` loggerLog l m) where
             onError :: E.SomeException -> IO ()
             onError e = E.handle ignoreError $ do
@@ -191,10 +218,21 @@                 loggerLog l $ Message tm Error ["*"] $ fromString $ "Exception during logging message: " ++ show e
             ignoreError :: E.SomeException -> IO ()
             ignoreError _ = return ()
-        startLog l = forkIO $ E.bracket l loggerClose rootScope where
+
+        -- | Initialize all loggers
+        startLog :: IO Logger -> IO ()
+        startLog l = E.bracket l loggerClose rootScope where
             rootScope l' = mapM_ (loggerLog' l') msgs
-    mapM_ startLog ls
-    return $ Log (writeChan ch) rs
+
+        -- | Write command with myThreadId
+        writeCommand :: Command -> IO ()
+        writeCommand cmd = do
+            i <- myThreadId
+            writeChan ch (i, cmd)
+
+    void $ forkIO $ void $ foldM process M.empty cts
+    mapM_ (forkIO . startLog) ls
+    return $ Log writeCommand rs
 
 -- | Write message to log
 writeLog :: Log -> Level -> Text -> IO ()

@@ -5,6 +5,9 @@ import Data.Text (Text)
 import qualified Data.Text.IO as T
 import System.Log.Base
+import System.IO
 
 console :: IO (Consumer Text)
-console = return $ Consumer True T.putStrLn (return ())
+console = do
+    hSetEncoding stdout utf8
+    return $ Consumer True T.putStrLn (return ())

@@ -14,5 +14,7 @@     createDirectoryIfMissing True $ takeDirectory f
     ex <- doesFileExist f
     let
-        putText txt = withFile f AppendMode $ \h -> T.hPutStrLn h txt
+        putText txt = withFile f AppendMode $ \h -> do
+            hSetEncoding h utf8
+            T.hPutStrLn h txt
     return $ Consumer (not ex) putText (return ())