diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -11,11 +11,15 @@ #else import Data.Aeson.QQ (aesonQQ) #endif +import Data.ByteString (pack) +import Data.ByteString.Lazy (unpack) import Data.Maybe -import Logging import System.IO.Unsafe +import Logging +import Logging.Config.Json + main :: IO () main = run manager $ defaultMain $ [ bgroup "stderr" [ bench "simple" $ nfIO $ $(debug) "Stderr.Simple" msg100 @@ -35,11 +39,11 @@ manager :: Manager {-# NOINLINE manager #-} -manager = unsafePerformIO $ fromJust $ decode $ encode $ +manager = unsafePerformIO $ getManager $ pack $ unpack $ encode $ [aesonQQ|{ "disabled": false, "catchUncaughtException": true, - "loggers": { + "sinks": { "Stderr.Simple": { "handlers": ["stderr.simple"], "propagate": false 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: 90b0b17510bc8c4fc178da4193122aee38d748d65201c114cd6c51476b45cb3e +-- hash: e7973c763207cddf6697fcd36825081d9f793242e5dc25a07c6b80d710174aa8 name: log4hs -version: 0.3.1.0 +version: 0.4.0.0 synopsis: A python logging style log library description: Please see the http://hackage.haskell.org/package/log4hs category: logging @@ -24,10 +24,12 @@ exposed-modules: Logging Logging.Aeson + Logging.Config.Json + Logging.Config.Type + Logging.Config.Yaml Logging.Types Logging.Utils other-modules: - Logging.Deprecated Logging.Internal Logging.TH Logging.Types.Class @@ -50,6 +52,7 @@ build-depends: aeson >=1.2 && <2.0 , base >=4.7 && <5 + , bytestring >=0.10 && <1.0 , containers >=0.5.10 && <1.0 , data-default >=0.5 && <1.0 , directory >=1.2 && <1.4 @@ -60,6 +63,7 @@ , text >=1.2 && <2.0 , time >=1.4 && <2.0 , vformat >=0.9.1 && <1.0 + , yaml >=0.9 && <1.0 default-language: Haskell2010 test-suite log4hs-test @@ -67,6 +71,7 @@ main-is: Spec.hs other-modules: Logging.AesonSpec + Logging.ConfigSpec Logging.TypesSpec LoggingSpec Paths_log4hs @@ -78,6 +83,7 @@ , aeson >=1.2 && <2.0 , aeson-qq >=0.8 && <1.0 , base >=4.7 && <5 + , bytestring >=0.10 && <1.0 , containers >=0.5.10 && <1.0 , data-default >=0.5 && <1.0 , directory >=1.2 && <1.4 @@ -92,6 +98,7 @@ , text >=1.2 && <2.0 , time >=1.4 && <2.0 , vformat >=0.9.1 && <1.0 + , yaml >=0.9 && <1.0 default-language: Haskell2010 benchmark log4hs-bench @@ -106,6 +113,7 @@ aeson >=1.2 && <2.0 , aeson-qq >=0.8 && <1.0 , base >=4.7 && <5 + , bytestring >=0.10 && <1.0 , containers >=0.5.10 && <1.0 , criterion >=1.0 && <2.0 , data-default >=0.5 && <1.0 @@ -118,4 +126,5 @@ , text >=1.2 && <2.0 , time >=1.4 && <2.0 , vformat >=0.9.1 && <1.0 + , yaml >=0.9 && <1.0 default-language: Haskell2010 diff --git a/src/Logging.hs b/src/Logging.hs --- a/src/Logging.hs +++ b/src/Logging.hs @@ -19,10 +19,11 @@ import Data.Aeson import Data.Maybe import Logging + import Logging.Config.Json import Prelude hiding (error) main :: IO () - main = fromJust (decode \"{}\") >>= flip run app + main = getManager "{}" >>= flip run app myLogger = \"MyLogger.Main\" @@ -36,20 +37,17 @@ $(logv) myLogger \"LEVEL 100\" \"this is a test message\" @ +See "Logging.Config.Json" and "Logging.Config.Yaml" to lean more about +decoding 'Manager' from json or yaml -__See "Logging.Aeson" to lean more about decoding json into 'Manager'__ -} module Logging - ( module Logging.Aeson - , module Logging.Types - , module Logging.Deprecated + ( module Logging.Types , module Logging.Internal -- ** Logging THs , module Logging.TH ) where -import Logging.Aeson -import Logging.Deprecated -import Logging.Internal hiding (log) +import Logging.Internal hiding (log) import Logging.TH import Logging.Types diff --git a/src/Logging/Aeson.hs b/src/Logging/Aeson.hs --- a/src/Logging/Aeson.hs +++ b/src/Logging/Aeson.hs @@ -6,7 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -module Logging.Aeson +module Logging.Aeson {-# DEPRECATED "Use Logging.Config.Json instead" #-} ( -- * Aeson Instances -- diff --git a/src/Logging/Config/Json.hs b/src/Logging/Config/Json.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Config/Json.hs @@ -0,0 +1,120 @@ +{-| This module provides a convenient way to decode a 'Manager' from json string + +There is a 'Config' type in "Logging.Config.Type" module, it is an instance +of 'FromJSON', 1) decode 'Config' from json string, 2) construct an 'Manager' +from 'Config'. + + +All 'Maybe' fileds can be omitted, the default value will be used, e.g. + +1) 'List' type field will use '[]' as default + +2) 'Bool' type filed will use False as default + +3) if the field is an instance of 'Data.Default.Default', use 'def' + +4) an appropriate value as default for other fields + + +In fact, you can decode 'Config' from an empty json (object) string, + +@ + manager <- getManager "{}" -- enable the 'OverloadedStrings' extension +@ + +it will create a manager with a root sink (i.e. 'Logging.defaultRoot'), +the 'Logging.defaultRoot' will be used when the root sink is omitted. + +Here is a json string template: + +@ + { + \"sinks\": + { + \"root\": + { + \"handlers\": [\"console\", \"file\"] + }, + \"App.Json\": + { + \"handlers\": [\"file\"], + \"propagate\": false + }, + \"App.Yaml\": + { + \"handlers\": [\"rotate\"], + \"propagate\": false + } + }, + \"handlers\": + { + \"console\": + { + \"type\": \"StreamHandler\", + \"level\": \"DEBUG\", + \"formatter\": \"simple\", + \"stream\": \"stderr\" + }, + \"file\": + { + \"type\": \"FileHandler\", + \"level\": \"Level 100\", + \"filterer\": [\"App.Json\"], + \"formatter\": \"standard\", + \"file\": \"/etc\/my\/json.log\", + \"encoding\": \"utf8\" + }, + \"rotate\": + { + \"type\": \"RotatingFileHandler\", + \"level\": \"INFO\", + \"filterer\": [\"App.Yaml\"], + \"formatter\": \"standard\", + \"file\": \"/etc\/my\/yaml.log\", + \"encoding\": \"utf8\", + \"maxBytes\": 1048576, + \"backupCount\": 10 + } + }, + \"formatters\": + { + \"simple\": \"{message}\", + \"standard\": \"{asctime:%Y-%m-%dT%H:%M:%S%6Q%z} - {level} - {logger}] {message}\" + }, + \"disabled\": false, + \"catchUncaughtException\": true + } +@ + +-} + +module Logging.Config.Json (getManager, getManagerFile) where + + +import Control.Exception +import Data.Aeson +import Data.ByteString +import Prelude hiding (readFile) + +import Logging.Config.Type +import Logging.Types (Manager) + + +-- | decode a 'Manager' from strict 'ByteString' +-- +-- @since 0.4.0 +getManager :: ByteString -> IO Manager +getManager bs = + case eitherDecodeStrict bs of + Left msg -> throw $ ConfigException msg + Right config -> createManager config + + +-- | decode a 'Manager' from a file +-- +-- @since 0.4.0 +getManagerFile :: FilePath -> IO Manager +getManagerFile path = getManager =<< catch (readFile path) reThrow + where + reThrow :: SomeException -> IO a + reThrow e = throw $ ConfigException $ displayException e diff --git a/src/Logging/Config/Type.hs b/src/Logging/Config/Type.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Config/Type.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Logging.Config.Type + ( Handler(..) + , Sink(..) + , Config(..) + , ConfigException(..) + , createManager + ) where + + +import Control.Exception (Exception) +import Data.Aeson +import Data.Default +import Data.IORef +import Data.Map.Lazy +import Data.Maybe +import Data.String +import GHC.Generics +import System.IO + +import Prelude hiding (map) +import qualified Prelude as P +import Text.Format + +import Logging.Internal +import qualified Logging.Types as T +import Logging.Utils + + +data Handler = StreamHandler { level :: Maybe String + , filterer :: Maybe [String] + , formatter :: Maybe String + , stream :: Maybe String + } + | FileHandler { level :: Maybe String + , filterer :: Maybe [String] + , formatter :: Maybe String + , file :: FilePath + , encoding :: Maybe String + } + | RotatingFileHandler { level :: Maybe String + , filterer :: Maybe [String] + , formatter :: Maybe String + , file :: FilePath + , encoding :: Maybe String + , maxBytes :: Maybe Int + , backupCount :: Maybe Int + } + deriving (Generic, Show) + +instance FromJSON Handler where + parseJSON = genericParseJSON option + where + sumEncoding = defaultTaggedObject { tagFieldName = "type" } + option = defaultOptions { sumEncoding = sumEncoding } + + +data Sink = Sink { level :: Maybe String + , filterer :: Maybe [String] + , handlers :: Maybe [String] + , propagate :: Maybe Bool + , disabled :: Maybe Bool + } deriving (Generic, Show) + +instance FromJSON Sink + + +data Config = Config { sinks :: Maybe (Map String Sink) + , handlers :: Maybe (Map String Handler) + , formatters :: Maybe (Map String String) + , disabled :: Maybe Bool + , catchUncaughtException :: Maybe Bool + } deriving (Generic, Show) + +instance FromJSON Config + + +newtype ConfigException = ConfigException { message :: String } + +instance Show ConfigException where + show e = "Logging Config Exception: " ++ (message e) + +instance Exception ConfigException + + +createManager :: Config -> IO T.Manager +createManager Config{..} = do + handlers <- mapM (createHandler formatters') $ fromMaybe empty handlers + sinks <- sequence $ mapWithKey (createSink handlers) $ fromMaybe empty sinks + + let root = findWithDefault defaultRoot "root" sinks + sinks' = delete "root" sinks + disabled' = fromMaybe False disabled + catchUncaughtException' = fromMaybe False catchUncaughtException + return $ T.Manager root sinks' disabled' catchUncaughtException' + where + formatters' :: Map String Format1 + formatters' = maybe (singleton "" "{message}") (map fromString) formatters + + createSink :: Map String T.SomeHandler -> String -> Sink -> IO T.Sink + createSink hs logger Sink{..} = do + let logger' = if logger == "root" then "" else logger + level' = maybe def read level + filterer' = maybe [] (P.map fromString) filterer + handlers' = [hs ! h | h <- fromMaybe [] handlers] + disabled' = fromMaybe False disabled + propagate' = fromMaybe False propagate + return $ T.Sink logger' level' filterer' handlers' disabled' propagate' + + getStream :: String -> Handle + getStream "stderr" = stderr + getStream "stdout" = stdout + getStream _ = error "Logging.Config: no parse (stream)" + + createHandler :: Map String Format1 -> Handler -> IO T.SomeHandler + createHandler fs StreamHandler{..} = do + let level' = maybe def read level + filterer' = maybe [] (P.map fromString) filterer + formatter' = maybe "{message}" ((!) fs) formatter + stream' = getStream $ fromMaybe "stderr" stream + return $ T.toHandler $ T.StreamHandler level' filterer' formatter' stream' + createHandler fs FileHandler{..} = do + let level' = maybe def read level + filterer' = maybe [] (P.map fromString) filterer + formatter' = maybe "{message}" ((!) fs) formatter + encoding' <- mkTextEncoding $ fromMaybe "utf8" encoding + stream <- newIORef undefined + return $ T.toHandler $ + T.FileHandler level' filterer' formatter' file encoding' stream + createHandler fs RotatingFileHandler{..} = do + let level' = maybe def read level + filterer' = maybe [] (P.map fromString) filterer + formatter' = maybe "{message}" ((!) fs) formatter + maxBytes' = fromMaybe 104857600 maxBytes + backupCount' = fromMaybe 10 backupCount + encoding' <- mkTextEncoding $ fromMaybe "utf8" encoding + stream <- newIORef undefined + return $ T.toHandler $ + T.RotatingFileHandler level' filterer' formatter' file encoding' + maxBytes' backupCount' stream diff --git a/src/Logging/Config/Yaml.hs b/src/Logging/Config/Yaml.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Config/Yaml.hs @@ -0,0 +1,81 @@ +{-| This module provides a convenient way to decode a 'Manager' from yaml string + + +Here is a yaml string template: + +@ + sinks: + root: + handlers: + - console + - file + App.Json: + handlers: + - file + propagate: false + App.Yaml: + handlers: + - rotate + propagate: false + + handlers: + console: + type: StreamHandler + level: DEBUG + formatter: simple + stream: stderr + file: + type: FileHandler + level: "Level 100" + formatter: standard + file: /etc/my/json.log + encoding: utf8 + rotate: + type: RotatingFileHandler + level: INFO + formatter: standard + file: /etc/my/json.log + encoding: utf8 + maxBytes: 1048576 + backupCount: 10 + + formatters: + simple: "{message}" + standard: "{asctime:%Y-%m-%dT%H:%M:%S%6Q%z} - {level} - {logger}] {message}" + + disabled: false + + catchUncaughtException: true +@ + +-} +module Logging.Config.Yaml (getManager, getManagerFile) where + + +import Control.Exception +import Data.ByteString +import Data.Yaml + +import Logging.Config.Type +import Logging.Types (Manager) + + +-- | decode a 'Manager' from strict 'ByteString' +-- +-- @since 0.4.0 +getManager :: ByteString -> IO Manager +getManager bs = + case decodeEither' bs of + Left e -> throw $ ConfigException $ prettyPrintParseException e + Right config -> createManager config + + +-- | decode a 'Manager' from a file +-- +-- @since 0.4.0 +getManagerFile :: FilePath -> IO Manager +getManagerFile path = do + res <- decodeFileEither path + case res of + Left e -> throw $ ConfigException $ prettyPrintParseException e + Right config -> createManager config diff --git a/src/Logging/Deprecated.hs b/src/Logging/Deprecated.hs deleted file mode 100644 --- a/src/Logging/Deprecated.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Logging.Deprecated - ( runJson - , jsonToManager - ) where - - -import Data.Aeson - -import Logging.Aeson -import Logging.Internal -import Logging.Types - --- |Run a logging environment from JSON 'Value'. --- --- A combinator of 'run' and 'fromJSON' --- --- A combinator of 'jsonToManager' and 'run' --- --- See 'Logging.Aeson' -{-# DEPRECATED runJson "will be removed in 1.0.0" #-} -runJson :: Value -> IO a -> IO a -runJson v io = sequence (fromJSON v) >>= \result -> - case result of - Error _ -> error "Logging.Aeson: no parse (manager)" - Success mgr -> run mgr io - - --- |Make a 'Manager' from JSON 'Value' --- --- Decode 'Aeson.Value' into 'Manager' --- --- See 'Logging.Aeson' -{-# DEPRECATED jsonToManager "will be removed in 1.0.0" #-} -jsonToManager :: Value -> IO Manager -jsonToManager v = sequence (fromJSON v) >>= \result -> - case result of - Error _ -> error "Logging.Aeson: no parse (manager)" - Success mgr -> return mgr diff --git a/test/Logging/ConfigSpec.hs b/test/Logging/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Logging/ConfigSpec.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Logging.ConfigSpec ( spec ) where + + +import Data.Aeson as Json +#if MIN_VERSION_aeson(1, 4, 3) +import Data.Aeson.QQ.Simple (aesonQQ) +#else +import Data.Aeson.QQ (aesonQQ) +#endif +import Data.ByteString (ByteString, pack, writeFile) +import Data.ByteString.Lazy (unpack) +import qualified Data.Map as M +import Data.Yaml as Yaml +import Data.Yaml.TH +import Prelude hiding (writeFile) +import System.Directory +import Test.Hspec +import Test.Hspec.QuickCheck + +import Logging +import Logging.Config.Json as Json +import Logging.Config.Yaml as Yaml + + +spec :: Spec +spec = beforeAll_ prepare $ + describe "Config & Manager" $ modifyMaxSize (const 1000) $ do + it "json" $ do + Manager{..} <- Json.getManager jsonRaw + 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) + + logger `shouldBe` "" + level `shouldBe` "DEBUG" + disabled `shouldBe` False + propagate `shouldBe` False + length filterer `shouldBe` 0 + length handlers `shouldBe` 1 + + it "sinks" $ do + Sink{..} <- (flip (M.!) "MyLogger" . sinks) <$> (Json.getManager jsonRaw) + + logger `shouldBe` "MyLogger" + level `shouldBe` "INFO" + propagate `shouldBe` False + disabled `shouldBe` False + length filterer `shouldBe` 1 + filterer == ["MyLogger.Main"] `shouldBe` True + length handlers `shouldBe` 2 + + +prepare :: IO () +prepare = do + createDirectoryIfMissing False "/tmp/log4hs" + writeFile "/tmp/log4hs/config.json" jsonRaw + writeFile "/tmp/log4hs/config.yaml" yamlRaw + + +jsonRaw :: ByteString +jsonRaw = pack $ unpack $ Json.encode + [aesonQQ|{ + "sinks": { + "root": { + "level": "DEBUG", + "handlers": ["console"], + "propagate": false + }, + "MyLogger": { + "level": "INFO", + "filterer": ["MyLogger.Main"], + "handlers": ["console", "file"], + "propagate": false + } + }, + "handlers": { + "console": { + "type": "StreamHandler", + "stream": "stderr", + "level": "DEBUG", + "formatter": "default" + }, + "file": { + "type": "FileHandler", + "level": "INFO", + "formatter": "default", + "file": "./default.log" + } + }, + "formatters": { + "default": "{asctime} - {level} - {logger}:{lineno}] {message}" + }, + "catchUncaughtException": true + }|] + + +yamlRaw :: ByteString +yamlRaw = Yaml.encode + [yamlQQ| + sinks: + root: + level: DEBUG + handlers: + - console + propagate: false + MyLogger: + level: INFO + filterer: + - MyLogger.Main + handlers: + - console + - file + propagate: false + handlers: + console: + type: StreamHandler + stream: stderr + level: DEBUG + formatter: default + file: + type: FileHandler + level: INFO + formatter: default + file: "./default.log" + formatters: + default: "{asctime} - {level} - {logger}:{lineno}] {message}" + catchUncaughtException: true + |]