Source file log.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2020-2022 Nomadic Labs <contact@nomadic-labs.com>           *)
(* Copyright (c) 2020 Metastate AG <hello@metastate.dev>                     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Base

(* The expected output of a normal run of Tezt is the log of the tests.
   So these should be on stdout.
   However, for some commands (especially those that are expected to be parsed
   by scripts such as --list-tsv), the expected output contains no logs, only data.
   For those commands, we thus log to stderr instead. We don't expect much logs
   except maybe warnings like "leftover files from a previous run". *)
let channel =
  match Cli.Commands.command with
  | Run -> stdout
  | List | List_tsv | Suggest_jobs | Version -> stderr

let current_worker_id = ref None

let set_current_worker_id id = current_worker_id := Some id

(* Current log file.
   It starts at [None], can be set to [Some channel] by [set_file], can be modified
   to another channel by [set_file], and is set back to [None] at exit.
   Invariant: if it is [Some channel], then [channel] is still open.
   [channel] is always closed when [log_file] is modified. *)
let log_file : out_channel option ref = ref None

let set_file filename =
  Option.iter close_out !log_file ;
  log_file := Some (open_out filename)

let flush_file () = Option.iter flush !log_file

type at_exit_warning_status = Do_not_warn | Warn_if_log | Already_warned

let at_exit_warning_status = ref Do_not_warn

let () =
  (* It is ok to use [Cli.Logs.log_file] before [Clap.close] because
     as an optional string its value cannot be a dummy value. *)
  Option.iter set_file Cli.Logs.file ;
  let close_log_file () =
    match !log_file with
    | None -> ()
    | Some file ->
        (* Setting [log_file] to [None] not only prevents closing the file
           again by mistake (which would not actually be an issue because
           [close_out] would just do nothing), it also prevents writing into
           the file. The latter would result in a "bad file descriptor" error,
           and could actually happen if another [at_exit] tries to log something
           (see test/cram/test-logs.t). *)
        log_file := None ;
        close_out file ;
        at_exit_warning_status := Warn_if_log
  in
  at_exit close_log_file

(* In theory we could simply escape spaces, backslashes, double quotes, single quotes
   and other symbols with a meaning for the shell.
   But 'some long argument' is arguably more readable than some\ long\ argument.
   We use this quoting method if the string contains no single quote. *)
let quote_shell s =
  let contains_single_quote = ref false in
  let needs_quotes = ref false in
  let categorize = function
    | '\'' ->
        needs_quotes := true ;
        contains_single_quote := true
    | 'a' .. 'z'
    | 'A' .. 'Z'
    | '0' .. '9'
    | '-' | '_' | '.' | '+' | '/' | ':' | '@' | '%' ->
        ()
    | _ -> needs_quotes := true
  in
  String.iter categorize s ;
  if not !needs_quotes then s
  else if not !contains_single_quote then "'" ^ s ^ "'"
  else Filename.quote s

let quote_shell_command command arguments =
  String.concat " " (List.map quote_shell (command :: arguments))

module Color = struct
  type t = string

  let ( ++ ) = ( ^ )

  let reset = "\027[0m"

  let bold = "\027[1m"

  let apply color string =
    if Cli.Logs.color then color ^ string ^ reset else string

  module FG = struct
    let black = "\027[30m"

    let red = "\027[31m"

    let green = "\027[32m"

    let yellow = "\027[33m"

    let blue = "\027[34m"

    let magenta = "\027[35m"

    let cyan = "\027[36m"

    let gray = "\027[37m"

    let bright_white = "\027[97m"
  end

  module BG = struct
    let black = "\027[40m"

    let red = "\027[41m"

    let green = "\027[42m"

    let yellow = "\027[43m"

    let blue = "\027[44m"

    let magenta = "\027[45m"

    let cyan = "\027[46m"

    let gray = "\027[47m"

    let bright_white = "\027[107m"
  end
end

module Style = struct
  type timestamp = Hidden | Visible of (float -> string)

  let default_timestamp_format timestamp =
    let time = Unix.gmtime timestamp in
    Printf.sprintf
      "%02d:%02d:%02d.%03d"
      time.tm_hour
      time.tm_min
      time.tm_sec
      (int_of_float ((timestamp -. float (truncate timestamp)) *. 1000.))

  let default_timestamp =
    if Cli.Logs.timestamp then Visible default_timestamp_format else Hidden

  type prefix = Hidden | Visible of (string -> string)

  let default_prefix = if Cli.Logs.prefix then Visible Fun.id else Hidden

  let timestamp = ref default_timestamp

  let prefix = ref default_prefix

  let set_timestamp style = timestamp := style

  let set_prefix style = prefix := style

  let get_timestamp () = !timestamp

  let get_prefix () = !prefix
end

(* The log buffer is a queue with a maximum size.
   Older items are dropped. *)
module Log_buffer = struct
  let capacity = Cli.Logs.buffer_size

  (* Each item is a tuple
     [(timestamp, worker_id, color, prefix, prefix_color, progress, message)]. *)
  let buffer = Array.make capacity (0., None, None, None, None, None, "")

  (* Index where to add the next item. *)
  let next = ref 0

  (* Number of items which are actually used in the array. *)
  let used = ref 0

  let reset () =
    next := 0 ;
    used := 0

  let push line =
    if capacity > 0 then (
      if !next >= capacity then next := 0 ;
      buffer.(!next) <- line ;
      incr next ;
      used := min capacity (!used + 1))

  (* Note: don't call [push] in [f]. *)
  let iter f =
    let first = !next - !used in
    let last = !next - 1 in
    for i = first to last do
      (* Add [capacity] to avoid issues with modulo of negative integers. *)
      f buffer.((i + capacity) mod capacity)
    done
end

let output_worker_id =
  (* [Cli.Options.job_count] can contain a dummy value (0) since we did not call
     [Clap.close] yet. *)
  let padding =
    1 + int_of_float (log10 (float_of_int (max 1 Cli.Options.job_count)))
  in
  fun output worker_id ->
    match worker_id with
    | None -> output String.(make (1 + padding) ' ')
    | Some id ->
        let ids = string_of_int id in
        output "#" ;
        output String.(make (padding - length ids) '0') ;
        output ids

let log_line_to ~use_colors
    (timestamp, worker_id, color, prefix, prefix_color, progress, message)
    channel =
  let output = output_string channel in
  (match !Style.timestamp with
  | Hidden -> ()
  | Visible f ->
      output "[" ;
      output (f timestamp) ;
      output "] ") ;
  if use_colors then Option.iter output color ;
  if Cli.Logs.worker_id && Cli.Options.job_count > 1 then (
    output "[" ;
    output_worker_id output worker_id ;
    output "]" ;
    output " ") ;
  (match !Style.prefix with
  | Hidden -> ()
  | Visible f ->
      Option.iter
        (fun prefix ->
          output "[" ;
          if use_colors then Option.iter output prefix_color ;
          output (f prefix) ;
          (if use_colors then
             match prefix_color with
             | None -> ()
             | Some _ ->
                 output Color.reset ;
                 Option.iter output color) ;
          output "] ")
        prefix) ;
  Option.iter output progress ;
  output message ;
  if use_colors && color <> None then output Color.reset ;
  output "\n"

let log_string ~(level : Cli.Logs.level) ?color ?prefix ?prefix_color
    ?progress_msg message =
  match String.split_on_char '\n' message with
  | [] | [""] -> ()
  | lines ->
      let log_line message =
        let line =
          ( Unix.gettimeofday (),
            !current_worker_id,
            color,
            prefix,
            prefix_color,
            progress_msg,
            message )
        in
        (match !at_exit_warning_status with
        | Do_not_warn ->
            Option.iter (log_line_to ~use_colors:false line) !log_file
        | Warn_if_log ->
            Printf.printf
              "[warn] Cannot log %S to file: file is closed. Did you try to \
               log from an at_exit handler that is registered before the Log \
               module? None of the following log messages will appear in the \
               log file.\n\
               %!"
              message ;
            at_exit_warning_status := Already_warned
        | Already_warned -> ()) ;
        match (Cli.Logs.level, level) with
        | _, Quiet -> invalid_arg "Log.log_string: level cannot be Quiet"
        | Error, Error
        | Warn, (Error | Warn)
        | Report, (Error | Warn | Report)
        | Info, (Error | Warn | Report | Info)
        | Debug, (Error | Warn | Report | Info | Debug) ->
            (if level = Error then
               Log_buffer.iter @@ fun line ->
               log_line_to ~use_colors:Cli.Logs.color line channel) ;
            Log_buffer.reset () ;
            log_line_to ~use_colors:Cli.Logs.color line channel ;
            flush channel
        | (Quiet | Error | Warn | Report | Info), _ -> Log_buffer.push line
      in
      List.iter log_line lines

let log ~level ?color ?prefix fmt =
  Format.kasprintf (log_string ~level ?color ?prefix) fmt

let debug ?color = log ~level:Debug ?color

let info ?color = log ~level:Info ?color

let report ?color = log ~level:Report ?color

let warn x = log ~level:Warn ~color:Color.FG.red ~prefix:"warn" x

let error x = log ~level:Error ~color:Color.FG.red ~prefix:"error" x

type test_result = Successful | Failed of string | Aborted

let test_result ~test_index ~test_count ~failure_count ~iteration test_result
    test_name =
  let prefix, prefix_color =
    match test_result with
    | Successful -> ("SUCCESS", Color.(FG.green ++ bold))
    | Failed _ -> ("FAILURE", Color.(FG.red ++ bold))
    | Aborted -> ("ABORTED", Color.(FG.red ++ bold))
  in
  let message =
    if Cli.Options.loop_mode <> Count 1 then
      Printf.sprintf "(loop %d) %s" iteration test_name
    else test_name
  in
  let progress_msg =
    sf
      "(%d/%d%s) "
      test_index
      test_count
      (if failure_count > 0 then sf ", %d failed" failure_count else "")
  in
  log_string ~level:Report ~prefix ~prefix_color ~progress_msg message

let command ?color ?prefix command arguments =
  let message = quote_shell_command command arguments in
  log_string ~level:Debug ?color ?prefix message ;
  if Cli.Logs.commands then print_endline message

let clear_error_context_queue = Log_buffer.reset