{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Logging.Config.Type
( Handler(..)
, Sink(..)
, Config(..)
, ConfigException(..)
, createManager
) where
import Control.Exception (Exception)
import Data.Aeson
import Data.Default
import Data.IORef
import Data.Map.Lazy
import Data.Maybe
import Data.String
import GHC.Generics
import System.IO
import Prelude hiding (map)
import qualified Prelude as P
import Text.Format
import Logging.Prelude
import qualified Logging.Types 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
}
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)
, disabled :: Maybe Bool
, catchUncaughtException :: 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
let root = findWithDefault defaultRoot "root" sinks
sinks' = delete "root" sinks
disabled' = fromMaybe False disabled
catchUncaughtException' = fromMaybe False catchUncaughtException
return $ T.Manager root sinks' disabled' catchUncaughtException'
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 <- newIORef undefined
return $ T.toHandler $
T.RotatingFileHandler level' filterer' formatter' file encoding'
maxBytes' backupCount' stream