log4hs 0.0.2.0 → 0.0.3.0

raw patch · 10 files changed

+283/−207 lines, 10 filesdep −unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies removed: unordered-containers

API changes (from Hackage documentation)

Files

• ChangeLog.md +1/−1
• log4hs.cabal +5/−6
• src/Data/Aeson/Extra.hs +0/−32
• src/Logging.hs +23/−55
• src/Logging/Aeson.hs +197/−0
• src/Logging/Deprecated.hs +38/−0
• src/Logging/Internal.hs +4/−104
• src/Logging/TH.hs +2/−1
• src/Logging/Types.hs +1/−0
• test/Spec.hs +12/−8

@@ -1,3 +1,3 @@-# Changelog for logging+# Changelog for log4hs  ## Unreleased changes

@@ -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

@@ -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

@@ -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 (..))

@@ -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

@@ -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

@@ -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

@@ -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". --

@@ -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

@@ -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