Source file logging.ml

(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

open Lwt
open Printf

type logger = {
    stream : string Lwt_stream.t
  ; push : string -> unit
  ; elements : int ref
  ; max_elements : int
  ; dropped_elements : int ref
}

let create max_elements =
  let elements = ref (ref 0) in
  let dropped_elements = ref (ref 0) in
  let stream, stream_push = Lwt_stream.create () in
  let push line =
    if !(!elements) > max_elements then incr !dropped_elements
    else (
      stream_push (Some line);
      incr !elements)
  in
  {
    stream
  ; push
  ; elements = !elements
  ; max_elements
  ; dropped_elements = !dropped_elements
  }

let get (logger : logger) =
  let return_lines all =
    logger.elements := !(logger.elements) - List.length all;
    let dropped = !(logger.dropped_elements) in
    logger.dropped_elements := 0;
    return
      (if dropped <> 0 then
         Printf.sprintf "<-- dropped %d log lines" dropped :: all
       else all)
  in

  (* Grab as many elements as we can without blocking *)
  let all = Lwt_stream.get_available logger.stream in
  if all <> [] then return_lines all
  else
    (* Block for at least one line *)
    Lwt_stream.nget 1 logger.stream >>= fun all -> return_lines all

(* General system logging *)
let logger = create 512

(* Operation logging *)
let access_logger = create 512

type level = Debug | Info | Warn | Error | Null

let log_level = ref Warn

let int_of_level = function
  | Debug -> 0
  | Info -> 1
  | Warn -> 2
  | Error -> 3
  | Null -> max_int

let string_of_level = function
  | Debug -> "debug"
  | Info -> "info"
  | Warn -> "warn"
  | Error -> "error"
  | Null -> "null"

let log level key (fmt : (_, _, _, _) format4) =
  let level = string_of_level level in
  Printf.ksprintf logger.push ("[%5s|%s] " ^^ fmt) level key

let debug key = log Debug key
let info key = log Info key
let warn key = log Warn key
let error key = log Error key

(* Access logger *)

type access_type =
  | Coalesce
  | Conflict
  | Commit
  | Newconn
  | Endconn
  | Debug of string
  | Start_transaction
  | End_transaction
  | Request of Xs_protocol.Request.payload
  | Response of Xs_protocol.Response.payload * string option

let string_of_tid ~con tid =
  if tid = 0l then sprintf "%-12s" con
  else sprintf "%-12s" (sprintf "%s.%li" con tid)

let string_of_access_type = function
  | Coalesce -> "coalesce "
  | Conflict -> "conflict "
  | Commit -> "commit   "
  | Newconn -> "newconn  "
  | Endconn -> "endconn  "
  | Debug x -> "         " ^ x
  | Start_transaction -> "t start  "
  | End_transaction -> "t end    "
  | Request r -> " <- in   " ^ Xs_protocol.Request.prettyprint_payload r
  | Response (r, info_opt) -> (
      " -> out  "
      ^ Xs_protocol.Response.prettyprint_payload r
      ^ match info_opt with Some x -> " (" ^ x ^ ")" | None -> "")

let disable_coalesce = ref false
let disable_conflict = ref false
let disable_commit = ref false
let disable_newconn = ref false
let disable_endconn = ref false
let disable_transaction = ref false
let disable_request = ref [ "read" ]

let disable_reply_ok =
  ref
    [
      "read"
    ; "directory"
    ; "getperms"
    ; "watch"
    ; "unwatch"
    ; "transaction_start"
    ; "transaction_end"
    ; "introduce"
    ; "release"
    ; "getdomainpath"
    ; "write"
    ; "mkdir"
    ; "rm"
    ; "setperms"
    ; (* "watchevent"; *)
      "isintroduced"
    ; "resume"
    ; "set_target"
    ; "restrict"
    ]

let disable_reply_err = ref [ "read" ]

let access_type_disabled = function
  | Coalesce -> !disable_coalesce
  | Conflict -> !disable_conflict
  | Commit -> !disable_commit
  | Newconn -> !disable_newconn
  | Endconn -> !disable_endconn
  | Debug _ -> false
  | Start_transaction | End_transaction -> !disable_transaction
  | Request r ->
      List.mem
        Xs_protocol.(Op.to_string (Request.ty_of_payload r))
        !disable_request
  | Response (r, _) -> (
      match r with
      | Xs_protocol.Response.Error x -> List.mem x !disable_reply_err
      | _ ->
          let ty = Xs_protocol.Response.ty_of_payload r in
          List.mem (Xs_protocol.Op.to_string ty) !disable_reply_ok)

let access_type_enabled x = not (access_type_disabled x)

let sanitize_data data =
  let data = Bytes.of_string data in
  for i = 0 to Bytes.length data - 1 do
    if Bytes.get data i = '\000' then Bytes.set data i ' '
  done;
  String.escaped (Bytes.to_string data)

let access_logging ~con ~tid ?(data = "") access_type =
  if access_type_enabled access_type then
    let tid = string_of_tid ~con tid in
    let access_type = string_of_access_type access_type in
    let data = sanitize_data data in
    Printf.ksprintf logger.push "%s %s %s" tid access_type data

let new_connection = access_logging Newconn
let end_connection = access_logging Endconn

let read_coalesce ~tid ~con data =
  access_logging Coalesce ~tid ~con ~data:("read " ^ data)

let write_coalesce data = access_logging Coalesce ~data:("write " ^ data)
let conflict = access_logging Conflict
let commit = access_logging Commit
let request ~tid ~con request = access_logging ~tid ~con (Request request)

let response ~tid ~con ?info response =
  access_logging ~tid ~con (Response (response, info))

let debug_print ~tid ~con x = access_logging ~tid ~con (Debug x)
let start_transaction ~tid ~con = access_logging ~tid ~con Start_transaction
let end_transaction ~tid ~con = access_logging ~tid ~con End_transaction