{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune #-}

{- |
Output and Logging from your program.

Broadly speaking, there are two kinds of program: console tools invoked for a
single purpose, and long-running daemons that effectively run forever.

Tools tend to be run to either have an effect (in which case they tend not to
a say much of anything) or to report a result. This tends to be written to
\"standard output\"—traditionally abbreviated in code as @stdout@—which is
usually printed to your terminal.

Daemons, on the other hand, don't write their output to file descriptor 1;
rather they tend to respond to requests by writing to files, replying over
network sockets, or sending up smoke signals (@ECPUTOOHOT@, in case you're
curious). What daemons /do/ output, however, is log messages.

While there are many sophisticated logging services around that you can
interact with directly, from the point of view of an individual /program/
these tend to have faded away and have become more an aspect of the
Infrastructure- or Platform-as-a-Service you're running on. Over the past few
years containerization mechanisms like __docker__, then more recently
container orchestration layers like __kubernetes__, have generally simply
captured programs' standard output /as if it were the program's log output/
and then sent that down external logging channels to whatever log analysis
system is available. Even programs running locally under __systemd__ or
similar tend to follow the same pattern; services write to @stdout@ and that
output, as "logs", ends up being fed to the system journal.

So with that in mind, in your program you will either be outputting results to
@stdout@ or not writing there at all, and you will either be describing
extensively what your application is up to, or not at all.

There is also a \"standard error\" file descriptor available. We recommend not
using it. At best it is unclear what is written to @stderr@ and what isn't; at
worse it is lost as many environments in the wild discard @stderr@ entirely.
To avoid this most of the time people just combine them in the invoking shell
with @2>&1@, which inevitably results in @stderr@ text appearing in the middle
of normal @stdout@ lines corrupting them.

The original idea of standard error was to provde a way to report adverse
conditions without interrupting normal text output, but as we have just
observed if it happens without context or out of order there isn't much point.
Instead this library offers a mechanism which caters for the different /kinds/
of output in a unified, safe manner.

== Three kinds of output/logging messages

/Standard output/

Your program's normal output to the terminal. This library provides the
'write' (and 'writeS' and 'writeR') functions to send output to @stdout@.

/Informational messages/

When running a tool, you sometimes need to know /what it is doing/ as it is
carrying out its steps. The 'info' function allows you to emit descriptive
messages to the log channel tracing the activities of your program.

Ideally you would never need to turn this on in a command-line tool, but
sometimes a user or operations engineer needs to see what an application is up
to. These should be human readable status messages to convey a sense of
progress.

In the case of long-running daemons, 'info' can be used to describe high-level
lifecycle events, to document individual requests, or even describe individual
transitions in a request handler's state machine, all depending on the nature
of your program.

/Debugging/

Programmers, on the other hand, often need to see the internal state of the
program when /debugging/.

You almost always you want to know the value of some variable or parameter, so
the 'debug' (and 'debugS' and 'debugR') utility functions here send log
messages to the console prefixed with a label that is, by convention, the name
of the value you are examining.

The important distinction here is that such internal values are almost never
useful for someone other than the person or team who wrote the code emitting
it. Operations engineers might be asked by developers to turn on @--debug@ing
and report back the results; but a user of your program is not going to do
that in and of themselves to solve a problem.

== Single output channel

It is the easy to make the mistake of having multiple subsystems attempting to
write to @stdout@ and these outputs corrupting each other, especially in a
multithreaded language like Haskell. The output actions described here send
all output to terminal down a single thread-safe channel. Output will be
written in the order it was executed, and (so long as you don't use the
@stdout@ Handle directly yourself) your terminal output will be sound.

Passing @--verbose@ on the command-line of your program will cause 'info' to
write its tracing messages to the terminal. This shares the same output
channel as the 'write'@*@ functions and will /not/ cause corruption of your
program's normal output.

Passing @--debug@ on the command-line of your program will cause the
'debug'@*@ actions to write their debug-level messages to the terminal. This
shares the same output channel as above and again will not cause corruption of
your program's normal output.

== Runtime

You can change the current logging level from within your program by calling
'Core.Program.Execute.setVerbosityLevel'. You can also toggle between normal
'Output', 'Verbose' output and 'Debug' logging by sending the @SIGUSR1@ signal
to the program using /kill/:

@
\$ kill -USR1 42069
\$
@
-}
module Core.Program.Logging
    ( putMessage
    , formatLogMessage
    , Severity (..)
    , Verbosity (..)

      -- * Normal output
    , write
    , writeS
    , writeR

      -- * Informational
    , info
    , warn
    , critical

      -- * Debugging
    , debug
    , debugS
    , debugR
    -- internal
    , internal
    , isEvent
    , isDebug
    , isInternal
    ) where

import Control.Concurrent.MVar (readMVar)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TQueue (writeTQueue)
import Control.Exception (evaluate)
import Control.Monad (when)
import Control.Monad.Reader.Class (MonadReader (ask))
import Data.Fixed
import Data.Hourglass qualified as H (ElapsedP, TimeFormatElem (..), timePrint)
import Data.Text.Short qualified as S (replicate)

import Core.Data.Clock
import Core.Program.Context
import Core.System.Base
import Core.Text.Colour
import Core.Text.Rope
import Core.Text.Utilities

data Message = Message Time Severity Rope (Maybe Rope)

data Severity
    = SeverityNone
    | SeverityCritical
    | SeverityWarn
    | SeverityInfo
    | SeverityDebug
    | SeverityInternal

putMessage :: Context τ -> Message -> IO ()
putMessage :: forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Message Time
now Severity
level Rope
text Maybe Rope
possiblelValue) = do
    let i :: MVar Time
i = forall τ. Context τ -> MVar Time
startTimeFrom Context τ
context
    Time
start <- forall a. MVar a -> IO a
readMVar MVar Time
i
    let output :: TQueue (Maybe Rope)
output = forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom Context τ
context
        coloured :: Bool
coloured = forall τ. Context τ -> Bool
terminalColouredFrom Context τ
context

    let display :: Rope
display = case Maybe Rope
possiblelValue of
            Just Rope
value ->
                if Char -> Rope -> Bool
containsCharacter Char
'\n' Rope
value
                    then Rope
text forall a. Semigroup a => a -> a -> a
<> Rope
" =\n" forall a. Semigroup a => a -> a -> a
<> Rope
value
                    else Rope
text forall a. Semigroup a => a -> a -> a
<> Rope
" = " forall a. Semigroup a => a -> a -> a
<> Rope
value
            Maybe Rope
Nothing -> Rope
text

    let !result :: Rope
result = Time -> Time -> Bool -> Severity -> Rope -> Rope
formatLogMessage Time
start Time
now Bool
coloured Severity
level Rope
display

    forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
output (forall a. a -> Maybe a
Just Rope
result)

formatLogMessage :: Time -> Time -> Bool -> Severity -> Rope -> Rope
formatLogMessage :: Time -> Time -> Bool -> Severity -> Rope -> Rope
formatLogMessage Time
start Time
now Bool
coloured Severity
severity Rope
message =
    let !start' :: Int64
start' = Time -> Int64
unTime Time
start
        !now' :: Int64
now' = Time -> Int64
unTime Time
now
        !stampZ :: String
stampZ =
            forall format t.
(TimeFormat format, Timeable t) =>
format -> t -> String
H.timePrint
                [ TimeFormatElem
H.Format_Hour
                , Char -> TimeFormatElem
H.Format_Text Char
':'
                , TimeFormatElem
H.Format_Minute
                , Char -> TimeFormatElem
H.Format_Text Char
':'
                , TimeFormatElem
H.Format_Second
                , Char -> TimeFormatElem
H.Format_Text Char
'Z'
                ]
                (forall a. Instant a => Time -> a
fromTime Time
now :: H.ElapsedP)

        -- I hate doing math in Haskell
        !elapsed :: Fixed E3
elapsed = forall a. Fractional a => Rational -> a
fromRational (forall a. Real a => a -> Rational
toRational (Int64
now' forall a. Num a => a -> a -> a
- Int64
start') forall a. Fractional a => a -> a -> a
/ Rational
1e9) :: Fixed E3

        !colour :: Rope
colour = case Severity
severity of
            Severity
SeverityNone -> Rope
emptyRope
            Severity
SeverityCritical -> AnsiColour -> Rope
intoEscapes AnsiColour
pureRed
            Severity
SeverityWarn -> AnsiColour -> Rope
intoEscapes AnsiColour
pureYellow
            Severity
SeverityInfo -> AnsiColour -> Rope
intoEscapes AnsiColour
dullWhite
            Severity
SeverityDebug -> AnsiColour -> Rope
intoEscapes AnsiColour
pureGrey
            Severity
SeverityInternal -> AnsiColour -> Rope
intoEscapes AnsiColour
dullBlue

        !reset :: Rope
reset = AnsiColour -> Rope
intoEscapes AnsiColour
resetColour
    in  case Bool
coloured of
            Bool
True ->
                forall a. Monoid a => [a] -> a
mconcat
                    [ AnsiColour -> Rope
intoEscapes AnsiColour
dullWhite
                    , forall α. Textual α => α -> Rope
intoRope String
stampZ
                    , Rope
" ("
                    , Int -> String -> Rope
padWithZeros Int
6 (forall a. Show a => a -> String
show Fixed E3
elapsed)
                    , Rope
") "
                    , Rope
colour
                    , Rope
message
                    , Rope
reset
                    ]
            Bool
False ->
                forall a. Monoid a => [a] -> a
mconcat
                    [ forall α. Textual α => α -> Rope
intoRope String
stampZ
                    , Rope
" ("
                    , Int -> String -> Rope
padWithZeros Int
6 (forall a. Show a => a -> String
show Fixed E3
elapsed)
                    , Rope
") "
                    , Rope
message
                    ]

{- |
Utility function to prepend \'0\' characters to a string representing a
number.
-}

{-
    Cloned from **locators** package Data.Locators.Hashes, BSD3 licence
-}
padWithZeros :: Int -> String -> Rope
padWithZeros :: Int -> String -> Rope
padWithZeros Int
digits String
str =
    forall α. Textual α => α -> Rope
intoRope ShortText
pad forall a. Semigroup a => a -> a -> a
<> forall α. Textual α => α -> Rope
intoRope String
str
  where
    !pad :: ShortText
pad = Int -> ShortText -> ShortText
S.replicate Int
len ShortText
"0"
    !len :: Int
len = Int
digits forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str

{- |
Write the supplied text to @stdout@.

This is for normal program output.

@
     'write' "Beginning now"
@
-}
write :: Rope -> Program τ ()
write :: forall τ. Rope -> Program τ ()
write Rope
text = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        let out :: TQueue (Maybe Rope)
out = forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom Context τ
context

        !Rope
text' <- forall a. a -> IO a
evaluate Rope
text
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out (forall a. a -> Maybe a
Just Rope
text')

{- |
Call 'show' on the supplied argument and write the resultant text to
@stdout@.

(This is the equivalent of 'print' from __base__)
-}
writeS :: Show α => α -> Program τ ()
writeS :: forall α τ. Show α => α -> Program τ ()
writeS = forall τ. Rope -> Program τ ()
write forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall α. Textual α => α -> Rope
intoRope forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

{- |
Pretty print the supplied argument and write the resultant text to
@stdout@. This will pass the detected terminal width to the 'render'
function, resulting in appopriate line wrapping when rendering your value.
-}
writeR :: Render α => α -> Program τ ()
writeR :: forall α τ. Render α => α -> Program τ ()
writeR α
thing = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        let out :: TQueue (Maybe Rope)
out = forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom Context τ
context
        let columns :: Int
columns = forall τ. Context τ -> Int
terminalWidthFrom Context τ
context

        let text :: Rope
text = forall α. Render α => Int -> α -> Rope
render Int
columns α
thing
        !Rope
text' <- forall a. a -> IO a
evaluate Rope
text
        forall a. STM a -> IO a
atomically (forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out (forall a. a -> Maybe a
Just Rope
text'))

{- |
Note a significant event, state transition, status; also used as a heading for
subsequent debugging messages. This:

@
    'info' "Starting..."
@

will result in

> 13:05:55Z (00.112) Starting...

appearing on @stdout@. The output string is current time in UTC, and time
elapsed since startup shown to the nearest millisecond (our timestamps are to
nanosecond precision, but you don't need that kind of resolution in in
ordinary debugging).

@since 0.2.12
-}
info :: Rope -> Program τ ()
info :: forall τ. Rope -> Program τ ()
info Rope
text = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isEvent Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
            Time
now <- IO Time
getCurrentTimeNanoseconds
            forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityInfo Rope
text forall a. Maybe a
Nothing)

{- |
Emit a diagnostic message warning of an off-nominal condition. They are best
used for unexpected conditions or places where defaults are being applied
(potentially detrimentally).

@
     'warn' "You left the lights on again"
@

Warnings are worthy of note if you are looking into the behaviour of the
system, and usually—but not always—indicate a problem. That problem may not
need to be rectified, certainly not immediately.

__DO NOT PAGE OPERATIONS STAFF ON WARNINGS__.

For example, see "Core.Program.Execute"'s 'Core.Program.Execute.trap_'
function, a wrapper action which allows you to restart a loop when combined
with 'Control.Monad.forever'. @trap_@ swollows exceptions /but does not do/
/so silently/, instead using 'warn' to log a warning as an information
message. You don't need to do anything about the warning right away; after all
the point is to allow your program to continue. If it is happening unexpectly
or frequently, however, the issue bears investigation and the warning severity
message will give you a starting point for diagnosis.

@since 0.2.12
-}
warn :: Rope -> Program τ ()
warn :: forall τ. Rope -> Program τ ()
warn Rope
text = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isEvent Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
            Time
now <- IO Time
getCurrentTimeNanoseconds
            forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityWarn Rope
text forall a. Maybe a
Nothing)

{- |
Report an anomoly or condition critical to the ongoing health of the program.

@
     'critical' "Unable to do hostname lookups"      -- Yup, it was DNS. It's always DNS.
@

The term \"critical\" generally means the program is now in an unexpected or
invalid state, that further processing is incorrect, and that the program is
likely about to crash. The key is to get the message out to the informational
channel as quickly as possible before it does.

For example, an uncaught exception bubbling to the top the
'Core.Program.Execute.Program' monad will be logged as a 'critical' severity
message and forceibly output to the console before the program exits. Your
program is crashing, but at least you have a chance to find about why before
it does.

You're not going to page your operations staff on these either, but if they're
happening in a production service and it's getting restarted a lot as a result
you're probably going to be hearing about it.

@since 0.2.12
-}
critical :: Rope -> Program τ ()
critical :: forall τ. Rope -> Program τ ()
critical Rope
text = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isEvent Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
            Time
now <- IO Time
getCurrentTimeNanoseconds
            forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityCritical Rope
text forall a. Maybe a
Nothing)

isEvent :: Verbosity -> Bool
isEvent :: Verbosity -> Bool
isEvent Verbosity
level = case Verbosity
level of
    Verbosity
Output -> Bool
False
    Verbosity
Verbose -> Bool
True
    Verbosity
Debug -> Bool
True
    Verbosity
Internal -> Bool
True

isDebug :: Verbosity -> Bool
isDebug :: Verbosity -> Bool
isDebug Verbosity
level = case Verbosity
level of
    Verbosity
Output -> Bool
False
    Verbosity
Verbose -> Bool
False
    Verbosity
Debug -> Bool
True
    Verbosity
Internal -> Bool
True

isInternal :: Verbosity -> Bool
isInternal :: Verbosity -> Bool
isInternal Verbosity
level = case Verbosity
level of
    Verbosity
Output -> Bool
False
    Verbosity
Verbose -> Bool
False
    Verbosity
Debug -> Bool
False
    Verbosity
Internal -> Bool
True

{- |
Output a debugging message formed from a label and a value. This is like
'info' above but for the (rather common) case of needing to inspect or record
the value of a variable when debugging code. This:

@
    'Core.Program.Execute.setProgramName' \"hello\"
    name <- 'Core.Program.Execute.getProgramName'
    'debug' \"programName\" name
@

will result in

> 13:05:58Z (03.141) programName = hello

appearing on @stdout@, assuming these actions executed about three seconds
after program start.
-}
debug :: Rope -> Rope -> Program τ ()
debug :: forall τ. Rope -> Rope -> Program τ ()
debug Rope
label Rope
value = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isDebug Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
            Time
now <- IO Time
getCurrentTimeNanoseconds
            !Rope
value' <- forall a. a -> IO a
evaluate Rope
value
            forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityDebug Rope
label (forall a. a -> Maybe a
Just Rope
value'))

{- |
Convenience for the common case of needing to inspect the value
of a general variable which has a 'Show' instance
-}
debugS :: Show α => Rope -> α -> Program τ ()
debugS :: forall α τ. Show α => Rope -> α -> Program τ ()
debugS Rope
label α
value = forall τ. Rope -> Rope -> Program τ ()
debug Rope
label (forall α. Textual α => α -> Rope
intoRope (forall a. Show a => a -> String
show α
value))

{- |
Convenience for the common case of needing to inspect the value of a
general variable for which there is a 'Render' instance and so can pretty
print the supplied argument to the log. This will pass the detected
terminal width to the 'render' function, resulting in appopriate line
wrapping when rendering your value (if logging to something other than
console the default width of @80@ will be applied).
-}
debugR :: Render α => Rope -> α -> Program τ ()
debugR :: forall α τ. Render α => Rope -> α -> Program τ ()
debugR Rope
label α
thing = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isDebug Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
            Time
now <- IO Time
getCurrentTimeNanoseconds

            let columns :: Int
columns = forall τ. Context τ -> Int
terminalWidthFrom Context τ
context

            -- TODO take into account 22 width already consumed by Time
            -- TODO move render to putMessage? putMessageR?
            let value :: Rope
value = forall α. Render α => Int -> α -> Rope
render Int
columns α
thing
            !Rope
value' <- forall a. a -> IO a
evaluate Rope
value
            forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityDebug Rope
label (forall a. a -> Maybe a
Just Rope
value'))

internal :: Rope -> Program τ ()
internal :: forall τ. Rope -> Program τ ()
internal Rope
label = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isInternal Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
            Time
now <- IO Time
getCurrentTimeNanoseconds
            forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (Time -> Severity -> Rope -> Maybe Rope -> Message
Message Time
now Severity
SeverityInternal Rope
label forall a. Maybe a
Nothing)