log4hs-0.9.0.0: src/Logging/Config/Type.hs
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Logging.Config.Type
( Handler(..)
, Sink(..)
, Config(..)
, ConfigException(..)
, HandlerH(..)
, SinkH(..)
, ConfigH(..)
, createManager
) where
import Control.Concurrent.MVar
import Control.Exception (Exception)
import Data.Aeson
import Data.Aeson.Default
import Data.Aeson.Default.HKD
import Data.Aeson.Default.Map.Strict
import Data.Functor.Identity
import Data.IORef
import Data.Map.Lazy
import Data.Maybe
import Data.String
import Data.Time.Clock
import Data.Time.LocalTime
import GHC.Generics
import Prelude hiding (map)
import qualified Prelude as P
import System.IO
import Text.Format hiding (defaultOptions)
import qualified Logging.Class as T
import qualified Logging.Filter as T
import qualified Logging.Handler.FileHandler as T
import qualified Logging.Handler.RotatingFileHandler as T
import qualified Logging.Handler.StreamHandler as T
import qualified Logging.Handler.TimeRotatingFileHandler as T
import qualified Logging.Level as T
import qualified Logging.Manager as T
import Logging.Prelude
import qualified Logging.Sink as T
{-| A datatype used to decode json or yaml into 'Handler' datatypes.
All 'HKD' wrapped and 'Maybe' fields are optional fields, they can be omitted.
There are tow config file templates in "Logging.Config.Json" and
"Logging.Config.Yaml".
Note: When decoding from json or yaml, use 'type' field to specify handler type.
-}
data HandlerH f = StreamHandler { level :: HKD T.Level f
-- ^ Default is @NOTSET@.
, filterer :: HKD T.Filterer f
-- ^ Default is [].
, formatter :: HKD String f
-- ^ It represents key of 'ConfigH''s
-- formatters.
, stream :: HKD String f
-- ^ Only support 'stderr' and 'stdout',
-- default is 'stderr'.
}
| FileHandler { level :: HKD T.Level f
-- ^ Default is @NOTSET@.
, filterer :: HKD T.Filterer f
-- ^ Default is [].
, formatter :: HKD String f
-- ^ It represents key of 'ConfigH''s
-- formatters.
, file :: FilePath
, encoding :: HKD String f
-- ^ See 'System.IO.mkTextEncoding',
-- default is utf8.
}
| RotatingFileHandler { level :: HKD T.Level f
-- ^ Default is @NOTSET@.
, filterer :: HKD T.Filterer f
-- ^ Default is [].
, formatter :: HKD String f
-- ^ It represents key of 'ConfigH''s
-- formatters.
, file :: FilePath
, encoding :: HKD String f
-- ^ See 'System.IO.mkTextEncoding',
-- default is utf8.
, maxBytes :: HKD Int f
-- ^ Default is 100 MB.
, backupCount :: HKD Int f
-- ^ Default is 10.
}
| TimeRotatingFileHandler { level :: HKD T.Level f
-- ^ Default is @NOTSET@.
, filterer :: HKD T.Filterer f
-- ^ Default is [].
, formatter :: HKD String f
-- ^ It represents key of 'ConfigH''s
-- formatters.
, file :: FilePath
, encoding :: HKD String f
, timezone :: Maybe String
-- ^ If not set, same as 'Manager''s
-- timezone.
, rotateTime :: HKD T.RotateTime f
-- ^ Indicates when to rotate file,
-- e.g. @D3@ means every 3 days,
-- @W4@ means at 0 clock of 'Thursday',
-- try reading and showing
-- 'RotateTime'.
, backupCount :: HKD Int f
}
-- ^ @since 0.7.0
deriving Generic
instance FromJSON (HandlerH Maybe) where
parseJSON = genericParseJSON option
where
sumEncoding = defaultTaggedObject { tagFieldName = "type" }
option = defaultOptions { sumEncoding = sumEncoding }
instance Default HandlerH where
constrDef constr
| constr == "StreamHandler" = StreamHandler{..}
| constr == "FileHandler" = FileHandler{..}
| constr == "RotatingFileHandler" = RotatingFileHandler{..}
| constr == "TimeRotatingFileHandler" = TimeRotatingFileHandler{..}
where
(level, filterer, formatter) = ("NOTSET", [], "{message}")
(stream, file, encoding) = ("stderr", "./logging.log", "UTF-8")
(maxBytes, backupCount) = (104857600, 10)
(timezone, rotateTime) = (Nothing, T.Day 1)
type Handler = HandlerH Identity
--------------------------------------------------------------------------------
data SinkH f = Sink { level :: HKD T.Level f
-- Default is "NOTSET"
, filterer :: HKD T.Filterer f
-- Default is []
, handlers :: HKD [String] f
-- ^ A list of key of 'ConfigH''s handlers
, propagate :: HKD Bool f
, disabled :: HKD Bool f
} deriving Generic
instance FromJSON (SinkH Maybe)
instance Default SinkH where
constrDef _ = Sink "NOTSET" [] [] True False
type Sink = SinkH Identity
--------------------------------------------------------------------------------
data ConfigH f = Config { sinks :: HKD (MapH String SinkH f) f
, handlers :: HKD (MapH String HandlerH f) f
, formatters :: HKD (Map String String) f
-- See "Format1" to learn how to write format string.
, timezone :: Maybe String -- ^ @since 0.7.0
-- Default is the result of 'getCurrentTimeZone'.
, disabled :: HKD Bool f
} deriving Generic
instance FromJSON (ConfigH Maybe)
instance Default ConfigH where
constrDef _ = Config mempty mempty mempty Nothing False
type Config = ConfigH Identity
--------------------------------------------------------------------------------
newtype ConfigException = ConfigException { message :: String }
instance Show ConfigException where
show e = "Logging Config Exception: " ++ (message e)
instance Exception ConfigException
--------------------------------------------------------------------------------
{-| Create "Logging.Manager.Manager" from 'Config'.
This function is only used by "Logging.Config.Json" and "Logging.Config.Yaml",
use functions provided in these two modules directly.
-}
createManager :: Config -> IO T.Manager
createManager Config{..} = do
hs <- mapM (createHandler $ map fromString formatters) $ unMapH handlers
ss <- sequence $ mapWithKey (createSink hs) $ unMapH sinks
timezone <- maybe getCurrentTimeZone (pure . read) timezone
let root = findWithDefault defaultRoot "root" ss
sinks = delete "root" ss
catchUncaughtException = False -- TODO remove
return $ T.Manager{..}
where
stderrHandler :: T.SomeHandler
stderrHandler = T.toHandler $ T.StreamHandler "NOTSET" [] "{message}" stderr
defaultRoot :: T.Sink
defaultRoot = T.Sink "" "DEBUG" [] [stderrHandler] False False
createSink :: Map String T.SomeHandler -> String -> Sink -> IO T.Sink
createSink hs logger Sink{..} = do
logger <- pure $ if logger == "root" then "" else logger
handlers <- pure [hs ! h | h <- handlers]
return $ T.Sink{..}
createHandler :: Map String Format1 -> Handler -> IO T.SomeHandler
createHandler fs StreamHandler{..} = do
formatter <- pure $ fs ! formatter
stream <- pure $ mkStdHandle stream
return $ T.toHandler $ T.StreamHandler{..}
createHandler fs FileHandler{..} = do
formatter <- pure $ fs ! formatter
encoding <- mkTextEncoding encoding
stream <- newIORef undefined
return $ T.toHandler $ T.FileHandler{..}
createHandler fs RotatingFileHandler{..} = do
formatter <- return $ fs ! formatter
encoding <- mkTextEncoding encoding
stream <- newEmptyMVar
return $ T.toHandler $ T.RotatingFileHandler{..}
createHandler fs TimeRotatingFileHandler{timezone=tz, ..} = do
formatter <- pure $ fs ! formatter
timezone <- maybe getCurrentTimeZone (pure . read) $ mappend tz timezone
encoding <- mkTextEncoding encoding
rotateAt <- newIORef =<< getCurrentTime
stream <- newEmptyMVar
return $ T.toHandler $ T.TimeRotatingFileHandler{..}