yet-another-logger (empty) → 0.0.1
raw patch · 13 files changed
+1889/−0 lines, 13 filesdep +aesondep +ansi-terminaldep +asyncsetup-changed
Dependencies added: aeson, ansi-terminal, async, base, base-unicode-symbols, bytestring, case-insensitive, configuration-tools, deepseq, either, enclosed-exceptions, lens, lifted-base, monad-control, mtl, optparse-applicative, stm, stm-chans, text, trace, transformers, transformers-base
Files
- CHANGELOG.md +5/−0
- LICENSE +11/−0
- README.md +108/−0
- Setup.hs +2/−0
- constraints +117/−0
- src/System/Logger.hs +165/−0
- src/System/Logger/Backend/ColorOption.hs +120/−0
- src/System/Logger/Backend/Handle.hs +251/−0
- src/System/Logger/Internal.hs +55/−0
- src/System/Logger/Logger.hs +81/−0
- src/System/Logger/Logger/Internal.hs +420/−0
- src/System/Logger/Types.hs +438/−0
- yet-another-logger.cabal +116/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+0.0.1+=====++First public release+
+ LICENSE view
@@ -0,0 +1,11 @@+Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.
+ README.md view
@@ -0,0 +1,108 @@+[](https://travis-ci.org/alephcloud/hs-yet-another-logger)++A logging framework written with flexibility and performance in mind.++Quick Start+===========++```haskell+import System.Logger++main ∷ IO ()+main = withConsoleLogger Info $ do+ logg Info "moin"+ withLabel ("function", "f") f+ logg Warn "tschüss"+ where+ f = withLevel Debug $ do+ logg Debug "debug f"+```++Overview+========++**This Version is yet a preview**++The logging system consists of four main parts:++1. The logging front-end are those types and functions that are used+ to produce log messages in the code. This includes the `LogLevel`+ type, the `LogPolicy` type, the `LogLabel` and `LogScope` types,+ the `LogFunction` type, and the `MonadLog` type class.++2. The abstract `LoggerCtx` is the context through which the `LogFunction`+ delivers log messages to the logger back-end.++3. The formatter is a function for serializing log messages.++4. The logger back-end is a callback that is invoked by `Logger` on+ each log messages. The logger back-end applies the formatting function+ and delivers the log messages to some sink.++The framework allows you to combine this components in a modular way. The+front-end types, the `Logger`, and the back-end callback are represented by+types or type classes. The formatter exists only as a concept in the+implementation of back-ends. These types and concepts together form the+abstract logger interface that is defined in the module `System.Logger.Types`.++The package also provides a concrete Logger that implements these components+in the module `System.Logger.Logger` and `System.Logger.Backend.Handle`.++Logger Implementation+=====================++Writing a log message in a service application should introduce only minimal+latency overhead in the thread where the log message is written. Processing+should be done asynchronously as much as possible. This framework addresses+this by doing all serialization and IO in an asynchronous logger back-end+callback.++When a log message is produced it is associated with a logger context. The+logger context includes++* a log-level threshold,+* a scope, which is a list of key-value labels which are used to+ tag log messages with additional information, and+* a policy that specifies how to deal with a situation where the+ log message pipeline is congested.++A log message can be any Haskell type with `Show`, `Typeable`, and `NFData`+constraint. Ideally the logged value is computed anyways in the program so that+constructing and forcing it does not introduce any additional overhead.++When a log messages is produced it is tagged with a time stamp. This introduces+overhead and there is be room for optimizations here. A log message also has a+log-level. If the log-threshold that is effective at the time a log message is+written isn't met, no message is produced.++The logger has an internal log message queue. Further benchmarking should be+done in chosen the queue implementation that is best suited for this purpose.++The logger asynchronously reads log messages from the queue and calls the+back-end callback for each message. Right now the code includes only a single+back-end, namely for writing to a handle, but we are going to add more+back-ends soon. Due to the modular design, it is possible to combine different+back-ends into a single back-end so that messages are processed by more than a+single back-end and delivered to more than a single sink.++A back-end includes a formatting function. This is where, beside IO, most+processing happens.++Delaying the serialization to the very end of the processing pipeline has+the following advantages:++1. serialization is done asynchronously,+2. serialization is done only for messages that are actually delivered and+ it is done only for those parts of the message that are relevant for the+ respective back-end, and+3. it is easy to deploy different serialization methods.++For instance, when logging to the console, one usually wants a line-wise+UNIX-tool friendly format. For a cloud service one may chose an efficient+binary serialization with a back-end that stores messages in a remote database.+There may be circumstances where the data of all or some messages is just+aggregated for statistical analysis before the messages are discarded. The+modular design, which decouples generation and serialization of log messages,+allows one to accommodate these different scenarios by just using different+back-ends, possibly parameterized by the formatting function.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ constraints view
@@ -0,0 +1,117 @@+constraints: Cabal ==1.22.0.0,+ MonadRandom ==0.3,+ adjunctions ==4.2,+ aeson ==0.8.0.2,+ ansi-terminal ==0.6.2.1,+ ansi-wl-pprint ==0.6.7.1,+ array ==0.5.0.0,+ asn1-encoding ==0.9.0,+ asn1-parse ==0.9.0,+ asn1-types ==0.3.0,+ async ==2.0.1.6,+ attoparsec ==0.12.1.2,+ base ==4.7.0.1,+ base-unicode-symbols ==0.2.2.4,+ base64-bytestring ==1.0.0.1,+ bifunctors ==4.1.1.1,+ binary ==0.7.1.0,+ blaze-builder ==0.3.3.4,+ byteable ==0.1.1,+ bytestring ==0.10.4.0,+ case-insensitive ==1.2.0.3,+ cereal ==0.4.0.1,+ cipher-aes ==0.2.8,+ cipher-des ==0.0.6,+ cipher-rc4 ==0.1.4,+ comonad ==4.2.2,+ conduit ==1.2.3.1,+ configuration-tools ==0.2.10,+ connection ==0.2.4,+ containers ==0.5.5.1,+ contravariant ==1.2.0.1,+ cookie ==0.4.1.4,+ crypto-cipher-types ==0.0.9,+ crypto-numbers ==0.2.3,+ crypto-pubkey ==0.2.8,+ crypto-pubkey-types ==0.4.3,+ crypto-random ==0.0.7,+ cryptohash ==0.11.6,+ data-default ==0.5.3,+ data-default-class ==0.0.1,+ data-default-instances-base ==0.0.1,+ data-default-instances-containers ==0.0.1,+ data-default-instances-dlist ==0.0.1,+ data-default-instances-old-locale ==0.0.1,+ deepseq ==1.3.0.2,+ directory ==1.2.1.0,+ distributive ==0.4.4,+ dlist ==0.7.1,+ either ==4.3.2.1,+ enclosed-exceptions ==1.0.1,+ errors ==1.4.7,+ exceptions ==0.6.1,+ filepath ==1.3.0.2,+ free ==4.10.0.1,+ ghc-prim ==0.3.1.0,+ hashable ==1.2.3.1,+ hourglass ==0.2.8,+ http-client ==0.4.7,+ http-client-tls ==0.2.2,+ http-types ==0.8.5,+ integer-gmp ==0.5.1.0,+ kan-extensions ==4.2,+ lens ==4.7,+ lifted-base ==0.2.3.3,+ mime-types ==0.1.0.5,+ mmorph ==1.0.4,+ monad-control ==1.0.0.1,+ mtl ==2.2.1,+ nats ==1,+ network ==2.6.0.2,+ network-uri ==2.6.0.1,+ old-locale ==1.0.0.6,+ optparse-applicative ==0.11.0.1,+ parallel ==3.2.0.4,+ parsec ==3.1.7,+ pem ==0.2.2,+ prelude-extras ==0.4,+ pretty ==1.1.1.1,+ primitive ==0.5.3.0,+ process ==1.2.0.0,+ profunctors ==4.3.2,+ publicsuffixlist ==0.1,+ random ==1.0.1.1,+ reflection ==1.4,+ resourcet ==1.1.3.3,+ rts ==1.0,+ safe ==0.3.6,+ scientific ==0.3.3.5,+ securemem ==0.1.3,+ semigroupoids ==4.2,+ semigroups ==0.16.0.1,+ socks ==0.5.4,+ split ==0.2.2,+ stm ==2.4.3,+ stm-chans ==3.0.0.2,+ streaming-commons ==0.1.8,+ syb ==0.4.2,+ tagged ==0.7.2,+ template-haskell ==2.9.0.0,+ text ==1.2.0.3,+ time ==1.4.2,+ tls ==1.2.16,+ trace ==0.1.0.4,+ transformers ==0.4.1.0,+ transformers-base ==0.4.3,+ transformers-compat ==0.3.3.4,+ unix ==2.7.0.1,+ unordered-containers ==0.2.5.1,+ utf8-string ==0.3.8,+ vector ==0.10.11.0,+ void ==0.7,+ x509 ==1.5.0.1,+ x509-store ==1.5.0,+ x509-system ==1.5.0,+ x509-validation ==1.5.1,+ yaml ==0.8.10.1,+ zlib ==0.5.4.1
+ src/System/Logger.hs view
@@ -0,0 +1,165 @@+-- Copyright (c) 2014-2015 PivotCloud, Inc.+--+-- System.Logger+--+-- Please feel free to contact us at licensing@pivotmail.com with any+-- contributions, additions, or other feedback; we would love to hear from+-- you.+--+-- Licensed under the Apache License, Version 2.0 (the "License"); you may+-- not use this file except in compliance with the License. You may obtain a+-- copy of the License at http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT+-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the+-- License for the specific language governing permissions and limitations+-- under the License.++-- |+-- Module: System.Logger+-- Description: Yet Another Logger+-- Copyright: Copyright © 2015 PivotCloud, Inc.+-- License: Apache-2.0+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- This module re-exports the logger interface from "System.Logger.Types" and+-- the implementation of that interface from "System.Logger.Logger" and+-- "System.Logger.Backend.Handle".+--++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++module System.Logger+( withConsoleLogger+, withFileLogger++-- * Logger Interface+, module System.Logger.Types++-- * Yet Another Logger+, module System.Logger.Logger++-- * Handle Backend+, module System.Logger.Backend.Handle++-- * Logging System Configuration+, LogConfig(..)+, logConfigLogger+, logConfigBackend+, defaultLogConfig+, validateLogConfig+, pLogConfig+) where++import Configuration.Utils hiding (Lens')++import Control.Lens hiding ((.=))+import Control.Monad.IO.Class+import Control.Monad.Trans.Control++import qualified Data.Text as T+import Data.Typeable++import GHC.Generics++import Prelude.Unicode++import System.Logger.Backend.ColorOption+import System.Logger.Backend.Handle+import System.Logger.Logger+import System.Logger.Types++-- | A simple console logger+--+-- > import System.Logger+-- >+-- > main ∷ IO ()+-- > main = withConsoleLogger Info $ do+-- > logg Info "moin"+-- > withLabel ("function", "f") f+-- > logg Warn "tschüss"+-- > where+-- > f = withLevel Debug $ do+-- > logg Debug "debug f"+--+withConsoleLogger+ ∷ (MonadIO m, MonadBaseControl IO m)+ ⇒ LogLevel+ → LoggerT T.Text m α+ → m α+withConsoleLogger level inner =+ withHandleBackend (config ^. logConfigBackend) $ \backend →+ withLogger (config ^. logConfigLogger) backend $ runLoggerT inner+ where+ config = defaultLogConfig+ & logConfigLogger ∘ loggerConfigThreshold .~ level++-- | A simple file logger+--+withFileLogger+ ∷ (MonadIO m, MonadBaseControl IO m)+ ⇒ FilePath+ → LogLevel+ → LoggerT T.Text m α+ → m α+withFileLogger f level inner =+ withHandleBackend (config ^. logConfigBackend) $ \backend →+ withLogger (config ^. logConfigLogger) backend $ runLoggerT inner+ where+ config = defaultLogConfig+ & logConfigLogger ∘ loggerConfigThreshold .~ level+ & logConfigBackend ∘ handleBackendConfigColor .~ ColorFalse+ & logConfigBackend ∘ handleBackendConfigHandle .~ FileHandle f++-- -------------------------------------------------------------------------- --+-- Logging System Configuration++data LogConfig = LogConfig+ { _logConfigLogger ∷ !LoggerConfig+ , _logConfigBackend ∷ !HandleBackendConfig+ }+ deriving (Show, Read, Eq, Ord, Typeable, Generic)++logConfigLogger ∷ Lens' LogConfig LoggerConfig+logConfigLogger = lens _logConfigLogger $ \a b → a { _logConfigLogger = b }++logConfigBackend ∷ Lens' LogConfig HandleBackendConfig+logConfigBackend = lens _logConfigBackend $ \a b → a { _logConfigBackend = b }++defaultLogConfig ∷ LogConfig+defaultLogConfig = LogConfig+ { _logConfigLogger = defaultLoggerConfig+ , _logConfigBackend = defaultHandleBackendConfig+ }++validateLogConfig ∷ ConfigValidation LogConfig []+validateLogConfig LogConfig{..} = do+ validateLoggerConfig _logConfigLogger+ validateHandleBackendConfig _logConfigBackend++instance ToJSON LogConfig where+ toJSON LogConfig{..} = object+ [ "logger" .= _logConfigLogger+ , "backend" .= _logConfigBackend+ ]++instance FromJSON (LogConfig → LogConfig) where+ parseJSON = withObject "LogConfig" $ \o → id+ <$< logConfigLogger %.: "logger" × o+ <*< logConfigBackend %.: "backend" × o++pLogConfig ∷ MParser LogConfig+pLogConfig = id+ <$< logConfigLogger %:: pLoggerConfig+ <*< logConfigBackend %:: pHandleBackendConfig+
+ src/System/Logger/Backend/ColorOption.hs view
@@ -0,0 +1,120 @@+-- Copyright (c) 2014-2015 PivotCloud, Inc.+--+-- System.Logger.Backend.ColorOption+--+-- Please feel free to contact us at licensing@pivotmail.com with any+-- contributions, additions, or other feedback; we would love to hear from+-- you.+--+-- Licensed under the Apache License, Version 2.0 (the "License"); you may+-- not use this file except in compliance with the License. You may obtain a+-- copy of the License at http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT+-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the+-- License for the specific language governing permissions and limitations+-- under the License.++-- |+-- Module: System.Logger.Backend.ColorOption+-- Copyright: Copyright (c) 2014-2015 PivotCloud, Inc.+-- License: Apache License, Version 2.0+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- An option that indicates whether ANSI color escapes shall+-- be used in textual output.++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++module System.Logger.Backend.ColorOption+( ColorOption(..)+, readColorOption+, colorOptionText+, defaultColorOption+, pColorOption+, useColor+) where++import Configuration.Utils++import Control.DeepSeq+import Control.Monad.Except++import qualified Data.CaseInsensitive as CI+import Data.Monoid+import Data.Monoid.Unicode+import Data.String+import Data.Typeable++import GHC.Generics++import qualified Options.Applicative as O++import Prelude.Unicode++import qualified System.Console.ANSI as A+import System.IO (Handle)++-- -------------------------------------------------------------------------- --+-- Color Option++-- | Color Option+--+data ColorOption+ = ColorAuto+ | ColorFalse+ | ColorTrue+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic)++instance NFData ColorOption++readColorOption+ ∷ (Monad m, Eq a, Show a, CI.FoldCase a, IsString a, IsString e, Monoid e, MonadError e m)+ ⇒ a+ → m ColorOption+readColorOption x = case CI.mk x of+ "auto" → return ColorAuto+ "false" → return ColorFalse+ "true" → return ColorTrue+ e → throwError $ "unexpected color option value: "+ ⊕ fromString (show e)+ ⊕ ", expected \"auto\", \"false\", or \"true\""++colorOptionText+ ∷ IsString a+ ⇒ ColorOption+ → a+colorOptionText ColorAuto = "auto"+colorOptionText ColorFalse = "false"+colorOptionText ColorTrue = "true"++defaultColorOption ∷ ColorOption+defaultColorOption = ColorAuto++instance ToJSON ColorOption where+ toJSON = String ∘ colorOptionText++instance FromJSON ColorOption where+ parseJSON = withText "ColorOption" $ either fail return ∘ readColorOption++pColorOption ∷ O.Parser ColorOption+pColorOption = option (eitherReader readColorOption)+ × long "color"+ ⊕ short 'c'+ ⊕ help "whether to use ANSI terminal colors in the output"++useColor+ ∷ ColorOption+ → Handle+ → IO Bool+useColor ColorFalse _ = return False+useColor ColorTrue _ = return True+useColor ColorAuto handle = A.hSupportsANSI handle+
+ src/System/Logger/Backend/Handle.hs view
@@ -0,0 +1,251 @@+-- Copyright (c) 2014-2015 PivotCloud, Inc.+--+-- System.Logger.Backend.Handle+--+-- Please feel free to contact us at licensing@pivotmail.com with any+-- contributions, additions, or other feedback; we would love to hear from+-- you.+--+-- Licensed under the Apache License, Version 2.0 (the "License"); you may+-- not use this file except in compliance with the License. You may obtain a+-- copy of the License at http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT+-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the+-- License for the specific language governing permissions and limitations+-- under the License.++-- |+-- Module: System.Logger.Backend.Handle+-- Description: Handle Backend for Yet Another Logger+-- Copyright: Copyright (c) 2014-2015 PivotCloud, Inc.+-- License: Apache License, Version 2.0+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++module System.Logger.Backend.Handle+(+-- * Handle Configuration+ LoggerHandleConfig(..)+, loggerHandleConfigText+, readLoggerHandleConfig+, validateLoggerHandleConfig+, pLoggerHandleConfig++-- * Backend Configuration+, HandleBackendConfig(..)+, handleBackendConfigHandle+, handleBackendConfigColor+, defaultHandleBackendConfig+, validateHandleBackendConfig+, pHandleBackendConfig++-- * Backend Implementation+, withHandleBackend+, handleBackend+) where++import Configuration.Utils hiding (Lens', Error)+import Configuration.Utils.Validation++import Control.DeepSeq+import Control.Lens hiding ((.=))+import Control.Monad.Except+import Control.Monad.Trans.Control+import Control.Monad.Writer++import qualified Data.CaseInsensitive as CI+import qualified Data.List as L+import Data.Monoid.Unicode+import Data.String+import qualified Data.Text as T+import Data.Text.Lens+import qualified Data.Text.IO as T+import Data.Typeable++import GHC.Generics++import qualified Options.Applicative as O++import Prelude.Unicode++import qualified System.Console.ANSI as A+import System.IO++-- internal modules++import System.Logger.Backend.ColorOption+import System.Logger.Internal+import System.Logger.Types++-- -------------------------------------------------------------------------- --+-- Handle Logger Backend Configuration++data LoggerHandleConfig+ = StdOut+ | StdErr+ | FileHandle FilePath+ deriving (Show, Read, Eq, Ord, Typeable, Generic)++instance NFData LoggerHandleConfig++readLoggerHandleConfig+ ∷ (MonadError e m, Eq a, Show a, CI.FoldCase a, IsText a, IsString e, Monoid e)+ ⇒ a+ → m LoggerHandleConfig+readLoggerHandleConfig x = case CI.mk tx of+ "stdout" → return StdOut+ "stderr" → return StdErr+ _ | CI.mk (L.take 5 tx) ≡ "file:" → return $ FileHandle (L.drop 5 tx)+ e → throwError $ "unexpected logger handle value: "+ ⊕ fromString (show e)+ ⊕ ", expected \"stdout\", \"stderr\", or \"file:<FILENAME>\""+ where+ tx = packed # x++loggerHandleConfigText+ ∷ (IsString a, Monoid a)+ ⇒ LoggerHandleConfig+ → a+loggerHandleConfigText StdOut = "stdout"+loggerHandleConfigText StdErr = "stderr"+loggerHandleConfigText (FileHandle f) = "file:" ⊕ fromString f++validateLoggerHandleConfig ∷ ConfigValidation LoggerHandleConfig λ+validateLoggerHandleConfig (FileHandle filepath) = validateFileWritable "file handle" filepath+validateLoggerHandleConfig _ = return ()++instance ToJSON LoggerHandleConfig where+ toJSON = String ∘ loggerHandleConfigText++instance FromJSON LoggerHandleConfig where+ parseJSON = withText "LoggerHandleConfig" $ either fail return ∘ readLoggerHandleConfig++pLoggerHandleConfig ∷ O.Parser LoggerHandleConfig+pLoggerHandleConfig = option (eitherReader readLoggerHandleConfig)+ × long "logger-backend-handle"+ ⊕ metavar "stdout|stderr|file:<FILENAME>"+ ⊕ help "handle where the logs are written"++-- -------------------------------------------------------------------------- --+-- Logger Backend Configuration++-- | HandleBackendConfig+--+data HandleBackendConfig = HandleBackendConfig+ { _handleBackendConfigColor ∷ !ColorOption+ , _handleBackendConfigHandle ∷ !LoggerHandleConfig+ }+ deriving (Show, Read, Eq, Ord, Typeable, Generic)++handleBackendConfigColor ∷ Lens' HandleBackendConfig ColorOption+handleBackendConfigColor = lens _handleBackendConfigColor $ \a b → a { _handleBackendConfigColor = b }++handleBackendConfigHandle ∷ Lens' HandleBackendConfig LoggerHandleConfig+handleBackendConfigHandle = lens _handleBackendConfigHandle $ \a b → a { _handleBackendConfigHandle = b }++instance NFData HandleBackendConfig++defaultHandleBackendConfig ∷ HandleBackendConfig+defaultHandleBackendConfig = HandleBackendConfig+ { _handleBackendConfigColor = defaultColorOption+ , _handleBackendConfigHandle = StdOut+ }++validateHandleBackendConfig ∷ ConfigValidation HandleBackendConfig []+validateHandleBackendConfig HandleBackendConfig{..} = do+ validateLoggerHandleConfig _handleBackendConfigHandle+ case (_handleBackendConfigHandle, _handleBackendConfigColor) of+ (FileHandle _, ColorTrue) →+ tell ["log messages are formatted using ANSI color escape codes but are written to a file"]+ _ → return ()++instance ToJSON HandleBackendConfig where+ toJSON HandleBackendConfig{..} = object+ [ "color" .= _handleBackendConfigColor+ , "handle" .= _handleBackendConfigHandle+ ]++instance FromJSON (HandleBackendConfig → HandleBackendConfig) where+ parseJSON = withObject "HandleBackendConfig" $ \o → id+ <$< handleBackendConfigColor ..: "color" × o+ <*< handleBackendConfigHandle ..: "handle" × o++pHandleBackendConfig ∷ MParser HandleBackendConfig+pHandleBackendConfig = id+ <$< handleBackendConfigColor .:: pColorOption+ <*< handleBackendConfigHandle .:: pLoggerHandleConfig++-- -------------------------------------------------------------------------- --+-- Backend Implementation++withHandleBackend+ ∷ (MonadIO m, MonadBaseControl IO m)+ ⇒ HandleBackendConfig+ → (LoggerBackend T.Text → m α)+ → m α+withHandleBackend conf inner =+ case conf ^. handleBackendConfigHandle of+ StdErr → run stderr+ StdOut → run stdout+ FileHandle f → liftBaseOp (withFile f AppendMode) run+ where+ run h = do+ colored ← liftIO $ useColor (conf ^. handleBackendConfigColor) h+ inner $ handleBackend h colored++handleBackend+ ∷ Handle+ → Bool+ -- ^ whether to use ANSI color escape codes+ → LoggerBackend T.Text+handleBackend h colored eitherMsg = do+ T.hPutStrLn h+ $ inLevelColor colored ("[" ⊕ sshow level ⊕ "] ")+ ⊕ inScopeColor colored ("[" ⊕ formatedScope ⊕ "] ")+ ⊕ (msg ^. logMsg)+ where+ msg = either id id eitherMsg+ level = msg ^. logMsgLevel++ formatedScope = T.intercalate "|" ∘ L.map formatLabel ∘ reverse $ msg ^. logMsgScope+ formatLabel (key, val) = key ⊕ "=" ⊕ val++ inScopeColor True = inBlue+ inScopeColor False = id++ inLevelColor True = case level of+ Error → inRed+ Warn → inOrange+ Info → inGreen+ _ → id+ inLevelColor False = id++ inColor ∷ A.ColorIntensity → A.Color → T.Text → T.Text+ inColor i c t = T.pack (A.setSGRCode [A.SetColor A.Foreground i c]) ⊕ t ⊕ T.pack (A.setSGRCode [A.Reset])++ inRed ∷ T.Text → T.Text+ inRed = inColor A.Vivid A.Red++ inOrange ∷ T.Text → T.Text+ inOrange = inColor A.Dull A.Red++ inGreen ∷ T.Text → T.Text+ inGreen = inColor A.Dull A.Green++ inBlue ∷ T.Text → T.Text+ inBlue = inColor A.Dull A.Blue+{-# INLINEABLE handleBackend #-}+
+ src/System/Logger/Internal.hs view
@@ -0,0 +1,55 @@+-- Copyright (c) 2014-2015 PivotCloud, Inc.+--+-- System.Logger.Internal+--+-- Please feel free to contact us at licensing@pivotmail.com with any+-- contributions, additions, or other feedback; we would love to hear from+-- you.+--+-- Licensed under the Apache License, Version 2.0 (the "License"); you may+-- not use this file except in compliance with the License. You may obtain a+-- copy of the License at http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT+-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the+-- License for the specific language governing permissions and limitations+-- under the License.++-- |+-- Module: System.Logger.Internal+-- Copyright: Copyright (c) 2014-2015 PivotCloud, Inc.+-- License: Apache License, Version 2.0+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UnicodeSyntax #-}++module System.Logger.Internal+( sshow+) where++import Data.String++import Prelude.Unicode++sshow+ ∷ (Show a, IsString b)+ ⇒ a+ → b+sshow = fromString ∘ show+{-# INLINE sshow #-}+
+ src/System/Logger/Logger.hs view
@@ -0,0 +1,81 @@+-- Copyright (c) 2014-2015 PivotCloud, Inc.+--+-- System.Logger.Logger+--+-- Please feel free to contact us at licensing@pivotmail.com with any+-- contributions, additions, or other feedback; we would love to hear from+-- you.+--+-- Licensed under the Apache License, Version 2.0 (the "License"); you may+-- not use this file except in compliance with the License. You may obtain a+-- copy of the License at http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT+-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the+-- License for the specific language governing permissions and limitations+-- under the License.++-- |+-- Module: System.Logger.Logger+-- Description: Yet Another Logger Implementation+-- Copyright: Copyright (c) 2014-2015 PivotCloud, Inc.+-- License: Apache License, Version 2.0+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- This module provides a logger that implements the logger interface+-- that is defined in "System.Logger.Types".+--+-- All the code of this module is in "System.Logger.Logger.Internal".+--+-- The definitions in "System.Logger.Types" are re-exported by this module.+--++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++module System.Logger.Logger+(+-- * Re-Export Logger Interface+ module System.Logger.Types++-- * Logger+, Logger+, withLogger+, withLogFunction++-- * LoggerT Monad Transformer+, LoggerT+, runLoggerT+, runLogT++-- * Configuration Types++-- ** Logger Configuration+, LoggerConfig(..)+, loggerConfigQueueSize+, loggerConfigThreshold+, loggerConfigScope+, defaultLoggerConfig+, validateLoggerConfig+, pLoggerConfig++) where++import System.Logger.Types+import System.Logger.Logger.Internal+
+ src/System/Logger/Logger/Internal.hs view
@@ -0,0 +1,420 @@+-- Copyright (c) 2014-2015 PivotCloud, Inc.+--+-- System.Logger.Logger.Internal+--+-- Please feel free to contact us at licensing@pivotmail.com with any+-- contributions, additions, or other feedback; we would love to hear from+-- you.+--+-- Licensed under the Apache License, Version 2.0 (the "License"); you may+-- not use this file except in compliance with the License. You may obtain a+-- copy of the License at http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT+-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the+-- License for the specific language governing permissions and limitations+-- under the License.++-- |+-- Module: System.Logger.Logger.Internal+-- Description: Yet Another Logger Implementation+-- Copyright: Copyright (c) 2014-2015 PivotCloud, Inc.+-- License: Apache License, Version 2.0+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--+-- This module provides a logger that implements the logger interface+-- that is defined in "System.Logger.Types".+--+-- If you want to roll your own implementation you may use the code in this+-- module as an example and starting point.+--++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}++module System.Logger.Logger.Internal+(+-- * Logger Configuration+ LoggerConfig(..)+, loggerConfigQueueSize+, loggerConfigThreshold+, loggerConfigScope+, defaultLoggerConfig+, validateLoggerConfig+, pLoggerConfig++-- * Logger+, Logger+, loggerScope+, loggerThreshold+, createLogger+, releaseLogger+, withLogger+, loggCtx+, withLogFunction++-- * LoggerT Monad Transformer+, LoggerT+, runLoggerT+, runLogT+) where++import Configuration.Utils hiding (Lens', Error)++import Control.Concurrent.Async+-- FIXME: use a better data structure with non-amortized complexity bounds+import Control.Monad.STM+import Control.Concurrent.STM.TBMQueue+import Control.Concurrent.STM.TVar+import Control.DeepSeq+import Control.Exception.Lifted+import Control.Exception.Enclosed+import Control.Lens hiding ((.=))+import Control.Monad.Except+import Control.Monad.Trans.Control+import Control.Monad.Unicode++import Data.Monoid.Unicode+import Data.Typeable++import GHC.Generics++import Prelude.Unicode++-- internal modules++import System.Logger.Internal+import System.Logger.Types++-- -------------------------------------------------------------------------- --+-- Logger Configuration++-- | Logger Configuration+--+data LoggerConfig = LoggerConfig+ { _loggerConfigQueueSize ∷ !Int+ , _loggerConfigThreshold ∷ !LogLevel+ -- ^ initial log threshold, can be changed later on+ , _loggerConfigScope ∷ !LogScope+ -- ^ initial stack of log labels, can be extended later on+ , _loggerConfigPolicy ∷ !LogPolicy+ -- ^ how to deal with a congested logging pipeline+ }+ deriving (Show, Read, Eq, Ord, Typeable, Generic)++loggerConfigQueueSize ∷ Lens' LoggerConfig Int+loggerConfigQueueSize = lens _loggerConfigQueueSize $ \a b → a { _loggerConfigQueueSize = b }++loggerConfigThreshold ∷ Lens' LoggerConfig LogLevel+loggerConfigThreshold = lens _loggerConfigThreshold $ \a b → a { _loggerConfigThreshold = b }++loggerConfigScope ∷ Lens' LoggerConfig LogScope+loggerConfigScope = lens _loggerConfigScope $ \a b → a { _loggerConfigScope = b }++loggerConfigPolicy ∷ Lens' LoggerConfig LogPolicy+loggerConfigPolicy = lens _loggerConfigPolicy $ \a b → a { _loggerConfigPolicy = b }++instance NFData LoggerConfig++defaultLoggerConfig ∷ LoggerConfig+defaultLoggerConfig = LoggerConfig+ { _loggerConfigQueueSize = 1000+ , _loggerConfigThreshold = Warn+ , _loggerConfigScope = []+ , _loggerConfigPolicy = LogPolicyDiscard+ }++validateLoggerConfig ∷ ConfigValidation LoggerConfig λ+validateLoggerConfig _ = return ()++instance ToJSON LoggerConfig where+ toJSON LoggerConfig{..} = object+ [ "queue_size" .= _loggerConfigQueueSize+ , "log_level" .= _loggerConfigThreshold+ , "scope" .= _loggerConfigScope+ , "policy" .= _loggerConfigPolicy+ ]++instance FromJSON (LoggerConfig → LoggerConfig) where+ parseJSON = withObject "LoggerConfig" $ \o → id+ <$< loggerConfigQueueSize ..: "queue_size" × o+ <*< loggerConfigThreshold ..: "log_level" × o+ <*< loggerConfigScope ..: "scope" × o+ <*< loggerConfigPolicy ..: "policy" × o++pLoggerConfig ∷ MParser LoggerConfig+pLoggerConfig = id+ <$< loggerConfigQueueSize .:: option auto+ × long "queue-size"+ ⊕ metavar "INT"+ ⊕ help "size of the internal logger queue"+ <*< loggerConfigThreshold .:: pLogLevel+ <*< loggerConfigPolicy .:: pLogPolicy++-- -------------------------------------------------------------------------- --+-- Logger+--+-- The logger encapsulates a queue and a background worker that dequeues+-- log-messages and delivers them to a backend action. The opaque logger+-- context is thread safe. But it contains references to mutable state and+-- no copy or derivation of it must be used out-side of it's allocation scope.+--++-- | Interal log message queue.+--+-- The backend function formats and delivers log messages synchronously. In+-- order to not slow down the processing of the main program logic log messages+-- are enqueued and processed asynchronously by a background worker that takes+-- the message from queue and calls the backend function for each log message.+--+type LoggerQueue a = TBMQueue (LogMessage a)++data Logger a = Logger+ { _loggerQueue ∷ !(LoggerQueue a)+ , _loggerWorker ∷ !(Async ())+ , _loggerThreshold ∷ !LogLevel+ , _loggerScope ∷ !LogScope+ , _loggerPolicy ∷ !LogPolicy+ , _loggerMissed ∷ !(TVar Int)+ }+ deriving (Typeable, Generic)++loggerQueue ∷ Lens' (Logger a) (LoggerQueue a)+loggerQueue = lens _loggerQueue $ \a b → a { _loggerQueue = b }+{-# INLINE loggerQueue #-}++loggerWorker ∷ Lens' (Logger a) (Async ())+loggerWorker = lens _loggerWorker $ \a b → a { _loggerWorker = b }+{-# INLINE loggerWorker #-}++loggerThreshold ∷ Lens' (Logger a) LogLevel+loggerThreshold = lens _loggerThreshold $ \a b → a { _loggerThreshold = b }+{-# INLINE loggerThreshold #-}++loggerScope ∷ Lens' (Logger a) LogScope+loggerScope = lens _loggerScope $ \a b → a { _loggerScope = b }+{-# INLINE loggerScope #-}++loggerPolicy ∷ Lens' (Logger a) LogPolicy+loggerPolicy = lens _loggerPolicy $ \a b → a { _loggerPolicy = b }+{-# INLINE loggerPolicy #-}++loggerMissed ∷ Lens' (Logger a) (TVar Int)+loggerMissed = lens _loggerMissed $ \a b → a { _loggerMissed = b }+{-# INLINE loggerMissed #-}++createLogger+ ∷ MonadIO μ+ ⇒ LoggerConfig+ → LoggerBackend a+ → μ (Logger a)+createLogger LoggerConfig{..} backend = liftIO $ do+ queue ← newTBMQueueIO _loggerConfigQueueSize+ missed ← newTVarIO 0+ worker ← backendWorker backend queue missed+ return $ Logger+ { _loggerQueue = queue+ , _loggerWorker = worker+ , _loggerThreshold = _loggerConfigThreshold+ , _loggerScope = _loggerConfigScope+ , _loggerPolicy = _loggerConfigPolicy+ , _loggerMissed = missed+ }++-- FIXME: make this more reliable+--+-- For instance if 'readTBMQeue' (not sure if that can happen) throws an+-- exception 'releaseLogger' may not terminate.+--+-- We must deal better with exceptions thrown by the backend: we should+-- use some reasonable re-spawn logic. Right now there is the risk of a+-- busy loop.+--+backendWorker+ ∷ LoggerBackend a+ → LoggerQueue a+ → TVar Int+ → IO (Async ())+backendWorker backend queue missed = async $ go `catchAny` \e → do+ -- chances are that this fails, too...+ (backend ∘ Left $ backendErrorMsg (sshow e)) `catchAny` (const $ return ())+ go+ where+ go = atomically readMsg ≫= \case+ -- when the queue is closed and empty the backendWorker returns+ Nothing → return ()+ -- When there are still messages to process the backendWorker loops+ Just msg → backend msg ≫ go++ -- As long as the queue is not closed and empty this retries until+ -- a new message arrives+ --+ readMsg = do+ n ← swapTVar missed 0+ if n > 0+ then do+ return ∘ Just ∘ Left $ discardMsg n+ else+ fmap Right <$> readTBMQueue queue++ -- A log message that informs about discarded log messages+ discardMsg n = LogMessage+ { _logMsg = "discarded " ⊕ sshow n ⊕ " log messages"+ , _logMsgLevel = Warn+ , _logMsgScope = [("system", "logger")]+ }++ backendErrorMsg e = LogMessage+ { _logMsg = e+ , _logMsgLevel = Error+ , _logMsgScope = [("system", "logger"), ("component", "backend")]+ }++releaseLogger+ ∷ MonadIO μ+ ⇒ Logger a+ → μ ()+releaseLogger Logger{..} = liftIO $ do+ atomically $ closeTBMQueue _loggerQueue+ wait _loggerWorker++-- | Provide a computation with a 'Logger'.+--+-- Here is an example how this can be used to run a computation+-- with a 'MonadLog' constraint:+--+-- > withConsoleLogger+-- > ∷ (MonadIO m, MonadBaseControl IO m)+-- > ⇒ LogLevel+-- > → (LoggerT T.Text m α)+-- > → m α+-- > withConsoleLogger level = do+-- > backend ← mkHandleLoggerBackend $ config ^. loggerConfigBackend+-- > withLogger config backend ∘ flip runLoggerT+-- > where+-- > config = defaultLoggerConfig+-- > & loggerConfigThreshold .~ level+--+withLogger+ ∷ (MonadIO μ, MonadBaseControl IO μ)+ ⇒ LoggerConfig+ → LoggerBackend a+ → (Logger a → μ α)+ → μ α+withLogger config backend =+ bracket (createLogger config backend) releaseLogger++-- | For simple cases, when the logger threshold and the logger scope is+-- constant this function can be used to directly initialize a log function.+--+withLogFunction+ ∷ (Show a, Typeable a, NFData a, MonadIO μ, MonadBaseControl IO μ)+ ⇒ LoggerConfig+ → LoggerBackend a+ → (LogFunctionIO a → μ α)+ → μ α+withLogFunction config backend f = withLogger config backend $ f ∘ loggCtx++-- -------------------------------------------------------------------------- --+-- Log Function++data LoggerException a+ = QueueFullException (LogMessage a)+ deriving (Show, Eq, Ord, Typeable, Generic)++instance (Typeable a, Show a) ⇒ Exception (LoggerException a)++-- Log a message with the given logger context+--+-- If the logger context has been released (by closing the queue)+-- this function has not effect.+--+loggCtx+ ∷ (Show a, Typeable a, NFData a)+ ⇒ Logger a+ → LogFunctionIO a+loggCtx Logger{..} level msg = do+ case _loggerThreshold of+ Quiet → return ()+ threshold+ | level ≤ threshold → liftIO ∘ atomically $+ writeWithLogPolicy $!! LogMessage+ { _logMsg = msg+ , _logMsgLevel = level+ , _logMsgScope = _loggerScope+ }+ | otherwise → return ()+ where+ writeWithLogPolicy lmsg+ | _loggerPolicy ≡ LogPolicyBlock = writeTBMQueue _loggerQueue lmsg+ | otherwise = tryWriteTBMQueue _loggerQueue lmsg ≫= \case+ Just False+ | _loggerPolicy ≡ LogPolicyDiscard → modifyTVar' _loggerMissed succ+ | _loggerPolicy ≡ LogPolicyRaise → throwSTM $ QueueFullException lmsg++ _ → return ()+{-# INLINEABLE loggCtx #-}++-- -------------------------------------------------------------------------- --+-- Logger Instance++instance LoggerCtx (Logger a) a where+ loggerFunIO = loggCtx+ setLoggerLevel = loggerThreshold+ setLoggerScope = loggerScope+ setLoggerPolicy = loggerPolicy++-- -------------------------------------------------------------------------- --+-- LoggerT++type LoggerT a = LoggerCtxT (Logger a)++runLoggerT ∷ LoggerT a m α → Logger a → m α+runLoggerT = runLoggerCtxT+{-# INLINE runLoggerT #-}++-- | Convenience function that unwraps a 'MonadLog' computation over+-- a newly created 'Logger'+--+runLogT+ ∷ (MonadBaseControl IO m, MonadIO m)+ ⇒ LoggerConfig+ → LoggerBackend msg+ → LoggerT msg m α+ → m α+runLogT config backend = withLogger config backend ∘ runLoggerT++-- -------------------------------------------------------------------------- --+-- Tools++{-+-- | Log all errors that are in current error trace and reset the trace+-- to a single short summary message.+--+logErrorsG+ ∷ MonadIO μ+ ⇒ LogLevel+ → T.Text+ → ExceptT [T.Text] μ α+ → ExceptT [T.Text] μ α+logErrorsG level label p = p `catchError` \e → do+ loggG level $ label ⊕ " failed: " ⊕ T.intercalate " <|> " e+ throwError [label ⊕ " failed"]+-}++
+ src/System/Logger/Types.hs view
@@ -0,0 +1,438 @@+-- Copyright (c) 2014-2015 PivotCloud, Inc.+--+-- System.Logger.Types+--+-- Please feel free to contact us at licensing@pivotmail.com with any+-- contributions, additions, or other feedback; we would love to hear from+-- you.+--+-- Licensed under the Apache License, Version 2.0 (the "License"); you may+-- not use this file except in compliance with the License. You may obtain a+-- copy of the License at http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT+-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the+-- License for the specific language governing permissions and limitations+-- under the License.++-- |+-- Module: System.Logger.Types+-- Description: Basic Types of Yet Another Logger+-- Copyright: Copyright (c) 2014-2015 PivotCloud, Inc.+-- License: Apache License, Version 2.0+-- Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+-- Stability: experimental+--++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UnicodeSyntax #-}++module System.Logger.Types+(+-- * LogLevel+ LogLevel(..)+, logLevelText+, readLogLevel+, pLogLevel++-- * LogPolicy+, LogPolicy(..)+, logPolicyText+, readLogPolicy+, pLogPolicy++-- * LogLabel+, LogLabel+, LogScope++-- * Logger Backend+, LogMessage(..)+, logMsg+, logMsgLevel+, logMsgScope+, LoggerBackend++-- * Logger Frontend+, LogFunction+, LogFunctionIO++-- * LoggerCtx+, LoggerCtx(..)+, LoggerCtxT+, runLoggerCtxT++-- * MonadLog+, MonadLog(..)++) where++import Configuration.Utils hiding (Lens', Error)++import Control.DeepSeq+import Control.Lens hiding ((.=))+import Control.Monad.Base+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Trans.Either+import Control.Monad.State+import Control.Monad.Trans.Trace+import Control.Monad.Writer+import Control.Monad.Unicode++import qualified Data.CaseInsensitive as CI+import Data.Monoid.Unicode+import Data.String+import qualified Data.Text as T+import Data.Text.Lens+import Data.Typeable++import GHC.Generics++import qualified Options.Applicative as O++import Prelude.Unicode++-- -------------------------------------------------------------------------- --+-- Log-Level++data LogLevel+ = Quiet+ | Error+ | Warn+ | Info+ | Debug+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic)++instance NFData LogLevel++readLogLevel+ ∷ (MonadError e m, Eq a, Show a, CI.FoldCase a, IsString a, IsString e, Monoid e)+ ⇒ a+ → m LogLevel+readLogLevel x = case CI.mk x of+ "quiet" → return Quiet+ "error" → return Error+ "warn" → return Warn+ "info" → return Info+ "debug" → return Debug+ e → throwError $ "unexpected log level value: "+ ⊕ fromString (show e)+ ⊕ ", expected \"quiet\", \"error\", \"warn\", \"info\", or \"debug\""++logLevelText+ ∷ IsString a+ ⇒ LogLevel+ → a+logLevelText Quiet = "quiet"+logLevelText Error = "error"+logLevelText Warn = "warn"+logLevelText Info = "info"+logLevelText Debug = "debug"++instance ToJSON LogLevel where+ toJSON = String ∘ logLevelText++instance FromJSON LogLevel where+ parseJSON = withText "LogLevel" $ either fail return ∘ readLogLevel++pLogLevel ∷ O.Parser LogLevel+pLogLevel = option (eitherReader readLogLevel)+ × long "loglevel"+ ⊕ metavar "quiet|error|warn|info|debug"+ ⊕ help "threshold for log messages"++-- -------------------------------------------------------------------------- --+-- Log Policy++-- | Policy that determines how the case of a congested logging+-- pipeline is addressed.+--+data LogPolicy+ = LogPolicyDiscard+ | LogPolicyRaise+ | LogPolicyBlock+ deriving (Show, Read, Eq, Ord, Bounded, Enum, Typeable, Generic)++logPolicyText ∷ IsString s ⇒ LogPolicy → s+logPolicyText LogPolicyDiscard = "discard"+logPolicyText LogPolicyRaise = "raise"+logPolicyText LogPolicyBlock = "block"++readLogPolicy+ ∷ (MonadError e m, Eq a, Show a, CI.FoldCase a, IsText a, IsString e, Monoid e)+ ⇒ a+ → m LogPolicy+readLogPolicy x = case CI.mk tx of+ "discard" → return LogPolicyDiscard+ "raise" → return LogPolicyRaise+ "block" → return LogPolicyBlock+ e → throwError+ $ "invalid log policy value " ⊕ fromString (show e) ⊕ ";"+ ⊕ " the log policy value must be one of \"discard\", \"raise\", or \"block\""+ where+ tx = packed # x++instance ToJSON LogPolicy where+ toJSON = toJSON ∘ (logPolicyText ∷ LogPolicy → T.Text)++instance FromJSON LogPolicy where+ parseJSON = withText "LogPolicy" $ either fail return ∘ readLogPolicy++pLogPolicy ∷ O.Parser LogPolicy+pLogPolicy = option (eitherReader readLogPolicy)+ × long "log-policy"+ ⊕ metavar "block|raise|discard"+ ⊕ help "how to deal with a congested logging pipeline"++-- -------------------------------------------------------------------------- --+-- Log-Label++type LogLabel = (T.Text, T.Text)+type LogScope = [LogLabel]++-- -------------------------------------------------------------------------- --+-- Backend++-- | The Internal log message type.+--+-- The type parameter @a@ is expected to provide intances+-- of 'Show', 'Typeable', and 'NFData'.+--+-- If we need to support different backends, we may consider+-- including the backend here...+--+data LogMessage a = LogMessage+ { _logMsg ∷ !a+ , _logMsgLevel ∷ !LogLevel+ , _logMsgScope ∷ !LogScope+ -- ^ efficiency of this depends on whether this is shared+ -- between log messsages. Usually this should be just a pointer to+ -- a shared list.+ }+ deriving (Show, Read, Eq, Ord, Typeable, Generic)++logMsg ∷ Lens' (LogMessage a) a+logMsg = lens _logMsg $ \a b → a { _logMsg = b }++logMsgLevel ∷ Lens' (LogMessage a) LogLevel+logMsgLevel = lens _logMsgLevel $ \a b → a { _logMsgLevel = b }++logMsgScope ∷ Lens' (LogMessage a) LogScope+logMsgScope = lens _logMsgScope $ \a b → a { _logMsgScope = b }++instance NFData a ⇒ NFData (LogMessage a)++-- | This is given to logger when it is created. It formats and delivers+-- individual log messages synchronously.+--+-- The type parameter @a@ is expected to provide instances for 'Show'+-- 'Typeable', and 'NFData'.+--+-- The 'Left' values of the argument allows the generation of log messages+-- that are independent of the parameter @a@. The motivation for this is+-- reporting issues in Logging system itself, like a full logger queue+-- or providing statistics about the fill level of the queue. There may+-- be other uses of this, too.+--+-- TODO there may be scenarios where chunked processing is beneficial.+-- While this can be done in a closure of this function a more direct+-- support might be desirable.+--+type LoggerBackend a = Either (LogMessage T.Text) (LogMessage a) → IO ()++-- -------------------------------------------------------------------------- --+-- Frontend++-- | This function is provided by the logger.+--+type LogFunctionIO a = LogLevel → a → IO ()+type LogFunction a m = LogLevel → a → m ()++-- -------------------------------------------------------------------------- --+-- MonadLog++class Monad m ⇒ MonadLog a m | m → a where+ logg ∷ LogFunction a m+ withLevel ∷ LogLevel → m α → m α+ withLabel ∷ LogLabel → m α → m α+ withPolicy ∷ LogPolicy → m α → m α++-- Not sure if this instance is a good idea+instance (Show a, Typeable a, NFData a, MonadIO m, LoggerCtx ctx a, MonadReader ctx m) ⇒ MonadLog a m where+ logg l m = ask ≫= \ctx → liftIO (loggerFunIO ctx l m)+ withLevel level = local $ setLoggerLevel .~ level+ withLabel label = local $ setLoggerScope %~ (:) label+ withPolicy policy = local $ setLoggerPolicy .~ policy++ {-# INLINE logg #-}+ {-# INLINE withLevel #-}+ {-# INLINE withLabel #-}+ {-# INLINE withPolicy #-}++-- Not sure if this instance is a good idea+instance MonadLog a m ⇒ MonadLog a (ReaderT σ m) where+ logg l = lift ∘ logg l+ withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return+ withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return+ withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return++ {-# INLINE logg #-}+ {-# INLINE withLevel #-}+ {-# INLINE withLabel #-}+ {-# INLINE withPolicy #-}++instance (Monoid σ, MonadLog a m) ⇒ MonadLog a (WriterT σ m) where+ logg l = lift ∘ logg l+ withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return+ withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return+ withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return++ {-# INLINE logg #-}+ {-# INLINE withLevel #-}+ {-# INLINE withLabel #-}+ {-# INLINE withPolicy #-}++instance (MonadLog a m) ⇒ MonadLog a (ExceptT ε m) where+ logg l = lift ∘ logg l+ withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return+ withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return+ withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return++ {-# INLINE logg #-}+ {-# INLINE withLevel #-}+ {-# INLINE withLabel #-}+ {-# INLINE withPolicy #-}++instance (MonadLog a m) ⇒ MonadLog a (StateT σ m) where+ logg l = lift ∘ logg l+ withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return+ withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return+ withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return++ {-# INLINE logg #-}+ {-# INLINE withLevel #-}+ {-# INLINE withLabel #-}+ {-# INLINE withPolicy #-}++instance (MonadLog a m) ⇒ MonadLog a (TraceT t e m) where+ logg l = lift ∘ logg l+ withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return+ withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return+ withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return++ {-# INLINE logg #-}+ {-# INLINE withLevel #-}+ {-# INLINE withLabel #-}+ {-# INLINE withPolicy #-}++instance (MonadLog a m) ⇒ MonadLog a (EitherT σ m) where+ logg l = lift ∘ logg l+ withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return+ withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return+ withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return++ {-# INLINE logg #-}+ {-# INLINE withLevel #-}+ {-# INLINE withLabel #-}+ {-# INLINE withPolicy #-}++{-+-- Uses @OverlappingInstances@ to lift MonadLog in all transformers with an+-- instance for 'MonadTransControl'.+--+-- It would be really cool if this would work+--+instance (MonadLog a m, MonadTransControl t, Monad n, n ~ (t m)) ⇒ MonadLog a n where+ logg l = lift ∘ logg l+ withLevel level inner = liftWith (\run → withLevel level (run inner)) ≫= restoreT ∘ return+ withLabel label inner = liftWith (\run → withLabel label (run inner)) ≫= restoreT ∘ return+ withPolicy policy inner = liftWith (\run → withPolicy policy (run inner)) ≫= restoreT ∘ return++ {-# INLINE logg #-}+ {-# INLINE withLevel #-}+ {-# INLINE withLabel #-}+ {-# INLINE withPolicy #-}+-}++-- -------------------------------------------------------------------------- --+-- Logger Context++-- | Abstraction of a logger context that can be used without dependening on+-- a specific monadic context.+--+-- The 'loggerFunIO' incorporates a 'LoggerBackend'. An instance of a 'LoggerCtx'+-- is free to use a hard coded 'LoggerBackend' or to be usable with different+-- 'LoggerBackend' functions. The latter is recommended but not required.+--+-- You don't have to provide an instance of this for your logger. Instead you+-- may just provide an instance of 'MonadLog' directly.+--+-- If this doesn't fit your needs you may use a newtype wrapper and define+-- your own instances.+--+class LoggerCtx ctx msg | ctx → msg where+ loggerFunIO+ ∷ (Show msg, Typeable msg, NFData msg)+ ⇒ ctx+ → LogFunctionIO msg++ setLoggerLevel ∷ Setter' ctx LogLevel+ setLoggerScope ∷ Setter' ctx LogScope+ setLoggerPolicy ∷ Setter' ctx LogPolicy++ withLoggerLevel ∷ LogLevel → ctx → (ctx → α) → α+ withLoggerLevel level ctx f = f $ ctx & setLoggerLevel .~ level+ {-# INLINE withLoggerLevel #-}++ withLoggerLabel ∷ LogLabel → ctx → (ctx → α) → α+ withLoggerLabel label ctx f = f $ ctx & setLoggerScope %~ (:) label+ {-# INLINE withLoggerLabel #-}++ withLoggerPolicy ∷ LogPolicy → ctx → (ctx → α) → α+ withLoggerPolicy policy ctx f = f $ ctx & setLoggerPolicy .~ policy+ {-# INLINE withLoggerPolicy #-}++newtype LoggerCtxT ctx m α = LoggerCtxT { unLoggerCtxT ∷ ReaderT ctx m α }+ deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadReader ctx, MonadError a, MonadState a, MonadWriter a, MonadBase a)++instance MonadTransControl (LoggerCtxT ctx) where+ type StT (LoggerCtxT ctx) a = StT (ReaderT ctx) a+ liftWith = defaultLiftWith LoggerCtxT unLoggerCtxT+ restoreT = defaultRestoreT LoggerCtxT++instance MonadBaseControl b m ⇒ MonadBaseControl b (LoggerCtxT ctx m) where+ type StM (LoggerCtxT ctx m) a = ComposeSt (LoggerCtxT ctx) m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM++runLoggerCtxT+ ∷ LoggerCtxT ctx m α+ → ctx+ → m α+runLoggerCtxT = runReaderT ∘ unLoggerCtxT++instance (Show a, Typeable a, NFData a, MonadIO m, LoggerCtx ctx a) ⇒ MonadLog a (LoggerCtxT ctx m) where+ logg l m = ask ≫= \ctx → liftIO (loggerFunIO ctx l m)+ withLevel level = local $ setLoggerLevel .~ level+ withLabel label = local $ setLoggerScope %~ (:) label+ withPolicy policy = local $ setLoggerPolicy .~ policy++ {-# INLINE logg #-}+ {-# INLINE withLevel #-}+ {-# INLINE withLabel #-}+ {-# INLINE withPolicy #-}+
+ yet-another-logger.cabal view
@@ -0,0 +1,116 @@+Name: yet-another-logger+Version: 0.0.1+Synopsis: Yet Another Logger+Description:+ A logging framework written with flexibility and performance+ in mind.+ .+ = Quick Start+ .+ > import System.Logger+ >+ > main ∷ IO ()+ > main = withConsoleLogger Info $ do+ > logg Info "moin"+ > withLabel ("function", "f") f+ > logg Warn "tschüss"+ > where+ > f = withLevel Debug $ do+ > logg Debug "debug f"+ .+ = Description+ .+ /This Version is yet a preview/+ .+ The logging system consists of four main parts:+ .+ 1. The logging front-end are those types and functions that are used+ to produce log messages in the code. This includes the 'LogLevel'+ type, the 'LogPolicy' type, the 'LogLabel' and 'LogScope' types,+ the 'LogFunction' type, and the 'MonadLog' type class.+ .+ 2. The abstract 'LoggerCtx' is the context through which the 'LogFunction'+ delivers log messages to the logger back-end.+ .+ 3. The formatter is a function for serializing log messages.+ .+ 4. The logger back-end is a callback that is invoked by 'Logger' on+ each log messages. The logger back-end applies the formatting function+ and delivers the log messages to some sink.+ .+ The framework allows to combine this components in a modular way. The+ front-end types, the 'Logger', and the back-end callback are represented+ by types or type classes. The formatter exists only as a concept+ in the implementation of back-ends. These types and concepts together+ form the abstract logger interface that is defined in the module+ "System.Logger.Types".+ .+ The package also provides a concrete Logger that implements these components+ in the module "System.Logger.Logger" and "System.Logger.Backend.Handle"++Homepage: https://github.com/alephcloud/hs-yet-another-logger+License: Apache-2.0+Author: Lars Kuhtz <lkuhtz@pivotmail.com>+Maintainer: Lars Kuhtz <lkuhtz@pivotmail.com>+Copyright: Copyright (c) 2014-2015 PivotCloud, Inc.+Category: Logging, System+Build-type: Simple+Cabal-version: >= 1.18+License-file: LICENSE++extra-doc-files:+ README.md,+ CHANGELOG.md++extra-source-files:+ constraints++source-repository head+ type: git+ location: https://github.com/alephcloud/hs-yet-another-logger++source-repository this+ type: git+ location: https://github.com/alephcloud/hs-yet-another-logger+ branch: master+ tag: 0.0.1++Library+ default-language: Haskell2010+ hs-source-dirs: src++ exposed-modules:+ System.Logger+ System.Logger.Backend.ColorOption+ System.Logger.Backend.Handle+ System.Logger.Internal+ System.Logger.Logger+ System.Logger.Logger.Internal+ System.Logger.Types++ build-depends:+ async >= 2.0,+ aeson >= 0.7,+ ansi-terminal >= 0.6,+ base == 4.*,+ base-unicode-symbols >= 0.2,+ bytestring >= 0.10,+ case-insensitive >= 1.2,+ configuration-tools >= 0.2.8,+ deepseq >= 1.3,+ either >= 4.3,+ enclosed-exceptions >= 1.0,+ lens >= 4.6,+ lifted-base >= 0.2.3,+ monad-control >= 1.0,+ mtl >= 2.2,+ optparse-applicative >= 0.11,+ stm >= 2.4,+ stm-chans >= 3.0,+ text >= 1.2,+ trace >= 0.1,+ transformers >= 0.3,+ transformers-base >= 0.4++ ghc-options: -Wall+