log4hs 0.0.5.0 → 0.0.6.0
raw patch · 7 files changed
+294/−126 lines, 7 filesdep +criteriondep +generic-lensdep +lensdep ~aesondep ~containersPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: criterion, generic-lens, lens
Dependency ranges changed: aeson, containers
API changes (from Hackage documentation)
- Logging.Aeson: instance Data.Aeson.Types.FromJSON.FromJSON (Data.Map.Internal.Map GHC.Base.String Logging.Types.Formatter -> GHC.Types.IO Logging.Types.HandlerT)
- Logging.Aeson: instance Data.Aeson.Types.FromJSON.FromJSON (GHC.Base.String -> Data.Map.Internal.Map GHC.Base.String Logging.Types.HandlerT -> Logging.Types.Sink)
- Logging.Aeson: instance Data.Aeson.Types.FromJSON.FromJSON (GHC.Types.IO Logging.Types.HandlerT)
- Logging.Types: [$sel:name:Filter] :: Filter -> String
- Logging.Types: [$sel:nlen:Filter] :: Filter -> Int
- Logging.Types: [HandlerT] :: Handler a => a -> HandlerT
- Logging.Types: acquire :: Handler a => a -> IO ()
- Logging.Types: data Filter
- Logging.Types: data HandlerT
- Logging.Types: getFilterer :: Handler a => a -> Filterer
- Logging.Types: getFormatter :: Handler a => a -> Formatter
- Logging.Types: getLevel :: Handler a => a -> Level
- Logging.Types: instance Language.Haskell.TH.Syntax.Lift Logging.Types.Level
- Logging.Types: release :: Handler a => a -> IO ()
- Logging.Types: setFilterer :: Handler a => a -> Filterer -> a
- Logging.Types: setFormatter :: Handler a => a -> Formatter -> a
- Logging.Types: setLevel :: Handler a => a -> Level -> a
- Logging.Types: with :: Handler a => a -> (a -> IO b) -> IO b
+ Logging.Aeson: instance Data.Aeson.Types.FromJSON.FromJSON (Data.Map.Internal.Map GHC.Base.String Logging.Types.Formatter -> GHC.Types.IO Logging.Types.SomeHandler)
+ Logging.Aeson: instance Data.Aeson.Types.FromJSON.FromJSON (GHC.Base.String -> Data.Map.Internal.Map GHC.Base.String Logging.Types.SomeHandler -> Logging.Types.Sink)
+ Logging.Aeson: instance Data.Aeson.Types.FromJSON.FromJSON (GHC.Types.IO Logging.Types.SomeHandler)
+ Logging.Types: [SomeHandler] :: Handler h => h -> SomeHandler
+ Logging.Types: data SomeHandler
+ Logging.Types: fromHandler :: Handler a => SomeHandler -> Maybe a
+ Logging.Types: instance Data.Generics.Product.Typed.HasType Logging.Types.Filterer Logging.Types.SomeHandler
+ Logging.Types: instance Data.Generics.Product.Typed.HasType Logging.Types.Formatter Logging.Types.SomeHandler
+ Logging.Types: instance Data.Generics.Product.Typed.HasType Logging.Types.Level Logging.Types.SomeHandler
+ Logging.Types: instance Data.Generics.Product.Typed.HasType Logging.Types.Lock Logging.Types.SomeHandler
+ Logging.Types: instance GHC.Generics.Generic Logging.Types.StreamHandler
+ Logging.Types: instance GHC.Read.Read Logging.Types.Filter
+ Logging.Types: instance GHC.Show.Show Logging.Types.Filter
+ Logging.Types: instance Logging.Types.Handler Logging.Types.SomeHandler
+ Logging.Types: newtype Filter
+ Logging.Types: toHandler :: Handler a => a -> SomeHandler
- Logging.Types: Filter :: String -> Int -> Filter
+ Logging.Types: Filter :: Logger -> Filter
- Logging.Types: Sink :: Logger -> Level -> Filterer -> [HandlerT] -> Bool -> Bool -> Sink
+ Logging.Types: Sink :: Logger -> Level -> Filterer -> [SomeHandler] -> Bool -> Bool -> Sink
- Logging.Types: StreamHandler :: Handle -> Level -> Filterer -> Formatter -> MVar () -> StreamHandler
+ Logging.Types: StreamHandler :: Handle -> Level -> Filterer -> Formatter -> Lock -> StreamHandler
- Logging.Types: [$sel:handlers:Sink] :: Sink -> [HandlerT]
+ Logging.Types: [$sel:handlers:Sink] :: Sink -> [SomeHandler]
- Logging.Types: [$sel:lock:StreamHandler] :: StreamHandler -> MVar ()
+ Logging.Types: [$sel:lock:StreamHandler] :: StreamHandler -> Lock
- Logging.Types: class Handler a
+ Logging.Types: class (HasType Level a, HasType Filterer a, HasType Formatter a, HasType Lock a, Typeable a) => Handler a
Files
- bench/Main.hs +107/−0
- log4hs.cabal +34/−6
- src/Logging/Aeson.hs +21/−20
- src/Logging/Internal.hs +21/−18
- src/Logging/Types.hs +88/−62
- test/Logging/AesonSpec.hs +21/−18
- test/LoggingSpec.hs +2/−2
+ bench/Main.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++import Criterion.Main+import Data.Aeson+import Data.Aeson.QQ.Simple+import Data.Maybe+import Logging+import System.IO.Unsafe+++main :: IO ()+main = run manager $ defaultMain $+ [ bgroup "stderr" [ bench "simple" $ nfIO $ $(debug) "Stderr.Simple" msg100+ , bench "normal" $ nfIO $ $(info) "Stderr.Normal" msg100+ , bench "full" $ nfIO $ $(fatal) "Stderr.Full" msg100+ ]+ , bgroup "file" [ bench "simple" $ nfIO $ $(debug) "File.Simple" msg100+ , bench "normal" $ nfIO $ $(info) "File.Normal" msg100+ , bench "full" $ nfIO $ $(fatal) "File.Full" msg100+ ]+ ]+++msg100 :: String+msg100 = replicate 100 'W'+++manager :: Manager+{-# NOINLINE manager #-}+manager = unsafePerformIO $ fromJust $ decode $ encode $+ [aesonQQ|{+ "disabled": false,+ "catchUncaughtException": true,+ "loggers": {+ "Stderr.Simple": {+ "handlers": ["stderr.simple"],+ "propagate": false+ },+ "Stderr.Normal": {+ "handlers": ["stderr.normal"],+ "propagate": false+ },+ "Stderr.Full": {+ "handlers": ["stderr.full"],+ "propagate": false+ },+ "File.Simple": {+ "handlers": ["file.simple"],+ "propagate": false+ },+ "File.Normal": {+ "handlers": ["file.normal"],+ "propagate": false+ },+ "File.Full": {+ "handlers": ["file.full"],+ "propagate": false+ }+ },+ "handlers": {+ "stderr.simple": {+ "type": "StreamHandler",+ "stream": "stderr",+ "level": "DEBUG",+ "formatter": "simple"+ },+ "stderr.normal": {+ "type": "StreamHandler",+ "stream": "stderr",+ "level": "INFO",+ "formatter": "normal"+ },+ "stderr.full": {+ "type": "StreamHandler",+ "stream": "stderr",+ "level": "ERROR",+ "formatter": "full"+ },+ "file.simple": {+ "type": "FileHandler",+ "level": "DEBUG",+ "formatter": "simple",+ "file": "/tmp/log4hs/benchmark.simple.log"+ },+ "file.normal": {+ "type": "FileHandler",+ "level": "INFO",+ "formatter": "normal",+ "file": "/tmp/log4hs/benchmark.normal.log"+ },+ "file.full": {+ "type": "FileHandler",+ "level": "ERROR",+ "formatter": "full",+ "file": "/tmp/log4hs/benchmark.full.log"+ }+ },+ "formatters": {+ "simple": "%(message)s",+ "normal": "%(asctime)s - %(level)s - %(logger)s] %(message)s",+ "full": "%(asctime)s - %(level)s - %(logger)s - %(pathname)s/%(filename)s:%(lineno)d] %(message)s"+ }+ }|]+
log4hs.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 6da912ef94ad42318d7758fcdd3d5893c0f3d6c4863cc543e25dd6f91ba71bb2+-- hash: f2370e21e4ee599e5f39cb01456bcda6598b0a4ed115c1b69a0f94049635a3d5 name: log4hs-version: 0.0.5.0+version: 0.0.6.0 synopsis: A python logging style log library description: Please see the http://hackage.haskell.org/package/log4hs category: logging@@ -33,12 +33,14 @@ hs-source-dirs: src build-depends:- aeson >=0.8 && <1.5+ aeson >=1.2 && <1.5 , base >=4.7 && <5- , containers >=0.6 && <0.7+ , containers >=0.5 && <0.7 , data-default >=0.5 && <1.0 , directory >=1.2 && <1.4 , filepath >=1.3 && <1.5+ , generic-lens >=0.5 && <2.0+ , lens >=4.15 && <5.0 , template-haskell >=2.0 && <3.0 , text >=1.2 && <2.0 , time >=1.4 && <2.0@@ -57,16 +59,42 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck >=2.0 && <3.0- , aeson >=0.8 && <1.5+ , aeson >=1.2 && <1.5 , base >=4.7 && <5- , containers >=0.6 && <0.7+ , containers >=0.5 && <0.7 , data-default >=0.5 && <1.0 , directory >=1.2 && <1.4 , filepath >=1.3 && <1.5+ , generic-lens >=0.5 && <2.0 , hspec >=2.1 && <3.0 , hspec-core >=2.1 && <3.0+ , lens >=4.15 && <5.0 , log4hs , process >=1.2 && <2.0+ , template-haskell >=2.0 && <3.0+ , text >=1.2 && <2.0+ , time >=1.4 && <2.0+ default-language: Haskell2010++benchmark log4hs-bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Paths_log4hs+ hs-source-dirs:+ bench+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson >=1.2 && <1.5+ , base >=4.7 && <5+ , containers >=0.5 && <0.7+ , criterion >=1.0 && <2.0+ , data-default >=0.5 && <1.0+ , directory >=1.2 && <1.4+ , filepath >=1.3 && <1.5+ , generic-lens >=0.5 && <2.0+ , lens >=4.15 && <5.0+ , log4hs , template-haskell >=2.0 && <3.0 , text >=1.2 && <2.0 , time >=1.4 && <2.0
src/Logging/Aeson.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} module Logging.Aeson (@@ -10,14 +11,14 @@ -- $aesondoc ) where -import Control.Applicative (pure)+import Control.Applicative (pure) import Control.Concurrent.MVar+import Control.Lens (set) import Data.Aeson-import Data.Aeson.Types (Parser, typeMismatch)+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 Data.Generics.Product.Typed+import qualified Data.Map.Lazy as M import System.Directory import System.FilePath import System.IO@@ -45,7 +46,7 @@ \"handlers\": {\"console\": {}, \"file\": {}}, \"formatters\": {\"default\": {}, \"simple\": {}}, \"disabled\": false,- \"catchUncaughtException\": true,+ \"catchUncaughtException\": true } @ @@ -132,7 +133,7 @@ instance FromJSON Filter where- parseJSON v = (\s -> Filter s $ length s) <$> parseJSON v+ parseJSON v = Filter <$> parseJSON v instance FromJSON Formatter where@@ -155,7 +156,7 @@ parseStream _ = error "Logging.Aeson: no parse (stream)" -instance FromJSON (IO HandlerT) where+instance FromJSON (IO SomeHandler) where parseJSON = withObject "Handler" $ \v -> (v .: "type") >>= (`parseHandler` v) where openLogFile :: FilePath -> IO Handle@@ -166,24 +167,24 @@ hSetEncoding stream utf8 return stream - parseHandler :: String -> Object -> Parser (IO HandlerT)+ parseHandler :: String -> Object -> Parser (IO SomeHandler) parseHandler "StreamHandler" v = do hdl <- parseJSON (Object v)- return $ HandlerT <$> (hdl :: IO StreamHandler)+ return $ toHandler <$> (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'+ return $ toHandler <$> hdl' parseHandler t _ = error $ "Logging.Aeson: no parse (Handler" ++ t ++")" -instance FromJSON (Map String Formatter -> IO HandlerT) where+instance FromJSON (M.Map String Formatter -> IO SomeHandler) 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)+ return $ \fs -> hdlio >>= \hdl -> return $+ set (typed @Formatter) (M.findWithDefault def key fs) hdl instance FromJSON (Sink) where@@ -196,23 +197,23 @@ <*> v .:? "propagate" .!= False -instance FromJSON (String -> Map String HandlerT -> Sink) where+instance FromJSON (String -> M.Map String SomeHandler -> 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]+ , handlers = [hs M.! k | k <- keys] } -type Formatters = Map String Formatter-type HandlerTsMakerIO = Map String (Formatters -> IO HandlerT)-type SinksMaker = Map String (String -> Map String HandlerT -> Sink)+type Formatters = M.Map String Formatter+type HandlersMakerIO = M.Map String (Formatters -> IO SomeHandler)+type SinksMaker = M.Map String (String -> M.Map String SomeHandler -> Sink) instance FromJSON (IO Manager) where parseJSON = withObject "Manager" $ \v -> do fmts :: Formatters <- v .:? "formatters" .!= (object []) >>= parseJSON- hdls :: HandlerTsMakerIO <- v .:? "handlers" .!= (object []) >>= parseJSON+ hdls :: HandlersMakerIO <- v .:? "handlers" .!= (object []) >>= parseJSON sinks :: SinksMaker <- v .:? "loggers" .!= (object []) >>= parseJSON disabled <- v .:? "disabled" .!= False
src/Logging/Internal.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} module Logging.Internal ( run@@ -12,19 +13,21 @@ ) where import Control.Concurrent.MVar-import Control.Exception (SomeException, bracket_)-import Control.Monad (forM_, void, when)-import Control.Monad.IO.Class (MonadIO (..))+import Control.Exception (SomeException, bracket_)+import Control.Lens (view)+import Control.Monad (forM_, void, when)+import Control.Monad.IO.Class (MonadIO (..)) import Data.Default+import Data.Generics.Product.Typed import Data.IORef-import Data.List (dropWhileEnd)-import Data.Map.Lazy ((!?))+import Data.List (dropWhileEnd)+import Data.Map.Lazy ((!?)) import Data.Time.Clock import Data.Time.LocalTime-import GHC.Conc (setUncaughtExceptionHandler)-import Prelude hiding (filter, log)-import System.IO (Handle, stderr, stdout)-import System.IO.Unsafe (unsafePerformIO)+import GHC.Conc (setUncaughtExceptionHandler)+import Prelude hiding (filter, log)+import System.IO (Handle, stderr, stdout)+import System.IO.Unsafe (unsafePerformIO) import Logging.Types @@ -58,7 +61,7 @@ shutdown = closeHandlers root >> forM_ sinks closeHandlers closeHandlers :: Sink -> IO ()- closeHandlers Sink{..} = forM_ handlers $ \(HandlerT hdl) -> close hdl+ closeHandlers Sink{..} = forM_ handlers close -- |Low-level logging routine which creates a LogRecord and then calls@@ -92,9 +95,9 @@ | logger `elem` ["", rootLogger] = Just root | otherwise = sinks !? logger - callHandlers :: [HandlerT] -> LogRecord -> IO ()- callHandlers handlers rcd = forM_ handlers $ \hdlt@(HandlerT hdl) ->- when (isHandlerEnableFor hdlt rcd) $ void $ Logging.Types.handle hdl rcd+ callHandlers :: [SomeHandler] -> LogRecord -> IO ()+ callHandlers handlers rcd = forM_ handlers $ \hdl ->+ when (isHandlerEnableFor hdl rcd) $ void $ Logging.Types.handle hdl rcd isSinkEnabledFor :: Sink -> LogRecord -> Bool isSinkEnabledFor sink@Sink{..} rcd@LogRecord{level=level'}@@ -102,10 +105,10 @@ | level' < level = False | otherwise = filter sink rcd - isHandlerEnableFor :: HandlerT -> LogRecord -> Bool- isHandlerEnableFor (HandlerT hdl) rcd@LogRecord{level=level'}- | level' < getLevel hdl = False- | otherwise = filter (getFilterer hdl) rcd+ isHandlerEnableFor :: SomeHandler -> LogRecord -> Bool+ isHandlerEnableFor hdl rcd@LogRecord{level=level'}+ | level' < (view (typed @Level) hdl) = False+ | otherwise = filter (view (typed @Filterer) hdl) rcd -- |A ultility function for creating 'StreamHandler'@@ -128,4 +131,4 @@ -- -- You can use it when you make 'Manager' manually. defaultRoot :: Sink-defaultRoot = Sink "" "DEBUG" [] [HandlerT stderrHandler] False False+defaultRoot = Sink "" "DEBUG" [] [toHandler stderrHandler] False False
src/Logging/Types.hs view
@@ -1,10 +1,13 @@-{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-} module Logging.Types ( Logger(..)@@ -13,8 +16,8 @@ , Filter(..) , Filterer , Formatter(..)+ , SomeHandler(..) , StreamHandler(..)- , HandlerT(..) , Sink(..) , Manager(..) , Filterable(..)@@ -22,21 +25,24 @@ , Handler(..) ) where -import Control.Concurrent.MVar (MVar, putMVar, takeMVar)-import Control.Exception (bracket)-import Control.Monad (unless, when)+import Control.Concurrent.MVar (MVar, putMVar, takeMVar)+import Control.Exception (bracket)+import Control.Lens (set, view)+import Control.Monad (unless, when) import Data.Default-import Data.List (stripPrefix)-import Data.Map.Lazy (Map)+import Data.Generics.Product.Typed+import Data.List (stripPrefix)+import Data.Map.Lazy (Map) import Data.String import Data.Time.Clock-import qualified Data.Time.Format as TF+import qualified Data.Time.Format as TF import Data.Time.LocalTime-import Language.Haskell.TH.Syntax (Lift)-import Prelude hiding (filter)+import Data.Typeable+import GHC.Generics+import Prelude hiding (filter) import System.FilePath import System.IO-import Text.Printf (printf)+import Text.Printf (printf) -- |'Logger' is just a name. type Logger = String@@ -58,7 +64,7 @@ -- >>> "DEBUG" == (Level 10) -- True ---newtype Level = Level Int deriving (Lift, Eq, Ord)+newtype Level = Level Int deriving (Eq, Ord) instance Show Level where show (Level 0) = "NOTSET"@@ -118,15 +124,10 @@ -- events logged by loggers "A.B", "A.B.C", "A.B.C.D", "A.B.D" etc. -- but not "A.BB", "B.A.B" etc. -- If initialized name with the empty string, all events are passed.-data Filter = Filter { name :: String- , nlen :: Int- }+newtype Filter = Filter Logger deriving (Read, Show, Eq) instance IsString Filter where- fromString s = Filter s $ length s--instance Eq Filter where- (==) f s = (==) (name f) (name s)+ fromString = Filter -- |List of Filter@@ -170,6 +171,31 @@ def = Formatter "%(message)s" "%Y-%m-%dT%H:%M:%S%6Q%z" +type Lock = MVar ()+++-- |The 'SomeHandler' type is the root of the handler type hierarchy.+-- It hold the real 'Handler' instance+data SomeHandler where+ SomeHandler :: Handler h => h -> SomeHandler++instance {-# OVERLAPPING #-} HasType Level SomeHandler where+ getTyped (SomeHandler h) = view (typed @Level) h+ setTyped v (SomeHandler h) = SomeHandler $ set (typed @Level) v h++instance {-# OVERLAPPING #-} HasType Filterer SomeHandler where+ getTyped (SomeHandler h) = view (typed @Filterer) h+ setTyped v (SomeHandler h) = SomeHandler $ set (typed @Filterer) v h++instance {-# OVERLAPPING #-} HasType Formatter SomeHandler where+ getTyped (SomeHandler h) = view (typed @Formatter) h+ setTyped v (SomeHandler h) = SomeHandler $ set (typed @Formatter) v h++instance {-# OVERLAPPING #-} HasType Lock SomeHandler where+ getTyped (SomeHandler h) = view (typed @Lock) h+ setTyped v (SomeHandler h) = SomeHandler $ set (typed @Lock) v h++ -- | A handler type which writes logging records, appropriately formatted, -- to a stream. --@@ -181,13 +207,8 @@ , level :: Level , filterer :: Filterer , formatter :: Formatter- , lock :: MVar ()- }----- |A GADT represents any 'Handler' instance-data HandlerT where- HandlerT :: Handler a => a -> HandlerT+ , lock :: Lock+ } deriving (Generic) -- |'Sink' represents a single logging channel.@@ -209,7 +230,7 @@ data Sink = Sink { logger :: Logger , level :: Level , filterer :: Filterer- , handlers :: [HandlerT]+ , handlers :: [SomeHandler] , disabled :: Bool , propagate :: Bool -- ^ It will pop up until root or the -- ancestor's propagation is disabled@@ -234,11 +255,11 @@ filter (f:fs) rcd = (filter f) rcd && (filter fs rcd) instance Filterable Filter where- filter f rcd@LogRecord{..}- | (nlen f) == 0 = True- | otherwise = case stripPrefix (name f) logger of- Just "" -> True -- filter name == record logger- Just ('.':_) -> True -- filter name is record logger's child+ filter (Filter self) rcd@LogRecord{..}+ | self == "" = True+ | otherwise = case stripPrefix self logger of+ Just "" -> True -- self == logger+ Just ('.':_) -> True -- self == parent logger _ -> False instance Filterable Sink where@@ -289,50 +310,55 @@ -- |A type class that abstracts the characteristics of a 'Handler'-class Handler a where- getLevel :: a -> Level- setLevel :: a -> Level -> a-- getFilterer :: a -> Filterer- setFilterer :: a -> Filterer -> a-- getFormatter :: a -> Formatter- setFormatter :: a -> Formatter -> a-- acquire :: a -> IO ()- release :: a -> IO ()-- with :: a -> (a -> IO b) -> IO b- with l io = bracket (acquire l) (\_ -> release l) (\_ -> io l)-+class ( HasType Level a+ , HasType Filterer a+ , HasType Formatter a+ , HasType Lock a+ , Typeable a+ ) => Handler a where emit :: a -> LogRecord -> IO ()+ flush :: a -> IO ()+ flush _ = return ()+ close :: a -> IO ()+ close _ = return () handle :: a -> LogRecord -> IO Bool handle hdl rcd = do- let rv = filter (getFilterer hdl) rcd- when rv $ with hdl (`emit` rcd)- return rv+ let rv = filter (view (typed @Filterer) hdl) rcd+ when rv $ with hdl (`emit` rcd)+ return rv+ where+ acquire :: a -> IO ()+ acquire = takeMVar . (view $ typed @Lock) -instance Handler StreamHandler where- getLevel = level- setLevel h v = h { level = v }+ release :: a -> IO ()+ release = (`putMVar` ()) . (view $ typed @Lock) - getFilterer = filterer- setFilterer h f = h { filterer = f }+ with :: a -> (a -> IO b) -> IO b+ with l io = bracket (acquire l) (\_ -> release l) (\_ -> io l) - getFormatter = formatter- setFormatter h f = h { formatter = f }+ fromHandler :: SomeHandler -> Maybe a+ fromHandler (SomeHandler h) = cast h - acquire = takeMVar . lock- release = (`putMVar` ()) . lock+ toHandler :: a -> SomeHandler+ toHandler = SomeHandler +instance Handler SomeHandler where+ emit (SomeHandler h) = emit h+ flush (SomeHandler h) = flush h+ close (SomeHandler h) = close h+ fromHandler = Just . id+ toHandler = id++instance Handler StreamHandler where emit hdl rcd = do- hPutStrLn (stream hdl) $ format (getFormatter hdl) rcd+ hPutStrLn (stream hdl) $ format (view (typed @Formatter) hdl) rcd flush hdl flush = hFlush . stream+ close StreamHandler{..} = do isClosed <- hIsClosed stream unless isClosed $ hIsTerminalDevice stream >>= (`unless` (hClose stream))
test/Logging/AesonSpec.hs view
@@ -2,16 +2,19 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} module Logging.AesonSpec ( spec ) where +import Control.Lens (view) import Control.Monad import Data.Aeson-import Data.Aeson.QQ.Simple (aesonQQ)-import Data.Default (def)-import Data.List (intercalate)-import qualified Data.Map as M-import Data.Maybe (fromJust)+import Data.Aeson.QQ.Simple (aesonQQ)+import Data.Default (def)+import Data.Generics.Product.Typed+import Data.List (intercalate)+import qualified Data.Map as M+import Data.Maybe (fromJust) import System.IO import System.IO.Unsafe import Test.Hspec@@ -33,8 +36,8 @@ filterSpec :: Spec filterSpec = describe "Filter" $ modifyMaxSize (const 1000) $ do prop "decode" $ \fs ->- let name = intercalate "." fs- in (decode $ encode name) == Just (Filter name $ length name)+ let logger = intercalate "." fs+ in (decode $ encode logger) == Just (Filter logger) formatterSpec :: Spec@@ -74,10 +77,10 @@ stream == stdout `shouldBe` True level == "DEBUG" `shouldBe` True- filterer == [Filter "Module.Submodule" 16] `shouldBe` True+ filterer == [Filter "Module.Submodule"] `shouldBe` True formatter == def {fmt = "default"} `shouldBe` True - it "decode (formatters -> HandlerT)" $ do+ it "decode (formatters -> SomeHandler)" $ do let simple = def {fmt = "%(logger)s: %(message)s"} func = fromJust $ decode $ encode [aesonQQ|@@ -89,10 +92,10 @@ } |] - (HandlerT handler) <- func $ M.singleton ("simple" :: String) simple- getLevel handler == "DEBUG" `shouldBe` True- getFilterer handler == [Filter "Module.Submodule" 16] `shouldBe` True- getFormatter handler == simple `shouldBe` True+ handler@(SomeHandler _) <- func $ M.singleton ("simple" :: String) simple+ view (typed @Level) handler == "DEBUG" `shouldBe` True+ view (typed @Filterer) handler == ["Module.Submodule"] `shouldBe` True+ view (typed @Formatter) handler == simple `shouldBe` True sinkSpec :: Spec@@ -111,14 +114,14 @@ logger `shouldBe` "placeholder" level `shouldBe` "DEBUG"- filterer == [Filter "Module.Submodule" 16] `shouldBe` True+ filterer == ["Module.Submodule"] `shouldBe` True length handlers `shouldBe` 0 disabled `shouldBe` False propagate `shouldBe` True it "decode (logger -> handlers -> sink)" $ do- let handlerMap = M.fromList [ ("console", HandlerT stderrHandler)- , ("file" :: String, HandlerT stderrHandler)+ let handlerMap = M.fromList [ ("console", toHandler stderrHandler)+ , ("file" :: String, toHandler stderrHandler) ] func = fromJust $ decode $ encode $ [aesonQQ|@@ -132,7 +135,7 @@ logger `shouldBe` "MyLogger" level `shouldBe` "INFO"- filterer == [Filter "Module.Submodule" 16] `shouldBe` True+ filterer == ["Module.Submodule"] `shouldBe` True length handlers `shouldBe` 2 -- deep test handlers disabled `shouldBe` False propagate `shouldBe` False@@ -166,7 +169,7 @@ propagate `shouldBe` False disabled `shouldBe` False length filterer `shouldBe` 1- filterer == [Filter "MyLogger.Main" 13] `shouldBe` True+ filterer == ["MyLogger.Main"] `shouldBe` True length handlers `shouldBe` 2
test/LoggingSpec.hs view
@@ -143,13 +143,13 @@ ] -createPipeHandler :: Level -> Filterer -> Formatter -> IO (HandlerT, Handle)+createPipeHandler :: Level -> Filterer -> Formatter -> IO (SomeHandler, Handle) createPipeHandler level filterer formatter = do lock <- newMVar () (read, write) <- createPipe hSetEncoding read utf8 hSetEncoding write utf8- return $ ( HandlerT $ StreamHandler write level filterer formatter lock+ return $ ( toHandler $ StreamHandler write level filterer formatter lock , read )