{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Our own mini logging system. Can read log level from env as
-- HAGIA_LOGLEVEL, defaults to fatal.
--
-- Provides instance for Control.Monad.Logger as well, so that we don't have to
-- use their LoggerT
module Log
    ( MonadLog (..)

      -- * Logging functions
    , trace
    , debug
    , info
    , warning
    , error
    , fatal

      -- * Levels
    , levelTrace
    , levelDebug
    , levelInfo
    , levelWarning
    , levelError
    , levelFatal

      -- * Transformer for log level
    , LoggerT (..)
    , runLoggerT

      -- * Helpers for yesod logging
    , logFast
    , formatWarpRequest
    ) where

-- Consider using monad-logger directly in the future with template haskell.
-- Very similar to rust. Or maybe even the one with CallStack. Although yesos
-- and warp use fast-logger instead, with a similar in form but different
-- nominally interface, so I need to unite them in one way or another.

import ClassyPrelude hiding (error, trace)
import Log.Level

import qualified Control.Monad.Logger as MonadLogger
import qualified Network.Wai as Wai
import qualified Network.Wai.Middleware.RequestLogger as Wai
import qualified System.Log.FastLogger as FastLogger

import Conduit (PrimMonad (primitive))
import Control.Monad.Logger (MonadLogger (..), MonadLoggerIO)
import Network.HTTP.Types (HttpVersion (HttpVersion), Status (..))
import System.Environment (lookupEnv)
import System.IO.Unsafe (unsafePerformIO)

class MonadLog m where
    shouldLog :: LogLevel -> m Bool
    logAtLevel :: LogLevel -> Text -> m ()

trace, debug, info, warning, error, fatal :: MonadLog m => Text -> m ()
trace = logAtLevel levelTrace
debug = logAtLevel levelDebug
info = logAtLevel levelInfo
warning = logAtLevel levelWarning
error = logAtLevel levelError
fatal = logAtLevel levelFatal
{-# INLINEABLE trace #-}
{-# INLINEABLE debug #-}
{-# INLINEABLE info #-}
{-# INLINEABLE warning #-}
{-# INLINEABLE error #-}
{-# INLINEABLE fatal #-}

instance MonadIO m => MonadLog m where
    shouldLog level = do
        envLogLevel <- readIORef envLogLevelVar
        pure $ level >= envLogLevel

    logAtLevel level message =
        whenM (shouldLog level) $
            sayErr $
                displayLogLevel level <> message
    {-# INLINEABLE logAtLevel #-}

envLogLevelVar :: IORef LogLevel
envLogLevelVar = unsafePerformIO $ do
    levelStr <- lookupEnv "HAGIA_LOGLEVEL"
    let level = case levelStr of
            Just "trace" -> levelTrace
            Just "debug" -> levelDebug
            Just "info" -> levelInfo
            Just "warning" -> levelWarning
            Just "error" -> levelError
            Just "fatal" -> levelFatal
            _ -> levelFatal
    when (level == levelTrace) $ sayErr "[TRACE] Created logger at level 'trace'"
    newIORef level
{-# NOINLINE envLogLevelVar #-}

displayLogLevel :: LogLevel -> Text
displayLogLevel lvl
    | lvl == levelTrace = "[TRACE] "
    | lvl == levelDebug = "[DEBUG] "
    | lvl == levelInfo = "[INFO] "
    | lvl == levelWarning = "[WARNING] "
    | lvl == levelError = "[ERROR] "
    | lvl == levelFatal = "[FATAL] "
    | otherwise = "[UNKNOWN] "

newtype LoggerT m a = LoggerT {internalRunLoggerT :: LogLevel -> m a}

runLoggerT :: LogLevel -> LoggerT m a -> m a
runLoggerT = flip internalRunLoggerT

instance {-# OVERLAPPING #-} MonadIO m => MonadLog (LoggerT m) where
    shouldLog lvl = LoggerT $ \setLevel -> pure $ lvl >= setLevel
    logAtLevel lvl msg =
        whenM (shouldLog lvl) $
            sayErr $
                displayLogLevel lvl <> msg

instance Functor m => Functor (LoggerT m) where
    fmap f m = LoggerT $ fmap f . internalRunLoggerT m

instance Applicative m => Applicative (LoggerT m) where
    pure x = LoggerT $ const $ pure x
    f <*> v = LoggerT $ \lvl -> internalRunLoggerT f lvl <*> internalRunLoggerT v lvl

instance Monad m => Monad (LoggerT m) where
    m >>= k = LoggerT $ \lvl -> do
        a <- internalRunLoggerT m lvl
        internalRunLoggerT (k a) lvl

instance (PrimMonad m) => PrimMonad (LoggerT m) where
    type PrimState (LoggerT m) = PrimState m
    primitive f = LoggerT $ const $ primitive f

instance MonadIO m => MonadIO (LoggerT m) where
    liftIO m = LoggerT $ const $ liftIO m

instance MonadUnliftIO m => MonadUnliftIO (LoggerT m) where
    withRunInIO inner = LoggerT $ \lvl ->
        withRunInIO $ \run ->
            inner (run . runLoggerT lvl)

instance (Monad m, MonadLog m) => MonadLogger m where
    monadLoggerLog _loc source level msg = logAtLevel level' msg'
      where
        msg' = prefixSource . decodeUtf8 . MonadLogger.fromLogStr . MonadLogger.toLogStr $ msg
        prefixSource x
            | null source = x
            | otherwise = "[" <> source <> "] " <> x
        level' = convertLogLevel level

instance (MonadIO m, MonadLog m) => MonadLoggerIO m where
    askLoggerIO = pure monadLoggerLog

-- | Log using fast-logger instead of stderr
logFast
    :: (MonadIO m, MonadLog m)
    => FastLogger.LoggerSet
    -> loc
    -> Text
    -> MonadLogger.LogLevel
    -> MonadLogger.LogStr
    -> m ()
logFast logger _loc source level msg =
    whenM (shouldLog level') $
        liftIO $
            FastLogger.pushLogStrLn logger $
                levelStr <> msg'
  where
    levelStr = FastLogger.toLogStr $ displayLogLevel level'
    msg'
        | null source = msg
        | otherwise = FastLogger.toLogStr ("[" <> source <> "] ") <> msg
    level' = convertLogLevel level

convertLogLevel :: MonadLogger.LogLevel -> LogLevel
convertLogLevel = \case
    MonadLogger.LevelDebug -> levelDebug
    MonadLogger.LevelInfo -> levelInfo
    MonadLogger.LevelWarn -> levelWarning
    MonadLogger.LevelError -> levelError
    MonadLogger.LevelOther _ -> levelDebug

formatWarpRequest :: Wai.OutputFormatter
formatWarpRequest _date req Status{statusCode, statusMessage} _wtf =
    "[DEBUG] [warp] "
        <> FastLogger.toLogStr (Wai.requestMethod req)
        <> " "
        <> FastLogger.toLogStr (Wai.rawPathInfo req)
        <> FastLogger.toLogStr (Wai.rawQueryString req)
        <> " "
        <> let HttpVersion major minor = Wai.httpVersion req
           in  "HTTP/"
                <> FastLogger.toLogStr major
                <> "."
                <> FastLogger.toLogStr minor
                <> " "
                <> maybeAdd Wai.requestHeaderHost
                <> maybeAdd Wai.requestHeaderReferer
                <> maybeAdd Wai.requestHeaderUserAgent
                <> "-> "
                <> lshow statusCode
                <> " "
                <> FastLogger.toLogStr statusMessage
                <> "\n"
  where
    lshow :: Show a => a -> MonadLogger.LogStr
    lshow = FastLogger.toLogStr . tshow
    maybeAdd f = case f req of
        Nothing -> ""
        Just h -> lshow h <> " "