diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,3 @@ -# Changelog for logging +# Changelog for log4hs ## Unreleased changes 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: a3438c9a7d132145f0468cc5eb8a4ebe54bd68bf61668f53e134e25e013f332c +-- hash: 98410eaec949ad056db17a215e79111cd33b233aeedfd41caeecb8c3207823ec name: log4hs -version: 0.0.2.0 +version: 0.0.3.0 synopsis: A python logging style log library description: Please see the README category: logging @@ -23,11 +23,12 @@ library exposed-modules: Logging + Logging.Aeson + Logging.Types other-modules: - Data.Aeson.Extra + Logging.Deprecated Logging.Internal Logging.TH - Logging.Types Paths_log4hs hs-source-dirs: src @@ -41,7 +42,6 @@ , template-haskell >=2.0 && <3.0 , text >=1.2 && <2.0 , time >=1.4 && <2.0 - , unordered-containers >=0.2 && <1.0 default-language: Haskell2010 test-suite log4hs-test @@ -67,5 +67,4 @@ , template-haskell >=2.0 && <3.0 , text >=1.2 && <2.0 , time >=1.4 && <2.0 - , unordered-containers >=0.2 && <1.0 default-language: Haskell2010 diff --git a/src/Data/Aeson/Extra.hs b/src/Data/Aeson/Extra.hs deleted file mode 100644 --- a/src/Data/Aeson/Extra.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Data.Aeson.Extra - ( lookupObject - , lookupArray - , lookupString - , lookupBool - ) where - - -import Data.Aeson -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T - -lookupObject key kvs = - case (HM.lookup key kvs) of - Just (Object obj) -> - HM.fromList $ map (\(k, v) -> (T.unpack k, v)) $ HM.toList obj - _ -> HM.empty - -lookupArray key kvs = - case (HM.lookup key kvs) of - Just (Array arr) -> foldr (:) [] arr - _ -> [] - -lookupString def key kvs = - case (HM.lookup key kvs) of - Just (String t) -> T.unpack t - _ -> def - -lookupBool def key kvs = - case (HM.lookup key kvs) of - Just (Bool b) -> b - _ -> def diff --git a/src/Logging.hs b/src/Logging.hs --- a/src/Logging.hs +++ b/src/Logging.hs @@ -8,81 +8,49 @@ = A python logging style log library. -=== A full example: +=== A simple example: @ \{\-\# LANGUAGE OverloadedStrings \#\-\} - \{\-\# LANGUAGE QuasiQuotes \#\-\} - \{\-\# LANGUAGE RecordWildCards \#\-\} \{\-\# LANGUAGE TemplateHaskell \#\-\} - - module Main (main) where + module Main ( main ) where - import Data.Aeson.QQ.Simple (aesonQQ) - import Prelude hiding (error) - import Logging (runJson, debug, info, warn, error, fatal, logv) + import Data.Aeson + import Data.Maybe + import Logging + import Prelude hiding (error) main :: IO () - main = 'runJson' manager app + main = fromJust (decode \"{}\") >>= flip run app myLogger = \"MyLogger.Main\" app :: IO () app = do - \$(debug) myLogger \"this message should print into MyLogger\" - \$(info) myLogger \"this message should print into MyLogger\" - \$(warn) myLogger \"this message should print into MyLogger\" - \$(error) myLogger \"this message should print into MyLogger\" - \$(fatal) myLogger \"this message should print into MyLogger\" - \$(logv) myLogger "LEVEL 100" \"this message should print into MyLogger\" - - \-\- The best practice is putting all config into a separate file, - \-\- e.g "Logging.json" - manager = [aesonQQ|{ - \"loggers\": { - \"root\": { - \"level\": \"DEBUG\", - \"handlers\": [\"console\"], - \"propagate\": false - }, - \"MyLogger\": { - \"level\": \"INFO\", - \"filterer\": [\"MyLogger.Main\"], - \"handlers\": [\"file\"], - \"propagate\": false - } - }, - \"handlers\": { - \"console\": { - \"type\": \"StreamHandler\", - \"stream\": \"stderr\", - \"level\": \"DEBUG\", - \"formatter\": \"defaultFormatter\" - }, - \"file\": { - \"type\": \"FileHandler\", - \"level\": \"INFO\", - \"formatter\": \"defaultFormatter\", - \"file\": \"./default.log\" - } - }, - \"formatters\": { - \"defaultFormatter\": { - \"fmt\": \"%(asctime)s - %(level)s - %(logger)s - %(pathname)s/%(filename)s:%(lineno)d] %(message)s\" - } - } - }|] + $(debug) myLogger \"this is a test message\" + $(info) myLogger \"this is a test message\" + $(warn) myLogger \"this is a test message\" + $(error) myLogger \"this is a test message\" + $(fatal) myLogger \"this is a test message\" + $(logv) myLogger \"LEVEL 100\" \"this is a test message\" @ + + +__See 'Logging.Aeson' to lean more about decoding json into 'Manager'__ -} module Logging - ( module Logging.Internal + ( module Logging.Aeson + , module Logging.Deprecated + , module Logging.Internal -- ** Logging THs , module Logging.TH -- ** Types , module Logging.Types ) where -import Logging.Internal hiding (log) +import Logging.Aeson +import Logging.Deprecated +import Logging.Internal hiding (log) import Logging.TH -import Logging.Types hiding (Filterable (..), Formattable (..)) +import Logging.Types hiding (Filterable (..), Formattable (..)) diff --git a/src/Logging/Aeson.hs b/src/Logging/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Aeson.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Logging.Aeson + ( + -- * Aeson Instances + -- + -- $aesondoc + ) where + +import Control.Applicative (pure) +import Control.Concurrent.MVar +import Data.Aeson +import Data.Aeson.Types (Parser, typeMismatch) +import Data.Default +import Data.Map.Lazy (Map, (!)) +import qualified Data.Map.Lazy as M +import qualified Data.Text as T +import System.Directory +import System.FilePath +import System.IO + +import Logging.Internal +import Logging.Types + + +mapAp :: (Applicative f1, Applicative f2) => f1 (a -> b) -> f2 a -> (f1 (f2 b)) +mapAp f x = ((<*> x) . pure) <$> f + +mapAp2 :: (Applicative f1, Applicative f2) => f1 (a -> b -> c) -> f2 a -> f2 b -> (f1 (f2 c)) +mapAp2 f x y = ((<*> y). (<*> x) . pure) <$> f + + +{- $aesondoc + +By using 'Data.Aeson', we can decode json string into 'Manager'. + +__A basic 'Manager' json format:__ + +@ + { + \"loggers\": {\"root\": {}, \"MyLogger\": {}}, + \"handlers\": {\"console\": {}, \"file\": {}}, + \"formatters\": {\"default\": {}, \"simple\": {}} + } +@ + + +In practice, a set of handlers share a formatter, and other handlers share +another one, so we define all the formatters in a map, handler refernces +the formatter throught its key. + +So as handlers, sinks may share same handlers. + +__Examples of 'Formatter' json__ + +@ + -- a standard format + { + \"fmt\": \"%(message)s\", + \"datefmt\": \"%Y-%m-%dT%H:%M:%S\" + } + + -- missing field will use default value + { + \"fmt": "%(message)s\", + \"datefmt\": \"%Y-%m-%dT%H:%M:%S\" + } + + -- it works as well, just a string + \"%(message)s\" +@ + +__Examples of 'Handler' json__ + +Note: Besides some common field, handler's other fields depend on its type. + +@ + -- a standard format + { + \"type\": \"StreamHandler\", + \"stream\": \"stderr\", + \"level\": \"DEBUG\", + \"filterer\": [\"Package.Module.Submodule\"], + \"formatter\": \"default\", + } + + -- FileHandler is just a StreamHandler, the stream is created by openFile + { + \"type\": \"FileHandler\", + \"file\": \"./default.log\", + \"level\": \"INFO\", + \"filterer\": [], + \"formatter\": \"simple\", + } +@ +-} + +instance FromJSON Level where + parseJSON v = read <$> parseJSON v + + +instance FromJSON Filter where + parseJSON v = (\s -> Filter s $ length s) <$> parseJSON v + + +instance FromJSON Formatter where + parseJSON (Object v) = Formatter <$> v .:? "fmt" .!= (fmt def) + <*> v .:? "datefmt" .!= (datefmt def) + parseJSON (String v) = (\fmt -> def {fmt = fmt}) <$> parseJSON (String v) + parseJSON invalid = typeMismatch "Object" invalid + + +instance FromJSON (IO StreamHandler) where + parseJSON = withObject "StreamHandler" $ \v -> flip mapAp (newMVar ()) $ + StreamHandler <$> (parseStream <$> (v .:? "stream" .!= "stderr")) + <*> v .:? "level" .!= def + <*> v .:? "filterer" .!= [] + <*> v .:? "formatter" .!= def + where + parseStream :: String -> Handle + parseStream "stderr" = stderr + parseStream "stdout" = stdout + parseStream _ = error "Logging.Aeson: no parse (stream)" + + +instance FromJSON (IO HandlerT) where + parseJSON = withObject "Handler" $ \v -> (v .: "type") >>= (`parseHandler` v) + where + openLogFile :: FilePath -> IO Handle + openLogFile file = do + file' <- makeAbsolute file + createDirectoryIfMissing True $ takeDirectory file' + stream <- openFile file AppendMode + hSetEncoding stream utf8 + return stream + + parseHandler :: String -> Object -> Parser (IO HandlerT) + parseHandler "StreamHandler" v = do + hdl <- parseJSON (Object v) + return $ HandlerT <$> (hdl :: IO StreamHandler) + parseHandler "FileHandler" v = do + hdl :: (IO StreamHandler) <- parseJSON (Object v) + stream <- openLogFile <$> (v .: "file" .!= "default.log") + hdl' <- mapAp2 (pure $ \h s -> h {stream = s}) hdl stream + return $ HandlerT <$> hdl' + parseHandler t _ = error $ "Logging.Aeson: no parse (Handler" ++ t ++")" + + +instance FromJSON (Map String Formatter -> IO HandlerT) where + parseJSON = withObject "Handler" $ \v -> do + hdlio <- parseJSON (Object v) + key <- v .:? "formatter" .!= "" + return $ \fs -> hdlio >>= \(HandlerT hdl) -> do + return $ HandlerT $ setFormatter hdl (M.findWithDefault def key fs) + + +instance FromJSON (Sink) where + parseJSON = withObject "Sink" $ \v -> + Sink <$> v .:? "logger" .!= "placeholder" + <*> v .:? "level" .!= def + <*> v .:? "filterer" .!= [] + <*> (return []) + <*> v .:? "disabled" .!= False + <*> v .:? "propagate" .!= False + + +instance FromJSON (String -> Map String HandlerT -> Sink) where + parseJSON = withObject "Sink" $ \v -> do + sink <- parseJSON (Object v) + keys <- v .:? "handlers" .!= [] + return $ \lgr hs -> sink { logger = if lgr == "root" then "" else lgr + , handlers = [hs ! k | k <- keys] + } + + +type Formatters = Map String Formatter +type HandlerTsMakerIO = Map String (Formatters -> IO HandlerT) +type SinksMaker = Map String (String -> Map String HandlerT -> Sink) + +instance FromJSON (IO Manager) where + parseJSON = withObject "Manager" $ \v -> do + fmts :: Formatters <- v .:? "formatters" .!= (object []) >>= parseJSON + hdls :: HandlerTsMakerIO <- v .:? "handlers" .!= (object []) >>= parseJSON + sinks :: SinksMaker <- v .:? "loggers" .!= (object []) >>= parseJSON + + disabled <- v .:? "disabled" .!= False + catchUncaughtException <- v .:? "catchUncaughtException" .!= False + + return $ do + hdls' <- sequence $ M.map (\f -> f fmts) hdls + let sinks' = M.mapWithKey (\k f -> f k hdls') sinks + root = M.findWithDefault defaultRoot "root" sinks' + sinks'' = M.delete "root" sinks' + return $ Manager root sinks'' disabled catchUncaughtException diff --git a/src/Logging/Deprecated.hs b/src/Logging/Deprecated.hs new file mode 100644 --- /dev/null +++ b/src/Logging/Deprecated.hs @@ -0,0 +1,38 @@ +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/src/Logging/Internal.hs b/src/Logging/Internal.hs --- a/src/Logging/Internal.hs +++ b/src/Logging/Internal.hs @@ -5,37 +5,27 @@ module Logging.Internal ( run - , runJson - , jsonToManager , log , stderrHandler , stdoutHandler , defaultRoot ) where -import Control.Concurrent.MVar (MVar, newMVar) +import Control.Concurrent.MVar import Control.Exception (SomeException, bracket_) -import Control.Monad (forM_, sequence, void, when) +import Control.Monad (forM_, void, when) import Control.Monad.IO.Class (MonadIO (..)) -import Data.Aeson (Value (..)) import Data.Default -import qualified Data.HashMap.Strict as HM import Data.IORef import Data.List (dropWhileEnd) -import Data.Map.Lazy (Map, delete, fromList, (!?)) -import qualified Data.Text as T +import Data.Map.Lazy ((!?)) import Data.Time.Clock import Data.Time.LocalTime import GHC.Conc (setUncaughtExceptionHandler) import Prelude hiding (filter, log) -import System.Directory (createDirectoryIfMissing, - makeAbsolute) -import System.FilePath -import System.IO (Handle, IOMode (..), hSetEncoding, - openFile, stderr, stdout, utf8) +import System.IO (Handle, stderr, stdout) import System.IO.Unsafe (unsafePerformIO) -import Data.Aeson.Extra import Logging.Types {-# NOINLINE _mgr #-} @@ -69,96 +59,6 @@ closeHandlers :: Sink -> IO () closeHandlers Sink{..} = forM_ handlers $ \(HandlerT hdl) -> close hdl - - --- |Run a logging environment from JSON 'Value'. --- --- A combinator of 'run' and 'jsonToManager'. --- -runJson :: Value -> IO a -> IO a -runJson val io = jsonToManager val >>= (`run` io) - --- | Parse JSON to Formatter -jsonToFormatter :: Value -> Formatter -jsonToFormatter (Object obj) = - Formatter (lookupString fmt "fmt" obj) (lookupString datefmt "datefmt" obj) - where - Formatter{..} = def -jsonToFormatter (String fmt) = def {fmt = T.unpack fmt} -jsonToFormatter _ = def - - --- | Parse JSON to Filter -jsonToFilter :: Value -> Filter -jsonToFilter (String s) = let s' = T.unpack s in Filter s' (length s') -jsonToFilter _ = error "Logging.Internal: no parse (Filter)" - - --- | Parse JSON to Handler(T) -jsonToHandler :: Value -> (String -> Formatter) -> IO HandlerT -jsonToHandler (Object obj) lookupFmt = jsonToHandler' type_ - where - type_ = lookupString "" "type" obj - level = read $ lookupString "NOTSET" "level" obj - filterer = map jsonToFilter $ lookupArray "filterer" obj - formatter = lookupFmt $ lookupString "" "formatter" obj - - lock :: IO (MVar ()) - lock = newMVar () - - nameToStream :: String -> Handle - nameToStream "stderr" = stderr - nameToStream "stdout" = stdout - nameToStream _ = error "Logging.Internal: no parse (stream)" - - jsonToHandler' :: String -> IO HandlerT - jsonToHandler' "StreamHandler" = do - let stream = nameToStream $ lookupString "stderr" "stream" obj - (HandlerT . (StreamHandler stream level filterer formatter)) <$> lock - jsonToHandler' "FileHandler" = do - file <- makeAbsolute $ lookupString "default.log" "file" obj - createDirectoryIfMissing True $ takeDirectory file - stream <- openFile file AppendMode - hSetEncoding stream utf8 - (HandlerT . (StreamHandler stream level filterer formatter)) <$> lock - jsonToHandler' _ = error $ "Logging.Internal: no parse (Handler)" -jsonToHandler _ _ = undefined - - --- | Parse JSON to Sink -jsonToSink :: (String, Value) -> (String -> HandlerT) -> Sink -jsonToSink (logger, Object obj) lookupHdl = - Sink logger' level filterer handlers disabled propagate - where - logger' = if logger == "root" then "" else logger - level = read $ lookupString "NOTSET" "level" obj - filterer = map jsonToFilter $ lookupArray "filterer" obj - handlers = [lookupHdl (T.unpack v) | (String v) <- lookupArray "handlers" obj] - disabled = lookupBool False "disabled" obj - propagate = lookupBool False "propagate" obj -jsonToSink _ _ = error "Logging.Internal: no parse (Logger)" - - --- |Make a 'Manager' from JSON 'Value'. -jsonToManager :: Value -> IO Manager -jsonToManager (Object obj) = do - let formatters = HM.map jsonToFormatter $ lookupObject "formatters" obj - lookupFmt k = HM.lookupDefault def k formatters - handlerNames = lookupObject "handlers" obj - - handlers <- sequence $ HM.map (`jsonToHandler` lookupFmt) handlerNames - - let lookupHdl = (HM.!) handlers - sinkVals = lookupObject "loggers" obj - sinks = HM.mapWithKey (curry (`jsonToSink` lookupHdl)) sinkVals - - root = HM.lookupDefault defaultRoot "root" sinks - sinks' = delete "root" $ fromList $ HM.toList sinks - disabled = lookupBool False "disabled" obj - catchUncaughtException = lookupBool False "catchUncaughtException" obj - - return $ Manager root sinks' disabled catchUncaughtException -jsonToManager _ = error "Logging.Internal: no parse (Manager)" -- |Low-level logging routine which creates a LogRecord and then calls diff --git a/src/Logging/TH.hs b/src/Logging/TH.hs --- a/src/Logging/TH.hs +++ b/src/Logging/TH.hs @@ -11,12 +11,13 @@ , fatal ) where +import Control.Monad.IO.Class (MonadIO) import Language.Haskell.TH import Logging.Internal import Logging.Types -import Prelude hiding (error, log) +import Prelude hiding (error, log) -- | Log "message" with the severity "level". -- diff --git a/src/Logging/Types.hs b/src/Logging/Types.hs --- a/src/Logging/Types.hs +++ b/src/Logging/Types.hs @@ -161,6 +161,7 @@ -- Note that this class does not close the stream when the stream is a -- terminal device, e.g. 'stderr' and 'stdout'. -- +-- Note: 'FileHandler' is an alias of 'StreamHandler' data StreamHandler = StreamHandler { stream :: Handle , level :: Level , filterer :: Filterer diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,6 +5,7 @@ import Control.Concurrent.MVar import Control.Monad +import Data.Aeson as A import Data.Aeson.QQ.Simple (aesonQQ) import Data.Default (def) import Data.List (intercalate, lines) @@ -20,6 +21,7 @@ import qualified Test.QuickCheck.Monadic as QC import Logging +import Logging.Aeson main :: IO () main = hspec $ do @@ -100,14 +102,16 @@ QC.assert (msg == format rcd) testJsonToManager :: IO () -testJsonToManager = do - mgr@Manager{..} <- jsonToManager managerJson - -- root - testSink "root" root - -- sinks - length sinks `shouldBe` 1 - M.member "MyLogger" sinks `shouldBe` True - testSink "MyLogger" $ sinks M.! "MyLogger" +testJsonToManager = (sequence $ A.fromJSON managerJson) >>= \result -> + case result of + A.Error msg -> expectationFailure msg + A.Success mgr@Manager{..} -> do + -- root + testSink "root" root + -- sinks + length sinks `shouldBe` 1 + M.member "MyLogger" sinks `shouldBe` True + testSink "MyLogger" $ sinks M.! "MyLogger" where testSink :: Logger -> Sink -> IO () testSink "root" Sink{..} = do