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

module Logging.Internal
  ( run
  , runJson
  , jsonToManager
  , log
  , stderrHandler
  , stdoutHandler
  , defaultRoot
  ) where

import           Control.Concurrent.MVar (MVar, newMVar)
import           Control.Exception       (SomeException, bracket_)
import           Control.Monad           (forM_, sequence, void, when)
import           Control.Monad.IO.Class  (MonadIO (..))
import           Data.Aeson              (Value (..))
import           Data.Default
import qualified Data.HashMap.Strict     as HM
import           Data.IORef
import           Data.List               (dropWhileEnd)
import           Data.Map.Lazy           (Map, delete, fromList, (!?))
import qualified Data.Text               as T
import           Data.Time.Clock
import           Data.Time.LocalTime
import           GHC.Conc                (setUncaughtExceptionHandler)
import           Prelude                 hiding (filter, log)
import           System.Directory        (createDirectoryIfMissing,
                                          makeAbsolute)
import           System.FilePath
import           System.IO               (Handle, IOMode (..), hSetEncoding,
                                          openFile, stderr, stdout, utf8)
import           System.IO.Unsafe        (unsafePerformIO)

import           Data.Aeson.Extra
import           Logging.Types

{-# NOINLINE _mgr #-}
_mgr :: IORef Manager
_mgr = unsafePerformIO $ newIORef undefined


-- |Run a logging environment.
--
-- You should always write you application inside a logging environment.
--
-- 1. rename "main" function to "originMain" (or whatever you call it)
-- 2. write "main" as below
--
-- > main :: IO ()
-- > main = run manager originMain
-- > ...
--
run :: Manager -> IO a -> IO a
run mgr@Manager{..} io = do
    when catchUncaughtException $ setUncaughtExceptionHandler uceHandler
    bracket_ (atomicWriteIORef _mgr mgr) shutdown io
  where
    unknownLoc = ("unknown file", "unknown package", "unknown module", 0)

    uceHandler :: SomeException -> IO ()
    uceHandler e = log "" "ERROR" (show e) unknownLoc

    shutdown :: IO ()
    shutdown = closeHandlers root >> forM_ sinks closeHandlers

    closeHandlers :: Sink -> IO ()
    closeHandlers Sink{..} = forM_ handlers $ \(HandlerT hdl) -> close hdl


-- |Run a logging environment from JSON 'Value'.
--
-- A combinator of 'run' and 'jsonToManager'.
--
runJson :: Value -> IO a -> IO a
runJson val io = jsonToManager val >>= (`run` io)

-- | Parse JSON to Formatter
jsonToFormatter :: Value -> Formatter
jsonToFormatter (Object obj) =
    Formatter (lookupString fmt "fmt" obj) (lookupString datefmt "datefmt" obj)
  where
    Formatter{..} = def
jsonToFormatter (String fmt) = def {fmt = T.unpack fmt}
jsonToFormatter _ = def


-- | Parse JSON to Filter
jsonToFilter :: Value -> Filter
jsonToFilter (String s) = let s' = T.unpack s in Filter s' (length s')
jsonToFilter _          = error "Logging.Internal: no parse (Filter)"


-- | Parse JSON to Handler(T)
jsonToHandler :: Value -> (String -> Formatter) -> IO HandlerT
jsonToHandler (Object obj) lookupFmt = jsonToHandler' type_
  where
    type_ = lookupString "" "type" obj
    level = read $ lookupString "NOTSET" "level" obj
    filterer = map jsonToFilter $ lookupArray "filterer" obj
    formatter = lookupFmt $ lookupString "" "formatter" obj

    lock :: IO (MVar ())
    lock = newMVar ()

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

    jsonToHandler' :: String -> IO HandlerT
    jsonToHandler' "StreamHandler" = do
      let stream = nameToStream $ lookupString "stderr" "stream" obj
      (HandlerT . (StreamHandler stream level filterer formatter)) <$> lock
    jsonToHandler' "FileHandler" = do
      file <- makeAbsolute $ lookupString "default.log" "file" obj
      createDirectoryIfMissing True $ takeDirectory file
      stream <- openFile file AppendMode
      hSetEncoding stream utf8
      (HandlerT . (StreamHandler stream level filterer formatter)) <$> lock
    jsonToHandler' _ = error $ "Logging.Internal: no parse (Handler)"
jsonToHandler _ _ = undefined


-- | Parse JSON to Sink
jsonToSink :: (String, Value) -> (String -> HandlerT) -> Sink
jsonToSink (logger, Object obj) lookupHdl =
    Sink logger' level filterer handlers disabled propagate
  where
    logger' = if logger == "root" then "" else logger
    level = read $ lookupString "NOTSET" "level" obj
    filterer = map jsonToFilter $ lookupArray "filterer" obj
    handlers = [lookupHdl (T.unpack v) | (String v) <- lookupArray "handlers" obj]
    disabled = lookupBool False "disabled" obj
    propagate = lookupBool False "propagate" obj
jsonToSink _ _ = error "Logging.Internal: no parse (Logger)"


-- |Make a 'Manager' from JSON 'Value'.
jsonToManager :: Value -> IO Manager
jsonToManager (Object obj) = do
  let formatters = HM.map jsonToFormatter $ lookupObject "formatters" obj
      lookupFmt k = HM.lookupDefault def k formatters
      handlerNames = lookupObject "handlers" obj

  handlers <- sequence $ HM.map (`jsonToHandler` lookupFmt) handlerNames

  let lookupHdl = (HM.!) handlers
      sinkVals = lookupObject "loggers" obj
      sinks = HM.mapWithKey (curry (`jsonToSink` lookupHdl)) sinkVals

      root = HM.lookupDefault defaultRoot "root" sinks
      sinks' = delete "root" $ fromList $ HM.toList sinks
      disabled = lookupBool False "disabled" obj
      catchUncaughtException = lookupBool False "catchUncaughtException" obj

  return $ Manager root sinks' disabled catchUncaughtException
jsonToManager _ = error "Logging.Internal: no parse (Manager)"


-- |Low-level logging routine which creates a LogRecord and then calls
-- all the handlers of this logger to handle the record.
log :: MonadIO m
     => Logger -> Level -> String -> (String, String, String, Int) -> m ()
log logger level message location = liftIO $ do
    mgr@Manager{..} <- readIORef _mgr
    created <- getZonedTime

    let (file, package, modulename, lineno) = location

    when (not disabled) $ process logger mgr $
      LogRecord logger level message file package modulename lineno created
  where
    process :: Logger -> Manager -> LogRecord -> IO ()
    process logger mgr rcd =
      case lookupSink logger mgr of
        Just sink@Sink{..} -> do
          when (isSinkEnabledFor sink rcd) $ callHandlers handlers rcd
          let parentLogger = parent logger
              shouldPropagate = propagate && logger /= parentLogger
          when shouldPropagate $ process parentLogger mgr rcd
        Nothing -> process (parent logger) mgr rcd

    parent :: Logger -> Logger
    parent = dropWhileEnd (== '.') . dropWhileEnd (/= '.')

    lookupSink :: Logger -> Manager -> Maybe Sink
    lookupSink logger mgr@Manager{root=root@Sink{logger=rootLogger}, ..}
      | logger `elem` ["", rootLogger] = Just root
      | otherwise = sinks !? logger

    callHandlers :: [HandlerT] -> LogRecord -> IO ()
    callHandlers handlers rcd = forM_ handlers $ \hdlt@(HandlerT hdl) ->
      when (isHandlerEnableFor hdlt rcd) $ void $ Logging.Types.handle hdl rcd

    isSinkEnabledFor :: Sink -> LogRecord -> Bool
    isSinkEnabledFor sink@Sink{..} rcd@LogRecord{level=level'}
      | disabled = False
      | level' < level = False
      | otherwise = filter sink rcd

    isHandlerEnableFor :: HandlerT -> LogRecord -> Bool
    isHandlerEnableFor (HandlerT hdl) rcd@LogRecord{level=level'}
      | level' < getLevel hdl = False
      | otherwise = filter (getFilterer hdl) rcd


-- |A ultility function for creating 'StreamHandler'
makeStreamHandler :: Handle -> IO StreamHandler
makeStreamHandler stream = StreamHandler stream def [] def <$> newMVar ()


{-# NOINLINE stderrHandler #-}
-- |A 'StreamHandler' bound to 'stderr'
stderrHandler :: StreamHandler
stderrHandler = unsafePerformIO $ makeStreamHandler stderr

{-# NOINLINE stdoutHandler #-}
-- |A 'StreamHandler' bound to 'stdout'
stdoutHandler :: StreamHandler
stdoutHandler = unsafePerformIO $ makeStreamHandler stdout

{-# NOINLINE defaultRoot #-}
-- |Default root sink which is used by 'jsonToManager' when __root__ is missed.
--
-- You can use it when you make 'Manager' manually.
defaultRoot :: Sink
defaultRoot = Sink "" "DEBUG" [] [HandlerT stderrHandler] False False