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
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 ())
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
( 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
}
handler :: Settings -> Prelude.IO Handler
handler :: Settings -> IO Handler
handler Settings
settings = do
let skipLogging :: TracingSpan -> IO Bool
skipLogging TracingSpan
span =
case TracingSpan -> Succeeded
Platform.succeeded TracingSpan
span of
Succeeded
Platform.Succeeded -> do
Float
roll <- (Float, Float) -> IO Float
forall a. Random a => (a, a) -> IO a
Random.randomRIO (Float
0.0, Float
1.0)
Bool -> IO 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 -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure Bool
False
Platform.FailedWith SomeException
_ -> Bool -> IO 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
"",
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
skipLogging :: TracingSpan -> IO 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
data Settings = Settings
{
Settings -> FilePath
logFile :: Prelude.FilePath,
Settings -> Text
appName :: Text,
Settings -> Text
appEnvironment :: Text,
Settings -> Float
fractionOfSuccessRequestsLogged :: Float
}
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