diff --git a/src/irmin-client/client.ml b/src/irmin-client/client.ml index bcf76e2e58..38a561fae1 100644 --- a/src/irmin-client/client.ml +++ b/src/irmin-client/client.ml @@ -102,11 +102,11 @@ 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) @@ -114,7 +114,7 @@ struct 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,13 @@ 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 | `Remove ]) + * [ `Contents of + [ `Hash of Store.Hash.t | `Value of Store.contents ] + * Store.metadata option + | `Tree of Request_tree.t + | `Remove ]) list [@@deriving irmin] diff --git a/src/irmin-client/client_intf.ml b/src/irmin-client/client_intf.ml index e695345d0f..8b72bb5ef5 100644 --- a/src/irmin-client/client_intf.ml +++ b/src/irmin-client/client_intf.ml @@ -61,12 +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 | `Remove ]) + * [ `Contents of [ `Hash of hash | `Value of contents ] * metadata option + | `Tree of Request_tree.t + | `Remove ]) list (** A batch is list of updates and their associated paths *) diff --git a/src/irmin-client/dune b/src/irmin-client/dune index 2ea50d9a19..6795d090ca 100644 --- a/src/irmin-client/dune +++ b/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))) diff --git a/src/irmin-client/unix/IO.ml b/src/irmin-client/unix/IO.ml index 4debcffe3f..ab8a8fb263 100644 --- a/src/irmin-client/unix/IO.ml +++ b/src/irmin-client/unix/IO.ml @@ -78,7 +78,7 @@ 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 @@ -86,7 +86,7 @@ let websocket_to_flow 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 diff --git a/src/irmin-client/unix/dune b/src/irmin-client/unix/dune index dff625c0c0..579f1c7ee2 100644 --- a/src/irmin-client/unix/dune +++ b/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))) diff --git a/src/irmin-server/conn.ml b/src/irmin-server/conn.ml index 46e76009f9..94231bca95 100644 --- a/src/irmin-server/conn.ml +++ b/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 diff --git a/src/irmin-server/dune b/src/irmin-server/dune index ec1e324484..8bc80dde7a 100644 --- a/src/irmin-server/dune +++ b/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))) diff --git a/src/irmin-server/unix/dune b/src/irmin-server/unix/dune index c344e4d091..a133704a8c 100644 --- a/src/irmin-server/unix/dune +++ b/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 diff --git a/src/irmin-server/unix/server.ml b/src/irmin-server/unix/server.ml index 97adc2d3dd..8273d47ab4 100644 --- a/src/irmin-server/unix/server.ml +++ b/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 =