irmin-(client|server): adopt internal logs ppx

src/irmin-client/client.ml

@@ -102,19 +102,19 @@ struct
     let* res = Conn.Response.read_header t.conn in
     Conn.Response.get_error t.conn res >>= function
     | Some err ->
-        Log.err (fun l -> l "Request error: command=%s, error=%s" name err);
+        [%log.err "Request error: command=%s, error=%s" name err];
         Lwt.return_error (`Msg err)
     | None ->
         let+ x = Conn.read t.conn ty in
-        Log.debug (fun l -> l "Completed request: command=%s" name);
+        [%log.debug "Completed request: command=%s" name];
         x
 
   let request (t : t) (type x y)
       (module Cmd : C.CMD with type res = x and type req = y) (a : y) =
     if t.closed then raise Irmin.Closed
     else
       let name = Cmd.name in
-      Log.debug (fun l -> l "Starting request: command=%s" name);
+      [%log.debug "Starting request: command=%s" name];
       lock t (fun () ->
           let* () = send_command_header t (module Cmd) in
           let* () = Conn.write t.conn Cmd.req_t a in
@@ -425,13 +425,10 @@ struct
 
     type store = t
 
-    type batch_contents =
-      [ `Hash of Store.Hash.t | `Value of Store.contents ]
-      * Store.metadata option
-
     type t =
       (Store.path
-      * [ `Contents of batch_contents | `Tree of Request_tree.t ] option)
+      * [ `Contents of [ `Hash of Store.Hash.t | `Value of Store.contents ]
+      * Store.metadata option | `Tree of Request_tree.t ] option)
       list
     [@@deriving irmin]
 

src/irmin-client/client_intf.ml

@@ -61,11 +61,11 @@ module type S = sig
 
     type store = t
 
-    type batch_contents =
-      [ `Hash of hash | `Value of contents ] * metadata option
-
     type t =
-      (path * [ `Contents of batch_contents | `Tree of Request_tree.t ] option)
+      (path
+      * [ `Contents of [ `Hash of hash | `Value of contents ] * metadata option
+        | `Tree of Request_tree.t ]
+        option)
       list
     (** A batch is list of updates and their associated paths *)
 

src/irmin-client/dune

@@ -1,4 +1,6 @@
 (library
  (name irmin_client)
  (public_name irmin-client)
- (libraries irmin-server ipaddr))
+ (libraries irmin-server ipaddr)
+ (preprocess
+  (pps ppx_irmin.internal)))

src/irmin-client/unix/IO.ml

@@ -78,15 +78,15 @@ let websocket_to_flow client =
     Lwt.catch
       (fun () ->
         Websocket_lwt_unix.read client >>= fun frame ->
-        Log.debug (fun f -> f "<<< Client received frame");
+        [%log.debug "<<< Client received frame"];
         Lwt_io.write channel frame.content >>= fun () -> fill_ic channel client)
       (function End_of_file -> Lwt_io.close channel | exn -> Lwt.fail exn)
   in
   let rec send_oc handshake channel client =
     (if handshake then Websocket_protocol.read_handshake channel
      else Websocket_protocol.read_request channel)
     >>= fun content ->
-    Log.debug (fun f -> f ">>> Client sent frame");
+    [%log.debug ">>> Client sent frame"];
     Lwt.catch
       (fun () ->
         Websocket_lwt_unix.write client

src/irmin-client/unix/dune

@@ -6,4 +6,6 @@
   lwt.unix
   websocket-lwt-unix
   conduit-lwt-unix
-  irmin-server))
+  irmin-server)
+ (preprocess
+  (pps ppx_irmin.internal)))

src/irmin-server/conn.ml

@@ -46,7 +46,7 @@ module Make (I : IO) (T : Codec.S) = struct
 
   let write_raw t s : unit Lwt.t =
     let len = String.length s in
-    Log.debug (fun l -> l "Writing raw message: length=%d" len);
+    [%log.debug "Writing raw message: length=%d" len];
     let* x =
       IO.write_int64_be t.oc (Int64.of_int len) >>= fun () ->
       if len <= 0 then Lwt.return_unit else IO.write t.oc s
@@ -62,7 +62,7 @@ module Make (I : IO) (T : Codec.S) = struct
     let* n =
       Lwt.catch (fun () -> IO.read_int64_be t.ic) (fun _ -> Lwt.return 0L)
     in
-    Log.debug (fun l -> l "Raw message length=%Ld" n);
+    [%log.debug "Raw message length=%Ld" n];
     if n <= 0L then Lwt.return Bytes.empty
     else
       let n = Int64.to_int n in
@@ -117,15 +117,15 @@ module Make (I : IO) (T : Codec.S) = struct
     let v_header ~status = { status } [@@inline]
 
     let write_header t { status; _ } =
-      Log.debug (fun l -> l "Writing response header: status=%d" status);
+      [%log.debug "Writing response header: status=%d" status];
       let+ x = IO.write_char t.oc (char_of_int status) in
       x
 
     let read_header t =
-      Log.debug (fun l -> l "Starting response header read");
+      [%log.debug "Starting response header read"];
       let+ status = IO.read_char t.ic in
       let status = int_of_char status in
-      Log.debug (fun l -> l "Read response header: status=%d" status);
+      [%log.debug "Read response header: status=%d" status];
       { status }
     [@@inline]
 
@@ -135,7 +135,7 @@ module Make (I : IO) (T : Codec.S) = struct
       if is_error header then (
         let* x = read_raw t in
         let x = Bytes.to_string x in
-        Log.debug (fun l -> l "Error response message: %s" x);
+        [%log.debug "Error response message: %s" x];
         Lwt.return_some x)
       else Lwt.return_none
   end
@@ -146,7 +146,7 @@ module Make (I : IO) (T : Codec.S) = struct
     let v_header ~command = { command } [@@inline]
 
     let write_header t { command } : unit Lwt.t =
-      Log.debug (fun l -> l "Writing request header: command=%s" command);
+      [%log.debug "Writing request header: command=%s" command];
       let* () = IO.write_char t.oc (char_of_int (String.length command)) in
       IO.write t.oc (String.lowercase_ascii command)
 
@@ -157,7 +157,7 @@ module Make (I : IO) (T : Codec.S) = struct
         IO.read_into_exactly t.ic (Bytes.unsafe_of_string command) 0 length
       in
       let command = String.lowercase_ascii command in
-      Log.debug (fun l -> l "Request header read: command=%s" command);
+      [%log.debug "Request header read: command=%s" command];
       { command }
   end
 

src/irmin-server/dune

@@ -3,4 +3,4 @@
  (public_name irmin-server)
  (libraries logs fmt irmin lwt cmdliner)
  (preprocess
-  (pps ppx_irmin)))
+  (pps ppx_irmin.internal)))

src/irmin-server/unix/dune

@@ -2,7 +2,7 @@
  (name irmin_server_unix)
  (public_name irmin-server.unix)
  (preprocess
-  (pps ppx_blob))
+  (pps ppx_blob ppx_irmin.internal))
  (preprocessor_deps index.html)
  (libraries
   irmin-server

src/irmin-server/unix/server.ml

@@ -98,19 +98,17 @@ module Make (Codec : Conn.Codec.S) (Store : Irmin.Generic_key.S) = struct
     else
       Lwt.catch
         (fun () ->
-          Log.debug (fun l -> l "Receiving next command");
+          [%log.debug "Receiving next command"];
           (* Get request header (command and number of arguments) *)
           let* Conn.Request.{ command } = Conn.Request.read_header conn in
           (* Get command *)
           match Hashtbl.find_opt commands command with
           | None ->
               if String.length command = 0 then Lwt.return_unit
-              else
-                let () = Log.err (fun l -> l "Unknown command: %s" command) in
-                Conn.err conn ("unknown command: " ^ command)
+              else Conn.err conn ("unknown command: " ^ command)
           | Some (module Cmd : Command.CMD) ->
               let* req = Conn.read conn Cmd.req_t >|= invalid_arguments in
-              Log.debug (fun l -> l "Command: %s" Cmd.name);
+              [%log.debug "Command: %s" Cmd.name];
               let* res =
                 Lwt_mutex.with_lock command_lock @@ fun () ->
                 Cmd.run conn client info req
@@ -119,7 +117,7 @@ module Make (Codec : Conn.Codec.S) (Store : Irmin.Generic_key.S) = struct
         (function
           | Error.Error s ->
               (* Recover *)
-              Log.err (fun l -> l "Error response: %s" s);
+              [%log.err "Error response: %s" s];
               let* () = Conn.err conn s in
               Lwt_unix.sleep 0.01
           | End_of_file ->
@@ -131,8 +129,7 @@ module Make (Codec : Conn.Codec.S) (Store : Irmin.Generic_key.S) = struct
               else
                 (* Unhandled exception *)
                 let s = Printexc.to_string exn in
-                Log.err (fun l ->
-                    l "Exception: %s\n%s" s (Printexc.get_backtrace ()));
+                [%log.err "Exception: %s\n%s" s (Printexc.get_backtrace ())];
                 let* () = Conn.err conn s in
                 Lwt_unix.sleep 0.01)
       >>= fun () -> loop repo conn client info
@@ -145,12 +142,10 @@ module Make (Codec : Conn.Codec.S) (Store : Irmin.Generic_key.S) = struct
         (fun () -> Conn.Handshake.V1.check (module Store) conn)
         (fun _ -> Lwt.return_false)
     in
-    if not check then
+    if not check then (
       (* Hanshake failed *)
-      let () =
-        Log.info (fun l -> l "Client closed because of invalid handshake")
-      in
-      Lwt_io.close ic
+      [%log.info "Client closed because of invalid handshake"];
+      Lwt_io.close ic)
     else
       (* Handshake ok *)
       let client =
@@ -201,10 +196,10 @@ module Make (Codec : Conn.Codec.S) (Store : Irmin.Generic_key.S) = struct
           (fun () ->
             let* frame = Websocket_lwt_unix.Connected_client.recv client in
             if frame.opcode <> Binary then fill_ic channel other_channel client
-            else
-              let () = Log.debug (fun f -> f "<<< Server received frame") in
+            else (
+              [%log.debug "<<< Server received frame"];
               Lwt_io.write channel frame.content >>= fun () ->
-              fill_ic channel other_channel client)
+              fill_ic channel other_channel client))
           (function
             | End_of_file ->
                 (* The websocket has been closed is the assumption here *)
@@ -217,7 +212,7 @@ module Make (Codec : Conn.Codec.S) (Store : Irmin.Generic_key.S) = struct
         (if handshake then Websocket_protocol.read_handshake channel
          else Websocket_protocol.read_response channel)
         >>= fun content ->
-        Log.debug (fun f -> f ">>> Server sent frame");
+        [%log.debug ">>> Server sent frame"];
         Lwt.catch
           (fun () ->
             Websocket_lwt_unix.Connected_client.send client
@@ -234,7 +229,7 @@ module Make (Codec : Conn.Codec.S) (Store : Irmin.Generic_key.S) = struct
     Lwt.async (fun () -> send_oc true output_ic output_oc client);
     callback server input_ic output_oc
 
-  let on_exn x = Log.err (fun l -> l "EXCEPTION: %s" (Printexc.to_string x))
+  let on_exn x = [%log.err "EXCEPTION: %s" (Printexc.to_string x)]
 
   let dashboard t mode =
     let list store prefix =