Source file log.ml

(**
  Global ready-to-use logger

  TODO interface to manage State
*)

(**
{2 Example usage}

Create logging facility (messages origin)
{[let http = Log.facility "http"]}

Log from http subsystem at debug level
{[Log.debug http "received %u bytes"]}

Create and use object for http logging
{[let log = Log.from "http" (* new Log.logger http *);;
log#info "sent %u bytes" 1024
log#warn ~exn "failed here"
]}

Output only messages of warning level or higher for the http facility
{[http#allow `Warn]}
or
{[Logger.set_filter http `Warn]}
or
{[Log.set_filter ~name:"http" `Warn]}
or
{[Log.set_filter ~name:"http*" `Warn]} to set for all facilities starting with "http"

Output only messages of warning level or higher for all facilities
{[Log.set_filter `Warn]}

{2 API}
*)

open Printf
open ExtLib
open Prelude

(** Global logger state *)
module State = struct
  let all = Hashtbl.create 10
  let default_level = ref (`Info : Logger.level)

  let utc_timezone = ref false

  let facility name =
    try
      Hashtbl.find all name
    with
      Not_found ->
        let x = { Logger.name = name; show = Logger.int_level !default_level } in
        Hashtbl.add all name x;
        x

  let set_filter ?name level =
    match name with
    | None -> default_level := level; Hashtbl.iter (fun _ x -> Logger.set_filter x level) all
    | Some name when Stre.ends_with name "*" ->
      let prefix = String.slice ~last:(-1) name in
      Hashtbl.iter (fun k x -> if Stre.starts_with k prefix then Logger.set_filter x level) all
    | Some name -> Logger.set_filter (facility name) level

  let set_loglevels s =
    Stre.nsplitc s ',' |> List.iter begin fun spec ->
      match Stre.nsplitc spec '=' with
      | name :: l :: [] -> set_filter ~name (Logger.level l)
      | l :: [] -> set_filter @@ Logger.level l
      | _ -> Exn.fail "loglevel not recognized, specify either <level> or <facil>=<level> or <prefix>*=<level>"
    end

  let read_env_config ?(env="DEVKIT_LOG") () =
    set_loglevels @@ try Sys.getenv env with Not_found -> ""

  let output_ch ch =
    fun str -> try output_string ch str; flush ch with _ -> () (* logging never fails, most probably ENOSPC *)

  let format_simple_full level facil ts pairs msg =
    let pid = Unix.getpid () in
    let tid = U.gettid () in
    let pinfo = if pid = tid then sprintf "%5u:" pid else sprintf "%5u:%u" pid tid in
    let pairs_str = match pairs with [] -> "" | _ -> " " ^ Logfmt.to_string pairs in
    sprintf "[%s] %s [%s:%s] %s%s\n"
      (Time.to_string ~gmt:!utc_timezone ~ms:true ts)
      pinfo
      facil.Logger.name
      (Logger.string_level level)
      msg
      pairs_str

  let format_logfmt level facil ts pairs msg =
    let pairs = ("msg", msg) :: pairs in
    let pid = Unix.getpid () in
    let tid = U.gettid () in
    let pairs =
      if pid = tid then ("pid", string_of_int pid) :: pairs
      else ("pid", string_of_int pid) :: ("tid", string_of_int tid) :: pairs
    in
    let pairs =
      ("time", Time.to_string ~gmt:!utc_timezone ~ms:true ts) ::
      ("level", Logger.string_level level) ::
      ("facil", facil.Logger.name) ::
      pairs
    in
    let buf = Buffer.create 32 in
    Logfmt.add_to_buffer buf pairs;
    Buffer.add_char buf '\n';
    Buffer.contents buf

  open struct
    let cur_format: ([`Plain|`Logfmt]*_) Atomic.t = Atomic.make (`Plain, format_simple_full)
    let set_cur_format f = Atomic.set cur_format f
  end
  let get_cur_format () = Atomic.get cur_format
  let is_structured_format () = match get_cur_format () with `Plain, _ -> false | `Logfmt, _ -> true
  let set_plaintext () = set_cur_format (`Plain, format_simple_full)
  let set_logfmt () = set_cur_format (`Logfmt, format_logfmt)

  let format level facil ts pairs msg =
    (snd (Atomic.get cur_format)) level facil ts pairs msg

  let format_simple level facil msg =
    format level facil (Unix.gettimeofday()) [] msg

  let log_ch = stderr
  let () = assert (Unix.descr_of_out_channel stderr = Unix.stderr)
  let base_name = ref ""
  let hook = ref (fun _ _ _ -> ())
  let output_simple level facil s = !hook level facil s; output_ch log_ch s

  (** Main logger *)
  let logger_target = {Logger.
    format;
    output = output_simple;
  }
  let logger = Logger.put_simple logger_target

  let self = "lib"

  (*
    we open the new fd, then dup it to stderr and close afterwards
    so we are always logging to stderr
  *)
  let reopen_log_ch ?(self_call=false) file =
    try
      if self_call = false then base_name := file;
      let ch = Files.open_out_append_text file in
      Std.finally
        (fun () -> close_out_noerr ch)
        (fun () -> Unix.dup2 (Unix.descr_of_out_channel ch) Unix.stderr)
        ()
    with
      e ->
        let now = (Unix.gettimeofday ()) in
        logger.put `Warn (facility self) now [] (sprintf "reopen_log_ch(%s) failed : %s" file (Printexc.to_string e))

end

let facility = State.facility
let set_filter = State.set_filter
let set_loglevels = State.set_loglevels
let set_utc () = State.utc_timezone := true

(** Update facilities configuration from the environment.

    By default, it reads the configuration in the environment variable [DEVKIT_LOG]
    which can be overwritten using the optional [process_name] parameter.

    The value of environment variable should match the following grammar: [(\[<facil|prefix*>=\]debug|info|warn|error|critical\[,\])*]

    @raise Failure on invalid level values of wrong format
*)
let read_env_config = State.read_env_config

(**
  param [lines]: whether to split multiline message as separate log lines (default [true])

  param [backtrace]: whether to show backtrace if [exn] is given (default is [false])

  param [saved_backtrace]: supply backtrace to show instead of using [Printexc.get_backtrace]

  param [pairs] key/value pairs to add to the line, unconditionally

  param [structured_pairs] key/value pairs to use for structured log formats only. Plain logging will discard.
*)
type 'a pr = ?rate_limit:Control.Rate_limit.t -> ?exn:exn -> ?lines:bool -> ?backtrace:bool -> ?saved_backtrace:string list -> ?ts:Time.t -> ?structured_pairs:Logger.Pairs.t -> ?pairs:Logger.Pairs.t -> ('a, unit, string, unit) format4 -> 'a

(** Default rate limiter, shared between all the loggers *)
let main_rate_limiter = Control.Rate_limit.create ~burst_factor:10 ~allowed_per_sec:500. ()

class logger ?(logger=State.logger) facil =
  let make_s (logger: Logger.t) (level:Logger.level) =
  let output = function
  | true ->
      fun facil ts pairs s ->
        if String.contains s '\n' then
          List.iter (logger.put level facil ts pairs) @@ String.nsplit s "\n"
        else
          logger.put level facil ts pairs s
  | false -> logger.put level
  in
  let print_bt lines exn bt ts pairs s =
    output lines facil ts pairs (s ^ " : exn " ^ Exn.str exn ^ (if bt = [] then " (no backtrace)" else ""));
    List.iter (fun line -> logger.put level facil ts pairs ("    " ^ line)) bt
  in
  fun ?(rate_limit=main_rate_limiter) ?exn ?(lines=true) ?(backtrace=false) ?saved_backtrace ?(ts=Unix.gettimeofday()) ?(structured_pairs=[]) ?(pairs=[]) s ->
    if logger.allowed facil level && Control.Rate_limit.attempt rate_limit then
    let pairs = if State.is_structured_format () then List.rev_append structured_pairs pairs else pairs in
    try
      if Logger.allowed facil `Warn then (
        let rate_limited = Control.Rate_limit.take_rate_limited_count rate_limit in
        if rate_limited > 0 then logger.put `Warn facil ts [] (sprintf "(%d messages have been rate limited)" rate_limited));
      match exn with
      | None -> output lines facil ts pairs s
      | Some exn ->
      match saved_backtrace with
      | Some bt -> print_bt lines exn bt ts pairs s
      | None ->
      match backtrace with
      | true -> print_bt lines exn (Exn.get_backtrace ()) ts pairs s
      | false -> output lines facil ts pairs (s ^ " : exn " ^ Exn.str exn)
    with exn ->
      logger.put level facil ts pairs (sprintf "LOG FAILED : %S with message %S" (Exn.str exn) s)
in
let make : _ -> _ pr = fun output ?rate_limit ?exn ?lines ?backtrace ?saved_backtrace ?ts ?structured_pairs ?pairs fmt ->
    ksprintf (fun s -> output ?rate_limit ?exn ?lines ?backtrace ?saved_backtrace ?ts ?structured_pairs ?pairs s) fmt
in
let debug_s = make_s logger `Debug in
let warn_s = make_s logger `Warn in
let info_s = make_s logger `Info in
let error_s = make_s logger `Error in
let critical_s = make_s logger `Critical in
let put_s level = make_s logger level in
object
method debug_s = debug_s
method warn_s = warn_s
method info_s = info_s
method error_s = error_s
method critical_s = critical_s
method put_s = put_s

(* expecting direct inlining to be faster but it is not o_O
method debug : 'a. 'a pr =
  fun ?exn ?lines ?backtrace ?saved_backtrace fmt ->
  ksprintf (fun s -> debug_s ?exn ?lines ?backtrace ?saved_backtrace s) fmt
*)
method debug : 'a. 'a pr = make debug_s
method warn : 'a. 'a pr = make warn_s
method info : 'a. 'a pr = make info_s
method error : 'a. 'a pr = make error_s
method critical : 'a. 'a pr = make critical_s
method put : 'a. Logger.level -> 'a pr = fun level -> make (put_s level)

method allow (level:Logger.level) = Logger.set_filter facil level
method level : Logger.level = Logger.get_level facil
method name = facil.Logger.name
method facility : Logger.facil = facil
end

let from name = new logger (facility name)

(** internal logging facility *)
let self = from State.self

(** general logging facility *)
let main = from "main"

(** reopen log file *)
let reopen = function
| None -> ()
| Some name -> State.reopen_log_ch name

let log_start = ref (Time.now())
let cur_size = ref 0