module System.Wlog.LoggerConfig
( LoggerMap
, RotationParameters (..)
, fromScratch
, isValidRotation
, HandlerWrap (..)
, hwFilePath
, hwRounding
, LoggerTree (..)
, ltFiles
, ltSeverity
, ltSubloggers
, LoggerConfig (..)
, lcConsoleOutput
, lcFilePrefix
, lcMapper
, lcRotation
, lcShowTime
, lcShowTid
, lcTermSeverity
, lcTree
, zoomLogger
, consoleOutB
, mapperB
, maybePrefixB
, prefixB
, productionB
, showTidB
, showTimeB
) where
import Universum
import Control.Lens (at, makeLenses, zoom, _Just)
import Control.Monad.State (put)
import Data.Aeson (withObject)
import qualified Data.HashMap.Strict as HM hiding (HashMap)
import Data.Monoid (Any (..))
import Data.Text (Text)
import qualified Data.Text.Buildable as Buildable
import Data.Traversable (for)
import Data.Word (Word64)
import Data.Yaml (FromJSON (..), ToJSON (..), Value (Object),
object, (.!=), (.:), (.:?), (.=))
import Formatting (bprint, shown)
import GHC.Generics (Generic)
import System.FilePath (normalise)
import System.Wlog.LoggerName (LoggerName)
import System.Wlog.Wrapper (Severity)
filterObject :: [Text] -> HashMap Text a -> HashMap Text a
filterObject excluded = HM.filterWithKey $ \k _ -> k `notElem` excluded
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 Severity)
} 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 <- 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
, _lcTermSeverity :: Maybe Severity
, _lcShowTime :: Any
, _lcShowTid :: Any
, _lcConsoleOutput :: Any
, _lcMapper :: Endo LoggerName
, _lcFilePrefix :: Maybe FilePath
, _lcTree :: LoggerTree
}
makeLenses ''LoggerConfig
instance Monoid LoggerConfig where
mempty = LoggerConfig
{ _lcRotation = Nothing
, _lcTermSeverity = Nothing
, _lcShowTime = mempty
, _lcShowTid = mempty
, _lcConsoleOutput = mempty
, _lcMapper = mempty
, _lcFilePrefix = Nothing
, _lcTree = mempty
}
lc1 `mappend` lc2 = LoggerConfig
{ _lcRotation = orCombiner _lcRotation
, _lcTermSeverity = orCombiner _lcTermSeverity
, _lcShowTime = andCombiner _lcShowTime
, _lcShowTid = andCombiner _lcShowTid
, _lcConsoleOutput = andCombiner _lcConsoleOutput
, _lcMapper = andCombiner _lcMapper
, _lcFilePrefix = orCombiner _lcFilePrefix
, _lcTree = andCombiner _lcTree
}
where
orCombiner field = field lc1 <|> field lc2
andCombiner field = field lc1 <> field lc2
topLevelParams :: [Text]
topLevelParams =
["rotation", "showTime", "printOutput", "filePrefix" ]
instance FromJSON LoggerConfig where
parseJSON = withObject "rotation params" $ \o -> do
_lcRotation <- o .:? "rotation"
_lcTermSeverity <- o .:? "termSeverity"
_lcShowTime <- Any <$> o .:? "showTime" .!= False
_lcShowTid <- Any <$> o .:? "showTid" .!= False
_lcConsoleOutput <- Any <$> o .:? "printOutput" .!= False
_lcFilePrefix <- o .:? "filePrefix"
_lcTree <- parseJSON $ Object $ filterObject topLevelParams o
let _lcMapper = mempty
return LoggerConfig{..}
instance ToJSON LoggerConfig where
toJSON LoggerConfig{..} = object
[ "rotation" .= _lcRotation
, "termSeverity" .= _lcTermSeverity
, "showTime" .= getAny _lcShowTime
, "showTid" .= getAny _lcShowTid
, "printOutput" .= getAny _lcConsoleOutput
, "filePrefix" .= _lcFilePrefix
, ("logTree", toJSON _lcTree)
]
showTimeB :: LoggerConfig
showTimeB = mempty { _lcShowTime = Any True }
showTidB :: LoggerConfig
showTidB = mempty { _lcShowTid = Any True }
consoleOutB :: LoggerConfig
consoleOutB = mempty { _lcConsoleOutput = Any True }
productionB :: LoggerConfig
productionB = showTimeB <> consoleOutB
mapperB :: (LoggerName -> LoggerName) -> LoggerConfig
mapperB loggerNameMapper = mempty { _lcMapper = Endo loggerNameMapper }
maybePrefixB :: Maybe FilePath -> LoggerConfig
maybePrefixB prefix = mempty { _lcFilePrefix = prefix }
prefixB :: FilePath -> LoggerConfig
prefixB = maybePrefixB . Just