@@ -0,0 +1,255 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE StandaloneDeriving #-}
7+{-# LANGUAGE TemplateHaskell #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+
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
17+-- namespace.
18+module Katip.Monadic
19+ (
20+ -- * Monadic variants of logging functions from "Katip.Core"
21+ logfM
22+ , logtM
23+ , logItemM
24+
25+ -- * Machinery for merging typed log payloads/contexts
26+ , ContextualLog(..)
27+ , AnyLogContext
28+ , LogContexts
29+ , liftPayload
30+
31+ -- * Transformer for appending to a log context
32+ , ContextualLogT'
33+ , ContextualLogT
34+ , runContextualLogT
35+ ) where
36+
37+
38+-------------------------------------------------------------------------------
39+import Control.Applicative
40+import Control.Monad
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)
60+import Data.Aeson
61+import qualified Data.HashMap.Strict as HM
62+import Data.Monoid
63+import Language.Haskell.TH
64+-------------------------------------------------------------------------------
65+import Katip.Core
66+-------------------------------------------------------------------------------
67+
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
72+
73+
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)
78+
79+instance ToJSON LogContexts where
80+ toJSON (LogContexts cs) =
81+ Object $ mconcat $ map (\(AnyLogContext v) -> toObject v) cs
82+
83+instance ToObject LogContexts
84+
85+instance LogContext LogContexts where
86+ payloadKeys verb (LogContexts vs) = mconcat $ map payloadKeys' vs
87+ where
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
93+ x -> x
94+
95+
96+-------------------------------------------------------------------------------
97+-- | Lift a log context into the generic wrapper
98+liftPayload :: (LogContext a) => a -> LogContexts
99+liftPayload = LogContexts . (:[]) . AnyLogContext
100+
101+
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
109+
110+--TODO: is this INLINABLE?
111+#define TRANS(T) \
112+ instance (ContextualLog m, Monad m) => ContextualLog (T m) where \
113+ getLogContexts = lift getLogContexts; \
114+ getNamespace = lift getNamespace
115+
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
120+
121+TRANS(IdentityT)
122+TRANS(MaybeT)
123+TRANS(ListT)
124+TRANS(ReaderT r)
125+TRANS(Strict.StateT s)
126+TRANS(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)
132+
133+deriving instance (Monad m, ContextualLog m) => ContextualLog (KatipT m)
134+
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.
139+logItemM
140+ :: (Applicative m, ContextualLog m, Katip m)
141+ => Maybe Loc
142+ -> Severity
143+ -> LogStr
144+ -> m ()
145+logItemM loc sev msg = do
146+ ctx <- getLogContexts
147+ ns <- getNamespace
148+ logItem ctx ns loc sev msg
149+
150+
151+
152+-------------------------------------------------------------------------------
153+-- | Log with full context, but without any code
154+-- location. Automatically supplies payload and namespace.
155+logfM
156+ :: (Applicative m, ContextualLog m, Katip m)
157+ => Severity
158+ -- ^ Severity of the message
159+ -> LogStr
160+ -- ^ The log message
161+ -> m ()
162+logfM sev msg = do
163+ ctx <- getLogContexts
164+ ns <- getNamespace
165+ logf ctx ns sev msg
166+
167+
168+-------------------------------------------------------------------------------
169+-- | 'Loc'-tagged logging when using template-haskell is OK. Automatically supplies payload and namespace.
170+--
171+-- @$(logt) InfoS "Hello world"@
172+logtM :: ExpQ
173+logtM = [| logItemM (Just $(getLoc)) |]
174+
175+
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
180+-- instance.
181+--
182+-- @
183+-- instance ContextualLog m WebMonad where
184+-- getLogContexts = ...
185+-- getNamespace = Namespace ["web"]
186+--
187+-- dbCallInWeb = runContextualLogT getDBContext (Namespace ["db"]) $ do
188+-- someStuff
189+-- @
190+--
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"]@.
194+--
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
200+ , Applicative
201+ , Monad
202+ , MonadIO
203+ , MonadThrow
204+ , MonadCatch
205+ , MonadBase b
206+ , MonadState s
207+ , MonadWriter w
208+ , MonadError e
209+ , MonadPlus
210+ , MonadFix
211+ , Katip
212+ )
213+
214+type ContextualLogT m a = ContextualLogT' m m a
215+
216+instance MonadTrans (ContextualLogT' n) where
217+ lift = ContextualLogT . lift
218+
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
221+ ask = lift ask
222+ local f (ContextualLogT (ReaderT m)) = ContextualLogT $ ReaderT $ \r ->
223+ local f (m r)
224+
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 #-}
231+
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
236+
237+instance (ContextualLog m, Monad m) => ContextualLog (ContextualLogT' m m) where
238+ getLogContexts = ContextualLogT $ ReaderT $ \(gctxs, _) -> do
239+ ctxs <- gctxs
240+ ctxs' <- getLogContexts
241+ return $ ctxs <> ctxs'
242+ getNamespace = ContextualLogT $ ReaderT $ \(_, getNsInner) -> do
243+ nsOuter <- getNamespace
244+ nsInner <- getNsInner
245+ return $ nsOuter <> nsInner
246+
247+
248+runContextualLogT
249+ :: (Functor m, LogContext a)
250+ => m a
251+ -> m Namespace
252+ -> ContextualLogT m b
253+ -> m b
254+runContextualLogT lgtr nsgtr m = runReaderT (unContextualLogT m) (liftPayload <$> lgtr, nsgtr)
255+