{-|
Module: OpenTracing.Log

Logs are structured data that occur over the lifetime of a span.
-}

{-# LANGUAGE GADTs              #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RankNTypes         #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData         #-}
{-# LANGUAGE TemplateHaskell    #-}

module OpenTracing.Log
    ( LogRecord(..)
    , logTime
    , logFields

    , LogField(..)
    , logFieldLabel
    , logFieldEncoding
    , logFieldValue

    , LogFieldsFormatter
    , jsonAssoc
    , jsonMap
    )
where

import           Control.Exception
import           Control.Lens            hiding ((.=))
import           Data.Aeson
import qualified Data.Aeson.Encoding     as Encoding
import           Data.ByteString.Builder (Builder)
import           Data.Foldable
import           Data.List.NonEmpty      (NonEmpty)
import           Data.Text               (Text)
import           Data.Time.Clock
import           GHC.Stack
import qualified Data.Map.Strict as Map

-- | A single entry into a `Spans` logs. Occurs at a single time and contains multiple
-- (one or more) entries.
--
-- @since 0.1.0.0
data LogRecord = LogRecord
    { LogRecord -> UTCTime
_logTime   :: UTCTime
    , LogRecord -> NonEmpty LogField
_logFields :: NonEmpty LogField
    } deriving Int -> LogRecord -> ShowS
[LogRecord] -> ShowS
LogRecord -> String
(Int -> LogRecord -> ShowS)
-> (LogRecord -> String)
-> ([LogRecord] -> ShowS)
-> Show LogRecord
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogRecord] -> ShowS
$cshowList :: [LogRecord] -> ShowS
show :: LogRecord -> String
$cshow :: LogRecord -> String
showsPrec :: Int -> LogRecord -> ShowS
$cshowsPrec :: Int -> LogRecord -> ShowS
Show

-- | A piece of data in a `LogRecord`. Conceptually a key:value pair with a few
-- distinguished keys. More info about the distinguished keys in the [OpenTracing spec](https://github.com/opentracing/specification/blob/master/semantic_conventions.md#log-fields-table)
--
-- @since 0.1.0.0
data LogField where
    -- | A generic key:value pair entry into a `LogRecord`
    LogField :: Show      a => Text      -> a -> LogField

    -- | A stable identifier for some notable moment in the lifetime of a Span.
    Event    ::                Text           -> LogField

    -- | A concise, human-readable, one-line message explaining the event.
    Message  ::                Text           -> LogField

    -- | A stack trace in platform-conventional format
    Stack    ::                CallStack      -> LogField

    -- | The type or "kind" of an error (only for event="error" logs).
    ErrKind  ::                Text           -> LogField

    -- | The actual error exception
    ErrObj   :: Exception e => e              -> LogField

deriving instance (Show LogField)

type LogFieldsFormatter = forall t. Foldable t => t LogField -> Builder

-- | A log formatter that encodes each `LogField` as a single JSON object.
--
-- >>> BS.hPutBuilder stdout $ jsonAssoc [Event "e", LogField @Text "key" "value"]
-- [{"event":"\"e\""},{"key":"\"value\""}]
--
-- @since 0.1.0.0
jsonAssoc :: LogFieldsFormatter
jsonAssoc :: t LogField -> Builder
jsonAssoc = Encoding' Value -> Builder
forall tag. Encoding' tag -> Builder
Encoding.fromEncoding (Encoding' Value -> Builder)
-> (t LogField -> Encoding' Value) -> t LogField -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogField -> Encoding' Value) -> [LogField] -> Encoding' Value
forall a. (a -> Encoding' Value) -> [a] -> Encoding' Value
Encoding.list LogField -> Encoding' Value
go ([LogField] -> Encoding' Value)
-> (t LogField -> [LogField]) -> t LogField -> Encoding' Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t LogField -> [LogField]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  where
    go :: LogField -> Encoding' Value
go LogField
lf = Series -> Encoding' Value
Encoding.pairs (Series -> Encoding' Value) -> Series -> Encoding' Value
forall a b. (a -> b) -> a -> b
$
        Text -> Encoding' Value -> Series
Encoding.pair (LogField -> Text
logFieldLabel LogField
lf) (LogField -> Encoding' Value
logFieldEncoding LogField
lf)

-- | A log formatter that encodes each `LogField` as an entry in a shared JSON object
--
-- >>> BS.hPutBuilder stdout $ jsonMap  [Event "e", LogField @Text "key" "value"]
-- {"event":"e","key":"\"value\""}
--
-- @since 0.1.0.0
jsonMap :: LogFieldsFormatter
jsonMap :: t LogField -> Builder
jsonMap
    = Encoding' Value -> Builder
forall tag. Encoding' tag -> Builder
Encoding.fromEncoding
    (Encoding' Value -> Builder)
-> (t LogField -> Encoding' Value) -> t LogField -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Encoding' Text)
-> (Encoding' Value -> Encoding' Value)
-> (forall a.
    (Text -> Encoding' Value -> a -> a)
    -> a -> Map Text (Encoding' Value) -> a)
-> Map Text (Encoding' Value)
-> Encoding' Value
forall k v m.
(k -> Encoding' Text)
-> (v -> Encoding' Value)
-> (forall a. (k -> v -> a -> a) -> a -> m -> a)
-> m
-> Encoding' Value
Encoding.dict Text -> Encoding' Text
forall a. Text -> Encoding' a
Encoding.text Encoding' Value -> Encoding' Value
forall a. a -> a
id forall a.
(Text -> Encoding' Value -> a -> a)
-> a -> Map Text (Encoding' Value) -> a
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey'
    (Map Text (Encoding' Value) -> Encoding' Value)
-> (t LogField -> Map Text (Encoding' Value))
-> t LogField
-> Encoding' Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogField
 -> Map Text (Encoding' Value) -> Map Text (Encoding' Value))
-> Map Text (Encoding' Value)
-> t LogField
-> Map Text (Encoding' Value)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' LogField
-> Map Text (Encoding' Value) -> Map Text (Encoding' Value)
merge Map Text (Encoding' Value)
forall a. Monoid a => a
mempty
  where
    merge :: LogField
-> Map Text (Encoding' Value) -> Map Text (Encoding' Value)
merge LogField
lf = Text
-> Encoding' Value
-> Map Text (Encoding' Value)
-> Map Text (Encoding' Value)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (LogField -> Text
logFieldLabel LogField
lf) (LogField -> Encoding' Value
logFieldEncoding LogField
lf)

-- | Retrieve the label of a log field. Distinguished `LogField`s have predefined keys.
--
-- @since 0.1.0.0
logFieldLabel :: LogField -> Text
logFieldLabel :: LogField -> Text
logFieldLabel (LogField Text
x a
_) = Text
x
logFieldLabel (Event      Text
_) = Text
"event"
logFieldLabel (Message    Text
_) = Text
"message"
logFieldLabel (Stack      CallStack
_) = Text
"stack"
logFieldLabel (ErrKind    Text
_) = Text
"error.kind"
logFieldLabel (ErrObj     e
_) = Text
"error.object"

logFieldEncoding :: LogField -> Encoding
logFieldEncoding :: LogField -> Encoding' Value
logFieldEncoding (LogField Text
_ a
v) = String -> Encoding' Value
forall a. String -> Encoding' a
Encoding.string (String -> Encoding' Value) -> String -> Encoding' Value
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
v
logFieldEncoding (Event      Text
v) = Text -> Encoding' Value
forall a. Text -> Encoding' a
Encoding.text Text
v
logFieldEncoding (Message    Text
v) = Text -> Encoding' Value
forall a. Text -> Encoding' a
Encoding.text Text
v
logFieldEncoding (Stack      CallStack
v) = String -> Encoding' Value
forall a. String -> Encoding' a
Encoding.string (String -> Encoding' Value) -> String -> Encoding' Value
forall a b. (a -> b) -> a -> b
$ CallStack -> String
prettyCallStack CallStack
v
logFieldEncoding (ErrKind    Text
v) = Text -> Encoding' Value
forall a. Text -> Encoding' a
Encoding.text Text
v
logFieldEncoding (ErrObj     e
v) = String -> Encoding' Value
forall a. String -> Encoding' a
Encoding.string (String -> Encoding' Value) -> String -> Encoding' Value
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. Show a => a -> String
show e
v

logFieldValue :: LogField -> Value
logFieldValue :: LogField -> Value
logFieldValue (LogField Text
_ a
v) = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
v
logFieldValue (Event      Text
v) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
v
logFieldValue (Message    Text
v) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
v
logFieldValue (Stack      CallStack
v) = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ CallStack -> String
prettyCallStack CallStack
v
logFieldValue (ErrKind    Text
v) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
v
logFieldValue (ErrObj     e
v) = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. Show a => a -> String
show e
v


makeLenses ''LogRecord