canteven-log 0.2.0.0 → 0.3.0.2

raw patch · 4 files changed

+332/−82 lines, 4 filesdep +bytestringdep +fast-loggerdep +monad-loggernew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, fast-logger, monad-logger, template-haskell, time, transformers

API changes (from Hackage documentation)

Files

• canteven-log.cabal +25/−10
• src/Canteven/Log.hs +7/−72
• src/Canteven/Log/MonadLog.hs +204/−0
• src/Canteven/Log/Types.hs +96/−0

@@ -1,34 +1,49 @@--- Initial canteven-log.cabal generated by cabal init.  For further +-- Initial canteven-log.cabal generated by cabal init.  For further -- documentation, see http://haskell.org/cabal/users-guide/  name:                canteven-log-version:             0.2.0.0+version:             0.3.0.2 synopsis:            A canteven way of setting up logging for your program.--- description:         +description:+    A library that uses <https://hackage.haskell.org/package/canteven-config canteven-config>+    to parse logging settings. Compatible with both hslogger and monad-logger. homepage:            https://github.com/SumAll/haskell-canteven-log license:             Apache-2.0 license-file:        LICENSE author:              Rick Owens maintainer:          rowens@sumall.com--- copyright:           --- category:            +-- copyright:+category:            Development build-type:          Simple--- extra-source-files:  +-- extra-source-files: cabal-version:       >=1.10+homepage:            https://github.com/SumAll/haskell-canteven-log +source-repository head+  type: git+  location:  git://github.com/SumAll/haskell-canteven-log.git+ library-  exposed-modules:     -    Canteven.Log-  -- other-modules:       -  -- other-extensions:    +  exposed-modules:+    Canteven.Log,+    Canteven.Log.MonadLog+  other-modules:+    Canteven.Log.Types+  -- other-extensions:   build-depends:     aeson,     base >= 4 && < 5,+    bytestring,     canteven-config >= 1.0 && < 1.1,     directory,+    fast-logger,     filepath,     hslogger,+    monad-logger,+    template-haskell,     text,+    time >= 1.5 && <1.6,+    transformers,     yaml   hs-source-dirs:      src   default-language:    Haskell2010

@@ -10,19 +10,19 @@   setupLogging ) where -import Control.Applicative ((<$>), (<*>))-import Data.Aeson (Value(String, Object), (.:?), (.!=), (.:))-import Data.Yaml (FromJSON(parseJSON))+import Canteven.Log.Types (LogPriority(LP),+    LoggingConfig(LoggingConfig, logfile, level, loggers),+    LoggerDetails(LoggerDetails, loggerName, loggerLevel))+import Control.Applicative ((<$>)) import System.Directory (createDirectoryIfMissing) import System.FilePath (dropFileName) import System.IO (stdout)-import System.Log (Priority(INFO, DEBUG))+import System.Log (Priority(DEBUG)) import System.Log.Formatter (simpleLogFormatter) import System.Log.Handler (setFormatter) import System.Log.Handler.Simple (fileHandler, streamHandler) import System.Log.Logger (updateGlobalLogger, setHandlers, setLevel) import qualified Canteven.Config as Config (canteven)-import qualified Data.Text as T   {- |@@ -53,73 +53,8 @@   updateGlobalLogger "" (setLevel level . setHandlers handlers)   sequence_ [       updateGlobalLogger loggerName (setLevel loggerLevel) |-      LoggerDetails {loggerName, loggerLevel = LP loggerLevel} <- loggers+      LoggerDetails {loggerName = Just loggerName, loggerLevel = LP loggerLevel} <- loggers     ]   where     tweak h = setFormatter h (simpleLogFormatter logFormat)-    logFormat = "$prio [$tid] [$time] $loggername - $msg"---data LoggingConfig =-  LoggingConfig {-    level :: LogPriority,-    logfile :: Maybe FilePath,-    loggers :: [LoggerDetails]-  }--instance FromJSON LoggingConfig where-  parseJSON (Object topLevel) = do-    mLogging <- topLevel .:? "logging"-    case mLogging of-      Nothing -> return defaultLogging-      Just logging -> LoggingConfig-        <$> logging .:? "level" .!= LP INFO-        <*> logging .:? "logfile"-        <*> logging .:? "loggers" .!= []--  parseJSON value =-    fail $ "Couldn't parse logging config from value " ++ show value---{- |-  Don't bother with @data-default@. `LoggingConfig` is not exposed and-  the fewer dependencies the better.--}-defaultLogging :: LoggingConfig-defaultLogging = LoggingConfig {-    level = LP INFO,-    logfile = Nothing,-    loggers = []-  }---{- |-  A wrapper for Priority, so we can avoid orphan instances--}-newtype LogPriority = LP Priority--instance FromJSON LogPriority where-  parseJSON (String s) = case reads (T.unpack s) of-    [(priority, "")] -> return (LP priority)-    _ -> fail $ "couldn't parse Priority from string " ++ show s-  parseJSON value = fail $ "Couldn't parse Priority from value " ++ show value---{- |-  A way to set more fined-grained configuration for specific loggers.--}-data LoggerDetails =-  LoggerDetails {-    loggerName :: String,-    loggerLevel :: LogPriority-  }--instance FromJSON LoggerDetails where-  parseJSON (Object details) = do-    loggerName <- details .: "logger"-    loggerLevel <- details .: "level"-    return LoggerDetails {loggerName, loggerLevel}-  parseJSON value =-    fail $ "Couldn't parse logger details from value " ++ show value--+    logFormat = "[$time] $prio $loggername[$tid]: $msg"

@@ -0,0 +1,204 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+module Canteven.Log.MonadLog (+    LoggerTImpl,+    cantevenLogFormat,+    getRunCantevenLoggingT,+    getCantevenOutput,+    runCantevenLoggingDefaultT,+    ) where++import Canteven.Config (canteven)+import Canteven.Log.Types (LoggingConfig(LoggingConfig, logfile,+    level, loggers),+    LoggerDetails(LoggerDetails, loggerName, loggerPackage,+    loggerModule, loggerLevel),+    LogPriority(LP),+    defaultLogging)+import Control.Applicative ((<$>))+import Control.Concurrent (ThreadId, myThreadId)+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger (LogSource,+    LogLevel(LevelDebug, LevelInfo, LevelWarn, LevelError, LevelOther),+    LoggingT(runLoggingT))+import Data.Char (toUpper)+import Data.List (dropWhileEnd, isPrefixOf, isSuffixOf)+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Data.Monoid ((<>), mempty)+import Data.Time.Format (defaultTimeLocale, formatTime)+import Data.Time.LocalTime (ZonedTime, getZonedTime)+import Language.Haskell.TH (Loc(loc_filename, loc_package, loc_module,+    loc_start))+import System.Directory (createDirectoryIfMissing)+import System.FilePath (dropFileName)+import System.IO (Handle, IOMode(AppendMode), openFile, stdout, hFlush)+import System.Log.FastLogger (LogStr, fromLogStr, toLogStr)+import System.Log.Logger (Priority(DEBUG, INFO, NOTICE, WARNING, ERROR,+    NOTICE, CRITICAL, ALERT, EMERGENCY))+import qualified Data.ByteString.Char8 as S8+import qualified Data.Text as T++type LoggerTImpl = Loc -> LogSource -> LogLevel -> LogStr -> IO ()++runCantevenLoggingT+    :: (MonadIO io)+    => LoggingConfig+    -> LoggingT io a+    -> io a+runCantevenLoggingT config action = do+    handle <- liftIO $ setupHandle config+    runLoggingT action (cantevenOutput config handle)++-- | Get the logging config using canteven, and produce a way to use that+-- logging config to run a LoggingT.+getRunCantevenLoggingT+    :: (Functor io1, MonadIO io1, MonadIO io2)+    => io1 (LoggingT io2 a -> io2 a)+getRunCantevenLoggingT =+    runCantevenLoggingT <$> liftIO canteven++getCantevenOutput+    :: (Functor io, MonadIO io)+    => io LoggerTImpl+getCantevenOutput =+    uncurry cantevenOutput <$> liftIO setupLogger+  where+    setupLogger = do+        config <- canteven+        handle <- setupHandle config+        return (config, handle)++-- | Run a LoggingT, using the canteven logging format, with the default logging+-- configuration.+runCantevenLoggingDefaultT+    :: (MonadIO io)+    => LoggingT io a+    -> io a+runCantevenLoggingDefaultT = runCantevenLoggingT defaultLogging++cantevenOutput+    :: LoggingConfig+    -> Handle+    -> Loc+    -> LogSource+    -> LogLevel+    -> LogStr+    -> IO ()+cantevenOutput config handle loc src level msg =+    when (configPermits config loc src level) $ do+    time <- getZonedTime+    threadId <- myThreadId+    S8.hPutStr handle . fromLogStr $ cantevenLogFormat loc src level msg time threadId+    hFlush handle++-- | Figure out whether a particular log message is permitted, given a+-- particular config.+--+-- FIXME: if two LoggerDetails match the same message, it should probably take+-- the answer given by the most specific one that matches. However, at present+-- it just takes the first one.+configPermits :: LoggingConfig -> Loc -> LogSource -> LogLevel -> Bool+configPermits LoggingConfig {level=LP defaultLP, loggers} = runFilters+  where+    predicates = map toPredicate loggers+    toPredicate LoggerDetails {loggerName, loggerPackage,+                               loggerModule, loggerLevel=LP loggerLevel}+        loc src level =+        if matches (T.pack <$> loggerName) src &&+           matches loggerPackage (loc_package loc) &&+           matchesGlob loggerModule (loc_module loc)+        then Just (toHSLogPriority level >= loggerLevel)+        else Nothing+    -- It's considered a "match" if either the specification is absent (matches+    -- everything), or the specification is given and matches the target.+    matches Nothing _ = True+    matches (Just s1) s2 = s1 == s2+    -- Not real glob matching.+    matchesGlob Nothing _ = True+    matchesGlob (Just pattern) candidate+        | "*" `isSuffixOf` pattern = dropWhileEnd (=='*') pattern `isPrefixOf` candidate+        | otherwise = pattern == candidate+    runFilters loc src level =+        -- default to the defaultLP+        fromMaybe (toHSLogPriority level >= defaultLP) $+        -- take the first value+        listToMaybe $+        -- of the predicates that returned Just something+        mapMaybe (\p -> p loc src level) predicates+++-- | Convert a monad-logger 'LogLevel' into an hslogger 'Priority'. This is+-- necessary because LoggingConfig specify Priorities rather than LogLevels.+toHSLogPriority :: LogLevel -> Priority+toHSLogPriority LevelDebug = DEBUG+toHSLogPriority LevelInfo = INFO+toHSLogPriority LevelWarn = WARNING+toHSLogPriority LevelError = ERROR+toHSLogPriority (LevelOther other) =+    fromMaybe EMERGENCY $ -- unknown log levels are most critical+    lookup (T.toLower other) [+        ("notice", NOTICE),+        ("critical", CRITICAL),+        ("alert", ALERT)+        ]+++-- | This is similar to the version defined in monad-logger (which we can't+-- share because of privacy restrictions), but with the added nuance of+-- uppercasing.+cantevenLogLevelStr :: LogLevel -> LogStr+cantevenLogLevelStr level = case level of+    LevelOther t -> toLogStr $ T.toUpper t+    _            -> toLogStr $ S8.pack $ map toUpper $ drop 5 $ show level++-- | This log format is inspired by syslog and the X.org log+-- formats. Rationales are:+--+-- * Put the date first, because the date string tends to be a fixed number+--   of characters (or +/- 1 around changes to DST), so the eye can easily+--   skim over them.+--+-- * The "source" of a message comes before the message itself. "Source" is+--   composed of not just the "logger name" (called a source in+--   monad-logger), but also the package/module name and the thread+--   ID. Package and module name might seem controversial, but they+--   correspond to e.g. Log4J logger names based on classes.+--+-- * Filename/position of the message is perhaps the least important, but+--   can still be helpful. Put it at the end.+cantevenLogFormat+    :: Loc+    -> LogSource+    -> LogLevel+    -> LogStr+    -> ZonedTime+    -> ThreadId+    -> LogStr+cantevenLogFormat loc src level msg t tid =+    "[" <> toLogStr (fmtTime t) <> "] " <>+    cantevenLogLevelStr level <>+    " " <>+    (if T.null src+        then mempty+        else toLogStr src) <>+    "@" <> toLogStr (loc_package loc ++ ":" ++ loc_module loc) <>+    "[" <>+    toLogStr (show tid) <> "]: " <>+    msg <> " (" <> toLogStr (S8.pack fileLocStr) <> ")\n"+  where+    fmtTime = formatTime defaultTimeLocale "%F %X %Z"+    fileLocStr =+        loc_filename loc ++ ':' : line loc ++ ':' : char loc+      where+        line = show . fst . loc_start+        char = show . snd . loc_start++openFileForLogging :: FilePath -> IO Handle+openFileForLogging filename = do+    createDirectoryIfMissing True (dropFileName filename)+    openFile filename AppendMode++setupHandle :: LoggingConfig -> IO Handle+setupHandle LoggingConfig {logfile} =+    maybe (return stdout) openFileForLogging logfile

@@ -0,0 +1,96 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+module Canteven.Log.Types (+    LogPriority(..),+    LoggerDetails(..),+    LoggingConfig(..),+    defaultLogging,+    ) where++import Data.Aeson (Value(String, Object), (.:?), (.!=), (.:))+import Data.Maybe (catMaybes, listToMaybe)+import Data.Yaml (FromJSON(parseJSON))+import Control.Applicative ((<$>), (<*>))+import System.Log (Priority(INFO))+import qualified Data.Text as T++data LoggingConfig =+  LoggingConfig {+    level :: LogPriority,+    logfile :: Maybe FilePath,+    loggers :: [LoggerDetails]+  }++instance FromJSON LoggingConfig where+  parseJSON (Object topLevel) = do+    mLogging <- topLevel .:? "logging"+    case mLogging of+      Nothing -> return defaultLogging+      Just logging -> LoggingConfig+        <$> logging .:? "level" .!= LP INFO+        <*> logging .:? "logfile"+        <*> logging .:? "loggers" .!= []++  parseJSON value =+    fail $ "Couldn't parse logging config from value " ++ show value+++{- |+  Don't bother with @data-default@. `LoggingConfig` is not exposed and+  the fewer dependencies the better.+-}+defaultLogging :: LoggingConfig+defaultLogging = LoggingConfig {+    level = LP INFO,+    logfile = Nothing,+    loggers = []+  }+++{- |+  A wrapper for Priority, so we can avoid orphan instances+-}+newtype LogPriority = LP Priority++instance FromJSON LogPriority where+  parseJSON (String s) = case reads (T.unpack s) of+    [(priority, "")] -> return (LP priority)+    _ -> fail $ "couldn't parse Priority from string " ++ show s+  parseJSON value = fail $ "Couldn't parse Priority from value " ++ show value+++{- |+  A way to set more fined-grained configuration for specific log messages.++  Name, package, and module are "selectors" that identify which messages should+  be configured. Any absent "selectors" match everything. Name and package have to+  match exactly. Module can either match exactly, or -- if the config specifies a+  module ending in an asterisk -- match a prefix.++  'loggerLevel' is a "minimum priority". Messages that aren't at least as severe+  as this will not be logged.++  hslogger only supports "name". monad-logger supports all three.+-}+data LoggerDetails =+  LoggerDetails {+    loggerName :: Maybe String,+    loggerPackage :: Maybe String,+    loggerModule :: Maybe String,+    loggerLevel :: LogPriority+  }++instance FromJSON LoggerDetails where+  parseJSON (Object details) = do+    loggerName <- do+        names <- catMaybes <$> sequence [+            details .:? "logger",+            details .:? "source",+            details .:? "name"]+        return $ listToMaybe names+    loggerLevel <- details .: "level"+    loggerModule <- details .:? "module"+    loggerPackage <- details .:? "package"+    return LoggerDetails {loggerName, loggerPackage, loggerModule, loggerLevel}+  parseJSON value =+    fail $ "Couldn't parse logger details from value " ++ show value