Merge branch 'master' into lwt6-compat

* master:
  [Files.save_as]: just write directly to special files (#60)
  web: expose http_request_k (#58)
  structured logging (#59)
  log: add critical due to error level inflation
  ci: use ocaml 5.4
  files: add mkdir_p (#57)
  [Action.config_lines] document and test behavior of commented lines (#56)
  update to trace 0.12 and OTEL main
  web: track content-type
  fix: avoid curl.ml crash
  web: track more information about request/response in span

Author: raphael-proust

.github/workflows/makefile.yml

@@ -14,7 +14,7 @@ jobs:
       matrix:
         ocaml-version:
           - 4.14
-          - 5.2
+          - 5.4
 
     runs-on: ubuntu-22.04
 
@@ -37,7 +37,7 @@ jobs:
 
     - name: Pin libevent
       run: opam pin add libevent --dev
-      
+
     - name: Build
       run: opam exec -- dune build --profile=release
 

action.mli

@@ -185,9 +185,16 @@ val io_null : unit IO.output
 val file_lines_exn : string -> string list
 val file_lines : string -> string list
 
-(** read lines from file skipping empty lines and comments (lines starting with '#') *)
+(** Read lines from file skipping empty lines and comments (lines starting with '#').
+
+    Moreover, comments are stripped from lines (all characters
+    including and following a '#') and returned lines are trimmed. *)
 val make_config_lines : string list -> string list
 val config_lines_exn : string -> string list
+
+(** [config_lines file] read [file] and return the config lines.
+
+    See {!make_config_lines} for details on config lines. *)
 val config_lines : string -> string list
 
 

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",

devkit.opam

@@ -22,7 +22,7 @@ depends: [
   "pcre2" {>= "8.0.3"}
   "trace" {>= "0.12"}
   "extunix" {>= "0.1.4"}
-  "lwt" {>= "6.0.0"}
+  "lwt" {>= "5.10.0"}
   "lwt_ppx"
   "base-bytes"
   "base-unix"
@@ -38,6 +38,6 @@ depopts: [
 ]
 conflicts: [
   "jemalloc" {< "0.2"}
-  "opentelemetry" {< "0.6"}
+  "opentelemetry" {< "0.13"}
 ]
 available: arch != "arm32" & arch != "x86_32"

dune

@@ -68,7 +68,7 @@
 
 (executable
   (name test)
-  (libraries lwt lwt.unix devkit extlib extunix libevent ocamlnet_lite ounit2 unix yojson)
+  (libraries lwt lwt.unix devkit extlib extunix libevent ocamlnet_lite ounit2 threads unix yojson)
   (modules test test_httpev))
 
 ; uses 8GB+ RAM, so do not run as part of test suite

files.ml

@@ -55,7 +55,19 @@ let () =
   iter_files "/etc" (fun s _ -> print_endline s)
 *)
 
-let save_as name ?(mode=0o644) f =
+let mkdir_p ?(perm=0o755) path =
+  let rec aux path =
+    if Sys.file_exists path then begin
+      if not (Sys.is_directory path) then
+        Exn.fail "mkdir_p: %s exists but is not a directory" path
+    end else begin
+      aux (Filename.dirname path);
+      try Unix.mkdir path perm with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
+    end
+  in
+  aux path
+
+let save_as_regular name ?(mode=0o644) f =
   (* not using make_temp_file cause same dir is needed for atomic rename *)
   let temp = Printf.sprintf "%s.save.%d.tmp" name (U.gettid ()) in
   bracket (Unix.openfile temp [Unix.O_WRONLY;Unix.O_CREAT] mode) Unix.close begin fun fd ->
@@ -69,3 +81,9 @@ let save_as name ?(mode=0o644) f =
     with
       exn -> Exn.suppress Unix.unlink temp; raise exn
   end
+
+let rec save_as name ?mode f =
+  match (Unix.lstat name).st_kind with
+  | Unix.S_LNK -> save_as (Unix.realpath name) ?mode f
+  | Unix.S_REG | (exception Unix.Unix_error (Unix.ENOENT, _, _)) -> save_as_regular name ?mode f
+  | _ -> Out_channel.with_open_gen [ Open_wronly ] 0 name f

files.mli

@@ -16,12 +16,22 @@ val iter_files : string -> (string -> in_channel -> unit) -> unit
 val open_out_append_bin : string -> out_channel
 val open_out_append_text : string -> out_channel
 
+(** [mkdir_p ?perm path] creates directory [path] and all missing parent
+    directories. Similar to [mkdir -p]. Raises [Failure] if [path] exists
+    but is not a directory. Default [perm] is [0o755]. *)
+val mkdir_p : ?perm:Unix.file_perm -> string -> unit
+
 (** [save_as filename ?mode f] is similar to
-    [Control.with_open_file_bin] except that writing is done to a
-    temporary file that will be renamed to [filename] after [f] has
-    succesfully terminated. Therefore this guarantee that either
-    [filename] will not be modified or will contain whatever [f] was
-    writing to it as a side-effect.
+    [Control.with_open_file_bin] for regular files, except that
+    writing is done to a temporary file that will be renamed to
+    [filename] after [f] has succesfully terminated. Therefore this
+    guarantee that either [filename] will not be modified or will
+    contain whatever [f] was writing to it as a side-effect.
+
+    There is no such special treatment for special files (Unix.stat
+    kind not S_REG, e.g. devices, pipes, etc), instead they are
+    written to directly. Symlinks are followed (not overwritten in
+    place). Throws {!Unix.Unix_error} on broken symlinks.
 
     FIXME windows *)
 val save_as : string -> ?mode:Unix.file_perm -> (out_channel -> unit) -> unit

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