@@ -1,9 +1,12 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DefaultSignatures #-}
13{-# LANGUAGE DeriveFunctor #-}
24{-# LANGUAGE DeriveGeneric #-}
35{-# LANGUAGE ExistentialQuantification #-}
46{-# LANGUAGE FlexibleContexts #-}
57{-# LANGUAGE FlexibleInstances #-}
68{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+{-# LANGUAGE ImplicitParams #-}
710{-# LANGUAGE MultiParamTypeClasses #-}
811{-# LANGUAGE OverloadedStrings #-}
912{-# LANGUAGE RankNTypes #-}
@@ -11,14 +14,17 @@
1114{-# LANGUAGE TemplateHaskell #-}
1215{-# LANGUAGE TypeFamilies #-}
1316{-# LANGUAGE UndecidableInstances #-}
17+#if MIN_VERSION_base(4, 9, 0)
18+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
19+#endif
20+-- | This module is not meant to be imported directly and may contain
21+-- internal mechanisms that will change without notice.
1422module Katip.Core where
1523
1624-------------------------------------------------------------------------------
1725import Control.Applicative as A
1826import Control.AutoUpdate
1927import Control.Concurrent
20−import Control.Lens
21−import Control.Monad
2228import Control.Monad.Base
2329import Control.Monad.Catch
2430import Control.Monad.IO.Class
@@ -38,7 +44,7 @@ import Data.Foldable as FT
3844import qualified Data.HashMap.Strict as HM
3945import Data.List
4046import qualified Data.Map.Strict as M
41−import Data.Monoid
47+import Data.Semigroup
4248import Data.String
4349import Data.String.Conv
4450import Data.Text (Text)
@@ -46,13 +52,28 @@ import qualified Data.Text as T
4652import qualified Data.Text.Lazy.Builder as B
4753import Data.Time
4854import GHC.Generics hiding (to)
55+#if MIN_VERSION_base(4, 8, 0)
56+#if !MIN_VERSION_base(4, 9, 0)
57+import GHC.SrcLoc
58+#endif
59+import GHC.Stack
60+#endif
4961import Language.Haskell.TH
5062import qualified Language.Haskell.TH.Syntax as TH
63+import Lens.Micro
64+import Lens.Micro.TH
5165import Network.HostName
5266import System.Posix
5367-------------------------------------------------------------------------------
5468
5569
70+readMay :: Read a => String -> Maybe a
71+readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of
72+ [x] -> Just x
73+ [] -> Nothing -- no parse
74+ _ -> Nothing -- Ambiguous parse
75+
76+
5677-------------------------------------------------------------------------------
5778-- | Represents a heirarchy of namespaces going from general to
5879-- specific. For instance: ["processname", "subsystem"]. Note that
@@ -60,7 +81,7 @@ import System.Posix
6081-- IsString/OverloadedStrings, so "foo" will result in Namespace
6182-- ["foo"].
6283newtype Namespace = Namespace { unNamespace :: [Text] }
63− deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,Monoid)
84+ deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,Semigroup,Monoid)
6485
6586instance IsString Namespace where
6687 fromString s = Namespace [fromString s]
@@ -117,27 +138,25 @@ renderSeverity s = case s of
117138
118139
119140-------------------------------------------------------------------------------
120−severityText :: Prism' Text Severity
121−severityText = prism renderSeverity toSev
122− where
123− toSev "Debug" = Right DebugS
124− toSev "Info" = Right InfoS
125− toSev "Notice" = Right NoticeS
126− toSev "Warning" = Right WarningS
127− toSev "Error" = Right ErrorS
128− toSev "Critical" = Right CriticalS
129− toSev "Alert" = Right AlertS
130− toSev "Emergency" = Right EmergencyS
131− toSev x = Left x
141+textToSeverity :: Text -> Maybe Severity
142+textToSeverity "Debug" = Just DebugS
143+textToSeverity "Info" = Just InfoS
144+textToSeverity "Notice" = Just NoticeS
145+textToSeverity "Warning" = Just WarningS
146+textToSeverity "Error" = Just ErrorS
147+textToSeverity "Critical" = Just CriticalS
148+textToSeverity "Alert" = Just AlertS
149+textToSeverity "Emergency" = Just EmergencyS
150+textToSeverity _ = Nothing
132151
133−instance ToJSON Severity where
134− toJSON s = A.String (s ^. re severityText)
135152
153+instance ToJSON Severity where
154+ toJSON s = A.String (renderSeverity s)
136155
137156instance FromJSON Severity where
138157 parseJSON = A.withText "Severity" parseSeverity
139158 where
140− parseSeverity t = case t ^? severityText of
159+ parseSeverity t = case textToSeverity t of
141160 Just x -> return x
142161 Nothing -> fail $ "Invalid Severity " ++ toS t
143162
@@ -150,10 +169,16 @@ newtype LogStr = LogStr { unLogStr :: B.Builder }
150169instance IsString LogStr where
151170 fromString = LogStr . B.fromString
152171
172+
173+instance Semigroup LogStr where
174+ (LogStr a) <> (LogStr b) = LogStr (a <> b)
175+
176+
153177instance Monoid LogStr where
154− mappend (LogStr a) (LogStr b) = LogStr (a `mappend` b)
178+ mappend = (<>)
155179 mempty = LogStr mempty
156180
181+
157182instance FromJSON LogStr where
158183 parseJSON = A.withText "LogStr" parseLogStr
159184 where
@@ -290,13 +315,12 @@ instance FromJSON a => FromJSON (Item a) where
290315 <*> (fmap getLocJs <$> o A..: "loc")
291316
292317
293−processIDText :: Prism' Text ProcessID
294−processIDText = prism fromProcessID toProcessID
295− where
296− fromProcessID = toS . show
297− toProcessID t = case toS t ^? _Show of
298− Just i -> Right i
299− Nothing -> Left t
318+processIDToText :: ProcessID -> Text
319+processIDToText = toS . show
320+
321+
322+textToProcessID :: Text -> Maybe ProcessID
323+textToProcessID = readMay . toS
300324
301325
302326newtype ProcessIDJs = ProcessIDJs {
@@ -305,13 +329,13 @@ newtype ProcessIDJs = ProcessIDJs {
305329
306330
307331instance ToJSON ProcessIDJs where
308− toJSON (ProcessIDJs p) = A.String (p ^. re processIDText)
332+ toJSON (ProcessIDJs p) = A.String (processIDToText p)
309333
310334
311335instance FromJSON ProcessIDJs where
312336 parseJSON = A.withText "ProcessID" parseProcessID
313337 where
314− parseProcessID t = case t ^? processIDText of
338+ parseProcessID t = case textToProcessID t of
315339 Just p -> return $ ProcessIDJs p
316340 Nothing -> fail $ "Invalid ProcessIDJs " ++ toS t
317341
@@ -321,12 +345,17 @@ instance FromJSON ProcessIDJs where
321345data PayloadSelection
322346 = AllKeys
323347 | SomeKeys [Text]
348+ deriving (Show, Eq)
349+
350+instance Semigroup PayloadSelection where
351+ AllKeys <> _ = AllKeys
352+ _ <> AllKeys = AllKeys
353+ SomeKeys as <> SomeKeys bs = SomeKeys (as <> bs)
354+
324355
325356instance Monoid PayloadSelection where
326357 mempty = SomeKeys []
327− mappend AllKeys _ = AllKeys
328− mappend _ AllKeys = AllKeys
329− mappend (SomeKeys as) (SomeKeys bs) = SomeKeys (as++bs)
358+ mappend = (<>)
330359
331360
332361-------------------------------------------------------------------------------
@@ -339,8 +368,9 @@ instance Monoid PayloadSelection where
339368-- a ToJSON instance like:
340369--
341370-- > instance ToObject Foo
342−class ToJSON a => ToObject a where
371+class ToObject a where
343372 toObject :: a -> A.Object
373+ default toObject :: ToJSON a => a -> A.Object
344374 toObject v = case toJSON v of
345375 A.Object o -> o
346376 _ -> mempty
@@ -389,15 +419,22 @@ instance ToJSON SimpleLogPayload where
389419 toJSON (SimpleLogPayload as) = object $ map go as
390420 where go (k, AnyLogPayload v) = k A..= v
391421
422+
392423instance ToObject SimpleLogPayload
393424
425+
394426instance LogItem SimpleLogPayload where
395427 payloadKeys V0 _ = SomeKeys []
396428 payloadKeys _ _ = AllKeys
397429
430+
431+instance Semigroup SimpleLogPayload where
432+ SimpleLogPayload a <> SimpleLogPayload b = SimpleLogPayload (a <> b)
433+
434+
398435instance Monoid SimpleLogPayload where
399436 mempty = SimpleLogPayload []
400− SimpleLogPayload a `mappend` SimpleLogPayload b = SimpleLogPayload (a `mappend` b)
437+ mappend = (<>)
401438
402439
403440-------------------------------------------------------------------------------
@@ -412,7 +449,7 @@ sl a b = SimpleLogPayload [(a, AnyLogPayload b)]
412449payloadObject :: LogItem a => Verbosity -> a -> A.Object
413450payloadObject verb a = case FT.foldMap (flip payloadKeys a) [(V0)..verb] of
414451 AllKeys -> toObject a
415− SomeKeys ks -> HM.filterWithKey (\ k _ -> k `elem` ks) $ toObject a
452+ SomeKeys ks -> HM.filterWithKey (\ k _ -> k `FT.elem` ks) $ toObject a
416453
417454
418455-------------------------------------------------------------------------------
@@ -459,11 +496,15 @@ data Scribe = Scribe {
459496 }
460497
461498
499+instance Semigroup Scribe where
500+ (Scribe a) <> (Scribe b) = Scribe $ \ item -> do
501+ a item
502+ b item
503+
504+
462505instance Monoid Scribe where
463506 mempty = Scribe $ const $ return ()
464− mappend (Scribe a) (Scribe b) = Scribe $ \ item -> do
465− a item
466− b item
507+ mappend = (<>)
467508
468509
469510-------------------------------------------------------------------------------
@@ -476,12 +517,18 @@ permitItem sev i = _itemSeverity i >= sev
476517data LogEnv = LogEnv {
477518 _logEnvHost :: HostName
478519 , _logEnvPid :: ProcessID
479− , _logEnvNs :: Namespace
520+ , _logEnvApp :: Namespace
521+ -- ^ Name of application. This will typically never change. This
522+ -- field gets prepended to the namespace of your individual log
523+ -- messages. For example, if your app is MyApp and you write a log
524+ -- using "logItem" and the namespace "WebServer", the final
525+ -- namespace will be "MyApp.WebServer"
480526 , _logEnvEnv :: Environment
481527 , _logEnvTimer :: IO UTCTime
482528 -- ^ Action to fetch the timestamp. You can use something like
483529 -- 'AutoUpdate' for high volume logs but note that this may cause
484− -- some output forms to display logs out of order.
530+ -- some output forms to display logs out of order. Alternatively,
531+ -- you could just use 'getCurrentTime'.
485532 , _logEnvScribes :: M.Map Text Scribe
486533 }
487534makeLenses ''LogEnv
@@ -516,7 +563,7 @@ registerScribe
516563 -> Scribe
517564 -> LogEnv
518565 -> LogEnv
519−registerScribe nm h = logEnvScribes . at nm .~ Just h
566+registerScribe nm h = logEnvScribes %~ M.insert nm h
520567
521568
522569-------------------------------------------------------------------------------
@@ -527,12 +574,15 @@ unregisterScribe
527574 -- ^ Name of the scribe
528575 -> LogEnv
529576 -> LogEnv
530−unregisterScribe nm = logEnvScribes . at nm .~ Nothing
577+unregisterScribe nm = logEnvScribes %~ M.delete nm
531578
532579
533580-------------------------------------------------------------------------------
534581-- | Unregister *all* scribes. Logs will go off into space from this
535−-- point onward until new scribes are added.
582+-- point onward until new scribes are added. Note that you could use
583+-- this with `local` if you're using a Reader based stack to
584+-- temporarily disable log output. See `katipNoLogging` for an
585+-- example.
536586clearScribes
537587 :: LogEnv
538588 -> LogEnv
@@ -540,8 +590,16 @@ clearScribes = logEnvScribes .~ mempty
540590
541591
542592-------------------------------------------------------------------------------
543−-- | Monads where katip logging actions can be performed
544−class MonadIO m => Katip m where
593+-- | Monads where katip logging actions can be performed. Katip is the
594+-- most basic logging monad. You will typically use this directly if
595+-- you either don't want to use namespaces/contexts heavily or if you
596+-- want to pass in specific contexts and/or namespaces at each log site.
597+--
598+-- For something more powerful, look at the docs for 'KatipContext',
599+-- which keeps a namespace and merged context. You can write simple
600+-- functions that add additional namespacing and merges additional
601+-- context on the fly.
602+class MonadIO m => Katip m where
545603 getLogEnv :: m LogEnv
546604
547605
@@ -616,7 +674,7 @@ logItem a ns loc sev msg = do
616674 LogEnv{..} <- getLogEnv
617675 liftIO $ do
618676 item <- Item
619− <$> pure _logEnvNs
677+ <$> pure _logEnvApp
620678 <*> pure _logEnvEnv
621679 <*> pure sev
622680 <*> (mkThreadIdText <$> myThreadId)
@@ -625,9 +683,9 @@ logItem a ns loc sev msg = do
625683 <*> pure a
626684 <*> pure msg
627685 <*> _logEnvTimer
628− <*> pure (_logEnvNs <> ns)
686+ <*> pure (_logEnvApp <> ns)
629687 <*> pure loc
630− forM_ (M.elems _logEnvScribes) $ \ (Scribe h) -> h item
688+ FT.forM_ (M.elems _logEnvScribes) $ \ (Scribe h) -> h item
631689
632690
633691-------------------------------------------------------------------------------
@@ -713,9 +771,33 @@ liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
713771
714772-------------------------------------------------------------------------------
715773-- | For use when you want to include location in your logs. This will
716−-- fill the 'Maybe Loc' gap in 'logF' of this module.
717−getLoc :: Q Exp
718−getLoc = [| $(location >>= liftLoc) |]
774+-- fill the 'Maybe Loc' gap in 'logF' of this module, and relies on implicit
775+-- callstacks when available (GHC > 7.8).
776+#if MIN_VERSION_base(4, 8, 0)
777+getLoc :: (?loc :: CallStack) => Maybe Loc
778+getLoc = case getCallStack ?loc of
779+ [] -> Nothing
780+ xs -> Just . toLoc . last $ xs
781+ where
782+ toLoc :: (String, SrcLoc) -> Loc
783+ toLoc (_, l) = Loc {
784+ loc_filename = srcLocFile l
785+ , loc_package = srcLocPackage l
786+ , loc_module = srcLocModule l
787+ , loc_start = (srcLocStartLine l, srcLocStartCol l)
788+ , loc_end = (srcLocEndLine l, srcLocEndCol l)
789+ }
790+#else
791+getLoc :: Maybe Loc
792+getLoc = Nothing
793+#endif
794+
795+
796+-------------------------------------------------------------------------------
797+-- Like `getLoc`, but uses template-haskell and works with older versions of
798+-- the compiler (GHC 7.8 or older).
799+getLocTH :: ExpQ
800+getLocTH = [| $(location >>= liftLoc) |]
719801
720802
721803-------------------------------------------------------------------------------
@@ -723,7 +805,27 @@ getLoc = [| $(location >>= liftLoc) |]
723805--
724806-- @$(logT) obj mempty InfoS "Hello world"@
725807logT :: ExpQ
726−logT = [| \ a ns sev msg -> logItem a ns (Just $(getLoc)) sev msg |]
808+logT = [| \ a ns sev msg -> logItem a ns (Just $(getLocTH)) sev msg |]
809+
810+
811+-------------------------------------------------------------------------------
812+-- | 'Loc'-tagged logging using implicit-callstacks when available.
813+--
814+-- This function does not require template-haskell as it
815+-- automatically uses <https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-Stack.html#v:getCallStack implicit-callstacks>
816+-- when the code is compiled using GHC > 7.8. Using an older version of the
817+-- compiler will result in the emission of a log line without any location information,
818+-- so be aware of it. Users using GHC <= 7.8 may want to use the template-haskell function
819+-- `logT` for maximum compatibility.
820+--
821+-- @logLoc obj mempty InfoS "Hello world"@
822+logLoc :: (Applicative m, LogItem a, Katip m)
823+ => a
824+ -> Namespace
825+ -> Severity
826+ -> LogStr
827+ -> m ()
828+logLoc a ns = logItem a ns getLoc
727829
728830
729831-- taken from the file-location package