module Reporter.File.Internal where

import qualified Control.Concurrent.Async as Async
import qualified Control.Concurrent.STM as STM
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encoding
import qualified Data.ByteString.Lazy as ByteString
import qualified Data.Foldable
import qualified Environment
import qualified Network.HostName
import qualified Platform
import qualified Platform.ReporterHelpers as Helpers
import qualified Platform.Timer as Timer
import qualified System.IO
import qualified System.Random as Random
import qualified Prelude

-- Log tracing information for a request to a file. Tracing information contains
-- nested spans but will appear flattend in the log. Each tracing span will
-- appear on its own line in the log, ordered by its start date.
--
-- Example usage:
--
-- > settings <- File.decode
-- > handler <- File.handler settings
-- > File.report handler "request-id" span
report :: Handler -> Text -> Platform.TracingSpan -> Prelude.IO ()
report :: Handler -> Text -> TracingSpan -> IO ()
report Handler {TracingSpan -> IO Bool
skipLogging :: Handler -> TracingSpan -> IO Bool
skipLogging :: TracingSpan -> IO Bool
skipLogging, TBQueue [ByteString]
writeQueue :: Handler -> TBQueue [ByteString]
writeQueue :: TBQueue [ByteString]
writeQueue, LogContext
logContext :: Handler -> LogContext
logContext :: LogContext
logContext} Text
requestId TracingSpan
span = do
  Bool
skip <- TracingSpan -> IO Bool
skipLogging TracingSpan
span
  if Bool
skip
    then () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ()
    else
      LogContext -> TracingSpan -> [ByteString] -> [ByteString]
logItemRecursively LogContext
logContext {Text
requestId :: Text
requestId :: Text
requestId} TracingSpan
span []
        [ByteString] -> ([ByteString] -> STM ()) -> STM ()
forall a b. a -> (a -> b) -> b
|> TBQueue [ByteString] -> [ByteString] -> STM ()
forall a. TBQueue a -> a -> STM ()
STM.writeTBQueue TBQueue [ByteString]
writeQueue
        STM () -> (STM () -> STM ()) -> STM ()
forall a b. a -> (a -> b) -> b
|> (STM () -> STM () -> STM ()
forall a. STM a -> STM a -> STM a
`STM.orElse` () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ()) -- Drop the log if the queue is full.
        STM () -> (STM () -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
|> STM () -> IO ()
forall a. STM a -> IO a
STM.atomically

logItemRecursively ::
  LogContext ->
  Platform.TracingSpan ->
  [ByteString.ByteString] ->
  [ByteString.ByteString]
logItemRecursively :: LogContext -> TracingSpan -> [ByteString] -> [ByteString]
logItemRecursively LogContext
logContext TracingSpan
span [ByteString]
acc =
  LogContext -> TracingSpan -> [ByteString] -> [ByteString]
logItemRecursivelyHelper LogContext
logContext TracingSpan
span [ByteString]
acc
    [ByteString] -> ([ByteString] -> [ByteString]) -> [ByteString]
forall a b. a -> (a -> b) -> b
|> [ByteString] -> [ByteString]
forall a. List a -> List a
List.reverse

logItemRecursivelyHelper ::
  LogContext ->
  Platform.TracingSpan ->
  [ByteString.ByteString] ->
  [ByteString.ByteString]
logItemRecursivelyHelper :: LogContext -> TracingSpan -> [ByteString] -> [ByteString]
logItemRecursivelyHelper LogContext
logContext TracingSpan
span [ByteString]
acc =
  (TracingSpan -> [ByteString] -> [ByteString])
-> [ByteString] -> List TracingSpan -> [ByteString]
forall a b. (a -> b -> b) -> b -> List a -> b
List.foldr -- The right-most child is the oldest, so that's where we start
    ( LogContext -> TracingSpan -> [ByteString] -> [ByteString]
logItemRecursivelyHelper
        LogContext
logContext
          { namespace :: [Text]
namespace = TracingSpan -> Text
Platform.name TracingSpan
span Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: LogContext -> [Text]
namespace LogContext
logContext
          }
    )
    (LogContext -> TracingSpan -> ByteString
logItem LogContext
logContext TracingSpan
span ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
acc)
    (TracingSpan -> List TracingSpan
Platform.children TracingSpan
span)

logItem :: LogContext -> Platform.TracingSpan -> ByteString.ByteString
logItem :: LogContext -> TracingSpan -> ByteString
logItem LogContext {Timer
timer :: LogContext -> Timer
timer :: Timer
timer, [Text]
namespace :: [Text]
namespace :: LogContext -> [Text]
namespace, Text
environment :: LogContext -> Text
environment :: Text
environment, Text
requestId :: Text
requestId :: LogContext -> Text
requestId, Text
hostname :: LogContext -> Text
hostname :: Text
hostname} TracingSpan
span =
  Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
(Aeson..=) Text
"name" (TracingSpan -> Text
Platform.name TracingSpan
span)
    Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text -> UTCTime -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
(Aeson..=) Text
"start_utc" (Timer -> MonotonicTime -> UTCTime
Timer.toUTC Timer
timer (TracingSpan -> MonotonicTime
Platform.started TracingSpan
span))
    Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text -> Float -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
(Aeson..=) Text
"duration_ms" (Word64 -> Float
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral (TracingSpan -> Word64
Timer.durationInUs TracingSpan
span) Float -> Float -> Float
/ Float
1000)
    Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
(Aeson..=) Text
"env" Text
environment
    Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text -> [Text] -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
(Aeson..=) Text
"namespace" [Text]
namespace
    Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
(Aeson..=) Text
"request-id" Text
requestId
    Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
(Aeson..=) Text
"hostname" Text
hostname
    Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ ( case TracingSpan -> Maybe (Text, SrcLoc)
Platform.frame TracingSpan
span of
           Maybe (Text, SrcLoc)
Nothing -> Series
forall a. Monoid a => a
Prelude.mempty
           Just (Text
_, SrcLoc
srcLoc) ->
             Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
(Aeson..=) Text
"src" (SrcLoc -> Text
Helpers.srcString SrcLoc
srcLoc)
       )
    Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text -> Float -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
(Aeson..=) Text
"allocated_mb" (Int -> Float
toFloat (TracingSpan -> Int
Platform.allocated TracingSpan
span) Float -> Float -> Float
/ Float
1e6)
    Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text -> Maybe SomeTracingSpanDetails -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
(Aeson..=) Text
"details" (TracingSpan -> Maybe SomeTracingSpanDetails
Platform.details TracingSpan
span)
      Series -> (Series -> Encoding) -> Encoding
forall a b. a -> (a -> b) -> b
|> Series -> Encoding
Aeson.pairs
      Encoding -> (Encoding -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> Encoding -> ByteString
forall a. Encoding' a -> ByteString
Data.Aeson.Encoding.encodingToLazyByteString

data Handler = Handler
  { Handler -> Handle
fileHandle :: System.IO.Handle,
    Handler -> LogContext
logContext :: LogContext,
    Handler -> TracingSpan -> IO Bool
skipLogging :: Platform.TracingSpan -> Prelude.IO Bool,
    Handler -> TBQueue [ByteString]
writeQueue :: STM.TBQueue [ByteString.ByteString],
    Handler -> Async ()
loggingThread :: Async.Async ()
  }

data LogContext = LogContext
  { LogContext -> Timer
timer :: Timer.Timer,
    LogContext -> [Text]
namespace :: [Text],
    LogContext -> Text
environment :: Text,
    LogContext -> Text
requestId :: Text,
    LogContext -> Text
hostname :: Text
  }

-- | Create a 'Handler' for a specified set of 'Settings'. Do this once when
-- your application starts and reuse the 'Handler' you get.
handler :: Settings -> Prelude.IO Handler
handler :: Settings -> IO Handler
handler Settings
settings = do
  let skipLogging :: TracingSpan -> m Bool
skipLogging TracingSpan
span =
        case TracingSpan -> Succeeded
Platform.succeeded TracingSpan
span of
          Succeeded
Platform.Succeeded -> do
            Float
roll <- (Float, Float) -> m Float
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
Random.randomRIO (Float
0.0, Float
1.0)
            Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (Float
roll Float -> Float -> Bool
forall comparable.
Ord comparable =>
comparable -> comparable -> Bool
> Settings -> Float
fractionOfSuccessRequestsLogged Settings
settings)
          Succeeded
Platform.Failed -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure Bool
False
          Platform.FailedWith SomeException
_ -> Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure Bool
False
  Handle
fileHandle <- FilePath -> IOMode -> IO Handle
System.IO.openFile (Settings -> FilePath
logFile Settings
settings) IOMode
System.IO.AppendMode
  Text
hostname <- (FilePath -> Text) -> IO FilePath -> IO Text
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map FilePath -> Text
Text.fromList IO FilePath
Network.HostName.getHostName
  TBQueue [ByteString]
writeQueue <- STM (TBQueue [ByteString]) -> IO (TBQueue [ByteString])
forall a. STM a -> IO a
STM.atomically (Natural -> STM (TBQueue [ByteString])
forall a. Natural -> STM (TBQueue a)
STM.newTBQueue Natural
100)
  Async ()
loggingThread <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (TBQueue [ByteString] -> Handle -> IO ()
logLoop TBQueue [ByteString]
writeQueue Handle
fileHandle)
  Timer
timer <- IO Timer
Timer.mkTimer
  let logContext :: LogContext
logContext =
        LogContext :: Timer -> [Text] -> Text -> Text -> Text -> LogContext
LogContext
          { Timer
timer :: Timer
timer :: Timer
timer,
            Text
hostname :: Text
hostname :: Text
hostname,
            requestId :: Text
requestId = Text
"", -- This changes per request and so is set later.
            namespace :: [Text]
namespace = [Settings -> Text
appName Settings
settings],
            environment :: Text
environment = Settings -> Text
appEnvironment Settings
settings
          }
  Handler -> IO Handler
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
    Handler :: Handle
-> LogContext
-> (TracingSpan -> IO Bool)
-> TBQueue [ByteString]
-> Async ()
-> Handler
Handler
      { Handle
fileHandle :: Handle
fileHandle :: Handle
fileHandle,
        TracingSpan -> IO Bool
forall (m :: * -> *). MonadIO m => TracingSpan -> m Bool
skipLogging :: forall (m :: * -> *). MonadIO m => TracingSpan -> m Bool
skipLogging :: TracingSpan -> IO Bool
skipLogging,
        TBQueue [ByteString]
writeQueue :: TBQueue [ByteString]
writeQueue :: TBQueue [ByteString]
writeQueue,
        Async ()
loggingThread :: Async ()
loggingThread :: Async ()
loggingThread,
        LogContext
logContext :: LogContext
logContext :: LogContext
logContext
      }

logLoop ::
  STM.TBQueue [ByteString.ByteString] ->
  System.IO.Handle ->
  Prelude.IO ()
logLoop :: TBQueue [ByteString] -> Handle -> IO ()
logLoop TBQueue [ByteString]
writeQueue Handle
fileHandle = do
  [ByteString]
lines <- STM [ByteString] -> IO [ByteString]
forall a. STM a -> IO a
STM.atomically (TBQueue [ByteString] -> STM [ByteString]
forall a. TBQueue a -> STM a
STM.readTBQueue TBQueue [ByteString]
writeQueue)
  [ByteString] -> (ByteString -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
Data.Foldable.for_ [ByteString]
lines ((ByteString -> IO ()) -> IO ()) -> (ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
<| \ByteString
line -> do
    Handle -> ByteString -> IO ()
ByteString.hPut Handle
fileHandle ByteString
line
    Handle -> ByteString -> IO ()
ByteString.hPut Handle
fileHandle ByteString
"\n"
  TBQueue [ByteString] -> Handle -> IO ()
logLoop TBQueue [ByteString]
writeQueue Handle
fileHandle

cleanup :: Handler -> Prelude.IO ()
cleanup :: Handler -> IO ()
cleanup Handler {Async ()
loggingThread :: Async ()
loggingThread :: Handler -> Async ()
loggingThread, Handle
fileHandle :: Handle
fileHandle :: Handler -> Handle
fileHandle} = do
  Async () -> IO ()
forall a. Async a -> IO ()
Async.cancel Async ()
loggingThread
  Handle -> IO ()
System.IO.hClose Handle
fileHandle

-- | Configuration settings for this reporter. A value of this type can be read
-- from the environment using the 'decoder' function.
data Settings = Settings
  { -- | The file to log too. On unix systems you can set this to @/dev/stdout@
    -- in order to log to stdout.
    --
    -- [@environment variable@] LOG_FILE
    -- [@default value@] app.log
    Settings -> FilePath
logFile :: Prelude.FilePath,
    -- | The name of this application. This will be attached to all logs.
    --
    -- [@environment variable@] LOG_ROOT_NAMESPACE
    -- [@default value@] your-application-name-here
    Settings -> Text
appName :: Text,
    -- | The environment this application is running in. This will be attached
    -- to all logs.
    --
    -- [@environment variable@] ENVIRONMENT
    -- [@default value@] development
    Settings -> Text
appEnvironment :: Text,
    -- | The fraction of requests that should be logged. Set to 1 if you want to
    -- log everything, and a lower value to save money.
    --
    -- [@environment variable@] FRACTION_OF_SUCCESS_REQUESTS_LOGGED
    -- [@default value@] 1
    Settings -> Float
fractionOfSuccessRequestsLogged :: Float
  }

-- | Read 'Settings' from environment variables. Default variables will be used
-- in case no environment variable is set for an option.
decoder :: Environment.Decoder Settings
decoder :: Decoder Settings
decoder =
  (FilePath -> Text -> Text -> Float -> Settings)
-> Decoder (FilePath -> Text -> Text -> Float -> Settings)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure FilePath -> Text -> Text -> Float -> Settings
Settings
    Decoder (FilePath -> Text -> Text -> Float -> Settings)
-> (Decoder (FilePath -> Text -> Text -> Float -> Settings)
    -> Decoder (Text -> Text -> Float -> Settings))
-> Decoder (Text -> Text -> Float -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder FilePath
-> Decoder (FilePath -> Text -> Text -> Float -> Settings)
-> Decoder (Text -> Text -> Float -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder FilePath
logFileDecoder
    Decoder (Text -> Text -> Float -> Settings)
-> (Decoder (Text -> Text -> Float -> Settings)
    -> Decoder (Text -> Float -> Settings))
-> Decoder (Text -> Float -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder Text
-> Decoder (Text -> Text -> Float -> Settings)
-> Decoder (Text -> Float -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder Text
appNameDecoder
    Decoder (Text -> Float -> Settings)
-> (Decoder (Text -> Float -> Settings)
    -> Decoder (Float -> Settings))
-> Decoder (Float -> Settings)
forall a b. a -> (a -> b) -> b
|> Decoder Text
-> Decoder (Text -> Float -> Settings)
-> Decoder (Float -> Settings)
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder Text
environmentDecoder
    Decoder (Float -> Settings)
-> (Decoder (Float -> Settings) -> Decoder Settings)
-> Decoder Settings
forall a b. a -> (a -> b) -> b
|> Decoder Float -> Decoder (Float -> Settings) -> Decoder Settings
forall (m :: * -> *) a b. Applicative m => m a -> m (a -> b) -> m b
andMap Decoder Float
fractionOfSuccessRequestsLoggedDecoder

logFileDecoder :: Environment.Decoder Prelude.FilePath
logFileDecoder :: Decoder FilePath
logFileDecoder =
  Variable -> Parser FilePath -> Decoder FilePath
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Variable :: Text -> Text -> Text -> Variable
Environment.Variable
      { name :: Text
Environment.name = Text
"LOG_FILE",
        description :: Text
Environment.description = Text
"File to log too.",
        defaultValue :: Text
Environment.defaultValue = Text
"app.log"
      }
    Parser FilePath
Environment.filePath

appNameDecoder :: Environment.Decoder Text
appNameDecoder :: Decoder Text
appNameDecoder =
  Variable -> Parser Text -> Decoder Text
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Variable :: Text -> Text -> Text -> Variable
Environment.Variable
      { name :: Text
Environment.name = Text
"LOG_ROOT_NAMESPACE",
        description :: Text
Environment.description = Text
"Root of the log namespace. This should be the name of the application.",
        defaultValue :: Text
Environment.defaultValue = Text
"your-application-name-here"
      }
    Parser Text
Environment.text

environmentDecoder :: Environment.Decoder Text
environmentDecoder :: Decoder Text
environmentDecoder =
  Variable -> Parser Text -> Decoder Text
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Variable :: Text -> Text -> Text -> Variable
Environment.Variable
      { name :: Text
Environment.name = Text
"ENVIRONMENT",
        description :: Text
Environment.description = Text
"Environment to display in logs.",
        defaultValue :: Text
Environment.defaultValue = Text
"development"
      }
    Parser Text
Environment.text

fractionOfSuccessRequestsLoggedDecoder :: Environment.Decoder Float
fractionOfSuccessRequestsLoggedDecoder :: Decoder Float
fractionOfSuccessRequestsLoggedDecoder =
  Variable -> Parser Float -> Decoder Float
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Variable :: Text -> Text -> Text -> Variable
Environment.Variable
      { name :: Text
Environment.name = Text
"FRACTION_OF_SUCCESS_REQUESTS_LOGGED",
        description :: Text
Environment.description = Text
"The fraction of successful requests logged. Defaults to logging all successful requests.",
        defaultValue :: Text
Environment.defaultValue = Text
"1"
      }
    Parser Float
Environment.float