Aeson.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}

module Logging.Aeson
  (
  -- * Aeson Instances
  --
  -- $aesondoc
  ) where

import           Control.Applicative         (pure)
import           Control.Concurrent.MVar
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


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


{- $aesondoc

By using 'Data.Aeson', we can decode json string into 'Manager'.

__A basic 'Manager' json format:__

@
  {
    \"loggers\": {\"root\": {}, \"MyLogger\": {}},
    \"handlers\": {\"console\": {}, \"file\": {}},
    \"formatters\": {\"default\": {}, \"simple\": {}},
    \"disabled\": false,
    \"catchUncaughtException\": true
  }
@


In practice, a set of handlers share a formatter, and other handlers share
another one, so we define all the formatters in a map, handler refernces
the formatter throught its key.

So as handlers, sinks may share same handlers.

__Examples of 'Formatter' json__

@
  -- a standard format
  {
    \"fmt\": \"%(message)s\",
    \"datefmt\": \"%Y-%m-%dT%H:%M:%S\"
  }

  -- missing field will use default value
  {
    \"fmt": "%(message)s\",
    \"datefmt\": \"%Y-%m-%dT%H:%M:%S\"
  }

  -- it works as well, just a string
  \"%(message)s\"
@

__Examples of 'Handler' json__

Note: Besides some common field, handler's other fields depend on its type.

@
  -- a standard format
  {
    \"type\": \"StreamHandler\",
    \"stream\": \"stderr\",
    \"level\": \"DEBUG\",
    \"filterer\": [\"Package.Module.Submodule\"],
    \"formatter\": \"default\",
  }

  -- FileHandler is just a StreamHandler, the stream is created by openFile
  {
    \"type\": \"FileHandler\",
    \"file\": \"./default.log\",
    \"level\": \"INFO\",
    \"filterer\": [],
    \"formatter\": \"simple\",
  }
@

__Examples of 'Logger' ('Sink') json__

@
  -- a standard format
  {
    \"level\": \"DEBUG\",
    \"filterer\": [\"Package.Module.Submodule\"],
    \"handlers\": [\"console\"],
    \"propagate\": true,
    \"disabled\": false
  }

  -- this example is equivalent to the first
  {
    \"level\": \"DEBUG\",
    \"filterer\": [\"Package.Module.Submodule\"],
    \"handlers\": ["console"]
  }

  -- another example
  {
    \"level\": \"INFO\",
    \"handlers\": [\"console\", \"file\"],
    \"propagate\": false
  }
@
-}

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 (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 SomeHandler) 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 SomeHandler)
      parseHandler "StreamHandler" v = do
        hdl <- parseJSON (Object v)
        return $ toHandler <$> (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 $ toHandler <$> hdl'
      parseHandler t _ = error $ "Logging.Aeson: no parse (Handler" ++ t ++")"


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