diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +0.0.1 +===== + +First public release + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,108 @@ +[![Build Status](https://travis-ci.org/alephcloud/hs-yet-another-logger.svg)](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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/constraints b/constraints new file mode 100644 --- /dev/null +++ b/constraints @@ -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 diff --git a/src/System/Logger.hs b/src/System/Logger.hs new file mode 100644 --- /dev/null +++ b/src/System/Logger.hs @@ -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 +-- 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 + diff --git a/src/System/Logger/Backend/ColorOption.hs b/src/System/Logger/Backend/ColorOption.hs new file mode 100644 --- /dev/null +++ b/src/System/Logger/Backend/ColorOption.hs @@ -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 +-- 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 + diff --git a/src/System/Logger/Backend/Handle.hs b/src/System/Logger/Backend/Handle.hs new file mode 100644 --- /dev/null +++ b/src/System/Logger/Backend/Handle.hs @@ -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 +-- 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:\"" + 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:" + ⊕ 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 #-} + diff --git a/src/System/Logger/Internal.hs b/src/System/Logger/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Logger/Internal.hs @@ -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 +-- 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 #-} + diff --git a/src/System/Logger/Logger.hs b/src/System/Logger/Logger.hs new file mode 100644 --- /dev/null +++ b/src/System/Logger/Logger.hs @@ -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 +-- 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 + diff --git a/src/System/Logger/Logger/Internal.hs b/src/System/Logger/Logger/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Logger/Logger/Internal.hs @@ -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 +-- 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"] +-} + + diff --git a/src/System/Logger/Types.hs b/src/System/Logger/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Logger/Types.hs @@ -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 +-- 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 #-} + diff --git a/yet-another-logger.cabal b/yet-another-logger.cabal new file mode 100644 --- /dev/null +++ b/yet-another-logger.cabal @@ -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 +Maintainer: Lars Kuhtz +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 +