Logger.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- |
-- Module      : Gogol.Internal.Logger
-- Copyright   : (c) 2015-2022 Brendan Hay
-- License     : Mozilla Public License, v. 2.0.
-- Maintainer  : Brendan Hay <brendan.g.hay@gmail.com>
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
--
-- Types and functions for constructing loggers and emitting log messages.
module Gogol.Internal.Logger
  ( -- * Constructing a Logger
    Logger,
    newLogger,

    -- * Levels
    LogLevel (..),
    logError,
    logInfo,
    logDebug,
    logTrace,

    -- * Building Messages
    ToLog (..),
    buildLines,
  )
where

import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (..))
import Data.ByteString qualified as BS
import Data.ByteString.Builder (Builder)
import Data.ByteString.Builder qualified as Build
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as LBS
import Data.CaseInsensitive (CI)
import Data.CaseInsensitive qualified as CI
import Data.Int (Int16, Int8)
import Data.List (intersperse)
import Data.Text.Encoding qualified as Text
import Data.Text.Lazy qualified as LText
import Data.Text.Lazy.Encoding qualified as LText
import Data.Word (Word16)
import Gogol.Prelude hiding (Request)
import Network.HTTP.Conduit
import Network.HTTP.Types
import Numeric (showFFloat)
import System.IO

-- | A function threaded through various request and serialisation routines
-- to log informational and debug messages.
type Logger = LogLevel -> Builder -> IO ()

data LogLevel
  = -- | Info messages supplied by the user - this level is not emitted by the library.
    Info
  | -- | Error messages only.
    Error
  | -- | Useful debug information + info + error levels.
    Debug
  | -- | Includes potentially credentials metadata, and non-streaming response bodies.
    Trace
  deriving (Eq, Ord, Enum, Show)

-- | This is a primitive logger which can be used to log builds to a 'Handle'.
--
-- /Note:/ A more sophisticated logging library such as
-- <http://hackage.haskell.org/package/tinylog tinylog> or
-- <http://hackage.haskell.org/package/FastLogger fast-logger>
-- should be used in production code.
newLogger :: (MonadIO m) => LogLevel -> Handle -> m Logger
newLogger x hd = liftIO $ do
  hSetBinaryMode hd True
  hSetBuffering hd LineBuffering
  return $ \y b ->
    when (x >= y) $
      Build.hPutBuilder hd (b <> "\n")

logError,
  logInfo,
  logDebug,
  logTrace ::
    (MonadIO m, ToLog a) => Logger -> a -> m ()
logError f = liftIO . f Error . build
logInfo f = liftIO . f Info . build
logDebug f = liftIO . f Debug . build
logTrace f = liftIO . f Trace . build

class ToLog a where
  -- | Convert a value to a loggable builder.
  build :: a -> Builder

instance ToLog Builder where build = id

instance ToLog LBS.ByteString where build = Build.lazyByteString

instance ToLog ByteString where build = Build.byteString

instance ToLog Int where build = Build.intDec

instance ToLog Int8 where build = Build.int8Dec

instance ToLog Int16 where build = Build.int16Dec

instance ToLog Int32 where build = Build.int32Dec

instance ToLog Int64 where build = Build.int64Dec

instance ToLog Integer where build = Build.integerDec

instance ToLog Word where build = Build.wordDec

instance ToLog Word8 where build = Build.word8Dec

instance ToLog Word16 where build = Build.word16Dec

instance ToLog Word32 where build = Build.word32Dec

instance ToLog Word64 where build = Build.word64Dec

instance ToLog UTCTime where build = Build.stringUtf8 . show

instance ToLog Float where build = build . ($ "") . showFFloat Nothing

instance ToLog Double where build = build . ($ "") . showFFloat Nothing

instance ToLog Text where build = build . Text.encodeUtf8

instance ToLog LText.Text where build = build . LText.encodeUtf8

instance ToLog Char where build = build . BS8.singleton

instance ToLog [Char] where build = build . BS8.pack

instance ToLog StdMethod where build = build . renderStdMethod

-- | Intercalate a list of 'Builder's with newlines.
buildLines :: [Builder] -> Builder
buildLines = mconcat . intersperse "\n"

instance (ToLog a) => ToLog (CI a) where
  build = build . CI.foldedCase

instance (ToLog a) => ToLog (Maybe a) where
  build Nothing = "Nothing"
  build (Just x) = "Just " <> build x

instance ToLog Bool where
  build True = "True"
  build False = "False"

instance ToLog Status where
  build x = build (statusCode x) <> " " <> build (statusMessage x)

instance ToLog [Header] where
  build =
    mconcat
      . intersperse "; "
      . map (\(k, v) -> build k <> ": " <> build v)

instance ToLog HttpVersion where
  build HttpVersion {..} =
    "HTTP/"
      <> build httpMajor
      <> build '.'
      <> build httpMinor

instance ToLog RequestBody where
  build = \case
    RequestBodyBuilder n _ -> " <msger:" <> build n <> ">"
    RequestBodyStream n _ -> " <stream:" <> build n <> ">"
    RequestBodyLBS lbs
      | n <= 4096 -> build lbs
      | otherwise -> " <lazy:" <> build n <> ">"
      where
        n = LBS.length lbs
    RequestBodyBS bs
      | n <= 4096 -> build bs
      | otherwise -> " <strict:" <> build n <> ">"
      where
        n = BS.length bs
    _ -> " <chunked>"

instance ToLog HttpException where
  build x = "[HttpException] {\n" <> build (show x) <> "\n}"

instance ToLog Request where
  build x =
    buildLines
      [ "[Client Request] {",
        "  host      = " <> build (host x) <> ":" <> build (port x),
        "  secure    = " <> build (secure x),
        "  method    = " <> build (method x),
        "  timeout   = " <> build (show (responseTimeout x)),
        "  redirects = " <> build (redirectCount x),
        "  path      = " <> build (path x),
        "  query     = " <> build (queryString x),
        "  headers   = " <> build (requestHeaders x),
        "  body      = " <> build (requestBody x),
        "}"
      ]

instance ToLog (Response a) where
  build x =
    buildLines
      [ "[Client Response] {",
        "  status  = " <> build (responseStatus x),
        "  headers = " <> build (responseHeaders x),
        "}"
      ]