{-# LANGUAGE ConstraintKinds #-}
{-|
Module: IHP.Log.Types
Description:  Types for the IHP logging system
-}

module IHP.Log.Types
( Bytes(..)
, LogStr
, BufSize
, TimeFormat
, RotateSettings(..)
, toLogStr
, fromLogStr
, defaultBufSize
, simpleTimeFormat
, simpleTimeFormat'
, Logger(..)
, LogLevel(..)
, LogDestination(..)
, LoggingProvider(..)
, LoggerSettings(..)
, LogFormatter
, FormattedTime
, newLogger
, defaultLogger
, defaultDestination
, defaultFormatter
, withLevelFormatter
, withTimeFormatter
, withTimeAndLevelFormatter
) where

import qualified Prelude
import CorePrelude hiding (putStr, putStrLn, print, error, show)
import Data.Text as Text
import Data.Default (Default (def))
import System.Log.FastLogger (
    LogStr,
    LogType'(..),
    BufSize,
    FileLogSpec(..),
    TimedFileLogSpec(..),
    TimeFormat,
    toLogStr,
    fromLogStr,
    defaultBufSize,
    newTimeCache,
    simpleTimeFormat,
    simpleTimeFormat',
    newTimedFastLogger,
    ToLogStr (..)
    )

import qualified System.Log.FastLogger as FastLogger (FormattedTime)
import GHC.Records


-- some functions brought over from IHP.Prelude
-- can't import due to circular dependency with IHP.ModelSupport which relies on this module

tshow :: Show a => a -> Text
tshow :: forall a. Show a => a -> Text
tshow a
value = String -> Text
Text.pack (a -> String
forall a. Show a => a -> String
Prelude.show a
value)

show :: Show a => a -> Text
show :: forall a. Show a => a -> Text
show = a -> Text
forall a. Show a => a -> Text
tshow

-- | Interal logger type that encapsulates information needed to perform
-- logging operations. Users can also access this though the 'LoggingProvider'
-- class in controller and model actions to perform logic based on the set log level.
data Logger = Logger {
    Logger -> (FormattedTime -> LogStr) -> IO ()
write     :: !((FastLogger.FormattedTime -> LogStr) -> IO ()),
    Logger -> LogLevel
level     :: !LogLevel,
    Logger -> LogFormatter
formatter :: !LogFormatter,
    Logger -> IO FormattedTime
timeCache :: !(IO FastLogger.FormattedTime),
    Logger -> IO ()
cleanup   :: !(IO ())
}

data LogLevel
    -- | For general messages to help with debugging during development.
    -- Default log level in development.
    -- Also the log level used for SQL queries.
    -- See 'IHP.Log.debug' for example usage.
    = Debug
    -- | For info messages that help montior application usage.
    -- Default log level for production.
    -- See 'IHP.Log.info' for example usage.
    | Info
    -- | For warning messages when something might be wrong.
    -- See 'IHP.Log.warn' for example usage.
    | Warn
    -- | For application errors that can be recovered from.
    -- See 'IHP.Log.error' for example usage.
    | Error
    -- | For application errors that are fatal
    -- See 'IHP.Log.fatal' for example usage.
    | Fatal
    -- | For miscallenaous log messages. Highest log level - will always be logged
    -- See 'IHP.Log.unknown' for example usage.
    | Unknown
    deriving (Int -> LogLevel
LogLevel -> Int
LogLevel -> [LogLevel]
LogLevel -> LogLevel
LogLevel -> LogLevel -> [LogLevel]
LogLevel -> LogLevel -> LogLevel -> [LogLevel]
(LogLevel -> LogLevel)
-> (LogLevel -> LogLevel)
-> (Int -> LogLevel)
-> (LogLevel -> Int)
-> (LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> [LogLevel])
-> (LogLevel -> LogLevel -> LogLevel -> [LogLevel])
-> Enum LogLevel
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: LogLevel -> LogLevel
succ :: LogLevel -> LogLevel
$cpred :: LogLevel -> LogLevel
pred :: LogLevel -> LogLevel
$ctoEnum :: Int -> LogLevel
toEnum :: Int -> LogLevel
$cfromEnum :: LogLevel -> Int
fromEnum :: LogLevel -> Int
$cenumFrom :: LogLevel -> [LogLevel]
enumFrom :: LogLevel -> [LogLevel]
$cenumFromThen :: LogLevel -> LogLevel -> [LogLevel]
enumFromThen :: LogLevel -> LogLevel -> [LogLevel]
$cenumFromTo :: LogLevel -> LogLevel -> [LogLevel]
enumFromTo :: LogLevel -> LogLevel -> [LogLevel]
$cenumFromThenTo :: LogLevel -> LogLevel -> LogLevel -> [LogLevel]
enumFromThenTo :: LogLevel -> LogLevel -> LogLevel -> [LogLevel]
Enum, LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
/= :: LogLevel -> LogLevel -> Bool
Eq, Eq LogLevel
Eq LogLevel =>
(LogLevel -> LogLevel -> Ordering)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> LogLevel)
-> (LogLevel -> LogLevel -> LogLevel)
-> Ord LogLevel
LogLevel -> LogLevel -> Bool
LogLevel -> LogLevel -> Ordering
LogLevel -> LogLevel -> LogLevel
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LogLevel -> LogLevel -> Ordering
compare :: LogLevel -> LogLevel -> Ordering
$c< :: LogLevel -> LogLevel -> Bool
< :: LogLevel -> LogLevel -> Bool
$c<= :: LogLevel -> LogLevel -> Bool
<= :: LogLevel -> LogLevel -> Bool
$c> :: LogLevel -> LogLevel -> Bool
> :: LogLevel -> LogLevel -> Bool
$c>= :: LogLevel -> LogLevel -> Bool
>= :: LogLevel -> LogLevel -> Bool
$cmax :: LogLevel -> LogLevel -> LogLevel
max :: LogLevel -> LogLevel -> LogLevel
$cmin :: LogLevel -> LogLevel -> LogLevel
min :: LogLevel -> LogLevel -> LogLevel
Ord, Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogLevel -> ShowS
showsPrec :: Int -> LogLevel -> ShowS
$cshow :: LogLevel -> String
show :: LogLevel -> String
$cshowList :: [LogLevel] -> ShowS
showList :: [LogLevel] -> ShowS
Show)

instance ToLogStr LogLevel where
    toLogStr :: LogLevel -> LogStr
toLogStr LogLevel
Debug = LogStr
"DEBUG"
    toLogStr LogLevel
Info = LogStr
"INFO"
    toLogStr LogLevel
Warn = LogStr
"WARN"
    toLogStr LogLevel
Error = LogStr
"ERROR"
    toLogStr LogLevel
Fatal = LogStr
"FATAL"
    toLogStr LogLevel
Unknown = LogStr
"UNKNOWN"

-- | The timestamp in the formatted defined by the logger's timeFormat string.
type FormattedTime = ByteString

-- | Called every time a message is sent to the logger.
-- Since this is just a function type, it's trivial to define custom formatters:
--
-- @
--     withTimeAndLevelFormatterUpcaseAndHappy :: LogFormatter
--     withTimeAndLevelFormatterUpcaseAndHappy time level msg =
--        "[" <> toUpper (show level) <> "]"
--          <> "[" <> time <> "] "
--          <> toUpper msg <> " :) \n"
-- @
type LogFormatter = FormattedTime -> LogLevel -> LogStr -> LogStr

-- | A number of bytes, used in 'RotateSettings'
newtype Bytes = Bytes Integer

data RotateSettings
    -- | Log messages to a file which is never rotated.
    --
    -- @
    -- newLogger def {
    --    destination = File "Log/production.log" NoRotate defaultBufSize
    --    }
    -- @
    = NoRotate
    -- | Log messages to a file and rotate the file after it reaches the given size in bytes.
    -- Third argument is the max number of rotated log files to keep around before overwriting the oldest one.
    --
    -- Example: log to a file rotated once it is 4MB, and keep 7 files before overwriting the first file.
    --
    -- @
    --    newLogger def {
    --      destination = File "Log/production.log" (SizeRotate (Bytes (4 * 1024 * 1024)) 7) defaultBufSize
    --      }
    -- @
    | SizeRotate !Bytes !Int
    -- | Log messages to a file rotated on a timed basis.
    -- Expects a time format string as well as a function which compares two formatted time strings
    -- which is used to determine if the file should be rotated.
    -- Last argument is a function which is called on a log file once its rotated.
    --
    -- Example: rotate a file daily and compress the log file once rotated.
    --
    -- @
    --   let
    --       filePath = "Log/production.log"
    --       formatString = "%FT%H%M%S"
    --       timeCompare = (==) on C8.takeWhile (/=T))
    --       compressFile fp = void . forkIO $
    --           callProcess "tar" [ "--remove-files", "-caf", fp <> ".gz", fp ]
    --   in
    --     newLogger def {
    --        destination = File
    --          filePath
    --          (TimedRotate formatString timeCompare compressFile)
    --          defaultBufSize
    --        }
    -- @
    | TimedRotate !TimeFormat (FastLogger.FormattedTime -> FastLogger.FormattedTime -> Bool) (FilePath -> IO ())

-- | Where logged messages will be delivered to.
data LogDestination
    = None
    -- | Log messages to standard output.
    | Stdout !BufSize
    -- | Log messages to standard error.
    | Stderr !BufSize
    -- | Log message to a file. Rotate the log file with the behavior given by 'RotateSettings'.
    | File !FilePath !RotateSettings !BufSize
    -- | Send logged messages to a callback. Flush action called after every log.
    | Callback !(LogStr -> IO ()) !(IO ())

data LoggerSettings = LoggerSettings {
    LoggerSettings -> LogLevel
level       :: LogLevel,
    LoggerSettings -> LogFormatter
formatter   :: LogFormatter,
    LoggerSettings -> LogDestination
destination :: LogDestination,
    LoggerSettings -> FormattedTime
timeFormat  :: TimeFormat
}

instance Default LoggerSettings where
    def :: LoggerSettings
def = LoggerSettings {
        level :: LogLevel
level = LogLevel
Debug,
        formatter :: LogFormatter
formatter = LogFormatter
defaultFormatter,
        destination :: LogDestination
destination = LogDestination
defaultDestination,
        timeFormat :: FormattedTime
timeFormat = FormattedTime
simpleTimeFormat'
    }

-- | Logger default destination is to standard out.
defaultDestination :: LogDestination
defaultDestination :: LogDestination
defaultDestination = Int -> LogDestination
Stdout Int
defaultBufSize

-- | Used to get the logger for a given environment.
-- | Call in any instance of 'LoggingProvider' get the the environment's current logger.
-- Useful in controller and model actions, which both have logging contexts.
type LoggingProvider context = HasField "logger" context Logger

instance HasField "logger" Logger Logger where
    getField :: Logger -> Logger
getField Logger
logger = Logger
logger

-- | Create a new 'FastLogger' and wrap it in an IHP 'Logger'.
-- Use with the default logger settings and record update syntax for nice configuration:
--
-- > newLogger def { level = Error }
newLogger :: LoggerSettings -> IO Logger
newLogger :: LoggerSettings -> IO Logger
newLogger LoggerSettings { FormattedTime
LogDestination
LogLevel
LogFormatter
level :: LoggerSettings -> LogLevel
formatter :: LoggerSettings -> LogFormatter
destination :: LoggerSettings -> LogDestination
timeFormat :: LoggerSettings -> FormattedTime
level :: LogLevel
formatter :: LogFormatter
destination :: LogDestination
timeFormat :: FormattedTime
.. } = do
    IO FormattedTime
timeCache <- FormattedTime -> IO (IO FormattedTime)
newTimeCache FormattedTime
timeFormat
    ((FormattedTime -> LogStr) -> IO ()
write, IO ()
cleanup) <- IO FormattedTime
-> LogDestination -> IO ((FormattedTime -> LogStr) -> IO (), IO ())
makeFastLogger IO FormattedTime
timeCache LogDestination
destination
    Logger -> IO Logger
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Logger { IO ()
IO FormattedTime
LogLevel
LogFormatter
(FormattedTime -> LogStr) -> IO ()
write :: (FormattedTime -> LogStr) -> IO ()
level :: LogLevel
formatter :: LogFormatter
timeCache :: IO FormattedTime
cleanup :: IO ()
level :: LogLevel
formatter :: LogFormatter
timeCache :: IO FormattedTime
write :: (FormattedTime -> LogStr) -> IO ()
cleanup :: IO ()
.. }
    where
        makeFastLogger :: IO FormattedTime
-> LogDestination -> IO ((FormattedTime -> LogStr) -> IO (), IO ())
makeFastLogger IO FormattedTime
timeCache LogDestination
destination = IO FormattedTime
-> LogType -> IO ((FormattedTime -> LogStr) -> IO (), IO ())
newTimedFastLogger IO FormattedTime
timeCache (LogType -> IO ((FormattedTime -> LogStr) -> IO (), IO ()))
-> LogType -> IO ((FormattedTime -> LogStr) -> IO (), IO ())
forall a b. (a -> b) -> a -> b
$
            case LogDestination
destination of
                LogDestination
None                    -> LogType
LogNone
                Stdout Int
buf              -> Int -> LogType
LogStdout Int
buf
                Stderr Int
buf              -> Int -> LogType
LogStderr Int
buf
                File String
path RotateSettings
settings Int
buf  -> String -> RotateSettings -> Int -> LogType
makeFileLogger String
path RotateSettings
settings Int
buf
                Callback LogStr -> IO ()
callback IO ()
flush -> (LogStr -> IO ()) -> IO () -> LogType
forall a. (a -> IO ()) -> IO () -> LogType' a
LogCallback LogStr -> IO ()
callback IO ()
flush

        makeFileLogger :: String -> RotateSettings -> Int -> LogType
makeFileLogger String
path RotateSettings
NoRotate = String -> Int -> LogType
LogFileNoRotate String
path
        makeFileLogger String
path (SizeRotate (Bytes Integer
size) Int
count) = FileLogSpec -> Int -> LogType
LogFile (String -> Integer -> Int -> FileLogSpec
FileLogSpec String
path Integer
size Int
count)
        makeFileLogger String
path (TimedRotate FormattedTime
fmt FormattedTime -> FormattedTime -> Bool
cmp String -> IO ()
post) = TimedFileLogSpec -> Int -> LogType
LogFileTimedRotate (String
-> FormattedTime
-> (FormattedTime -> FormattedTime -> Bool)
-> (String -> IO ())
-> TimedFileLogSpec
TimedFileLogSpec String
path FormattedTime
fmt FormattedTime -> FormattedTime -> Bool
cmp String -> IO ()
post)

-- | Formats logs as-is to stdout.
defaultLogger :: IO Logger
defaultLogger :: IO Logger
defaultLogger = LoggerSettings -> IO Logger
newLogger LoggerSettings
forall a. Default a => a
def

-- | Formats the log as-is with a newline added.
defaultFormatter :: LogFormatter
defaultFormatter :: LogFormatter
defaultFormatter FormattedTime
_ LogLevel
_ LogStr
msg = LogStr
msg LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"

-- | Prepends the timestamp to the log message and adds a new line.
withTimeFormatter :: LogFormatter
withTimeFormatter :: LogFormatter
withTimeFormatter  FormattedTime
time LogLevel
_ LogStr
msg = LogStr
"[" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr FormattedTime
time LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"] " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
msg LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"

-- | Prepends the log level to the log message and adds a new line.
withLevelFormatter :: LogFormatter
withLevelFormatter :: LogFormatter
withLevelFormatter FormattedTime
time LogLevel
level LogStr
msg = LogStr
"[" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (LogLevel -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr LogLevel
level) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"] " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
msg LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"

-- | Prepends the log level and timestamp to the log message and adds a new line.
withTimeAndLevelFormatter :: LogFormatter
withTimeAndLevelFormatter :: LogFormatter
withTimeAndLevelFormatter FormattedTime
time LogLevel
level LogStr
msg = LogStr
"[" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (LogLevel -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr LogLevel
level) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"] [" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> FormattedTime -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr FormattedTime
time LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"] " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
msg LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"