{-# OPTIONS_HADDOCK prune, ignore-exports #-}

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

module Logging.Aeson
  (
  -- * Aeson Instances
  --
  -- $aesondoc
  ) 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


{- $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\": "format", \"simple\": "format"},
    \"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__

See 'Text.Format' of vformat package for more information about formatting.

@
  "{message}"
  "{logger} {level}: {message}"
  "{logger:<20.20s} {level:<8s}: {message}"
  "{asctime:%Y-%m-%dT%H:%M:%S%6Q%z} - {level} - {logger}] {message}"
@

__Examples of 'Handler' json__

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

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

  -- FileHandler
  {
    \"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 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