packages feed

simple-log 0.3.2 → 0.3.3

raw patch · 4 files changed

+56/−24 lines, 4 filesdep +async

Dependencies added: async

Files

simple-log.cabal view
@@ -1,5 +1,5 @@ Name:                 simple-log
-Version:              0.3.2
+Version:              0.3.3
 Synopsis:             Simple log for Haskell
 Description:          Log library for Haskell with removing unnecessary traces
 License:              BSD3
@@ -16,6 +16,7 @@   HS-Source-Dirs: src
   Build-Depends:
     base >= 4.0 && < 6,
+    async >= 2.0 && < 3.0,
     containers >= 0.5 && < 0.6,
     deepseq >= 1.4 && < 1.5,
     directory >= 1.2 && < 1.3,
src/System/Log/Simple.hs view
@@ -207,7 +207,7 @@     module System.Log.Simple.File
     ) where
 
-import System.Log.Simple.Base hiding (entries, flatten, rules, writeLog, scopeLog_, scopeLog, scoperLog)
+import System.Log.Simple.Base hiding (entries, flatten, rules)
 import System.Log.Simple.Config
 import System.Log.Simple.Monad
 import System.Log.Simple.Text
src/System/Log/Simple/Base.hs view
@@ -16,6 +16,7 @@     Log(..), noLog,
     newLog,
     writeLog,
+    stopLog,
     scopeLog_,
     scopeLog,
     scoperLog
@@ -26,6 +27,7 @@ import Control.Arrow
 import qualified Control.Exception as E
 import Control.Concurrent
+import qualified Control.Concurrent.Async as A
 import Control.Concurrent.MSem
 import Control.DeepSeq
 import Control.Monad
@@ -33,6 +35,7 @@ import Control.Monad.CatchIO
 import Data.List
 import qualified Data.Map as M
+import Data.Maybe (catMaybes, isJust)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time
@@ -165,15 +168,28 @@ -- | Log
 data Log = Log {
     logPost :: Command -> IO (),
+    logStop :: IO (),
     logRules :: IO Rules }
 
 -- | Empty log
 noLog :: Log
-noLog = Log (const (return ())) (return [])
+noLog = Log (const (return ())) (return ()) (return [])
 
 -- | Type to initialize rule updater
 type RulesLoad = IO (IO Rules)
 
+type ThreadMap = M.Map ThreadId (A.Async (), Chan (Maybe Command))
+type FChan a = Chan (Maybe a)
+
+writeFChan :: FChan a -> a -> IO ()
+writeFChan ch = writeChan ch . Just
+
+stopFChan :: FChan a -> IO ()
+stopFChan ch = writeChan ch Nothing
+
+getFChanContents :: FChan a -> IO [a]
+getFChanContents = liftM (catMaybes . takeWhile isJust) . getChanContents
+
 -- | 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
@@ -181,28 +197,37 @@ newLog :: RulesLoad -> [Logger] -> IO Log
 newLog _ [] = return noLog
 newLog rsInit ls = do
-    ch <- newChan :: IO (Chan (ThreadId, Command))
-    chOut <- newChan :: IO (Chan Command)
-    cts <- getChanContents ch
-    msgs <- getChanContents chOut
+    ch <- newChan :: IO (FChan (ThreadId, Command))
+    chOut <- newChan :: IO (FChan Command)
+    cts <- getFChanContents ch
+    msgs <- getFChanContents chOut
     rs <- rsInit
     r <- rs
 
     let
         -- | Write commands from separate threads to separate channels
-        process :: M.Map ThreadId (Chan Command) -> (ThreadId, Command) -> IO (M.Map ThreadId (Chan Command))
+        process :: ThreadMap -> (ThreadId, Command) -> IO ThreadMap
         process m (thId, cmd) = do
-            thChan <- maybe newThreadChan return $ M.lookup thId m
-            writeChan thChan cmd
-            return $ M.insert thId thChan m
+            (thAsync, thChan) <- maybe newChild return $ M.lookup thId m
+            writeFChan thChan cmd
+            return $ M.insert thId (thAsync, thChan) m
 
+        -- | Stop all spawned asyncs for threads
+        stopChildren :: ThreadMap -> IO ()
+        stopChildren m = do
+            forM_ (M.elems m) $ \(thAsync, thChan) -> do
+                stopFChan thChan
+                A.wait thAsync
+            stopFChan chOut
+
         -- | New chan for thread, accepts commands from thread, writes processed messages to log-thread
-        newThreadChan :: IO (Chan Command)
-        newThreadChan = do
+        newChild :: IO (A.Async (), FChan Command)
+        newChild = do
             thChan <- newChan
-            thCts <- getChanContents thChan
-            _ <- forkIO $ mapM_ (writeChan chOut) $ uncommand thCts
-            return thChan
+            thCts <- getFChanContents thChan
+            thAsync <- A.async $ mapM_ (writeFChan chOut) $
+                uncommand thCts
+            return (thAsync, thChan)
 
         -- | Filter commands
         uncommand :: [Command] -> [Command]
@@ -229,21 +254,27 @@         writeCommand :: Command -> IO ()
         writeCommand cmd = do
             i <- myThreadId
-            writeChan ch (i, cmd)
+            writeFChan ch (i, cmd)
 
-    void $ forkIO $ void $ foldM process M.empty cts
+    p <- A.async $ void $ do
+        m <- foldM process M.empty cts
+        stopChildren m
     mapM_ (forkIO . startLog) ls
-    return $ Log writeCommand rs
+    return $ Log writeCommand (stopFChan ch >> A.wait p) rs
 
 -- | Write message to log
 writeLog :: MonadIO m => Log -> Level -> Text -> m ()
-writeLog (Log post _) l msg = liftIO $ do
+writeLog (Log post _ _) l msg = liftIO $ do
     tm <- getZonedTime
     post $ PostMessage (Message tm l [] msg)
 
+-- | Wait log messages and stop log
+stopLog :: MonadIO m => Log -> m ()
+stopLog (Log _ stop _) = liftIO stop
+
 -- | New log-scope
 scopeLog_ :: MonadCatchIO m => Log -> Text -> m a -> m a
-scopeLog_ (Log post getRules) s act = do
+scopeLog_ (Log post _ getRules) s act = do
     rs <- liftIO getRules
     sem <- liftIO $ new (0 :: Integer)
     bracket_
src/System/Log/Simple/Monad.hs view
@@ -44,13 +44,13 @@ 
 log :: (MonadLog m) => Level -> Text -> m ()
 log l msg = do
-    (Log post _) <- askLog
+    (Log post _ _) <- askLog
     tm <- liftIO getZonedTime
     liftIO $ post $ PostMessage (Message tm l [] msg)
 
 scope_ :: (MonadLog m) => Text -> m a -> m a
 scope_ s act = do
-    (Log post getRules) <- askLog
+    (Log post _ getRules) <- askLog
     rs <- liftIO getRules
     sem <- liftIO $ new (0 :: Integer)
     bracket_ (liftIO $ post $ EnterScope s rs) (liftIO (post (LeaveScope $ signal sem) >> wait sem)) act
@@ -66,7 +66,7 @@ -- | Workaround: we must explicitely post 'LeaveScope'
 scopeM_ :: (MonadLog m, MonadError e m) => Text -> m a -> m a
 scopeM_ s act = do
-    (Log post getRules) <- askLog
+    (Log post _ getRules) <- askLog
     rs <- liftIO getRules
     sem <- liftIO $ new (0 :: Integer)
     let