{-# 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
data HandlerH f = StreamHandler { level :: HKD T.Level f
, filterer :: HKD T.Filterer f
, formatter :: HKD String f
, stream :: HKD String f
}
| FileHandler { level :: HKD T.Level f
, filterer :: HKD T.Filterer f
, formatter :: HKD String f
, file :: FilePath
, encoding :: HKD String f
}
| RotatingFileHandler { level :: HKD T.Level f
, filterer :: HKD T.Filterer f
, formatter :: HKD String f
, file :: FilePath
, encoding :: HKD String f
, maxBytes :: HKD Int f
, backupCount :: HKD Int f
}
| TimeRotatingFileHandler { level :: HKD T.Level f
, filterer :: HKD T.Filterer f
, formatter :: HKD String f
, file :: FilePath
, encoding :: HKD String f
, timezone :: Maybe String
, rotateTime :: HKD T.RotateTime f
, backupCount :: HKD Int f
}
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
, filterer :: HKD T.Filterer f
, handlers :: HKD [String] f
, 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
, timezone :: Maybe String
, 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
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
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{..}