structured logging

daemon.ml

@@ -62,6 +62,12 @@ let unless_exit x = Lwt.pick [wait_exit (); x]
 let get_args () =
   [
     ("-loglevel", Arg.String Log.set_loglevels, " ([<facil|prefix*>=]debug|info|warn|error[,])+");
+    ("-logformat",
+      Arg.Symbol (["plain"; "default"; "logfmt"], (function
+        | "plain" | "default" -> Log.State.set_plaintext ()
+        | "logfmt" -> Log.State.set_logfmt ()
+        | s -> failwith (Printf.sprintf "unknown log format %S" s))),
+      " Log output format (default: plain)");
     ExtArg.may_str "logfile" logfile "<file> Log file";
     ExtArg.may_str "pidfile" pidfile "<file> PID file";
     "-runas",

httpev.ml

@@ -284,7 +284,7 @@ let finish ?(shutdown=true) c =
   | Ready req ->
     Hashtbl.remove c.server.reqs req.id;
     if c.server.config.debug then
-      log #info "finished %s" (show_request req)
+      log #info "finished %s" (show_request req) ~structured_pairs:(pairs_of_request req)
 
 let write_f c (data,ack) ev fd _flags =
   let finish () = finish c; Ev.del ev in
@@ -324,7 +324,7 @@ let log_access_apache ch code size ?(background=false) req =
       (header_safe req "x-request-id")
       (if background then " (BG)" else "")
   with exn ->
-    log #warn ~exn "access log : %s" @@ show_request req
+    log #warn ~exn "access log : %s" (show_request req) ~structured_pairs:(pairs_of_request req)
 
 let log_status_apache ch status size req =
   match status with
@@ -498,10 +498,10 @@ let handle_request c body answer =
       | `Ok -> answer c.server req k
       end
     | _ ->
-      log #info "version %u.%u not supported from %s" (fst req.version) (snd req.version) (show_request req);
+      log #info "version %u.%u not supported from %s" (fst req.version) (snd req.version) (show_request req) ~structured_pairs:(pairs_of_request req);
       send_reply_async c Identity (`Version_not_supported,[],"HTTP/1.0 is supported")
   with exn ->
-    log #error ~exn "answer %s" @@ show_request req;
+    log #error ~exn "answer %s" (show_request req) ~structured_pairs:(pairs_of_request req);
     match req.blocking with
     | None -> send_reply_async c Identity (`Not_found,[],"Not found")
     | Some _ -> Exn.suppress teardown c.fd
@@ -639,7 +639,7 @@ let check_hung_requests server =
   let now = Time.now () in
   server.reqs |> Hashtbl.iter begin fun _ req ->
     if req.recv -. now > Time.minutes 30 then
-      log #warn "request takes too much time to process : %s" (show_request req)
+      log #warn "request takes too much time to process : %s" (show_request req) ~structured_pairs:(pairs_of_request req)
   end
 
 let check_waiting_requests srv =
@@ -845,7 +845,7 @@ let answer_blocking ?(debug=false) srv req answer k =
     | Continue continue -> 200, Some continue
     | exn ->
       let saved_backtrace = Exn.get_backtrace () in
-      log #warn ~exn ~backtrace:debug ~saved_backtrace "answer forked %s" (show_request req);
+      log #warn ~exn ~backtrace:debug ~saved_backtrace "answer forked %s" (show_request req) ~structured_pairs:(pairs_of_request req);
       -1, None
   in
   if srv.config.access_log_enabled then
@@ -873,7 +873,7 @@ let answer_forked ?debug srv req answer k =
       end;
       U.sys_exit 0
     | `Forked pid ->
-      log #info "forked %d : %s" pid (show_request req);
+      log #info "forked %d : %s" pid (show_request req) ~structured_pairs:(pairs_of_request req);
       k (`No_reply,[],""); (* close socket in parent immediately *)
       Hashtbl.add srv.h_childs pid ()
     end
@@ -883,7 +883,7 @@ let answer_forked ?debug srv req answer k =
       do_fork ()
     with
       exn ->
-        log #warn ~exn "answer fork failed %s" (show_request req);
+        log #warn ~exn "answer fork failed %s" (show_request req) ~structured_pairs:(pairs_of_request req);
         k (`Internal_server_error,[],"")
   in
   if Hashtbl.length srv.h_childs < srv.config.max_data_childs then
@@ -899,7 +899,7 @@ let answer_forked ?debug srv req answer k =
   else
   begin
     incr nr_rejected;
-    log #info "rejecting, overloaded : %s" (show_request req);
+    log #info "rejecting, overloaded : %s" (show_request req) ~structured_pairs:(pairs_of_request req);
     k (`Service_unavailable, ["Content-Type", "text/plain"], "overloaded")
   end
 
@@ -989,11 +989,11 @@ let handle_request_lwt c req answer =
       try%lwt
         answer c.server req
       with exn ->
-        log #error ~exn "answer %s" @@ show_request req;
+        log #error ~exn "answer %s" (show_request req) ~structured_pairs:(pairs_of_request req);
         return (`Not_found,[],"Not found")
     end
   | _ ->
-    log #info "version %u.%u not supported from %s" (fst req.version) (snd req.version) (show_request req);
+    log #info "version %u.%u not supported from %s" (fst req.version) (snd req.version) (show_request req) ~structured_pairs:(pairs_of_request req);
     return (`Version_not_supported,[],"HTTP/1.0 is supported")
 
 let read_buf ic buf =
@@ -1163,7 +1163,7 @@ let rest ~show_exn req answer =
   | Arg.Bad s -> bad_request @@ sprintf "bad parameter %s in %s" s req.url
   | exn ->
     let ref = random_ref () in
-    log#warn ~exn "failed ref:%Ld %s" ref (show_request req);
+    log#warn ~exn "failed ref:%Ld %s" ref (show_request req) ~structured_pairs:(pairs_of_request req);
     if show_exn then
       internal_error @@ sprintf "internal error ref:%Ld : %s" ref (match exn with Failure s -> s | _ -> Exn.str exn)
     else

httpev_common.ml

@@ -106,6 +106,17 @@ let show_request req =
     (header_safe req "user-agent")
     (header_safe req "x-request-id")
 
+let pairs_of_request req : Logger.Pairs.t =
+  [ "req_id", string_of_int req.id;
+    "client_addr", show_client_addr req;
+    "http_duration", sprintf "%.4f" (Time.get () -. req.conn);
+    "http_recv_duration", sprintf "%.4f" (req.recv -. req.conn);
+    "http_host", header_safe req "host";
+    "url", req.url;
+    "http_user_agent", header_safe req "user-agent";
+    "http_req_id", header_safe req "x-request-id"
+  ]
+
 let status_code : reply_status -> int = function
   | `Ok -> 200
   | `Created -> 201

log.ml

@@ -40,7 +40,6 @@ open Prelude
 
 (** Global logger state *)
 module State = struct
-
   let all = Hashtbl.create 10
   let default_level = ref (`Info : Logger.level)
 
@@ -77,30 +76,66 @@ module State = struct
   let output_ch ch =
     fun str -> try output_string ch str; flush ch with _ -> () (* logging never fails, most probably ENOSPC *)
 
-  let format_simple level facil msg =
+  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
-    sprintf "[%s] %s [%s:%s] %s\n"
-      (Time.to_string ~gmt:!utc_timezone ~ms:true (Unix.gettimeofday ()))
+    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
 
-  module Put = Logger.PutSimple(
-  struct
-    let format = format_simple
-    let output = fun level facil s -> let () = !hook level facil s in output_ch log_ch s
-  end)
+  let put = Logger.put_simple {
+    format;
+    output = output_simple;
+  }
 
-  module M = Logger.Make(Put)
+  (** Main logger, writes into [put] *)
+  let logger = Logger.make put
 
   let self = "lib"
 
@@ -117,11 +152,23 @@ module State = struct
         (fun () -> Unix.dup2 (Unix.descr_of_out_channel ch) Unix.stderr)
         ()
     with
-      e -> M.warn (facility self) "reopen_log_ch(%s) failed : %s" file (Printexc.to_string e)
+      e ->
+        let now = (Unix.gettimeofday ()) in
+        logger.warn (facility self) now [] "reopen_log_ch(%s) failed : %s" file (Printexc.to_string e)
 
 end
 
-include State.M
+let debug_s = State.logger.debug_s
+let info_s = State.logger.info_s
+let warn_s = State.logger.warn_s
+let error_s = State.logger.error_s
+let critical_s = State.logger.critical_s
+let put_s = State.logger.put_s
+let debug = State.logger.debug
+let info = State.logger.info
+let warn = State.logger.warn
+let error = State.logger.error
+let critical = State.logger.critical
 
 let facility = State.facility
 let set_filter = State.set_filter
@@ -142,43 +189,48 @@ 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 [backtrace]: whethgter 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 = ?exn:exn -> ?lines:bool -> ?backtrace:bool -> ?saved_backtrace:string list -> ('a, unit, string, unit) format4 -> 'a
+type 'a pr = ?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
 
 class logger facil =
-let make_s output_line =
+  let make_s (output_line:Logger.facil -> Time.t -> Logger.Pairs.t -> string -> unit) =
   let output = function
   | true ->
-      fun facil s ->
+      fun facil ts pairs s ->
         if String.contains s '\n' then
-          List.iter (output_line facil) @@ String.nsplit s "\n"
+          List.iter (output_line facil ts pairs) @@ String.nsplit s "\n"
         else
-          output_line facil s
+          output_line facil ts pairs s
   | false -> output_line
   in
-  let print_bt lines exn bt s =
-    output lines facil (s ^ " : exn " ^ Exn.str exn ^ (if bt = [] then " (no backtrace)" else ""));
-    List.iter (fun line -> output_line facil ("    " ^ line)) bt
+  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 -> output_line facil ts pairs ("    " ^ line)) bt
   in
-  fun ?exn ?(lines=true) ?(backtrace=false) ?saved_backtrace s ->
+  fun ?exn ?(lines=true) ?(backtrace=false) ?saved_backtrace ?(ts=Unix.gettimeofday()) ?(structured_pairs=[]) ?(pairs=[]) s ->
+    let pairs = if structured_pairs!=[] && State.is_structured_format () then List.rev_append structured_pairs pairs else pairs in
     try
       match exn with
-      | None -> output lines facil s
+      | None -> output lines facil ts pairs s
       | Some exn ->
       match saved_backtrace with
-      | Some bt -> print_bt lines exn bt s
+      | Some bt -> print_bt lines exn bt ts pairs s
       | None ->
       match backtrace with
-      | true -> print_bt lines exn (Exn.get_backtrace ()) s
-      | false -> output lines facil (s ^ " : exn " ^ Exn.str exn)
+      | true -> print_bt lines exn (Exn.get_backtrace ()) ts pairs s
+      | false -> output lines facil ts pairs (s ^ " : exn " ^ Exn.str exn)
     with exn ->
-      output_line facil (sprintf "LOG FAILED : %S with message %S" (Exn.str exn) s)
+      output_line facil ts pairs (sprintf "LOG FAILED : %S with message %S" (Exn.str exn) s)
 in
-let make output ?exn ?lines ?backtrace ?saved_backtrace fmt =
-  ksprintf (fun s -> output ?exn ?lines ?backtrace ?saved_backtrace s) fmt
+let make : _ -> _ pr = fun output ?exn ?lines ?backtrace ?saved_backtrace ?ts ?structured_pairs ?pairs fmt ->
+    ksprintf (fun s -> output ?exn ?lines ?backtrace ?saved_backtrace ?ts ?structured_pairs ?pairs s) fmt
 in
 let debug_s = make_s debug_s in
 let warn_s = make_s warn_s in

logfmt.ml

@@ -0,0 +1,41 @@
+
+let[@inline] needs_escape c =
+  Char.code c < 0x20 || c = '"' || c = '\\'
+
+let[@inline] needs_quotes c =
+  c = ' ' || Char.code c >= 0x80
+
+type cat = Safe | Has_space | Needs_escape
+
+let categorize s : cat =
+  let quote = ref false in
+
+  try
+    for i=0 to String.length s-1 do
+      let c = String.unsafe_get s i in
+      if needs_escape c then raise_notrace Exit;
+      if needs_quotes c then quote := true
+    done;
+    if !quote then Has_space else Safe
+  with Exit -> Needs_escape
+
+let add_pair buf k v =
+  Buffer.add_string buf k;
+  Buffer.add_char buf '=';
+  match categorize v with
+  | Safe -> Buffer.add_string buf v
+  | Has_space -> Printf.bprintf buf {|"%s"|} v
+  | Needs_escape -> Printf.bprintf buf "%S" v
+
+let rec add_to_buffer buf (pairs:Logger.Pairs.t) : unit =
+  match pairs with
+  | [] -> ()
+  | [k,v] -> add_pair buf k v
+  | (k,v) :: pairs -> add_pair buf k v; Buffer.add_char buf ' '; add_to_buffer buf pairs
+
+let to_string pairs = match pairs with
+  | [] -> ""
+  | _ ->
+    let buf = Buffer.create 32 in
+    add_to_buffer buf pairs;
+    Buffer.contents buf

logfmt.mli

@@ -0,0 +1,3 @@
+
+val add_to_buffer : Buffer.t -> Logger.Pairs.t -> unit
+val to_string : Logger.Pairs.t -> string