{-# 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{..}