Logging.hs

{-# 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 Data.Text.Encoding (decodeUtf8)
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 app = case (getLogLocation app, getLogFormat app) of
  (LogStdout, FormatTerminal) -> True
  (LogStdout, FormatJSON) -> False
  (LogStderr, FormatTerminal) -> True
  (LogStderr, FormatJSON) -> False
  (LogFile _, FormatTerminal) -> False
  (LogFile _, FormatJSON) -> False

getLogBehaviors :: HasLogging a => a -> IO (ByteString -> IO (), Bool)
getLogBehaviors app = case getLogLocation app of
  LogStdout -> (BS8.hPutStr stdout, ) <$> hSupportsANSI stdout
  LogStderr -> (BS8.hPutStr stderr, ) <$> hSupportsANSI stderr
  LogFile path -> pure (BS8.appendFile path, False)

parseEnvLogLevel :: Env.Parser LogLevel
parseEnvLogLevel = Env.var parse "LOG_LEVEL" $ Env.def LevelWarn
 where
  parse = Env.eitherReader $ \case
    "warn" -> Right LevelWarn
    "error" -> Right LevelError
    "debug" -> Right LevelDebug
    "info" -> Right LevelInfo
    level -> Left $ "unexpected log level: " <> level

parseEnvLogFormat :: Env.Parser LogFormat
parseEnvLogFormat = Env.var parse "LOG_FORMAT" $ Env.def FormatTerminal
 where
  parse = Env.eitherReader $ \case
    "json" -> Right FormatJSON
    "terminal" -> Right FormatTerminal
    format -> Left $ "unexpected format: " <> format

parseEnvLogLocation :: Env.Parser LogLocation
parseEnvLogLocation = Env.var parse "LOG_LOCATION" $ Env.def LogStdout
 where
  parse = Env.eitherReader $ \case
    "stdout" -> Right LogStdout
    "stderr" -> Right LogStderr
    "file" -> Right $ LogFile "fancy.log"
    file -> Right $ LogFile file

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

  let
    logger = case getLogFormat app of
      FormatJSON -> jsonLogger putLogLine
      FormatTerminal -> ansiLogger putLogLine isANSI

  flip runLoggingT logger
    $ filterLogger (\_ level -> level >= getLogLevel app) f
 where
  jsonLogger putLogLine loc src level str =
    putLogLine $ formatJsonLogStr loc src level str

  ansiLogger putLogLine isANSI loc src level str =
    putLogLine $ formatTerminal isANSI loc src level str

formatJsonLogStr :: Loc -> LogSource -> LogLevel -> LogStr -> ByteString
formatJsonLogStr loc src level =
  formatJson (Just loc) (Just src) level . decodeUtf8 . fromLogStr

formatJsonNoLoc :: ToJSON a => LogLevel -> a -> ByteString
formatJsonNoLoc = formatJson Nothing Nothing

formatJson
  :: ToJSON a => Maybe Loc -> Maybe LogSource -> LogLevel -> a -> ByteString
formatJson loc src level msg = (<> "\n") $ BSL.toStrict $ encode $ object
  [ "loc" .= (locJson <$> loc)
  , "src" .= src
  , "level" .= levelText level
  , "message" .= msg
  ]
 where
  locJson Loc {..} = object
    [ "filename" .= loc_filename
    , "package" .= loc_package
    , "module" .= loc_module
    , "start" .= loc_start
    , "end" .= loc_end
    ]

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

  (levelStr : logStr) =
    BS.split labelEnd . fromLogStr $ defaultLogStr loc src level $ toLogStr str

  esc x = if isANSI then BS8.pack $ setSGRCode [x] else ""

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

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