{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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@.
--
-- /Events/
--
-- When running a tool, you sometimes need to know /what it is doing/ as it is
-- carrying out its steps. The 'event' 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, 'event' can be used to describe
-- high-level lifecycle events, to document individual requests, or even
-- describing 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
-- messages to the log channel 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 'event'
-- 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.
--
-- == Logging channel
--
-- /Event and debug messages are internally also sent to a "logging channel",/
-- /as distinct from the "output" one. This would allow us to send them/
-- /directly to a file, syslog, or network logging service, but this is/
-- /as-yet unimplemented./
module Core.Program.Logging
  ( putMessage,
    Verbosity (..),

    -- * Normal output
    write,
    writeS,
    writeR,

    -- * Event tracing
    event,

    -- * Debugging
    debug,
    debugS,
    debugR,
  )
where

import Chrono.TimeStamp (TimeStamp (..), getCurrentTimeNanoseconds)
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 Core.Program.Context
import Core.System.Base
import Core.Text.Rope
import Core.Text.Utilities
import Data.Fixed
import Data.Hourglass (TimeFormatElem (..), timePrint)
import qualified Data.Text.Short as S (replicate)

{-
class Monad m => MonadLog a m where
    logMessage :: Monoid a => Severity -> a -> m ()
-}

putMessage :: Context τ -> Message -> IO ()
putMessage :: Context τ -> Message -> IO ()
putMessage Context τ
context message :: Message
message@(Message TimeStamp
now Verbosity
_ Rope
text Maybe Rope
potentialValue) = do
  let start :: TimeStamp
start = Context τ -> TimeStamp
forall τ. Context τ -> TimeStamp
startTimeFrom Context τ
context
  let output :: TQueue Rope
output = Context τ -> TQueue Rope
forall τ. Context τ -> TQueue Rope
outputChannelFrom Context τ
context
  let logger :: TQueue Message
logger = Context τ -> TQueue Message
forall τ. Context τ -> TQueue Message
loggerChannelFrom Context τ
context

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

  let result :: Rope
result = TimeStamp -> TimeStamp -> Rope -> Rope
formatLogMessage TimeStamp
start TimeStamp
now Rope
display

  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    TQueue Rope -> Rope -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Rope
output Rope
result
    TQueue Message -> Message -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Message
logger Message
message

formatLogMessage :: TimeStamp -> TimeStamp -> Rope -> Rope
formatLogMessage :: TimeStamp -> TimeStamp -> Rope -> Rope
formatLogMessage TimeStamp
start TimeStamp
now Rope
message =
  let start' :: Int64
start' = TimeStamp -> Int64
unTimeStamp TimeStamp
start
      now' :: Int64
now' = TimeStamp -> Int64
unTimeStamp TimeStamp
now
      stampZ :: String
stampZ =
        [TimeFormatElem] -> TimeStamp -> String
forall format t.
(TimeFormat format, Timeable t) =>
format -> t -> String
timePrint
          [ TimeFormatElem
Format_Hour,
            Char -> TimeFormatElem
Format_Text Char
':',
            TimeFormatElem
Format_Minute,
            Char -> TimeFormatElem
Format_Text Char
':',
            TimeFormatElem
Format_Second,
            Char -> TimeFormatElem
Format_Text Char
'Z'
          ]
          TimeStamp
now

      -- I hate doing math in Haskell
      elapsed :: Fixed E3
elapsed = Rational -> Fixed E3
forall a. Fractional a => Rational -> a
fromRational (Int64 -> Rational
forall a. Real a => a -> Rational
toRational (Int64
now' Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
start') Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
1e9) :: Fixed E3
   in [Rope] -> Rope
forall a. Monoid a => [a] -> a
mconcat
        [ String -> Rope
forall α. Textual α => α -> Rope
intoRope String
stampZ,
          Rope
" (",
          Int -> String -> Rope
padWithZeros Int
9 (Fixed E3 -> String
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 =
  ShortText -> Rope
forall α. Textual α => α -> Rope
intoRope ShortText
pad Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> String -> Rope
forall α. Textual α => α -> Rope
intoRope String
str
  where
    pad :: ShortText
pad = Int -> ShortText -> ShortText
S.replicate Int
len ShortText
"0"
    len :: Int
len = Int
digits Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
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 :: Rope -> Program τ ()
write Rope
text = do
  Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
    let out :: TQueue Rope
out = Context τ -> TQueue Rope
forall τ. Context τ -> TQueue Rope
outputChannelFrom Context τ
context

    !Rope
text' <- Rope -> IO Rope
forall a. a -> IO a
evaluate Rope
text
    STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue Rope -> Rope -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Rope
out 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 :: α -> Program τ ()
writeS = Rope -> Program τ ()
forall τ. Rope -> Program τ ()
write (Rope -> Program τ ()) -> (α -> Rope) -> α -> Program τ ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Rope
forall α. Textual α => α -> Rope
intoRope (String -> Rope) -> (α -> String) -> α -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. α -> String
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 :: α -> Program τ ()
writeR α
thing = do
  Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
    let out :: TQueue Rope
out = Context τ -> TQueue Rope
forall τ. Context τ -> TQueue Rope
outputChannelFrom Context τ
context
    let columns :: Int
columns = Context τ -> Int
forall τ. Context τ -> Int
terminalWidthFrom Context τ
context

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

-- |
-- Note a significant event, state transition, status, or debugging
-- message. This:
--
-- @
--     'event' "Starting..."
-- @
--
-- will result in
--
-- > 13:05:55Z (0000.001) Starting...
--
-- appearing on stdout /and/ the message being sent down the logging
-- channel. 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).
--
-- Messages sent to syslog will be logged at @Info@ level severity.
event :: Rope -> Program τ ()
event :: Rope -> Program τ ()
event Rope
text = do
  Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity
level <- MVar Verbosity -> IO Verbosity
forall a. MVar a -> IO a
readMVar (Context τ -> MVar Verbosity
forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isEvent Verbosity
level) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      TimeStamp
now <- IO TimeStamp
getCurrentTimeNanoseconds
      Context τ -> Message -> IO ()
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (TimeStamp -> Verbosity -> Rope -> Maybe Rope -> Message
Message TimeStamp
now Verbosity
Event Rope
text Maybe Rope
forall a. Maybe a
Nothing)

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

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

-- |
-- Output a debugging message formed from a label and a value. This is like
-- 'event' above but for the (rather common) case of needing to inspect or
-- record the value of a variable when debugging code.  This:
--
-- @
--     'setProgramName' \"hello\"
--     name <- 'getProgramName'
--     'debug' \"programName\" name
-- @
--
-- will result in
--
-- > 13:05:58Z (0003.141) programName = hello
--
-- appearing on stdout /and/ the message being sent down the logging channel,
-- assuming these actions executed about three seconds after program start.
--
-- Messages sent to syslog will be logged at @Debug@ level severity.
debug :: Rope -> Rope -> Program τ ()
debug :: Rope -> Rope -> Program τ ()
debug Rope
label Rope
value = do
  Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity
level <- MVar Verbosity -> IO Verbosity
forall a. MVar a -> IO a
readMVar (Context τ -> MVar Verbosity
forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isDebug Verbosity
level) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      TimeStamp
now <- IO TimeStamp
getCurrentTimeNanoseconds
      !Rope
value' <- Rope -> IO Rope
forall a. a -> IO a
evaluate Rope
value
      Context τ -> Message -> IO ()
forall τ. Context τ -> Message -> IO ()
putMessage Context τ
context (TimeStamp -> Verbosity -> Rope -> Maybe Rope -> Message
Message TimeStamp
now Verbosity
Debug Rope
label (Rope -> Maybe Rope
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 :: Rope -> α -> Program τ ()
debugS Rope
label α
value = Rope -> Rope -> Program τ ()
forall τ. Rope -> Rope -> Program τ ()
debug Rope
label (String -> Rope
forall α. Textual α => α -> Rope
intoRope (α -> String
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 :: Rope -> α -> Program τ ()
debugR Rope
label α
thing = do
  Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity
level <- MVar Verbosity -> IO Verbosity
forall a. MVar a -> IO a
readMVar (Context τ -> MVar Verbosity
forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isDebug Verbosity
level) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      TimeStamp
now <- IO TimeStamp
getCurrentTimeNanoseconds

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

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