katip-0.8.8.4: examples/example_lens.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Main
  ( main,
  )
where

-------------------------------------------------------------------------------
import Control.Applicative as A
import Control.Exception
import Control.Lens hiding ((.=))
import Control.Monad.Base
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.Aeson
import Data.Monoid as M
-------------------------------------------------------------------------------
import Katip
import System.IO (stdout)

-------------------------------------------------------------------------------

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 with Lens.
main :: IO ()
main = do
  -- 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. 'closeScribes' is
  -- blocking and flushes all messages out of a scribe and cleans up
  -- resources that were allocated at creation.
  handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V2
  let mkLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"
  bracket mkLogEnv closeScribes $ \le -> do
    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.
      katipAddNamespace "confrabulation" $
        katipAddContext (ConfrabLogCTX 42) $ do
          $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"
          confrabulateWidgets
      $(logTM) InfoS "Namespace and context are back to normal"
      katipNoLogging $
        $(logTM) DebugS "You'll never see this log message!"

-------------------------------------------------------------------------------
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, A.Applicative, Monad, MonadIO, MonadTrans)

-- MonadBase, MonadTransControl, and MonadBaseControl aren't strictly
-- needed for this example, but they are commonly required and
-- MonadTransControl/MonadBaseControl are a pain to implement, so I've
-- included them. Note that KatipT and KatipContextT already do this work for you.
instance MonadBase b m => MonadBase b (MyStack m) where
  liftBase = liftBaseDefault

instance MonadTransControl MyStack where
  type StT MyStack a = StT (ReaderT Int) a
  liftWith = defaultLiftWith MyStack unStack
  restoreT = defaultRestoreT MyStack

instance MonadBaseControl b m => MonadBaseControl b (MyStack m) where
  type StM (MyStack m) a = ComposeSt MyStack m a
  liftBaseWith = defaultLiftBaseWith
  restoreM = defaultRestoreM

instance (MonadIO m) => Katip (MyStack m) where
  getLogEnv = view msLogEnv
  localLogEnv f (MyStack m) = MyStack (local (over msLogEnv f) m)

instance (MonadIO m) => KatipContext (MyStack m) where
  getKatipContext = view msKContext
  localKatipContext f (MyStack m) = MyStack (local (over msKContext f) m)
  getKatipNamespace = view msKNamespace
  localKatipNamespace f (MyStack m) = MyStack (local (over msKNamespace f) m)

-------------------------------------------------------------------------------
runStack :: MyState -> MyStack m a -> m a
runStack s f = runReaderT (unStack f) s