{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Logging.Config.Type
( Handler(..)
, Sink(..)
, Config(..)
, ConfigException(..)
, createManager
) where
import Control.Concurrent.MVar
import Control.Exception (Exception)
import Data.Aeson
import Data.Default
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 System.IO
import Prelude hiding (map)
import qualified Prelude as P
import Text.Format hiding (defaultOptions)
import qualified Logging.Class 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.Manager as T
import Logging.Prelude
import qualified Logging.Sink as T
data Handler = StreamHandler { level :: Maybe String
, filterer :: Maybe [String]
, formatter :: Maybe String
, stream :: Maybe String
}
| FileHandler { level :: Maybe String
, filterer :: Maybe [String]
, formatter :: Maybe String
, file :: FilePath
, encoding :: Maybe String
}
| RotatingFileHandler { level :: Maybe String
, filterer :: Maybe [String]
, formatter :: Maybe String
, file :: FilePath
, encoding :: Maybe String
, maxBytes :: Maybe Int
, backupCount :: Maybe Int
}
| TimeRotatingFileHandler { level :: Maybe String
, filterer :: Maybe [String]
, formatter :: Maybe String
, file :: FilePath
, encoding :: Maybe String
, timezone :: Maybe String
, rotateTime :: Maybe String
, backupCount :: Maybe Int
}
deriving (Generic, Show)
instance FromJSON Handler where
parseJSON = genericParseJSON option
where
sumEncoding = defaultTaggedObject { tagFieldName = "type" }
option = defaultOptions { sumEncoding = sumEncoding }
data Sink = Sink { level :: Maybe String
, filterer :: Maybe [String]
, handlers :: Maybe [String]
, propagate :: Maybe Bool
, disabled :: Maybe Bool
} deriving (Generic, Show)
instance FromJSON Sink
data Config = Config { sinks :: Maybe (Map String Sink)
, handlers :: Maybe (Map String Handler)
, formatters :: Maybe (Map String String)
, timezone :: Maybe String
, disabled :: Maybe Bool
} deriving (Generic, Show)
instance FromJSON Config
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
handlers <- mapM (createHandler formatters') $ fromMaybe empty handlers
sinks <- sequence $ mapWithKey (createSink handlers) $ fromMaybe empty sinks
defaultTimezone <- getCurrentTimeZone
let root = findWithDefault defaultRoot "root" sinks
sinks' = delete "root" sinks
timezone' = maybe defaultTimezone read timezone
disabled' = fromMaybe False disabled
return $ T.Manager root sinks' timezone' disabled' False
where
formatters' :: Map String Format1
formatters' = maybe (singleton "" "{message}") (map fromString) formatters
stderrHandler :: T.SomeHandler
stderrHandler = T.toHandler $ T.StreamHandler def [] "{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
let logger' = if logger == "root" then "" else logger
level' = maybe def read level
filterer' = maybe [] (P.map fromString) filterer
handlers' = [hs ! h | h <- fromMaybe [] handlers]
disabled' = fromMaybe False disabled
propagate' = fromMaybe False propagate
return $ T.Sink logger' level' filterer' handlers' disabled' propagate'
getStream :: String -> Handle
getStream "stderr" = stderr
getStream "stdout" = stdout
getStream _ = error "Logging.Config: no parse (stream)"
createHandler :: Map String Format1 -> Handler -> IO T.SomeHandler
createHandler fs StreamHandler{..} = do
let level' = maybe def read level
filterer' = maybe [] (P.map fromString) filterer
formatter' = maybe "{message}" ((!) fs) formatter
stream' = getStream $ fromMaybe "stderr" stream
return $ T.toHandler $ T.StreamHandler level' filterer' formatter' stream'
createHandler fs FileHandler{..} = do
let level' = maybe def read level
filterer' = maybe [] (P.map fromString) filterer
formatter' = maybe "{message}" ((!) fs) formatter
encoding' <- mkTextEncoding $ fromMaybe "utf8" encoding
stream <- newIORef undefined
return $ T.toHandler $
T.FileHandler level' filterer' formatter' file encoding' stream
createHandler fs RotatingFileHandler{..} = do
let level' = maybe def read level
filterer' = maybe [] (P.map fromString) filterer
formatter' = maybe "{message}" ((!) fs) formatter
maxBytes' = fromMaybe 104857600 maxBytes
backupCount' = fromMaybe 10 backupCount
encoding' <- mkTextEncoding $ fromMaybe "utf8" encoding
stream <- newEmptyMVar
return $ T.toHandler $
T.RotatingFileHandler level' filterer' formatter' file encoding'
maxBytes' backupCount' stream
createHandler fs TimeRotatingFileHandler{timezone=tz, ..} = do
let level' = maybe def read level
filterer' = maybe [] (P.map fromString) filterer
formatter' = maybe "{message}" ((!) fs) formatter
tz' = mappend tz timezone
rotateTime' = maybe (T.Day 1) read rotateTime
backupCount' = fromMaybe 10 backupCount
encoding' <- mkTextEncoding $ fromMaybe "utf8" encoding
timezone' <- maybe getCurrentTimeZone (return . read) tz'
rotateAt <- newIORef =<< getCurrentTime
stream <- newEmptyMVar
return $ T.toHandler $
T.TimeRotatingFileHandler level' filterer' formatter' file encoding'
timezone' rotateTime' backupCount' rotateAt
stream