diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,80 @@ +# Katip [![Build Status](https://travis-ci.org/Soostone/katip.svg?branch=master)](https://travis-ci.org/Soostone/katip) + +Katip is a structured logging framework for Haskell. + +![Katip](./katip.jpg) + +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) 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/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 _) = () diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,4 @@ +0.1.0.0 +============== + +Initial release diff --git a/examples/example.hs b/examples/example.hs new file mode 100644 --- /dev/null +++ b/examples/example.hs @@ -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 diff --git a/examples/example_lens.hs b/examples/example_lens.hs new file mode 100644 --- /dev/null +++ b/examples/example_lens.hs @@ -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 diff --git a/katip.cabal b/katip.cabal new file mode 100644 --- /dev/null +++ b/katip.cabal @@ -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 diff --git a/src/Katip.hs b/src/Katip.hs new file mode 100644 --- /dev/null +++ b/src/Katip.hs @@ -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 +------------------------------------------------------------------------------- diff --git a/src/Katip/Core.hs b/src/Katip/Core.hs new file mode 100644 --- /dev/null +++ b/src/Katip/Core.hs @@ -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 diff --git a/src/Katip/Monadic.hs b/src/Katip/Monadic.hs new file mode 100644 --- /dev/null +++ b/src/Katip/Monadic.hs @@ -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 diff --git a/src/Katip/Scribes/Handle.hs b/src/Katip/Scribes/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Katip/Scribes/Handle.hs @@ -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 diff --git a/test/Katip/Tests.hs b/test/Katip/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Katip/Tests.hs @@ -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 diff --git a/test/Katip/Tests/Scribes/Handle.hs b/test/Katip/Tests/Scribes/Handle.hs new file mode 100644 --- /dev/null +++ b/test/Katip/Tests/Scribes/Handle.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ]