{-# LANGUAGE TupleSections #-}

module Freckle.App.Logging
  (
  -- * Logging settings
    HasLogging(..)
  , getLogDefaultANSI
  , getLogBehaviors
  , LogLevel
  , LogFormat(..)
  , LogLocation(..)

  -- ** Loading
  , parseEnvLogFormat
  , parseEnvLogLevel
  , parseEnvLogLocation

  -- * 'MonadLogger'-style running
  , runAppLoggerT

  -- * Formats, for use from other Logging libraries
  , formatJsonLogStr
  , formatJsonNoLoc
  , formatJson
  , formatTerminal
  ) where

import Freckle.App.Prelude

import Control.Monad.Logger
import Data.Aeson (ToJSON, encode, object, (.=))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import qualified Freckle.App.Env as Env
import System.Console.ANSI
  ( Color(Blue, Magenta, Red, Yellow)
  , ColorIntensity(Dull)
  , ConsoleLayer(Foreground)
  , SGR(Reset, SetColor)
  , hSupportsANSI
  , setSGRCode
  )
import System.IO (stderr, stdout)

data LogFormat
  = FormatJSON
  -- ^ Emit @{"level": "{level}", "message": "{message}"}@
  | FormatTerminal
  -- ^ Emit @[{level}] @{message}@, possibly colorized

data LogLocation
  = LogStdout
  | LogStderr
  | LogFile FilePath

-- | Class for getting Logging settings from your @app@ type
class HasLogging a where
    getLogLevel :: a -> LogLevel

    getLogFormat :: a -> LogFormat

    getLogLocation :: a -> LogLocation

-- | Provide a pure decision for colorizing output
--
-- This is useful in a context where actively checking for ANSI terminal support
-- is either not possible or too expensive. Given that we support 'LogFile', and
-- so are unlikely to be redirecting terminal output to a file, it is relatively
-- safe to use this determination.
--
getLogDefaultANSI :: HasLogging a => a -> Bool
getLogDefaultANSI :: a -> Bool
getLogDefaultANSI a
app = case (a -> LogLocation
forall a. HasLogging a => a -> LogLocation
getLogLocation a
app, a -> LogFormat
forall a. HasLogging a => a -> LogFormat
getLogFormat a
app) of
  (LogLocation
LogStdout, LogFormat
FormatTerminal) -> Bool
True
  (LogLocation
LogStdout, LogFormat
FormatJSON) -> Bool
False
  (LogLocation
LogStderr, LogFormat
FormatTerminal) -> Bool
True
  (LogLocation
LogStderr, LogFormat
FormatJSON) -> Bool
False
  (LogFile FilePath
_, LogFormat
FormatTerminal) -> Bool
False
  (LogFile FilePath
_, LogFormat
FormatJSON) -> Bool
False

getLogBehaviors :: HasLogging a => a -> IO (ByteString -> IO (), Bool)
getLogBehaviors :: a -> IO (ByteString -> IO (), Bool)
getLogBehaviors a
app = case a -> LogLocation
forall a. HasLogging a => a -> LogLocation
getLogLocation a
app of
  LogLocation
LogStdout -> (Handle -> ByteString -> IO ()
BS8.hPutStr Handle
stdout, ) (Bool -> (ByteString -> IO (), Bool))
-> IO Bool -> IO (ByteString -> IO (), Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Bool
hSupportsANSI Handle
stdout
  LogLocation
LogStderr -> (Handle -> ByteString -> IO ()
BS8.hPutStr Handle
stderr, ) (Bool -> (ByteString -> IO (), Bool))
-> IO Bool -> IO (ByteString -> IO (), Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Bool
hSupportsANSI Handle
stderr
  LogFile FilePath
path -> (ByteString -> IO (), Bool) -> IO (ByteString -> IO (), Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> ByteString -> IO ()
BS8.appendFile FilePath
path, Bool
False)

parseEnvLogLevel :: Env.Parser LogLevel
parseEnvLogLevel :: Parser LogLevel
parseEnvLogLevel = Reader LogLevel -> FilePath -> Mod LogLevel -> Parser LogLevel
forall a. Reader a -> FilePath -> Mod a -> Parser a
Env.var Reader LogLevel
parse FilePath
"LOG_LEVEL" (Mod LogLevel -> Parser LogLevel)
-> Mod LogLevel -> Parser LogLevel
forall a b. (a -> b) -> a -> b
$ LogLevel -> Mod LogLevel
forall a. a -> Mod a
Env.def LogLevel
LevelWarn
 where
  parse :: Reader LogLevel
parse = (FilePath -> Either FilePath LogLevel) -> Reader LogLevel
forall a. (FilePath -> Either FilePath a) -> Reader a
Env.eitherReader ((FilePath -> Either FilePath LogLevel) -> Reader LogLevel)
-> (FilePath -> Either FilePath LogLevel) -> Reader LogLevel
forall a b. (a -> b) -> a -> b
$ \case
    FilePath
"warn" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LevelWarn
    FilePath
"error" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LevelError
    FilePath
"debug" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LevelDebug
    FilePath
"info" -> LogLevel -> Either FilePath LogLevel
forall a b. b -> Either a b
Right LogLevel
LevelInfo
    FilePath
level -> FilePath -> Either FilePath LogLevel
forall a b. a -> Either a b
Left (FilePath -> Either FilePath LogLevel)
-> FilePath -> Either FilePath LogLevel
forall a b. (a -> b) -> a -> b
$ FilePath
"unexpected log level: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
level

parseEnvLogFormat :: Env.Parser LogFormat
parseEnvLogFormat :: Parser LogFormat
parseEnvLogFormat = Reader LogFormat -> FilePath -> Mod LogFormat -> Parser LogFormat
forall a. Reader a -> FilePath -> Mod a -> Parser a
Env.var Reader LogFormat
parse FilePath
"LOG_FORMAT" (Mod LogFormat -> Parser LogFormat)
-> Mod LogFormat -> Parser LogFormat
forall a b. (a -> b) -> a -> b
$ LogFormat -> Mod LogFormat
forall a. a -> Mod a
Env.def LogFormat
FormatTerminal
 where
  parse :: Reader LogFormat
parse = (FilePath -> Either FilePath LogFormat) -> Reader LogFormat
forall a. (FilePath -> Either FilePath a) -> Reader a
Env.eitherReader ((FilePath -> Either FilePath LogFormat) -> Reader LogFormat)
-> (FilePath -> Either FilePath LogFormat) -> Reader LogFormat
forall a b. (a -> b) -> a -> b
$ \case
    FilePath
"json" -> LogFormat -> Either FilePath LogFormat
forall a b. b -> Either a b
Right LogFormat
FormatJSON
    FilePath
"terminal" -> LogFormat -> Either FilePath LogFormat
forall a b. b -> Either a b
Right LogFormat
FormatTerminal
    FilePath
format -> FilePath -> Either FilePath LogFormat
forall a b. a -> Either a b
Left (FilePath -> Either FilePath LogFormat)
-> FilePath -> Either FilePath LogFormat
forall a b. (a -> b) -> a -> b
$ FilePath
"unexpected format: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
format

parseEnvLogLocation :: Env.Parser LogLocation
parseEnvLogLocation :: Parser LogLocation
parseEnvLogLocation = Reader LogLocation
-> FilePath -> Mod LogLocation -> Parser LogLocation
forall a. Reader a -> FilePath -> Mod a -> Parser a
Env.var Reader LogLocation
parse FilePath
"LOG_LOCATION" (Mod LogLocation -> Parser LogLocation)
-> Mod LogLocation -> Parser LogLocation
forall a b. (a -> b) -> a -> b
$ LogLocation -> Mod LogLocation
forall a. a -> Mod a
Env.def LogLocation
LogStdout
 where
  parse :: Reader LogLocation
parse = (FilePath -> Either FilePath LogLocation) -> Reader LogLocation
forall a. (FilePath -> Either FilePath a) -> Reader a
Env.eitherReader ((FilePath -> Either FilePath LogLocation) -> Reader LogLocation)
-> (FilePath -> Either FilePath LogLocation) -> Reader LogLocation
forall a b. (a -> b) -> a -> b
$ \case
    FilePath
"stdout" -> LogLocation -> Either FilePath LogLocation
forall a b. b -> Either a b
Right LogLocation
LogStdout
    FilePath
"stderr" -> LogLocation -> Either FilePath LogLocation
forall a b. b -> Either a b
Right LogLocation
LogStderr
    FilePath
"file" -> LogLocation -> Either FilePath LogLocation
forall a b. b -> Either a b
Right (LogLocation -> Either FilePath LogLocation)
-> LogLocation -> Either FilePath LogLocation
forall a b. (a -> b) -> a -> b
$ FilePath -> LogLocation
LogFile FilePath
"fancy.log"
    FilePath
file -> LogLocation -> Either FilePath LogLocation
forall a b. b -> Either a b
Right (LogLocation -> Either FilePath LogLocation)
-> LogLocation -> Either FilePath LogLocation
forall a b. (a -> b) -> a -> b
$ FilePath -> LogLocation
LogFile FilePath
file

runAppLoggerT :: HasLogging a => a -> LoggingT IO b -> IO b
runAppLoggerT :: a -> LoggingT IO b -> IO b
runAppLoggerT a
app LoggingT IO b
f = do
  (ByteString -> IO ()
putLogLine, Bool
isANSI) <- a -> IO (ByteString -> IO (), Bool)
forall a. HasLogging a => a -> IO (ByteString -> IO (), Bool)
getLogBehaviors a
app

  let
    logger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger = case a -> LogFormat
forall a. HasLogging a => a -> LogFormat
getLogFormat a
app of
      LogFormat
FormatJSON -> (ByteString -> IO ())
-> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
forall t.
(ByteString -> t) -> Loc -> LogSource -> LogLevel -> LogStr -> t
jsonLogger ByteString -> IO ()
putLogLine
      LogFormat
FormatTerminal -> (ByteString -> IO ())
-> Bool -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
forall a t.
ToLogStr a =>
(ByteString -> t) -> Bool -> Loc -> LogSource -> LogLevel -> a -> t
ansiLogger ByteString -> IO ()
putLogLine Bool
isANSI

  (LoggingT IO b
 -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO b)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT IO b
-> IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO b
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> IO b
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT Loc -> LogSource -> LogLevel -> LogStr -> IO ()
logger
    (LoggingT IO b -> IO b) -> LoggingT IO b -> IO b
forall a b. (a -> b) -> a -> b
$ (LogSource -> LogLevel -> Bool) -> LoggingT IO b -> LoggingT IO b
forall (m :: * -> *) a.
(LogSource -> LogLevel -> Bool) -> LoggingT m a -> LoggingT m a
filterLogger (\LogSource
_ LogLevel
level -> LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= a -> LogLevel
forall a. HasLogging a => a -> LogLevel
getLogLevel a
app) LoggingT IO b
f
 where
  jsonLogger :: (ByteString -> t) -> Loc -> LogSource -> LogLevel -> LogStr -> t
jsonLogger ByteString -> t
putLogLine Loc
loc LogSource
src LogLevel
level LogStr
str =
    ByteString -> t
putLogLine (ByteString -> t) -> ByteString -> t
forall a b. (a -> b) -> a -> b
$ Loc -> LogSource -> LogLevel -> LogStr -> ByteString
formatJsonLogStr Loc
loc LogSource
src LogLevel
level LogStr
str

  ansiLogger :: (ByteString -> t) -> Bool -> Loc -> LogSource -> LogLevel -> a -> t
ansiLogger ByteString -> t
putLogLine Bool
isANSI Loc
loc LogSource
src LogLevel
level a
str =
    ByteString -> t
putLogLine (ByteString -> t) -> ByteString -> t
forall a b. (a -> b) -> a -> b
$ Bool -> Loc -> LogSource -> LogLevel -> a -> ByteString
forall a.
ToLogStr a =>
Bool -> Loc -> LogSource -> LogLevel -> a -> ByteString
formatTerminal Bool
isANSI Loc
loc LogSource
src LogLevel
level a
str

formatJsonLogStr :: Loc -> LogSource -> LogLevel -> LogStr -> ByteString
formatJsonLogStr :: Loc -> LogSource -> LogLevel -> LogStr -> ByteString
formatJsonLogStr Loc
loc LogSource
src LogLevel
level =
  Maybe Loc -> Maybe LogSource -> LogLevel -> LogSource -> ByteString
forall a.
ToJSON a =>
Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString
formatJson (Loc -> Maybe Loc
forall a. a -> Maybe a
Just Loc
loc) (LogSource -> Maybe LogSource
forall a. a -> Maybe a
Just LogSource
src) LogLevel
level (LogSource -> ByteString)
-> (LogStr -> LogSource) -> LogStr -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LogSource
decodeUtf8 (ByteString -> LogSource)
-> (LogStr -> ByteString) -> LogStr -> LogSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
fromLogStr

formatJsonNoLoc :: ToJSON a => LogLevel -> a -> ByteString
formatJsonNoLoc :: LogLevel -> a -> ByteString
formatJsonNoLoc = Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString
forall a.
ToJSON a =>
Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString
formatJson Maybe Loc
forall a. Maybe a
Nothing Maybe LogSource
forall a. Maybe a
Nothing

formatJson
  :: ToJSON a => Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString
formatJson :: Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString
formatJson Maybe Loc
loc Maybe LogSource
src LogLevel
level a
msg = (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n") (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
  [ Key
"loc" Key -> Maybe Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Loc -> Value
locJson (Loc -> Value) -> Maybe Loc -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Loc
loc)
  , Key
"src" Key -> Maybe LogSource -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe LogSource
src
  , Key
"level" Key -> LogSource -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LogLevel -> LogSource
levelText LogLevel
level
  , Key
"message" Key -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a
msg
  ]
 where
  locJson :: Loc -> Value
locJson Loc {FilePath
CharPos
loc_end :: Loc -> CharPos
loc_start :: Loc -> CharPos
loc_module :: Loc -> FilePath
loc_package :: Loc -> FilePath
loc_filename :: Loc -> FilePath
loc_end :: CharPos
loc_start :: CharPos
loc_module :: FilePath
loc_package :: FilePath
loc_filename :: FilePath
..} = [Pair] -> Value
object
    [ Key
"filename" Key -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
loc_filename
    , Key
"package" Key -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
loc_package
    , Key
"module" Key -> FilePath -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= FilePath
loc_module
    , Key
"start" Key -> CharPos -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= CharPos
loc_start
    , Key
"end" Key -> CharPos -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= CharPos
loc_end
    ]

formatTerminal
  :: ToLogStr a
  => Bool -- ^ Supports escapes?
  -> Loc
  -> LogSource
  -> LogLevel
  -> a
  -> ByteString
formatTerminal :: Bool -> Loc -> LogSource -> LogLevel -> a -> ByteString
formatTerminal Bool
isANSI Loc
loc LogSource
src LogLevel
level a
str = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
  [ SGR -> ByteString
esc (SGR -> ByteString) -> SGR -> ByteString
forall a b. (a -> b) -> a -> b
$ LogLevel -> SGR
style LogLevel
level
  , ByteString -> Word8 -> ByteString
BS.snoc ByteString
levelStr Word8
forall b. Num b => b
labelEnd
  , SGR -> ByteString
esc SGR
Reset
  , ByteString -> [ByteString] -> ByteString
BS.intercalate (Word8 -> ByteString
BS.singleton Word8
forall b. Num b => b
labelEnd) [ByteString]
logStr
  , SGR -> ByteString
esc SGR
Reset
  ]
 where
  labelEnd :: b
labelEnd = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
']'

  (ByteString
levelStr, [ByteString]
logStr) =
    let formatted :: ByteString
formatted = LogStr -> ByteString
fromLogStr (LogStr -> ByteString) -> LogStr -> ByteString
forall a b. (a -> b) -> a -> b
$ Loc -> LogSource -> LogLevel -> LogStr -> LogStr
defaultLogStr Loc
loc LogSource
src LogLevel
level (LogStr -> LogStr) -> LogStr -> LogStr
forall a b. (a -> b) -> a -> b
$ a -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr a
str
    in
      case Word8 -> ByteString -> [ByteString]
BS.split Word8
forall b. Num b => b
labelEnd ByteString
formatted of
        [] -> (ByteString
"", [ByteString
formatted])
        (ByteString
x : [ByteString]
xs) -> (ByteString
x, [ByteString]
xs)

  esc :: SGR -> ByteString
esc SGR
x = if Bool
isANSI then FilePath -> ByteString
BS8.pack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ [SGR] -> FilePath
setSGRCode [SGR
x] else ByteString
""

style :: LogLevel -> SGR
style :: LogLevel -> SGR
style = \case
  LogLevel
LevelDebug -> ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Magenta
  LogLevel
LevelInfo -> ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Blue
  LogLevel
LevelWarn -> ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Yellow
  LogLevel
LevelError -> ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
Red
  LevelOther LogSource
_ -> SGR
Reset

levelText :: LogLevel -> Text
levelText :: LogLevel -> LogSource
levelText = \case
  LogLevel
LevelDebug -> LogSource
"Debug"
  LogLevel
LevelInfo -> LogSource
"Info"
  LogLevel
LevelWarn -> LogSource
"Warn"
  LogLevel
LevelError -> LogSource
"Error"
  LevelOther LogSource
x -> LogSource
x