{-# LANGUAGE RankNTypes      #-}
{-# LANGUAGE RecordWildCards #-}

-- | provide backends for `katip`

module Pos.Util.Log.Scribes
    ( mkStdoutScribe
    , mkStderrScribe
    , mkDevNullScribe
    , mkTextFileScribe
    , mkJsonFileScribe
    ) where

import           Universum

import           Control.AutoUpdate (UpdateSettings (..), defaultUpdateSettings,
                     mkAutoUpdate)
import           Control.Concurrent.MVar (modifyMVar_)
import           Control.Exception.Safe (catchIO)

import           Data.Aeson.Text (encodeToLazyText)
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import           Data.Text.Lazy.Builder
import qualified Data.Text.Lazy.IO as TIO
import           Data.Time (diffUTCTime)
import           Data.Time.Format (defaultTimeLocale, formatTime)
import           Katip.Core
import           Katip.Scribes.Handle (brackets)

import qualified Pos.Util.Log.Internal as Internal
import           Pos.Util.Log.LoggerConfig (NamedSeverity,
                     RotationParameters (..))
import           Pos.Util.Log.LoggerName (LoggerName)
import           Pos.Util.Log.Rotator (cleanupRotator, evalRotator,
                     initializeRotator)
import qualified Pos.Util.Log.Severity as Log (Severity (..))

import           System.Directory (createDirectoryIfMissing)
import           System.IO (BufferMode (LineBuffering), Handle,
                     IOMode (WriteMode), hClose, hSetBuffering, stderr, stdout)

-- | create a katip scribe for logging to a file in JSON representation
mkJsonFileScribe :: RotationParameters -> NamedSeverity -> Internal.FileDescription -> Log.Severity -> Verbosity -> IO Scribe
mkJsonFileScribe rot sevfilter fdesc s v = do
    mkFileScribe rot sevfilter fdesc formatter False s v
  where
    formatter :: (LogItem a) => Handle -> Bool -> Verbosity -> Item a -> IO Int
    formatter hdl _ v' item = do
        let tmsg = encodeToLazyText $ itemJson v' item
        TIO.hPutStrLn hdl tmsg
        return $ length tmsg

-- | create a katip scribe for logging to a file in textual representation
mkTextFileScribe :: RotationParameters -> NamedSeverity -> Internal.FileDescription -> Bool -> Log.Severity -> Verbosity -> IO Scribe
mkTextFileScribe rot sevfilter fdesc colorize s v = do
    mkFileScribe rot sevfilter fdesc formatter colorize s v
  where
    formatter :: Handle -> Bool -> Verbosity -> Item a -> IO Int
    formatter hdl colorize' v' item = do
        let tmsg = toLazyText $ formatItem colorize' v' item
        TIO.hPutStrLn hdl tmsg
        return $ length tmsg

-- | create a katip scribe for logging to a file
--   and handle file rotation within the katip-invoked logging function
mkFileScribe
    :: RotationParameters
    -> NamedSeverity
    -> Internal.FileDescription
    -> (forall a . LogItem a => Handle -> Bool -> Verbosity -> Item a -> IO Int)      -- format and output function, returns written bytes
    -> Bool                              -- whether the output is colourized
    -> Log.Severity -> Verbosity
    -> IO Scribe
mkFileScribe rot sevfilter fdesc formatter colorize s v = do
    let prefixDir = Internal.prefixpath fdesc
    (createDirectoryIfMissing True prefixDir)
        `catchIO` (Internal.prtoutException ("cannot log prefix directory: " ++ prefixDir))
    trp <- initializeRotator rot fdesc
    scribestate <- newMVar trp    -- triple of (handle), (bytes remaining), (rotate time)
    -- sporadically remove old log files - every 10 seconds
    cleanup <- mkAutoUpdate defaultUpdateSettings { updateAction = cleanupRotator rot fdesc, updateFreq = 10000000 }
    let finalizer :: IO ()
        finalizer = do
            modifyMVar_ scribestate $ \(hdl, b, t) -> do
                hClose hdl
                return (hdl, b, t)
    let logger :: forall a. LogItem a => Item a -> IO ()
        logger item =
          when (checkItem s sevfilter item) $
              modifyMVar_ scribestate $ \(hdl, bytes, rottime) -> do
                  byteswritten <- formatter hdl colorize v item
                  -- remove old files
                  cleanup
                  -- detect log file rotation
                  let bytes' = bytes - (toInteger $ byteswritten)
                  let tdiff' = round $ diffUTCTime rottime (_itemTime item)
                  if bytes' < 0 || tdiff' < (0 :: Integer)
                     then do   -- log file rotation
                        hClose hdl
                        (hdl2, bytes2, rottime2) <- evalRotator rot fdesc
                        return (hdl2, bytes2, rottime2)
                     else
                        return (hdl, bytes', rottime)

    return $ Scribe logger finalizer

-- | create a katip scribe for logging to a file
mkFileScribeH :: Handle -> Bool -> NamedSeverity -> Log.Severity -> Verbosity -> IO Scribe
mkFileScribeH h colorize sevfilter s v = do
    hSetBuffering h LineBuffering
    locklocal <- newMVar ()
    let logger :: Item a -> IO ()
        logger item = when (checkItem s sevfilter item) $
            bracket_ (takeMVar locklocal) (putMVar locklocal ()) $
                TIO.hPutStrLn h $! toLazyText $ formatItem colorize v item
    pure $ Scribe logger (hClose h)

-- | create a katip scribe for logging to the console
mkStdoutScribe :: NamedSeverity -> Log.Severity -> Verbosity -> IO Scribe
mkStdoutScribe = mkFileScribeH stdout True

-- | create a katip scribe for logging to stderr
mkStderrScribe :: NamedSeverity -> Log.Severity -> Verbosity -> IO Scribe
mkStderrScribe = mkFileScribeH stderr True

-- | @Scribe@ that outputs to '/dev/null' without locking
mkDevNullScribe :: Internal.LoggingHandler -> NamedSeverity -> Log.Severity -> Verbosity -> IO Scribe
mkDevNullScribe lh sevfilter s v = do
    h <- openFile "/dev/null" WriteMode
    let colorize = False
    hSetBuffering h LineBuffering
    let logger :: Item a -> IO ()
        logger item = when (checkItem s sevfilter item) $
            Internal.incrementLinesLogged lh
              >> (TIO.hPutStrLn h $! toLazyText $ formatItem colorize v item)
    pure $ Scribe logger (hClose h)

-- | check if item passes severity filter
checkItem :: Log.Severity -> NamedSeverity -> Item a -> Bool
checkItem s sevfilter item@Item{..} =
    permitItem (Internal.sev2klog severity) item
  where
    severity :: Log.Severity
    severity = fromMaybe s $ HM.lookup namedcontext sevfilter
    namedcontext :: LoggerName
    namedcontext = mconcat $ intercalateNs _itemNamespace

-- | format a @Item@
formatItem :: Bool -> Verbosity -> Item a -> Builder
formatItem withColor _verb Item{..} =
    fromText header <>
    fromText " " <>
    brackets (fromText timestamp) <>
    fromText " " <>
    unLogStr _itemMessage
  where
    header = colorBySeverity _itemSeverity $
             "[" <> mconcat namedcontext <> ":" <> severity <> ":" <> threadid <> "]"
    namedcontext = intercalateNs _itemNamespace
    severity = renderSeverity _itemSeverity
    threadid = getThreadIdText _itemThread
    timestamp = T.pack $ formatTime defaultTimeLocale tsformat _itemTime
    tsformat :: String
    tsformat = "%F %T%2Q %Z"
    colorBySeverity s m = case s of
      EmergencyS -> red m
      AlertS     -> red m
      CriticalS  -> red m
      ErrorS     -> red m
      NoticeS    -> magenta m
      WarningS   -> yellow m
      InfoS      -> blue m
      _          -> m
    red = colorize "31"
    yellow = colorize "33"
    magenta = colorize "35"
    blue = colorize "34"
    colorize c m
      | withColor = "\ESC["<> c <> "m" <> m <> "\ESC[0m"
      | otherwise = m
