hslogger 1.1.0 → 1.1.1

raw patch · 2 files changed

+155/−3 lines, 2 filesdep ~basedep ~directorydep ~mtl

Dependency ranges changed: base, directory, mtl, network, old-locale, process, unix

Files

• hslogger.cabal +4/−3
• src/System/Log/Handler/Rotating.hs +151/−0

@@ -1,10 +1,10 @@ Name: hslogger-Version: 1.1.0+Version: 1.1.1 License: LGPL Maintainer: John Goerzen <jgoerzen@complete.org> Author: John Goerzen Stability: Stable-Copyright: Copyright (c) 2004-2010 John Goerzen+Copyright: Copyright (c) 2004-2011 John Goerzen license-file: COPYRIGHT build-type: Simple Homepage: http://software.complete.org/hslogger@@ -39,10 +39,11 @@     Exposed-Modules:        System.Log, System.Log.Handler, System.Log.Formatter,         System.Log.Handler.Simple, System.Log.Handler.Syslog,+        System.Log.Handler.Rotating,         System.Log.Handler.Growl, System.Log.Handler.Log4jXML,         System.Log.Logger     Extensions: CPP, ExistentialQuantification-    Build-Depends: network, mtl+    Build-Depends: network < 2.3, mtl     if !os(windows)         Build-Depends: unix     if flag(small_base)

@@ -0,0 +1,151 @@+{- arch-tag: rotating log handlers
+Copyright (C) 2010-2012 ye yan <maskisland@gmail.com>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU Lesser General Public License as published by
+the Free Software Foundation; either version 2.1 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
+-}
+
+{- |
+   Module     : System.Log.Handler.Rotating
+   Copyright  : Copyright (C) 2010-2012 ye yan
+   License    : GNU LGPL, version 2.1 or above
+   Maintainer : ye yan <maskisland@gmail.com>
+   Stability  : beta test
+   Portability: portable
+
+rotating log handlers
+
+Written by ye yan
+
+-}
+
+module System.Log.Handler.Rotating (rotatingFileHandler, rotatingTimestampedFileHandler) where
+
+import Prelude hiding (catch)
+import Control.Exception (SomeException, catch)
+import Data.Char (ord)
+
+import System.Log
+import System.Log.Handler
+import System.Log.Formatter
+import System.IO
+import Control.Concurrent.MVar
+
+import Data.Time.Clock
+import Data.Time.Format
+import System.Locale
+import System.FilePath.Windows
+import System.Directory
+
+data XLogger = XLogger {
+    priority :: Priority,
+    formatter :: LogFormatter XLogger,
+    writeFunc :: LogRecord -> String -> IO (),
+    closeFunc :: IO ()
+}
+
+instance LogHandler XLogger where
+    setLevel sh p = sh {priority = p}
+    getLevel = priority
+    setFormatter sh f = sh{formatter = f}
+    getFormatter sh = formatter sh
+    emit sh lr loggerName = (writeFunc sh) lr loggerName
+    close sh = (closeFunc sh)
+
+class Sizeable a where
+    bytes :: (Integral b) => a -> b
+
+instance Sizeable Char where
+    bytes c 
+        | value < 256 = 1
+        | value < 65536 = 2
+        | value < 4294967296 = 4
+        where value = ord c
+
+instance Sizeable [Char] where
+    bytes str = sum $ map bytes str
+
+getFileSize file = withFile file AppendMode hFileSize
+
+writeToLimitedFile :: (Integral a) => FilePath -> a -> String -> (FilePath -> IO ()) -> IO ()
+writeToLimitedFile file limit msg backup =
+    do fileSize <- getFileSize file
+       let msgSize = bytes msg
+       if fileSize + msgSize > fromIntegral limit
+          then do backup file 
+                  writeToFile file WriteMode msg
+          else writeToFile file AppendMode msg
+    where writeToFile file mode msg = withFile file mode $ \handle -> do writeToHandle handle msg
+                                                                         hFlush handle
+          writeToHandle hdl msg =
+              hPutStrLn hdl msg `catch` (handleWriteException hdl msg)
+          handleWriteException :: Handle -> String -> SomeException -> IO ()
+          handleWriteException hdl msg e =
+              let msg' = "Error writing log message: " ++ show e ++
+                         " (original message: " ++ msg ++ ")"
+              in hPutStrLn hdl (encodingSave msg')
+          encodingSave = concatMap (\c -> if ord c > 127
+                                             then "\\" ++ show (ord c)
+                                             else [c])
+
+timestampedBackup file =
+    do time <- getCurrentTime
+       let timeStamp = formatTime defaultTimeLocale "%Y%m%d%H%M%S" time
+           tsFile = replaceBaseName file $ takeBaseName file ++ "_" ++ timeStamp
+       renameFile file tsFile
+
+whenFileExists :: FilePath -> (FilePath -> IO ()) -> IO ()
+whenFileExists file func =
+    do exists <- doesFileExist file
+       if exists
+          then func file
+          else return ()
+
+suffixedBackup count file =
+    do helper $ reverse $ files
+    where files = file : map (\x -> replaceBaseName file $ takeBaseName file ++ "_" ++ show x) [1..count]
+          helper (f:[]) = return ()
+          helper (f1:f2:fs) = do whenFileExists f2 (\_ -> renameFile f2 f1)
+                                 helper $ f2:fs
+
+-- params:
+-- file -> file name of the log file
+-- limit -> size limit
+-- bkcnt -> backup count which will be in format <path>\\<basename>_<num>.<extend>
+-- pri -> priority
+rotatingFileHandler :: (Integral a) => FilePath -> a -> a -> Priority -> IO XLogger
+rotatingFileHandler file limit bkcnt pri =
+    do lock <- newMVar ()
+       let myWriteFunc (_, msg) _ = withMVar lock $ \_ -> writeToLimitedFile file limit msg (suffixedBackup bkcnt)
+       return XLogger {
+           priority = pri,
+           formatter = nullFormatter,
+           writeFunc = myWriteFunc,
+           closeFunc = return ()
+       }
+
+-- params:
+-- file -> file name of the log file
+-- limit -> size limit
+-- pri -> priority
+rotatingTimestampedFileHandler :: (Integral a) => FilePath -> a -> Priority -> IO XLogger
+rotatingTimestampedFileHandler file limit pri = 
+    do lock <- newMVar ()
+       let myWriteFunc (_, msg) _ = withMVar lock $ \_ -> writeToLimitedFile file limit msg timestampedBackup
+       return XLogger {
+           priority = pri,
+           formatter = nullFormatter,
+           writeFunc = myWriteFunc,
+           closeFunc = return ()
+       }