-- | Backwards-compatible extension to a simple 'LogLevel' parser/filter
--
-- Assume you are using this library/module to parse a @LOG_LEVEL@ environment
-- variable, which is used to filter your logs.
--
-- Running,
--
-- @
-- LOG_LEVEL=warn ./my-program
-- @
--
-- Will do what you expect: filter all logging to only those messages
-- at-or-above @warn@ level.
--
-- While,
--
-- @
-- LOG_LEVEL=debug ./my-program
-- @
--
-- Will enable debug logging throughout.
--
-- This is all un-surprising and this module does not change behavior in this
-- case whatsoever. But let's say that is entirely too noisy. Because you're
-- using Amazonka and persistent, and have correctly integrated your main
-- logging with them, you are now getting /tons/ of spam from their very-chatty
-- debug logs, and its drowning out the application debug logs you were hoping
-- to see.
--
-- Well, now can do this:
--
-- @
-- LOG_LEVEL="debug,Amazonka:info,SQL:warn" ./my-program
-- @
--
-- And suddenly your application's debug logs are standing out again, because
-- everything from the Amazonka source is filtered to info and the SQL source is
-- filtered to warn.
--
-- The format parsed by 'readLogLevels' is:
--
-- @
-- [<source:level>, ...,]<level>[, <source:level>, ...]
-- @
--
-- Where @<level>@ defines the minimum level for anything not overridden by
-- source. If you go on to add any @<source:level>@ pairs, that will change the
-- minimum level for messages from that source.
module Blammo.Logging.LogSettings.LogLevels
  ( LogLevels
  , LogLevel (..)
  , newLogLevels
  , readLogLevels
  , showLogLevels
  , shouldLogLevel
  , defaultLogLevels
  ) where

import Prelude

import Control.Monad.Logger.Aeson
import Data.Either (partitionEithers)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T

data LogLevels = LogLevels
  { LogLevels -> LogLevel
llDefaultLevel :: LogLevel
  , LogLevels -> Map Text LogLevel
llSourceLevels :: Map LogSource LogLevel
  }
  deriving stock (LogLevels -> LogLevels -> Bool
(LogLevels -> LogLevels -> Bool)
-> (LogLevels -> LogLevels -> Bool) -> Eq LogLevels
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogLevels -> LogLevels -> Bool
== :: LogLevels -> LogLevels -> Bool
$c/= :: LogLevels -> LogLevels -> Bool
/= :: LogLevels -> LogLevels -> Bool
Eq, Int -> LogLevels -> ShowS
[LogLevels] -> ShowS
LogLevels -> String
(Int -> LogLevels -> ShowS)
-> (LogLevels -> String)
-> ([LogLevels] -> ShowS)
-> Show LogLevels
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogLevels -> ShowS
showsPrec :: Int -> LogLevels -> ShowS
$cshow :: LogLevels -> String
show :: LogLevels -> String
$cshowList :: [LogLevels] -> ShowS
showList :: [LogLevels] -> ShowS
Show)

newLogLevels :: LogLevel -> [(LogSource, LogLevel)] -> LogLevels
newLogLevels :: LogLevel -> [(Text, LogLevel)] -> LogLevels
newLogLevels LogLevel
level [(Text, LogLevel)]
sourceLevels =
  LogLevels
    { llDefaultLevel :: LogLevel
llDefaultLevel = LogLevel
level
    , llSourceLevels :: Map Text LogLevel
llSourceLevels = [(Text, LogLevel)] -> Map Text LogLevel
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, LogLevel)]
sourceLevels
    }

readLogLevels :: String -> Either String LogLevels
readLogLevels :: String -> Either String LogLevels
readLogLevels String
s = ([LogLevel], [(Text, LogLevel)]) -> Either String LogLevels
toLogLevels (([LogLevel], [(Text, LogLevel)]) -> Either String LogLevels)
-> ([Either LogLevel (Text, LogLevel)]
    -> ([LogLevel], [(Text, LogLevel)]))
-> [Either LogLevel (Text, LogLevel)]
-> Either String LogLevels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either LogLevel (Text, LogLevel)]
-> ([LogLevel], [(Text, LogLevel)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either LogLevel (Text, LogLevel)] -> Either String LogLevels)
-> Either String [Either LogLevel (Text, LogLevel)]
-> Either String LogLevels
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Text -> Either String (Either LogLevel (Text, LogLevel)))
-> [Text] -> Either String [Either LogLevel (Text, LogLevel)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Text -> Either String (Either LogLevel (Text, LogLevel))
readPiece [Text]
pieces
 where
  toLogLevels :: ([LogLevel], [(Text, LogLevel)]) -> Either String LogLevels
toLogLevels = \case
    ([], [(Text, LogLevel)]
_) -> String -> Either String LogLevels
forall {b}. String -> Either String b
invalid String
"no level present"
    (LogLevel
_ : LogLevel
_ : [LogLevel]
_, [(Text, LogLevel)]
_) -> String -> Either String LogLevels
forall {b}. String -> Either String b
invalid String
"more than one level present"
    ([LogLevel
level], [(Text, LogLevel)]
sourceLevels) -> LogLevels -> Either String LogLevels
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LogLevels -> Either String LogLevels)
-> LogLevels -> Either String LogLevels
forall a b. (a -> b) -> a -> b
$ LogLevel -> [(Text, LogLevel)] -> LogLevels
newLogLevels LogLevel
level [(Text, LogLevel)]
sourceLevels

  readPiece :: Text -> Either String (Either LogLevel (Text, LogLevel))
readPiece Text
t = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
":" Text
t of
    (Text
a, Text
":") -> String -> Either String (Either LogLevel (Text, LogLevel))
forall {b}. String -> Either String b
invalid (String -> Either String (Either LogLevel (Text, LogLevel)))
-> String -> Either String (Either LogLevel (Text, LogLevel))
forall a b. (a -> b) -> a -> b
$ String
"no level for source " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
a
    (Text
a, Text
b) | Text -> Bool
T.null Text
a -> String -> Either String (Either LogLevel (Text, LogLevel))
forall {b}. String -> Either String b
invalid (String -> Either String (Either LogLevel (Text, LogLevel)))
-> String -> Either String (Either LogLevel (Text, LogLevel))
forall a b. (a -> b) -> a -> b
$ String
"no source for level" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
b
    (Text
a, Text
b) | Text -> Bool
T.null Text
b -> Either LogLevel (Text, LogLevel)
-> Either String (Either LogLevel (Text, LogLevel))
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LogLevel (Text, LogLevel)
 -> Either String (Either LogLevel (Text, LogLevel)))
-> Either LogLevel (Text, LogLevel)
-> Either String (Either LogLevel (Text, LogLevel))
forall a b. (a -> b) -> a -> b
$ LogLevel -> Either LogLevel (Text, LogLevel)
forall a b. a -> Either a b
Left (LogLevel -> Either LogLevel (Text, LogLevel))
-> LogLevel -> Either LogLevel (Text, LogLevel)
forall a b. (a -> b) -> a -> b
$ Text -> LogLevel
readLogLevel Text
a
    (Text
a, Text
b) -> Either LogLevel (Text, LogLevel)
-> Either String (Either LogLevel (Text, LogLevel))
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LogLevel (Text, LogLevel)
 -> Either String (Either LogLevel (Text, LogLevel)))
-> Either LogLevel (Text, LogLevel)
-> Either String (Either LogLevel (Text, LogLevel))
forall a b. (a -> b) -> a -> b
$ (Text, LogLevel) -> Either LogLevel (Text, LogLevel)
forall a b. b -> Either a b
Right (Text
a, Text -> LogLevel
readLogLevel (Text -> LogLevel) -> Text -> LogLevel
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
1 Text
b)

  pieces :: [Text]
pieces = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"," (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
s

  invalid :: String -> Either String b
invalid String
reason = String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ String
"Invalid log level " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
reason

readLogLevel :: Text -> LogLevel
readLogLevel :: Text -> LogLevel
readLogLevel Text
t = case Text -> Text
T.toLower Text
t of
  Text
"debug" -> LogLevel
LevelDebug
  Text
"info" -> LogLevel
LevelInfo
  Text
"warn" -> LogLevel
LevelWarn
  Text
"error" -> LogLevel
LevelError
  Text
_ -> Text -> LogLevel
LevelOther Text
t

showLogLevels :: LogLevels -> String
showLogLevels :: LogLevels -> String
showLogLevels LogLevels {Map Text LogLevel
LogLevel
llDefaultLevel :: LogLevels -> LogLevel
llSourceLevels :: LogLevels -> Map Text LogLevel
llDefaultLevel :: LogLevel
llSourceLevels :: Map Text LogLevel
..} =
  Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
    Text -> [Text] -> Text
T.intercalate Text
"," ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
      LogLevel -> Text
showLogLevel LogLevel
llDefaultLevel
        Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Text, LogLevel) -> Text) -> [(Text, LogLevel)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map
          (\(Text
s, LogLevel
l) -> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LogLevel -> Text
showLogLevel LogLevel
l)
          (Map Text LogLevel -> [(Text, LogLevel)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text LogLevel
llSourceLevels)

showLogLevel :: LogLevel -> Text
showLogLevel :: LogLevel -> Text
showLogLevel = \case
  LogLevel
LevelDebug -> Text
"debug"
  LogLevel
LevelInfo -> Text
"info"
  LogLevel
LevelWarn -> Text
"warn"
  LogLevel
LevelError -> Text
"error"
  LevelOther Text
t -> Text
t

shouldLogLevel :: LogLevels -> LogSource -> LogLevel -> Bool
shouldLogLevel :: LogLevels -> Text -> LogLevel -> Bool
shouldLogLevel LogLevels {Map Text LogLevel
LogLevel
llDefaultLevel :: LogLevels -> LogLevel
llSourceLevels :: LogLevels -> Map Text LogLevel
llDefaultLevel :: LogLevel
llSourceLevels :: Map Text LogLevel
..} Text
source = (LogLevel -> LogLevel -> Bool
`lgte` LogLevel
minLevel)
 where
  minLevel :: LogLevel
minLevel = LogLevel -> Maybe LogLevel -> LogLevel
forall a. a -> Maybe a -> a
fromMaybe LogLevel
llDefaultLevel (Maybe LogLevel -> LogLevel) -> Maybe LogLevel -> LogLevel
forall a b. (a -> b) -> a -> b
$ Text -> Map Text LogLevel -> Maybe LogLevel
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
source Map Text LogLevel
llSourceLevels

defaultLogLevels :: LogLevels
defaultLogLevels :: LogLevels
defaultLogLevels =
  LogLevels {llDefaultLevel :: LogLevel
llDefaultLevel = LogLevel
LevelInfo, llSourceLevels :: Map Text LogLevel
llSourceLevels = Map Text LogLevel
forall k a. Map k a
Map.empty}

-- | Like '(>=)', but treats @'LevelOther' "trace"@ as below 'LevelDebug'
--
-- Normally, 'LevelOther' is the highest level, but it's common to use the
-- @trace@ level as more verbose than @debug@. With this comparison in use, we
-- can safely use @'LevelOther' "trace"@ for that.
lgte :: LogLevel -> LogLevel -> Bool
lgte :: LogLevel -> LogLevel -> Bool
lgte LogLevel
_ (LevelOther Text
x) | Text -> Text
T.toLower Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"trace" = Bool
True
lgte (LevelOther Text
x) LogLevel
_ | Text -> Text
T.toLower Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"trace" = Bool
False
lgte LogLevel
a LogLevel
b = LogLevel
a LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
b