{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}

module Logging.Config.Type
  ( Handler(..)
  , Sink(..)
  , Config(..)
  , ConfigException(..)
  , createManager
  ) where


import           Control.Concurrent.MVar
import           Control.Exception                       (Exception)
import           Data.Aeson
import           Data.Default
import           Data.IORef
import           Data.Map.Lazy
import           Data.Maybe
import           Data.String
import           Data.Time.Clock
import           Data.Time.LocalTime
import           GHC.Generics
import           System.IO

import           Prelude                                 hiding (map)
import qualified Prelude                                 as P
import           Text.Format                             hiding (defaultOptions)

import qualified Logging.Class                           as T
import qualified Logging.Handler.FileHandler             as T
import qualified Logging.Handler.RotatingFileHandler     as T
import qualified Logging.Handler.StreamHandler           as T
import qualified Logging.Handler.TimeRotatingFileHandler as T
import qualified Logging.Manager                         as T
import           Logging.Prelude
import qualified Logging.Sink                            as T


data Handler = StreamHandler { level     :: Maybe String
                             , filterer  :: Maybe [String]
                             , formatter :: Maybe String
                             , stream    :: Maybe String
                             }
             | FileHandler { level     :: Maybe String
                           , filterer  :: Maybe [String]
                           , formatter :: Maybe String
                           , file      :: FilePath
                           , encoding  :: Maybe String
                             -- ^ See 'System.IO.mkTextEncoding',
                             -- default is utf8.
                           }
             | RotatingFileHandler { level       :: Maybe String
                                   , filterer    :: Maybe [String]
                                   , formatter   :: Maybe String
                                   , file        :: FilePath
                                   , encoding    :: Maybe String
                                     -- ^ See 'System.IO.mkTextEncoding',
                                     -- default is utf8.
                                   , maxBytes    :: Maybe Int
                                     -- ^ Default is 100 MB.
                                   , backupCount :: Maybe Int
                                     -- ^ Default is 10.
                                   }
             | TimeRotatingFileHandler { level       :: Maybe String
                                       , filterer    :: Maybe [String]
                                       , formatter   :: Maybe String
                                       , file        :: FilePath
                                       , encoding    :: Maybe String
                                       , timezone    :: Maybe String
                                         -- ^ If not set, same as 'Manager''s
                                         -- timezone.
                                       , rotateTime  :: Maybe String
                                         -- ^ Indicates when to rotate file,
                                         -- e.g. @D3@ means every 3 days,
                                         -- @W4@ means at 0 clock of 'Thursday',
                                         -- try showing 'RotateTime'.
                                       , backupCount :: Maybe Int
                                       }
              -- ^ @since 0.7.0
              deriving (Generic, Show)

instance FromJSON Handler where
  parseJSON = genericParseJSON option
    where
      sumEncoding = defaultTaggedObject { tagFieldName = "type" }
      option = defaultOptions { sumEncoding = sumEncoding }


data Sink = Sink { level     :: Maybe String
                 , filterer  :: Maybe [String]
                 , handlers  :: Maybe [String]
                 , propagate :: Maybe Bool
                 , disabled  :: Maybe Bool
                 } deriving (Generic, Show)

instance FromJSON Sink


data Config = Config { sinks                  :: Maybe (Map String Sink)
                     , handlers               :: Maybe (Map String Handler)
                     , formatters             :: Maybe (Map String String)
                     , timezone               :: Maybe String -- ^ @since 0.7.0
                     , disabled               :: Maybe Bool
                     , catchUncaughtException :: Maybe Bool
                     } deriving (Generic, Show)

instance FromJSON Config


newtype ConfigException = ConfigException { message :: String }

instance Show ConfigException where
  show e = "Logging Config Exception: " ++ (message e)

instance Exception ConfigException


createManager :: Config -> IO T.Manager
createManager Config{..} = do
    handlers <- mapM (createHandler formatters') $ fromMaybe empty handlers
    sinks <- sequence $ mapWithKey (createSink handlers) $ fromMaybe empty sinks
    defaultTimezone <- getCurrentTimeZone

    let root = findWithDefault defaultRoot "root" sinks
        sinks' = delete "root" sinks
        timezone' = maybe defaultTimezone read timezone
        disabled' = fromMaybe False disabled
        catchUncaughtException' = fromMaybe False catchUncaughtException
    return $ T.Manager root sinks' timezone' disabled' catchUncaughtException'
  where
    formatters' :: Map String Format1
    formatters' = maybe (singleton "" "{message}") (map fromString) formatters

    stderrHandler :: T.SomeHandler
    stderrHandler = T.toHandler $ T.StreamHandler def [] "{message}" stderr

    defaultRoot :: T.Sink
    defaultRoot = T.Sink "" "DEBUG" [] [stderrHandler] False False

    createSink :: Map String T.SomeHandler -> String -> Sink -> IO T.Sink
    createSink hs logger Sink{..} = do
      let logger' = if logger == "root" then "" else logger
          level' = maybe def read level
          filterer' = maybe [] (P.map fromString) filterer
          handlers' = [hs ! h | h <- fromMaybe [] handlers]
          disabled' = fromMaybe False disabled
          propagate' = fromMaybe False propagate
      return $ T.Sink logger' level' filterer' handlers' disabled' propagate'

    getStream :: String -> Handle
    getStream "stderr" = stderr
    getStream "stdout" = stdout
    getStream _        = error "Logging.Config: no parse (stream)"

    createHandler :: Map String Format1 -> Handler -> IO T.SomeHandler
    createHandler fs StreamHandler{..} = do
      let level' = maybe def read level
          filterer' = maybe [] (P.map fromString) filterer
          formatter' = maybe "{message}" ((!) fs) formatter
          stream' = getStream $ fromMaybe "stderr" stream
      return $ T.toHandler $ T.StreamHandler level' filterer' formatter' stream'
    createHandler fs FileHandler{..} = do
      let level' = maybe def read level
          filterer' = maybe [] (P.map fromString) filterer
          formatter' = maybe "{message}" ((!) fs) formatter
      encoding' <- mkTextEncoding $ fromMaybe "utf8" encoding
      stream <- newIORef undefined
      return $ T.toHandler $
        T.FileHandler level' filterer' formatter' file encoding' stream
    createHandler fs RotatingFileHandler{..} = do
      let level' = maybe def read level
          filterer' = maybe [] (P.map fromString) filterer
          formatter' = maybe "{message}" ((!) fs) formatter
          maxBytes' = fromMaybe 104857600 maxBytes
          backupCount' = fromMaybe 10 backupCount
      encoding' <- mkTextEncoding $ fromMaybe "utf8" encoding
      stream <- newEmptyMVar
      return $ T.toHandler $
        T.RotatingFileHandler level' filterer' formatter' file encoding'
                              maxBytes' backupCount' stream
    createHandler fs TimeRotatingFileHandler{timezone=tz, ..} = do
      let level' = maybe def read level
          filterer' = maybe [] (P.map fromString) filterer
          formatter' = maybe "{message}" ((!) fs) formatter
          tz' = mappend tz timezone
          rotateTime' = maybe (T.Day 1) read rotateTime
          backupCount' = fromMaybe 10 backupCount
      encoding' <- mkTextEncoding $ fromMaybe "utf8" encoding
      timezone' <- maybe getCurrentTimeZone (return . read) tz'
      rotateAt <- newIORef =<< getCurrentTime
      stream <- newEmptyMVar
      return $ T.toHandler $
        T.TimeRotatingFileHandler level' filterer' formatter' file encoding'
                                  timezone' rotateTime' backupCount' rotateAt
                                  stream