katip-reference.hs

#!/usr/bin/env stack
{- stack --install-ghc
    --resolver lts-10.7
    script
    --compile
    --package katip
    --package universum
    --package aeson
-}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE NoImplicitPrelude #-}

import Data.Aeson
import Katip
import Katip.Monadic
import Universum

main = do
  loggingBracket $ \logging ->
    runKatipContextT (ltsLogEnv logging) (ltsContext logging) (ltsNamespace logging) app

newtype FlowId = FlowId Text

instance LogItem FlowId where
  payloadKeys _ _ = AllKeys

instance ToObject FlowId where
  toObject (FlowId flowid) = ["flowId" .= flowid, "test" .= ("bar" :: Text)]

app :: KatipContext m => m ()
app = do
  katipAddNamespace (Namespace ["cont"]) $ katipAddContext (FlowId "foo") $ logFM InfoS "Foobar"

makeLogEnv :: IO LogEnv
makeLogEnv = do
  let env = (Environment "start")
  handleScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2
  registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv (Namespace ["TestService"]) env

loggingBracket :: (KatipContextTState -> IO c) -> IO c
loggingBracket fun = do
  bracket makeLogEnv closeScribes $ \le -> do
    let
      logging = KatipContextTState
        { ltsLogEnv = le
        , ltsContext = liftPayload () -- this context will be attached to every log in your app and merged w/ subsequent contexts
        , ltsNamespace = "main"
        }
    fun logging