{-# OPTIONS_HADDOCK prune, ignore-exports #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Logging.Aeson
(
) where
import Control.Applicative (pure)
import Control.Lens (set)
import Data.Aeson
import Data.Aeson.Types (Parser, typeMismatch)
import Data.Default
import Data.Generics.Product.Typed
import Data.IORef
import qualified Data.Map.Lazy as M
import Data.String
import System.Directory
import System.FilePath
import System.IO
import Text.Format
import Logging.Internal
import Logging.Types
import Logging.Utils
instance FromJSON Level where
parseJSON v = read <$> parseJSON v
instance FromJSON Filter where
parseJSON v = Filter <$> parseJSON v
instance FromJSON Format1 where
parseJSON v = fromString <$> parseJSON v
instance FromJSON StreamHandler where
parseJSON = withObject "StreamHandler" $ \v ->
StreamHandler <$> v .:? "level" .!= def
<*> v .:? "filterer" .!= []
<*> v .:? "formatter" .!= "{message}"
<*> (parseStream <$> (v .:? "stream" .!= "stderr"))
where
parseStream :: String -> Handle
parseStream "stderr" = stderr
parseStream "stdout" = stdout
parseStream _ = error "Logging.Aeson: no parse (stream)"
instance FromJSON (IO FileHandler) where
parseJSON = withObject "FileHandler" $ \v -> do
level <- v .:? "level" .!= def
filterer <- v .:? "filterer" .!= []
formatter <- v .:? "formatter" .!= "{message}"
file <- v .:? "file" .!= "log4hs.log"
encoding <- v .:? "encoding" .!= (show utf8)
return $ do
stream <- newIORef undefined
encoding' <- mkTextEncoding encoding
return $ FileHandler level filterer formatter file encoding' stream
instance FromJSON (IO SomeHandler) where
parseJSON = withObject "Handler" $ \v -> (v .: "type") >>= (`parseHandler` v)
where
parseHandler :: String -> Object -> Parser (IO SomeHandler)
parseHandler "StreamHandler" v = do
hdl <- parseJSON (Object v)
return $ return $ toHandler (hdl :: StreamHandler)
parseHandler "FileHandler" v = do
hdlIo <- parseJSON (Object v)
return $ toHandler <$> (hdlIo :: IO FileHandler)
instance FromJSON (M.Map String Format1 -> IO SomeHandler) where
parseJSON = withObject "Handler" $ \v -> do
hdlio <- parseJSON (Object v)
key <- v .:? "formatter" .!= "{message}"
return $ \fs -> hdlio >>= \hdl -> return $
set (typed @Format1) (M.findWithDefault "" key fs) hdl
instance FromJSON (Sink) where
parseJSON = withObject "Sink" $ \v ->
Sink <$> v .:? "logger" .!= "placeholder"
<*> v .:? "level" .!= def
<*> v .:? "filterer" .!= []
<*> (return [])
<*> v .:? "disabled" .!= False
<*> v .:? "propagate" .!= False
instance FromJSON (String -> M.Map String SomeHandler -> Sink) where
parseJSON = withObject "Sink" $ \v -> do
sink <- parseJSON (Object v)
keys <- v .:? "handlers" .!= []
return $ \lgr hs -> sink { logger = if lgr == "root" then "" else lgr
, handlers = [hs M.! k | k <- keys]
}
type Formatters = M.Map String Format1
type HandlersMakerIO = M.Map String (Formatters -> IO SomeHandler)
type SinksMaker = M.Map String (String -> M.Map String SomeHandler -> Sink)
instance FromJSON (IO Manager) where
parseJSON = withObject "Manager" $ \v -> do
fmts :: Formatters <- v .:? "formatters" .!= (object []) >>= parseJSON
hdls :: HandlersMakerIO <- v .:? "handlers" .!= (object []) >>= parseJSON
sinks :: SinksMaker <- v .:? "loggers" .!= (object []) >>= parseJSON
disabled <- v .:? "disabled" .!= False
catchUncaughtException <- v .:? "catchUncaughtException" .!= False
return $ do
hdls' <- sequence $ M.map (\f -> f fmts) hdls
let sinks' = M.mapWithKey (\k f -> f k hdls') sinks
root = M.findWithDefault defaultRoot "root" sinks'
sinks'' = M.delete "root" sinks'
return $ Manager root sinks'' disabled catchUncaughtException