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

-- | 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
    info,
    userIsAnnoyed,
    userIsConfused,
    userIsPained,
    userIsBlocked,
    withContext,
    context,

    -- * Secrets
    Secret,
    mkSecret,
    unSecret,

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

import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import GHC.Generics (Generic)
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 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 [Context]
contexts

-- | A log message when the user is annoyed, but not blocked.
--
--   Log.userIsAnnoyed
--     "We poked the user unnecessarily."
--     "Try to stop poking the user."
--     [ Log.context "The type of poking stick" poker ]
userIsAnnoyed :: Stack.HasCallStack => Text -> Text -> [Context] -> Task e ()
userIsAnnoyed :: Text -> Text -> [Context] -> Task e ()
userIsAnnoyed Text
message Text
advisory [Context]
contexts =
  let triage :: TriageInfo
triage = Impact -> Text -> TriageInfo
TriageInfo Impact
UserAnnoyed Text
advisory
   in (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 -> TriageInfo -> Context
forall a. ToJSON a => Text -> a -> Context
Context Text
"triage" TriageInfo
triage Context -> [Context] -> [Context]
forall a. a -> [a] -> [a]
: [Context]
contexts)

-- | Like @userIsAnnoyed@, but when the user is userIsConfused.
userIsConfused :: Stack.HasCallStack => Text -> Text -> [Context] -> Task e ()
userIsConfused :: Text -> Text -> [Context] -> Task e ()
userIsConfused Text
message Text
advisory [Context]
contexts =
  let triage :: TriageInfo
triage = Impact -> Text -> TriageInfo
TriageInfo Impact
UserConfused Text
advisory
   in (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 -> TriageInfo -> Context
forall a. ToJSON a => Text -> a -> Context
Context Text
"triage" TriageInfo
triage Context -> [Context] -> [Context]
forall a. a -> [a] -> [a]
: [Context]
contexts)

-- | Like @userIsAnnoyed@, but when the user is in pain.
userIsPained :: Stack.HasCallStack => Text -> Text -> [Context] -> Task e ()
userIsPained :: Text -> Text -> [Context] -> Task e ()
userIsPained Text
message Text
advisory [Context]
contexts =
  let triage :: TriageInfo
triage = Impact -> Text -> TriageInfo
TriageInfo Impact
UserInPain Text
advisory
   in (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 -> TriageInfo -> Context
forall a. ToJSON a => Text -> a -> Context
Context Text
"triage" TriageInfo
triage Context -> [Context] -> [Context]
forall a. a -> [a] -> [a]
: [Context]
contexts)

-- | Like @userIsAnnoyed@, but when the user is blocked.
userIsBlocked :: Stack.HasCallStack => Text -> Text -> [Context] -> Task e ()
userIsBlocked :: Text -> Text -> [Context] -> Task e ()
userIsBlocked Text
message Text
advisory [Context]
contexts =
  let triage :: TriageInfo
triage = Impact -> Text -> TriageInfo
TriageInfo Impact
UserBlocked Text
advisory
   in (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 -> TriageInfo -> Context
forall a. ToJSON a => Text -> a -> Context
Context Text
"triage" TriageInfo
triage 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
        (LogContexts -> Task e ()
forall d e. TracingSpanDetails d => d -> Task e ()
Platform.setTracingSpanDetails ([Context] -> LogContexts
LogContexts [Context]
contexts))
    )

--
-- 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 :: (Aeson.ToJSON a) => Text -> a -> Context
context :: Text -> a -> Context
context = Text -> a -> Context
forall 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 :: Aeson.ToJSON a => Text -> a -> 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
--

-- | A logged message for log levels warning and above. Because these levels
-- indicate a (potential) problem we want to provide some additional data that
-- would help a triager figure out what next steps to take.
data TriageInfo
  = TriageInfo
      { TriageInfo -> Impact
impact :: Impact,
        TriageInfo -> Text
advisory :: Text
      }
  deriving ((forall x. TriageInfo -> Rep TriageInfo x)
-> (forall x. Rep TriageInfo x -> TriageInfo) -> Generic TriageInfo
forall x. Rep TriageInfo x -> TriageInfo
forall x. TriageInfo -> Rep TriageInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TriageInfo x -> TriageInfo
$cfrom :: forall x. TriageInfo -> Rep TriageInfo x
Generic)

instance Aeson.ToJSON TriageInfo

-- | Classification of the levels of impact an issue might have on end-users.
data Impact
  = UserAnnoyed
  | UserConfused
  | UserInPain
  | UserBlocked
  deriving (Int -> Impact -> ShowS
[Impact] -> ShowS
Impact -> String
(Int -> Impact -> ShowS)
-> (Impact -> String) -> ([Impact] -> ShowS) -> Show Impact
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Impact] -> ShowS
$cshowList :: [Impact] -> ShowS
show :: Impact -> String
$cshow :: Impact -> String
showsPrec :: Int -> Impact -> ShowS
$cshowsPrec :: Int -> Impact -> ShowS
Show)

instance Aeson.ToJSON Impact where
  toJSON :: Impact -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (Text -> Value) -> (Impact -> Text) -> Impact -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< Impact -> Text
impactToText

  toEncoding :: Impact -> Encoding
toEncoding = Text -> Encoding
forall a. ToJSON a => a -> Encoding
Aeson.toEncoding (Text -> Encoding) -> (Impact -> Text) -> Impact -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
<< Impact -> Text
impactToText

impactToText :: Impact -> Text
impactToText :: Impact -> Text
impactToText Impact
kind =
  case Impact
kind of
    Impact
UserAnnoyed -> Text
"This is causing inconveniences to users but they will be able to achieve want they want."
    Impact
UserBlocked -> Text
"User is blocked from performing an action."
    Impact
UserConfused -> Text
"The UI did something unexpected and it's unclear why."
    Impact
UserInPain -> Text
"This is causing pain to users and workaround is not obvious."

-- 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