{-# 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 qualified Data.Map.Lazy as M
import System.Directory
import System.FilePath
import System.IO
import Logging.Internal
import Logging.Types
import Logging.Utils
mapAp :: (Applicative f1, Applicative f2) => f1 (a -> b) -> f2 a -> (f1 (f2 b))
mapAp f x = ((<*> x) . pure) <$> f
mapAp2 :: (Applicative f1, Applicative f2) => f1 (a -> b -> c) -> f2 a -> f2 b -> (f1 (f2 c))
mapAp2 f x y = ((<*> y). (<*> x) . pure) <$> f
instance FromJSON Level where
parseJSON v = read <$> parseJSON v
instance FromJSON Filter where
parseJSON v = Filter <$> parseJSON v
instance FromJSON Formatter where
parseJSON (Object v) = Formatter <$> v .:? "fmt" .!= (fmt def)
<*> v .:? "datefmt" .!= (datefmt def)
parseJSON (String v) = (\fmt -> def {fmt = fmt}) <$> parseJSON (String v)
parseJSON invalid = typeMismatch "Object" invalid
instance FromJSON (StreamHandler) where
parseJSON = withObject "StreamHandler" $ \v ->
StreamHandler <$> (parseStream <$> (v .:? "stream" .!= "stderr"))
<*> v .:? "level" .!= def
<*> v .:? "filterer" .!= []
<*> v .:? "formatter" .!= def
where
parseStream :: String -> Handle
parseStream "stderr" = stderr
parseStream "stdout" = stdout
parseStream _ = error "Logging.Aeson: no parse (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
hdl <- parseJSON (Object v)
file <- v .: "file" .!= "default.log"
return $ openLogFile file utf8 >>= \stream -> return $
toHandler (hdl {stream = stream} :: StreamHandler)
instance FromJSON (M.Map String Formatter -> IO SomeHandler) where
parseJSON = withObject "Handler" $ \v -> do
hdlio <- parseJSON (Object v)
key <- v .:? "formatter" .!= ""
return $ \fs -> hdlio >>= \hdl -> return $
set (typed @Formatter) (M.findWithDefault def 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 Formatter
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