structured-logger

Logger.hs

-- | Logger environment, keeps internal Katip environment,
-- current contexts (metadata), namespaces and minimal interesting
-- severity and verbosity.
data LoggerEnv = LoggerEnv
  { action :: LogAction IO Message
  , context :: Seq.Seq Structured
  }

-- | Create logger and initialize it with defaults.
withLogger
  :: LoggerConfig
  -> (LoggerEnv -> IO a)
  -> IO a
withLogger LoggerConfig{..} f
  | Just True <- loggerConfigDisabled = f emptyLogger
  | otherwise =
      withBackgroundLogger
       loggerConfigMessagesInFlight
       (LogAction $ \x -> feed x >> incCounter metric_written_total >> Window.decGauge metric_in_flight)
       (hFlush stdout)
       $ \(LogAction log_action) ->
         f $ LoggerEnv (LogAction $ \x -> incCounter metric_submitted_total >> log_action x >> Window.incGauge metric_in_flight) Seq.Empty
  where
    LogAction feed = feedHandle stdout

Logger.Internal.hs

{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module Cheops.Logger.Structured
  ( Structured(..)
  , Message(..)
  , LogStr(..)
  , PushContext(..)
  , feedHandle
  , mkThreadId
    -- * Katip compatibility.
  , Severity(..)
  , showLS
  , ls
  , sl
  ) where

import Colog.Core hiding (Severity)

import Control.Concurrent
import Control.Exception
import Data.Aeson
import Data.Aeson.Encoding as Aeson
import qualified Data.ByteString.Builder as Builder
import Data.Coerce
import Data.Foldable
import qualified Data.List.NonEmpty as NE
import Data.Sequence
import Data.String
import Data.String.Conv
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import Foreign.C
import GHC.Conc
import GHC.Exts hiding (toList)
import System.IO

data Structured
  = Segment T.Text
  | Attr T.Text Encoding

data Message = Message
  { message_severity :: Severity
  , thread_id :: Int
  , attributes :: Seq Structured
  , message :: LogStr
  }

mkThreadId :: ThreadId -> Int
{-# NOINLINE mkThreadId #-}
mkThreadId (ThreadId tid) = fromIntegral (getThreadId tid)

foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt

feedHandle :: Handle -> LogAction IO Message
feedHandle h = LogAction $ \Message{..} ->
    let msg = Aeson.pairs $ mconcat
         [ case namespace of
             Nothing -> mempty
             Just xs -> Aeson.pair "namespace" $ Aeson.lazyText xs
         , Aeson.pair "severity" $ commonSeverity message_severity
         , Aeson.pair "thread" $ Aeson.int thread_id
         , case user_data of
             Nothing -> mempty
             Just xs -> Aeson.pair "data" $ Aeson.pairs xs
         , Aeson.pair "message" $ lazyText $ coerce TLB.toLazyText message
         ]
        namespace = TL.intercalate ".". toList <$> NE.nonEmpty
           [ TL.fromStrict tm
           | Segment tm <- toList attributes
           ]
        user_data = fold <$> NE.nonEmpty
          [ pair key attributeValue
          | Attr key attributeValue <- toList attributes
          ]
    in try (Builder.hPutBuilder h $ Aeson.fromEncoding msg <> Builder.char7 '\n') >>= \case
         Left e -> do
           Builder.hPutBuilder h $ Aeson.fromEncoding (Aeson.pairs
              $ mconcat
              [ Aeson.pair "namespace" (Aeson.text "logger")
              , Aeson.pair "exception" (Aeson.string (show (e::SomeException)))
              ])
              <> Builder.char7 '\n'
         Right _ -> pure ()

-- Katip compatibility
newtype LogStr = LogStr TLB.Builder
  deriving newtype IsString
  deriving newtype Semigroup
  deriving newtype Monoid

data Severity = DebugS | InfoS | NoticeS | WarningS | ErrorS  | CriticalS | AlertS | EmergencyS
  deriving Show

-- | Convert severity into the one accepted by the loger.
commonSeverity :: Severity -> Aeson.Encoding
commonSeverity DebugS     = Aeson.text "DEBUG"
commonSeverity InfoS      = Aeson.text "INFO"
commonSeverity NoticeS    = Aeson.text "NOTICE"
commonSeverity WarningS   = Aeson.text "WARNING"
commonSeverity ErrorS     = Aeson.text "ERROR"
commonSeverity CriticalS  = Aeson.text "CRITICAL"
commonSeverity AlertS     = Aeson.text "ALERT"
commonSeverity EmergencyS = Aeson.text "EMERGENCY"

newtype PushContext = PushContext (Seq Structured -> Seq Structured)

sl :: ToJSON a => T.Text -> a -> PushContext
sl label msg = PushContext $ \x -> x |> Attr label (toEncoding msg)

logStr :: StringConv a T.Text => a -> LogStr
logStr t = LogStr (TLB.fromText $ toS t)

ls :: StringConv a T.Text => a -> LogStr
ls = logStr

showLS :: Show a => a -> LogStr
showLS = ls . show