{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE RankNTypes #-}

module Platform.Internal where

import Basics
import Control.Applicative ((<|>))
import qualified Control.AutoUpdate as AutoUpdate
import qualified Control.Concurrent.Async as Async
import qualified Control.Exception.Safe as Exception
import Data.Aeson ((.:), (.:?), (.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encoding as Aeson.Encoding
import qualified Data.IORef as IORef
import qualified Data.Text
import qualified Data.Typeable as Typeable
import qualified GHC.Clock as Clock
import GHC.Generics (Generic)
import qualified GHC.Stack as Stack
import qualified GHC.Word
import Internal.Shortcut (andThen, map)
import qualified Internal.Shortcut as Shortcut
import qualified List
import Maybe (Maybe (..))
import Result (Result (Err, Ok))
import qualified System.Mem
import qualified System.Mem as Mem
import qualified System.Timeout as Timeout
import Text (Text)
import qualified Tuple
import Prelude
  ( Applicative (pure, (<*>)),
    Functor,
    IO,
    Monad ((>>=)),
  )
import qualified Prelude

--
-- TASK
--

-- | Here are some common tasks:
--
-- - @now : Task x Posix@
-- - @query : String -> Task Error ()@
-- - @sleep : Float -> Task x ()@
--
-- In each case we have a Task that will resolve successfully with an a value
-- or unsuccessfully with an x value. So Postgres.query may fail with an Error
-- if the query is invalid. Whereas Time.now never fails so I cannot be more
-- specific than x. No such value will ever exist! Instead it always succeeds
-- with the current POSIX time.
--
-- More generally a task is a /description/ of what you need to do. Like a todo
-- list. Or like a grocery list. Or like GitHub issues. So saying "the task is
-- to tell me the current POSIX time" does not complete the task! You need
-- 'perform' tasks or 'attempt' tasks.
newtype Task x a = Task {Task x a -> LogHandler -> IO (Result x a)
_run :: LogHandler -> IO (Result x a)}
  deriving (a -> Task x b -> Task x a
(a -> b) -> Task x a -> Task x b
(forall a b. (a -> b) -> Task x a -> Task x b)
-> (forall a b. a -> Task x b -> Task x a) -> Functor (Task x)
forall a b. a -> Task x b -> Task x a
forall a b. (a -> b) -> Task x a -> Task x b
forall x a b. a -> Task x b -> Task x a
forall x a b. (a -> b) -> Task x a -> Task x b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Task x b -> Task x a
$c<$ :: forall x a b. a -> Task x b -> Task x a
fmap :: (a -> b) -> Task x a -> Task x b
$cfmap :: forall x a b. (a -> b) -> Task x a -> Task x b
Functor)

instance Applicative (Task a) where
  pure :: a -> Task a a
pure a
a =
    (LogHandler -> IO (Result a a)) -> Task a a
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task (\LogHandler
_ -> Result a a -> IO (Result a a)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure (a -> Result a a
forall error value. value -> Result error value
Ok a
a))

  <*> :: Task a (a -> b) -> Task a a -> Task a b
(<*>) Task a (a -> b)
func Task a a
task =
    (LogHandler -> IO (Result a b)) -> Task a b
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task ((LogHandler -> IO (Result a b)) -> Task a b)
-> (LogHandler -> IO (Result a b)) -> Task a b
forall a b. (a -> b) -> a -> b
<| \LogHandler
key ->
      let onResult :: Result error (t -> value) -> Result error t -> Result error value
onResult Result error (t -> value)
resultFunc Result error t
resultTask =
            case (Result error (t -> value)
resultFunc, Result error t
resultTask) of
              (Ok t -> value
func_, Ok t
task_) ->
                value -> Result error value
forall error value. value -> Result error value
Ok (t -> value
func_ t
task_)
              (Err error
x, Result error t
_) ->
                error -> Result error value
forall error value. error -> Result error value
Err error
x
              (Result error (t -> value)
_, Err error
x) ->
                error -> Result error value
forall error value. error -> Result error value
Err error
x
       in do
            Result a (a -> b)
func_ <- Task a (a -> b) -> LogHandler -> IO (Result a (a -> b))
forall x a. Task x a -> LogHandler -> IO (Result x a)
_run Task a (a -> b)
func LogHandler
key
            Result a a
task_ <- Task a a -> LogHandler -> IO (Result a a)
forall x a. Task x a -> LogHandler -> IO (Result x a)
_run Task a a
task LogHandler
key
            Result a b -> IO (Result a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result a (a -> b) -> Result a a -> Result a b
forall error t value.
Result error (t -> value) -> Result error t -> Result error value
onResult Result a (a -> b)
func_ Result a a
task_)

instance Monad (Task a) where
  Task a a
task >>= :: Task a a -> (a -> Task a b) -> Task a b
>>= a -> Task a b
func =
    (LogHandler -> IO (Result a b)) -> Task a b
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task ((LogHandler -> IO (Result a b)) -> Task a b)
-> (LogHandler -> IO (Result a b)) -> Task a b
forall a b. (a -> b) -> a -> b
<| \LogHandler
key ->
      let onResult :: Result a a -> IO (Result a b)
onResult Result a a
result =
            case Result a a
result of
              Ok a
ok ->
                Task a b -> LogHandler -> IO (Result a b)
forall x a. Task x a -> LogHandler -> IO (Result x a)
_run (a -> Task a b
func a
ok) LogHandler
key
              Err a
err ->
                Result a b -> IO (Result a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Result a b
forall error value. error -> Result error value
Err a
err)
       in Task a a -> LogHandler -> IO (Result a a)
forall x a. Task x a -> LogHandler -> IO (Result x a)
_run Task a a
task LogHandler
key IO (Result a a)
-> (IO (Result a a) -> IO (Result a b)) -> IO (Result a b)
forall a b. a -> (a -> b) -> b
|> (Result a a -> IO (Result a b))
-> IO (Result a a) -> IO (Result a b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
andThen Result a a -> IO (Result a b)
onResult

--
-- SPAN
--

-- | A @TracingSpan@ contains debugging information related to a section of the
-- program. TracingSpans can be nested inside other tracingSpans to form a
-- tree, each tracingSpan representing part of the execution of the program.
-- This format is a typical way to store tracing data. Check out this section
-- of the documentation on the open tracing standard for a good introduction on
-- tracing data and tracingSpans:
--
-- https://github.com/opentracing/specification/blob/master/specification.md#the-opentracing-data-model
--
-- From tracingSpans we can derive many other formats of debugging information:
--
-- - Logs are tracingSpans flattened into a series of events ordered by time. For
--   example, consider the following tracingSpans:
--
-- > do the laundry   11:00-12:15
-- >     wash clothes   11:00-12:00
-- >     hang clothes to dry   12:00-12:15
--
--   we could recover the following logs from this:
--
-- > 11:00 starting do the laundry
-- > 11:00 wash clothes
-- > 12:00 hang clothes to dry
-- > 12:15 finishing do the laundry
--
-- - Metrics are rolling statistics on tracingSpans. For example, we can
--   increment a counter every time we see a particular tracingSpan pass by.
--
-- So whether we're looking for tracing data, logs, or metrics, tracingSpans
-- got us covered.
data TracingSpan = TracingSpan
  { -- | A description of this tracingSpan. This should not contain any
    -- dynamically generated strings to make grouping tracingSpans easy.
    -- Any contextual info should go into 'details'.
    TracingSpan -> Text
name :: Text,
    -- | The time this tracingSpan started.
    TracingSpan -> MonotonicTime
started :: MonotonicTime,
    -- | The time this tracingSpan finished.
    TracingSpan -> MonotonicTime
finished :: MonotonicTime,
    -- | The source code location of this tracingSpan. The first @Text@ is
    -- the name of the function getting called.
    TracingSpan -> Maybe (Text, SrcLoc)
frame :: Maybe (Text, Stack.SrcLoc),
    -- | Unique information for this tracingSpan.
    TracingSpan -> Maybe SomeTracingSpanDetails
details :: Maybe SomeTracingSpanDetails,
    -- | A short blurb describing the details of this span, for use in
    -- tooling for inspecting these spans.
    TracingSpan -> Maybe Text
summary :: Maybe Text,
    -- | Whether this tracingSpan succeeded. If any of the children of this
    -- tracingSpan failed, so will this tracingSpan. This will create a
    -- path to the tracingSpan closest to the failure from the root
    -- tracingSpan.
    TracingSpan -> Succeeded
succeeded :: Succeeded,
    -- | The amount of bytes were allocated on the current thread while this
    -- span was running. This is a proxy for the amount of work done. If
    -- this number is low but the span took a long time to complete this
    -- indicates the thread was blocked for some time, or that work was done
    -- on other threads.
    TracingSpan -> Int
allocated :: Int,
    -- | Any subtracingSpans nested inside this tracingSpan. These are
    -- ordered in reverse chronological order, so most recent tracingSpan
    -- first, because it's cheaper to append new tracingSpans onto the left
    -- of the list.
    TracingSpan -> [TracingSpan]
children :: [TracingSpan]
  }
  deriving (Int -> TracingSpan -> ShowS
[TracingSpan] -> ShowS
TracingSpan -> String
(Int -> TracingSpan -> ShowS)
-> (TracingSpan -> String)
-> ([TracingSpan] -> ShowS)
-> Show TracingSpan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TracingSpan] -> ShowS
$cshowList :: [TracingSpan] -> ShowS
show :: TracingSpan -> String
$cshow :: TracingSpan -> String
showsPrec :: Int -> TracingSpan -> ShowS
$cshowsPrec :: Int -> TracingSpan -> ShowS
Prelude.Show, (forall x. TracingSpan -> Rep TracingSpan x)
-> (forall x. Rep TracingSpan x -> TracingSpan)
-> Generic TracingSpan
forall x. Rep TracingSpan x -> TracingSpan
forall x. TracingSpan -> Rep TracingSpan x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TracingSpan x -> TracingSpan
$cfrom :: forall x. TracingSpan -> Rep TracingSpan x
Generic)

instance Aeson.ToJSON TracingSpan where
  toJSON :: TracingSpan -> Value
toJSON TracingSpan
span =
    [Pair] -> Value
Aeson.object
      [ Text
"name" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Text
name TracingSpan
span,
        Text
"started" Text -> MonotonicTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> MonotonicTime
started TracingSpan
span,
        Text
"finished" Text -> MonotonicTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> MonotonicTime
finished TracingSpan
span,
        Text
"frame" Text -> Maybe SrcLocForEncoding -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((Text, SrcLoc) -> SrcLocForEncoding)
-> Maybe (Text, SrcLoc) -> Maybe SrcLocForEncoding
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (Text, SrcLoc) -> SrcLocForEncoding
SrcLocForEncoding (TracingSpan -> Maybe (Text, SrcLoc)
frame TracingSpan
span),
        Text
"details" Text -> Maybe SomeTracingSpanDetails -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Maybe SomeTracingSpanDetails
details TracingSpan
span,
        Text
"summary" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Maybe Text
summary TracingSpan
span,
        Text
"succeeded" Text -> Succeeded -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Succeeded
succeeded TracingSpan
span,
        Text
"allocated" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Int
allocated TracingSpan
span,
        Text
"children" Text -> [TracingSpan] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> [TracingSpan]
children TracingSpan
span
      ]
  toEncoding :: TracingSpan -> Encoding
toEncoding TracingSpan
span =
    Series -> Encoding
Aeson.pairs
      ( Text
"name" Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Text
name TracingSpan
span
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"started" Text -> MonotonicTime -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> MonotonicTime
started TracingSpan
span
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"finished" Text -> MonotonicTime -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> MonotonicTime
finished TracingSpan
span
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"frame" Text -> Maybe SrcLocForEncoding -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((Text, SrcLoc) -> SrcLocForEncoding)
-> Maybe (Text, SrcLoc) -> Maybe SrcLocForEncoding
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (Text, SrcLoc) -> SrcLocForEncoding
SrcLocForEncoding (TracingSpan -> Maybe (Text, SrcLoc)
frame TracingSpan
span)
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"details" Text -> Maybe SomeTracingSpanDetails -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Maybe SomeTracingSpanDetails
details TracingSpan
span
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"summary" Text -> Maybe Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Maybe Text
summary TracingSpan
span
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"succeeded" Text -> Succeeded -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Succeeded
succeeded TracingSpan
span
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"allocated" Text -> Int -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> Int
allocated TracingSpan
span
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"children" Text -> [TracingSpan] -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= TracingSpan -> [TracingSpan]
children TracingSpan
span
      )

instance Aeson.FromJSON TracingSpan where
  parseJSON :: Value -> Parser TracingSpan
parseJSON =
    String
-> (Object -> Parser TracingSpan) -> Value -> Parser TracingSpan
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject
      String
"TracingSpan"
      ( \Object
object -> do
          Text
name <- Object
object Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"name"
          MonotonicTime
started <- Object
object Object -> Text -> Parser MonotonicTime
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"started"
          MonotonicTime
finished <- Object
object Object -> Text -> Parser MonotonicTime
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"finished"
          Maybe (Text, SrcLoc)
frame <- (Maybe SrcLocForEncoding -> Maybe (Text, SrcLoc))
-> Parser (Maybe SrcLocForEncoding)
-> Parser (Maybe (Text, SrcLoc))
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map ((SrcLocForEncoding -> (Text, SrcLoc))
-> Maybe SrcLocForEncoding -> Maybe (Text, SrcLoc)
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map SrcLocForEncoding -> (Text, SrcLoc)
unSrcLocForEncoding) (Object
object Object -> Text -> Parser (Maybe SrcLocForEncoding)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"frame")
          Maybe SomeTracingSpanDetails
details <- Object
object Object -> Text -> Parser (Maybe SomeTracingSpanDetails)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"details"
          Maybe Text
summary <- Object
object Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"summary"
          Succeeded
succeeded <- Object
object Object -> Text -> Parser Succeeded
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"succeeded"
          Int
allocated <- Object
object Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"allocated"
          [TracingSpan]
children <- Object
object Object -> Text -> Parser [TracingSpan]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"children"
          TracingSpan -> Parser TracingSpan
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
            TracingSpan :: Text
-> MonotonicTime
-> MonotonicTime
-> Maybe (Text, SrcLoc)
-> Maybe SomeTracingSpanDetails
-> Maybe Text
-> Succeeded
-> Int
-> [TracingSpan]
-> TracingSpan
TracingSpan
              { Text
name :: Text
name :: Text
name,
                MonotonicTime
started :: MonotonicTime
started :: MonotonicTime
started,
                MonotonicTime
finished :: MonotonicTime
finished :: MonotonicTime
finished,
                Maybe (Text, SrcLoc)
frame :: Maybe (Text, SrcLoc)
frame :: Maybe (Text, SrcLoc)
frame,
                Maybe SomeTracingSpanDetails
details :: Maybe SomeTracingSpanDetails
details :: Maybe SomeTracingSpanDetails
details,
                Maybe Text
summary :: Maybe Text
summary :: Maybe Text
summary,
                Succeeded
succeeded :: Succeeded
succeeded :: Succeeded
succeeded,
                Int
allocated :: Int
allocated :: Int
allocated,
                [TracingSpan]
children :: [TracingSpan]
children :: [TracingSpan]
children
              }
      )

newtype SrcLocForEncoding = SrcLocForEncoding {SrcLocForEncoding -> (Text, SrcLoc)
unSrcLocForEncoding :: (Text, Stack.SrcLoc)}

instance Aeson.ToJSON SrcLocForEncoding where
  toJSON :: SrcLocForEncoding -> Value
toJSON (SrcLocForEncoding (Text
name, SrcLoc
loc)) =
    [Pair] -> Value
Aeson.object
      [ Text
"name" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
name,
        Text
"package" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> String
Stack.srcLocPackage SrcLoc
loc,
        Text
"module" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> String
Stack.srcLocModule SrcLoc
loc,
        Text
"file" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> String
Stack.srcLocFile SrcLoc
loc,
        Text
"startLine" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocStartLine SrcLoc
loc,
        Text
"startCol" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocStartCol SrcLoc
loc,
        Text
"endLine" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocEndLine SrcLoc
loc,
        Text
"endCol" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocEndCol SrcLoc
loc
      ]
  toEncoding :: SrcLocForEncoding -> Encoding
toEncoding (SrcLocForEncoding (Text
name, SrcLoc
loc)) =
    Series -> Encoding
Aeson.pairs
      ( Text
"name" Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
name
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"package" Text -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> String
Stack.srcLocPackage SrcLoc
loc
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"module" Text -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> String
Stack.srcLocModule SrcLoc
loc
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"file" Text -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> String
Stack.srcLocFile SrcLoc
loc
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"startLine" Text -> Int -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocStartLine SrcLoc
loc
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"startCol" Text -> Int -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocStartCol SrcLoc
loc
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"endLine" Text -> Int -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocEndLine SrcLoc
loc
          Series -> Series -> Series
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"endCol" Text -> Int -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= SrcLoc -> Int
Stack.srcLocEndCol SrcLoc
loc
      )

instance Aeson.FromJSON SrcLocForEncoding where
  parseJSON :: Value -> Parser SrcLocForEncoding
parseJSON =
    String
-> (Object -> Parser SrcLocForEncoding)
-> Value
-> Parser SrcLocForEncoding
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject
      String
"SrcLocForEncoding"
      ( \Object
object -> do
          Text
name <- Object
object Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"name"
          String
srcLocPackage <- Object
object Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"package"
          String
srcLocModule <- Object
object Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"module"
          String
srcLocFile <- Object
object Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"file"
          Int
srcLocStartLine <- Object
object Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"startLine"
          Int
srcLocStartCol <- Object
object Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"startCol"
          Int
srcLocEndLine <- Object
object Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"endLine"
          Int
srcLocEndCol <- Object
object Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"endCol"
          SrcLocForEncoding -> Parser SrcLocForEncoding
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
            ( (Text, SrcLoc) -> SrcLocForEncoding
SrcLocForEncoding
                ( Text
name,
                  SrcLoc :: String -> String -> String -> Int -> Int -> Int -> Int -> SrcLoc
Stack.SrcLoc
                    { String
srcLocPackage :: String
srcLocPackage :: String
Stack.srcLocPackage,
                      String
srcLocModule :: String
srcLocModule :: String
Stack.srcLocModule,
                      String
srcLocFile :: String
srcLocFile :: String
Stack.srcLocFile,
                      Int
srcLocStartLine :: Int
srcLocStartLine :: Int
Stack.srcLocStartLine,
                      Int
srcLocStartCol :: Int
srcLocStartCol :: Int
Stack.srcLocStartCol,
                      Int
srcLocEndLine :: Int
srcLocEndLine :: Int
Stack.srcLocEndLine,
                      Int
srcLocEndCol :: Int
srcLocEndCol :: Int
Stack.srcLocEndCol
                    }
                )
            )
      )

-- | A tracing span containing default empty values for all fields. Usually we
-- don't need this because TracingSpans get created for us when we evaluate
-- tasks. This can be useful when testing reporting code to see if it produces
-- the right outputs given a specific tracing span as input.
emptyTracingSpan :: TracingSpan
emptyTracingSpan :: TracingSpan
emptyTracingSpan =
  TracingSpan :: Text
-> MonotonicTime
-> MonotonicTime
-> Maybe (Text, SrcLoc)
-> Maybe SomeTracingSpanDetails
-> Maybe Text
-> Succeeded
-> Int
-> [TracingSpan]
-> TracingSpan
TracingSpan
    { name :: Text
name = Text
"",
      started :: MonotonicTime
started = MonotonicTime
0,
      finished :: MonotonicTime
finished = MonotonicTime
0,
      frame :: Maybe (Text, SrcLoc)
frame = Maybe (Text, SrcLoc)
forall a. Maybe a
Nothing,
      details :: Maybe SomeTracingSpanDetails
details = Maybe SomeTracingSpanDetails
forall a. Maybe a
Nothing,
      summary :: Maybe Text
summary = Maybe Text
forall a. Maybe a
Nothing,
      succeeded :: Succeeded
succeeded = Succeeded
Succeeded,
      allocated :: Int
allocated = Int
0,
      children :: [TracingSpan]
children = []
    }

-- | The @Succeeded@ type is used to indicate whether or not a particular
-- @TracingSpan@ ran without encountering user-facing problems.
data Succeeded
  = -- | A tracingSpan that didn't fail with an unexpected exception, or was
    -- explicitly marked as failed by the user.
    --
    -- When a tracingSpan returns a failed task we do not count that as @Failed@
    -- here, because a failed task might be part of normal program
    -- operation. We wouldn't want to log those kinds of failures as errors.
    Succeeded
  | -- | A tracingSpan marked as failed by a user, for example by logging with a
    -- high severity to indicate a user is in pain.
    Failed
  | -- | A tracingSpan that failed with an unhandled exception thrown by the
    -- Haskell runtime or a library.
    FailedWith Exception.SomeException
  deriving (Int -> Succeeded -> ShowS
[Succeeded] -> ShowS
Succeeded -> String
(Int -> Succeeded -> ShowS)
-> (Succeeded -> String)
-> ([Succeeded] -> ShowS)
-> Show Succeeded
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Succeeded] -> ShowS
$cshowList :: [Succeeded] -> ShowS
show :: Succeeded -> String
$cshow :: Succeeded -> String
showsPrec :: Int -> Succeeded -> ShowS
$cshowsPrec :: Int -> Succeeded -> ShowS
Prelude.Show)

instance Aeson.ToJSON Succeeded where
  toJSON :: Succeeded -> Value
toJSON Succeeded
Succeeded = Text -> Value
Aeson.String Text
"Succeeded"
  toJSON Succeeded
Failed = Text -> Value
Aeson.String Text
"Failed"
  toJSON (FailedWith SomeException
exception) =
    SomeException -> String
forall e. Exception e => e -> String
Exception.displayException SomeException
exception
      String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> String -> Text
Data.Text.pack
      Text -> (Text -> Value) -> Value
forall a b. a -> (a -> b) -> b
|> Text -> Value
Aeson.String
  toEncoding :: Succeeded -> Encoding
toEncoding Succeeded
Succeeded = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.Encoding.text Text
"Succeeded"
  toEncoding Succeeded
Failed = Text -> Encoding
forall a. Text -> Encoding' a
Aeson.Encoding.text Text
"Failed"
  toEncoding (FailedWith SomeException
exception) =
    SomeException -> String
forall e. Exception e => e -> String
Exception.displayException SomeException
exception
      String -> (String -> Encoding) -> Encoding
forall a b. a -> (a -> b) -> b
|> String -> Encoding
forall a. String -> Encoding' a
Aeson.Encoding.string

instance Aeson.FromJSON Succeeded where
  parseJSON :: Value -> Parser Succeeded
parseJSON =
    String -> (Text -> Parser Succeeded) -> Value -> Parser Succeeded
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText
      String
"Succeeded"
      ( \Text
text ->
          case Text
text of
            Text
"Succeeded" -> Succeeded -> Parser Succeeded
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure Succeeded
Succeeded
            Text
"Failed" -> Succeeded -> Parser Succeeded
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure Succeeded
Failed
            Text
_ ->
              Text -> ParsedException
ParsedException Text
text
                ParsedException
-> (ParsedException -> SomeException) -> SomeException
forall a b. a -> (a -> b) -> b
|> ParsedException -> SomeException
forall e. Exception e => e -> SomeException
Exception.toException
                SomeException -> (SomeException -> Succeeded) -> Succeeded
forall a b. a -> (a -> b) -> b
|> SomeException -> Succeeded
FailedWith
                Succeeded -> (Succeeded -> Parser Succeeded) -> Parser Succeeded
forall a b. a -> (a -> b) -> b
|> Succeeded -> Parser Succeeded
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
      )

-- Helper type for when we're decoding a TracingSpan. SomeException doesn't have
-- aeson instances for encoding or decoding. For encoding a SomeException we can
-- make something up, but we can never decode it back into the original
-- exception type. Hence this ParsedException for decoding into instead.
newtype ParsedException = ParsedException Text
  deriving ([ParsedException] -> Encoding
[ParsedException] -> Value
ParsedException -> Encoding
ParsedException -> Value
(ParsedException -> Value)
-> (ParsedException -> Encoding)
-> ([ParsedException] -> Value)
-> ([ParsedException] -> Encoding)
-> ToJSON ParsedException
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ParsedException] -> Encoding
$ctoEncodingList :: [ParsedException] -> Encoding
toJSONList :: [ParsedException] -> Value
$ctoJSONList :: [ParsedException] -> Value
toEncoding :: ParsedException -> Encoding
$ctoEncoding :: ParsedException -> Encoding
toJSON :: ParsedException -> Value
$ctoJSON :: ParsedException -> Value
Aeson.ToJSON)

instance Prelude.Show ParsedException where
  show :: ParsedException -> String
show (ParsedException Text
text) = Text -> String
Data.Text.unpack Text
text

instance Exception.Exception ParsedException

-- | If the first bit of code succeeded and the second failed, the combination
-- of the two has failed as well. The @SemiGroup@ and @Monoid@ type instances
-- for @Succeeded@ allow us to combine @Succeeded@ values in such a fashion.
--
-- The rule expressed here is that the Succeeded value of a combination of
-- computations if the same as the worst thing that happened to any of the
-- individual computations.
instance Prelude.Semigroup Succeeded where
  FailedWith SomeException
err <> :: Succeeded -> Succeeded -> Succeeded
<> Succeeded
_ = SomeException -> Succeeded
FailedWith SomeException
err
  Succeeded
_ <> FailedWith SomeException
err = SomeException -> Succeeded
FailedWith SomeException
err
  Succeeded
Failed <> Succeeded
_ = Succeeded
Failed
  Succeeded
_ <> Succeeded
Failed = Succeeded
Failed
  Succeeded
_ <> Succeeded
_ = Succeeded
Succeeded

instance Prelude.Monoid Succeeded where
  mempty :: Succeeded
mempty = Succeeded
Succeeded

--
-- SPAN DETAILS
--

-- | A wrapper around the various types that specify details for different kinds
-- of tracingSpans.
--
-- Depending on what happens within a tracingSpan we want to log different
-- information for debugging. A tracingSpan for a database query might include
-- the SQL of the query, and a tracingSpan for an HTTP request the URL the
-- request is addressed to.
--
-- We could define a single @SomeTracingSpanDetails@ type that can represent all
-- of these different types of details. One way would be to write a union:
--
-- > data SomeTracingSpanDetails
-- >   = Sql SqlDetails
-- >   | Http HttpDetails
-- >   | ...
--
-- The disadvantage of this is that nri-prelude will have to know about every
-- possible type of tracingSpan. If a library wanted to log new information it
-- would have to change @nri-prelude@ first to support this. That's a barrier to
-- adding useful logging information we'd prefer not to have.
--
-- Another approach is to have the details field take arbitrary JSON:
--
-- > type SomeTracingSpanDetails = Data.Aeson.Value
--
-- This allows any library to log what it wants without requiring any changes in
-- nri-prelude. However, unless we parse that JSON back into the original types
-- (which is wasteful and can fail) we have lost the ability to render specific
-- bits of information in special ways. If we provide Bugsnag with the stack
-- trace of an error it will present it nicely in its UI. NewRelic can treat SQL
-- strings of queries in a special way. But we don't have stack traces or SQL
-- strings to give, just opaque JSON blobs.
--
-- We'd like to both let libraries define custom detail types _and_ be able to
-- read specific fields from those types in loggers that present certain bits of
-- information in nice ways. To do that we allow a bit of type magic here.
-- Analogous to Haskell's @SomeException@ type and @Exception@ type class, we
-- define a @SomeTracingSpanDetails@ type and @TracingSpanDetails@ type class.
--
-- The SomeTracingSpanDetails type can wrap any custom type, as long as it has
-- @TracingSpanDetails@ instance. The @TracingSpanDetails@ instance allows us
-- to recover the original details type if we want to treat it special in a
-- custom logger.
data SomeTracingSpanDetails where
  SomeTracingSpanDetails :: (TracingSpanDetails a) => a -> SomeTracingSpanDetails

instance Aeson.ToJSON SomeTracingSpanDetails where
  toJSON :: SomeTracingSpanDetails -> Value
toJSON (SomeTracingSpanDetails a
details) = a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON a
details

  toEncoding :: SomeTracingSpanDetails -> Encoding
toEncoding (SomeTracingSpanDetails a
details) = a -> Encoding
forall a. ToJSON a => a -> Encoding
Aeson.toEncoding a
details

instance Aeson.FromJSON SomeTracingSpanDetails where
  parseJSON :: Value -> Parser SomeTracingSpanDetails
parseJSON Value
x =
    Value -> Parser Value
forall a. FromJSON a => Value -> Parser a
Aeson.parseJSON Value
x
      Parser Value
-> (Parser Value -> Parser SomeTracingSpanDetails)
-> Parser SomeTracingSpanDetails
forall a b. a -> (a -> b) -> b
|> (Value -> SomeTracingSpanDetails)
-> Parser Value -> Parser SomeTracingSpanDetails
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.fmap
        (ParsedTracingSpandetails -> SomeTracingSpanDetails
forall e. TracingSpanDetails e => e -> SomeTracingSpanDetails
toTracingSpanDetails (ParsedTracingSpandetails -> SomeTracingSpanDetails)
-> (Value -> ParsedTracingSpandetails)
-> Value
-> SomeTracingSpanDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< Value -> ParsedTracingSpandetails
ParsedTracingSpandetails)

instance TracingSpanDetails SomeTracingSpanDetails where
  toTracingSpanDetails :: SomeTracingSpanDetails -> SomeTracingSpanDetails
toTracingSpanDetails SomeTracingSpanDetails
details = SomeTracingSpanDetails
details

  fromTracingSpanDetails :: SomeTracingSpanDetails -> Maybe SomeTracingSpanDetails
fromTracingSpanDetails = SomeTracingSpanDetails -> Maybe SomeTracingSpanDetails
forall a. a -> Maybe a
Just

instance Prelude.Show SomeTracingSpanDetails where
  show :: SomeTracingSpanDetails -> String
show (SomeTracingSpanDetails a
details) =
    a -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode a
details
      ByteString -> (ByteString -> String) -> String
forall a b. a -> (a -> b) -> b
|> ByteString -> String
forall a. Show a => a -> String
Prelude.show

-- | A container for tracing span details if we parsed them back from JSON.
-- We don't require users of this library to define FromJSON instances of their
-- own tracing span details because it's not necessary for logging, but to
-- support tooling reading data structures produced by this lib we'd still like
-- to be able to parse tracing spans from JSON. This helper type allows us to do
-- so.
newtype ParsedTracingSpandetails = ParsedTracingSpandetails Aeson.Value
  deriving ([ParsedTracingSpandetails] -> Encoding
[ParsedTracingSpandetails] -> Value
ParsedTracingSpandetails -> Encoding
ParsedTracingSpandetails -> Value
(ParsedTracingSpandetails -> Value)
-> (ParsedTracingSpandetails -> Encoding)
-> ([ParsedTracingSpandetails] -> Value)
-> ([ParsedTracingSpandetails] -> Encoding)
-> ToJSON ParsedTracingSpandetails
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ParsedTracingSpandetails] -> Encoding
$ctoEncodingList :: [ParsedTracingSpandetails] -> Encoding
toJSONList :: [ParsedTracingSpandetails] -> Value
$ctoJSONList :: [ParsedTracingSpandetails] -> Value
toEncoding :: ParsedTracingSpandetails -> Encoding
$ctoEncoding :: ParsedTracingSpandetails -> Encoding
toJSON :: ParsedTracingSpandetails -> Value
$ctoJSON :: ParsedTracingSpandetails -> Value
Aeson.ToJSON)

instance TracingSpanDetails ParsedTracingSpandetails

-- | Every type we want to use as tracingSpan metadata needs a
-- @TracingSpanDetails@ instance.  The @TracingSpanDetails@ class fulfills
-- these roles:
--
-- - It allows for conversion between the custom details type and the
--   @SomeTracingSpanDetails@ type stored in a @TracingSpan@.
-- - It requires the custom details type to also have a @ToJSON@ instance.
--
-- This gives a logger two options for rendering a @SomeTracingSpanDetails@
-- value into a format understood by a monitoring tool:
--
-- - It can try @fromTracingSpanDetails@ to try to recover one of the custom
--   tracingSpan details types it has implemented custom rendering logic for.
-- - If this particular tracingSpan details type is unknown to this particular
--   logger, it can obtain always obtain a generic JSON blob of the information
--   instead.
class (Typeable.Typeable e, Aeson.ToJSON e) => TracingSpanDetails e where
  toTracingSpanDetails :: e -> SomeTracingSpanDetails
  toTracingSpanDetails = e -> SomeTracingSpanDetails
forall e. TracingSpanDetails e => e -> SomeTracingSpanDetails
SomeTracingSpanDetails

  fromTracingSpanDetails :: SomeTracingSpanDetails -> Maybe e
  fromTracingSpanDetails (SomeTracingSpanDetails a
d) = a -> Maybe e
forall a b. (Typeable a, Typeable b) => a -> Maybe b
Typeable.cast a
d

-- | A helper type used for @renderTracingSpanDetails@. Used to wrap rendering
-- functions so they have the same type and can be put in a list together.
data Renderer a where
  Renderer :: TracingSpanDetails s => (s -> a) -> Renderer a

-- | In reporting logic we'd like to case on the different types a
-- 'SomeTracingSpanDetails' can contain and write logic for each one. This
-- helper allows us to do so.
--
-- > newtype ImportantFact = ImportantFact Text
-- > instance ToJSON ImportantFact
-- > instance SpanDetails ImportantFact
-- >
-- > newtype KeyStatistic = KeyStatistic Int
-- > instance ToJSON KeyStatistic
-- > instance SpanDetails KeyStatistic
-- >
-- > toTracingSpanDetails (ImportantFact "Koala's are adorable")
-- >   |> renderTracingSpanDetails
-- >        [ Renderer (\ImportantFact fact -> fact)
-- >        , Renderer (\KeyStatistic stat -> Text.fromInt stat)
-- >        ]
-- >   |> Maybe.withDefault (\details -> show (Data.Aeson.encode details))
--
-- Remember that @SomeTracingSpanDetails@ are always JSON-serializable, so you
-- can use that if you need to render a span of a type you didn't prepare for.
renderTracingSpanDetails :: [Renderer a] -> SomeTracingSpanDetails -> Maybe a
renderTracingSpanDetails :: [Renderer a] -> SomeTracingSpanDetails -> Maybe a
renderTracingSpanDetails [Renderer a]
rs SomeTracingSpanDetails
s =
  case [Renderer a]
rs of
    [] -> Maybe a
forall a. Maybe a
Nothing
    (Renderer s -> a
r) : [Renderer a]
rest -> (s -> a) -> Maybe s -> Maybe a
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
Shortcut.map s -> a
r (SomeTracingSpanDetails -> Maybe s
forall e. TracingSpanDetails e => SomeTracingSpanDetails -> Maybe e
fromTracingSpanDetails SomeTracingSpanDetails
s) Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Renderer a] -> SomeTracingSpanDetails -> Maybe a
forall a. [Renderer a] -> SomeTracingSpanDetails -> Maybe a
renderTracingSpanDetails [Renderer a]
rest SomeTracingSpanDetails
s

--
-- HANDLER
--

-- | Our @Task@ type secretly passed a value of this type throughout our
-- application. Anywhere in our application we can add context to the log
-- handler. For example we might wrap our database queries in a tracingSpan
-- called "query" and add some bits of context, such as the SQL operation the
-- query is performing. These bits of metadata will then be used as much as
-- possible in logging messages, tracing, and error reporting.
--
-- Note that we do not report recorded information anywhere (log it to file, or
-- to an observability platform), until we completely finish a request. This
-- gives us the option _not_ to report on a particular request. We might use
-- this to report only on a subset of the succeeding requests, to save us money
-- without loosing important signal. We'll only know whether a request succeeds
-- after it completes though, so we have to hold off on any reporting for a
-- request until it's done.
data LogHandler = LogHandler
  { -- | We're making the assumption that every task we run is ran because
    -- of some sort of request, and that this request has a unique
    -- identifier.  We take this identifier from the incoming request and
    -- pass it on when we call external services. If something goes wrong
    -- we'll be able to collect all information related to a single request
    -- from all the components in our architecture that did work for it.
    LogHandler -> Text
requestId :: Text,
    -- | Every tracingSpan gets its own handler. That way if we record
    -- debugging information using a handler we'll know which tracingSpan
    -- the information belongs to. This function creates a new handler for
    -- a child tracingSpan of the current handler.
    LogHandler -> HasCallStack => Text -> IO LogHandler
startChildTracingSpan :: Stack.HasCallStack => Text -> IO LogHandler,
    -- | There's common fields all tracingSpans have such as a name and
    -- start and finish times. On top of that each tracingSpan can define a
    -- custom type containing useful custom data. This function allows us
    -- to set this custom data for the current tracingSpan. We could design
    -- it so this data is passed in as an extra argument when we create the
    -- tracingSpan, but then we'd miss out on useful details that only
    -- become known as the tracingSpan runs, for example the response code
    -- of an HTTP request.
    LogHandler -> forall d. TracingSpanDetails d => d -> IO ()
setTracingSpanDetailsIO :: forall d. TracingSpanDetails d => d -> IO (),
    -- | Set a summary for the current tracingSpan. This is shown in tools
    -- used to inspect spans as a stand-in for the full tracingSpan details
    -- in places where we only have room to show a little text.
    LogHandler -> Text -> IO ()
setTracingSpanSummaryIO :: Text -> IO (),
    -- | Mark the current tracingSpan as failed. Some reporting backends
    -- will use this to decide whether a particular request is worth
    -- reporting on.
    LogHandler -> IO ()
markTracingSpanFailedIO :: IO (),
    -- | Mark the current tracingSpan as finished, which will set the
    -- @finished@ timestamp. What this function does depends on the
    -- tracingSpan. Once we're done collecting data for the root
    -- tracingSpan we'll want to pass the tracingSpan "out", to some code
    -- that will report the debugging data to whatever observability
    -- platform(s) are used. Once we're done collecting data for child
    -- tracingSpans we'll want to add the "completed" child tracingSpan to
    -- its parent.
    LogHandler -> Maybe SomeException -> IO ()
finishTracingSpan :: Maybe Exception.SomeException -> IO ()
  }

-- | Helper that creates one of the handler's above. This is intended for
-- internal use in this library only and not for exposing. Outside of this
-- library the @rootTracingSpanIO@ is the more user-friendly way to get hands
-- on a @LogHandler@.
mkHandler ::
  Stack.HasCallStack =>
  Text ->
  Clock ->
  (TracingSpan -> IO ()) ->
  Text ->
  IO LogHandler
mkHandler :: Text -> Clock -> (TracingSpan -> IO ()) -> Text -> IO LogHandler
mkHandler Text
requestId Clock
clock TracingSpan -> IO ()
onFinish Text
name' = do
  IORef TracingSpan
tracingSpanRef <-
    (HasCallStack => Clock -> Text -> IO TracingSpan)
-> Clock -> Text -> IO TracingSpan
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack => Clock -> Text -> IO TracingSpan
startTracingSpan Clock
clock Text
name'
      IO TracingSpan
-> (IO TracingSpan -> IO (IORef TracingSpan))
-> IO (IORef TracingSpan)
forall a b. a -> (a -> b) -> b
|> (TracingSpan -> IO (IORef TracingSpan))
-> IO TracingSpan -> IO (IORef TracingSpan)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
andThen TracingSpan -> IO (IORef TracingSpan)
forall a. a -> IO (IORef a)
IORef.newIORef
  Int
allocationCounterStartVal <- IO Int
System.Mem.getAllocationCounter
  LogHandler -> IO LogHandler
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    LogHandler :: Text
-> (HasCallStack => Text -> IO LogHandler)
-> (forall d. TracingSpanDetails d => d -> IO ())
-> (Text -> IO ())
-> IO ()
-> (Maybe SomeException -> IO ())
-> LogHandler
LogHandler
      { Text
requestId :: Text
requestId :: Text
requestId,
        startChildTracingSpan :: HasCallStack => Text -> IO LogHandler
startChildTracingSpan = HasCallStack =>
Text -> Clock -> (TracingSpan -> IO ()) -> Text -> IO LogHandler
Text -> Clock -> (TracingSpan -> IO ()) -> Text -> IO LogHandler
mkHandler Text
requestId Clock
clock (IORef TracingSpan -> TracingSpan -> IO ()
appendTracingSpanToParent IORef TracingSpan
tracingSpanRef),
        setTracingSpanDetailsIO :: forall d. TracingSpanDetails d => d -> IO ()
setTracingSpanDetailsIO = \d
details' ->
          IORef TracingSpan -> (TracingSpan -> TracingSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
updateIORef
            IORef TracingSpan
tracingSpanRef
            (\TracingSpan
tracingSpan' -> TracingSpan
tracingSpan' {details :: Maybe SomeTracingSpanDetails
details = SomeTracingSpanDetails -> Maybe SomeTracingSpanDetails
forall a. a -> Maybe a
Just (d -> SomeTracingSpanDetails
forall e. TracingSpanDetails e => e -> SomeTracingSpanDetails
toTracingSpanDetails d
details')}),
        setTracingSpanSummaryIO :: Text -> IO ()
setTracingSpanSummaryIO = \Text
text ->
          IORef TracingSpan -> (TracingSpan -> TracingSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
updateIORef
            IORef TracingSpan
tracingSpanRef
            (\TracingSpan
tracingSpan' -> TracingSpan
tracingSpan' {summary :: Maybe Text
summary = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
text}),
        markTracingSpanFailedIO :: IO ()
markTracingSpanFailedIO =
          IORef TracingSpan -> (TracingSpan -> TracingSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
updateIORef
            IORef TracingSpan
tracingSpanRef
            (\TracingSpan
tracingSpan' -> TracingSpan
tracingSpan' {succeeded :: Succeeded
succeeded = TracingSpan -> Succeeded
succeeded TracingSpan
tracingSpan' Succeeded -> Succeeded -> Succeeded
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Succeeded
Failed}),
        finishTracingSpan :: Maybe SomeException -> IO ()
finishTracingSpan = Clock
-> Int
-> IORef TracingSpan
-> Maybe SomeException
-> IO TracingSpan
finalizeTracingSpan Clock
clock Int
allocationCounterStartVal IORef TracingSpan
tracingSpanRef (Maybe SomeException -> IO TracingSpan)
-> (IO TracingSpan -> IO ()) -> Maybe SomeException -> IO ()
forall a b c. (a -> b) -> (b -> c) -> a -> c
>> (TracingSpan -> IO ()) -> IO TracingSpan -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
andThen TracingSpan -> IO ()
onFinish
      }

-- | Set the details for a tracingSpan created using the @tracingSpan@
-- function. Like @tracingSpan@ this is intended for use in writing libraries
-- that define custom types of effects, such as database queries or http
-- requests.
--
-- It's often a good idea to use this together with @Platform.finally@ or
-- @Platform.bracketWithError@, to ensure we record tracingSpan details even in
-- the event of an exception cutting the execution of our tracingSpan short.
--
-- > tracingSpan "holiday" do
-- >   let bookPick = BookPick "The Stone Sky"
-- >   Platform.finally
-- >     (readBook bookPick)
-- >     (setTracingSpanDetails bookPick)
-- >
-- > newtype BookPick = BookPick Text
-- >   deriving (Aeson.ToJSON)
-- >
-- > instance TracingSpanDetails BookPick
setTracingSpanDetails :: TracingSpanDetails d => d -> Task e ()
setTracingSpanDetails :: d -> Task e ()
setTracingSpanDetails d
details =
  (LogHandler -> IO (Result e ())) -> Task e ()
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task
    ( \LogHandler
handler ->
        LogHandler -> d -> IO ()
LogHandler -> forall d. TracingSpanDetails d => d -> IO ()
setTracingSpanDetailsIO LogHandler
handler d
details
          IO () -> (IO () -> IO (Result e ())) -> IO (Result e ())
forall a b. a -> (a -> b) -> b
|> (() -> Result e ()) -> IO () -> IO (Result e ())
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map () -> Result e ()
forall error value. value -> Result error value
Ok
    )

-- | Set a summary for the tracingSpan created with the @tracingSpan@ function.
-- Like @tracingSpan@ this is intended for use in writing libraries that define
-- custom types of effects, such as database queries or http requests.
--
-- The summary is shown in tools used to inspect spans as a stand-in for the
-- full tracingSpan details in places where we only have room to show a little
-- text.
setTracingSpanSummary :: Text -> Task e ()
setTracingSpanSummary :: Text -> Task e ()
setTracingSpanSummary Text
text =
  (LogHandler -> IO (Result e ())) -> Task e ()
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task
    ( \LogHandler
handler ->
        LogHandler -> Text -> IO ()
setTracingSpanSummaryIO LogHandler
handler Text
text
          IO () -> (IO () -> IO (Result e ())) -> IO (Result e ())
forall a b. a -> (a -> b) -> b
|> (() -> Result e ()) -> IO () -> IO (Result e ())
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map () -> Result e ()
forall error value. value -> Result error value
Ok
    )

-- | Mark a tracingSpan created with the @tracingSpan@ function as failed. Like
-- @tracingSpan@ this is intended for use in writing libraries that define
-- custom types of effects, such as database queries or http requests.
--
-- > tracingSpan "holiday" do
-- >   Platform.finally
-- >     (readBook bookPick)
-- >     (setTracingSpanSummary "The Stone Sky")
markTracingSpanFailed :: Task e ()
markTracingSpanFailed :: Task e ()
markTracingSpanFailed =
  (LogHandler -> IO (Result e ())) -> Task e ()
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task ((() -> Result e ()) -> IO () -> IO (Result e ())
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map () -> Result e ()
forall error value. value -> Result error value
Ok (IO () -> IO (Result e ()))
-> (LogHandler -> IO ()) -> LogHandler -> IO (Result e ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< LogHandler -> IO ()
markTracingSpanFailedIO)

-- | Create an initial @TracingSpan@ with some initial values.
startTracingSpan :: Stack.HasCallStack => Clock -> Text -> IO TracingSpan
startTracingSpan :: Clock -> Text -> IO TracingSpan
startTracingSpan Clock
clock Text
name = do
  MonotonicTime
started <- Clock -> IO MonotonicTime
monotonicTimeInMsec Clock
clock
  TracingSpan -> IO TracingSpan
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    TracingSpan :: Text
-> MonotonicTime
-> MonotonicTime
-> Maybe (Text, SrcLoc)
-> Maybe SomeTracingSpanDetails
-> Maybe Text
-> Succeeded
-> Int
-> [TracingSpan]
-> TracingSpan
TracingSpan
      { Text
name :: Text
name :: Text
name,
        MonotonicTime
started :: MonotonicTime
started :: MonotonicTime
started,
        finished :: MonotonicTime
finished = MonotonicTime
started,
        frame :: Maybe (Text, SrcLoc)
frame =
          -- This records a single stack frame containing the location in source
          -- code that creates this tracingSpan. It wouldn't be that useful if
          -- this single stack frame referenced the line in this source file
          -- where the @startTracingSpan@ function itself gets called, that would
          -- be the same line for every tracingSpan! Instead we'd like the source
          -- location recorded here to be the line outside this library calling
          -- into it. For example: the line in the application doing a database
          -- query, or logging some information.
          --
          -- That's why you see the @Stack.HasCallStack@ constraints and
          -- @Stack.withFrozenCallStack@ calls on this function's callers all the
          -- way to the boundary of the library. Unfortunately, that's what we
          -- need to do to push the stack frame we record out of the library.
          --
          -- We record only a single stack frame because that's all we get
          -- anyway, unless we'd start adding @Stack.HasCallStack@ constraints to
          -- functions in our Haskell applications. But because we record a frame
          -- for each tracingSpan together these frames can create a stack trace
          -- with a couple of different frames.
          --
          -- See the docs of the @GHC.Stack@ module for more information on how
          -- these traces work.
          CallStack
HasCallStack => CallStack
Stack.callStack
            CallStack
-> (CallStack -> [(String, SrcLoc)]) -> [(String, SrcLoc)]
forall a b. a -> (a -> b) -> b
|> CallStack -> [(String, SrcLoc)]
Stack.getCallStack
            [(String, SrcLoc)]
-> ([(String, SrcLoc)] -> Maybe (String, SrcLoc))
-> Maybe (String, SrcLoc)
forall a b. a -> (a -> b) -> b
|> [(String, SrcLoc)] -> Maybe (String, SrcLoc)
forall a. List a -> Maybe a
List.head
            Maybe (String, SrcLoc)
-> (Maybe (String, SrcLoc) -> Maybe (Text, SrcLoc))
-> Maybe (Text, SrcLoc)
forall a b. a -> (a -> b) -> b
|> ((String, SrcLoc) -> (Text, SrcLoc))
-> Maybe (String, SrcLoc) -> Maybe (Text, SrcLoc)
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
Shortcut.map ((String -> Text) -> (String, SrcLoc) -> (Text, SrcLoc)
forall a x b. (a -> x) -> (a, b) -> (x, b)
Tuple.mapFirst String -> Text
Data.Text.pack),
        details :: Maybe SomeTracingSpanDetails
details = Maybe SomeTracingSpanDetails
forall a. Maybe a
Nothing,
        summary :: Maybe Text
summary = Maybe Text
forall a. Maybe a
Nothing,
        succeeded :: Succeeded
succeeded = Succeeded
Succeeded,
        allocated :: Int
allocated = Int
0,
        children :: [TracingSpan]
children = []
      }

-- | Some final properties to set on a tracingSpan before calling it done.
finalizeTracingSpan :: Clock -> Int -> IORef.IORef TracingSpan -> Maybe Exception.SomeException -> IO TracingSpan
finalizeTracingSpan :: Clock
-> Int
-> IORef TracingSpan
-> Maybe SomeException
-> IO TracingSpan
finalizeTracingSpan Clock
clock Int
allocationCounterStartVal IORef TracingSpan
tracingSpanRef Maybe SomeException
maybeException = do
  MonotonicTime
finished <- Clock -> IO MonotonicTime
monotonicTimeInMsec Clock
clock
  Int
allocationCounterEndVal <- IO Int
System.Mem.getAllocationCounter
  TracingSpan
tracingSpan' <- IORef TracingSpan -> IO TracingSpan
forall a. IORef a -> IO a
IORef.readIORef IORef TracingSpan
tracingSpanRef
  TracingSpan -> IO TracingSpan
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    TracingSpan
tracingSpan'
      { MonotonicTime
finished :: MonotonicTime
finished :: MonotonicTime
finished,
        -- Below we implement the rule that if any of the children of a
        -- tracingSpan failed, that tracingSpan itself failed too. The reason
        -- we have this rule is to make it easy to see if a request as a whole
        -- failed (just check the 'succeeded' property of the root tracingSpan
        -- to see if any errors occurred), and to make it easy to trace the
        -- source of a problem from the root tracingSpan upward by following
        -- the failing child tracingSpans.
        succeeded :: Succeeded
succeeded =
          TracingSpan -> Succeeded
succeeded TracingSpan
tracingSpan'
            Succeeded -> Succeeded -> Succeeded
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ case Maybe SomeException
maybeException of
              Just SomeException
exception -> SomeException -> Succeeded
FailedWith SomeException
exception
              Maybe SomeException
Nothing ->
                (TracingSpan -> Succeeded) -> [TracingSpan] -> [Succeeded]
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map TracingSpan -> Succeeded
Platform.Internal.succeeded (TracingSpan -> [TracingSpan]
children TracingSpan
tracingSpan')
                  [Succeeded] -> ([Succeeded] -> Succeeded) -> Succeeded
forall a b. a -> (a -> b) -> b
|> [Succeeded] -> Succeeded
forall a. Monoid a => [a] -> a
Prelude.mconcat,
        -- The allocation counter counts down as it allocations bytest. We
        -- subtract in this order to get a positive number.
        allocated :: Int
allocated = Int
allocationCounterStartVal Int -> Int -> Int
forall number. Num number => number -> number -> number
- Int
allocationCounterEndVal
      }

appendTracingSpanToParent :: IORef.IORef TracingSpan -> TracingSpan -> IO ()
appendTracingSpanToParent :: IORef TracingSpan -> TracingSpan -> IO ()
appendTracingSpanToParent IORef TracingSpan
parentRef TracingSpan
child =
  IORef TracingSpan -> (TracingSpan -> TracingSpan) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
updateIORef IORef TracingSpan
parentRef ((TracingSpan -> TracingSpan) -> IO ())
-> (TracingSpan -> TracingSpan) -> IO ()
forall a b. (a -> b) -> a -> b
<| \TracingSpan
parentTracingSpan ->
    -- Note child tracingSpans are consed to the front of the list, so children
    -- are ordered new-to-old.
    TracingSpan
parentTracingSpan {children :: [TracingSpan]
children = TracingSpan
child TracingSpan -> [TracingSpan] -> [TracingSpan]
forall a. a -> [a] -> [a]
: TracingSpan -> [TracingSpan]
children TracingSpan
parentTracingSpan}

updateIORef :: IORef.IORef a -> (a -> a) -> IO ()
updateIORef :: IORef a -> (a -> a) -> IO ()
updateIORef IORef a
ref a -> a
f = IORef a -> (a -> (a, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef a
ref (\a
x -> (a -> a
f a
x, ()))

--
-- SPAN CONSTRUCTION
--

-- | Run a task in a tracingSpan.
--
-- > tracingSpan "code dance" <| do
-- >   waltzPassLeft
-- >   clockwiseTurn 60
--
-- This will help provide better debugging information if something goes wrong
-- inside the wrapped task.
tracingSpan :: Stack.HasCallStack => Text -> Task e a -> Task e a
tracingSpan :: Text -> Task e a -> Task e a
tracingSpan Text
name (Task LogHandler -> IO (Result e a)
run) =
  (LogHandler -> IO (Result e a)) -> Task e a
forall x a. (LogHandler -> IO (Result x a)) -> Task x a
Task
    ( \LogHandler
handler ->
        (HasCallStack =>
 LogHandler
 -> Text -> (LogHandler -> IO (Result e a)) -> IO (Result e a))
-> LogHandler
-> Text
-> (LogHandler -> IO (Result e a))
-> IO (Result e a)
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack
          HasCallStack =>
LogHandler
-> Text -> (LogHandler -> IO (Result e a)) -> IO (Result e a)
forall a.
HasCallStack =>
LogHandler -> Text -> (LogHandler -> IO a) -> IO a
tracingSpanIO
          LogHandler
handler
          Text
name
          LogHandler -> IO (Result e a)
run
    )

-- | Like @tracingSpan@, but this one runs in @IO@ instead of @Task@. We
-- sometimes need this in libraries. @Task@ has the concept of a @LogHandler@
-- built in but @IO@ does not, so we'll have to pass it around ourselves.
--
-- > tracingSpanIO handler "code dance" <| \childHandler -> do
-- >   waltzPassLeft childHandler
-- >   clockwiseTurn childHandler 60
tracingSpanIO :: Stack.HasCallStack => LogHandler -> Text -> (LogHandler -> IO a) -> IO a
tracingSpanIO :: LogHandler -> Text -> (LogHandler -> IO a) -> IO a
tracingSpanIO LogHandler
handler Text
name LogHandler -> IO a
run =
  IO LogHandler
-> (Maybe SomeException -> LogHandler -> IO ())
-> (LogHandler -> IO a)
-> IO a
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c
Exception.bracketWithError
    ((HasCallStack => IO LogHandler) -> IO LogHandler
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack (LogHandler -> HasCallStack => Text -> IO LogHandler
LogHandler -> Text -> IO LogHandler
startChildTracingSpan LogHandler
handler Text
name))
    ((LogHandler -> Maybe SomeException -> IO ())
-> Maybe SomeException -> LogHandler -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
Prelude.flip LogHandler -> Maybe SomeException -> IO ()
finishTracingSpan)
    LogHandler -> IO a
run

-- | Special version of @tracingSpanIO@ to call in the root of your application.
-- Instead of taking a parent handler it takes a continuation that will be
-- called with this root tracingSpan after it has run.
--
-- > rootTracingSpanIO "request-23" Prelude.print "incoming request" <| \handler ->
-- >   handleRequest
-- >   |> Task.perform handler
rootTracingSpanIO :: Stack.HasCallStack => Text -> (TracingSpan -> IO ()) -> Text -> (LogHandler -> IO a) -> IO a
rootTracingSpanIO :: Text
-> (TracingSpan -> IO ()) -> Text -> (LogHandler -> IO a) -> IO a
rootTracingSpanIO Text
requestId TracingSpan -> IO ()
onFinish Text
name LogHandler -> IO a
runIO = do
  Clock
clock' <- IO Clock
mkClock
  IO LogHandler
-> (Maybe SomeException -> LogHandler -> IO ())
-> (LogHandler -> IO a)
-> IO a
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c
Exception.bracketWithError
    ((HasCallStack =>
 Text -> Clock -> (TracingSpan -> IO ()) -> Text -> IO LogHandler)
-> Text -> Clock -> (TracingSpan -> IO ()) -> Text -> IO LogHandler
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack HasCallStack =>
Text -> Clock -> (TracingSpan -> IO ()) -> Text -> IO LogHandler
mkHandler Text
requestId Clock
clock' (TracingSpan -> IO ()
onFinish (TracingSpan -> IO ()) -> (IO () -> IO ()) -> TracingSpan -> IO ()
forall a b c. (a -> b) -> (b -> c) -> a -> c
>> IO () -> IO ()
reportSafely) Text
name)
    ((LogHandler -> Maybe SomeException -> IO ())
-> Maybe SomeException -> LogHandler -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
Prelude.flip LogHandler -> Maybe SomeException -> IO ()
finishTracingSpan)
    LogHandler -> IO a
runIO

-- After a root action (HTTP request, perform a job from a queue, etc) is done
-- we run our reporting logic, which sends debugging information to platforms
-- like Bugsnag and NewRelic.
--
-- This information is important when helping us debug our applications, but it
-- shouldn't be able to cause problems for the non-reporting logic, i.e. the
-- parts responsible for sending a response back to the user.
--
-- This function might kill the reporting thread if it thinks it's misbehaving.
-- It's up to the reporting logic to implement cleanup logic or notifications
-- of failed reporting using functions like `bracket`.
reportSafely :: IO () -> IO ()
reportSafely :: IO () -> IO ()
reportSafely IO ()
report = do
  -- Spawning a separate thread for the reporting logic ensures the main request
  -- thread doesn't need to wait with responding to the user until reporting
  -- logic finishes. It also ensures exceptions thrown in reporting logic won't
  -- result in failure responses to requests.
  Async (Maybe ())
_ <-
    IO (Maybe ()) -> IO (Async (Maybe ()))
forall a. IO a -> IO (Async a)
Async.async (IO (Maybe ()) -> IO (Async (Maybe ())))
-> IO (Maybe ()) -> IO (Async (Maybe ()))
forall a b. (a -> b) -> a -> b
<| do
      -- Setting an allocation limit helps protect us from reporting logic using
      -- lots of CPU time and negatively affecting application performance.
      Int -> IO ()
Mem.setAllocationCounter Int
reportingAllocationLimitInBytes
      IO ()
Mem.enableAllocationLimit
      -- This thread is spawned without anybody watching how it does. We set a
      -- maximum running time here to ensure it eventually completes.
      Int -> IO () -> IO (Maybe ())
forall a. Int -> IO a -> IO (Maybe a)
Timeout.timeout Int
reportingTimeoutInMicroSeconds IO ()
report
  () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure ()

-- | The maximum amount of bytes the reporting logic is allowed to allocate.
-- Note that this is more of a limit on CPU time then maximum live memory. See
-- the documentation on `setAllocationCounter` for more details:
--
-- https://hackage.haskell.org/package/base-4.14.0.0/docs/System-Mem.html#v:enableAllocationLimit
--
-- The current value is a somewhat arbitrary initial value, intentionally not
-- very strict. The hope is experience will help us tighten this value a bit.
reportingAllocationLimitInBytes :: Int
reportingAllocationLimitInBytes :: Int
reportingAllocationLimitInBytes = Int
1024 Int -> Int -> Int
forall number. Num number => number -> number -> number
* Int
1024 Int -> Int -> Int
forall number. Num number => number -> number -> number
* Int
1024

-- | The maximum amount of time reporting logic is allowed to run for a single
-- request.
--
-- The current value is a somewhat arbitrary initial value, intentionally not
-- very strict. The hope is experience will help us tighten this value a bit.
reportingTimeoutInMicroSeconds :: Prelude.Int
reportingTimeoutInMicroSeconds :: Int
reportingTimeoutInMicroSeconds = Int
5_000_000

--
-- CLOCK
--

-- | A clock we can use to get the current time, to check when tracingSpans are
-- starting or ending. We could call @getCurrentTime@ or somesuch whenever we
-- need the time but we'd be calling this a lot: every time a tracingSpan
-- starts or finishes. The @Clock@ type we pass around here contains cached
-- version of @getCurrentTime@. We can call it as often as we like and it will
-- only get the current time at most once every millisecond.
newtype Clock = Clock {Clock -> IO MonotonicTime
monotonicTimeInMsec :: IO MonotonicTime}

mkClock :: IO Clock
mkClock :: IO Clock
mkClock =
  UpdateSettings MonotonicTime -> IO (IO MonotonicTime)
forall a. UpdateSettings a -> IO (IO a)
AutoUpdate.mkAutoUpdate
    UpdateSettings ()
AutoUpdate.defaultUpdateSettings
      { updateAction :: IO MonotonicTime
AutoUpdate.updateAction =
          IO Word64
Clock.getMonotonicTimeNSec
            IO Word64 -> (IO Word64 -> IO MonotonicTime) -> IO MonotonicTime
forall a b. a -> (a -> b) -> b
|> (Word64 -> MonotonicTime) -> IO Word64 -> IO MonotonicTime
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (\Word64
n -> Word64 -> MonotonicTime
MonotonicTime (Word64
n Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`Prelude.div` Word64
1000)),
        updateFreq :: Int
AutoUpdate.updateFreq = Int
100 -- Once every 100 microseconds
      }
    IO (IO MonotonicTime)
-> (IO (IO MonotonicTime) -> IO Clock) -> IO Clock
forall a b. a -> (a -> b) -> b
|> (IO MonotonicTime -> Clock) -> IO (IO MonotonicTime) -> IO Clock
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map IO MonotonicTime -> Clock
Clock

-- |
-- You might expect a timestamp here, but timestamps are unreliable for
-- measuring how long a bit of code runs. For example: events like leap seconds
-- can cause them to move backards. This might result in us measuring the
-- duration of an operation and finding it to be minus 200 milliseconds.
--
-- We use @GHC.Clock.getMonotonicTimeNSec@ to let the OS tell us how much time
-- has passed since an arbitrary but constant moment in the past. That might
-- not seem all that useful, but if we 'sync watches' at one moment by getting
-- the monotonic and "regular" time in the same moment then we'll able to
-- convert any monotonic time to real timestamps. Conversion is not our concern
-- here though, we just store these monotonic times and let code that reporters
-- that use these tracingSpans convert the monotonic times into whatever format
-- they need.
newtype MonotonicTime = MonotonicTime
  { -- | The number of microseconds that have passed since an arbitrary but
    -- constant moment in the past.
    MonotonicTime -> Word64
inMicroseconds :: GHC.Word.Word64
  }
  deriving (Int -> MonotonicTime -> ShowS
[MonotonicTime] -> ShowS
MonotonicTime -> String
(Int -> MonotonicTime -> ShowS)
-> (MonotonicTime -> String)
-> ([MonotonicTime] -> ShowS)
-> Show MonotonicTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MonotonicTime] -> ShowS
$cshowList :: [MonotonicTime] -> ShowS
show :: MonotonicTime -> String
$cshow :: MonotonicTime -> String
showsPrec :: Int -> MonotonicTime -> ShowS
$cshowsPrec :: Int -> MonotonicTime -> ShowS
Prelude.Show, Integer -> MonotonicTime
MonotonicTime -> MonotonicTime
MonotonicTime -> MonotonicTime -> MonotonicTime
(MonotonicTime -> MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime)
-> (Integer -> MonotonicTime)
-> Num MonotonicTime
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> MonotonicTime
$cfromInteger :: Integer -> MonotonicTime
signum :: MonotonicTime -> MonotonicTime
$csignum :: MonotonicTime -> MonotonicTime
abs :: MonotonicTime -> MonotonicTime
$cabs :: MonotonicTime -> MonotonicTime
negate :: MonotonicTime -> MonotonicTime
$cnegate :: MonotonicTime -> MonotonicTime
* :: MonotonicTime -> MonotonicTime -> MonotonicTime
$c* :: MonotonicTime -> MonotonicTime -> MonotonicTime
- :: MonotonicTime -> MonotonicTime -> MonotonicTime
$c- :: MonotonicTime -> MonotonicTime -> MonotonicTime
+ :: MonotonicTime -> MonotonicTime -> MonotonicTime
$c+ :: MonotonicTime -> MonotonicTime -> MonotonicTime
Prelude.Num, MonotonicTime -> MonotonicTime -> Bool
(MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> Bool) -> Eq MonotonicTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MonotonicTime -> MonotonicTime -> Bool
$c/= :: MonotonicTime -> MonotonicTime -> Bool
== :: MonotonicTime -> MonotonicTime -> Bool
$c== :: MonotonicTime -> MonotonicTime -> Bool
Prelude.Eq, Eq MonotonicTime
Eq MonotonicTime
-> (MonotonicTime -> MonotonicTime -> Ordering)
-> (MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> Bool)
-> (MonotonicTime -> MonotonicTime -> MonotonicTime)
-> (MonotonicTime -> MonotonicTime -> MonotonicTime)
-> Ord MonotonicTime
MonotonicTime -> MonotonicTime -> Bool
MonotonicTime -> MonotonicTime -> Ordering
MonotonicTime -> MonotonicTime -> MonotonicTime
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MonotonicTime -> MonotonicTime -> MonotonicTime
$cmin :: MonotonicTime -> MonotonicTime -> MonotonicTime
max :: MonotonicTime -> MonotonicTime -> MonotonicTime
$cmax :: MonotonicTime -> MonotonicTime -> MonotonicTime
>= :: MonotonicTime -> MonotonicTime -> Bool
$c>= :: MonotonicTime -> MonotonicTime -> Bool
> :: MonotonicTime -> MonotonicTime -> Bool
$c> :: MonotonicTime -> MonotonicTime -> Bool
<= :: MonotonicTime -> MonotonicTime -> Bool
$c<= :: MonotonicTime -> MonotonicTime -> Bool
< :: MonotonicTime -> MonotonicTime -> Bool
$c< :: MonotonicTime -> MonotonicTime -> Bool
compare :: MonotonicTime -> MonotonicTime -> Ordering
$ccompare :: MonotonicTime -> MonotonicTime -> Ordering
$cp1Ord :: Eq MonotonicTime
Prelude.Ord, [MonotonicTime] -> Encoding
[MonotonicTime] -> Value
MonotonicTime -> Encoding
MonotonicTime -> Value
(MonotonicTime -> Value)
-> (MonotonicTime -> Encoding)
-> ([MonotonicTime] -> Value)
-> ([MonotonicTime] -> Encoding)
-> ToJSON MonotonicTime
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MonotonicTime] -> Encoding
$ctoEncodingList :: [MonotonicTime] -> Encoding
toJSONList :: [MonotonicTime] -> Value
$ctoJSONList :: [MonotonicTime] -> Value
toEncoding :: MonotonicTime -> Encoding
$ctoEncoding :: MonotonicTime -> Encoding
toJSON :: MonotonicTime -> Value
$ctoJSON :: MonotonicTime -> Value
Aeson.ToJSON, Value -> Parser [MonotonicTime]
Value -> Parser MonotonicTime
(Value -> Parser MonotonicTime)
-> (Value -> Parser [MonotonicTime]) -> FromJSON MonotonicTime
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MonotonicTime]
$cparseJSONList :: Value -> Parser [MonotonicTime]
parseJSON :: Value -> Parser MonotonicTime
$cparseJSON :: Value -> Parser MonotonicTime
Aeson.FromJSON)