{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module System.Wlog.LoggerConfig
( LoggerMap
, RotationParameters (..)
, fromScratch
, isValidRotation
, HandlerWrap (..)
, hwFilePath
, hwRounding
, LoggerTree (..)
, ltFiles
, ltSeverity
, ltSubloggers
, LoggerConfig (..)
, lcConsoleAction
, lcMapper
, lcRotation
, lcShowTime
, lcShowTid
, lcTermSeverityOut
, lcTermSeverityErr
, lcTree
, zoomLogger
, consoleActionB
, customConsoleActionB
, mapperB
, productionB
, showTidB
, showTimeB
, termSeveritiesOutB
, termSeveritiesErrB
) where
import Universum
import Control.Lens (at, makeLenses, zoom, _Just)
import Control.Monad.State (put)
import Data.Aeson (withObject)
import Data.Monoid (Any (..))
import Data.Text (Text)
import Data.Traversable (for)
import Data.Word (Word64)
import Data.Yaml (FromJSON (..), Object, Parser, ToJSON (..), Value (..), object, (.!=), (.:),
(.:?), (.=))
import Formatting (bprint, shown)
import GHC.Generics (Generic)
import System.FilePath (normalise)
import System.Wlog.LoggerName (LoggerName)
import System.Wlog.LogHandler.Simple (defaultHandleAction)
import System.Wlog.Severity (Severities, allSeverities, debugPlus, errorPlus, infoPlus, noticePlus,
warningPlus)
import qualified Data.HashMap.Strict as HM hiding (HashMap)
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Buildable as Buildable
import qualified Data.Vector as Vector
filterObject :: [Text] -> HashMap Text a -> HashMap Text a
filterObject excluded = HM.filterWithKey $ \k _ -> k `notElem` excluded
parseSeverities :: Object -> Text -> Parser (Maybe Severities)
parseSeverities o term = do
case HM.lookup term o of
Just value -> case value of
String word -> case word of
"All" -> pure $ Just allSeverities
"Debug+" -> pure $ Just debugPlus
"Info+" -> pure $ Just infoPlus
"Notice+" -> pure $ Just noticePlus
"Warning+" -> pure $ Just warningPlus
"Error+" -> pure $ Just errorPlus
_ -> fail $ T.unpack $ "Unknown severity: " <> word
Array sevs -> Just . Set.fromList . Vector.toList <$> Vector.mapM parseJSON sevs
_ -> fail "Incorrect severities format"
Nothing -> pure $ Nothing
data HandlerWrap = HandlerWrap
{ _hwFilePath :: !FilePath
, _hwRounding :: !(Maybe Int)
} deriving (Generic,Show)
makeLenses ''HandlerWrap
type LoggerMap = HashMap Text LoggerTree
data LoggerTree = LoggerTree
{ _ltSubloggers :: !LoggerMap
, _ltFiles :: ![HandlerWrap]
, _ltSeverity :: !(Maybe Severities)
} deriving (Generic, Show)
makeLenses ''LoggerTree
instance Monoid LoggerTree where
mempty = LoggerTree
{ _ltFiles = []
, _ltSeverity = Nothing
, _ltSubloggers = mempty
}
lt1 `mappend` lt2 = LoggerTree
{ _ltFiles = _ltFiles lt1 <> _ltFiles lt2
, _ltSeverity = _ltSeverity lt1 <|> _ltSeverity lt2
, _ltSubloggers = _ltSubloggers lt1 <> _ltSubloggers lt2
}
instance ToJSON HandlerWrap
instance FromJSON HandlerWrap where
parseJSON = withObject "handler wrap" $ \o -> do
(_hwFilePath :: FilePath) <- normalise <$> o .: "file"
(_hwRounding :: Maybe Int) <- o .:? "round"
pure HandlerWrap{..}
nonLoggers :: [Text]
nonLoggers = ["file", "files", "severity", "rounding", "handlers"]
instance ToJSON LoggerTree
instance FromJSON LoggerTree where
parseJSON = withObject "loggers tree" $ \o -> do
(singleFile :: Maybe FilePath) <- fmap normalise <$> o .:? "file"
(manyFiles :: [FilePath]) <- map normalise <$> (o .:? "files" .!= [])
handlers <- o .:? "handlers" .!= []
let fileHandlers =
map (\fp -> HandlerWrap fp Nothing) $
maybe [] (:[]) singleFile ++ manyFiles
let _ltFiles = fileHandlers <> handlers
_ltSeverity <- parseSeverities o "severity"
_ltSubloggers <- for (filterObject nonLoggers o) parseJSON
return LoggerTree{..}
fromScratch :: Monoid m => State m a -> m
fromScratch = executingState mempty
zoomLogger :: Text -> State LoggerTree () -> State LoggerTree ()
zoomLogger loggerName initializer = zoom (ltSubloggers.at loggerName) $ do
put $ Just mempty
zoom _Just initializer
data RotationParameters = RotationParameters
{ rpLogLimit :: !Word64
, rpKeepFiles :: !Word
} deriving (Generic, Show)
instance Buildable.Buildable RotationParameters where
build = bprint shown
instance ToJSON RotationParameters
instance FromJSON RotationParameters where
parseJSON = withObject "rotation params" $ \o -> do
rpLogLimit <- o .: "logLimit"
rpKeepFiles <- o .: "keepFiles"
return RotationParameters{..}
isValidRotation :: RotationParameters -> Bool
isValidRotation RotationParameters{..} = rpLogLimit > 0 && rpKeepFiles > 0
data LoggerConfig = LoggerConfig
{
_lcRotation :: Maybe RotationParameters
, _lcTermSeverityOut :: Maybe Severities
, _lcTermSeverityErr :: Maybe Severities
, _lcShowTime :: Any
, _lcShowTid :: Any
, _lcConsoleAction :: Last (Handle -> Text -> IO ())
, _lcMapper :: Endo LoggerName
, _lcTree :: LoggerTree
}
makeLenses ''LoggerConfig
instance Monoid LoggerConfig where
mempty = LoggerConfig
{ _lcRotation = Nothing
, _lcTermSeverityOut = Nothing
, _lcTermSeverityErr = Nothing
, _lcShowTime = mempty
, _lcShowTid = mempty
, _lcConsoleAction = mempty
, _lcMapper = mempty
, _lcTree = mempty
}
lc1 `mappend` lc2 = LoggerConfig
{ _lcRotation = orCombiner _lcRotation
, _lcTermSeverityOut = orCombiner _lcTermSeverityOut
, _lcTermSeverityErr = orCombiner _lcTermSeverityErr
, _lcShowTime = andCombiner _lcShowTime
, _lcShowTid = andCombiner _lcShowTid
, _lcConsoleAction = andCombiner _lcConsoleAction
, _lcMapper = andCombiner _lcMapper
, _lcTree = andCombiner _lcTree
}
where
orCombiner field = field lc1 <|> field lc2
andCombiner field = field lc1 <> field lc2
instance FromJSON LoggerConfig where
parseJSON = withObject "rotation params" $ \o -> do
_lcRotation <- o .:? "rotation"
_lcTermSeverityOut <- parseSeverities o "termSeveritiesOut"
_lcTermSeverityErr <- parseSeverities o "termSeveritiesErr"
_lcShowTime <- Any <$> o .:? "showTime" .!= False
_lcShowTid <- Any <$> o .:? "showTid" .!= False
_lcTree <- o .:? "loggerTree" .!= mempty
printConsoleFlag <- o .:? "printOutput" .!= False
let _lcConsoleAction = Last $ bool Nothing (Just defaultHandleAction) printConsoleFlag
let _lcMapper = mempty
return LoggerConfig{..}
instance ToJSON LoggerConfig where
toJSON LoggerConfig{..} = object
[ "rotation" .= _lcRotation
, "termSeveritiesOut" .= _lcTermSeverityOut
, "termSeveritiesErr" .= _lcTermSeverityErr
, "showTime" .= getAny _lcShowTime
, "showTid" .= getAny _lcShowTid
, "printOutput" .= maybe False (const True) (getLast _lcConsoleAction)
, ("logTree", toJSON _lcTree)
]
termSeveritiesOutB :: Severities -> LoggerConfig
termSeveritiesOutB severities = mempty { _lcTermSeverityOut = Just severities }
termSeveritiesErrB :: Severities -> LoggerConfig
termSeveritiesErrB severities = mempty { _lcTermSeverityErr = Just severities }
showTimeB :: LoggerConfig
showTimeB = mempty { _lcShowTime = Any True }
showTidB :: LoggerConfig
showTidB = mempty { _lcShowTid = Any True }
consoleActionB :: (Handle -> Text -> IO ()) -> LoggerConfig
consoleActionB action = mempty { _lcConsoleAction = Last $ Just action }
customConsoleActionB :: Maybe (Handle -> Text -> IO ()) -> LoggerConfig
customConsoleActionB action = mempty { _lcConsoleAction = Last action }
productionB :: LoggerConfig
productionB = showTimeB <> customConsoleActionB (Just defaultHandleAction)
mapperB :: (LoggerName -> LoggerName) -> LoggerConfig
mapperB loggerNameMapper = mempty { _lcMapper = Endo loggerNameMapper }