diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for log4hs +## V0.8.0 +- Add `IsMessage` class +- Deprecate `catchUncaughtException` +- Add support for contextual logging + ## V0.7.1 - Fix error handling issue diff --git a/log4hs.cabal b/log4hs.cabal --- a/log4hs.cabal +++ b/log4hs.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 40bf737c00b6bef41f168df6d0a764776ea87f6bd584dc12b6e12ce2764770b6 +-- hash: 8762d58dd571f8027cd0efeab16d060754fa1b0c76d87bd50f61fac31e7f116a name: log4hs -version: 0.7.1.0 +version: 0.8.0.0 synopsis: A python logging style log library description: Please see the http://hackage.haskell.org/package/log4hs category: logging @@ -30,6 +30,7 @@ Logging.Filter Logging.Global Logging.Global.TH + Logging.Global.TH.Context Logging.Handler.FileHandler Logging.Handler.RotatingFileHandler Logging.Handler.StreamHandler @@ -39,6 +40,7 @@ Logging.Manager Logging.Monad Logging.Monad.TH + Logging.Monad.TH.Context Logging.Prelude Logging.Record Logging.Sink @@ -48,6 +50,7 @@ other-modules: Logging.Class.Filterable Logging.Class.Handler + Logging.Class.Message Logging.Global.Internal Logging.Monad.Internal Paths_log4hs @@ -67,7 +70,8 @@ , template-haskell >=2.0 && <3.0 , text >=1.2 && <2.0 , time >=1.4 && <2.0 - , vformat >=0.13 && <1.0 + , vformat >=0.14.1 && <1.0 + , vformat-aeson >=0.1 && <1.0 , vformat-time >=0.1 && <1.0 , yaml >=0.9 && <1.0 default-language: Haskell2010 @@ -104,7 +108,8 @@ , template-haskell >=2.0 && <3.0 , text >=1.2 && <2.0 , time >=1.4 && <2.0 - , vformat >=0.13 && <1.0 + , vformat >=0.14.1 && <1.0 + , vformat-aeson >=0.1 && <1.0 , vformat-time >=0.1 && <1.0 , yaml >=0.9 && <1.0 default-language: Haskell2010 @@ -134,7 +139,8 @@ , template-haskell >=2.0 && <3.0 , text >=1.2 && <2.0 , time >=1.4 && <2.0 - , vformat >=0.13 && <1.0 + , vformat >=0.14.1 && <1.0 + , vformat-aeson >=0.1 && <1.0 , vformat-time >=0.1 && <1.0 , yaml >=0.9 && <1.0 default-language: Haskell2010 diff --git a/src/Logging/Class.hs b/src/Logging/Class.hs --- a/src/Logging/Class.hs +++ b/src/Logging/Class.hs @@ -1,8 +1,10 @@ module Logging.Class ( module Logging.Class.Filterable , module Logging.Class.Handler + , module Logging.Class.Message ) where import Logging.Class.Filterable import Logging.Class.Handler +import Logging.Class.Message diff --git a/src/Logging/Class/Message.hs b/src/Logging/Class/Message.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Class/Message.hs @@ -0,0 +1,46 @@ +module Logging.Class.Message ( IsMessage(..) ) where + +import Control.Exception +import Data.Aeson +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as LB8 +import Data.List (intercalate) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT + +{-| A class for datatypes that can be converted to log message. + +@since 0.8.0 +-} +class IsMessage a where + toMessage :: a -> String + + toMessageList :: [a] -> String + toMessageList [] = "" + toMessageList xs = "[" ++ (intercalate "," $ map toMessage xs) ++ "]" + +instance IsMessage Char where + toMessage = (: "") + toMessageList = id + +instance IsMessage B8.ByteString where + toMessage = B8.unpack + +instance IsMessage LB8.ByteString where + toMessage = LB8.unpack + +instance IsMessage T.Text where + toMessage = T.unpack + +instance IsMessage LT.Text where + toMessage = LT.unpack + +instance IsMessage Value where + toMessage = toMessage . encode + +instance IsMessage SomeException where + toMessage = show + +instance IsMessage a => IsMessage [a] where + {-# SPECIALIZE instance IsMessage [Char] #-} + toMessage = toMessageList diff --git a/src/Logging/Config/Type.hs b/src/Logging/Config/Type.hs --- a/src/Logging/Config/Type.hs +++ b/src/Logging/Config/Type.hs @@ -99,12 +99,11 @@ instance FromJSON Sink -data Config = Config { sinks :: Maybe (Map String Sink) - , handlers :: Maybe (Map String Handler) - , formatters :: Maybe (Map String String) - , timezone :: Maybe String -- ^ @since 0.7.0 - , disabled :: Maybe Bool - , catchUncaughtException :: Maybe Bool +data Config = Config { sinks :: Maybe (Map String Sink) + , handlers :: Maybe (Map String Handler) + , formatters :: Maybe (Map String String) + , timezone :: Maybe String -- ^ @since 0.7.0 + , disabled :: Maybe Bool } deriving (Generic, Show) instance FromJSON Config @@ -128,8 +127,7 @@ sinks' = delete "root" sinks timezone' = maybe defaultTimezone read timezone disabled' = fromMaybe False disabled - catchUncaughtException' = fromMaybe False catchUncaughtException - return $ T.Manager root sinks' timezone' disabled' catchUncaughtException' + return $ T.Manager root sinks' timezone' disabled' False where formatters' :: Map String Format1 formatters' = maybe (singleton "" "{message}") (map fromString) formatters diff --git a/src/Logging/Global/Internal.hs b/src/Logging/Global/Internal.hs --- a/src/Logging/Global/Internal.hs +++ b/src/Logging/Global/Internal.hs @@ -10,10 +10,12 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class +import Data.Aeson import Data.IORef import Prelude hiding (log) import System.IO.Unsafe +import Logging.Class import Logging.Level import Logging.Logger import Logging.Manager @@ -25,16 +27,15 @@ error "Global logging manager is not set, see Logging.Global.run" -log :: MonadIO m - => Logger -> Level -> String -> (String, String, String, Int) - -> m () -log logger level message location = liftIO $ do +log :: (MonadIO m, IsMessage s, ToJSON c) + => Logger -> Level -> s -> c -> (String, String, String, Int) -> m () +log logger level msg ctx location = liftIO $ do manager <- readIORef ref - M.runLoggingT (M.log logger level message location) manager + M.runLoggingT (M.log logger level msg ctx location) manager {-| Run the global logging environment. -You should always run you application in the global logging environment. +Run you application in the global logging environment. @ main :: IO () @@ -63,17 +64,17 @@ forkIO app2 ... @ + +Note: If there is an unhandled 'Exception' in your application, it will be +logged into the __root__ 'Sink', and then rethrown. -} run :: Manager -> IO a -> IO a run manager@Manager{..} io = do bracket_ (initialize manager >> atomicWriteIORef ref manager) (terminate manager) - (runInner catchUncaughtException io) + (catch io logThrow) where unknownLoc = ("unknown file", "unknown package", "unknown module", 0) - runInner :: Bool -> IO a -> IO a - runInner False io = io - runInner True io = catch io $ \e -> do - log "" "ERROR" (show (e :: SomeException)) unknownLoc - runInner True io + logThrow :: SomeException -> IO a + logThrow e = log "" "ERROR" e Null unknownLoc >> throw e diff --git a/src/Logging/Global/TH.hs b/src/Logging/Global/TH.hs --- a/src/Logging/Global/TH.hs +++ b/src/Logging/Global/TH.hs @@ -15,9 +15,11 @@ ) where import Control.Monad.IO.Class (MonadIO) +import Data.Aeson import Language.Haskell.TH import Prelude hiding (error, log) +import Logging.Class import Logging.Global.Internal import Logging.Level import Logging.Logger @@ -25,7 +27,7 @@ -- | Log "message" with the severity "level". -- -- The missing type signature: --- 'MonadIO' m => 'Logger' -> 'Level' -> 'String' -> m () +-- ('MonadIO' m, 'IsMessage' s) => 'Logger' -> 'Level' -> s -> m () logv :: ExpQ logv = do loc <- location @@ -34,11 +36,12 @@ modulename = loc_module loc lineno = fst $ loc_start loc location = (filename, packagename, modulename, lineno) - [| \logger level msg -> log logger level msg location |] + [| \logger level msg -> log logger level msg Null location |] -- | Log "message" with a specific severity. -- --- The missing type signature: 'MonadIO' m => 'Logger' -> 'String' -> m () +-- The missing type signature: +-- ('MonadIO' m, 'IsMessage' s) => 'Logger' -> s -> m () debug, info, warn, error, fatal :: ExpQ debug = [| \logger -> $(logv) logger $ read "DEBUG" |] info = [| \logger -> $(logv) logger $ read "INFO" |] diff --git a/src/Logging/Global/TH/Context.hs b/src/Logging/Global/TH/Context.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Global/TH/Context.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| A contextual version of "Logging.Global.TH". + +@since 0.8.0 +-} + +module Logging.Global.TH.Context + ( logv + , debug + , info + , warn + , error + , fatal + ) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson +import Language.Haskell.TH +import Prelude hiding (error, log) + +import Logging.Class +import Logging.Global.Internal +import Logging.Level +import Logging.Logger + +-- | Log "message" with the severity "level". +-- +-- The missing type signature: +-- ('MonadIO' m, 'IsMessage' s, 'ToJSON' c) => 'Logger' -> 'Level' -> s -> c +-- -> m () +logv :: ExpQ +logv = do + loc <- location + let filename = loc_filename loc + packagename = loc_package loc + modulename = loc_module loc + lineno = fst $ loc_start loc + location = (filename, packagename, modulename, lineno) + [| \logger level msg ctx -> log logger level msg ctx location |] + +-- | Log "message" with a specific severity. +-- +-- The missing type signature: +-- ('MonadIO' m, 'IsMessage' s, 'ToJSON' c) => 'Logger' -> s -> c -> m () +debug, info, warn, error, fatal :: ExpQ +debug = [| \logger -> $(logv) logger $ read "DEBUG" |] +info = [| \logger -> $(logv) logger $ read "INFO" |] +warn = [| \logger -> $(logv) logger $ read "WARN" |] +error = [| \logger -> $(logv) logger $ read "ERROR" |] +fatal = [| \logger -> $(logv) logger $ read "FATAL" |] diff --git a/src/Logging/Manager.hs b/src/Logging/Manager.hs --- a/src/Logging/Manager.hs +++ b/src/Logging/Manager.hs @@ -22,7 +22,12 @@ , timezone :: TimeZone -- ^ @since 0.7.0 , disabled :: Bool , catchUncaughtException :: Bool + -- ^ Since 0.8.0, unhandled + -- 'Exception's are logged only in the global + -- logging environment. } + +{-# DEPRECATED catchUncaughtException "Will be removed" #-} -- | Initialize a 'Manager', open all its handlers. diff --git a/src/Logging/Monad/Internal.hs b/src/Logging/Monad/Internal.hs --- a/src/Logging/Monad/Internal.hs +++ b/src/Logging/Monad/Internal.hs @@ -18,6 +18,7 @@ import Control.Monad import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Reader +import Data.Aeson import Data.Default import Data.Generics.Product.Typed import Data.IORef @@ -52,10 +53,10 @@ runIO = lift . liftIO -log :: MonadIO m - => Logger -> Level -> String -> (String, String, String, Int) +log :: (MonadIO m, IsMessage s, ToJSON c) + => Logger -> Level -> s -> c -> (String, String, String, Int) -> LoggingT m () -log logger level message location = do +log logger level msg ctx location = do manager@Manager{..} <- ask utctime <- runIO getCurrentTime thread <- runIO myThreadId @@ -66,6 +67,8 @@ diffTime = utcTimeToPOSIXSeconds utctime created = timestamp diffTime msecs = milliseconds diffTime - (seconds diffTime * 1000) + message = toMessage msg + context = toJSON ctx when (not disabled) $ runIO $ process logger manager LogRecord{..} where diff --git a/src/Logging/Monad/TH.hs b/src/Logging/Monad/TH.hs --- a/src/Logging/Monad/TH.hs +++ b/src/Logging/Monad/TH.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} {-| This module provides a series of log routines that create a 'LogRecord' and then emit a log event. @@ -23,9 +22,11 @@ ) where import Control.Monad.IO.Class (MonadIO) +import Data.Aeson import Language.Haskell.TH import Prelude hiding (error, log) +import Logging.Class import Logging.Level import Logging.Logger import Logging.Monad.Internal @@ -33,7 +34,7 @@ -- | Log "message" with the severity "level". -- -- The missing type signature: --- 'MonadIO' m => 'Logger' -> 'Level' -> 'String' -> 'LoggingT' m () +-- ('MonadIO' m, 'IsMessage' s) => 'Logger' -> 'Level' -> s -> 'LoggingT' m () logv :: ExpQ logv = do loc <- location @@ -42,12 +43,12 @@ modulename = loc_module loc lineno = fst $ loc_start loc location = (filename, packagename, modulename, lineno) - [| \logger level msg -> log logger level msg location |] + [| \logger level msg -> log logger level msg Null location |] -- | Log "message" with a specific severity. -- -- The missing type signature: --- 'MonadIO' m => 'Logger' -> 'String' -> 'LoggingT' m () +-- ('MonadIO' m, 'IsMessage' s) => 'Logger' -> s -> 'LoggingT' m () debug, info, warn, error, fatal :: ExpQ debug = [| \logger -> $(logv) logger $ read "DEBUG" |] info = [| \logger -> $(logv) logger $ read "INFO" |] diff --git a/src/Logging/Monad/TH/Context.hs b/src/Logging/Monad/TH/Context.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Monad/TH/Context.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| A contextual version of "Logging.Monad.TH". + +Logging with context is very usefull for tracking issues through log records +or analyzing log records through other tools. It also provides a solution to +custom record fields other than 'LogRecord''s fileds. + +For example, by using the following 'Format1', a line of json string will be +written to a file or printed to the stderr. + +@ +"{{\\\"logger\\\": \\\"{logger}\\\", \\\"context\\\": {context}}}" +@ + +@since 0.8.0 +-} + +module Logging.Monad.TH.Context + ( logv + , debug + , info + , warn + , error + , fatal + ) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson +import Language.Haskell.TH +import Prelude hiding (error, log) + +import Logging.Class +import Logging.Level +import Logging.Logger +import Logging.Monad.Internal + +-- | Log "message" with the severity "level". +-- +-- The missing type signature: +-- ('MonadIO' m, 'IsMessage' s, 'ToJSON' c) => 'Logger' -> 'Level' -> s -> c +-- -> 'LoggingT' m () +logv :: ExpQ +logv = do + loc <- location + let filename = loc_filename loc + packagename = loc_package loc + modulename = loc_module loc + lineno = fst $ loc_start loc + location = (filename, packagename, modulename, lineno) + [| \logger level msg ctx -> log logger level msg ctx location |] + +-- | Log "message" with a specific severity. +-- +-- The missing type signature: +-- ('MonadIO' m, 'IsMessage' s, 'ToJSON' c) => 'Logger' -> s -> c +-- -> 'LoggingT' m () +debug, info, warn, error, fatal :: ExpQ +debug = [| \logger -> $(logv) logger $ read "DEBUG" |] +info = [| \logger -> $(logv) logger $ read "INFO" |] +warn = [| \logger -> $(logv) logger $ read "WARN" |] +error = [| \logger -> $(logv) logger $ read "ERROR" |] +fatal = [| \logger -> $(logv) logger $ read "FATAL" |] diff --git a/src/Logging/Record.hs b/src/Logging/Record.hs --- a/src/Logging/Record.hs +++ b/src/Logging/Record.hs @@ -4,10 +4,12 @@ module Logging.Record ( LogRecord(..) ) where import Control.Concurrent +import Data.Aeson import Data.Time.Clock import Data.Time.LocalTime import GHC.Generics import Text.Format +import Text.Format.Aeson import Text.Format.Time import Logging.Level @@ -70,6 +72,8 @@ -- ^ Use @{utctime:%3q}@ instead. -- See "Text.Format.Time" and "Data.Time.Format". , thread :: ThreadId + , context :: Value + -- ^ See "vformat-aeson" package } deriving (Generic, Show) instance FormatArg LogRecord diff --git a/test/LoggingTest/ConfigSpec.hs b/test/LoggingTest/ConfigSpec.hs --- a/test/LoggingTest/ConfigSpec.hs +++ b/test/LoggingTest/ConfigSpec.hs @@ -36,28 +36,24 @@ length sinks `shouldBe` 1 M.member "MyLogger" sinks `shouldBe` True disabled `shouldBe` False - catchUncaughtException `shouldBe` True it "yaml" $ do Manager{..} <- Yaml.getManager yamlRaw length sinks `shouldBe` 1 M.member "MyLogger" sinks `shouldBe` True disabled `shouldBe` False - catchUncaughtException `shouldBe` True it "json file" $ do Manager{..} <- Json.getManagerFile "/tmp/log4hs/config.json" length sinks `shouldBe` 1 M.member "MyLogger" sinks `shouldBe` True disabled `shouldBe` False - catchUncaughtException `shouldBe` True it "yaml file" $ do Manager{..} <- Yaml.getManagerFile "/tmp/log4hs/config.yaml" length sinks `shouldBe` 1 M.member "MyLogger" sinks `shouldBe` True disabled `shouldBe` False - catchUncaughtException `shouldBe` True it "root sink" $ do Sink{..} <- root <$> (Json.getManager jsonRaw) diff --git a/test/LoggingTest/Prelude.hs b/test/LoggingTest/Prelude.hs --- a/test/LoggingTest/Prelude.hs +++ b/test/LoggingTest/Prelude.hs @@ -13,6 +13,7 @@ import Control.Monad +import Data.Aeson import Data.List (dropWhileEnd, intersperse) import Data.String import Data.Time.LocalTime @@ -72,6 +73,7 @@ created = timestamp difftime msecs = milliseconds difftime thread = undefined + context = Null return $ LogRecord{..}