{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}

-- | This module is dedicated to logging information in production, to help
-- understand what the application is doing when something goes wrong. This sets
-- it apart from the @Debug@ module which provide helpers for debugging problems
-- in development.
--
-- This module does not have an Elm counterpart.
module Log
  ( -- * Logging
    debug,
    info,
    warn,
    error,
    withContext,
    context,

    -- * Secrets
    Secret,
    mkSecret,
    unSecret,

    -- * For use in observability modules
    Context (..),
    LogContexts (..),
  )
where

import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import qualified GHC.Stack as Stack
import NriPrelude
import qualified Platform
import qualified Platform.Internal as Internal
import qualified Task
import qualified Text.Show
import qualified Prelude

-- | A log message that is probably only useful in development, or when we're
-- really confused about something and need ALL THE CONTEXT.
--
-- In addition to a log message you can pass additional key-value pairs with
-- information that might be relevant for debugging.
--
-- > debug "Computation partially succeeded" [context "answer" 2]
debug :: Stack.HasCallStack => Text -> [Context] -> Task e ()
debug :: Text -> [Context] -> Task e ()
debug Text
message [Context]
contexts =
  (HasCallStack => Text -> ReportStatus -> [Context] -> Task e ())
-> Text -> ReportStatus -> [Context] -> Task e ()
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack
    HasCallStack => Text -> ReportStatus -> [Context] -> Task e ()
forall e.
HasCallStack =>
Text -> ReportStatus -> [Context] -> Task e ()
log
    Text
message
    ReportStatus
ReportAsSucceeded
    (Text -> LogLevel -> Context
forall a. (Show a, ToJSON a) => Text -> a -> Context
Context Text
"level" LogLevel
Debug Context -> [Context] -> [Context]
forall a. a -> [a] -> [a]
: [Context]
contexts)

-- | A log message useful for when things have gone off the rails.
-- We should have a ton of messages at this level.
-- It should help us out when we're dealing with something hard.
--
-- In addition to a log message you can pass additional key-value pairs with
-- information that might be relevant for debugging.
--
-- > info "I added 1 and 1" [context "answer" 2]
info :: Stack.HasCallStack => Text -> [Context] -> Task e ()
info :: Text -> [Context] -> Task e ()
info Text
message [Context]
contexts =
  (HasCallStack => Text -> ReportStatus -> [Context] -> Task e ())
-> Text -> ReportStatus -> [Context] -> Task e ()
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack
    HasCallStack => Text -> ReportStatus -> [Context] -> Task e ()
forall e.
HasCallStack =>
Text -> ReportStatus -> [Context] -> Task e ()
log
    Text
message
    ReportStatus
ReportAsSucceeded
    (Text -> LogLevel -> Context
forall a. (Show a, ToJSON a) => Text -> a -> Context
Context Text
"level" LogLevel
Info Context -> [Context] -> [Context]
forall a. a -> [a] -> [a]
: [Context]
contexts)

-- | A log message when something went wrong, but it did not go wrong in a way
-- to totally break the thing we're doing. These should be triaged and fixed
-- soon, but aren't show-stoppers.
--
-- In addition to a log message you can pass additional key-value pairs with
-- information that might be relevant for debugging.
--
-- > warn "This field was sent, but we're gonna deprecate it!" []
warn :: Stack.HasCallStack => Text -> [Context] -> Task e ()
warn :: Text -> [Context] -> Task e ()
warn Text
message [Context]
contexts =
  (HasCallStack => Text -> ReportStatus -> [Context] -> Task e ())
-> Text -> ReportStatus -> [Context] -> Task e ()
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack
    HasCallStack => Text -> ReportStatus -> [Context] -> Task e ()
forall e.
HasCallStack =>
Text -> ReportStatus -> [Context] -> Task e ()
log
    Text
message
    ReportStatus
ReportAsFailed
    (Text -> LogLevel -> Context
forall a. (Show a, ToJSON a) => Text -> a -> Context
Context Text
"level" LogLevel
Warn Context -> [Context] -> [Context]
forall a. a -> [a] -> [a]
: [Context]
contexts)

-- | A log message when we can't continue with what we were trying to do
-- because of a problem.
--
-- In addition to a log message you can pass additional key-value pairs with
-- information that might be relevant for debugging.
--
-- > error "The user tried to request this thing, but they aren't allowed!" []
error :: Stack.HasCallStack => Text -> [Context] -> Task e ()
error :: Text -> [Context] -> Task e ()
error Text
message [Context]
contexts =
  (HasCallStack => Text -> ReportStatus -> [Context] -> Task e ())
-> Text -> ReportStatus -> [Context] -> Task e ()
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack
    HasCallStack => Text -> ReportStatus -> [Context] -> Task e ()
forall e.
HasCallStack =>
Text -> ReportStatus -> [Context] -> Task e ()
log
    Text
message
    ReportStatus
ReportAsFailed
    (Text -> LogLevel -> Context
forall a. (Show a, ToJSON a) => Text -> a -> Context
Context Text
"level" LogLevel
Error Context -> [Context] -> [Context]
forall a. a -> [a] -> [a]
: [Context]
contexts)

-- | Mark a block of code as a logical unit by giving it a name. This name will
-- be used in logs and monitoring dashboards, so use this function to help
-- debug production problems.
--
-- In addition to a name you can pass this function a list of context. A
-- context is a key-value pair you want to attach to all logs made inside of
-- the block of code wrapped.
--
-- Example usage:
--
-- > withContext "play-music" [context "artist" "The Beatles"] <| do
-- >   -- your code here!
--
-- Additionally, this function adds an entry to our homemade stack trace for if something errors.
-- Why not use the built-in stack trace? Well, the built-in stack trace only records a frame if you
-- add @Stack.HasCallStack =>@ to the function, so if we want a full stack trace, we need to add
-- that to literally all functions. Instead of doing that, we will use @withContext@ to collect
-- the stack trace, since it is used fairly often already. It will not be complete either, but
-- it's the best we can do without too much trouble.
withContext ::
  Stack.HasCallStack =>
  Text ->
  [Context] ->
  Task e b ->
  Task e b
withContext :: Text -> [Context] -> Task e b -> Task e b
withContext Text
name [Context]
contexts Task e b
task =
  (HasCallStack => Text -> Task e b -> Task e b)
-> Text -> Task e b -> Task e b
forall a. HasCallStack => (HasCallStack => a) -> a
Stack.withFrozenCallStack
    HasCallStack => Text -> Task e b -> Task e b
forall e a. HasCallStack => Text -> Task e a -> Task e a
Internal.tracingSpan
    Text
name
    ( Task e b -> Task e () -> Task e b
forall e a b. Task e a -> Task e b -> Task e a
Platform.finally
        Task e b
task
        ( do
            LogContexts -> Task e ()
forall d e. TracingSpanDetails d => d -> Task e ()
Platform.setTracingSpanDetails ([Context] -> LogContexts
LogContexts [Context]
contexts)
            Text -> Task e ()
forall e. Text -> Task e ()
Platform.setTracingSpanSummary Text
name
        )
    )

--
-- CONTEXT
--

-- | A key-value pair that can be added to a log context. All log expressions
-- within the context will always log this key-value pair.
context :: (Show a, Aeson.ToJSON a) => Text -> a -> Context
context :: Text -> a -> Context
context = Text -> a -> Context
forall a. (Show a, ToJSON a) => Text -> a -> Context
Context

-- | Extra information to attach to a log message. It is passed a string key
-- defining what the data is and a value with a @ToJSON@ instance.
data Context where
  Context :: (Show a, Aeson.ToJSON a) => Text -> a -> Context

deriving instance Show Context

-- | A set of log contexts.
newtype LogContexts
  = LogContexts [Context]

instance Aeson.ToJSON LogContexts where
  toJSON :: LogContexts -> Value
toJSON (LogContexts [Context]
contexts) =
    [Context]
contexts
      [Context] -> ([Context] -> [Pair]) -> [Pair]
forall a b. a -> (a -> b) -> b
|> (Context -> Pair) -> [Context] -> [Pair]
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (\(Context Text
key a
val) -> Text
key Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
val)
      [Pair] -> ([Pair] -> Value) -> Value
forall a b. a -> (a -> b) -> b
|> [Pair] -> Value
Aeson.object

  toEncoding :: LogContexts -> Encoding
toEncoding (LogContexts [Context]
contexts) =
    [Context]
contexts
      [Context] -> ([Context] -> Series) -> Series
forall a b. a -> (a -> b) -> b
|> (Context -> Series) -> [Context] -> Series
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Prelude.foldMap (\(Context Text
key a
val) -> Text
key Text -> a -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
val)
      Series -> (Series -> Encoding) -> Encoding
forall a b. a -> (a -> b) -> b
|> Series -> Encoding
Aeson.pairs

instance Internal.TracingSpanDetails LogContexts

--
-- SECRET
--

-- | Wrap a value in a secret to prevent it from being accidentally logged.
--
-- > Debug.log "Logging a secret" (mkSecret "My PIN is 1234")
-- > --> Logging a secret: Secret *****
mkSecret :: a -> Secret a
mkSecret :: a -> Secret a
mkSecret = a -> Secret a
forall a. a -> Secret a
Secret

-- | Retrieve the original value from a secret. Be very careful with this and ask
-- yourself: is there really no way I can pass this value on as a secret
-- further before I need to unwrap it?
--
-- The longer a value is wrapped in a Secret, the smaller the odds of it
-- accidentally being logged.
unSecret :: Secret a -> a
unSecret :: Secret a -> a
unSecret (Secret a
x) = a
x

-- | Distinguishes data that is secret and should not be logged.
--
-- Please be careful when defining or altering instances for this data type.
-- There's a good chance we will leak credentials, PII, or
-- other equally sensitive information.
newtype Secret a
  = Secret a
  deriving (Secret a -> Secret a -> Bool
(Secret a -> Secret a -> Bool)
-> (Secret a -> Secret a -> Bool) -> Eq (Secret a)
forall a. Eq a => Secret a -> Secret a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Secret a -> Secret a -> Bool
$c/= :: forall a. Eq a => Secret a -> Secret a -> Bool
== :: Secret a -> Secret a -> Bool
$c== :: forall a. Eq a => Secret a -> Secret a -> Bool
Prelude.Eq, a -> Secret b -> Secret a
(a -> b) -> Secret a -> Secret b
(forall a b. (a -> b) -> Secret a -> Secret b)
-> (forall a b. a -> Secret b -> Secret a) -> Functor Secret
forall a b. a -> Secret b -> Secret a
forall a b. (a -> b) -> Secret a -> Secret b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Secret b -> Secret a
$c<$ :: forall a b. a -> Secret b -> Secret a
fmap :: (a -> b) -> Secret a -> Secret b
$cfmap :: forall a b. (a -> b) -> Secret a -> Secret b
Prelude.Functor)

instance Prelude.Applicative Secret where
  Secret a -> b
f <*> :: Secret (a -> b) -> Secret a -> Secret b
<*> Secret a
x = b -> Secret b
forall a. a -> Secret a
Secret (a -> b
f a
x)

  pure :: a -> Secret a
pure = a -> Secret a
forall a. a -> Secret a
Secret

-- | N.B. This instance of 'Show' is not law abiding.
--
-- This instance exists because we sometimes use 'Secret' in data types
-- that have to derive 'Show' (due to other constraints on those data types).
--
-- This is not a pattern to follow; it's an exception.
instance Show (Secret a) where
  showsPrec :: Int -> Secret a -> ShowS
showsPrec Int
p Secret a
_ =
    Bool -> ShowS -> ShowS
Text.Show.showParen (Int
p Int -> Int -> Bool
forall comparable.
Ord comparable =>
comparable -> comparable -> Bool
> Int
10) (String -> ShowS
Text.Show.showString String
"Secret \"*****\"")

instance Aeson.ToJSON (Secret a) where
  toJSON :: Secret a -> Value
toJSON Secret a
_ = Text -> Value
Aeson.String Text
"Secret *****"

--
-- TRIAGE
--

data LogLevel
  = Debug
  | Info
  | Warn
  | Error
  deriving ((forall x. LogLevel -> Rep LogLevel x)
-> (forall x. Rep LogLevel x -> LogLevel) -> Generic LogLevel
forall x. Rep LogLevel x -> LogLevel
forall x. LogLevel -> Rep LogLevel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LogLevel x -> LogLevel
$cfrom :: forall x. LogLevel -> Rep LogLevel x
Generic, Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogLevel] -> ShowS
$cshowList :: [LogLevel] -> ShowS
show :: LogLevel -> String
$cshow :: LogLevel -> String
showsPrec :: Int -> LogLevel -> ShowS
$cshowsPrec :: Int -> LogLevel -> ShowS
Show)

instance Aeson.ToJSON LogLevel

-- ReportAsFailed marks the request as a failure in logging, but has no impact on the resulting Task. E.g. will not trigger a 500 error but will report an error to, e.g. BugSnag.
data ReportStatus = ReportAsFailed | ReportAsSucceeded

log :: Stack.HasCallStack => Text -> ReportStatus -> [Context] -> Task e ()
log :: Text -> ReportStatus -> [Context] -> Task e ()
log Text
msg ReportStatus
reportStatus [Context]
contexts =
  Text -> Task e () -> Task e ()
forall e a. HasCallStack => Text -> Task e a -> Task e a
Internal.tracingSpan Text
msg (Task e () -> Task e ()) -> Task e () -> Task e ()
forall a b. (a -> b) -> a -> b
<| do
    LogContexts -> Task e ()
forall d e. TracingSpanDetails d => d -> Task e ()
Platform.setTracingSpanDetails ([Context] -> LogContexts
LogContexts [Context]
contexts)
    case ReportStatus
reportStatus of
      ReportStatus
ReportAsSucceeded -> () -> Task e ()
forall a x. a -> Task x a
Task.succeed ()
      ReportStatus
ReportAsFailed -> Task e ()
forall e. Task e ()
Platform.markTracingSpanFailed