{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module System.Wlog.LoggerConfig
( LoggerMap
, RotationParameters (..)
, fromScratch
, isValidRotation
, HandlerWrap (..)
, hwFilePath
, hwRounding
, LoggerTree (..)
, ltFiles
, ltSeverity
, ltSubloggers
, LoggerConfig (..)
, lcConsoleAction
, lcLogsDirectory
, lcMapper
, lcRotation
, lcShowTime
, lcShowTid
, lcTermSeverityOut
, lcTermSeverityErr
, lcTree
, zoomLogger
, atLogger
, consoleActionB
, customConsoleActionB
, mapperB
, maybeLogsDirB
, logsDirB
, productionB
, showTidB
, showTimeB
, termSeveritiesOutB
, termSeveritiesErrB
) where
import Universum
import Data.Aeson (withObject)
import Data.Traversable (for)
import Data.Yaml (FromJSON (..), Object, Parser, ToJSON (..), Value (..), object, (.!=), (.:),
(.:?), (.=))
import Fmt (build, (||+))
import Lens.Micro.Platform (at, makeLenses, zoom, _Just)
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 Text
import qualified Data.Vector as Vector
import qualified GHC.Show as Show
filterObject :: [Text] -> HashMap Text a -> HashMap LoggerName a
filterObject excluded = HM.fromList . map (first LoggerName) . HM.toList . HM.filterWithKey (\k _ -> k `notElem` excluded)
parseSeverities :: Object -> Text -> Parser (Maybe Severities)
parseSeverities o term =
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 $ toString $ "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 LoggerName LoggerTree
data LoggerTree = LoggerTree
{ _ltSubloggers :: !LoggerMap
, _ltFiles :: ![HandlerWrap]
, _ltSeverity :: !(Maybe Severities)
} deriving (Generic, Show)
makeLenses ''LoggerTree
instance Semigroup LoggerTree where
lt1 <> lt2 = LoggerTree
{ _ltFiles = andCombiner _ltFiles
, _ltSeverity = orCombiner _ltSeverity
, _ltSubloggers = andCombiner _ltSubloggers
}
where
orCombiner field = field lt1 <|> field lt2
andCombiner field = field lt1 <> field lt2
instance Monoid LoggerTree where
mempty = LoggerTree
{ _ltFiles = []
, _ltSeverity = Nothing
, _ltSubloggers = mempty
}
mappend = (<>)
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 (`HandlerWrap` Nothing) $
maybeToList 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 :: LoggerName -> 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 RotationParameters where
build x = x||+""
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
, _lcLogsDirectory :: Maybe FilePath
, _lcTree :: LoggerTree
}
makeLenses ''LoggerConfig
instance Semigroup LoggerConfig where
lc1 <> lc2 = LoggerConfig
{ _lcRotation = orCombiner _lcRotation
, _lcTermSeverityOut = orCombiner _lcTermSeverityOut
, _lcTermSeverityErr = orCombiner _lcTermSeverityErr
, _lcShowTime = andCombiner _lcShowTime
, _lcShowTid = andCombiner _lcShowTid
, _lcConsoleAction = andCombiner _lcConsoleAction
, _lcMapper = andCombiner _lcMapper
, _lcLogsDirectory = orCombiner _lcLogsDirectory
, _lcTree = andCombiner _lcTree
}
where
orCombiner field = field lc1 <|> field lc2
andCombiner field = field lc1 <> field lc2
instance Monoid LoggerConfig where
mempty = LoggerConfig
{ _lcRotation = Nothing
, _lcTermSeverityOut = Nothing
, _lcTermSeverityErr = Nothing
, _lcShowTime = mempty
, _lcShowTid = mempty
, _lcConsoleAction = mempty
, _lcMapper = mempty
, _lcLogsDirectory = Nothing
, _lcTree = mempty
}
mappend = (<>)
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
_lcLogsDirectory <- o .:? "filePrefix"
_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" .= isJust (getLast _lcConsoleAction)
, "filePrefix" .= _lcLogsDirectory
, ("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 }
maybeLogsDirB :: Maybe FilePath -> LoggerConfig
maybeLogsDirB prefix = mempty { _lcLogsDirectory = prefix }
logsDirB :: FilePath -> LoggerConfig
logsDirB = maybeLogsDirB . Just
atLogger :: LoggerName -> Traversal' LoggerConfig LoggerTree
atLogger logName = lcTree . leveldown (LoggerName <$> Text.splitOn "." (getLoggerName logName))
where
leveldown :: [LoggerName] -> Traversal' LoggerTree LoggerTree
leveldown [] = bug EmptyLoggerName
leveldown [x] = getSublogger x
leveldown (x:xs) = getSublogger x . leveldown xs
getSublogger :: LoggerName -> Traversal' LoggerTree LoggerTree
getSublogger x = ltSubloggers . at x . _Just
data LoggerLensException = EmptyLoggerName
instance Exception LoggerLensException
instance Show LoggerLensException where
show EmptyLoggerName = "Logger name should be provided"