module System.Wlog.LoggerConfig
( LoggerMap
, RotationParameters (..)
, fromScratch
, isValidRotation
, HandlerWrap (..)
, hwFilePath
, hwRounding
, LoggerTree (..)
, ltFiles
, ltSeverity
, ltSubloggers
, LoggerConfig (..)
, lcConsoleAction
, lcFilePrefix
, lcMapper
, lcRotation
, lcShowTime
, lcShowTid
, lcTermSeverity
, lcTree
, zoomLogger
, consoleActionB
, customConsoleActionB
, mapperB
, maybePrefixB
, prefixB
, productionB
, showTidB
, showTimeB
, termSeverityB
) 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.Handler.Simple (defaultHandleAction)
import System.Wlog.LoggerName (LoggerName)
import System.Wlog.Severity (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
, _lcConsoleAction :: Last (Handle -> Text -> IO ())
, _lcMapper :: Endo LoggerName
, _lcFilePrefix :: Maybe FilePath
, _lcTree :: LoggerTree
}
makeLenses ''LoggerConfig
instance Monoid LoggerConfig where
mempty = LoggerConfig
{ _lcRotation = Nothing
, _lcTermSeverity = Nothing
, _lcShowTime = mempty
, _lcShowTid = mempty
, _lcConsoleAction = mempty
, _lcMapper = mempty
, _lcFilePrefix = Nothing
, _lcTree = mempty
}
lc1 `mappend` lc2 = LoggerConfig
{ _lcRotation = orCombiner _lcRotation
, _lcTermSeverity = orCombiner _lcTermSeverity
, _lcShowTime = andCombiner _lcShowTime
, _lcShowTid = andCombiner _lcShowTid
, _lcConsoleAction = andCombiner _lcConsoleAction
, _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"
, "termSeverity"
, "showTime"
, "showTid"
, "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
_lcFilePrefix <- o .:? "filePrefix"
_lcTree <- parseJSON $ Object $ filterObject topLevelParams o
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
, "termSeverity" .= _lcTermSeverity
, "showTime" .= getAny _lcShowTime
, "showTid" .= getAny _lcShowTid
, "printOutput" .= maybe False (const True) (getLast _lcConsoleAction)
, "filePrefix" .= _lcFilePrefix
, ("logTree", toJSON _lcTree)
]
termSeverityB :: Severity -> LoggerConfig
termSeverityB severity = mempty { _lcTermSeverity = Just severity }
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 }
maybePrefixB :: Maybe FilePath -> LoggerConfig
maybePrefixB prefix = mempty { _lcFilePrefix = prefix }
prefixB :: FilePath -> LoggerConfig
prefixB = maybePrefixB . Just