@@ -0,0 +1,255 @@
2+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE StandaloneDeriving #-}
7+{-# LANGUAGE TemplateHaskell #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE UndecidableInstances #-}
11+-- | Provides support for treating payloads and namespaces as
12+-- composable contexts. The common pattern would be to provide a
13+-- 'ContextualLog' instance for your base monad. When your program
14+-- changes to a more detailed context, say to the database, you can
15+-- use 'ContextualLogT' to tack on a typed context and a namespace
16+-- which will be merged into the enclosing monad's context and
20+ -- * Monadic variants of logging functions from "Katip.Core"
25+ -- * Machinery for merging typed log payloads/contexts
31+ -- * Transformer for appending to a log context
38+-------------------------------------------------------------------------------
39+import Control.Applicative
41+import Control.Monad.Base
42+import Control.Monad.Catch
43+import Control.Monad.Error.Class
44+import Control.Monad.Fix
45+import Control.Monad.IO.Class
46+import Control.Monad.RWS.Class
47+import Control.Monad.Trans.Class
48+import Control.Monad.Trans.Control
49+import Control.Monad.Trans.Error (ErrorT)
50+import Control.Monad.Trans.Identity (IdentityT)
51+import Control.Monad.Trans.List (ListT)
52+import Control.Monad.Trans.Maybe (MaybeT)
53+import Control.Monad.Trans.Reader (ReaderT (..), runReaderT)
54+import Control.Monad.Trans.RWS (RWST)
55+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST)
56+import Control.Monad.Trans.State (StateT)
57+import qualified Control.Monad.Trans.State.Strict as Strict (StateT)
58+import Control.Monad.Trans.Writer (WriterT)
59+import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT)
61+import qualified Data.HashMap.Strict as HM
63+import Language.Haskell.TH
64+-------------------------------------------------------------------------------
66+-------------------------------------------------------------------------------
68+-- | A wrapper around a log context that erases type information so
69+-- that contexts from multiple layers can be combined intelligently.
70+data AnyLogContext where
71+ AnyLogContext :: (LogContext a) => a -> AnyLogContext
74+-------------------------------------------------------------------------------
75+-- | Heterogeneous list of log contexts that provides a smart
76+-- 'LogContext' instance for combining multiple payload policies.
77+newtype LogContexts = LogContexts [AnyLogContext] deriving (Monoid)
79+instance ToJSON LogContexts where
80+ toJSON (LogContexts cs) =
81+ Object $ mconcat $ map (\(AnyLogContext v) -> toObject v) cs
83+instance ToObject LogContexts
85+instance LogContext LogContexts where
86+ payloadKeys verb (LogContexts vs) = mconcat $ map payloadKeys' vs
88+ -- To ensure AllKeys doesn't leak keys from other values when
89+ -- combined, we resolve AllKeys to its equivalent SomeKeys
90+ -- representation first.
91+ payloadKeys' (AnyLogContext v) = case payloadKeys verb v of
92+ AllKeys -> SomeKeys $ HM.keys $ toObject v
96+-------------------------------------------------------------------------------
97+-- | Lift a log context into the generic wrapper
98+liftPayload :: (LogContext a) => a -> LogContexts
99+liftPayload = LogContexts . (:[]) . AnyLogContext
102+-------------------------------------------------------------------------------
103+-- | A monadic context that has an inherant way to get logging
104+-- context and namespace. Examples include a web application monad or
105+-- database monad. Combine with 'ContextualLogT' to nest.
106+class ContextualLog m where
107+ getLogContexts :: m LogContexts
108+ getNamespace :: m Namespace
110+--TODO: is this INLINABLE?
112+ instance (ContextualLog m, Monad m) => ContextualLog (T m) where \
113+ getLogContexts = lift getLogContexts; \
114+ getNamespace = lift getNamespace
116+#define TRANS_CTX(CTX, T) \
117+ instance (CTX, ContextualLog m, Monad m) => ContextualLog (T m) where \
118+ getLogContexts = lift getLogContexts; \
119+ getNamespace = lift getNamespace
125+TRANS(Strict.StateT s)
127+TRANS_CTX(Error e, ErrorT e)
128+TRANS_CTX(Monoid w, Strict.WriterT w)
129+TRANS_CTX(Monoid w, WriterT w)
130+TRANS_CTX(Monoid w, Strict.RWST r w s)
131+TRANS_CTX(Monoid w, RWST r w s)
133+deriving instance (Monad m, ContextualLog m) => ContextualLog (KatipT m)
135+-------------------------------------------------------------------------------
136+-- | Log with everything, including a source code location. This is
137+-- very low level and you typically can use 'logtM' in its
138+-- place. Automaticallysupplies payload and namespace.
140+ :: (Applicative m, ContextualLog m, Katip m)
145+logItemM loc sev msg = do
146+ ctx <- getLogContexts
148+ logItem ctx ns loc sev msg
152+-------------------------------------------------------------------------------
153+-- | Log with full context, but without any code
154+-- location. Automatically supplies payload and namespace.
156+ :: (Applicative m, ContextualLog m, Katip m)
158+ -- ^ Severity of the message
160+ -- ^ The log message
163+ ctx <- getLogContexts
168+-------------------------------------------------------------------------------
169+-- | 'Loc'-tagged logging when using template-haskell is OK. Automatically supplies payload and namespace.
171+-- @$(logt) InfoS "Hello world"@
173+logtM = [| logItemM (Just $(getLoc)) |]
176+-------------------------------------------------------------------------------
177+-- | Wrapper over 'ReaderT' that provides a passthrough instance for
178+-- 'MonadReader' so your stack will not be affected. Also provides a
179+-- 'ContextualLog' instance which combines with the inner monad's
183+-- instance ContextualLog m WebMonad where
184+-- getLogContexts = ...
185+-- getNamespace = Namespace ["web"]
187+-- dbCallInWeb = runContextualLogT getDBContext (Namespace ["db"]) $ do
191+-- In the above example, any logging inside of @dbCallInWeb@ will get
192+-- the (optionally) monadic log context for the db, combine it with
193+-- the web server's and will use the namespace @Namespace ["web","db"]@.
195+-- 'ContextualLogT' is exported which fixes @n ~ m@. The two type
196+-- variables must be present for defining a 'MonadTransControl' instance.
197+newtype ContextualLogT' n m a = ContextualLogT {
198+ unContextualLogT :: ReaderT (n LogContexts, n Namespace) m a
199+ } deriving ( Functor
214+type ContextualLogT m a = ContextualLogT' m m a
216+instance MonadTrans (ContextualLogT' n) where
217+ lift = ContextualLogT . lift
219+-- Reader is a passthrough. We don't expose our internal reader so as not to conflict
220+instance (MonadReader r m) => MonadReader r (ContextualLogT' n m) where
222+ local f (ContextualLogT (ReaderT m)) = ContextualLogT $ ReaderT $ \r ->
225+instance MonadTransControl (ContextualLogT' n) where
226+ type StT (ContextualLogT' n) a = StT (ReaderT (n LogContexts)) a
227+ liftWith = defaultLiftWith ContextualLogT unContextualLogT
228+ restoreT = defaultRestoreT ContextualLogT
229+ {-# INLINE liftWith #-}
230+ {-# INLINE restoreT #-}
232+instance (MonadBaseControl b m) => MonadBaseControl b (ContextualLogT' n m) where
233+ type StM ((ContextualLogT' n) m) a = ComposeSt (ContextualLogT' n) m a
234+ liftBaseWith = defaultLiftBaseWith
235+ restoreM = defaultRestoreM
237+instance (ContextualLog m, Monad m) => ContextualLog (ContextualLogT' m m) where
238+ getLogContexts = ContextualLogT $ ReaderT $ \(gctxs, _) -> do
240+ ctxs' <- getLogContexts
241+ return $ ctxs <> ctxs'
242+ getNamespace = ContextualLogT $ ReaderT $ \(_, getNsInner) -> do
243+ nsOuter <- getNamespace
244+ nsInner <- getNsInner
245+ return $ nsOuter <> nsInner
249+ :: (Functor m, LogContext a)
252+ -> ContextualLogT m b
254+runContextualLogT lgtr nsgtr m = runReaderT (unContextualLogT m) (liftPayload <$> lgtr, nsgtr)