packages feed

easy-logger (empty) → 0.1.0.0

raw patch · 12 files changed

+1063/−0 lines, 12 filesdep +QuickCheckdep +arraydep +auto-updatesetup-changed

Dependencies added: QuickCheck, array, auto-update, base, bytestring, containers, easy-logger, hspec, quickcheck-assertions, template-haskell, text, unix-compat, unix-time

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for easy-logger++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,89 @@+# Easy Logging for Haskell++Easy-logger can be used to easily create logs, without handling any Monad. Just log as you go. The+package provides logging for code that lives in the `IO` Monad, implements `MonadIO m`, as well as+for pure code.++## Usage++Initialise the logger for your package and start logging:++    import qualified Data.Text                          as T++    main :: IO ()+    main = do+      $(initLogger) (LogFile "package.log") LogDebug+      $(logInfo) ("Starting App" :: T.Text)+      ...+      # At the end of your program, flush the buffers:+      finalizeAllLoggers++You can also include the logs of the libraries that you use and which use the @easy-logger@ package+for logging. If the library maintainer is nice, (s)he allows you to turn on/off logging for that+library only. See the Library section below how to do it. To turn logging for all packages+(that use easy-logger) on, do this:++    import qualified Data.Text                          as T++    main :: IO ()+    main = do+      $(initLoggerAllPackages) (LogFile "package.log") LogAll True+      $(logInfo) ("Starting App" :: T.Text)+      ...+      # At the end of your program, flush the buffers:+      finalizeAllLoggers++You want to log in pure code without wrapping anything in a Monad? Here you go:++    fromEither :: Either String Int -> Int+    fromEither (Right v)  = v+    fromEither (Left str) = $(pureLogPrintError) ("Parse error: " <> T.pack str) defaultValue+    defaultValue = 0++Under the hood `pureLogPrintError` uses `unsafePerformIO` to log. The return value, i.e.+`defaultValue` in the example, ensures that the log is actually executed when the error occurs.++## Log Levels and Destinations++The available log levels are:++    -- | Log Level. Levels are sorted. `All` < `Debug` < `Info` < `Warning` < `Error`. None disables all logging. Default: All+    data LogLevel+      = LogNone+      | LogAll+      | LogDebug+      | LogInfo+      | LogWarning+      | LogError+      deriving (Show, Read, Bounded, Enum, Eq, Ord)++The logger can be used to log to `stderr`, `stdout` or a file:++    -- | Logging destination. See also `setLoggingDestination`.+    data LogDestination+      = LogStdErr+      | LogStdOut+      | LogFile FilePath+++## Library++If you are exposing a library, let your user turn on/off the logging for your library. The+Template-Haskell code ensures that your package name is provided to the logger, and thus logging for this module only is turned on/off.+++    {-# LANGUAGE TemplateHaskell #-}+    module My.Great.Package.Logging+        ( enableMyGreatPackageLogging+        , disableMyGreatPackageLogging+        ) where++    import           EasyLogger++    enableMyGreatPackageLogging :: LogDestination -> LogLevel -> IO ()+    enableMyGreatPackageLogging = $(initLogger)++    disableMyGreatPackageLogging :: IO ()+    disableMyGreatPackageLogging = $(finalizeLogger)++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ easy-logger.cabal view
@@ -0,0 +1,74 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           easy-logger+version:        0.1.0.0+synopsis:       Logging made easy.+description:    Please see the README on GitHub at <https://github.com/githubuser/easy-logger#readme>+category:       Logging+homepage:       https://github.com/schnecki/easy-logger#readme+bug-reports:    https://github.com/schnecki/easy-logger/issues+author:         Manuel Schneckenreither+maintainer:     manuel.schnecki@gmail.com+copyright:      2021 Manuel Schneckenreither+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/schnecki/easy-logger++library+  exposed-modules:+      EasyLogger+      EasyLogger.Date+      EasyLogger.Logger+      EasyLogger.LoggerSet+      EasyLogger.LogStr+      EasyLogger.Push+  other-modules:+      Paths_easy_logger+  hs-source-dirs:+      src+  build-depends:+      array+    , auto-update+    , base >=4.7 && <5+    , bytestring+    , containers+    , template-haskell+    , text+    , unix-compat+    , unix-time+  default-language: Haskell2010++test-suite easy-logger-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_easy_logger+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , array+    , auto-update+    , base >=4.7 && <5+    , bytestring+    , containers+    , easy-logger+    , hspec+    , quickcheck-assertions+    , template-haskell+    , text+    , unix-compat+    , unix-time+  default-language: Haskell2010
+ src/EasyLogger.hs view
@@ -0,0 +1,5 @@+module EasyLogger+    ( module EasyLogger+    ) where++import           EasyLogger.Logger as EasyLogger
+ src/EasyLogger/Date.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+module EasyLogger.Date+    ( FormattedTime+    , TimeFormat+    , newTimeCache+    , simpleTimeFormat+    , simpleTimeFormat'+    ) where++import           Control.AutoUpdate       (defaultUpdateSettings, mkAutoUpdate,+                                           updateAction)+import           Data.ByteString+import           Data.UnixTime            (formatUnixTime, fromEpochTime)+import           System.PosixCompat.Time  (epochTime)+import           System.PosixCompat.Types (EpochTime)+++-- | Type aliaes for date format and formatted date.+type FormattedTime = ByteString+type TimeFormat = ByteString+++----------------------------------------------------------------++-- | Get date using UnixTime.+getTime :: IO EpochTime+getTime = epochTime++-- | Format unix EpochTime date.+formatDate :: TimeFormat -> EpochTime -> IO FormattedTime+formatDate fmt = formatUnixTime fmt . fromEpochTime++----------------------------------------------------------------++-- |  Make 'IO' action which get cached formatted local time.+-- Use this to avoid the cost of frequently time formatting by caching an+-- 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}++-- | A simple time cache using format @"%d/%b/%Y:%T %z"@+simpleTimeFormat :: TimeFormat+simpleTimeFormat = "%d/%b/%Y:%T %z"++-- | A simple time cache using format @"%d-%b-%Y %T"@+simpleTimeFormat' :: TimeFormat+simpleTimeFormat' = "%d-%b-%Y %T"
+ src/EasyLogger/LogStr.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TypeSynonymInstances #-}+module EasyLogger.LogStr+    ( LogStr (..)+    , ToLogStr (..)+    , logStrLen+    , mkMinLogStrLen+    ) where++import qualified Data.ByteString         as BS+import           Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Char8   as S8+import qualified Data.ByteString.Lazy    as BL+import           Data.String             (IsString (..))+import qualified Data.Text               as T+import qualified Data.Text.Encoding      as T+import qualified Data.Text.Lazy          as TL+import qualified Data.Text.Lazy.Encoding as TL++import           Data.Int+import           Data.Word++toBuilder :: BS.ByteString -> Builder+toBuilder = B.byteString++fromBuilder :: Builder -> BS.ByteString+fromBuilder = BL.toStrict . B.toLazyByteString+++-- | Log message builder. Use ('<>') to append two LogStr in O(1).+data LogStr = LogStr !Int Builder++instance Semigroup LogStr where+    {-# INLINE (<>) #-}+    LogStr s1 b1 <> LogStr s2 b2 = LogStr (s1 + s2) (b1 <> b2)++instance Monoid LogStr where+    mempty = LogStr 0 (toBuilder BS.empty)++instance IsString LogStr where+    {-# INLINE fromString #-}+    fromString = toLogStr . TL.pack++-- | Converting 'LogStr' to 'ByteString'.+fromLogStr :: LogStr -> BS.ByteString+fromLogStr (LogStr _ builder) = fromBuilder builder++logStrLen :: LogStr -> Int+logStrLen (LogStr l _) = l++mkMinLogStrLen :: Int -> LogStr -> LogStr+mkMinLogStrLen minLen logStr@(LogStr l _)+  | len > 0 = logStr <> LogStr len (toBuilder $ BS.replicate (minLen - l) space)+  | otherwise = logStr+  where+    len = minLen - l+    space = 32+++-- | Types that can be converted to a 'LogStr'. Instances for+-- types from the @text@ library use a UTF-8 encoding. Instances+-- for numerical types use a decimal encoding.+class ToLogStr msg where+    toLogStr :: msg -> LogStr++instance ToLogStr LogStr where+    {-# INLINE toLogStr #-}+    toLogStr = id+instance ToLogStr S8.ByteString where+    {-# INLINE toLogStr #-}+    toLogStr bs = LogStr (BS.length bs) (toBuilder bs)+instance ToLogStr BL.ByteString where+    {-# INLINE toLogStr #-}+    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)+instance ToLogStr String where+    {-# INLINE toLogStr #-}+    toLogStr = toLogStr . TL.pack+instance ToLogStr T.Text where+    {-# INLINE toLogStr #-}+    toLogStr = toLogStr . T.encodeUtf8+instance ToLogStr TL.Text where+    {-# INLINE toLogStr #-}+    toLogStr = toLogStr . TL.encodeUtf8++-- | @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 #-}+    toLogStr = toLogStr . B.int64Dec++-- | @since 2.4.14+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 #-}+    toLogStr = toLogStr . B.word64Dec++-- | @since 2.4.14+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++instance Eq LogStr where+  a == b = fromLogStr a == fromLogStr b
+ src/EasyLogger/Logger.hs view
@@ -0,0 +1,363 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}+module EasyLogger.Logger+    ( LogDestination (..)+    , LogLevel (..)+    , initLogger+    , initLoggerAllPackages+    , setLoggingDestination+    , setMinLogLevel+    , logAll+    , logPrintAll+    , logDebug+    , logPrintDebug+    , logInfo+    , logPrintInfo+    , logWarning+    , logPrintWarning+    , logError+    , logPrintError+    , pureLogAll+    , pureLogPrintAll+    , pureLogDebug+    , pureLogPrintDebug+    , pureLogInfo+    , pureLogPrintInfo+    , pureLogWarning+    , pureLogPrintWarning+    , pureLogError+    , pureLogPrintError+    , finalizeAllLoggers+    , finalizeLogger+    , flushLoggers+    ) where++import           Control.Applicative        ((<|>))+import           Control.Monad              (join, when)+import           Control.Monad.IO.Class     (liftIO)+import qualified Data.ByteString.Char8      as S8+import           Data.IORef+import           Data.List                  (find)+import qualified Data.Map.Strict            as M+import qualified Data.Text                  as T+import           Language.Haskell.TH.Syntax as TH+import           System.IO+import           System.IO.Unsafe           (unsafePerformIO)++import           EasyLogger.Date+import           EasyLogger.LogStr+import           EasyLogger.LoggerSet+import           EasyLogger.Push+++-- | Add a @LoggerSet@ to the known loggers.+setLoggerSet :: String -> LoggerSet -> IO ()+setLoggerSet pkgName set = modifyIORef' loggerSets (M.insert pkgName set)+++-- | Set of loggers. We have one @LoggerSet@ for each package.+loggerSets :: IORef (M.Map String LoggerSet)+loggerSets = unsafePerformIO $ newIORef mempty+{-# NOINLINE loggerSets  #-}+++-- | Should be used to ensure all logs are completely written before the program exists. Cleans all the file descriptors. You (and also no other library) MUST NOT log after this command as all loggers+-- are deinitalized. However, you might initialize the loggers again and before restarting to log.+finalizeAllLoggers :: IO ()+finalizeAllLoggers = do+  pkgs <- map fst . M.toList <$> readIORef loggerSets+  mapM_ closeLoggerPkg pkgs+++-- | Can be used to destroy your own logger (from your package) only. You MUST NOT log after this command.+finalizeLogger :: Q Exp+finalizeLogger = [| closeLogger $(qLocation >>= liftLoc)|]+++-- | Flush all loggers of all packages.+flushLoggers :: IO ()+flushLoggers = readIORef loggerSets >>= mapM_ flushLoggerSet+++-- | Close logger of calling package.+closeLogger :: Loc -> IO ()+closeLogger (Loc _ pkgName _ _ _) = closeLoggerPkg pkgName++-- | Close logger of package with provided package name.+closeLoggerPkg :: String -> IO ()+closeLoggerPkg pkgName = do+  refs <- readIORef loggerSets+  case M.lookup pkgName refs of+    Nothing -> return ()+    Just set@(LoggerSet Nothing _ _ _) -> deletePackage pkgName >> rmLoggerSet set+    Just set@(LoggerSet justFp _ _ _) -> do+      deletePackage pkgName+      let nrFD = length $ filter (\(LoggerSet mFp _ _ _) -> mFp == justFp) (M.elems refs)+      if nrFD <= 1+        then rmLoggerSet set+        else flushLoggerSet set++-- | Delete a package from the logger sets and with this disable all logging. Ensure the LoggerSet is deleted in case this is the last FD before calling this function!+deletePackage :: String -> IO ()+deletePackage pkg = modifyIORef' loggerSets (M.delete pkg)+++-- | Logging destination. See also `setLoggingDestination`.+data LogDestination+  = LogStdErr+  | LogStdOut+  | LogFile FilePath++-- | Log messages from other packages that use this library too, even if they did not call @initLogger@?+type LogFromAllPackages = Bool++-- | Initialise the logger. MUST only be called in the executable code (not the exposed library code)! Takes a `Bool` that decides wether to log messages from other packages that use the same library+-- and did not initalize the Logger (which should be the case for all of them!).+initLoggerAllPackages :: Q Exp+initLoggerAllPackages = [| \dest logLevel logAllPkgs -> setMinLogLevel logLevel >> setLoggingDestination (loc_package $(qLocation >>= liftLoc)) dest logAllPkgs |]++-- | Initialise the logger. MUST only be called in the executable code (not the exposed library code)! Ignores the other packages logs, if the same packages is used for logging.+initLogger :: Q Exp+initLogger = [| \dest logLevel -> setMinLogLevel logLevel >> setLoggingDestination (loc_package $(qLocation >>= liftLoc)) dest False |]++-- | Set the destination for all consequitive for logging. You should only set this once, at the beginning of the program! The default is `LogStdOut`.+setLoggingDestination :: String -> LogDestination -> LogFromAllPackages -> IO ()+setLoggingDestination pkgName LogStdErr logAllPkgs    = newStderrLoggerSet defaultBufSize  >>= \ls -> setLoggerSet pkgName ls >> when logAllPkgs (setLoggingDestinationAllPkgs ls defaultLogPkgName LogStdErr)+setLoggingDestination pkgName LogStdOut logAllPkgs    = newStdoutLoggerSet defaultBufSize  >>= \ls -> setLoggerSet pkgName ls >> when logAllPkgs (setLoggingDestinationAllPkgs ls defaultLogPkgName LogStdOut)+setLoggingDestination pkgName (LogFile fp) logAllPkgs = do+  allLs <- M.elems <$> readIORef loggerSets+  ls <-+    case find (\(LoggerSet mFp _ _ _) -> mFp == Just fp) allLs of+      Nothing     -> newFileLoggerSet defaultBufSize fp+      Just lsFile -> newFileLoggerSetSameFile defaultBufSize lsFile+  setLoggerSet pkgName ls >> when logAllPkgs (setLoggingDestinationAllPkgs ls defaultLogPkgName (LogFile fp))+++setLoggingDestinationAllPkgs :: LoggerSet -> String -> LogDestination -> IO ()+setLoggingDestinationAllPkgs _ pkgName LogStdErr  = newStderrLoggerSet defaultBufSize          >>= setLoggerSet pkgName+setLoggingDestinationAllPkgs _ pkgName LogStdOut  = newStdoutLoggerSet defaultBufSize          >>= setLoggerSet pkgName+setLoggingDestinationAllPkgs ls pkgName LogFile{} = newFileLoggerSetSameFile defaultBufSize ls >>= setLoggerSet pkgName+++defaultLogPkgName :: String+defaultLogPkgName = "__default__"++-- | The default buffer size (4,096 bytes).+defaultBufSize :: BufSize+defaultBufSize = 4096+++-- | Log Level. Levels are sorted. `All` < `Debug` < `Info` < `Warning` < `Error`. None disables all logging. Default: All+data LogLevel+  = LogNone+  | LogAll+  | LogDebug+  | LogInfo+  | LogWarning+  | LogError+  deriving (Show, Read, Bounded, Enum, Eq, Ord)++-- | Log level text. Make sure you call @initLogger@, or logging will be disabled.+logLevelText :: LogLevel -> T.Text+logLevelText LogNone    = mempty+logLevelText LogAll     = "ALL"+logLevelText LogDebug   = "DEBUG"+logLevelText LogInfo    = "INFO "+logLevelText LogWarning = "WARN "+logLevelText LogError   = "ERROR"++-- | Generic log function. Use TH version, e.g. `logDebug`.+logFun :: (ToLogStr msg) => Loc -> LogLevel -> msg -> IO ()+logFun _ LogNone _ = return ()+logFun loc@(Loc _ pkg _ _ _) level msg = do+  minLevel <- readIORef minLogLevel+  when (level >= minLevel) $ do+    now <- join (readIORef cachedTime)+    readIORef loggerSets >>= \sets ->+      case getLogger sets of+        -- Nothing | M.null sets -> error "You must call `initLogger` at the start of your application! See the documentation of `EasyLogger.Logger`."+        Nothing  -> return ()+        Just set -> pushLogStr set (defaultLogStr loc now level (toLogStr msg))+  where+    getLogger sets = M.lookup pkg sets <|> M.lookup defaultLogPkgName sets+++cachedTime :: IORef (IO FormattedTime)+cachedTime = unsafePerformIO $ do+  cache <- newTimeCache simpleTimeFormat'+  newIORef cache++minLogLevel :: IORef LogLevel+minLogLevel = unsafePerformIO $ newIORef LogAll+{-# NOINLINE minLogLevel  #-}++-- | Set the least logging level. Levels lower will not be logged. Log Level Order: `Debug` < `Info` < `Warning` < `Error`. `None` disables all logging. Note that the output to stderr using e.g. `logPrintError` will not+-- be affected!+setMinLogLevel :: LogLevel -> IO ()+setMinLogLevel = writeIORef minLogLevel++------------------------------ All ------------------------------++-- | Generates a function that takes a 'Text' and logs a 'LevelAll' message. Usage:+--+-- > $(logAll) "This is a debug log message"+logAll :: Q Exp+logAll = [| liftIO . logFun $(qLocation >>= liftLoc) LogAll |]++-- | Same as `logAll`, but for pure code. Uses @unsafePerformIO@.+--+-- > $(pureLogAll) "This is a debug log message" (3 * 3)+pureLogAll :: Q Exp+pureLogAll = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogAll txt >> return a) |]+++-- | Same as `logAll`, but also prints the message on `stdout`.+logPrintAll :: Q Exp+logPrintAll = [| \txt -> liftIO (hPutStrLn stdout ("DEBUG: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogAll txt) |]++-- | Same as `pureLogAll`, but also prints the message on `stdout`.+--+-- > $(pureLogPrintAll) "This is a debug log message" (3 * 3)+pureLogPrintAll :: Q Exp+pureLogPrintAll = [| \txt a -> unsafePerformIO (hPutStrLn stdout ("DEBUG: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogAll txt >> return a) |]+++------------------------------ Debug ------------------------------++-- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage:+--+-- > $(logDebug) "This is a debug log message"+logDebug :: Q Exp+logDebug = [| liftIO . logFun $(qLocation >>= liftLoc) LogDebug |]++-- | Same as `logDebug`, but for pure code. Uses @unsafePerformIO@+--+-- > $(pureLogDebug) "This is a debug log message" defaultValue+pureLogDebug :: Q Exp+pureLogDebug = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogDebug txt >> return a) |]+++-- | Same as `logDebug`, but also prints the message on `stdout`.+logPrintDebug :: Q Exp+logPrintDebug = [| \txt -> hPutStrLn stdout ("DEBUG: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogDebug txt |]++-- | Same as `pureLogDebug`, but also prints the message on `stdout`.+--+-- > $(purePrintLogDebug) "This is a debug log message" defaultValue+pureLogPrintDebug :: Q Exp+pureLogPrintDebug = [| \txt a -> unsafePerformIO (hPutStrLn stdout ("DEBUG: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogDebug txt >> return a) |]+++------------------------------ Info ------------------------------++-- | Generates a function that takes a 'Text' and logs a 'LevelInfo' message. Usage:+--+-- > $(logInfo) "This is a info log message"+logInfo :: Q Exp+logInfo = [| liftIO . logFun $(qLocation >>= liftLoc) LogInfo |]++-- | Same as `logInfo`, but for pure code. Uses @unsafePerformIO@.+--+-- > $(pureLogInfo) "This is a warning log message" (funcX 10)+pureLogInfo :: Q Exp+pureLogInfo = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogInfo txt >> return a) |]+++-- | Same as `logInfo`, but also prints the message on `stdout`.+logPrintInfo :: Q Exp+logPrintInfo = [| \txt -> liftIO (hPutStrLn stdout ("INFO: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogInfo txt) |]++-- | Same as `pureLogInfo`, but also prints the message on `stdout`.+--+-- > $(pureLogPrintInfo) "This is a warning log message" (funcX 10)+pureLogPrintInfo :: Q Exp+pureLogPrintInfo = [| \txt a -> unsafePerformIO (hPutStrLn stdout ("INFO: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogInfo txt >> return a) |]+++------------------------------ Warning ------------------------------++-- | Generates a function that takes a 'Text' and logs a 'LevelWarning' message. Usage:+--+-- > $(logWarning) "This is a warning log message"+logWarning :: Q Exp+logWarning = [| liftIO . logFun $(qLocation >>= liftLoc) LogWarning |]++-- | Same as `logWarning`, but for pure code. Uses @unsafePerformIO@.+--+-- > $(pureLogWarning) "This is a warning log message" "myresult"+pureLogWarning :: Q Exp+pureLogWarning = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogWarning txt >> return a) |]+++-- | Same as `logWarning`, but also prints the message on `stdout`.+logPrintWarning :: Q Exp+logPrintWarning = [| \txt -> liftIO (hPutStrLn stdout ("WARNING: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogWarning txt) |]+++-- | Same as `pureLogWarning`, but also prints the warning.+--+-- > $(pureLogPrintWarning) "This is a error log message" (4 + 4)+pureLogPrintWarning :: Q Exp+pureLogPrintWarning = [| \txt a -> unsafePerformIO (hPutStrLn stdout ("WARNING: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogWarning txt >> return a)  |]+++------------------------------ Error ------------------------------++-- | Generates a function that takes a 'Text' and logs a 'LevelError' message. Usage:+--+-- > $(logError) "This is a error log message"+logError :: Q Exp+logError = [| liftIO . logFun $(qLocation >>= liftLoc) LogError |]+++-- | Same as `logError`, but for pure code. Uses @unsafePerformIO@.+--+-- > $(pureLogError) "This is a error log message" (4 + 4)+pureLogError :: Q Exp+pureLogError = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogError txt >> return a) |]+++-- | Same as `logError`, but also prints the message on `stderr`.+logPrintError :: Q Exp+logPrintError = [| \txt -> liftIO (hPutStrLn stderr ("ERROR: " ++ T.unpack txt) >> hFlush stderr >> logFun $(qLocation >>= liftLoc) LogError txt) |]+++-- | Same as `pureLogError`, but also prints the message on `stderr`.+--+-- > $(pureLogPrintError) "This is a error log message" (4 + 4)+pureLogPrintError :: Q Exp+pureLogPrintError = [| \txt a -> unsafePerformIO (hPutStrLn stderr ("ERROR: " ++ T.unpack txt) >> hFlush stderr >> logFun $(qLocation >>= liftLoc) LogError txt >> return a) |]+++---- Helpers:++defaultLogStr :: Loc+              -> FormattedTime+              -> LogLevel+              -> LogStr+              -> LogStr+defaultLogStr loc time level msg =+  "[" <> toLogStr (logLevelText level) <> ("#" <> toLogStr time) <> "] " <> mkTrailWs msg <> " @(" <> toLogStr (S8.pack fileLocStr) <> ")\n"+  where+    mkTrailWs = mkMinLogStrLen defaultMinLogMsgLen+    fileLocStr = loc_package loc ++ ':' : loc_module loc ++ ' ' : loc_filename loc ++ ':' : line loc ++ ':' : char loc ++ '-' : lineEnd loc ++ ':' : charEnd loc+    line = show . fst . loc_start+    char = show . snd . loc_start+    lineEnd = show . fst . loc_end+    charEnd = show . snd . loc_end+++defaultMinLogMsgLen :: Int+defaultMinLogMsgLen = 60+++liftLoc :: Loc -> Q Exp+liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc+    $(TH.lift a)+    $(TH.lift b)+    $(TH.lift c)+    ($(TH.lift d1), $(TH.lift d2))+    ($(TH.lift e1), $(TH.lift e2))+    |]++
+ src/EasyLogger/LoggerSet.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE BangPatterns #-}+module EasyLogger.LoggerSet+  ( Logger(..)+  , LoggerSet(..)+  , BufSize+  , newFileLoggerSet+  , newFileLoggerSetSameFile+  , newStdoutLoggerSet+  , newStderrLoggerSet+  , newFDLoggerSet+  , toBufIOWith+  , write+  , writeLogStr+  , flushLog+  , rmLoggerSet+  , flushLoggerSet+  ) where++import           Control.Concurrent            (getNumCapabilities)+import           Control.Concurrent.MVar+import           Control.Debounce              (debounceAction, defaultDebounceSettings,+                                                mkDebounce)+import           Control.Monad                 (replicateM, when)+import           Data.Array                    (Array, bounds, listArray, (!))+import           Data.ByteString.Builder+import           Data.ByteString.Builder.Extra (Next (..))+import qualified Data.ByteString.Builder.Extra as BBE+import           Data.ByteString.Internal+import           Data.IORef+import           Data.Maybe                    (isJust)+import           Data.Word+import           Foreign.ForeignPtr            (withForeignPtr)+import           Foreign.Marshal.Alloc         (free, mallocBytes)+import           Foreign.Ptr                   (Ptr, plusPtr)+import           GHC.IO.Device                 (close)+import           GHC.IO.FD                     (FD, openFile, stderr, stdout,+                                                writeRawBufferPtr)+import           GHC.IO.IOMode                 (IOMode (..))++import           EasyLogger.LogStr++-- | The type for buffer size of each core.+type BufSize = Int+type Buffer = Ptr Word8++data Logger = Logger !BufSize (MVar Buffer) (IORef LogStr)++newLogger :: BufSize -> IO Logger+newLogger size = Logger size <$> (mallocBytes size >>= newMVar) <*> newIORef mempty++-- | 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) (Array Int Logger) (IO ())++-- | Creating a new 'LoggerSet' using a file.+newFileLoggerSet :: BufSize -> FilePath -> IO LoggerSet+newFileLoggerSet size file = openFileFD >>= newFDLoggerSet size (Just file)+  where+    openFileFD = fst <$> openFile file AppendMode False++-- | Creating a new 'LoggerSet' using a file.+newFileLoggerSetSameFile :: BufSize -> LoggerSet -> IO LoggerSet+newFileLoggerSetSameFile size (LoggerSet mFp ioRefFD _ _) = readIORef ioRefFD >>= newFDLoggerSet size mFp+++-- | Creating a new 'LoggerSet' using stdout.+newStdoutLoggerSet :: BufSize -> IO LoggerSet+newStdoutLoggerSet size = newFDLoggerSet size Nothing stdout++-- | Creating a new 'LoggerSet' using stderr.+newStderrLoggerSet :: BufSize -> IO LoggerSet+newStderrLoggerSet size = newFDLoggerSet size Nothing stderr++-- | Creating a new 'LoggerSet' using a FD.+newFDLoggerSet :: BufSize -> Maybe FilePath -> FD -> IO LoggerSet+newFDLoggerSet size mfile fd = do+    n <- getNumCapabilities+    loggers <- replicateM n $ newLogger (max 1 size)+    let arr = listArray (0,n-1) loggers+    fref <- newIORef fd+    flush <- mkDebounce defaultDebounceSettings+        { debounceAction = flushLogStrRaw fref arr+        }+    return $ LoggerSet mfile fref arr flush+++flushLogStrRaw :: IORef FD -> Array Int Logger -> IO ()+flushLogStrRaw fdref arr = do+    let (l,u) = bounds arr+    mapM_ flushIt [l .. u]+  where+    flushIt i = flushLog fdref (arr ! i)+++flushLog :: IORef FD -> Logger -> IO ()+flushLog fdref (Logger size mbuf 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 (written < len) $+            loop (bf `plusPtr` fromIntegral written) (len - written)++writeRawBufferPtr2FD :: IORef FD -> Ptr Word8 -> Int -> IO Int+writeRawBufferPtr2FD fdref bf len = do+    fd <- readIORef fdref+    fromIntegral <$> writeRawBufferPtr "write" fd bf 0 (fromIntegral len)+++toBufIOWith :: Buffer -> BufSize -> (Buffer -> Int -> IO ()) -> Builder -> IO ()+toBufIOWith buf !size io builder = loop $ BBE.runBuilder builder+  where+    loop writer = do+        (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'++-- | Flushing the buffers.+flushLoggerSet :: LoggerSet -> IO ()+flushLoggerSet (LoggerSet _ fdref arr _) = do+    let (l,u) = bounds arr+    let nums = [l .. u]+    mapM_ flushIt nums+  where+    flushIt i = flushLog fdref (arr ! i)+++-- | Flushing the buffers, closing the internal file information+--   and freeing the buffers.+rmLoggerSet :: LoggerSet -> IO ()+rmLoggerSet (LoggerSet mfile fdref arr _) = do+    let (l,u) = bounds arr+    let nums = [l .. u]+    mapM_ flushIt nums+    mapM_ freeIt nums+    fd <- readIORef fdref+    when (isJust mfile) $ close fd+  where+    flushIt i = flushLog fdref (arr ! i)+    freeIt i = do+        let (Logger _ mbuf _) = arr ! i+        takeMVar mbuf >>= free
+ src/EasyLogger/Push.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}+module EasyLogger.Push+    ( pushLogStr+    , pushLogStrLn+    ) where+++-- import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction)+-- import System.Log.FastLogger.Types (TimeFormat, FormattedTime)+import           Control.Concurrent+import           Data.Array            (bounds, (!))+import           Data.IORef+import           Foreign.Marshal.Alloc (allocaBytes)+import           GHC.IO.FD++import           EasyLogger.LoggerSet+import           EasyLogger.LogStr+++-- | 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 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 logger logmsg+    flush+++-- | Same as 'pushLogStr' but also appends a newline.+pushLogStrLn :: LoggerSet -> LogStr -> IO ()+pushLogStrLn loggerSet logStr = pushLogStr loggerSet (logStr <> "\n")++pushLog :: IORef FD -> Logger -> LogStr -> IO ()+pushLog fdref logger@(Logger size mbuf ref) nlogmsg@(LogStr nlen nbuilder)+  | nlen > size = do+      flushLog fdref 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)
+ test/Spec.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+module Main where++--------------------------------------------------------------------------+-- imports++import qualified Data.Text                  as T+import           Logging+import           Test.QuickCheck++-- file Spec.hs+import           Test.Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck+import           Test.QuickCheck.Assertions+import           Test.QuickCheck.Monadic+import           Test.QuickCheck.Property++--------------------------------------------------------------------------++getLogMessages :: FilePath -> IO [String]+getLogMessages fp = do+  txt <- readFile fp+  let ls = lines txt+  return $ map getLogMsg ls+  where+    getLogMsg = T.unpack . T.strip . T.takeWhile (/= '@') . T.tail . T.dropWhile (/= ']') . T.pack++--------------------------------------------------------------------------++prop_Logging :: Property+prop_Logging = ioProperty $ do+  writeFile "test/files/prop_Logging.log" ""+  $(initLogger) (LogFile ("test/files/prop_Logging.log" :: FilePath)) LogAll+  $(logDebug) "test run"+  finalizeAllLoggers+  lastLog <- getLogMessages "test/files/prop_Logging.log"+  return (["test run"] === lastLog)++prop_NoInit :: IO ()+prop_NoInit = do+  writeFile "test/files/prop_NoInit.log" ""+  $(logDebug) "test run"+++--------------------------------------------------------------------------+-- main++return []+-- prop_conj :: Property+-- prop_conj = counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) .&&.+--             counterexample "reverse" $(monomorphic 'prop_Reverse)++-- prop_disj :: Property+-- prop_disj = counterexample "reverse" $(monomorphic 'prop_Reverse) .||.+--             counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson)+-- return []+++main :: IO ()+main = hspec $ do+  describe "prop_Logging" $ do+    it "logs to file and reads content" $ prop_Logging++  describe "initialization" $ do+    it "throws an exception if not initialized" $+      prop_NoInit `shouldThrow` anyException