{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE MagicHash #-}
{-# OPTIONS_HADDOCK not-home #-}
-- |
--
-- Structure for tracing context.
--
-- We assume that each message ('Message') can be tagged with two types of values:
--
--    * @segment@ - path that tells where are we in the codebase.
--    * @attrbibutes@ - additional key-value tags, where value is an arbitrary json object.
-- 
-- Segment is needed in a case if we want to apply differrent logging rules to the differrent
-- parts of the codebase. For example we may way to log all the messages in the component one
-- but not all the rest.
--
-- In addition each @Message@ provides some common fields:
--
--    * "thread" - id of the thread that emits message
--    * "severity" - message severity
--
-- All messages in the same context share segment and attributes. So when exported to the log
-- analytics systems it's easy to load all the information associated with it.
--
-- **Compatibility note** internal structure of the message may be changed in the future in case
-- if it's proven that another implementation is faster or more memory efficient. However the
-- higher level API is likely to be stable.
module Colog.Json.Internal.Structured
  ( -- * Log datastructure.
    Structured(..)
  , Message(..)
  , LogStr(..)
  , PushContext(..)
    -- * Internals.
  , Severity(..)
  , encodeSeverity
  , showLS
  , ls
  , sl
  , mkThreadId
  ) where

import Control.Concurrent
import Data.Aeson
import Data.Aeson.Encoding as Aeson
import Data.Sequence
import Data.String
import Data.String.Conv
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as TLB
import Foreign.C
import GHC.Conc
import GHC.Exts hiding (toList)

-- | Part of the structured message.
data Structured
  = Segment T.Text -- ^ Part of the message that is associated this the context of code.
  | Attr T.Text Encoding -- ^ Add attribute to the list.

-- | Log message.
data Message = Message
  { Message -> Severity
message_severity :: Severity -- ^ Message severity.
  , Message -> Int
thread_id :: Int -- ^ Thread that emitted message.
  , Message -> Seq Structured
attributes :: Seq Structured -- ^ List of attributes associated with the context.
  , Message -> LogStr
message :: LogStr -- ^ Message to log.
  }


-- | Efficient message builder.
newtype LogStr = LogStr TLB.Builder
  deriving newtype String -> LogStr
(String -> LogStr) -> IsString LogStr
forall a. (String -> a) -> IsString a
fromString :: String -> LogStr
$cfromString :: String -> LogStr
IsString
  deriving newtype b -> LogStr -> LogStr
NonEmpty LogStr -> LogStr
LogStr -> LogStr -> LogStr
(LogStr -> LogStr -> LogStr)
-> (NonEmpty LogStr -> LogStr)
-> (forall b. Integral b => b -> LogStr -> LogStr)
-> Semigroup LogStr
forall b. Integral b => b -> LogStr -> LogStr
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> LogStr -> LogStr
$cstimes :: forall b. Integral b => b -> LogStr -> LogStr
sconcat :: NonEmpty LogStr -> LogStr
$csconcat :: NonEmpty LogStr -> LogStr
<> :: LogStr -> LogStr -> LogStr
$c<> :: LogStr -> LogStr -> LogStr
Semigroup
  deriving newtype Semigroup LogStr
LogStr
Semigroup LogStr
-> LogStr
-> (LogStr -> LogStr -> LogStr)
-> ([LogStr] -> LogStr)
-> Monoid LogStr
[LogStr] -> LogStr
LogStr -> LogStr -> LogStr
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [LogStr] -> LogStr
$cmconcat :: [LogStr] -> LogStr
mappend :: LogStr -> LogStr -> LogStr
$cmappend :: LogStr -> LogStr -> LogStr
mempty :: LogStr
$cmempty :: LogStr
$cp1Monoid :: Semigroup LogStr
Monoid

-- | Logger severity.
data Severity
  = DebugS      -- ^ Debug level, intended for internal information
  | InfoS       -- ^ Info level, that may be interesting to the user
  | NoticeS     -- ^ Notice, information that
  | WarningS    -- ^ Warning, information possible problem problem of some sort
  | ErrorS      -- ^ Error, information about a problem
  | CriticalS   -- ^ Critical error, intended for error that may break the system
  | AlertS      -- ^ Critical error where immediate actions should be taken
  | EmergencyS  -- ^ System wide emergency
  deriving (Int -> Severity -> ShowS
[Severity] -> ShowS
Severity -> String
(Int -> Severity -> ShowS)
-> (Severity -> String) -> ([Severity] -> ShowS) -> Show Severity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Severity] -> ShowS
$cshowList :: [Severity] -> ShowS
show :: Severity -> String
$cshow :: Severity -> String
showsPrec :: Int -> Severity -> ShowS
$cshowsPrec :: Int -> Severity -> ShowS
Show, Severity
Severity -> Severity -> Bounded Severity
forall a. a -> a -> Bounded a
maxBound :: Severity
$cmaxBound :: Severity
minBound :: Severity
$cminBound :: Severity
Bounded, Severity -> Severity -> Bool
(Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool) -> Eq Severity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Severity -> Severity -> Bool
$c/= :: Severity -> Severity -> Bool
== :: Severity -> Severity -> Bool
$c== :: Severity -> Severity -> Bool
Eq, Eq Severity
Eq Severity
-> (Severity -> Severity -> Ordering)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Severity)
-> (Severity -> Severity -> Severity)
-> Ord Severity
Severity -> Severity -> Bool
Severity -> Severity -> Ordering
Severity -> Severity -> Severity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Severity -> Severity -> Severity
$cmin :: Severity -> Severity -> Severity
max :: Severity -> Severity -> Severity
$cmax :: Severity -> Severity -> Severity
>= :: Severity -> Severity -> Bool
$c>= :: Severity -> Severity -> Bool
> :: Severity -> Severity -> Bool
$c> :: Severity -> Severity -> Bool
<= :: Severity -> Severity -> Bool
$c<= :: Severity -> Severity -> Bool
< :: Severity -> Severity -> Bool
$c< :: Severity -> Severity -> Bool
compare :: Severity -> Severity -> Ordering
$ccompare :: Severity -> Severity -> Ordering
$cp1Ord :: Eq Severity
Ord, Int -> Severity
Severity -> Int
Severity -> [Severity]
Severity -> Severity
Severity -> Severity -> [Severity]
Severity -> Severity -> Severity -> [Severity]
(Severity -> Severity)
-> (Severity -> Severity)
-> (Int -> Severity)
-> (Severity -> Int)
-> (Severity -> [Severity])
-> (Severity -> Severity -> [Severity])
-> (Severity -> Severity -> [Severity])
-> (Severity -> Severity -> Severity -> [Severity])
-> Enum Severity
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Severity -> Severity -> Severity -> [Severity]
$cenumFromThenTo :: Severity -> Severity -> Severity -> [Severity]
enumFromTo :: Severity -> Severity -> [Severity]
$cenumFromTo :: Severity -> Severity -> [Severity]
enumFromThen :: Severity -> Severity -> [Severity]
$cenumFromThen :: Severity -> Severity -> [Severity]
enumFrom :: Severity -> [Severity]
$cenumFrom :: Severity -> [Severity]
fromEnum :: Severity -> Int
$cfromEnum :: Severity -> Int
toEnum :: Int -> Severity
$ctoEnum :: Int -> Severity
pred :: Severity -> Severity
$cpred :: Severity -> Severity
succ :: Severity -> Severity
$csucc :: Severity -> Severity
Enum)

-- | Convert severity into the one accepted by the loger.
encodeSeverity :: Severity -> Aeson.Encoding
{-# INLINE encodeSeverity #-}
encodeSeverity :: Severity -> Encoding
encodeSeverity Severity
DebugS     = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.text Text
"DEBUG"
encodeSeverity Severity
InfoS      = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.text Text
"INFO"
encodeSeverity Severity
NoticeS    = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.text Text
"NOTICE"
encodeSeverity Severity
WarningS   = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.text Text
"WARNING"
encodeSeverity Severity
ErrorS     = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.text Text
"ERROR"
encodeSeverity Severity
CriticalS  = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.text Text
"CRITICAL"
encodeSeverity Severity
AlertS     = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.text Text
"ALERT"
encodeSeverity Severity
EmergencyS = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.text Text
"EMERGENCY"

-- | Wrapper over the structured message builder.
newtype PushContext = PushContext (Seq Structured -> Seq Structured)

-- | "Simple logger" adds a key value to the context:
--
-- @sl "foo" 123@
--
-- Will add @"foo":123@ key pair to the current list of the attributes.
-- Submitted value is stored with json encoding.
sl :: ToJSON a => T.Text -> a -> PushContext
sl :: Text -> a -> PushContext
sl Text
label a
msg = (Seq Structured -> Seq Structured) -> PushContext
PushContext \Seq Structured
x ->
  Seq Structured
x Seq Structured -> Structured -> Seq Structured
forall a. Seq a -> a -> Seq a
|> Text -> Encoding -> Structured
Attr Text
label (a -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding a
msg)

-- | Log any message.
logStr :: StringConv a T.Text => a -> LogStr
logStr :: a -> LogStr
logStr a
t = Builder -> LogStr
LogStr (Text -> Builder
TLB.fromText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a b. StringConv a b => a -> b
toS a
t)

-- | Convert message can be converted.
ls :: StringConv a T.Text => a -> LogStr
ls :: a -> LogStr
ls = a -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr

-- | Convert loggable value from any message that has show instance.
showLS :: Show a => a -> LogStr
showLS :: a -> LogStr
showLS = String -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (String -> LogStr) -> (a -> String) -> a -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

-- | Helper function to get id of the thread.
mkThreadId :: ThreadId -> Int
{-# NOINLINE mkThreadId #-}
mkThreadId :: ThreadId -> Int
mkThreadId (ThreadId ThreadId#
tid) = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ThreadId# -> CInt
getThreadId ThreadId#
tid)

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