katip (empty) → 0.1.0.0
raw patch · 15 files changed
+1961/−0 lines, 15 filesdep +aesondep +auto-updatedep +basesetup-changed
Dependencies added: aeson, auto-update, base, blaze-builder, bytestring, containers, criterion, deepseq, directory, either, exceptions, hostname, katip, lens, lens-aeson, monad-control, mtl, old-locale, quickcheck-instances, regex-tdfa-rc, resourcet, string-conv, tasty, tasty-hunit, tasty-quickcheck, template-haskell, temporary, text, time, time-locale-compat, transformers, transformers-base, transformers-compat, unix, unordered-containers
Files
- LICENSE +30/−0
- README.md +80/−0
- Setup.hs +2/−0
- bench/Main.hs +94/−0
- changelog.md +4/−0
- examples/example.hs +108/−0
- examples/example_lens.hs +116/−0
- katip.cabal +115/−0
- src/Katip.hs +108/−0
- src/Katip/Core.hs +734/−0
- src/Katip/Monadic.hs +272/−0
- src/Katip/Scribes/Handle.hs +106/−0
- test/Katip/Tests.hs +101/−0
- test/Katip/Tests/Scribes/Handle.hs +72/−0
- test/Main.hs +19/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015-2016, Soostone Inc++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ozgun Ataman nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,80 @@+# Katip [](https://travis-ci.org/Soostone/katip)++Katip is a structured logging framework for Haskell.++++Kâtip (pronounced kah-tip) is the Turkish word for scribe.++## Features++* *Structured:* Logs are structured, meaning they can be individually+ tagged with key value data (JSON Objects). This helps you add+ critical details to log messages before you need them so that when+ you do, they are available. Katip exposes a typeclass for log+ payloads so that you can use rich, domain-specific Haskell types to+ add context that will be automatically merged in with existing log+ context.++* *Easy to Integration:* Katip was designed to be easily integrated+ into existing monads. By using typeclasses for logging facilities,+ individual subsystems and even libraries can easily add their own+ namespacing and context without having any knowledge of their+ logging environment.++* *Practical Use:* Katip comes with a set of convenience facilities+ built-in, so it can be used without much headache even in small+ projects.++ * A `Handle` backend for logging to files in simple settings.++ * A `AnyLogPayload` key-value type that makes it easy to log+ structured columns on the fly without having to define new data+ types.++ * A `Monadic` interface where logging namespace can be obtained+ from the monad context.++ * Multiple variants of the fundamental logging functions for+ optionally including fields and line-number information.++* *Extensible:* Can be easily extended (even at runtime) to output to+ multiple backends at once (known as scribes). See+ `katip-elasticsearch` as an example. Backends for other forms of+ storage are trivial to write, including both hosted database systems+ and SaaS logging providers.++* *Debug-Friendly:* Critical details for monitoring production systems+ such as host, PID, thread id, module and line location are+ automatically captured. User-specified attributes such as+ environment (e.g. Production, Test, Dev) and system name are also+ captured.++* *Configurable:* Can be adjusted on a per-scribe basis both with+ verbosity and severity.++ * *Verbosity* dictates how much of the log structure should+ actually get logged. In code you can capture highly detailed+ metadata and decide how much of that gets emitted to each backend.++ * *Severity* AKA "log level" is specified with each message and+ individual scribes can decide whether or not to record that+ severity. It is even possible to at runtime swap out and replace+ loggers, allowing for swapping in verbose debug logging at runtime+ if you want.++* *Battle-Tested:* Katip has been integrated into several production+ systems since 2015 and has logged hundreds of millions of messages+ to files and ElasticSearch.+++## Examples+Be sure to look in the [examples](./examples) directory for some examples of how+to integrate Katip into your own stack.+++## Contributors++* [Ozgun Ataman](https://github.com/ozataman)+* [Michael Xavier](https://github.com/MichaelXavier)+* [Doug Beardsley](https://github.com/mightybyte)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main+ ( main+ ) where+++-------------------------------------------------------------------------------+import Control.Concurrent+import Control.DeepSeq+import Criterion.Main+import Data.Aeson+import Data.Monoid as M+import Data.Time.Calendar+import Data.Time.Clock+import System.IO+import System.Posix+-------------------------------------------------------------------------------+import Katip.Core+import Katip.Scribes.Handle+-------------------------------------------------------------------------------++main :: IO ()+main = defaultMain [+ handleScribeBench+ ]+++-------------------------------------------------------------------------------+handleScribeBench :: Benchmark+handleScribeBench = bgroup "Katip.Scribes.Handle" [+ env setupEnv $ \ ~(Scribe push, tid) ->+ bench "Bytestring Builder" $+ whnfIO $ push $ exItem tid+ ]+ where+ setupEnv = do+ scribe <- setup+ tid <- myThreadId+ return (scribe, mkThreadIdText tid)+++-------------------------------------------------------------------------------+exItem :: ThreadIdText -> Item ExPayload+exItem tid = Item {+ _itemApp = Namespace ["app"]+ , _itemEnv = Environment "production"+ , _itemSeverity = WarningS+ , _itemThread = tid+ , _itemHost = "example"+ , _itemProcess = CPid 123+ , _itemPayload = ExPayload+ , _itemMessage = "message"+ , _itemTime = mkUTCTime 2015 3 14 1 5 9+ , _itemNamespace = Namespace ["foo"]+ , _itemLoc = Nothing+ }+++-------------------------------------------------------------------------------+data ExPayload = ExPayload++instance ToJSON ExPayload where+ toJSON _ = Object M.mempty++instance ToObject ExPayload++instance LogItem ExPayload where+ payloadKeys _ _ = AllKeys+++-------------------------------------------------------------------------------+mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime+mkUTCTime y mt d h mn s = UTCTime day dt+ where+ day = fromGregorian y mt d+ dt = h * 60 * 60 + mn * 60 + s+++-------------------------------------------------------------------------------+setup :: IO Scribe+setup = do+ h <- openFile "/dev/null" WriteMode+ mkHandleScribe ColorIfTerminal h DebugS V0+++-------------------------------------------------------------------------------+deriving instance NFData ThreadIdText+++instance NFData Scribe where+ rnf (Scribe _) = ()
+ changelog.md view
@@ -0,0 +1,4 @@+0.1.0.0+==============++Initial release
+ examples/example.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Main+ ( main+ ) where+++-------------------------------------------------------------------------------+import Control.Monad.Reader+import Data.Aeson+import Data.Monoid as M+import System.IO (stdout)+-------------------------------------------------------------------------------+import Katip+-------------------------------------------------------------------------------+++-- | An example of advanced katip usage. Be sure to check out+-- lens_example for a slightly cleaner and more general pattern.+main :: IO ()+main = do+ le <- initLogEnv "main" "production"+ -- We'll set up a scribe that logs to stdout and will only log item+ -- fields permitted for Verbosity 2 and will throw out Debug+ -- messages entirely. Note that katip provides facilities like+ -- 'unregisterScribe' and 'registerScribe' to make it possible to+ -- hot-swap scribes at runtime if you need to.+ handleScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2+ let le' = registerScribe "stdout" handleScribe le+ let s = MyState M.mempty mempty le'+ runStack s $ do+ $(logTM) InfoS "Started"+ -- this will add "confrabulation" to the current namespace, making+ -- logs made under this block have the namespace of+ -- "main.confrabulation". Further, ConfrabLogCTX's key/value+ -- context will also get merged with the context above it. You can+ -- use this to stack up various contextual details throughout your+ -- code and they will be flattened out and combined in the log+ -- output.+ addNamespace "confrabulation" $ addContext (ConfrabLogCTX 42) $ do+ $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"+ confrabulateWidgets+ $(logTM) InfoS "Namespace and context are back to normal"+++-------------------------------------------------------------------------------+newtype ConfrabLogCTX = ConfrabLogCTX Int+++instance ToJSON ConfrabLogCTX where+ toJSON (ConfrabLogCTX factor) = object ["confrab_factor" .= factor]+++instance ToObject ConfrabLogCTX+++instance LogItem ConfrabLogCTX where+ payloadKeys _verb _a = AllKeys+++-------------------------------------------------------------------------------+confrabulateWidgets :: (Monad m) => m ()+confrabulateWidgets = return ()+++-------------------------------------------------------------------------------+data MyState = MyState {+ msKNamespace :: Namespace+ , msKContext :: LogContexts+ , msLogEnv :: LogEnv+ }+++-------------------------------------------------------------------------------+newtype MyStack m a = MyStack {+ unStack :: ReaderT MyState m a+ } deriving (MonadReader MyState, Functor, Applicative, Monad, MonadIO)+++instance (MonadIO m) => Katip (MyStack m) where+ getLogEnv = asks msLogEnv+++instance (MonadIO m) => KatipContext (MyStack m) where+ getKatipContext = asks msKContext+ getKatipNamespace = asks msKNamespace+++-------------------------------------------------------------------------------+-- | Merge some context into the log only for the given block+addContext :: (LogItem i, MonadReader MyState m) => i -> m a -> m a+addContext i = local (\r -> r { msKContext = msKContext r <> ctxs })+ where+ ctxs = liftPayload i+++-------------------------------------------------------------------------------+-- | Add a layer of namespace to the logs only for the given block+addNamespace :: (MonadReader MyState m) => Namespace -> m a -> m a+addNamespace ns = local (\r -> r { msKNamespace = msKNamespace r <> ns })+++-------------------------------------------------------------------------------+runStack :: MyState -> MyStack m a -> m a+runStack s f = runReaderT (unStack f) s
+ examples/example_lens.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Main+ ( main+ ) where+++-------------------------------------------------------------------------------+import Control.Lens hiding ((.=))+import Control.Monad.Reader+import Data.Aeson+import Data.Monoid as M+import System.IO (stdout)+-------------------------------------------------------------------------------+import Katip+-------------------------------------------------------------------------------+++data MyState = MyState {+ _msKNamespace :: Namespace+ , _msKContext :: LogContexts+ , _msLogEnv :: LogEnv+ }+++-- This gives us HasMyState, which is helpful for complex stacks where+-- MyState may be nested somewhere deeper inside a larger data+-- structure. You can keep functions that operate on MyState as+-- general as possible.+makeClassy ''MyState+++-------------------------------------------------------------------------------+-- | An example of advanced katip usage. Be sure to check out+-- lens_example for a slightly cleaner and more general pattern.+main :: IO ()+main = do+ le <- initLogEnv "main" "production"+ -- We'll set up a scribe that logs to stdout and will only log item+ -- fields permitted for Verbosity 2 and will throw out Debug+ -- messages entirely. Note that katip provides facilities like+ -- 'unregisterScribe' and 'registerScribe' to make it possible to+ -- hot-swap scribes at runtime if you need to.+ handleScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2+ let le' = registerScribe "stdout" handleScribe le+ let s = MyState M.mempty mempty le'+ runStack s $ do+ $(logTM) InfoS "Started"+ -- this will add "confrabulation" to the current namespace, making+ -- logs made under this block have the namespace of+ -- "main.confrabulation". Further, ConfrabLogCTX's key/value+ -- context will also get merged with the context above it. You can+ -- use this to stack up various contextual details throughout your+ -- code and they will be flattened out and combined in the log+ -- output.+ addNamespace "confrabulation" $ addContext (ConfrabLogCTX 42) $ do+ $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"+ confrabulateWidgets+ $(logTM) InfoS "Namespace and context are back to normal"+++-------------------------------------------------------------------------------+newtype ConfrabLogCTX = ConfrabLogCTX Int+++instance ToJSON ConfrabLogCTX where+ toJSON (ConfrabLogCTX factor) = object ["confrab_factor" .= factor]+++instance ToObject ConfrabLogCTX+++instance LogItem ConfrabLogCTX where+ payloadKeys _verb _a = AllKeys+++-------------------------------------------------------------------------------+confrabulateWidgets :: (Monad m) => m ()+confrabulateWidgets = return ()+++-------------------------------------------------------------------------------+newtype MyStack m a = MyStack {+ unStack :: ReaderT MyState m a+ } deriving (MonadReader MyState, Functor, Applicative, Monad, MonadIO)+++instance (MonadIO m) => Katip (MyStack m) where+ getLogEnv = view msLogEnv+++instance (MonadIO m) => KatipContext (MyStack m) where+ getKatipContext = view msKContext+ getKatipNamespace = view msKNamespace+++-------------------------------------------------------------------------------+-- | Merge some context into the log only for the given block+addContext :: (LogItem i, MonadReader r m, HasMyState r) => i -> m a -> m a+addContext i = local (\r -> r & msKContext <>~ ctxs)+ where+ ctxs = liftPayload i+++-------------------------------------------------------------------------------+-- | Add a layer of namespace to the logs only for the given block+addNamespace :: (MonadReader r m, HasMyState r) => Namespace -> m a -> m a+addNamespace ns = local (\r -> r & msKNamespace <>~ ns)+++-------------------------------------------------------------------------------+runStack :: MyState -> MyStack m a -> m a+runStack s f = runReaderT (unStack f) s
+ katip.cabal view
@@ -0,0 +1,115 @@+name: katip+version: 0.1.0.0+synopsis: A structured logging framework.+description:+ Katip is a structured logging framework. See README.md for more details.++license: BSD3+license-file: LICENSE+author: Ozgun Ataman+maintainer: ozgun.ataman@soostone.com+copyright: Soostone Inc, 2015-2016+category: Data, Text, Logging+build-type: Simple+cabal-version: >=1.10+extra-source-files:+ README.md+ changelog.md+ examples/example.hs+ examples/example_lens.hs+ bench/Main.hs+ test/Main.hs+ test/Katip/Tests.hs+ test/Katip/Tests/Scribes/Handle.hs++flag lib-Werror+ default: False+ manual: True++library+ exposed-modules:+ Katip+ Katip.Core+ Katip.Monadic+ Katip.Scribes.Handle++ default-extensions:+ DeriveGeneric+ FlexibleContexts+ GeneralizedNewtypeDeriving+ MultiParamTypeClasses+ RankNTypes+ RecordWildCards+ TemplateHaskell+ OverloadedStrings++ build-depends: base >=4.5 && <5+ , aeson >=0.6 && <0.12+ , auto-update >= 0.1 && < 0.2+ , bytestring >= 0.9 && < 0.11+ , containers >=0.4 && <0.6+ , either >= 4 && < 4.5+ , exceptions >= 0.5 && < 0.9+ , hostname >=1.0 && <1.1+ , lens >= 4.4 && <4.14+ , lens-aeson < 1.1+ , old-locale >= 1.0 && < 1.1+ , string-conv >= 0.1 && < 0.2+ , template-haskell >= 2.8 && < 2.11+ , text >= 0.11 && <1.3+ , time >= 1 && < 1.6+ , time-locale-compat >= 0.1.0.1 && < 0.2+ , transformers >= 0.3 && < 0.5+ , transformers-compat+ , unix >= 2.5 && < 2.8+ , unordered-containers >= 0.2 && < 0.3+ , monad-control >= 1.0 && < 1.1+ , mtl+ , transformers-base+ , resourcet++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ if flag(lib-Werror)+ ghc-options: -Werror++test-suite test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ default-language: Haskell2010+ build-depends: base+ , katip+ , aeson+ , tasty >= 0.10.1.2+ , tasty-hunit+ , tasty-quickcheck+ , quickcheck-instances+ , template-haskell+ , text+ , time+ , temporary+ , directory+ , regex-tdfa-rc+++benchmark bench+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench+ default-language: Haskell2010+ ghc-options: -O2 -Wall+ if flag(lib-Werror)+ ghc-options: -Werror+ build-depends:+ base+ , aeson+ , blaze-builder+ , katip+ , criterion >= 1.1.0.0+ , unix+ , text+ , time+ , transformers+ , deepseq
+ src/Katip.hs view
@@ -0,0 +1,108 @@+-- | Includes all of the API's youll need to use Katip. Be sure to+-- check out the included @examples@ directory for an example of+-- usage.+--+-- To get up and running, the workflow is generally:+--+-- * Set up a 'LogEnv' using 'initLogEnv'.+--+-- * Add 'Scribe's using 'registerScribe'.+--+-- * Either use 'KatipT' or 'KatipContextT' for a pre-built+-- transformer stack or add 'Katip' and 'KatipContext' instances to+-- your own transformer stack. If you do the latter, you may want to+-- look in the @examples@ dir for some tips on composing contexts and+-- namespaces.+--+-- * Define some structured log data throughout your application and+-- implement 'ToObject' and 'LogItem' for them.+--+-- * Begin logging with 'logT', 'logTM', etc.+--+-- * Define your own 'Scribe' if you need to output to some as-yet+-- unsupported format or service. If you think it would be useful to+-- others, consider releasing your own package.+module Katip+ (++ -- * Framework Types++ Katip (..)+ , Namespace (..)+ , Environment (..)+ , Severity (..)+ , renderSeverity+ , severityText+ , Verbosity (..)+ , ToObject (..)+ , LogItem (..)+ , Item(..)+ , itemApp+ , itemEnv+ , itemSeverity+ , itemThread+ , itemHost+ , itemProcess+ , itemPayload+ , itemMessage+ , itemTime+ , itemNamespace+ , itemLoc+ , ThreadIdText(..)+ , PayloadSelection (..)+ , Scribe (..)+ , LogEnv (..)+ , logEnvHost+ , logEnvPid+ , logEnvNs+ , logEnvEnv+ , logEnvTimer+ , logEnvScribes+ , KatipContext(..)+ , AnyLogContext+ , LogContexts, liftPayload+ , SimpleLogPayload, sl++ -- * A Built-in Monad For Logging+ , KatipT (..)+ , runKatipT++ -- * Initializing Loggers+ , initLogEnv+ , registerScribe+ , unregisterScribe+ , clearScribes++ -- * Logging Functions+ , LogStr (..)+ , logStr, ls, showLS++ , logF+ , logMsg+ , logT+ , logItem+ , logException+ , logFM+ , logTM+ , logItemM+ , logExceptionM++ -- * Included Scribes+ , mkHandleScribe+ , ColorStrategy (..)++ -- * Tools for implementing Scribes+ , permitItem+ , payloadObject+ , itemJson++ -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances+ , KatipContextT+ , runKatipContextT+ ) where++-------------------------------------------------------------------------------+import Katip.Core+import Katip.Monadic+import Katip.Scribes.Handle+-------------------------------------------------------------------------------
+ src/Katip/Core.hs view
@@ -0,0 +1,734 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Katip.Core where++-------------------------------------------------------------------------------+import Control.Applicative as A+import Control.AutoUpdate+import Control.Concurrent+import Control.Lens+import Control.Monad+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Control+import Control.Monad.Trans.Either+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Resource+import Control.Monad.Trans.State+import Control.Monad.Trans.Writer+import Data.Aeson (FromJSON (..), ToJSON (..),+ object)+import qualified Data.Aeson as A+import Data.Foldable as FT+import qualified Data.HashMap.Strict as HM+import Data.List+import qualified Data.Map.Strict as M+import Data.Monoid+import Data.String+import Data.String.Conv+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as B+import Data.Time+import GHC.Generics hiding (to)+import Language.Haskell.TH+import qualified Language.Haskell.TH.Syntax as TH+import Network.HostName+import System.Posix+-------------------------------------------------------------------------------+++-------------------------------------------------------------------------------+-- | Represents a heirarchy of namespaces going from general to+-- specific. For instance: ["processname", "subsystem"]. Note that+-- single-segment namespaces can be created using+-- IsString/OverloadedStrings, so "foo" will result in Namespace+-- ["foo"].+newtype Namespace = Namespace { unNamespace :: [Text] }+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,Monoid)++instance IsString Namespace where+ fromString s = Namespace [fromString s]+++-------------------------------------------------------------------------------+-- | Ready namespace for emission with dots to join the segments.+intercalateNs :: Namespace -> [Text]+intercalateNs (Namespace xs) = intersperse "." xs+++-------------------------------------------------------------------------------+-- | Application environment, like @prod@, @devel@, @testing@.+newtype Environment = Environment { getEnvironment :: Text }+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,IsString)+++-------------------------------------------------------------------------------+data Severity+ = DebugS -- ^ Debug messages+ | InfoS -- ^ Information+ | NoticeS -- ^ Normal runtime Conditions+ | WarningS -- ^ General Warnings+ | ErrorS -- ^ General Errors+ | CriticalS -- ^ Severe situations+ | AlertS -- ^ Take immediate action+ | EmergencyS -- ^ System is unusable+ deriving (Eq, Ord, Show, Read, Generic, Enum, Bounded)+++-------------------------------------------------------------------------------+-- | Verbosity controls the amount of information (columns) a 'Scribe'+-- emits during logging.+--+-- The convention is:+-- - 'V0' implies no additional payload information is included in message.+-- - 'V3' implies the maximum amount of payload information.+-- - Anything in between is left to the discretion of the developer.+data Verbosity = V0 | V1 | V2 | V3+ deriving (Eq, Ord, Show, Read, Generic, Enum)+++-------------------------------------------------------------------------------+renderSeverity :: Severity -> Text+renderSeverity s = case s of+ DebugS -> "Debug"+ InfoS -> "Info"+ NoticeS -> "Notice"+ WarningS -> "Warning"+ ErrorS -> "Error"+ CriticalS -> "Critical"+ AlertS -> "Alert"+ EmergencyS -> "Emergency"+++-------------------------------------------------------------------------------+severityText :: Prism' Text Severity+severityText = prism renderSeverity toSev+ where+ toSev "Debug" = Right DebugS+ toSev "Info" = Right InfoS+ toSev "Notice" = Right NoticeS+ toSev "Warning" = Right WarningS+ toSev "Error" = Right ErrorS+ toSev "Critical" = Right CriticalS+ toSev "Alert" = Right AlertS+ toSev "Emergency" = Right EmergencyS+ toSev x = Left x++instance ToJSON Severity where+ toJSON s = A.String (s ^. re severityText)+++instance FromJSON Severity where+ parseJSON = A.withText "Severity" parseSeverity+ where+ parseSeverity t = case t ^? severityText of+ Just x -> return x+ Nothing -> fail $ "Invalid Severity " ++ toS t+++-------------------------------------------------------------------------------+-- | Log message with Builder unerneath; use '<>' to concat in O(1).+newtype LogStr = LogStr { unLogStr :: B.Builder }+ deriving (Generic, Show)++instance IsString LogStr where+ fromString = LogStr . B.fromString++instance Monoid LogStr where+ mappend (LogStr a) (LogStr b) = LogStr (a `mappend` b)+ mempty = LogStr mempty++instance FromJSON LogStr where+ parseJSON = A.withText "LogStr" parseLogStr+ where+ parseLogStr = return . LogStr . B.fromText++-------------------------------------------------------------------------------+-- | Pack any string-like thing into a 'LogStr'. This will+-- automatically work on 'String', 'ByteString, 'Text' and any of the+-- lazy variants.+logStr :: StringConv a Text => a -> LogStr+logStr t = LogStr (B.fromText $ toS t)+++-------------------------------------------------------------------------------+-- | Shorthand for 'logMsg'+ls :: StringConv a Text => a -> LogStr+ls = logStr+++-------------------------------------------------------------------------------+-- | Convert any showable type into a LogStr.+showLS :: Show a => a -> LogStr+showLS = ls . show+++-------------------------------------------------------------------------------+newtype ThreadIdText = ThreadIdText {+ getThreadIdText :: Text+ } deriving (ToJSON, FromJSON, Show, Eq, Ord)+++mkThreadIdText :: ThreadId -> ThreadIdText+mkThreadIdText = ThreadIdText . T.pack . show+++-------------------------------------------------------------------------------+-- | This has everything each log message will contain.+data Item a = Item {+ _itemApp :: Namespace+ , _itemEnv :: Environment+ , _itemSeverity :: Severity+ , _itemThread :: ThreadIdText+ , _itemHost :: HostName+ , _itemProcess :: ProcessID+ , _itemPayload :: a+ , _itemMessage :: LogStr+ , _itemTime :: UTCTime+ , _itemNamespace :: Namespace+ , _itemLoc :: Maybe Loc+ } deriving (Generic, Functor)+makeLenses ''Item+++instance Show a => Show (Item a) where+ show Item{..} = "Item {_itemApp = " ++ show _itemApp ++ ", " +++ "_itemEnv = " ++ show _itemEnv ++ ", " +++ "_itemSeverity = " ++ show _itemSeverity ++ ", " +++ "_itemThread = " ++ show _itemThread ++ ", " +++ "_itemHost = " ++ show _itemHost ++ ", " +++ "_itemProcess = " ++ show _itemProcess ++ ", " +++ "_itemPayload = " ++ show _itemPayload ++ ", " +++ "_itemMessage = " ++ show _itemMessage ++ ", " +++ "_itemTime = " ++ show _itemTime ++ ", " +++ "_itemNamespace = " ++ show _itemNamespace ++ ", " +++ "_itemLoc = " ++ show (LocShow <$> _itemLoc) ++ "}"+++newtype LocShow = LocShow Loc+++instance Show LocShow where+ show (LocShow Loc{..}) =+ "Loc {loc_filename = " ++ show loc_filename ++ ", " +++ "loc_package = " ++ show loc_package ++ ", " +++ "loc_module = " ++ show loc_module ++ ", " +++ "loc_start = " ++ show loc_start ++ ", " +++ "loc_end = " ++ show loc_end ++ "}"+++instance ToJSON a => ToJSON (Item a) where+ toJSON Item{..} = A.object+ [ "app" A..= _itemApp+ , "env" A..= _itemEnv+ , "sev" A..= _itemSeverity+ , "thread" A..= getThreadIdText _itemThread+ , "host" A..= _itemHost+ , "pid" A..= ProcessIDJs _itemProcess+ , "data" A..= _itemPayload+ , "msg" A..= (B.toLazyText $ unLogStr _itemMessage)+ , "at" A..= _itemTime+ , "ns" A..= _itemNamespace+ , "loc" A..= fmap LocJs _itemLoc+ ]++newtype LocJs = LocJs { getLocJs :: Loc }+++instance ToJSON LocJs where+ toJSON (LocJs (Loc fn p m (l, c) _)) = A.object+ [ "loc_fn" A..= fn+ , "loc_pkg" A..= p+ , "loc_mod" A..= m+ , "loc_ln" A..= l+ , "loc_col" A..= c+ ]+++instance FromJSON LocJs where+ parseJSON = A.withObject "LocJs" parseLocJs+ where+ parseLocJs o = do+ fn <- o A..: "loc_fn"+ p <- o A..: "loc_pkg"+ m <- o A..: "loc_mod"+ l <- o A..: "loc_ln"+ c <- o A..: "loc_col"+ return $ LocJs $ Loc fn p m (l, c) (l, c)+++instance FromJSON a => FromJSON (Item a) where+ parseJSON = A.withObject "Item" parseItem+ where+ parseItem o = Item+ <$> o A..: "app"+ <*> o A..: "env"+ <*> o A..: "sev"+ <*> o A..: "thread"+ <*> o A..: "host"+ <*> (getProcessIDJs <$> o A..: "pid")+ <*> o A..: "data"+ <*> o A..: "msg"+ <*> o A..: "at"+ <*> o A..: "ns"+ <*> (fmap getLocJs <$> o A..: "loc")+++processIDText :: Prism' Text ProcessID+processIDText = prism fromProcessID toProcessID+ where+ fromProcessID = toS . show+ toProcessID t = case toS t ^? _Show of+ Just i -> Right i+ Nothing -> Left t+++newtype ProcessIDJs = ProcessIDJs {+ getProcessIDJs :: ProcessID+ }+++instance ToJSON ProcessIDJs where+ toJSON (ProcessIDJs p) = A.String (p ^. re processIDText)+++instance FromJSON ProcessIDJs where+ parseJSON = A.withText "ProcessID" parseProcessID+ where+ parseProcessID t = case t ^? processIDText of+ Just p -> return $ ProcessIDJs p+ Nothing -> fail $ "Invalid ProcessIDJs " ++ toS t+++-------------------------------------------------------------------------------+-- | Field selector by verbosity within JSON payload.+data PayloadSelection+ = AllKeys+ | SomeKeys [Text]++instance Monoid PayloadSelection where+ mempty = SomeKeys []+ mappend AllKeys _ = AllKeys+ mappend _ AllKeys = AllKeys+ mappend (SomeKeys as) (SomeKeys bs) = SomeKeys (as++bs)+++-------------------------------------------------------------------------------+-- | Katip requires JSON objects to be logged as context. This+-- typeclass provides a default instance which uses ToJSON and+-- produces an empty object if 'toJSON' results in any type other than+-- object. If you have a type you want to log that produces an Array+-- or Number for example, you'll want to write an explicit instance+-- here. You can trivially add a ToObject instance for something with+-- a ToJSON instance like:+--+-- > instance ToObject Foo+class ToJSON a => ToObject a where+ toObject :: a -> A.Object+ toObject v = case toJSON v of+ A.Object o -> o+ _ -> mempty++instance ToObject ()+instance ToObject A.Object++-------------------------------------------------------------------------------+-- | Payload objects need instances of this class. LogItem makes it so+-- that you can have very verbose items getting logged with lots of+-- extra fields but under normal circumstances, if your scribe is+-- configured for a lower verbosity level, it will only log a+-- selection of those keys. Furthermore, each 'Scribe' can be+-- configured with a different 'Verbosity' level. You could even use+-- 'registerScribe', 'unregisterScribe', and 'clearScribes' to at+-- runtime swap out your existing scribes for more verbose debugging+-- scribes if you wanted to.+--+-- When defining 'payloadKeys', don't redundantly declare the same+-- keys for higher levels of verbosity. Each level of verbosity+-- automatically and recursively contains all keys from the level+-- before it.+class ToObject a => LogItem a where++ -- | List of keys in the JSON object that should be included in message.+ payloadKeys :: Verbosity -> a -> PayloadSelection+++instance LogItem () where payloadKeys _ _ = SomeKeys []+++data AnyLogPayload = forall a. ToJSON a => AnyLogPayload a++newtype SimpleLogPayload = SimpleLogPayload {+ unSimpleLogPayload :: [(Text, AnyLogPayload)]+ }++-------------------------------------------------------------------------------+-- | A built-in convenience log payload that won't log anything on 'V0',+-- but will log everything in any other level of verbosity. Intended+-- for easy in-line usage without having to define new log types.+--+-- Construct using 'sl' and combine multiple tuples using '<>' from+-- 'Monoid'.+instance ToJSON SimpleLogPayload where+ toJSON (SimpleLogPayload as) = object $ map go as+ where go (k, AnyLogPayload v) = k A..= v++instance ToObject SimpleLogPayload++instance LogItem SimpleLogPayload where+ payloadKeys V0 _ = SomeKeys []+ payloadKeys _ _ = AllKeys++instance Monoid SimpleLogPayload where+ mempty = SimpleLogPayload []+ SimpleLogPayload a `mappend` SimpleLogPayload b = SimpleLogPayload (a `mappend` b)+++-------------------------------------------------------------------------------+-- | Construct a simple log from any JSON item.+sl :: ToJSON a => Text -> a -> SimpleLogPayload+sl a b = SimpleLogPayload [(a, AnyLogPayload b)]+++-------------------------------------------------------------------------------+-- | Constrain payload based on verbosity. Backends should use this to+-- automatically bubble higher verbosity levels to lower ones.+payloadObject :: LogItem a => Verbosity -> a -> A.Object+payloadObject verb a = case FT.foldMap (flip payloadKeys a) [(V0)..verb] of+ AllKeys -> toObject a+ SomeKeys ks -> HM.filterWithKey (\ k _ -> k `elem` ks) $ toObject a+++-------------------------------------------------------------------------------+-- | Convert log item to its JSON representation while trimming its+-- payload based on the desired verbosity. Backends that push JSON+-- messages should use this to obtain their payload.+itemJson :: LogItem a => Verbosity -> Item a -> A.Value+itemJson verb a = toJSON $ a & itemPayload %~ payloadObject verb+++-------------------------------------------------------------------------------+-- | Scribes are handlers of incoming items. Each registered scribe+-- knows how to push a log item somewhere.+--+-- = Guidelines for writing your own 'Scribe'+--+-- Scribes should always take a 'Severity' and 'Verbosity'.+--+-- Severity is used to *exclude log messages* that are < the provided+-- Severity. For instance, if the user passes InfoS, DebugS items+-- should be ignored. Katip provides the 'permitItem' utility for this.+--+-- Verbosity is used to select keys from the log item's payload. Each+-- 'LogItem' instance describes what keys should be retained for each+-- Verbosity level. Use the 'payloadObject' utility for extracting the keys+-- that should be permitted.+--+-- There is no built-in mechanism in katip for telling a scribe that+-- its time to shut down. 'unregisterScribe' merely drops it from the+-- 'LogEnv'. This means there are 2 ways to handle resources as a scribe:+--+-- 1. Pass in the resource when the scribe is created. Handle+-- allocation and release of the resource elsewhere. This is what the+-- Handle scribe does.+--+-- 2. Return a finalizing function that tells the scribe to shut+-- down. @katip-elasticsearch@'s @mkEsScribe@ returns a @IO (Scribe,+-- IO ())@. The finalizer will flush any queued log messages and shut+-- down gracefully before returning. This can be hooked into your+-- application's shutdown routine to ensure you never miss any log+-- messages on shutdown.+data Scribe = Scribe {+ liPush :: forall a. LogItem a => Item a -> IO ()+ }+++instance Monoid Scribe where+ mempty = Scribe $ const $ return ()+ mappend (Scribe a) (Scribe b) = Scribe $ \ item -> do+ a item+ b item+++-------------------------------------------------------------------------------+-- | Should this item be logged given the user's maximum severity?+permitItem :: Severity -> Item a -> Bool+permitItem sev i = _itemSeverity i >= sev+++-------------------------------------------------------------------------------+data LogEnv = LogEnv {+ _logEnvHost :: HostName+ , _logEnvPid :: ProcessID+ , _logEnvNs :: Namespace+ , _logEnvEnv :: Environment+ , _logEnvTimer :: IO UTCTime+ -- ^ Action to fetch the timestamp. You can use something like+ -- 'AutoUpdate' for high volume logs but note that this may cause+ -- some output forms to display logs out of order.+ , _logEnvScribes :: M.Map Text Scribe+ }+makeLenses ''LogEnv+++-------------------------------------------------------------------------------+-- | Create a reasonable default InitLogEnv. Uses an 'AutoUdate' with+-- the default settings as the timer. If you are concerned about+-- timestamp precision or event ordering in log outputs like+-- ElasticSearch, you should replace the timer with 'getCurrentTime'+initLogEnv+ :: Namespace+ -- ^ A base namespace for this application+ -> Environment+ -- ^ Current run environment (e.g. @prod@ vs. @devel@)+ -> IO LogEnv+initLogEnv an env = LogEnv+ <$> getHostName+ <*> getProcessID+ <*> pure an+ <*> pure env+ <*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }+ <*> pure mempty+++-------------------------------------------------------------------------------+-- | Add a scribe to the list. All future log calls will go to this+-- scribe in addition to the others.+registerScribe+ :: Text+ -- ^ Name the scribe+ -> Scribe+ -> LogEnv+ -> LogEnv+registerScribe nm h = logEnvScribes . at nm .~ Just h+++-------------------------------------------------------------------------------+-- | Remove a scribe from the list. All future log calls will no+-- longer use this scribe. If the given scribe doesn't exist, its a no-op.+unregisterScribe+ :: Text+ -- ^ Name of the scribe+ -> LogEnv+ -> LogEnv+unregisterScribe nm = logEnvScribes . at nm .~ Nothing+++-------------------------------------------------------------------------------+-- | Unregister *all* scribes. Logs will go off into space from this+-- point onward until new scribes are added.+clearScribes+ :: LogEnv+ -> LogEnv+clearScribes = logEnvScribes .~ mempty+++-------------------------------------------------------------------------------+-- | Monads where katip logging actions can be performed+class MonadIO m => Katip m where+ getLogEnv :: m LogEnv+++instance Katip m => Katip (ReaderT s m) where+ getLogEnv = lift getLogEnv+++instance Katip m => Katip (EitherT s m) where+ getLogEnv = lift getLogEnv+++instance Katip m => Katip (MaybeT m) where+ getLogEnv = lift getLogEnv+++instance Katip m => Katip (StateT s m) where+ getLogEnv = lift getLogEnv+++instance (Katip m, Monoid s) => Katip (WriterT s m) where+ getLogEnv = lift getLogEnv++instance (Katip m) => Katip (ResourceT m) where+ getLogEnv = lift getLogEnv+++-------------------------------------------------------------------------------+-- | A concrete monad you can use to run logging actions.+newtype KatipT m a = KatipT { unKatipT :: ReaderT LogEnv m a }+ deriving ( Functor, Applicative, Monad, MonadIO+ , MonadMask, MonadCatch, MonadThrow, MonadTrans, MonadBase b)+++instance MonadIO m => Katip (KatipT m) where+ getLogEnv = KatipT ask+++instance MonadTransControl KatipT where+ type StT (KatipT) a = a+ liftWith f = KatipT $ ReaderT $ \le -> f $ \t -> runKatipT le t+ restoreT = KatipT . ReaderT . const+ {-# INLINABLE liftWith #-}+ {-# INLINABLE restoreT #-}+++instance (MonadBaseControl b m) => MonadBaseControl b (KatipT m) where+ type StM ((KatipT) m) a = ComposeSt (KatipT) m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM+++-------------------------------------------------------------------------------+-- | Execute 'KatipT' on a log env.+runKatipT :: LogEnv -> KatipT m a -> m a+runKatipT le (KatipT f) = runReaderT f le+++-------------------------------------------------------------------------------+-- | Log with everything, including a source code location. This is+-- very low level and you typically can use 'logT' in its place.+logItem+ :: (A.Applicative m, LogItem a, Katip m)+ => a+ -> Namespace+ -> Maybe Loc+ -> Severity+ -> LogStr+ -> m ()+logItem a ns loc sev msg = do+ LogEnv{..} <- getLogEnv+ liftIO $ do+ item <- Item+ <$> pure _logEnvNs+ <*> pure _logEnvEnv+ <*> pure sev+ <*> (mkThreadIdText <$> myThreadId)+ <*> pure _logEnvHost+ <*> pure _logEnvPid+ <*> pure a+ <*> pure msg+ <*> _logEnvTimer+ <*> pure (_logEnvNs <> ns)+ <*> pure loc+ forM_ (M.elems _logEnvScribes) $ \ (Scribe h) -> h item+++-------------------------------------------------------------------------------+-- | Log with full context, but without any code location.+logF+ :: (Applicative m, LogItem a, Katip m)+ => a+ -- ^ Contextual payload for the log+ -> Namespace+ -- ^ Specific namespace of the message.+ -> Severity+ -- ^ Severity of the message+ -> LogStr+ -- ^ The log message+ -> m ()+logF a ns sev msg = logItem a ns Nothing sev msg++++-------------------------------------------------------------------------------+-- | Perform an action while logging any exceptions that may occur.+-- Inspired by 'onException`.+--+-- >>>> logException () mempty ErrorS (error "foo")+logException+ :: (Katip m, LogItem a, MonadCatch m, Applicative m)+ => a -- ^ Log context+ -> Namespace -- ^ Namespace+ -> Severity -- ^ Severity+ -> m b -- ^ Main action being run+ -> m b+logException a ns sev action = action `catchAll` \e -> f e >> throwM e+ where+ f e = logF a ns sev (msg e)+ msg e = ls (T.pack "An exception has occured: ") <> showLS e+++-------------------------------------------------------------------------------+-- | Log a message without any payload/context or code location.+logMsg+ :: (Applicative m, Katip m)+ => Namespace+ -> Severity+ -> LogStr+ -> m ()+logMsg ns sev msg = logF () ns sev msg+++instance TH.Lift Namespace where+ lift (Namespace xs) =+ let xs' = map T.unpack xs+ in [| Namespace (map T.pack xs') |]+++instance TH.Lift Verbosity where+ lift V0 = [| V0 |]+ lift V1 = [| V1 |]+ lift V2 = [| V2 |]+ lift V3 = [| V3 |]+++instance TH.Lift Severity where+ lift DebugS = [| DebugS |]+ lift InfoS = [| InfoS |]+ lift NoticeS = [| NoticeS |]+ lift WarningS = [| WarningS |]+ lift ErrorS = [| ErrorS |]+ lift CriticalS = [| CriticalS |]+ lift AlertS = [| AlertS |]+ lift EmergencyS = [| EmergencyS |]+++-- | Lift a location into an Exp.+liftLoc :: Loc -> Q Exp+liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc+ $(TH.lift a)+ $(TH.lift b)+ $(TH.lift c)+ ($(TH.lift d1), $(TH.lift d2))+ ($(TH.lift e1), $(TH.lift e2))+ |]+++-------------------------------------------------------------------------------+-- | For use when you want to include location in your logs. This will+-- fill the 'Maybe Loc' gap in 'logF' of this module.+getLoc :: Q Exp+getLoc = [| $(location >>= liftLoc) |]+++-------------------------------------------------------------------------------+-- | 'Loc'-tagged logging when using template-haskell.+--+-- @$(logT) obj mempty InfoS "Hello world"@+logT :: ExpQ+logT = [| \ a ns sev msg -> logItem a ns (Just $(getLoc)) sev msg |]+++-- taken from the file-location package+-- turn the TH Loc loaction information into a human readable string+-- leaving out the loc_end parameter+locationToString :: Loc -> String+locationToString loc = (loc_package loc) ++ ':' : (loc_module loc) +++ ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)+ where+ line = show . fst . loc_start+ char = show . snd . loc_start
+ src/Katip/Monadic.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Provides support for treating payloads and namespaces as+-- composable contexts. The common pattern would be to provide a+-- 'KatipContext' instance for your base monad.+module Katip.Monadic+ (+ -- * Monadic variants of logging functions from "Katip.Core"+ logFM+ , logTM+ , logItemM+ , logExceptionM++ -- * Machinery for merging typed log payloads/contexts+ , KatipContext(..)+ , AnyLogContext+ , LogContexts+ , liftPayload++ -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances+ , KatipContextT(..)+ , runKatipContextT+ , KatipContextTState(..)+ ) where+++-------------------------------------------------------------------------------+import Control.Applicative+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Error.Class+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Control+import Control.Monad.Trans.Either (EitherT)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Trans.List (ListT)+import Control.Monad.Trans.Maybe (MaybeT)+import Control.Monad.Trans.Resource (ResourceT)+import Control.Monad.Trans.RWS (RWST)+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST)+import qualified Control.Monad.Trans.State.Strict as Strict (StateT)+import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT)+import Control.Monad.Writer+import Data.Aeson+import qualified Data.HashMap.Strict as HM+import Data.Monoid as M+import Data.Text (Text)+import Language.Haskell.TH+-------------------------------------------------------------------------------+import Katip.Core+-------------------------------------------------------------------------------++-- | A wrapper around a log context that erases type information so+-- that contexts from multiple layers can be combined intelligently.+data AnyLogContext where+ AnyLogContext :: (LogItem a) => a -> AnyLogContext+++-------------------------------------------------------------------------------+-- | Heterogeneous list of log contexts that provides a smart+-- 'LogContext' instance for combining multiple payload policies. This+-- is critical for log contexts deep down in a stack to be able to+-- inject their own context without worrying about other context that+-- has already been set.+newtype LogContexts = LogContexts [AnyLogContext] deriving (Monoid)++instance ToJSON LogContexts where+ toJSON (LogContexts cs) =+ Object $ mconcat $ map (\(AnyLogContext v) -> toObject v) cs++instance ToObject LogContexts++instance LogItem LogContexts where+ payloadKeys verb (LogContexts vs) = mconcat $ map payloadKeys' vs+ where+ -- To ensure AllKeys doesn't leak keys from other values when+ -- combined, we resolve AllKeys to its equivalent SomeKeys+ -- representation first.+ payloadKeys' (AnyLogContext v) = case payloadKeys verb v of+ AllKeys -> SomeKeys $ HM.keys $ toObject v+ x -> x+++-------------------------------------------------------------------------------+-- | Lift a log context into the generic wrapper so that it can+-- combine with the existing log context.+liftPayload :: (LogItem a) => a -> LogContexts+liftPayload = LogContexts . (:[]) . AnyLogContext+++-------------------------------------------------------------------------------+-- | A monadic context that has an inherant way to get logging+-- context and namespace. Examples include a web application monad or+-- database monad.+class Katip m => KatipContext m where+ getKatipContext :: m LogContexts+ getKatipNamespace :: m Namespace++--TODO: is this INLINABLE?+#define TRANS(T) \+ instance (KatipContext m, Katip (T m)) => KatipContext (T m) where \+ getKatipContext = lift getKatipContext; \+ getKatipNamespace = lift getKatipNamespace++#define TRANS_CTX(CTX, T) \+ instance (CTX, KatipContext m, Katip (T m)) => KatipContext (T m) where \+ getKatipContext = lift getKatipContext; \+ getKatipNamespace = lift getKatipNamespace++TRANS(IdentityT)+TRANS(MaybeT)+TRANS(EitherT e)+TRANS(ListT)+TRANS(ReaderT r)+TRANS(ResourceT)+TRANS(Strict.StateT s)+TRANS(StateT s)+TRANS(ExceptT s)+TRANS_CTX(Monoid w, Strict.WriterT w)+TRANS_CTX(Monoid w, WriterT w)+TRANS_CTX(Monoid w, Strict.RWST r w s)+TRANS_CTX(Monoid w, RWST r w s)++deriving instance (Monad m, KatipContext m) => KatipContext (KatipT m)++-------------------------------------------------------------------------------+-- | Log with everything, including a source code location. This is+-- very low level and you typically can use 'logTM' in its+-- place. Automaticallysupplies payload and namespace.+logItemM+ :: (Applicative m, KatipContext m, Katip m)+ => Maybe Loc+ -> Severity+ -> LogStr+ -> m ()+logItemM loc sev msg = do+ ctx <- getKatipContext+ ns <- getKatipNamespace+ logItem ctx ns loc sev msg++++-------------------------------------------------------------------------------+-- | Log with full context, but without any code+-- location. Automatically supplies payload and namespace.+logFM+ :: (Applicative m, KatipContext m, Katip m)+ => Severity+ -- ^ Severity of the message+ -> LogStr+ -- ^ The log message+ -> m ()+logFM sev msg = do+ ctx <- getKatipContext+ ns <- getKatipNamespace+ logF ctx ns sev msg+++-------------------------------------------------------------------------------+-- | 'Loc'-tagged logging when using template-haskell. Automatically+-- supplies payload and namespace.+--+-- @$(logt) InfoS "Hello world"@+logTM :: ExpQ+logTM = [| logItemM (Just $(getLoc)) |]+++-------------------------------------------------------------------------------+-- | Perform an action while logging any exceptions that may occur.+-- Inspired by 'onException`.+--+-- >>>> error "foo" `logExceptionM` ErrorS+logExceptionM+ :: (KatipContext m, MonadCatch m, Applicative m)+ => m a -- ^ Main action to run+ -> Severity -- ^ Severity+ -> m a+logExceptionM action sev = action `catchAll` \e -> f e >> throwM e+ where+ f e = logFM sev (msg e)+ msg e = ls ("An exception has occured: " :: Text) M.<> showLS e+++-------------------------------------------------------------------------------+-- | Provides a simple transformer that defines a 'KatipContext'+-- instance for a fixed namespace and context. You will typically only+-- use this if you are forced to run in IO but still want to have your+-- log context. This is the slightly more powerful version of KatipT+-- in that it provides KatipContext instead of just Katip. For instance:+--+-- @+-- threadWithLogging = do+-- le <- getLogEnv+-- ctx <- getKatipContext+-- ns <- getKatipNamespace+-- forkIO $ runKatipContextT le ctx ns $ do+-- $(logTM) InfoS "Look, I can log in IO and retain context!"+-- doOtherStuff+-- @+newtype KatipContextT m a = KatipContextT {+ unKatipContextT :: ReaderT KatipContextTState m a+ } deriving ( Functor+ , Applicative+ , Monad+ , MonadIO+ , MonadThrow+ , MonadCatch+ , MonadMask+ , MonadBase b+ , MonadState s+ , MonadWriter w+ , MonadError e+ , MonadPlus+ , Alternative+ , MonadFix+ , MonadTrans+ )+++data KatipContextTState = KatipContextTState {+ ltsLogEnv :: !LogEnv+ , ltsContext :: !LogContexts+ , ltsNamespace :: !Namespace+ }+++instance MonadTransControl KatipContextT where+ type StT KatipContextT a = StT (ReaderT KatipContextTState) a+ liftWith = defaultLiftWith KatipContextT unKatipContextT+ restoreT = defaultRestoreT KatipContextT+ {-# INLINE liftWith #-}+ {-# INLINE restoreT #-}+++instance (MonadBaseControl b m) => MonadBaseControl b (KatipContextT m) where+ type StM (KatipContextT m) a = ComposeSt KatipContextT m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM+++-- Reader is a passthrough. We don't expose our internal reader so as not to conflict+instance (MonadReader r m) => MonadReader r (KatipContextT m) where+ ask = lift ask+ local f (KatipContextT (ReaderT m)) = KatipContextT $ ReaderT $ \r ->+ local f (m r)+++instance (MonadIO m) => Katip (KatipContextT m) where+ getLogEnv = KatipContextT $ ReaderT $ \lts -> return (ltsLogEnv lts)+++instance (MonadIO m) => KatipContext (KatipContextT m) where+ getKatipContext = KatipContextT $ ReaderT $ \lts -> return (ltsContext lts)+ getKatipNamespace = KatipContextT $ ReaderT $ \lts -> return (ltsNamespace lts)+++-------------------------------------------------------------------------------+runKatipContextT :: (LogItem c) => LogEnv -> c -> Namespace -> KatipContextT m a -> m a+runKatipContextT le ctx ns = flip runReaderT lts . unKatipContextT+ where+ lts = KatipContextTState le (liftPayload ctx) ns
+ src/Katip/Scribes/Handle.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE RecordWildCards #-}++module Katip.Scribes.Handle where++-------------------------------------------------------------------------------+import Control.Lens+import Control.Monad+import Data.Aeson.Lens+import qualified Data.HashMap.Strict as HM+import Data.Monoid+import Data.Text.Lazy.Builder+import Data.Text.Lazy.IO as T+import Data.Time+import qualified Data.Time.Locale.Compat as LC+import System.IO+import System.IO.Unsafe (unsafePerformIO)+-------------------------------------------------------------------------------+import Katip.Core+-------------------------------------------------------------------------------+++-------------------------------------------------------------------------------+brackets :: Builder -> Builder+brackets m = fromText "[" <> m <> fromText "]"+++-------------------------------------------------------------------------------+getKeys :: LogItem s => Verbosity -> s -> [Builder]+getKeys verb a = payloadObject verb a ^..+ to HM.toList . traverse . to rendPair+ where+ rendPair (k,v) = fromText k <> fromText ":" <> (v ^. _Primitive . to renderPrim)+++-------------------------------------------------------------------------------+renderPrim :: Primitive -> Builder+renderPrim (StringPrim t) = fromText t+renderPrim (NumberPrim s) = fromString (show s)+renderPrim (BoolPrim b) = fromString (show b)+renderPrim NullPrim = fromText "null"+++-------------------------------------------------------------------------------+data ColorStrategy+ = ColorLog Bool+ -- ^ Whether to use color control chars in log output+ | ColorIfTerminal+ -- ^ Color if output is a terminal+++-------------------------------------------------------------------------------+-- | Logs to a file handle such as stdout, stderr, or a file.+mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe+mkHandleScribe cs h sev verb = do+ hSetBuffering h LineBuffering+ colorize <- case cs of+ ColorIfTerminal -> hIsTerminalDevice h+ ColorLog b -> return b+ return $ Scribe $ \ i@Item{..} -> do+ when (permitItem sev i) $+ T.hPutStrLn h $ toLazyText $ formatItem colorize verb i+++-------------------------------------------------------------------------------+formatItem :: LogItem a => Bool -> Verbosity -> Item a -> Builder+formatItem withColor verb Item{..} =+ brackets nowStr <>+ brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>+ brackets (fromText (renderSeverity' _itemSeverity)) <>+ brackets (fromString _itemHost) <>+ brackets (fromString (show _itemProcess)) <>+ brackets (fromText (getThreadIdText _itemThread)) <>+ mconcat ks <>+ maybe mempty (brackets . fromString . locationToString) _itemLoc <>+ fromText " " <> (unLogStr _itemMessage)+ where+ nowStr = fromString $ formatTime LC.defaultTimeLocale "%Y-%m-%d %H:%M:%S" _itemTime+ ks = map brackets $ getKeys verb _itemPayload+ renderSeverity' s = case s of+ EmergencyS -> red $ renderSeverity s+ AlertS -> red $ renderSeverity s+ CriticalS -> red $ renderSeverity s+ ErrorS -> red $ renderSeverity s+ WarningS -> yellow $ renderSeverity s+ _ -> renderSeverity s+ red = colorize "31"+ yellow = colorize "33"+ colorize c s+ | withColor = "\ESC["<> c <> "m" <> s <> "\ESC[0m"+ | otherwise = s+++-------------------------------------------------------------------------------+-- | An implicit environment to enable logging directly ouf of the IO monad.+_ioLogEnv :: LogEnv+_ioLogEnv = unsafePerformIO $ do+ le <- initLogEnv "io" "io"+ lh <- mkHandleScribe ColorIfTerminal stdout DebugS V3+ return $ registerScribe "stdout" lh le+{-# NOINLINE _ioLogEnv #-}+++-- -------------------------------------------------------------------------------+-- -- | A default IO instance to make prototype development easy. User+-- -- your own 'Monad' for production.+-- instance Katip IO where getLogEnv = return _ioLogEnv
+ test/Katip/Tests.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Katip.Tests+ ( tests+ ) where+++-------------------------------------------------------------------------------+import Control.Applicative+import Data.Aeson+import qualified Data.Text.Lazy.Builder as B+import Data.Time+import Data.Time.Clock.POSIX+import Language.Haskell.TH+import System.Posix.Types+import Test.QuickCheck.Instances ()+import Test.Tasty+import Test.Tasty.QuickCheck+-------------------------------------------------------------------------------+import Katip+-------------------------------------------------------------------------------+++tests :: TestTree+tests = testGroup "Katip"+ [+ testProperty "JSON cycle Item" $ \(i :: Item ()) ->+ prop_json_cycle i+ ]+++-------------------------------------------------------------------------------+prop_json_cycle :: (ToJSON a, FromJSON a, Eq a, Show a) => a -> Property+prop_json_cycle a = eitherDecode (encode a) === Right a+++-------------------------------------------------------------------------------+instance Arbitrary a => Arbitrary (Item a) where+ arbitrary = Item+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> (getCleanUTCTime <$> arbitrary)+ <*> arbitrary+ <*> arbitrary+++-------------------------------------------------------------------------------+newtype CleanUTCTime = CleanUTCTime {+ getCleanUTCTime :: UTCTime+ }+++-------------------------------------------------------------------------------+-- Work around time parsing precision issues in aeson+instance Arbitrary CleanUTCTime where+ arbitrary = CleanUTCTime . posixSecondsToUTCTime . fromInteger <$> arbitrary+++-------------------------------------------------------------------------------+deriving instance Arbitrary Namespace+deriving instance Arbitrary Environment+deriving instance Arbitrary ThreadIdText+deriving instance Arbitrary CPid+deriving instance Eq LogStr+deriving instance (Eq a) => Eq (Item a)+++-------------------------------------------------------------------------------+instance Arbitrary Loc where+ arbitrary = do+ f <- arbitrary+ p <- arbitrary+ m <- arbitrary+ s <- arbitrary+ return $ Loc f p m s s+++-------------------------------------------------------------------------------+instance Arbitrary Severity where+ arbitrary = oneof $ map pure [ DebugS+ , InfoS+ , NoticeS+ , WarningS+ , ErrorS+ , CriticalS+ , AlertS+ , EmergencyS+ ]+++-------------------------------------------------------------------------------+instance Arbitrary LogStr where+ arbitrary = LogStr . B.fromText <$> arbitrary
+ test/Katip/Tests/Scribes/Handle.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}+module Katip.Tests.Scribes.Handle+ ( tests+ ) where++-------------------------------------------------------------------------------+import Control.Monad+import Data.Aeson+import Data.Text (Text)+import qualified Data.Text.IO as T+import System.Directory+import System.IO+import System.IO.Temp+import Test.Tasty+import Test.Tasty.HUnit+import Text.Regex.TDFA+-------------------------------------------------------------------------------+import Katip+-------------------------------------------------------------------------------+++tests :: TestTree+tests = testGroup "Katip.Scribes.Handle"+ [+ withResource setup teardown $ \setupScribe -> testCase "logs the correct data" $ do+ (path, h, le) <- setupScribe+ runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"+ hClose h+ res <- readFile path+ let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note:some note\\] test message" :: String+ let matches = res =~ pat+ matches @?= True+ ]+++-------------------------------------------------------------------------------+data DummyLogItem = DummyLogItem {+ dliNote :: Text+ }+++instance ToJSON DummyLogItem where+ toJSON (DummyLogItem n) = object ["note" .= n]+++instance ToObject DummyLogItem+++instance LogItem DummyLogItem where+ payloadKeys _ _ = AllKeys+++-------------------------------------------------------------------------------+dummyLogItem :: DummyLogItem+dummyLogItem = DummyLogItem "some note"+++-------------------------------------------------------------------------------+setup :: IO (FilePath, Handle, LogEnv)+setup = do+ tempDir <- getTemporaryDirectory+ (fp, h) <- openTempFile tempDir "katip.log"+ s <- mkHandleScribe (ColorLog False) h DebugS V3+ le <- initLogEnv "katip-test" "test"+ return (fp, h, registerScribe "handle" s le)+++-------------------------------------------------------------------------------+teardown :: (FilePath, Handle, LogEnv) -> IO ()+teardown (_, h, _) = do+ chk <- hIsOpen h+ when chk $ hClose h
+ test/Main.hs view
@@ -0,0 +1,19 @@+module Main (main) where++-------------------------------------------------------------------------------+import Test.Tasty+-------------------------------------------------------------------------------+import qualified Katip.Tests+import qualified Katip.Tests.Scribes.Handle+-------------------------------------------------------------------------------+++main :: IO ()+main = defaultMain testSuite++testSuite :: TestTree+testSuite = testGroup "katip"+ [+ Katip.Tests.tests+ , Katip.Tests.Scribes.Handle.tests+ ]