-- |
-- 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.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 = (Message -> IO ()) -> LogAction IO Message
forall (m :: * -> *) msg. (msg -> m ()) -> LogAction m msg
LogAction \Message
m ->
  let msg :: Encoding
msg = Message -> Encoding
encodeMessage Message
m
  in IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (Handle -> Builder -> IO ()
Builder.hPutBuilder Handle
h (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Encoding -> Builder
forall tag. Encoding' tag -> Builder
Aeson.fromEncoding Encoding
msg Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char7 Char
'\n') IO (Either SomeException ())
-> (Either SomeException () -> IO ()) -> IO ()
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 (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ Encoding -> Builder
forall tag. Encoding' tag -> Builder
Aeson.fromEncoding (Series -> Encoding
Aeson.pairs
            (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat
            [ Text -> Encoding -> Series
Aeson.pair Text
"namespace" (Text -> Encoding
forall a. Text -> Encoding' a
Aeson.text Text
"logger")
            , Text -> Encoding -> Series
Aeson.pair Text
"exception" (String -> Encoding
forall a. String -> Encoding' a
Aeson.string (SomeException -> String
forall a. Show a => a -> String
show (SomeException
e::SomeException)))
            ])
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char7 Char
'\n'
       Right ()
_ -> () -> IO ()
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 (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat [Series]
fields where
  fields :: [Series]
fields =
     [ case Maybe Text
namespace of
         Maybe Text
Nothing -> Series
forall a. Monoid a => a
mempty
         Just Text
xs -> Text -> Encoding -> Series
Aeson.pair Text
"namespace" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ Text -> Encoding
forall a. Text -> Encoding' a
Aeson.lazyText Text
xs
     , Text -> Encoding -> Series
Aeson.pair Text
"severity" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ Severity -> Encoding
encodeSeverity Severity
message_severity
     , Text -> Encoding -> Series
Aeson.pair Text
"thread" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ Int -> Encoding
Aeson.int Int
thread_id
     , case Maybe Series
user_data of
         Maybe Series
Nothing -> Series
forall a. Monoid a => a
mempty
         Just Series
xs -> Text -> Encoding -> Series
Aeson.pair Text
"data" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ Series -> Encoding
Aeson.pairs Series
xs
     , Text -> Encoding -> Series
Aeson.pair Text
"message" (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ Text -> Encoding
forall a. Text -> Encoding' a
lazyText (Text -> Encoding) -> Text -> Encoding
forall a b. (a -> b) -> a -> b
$ (Builder -> Text) -> LogStr -> Text
coerce Builder -> Text
TLB.toLazyText LogStr
message
     ]
  namespace :: Maybe Text
namespace = Text -> [Text] -> Text
TL.intercalate Text
"."([Text] -> Text)
-> (NonEmpty Text -> [Text]) -> NonEmpty Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Text -> [Text]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Text -> Text) -> Maybe (NonEmpty Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
     [ Text -> Text
TL.fromStrict Text
tm
     | Segment Text
tm <- Seq Structured -> [Structured]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Structured
attributes
     ]
  user_data :: Maybe Series
user_data = NonEmpty Series -> Series
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (NonEmpty Series -> Series)
-> Maybe (NonEmpty Series) -> Maybe Series
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Series] -> Maybe (NonEmpty Series)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
    [ Text -> Encoding -> Series
pair Text
key Encoding
attributeValue
    | Attr Text
key Encoding
attributeValue <- Seq Structured -> [Structured]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Structured
attributes
    ]