master..71f9cba · typeable/control-logger

git.iko.soy/typeable/control-logger

on 71f9cba help sign in

.gitignoredeleted−3

since splitsnapshots

unifiedsplit

@@ -1,3 +0,0 @@

1−.stack-work

2−*~

3−*.swp

LICENSEdeleted−2

@@ -1,2 +0,0 @@

README.mddeleted−3

@@ -1,3 +0,0 @@

1−# control-logger

2−

3−Utilities for logging

control-logger.cabal+41−51

@@ -1,55 +1,45 @@

1−cabal-version: 2.4

2−name: control-logger

1+name: control-logger

3−version: 0.1.0.0

2+version: 0.1.0.0

4−synopsis: Logger used by all projects

3+synopsis: Logger used by all projects

5−license-file: LICENSE

4+license: AllRightsReserved

6−build-type: Simple

5+build-type: Simple

6+cabal-version: >=1.10

8library

9− hs-source-dirs: src

9+ hs-source-dirs: src

10− ghc-options: -Wall

10+ ghc-options: -Wall

11−

12 if !impl(ghcjs)

11 if !impl(ghcjs)

13− exposed-modules:

12+ exposed-modules: Control.Logger

14− Control.Logger

15− Control.Logger.Katip

13+ Control.Logger.Katip

16− Control.Logger.Katip.Utils

14+ Control.Logger.Katip.Scribes.Reopenable

17− Control.Logger.Orphans

18−

19− exposed-modules: Control.Logger.Internal

15+ exposed-modules: Control.Logger.Internal

20− build-depends:

16+ build-depends: base

21− , aeson

17+ , aeson

22− , base >=4.11

18+ , bloodhound

23− , bytestring

19+ , bytestring

24− , control-has

25− , control-has-katip

20+ , control-has

26− , deepseq

21+ , deepseq

27− , exceptions

22+ , exceptions

28− , fast-logger >=2.4.11

23+ , fast-logger

29− , http-client

24+ , http-client

30− , lens

25+ , lens

31− , monad-logger

32− , mtl

26+ , mtl

33− , shakespeare

27+ , shakespeare

34− , text

28+ , text

35− , time

29+ , time

36− , unordered-containers

30+ , unordered-containers

37−

38 if !impl(ghcjs)

31 if !impl(ghcjs)

39− build-depends:

32+ build-depends: katip

40− , katip >=0.8.8.0

33+ , katip-elasticsearch

41− , optparse-applicative

42−

43− default-language: Haskell2010

34+ default-language: Haskell2010

44− default-extensions:

35+ default-extensions: RankNTypes

45− ConstraintKinds

46− DataKinds

36+ DataKinds

47− DeriveGeneric

48− FlexibleContexts

37+ FlexibleContexts

49− FlexibleInstances

38+ FlexibleInstances

50− LambdaCase

39+ LambdaCase

51− OverloadedStrings

40+ OverloadedStrings

52− RankNTypes

41+ ScopedTypeVariables

42+ DeriveGeneric

43+ ConstraintKinds

53− RecordWildCards

44+ RecordWildCards

54− ScopedTypeVariables

55− TypeSynonymInstances

45+ TypeSynonymInstances

default.nixdeleted−9

@@ -1,9 +0,0 @@

1−{ pkgs ? import <nixpkgs> {} }:

2−

3−pkgs.mkShell {

4− buildInputs = [

5− pkgs.ghc

6− pkgs.haskellPackages.cabal-install

7− pkgs.zlib

8− ];

9−}

src/Control/Logger.hs+19−75

@@ -1,10 +1,7 @@

1−{-# LANGUAGE CPP #-}

2module Control.Logger

3 ( Logger

4 , loggerContext

5− , scrubber

6− , censor

7− , censorWith

8 , logMsg

5 , logMsg

9 , logMsgWith

6 , logMsgWith

10 , logInfo

7 , logInfo

@@ -35,123 +32,71 @@ module Control.Logger

35 , compactCallStack

32 , compactCallStack

36 , st

33 , st

37 , ToObject(..)

34 , ToObject(..)

38− , withScrubber

39− , censoringWith

40− , censoring

41 ) where

35 ) where

43import Control.Has

37import Control.Has

44−import Control.Lens hiding (censoring)

45import Control.Logger.Internal

38import Control.Logger.Internal

46−import Control.Logger.Orphans ()

47−import Control.Monad

48import Control.Monad.Catch

39import Control.Monad.Catch

49−import Control.Monad.IO.Class

50−import qualified Data.List as List

40+import qualified Data.List as List

51−import Data.Monoid

52−import Data.Text (Text)

41+import Data.Text (Text)

53−import qualified Data.Text as Text

42+import qualified Data.Text as Text

54import Data.Time

43import Data.Time

55import GHC.Stack

44import GHC.Stack

56−import Katip (ToObject (..))

45+import Katip (ToObject(..))

57import System.Log.FastLogger

46import System.Log.FastLogger

58−import Text.Shakespeare.Text (st)

47+import Text.Shakespeare.Text (st)

60logError

49logError

61 :: (LoggingMonad r m)

50 :: (LoggingMonad r m)

62 => Text

51 => Text

63 -> m ()

52 -> m ()

64−logError msg = withFrozenCallStack (logMsg Error msg)

53+logError = withFrozenCallStack . logMsg Error

66logDebug

55logDebug

67 :: (LoggingMonad r m)

56 :: (LoggingMonad r m)

68 => Text

57 => Text

69 -> m ()

58 -> m ()

70−logDebug msg = withFrozenCallStack (logMsg Debug msg)

59+logDebug = withFrozenCallStack . logMsg Debug

72logInfo

61logInfo

73 :: (LoggingMonad r m)

62 :: (LoggingMonad r m)

74 => Text

63 => Text

75 -> m ()

64 -> m ()

76−logInfo msg = withFrozenCallStack (logMsg Info msg)

65+logInfo = withFrozenCallStack . logMsg Info

78logWarn

67logWarn

79 :: (LoggingMonad r m)

68 :: (LoggingMonad r m)

80 => Text

69 => Text

81 -> m ()

70 -> m ()

82−logWarn msg = withFrozenCallStack (logMsg Warn msg)

71+logWarn = withFrozenCallStack . logMsg Warn

84logInfoWith

73logInfoWith

85 :: (MonadIO m, HasCallStack)

74 :: (MonadIO m, HasCallStack)

86 => Logger

75 => Logger

87 -> Text

76 -> Text

88 -> m ()

77 -> m ()

89−logInfoWith logger msg = withFrozenCallStack (logMsgWith logger Info msg)

78+logInfoWith logger = withFrozenCallStack . logMsgWith logger Info

91logDebugWith

80logDebugWith

92 :: (MonadIO m, HasCallStack)

81 :: (MonadIO m, HasCallStack)

93 => Logger

82 => Logger

94 -> Text

83 -> Text

95 -> m ()

84 -> m ()

96−logDebugWith logger msg = withFrozenCallStack (logMsgWith logger Debug msg)

85+logDebugWith logger = withFrozenCallStack . logMsgWith logger Debug

98logWarnWith

87logWarnWith

99 :: (MonadIO m, HasCallStack)

88 :: (MonadIO m, HasCallStack)

100 => Logger

89 => Logger

101 -> Text

90 -> Text

102 -> m ()

91 -> m ()

103−logWarnWith logger msg = withFrozenCallStack (logMsgWith logger Warn msg)

92+logWarnWith logger = withFrozenCallStack . logMsgWith logger Warn

104

105logErrorWith

94logErrorWith

106 :: (MonadIO m, HasCallStack)

95 :: (MonadIO m, HasCallStack)

107 => Logger

96 => Logger

108 -> Text

97 -> Text

109 -> m ()

98 -> m ()

110−logErrorWith logger msg = withFrozenCallStack (logMsgWith logger Error msg)

99+logErrorWith logger = withFrozenCallStack . logMsgWith logger Error

111−

112−safeReplace :: Text -> Text -> Text -> Text

113−safeReplace what with where_

114− | Text.null what = where_

115− | otherwise = Text.replace what with where_

116−

117−-- | Add a some text to scrubber

118−censorWith :: Text -> Text -> Logger -> Logger

119−censorWith replacement needle l =

120− l & scrubber <>~ Endo (safeReplace needle replacement)

121−

122−-- | Censor with "***"

123−censor :: Text -> Logger -> Logger

124−censor = censorWith "***"

125−

126−-- | Run an action with adjusted scrubber

127−withScrubber

128− :: forall r m a. (Has Logger r, MonadReader r m)

129− => (Endo Text -> Endo Text)

130− -> m a

131− -> m a

132−withScrubber scrubF = local expandScrubber

133− where

134− expandScrubber :: r -> r

135− expandScrubber = over part (over scrubber scrubF)

136−

137−-- | Run an action while censoring additional text from logs

138−censoringWith

139− :: (Has Logger r, MonadReader r m)

140− => Text

141− -> Text

142− -> m a

143− -> m a

144−censoringWith replacement txt = withScrubber (<> censored)

145− where

146− censored = Endo (safeReplace txt replacement)

147−

148−-- | Run an action while censoring additional text from logs

149−censoring

150− :: (Has Logger r, MonadReader r m)

151− => Text

152− -> m a

153− -> m a

154−censoring = censoringWith "***"

155

100

156-- | Log exceptions occured in computation and just ignore them.

101-- | Log exceptions occured in computation and just ignore them.

157tryLogError

102tryLogError

@@ -196,21 +141,20 @@ logExceptions ma = catch ma $ \e -> do

196 throwM e

141 throwM e

197

142

198oneoffLog :: MonadIO m => Logger -> LogSeverity -> Text -> m ()

143oneoffLog :: MonadIO m => Logger -> LogSeverity -> Text -> m ()

199−oneoffLog logger s t =

200− withFrozenCallStack (flip runReaderT logger $ logMsg s t)

144+oneoffLog logger s t = flip runReaderT logger $ logMsg s t

201

145

202fileLogger :: MonadIO m => FilePath -> m Logger

146fileLogger :: MonadIO m => FilePath -> m Logger

203fileLogger fp = fastFunc <$> liftIO (newFileLoggerSet defaultBufSize fp)

147fileLogger fp = fastFunc <$> liftIO (newFileLoggerSet defaultBufSize fp)

204

148

205silentLogger :: Logger

149silentLogger :: Logger

206−silentLogger = Logger mempty mempty (\_ _ _ _ -> return ())

150+silentLogger = Logger mempty (\_ _ _ _ -> return ())

207

151

208-- | Logger which flushes buffer after each message. This is useful with

152-- | Logger which flushes buffer after each message. This is useful with

209-- stderrLogger.

153-- stderrLogger.

210flushingFastFunc

154flushingFastFunc

211 :: LogSeverity -> LoggerSet -> Logger

155 :: LogSeverity -> LoggerSet -> Logger

212flushingFastFunc minLogLevel loggerSet =

156flushingFastFunc minLogLevel loggerSet =

213− Logger mempty mempty $ \_ stack logLevel msg ->

157+ Logger mempty $ \_ stack logLevel msg ->

214 when (logLevel >= minLogLevel) $ do

158 when (logLevel >= minLogLevel) $ do

215 ts <- getCurrentTime

159 ts <- getCurrentTime

216 pushLogStr loggerSet

160 pushLogStr loggerSet

@@ -234,14 +178,14 @@ flushingStderrLogger =

234-- | Make our outdated 'Logger' of fast-logger's 'LoggerSet'

178-- | Make our outdated 'Logger' of fast-logger's 'LoggerSet'

235fastFunc :: LoggerSet -> Logger

179fastFunc :: LoggerSet -> Logger

236fastFunc loggerSet =

180fastFunc loggerSet =

237− Logger mempty mempty $ \_ _ _ msg -> pushLogStr loggerSet $ toLogStr msg

181+ Logger mempty $ \_ _ _ msg -> pushLogStr loggerSet $ toLogStr msg

238

182

239type LogSource = Text

183type LogSource = Text

240

184

241-- | Default logger tests and same things.

185-- | Default logger tests and same things.

242defaultFastFunc :: LogSource -> LogSeverity -> LoggerSet -> Logger

186defaultFastFunc :: LogSource -> LogSeverity -> LoggerSet -> Logger

243defaultFastFunc loc minLogLevel loggerSet =

187defaultFastFunc loc minLogLevel loggerSet =

244− Logger mempty mempty $ \_ stack s msg -> when (s >= minLogLevel) $ do

188+ Logger mempty $ \_ stack s msg -> when (s >= minLogLevel) $ do

245 ts <- getCurrentTime

189 ts <- getCurrentTime

246 pushLogStr loggerSet $ formatLogStr ts stack loc s (toLogStr msg)

190 pushLogStr loggerSet $ formatLogStr ts stack loc s (toLogStr msg)

247

191

src/Control/Logger/Internal.hs+8−29

@@ -1,12 +1,9 @@

1{-# LANGUAGE TemplateHaskell #-}

2−{-# LANGUAGE NamedFieldPuns #-}

3−{-# LANGUAGE CPP #-}

5module Control.Logger.Internal

3module Control.Logger.Internal

6 ( Logger(..)

4 ( Logger(..)

7 , loggerContext

5 , loggerContext

8 , loggerAction

6 , loggerAction

9− , scrubber

10 , runLogger

7 , runLogger

11 , LogSeverity(..)

8 , LogSeverity(..)

12 , LoggingMonad

9 , LoggingMonad

@@ -16,11 +13,10 @@ module Control.Logger.Internal

17import Control.Has

14import Control.Has

18import Control.Lens

15import Control.Lens

19−import Control.Monad.IO.Class

20import Control.DeepSeq

16import Control.DeepSeq

21−import Data.Aeson (ToJSON, FromJSON, Object, Value(..))

17+import Data.Aeson (ToJSON, FromJSON, Object)

22import Data.Text (Text)

18import Data.Text (Text)

23−import Data.Monoid

19+import GHC.Generics (Generic)

24import GHC.Stack

20import GHC.Stack

@@ -34,26 +30,23 @@ data LogSeverity

34instance ToJSON LogSeverity

30instance ToJSON LogSeverity

35instance FromJSON LogSeverity

31instance FromJSON LogSeverity

37−data Logger = Logger

33+data Logger

34+ = Logger

38 { _loggerContext :: Object

35 { _loggerContext :: Object

39− , _scrubber :: Endo Text

40 , _loggerAction :: Object -> CallStack -> LogSeverity -> Text -> IO ()

36 , _loggerAction :: Object -> CallStack -> LogSeverity -> Text -> IO ()

41 } deriving Generic

37 } deriving Generic

43−instance NFData Logger where

39+instance NFData Logger

44− rnf Logger{_loggerContext, _scrubber, _loggerAction} =

45− rnf _loggerContext `deepseq` rwhnf (appEndo _scrubber) `deepseq` rwhnf _loggerAction

47makeLenses ''Logger

41makeLenses ''Logger

49instance Semigroup Logger where

43instance Semigroup Logger where

50− (Logger ctx1 s1 l1) <> (Logger ctx2 s2 l2)

44+ (Logger ctx1 l1) <> (Logger ctx2 l2) = Logger ctx'

51− = Logger ctx' (s1 <> s2)

52 $ \ctx stack s t -> l1 ctx stack s t >> l2 ctx stack s t

45 $ \ctx stack s t -> l1 ctx stack s t >> l2 ctx stack s t

53 where ctx' = ctx1 <> ctx2

46 where ctx' = ctx1 <> ctx2

55instance Monoid Logger where

48instance Monoid Logger where

56− mempty = Logger mempty mempty $ \_ _ _ _ -> pure ()

49+ mempty = Logger mempty $ \_ _ _ _ -> pure ()

58type LoggingMonad r m =

51type LoggingMonad r m =

59 (MonadReader r m, Has Logger r, MonadIO m, HasCallStack)

52 (MonadReader r m, Has Logger r, MonadIO m, HasCallStack)

@@ -77,18 +70,4 @@ logMsgWith logger s t =

77 liftIO $ runLogger logger callStack s t

70 liftIO $ runLogger logger callStack s t

79runLogger :: Logger -> CallStack -> LogSeverity -> Text -> IO ()

72runLogger :: Logger -> CallStack -> LogSeverity -> Text -> IO ()

80−runLogger (Logger ctx theScrubber logger) cs ls txt

73+runLogger (Logger ctx logger) = logger ctx

81− = logger (scrubContext theScrubber ctx) cs ls (appEndo theScrubber txt)

82−

83−

84−scrubContext :: Endo Text -> Object -> Object

85−scrubContext theScrubber = fmap doScrub

86− where

87− doScrub :: Value -> Value

88− doScrub = \case

89− Object object -> Object (fmap doScrub object)

90− Array array -> Array (fmap doScrub array)

91− String string -> String (appEndo theScrubber string)

92− n@Number{} -> n

93− b@Bool{} -> b

94− n@Null -> n

src/Control/Logger/Katip.hs+130−5

@@ -2,26 +2,60 @@

2{-# OPTIONS_GHC -fno-warn-orphans #-}

4module Control.Logger.Katip

5+ ( ElasticServer(..)

5− ( logSeverityToKSeverity

6+ , logSeverityToKSeverity

7+ , registerElastic

8+ , maybeElastic

6 , KatipContextTState(..)

9 , KatipContextTState(..)

7 , getKatipLogger

10 , getKatipLogger

8− , ourItemJson

11+ , ourFormatter

12+ , ourMapping

9 , katipIndexNameString

13 , katipIndexNameString

14+ , reopenableFileLog

10 ) where

15 ) where

12import Control.EnvT

17import Control.EnvT

13−import Control.Has.Katip ()

14import Control.Lens hiding ((.=))

18import Control.Lens hiding ((.=))

15import Control.Logger.Internal

19import Control.Logger.Internal

20+import Control.Logger.Katip.Scribes.Reopenable

16import Data.Aeson hiding (Error)

21import Data.Aeson hiding (Error)

22+import Data.ByteString (ByteString)

23+import qualified Data.HashMap.Strict as HM

24+import Data.Proxy as P

17import Data.Text (Text)

25import Data.Text (Text)

18import qualified Data.Text as T

26import qualified Data.Text as T

27+import qualified Data.Text.Encoding as T

19import qualified Data.Text.Lazy.Builder as T.Builder

28import qualified Data.Text.Lazy.Builder as T.Builder

29+import Database.V5.Bloodhound

20import Katip as K hiding (logMsg)

30import Katip as K hiding (logMsg)

21−import Katip.Core (LocJs(..), ProcessIDJs(..))

31+import Katip.Core (ItemFunc(..), LocJs(..), ProcessIDJs(..))

22import Katip.Monadic (KatipContextTState(..))

32import Katip.Monadic (KatipContextTState(..))

33+import Katip.Scribes.ElasticSearch

34+import Katip.Scribes.ElasticSearch.Internal as K

35+import Network.HTTP.Client

38+data ElasticServer = ElasticServer

39+ { _esServer :: !(Maybe Server)

40+ , _esUsername :: !(Maybe ByteString)

41+ , _esPassword :: !(Maybe ByteString)

42+ } deriving (Eq, Show)

43+

44+instance FromJSON ElasticServer where

45+ parseJSON = withObject "ElasticServer" $ \obj -> ElasticServer

46+ <$> (obj .: "server")

47+ <*> (fmap T.encodeUtf8 <$> (obj .: "username"))

48+ <*> (fmap T.encodeUtf8 <$> (obj .: "password"))

49+

50+instance ToJSON ElasticServer where

51+ toJSON es = object

52+ [ "server" .= fmap fromServer (_esServer es)

53+ , "username" .= fmap T.decodeUtf8 (_esUsername es)

54+ , "password" .= fmap T.decodeUtf8 (_esPassword es)

55+ ]

56+ where

57+ fromServer (Server s) = s

58+

25logSeverityToKSeverity :: LogSeverity -> Severity

59logSeverityToKSeverity :: LogSeverity -> Severity

26logSeverityToKSeverity = \case

60logSeverityToKSeverity = \case

27 Debug -> DebugS

61 Debug -> DebugS

@@ -29,6 +63,91 @@ logSeverityToKSeverity = \case

29 Warn -> WarningS

63 Warn -> WarningS

30 Error -> ErrorS

64 Error -> ErrorS

66+registerElastic

67+ :: Text

68+ -- ^ git revision

69+ -> Verbosity

70+ -> ElasticServer

71+ -> PermitFunc

72+ -> LogEnv

73+ -> IO LogEnv

74+registerElastic gitRev verbosity ElasticServer{..} permitF env =

75+ case _esServer of

76+ Nothing -> return env

77+ Just server -> do

78+ elastic <- do

79+ mgr <- newManager defaultManagerSettings

80+ let

81+ bloodhoundEnv = (mkBHEnv server mgr)

82+ { bhRequestHook = requestHook }

83+ mkEsScribe cfg bloodhoundEnv permitF verbosity

84+ registerScribe "elastic" elastic defaultScribeSettings env

85+ where

86+ cfg = (defaultEsScribeCfgV5 ixName mappingName)

87+ { essItemFormatter = ourFormatter gitRev

88+ , essIndexMappingValue = ourMapping mappingName }

89+ where

90+ ixName = IndexName katipIndexNameString

91+ mappingName = MappingName "logs"

92+ requestHook = return . case (_esUsername, _esPassword) of

93+ (Just u, Just p) -> applyBasicAuth u p

94+ _ -> id

95+

96+-- | Doubles the value of @msg@ key into the @msg-keyword@ and adds

97+-- the @rev-hash@ value to each record. The @msg-keyword@ is needed to

98+-- group errors by message. The @rev-hash@ is needed for many purposes

99+-- and for grouping as well.

100+ourFormatter

101+ :: Text

102+ -- ^ git revision string

103+ -> Verbosity

104+ -> ItemFunc Value

105+ourFormatter gitRev verb = ItemFunc $ \item -> go $ ourItemJson verb item

106+ where

107+ go :: Value -> Value

108+ go = \case

109+ Object h -> Object $ setRev $ dupMsg h

110+ x -> x -- drop exception here?

111+ where

112+ setRev :: HM.HashMap Text Value -> HM.HashMap Text Value

113+ setRev = HM.insert "rev-hash" (toJSON gitRev)

114+ dupMsg :: HM.HashMap Text Value -> HM.HashMap Text Value

115+ dupMsg m = HM.alter (const $ HM.lookup "msg" m) "msg-keyword" m

116+

117+ourMapping :: K.MappingName ESV5 -> Value

118+ourMapping mn = object

119+ [fromMappingName prx mn .= object ["properties" .= object prs]]

120+ where

121+ prs =

122+ [ unanalyzedString "thread"

123+ , unanalyzedString "sev"

124+ , unanalyzedString "pid"

125+ -- ns is frequently fulltext searched

126+ , analyzedString "ns"

127+ -- we want message to be fulltext searchable

128+ , analyzedString "msg"

129+ -- we want to group by the message as well

130+ , unanalyzedString "msg-keyword"

131+ -- we want to group by revision hash

132+ , unanalyzedString "rev-hash"

133+ , "loc" .= locType

134+ , unanalyzedString "host"

135+ , unanalyzedString "env"

136+ , "at" .= dateType

137+ , unanalyzedString "app"

138+ ]

139+ prx = P.Proxy :: P.Proxy ESV5

140+ unanalyzedString k = k .= unanalyzedStringSpec prx

141+ analyzedString k = k .= analyzedStringSpec prx

142+ locType = object ["properties" .= object locPairs]

143+ locPairs =

144+ [ unanalyzedString "loc_pkg"

145+ , unanalyzedString "loc_mod"

146+ , unanalyzedString "loc_ln"

147+ , unanalyzedString "loc_fn"

148+ , unanalyzedString "loc_col"

149+ ]

150+ dateType = object ["format" .= esDateFormat, "type" .= String "date"]

151

33katipIndexNameString :: Text

152katipIndexNameString :: Text

34katipIndexNameString = "antorica-b2b-logs"

153katipIndexNameString = "antorica-b2b-logs"

@@ -51,12 +170,18 @@ ourItemJson verb item = formatItem $

51 , "loc" .= fmap LocJs _itemLoc

170 , "loc" .= fmap LocJs _itemLoc

52 ]

171 ]

172

173+-- | Return empty server if Nothing

174+maybeElastic :: Maybe ElasticServer -> ElasticServer

175+maybeElastic = \case

176+ Nothing -> ElasticServer Nothing Nothing Nothing

177+ Just a -> a

178+

54instance LogItem Object where

179instance LogItem Object where

55 payloadKeys V0 _ = SomeKeys []

180 payloadKeys V0 _ = SomeKeys []

56 payloadKeys _ _ = AllKeys

181 payloadKeys _ _ = AllKeys

182

58getKatipLogger :: KatipContextTState -> Logger

183getKatipLogger :: KatipContextTState -> Logger

59−getKatipLogger katipCtx = Logger (toObject . ltsContext $ katipCtx) mempty

184+getKatipLogger katipCtx = Logger (toObject . ltsContext $ katipCtx)

60 $ \ ctx stack s msg ->

185 $ \ ctx stack s msg ->

61 let ?callStack = stack

186 let ?callStack = stack

62 in

187 in

src/Control/Logger/Katip/Scribes/Reopenable.hsnew file+19

@@ -0,0 +1,19 @@

1+module Control.Logger.Katip.Scribes.Reopenable where

3+import Katip

4+import Katip.Scribes.Handle.FileOwner

6+-- | Utility function to create scribe using the 'FileOwner'

7+-- inside. Returns new scribe and action to reopen the log

8+-- file. Reopening is performed asyncronously.

9+reopenableFileLog

10+ :: FilePath

11+ -> (forall a. LogItem a => ItemFormatter a)

12+ -> PermitFunc

13+ -> Verbosity

14+ -> IO (Scribe, IO ())

15+reopenableFileLog fPath formatter permitF verbosity = do

16+ owner <- newFileOwner fPath defaultFileOwnerSettings

17+ s <- mkFileOwnerScribeWithFormatter formatter (ColorLog False)

18+ owner permitF verbosity

19+ return (s, fileOwnerControl owner ReopenMsg)

src/Control/Logger/Katip/Utils.hsdeleted−124

@@ -1,124 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−

3−module Control.Logger.Katip.Utils

4− ( katipIndexNameString

5− , module Katip.Monadic

6− , LogFormat(..)

7− , registerFileScribe

8− , setLoggingCtx

9− , getKatipLogger

10− , logSeverityToKSeverity

11− ) where

12−

13−import Control.EnvT

14−import Control.Exception

15−import Control.Has

16−import Control.Lens hiding ((.=))

17−import Control.Logger as L

18−import Control.Logger.Internal as L

19−import Control.Logger.Katip as L

20−import Data.Aeson hiding (Error)

21−import Data.Aeson.Text

22−#if MIN_VERSION_aeson(2,0,0)

23−import qualified Data.Aeson.KeyMap as HM

24−import qualified Data.Aeson.Key as HM

25−#else

26−import qualified Data.HashMap.Strict as HM

27−#endif

28−import Data.Text (Text)

29−import qualified Data.Text.Lazy as T

30−import qualified Data.Text.Lazy.Builder as T.Builder

31−import Katip as K hiding (logMsg)

32−import Katip.Monadic (KatipContextTState(..))

33−import qualified Katip.Scribes.Handle as K

34−import System.IO

35−

36−

37−#if MIN_VERSION_aeson(2,0,0)

38−type KeyMap v = HM.KeyMap v

39−textToKey :: Text -> Key

40−textToKey = HM.fromText

41−keyToText :: Key -> Text

42−keyToText = HM.toText

43−#else

44−type KeyMap v = HM.HashMap Text v

45−type Key = Text

46−textToKey :: Text -> Key

47−textToKey = id

48−keyToText :: Key -> Text

49−keyToText = id

50−#endif

51−

52−-- | How to format logs

53−data LogFormat

54− = LogBracket -- ^ use `bracketFormat`

55− | LogJson -- ^ use `jsonFormat`

56− deriving (Eq, Show)

57−

58−registerFileScribe

59− :: Text -> Verbosity -> LogFormat -> FilePath -> PermitFunc -> [(Text, Text)]

60− -> LogEnv -> IO LogEnv

61−registerFileScribe gitRev verbosity format filePath permitF additions logenv =

62− bracketOnError (openFile filePath AppendMode) hClose $ \h -> do

63− scribe_ <- mkHandleScribeWithFormatter formatter

64− (ColorLog False) h permitF verbosity

65− let

66− fileScribe = scribe_

67− { scribeFinalizer = scribeFinalizer scribe_ `finally` hClose h

68− }

69− registerScribe "file" fileScribe defaultScribeSettings logenv

70− where

71− formatter :: forall a. LogItem a => ItemFormatter a

72− formatter = case format of

73− LogBracket -> customBracketFormat additions'

74− LogJson -> customJsonFormat gitRev additions'

75− additions'

76− = HM.fromList

77− . map (\(k, v) -> (textToKey k, String v))

78− $ additions

79−

80−-- | JSON formatter that adds the specified fields to the output

81−customJsonFormat

82− :: forall a. LogItem a => Text -> KeyMap Value -> ItemFormatter a

83−customJsonFormat gitRev additions withColor verb i = (mappend "\n") $

84− -- Here we reimplement the standard formater because we want the

85− -- additional key/value pairs to be added at the top level.

86− -- So we can't use the LogWithAdditions like we do for bracket format

87− T.Builder.fromText $

88− K.colorBySeverity withColor (_itemSeverity i) $

89− (T.toStrict . encodeToLazyText) (extend $ ourItemJson verb i)

90− where

91− extend (Object o) = Object $ HM.union additions' o

92− extend v = v

93− additions' = HM.insert "rev-hash" (toJSON gitRev) additions

94−

95−-- | Bracket formatter that adds the specified fields to the output

96−customBracketFormat

97− :: forall a. LogItem a => KeyMap Value -> ItemFormatter a

98−customBracketFormat additions withColor verb i =

99− bracketFormat withColor verb (LogWithAdditions additions <$> i)

100−

101−-- | Log item payload that adds the specified additional key/value pairs

102−-- to the output on at verbosity levels

103−data LogWithAdditions a = LogWithAdditions (KeyMap Value) a

104− deriving (Show)

105−

106−instance LogItem a => LogItem (LogWithAdditions a) where

107− payloadKeys v (LogWithAdditions additions a) =

108− case payloadKeys v a of

109− AllKeys -> AllKeys

110− SomeKeys keys -> SomeKeys (map keyToText (HM.keys additions) ++ keys)

111−

112−instance ToObject a => ToObject (LogWithAdditions a) where

113− toObject (LogWithAdditions additions a) =

114− HM.union additions (toObject a)

115−

116−setLoggingCtx

117− :: (Has Logger r, Monad m)

118− => Object

119− -> ReaderT r m a

120− -> ReaderT r m a

121−setLoggingCtx ctx' = local (part %~ go)

122− where

123− go (Logger ctx scrbber f) =

124− Logger (ctx <> ctx') scrbber f

src/Control/Logger/Orphans.hsdeleted−47

@@ -1,47 +0,0 @@

1−{-# LANGUAGE ImplicitParams #-}

2−{-# LANGUAGE UndecidableInstances #-}

3−{-# OPTIONS_GHC -Wno-orphans #-}

4−

5−module Control.Logger.Orphans

6− (

7− ) where

8−

9−import Control.EnvT

10−import Control.Has

11−import Control.Logger.Internal

12−import Control.Monad.Logger

13−import qualified Data.Text.Encoding as T

14−import GHC.Stack

15−

16−

17−instance (Has Logger r, MonadIO m)

18− => MonadLogger (EnvT r m) where

19− monadLoggerLog loc _ level msg =

20− let ?callStack = freezeCallStack (locToCallStack loc)

21− in withFrozenCallStack

22− $ logMsg

23− (mlLevelToLogSeverity level)

24− (T.decodeUtf8Lenient . fromLogStr . toLogStr $ msg)

25−

26−locToCallStack :: Loc -> CallStack

27−locToCallStack Loc {..} = fromCallSiteList

28− [ ( ""

29− , SrcLoc

30− { srcLocFile = loc_filename

31− , srcLocPackage = loc_package

32− , srcLocModule = loc_module

33− , srcLocStartLine = fst loc_start

34− , srcLocStartCol = snd loc_start

35− , srcLocEndLine = fst loc_end

36− , srcLocEndCol = snd loc_end

37− }

38− )

39− ]

40−

41−mlLevelToLogSeverity :: LogLevel -> LogSeverity

42−mlLevelToLogSeverity = \case

43− LevelDebug -> Debug

44− LevelInfo -> Info

45− LevelWarn -> Warn

46− LevelError -> Error

47− LevelOther _ -> Error