packages feed

fast-logger 3.1.2 → 3.2.6

raw patch · 18 files changed

Files

ChangeLog.md view
@@ -1,3 +1,35 @@+## 3.2.6++* Labeling the thread of SingleLogger.++## 3.2.5++* Giving names to threads.++## 3.2.4++* Avoid unnecessary copy for Text values with text-2.0+  [#219](https://github.com/kazu-yamamoto/logger/pull/219)++## 3.2.3++* Ensuring flush for single logger.+  [#214](https://github.com/kazu-yamamoto/logger/pull/214)++## 3.2.2++* Corrected handling of messages at the buffer boundary in the SingleLogger+  [#211](https://github.com/kazu-yamamoto/logger/pull/211)++## 3.2.1++* Fixing a bug where a single logger is not killed++## 3.2.0++* newFastLogger1 ensures the ordering of logs+  [#207](https://github.com/kazu-yamamoto/logger/pull/207)+ ## 3.1.2  * Require unix-compat >= 0.2
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
System/Log/FastLogger.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP               #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs             #-}  -- | This module provides a fast logging system which --   scales on multicore environments (i.e. +RTS -N\<x\>).@@ -10,37 +10,44 @@ --   should rely more on message timestamps than on their order in the --   log. module System.Log.FastLogger (-  -- * FastLogger-    FastLogger-  , LogType-  , LogType'(..)-  , newFastLogger-  , newFastLogger1-  , withFastLogger-  -- * Timed FastLogger-  , TimedFastLogger-  , newTimedFastLogger-  , withTimedFastLogger-  -- * Log messages-  , LogStr-  , ToLogStr(..)-  , fromLogStr-  , logStrLength-  -- * Buffer size-  , BufSize-  , defaultBufSize-  -- * LoggerSet-  , module System.Log.FastLogger.LoggerSet-  -- * Date cache-  , module System.Log.FastLogger.Date-  -- * File rotation-  , module System.Log.FastLogger.File-  -- * Types-  , module System.Log.FastLogger.Types-  ) where+    -- * FastLogger+    FastLogger,+    LogType,+    LogType' (..),+    newFastLogger,+    newFastLogger1,+    withFastLogger, -import Control.Concurrent (MVar, newMVar, tryTakeMVar, putMVar)-import Control.Exception (handle, SomeException(..), bracket)+    -- * Timed FastLogger+    TimedFastLogger,+    newTimedFastLogger,+    withTimedFastLogger,++    -- * Log messages+    LogStr,+    ToLogStr (..),+    fromLogStr,+    logStrLength,++    -- * Buffer size+    BufSize,+    defaultBufSize,++    -- * LoggerSet+    module System.Log.FastLogger.LoggerSet,++    -- * Date cache+    module System.Log.FastLogger.Date,++    -- * File rotation+    module System.Log.FastLogger.File,++    -- * Types+    module System.Log.FastLogger.Types,+) where++import Control.Concurrent (MVar, newMVar, putMVar, tryTakeMVar)+import Control.Exception (SomeException (..), bracket, handle) import System.EasyFile (getFileSize)  import System.Log.FastLogger.Date@@ -55,6 +62,7 @@  -- | 'FastLogger' simply log 'logStr'. type FastLogger = LogStr -> IO ()+ -- | 'TimedFastLogger' pass 'FormattedTime' to callback and simply log its result. -- this can be used to customize how to log timestamp. --@@ -70,31 +78,44 @@  -- | Logger Type. data LogType' a where-    LogNone :: LogType' LogStr    -- ^ No logging.-    LogStdout :: BufSize -> LogType' LogStr-                                  -- ^ Logging to stdout.-                                  --   'BufSize' is a buffer size-                                  --   for each capability.-    LogStderr :: BufSize -> LogType' LogStr-                                  -- ^ Logging to stderr.-                                  --   'BufSize' is a buffer size-                                  --   for each capability.-    LogFileNoRotate :: FilePath -> BufSize -> LogType' LogStr-                                  -- ^ Logging to a file.-                                  --   'BufSize' is a buffer size-                                  --   for each capability.-    LogFile :: FileLogSpec -> BufSize -> LogType' LogStr-                                  -- ^ Logging to a file.-                                  --   'BufSize' is a buffer size-                                  --   for each capability.-                                  --   File rotation is done on-demand.-    LogFileTimedRotate :: TimedFileLogSpec -> BufSize -> LogType' LogStr -- ^ Logging to a file.-                                  --   'BufSize' is a buffer size-                                  --   for each capability.-                                  --   Rotation happens based on check specified-                                  --   in 'TimedFileLogSpec'.-    LogCallback :: (v -> IO ()) -> IO () -> LogType' v  -- ^ Logging with a log and flush action.-                                                          -- run flush after log each message.+    LogNone :: LogType' LogStr+        -- ^ No logging.+    LogStdout :: BufSize+        -> LogType' LogStr+        -- ^ Logging to stdout.+        --   'BufSize' is a buffer size+        --   for each capability.+    LogStderr :: BufSize+        -> LogType' LogStr+        -- ^ Logging to stderr.+        --   'BufSize' is a buffer size+        --   for each capability.+    LogFileNoRotate :: FilePath+        -> BufSize+        -> LogType' LogStr+        -- ^ Logging to a file.+        --   'BufSize' is a buffer size+        --   for each capability.+    LogFile :: FileLogSpec+        -> BufSize+        -> LogType' LogStr+        -- ^ Logging to a file.+        --   'BufSize' is a buffer size+        --   for each capability.+        --   File rotation is done on-demand.+    LogFileTimedRotate :: TimedFileLogSpec+        -> BufSize+        -> LogType' LogStr+        -- ^ Logging to a file.+        --   'BufSize' is a buffer size+        --   for each capability.+        --   Rotation happens based on check specified+        --   in 'TimedFileLogSpec'.+    LogCallback :: (v -> IO ())+        -> IO ()+        -> LogType' v+        -- ^ Logging with a log and flush action.+        -- run flush after log each message.  -- | Initialize a 'FastLogger' without attaching timestamp -- a tuple of logger and clean up action are returned.@@ -109,20 +130,21 @@ newFastLogger typ = newFastLoggerCore Nothing typ  -- | Like `newFastLogger`, but creating a logger that uses only 1--- capability. This scales less well on multi-core machines,--- but provides time-ordered output.+-- internal builder. This scales less on multi-core machines and+-- consumes more memory because of an internal queue but provides+-- time-ordered output. newFastLogger1 :: LogType' v -> IO (v -> IO (), IO ()) newFastLogger1 typ = newFastLoggerCore (Just 1) typ  newFastLoggerCore :: Maybe Int -> LogType' v -> IO (v -> IO (), IO ()) newFastLoggerCore mn typ = case typ of-    LogNone                        -> return (const noOp, noOp)-    LogStdout bsize                -> newStdoutLoggerSetN bsize mn >>= stdLoggerInit-    LogStderr bsize                -> newStderrLoggerSetN bsize mn >>= stdLoggerInit-    LogFileNoRotate fp bsize       -> newFileLoggerSetN bsize mn fp >>= fileLoggerInit-    LogFile fspec bsize            -> rotateLoggerInit fspec bsize+    LogNone -> return (const noOp, noOp)+    LogStdout bsize -> newStdoutLoggerSetN bsize mn >>= stdLoggerInit+    LogStderr bsize -> newStderrLoggerSetN bsize mn >>= stdLoggerInit+    LogFileNoRotate fp bsize -> newFileLoggerSetN bsize mn fp >>= fileLoggerInit+    LogFile fspec bsize -> rotateLoggerInit fspec bsize     LogFileTimedRotate fspec bsize -> timedRotateLoggerInit fspec bsize-    LogCallback cb flush           -> return (\str -> cb str >> flush, noOp)+    LogCallback cb flush -> return (\str -> cb str >> flush, noOp)   where     stdLoggerInit lgrset = return (pushLogStr lgrset, rmLoggerSet lgrset)     fileLoggerInit lgrset = return (pushLogStr lgrset, rmLoggerSet lgrset)@@ -154,20 +176,22 @@  -- | Initialize a 'FastLogger' with timestamp attached to each message. -- a tuple of logger and clean up action are returned.-newTimedFastLogger ::-    IO FormattedTime    -- ^ How do we get 'FormattedTime'?-                        -- "System.Log.FastLogger.Date" provide cached formatted time.-    -> LogType -> IO (TimedFastLogger, IO ())+newTimedFastLogger+    :: IO FormattedTime+    -- ^ How do we get 'FormattedTime'?+    -- "System.Log.FastLogger.Date" provide cached formatted time.+    -> LogType+    -> IO (TimedFastLogger, IO ()) newTimedFastLogger tgetter typ = case typ of-    LogNone                        -> return (const noOp, noOp)-    LogStdout bsize                -> newStdoutLoggerSet bsize >>= stdLoggerInit-    LogStderr bsize                -> newStderrLoggerSet bsize >>= stdLoggerInit-    LogFileNoRotate fp bsize       -> newFileLoggerSet bsize fp >>= fileLoggerInit-    LogFile fspec bsize            -> rotateLoggerInit fspec bsize+    LogNone -> return (const noOp, noOp)+    LogStdout bsize -> newStdoutLoggerSet bsize >>= stdLoggerInit+    LogStderr bsize -> newStderrLoggerSet bsize >>= stdLoggerInit+    LogFileNoRotate fp bsize -> newFileLoggerSet bsize fp >>= fileLoggerInit+    LogFile fspec bsize -> rotateLoggerInit fspec bsize     LogFileTimedRotate fspec bsize -> timedRotateLoggerInit fspec bsize-    LogCallback cb flush           -> return (\f -> tgetter >>= cb . f >> flush, noOp)+    LogCallback cb flush -> return (\f -> tgetter >>= cb . f >> flush, noOp)   where-    stdLoggerInit lgrset = return ( \f -> tgetter >>= pushLogStr lgrset . f, rmLoggerSet lgrset)+    stdLoggerInit lgrset = return (\f -> tgetter >>= pushLogStr lgrset . f, rmLoggerSet lgrset)     fileLoggerInit lgrset = return (\f -> tgetter >>= pushLogStr lgrset . f, rmLoggerSet lgrset)     rotateLoggerInit fspec bsize = do         lgrset <- newFileLoggerSet bsize $ log_file fspec@@ -194,7 +218,8 @@         return (logger, rmLoggerSet lgrset)  -- | 'bracket' version of 'newTimeFastLogger'-withTimedFastLogger :: IO FormattedTime -> LogType -> (TimedFastLogger -> IO a) -> IO a+withTimedFastLogger+    :: IO FormattedTime -> LogType -> (TimedFastLogger -> IO a) -> IO a withTimedFastLogger tgetter typ log' = bracket (newTimedFastLogger tgetter typ) snd (log' . fst)  ----------------------------------------------------------------@@ -206,17 +231,21 @@ decrease ref = atomicModifyIORef' ref (\x -> (x - 1, x - 1))  -- updateTime returns whether the timeframe has changed-updateTime :: (FormattedTime -> FormattedTime -> Bool) -> IORef FormattedTime -> FormattedTime -> IO Bool+updateTime+    :: (FormattedTime -> FormattedTime -> Bool)+    -> IORef FormattedTime+    -> FormattedTime+    -> IO Bool updateTime cmp ref newTime = atomicModifyIORef' ref (\x -> (newTime, not $ cmp x newTime))  tryRotate :: LoggerSet -> FileLogSpec -> IORef Int -> MVar () -> IO () tryRotate lgrset spec ref mvar = bracket lock unlock rotateFiles   where-    lock           = tryTakeMVar mvar+    lock = tryTakeMVar mvar     unlock Nothing = return ()-    unlock _       = putMVar mvar ()+    unlock _ = putMVar mvar ()     rotateFiles Nothing = return ()-    rotateFiles _       = do+    rotateFiles _ = do         msiz <- getSize         case msiz of             -- A file is not available.@@ -232,25 +261,26 @@                     writeIORef ref $ estimate (limit - siz)     file = log_file spec     limit = log_file_size spec-    getSize = handle (\(SomeException _) -> return Nothing) $-        -- The log file is locked by GHC.-        -- We need to get its file size by the way not using locks.-        Just . fromIntegral <$> getFileSize file+    getSize =+        handle (\(SomeException _) -> return Nothing) $+            -- The log file is locked by GHC.+            -- We need to get its file size by the way not using locks.+            Just . fromIntegral <$> getFileSize file     -- 200 is an ad-hoc value for the length of log line.     estimate x = fromInteger (x `div` 200)  tryTimedRotate :: TimedFileLogSpec -> FormattedTime -> MVar LoggerSet -> IO () tryTimedRotate spec now mvar = bracket lock unlock rotateFiles   where-    lock           = tryTakeMVar mvar+    lock = tryTakeMVar mvar     unlock Nothing = return ()     unlock (Just lgrset) = do         let (newlgrset, current_path) = replaceLoggerSet lgrset new_file_path         putMVar mvar newlgrset         case current_path of-          Nothing   -> return ()-          Just path -> timed_post_process spec path-    rotateFiles Nothing  = return ()+            Nothing -> return ()+            Just path -> timed_post_process spec path+    rotateFiles Nothing = return ()     rotateFiles (Just lgrset) = do         let (newlgrset, _) = replaceLoggerSet lgrset new_file_path         renewLoggerSet newlgrset
System/Log/FastLogger/Date.hs view
@@ -4,24 +4,25 @@ -- | -- Formatting time is slow. -- This package provides mechanisms to cache formatted date.-module System.Log.FastLogger.Date-  ( -- * Date cacher-    newTimeCache-  , simpleTimeFormat-  , simpleTimeFormat'-  ) where+module System.Log.FastLogger.Date (+    -- * Date cacher+    newTimeCache,+    simpleTimeFormat,+    simpleTimeFormat',+) where -import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction)-import System.Log.FastLogger.Types (TimeFormat, FormattedTime)+import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, updateAction, updateThreadName) import Data.UnixTime (formatUnixTime, fromEpochTime)-import System.PosixCompat.Types (EpochTime)+import System.Log.FastLogger.Types (FormattedTime, TimeFormat) import System.PosixCompat.Time (epochTime)+import System.PosixCompat.Types (EpochTime)  ----------------------------------------------------------------  -- | Get date using UnixTime. getTime :: IO EpochTime getTime = epochTime+ -- | Format unix EpochTime date. formatDate :: TimeFormat -> EpochTime -> IO FormattedTime formatDate fmt = formatUnixTime fmt . fromEpochTime@@ -33,9 +34,12 @@ -- auto updating formatted time, this cache update every 1 second. -- more detail in "Control.AutoUpdate" newTimeCache :: TimeFormat -> IO (IO FormattedTime)-newTimeCache fmt = mkAutoUpdate defaultUpdateSettings{-        updateAction = getTime >>= formatDate fmt-    }+newTimeCache fmt =+    mkAutoUpdate+        defaultUpdateSettings+            { updateAction = getTime >>= formatDate fmt+            , updateThreadName = "Date string cacher of FastLogger (AutoUpdate)"+            }  -- | A simple time cache using format @"%d/%b/%Y:%T %z"@ simpleTimeFormat :: TimeFormat
System/Log/FastLogger/File.hs view
@@ -3,27 +3,35 @@ {-# LANGUAGE Safe #-} #endif -module System.Log.FastLogger.File-    ( FileLogSpec(..)-    , TimedFileLogSpec (..)-    , check-    , rotate-    , prefixTime-    ) where+module System.Log.FastLogger.File (+    FileLogSpec (..),+    TimedFileLogSpec (..),+    check,+    rotate,+    prefixTime,+) where  import Data.ByteString.Char8 (unpack)-import System.Directory (doesFileExist, doesDirectoryExist, getPermissions, writable, renameFile)-import System.FilePath (takeDirectory, dropFileName, takeFileName, (</>))+import System.Directory (+    doesDirectoryExist,+    doesFileExist,+    getPermissions,+    renameFile,+    writable,+ )+import System.FilePath (dropFileName, takeDirectory, takeFileName, (</>))  import System.Log.FastLogger.Imports-import System.Log.FastLogger.Types (TimeFormat, FormattedTime)+import System.Log.FastLogger.Types (FormattedTime, TimeFormat)  -- | The spec for logging files-data FileLogSpec = FileLogSpec {-    log_file :: FilePath-  , log_file_size :: Integer -- ^ Max log file size (in bytes) before requiring rotation.-  , log_backup_number :: Int -- ^ Max number of rotated log files to keep around before overwriting the oldest one.-  }+data FileLogSpec = FileLogSpec+    { log_file :: FilePath+    , log_file_size :: Integer+    -- ^ Max log file size (in bytes) before requiring rotation.+    , log_backup_number :: Int+    -- ^ Max number of rotated log files to keep around before overwriting the oldest one.+    }  -- | The spec for time based rotation. It supports post processing of log files. Does -- not delete any logs. Example:@@ -38,17 +46,20 @@ --        compressFile fp = void . forkIO $ --            callProcess "tar" [ "--remove-files", "-caf", fp <> ".gz", fp ] -- @-data TimedFileLogSpec = TimedFileLogSpec {-    timed_log_file :: FilePath              -- ^ base file path-  , timed_timefmt  :: TimeFormat            -- ^ time format to prepend-  , timed_same_timeframe  :: FormattedTime -> FormattedTime -> Bool-                                            -- ^ function that compares two-                                            --   formatted times as specified by-                                            --   timed_timefmt and decides if a-                                            --   new rotation is supposed to-                                            --   begin-  , timed_post_process :: FilePath -> IO () -- ^ processing function called asynchronously after a file is added to the rotation-  }+data TimedFileLogSpec = TimedFileLogSpec+    { timed_log_file :: FilePath+    -- ^ base file path+    , timed_timefmt :: TimeFormat+    -- ^ time format to prepend+    , timed_same_timeframe :: FormattedTime -> FormattedTime -> Bool+    -- ^ function that compares two+    --   formatted times as specified by+    --   timed_timefmt and decides if a+    --   new rotation is supposed to+    --   begin+    , timed_post_process :: FilePath -> IO ()+    -- ^ processing function called asynchronously after a file is added to the rotation+    }  -- | Checking if a log file can be written. check :: FilePath -> IO ()@@ -70,11 +81,11 @@   where     path = log_file spec     n = log_backup_number spec-    dsts' = reverse . ("":) . map (('.':). show) $ [0..n-1]-    dsts = map (path++) dsts'-    srcs = tail dsts+    dsts' = reverse . ("" :) . map (('.' :) . show) $ [0 .. n - 1]+    dsts = map (path ++) dsts'+    srcs = drop 1 dsts     srcdsts = zip srcs dsts-    move (src,dst) = do+    move (src, dst) = do         exist <- doesFileExist src         when exist $ renameFile src dst
System/Log/FastLogger/FileIO.hs view
@@ -2,9 +2,9 @@  import Foreign.Ptr (Ptr) import GHC.IO.Device (close)-import GHC.IO.FD (openFile, stderr, stdout,  writeRawBufferPtr)-import qualified GHC.IO.FD as POSIX (FD(..))-import GHC.IO.IOMode (IOMode(..))+import GHC.IO.FD (openFile, stderr, stdout, writeRawBufferPtr)+import qualified GHC.IO.FD as POSIX (FD (..))+import GHC.IO.IOMode (IOMode (..))  import System.Log.FastLogger.Imports @@ -25,13 +25,14 @@ writeRawBufferPtr2FD :: IORef FD -> Ptr Word8 -> Int -> IO Int writeRawBufferPtr2FD fdref bf len = do     fd <- readIORef fdref-    if isFDValid fd then-        fromIntegral <$> writeRawBufferPtr "write" fd bf 0 (fromIntegral len)-      else-        return (-1)+    if isFDValid fd+        then+            fromIntegral <$> writeRawBufferPtr "write" fd bf 0 (fromIntegral len)+        else+            return (-1)  invalidFD :: POSIX.FD-invalidFD = stdout { POSIX.fdFD = -1 }+invalidFD = stdout{POSIX.fdFD = -1}  isFDValid :: POSIX.FD -> Bool isFDValid fd = POSIX.fdFD fd /= -1
System/Log/FastLogger/IO.hs view
@@ -8,10 +8,10 @@  module System.Log.FastLogger.IO where -import Data.ByteString.Builder.Extra (Next(..))+import Data.ByteString.Builder.Extra (Next (..)) import qualified Data.ByteString.Builder.Extra as BBE import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Marshal.Alloc (mallocBytes, free)+import Foreign.Marshal.Alloc (free, mallocBytes) import Foreign.Ptr (Ptr, plusPtr)  import System.Log.FastLogger.Imports@@ -39,9 +39,9 @@         (len, next) <- writer buf size         io buf len         case next of-             Done -> return ()-             More minSize writer'-               | size < minSize -> error "toBufIOWith: More: minSize"-               | otherwise      -> loop writer'-             Chunk (PS fptr off siz) writer' ->-               withForeignPtr fptr $ \ptr -> io (ptr `plusPtr` off) siz >> loop writer'+            Done -> return ()+            More minSize writer'+                | size < minSize -> error "toBufIOWith: More: minSize"+                | otherwise -> loop writer'+            Chunk (PS fptr off siz) writer' ->+                withForeignPtr fptr $ \ptr -> io (ptr `plusPtr` off) siz >> loop writer'
System/Log/FastLogger/Imports.hs view
@@ -1,22 +1,22 @@ {-# LANGUAGE Trustworthy #-}  module System.Log.FastLogger.Imports (-    ByteString(..)-  , module Control.Applicative-  , module Control.Monad-  , module Data.IORef-  , module Data.List-  , module Data.Int-  , module Data.Monoid-  , module Data.Ord-  , module Data.Word-  , module Data.Maybe-  , module Numeric-  ) where+    ByteString (..),+    module Control.Applicative,+    module Control.Monad,+    module Data.IORef,+    module Data.List,+    module Data.Int,+    module Data.Monoid,+    module Data.Ord,+    module Data.Word,+    module Data.Maybe,+    module Numeric,+) where  import Control.Applicative import Control.Monad-import Data.ByteString.Internal (ByteString(..))+import Data.ByteString.Internal (ByteString (..)) import Data.IORef import Data.Int import Data.List
System/Log/FastLogger/Internal.hs view
@@ -1,15 +1,19 @@ -- | -- The contents of this module can change at any time without warning.-module System.Log.FastLogger.Internal-  ( module System.Log.FastLogger.IO-  , module System.Log.FastLogger.FileIO-  , module System.Log.FastLogger.LogStr-  , module System.Log.FastLogger.Logger-  , module System.Log.FastLogger.LoggerSet-  ) where+module System.Log.FastLogger.Internal (+    module System.Log.FastLogger.IO,+    module System.Log.FastLogger.FileIO,+    module System.Log.FastLogger.LogStr,+    module System.Log.FastLogger.SingleLogger,+    module System.Log.FastLogger.MultiLogger,+    module System.Log.FastLogger.Write,+    module System.Log.FastLogger.LoggerSet,+) where -import System.Log.FastLogger.IO import System.Log.FastLogger.FileIO+import System.Log.FastLogger.IO import System.Log.FastLogger.LogStr-import System.Log.FastLogger.Logger import System.Log.FastLogger.LoggerSet+import System.Log.FastLogger.MultiLogger+import System.Log.FastLogger.SingleLogger+import System.Log.FastLogger.Write
System/Log/FastLogger/LogStr.hs view
@@ -1,16 +1,16 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-}  module System.Log.FastLogger.LogStr (-    Builder-  , LogStr(..)-  , logStrLength-  , fromLogStr-  , ToLogStr(..)-  , mempty-  , (<>)-  ) where+    Builder,+    LogStr (..),+    logStrLength,+    fromLogStr,+    ToLogStr (..),+    mempty,+    (<>),+) where  import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder)@@ -21,9 +21,12 @@ #if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as Semi (Semigroup(..)) #endif-import Data.String (IsString(..))+import Data.String (IsString (..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T+#if MIN_VERSION_text(2,0,0)+import qualified Data.Text.Foreign as T+#endif import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL @@ -50,12 +53,14 @@ instance Semi.Semigroup LogStr where     {-# INLINE (<>) #-}     LogStr s1 b1 <> LogStr s2 b2 = LogStr (s1 + s2) (b1 <> b2)-#endif- instance Monoid LogStr where     mempty = LogStr 0 (toBuilder BS.empty)+#else+instance Monoid LogStr where+    mempty = LogStr 0 (toBuilder BS.empty)     {-# INLINE mappend #-}     LogStr s1 b1 `mappend` LogStr s2 b2 = LogStr (s1 + s2) (b1 <> b2)+#endif  instance IsString LogStr where     {-# INLINE fromString #-}@@ -78,7 +83,9 @@     toLogStr b = LogStr (fromIntegral (BL.length b)) (B.lazyByteString b) instance ToLogStr Builder where     {-# INLINE toLogStr #-}-    toLogStr x = let b = B.toLazyByteString x in LogStr (fromIntegral (BL.length b)) (B.lazyByteString b)+    toLogStr x =+        let b = B.toLazyByteString x+         in LogStr (fromIntegral (BL.length b)) (B.lazyByteString b) instance ToLogStr SBS.ShortByteString where     {-# INLINE toLogStr #-}     toLogStr b = LogStr (SBS.length b) (B.shortByteString b)@@ -87,27 +94,38 @@     toLogStr = toLogStr . TL.pack instance ToLogStr T.Text where     {-# INLINE toLogStr #-}+#if MIN_VERSION_text(2,0,0)+    toLogStr t = LogStr (T.lengthWord8 t) (T.encodeUtf8Builder t)+#else     toLogStr = toLogStr . T.encodeUtf8+#endif instance ToLogStr TL.Text where     {-# INLINE toLogStr #-}+#if MIN_VERSION_text(2,0,0)+    toLogStr t = LogStr (TL.foldlChunks (\n c -> T.lengthWord8 c + n) 0 t) (TL.encodeUtf8Builder t)+#else     toLogStr = toLogStr . TL.encodeUtf8-+#endif -- | @since 2.4.14 instance ToLogStr Int where     {-# INLINE toLogStr #-}     toLogStr = toLogStr . B.intDec+ -- | @since 2.4.14 instance ToLogStr Int8 where     {-# INLINE toLogStr #-}     toLogStr = toLogStr . B.int8Dec+ -- | @since 2.4.14 instance ToLogStr Int16 where     {-# INLINE toLogStr #-}     toLogStr = toLogStr . B.int16Dec+ -- | @since 2.4.14 instance ToLogStr Int32 where     {-# INLINE toLogStr #-}     toLogStr = toLogStr . B.int32Dec+ -- | @since 2.4.14 instance ToLogStr Int64 where     {-# INLINE toLogStr #-}@@ -117,18 +135,22 @@ instance ToLogStr Word where     {-# INLINE toLogStr #-}     toLogStr = toLogStr . B.wordDec+ -- | @since 2.4.14 instance ToLogStr Word8 where     {-# INLINE toLogStr #-}     toLogStr = toLogStr . B.word8Dec+ -- | @since 2.4.14 instance ToLogStr Word16 where     {-# INLINE toLogStr #-}     toLogStr = toLogStr . B.word16Dec+ -- | @since 2.4.14 instance ToLogStr Word32 where     {-# INLINE toLogStr #-}     toLogStr = toLogStr . B.word32Dec+ -- | @since 2.4.14 instance ToLogStr Word64 where     {-# INLINE toLogStr #-}@@ -138,20 +160,22 @@ instance ToLogStr Integer where     {-# INLINE toLogStr #-}     toLogStr = toLogStr . B.integerDec+ -- | @since 2.4.14 instance ToLogStr Float where     {-# INLINE toLogStr #-}     toLogStr = toLogStr . B.floatDec+ -- | @since 2.4.14 instance ToLogStr Double where     {-# INLINE toLogStr #-}     toLogStr = toLogStr . B.doubleDec  instance Show LogStr where-  show = show . T.decodeUtf8 . fromLogStr+    show = show . T.decodeUtf8 . fromLogStr  instance Eq LogStr where-  a == b = fromLogStr a == fromLogStr b+    a == b = fromLogStr a == fromLogStr b  -- | Obtaining the length of 'LogStr'. logStrLength :: LogStr -> Int
− System/Log/FastLogger/Logger.hs 
@@ -1,85 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Safe #-}--module System.Log.FastLogger.Logger (-    Logger(..)-  , newLogger-  , pushLog-  , flushLog-  ) where---import Control.Concurrent (MVar, withMVar)-import Foreign.Marshal.Alloc (allocaBytes)-import Foreign.Ptr (plusPtr)--import System.Log.FastLogger.FileIO-import System.Log.FastLogger.IO-import System.Log.FastLogger.Imports-import System.Log.FastLogger.LogStr--------------------------------------------------------------------newtype Logger = Logger (IORef LogStr)--------------------------------------------------------------------newLogger :: IO Logger-newLogger = Logger <$> newIORef mempty--------------------------------------------------------------------pushLog :: IORef FD -> BufSize -> MVar Buffer -> Logger -> LogStr -> IO ()-pushLog fdref size mbuf logger@(Logger ref) nlogmsg@(LogStr nlen nbuilder)-  | nlen > size = do-      flushLog fdref size mbuf logger-      -- Make sure we have a large enough buffer to hold the entire-      -- contents, thereby allowing for a single write system call and-      -- avoiding interleaving. This does not address the possibility-      -- of write not writing the entire buffer at once.-      allocaBytes nlen $ \buf -> withMVar mbuf $ \_ ->-        toBufIOWith buf nlen (write fdref) nbuilder-  | otherwise = do-    mmsg <- atomicModifyIORef' ref checkBuf-    case mmsg of-        Nothing  -> return ()-        Just msg -> withMVar mbuf $ \buf -> writeLogStr fdref buf size msg-  where-    checkBuf ologmsg@(LogStr olen _)-      | size < olen + nlen = (nlogmsg, Just ologmsg)-      | otherwise          = (ologmsg <> nlogmsg, Nothing)--------------------------------------------------------------------flushLog :: IORef FD -> BufSize -> MVar Buffer -> Logger -> IO ()-flushLog fdref size mbuf (Logger lref) = do-    logmsg <- atomicModifyIORef' lref (\old -> (mempty, old))-    -- If a special buffer is prepared for flusher, this MVar could-    -- be removed. But such a code does not contribute logging speed-    -- according to experiment. And even with the special buffer,-    -- there is no grantee that this function is exclusively called-    -- for a buffer. So, we use MVar here.-    -- This is safe and speed penalty can be ignored.-    withMVar mbuf $ \buf -> writeLogStr fdref buf size logmsg---------------------------------------------------------------------- | Writting 'LogStr' using a buffer in blocking mode.---   The size of 'LogStr' must be smaller or equal to---   the size of buffer.-writeLogStr :: IORef FD-            -> Buffer-            -> BufSize-            -> LogStr-            -> IO ()-writeLogStr fdref buf size (LogStr len builder)-  | size < len = error "writeLogStr"-  | otherwise  = toBufIOWith buf size (write fdref) builder--write :: IORef FD -> Buffer -> Int -> IO ()-write fdref buf len' = loop buf (fromIntegral len')-  where-    loop bf len = do-        written <- writeRawBufferPtr2FD fdref bf len-        when (0 <= written && written < len) $-            loop (bf `plusPtr` fromIntegral written) (len - written)
System/Log/FastLogger/LoggerSet.hs view
@@ -1,48 +1,62 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}  module System.Log.FastLogger.LoggerSet (-  -- * Creating a logger set-    LoggerSet-  , newFileLoggerSet-  , newFileLoggerSetN-  , newStdoutLoggerSet-  , newStdoutLoggerSetN-  , newStderrLoggerSet-  , newStderrLoggerSetN-  , newLoggerSet-  , newFDLoggerSet-  -- * Renewing and removing a logger set-  , renewLoggerSet-  , rmLoggerSet-  -- * Writing a log message-  , pushLogStr-  , pushLogStrLn-  -- * Flushing buffered log messages-  , flushLogStr-  -- * Misc-  , replaceLoggerSet-  ) where+    -- * Creating a logger set+    LoggerSet,+    newFileLoggerSet,+    newFileLoggerSetN,+    newStdoutLoggerSet,+    newStdoutLoggerSetN,+    newStderrLoggerSet,+    newStderrLoggerSetN,+    newLoggerSet,+    newFDLoggerSet, -import Control.Concurrent (MVar, getNumCapabilities, myThreadId, threadCapability, takeMVar, newMVar)-import Control.Debounce (mkDebounce, defaultDebounceSettings, debounceAction)-import Data.Array (Array, listArray, (!), bounds)+    -- * Renewing and removing a logger set+    renewLoggerSet,+    rmLoggerSet, +    -- * Writing a log message+    pushLogStr,+    pushLogStrLn,++    -- * Flushing buffered log messages+    flushLogStr,++    -- * Misc+    replaceLoggerSet,+) where++import Control.Concurrent (getNumCapabilities)+import Control.Debounce (debounceAction, defaultDebounceSettings, mkDebounce, debounceThreadName)+ import System.Log.FastLogger.FileIO import System.Log.FastLogger.IO import System.Log.FastLogger.Imports import System.Log.FastLogger.LogStr-import System.Log.FastLogger.Logger+import System.Log.FastLogger.MultiLogger (MultiLogger)+import qualified System.Log.FastLogger.MultiLogger as M+import System.Log.FastLogger.SingleLogger (SingleLogger)+import qualified System.Log.FastLogger.SingleLogger as S+import System.Log.FastLogger.Write  ---------------------------------------------------------------- +data Logger = SL SingleLogger | ML MultiLogger++----------------------------------------------------------------+ -- | A set of loggers. --   The number of loggers is the capabilities of GHC RTS. --   You can specify it with \"+RTS -N\<x\>\". --   A buffer is prepared for each capability.-data LoggerSet = LoggerSet (Maybe FilePath) (IORef FD)-                           BufSize (MVar Buffer)-                           (Array Int Logger)-                           (IO ())+data LoggerSet = LoggerSet+    { lgrsetFilePath :: Maybe FilePath+    , lgrsetFdRef :: IORef FD+    , lgrsetLogger :: Logger+    , lgrsetDebounce :: IO ()+    }  -- | Creating a new 'LoggerSet' using a file. --@@ -77,6 +91,7 @@ newStderrLoggerSetN size mn = getStderrFD >>= newFDLoggerSet size mn Nothing  {-# DEPRECATED newLoggerSet "Use newFileLoggerSet etc instead" #-}+ -- | Creating a new 'LoggerSet'. --   If 'Nothing' is specified to the second argument, --   stdout is used.@@ -88,33 +103,41 @@ newFDLoggerSet :: BufSize -> Maybe Int -> Maybe FilePath -> FD -> IO LoggerSet newFDLoggerSet size mn mfile fd = do     n <- case mn of-      Just n' -> return n'-      Nothing -> getNumCapabilities-    loggers <- replicateM n newLogger-    let arr = listArray (0,n-1) loggers-    fref <- newIORef fd+        Just n' -> return n'+        Nothing -> getNumCapabilities+    fdref <- newIORef fd     let bufsiz = max 1 size-    mbuf <- getBuffer bufsiz >>= newMVar-    flush <- mkDebounce defaultDebounceSettings-        { debounceAction = flushLogStrRaw fref bufsiz mbuf arr-        }-    return $ LoggerSet mfile fref bufsiz mbuf arr flush+    logger <-+        if n == 1 && mn == Just 1+            then+                SL <$> S.newSingleLogger bufsiz fdref+            else do+                ML <$> M.newMultiLogger n bufsiz fdref+    flush <-+        mkDebounce+            defaultDebounceSettings+                { debounceAction = flushLogStrRaw logger+                , debounceThreadName = "Loggerset of FastLogger (Debounce)"+                }+    return $+        LoggerSet+            { lgrsetFilePath = mfile+            , lgrsetFdRef = fdref+            , lgrsetLogger = logger+            , lgrsetDebounce = flush+            }  -- | Writing a log message to the corresponding buffer. --   If the buffer becomes full, the log messages in the buffer --   are written to its corresponding file, stdout, or stderr. pushLogStr :: LoggerSet -> LogStr -> IO ()-pushLogStr (LoggerSet _ fdref size mbuf arr flush) logmsg = do-    (i, _) <- myThreadId >>= threadCapability-    -- The number of capability could be dynamically changed.-    -- So, let's check the upper boundary of the array.-    let u = snd $ bounds arr-        lim = u + 1-        j | i < lim   = i-          | otherwise = i `mod` lim-    let logger = arr ! j-    pushLog fdref size mbuf logger logmsg-    flush+pushLogStr LoggerSet{..} logmsg = case lgrsetLogger of+    SL sl -> do+        pushLog sl logmsg+        lgrsetDebounce+    ML ml -> do+        pushLog ml logmsg+        lgrsetDebounce  -- | Same as 'pushLogStr' but also appends a newline. pushLogStrLn :: LoggerSet -> LogStr -> IO ()@@ -130,41 +153,36 @@ --   function can be used to force flushing outside of the debounced --   flush calls. flushLogStr :: LoggerSet -> IO ()-flushLogStr (LoggerSet _ fref size mbuf arr _) = flushLogStrRaw fref size mbuf arr+flushLogStr LoggerSet{..} = flushLogStrRaw lgrsetLogger -flushLogStrRaw :: IORef FD -> BufSize -> MVar Buffer -> Array Int Logger -> IO ()-flushLogStrRaw fdref size mbuf arr = do-    let (l,u) = bounds arr-    mapM_ flushIt [l .. u]-  where-    flushIt i = flushLog fdref size mbuf (arr ! i)+flushLogStrRaw :: Logger -> IO ()+flushLogStrRaw (SL sl) = flushAllLog sl+flushLogStrRaw (ML ml) = flushAllLog ml  -- | Renewing the internal file information in 'LoggerSet'. --   This does nothing for stdout and stderr. renewLoggerSet :: LoggerSet -> IO ()-renewLoggerSet (LoggerSet Nothing     _    _ _ _ _) = return ()-renewLoggerSet (LoggerSet (Just file) fref _ _ _ _) = do-    newfd <- openFileFD file-    oldfd <- atomicModifyIORef' fref (\fd -> (newfd, fd))-    closeFD oldfd+renewLoggerSet LoggerSet{..} = case lgrsetFilePath of+    Nothing -> return ()+    Just file -> do+        newfd <- openFileFD file+        oldfd <- atomicModifyIORef' lgrsetFdRef (\fd -> (newfd, fd))+        closeFD oldfd  -- | Flushing the buffers, closing the internal file information --   and freeing the buffers. rmLoggerSet :: LoggerSet -> IO ()-rmLoggerSet (LoggerSet mfile fdref size mbuf arr _) = do-    fd <- readIORef fdref+rmLoggerSet LoggerSet{..} = do+    fd <- readIORef lgrsetFdRef     when (isFDValid fd) $ do-        let (l,u) = bounds arr-        let nums = [l .. u]-        mapM_ flushIt nums-        takeMVar mbuf >>= freeBuffer-        when (isJust mfile) $ closeFD fd-        writeIORef fdref invalidFD-  where-    flushIt i = flushLog fdref size mbuf(arr ! i)+        case lgrsetLogger of+            SL sl -> stopLoggers sl+            ML ml -> stopLoggers ml+        when (isJust lgrsetFilePath) $ closeFD fd+        writeIORef lgrsetFdRef invalidFD  -- | Replacing the file path in 'LoggerSet' and returning a new --   'LoggerSet' and the old file path. replaceLoggerSet :: LoggerSet -> FilePath -> (LoggerSet, Maybe FilePath)-replaceLoggerSet (LoggerSet current_path a b c d e) new_file_path =-    (LoggerSet (Just new_file_path) a b c d e, current_path)+replaceLoggerSet lgrset@LoggerSet{..} new_file_path =+    (lgrset{lgrsetFilePath = Just new_file_path}, lgrsetFilePath)
+ System/Log/FastLogger/MultiLogger.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE RecordWildCards #-}++module System.Log.FastLogger.MultiLogger (+    MultiLogger,+    newMultiLogger,+) where++import Control.Concurrent (+    MVar,+    myThreadId,+    newMVar,+    takeMVar,+    threadCapability,+    withMVar,+ )+import Data.Array (Array, bounds, listArray, (!))++import System.Log.FastLogger.FileIO+import System.Log.FastLogger.IO+import System.Log.FastLogger.Imports+import System.Log.FastLogger.LogStr+import System.Log.FastLogger.Write++----------------------------------------------------------------++newtype MLogger = MLogger+    { lgrRef :: IORef LogStr+    }++-- | A scale but non-time-ordered logger.+data MultiLogger = MultiLogger+    { mlgrArray :: Array Int MLogger+    , mlgrMBuffer :: MVar Buffer+    , mlgrBufSize :: BufSize+    , mlgrFdRef :: IORef FD+    }++instance Loggers MultiLogger where+    stopLoggers = System.Log.FastLogger.MultiLogger.stopLoggers+    pushLog = System.Log.FastLogger.MultiLogger.pushLog+    flushAllLog = System.Log.FastLogger.MultiLogger.flushAllLog++----------------------------------------------------------------++newMLogger :: IO MLogger+newMLogger = MLogger <$> newIORef mempty++-- | Creating `MultiLogger`.+--   The first argument is the number of the internal builders.+newMultiLogger :: Int -> BufSize -> IORef FD -> IO MultiLogger+newMultiLogger n bufsize fdref = do+    mbuf <- getBuffer bufsize >>= newMVar+    arr <- listArray (0, n - 1) <$> replicateM n newMLogger+    return $+        MultiLogger+            { mlgrArray = arr+            , mlgrMBuffer = mbuf+            , mlgrBufSize = bufsize+            , mlgrFdRef = fdref+            }++----------------------------------------------------------------++pushLog :: MultiLogger -> LogStr -> IO ()+pushLog ml@MultiLogger{..} logmsg = do+    (i, _) <- myThreadId >>= threadCapability+    -- The number of capability could be dynamically changed.+    -- So, let's check the upper boundary of the array.+    let u = snd $ bounds mlgrArray+        lim = u + 1+        j+            | i < lim = i+            | otherwise = i `mod` lim+    let logger = mlgrArray ! j+    pushLog' logger logmsg+  where+    pushLog' logger@MLogger{..} nlogmsg@(LogStr nlen _)+        | nlen > mlgrBufSize = do+            flushLog ml logger+            -- Make sure we have a large enough buffer to hold the entire+            -- contents, thereby allowing for a single write system call and+            -- avoiding interleaving. This does not address the possibility+            -- of write not writing the entire buffer at once.+            writeBigLogStr' ml nlogmsg+        | otherwise = do+            action <- atomicModifyIORef' lgrRef checkBuf+            action+      where+        checkBuf ologmsg@(LogStr olen _)+            | mlgrBufSize < olen + nlen = (nlogmsg, writeLogStr' ml ologmsg)+            | otherwise = (ologmsg <> nlogmsg, return ())++----------------------------------------------------------------++flushAllLog :: MultiLogger -> IO ()+flushAllLog ml@MultiLogger{..} = do+    let flushIt i = flushLog ml (mlgrArray ! i)+        (l, u) = bounds mlgrArray+        nums = [l .. u]+    mapM_ flushIt nums++flushLog :: MultiLogger -> MLogger -> IO ()+flushLog ml MLogger{..} = do+    -- If a special buffer is prepared for flusher, this MVar could+    -- be removed. But such a code does not contribute logging speed+    -- according to experiment. And even with the special buffer,+    -- there is no grantee that this function is exclusively called+    -- for a buffer. So, we use MVar here.+    -- This is safe and speed penalty can be ignored.+    old <- atomicModifyIORef' lgrRef (\old -> (mempty, old))+    writeLogStr' ml old++----------------------------------------------------------------++stopLoggers :: MultiLogger -> IO ()+stopLoggers ml@MultiLogger{..} = do+    System.Log.FastLogger.MultiLogger.flushAllLog ml+    takeMVar mlgrMBuffer >>= freeBuffer++----------------------------------------------------------------++writeLogStr' :: MultiLogger -> LogStr -> IO ()+writeLogStr' MultiLogger{..} logstr =+    withMVar mlgrMBuffer $ \buf -> writeLogStr buf mlgrFdRef logstr++writeBigLogStr' :: MultiLogger -> LogStr -> IO ()+writeBigLogStr' MultiLogger{..} logstr =+    withMVar mlgrMBuffer $ \_ -> writeBigLogStr mlgrFdRef logstr
+ System/Log/FastLogger/SingleLogger.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE RecordWildCards #-}++module System.Log.FastLogger.SingleLogger (+    SingleLogger,+    newSingleLogger,+) where++import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.STM+import GHC.Conc.Sync (labelThread)++import System.Log.FastLogger.FileIO+import System.Log.FastLogger.IO+import System.Log.FastLogger.Imports+import System.Log.FastLogger.LogStr+import System.Log.FastLogger.Write++----------------------------------------------------------------++data Ent = F (MVar ()) Bool | L LogStr+type Q = [Ent] -- writer queue++-- | A non-scale but time-ordered logger.+data SingleLogger = SingleLogger+    { slgrRef :: IORef (LogStr, Q)+    , slgrFlush :: Bool -> IO () -- teminate if False+    , slgrWakeup :: IO ()+    , slgrBuffer :: Buffer+    , slgrBufSize :: BufSize+    , slgrFdRef :: IORef FD+    }++instance Loggers SingleLogger where+    stopLoggers = System.Log.FastLogger.SingleLogger.stopLoggers+    pushLog = System.Log.FastLogger.SingleLogger.pushLog+    flushAllLog = System.Log.FastLogger.SingleLogger.flushAllLog++----------------------------------------------------------------++writer+    :: BufSize+    -> Buffer+    -> IORef FD+    -> TVar Int+    -> IORef (LogStr, Q)+    -> IO ()+writer bufsize buf fdref tvar ref = loop (0 :: Int)+  where+    loop cnt = do+        cnt' <- atomically $ do+            n <- readTVar tvar+            check (n /= cnt)+            return n+        msgs <- reverse <$> atomicModifyIORef' ref (\(msg, q) -> ((msg, []), q))+        cont <- go msgs+        when cont $ loop cnt'+    go [] = return True+    go (F mvar cont : msgs) = do+        putMVar mvar ()+        if cont then go msgs else return False+    go (L msg@(LogStr len _) : msgs)+        | len <= bufsize = writeLogStr buf fdref msg >> go msgs+        | otherwise = writeBigLogStr fdref msg >> go msgs++----------------------------------------------------------------++-- | Creating `SingleLogger`.+newSingleLogger :: BufSize -> IORef FD -> IO SingleLogger+newSingleLogger bufsize fdref = do+    tvar <- newTVarIO 0+    ref <- newIORef (mempty, [])+    buf <- getBuffer bufsize+    tid <- forkIO $ writer bufsize buf fdref tvar ref+    labelThread tid "FastLogger single logger's writer"+    let wakeup = atomically $ modifyTVar' tvar (+ 1)+        flush cont = do+            mvar <- newEmptyMVar+            let fin = F mvar cont+            atomicModifyIORef' ref (\(old, q) -> ((mempty, fin : L old : q), ()))+            wakeup+            takeMVar mvar+    return $+        SingleLogger+            { slgrRef = ref+            , slgrFlush = flush+            , slgrWakeup = wakeup+            , slgrBuffer = buf+            , slgrBufSize = bufsize+            , slgrFdRef = fdref+            }++----------------------------------------------------------------++pushLog :: SingleLogger -> LogStr -> IO ()+pushLog SingleLogger{..} nlogmsg@(LogStr nlen _)+    | nlen > slgrBufSize = do+        atomicModifyIORef' slgrRef (\(old, q) -> ((mempty, L nlogmsg : L old : q), ()))+        slgrWakeup+    | otherwise = do+        wake <- atomicModifyIORef' slgrRef checkBuf+        when wake slgrWakeup+  where+    checkBuf (ologmsg@(LogStr olen _), q)+        | slgrBufSize < olen + nlen = ((nlogmsg, L ologmsg : q), True)+        | otherwise = ((ologmsg <> nlogmsg, q), False)++flushAllLog :: SingleLogger -> IO ()+flushAllLog SingleLogger{..} = do+    atomicModifyIORef' slgrRef (\(old, q) -> ((mempty, L old : q), ()))+    slgrFlush True++stopLoggers :: SingleLogger -> IO ()+stopLoggers SingleLogger{..} = do+    slgrFlush False+    freeBuffer slgrBuffer
System/Log/FastLogger/Types.hs view
@@ -1,8 +1,8 @@ module System.Log.FastLogger.Types (-  -- * Types-    TimeFormat-  , FormattedTime-  ) where+    -- * Types+    TimeFormat,+    FormattedTime,+) where  import System.Log.FastLogger.Imports @@ -10,4 +10,5 @@  -- | Type aliaes for date format and formatted date. type FormattedTime = ByteString+ type TimeFormat = ByteString
+ System/Log/FastLogger/Write.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE RecordWildCards #-}++module System.Log.FastLogger.Write (+    writeLogStr,+    writeBigLogStr,+    Loggers (..),+) where++import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Ptr (plusPtr)++import System.Log.FastLogger.FileIO+import System.Log.FastLogger.IO+import System.Log.FastLogger.Imports+import System.Log.FastLogger.LogStr++----------------------------------------------------------------++-- | Writting 'LogStr' using a buffer in blocking mode.+--   The size of 'LogStr' must be smaller or equal to+--   the size of buffer.+writeLogStr :: Buffer -> IORef FD -> LogStr -> IO ()+writeLogStr buf fdref (LogStr len builder) =+    toBufIOWith buf len (write fdref) builder++-- | Writting 'LogStr' using a temporary buffer.+writeBigLogStr :: IORef FD -> LogStr -> IO ()+writeBigLogStr fdref (LogStr len builder) = allocaBytes len $ \buf ->+    toBufIOWith buf len (write fdref) builder++write :: IORef FD -> Buffer -> Int -> IO ()+write fdref buf len' = loop buf (fromIntegral len')+  where+    loop bf len = do+        written <- writeRawBufferPtr2FD fdref bf len+        when (0 <= written && written < len) $+            loop (bf `plusPtr` fromIntegral written) (len - written)++----------------------------------------------------------------++-- | A class for internal loggers.+class Loggers a where+    stopLoggers :: a -> IO ()+    pushLog :: a -> LogStr -> IO ()+    flushAllLog :: a -> IO ()
fast-logger.cabal view
@@ -1,64 +1,80 @@-Name:                   fast-logger-Version:                3.1.2-Author:                 Kazu Yamamoto <kazu@iij.ad.jp>-Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>-License:                BSD3-License-File:           LICENSE-Synopsis:               A fast logging system-Description:            A fast logging system for Haskell-Homepage:               https://github.com/kazu-yamamoto/logger-Category:               System-Cabal-Version:          >= 1.10-Build-Type:             Simple-Extra-Source-Files:     README.md ChangeLog.md-Tested-With:            GHC ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.3+cabal-version:      >=1.10+name:               fast-logger+version:            3.2.6+license:            BSD3+license-file:       LICENSE+maintainer:         Kazu Yamamoto <kazu@iij.ad.jp>+author:             Kazu Yamamoto <kazu@iij.ad.jp>+tested-with:+    ghc ==7.8.4 || ==7.10.3 || ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.3 -Library-  Default-Language:     Haskell2010-  GHC-Options:          -Wall-  Exposed-Modules:      System.Log.FastLogger-                        System.Log.FastLogger.Date-                        System.Log.FastLogger.File-                        System.Log.FastLogger.Internal-                        System.Log.FastLogger.LoggerSet-                        System.Log.FastLogger.Types-  Other-Modules:        System.Log.FastLogger.Imports-                        System.Log.FastLogger.IO-                        System.Log.FastLogger.FileIO-                        System.Log.FastLogger.LogStr-                        System.Log.FastLogger.Logger-  Build-Depends:        base >= 4.9 && < 5-                      , array-                      , auto-update >= 0.1.2-                      , easy-file >= 0.2-                      , bytestring >= 0.10.4-                      , directory-                      , filepath-                      , text-                      , unix-time >= 0.4.4-                      , unix-compat >= 0.2-  if impl(ghc < 7.8)-      Build-Depends:    bytestring-builder-  if impl(ghc >= 8)-      Default-Extensions:  Strict StrictData+homepage:           https://github.com/kazu-yamamoto/logger+synopsis:           A fast logging system+description:        A fast logging system for Haskell+category:           System+build-type:         Simple+extra-source-files:+    README.md+    ChangeLog.md -Test-Suite spec-  Main-Is:          Spec.hs-  Hs-Source-Dirs:   test-  Default-Language: Haskell2010-  Type:             exitcode-stdio-1.0+source-repository head+    type:     git+    location: https://github.com/kazu-yamamoto/logger.git -  Ghc-Options:      -Wall -threaded-  Other-Modules:    FastLoggerSpec-  Build-Tools:      hspec-discover >= 2.6-  Build-Depends:    base >= 4 && < 5-                  , bytestring >= 0.10.4-                  , directory-                  , fast-logger-                  , hspec-  if impl(ghc >= 8)-      Default-Extensions:  Strict StrictData+library+    exposed-modules:+        System.Log.FastLogger+        System.Log.FastLogger.Date+        System.Log.FastLogger.File+        System.Log.FastLogger.Internal+        System.Log.FastLogger.LoggerSet+        System.Log.FastLogger.Types -Source-Repository head-  Type:                 git-  Location:             git://github.com/kazu-yamamoto/logger.git+    other-modules:+        System.Log.FastLogger.Imports+        System.Log.FastLogger.FileIO+        System.Log.FastLogger.IO+        System.Log.FastLogger.LogStr+        System.Log.FastLogger.MultiLogger+        System.Log.FastLogger.SingleLogger+        System.Log.FastLogger.Write++    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4.9 && <5,+        array,+        auto-update >=0.2.2,+        easy-file >=0.2,+        bytestring >=0.10.4,+        directory,+        filepath,+        stm,+        text,+        unix-time >=0.4.4,+        unix-compat >=0.2++    if impl(ghc <7.8)+        build-depends: bytestring-builder++    if impl(ghc >=8)+        default-extensions: Strict StrictData++test-suite spec+    type:             exitcode-stdio-1.0+    main-is:          Spec.hs+    build-tools:      hspec-discover >=2.6+    hs-source-dirs:   test+    other-modules:    FastLoggerSpec+    default-language: Haskell2010+    ghc-options:      -Wall -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        base >=4 && <5,+        async,+        bytestring >=0.10.4,+        directory,+        fast-logger,+        hspec++    if impl(ghc >=8)+        default-extensions: Strict StrictData
test/FastLoggerSpec.hs view
@@ -1,66 +1,75 @@-{-# LANGUAGE OverloadedStrings, BangPatterns, CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} -module FastLoggerSpec where+module FastLoggerSpec (spec) where  #if __GLASGOW_HASKELL__ < 709 import Control.Applicative ((<$>)) #endif+import Control.Concurrent (getNumCapabilities)+import Control.Concurrent.Async (forConcurrently_) import Control.Exception (finally)-import Control.Monad (when)+import Control.Monad (forM_, when) import qualified Data.ByteString.Char8 as BS+import Data.List (sort)+#if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>))-import Data.String (IsString(fromString))+#endif+import Data.String (IsString (fromString)) import System.Directory (doesFileExist, removeFile)-import System.Log.FastLogger+import Text.Printf (printf)+ import Test.Hspec import Test.Hspec.QuickCheck (prop) +import System.Log.FastLogger+ spec :: Spec spec = do-  describe "instance Show LogStr" $ do-    prop "it should be consistent with instance IsString" $ \str ->-      let logstr :: LogStr-          logstr = fromString str-      in show logstr == show str-  describe "instance Eq LogStr" $ do-    prop "it should be consistent with instance IsString" $ \str1 str2 ->-      let logstr1, logstr2 :: LogStr-          logstr1 = fromString str1-          logstr2 = fromString str2-      in (logstr1 == logstr2) == (str1 == str2)-  describe "pushLogMsg" $ do-    it "is safe for a large message" $ safeForLarge [-        100-      , 1000-      , 10000-      , 100000-      , 1000000-      ]-    it "logs all messages" logAllMsgs+    describe "instance Show LogStr" $ do+        prop "it should be consistent with instance IsString" $ \str ->+            let logstr :: LogStr+                logstr = fromString str+             in show logstr == show str -nullLogger :: IO LoggerSet-#ifdef mingw32_HOST_OS-nullLogger = newFileLoggerSet 4096 "nul"-#else-nullLogger = newFileLoggerSet 4096 "/dev/null"-#endif+    describe "instance Eq LogStr" $ do+        prop "it should be consistent with instance IsString" $ \str1 str2 ->+            let logstr1, logstr2 :: LogStr+                logstr1 = fromString str1+                logstr2 = fromString str2+             in (logstr1 == logstr2) == (str1 == str2) +    describe "pushLogMsg" $ do+        it "is safe for a large message" $+            safeForLarge+                [ 100+                , 1000+                , 10000+                , 100000+                , 1000000+                ]+        it "logs all messages" logAllMsgs++    describe "fastlogger 1" $ do+        it "maintains the ordering of log messages" logOrdering++tempFile :: FilePath+tempFile = "test/temp.txt"+ safeForLarge :: [Int] -> IO ()-safeForLarge ns = mapM_ safeForLarge' ns+safeForLarge = mapM_ safeForLarge'  safeForLarge' :: Int -> IO ()-safeForLarge' n = flip finally (cleanup tmpfile) $ do-    cleanup tmpfile-    lgrset <- newFileLoggerSet defaultBufSize tmpfile-    let xs = toLogStr $ BS.pack $ take (abs n) (cycle ['a'..'z'])+safeForLarge' n = flip finally (cleanup tempFile) $ do+    cleanup tempFile+    lgrset <- newFileLoggerSet defaultBufSize tempFile+    let xs = toLogStr $ BS.pack $ take (abs n) (cycle ['a' .. 'z'])         lf = "x"     pushLogStr lgrset $ xs <> lf     flushLogStr lgrset     rmLoggerSet lgrset-    bs <- BS.readFile tmpfile-    bs `shouldBe` BS.pack (take (abs n) (cycle ['a'..'z']) <> "x")-    where-        tmpfile = "test/temp"+    bs <- BS.readFile tempFile+    bs `shouldBe` BS.pack (take (abs n) (cycle ['a' .. 'z']) <> "x")  cleanup :: FilePath -> IO () cleanup file = do@@ -68,16 +77,39 @@     when exist $ removeFile file  logAllMsgs :: IO ()-logAllMsgs = logAll "LICENSE" `finally` cleanup tmpfile+logAllMsgs = logAll "LICENSE" `finally` cleanup tempFile   where-    tmpfile = "test/temp"     logAll file = do-        cleanup tmpfile-        lgrset <- newFileLoggerSet 512 tmpfile+        cleanup tempFile+        lgrset <- newFileLoggerSet 512 tempFile         src <- BS.readFile file         let bs = (<> "\n") . toLogStr <$> BS.lines src         mapM_ (pushLogStr lgrset) bs         flushLogStr lgrset         rmLoggerSet lgrset-        dst <- BS.readFile tmpfile+        dst <- BS.readFile tempFile         dst `shouldBe` src++logOrdering :: IO ()+logOrdering = flip finally (cleanup tempFile) $ do+    cleanup tempFile+    -- 128 is small enough for out-of-ordering+    (pushlog, teardown) <- newFastLogger1 $ LogFileNoRotate tempFile 128+    numCapabilities <- getNumCapabilities+    let concurrency = numCapabilities * 200 :: Int+        logEntriesCount = 100 :: Int+    forConcurrently_ [0 .. concurrency - 1] $ \t ->+        forM_ [0 .. logEntriesCount - 1] $ \i -> do+            let tag = mktag t+                cnt = printf "%02d" i :: String+                logmsg = toLogStr tag <> "log line nr: " <> toLogStr cnt <> "\n"+            pushlog logmsg+    teardown+    xs <- BS.lines <$> BS.readFile tempFile+    forM_ [0 .. concurrency - 1] $ \t -> do+        let tag = BS.pack $ mktag t+            msgs = filter (tag `BS.isPrefixOf`) xs+        sort msgs `shouldBe` msgs+  where+    mktag :: Int -> String+    mktag t = "thread id: " <> show t <> " "