Handle.hs

{-# LANGUAGE CPP, OverloadedStrings #-}

module Katip.Scribes.Handle where

-------------------------------------------------------------------------------
import Control.Concurrent
import Control.Exception (bracket_, finally)
import Data.Aeson
#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import Data.Bifunctor (Bifunctor (..))
#else
import qualified Data.HashMap.Strict as HM
#endif
import Data.Monoid as M
import Data.Scientific as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder
import Data.Text.Lazy.Encoding (decodeUtf8)
import Data.Text.Lazy.IO as T
import qualified Data.Vector as V
-------------------------------------------------------------------------------
import Katip.Core
import Katip.Format.Time (formatAsLogTime)
import System.IO

-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
brackets :: Builder -> Builder
brackets m = "[" M.<> m <> "]"
{-# INLINE brackets #-}

-------------------------------------------------------------------------------
getKeys :: LogItem s => Verbosity -> s -> [Builder]
getKeys verb a = concat (toBuilders (payloadObject verb a))
{-# INLINE getKeys #-}

#if MIN_VERSION_aeson(2, 0, 0)
toBuilders :: KM.KeyMap Value -> [[Builder]]
toBuilders = fmap (renderPair . first K.toText) . KM.toList
{-# INLINE toBuilders #-}

toTxtKeyList :: KM.KeyMap v -> [(Text, v)]
toTxtKeyList mp = first K.toText <$> KM.toList mp
{-# INLINE toTxtKeyList #-}
#else
toBuilders :: HM.HashMap Text Value -> [[Builder]]
toBuilders = fmap renderPair . HM.toList
{-# INLINE toBuilders #-}

toTxtKeyList :: HM.HashMap Text v -> [(Text, v)]
toTxtKeyList = HM.toList
{-# INLINE toTxtKeyList #-}
#endif

renderPair :: (Text, Value) -> [Builder]
renderPair (k, v) =
  case v of
    Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- toTxtKeyList o]
    Array a -> concat [renderPair (k <> "." <> T.pack (show k'), v') | (k', v') <- V.toList (V.indexed a)]
    String t -> [fromText (k <> ":" <> t)]
    Number n -> [fromText (k <> ":") <> fromString (formatNumber n)]
    Bool b -> [fromText (k <> ":") <> fromString (show b)]
    Null -> [fromText (k <> ":null")]
  where
    formatNumber :: Scientific -> String
    formatNumber n =
      formatScientific Generic (if isFloating n then Nothing else Just 0) n
{-# INLINE renderPair #-}

-------------------------------------------------------------------------------
data ColorStrategy
  = -- | Whether to use color control chars in log output
    ColorLog Bool
  | -- | Color if output is a terminal
    ColorIfTerminal
  deriving (Show, Eq)

-------------------------------------------------------------------------------

-- | Logs to a file handle such as stdout, stderr, or a file. Contexts
-- and other information will be flattened out into bracketed
-- fields. For example:
--
-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
--
-- Returns the newly-created `Scribe`. The finalizer flushes the
-- handle. Handle mode is set to 'LineBuffering' automatically.
mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
mkHandleScribe = mkHandleScribeWithFormatter bracketFormat
{-# INLINE mkHandleScribe #-}

-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom
-- `ItemFormatter` that can be used to format `Item` as needed.
--
-- Returns the newly-created `Scribe`. The finalizer flushes the
-- handle. Handle mode is set to 'LineBuffering' automatically.
mkHandleScribeWithFormatter ::
  (forall a. LogItem a => ItemFormatter a) ->
  ColorStrategy ->
  Handle ->
  PermitFunc ->
  Verbosity ->
  IO Scribe
mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do
  hSetBuffering h LineBuffering
  colorize <- case cs of
    ColorIfTerminal -> hIsTerminalDevice h
    ColorLog b -> return b
  lock <- newMVar ()
  let logger i@Item {} = do
        bracket_ (takeMVar lock) (putMVar lock ()) $
          T.hPutStrLn h $ toLazyText $ itemFormatter colorize verb i
  return $ Scribe logger (hFlush h) permitF
{-# INLINE mkHandleScribeWithFormatter #-}

-------------------------------------------------------------------------------

-- | A specialization of 'mkHandleScribe' that takes a 'FilePath'
-- instead of a 'Handle'. It is responsible for opening the file in
-- 'AppendMode' and will close the file handle on
-- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle
-- to 'LineBuffering' mode.
mkFileScribe :: FilePath -> PermitFunc -> Verbosity -> IO Scribe
mkFileScribe f permitF verb = do
  h <- openFile f AppendMode
  Scribe logger finalizer permit <- mkHandleScribe (ColorLog False) h permitF verb
  return (Scribe logger (finalizer `finally` hClose h) permit)
{-# INLINE mkFileScribe #-}

-------------------------------------------------------------------------------

-- | A custom ItemFormatter for logging `Item`s. Takes a `Bool` indicating
-- whether to colorize the output, `Verbosity` of output, and an `Item` to
-- format.
--
-- See `bracketFormat` and `jsonFormat` for examples.
type ItemFormatter a = Bool -> Verbosity -> Item a -> Builder

formatItem :: LogItem a => ItemFormatter a
formatItem = bracketFormat
{-# DEPRECATED formatItem "Use bracketFormat instead" #-}
{-# INLINE formatItem #-}

-- | A traditional 'bracketed' log format. Contexts and other information will
-- be flattened out into bracketed fields. For example:
--
-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started
-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context
-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal
bracketFormat :: LogItem a => ItemFormatter a
bracketFormat withColor verb Item {..} =
  brackets nowStr
    <> brackets (mconcat $ map fromText $ intercalateNs _itemNamespace)
    <> brackets (fromText (renderSeverity' _itemSeverity))
    <> brackets (fromString _itemHost)
    <> brackets ("PID " <> fromString (show _itemProcess))
    <> brackets ("ThreadId " <> fromText (getThreadIdText _itemThread))
    <> mconcat ks
    <> maybe mempty (brackets . fromString . locationToString) _itemLoc
    <> fromText " "
    <> (unLogStr _itemMessage)
  where
    nowStr = fromText (formatAsLogTime _itemTime)
    ks = map brackets $ getKeys verb _itemPayload
    renderSeverity' severity =
      colorBySeverity withColor severity (renderSeverity severity)
{-# INLINE bracketFormat #-}

-- | Logs items as JSON. This can be useful in circumstances where you already
-- have infrastructure that is expecting JSON to be logged to a standard stream
-- or file. For example:
--
-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Started","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":44},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp","confrabulation"],"data":{"confrab_factor":42},"app":["MyApp"],"msg":"Confrabulating widgets, with extra namespace and context","pid":"10456","loc":{"loc_col":11,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":53},"host":"myhost.example.com","sev":"Debug","thread":"ThreadId 139"}
-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Namespace and context are back to normal","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":55},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}
jsonFormat :: LogItem a => ItemFormatter a
jsonFormat withColor verb i =
  fromText $
    colorBySeverity withColor (_itemSeverity i) $
      toStrict $ decodeUtf8 $ encode $ itemJson verb i
{-# INLINE jsonFormat #-}

-- | Color a text message based on `Severity`. `ErrorS` and more severe errors
-- are colored red, `WarningS` is colored yellow, and all other messages are
-- rendered in the default color.
colorBySeverity :: Bool -> Severity -> Text -> Text
colorBySeverity withColor severity msg = case severity of
  EmergencyS -> red msg
  AlertS -> red msg
  CriticalS -> red msg
  ErrorS -> red msg
  WarningS -> yellow msg
  _ -> msg
  where
    red = colorize "31"
    yellow = colorize "33"
    colorize c s
      | withColor = "\ESC[" <> c <> "m" <> s <> "\ESC[0m"
      | otherwise = s
{-# INLINE colorBySeverity #-}

-- | Provides a simple log environment with 1 scribe going to
-- stdout. This is a decent example of how to build a LogEnv and is
-- best for scripts that just need a quick, reasonable set up to log
-- to stdout.
ioLogEnv :: PermitFunc -> Verbosity -> IO LogEnv
ioLogEnv permit verb = do
  le <- initLogEnv "io" "io"
  lh <- mkHandleScribe ColorIfTerminal stdout permit verb
  registerScribe "stdout" lh defaultScribeSettings le
{-# INLINE ioLogEnv #-}