{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Logging.Aeson
(
) where
import Control.Applicative (pure)
import Control.Concurrent.MVar
import Data.Aeson
import Data.Aeson.Types (Parser, typeMismatch)
import Data.Default
import Data.Map.Lazy (Map, (!))
import qualified Data.Map.Lazy as M
import qualified Data.Text as T
import System.Directory
import System.FilePath
import System.IO
import Logging.Internal
import Logging.Types
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 = (\s -> Filter s $ length s) <$> 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 (IO StreamHandler) where
parseJSON = withObject "StreamHandler" $ \v -> flip mapAp (newMVar ()) $
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 HandlerT) where
parseJSON = withObject "Handler" $ \v -> (v .: "type") >>= (`parseHandler` v)
where
openLogFile :: FilePath -> IO Handle
openLogFile file = do
file' <- makeAbsolute file
createDirectoryIfMissing True $ takeDirectory file'
stream <- openFile file AppendMode
hSetEncoding stream utf8
return stream
parseHandler :: String -> Object -> Parser (IO HandlerT)
parseHandler "StreamHandler" v = do
hdl <- parseJSON (Object v)
return $ HandlerT <$> (hdl :: IO StreamHandler)
parseHandler "FileHandler" v = do
hdl :: (IO StreamHandler) <- parseJSON (Object v)
stream <- openLogFile <$> (v .: "file" .!= "default.log")
hdl' <- mapAp2 (pure $ \h s -> h {stream = s}) hdl stream
return $ HandlerT <$> hdl'
parseHandler t _ = error $ "Logging.Aeson: no parse (Handler" ++ t ++")"
instance FromJSON (Map String Formatter -> IO HandlerT) where
parseJSON = withObject "Handler" $ \v -> do
hdlio <- parseJSON (Object v)
key <- v .:? "formatter" .!= ""
return $ \fs -> hdlio >>= \(HandlerT hdl) -> do
return $ HandlerT $ setFormatter hdl (M.findWithDefault def key fs)
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 -> Map String HandlerT -> 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 ! k | k <- keys]
}
type Formatters = Map String Formatter
type HandlerTsMakerIO = Map String (Formatters -> IO HandlerT)
type SinksMaker = Map String (String -> Map String HandlerT -> Sink)
instance FromJSON (IO Manager) where
parseJSON = withObject "Manager" $ \v -> do
fmts :: Formatters <- v .:? "formatters" .!= (object []) >>= parseJSON
hdls :: HandlerTsMakerIO <- 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