git.iko.soy/typeable/katip
on master help sign in
Drop transformers helpers

These ended up being really unintuitive to use and easy to replace with simple helper functions that interact with the user's own transformer stack without necessarily adding more layers.

commit0fb40b6a87e1e8889b1d6d40830870d6e503b1e6 authorMichael Xavier <michael@michaelxavier.net> dateMon 29 Feb 2016, 16:31 (11 years ago) parente7e998a
10 files changed+235−270
compare with master
unifiedsplit
.gitignore+4 .travis.yml+1 katip-elasticsearch/katip-elasticsearch.cabal+25 katip-elasticsearch/src/Katip/Scribes/ElasticSearch.hs+1−1 katip/examples/Main.hs−122 katip/examples/example.hs+92 katip/examples/example_lens.hs+100 katip/katip.cabal+11 katip/src/Katip.hs−6 katip/src/Katip/Monadic.hs+1−141
.gitignore+4
@@ -3,3 +3,7 @@ dist
33cabal.sandbox.config
44TAGS
55.stack-work/
6+*.o
7+*.hi
8+*.dyn_o
9+*.dyn_hi
.travis.yml+1
@@ -38,6 +38,7 @@ script:
3838 - stack $ARGS --no-terminal test --haddock --no-haddock-deps
3939 - stack $ARGS bench
4040 - stack $ARGS build
41+ - for f in examples/*.hs; do stack $ARGS ghc -- -Wall -Werror $f -o /dev/null; done
4142 - stack $ARGS sdist
4243
4344# Caching so the next build will be fast too.
katip-elasticsearch/katip-elasticsearch.cabal+25
@@ -1,5 +1,27 @@
11name: katip-elasticsearch
22synopsis: ElasticSearch scribe for the Katip logging framework.
3+description:
4+
5+ katip-elasticsearch is a scribe for the Katip logging framework that
6+ sends structured logs to ElasticSearch. Some noteworthy features:
7+
8+ * Built in bounded buffering.
9+
10+ * Configurable pool of logging workers to help with high write
11+ volume.
12+
13+ * Optional field type annotation to avoid mistyping values.
14+
15+ * Optional automatic date sharding, so logs can be filed into
16+ monthly, daily, hourly, every minute indices. You can even specify
17+ your own index routing logic. This pattern can be seen in the ELK
18+ stack as a way of keeping indexes reasonably sized and easy to
19+ optimize, rotate, and manage.
20+
21+ * Customizable retry policy for temporary outages and errors.
22+
23+ * Automatic index and mapping setup.
24+
325version: 0.1.0.0
426license: BSD3
527license-file: LICENSE
@@ -9,6 +31,9 @@ copyright: Soostone Inc, 2015
931category: Data
1032build-type: Simple
1133cabal-version: >=1.10
34+extra-source-files:
35+ bench/Main.hs
36+ test/Main.hs
1237
1338flag lib-Werror
1439 default: False
katip-elasticsearch/src/Katip/Scribes/ElasticSearch.hs+1−1
@@ -79,7 +79,7 @@ data EsScribeCfg = EsScribeCfg {
7979 -- mapping, the first log item will set the type and any that
8080 -- don't conform will be *discarded*. If you set this to True,
8181 -- keys will recursively be appended with their ES core
82− -- type. e.g. "id" would become "id::long" and "id::string"
82+ -- type. e.g. "id" would become "id::l" and "id::s"
8383 -- automatically, so they won't conflict. When this library
8484 -- exposes a querying API, we will try to make deserialization and
8585 -- querying transparently remove the type annotations if this is
katip/examples/Main.hsdeleted−122
@@ -1,122 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE MultiParamTypeClasses #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−
5−{-# LANGUAGE NoMonomorphismRestriction #-}
6−
7−
8−module Main where
9−
10−-------------------------------------------------------------------------------
11−import Control.Applicative
12−import Control.Monad.Reader
13−import Data.Aeson
14−import Data.Text
15−-------------------------------------------------------------------------------
16−import Katip
17−import Katip.Scribes.Handle
18−-------------------------------------------------------------------------------
19−
20−
21−
22−main :: IO ()
23−main = runKatipT _ioLogEnv $ do
24− logMsg "example" InfoS "Easy to emit from IO directly!"
25− logF myContext "example" InfoS "Here's a more stateful item."
26− $(logT) myContext "example" InfoS "Here's one with code location."
27− runHandler handler
28−
29−
30−myContext :: MyContext
31−myContext = MyContext "blah" 3
32−
33−data MyContext = MyContext {
34− foo :: Text
35− , bar :: Int
36− }
37−
38−
39−instance ToJSON MyContext where
40− toJSON mc = object ["foo" .= foo mc, "bar" .= bar mc]
41−
42−instance ToObject MyContext
43−
44−instance LogItem MyContext where
45− payloadKeys _ _ = AllKeys
46−
47−-------------------------------------------------------------------------------
48−type Handler a = WebT (KatipT IO) a
49−
50−
51−runHandler :: Handler a -> KatipT IO a
52−runHandler h = runReaderT (unWebT h) req
53− where
54− req = Request "GET" "/foo/bar" "example.com"
55−
56−withDB :: (ConnInfo -> Handler ()) -> Handler ()
57−withDB f = f $ ConnInfo "1234" "exampledb" ()
58−
59−
60−handler :: Handler ()
61−handler = do
62− $(logTM) InfoS "got request"
63− withDB $ \ci -> do
64− let dbctx = DBLog (ciConnId ci)
65− let ns = Namespace ["db", ciConnDB ci]
66− runLogT (return dbctx) (return ns) $ do
67− liftIO $ putStrLn "DB things!"
68− $(logTM) InfoS "calling db"
69−
70−-------------------------------------------------------------------------------
71−data Request = Request {
72− reqMethod :: Text
73− , reqPath :: Text
74− , reqReferer :: Text
75− }
76−
77−instance ToJSON Request where
78− toJSON req = object [ "method" .= reqMethod req
79− , "path" .= reqPath req
80− , "referer" .= reqReferer req
81− ]
82−
83−instance ToObject Request
84−
85−instance LogItem Request where
86− payloadKeys V3 _ = AllKeys
87− payloadKeys _ _ = SomeKeys ["method", "path"]
88−
89−newtype WebT m a = WebT {
90− unWebT :: ReaderT Request m a
91− } deriving ( Monad
92− , Functor
93− , Applicative
94− , MonadReader Request
95− , MonadTrans
96− , MonadIO
97− , Katip
98− )
99−
100−instance Katip m => KatipContext (WebT m) where
101− getKatipContext = liftM liftPayload ask
102− getKatipNamespace = return $ Namespace ["myApp"]
103−
104−
105−-------------------------------------------------------------------------------
106−data ConnInfo = ConnInfo {
107− ciConnId :: Text
108− , ciConnDB :: Text
109− , ciConn :: ()
110− }
111−
112−data DBLog = DBLog {
113− dblConnId :: Text
114− }
115−
116−instance ToJSON DBLog where
117− toJSON dbl = object ["connId" .= dblConnId dbl]
118−
119−instance ToObject DBLog
120−
121−instance LogItem DBLog where
122− payloadKeys _ _ = AllKeys
katip/examples/example.hsnew file+92
@@ -0,0 +1,92 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE TemplateHaskell #-}
6+module Main
7+ ( main
8+ ) where
9+
10+
11+-------------------------------------------------------------------------------
12+import Control.Monad.Reader
13+import Data.Aeson
14+import Data.Monoid as M
15+-------------------------------------------------------------------------------
16+import Katip
17+-------------------------------------------------------------------------------
18+
19+
20+-- | An example of advanced katip usage. Be sure to check out
21+-- lens_example for a slightly cleaner and more general pattern.
22+main :: IO ()
23+main = do
24+ s <- MyState M.mempty mempty <$> initLogEnv mempty (Environment "production")
25+ runStack s $ do
26+ $(logTM) InfoS "Started"
27+ addNamespace "confrabulation" $ addContext (ConfrabLogCTX 42) $ do
28+ $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"
29+ confrabulateWidgets
30+ $(logTM) InfoS "Namespace and context are back to normal"
31+
32+
33+-------------------------------------------------------------------------------
34+newtype ConfrabLogCTX = ConfrabLogCTX Int
35+
36+
37+instance ToJSON ConfrabLogCTX where
38+ toJSON (ConfrabLogCTX factor) = object ["confrab_factor" .= factor]
39+
40+
41+instance ToObject ConfrabLogCTX
42+
43+
44+instance LogItem ConfrabLogCTX where
45+ payloadKeys _verb _a = AllKeys
46+
47+
48+-------------------------------------------------------------------------------
49+confrabulateWidgets :: (Monad m) => m ()
50+confrabulateWidgets = return ()
51+
52+
53+-------------------------------------------------------------------------------
54+data MyState = MyState {
55+ msKNamespace :: Namespace
56+ , msKContext :: LogContexts
57+ , msLogEnv :: LogEnv
58+ }
59+
60+
61+-------------------------------------------------------------------------------
62+newtype MyStack m a = MyStack {
63+ unStack :: ReaderT MyState m a
64+ } deriving (MonadReader MyState, Functor, Applicative, Monad, MonadIO)
65+
66+
67+instance (MonadIO m) => Katip (MyStack m) where
68+ getLogEnv = asks msLogEnv
69+
70+
71+instance (MonadIO m) => KatipContext (MyStack m) where
72+ getKatipContext = asks msKContext
73+ getKatipNamespace = asks msKNamespace
74+
75+
76+-------------------------------------------------------------------------------
77+-- | Merge some context into the log only for the given block
78+addContext :: (LogItem i, MonadReader MyState m) => i -> m a -> m a
79+addContext i = local (\r -> r { msKContext = msKContext r <> ctxs })
80+ where
81+ ctxs = liftPayload i
82+
83+
84+-------------------------------------------------------------------------------
85+-- | Add a layer of namespace to the logs only for the given block
86+addNamespace :: (MonadReader MyState m) => Namespace -> m a -> m a
87+addNamespace ns = local (\r -> r { msKNamespace = msKNamespace r <> ns })
88+
89+
90+-------------------------------------------------------------------------------
91+runStack :: MyState -> MyStack m a -> m a
92+runStack s f = runReaderT (unStack f) s
katip/examples/example_lens.hsnew file+100
@@ -0,0 +1,100 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE TemplateHaskell #-}
6+module Main
7+ ( main
8+ ) where
9+
10+
11+-------------------------------------------------------------------------------
12+import Control.Lens hiding ((.=))
13+import Control.Monad.Reader
14+import Data.Aeson
15+import Data.Monoid as M
16+-------------------------------------------------------------------------------
17+import Katip
18+-------------------------------------------------------------------------------
19+
20+
21+data MyState = MyState {
22+ _msKNamespace :: Namespace
23+ , _msKContext :: LogContexts
24+ , _msLogEnv :: LogEnv
25+ }
26+
27+
28+-- This gives us HasMyState, which is helpful for complex stacks where
29+-- MyState may be nested somewhere deeper inside a larger data
30+-- structure. You can keep functions that operate on MyState as
31+-- general as possible.
32+makeClassy ''MyState
33+
34+
35+-------------------------------------------------------------------------------
36+-- | An example of advanced katip usage. Be sure to check out
37+-- lens_example for a slightly cleaner and more general pattern.
38+main :: IO ()
39+main = do
40+ s <- MyState M.mempty mempty <$> initLogEnv mempty (Environment "production")
41+ runStack s $ do
42+ $(logTM) InfoS "Started"
43+ addNamespace "confrabulation" $ addContext (ConfrabLogCTX 42) $ do
44+ $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"
45+ confrabulateWidgets
46+ $(logTM) InfoS "Namespace and context are back to normal"
47+
48+
49+-------------------------------------------------------------------------------
50+newtype ConfrabLogCTX = ConfrabLogCTX Int
51+
52+
53+instance ToJSON ConfrabLogCTX where
54+ toJSON (ConfrabLogCTX factor) = object ["confrab_factor" .= factor]
55+
56+
57+instance ToObject ConfrabLogCTX
58+
59+
60+instance LogItem ConfrabLogCTX where
61+ payloadKeys _verb _a = AllKeys
62+
63+
64+-------------------------------------------------------------------------------
65+confrabulateWidgets :: (Monad m) => m ()
66+confrabulateWidgets = return ()
67+
68+
69+-------------------------------------------------------------------------------
70+newtype MyStack m a = MyStack {
71+ unStack :: ReaderT MyState m a
72+ } deriving (MonadReader MyState, Functor, Applicative, Monad, MonadIO)
73+
74+
75+instance (MonadIO m) => Katip (MyStack m) where
76+ getLogEnv = view msLogEnv
77+
78+
79+instance (MonadIO m) => KatipContext (MyStack m) where
80+ getKatipContext = view msKContext
81+ getKatipNamespace = view msKNamespace
82+
83+
84+-------------------------------------------------------------------------------
85+-- | Merge some context into the log only for the given block
86+addContext :: (LogItem i, MonadReader r m, HasMyState r) => i -> m a -> m a
87+addContext i = local (\r -> r & msKContext <>~ ctxs)
88+ where
89+ ctxs = liftPayload i
90+
91+
92+-------------------------------------------------------------------------------
93+-- | Add a layer of namespace to the logs only for the given block
94+addNamespace :: (MonadReader r m, HasMyState r) => Namespace -> m a -> m a
95+addNamespace ns = local (\r -> r & msKNamespace <>~ ns)
96+
97+
98+-------------------------------------------------------------------------------
99+runStack :: MyState -> MyStack m a -> m a
100+runStack s f = runReaderT (unStack f) s
katip/katip.cabal+11
@@ -24,6 +24,10 @@ description:
2424 configured to a different log severity.
2525
2626 A note on the name: Katip is Turkish for scribe.
27+
28+ Be sure to look in the @examples@ directory for some examples of how
29+ do integrate Katip into your own stack.
30+
2731license: BSD3
2832license-file: LICENSE
2933author: Ozgun Ataman
@@ -32,6 +36,13 @@ copyright: Soostone Inc, 2015
3236category: Data, Text, Logging
3337build-type: Simple
3438cabal-version: >=1.10
39+extra-source-files:
40+ examples/example.hs
41+ examples/example_lens.hs
42+ bench/Main.hs
43+ test/Main.hs
44+ test/Katip/Tests.hs
45+ test/Katip/Tests/Scribes/Handle.hs
3546
3647flag lib-Werror
3748 default: False
katip/src/Katip.hs−6
@@ -63,12 +63,6 @@ module Katip
6363 , logItemM
6464 , logExceptionM
6565
66− -- * Transformer for appending to a log context
67− , LogT
68− , runLogT
69− , BlankLogT
70− , runBlankLogT
71−
7266 -- * Included Scribes
7367 , mkHandleScribe
7468 , ColorStrategy (..)
katip/src/Katip/Monadic.hs+1−141
@@ -28,33 +28,18 @@ module Katip.Monadic
2828 , AnyLogContext
2929 , LogContexts
3030 , liftPayload
31−
32− -- * Transformer for appending to a log context
33− , LogT'
34− , LogT
35− , runLogT
36− , BlankLogT
37− , runBlankLogT
3831 ) where
3932
4033
4134-------------------------------------------------------------------------------
42−import Control.Applicative
43−import Control.Monad
44−import Control.Monad.Base
4535import Control.Monad.Catch
46−import Control.Monad.Error.Class
47−import Control.Monad.Fix
48−import Control.Monad.IO.Class
49−import Control.Monad.RWS.Class
5036import Control.Monad.Trans.Class
51−import Control.Monad.Trans.Control
5237import Control.Monad.Trans.Either (EitherT)
5338import Control.Monad.Trans.Except (ExceptT)
5439import Control.Monad.Trans.Identity (IdentityT)
5540import Control.Monad.Trans.List (ListT)
5641import Control.Monad.Trans.Maybe (MaybeT)
57−import Control.Monad.Trans.Reader (ReaderT (..), runReaderT)
42+import Control.Monad.Trans.Reader (ReaderT)
5843import Control.Monad.Trans.Resource (ResourceT)
5944import Control.Monad.Trans.RWS (RWST)
6045import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST)
@@ -195,128 +180,3 @@ logExceptionM action sev = action `catchAll` \e -> f e >> throwM e
195180 where
196181 f e = logFM sev (msg e)
197182 msg e = ls ("An exception has occured: " :: Text) <> showLS e
198−
199−
200−-------------------------------------------------------------------------------
201−-- | Wrapper over 'ReaderT' that provides a passthrough instance for
202−-- 'MonadReader' so your stack will not be affected. Also provides a
203−-- 'KatipContext' instance which combines with the inner monad's
204−-- instance.
205−--
206−-- @
207−-- instance KatipContext m WebMonad where
208−-- getKatipContext = ...
209−-- getKatipNamespace = Namespace ["web"]
210−--
211−-- dbCallInWeb = runLogT getDBContext (Namespace ["db"]) $ do
212−-- someStuff
213−-- @
214−--
215−-- In the above example, any logging inside of @dbCallInWeb@ will get
216−-- the (optionally) monadic log context for the db, combine it with
217−-- the web server's and will use the namespace @Namespace ["web","db"]@.
218−--
219−-- 'LogT' is exported which fixes @n ~ m@. The two type
220−-- variables must be present for defining a 'MonadTransControl' instance.
221−newtype LogT' n m a = LogT {
222− unLogT :: ReaderT (n LogContexts, n Namespace) m a
223− } deriving ( Functor
224− , Applicative
225− , Monad
226− , MonadIO
227− , MonadThrow
228− , MonadCatch
229− , MonadMask
230− , MonadBase b
231− , MonadState s
232− , MonadWriter w
233− , MonadError e
234− , MonadPlus
235− , Alternative
236− , MonadFix
237− , Katip
238− )
239−
240−type LogT m a = LogT' m m a
241−
242−instance MonadTrans (LogT' n) where
243− lift = LogT . lift
244−
245−-- Reader is a passthrough. We don't expose our internal reader so as not to conflict
246−instance (MonadReader r m) => MonadReader r (LogT' n m) where
247− ask = lift ask
248− local f (LogT (ReaderT m)) = LogT $ ReaderT $ \r ->
249− local f (m r)
250−
251−instance MonadTransControl (LogT' n) where
252− type StT (LogT' n) a = StT (ReaderT (n LogContexts)) a
253− liftWith = defaultLiftWith LogT unLogT
254− restoreT = defaultRestoreT LogT
255− {-# INLINE liftWith #-}
256− {-# INLINE restoreT #-}
257−
258−instance (MonadBaseControl b m) => MonadBaseControl b (LogT' n m) where
259− type StM ((LogT' n) m) a = ComposeSt (LogT' n) m a
260− liftBaseWith = defaultLiftBaseWith
261− restoreM = defaultRestoreM
262−
263−instance (KatipContext m, Monad m) => KatipContext (LogT' m m) where
264− getKatipContext = LogT $ ReaderT $ \(gctxs, _) -> do
265− ctxs <- gctxs
266− ctxs' <- getKatipContext
267− return $ ctxs <> ctxs'
268− getKatipNamespace = LogT $ ReaderT $ \(_, getNsInner) -> do
269− nsOuter <- getKatipNamespace
270− nsInner <- getNsInner
271− return $ nsOuter <> nsInner
272−
273−runLogT
274− :: (Functor m, LogItem a)
275− => m a
276− -> m Namespace
277− -> LogT m b
278− -> m b
279−runLogT lgtr nsgtr m = runReaderT (unLogT m) (liftPayload <$> lgtr, nsgtr)
280−
281−
282−-------------------------------------------------------------------------------
283−-- | Type analogous to IdentityT that provides an empty log
284−-- context. Use this if your root monad doesn't have a LogContext instance.
285−newtype BlankLogT m a = BlankLogT {
286− runBlankLogT :: m a
287− } deriving ( Functor
288− , Applicative
289− , Monad
290− , MonadIO
291− , MonadThrow
292− , MonadCatch
293− , MonadMask
294− , MonadBase b
295− , MonadReader r
296− , MonadState s
297− , MonadWriter w
298− , MonadError e
299− , MonadPlus
300− , Alternative
301− , MonadFix
302− , Katip
303− )
304−
305−instance Katip m => KatipContext (BlankLogT m) where
306− getKatipContext = return mempty
307− getKatipNamespace = return mempty
308−
309−instance MonadTrans BlankLogT where
310− lift = BlankLogT
311−
312−instance MonadTransControl BlankLogT where
313− type StT BlankLogT a = a
314− liftWith f = BlankLogT $ f runBlankLogT
315− restoreT = BlankLogT
316− {-# INLINABLE liftWith #-}
317− {-# INLINABLE restoreT #-}
318−
319−instance (MonadBaseControl b m) => MonadBaseControl b (BlankLogT m) where
320− type StM (BlankLogT m) a = ComposeSt BlankLogT m a
321− liftBaseWith = defaultLiftBaseWith
322− restoreM = defaultRestoreM