module Blammo.Logging.LogSettings.LogLevels
( LogLevels
, LogLevel(..)
, newLogLevels
, readLogLevels
, 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 LogSource 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
/= :: LogLevels -> LogLevels -> Bool
$c/= :: LogLevels -> LogLevels -> Bool
== :: LogLevels -> LogLevels -> Bool
$c== :: 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
showList :: [LogLevels] -> ShowS
$cshowList :: [LogLevels] -> ShowS
show :: LogLevels -> String
$cshow :: LogLevels -> String
showsPrec :: Int -> LogLevels -> ShowS
$cshowsPrec :: Int -> LogLevels -> ShowS
Show)
newLogLevels :: LogLevel -> [(LogSource, LogLevel)] -> LogLevels
newLogLevels :: LogLevel -> [(LogSource, LogLevel)] -> LogLevels
newLogLevels LogLevel
level [(LogSource, LogLevel)]
sourceLevels = LogLevels :: LogLevel -> Map LogSource LogLevel -> LogLevels
LogLevels
{ llDefaultLevel :: LogLevel
llDefaultLevel = LogLevel
level
, llSourceLevels :: Map LogSource LogLevel
llSourceLevels = [(LogSource, LogLevel)] -> Map LogSource LogLevel
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(LogSource, LogLevel)]
sourceLevels
}
readLogLevels :: String -> Either String LogLevels
readLogLevels :: String -> Either String LogLevels
readLogLevels String
s = ([LogLevel], [(LogSource, LogLevel)]) -> Either String LogLevels
toLogLevels (([LogLevel], [(LogSource, LogLevel)]) -> Either String LogLevels)
-> ([Either LogLevel (LogSource, LogLevel)]
-> ([LogLevel], [(LogSource, LogLevel)]))
-> [Either LogLevel (LogSource, LogLevel)]
-> Either String LogLevels
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either LogLevel (LogSource, LogLevel)]
-> ([LogLevel], [(LogSource, LogLevel)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either LogLevel (LogSource, LogLevel)]
-> Either String LogLevels)
-> Either String [Either LogLevel (LogSource, LogLevel)]
-> Either String LogLevels
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (LogSource
-> Either String (Either LogLevel (LogSource, LogLevel)))
-> [LogSource]
-> Either String [Either LogLevel (LogSource, LogLevel)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse LogSource -> Either String (Either LogLevel (LogSource, LogLevel))
readPiece [LogSource]
pieces
where
toLogLevels :: ([LogLevel], [(LogSource, LogLevel)]) -> Either String LogLevels
toLogLevels = \case
([], [(LogSource, LogLevel)]
_) -> String -> Either String LogLevels
forall b. String -> Either String b
invalid String
"no level present"
(LogLevel
_ : LogLevel
_ : [LogLevel]
_, [(LogSource, LogLevel)]
_) -> String -> Either String LogLevels
forall b. String -> Either String b
invalid String
"more than one level present"
([LogLevel
level], [(LogSource, LogLevel)]
sourceLevels) -> LogLevels -> Either String LogLevels
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 -> [(LogSource, LogLevel)] -> LogLevels
newLogLevels LogLevel
level [(LogSource, LogLevel)]
sourceLevels
readPiece :: LogSource -> Either String (Either LogLevel (LogSource, LogLevel))
readPiece LogSource
t = case LogSource -> LogSource -> (LogSource, LogSource)
T.breakOn LogSource
":" LogSource
t of
(LogSource
a, LogSource
":") -> String -> Either String (Either LogLevel (LogSource, LogLevel))
forall b. String -> Either String b
invalid (String -> Either String (Either LogLevel (LogSource, LogLevel)))
-> String -> Either String (Either LogLevel (LogSource, LogLevel))
forall a b. (a -> b) -> a -> b
$ String
"no level for source " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> LogSource -> String
unpack LogSource
a
(LogSource
a, LogSource
b) | LogSource -> Bool
T.null LogSource
a -> String -> Either String (Either LogLevel (LogSource, LogLevel))
forall b. String -> Either String b
invalid (String -> Either String (Either LogLevel (LogSource, LogLevel)))
-> String -> Either String (Either LogLevel (LogSource, LogLevel))
forall a b. (a -> b) -> a -> b
$ String
"no source for level" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> LogSource -> String
unpack LogSource
b
(LogSource
a, LogSource
b) | LogSource -> Bool
T.null LogSource
b -> Either LogLevel (LogSource, LogLevel)
-> Either String (Either LogLevel (LogSource, LogLevel))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LogLevel (LogSource, LogLevel)
-> Either String (Either LogLevel (LogSource, LogLevel)))
-> Either LogLevel (LogSource, LogLevel)
-> Either String (Either LogLevel (LogSource, LogLevel))
forall a b. (a -> b) -> a -> b
$ LogLevel -> Either LogLevel (LogSource, LogLevel)
forall a b. a -> Either a b
Left (LogLevel -> Either LogLevel (LogSource, LogLevel))
-> LogLevel -> Either LogLevel (LogSource, LogLevel)
forall a b. (a -> b) -> a -> b
$ LogSource -> LogLevel
readLogLevel LogSource
a
(LogSource
a, LogSource
b) -> Either LogLevel (LogSource, LogLevel)
-> Either String (Either LogLevel (LogSource, LogLevel))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LogLevel (LogSource, LogLevel)
-> Either String (Either LogLevel (LogSource, LogLevel)))
-> Either LogLevel (LogSource, LogLevel)
-> Either String (Either LogLevel (LogSource, LogLevel))
forall a b. (a -> b) -> a -> b
$ (LogSource, LogLevel) -> Either LogLevel (LogSource, LogLevel)
forall a b. b -> Either a b
Right (LogSource
a, LogSource -> LogLevel
readLogLevel (LogSource -> LogLevel) -> LogSource -> LogLevel
forall a b. (a -> b) -> a -> b
$ Int -> LogSource -> LogSource
T.drop Int
1 LogSource
b)
pieces :: [LogSource]
pieces = (LogSource -> Bool) -> [LogSource] -> [LogSource]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (LogSource -> Bool) -> LogSource -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> Bool
T.null) ([LogSource] -> [LogSource]) -> [LogSource] -> [LogSource]
forall a b. (a -> b) -> a -> b
$ (LogSource -> LogSource) -> [LogSource] -> [LogSource]
forall a b. (a -> b) -> [a] -> [b]
map LogSource -> LogSource
T.strip ([LogSource] -> [LogSource]) -> [LogSource] -> [LogSource]
forall a b. (a -> b) -> a -> b
$ LogSource -> LogSource -> [LogSource]
T.splitOn LogSource
"," (LogSource -> [LogSource]) -> LogSource -> [LogSource]
forall a b. (a -> b) -> a -> b
$ String -> LogSource
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 :: LogSource -> LogLevel
readLogLevel LogSource
t = case LogSource -> LogSource
T.toLower LogSource
t of
LogSource
"debug" -> LogLevel
LevelDebug
LogSource
"info" -> LogLevel
LevelInfo
LogSource
"warn" -> LogLevel
LevelWarn
LogSource
"error" -> LogLevel
LevelError
LogSource
_ -> LogSource -> LogLevel
LevelOther LogSource
t
shouldLogLevel :: LogLevels -> LogSource -> LogLevel -> Bool
shouldLogLevel :: LogLevels -> LogSource -> LogLevel -> Bool
shouldLogLevel LogLevels {Map LogSource LogLevel
LogLevel
llSourceLevels :: Map LogSource LogLevel
llDefaultLevel :: LogLevel
llSourceLevels :: LogLevels -> Map LogSource LogLevel
llDefaultLevel :: LogLevels -> LogLevel
..} LogSource
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
$ LogSource -> Map LogSource LogLevel -> Maybe LogLevel
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup LogSource
source Map LogSource LogLevel
llSourceLevels
defaultLogLevels :: LogLevels
defaultLogLevels :: LogLevels
defaultLogLevels =
LogLevels :: LogLevel -> Map LogSource LogLevel -> LogLevels
LogLevels { llDefaultLevel :: LogLevel
llDefaultLevel = LogLevel
LevelInfo, llSourceLevels :: Map LogSource LogLevel
llSourceLevels = Map LogSource LogLevel
forall k a. Map k a
Map.empty }
lgte :: LogLevel -> LogLevel -> Bool
lgte :: LogLevel -> LogLevel -> Bool
lgte LogLevel
_ (LevelOther LogSource
x) | LogSource -> LogSource
T.toLower LogSource
x LogSource -> LogSource -> Bool
forall a. Eq a => a -> a -> Bool
== LogSource
"trace" = Bool
True
lgte (LevelOther LogSource
x) LogLevel
_ | LogSource -> LogSource
T.toLower LogSource
x LogSource -> LogSource -> Bool
forall a. Eq a => a -> a -> Bool
== LogSource
"trace" = Bool
False
lgte LogLevel
a LogLevel
b = LogLevel
a LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= LogLevel
b