-- |
-- Action that allows to write structured log message.
-- 
module Colog.Json.Action
  ( logToHandle
  , encodeMessage
  ) where

import Colog.Core
import Colog.Json.Internal.Structured
import Control.Exception
import Data.Aeson.Encoding as Aeson
import qualified Data.Aeson.Key as Aeson.Key
import qualified Data.ByteString.Builder as Builder
import Data.Coerce
import Data.Foldable
import qualified Data.List.NonEmpty as NE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import System.IO

-- | Dump logs to the output. On the contrary to the usual co-log functions this one
-- embeds all the functionality inside. However all internals are exposed and in the
-- case if you need any special functionality you can build your own function.
--
-- This function serializes a message to a temporary buffer and dumps buffer contents
-- to the handle as soon as it's filled.  See 'encodeMessage' for encoding details.
--
-- Notes:
--
--   1. In case of exception this function tries to dump information about exception
--      in the handle once. But if another exception arrives while storing info, 
--      function rethorws the second exception.
--
--   2. During log dumping this function captures all exceptions (@SomeException@) including
--      asynchronous ones. So it should be run under a mask.
--
--   3. Running a function under interruptible mask is safe as long no other thread 
--      is using a @Handle@.
--
--   4. This function does not add timestamp to the message. This is done because
--      we can always rely on external tools to add timestamp, whether it would be @ts@
--      or @journald@ or docker-logger.
--      However if timestamp from the program is strictly needed it's possible to add
--      it to the user data.
--
--   5. If user data contains multiple values with the equal keys all the values will
--      be stored. In case if it's unbearable you should remove duplicates when generating
--      a @Message@
--
--   6. While dumping the message to the @Handle@ no lock is obtained, so the user
--      is responsible for running this function in a race free context. It can be done
--      either from a single thread, or using additional locking mechanisms.
--
--   8. This function relies on the line bufferring in order to dump logs promptly. It's
--      up to the user to decide how to setup it but in case of block buffering during
--      low activity logs may be delayed a lot.
--
logToHandle :: Handle -> LogAction IO Message
logToHandle :: Handle -> LogAction IO Message
logToHandle Handle
h = forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction \Message
m ->
  let msg :: Encoding
msg = Message -> Encoding
encodeMessage Message
m
  in forall e a. Exception e => IO a -> IO (Either e a)
try (Handle -> Builder -> IO ()
Builder.hPutBuilder Handle
h forall a b. (a -> b) -> a -> b
$ forall tag. Encoding' tag -> Builder
Aeson.fromEncoding Encoding
msg forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char7 Char
'\n') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
       Left SomeException
e -> do
         Handle -> Builder -> IO ()
Builder.hPutBuilder Handle
h forall a b. (a -> b) -> a -> b
$ forall tag. Encoding' tag -> Builder
Aeson.fromEncoding (Series -> Encoding
Aeson.pairs
            forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
            [ Key -> Encoding -> Series
Aeson.pair Key
"namespace" (forall a. Text -> Encoding' a
Aeson.text Text
"logger")
            , Key -> Encoding -> Series
Aeson.pair Key
"exception" (forall a. String -> Encoding' a
Aeson.string (forall a. Show a => a -> String
show (SomeException
e::SomeException)))
            ])
            forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char7 Char
'\n'
       Right ()
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Efficiently convert a message into JSON encoding.
--
-- Message structure:
-- 
-- @
-- { "namespace": "segment1.segment2"
-- , "severity": "DEBUG"
-- , "thread": 123121
-- , "data":  { ... }
-- , "message": "text message"
-- }
-- @
-- 
-- In case if there are no user attributes "data" key is omitted.
encodeMessage :: Message -> Encoding
{-# INLINE encodeMessage #-}
encodeMessage :: Message -> Encoding
encodeMessage Message{Int
Seq Structured
Severity
LogStr
message :: Message -> LogStr
attributes :: Message -> Seq Structured
thread_id :: Message -> Int
message_severity :: Message -> Severity
message :: LogStr
attributes :: Seq Structured
thread_id :: Int
message_severity :: Severity
..} = Series -> Encoding
Aeson.pairs forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Series]
fields where
  fields :: [Series]
fields =
     [ case Maybe Text
namespace of
         Maybe Text
Nothing -> forall a. Monoid a => a
mempty
         Just Text
xs -> Key -> Encoding -> Series
Aeson.pair Key
"namespace" forall a b. (a -> b) -> a -> b
$ forall a. Text -> Encoding' a
Aeson.lazyText Text
xs
     , Key -> Encoding -> Series
Aeson.pair Key
"severity" forall a b. (a -> b) -> a -> b
$ Severity -> Encoding
encodeSeverity Severity
message_severity
     , Key -> Encoding -> Series
Aeson.pair Key
"thread" forall a b. (a -> b) -> a -> b
$ Int -> Encoding
Aeson.int Int
thread_id
     , case Maybe Series
user_data of
         Maybe Series
Nothing -> forall a. Monoid a => a
mempty
         Just Series
xs -> Key -> Encoding -> Series
Aeson.pair Key
"data" forall a b. (a -> b) -> a -> b
$ Series -> Encoding
Aeson.pairs Series
xs
     , Key -> Encoding -> Series
Aeson.pair Key
"message" forall a b. (a -> b) -> a -> b
$ forall a. Text -> Encoding' a
lazyText forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce Builder -> Text
TLB.toLazyText LogStr
message
     ]
  namespace :: Maybe Text
namespace = Text -> [Text] -> Text
TL.intercalate Text
"."forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
     [ Text -> Text
TL.fromStrict Text
tm
     | Segment Text
tm <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Structured
attributes
     ]
  user_data :: Maybe Series
user_data = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
    [ Key -> Encoding -> Series
pair (Text -> Key
Aeson.Key.fromText Text
key) Encoding
attributeValue
    | Attr Text
key Encoding
attributeValue <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Structured
attributes
    ]