From 9519347b26c0fd477f86f475833bbb983e7ac66a Mon Sep 17 00:00:00 2001 From: Ulugbek Abdullaev Date: Wed, 20 Jan 2021 12:09:30 +0500 Subject: [PATCH 1/6] * make State.Context abstract over additional context embedded in it * make client, server capabilities management more explicit --- fuzz/smart.ml | 6 +++--- src/not-so-smart/fetch.ml | 7 ++++--- src/not-so-smart/find_common.ml | 7 +++++-- src/not-so-smart/push.ml | 9 +++++---- src/not-so-smart/smart.ml | 30 +++++++++++++++++++++++------- src/not-so-smart/smart.mli | 11 ++++++++--- src/not-so-smart/state.ml | 26 +++++++++----------------- src/not-so-smart/state.mli | 21 +++++++++------------ 8 files changed, 66 insertions(+), 51 deletions(-) diff --git a/fuzz/smart.ml b/fuzz/smart.ml index 14a78cf19..b8c3f1ea4 100644 --- a/fuzz/smart.ml +++ b/fuzz/smart.ml @@ -52,7 +52,7 @@ let ( >>= ) = Crowbar.dynamic_bind let () = let of_string str = - let ctx = Smart.Context.make [] in + let ctx = Smart.Context.make ~client_caps:[] in let state = Smart.decode ctx (Smart.packet ~trim:false) (fun _ctx res -> Return res) in @@ -85,7 +85,7 @@ let () = let () = let of_string str = - let ctx = Smart.Context.make [] in + let ctx = Smart.Context.make ~client_caps:[] in let state = Smart.decode ctx Smart.advertised_refs (fun _ctx res -> Return res) in @@ -105,7 +105,7 @@ let () = go state in let to_string v = - let ctx = Smart.Context.make [] in + let ctx = Smart.Context.make ~client_caps:[] in let buf = Buffer.create 0x1000 in let state = Smart.encode ctx Smart.send_advertised_refs v (fun _ctx -> diff --git a/src/not-so-smart/fetch.ml b/src/not-so-smart/fetch.ml index 8fbbf8f42..4b33d3cc6 100644 --- a/src/not-so-smart/fetch.ml +++ b/src/not-so-smart/fetch.ml @@ -75,7 +75,7 @@ struct let fetch_v1 ?(uses_git_transport = false) ?(push_stdout = ignore) ?(push_stderr = ignore) ~capabilities ?deepen ?want:(refs = `None) ~host path flow store access fetch_cfg pack = - let capabilities = + let client_caps = (* XXX(dinosaure): HTTP ([stateless]) enforces no-done capabilities. Otherwise, you never will receive the PACK file. *) if fetch_cfg.Neg.no_done && not (no_done capabilities) then @@ -93,10 +93,11 @@ struct let* v = recv ctx advertised_refs in let v = Smart.Advertised_refs.map ~fuid:Uid.of_hex ~fref:Ref.v v in let uids, refs = references refs (Smart.Advertised_refs.refs v) in - Smart.Context.update ctx (Smart.Advertised_refs.capabilities v); + let server_caps = Smart.Advertised_refs.capabilities v in + Smart.Context.replace_server_caps ctx server_caps; return (uids, refs) in - let ctx = Smart.Context.make capabilities in + let ctx = Smart.Context.make ~client_caps in let negotiator = Neg.make ~compare:Uid.compare in Neg.tips sched access store negotiator |> prj >>= fun () -> Smart_flow.run sched fail io flow (prelude ctx) |> prj diff --git a/src/not-so-smart/find_common.ml b/src/not-so-smart/find_common.ml index 5289b4df1..41e965b20 100644 --- a/src/not-so-smart/find_common.ml +++ b/src/not-so-smart/find_common.ml @@ -108,13 +108,16 @@ let find_common ({ bind; return } as scheduler) io flow Smart.( let uid = (to_hex <.> fst) uid in let others = List.map (to_hex <.> fst) others in - let capabilities, _ = Smart.Context.capabilities ctx in + let { Smart.Context.client_caps; _ } = + Smart.Context.capabilities ctx + in let deepen = (deepen :> [ `Depth of int | `Not of string | `Timestamp of int64 ] option) in send ctx want - (Want.want ~capabilities ~shallows:shallowed ?deepen uid ~others)) + (Want.want ~capabilities:client_caps ~shallows:shallowed ?deepen uid + ~others)) >>= fun () -> (match deepen with | None -> return () diff --git a/src/not-so-smart/push.ml b/src/not-so-smart/push.ml index 3375c65a6..0567e0679 100644 --- a/src/not-so-smart/push.ml +++ b/src/not-so-smart/push.ml @@ -39,8 +39,8 @@ struct pp_error = Flow.pp_error; } - let push ?(uses_git_transport = true) ~capabilities:caps cmds ~host path flow - store access push_cfg pack = + let push ?(uses_git_transport = true) ~capabilities:client_caps cmds ~host + path flow store access push_cfg pack = let fiber ctx = let open Smart in let* () = @@ -50,10 +50,11 @@ struct else return () in let* v = recv ctx advertised_refs in - Context.update ctx (Smart.Advertised_refs.capabilities v); + let server_caps = Smart.Advertised_refs.capabilities v in + Context.replace_server_caps ctx server_caps; return (Smart.Advertised_refs.map ~fuid:Uid.of_hex ~fref:Ref.v v) in - let ctx = Smart.Context.make caps in + let ctx = Smart.Context.make ~client_caps in Smart_flow.run sched fail io flow (fiber ctx) |> prj >>= fun advertised_refs -> Pck.commands sched diff --git a/src/not-so-smart/smart.ml b/src/not-so-smart/smart.ml index 5aadd5092..be2127b81 100644 --- a/src/not-so-smart/smart.ml +++ b/src/not-so-smart/smart.ml @@ -111,12 +111,28 @@ type ('a, 'err) t = ('a, 'err) State.t = | Error of 'err module Context = struct - type t = State.Context.t + type capabilities = { + client_caps : Capability.t list; + server_caps : Capability.t list; + } - let make = State.Context.make - let update = State.Context.update - let is_cap_shared = State.Context.is_cap_shared - let capabilities = State.Context.capabilities + let pp_capabilities _ppf _v = () + + include State.Context + + type nonrec t = capabilities t + + let make ~client_caps = make { client_caps; server_caps = [] } + let pp ppf v = pp pp_capabilities ppf v + let capabilities ctx = context ctx + + let replace_server_caps ctx caps = + update ~f:(fun ~old_ctx -> { old_ctx with server_caps = caps }) ctx + + let is_cap_shared ctx cap = + let { client_caps; server_caps } = capabilities ctx in + let is_cap_in caps = List.exists (fun c -> Capability.equal c cap) caps in + is_cap_in client_caps && is_cap_in server_caps end include Witness @@ -143,7 +159,7 @@ let send_pack ?(stateless = false) side_band = let packet ~trim = Packet trim let send_advertised_refs : _ send = Advertised_refs -include State.Scheduler (State.Context) (Value) +include State.Scheduler (Context) (Value) let pp_error ppf = function | #Protocol.Encoder.error as err -> Protocol.Encoder.pp_error ppf err @@ -151,6 +167,6 @@ let pp_error ppf = function module Unsafe = struct let write context packet = - let encoder = State.Context.encoder context in + let encoder = Context.encoder context in Protocol.Encoder.unsafe_encode_packet encoder ~packet end diff --git a/src/not-so-smart/smart.mli b/src/not-so-smart/smart.mli index bce65e9e6..72f840b3b 100644 --- a/src/not-so-smart/smart.mli +++ b/src/not-so-smart/smart.mli @@ -194,10 +194,15 @@ val pp_error : error Fmt.t module Context : sig type t - val make : Capability.t list -> t - val update : t -> Capability.t list -> unit + type capabilities = { + client_caps : Capability.t list; + server_caps : Capability.t list; + } + + val make : client_caps:Capability.t list -> t + val capabilities : t -> capabilities + val replace_server_caps : t -> Capability.t list -> unit val is_cap_shared : t -> Capability.t -> bool - val capabilities : t -> Capability.t list * Capability.t list end type 'a send diff --git a/src/not-so-smart/state.ml b/src/not-so-smart/state.ml index e44057a74..53502d9e6 100644 --- a/src/not-so-smart/state.ml +++ b/src/not-so-smart/state.ml @@ -36,35 +36,27 @@ end module Context = struct open Pkt_line - type t = { + type 'ctx t = { encoder : Encoder.encoder; decoder : Decoder.decoder; - mutable capabilities : Capability.t list * Capability.t list; + mutable ctx : 'ctx; } type encoder = Encoder.encoder type decoder = Decoder.decoder - let pp _ppf _t = () + let pp _pp_ctx _ppf _t = () - let make capabilities = - { - encoder = Encoder.create (); - decoder = Decoder.create (); - capabilities = capabilities, []; - } + let make ctx = + { encoder = Encoder.create (); decoder = Decoder.create (); ctx } let encoder { encoder; _ } = encoder let decoder { decoder; _ } = decoder - let capabilities { capabilities; _ } = capabilities - - let update ({ capabilities = client_side, _; _ } as t) server_side = - t.capabilities <- client_side, server_side + let context { ctx; _ } = ctx - let is_cap_shared t capability = - let client_side, server_side = t.capabilities in - let a = List.exists (Capability.equal capability) client_side in - a && List.exists (Capability.equal capability) server_side + let update t ~(f : old_ctx:'ctx -> 'ctx) = + let new_ctx = f ~old_ctx:t.ctx in + t.ctx <- new_ctx end module Scheduler diff --git a/src/not-so-smart/state.mli b/src/not-so-smart/state.mli index fa6748125..2549d88cd 100644 --- a/src/not-so-smart/state.mli +++ b/src/not-so-smart/state.mli @@ -33,19 +33,16 @@ module type VALUE = sig end module Context : sig - open Pkt_line + type 'ctx t + type encoder = Pkt_line.Encoder.encoder + type decoder = Pkt_line.Decoder.decoder - include - CONTEXT - with type encoder = Encoder.encoder - and type decoder = Decoder.decoder - - val make : Capability.t list -> t - (** [make caps] creates [Context.t] with client's capabilities [caps] *) - - val capabilities : t -> Capability.t list * Capability.t list - val update : t -> Capability.t list -> unit - val is_cap_shared : t -> Capability.t -> bool + val pp : 'ctx Fmt.t -> 'ctx t Fmt.t + val encoder : 'ctx t -> encoder + val decoder : 'ctx t -> decoder + val make : 'ctx -> 'ctx t + val context : 'ctx t -> 'ctx + val update : 'ctx t -> f:(old_ctx:'ctx -> 'ctx) -> unit end module Scheduler From 967e86d41c1858841399196273f28c1c1badc938 Mon Sep 17 00:00:00 2001 From: dinosaure Date: Sat, 9 Jan 2021 18:15:14 +0100 Subject: [PATCH 2/6] git-nss is integrated into git package --- test/smart/dune | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/test/smart/dune b/test/smart/dune index 893b00f6e..32231b33d 100644 --- a/test/smart/dune +++ b/test/smart/dune @@ -16,9 +16,7 @@ (rule (alias runtest) - (package git-unix) - (enabled_if - (= %{os_type} "Unix")) + (package git) (deps (:test test.exe) pack-testzone-0.pack From ac0e22e20de1e3d3ab692335ce83dd8c12cd7996 Mon Sep 17 00:00:00 2001 From: Ulugbek Abdullaev Date: Mon, 28 Dec 2020 18:13:54 +0500 Subject: [PATCH 3/6] * refactor nss/protocol.(ml/mli)/Encoder and add comments * rename 'decoder_from' to more conventional 'of_string' * add safer version of peek pkt that also support git wire protocol v2 pkts: delim-pkt and response-end-pkt * move 'prompt_pkt' to 'decoder.mli' to reuse it in git wire proto v2 * add 'read_pkt' * add 'junk_chars' fn to 'Decoder' to increase 'decoder.pos' by 'n' * move 'bind' and '>>=' from nss/protocol.ml to pkt_line.decoder * [wip] support wire proto v2 capabilities * add 'Ls_refs', 'Fetch_command' modules to represent commands 'ls-refs' and 'fetch' respectively; * add 'Encoder' module to wire-proto-v2 with support for encoding command requests and copy-paste NSS's 'encode_proto_request' * add some comments to better define parts of a packet line: specific names for 4 bytes that encode packet length, the bytes that follow the length bytes, etc. * rename length calculating function 'pkt_len' to 'encoded_pkt_len' that returns the value hex-encoded in the first 4 bytes of the packet line and 'pkt_len_at_least_4' returns 'max 4 (encoded_pkt_len pkt)' * copy-paste 'Proto_request' module from NSS * update 'response' type in proto-v2 'Protocol' * add 'Extended_pkt_line_decoder' that provides more functionality than 'Pkt_line.Decoder' but not specific to the protocol * add decoding for all commands of wire proto v2 * reflect changes after 'mimic' lib introduction * make 'smart_flow' more understandable * reduce dup code, e.g., (>>=) * reorganize stuff closer to its use * rename stuff for more clarity * move smart protocol (wire proto v1)-based 'fetch' code to separate modules * functorize 'Smart_flow' * rename 'Smart_flow' to 'State_flow' * add mli file to 'State_flow' * improve 'nss/state.ml' API: - it improves cases when we want to "open" the module to get infix/syntax operators - it also make the API more uniform and rich, e.g., adds "map" fn * rename "fail" to "io_raise": 1) avoid clash with "fail" from "smart"/"wire_proto_v2" 2) to highlight that it causes "exception"al behavior * add support for "ls-refs" command (without args) * fix log.debug use and its message --- src/not-so-smart/capability_v2.ml | 32 ++ src/not-so-smart/capability_v2.mli | 9 + src/not-so-smart/decoder.ml | 71 ++- src/not-so-smart/decoder.mli | 55 ++- src/not-so-smart/dune | 32 +- src/not-so-smart/encoder.ml | 19 +- src/not-so-smart/encoder.mli | 6 + src/not-so-smart/fetch.ml | 189 +++++--- src/not-so-smart/fetch.mli | 58 ++- src/not-so-smart/find_common.ml | 200 +++++---- src/not-so-smart/proto_vals_v2.ml | 672 +++++++++++++++++++++++++++++ src/not-so-smart/protocol.ml | 14 +- src/not-so-smart/push.ml | 2 + src/not-so-smart/smart.mli | 2 +- src/not-so-smart/smart_flow.ml | 52 --- src/not-so-smart/smart_flow.mli | 13 - src/not-so-smart/smart_git.ml | 65 +-- src/not-so-smart/state.ml | 21 +- src/not-so-smart/state.mli | 21 +- src/not-so-smart/state_flow.ml | 76 ++++ src/not-so-smart/state_flow.mli | 24 ++ src/not-so-smart/wire_proto_v2.ml | 111 +++++ test/smart/dune | 10 +- test/smart/pipe.ml | 69 +++ test/smart/test.ml | 549 ++++++++++++++--------- 25 files changed, 1862 insertions(+), 510 deletions(-) create mode 100644 src/not-so-smart/capability_v2.ml create mode 100644 src/not-so-smart/capability_v2.mli create mode 100644 src/not-so-smart/proto_vals_v2.ml delete mode 100644 src/not-so-smart/smart_flow.ml delete mode 100644 src/not-so-smart/smart_flow.mli create mode 100644 src/not-so-smart/state_flow.ml create mode 100644 src/not-so-smart/state_flow.mli create mode 100644 src/not-so-smart/wire_proto_v2.ml create mode 100644 test/smart/pipe.ml diff --git a/src/not-so-smart/capability_v2.ml b/src/not-so-smart/capability_v2.ml new file mode 100644 index 000000000..c65d7a01a --- /dev/null +++ b/src/not-so-smart/capability_v2.ml @@ -0,0 +1,32 @@ +open Astring + +type t = + [ `Atom of string + | `Key_value of string * string + | `Command_features of string * string list ] + +(* TODO: integrate better support for known capabilities and commands + e.g., ls-refs, etc. *) +let of_string s = + match String.cut ?rev:None ~sep:"=" s with + | None -> `Atom s + | Some (k, v) -> ( + match String.cuts ?rev:None ?empty:None ~sep:" " v with + | [] -> raise @@ Invalid_argument s + | [ v ] -> `Key_value (k, v) + | command :: features -> `Command_features (command, features)) + +let to_string = function + | `Atom s -> s + | `Key_value (k, v) -> Fmt.str "%s=%s" k v + | `Command_features (s, s_lst) -> + Fmt.str "%s=%s" s (String.concat ~sep:" " s_lst) + +let equal t1 t2 = + match t1, t2 with + | `Atom s1, `Atom s2 -> String.equal s1 s2 + | `Key_value (k1, v1), `Key_value (k2, v2) -> + String.equal k1 k2 && String.equal v1 v2 + | `Command_features (c1, fs1), `Command_features (c2, fs2) -> + String.equal c1 c2 && List.for_all2 String.equal fs1 fs2 + | _ -> false diff --git a/src/not-so-smart/capability_v2.mli b/src/not-so-smart/capability_v2.mli new file mode 100644 index 000000000..864c6c8ef --- /dev/null +++ b/src/not-so-smart/capability_v2.mli @@ -0,0 +1,9 @@ +type t = + private + [ `Atom of string + | `Key_value of string * string + | `Command_features of string * string list ] + +val of_string : string -> t +val to_string : t -> string +val equal : t -> t -> bool diff --git a/src/not-so-smart/decoder.ml b/src/not-so-smart/decoder.ml index 763cc2261..44555807c 100644 --- a/src/not-so-smart/decoder.ml +++ b/src/not-so-smart/decoder.ml @@ -1,9 +1,12 @@ +module Log = (val let src = Logs.Src.create "nss/decoder" in + Logs.src_log src : Logs.LOG) + type decoder = { buffer : Bytes.t; mutable pos : int; mutable max : int } let io_buffer_size = 65536 let create () = { buffer = Bytes.create io_buffer_size; pos = 0; max = 0 } -let decoder_from x = +let of_string x = let max = String.length x in let buffer = Bytes.of_string x in { buffer; pos = 0; max } @@ -53,6 +56,17 @@ exception Leave of error info let return (type v) (v : v) _ : (v, 'err) state = Done v +let rec bind x ~f = + match x with + | Done v -> f v + | Read { buffer; off; len; continue; eof } -> + let continue len = bind (continue len) ~f in + let eof () = bind (eof ()) ~f in + Read { buffer; off; len; continue; eof } + | Error _ as err -> err + +let ( >>= ) x f = bind x ~f + let safe : (decoder -> ('v, ([> error ] as 'err)) state) -> decoder -> ('v, 'err) state = @@ -254,11 +268,62 @@ let peek_pkt decoder = if len >= 4 then decoder.buffer, decoder.pos + 4, len - 4 else decoder.buffer, decoder.pos + 4, 0 +type pkt = + | Flush_pkt (** length in hex 0000 *) + | Delim_pkt (** 0001 *) + | Response_end_pkt (** 0002 *) + | Invalid_len_pkt of int (** 0003 or 0004 *) + | Pkt of (int * string) + (** e.g., 0008done is represented as (8, "done"); + we want to keep length to avoid calling [pkt_len_unsafe] several times; + we can't do [String.length str] + 4 because there may be LF, which is trimmed away, + so we should rely on the length encoded in the pkt *) + +let peek_pkt' ?(trim = true) ({ buffer; pos; _ } as decoder) = + match pkt_len_unsafe decoder with + | 0 -> Flush_pkt + | 1 -> Delim_pkt + | 2 -> Response_end_pkt + | (3 | 4) as i -> Invalid_len_pkt i + | i when i < 0 -> Invalid_len_pkt i + | pkt_len -> + let pkt_content_len = pkt_len - 4 in + let pkt_content (* pkt excluding 1st 4 bytes, ie pkt len *) = + Bytes.create pkt_content_len + in + Bytes.blit buffer (pos + 4) pkt_content 0 pkt_content_len; + let pkt_content = if trim then Bytes.trim pkt_content else pkt_content in + Pkt (pkt_len, Bytes.to_string pkt_content) + | exception Invalid_argument s -> + Fmt.failwith + "peek_pkt: decoder.buffer didn't contain 4 'length' bytes: %s" s + +let encoded_pkt_len = function + | Flush_pkt -> 0 + | Delim_pkt -> 1 + | Response_end_pkt -> 2 + | Invalid_len_pkt i -> i + | Pkt (l, _) -> l + +let pkt_len_at_least_4 pkt = max 4 (encoded_pkt_len pkt) + +let read_pkt ?(trim = true) ({ pos; _ } as decoder) = + let pkt = peek_pkt' ~trim decoder in + let advance_n_bytes = pkt_len_at_least_4 pkt in + decoder.pos <- pos + advance_n_bytes; + pkt + +let is_flush_pkt = function Flush_pkt -> true | _ -> false + let junk_pkt decoder = let len = pkt_len_unsafe decoder in if len < 4 then decoder.pos <- decoder.pos + 4 else decoder.pos <- decoder.pos + len +let junk_chars n ({ pos; _ } as decoder) = + assert (n >= 4); + decoder.pos <- pos + n + let peek_while_eol decoder = let idx = ref decoder.pos in let chr = ref '\000' in @@ -297,3 +362,7 @@ let peek_while_eol_or_space decoder = if !idx < end_of_input decoder && ((!chr = '\n' && !has_cr) || !chr = ' ') then decoder.buffer, decoder.pos, !idx + 1 - decoder.pos else leave_with decoder `Expected_eol_or_space + +let rec prompt_pkt ?strict k decoder = + if at_least_one_pkt decoder then k decoder + else prompt ?strict (prompt_pkt ?strict k) decoder diff --git a/src/not-so-smart/decoder.mli b/src/not-so-smart/decoder.mli index cd5b44428..ff04b83b4 100644 --- a/src/not-so-smart/decoder.mli +++ b/src/not-so-smart/decoder.mli @@ -1,13 +1,27 @@ (** Module for decoding Git pkt lines, as specified at https://github.com/git/git/blob/master/Documentation/technical/protocol-common.txt + We define a "packet line" (aka a "packet") as + + | 4 bytes || (enc-pkt-len)-4 | + [ enc-pkt-len ][ pkt-content ] + |------- pkt-len ------| + + Example: "0009done\n" where [enc-pkt-len = 4] and [pkt-content = "done"] given we + usually trim LF ("\n"). + + "Encoded" packet length, [enc-pkt-len], is the first 4 bytes in the packet + that encode the length of the packet in hex. It can have specific values of 0, 1, 2 + to encode flush, delimiter, and message (response end) packets respectively. + Otherwise, it should be >= 4, i.e., 4 length bytes + the length of the packet content. + In the docs, we define [min_pkt_len = 4] as in specs. *) type decoder = { buffer : bytes; mutable pos : int; mutable max : int } val io_buffer_size : int val create : unit -> decoder -val decoder_from : string -> decoder +val of_string : string -> decoder val end_of_input : decoder -> int type error = @@ -39,6 +53,10 @@ type ('v, 'err) state = } | Error of 'err info +val return : 'v -> decoder -> ('v, 'err) state +val bind : ('a, 'b) state -> f:('a -> ('c, 'b) state) -> ('c, 'b) state +val ( >>= ) : ('a, 'b) state -> ('a -> ('c, 'b) state) -> ('c, 'b) state + val leave_with : decoder -> error -> 'never (** [leave_with d error] raises [Leave { error; buffer = d.buffer; committed = d.pos }] @@ -50,7 +68,6 @@ val safe : if exception [Leave err] is raised, the function returns [Error of err] *) val fail : decoder -> ([> error ] as 'err) -> ('v, 'err) state -val return : 'v -> decoder -> ('v, 'err) state val peek_char : decoder -> char option val string : string -> decoder -> unit val junk_char : decoder -> unit @@ -74,9 +91,43 @@ val peek_while_eol : decoder -> bytes * int * int val peek_while_eol_or_space : decoder -> bytes * int * int val peek_pkt : decoder -> bytes * int * int +type pkt = + | Flush_pkt (** length in hex 0000 *) + | Delim_pkt (** 0001 *) + | Response_end_pkt (** 0002 *) + | Invalid_len_pkt of int (** 0003 or 0004; the latter is meaningless *) + | Pkt of (int * string) + (** (enc-pkt-len, pkt-content) e.g., 0008done is represented as (8, "done") *) + +val is_flush_pkt : pkt -> bool + +val encoded_pkt_len : pkt -> int +(** returns the length of packet encoded in first 4 bytes of the packet + e.g., for a packet "0008done", 8 is returned *) + +val pkt_len_at_least_4 : pkt -> int +(** [pkt_len pkt] returns [max 4 (encoded_pkt_len pkt)], + i.e., the returned value >= 4 *) + +val peek_pkt' : ?trim:bool -> decoder -> pkt + +val read_pkt : ?trim:bool -> decoder -> pkt +(** returns the packet and advances [decoder.pos] to packet's full length *) + val junk_pkt : decoder -> unit (** increase [decoder.pos] by [max min_pkt_len pkt_len], where [pkt_len] is the length of the pkt line starting at the current value of [decoder.pos] (before increasing) and [min_pkt_len = 4]. @raise Invalid_argument if there aren't 4 bytes representing the length *) + +val junk_chars : int -> decoder -> unit +(** [junk_chars n d] increases [d.pos] by [n]; + can be used similar to [junk_pkt] when the length of a packet line is known from + [peek_pkt], for example. *) + +val prompt_pkt : + ?strict:bool -> + (decoder -> ('a, ([> error ] as 'b)) state) -> + decoder -> + ('a, 'b) state diff --git a/src/not-so-smart/dune b/src/not-so-smart/dune index a16b23524..38b30d3de 100644 --- a/src/not-so-smart/dune +++ b/src/not-so-smart/dune @@ -2,13 +2,27 @@ (name pkt_line) (public_name git.nss.pkt-line) (modules decoder encoder) - (libraries astring fmt)) + (libraries astring fmt logs)) + +(library + (name state) + (public_name git.nss.state) + (modules state) + (libraries git.nss.pkt-line fmt)) (library (name smart) (public_name git.nss.smart) - (modules smart filter capability state protocol) - (libraries git.nss.pkt-line result rresult ipaddr domain-name astring fmt)) + (modules smart filter capability protocol) + (libraries git.nss.pkt-line git.nss.state result rresult ipaddr domain-name + astring fmt)) + +(library + (name wire_proto_v2) + (public_name git.nss.wire-proto-v2) + (modules capability_v2 proto_vals_v2 wire_proto_v2) + (libraries astring domain-name emile fmt git.nss.pkt-line git.nss.sigs + git.nss.state logs mimic result rresult uri)) (library (name sigs) @@ -17,10 +31,10 @@ (libraries fmt cstruct)) (library - (name smart_flow) - (public_name git.nss.smart-flow) - (modules smart_flow) - (libraries cstruct fmt git.nss.sigs git.nss.smart logs)) + (name state_flow) + (public_name git.nss.state-flow) + (modules state_flow) + (libraries cstruct fmt git.nss.sigs git.nss.state git.nss.smart logs)) (library (name hkt) @@ -32,7 +46,7 @@ (name neg) (public_name git.nss.neg) (modules neg find_common default) - (libraries fmt rresult cstruct sigs logs psq smart git.nss.smart-flow)) + (libraries fmt rresult cstruct sigs logs psq smart git.nss.state-flow)) (library (name pck) @@ -45,7 +59,7 @@ (public_name git.nss) (modules nss fetch push) (libraries fmt result rresult logs ipaddr domain-name smart sigs neg pck - git.nss.smart-flow)) + git.nss.state-flow git.nss.state wire_proto_v2)) (library (name unixiz) diff --git a/src/not-so-smart/encoder.ml b/src/not-so-smart/encoder.ml index a68f5efb3..a1f2bdd78 100644 --- a/src/not-so-smart/encoder.ml +++ b/src/not-so-smart/encoder.ml @@ -42,17 +42,14 @@ let flush k0 encoder = k1 0 else k0 encoder -let write encoder s = - let max = Bytes.length encoder.payload in - let go j l encoder = - let rem = max - encoder.pos in - let len = if l > rem then rem else l in - Bytes.blit_string s j encoder.payload encoder.pos len; - encoder.pos <- encoder.pos + len; - if len < l then leave_with encoder `No_enough_space - in - (* XXX(dinosaure): should never appear, but avoid continuation allocation. *) - go 0 (String.length s) encoder +let write ({ pos; payload } as encoder) s = + let max = Bytes.length payload in + let s_len = String.length s in + let rem = max - pos in + let wr_n_bytes = min rem s_len in + Bytes.blit_string s 0 payload pos wr_n_bytes; + encoder.pos <- pos + wr_n_bytes; + if wr_n_bytes < s_len then leave_with encoder `No_enough_space let blit encoder ~buf ~off ~len = let max = Bytes.length encoder.payload in diff --git a/src/not-so-smart/encoder.mli b/src/not-so-smart/encoder.mli index eaab5fa98..30328fcfc 100644 --- a/src/not-so-smart/encoder.mli +++ b/src/not-so-smart/encoder.mli @@ -19,5 +19,11 @@ type 'err state = val safe : (encoder -> ([> error ] as 'err) state) -> encoder -> 'err state val flush : (encoder -> ([> error ] as 'err) state) -> encoder -> 'err state + val write : encoder -> string -> unit +(** [write e s] writes [s] into [e.payload] if there is enough space, i.e., + [Bytes.length e e.payload - e.pos > String.length s]. Otherwise, raises. + + @raise Leave `No_enough_space if [String.length ]*) + val blit : encoder -> buf:string -> off:int -> len:int -> unit diff --git a/src/not-so-smart/fetch.ml b/src/not-so-smart/fetch.ml index 4b33d3cc6..585a4fb17 100644 --- a/src/not-so-smart/fetch.ml +++ b/src/not-so-smart/fetch.ml @@ -1,22 +1,24 @@ -type configuration = Neg.configuration - -let multi_ack capabilities = - match - ( List.exists (( = ) `Multi_ack) capabilities, - List.exists (( = ) `Multi_ack_detailed) capabilities ) - with - | true, true | false, true -> `Detailed - | true, false -> `Some - | false, false -> `None - -let no_done = List.exists (( = ) `No_done) - -let configuration ?(stateless = false) capabilities = - { - Neg.stateless; - Neg.no_done = (if stateless then true else no_done capabilities); - Neg.multi_ack = multi_ack capabilities; - } +module V1 = struct + type configuration = Neg.configuration + + let multi_ack capabilities = + match + ( List.exists (( = ) `Multi_ack) capabilities, + List.exists (( = ) `Multi_ack_detailed) capabilities ) + with + | true, true | false, true -> `Detailed + | true, false -> `Some + | false, false -> `None + + let no_done = List.exists (( = ) `No_done) + + let configuration ?(stateless = false) capabilities = + { + Neg.stateless; + Neg.no_done = (if stateless then true else no_done capabilities); + Neg.multi_ack = multi_ack capabilities; + } +end module S = Sigs @@ -42,7 +44,7 @@ struct return = (fun x -> inj (return x)); } - let fail exn = + let io_raise exn = let fail = IO.fail exn in inj fail @@ -72,59 +74,104 @@ struct in List.fold_left fold [] have |> List.split - let fetch_v1 ?(uses_git_transport = false) ?(push_stdout = ignore) - ?(push_stderr = ignore) ~capabilities ?deepen ?want:(refs = `None) ~host - path flow store access fetch_cfg pack = - let client_caps = - (* XXX(dinosaure): HTTP ([stateless]) enforces no-done capabilities. Otherwise, you never - will receive the PACK file. *) - if fetch_cfg.Neg.no_done && not (no_done capabilities) then - `No_done :: capabilities - else capabilities - in - let prelude ctx = - let open Smart in + module V1 = struct + module Smart_flow = State_flow.Make (Smart) + + let fetch ?(uses_git_transport = false) ?(push_stdout = ignore) + ?(push_stderr = ignore) ~capabilities ?deepen ?want:(refs = `None) ~host + path flow store access fetch_cfg push_pack = + let client_caps = + (* XXX(dinosaure): HTTP ([stateless]) enforces no-done capabilities. Otherwise, you never + will receive the PACK file. *) + if fetch_cfg.Neg.no_done && not (V1.no_done capabilities) then + `No_done :: capabilities + else capabilities + in + + let prelude ctx = + let open Smart in + let* () = + if uses_git_transport then + send ctx proto_request + (Proto_request.upload_pack ~host ~version:1 path) + else return () + in + let* v = recv ctx advertised_refs in + let v = Smart.Advertised_refs.map ~fuid:Uid.of_hex ~fref:Ref.v v in + let uids, refs = references refs (Smart.Advertised_refs.refs v) in + let server_caps = Smart.Advertised_refs.capabilities v in + Smart.Context.replace_server_caps ctx server_caps; + return (uids, refs) + in + + let ctx = Smart.Context.make ~client_caps in + + Smart_flow.run sched io_raise io flow (prelude ctx) |> prj + >>= fun (uids, refs) -> + let hex = + { Neg.to_hex = Uid.to_hex; of_hex = Uid.of_hex; compare = Uid.compare } + in + + let negotiator = Neg.make ~compare:Uid.compare in + Neg.tips sched access store negotiator |> prj >>= fun () -> + Neg.find_common sched io flow fetch_cfg hex access store negotiator ctx + ?deepen uids + |> prj + >>= function + | `Close -> return [] + | `Continue res -> + let recv_pack_state ctx = + let open Smart in + let side_band = + Smart.Context.is_cap_shared ctx `Side_band + || Smart.Context.is_cap_shared ctx `Side_band_64k + in + recv ctx (recv_pack ~side_band ~push_stdout ~push_stderr push_pack) + in + if res < 0 then Log.warn (fun m -> m "No common commits"); + let rec read_pack () = + Log.debug (fun m -> m "Reading PACK file..."); + Smart_flow.run sched io_raise io flow (recv_pack_state ctx) |> prj + >>= fun should_continue -> + if should_continue then read_pack () else return () + in + Log.debug (fun m -> m "Start to download PACK file."); + read_pack () >>= fun () -> return (List.combine refs uids) + end + + module V2 = struct + module State_flow = State_flow.Make (Wire_proto_v2) + + let connect ?(uses_git_transport = false) ~host ~path ctx = + let open Wire_proto_v2.Syntax in + let return = Wire_proto_v2.return in let* () = if uses_git_transport then - send ctx proto_request - (Proto_request.upload_pack ~host ~version:1 path) + Wire_proto_v2.( + send ctx Witness.Proto_request + (Proto_vals_v2.Proto_request.upload_pack ~host ~version:2 path)) else return () in - let* v = recv ctx advertised_refs in - let v = Smart.Advertised_refs.map ~fuid:Uid.of_hex ~fref:Ref.v v in - let uids, refs = references refs (Smart.Advertised_refs.refs v) in - let server_caps = Smart.Advertised_refs.capabilities v in - Smart.Context.replace_server_caps ctx server_caps; - return (uids, refs) - in - let ctx = Smart.Context.make ~client_caps in - let negotiator = Neg.make ~compare:Uid.compare in - Neg.tips sched access store negotiator |> prj >>= fun () -> - Smart_flow.run sched fail io flow (prelude ctx) |> prj - >>= fun (uids, refs) -> - let hex = - { Neg.to_hex = Uid.to_hex; of_hex = Uid.of_hex; compare = Uid.compare } - in - Neg.find_common sched io flow fetch_cfg hex access store negotiator ctx - ?deepen uids - |> prj - >>= function - | `Close -> return [] - | `Continue res -> - let pack ctx = - let open Smart in - let side_band = - Smart.Context.is_cap_shared ctx `Side_band - || Smart.Context.is_cap_shared ctx `Side_band_64k - in - recv ctx (recv_pack ~side_band ~push_stdout ~push_stderr pack) - in - if res < 0 then Log.warn (fun m -> m "No common commits"); - let rec go () = - Log.debug (fun m -> m "Read PACK file."); - Smart_flow.run sched fail io flow (pack ctx) |> prj - >>= fun continue -> if continue then go () else return () - in - Log.debug (fun m -> m "Start to download PACK file."); - go () >>= fun () -> return (List.combine refs uids) + Wire_proto_v2.(recv ctx Witness.Capability_advertisement) + + let get_server_capabilities ?(uses_git_transport = false) ~host ~path ctx + flow = + let get_caps ctx = + let open Wire_proto_v2.Syntax in + let* caps = connect ~uses_git_transport ~host ~path ctx in + let* () = Wire_proto_v2.send ctx Flush () in + Wire_proto_v2.return caps + in + State_flow.run sched io_raise io flow (get_caps ctx) |> prj + + let ls_refs_request ?(uses_git_transport = false) ~host ~path ctx flow req = + let ls_refs_resp = + let open Wire_proto_v2.Syntax in + let* caps = connect ~uses_git_transport ~host ~path ctx in + (* TODO: how are server caps handled on the client side? *) + let* () = Wire_proto_v2.send ctx Ls_refs_req (`Client_caps caps, req) in + Wire_proto_v2.recv ctx Ls_refs_res + in + State_flow.run sched io_raise io flow ls_refs_resp |> prj + end end diff --git a/src/not-so-smart/fetch.mli b/src/not-so-smart/fetch.mli index 96c0aefe5..33dfec5dc 100644 --- a/src/not-so-smart/fetch.mli +++ b/src/not-so-smart/fetch.mli @@ -1,8 +1,11 @@ open Sigs -type configuration = Neg.configuration +module V1 : sig + type configuration = Neg.configuration -val configuration : ?stateless:bool -> Smart.Capability.t list -> configuration + val configuration : + ?stateless:bool -> Smart.Capability.t list -> configuration +end module Make (Scheduler : SCHED) @@ -10,19 +13,40 @@ module Make (Flow : FLOW with type 'a fiber = 'a Scheduler.s) (Uid : UID) (Ref : REF) : sig - val fetch_v1 : - ?uses_git_transport:bool -> - ?push_stdout:(string -> unit) -> - ?push_stderr:(string -> unit) -> - capabilities:Smart.Capability.t list -> - ?deepen:[ `Depth of int | `Timestamp of int64 ] -> - ?want:[ `All | `Some of Ref.t list | `None ] -> - host:[ `Addr of Ipaddr.t | `Domain of [ `host ] Domain_name.t ] -> - string -> - Flow.t -> - (Uid.t, Uid.t * int ref * int64, 'g) store -> - (Uid.t, _, Uid.t * int ref * int64, 'g, Scheduler.t) access -> - configuration -> - (string * int * int -> unit) -> - (Ref.t * Uid.t) list IO.t + module V1 : sig + val fetch : + ?uses_git_transport:bool -> + ?push_stdout:(string -> unit) -> + ?push_stderr:(string -> unit) -> + capabilities:Smart.Capability.t list -> + ?deepen:[ `Depth of int | `Timestamp of int64 ] -> + ?want:[ `All | `Some of Ref.t list | `None ] -> + host:[ `Addr of Ipaddr.t | `Domain of [ `host ] Domain_name.t ] -> + string -> + Flow.t -> + (Uid.t, Uid.t * int ref * int64, 'g) store -> + (Uid.t, _, Uid.t * int ref * int64, 'g, Scheduler.t) access -> + V1.configuration -> + (string * int * int -> unit) -> + (Ref.t * Uid.t) list IO.t + end + + module V2 : sig + val get_server_capabilities : + ?uses_git_transport:bool -> + host:[ `host ] Domain_name.t -> + path:string -> + Wire_proto_v2.Context.t -> + Flow.t -> + Wire_proto_v2.Capability.t list IO.t + + val ls_refs_request : + ?uses_git_transport:bool -> + host:[ `host ] Domain_name.t -> + path:string -> + Wire_proto_v2.Context.capabilities State.Context.t -> + Flow.t -> + Wire_proto_v2.Proto_vals_v2.Ls_refs.request -> + Wire_proto_v2.Proto_vals_v2.Ls_refs.response IO.t + end end diff --git a/src/not-so-smart/find_common.ml b/src/not-so-smart/find_common.ml index 41e965b20..d425ad1cf 100644 --- a/src/not-so-smart/find_common.ml +++ b/src/not-so-smart/find_common.ml @@ -1,31 +1,8 @@ open Sigs -open Smart_flow - -let ( <.> ) f g x = f (g x) module Log = (val let src = Logs.Src.create "find-common" in Logs.src_log src : Logs.LOG) -let _initial_flush = 16 -let _max_in_vain = 256 -let _large_flush = 16384 -let _pipe_safe_flush = 32 - -(* XXX(dinosaure): this part is really **ugly**! But we must follow the same - behaviour of [git]. Instead to understand the synchronisation process of [git] - with Smart.v1 and implement a state of the art synchronisation algorithm, I - translated as is [fetch-pack.c:find_common] in OCaml. *) - -let unsafe_write_have ctx hex = - let packet = Fmt.str "have %s\n" hex in - Smart.Unsafe.write ctx packet - -let next_flush stateless count = - if stateless then - if count < _large_flush then count lsl 1 else count * 11 / 10 - else if count < _pipe_safe_flush then count lsl 1 - else count + _pipe_safe_flush - type configuration = { stateless : bool; mutable multi_ack : [ `None | `Some | `Detailed ]; @@ -38,76 +15,116 @@ type 'uid hex = { compare : 'uid -> 'uid -> int; } -let tips { bind; return } { get; deref; locals; _ } store negotiator = - let ( >>= ) = bind in - let ( >>| ) x f = x >>= fun x -> return (f x) in +(* Constants defined by the canoncial git implementation in C *) +let initial_flush = 16 +let max_in_vain = 256 +let large_flush = 16384 +let pipe_safe_flush = 32 - let rec go = function - | [] -> return () - | reference :: others -> - deref store reference - >>= Option.fold ~none:(return None) ~some:(fun uid -> get uid store) - >>| Option.iter (fun obj -> Default.tip negotiator obj) - >>= fun () -> go others - in - locals store >>= go +(** module type that defins common functions for a scheduler, e.g., Lwt or Async *) +module type Io_monad = sig + type s + + val bind : ('a, s) io -> ('a -> ('b, s) io) -> ('b, s) io + val map : ('a -> 'b) -> ('a, s) io -> ('b, s) io + val ( >>= ) : ('a, s) io -> ('a -> ('b, s) io) -> ('b, s) io + val ( >>| ) : ('a, s) io -> ('a -> 'b) -> ('b, s) io + val return : 'a -> ('a, s) io + + val fold_left_s : + f:('a -> 'b -> ('a, s) io) -> init:'a -> 'b list -> ('a, s) io +end + +(** given ['s Sigs.scheduler], returns a module of type [Io_monad] that has + infix operations, etc. This allows us to avoid repetitive redefinition of common + functions. *) +let io_monad (type t) { bind; return } = + (module struct + type s = t + + let bind = bind + let return = return + let map f x = bind x (fun v -> return (f v)) + let ( >>= ) = bind + let ( >>| ) x f = map f x + + let fold_left_s ~f ~init l = + let rec go a = function + | [] -> return a + | x :: r -> bind (f a x) (fun a' -> go a' r) + in + go init l end : Io_monad + with type s = t) + +(* XXX(dinosaure): this part is really **ugly**! But we must follow the same + behaviour of [git]. Instead to understand the synchronisation process of [git] + with Smart.v1 and implement a state of the art synchronisation algorithm, I + translated as is [fetch-pack.c:find_common] in OCaml. *) + +module Smart_flow = State_flow.Make (Smart) + +let tips (type t) scheduler access store negotiator = + let open (val io_monad scheduler : Io_monad with type s = t) in + access.locals store >>= fun ref_lst -> + fold_left_s ref_lst ~init:() ~f:(fun () reference -> + access.deref store reference + >>= Option.fold ~none:(return None) ~some:(fun uid -> + access.get uid store) + >>| Option.iter (fun obj -> Default.tip negotiator obj)) -let consume_shallow_list ({ bind; return } as scheduler) io flow cfg deepen - { of_hex; _ } _access _store ctx = - let ( >>= ) = bind in +let consume_shallow_list (type t) scheduler io flow cfg deepen { of_hex; _ } ctx + = + let open (val io_monad scheduler : Io_monad with type s = t) in if cfg.stateless && Option.is_some deepen then - run scheduler raise io flow Smart.(recv ctx shallows) >>= fun shallows -> - let lst = List.map (Smart.Shallow.map ~f:of_hex) shallows in - return lst + Smart_flow.run scheduler raise io flow Smart.(recv ctx shallows) + >>| fun shallows -> List.map (Smart.Shallow.map ~f:of_hex) shallows else return [] -let handle_shallow ({ bind; return } as scheduler) io flow { of_hex; _ } access - store ctx = - let ( >>= ) = bind in - run scheduler raise io flow Smart.(recv ctx shallows) >>= fun shallows -> - let lst = List.map (Smart.Shallow.map ~f:of_hex) shallows in - let f = function +let handle_shallow (type t) scheduler io flow { of_hex; _ } access store ctx = + let open (val io_monad scheduler : Io_monad with type s = t) in + Smart_flow.run scheduler raise io flow Smart.(recv ctx shallows) + >>= fun shallows -> + let shallows = List.map (Smart.Shallow.map ~f:of_hex) shallows in + fold_left_s shallows ~init:() ~f:(fun () -> function | Smart.Shallow.Shallow uid -> access.shallow store uid - | Smart.Shallow.Unshallow uid -> access.unshallow store uid - in - let rec go = function [] -> return () | h :: t -> f h >>= fun () -> go t in - go lst + | Unshallow uid -> access.unshallow store uid) -let find_common ({ bind; return } as scheduler) io flow - ({ stateless; no_done; _ } as cfg) ({ to_hex; of_hex; compare } as hex) - access store negotiator ctx +let unsafe_write_have ctx hex = + let packet = Fmt.str "have %s\n" hex in + Smart.Unsafe.write ctx packet + +let next_flush stateless count = + if stateless then if count < large_flush then count lsl 1 else count * 11 / 10 + else if count < pipe_safe_flush then count lsl 1 + else count + pipe_safe_flush + +let find_common (type t) scheduler io flow cfg + ({ to_hex; of_hex; compare } as hex) access store negotiator ctx ?(deepen : [ `Depth of int | `Timestamp of int64 ] option) refs = - let ( >>= ) = bind in - let ( >>| ) x f = x >>= fun x -> return (f x) in - let fold_left_s ~f a l = - let rec go a = function - | [] -> return a - | x :: r -> f a x >>= fun a -> go a r - in - go a l - in + let open (val io_monad scheduler : Io_monad with type s = t) in + let { stateless; no_done; _ } = cfg in + let fold acc remote_uid = - Log.debug (fun m -> m "<%s> exists locally?" (to_hex remote_uid)); - access.get remote_uid store >>= function - | Some _ -> return acc - | None -> return ((remote_uid, ref 0) :: acc) + access.get remote_uid store >>| function + | Some _ -> acc + | None -> (remote_uid, ref 0) :: acc in - fold_left_s ~f:fold [] refs + + fold_left_s ~f:fold ~init:[] refs >>| List.sort_uniq (fun (a, _) (b, _) -> compare a b) >>= function | [] -> Log.debug (fun m -> m "Nothing to download."); - run scheduler raise io flow Smart.(send ctx flush ()) >>= fun () -> - return `Close - | uid :: others -> - Log.debug (fun m -> - m "We want %d commit(s)." (List.length (uid :: others))); + Smart_flow.run scheduler raise io flow Smart.(send ctx flush ()) + >>= fun () -> return `Close + | (uid, _) :: others as refs -> + Log.debug (fun m -> m "We want %d commit(s)." (List.length refs)); access.shallowed store >>= fun shallowed -> let shallowed = List.map to_hex shallowed in - run scheduler raise io flow + Smart_flow.run scheduler raise io flow Smart.( - let uid = (to_hex <.> fst) uid in - let others = List.map (to_hex <.> fst) others in + let uid = to_hex uid in + let others = List.map (fun (uid, _) -> to_hex uid) others in let { Smart.Context.client_caps; _ } = Smart.Context.capabilities ctx in @@ -125,7 +142,7 @@ let find_common ({ bind; return } as scheduler) io flow >>= fun () -> let in_vain = ref 0 in let count = ref 0 in - let flush_at = ref _initial_flush in + let flush_at = ref initial_flush in let flushes = ref 0 in let got_continue = ref false in let got_ready = ref false in @@ -147,33 +164,30 @@ let find_common ({ bind; return } as scheduler) io flow m "count: %d, in-vain: %d, flush-at: %d.\n%!" !count !in_vain !flush_at); if !flush_at <= !count then ( - run scheduler raise io flow Smart.(send ctx flush ()) + Smart_flow.run scheduler raise io flow Smart.(send ctx flush ()) >>= fun () -> incr flushes; flush_at := next_flush stateless !count; - if (not stateless) && !count = _initial_flush then go negotiator + if (not stateless) && !count = initial_flush then go negotiator else - consume_shallow_list scheduler io flow cfg None hex access store - ctx + consume_shallow_list scheduler io flow cfg None hex ctx >>= fun _shallows -> let rec loop () = - run scheduler raise io flow Smart.(recv ctx ack) + Smart_flow.run scheduler raise io flow Smart.(recv ctx ack) >>| Smart.Negotiation.map ~f:of_hex >>= fun ack -> match ack with | Smart.Negotiation.NAK -> Log.debug (fun m -> m "Receive NAK."); return `Continue - | Smart.Negotiation.ACK _ -> + | ACK _ -> flushes := 0; cfg.multi_ack <- `None; (* XXX(dinosaure): [multi_ack] supported by the client but it is not supported by the server. TODO: use [Context.shared]. *) retval := 0; return `Done - | Smart.Negotiation.ACK_common uid - | Smart.Negotiation.ACK_ready uid - | Smart.Negotiation.ACK_continue uid -> ( + | ACK_common uid | ACK_ready uid | ACK_continue uid -> ( access.get uid store >>= function | None -> assert false | Some obj -> @@ -215,7 +229,7 @@ let find_common ({ bind; return } as scheduler) io flow | `Done -> return () | `Continue -> decr flushes; - if !got_continue && _max_in_vain < !in_vain then return () + if !got_continue && max_in_vain < !in_vain then return () else if !got_ready then return () else go negotiator) else go negotiator @@ -224,7 +238,8 @@ let find_common ({ bind; return } as scheduler) io flow Log.debug (fun m -> m "Negotiation (got ready: %b, no-done: %b)." !got_ready no_done); (if (not !got_ready) || not no_done then - run scheduler raise io flow Smart.(send ctx negotiation_done ()) + Smart_flow.run scheduler raise io flow + Smart.(send ctx negotiation_done ()) else return ()) >>= fun () -> if !retval <> 0 then ( @@ -232,23 +247,22 @@ let find_common ({ bind; return } as scheduler) io flow incr flushes); (if (not !got_ready) || not no_done then ( Log.debug (fun m -> m "Negotiation is done!"); - run scheduler raise io flow Smart.(recv ctx shallows) + Smart_flow.run scheduler raise io flow Smart.(recv ctx shallows) >>= fun _shallows -> return ()) else return ()) >>= fun () -> let rec go () = if !flushes > 0 || cfg.multi_ack = `Some || cfg.multi_ack = `Detailed then ( - run scheduler raise io flow Smart.(recv ctx ack) + Smart_flow.run scheduler raise io flow Smart.(recv ctx ack) >>| Smart.Negotiation.map ~f:of_hex >>= fun ack -> match ack with | Smart.Negotiation.ACK _ -> return (`Continue 0) - | Smart.Negotiation.ACK_common _ | Smart.Negotiation.ACK_continue _ - | Smart.Negotiation.ACK_ready _ -> + | ACK_common _ | ACK_continue _ | ACK_ready _ -> cfg.multi_ack <- `Some; go () - | Smart.Negotiation.NAK -> + | NAK -> decr flushes; go ()) else if !count > 0 then return (`Continue !retval) diff --git a/src/not-so-smart/proto_vals_v2.ml b/src/not-so-smart/proto_vals_v2.ml new file mode 100644 index 000000000..85c67aa76 --- /dev/null +++ b/src/not-so-smart/proto_vals_v2.ml @@ -0,0 +1,672 @@ +open Astring +module Capability = Capability_v2 + +module Proto_request = struct + type t = { + path : string; + host : [ `host ] Domain_name.t * int option; + version : int; + request_command : [ `Upload_pack | `Receive_pack | `Upload_archive ]; + } + + let upload_pack ~host ?port ?(version = 2) path = + let host = host, port in + { request_command = `Upload_pack; host; version; path } + + let receive_pack ~host ?port ?(version = 1) path = + let host = host, port in + { request_command = `Receive_pack; host; version; path } + + let pp ppf { path; host; request_command; version } = + let pp_request_command ppf = function + | `Upload_pack -> Fmt.pf ppf "git-upload-pack" + | `Receive_pack -> Fmt.pf ppf "git-receive-pack" + | `Upload_archive -> Fmt.pf ppf "git-upload-archive" + in + let pp_host ppf = function + | host, Some port -> Fmt.pf ppf "%a:%d" Domain_name.pp host port + | host, None -> Fmt.pf ppf "%a" Domain_name.pp host + in + Fmt.pf ppf "%a %s %a %a" pp_request_command request_command path + Fmt.(prefix (const string " host=") pp_host) + host + Fmt.(prefix (const string " version=") int) + version +end + +module Command = struct type t = { name : string; args : string list } end + +module Ls_refs = struct + type ref_attr = + | Symref_target of string (** symref target *) + | Peeled of string (** peeled obj-id *) + + type ref_ = { obj_id : string; name : string; attributes : ref_attr list } + + let pp_ref_attr ppf = function + | Symref_target s -> Fmt.pf ppf "Symref-target %s" s + | Peeled s -> Fmt.pf ppf "Peeled %s" s + + let pp_ref ppf { obj_id; name; attributes } = + Fmt.pf ppf "{obj_id: %s;\n name: %s;\n attributes: [%a]}\n" obj_id name + (Fmt.list pp_ref_attr) attributes + + type prefix = Prefix of string [@@unboxed] + type request = { symrefs : bool; peel : bool; ref_prefixes : prefix list } + type response = ref_ list + + let make_request ~symrefs ~peel ref_prefixes = { symrefs; peel; ref_prefixes } +end + +module Fetch_command = struct + type ack_res = Nak | Acks of string list + + type acks = { + ack_res : ack_res option; + is_ready : bool; (* false if ready line is absent *) + } + + type response = + | Acks_only of acks + | Detailed_with_packfile of { + acks : acks; + shallow_info : + [ `Shallows of string list ] * [ `Unshallows of string list ]; + wanted_refs : (string * string) list; + packfile_uris : (string * string) list; + } +end + +module Extended_pkt_line_decoder = struct + include Pkt_line.Decoder + + type error = + [ Pkt_line.Decoder.error + | `Mismatch of [ `Expected of err_constr ] * [ `Got of err_constr ] ] + + and err_constr = + [ `Str of string + | `Pkt of err_constr list + | `Flush_pkt + | `Delim_pkt + | `Response_end_pkt + | `Invalid_len_pkt of int + | `Or of err_constr * err_constr ] + + let rec pp_err_constr ppf = function + | `Str s -> Fmt.string ppf s + | `Pkt lst -> + Fmt.pf ppf "PKT-LINE(%a)" (Fmt.list ~sep:Fmt.nop pp_err_constr) lst + | `Flush_pkt -> Fmt.string ppf "flush-pkt" + | `Delim_pkt -> Fmt.string ppf "delim-pkt" + | `Response_end_pkt -> Fmt.string ppf "Message pkt (aka response end pkt)" + | `Invalid_len_pkt i -> Fmt.pf ppf "pkt of invalid length: %d" i + | `Or (a, b) -> Fmt.pf ppf "(%a OR %a)" pp_err_constr a pp_err_constr b + + let mismatch ~expected ~got = `Mismatch (`Expected expected, `Got got) + let unexpected_flush_pkt ~expected = mismatch ~expected ~got:`Flush_pkt + let unexpected_delim_pkt ~expected = mismatch ~expected ~got:`Delim_pkt + + let unexpected_response_end_pkt ~expected = + mismatch ~expected ~got:`Response_end_pkt + + let invalid_len_pkt ~expected l = mismatch ~expected ~got:(`Invalid_len_pkt l) + + let unexpected_pkt ~expected = function + | Flush_pkt -> unexpected_flush_pkt ~expected + | Delim_pkt -> unexpected_delim_pkt ~expected + | Response_end_pkt -> unexpected_response_end_pkt ~expected + | Invalid_len_pkt l -> invalid_len_pkt ~expected l + | Pkt (_, pkt_content) -> mismatch ~expected ~got:(`Str pkt_content) + + let pp_error ppf = function + | `Mismatch (`Expected exp, `Got got) -> + Fmt.pf ppf "Expected: %a\nGot: %a\n" pp_err_constr exp pp_err_constr got + | #Pkt_line.Decoder.error as err -> pp_error ppf err + + (** [skip_string s d] {!reads} a packet line from [d] + and expects the read pkt line content to be equal to [s] + + @raise Invalid_argument if no packet line could be read *) + let skip_string s decoder = + match read_pkt decoder with + | Pkt (_, s0) when String.equal s0 s -> return () decoder + | Pkt (_, s0) -> Fmt.failwith "expected: %s\nfound: %s\n" s s0 + | _ -> raise @@ Invalid_argument "expected but didn't get a packet line" + + let error { buffer; pos; _ } error = Error { error; buffer; committed = pos } + + type ('acc, 'err, 'a, 'b) continue_or_stop = + | Continue of 'acc + | Stop_ok + | Stop_ok_same_pos (** keeps position [decoder.pos] same *) + | Stop_err of 'err + (** terminate decoding with error; keeps position [decoder.pos] same *) + + let continue acc = Continue acc + let stop_ok = Stop_ok + let stop_ok_same_pos = Stop_ok_same_pos + let stop_err err = Stop_err err + + let decode_fold_until ~f ~init ~finalize decoder = + let rec loop acc decoder = + let pkt = peek_pkt' decoder in + let pkt_len = pkt_len_at_least_4 pkt in + let acc' = f acc pkt in + match acc' with + | Continue acc -> + junk_chars pkt_len decoder; + prompt_pkt (loop acc) decoder + | Stop_ok_same_pos -> + let res = finalize acc in + return res decoder + | Stop_ok -> + junk_chars pkt_len decoder; + let res = finalize acc in + return res decoder + | Stop_err err -> error decoder err + in + prompt_pkt (loop init) decoder +end + +module Decoder = struct + open Extended_pkt_line_decoder + module Substr = String.Sub + + type nonrec error = error + + let pp_error = pp_error + let ( >>=? ) x f = Option.bind x f + let ( >|=? ) x f = Option.map f x + + (** + capability-advertisement = protocol-version + capability-list + flush-pkt + + protocol-version = PKT-LINE("version 2" LF) + capability-list = *capability + capability = PKT-LINE(key[=value] LF) + + key = 1*(ALPHA | DIGIT | "-_") + value = 1*(ALPHA | DIGIT | " -_.,?\/{}[]()<>!@#$%^&*+=:;") *) + let decode_capability_ads decoder = + (* protocol-version *) + prompt_pkt (skip_string "version 2") decoder >>= fun () -> + let expected = `Pkt [ `Str "key[=value] LF" ] in + + (* capability-list + flush-pkt *) + decode_fold_until decoder ~init:[] ~finalize:List.rev ~f:(fun acc -> + function + | Flush_pkt -> Stop_ok + | Pkt (_, pkt_content) -> + Continue (Capability.of_string pkt_content :: acc) + | (Delim_pkt | Response_end_pkt | Invalid_len_pkt _) as pkt -> + Stop_err (unexpected_pkt ~expected pkt)) + + let v_space = Substr.of_string " " + let v_colon = Substr.of_string ":" + let is_symref_target_v s = Substr.equal s (Substr.of_string "symref-target") + let is_peeled_v s = Substr.equal s (Substr.of_string "peeled") + + (** + output = *ref + flush-pkt + + ref = PKT-LINE(obj-id SP refname *(SP ref-attribute) LF) + ref-attribute = (symref | peeled) + symref = "symref-target:" symref-target + peeled = "peeled:" obj-id *) + let decode_ls_refs_response decoder = + let expected = + `Or (`Flush_pkt, `Pkt [ `Str "obj-id SP refname *(SP ref-attribute) LF" ]) + in + (* ref-attribute *) + let parse_ref_attr attr = + Substr.cut ~sep:v_colon attr >>=? fun (k, v) -> + match Substr.to_string k, Substr.to_string v with + | "symref-target", v -> Some (Ls_refs.Symref_target v) + | "peeled", v -> Some (Ls_refs.Peeled v) + | _ -> None + in + (* ref *) + let parse_ref ref_ = + let s = String.Sub.of_string ref_ in + match String.Sub.cuts ~sep:v_space s with + | obj_id :: name :: ref_attrs -> + let obj_id = Substr.to_string obj_id in + let name = Substr.to_string name in + let rec parse_or_none acc = function + | [] -> Some (List.rev acc) + | r :: rest -> + parse_ref_attr r >>=? fun r -> parse_or_none (r :: acc) rest + in + parse_or_none [] ref_attrs + |> Option.map (fun attributes -> Ls_refs.{ obj_id; name; attributes }) + | [] | _ :: _ -> None + in + decode_fold_until decoder ~init:[] ~finalize:List.rev ~f:(fun acc -> + function + | Flush_pkt -> Stop_ok + | Pkt (_, pkt) -> ( + match parse_ref pkt with + | Some ref_ -> Continue (ref_ :: acc) + | None -> Stop_err (mismatch ~expected ~got:(`Str pkt))) + | (Delim_pkt | Response_end_pkt | Invalid_len_pkt _) as pkt -> + Stop_err (unexpected_pkt ~expected pkt)) + + let peek_pkt ?(trim = true) decoder = + let buf, off, len = peek_pkt decoder in + let buf = Bytes.to_string buf in + let res = String.Sub.v buf ~start:off ~stop:(off + len) in + let is_new_line c = Char.equal c '\n' in + if trim then String.Sub.trim ~drop:is_new_line res else res + + let prompt_pack_without_sideband kcontinue keof decoder = + if decoder.pos > 0 then ( + let rest = decoder.max - decoder.pos in + Bytes.unsafe_blit decoder.buffer decoder.pos decoder.buffer 0 rest; + decoder.max <- rest; + decoder.pos <- 0); + let rec go off = + if off = Bytes.length decoder.buffer && decoder.pos > 0 then + Error + { + error = `No_enough_space; + buffer = decoder.buffer; + committed = decoder.pos; + } + else if off - decoder.pos > 0 then ( + decoder.max <- off; + safe kcontinue decoder) + else + Read + { + buffer = decoder.buffer; + off; + len = Bytes.length decoder.buffer - off; + continue = (fun len -> go (off + len)); + eof = keof decoder; + } + in + go decoder.max + + let peek_pack_without_sideband (decoder : decoder) = + let payload = + Bytes.sub_string decoder.buffer decoder.pos (decoder.max - decoder.pos) + in + payload, 0, decoder.max - decoder.pos + + let junk_pack_without_sideband (decoder : decoder) = + decoder.pos <- decoder.max + + let decode_pack ?(side_band = false) ~push_pack ~push_stdout ~push_stderr + decoder = + let with_side_band decoder = + let v = peek_pkt ~trim:false decoder in + match String.Sub.head v with + | Some '\001' -> + let off = String.Sub.start_pos v + 1 in + let len = String.Sub.stop_pos v - off in + let buf = String.Sub.base_string v in + push_pack (buf, off, len); + junk_pkt decoder; + return true decoder + | Some '\002' -> + let tail = String.Sub.to_string (String.Sub.tail v) (* copy *) in + push_stdout tail; + junk_pkt decoder; + return true decoder + | Some '\003' -> + let tail = String.Sub.to_string (String.Sub.tail v) (* copy *) in + push_stderr tail; + junk_pkt decoder; + return true decoder + | Some _ -> fail decoder (`Invalid_side_band (String.Sub.to_string v)) + | None -> return false decoder + in + let end_of_pack decoder () = return false decoder in + let without_side_band decoder = + let buf, off, len = peek_pack_without_sideband decoder in + push_pack (buf, off, len); + junk_pack_without_sideband decoder; + return true decoder + in + if side_band then prompt_pkt ~strict:true with_side_band decoder + else prompt_pack_without_sideband without_side_band end_of_pack decoder + + (** [if_str_else s then_ else_ d] peeks the to-be-read packet [p] and + if its packet content equals [s], runs [then_] junking [p]; + otherwise, runs [else_] without junking packet [p]. *) + let if_str_else str ~then_ ~else_ decoder = + match peek_pkt' decoder with + | Pkt (l, pkt_content) when String.equal pkt_content str -> + junk_chars l decoder; + prompt_pkt then_ decoder + | Pkt _ | Flush_pkt | Delim_pkt | Response_end_pkt | Invalid_len_pkt _ -> + prompt_pkt else_ decoder + + let or_delim_pkt other = `Or (`Delim_pkt, other) + + (** + output = acknowledgements flush-pkt | + [acknowledgments delim-pkt] [shallow-info delim-pkt] + [wanted-refs delim-pkt] [packfile-uris delim-pkt] + packfile flush-pkt + + acknowledgments = PKT-LINE("acknowledgments" LF) + (nak | *ack) + (ready) + Note: The spec for acknowledgements seem to confuse parens for brackets to + specify "ready" as optional. + + ready = PKT-LINE("ready" LF) + nak = PKT-LINE("NAK" LF) + ack = PKT-LINE("ACK" SP obj-id LF) + + shallow-info = PKT-LINE("shallow-info" LF) + *PKT-LINE((shallow | unshallow) LF) + shallow = "shallow" SP obj-id + unshallow = "unshallow" SP obj-id + + wanted-refs = PKT-LINE("wanted-refs" LF) + *PKT-LINE(wanted-ref LF) + wanted-ref = obj-id SP refname + + packfile-uris = PKT-LINE("packfile-uris" LF) *packfile-uri + packfile-uri = PKT-LINE(40*(HEXDIGIT) SP *%x20-ff LF) + + packfile = PKT-LINE("packfile" LF) + *PKT-LINE(%x01-03 *%x00-ff) *) + let decode_fetch_response decoder = + let open Fetch_command in + let decode_detailed_with_packfile acks decoder = + let decode_pack decoder : (unit, _) state = + match read_pkt decoder with + | Pkt (_, "packfile") -> failwith "(TODO:) not implemented" + | _ as pkt -> + unexpected_pkt ~expected:(`Str "packfile") pkt |> error decoder + in + + let decode_packfile_uris decoder = + let parse_packfile_uri s = + String.cut ~sep:" " s >>=? fun (obj_id, v) -> + if String.length obj_id = 40 then Some (obj_id, v) else None + in + let then_ decoder = + let expected = + or_delim_pkt (`Pkt [ `Str "40*(HEXDIGIT) SP *%x20-ff LF" ]) + in + decode_fold_until decoder ~init:[] ~finalize:List.rev + ~f:(fun acc pkt -> + match pkt with + | Delim_pkt -> Stop_ok + | Pkt (_, pkt_content) -> ( + match parse_packfile_uri pkt_content with + | None -> Stop_err (unexpected_pkt ~expected pkt) + | Some (obj_id, v) -> Continue ((obj_id, v) :: acc)) + | (Flush_pkt | Response_end_pkt | Invalid_len_pkt _) as pkt -> + Stop_err (unexpected_pkt ~expected pkt)) + in + let else_ decoder = return [] decoder in + prompt_pkt (if_str_else "packfile-uris" ~then_ ~else_) decoder + in + + let decode_wanted_refs decoder = + let then_ decoder = + let expected = or_delim_pkt (`Pkt [ `Str "obj-id SP refname" ]) in + decode_fold_until decoder ~init:[] ~finalize:List.rev + ~f:(fun acc pkt -> + match pkt with + | Delim_pkt -> Stop_ok + | Pkt (_, pkt_content) -> ( + match String.cut ?rev:None ~sep:" " pkt_content with + | Some (obj_id, refname) when String.length obj_id = 40 -> + Continue ((obj_id, refname) :: acc) + | Some _ | None -> Stop_err (unexpected_pkt ~expected pkt)) + | Flush_pkt | Response_end_pkt | Invalid_len_pkt _ -> + Stop_err (unexpected_pkt ~expected pkt)) + in + let else_ decoder = return [] decoder in + prompt_pkt (if_str_else "wanted-refs" ~then_ ~else_) decoder + in + + let decode_shallow_info decoder = + let then_ decoder = + let expected = + `Or + ( `Delim_pkt, + `Or + ( `Pkt [ `Str "\"shallow\" SP obj-id" ], + `Pkt [ `Str "\"unshallow\" SP obj-id" ] ) ) + in + decode_fold_until decoder ~init:([], []) + ~finalize:(fun (ll, lr) -> + `Shallows (List.rev ll), `Unshallows (List.rev lr)) + ~f:(fun (shallows, unshallows) pkt -> + match pkt with + | Delim_pkt -> Stop_ok + | Pkt (_, pkt_content) -> ( + match String.cut ~sep:" " pkt_content with + | Some ("shallow", obj_id) -> + Continue (obj_id :: shallows, unshallows) + | Some ("unshallow", obj_id) -> + Continue (shallows, obj_id :: unshallows) + | None | Some _ -> Stop_err (unexpected_pkt ~expected pkt)) + | Flush_pkt | Response_end_pkt | Invalid_len_pkt _ -> + Stop_err (unexpected_pkt ~expected pkt)) + in + let else_ decoder = return (`Shallows [], `Unshallows []) decoder in + prompt_pkt (if_str_else "shallow-info" ~then_ ~else_) decoder + in + + prompt_pkt decode_shallow_info decoder >>= fun shallow_info -> + prompt_pkt decode_wanted_refs decoder >>= fun wanted_refs -> + prompt_pkt decode_packfile_uris decoder >>= fun packfile_uris -> + prompt_pkt decode_pack decoder >>= fun () -> + return + (Detailed_with_packfile + { acks; shallow_info; wanted_refs; packfile_uris }) + decoder + in + + (* acknowledgements *) + let decode_acknowledgements decoder = + let decode_acks_flush_or_delim ~is_ready nak_or_acks decoder = + match read_pkt decoder with + | Flush_pkt -> + return (Acks_only { ack_res = nak_or_acks; is_ready }) decoder + | Delim_pkt -> + prompt_pkt + (decode_detailed_with_packfile + { ack_res = nak_or_acks; is_ready }) + decoder + | _ -> failwith "expected flush-pkt or delim-pkt" + in + + let decode_ready ~is_ready nak_or_acks decoder = + if is_ready then + prompt_pkt (decode_acks_flush_or_delim ~is_ready nak_or_acks) decoder + else + match peek_pkt' decoder with + | Flush_pkt | Delim_pkt -> + decode_acks_flush_or_delim ~is_ready:false nak_or_acks decoder + | Response_end_pkt | Invalid_len_pkt _ -> + failwith "was trying to parse ready" + | Pkt (l, "ready") -> + junk_chars l decoder; + prompt_pkt + (decode_acks_flush_or_delim ~is_ready:true nak_or_acks) + decoder + | Pkt _ -> failwith "unexpected string %s" + in + + let rec decode_acks acks decoder = + match peek_pkt' decoder with + | Flush_pkt | Delim_pkt -> + decode_acks_flush_or_delim ~is_ready:false (Some (Acks acks)) + decoder + | Pkt (l, "ready") -> + junk_chars l decoder; + let acks = match acks with [] -> None | _ -> Some (Acks acks) in + prompt_pkt (decode_ready ~is_ready:true acks) decoder + | Pkt (l, pkt) -> ( + match String.cut ~sep:" " pkt with + | None -> failwith "was decoding acks but got %s" + | Some ("ACK", obj_id) -> + junk_chars l decoder; + prompt_pkt (decode_acks (obj_id :: acks)) decoder + | Some _ -> failwith "unexpected string") + | Response_end_pkt | Invalid_len_pkt _ -> failwith "was decoding acks" + in + + prompt_pkt (skip_string "acknowledgements") decoder >>= fun () -> + let k decoder = + match peek_pkt' decoder with + | Flush_pkt | Delim_pkt -> + (* don't need [prompt_pkt] because we peeked and saw pkt available *) + decode_acks_flush_or_delim ~is_ready:false None decoder + | Pkt (l, "NAK") -> + junk_chars l decoder; + prompt_pkt (decode_ready ~is_ready:false (Some Nak)) decoder + | Pkt (l, "ready") -> + junk_chars l decoder; + prompt_pkt (decode_acks_flush_or_delim ~is_ready:true None) decoder + | Pkt (_, pkt) when String.is_prefix ~affix:"ACK " pkt -> + decode_acks [] decoder + | (Response_end_pkt | Invalid_len_pkt _ | Pkt _) as pkt -> + unexpected_pkt + ~expected:(`Or (`Str "(ready)", `Str "(nak | *ack)")) + pkt + |> error decoder + in + prompt_pkt k decoder + in + decode_acknowledgements decoder +end + +module Encoder = struct + open Pkt_line.Encoder + + type nonrec error = error + + let pp_error = pp_error + let kdone _encoder = Done + + let kflush encoder = + write encoder "0000"; + flush kdone encoder + + let kdelim_pkt encoder = write encoder "0001" + let write_space encoder = write encoder " " + let write_zero encoder = write encoder "\000" + let write_lf encoder = write encoder "\n" + + (* different from [delayed_write_pkt] defined in [nss/protocol] in that + pkt lines are appended by LF as instructed in the git specs *) + let delayed_write_pkt k0 k1 ({ pos; payload } as encoder) = + (* leave space for pkt length: 4 bytes *) + encoder.pos <- pos + 4; + k0 encoder; + write_lf encoder; + (* XXX(dinosaure): or [encoder.pos <- encoder.pos + 4]? *) + let len = encoder.pos - pos in + Bytes.blit_string (Fmt.str "%04X" len) 0 payload pos 4; + flush k1 encoder + + let encode_flush = kflush + + let encode_proto_request encoder + { Proto_request.path; host; version; request_command } = + let write_request_command encoder = function + | `Upload_pack -> write encoder "git-upload-pack" + | `Receive_pack -> write encoder "git-receive-pack" + | `Upload_archive -> write encoder "git-upload-archive" + in + let write_version encoder version = + let version = Fmt.str "version=%d" version in + write encoder version + in + let write_host encoder = function + | host, Some port -> + let host = Fmt.str "host=%s:%d" (Domain_name.to_string host) port in + write encoder host + | host, None -> + let host = Fmt.str "host=%s" (Domain_name.to_string host) in + write encoder host + in + let k encoder = + write_request_command encoder request_command; + write_space encoder; + write encoder path; + write_zero encoder; + write_host encoder host; + write_zero encoder; + if version > 1 then ( + write_zero encoder; + write_version encoder version; + write_zero encoder) + in + delayed_write_pkt k kdone encoder + + (** + request = empty-request | command-request + empty-request = flush-pkt + command-request = command + capability-list + [command-args] + flush-pkt + command = PKT-LINE("command=" key LF) + command-args = delim-pkt + *command-specific-arg + + command-specific-args are packet line framed arguments defined by + each individual command. *) + let encode_request req capabilities encoder = + match req with + | `Empty -> kflush encoder + | `Command Command.{ name; args } -> + (* command-args *) + let write_command_args args encoder = + match args with + | [] -> kflush encoder + | args -> + let rec loop args encoder = + match args with + | [] -> kflush encoder + | arg :: rest -> + let write_arg encoder = write encoder arg in + delayed_write_pkt write_arg (loop rest) encoder + in + delayed_write_pkt kdelim_pkt (loop args) encoder + in + (* capability-list *) + let rec write_caps caps encoder = + match caps with + | [] -> write_command_args args encoder + | hd :: tl -> + let write_cap encoder = write encoder (Capability.to_string hd) in + delayed_write_pkt write_cap (write_caps tl) encoder + in + (* command *) + let write_command encoder = + write encoder @@ Fmt.str "command=%s" name + in + delayed_write_pkt write_command (write_caps capabilities) encoder + + let ls_refs_request_args { Ls_refs.symrefs; peel; ref_prefixes } = + let ref_pref_args = List.map (fun (Ls_refs.Prefix p) -> p) ref_prefixes in + let peel_arg = if peel then [ "peel" ] else [] in + let symrefs_arg = if symrefs then [ "symrefs" ] else [] in + List.concat + [ + symrefs_arg; peel_arg; ref_pref_args; + (* order of args placement may matter *) + ] + + let encode_ls_refs_request capabilities encoder req = + let args = ls_refs_request_args req in + let command = `Command { Command.name = "ls-refs"; args } in + encode_request command capabilities encoder +end diff --git a/src/not-so-smart/protocol.ml b/src/not-so-smart/protocol.ml index 7d0097e89..6b920c80b 100644 --- a/src/not-so-smart/protocol.ml +++ b/src/not-so-smart/protocol.ml @@ -296,10 +296,6 @@ module Decoder = struct Fmt.pf ppf "Invalid result command (%S)" raw | `Unexpected_flush -> Fmt.string ppf "Unexpected flush" - let rec prompt_pkt ?strict k decoder = - if at_least_one_pkt decoder then k decoder - else prompt ?strict (prompt_pkt ?strict k) decoder - let is_new_line = function '\n' -> true | _ -> false let peek_pkt ?(trim = true) decoder = @@ -701,7 +697,7 @@ module Decoder = struct match String.Sub.head pkt with | Some '\001' -> let str = String.Sub.(to_string (tail pkt)) in - let decoder' = decoder_from str in + let decoder' = of_string str in decode_status decoder' >>= fun res -> junk_pkt decoder; prompt_pkt (return res) decoder @@ -732,13 +728,13 @@ module Encoder = struct let write_zero encoder = write encoder "\000" let write_new_line encoder = write encoder "\n" - let delayed_write_pkt k0 k1 encoder = - let pos = encoder.pos in - encoder.pos <- encoder.pos + 4; + let delayed_write_pkt k0 k1 ({ pos; payload } as encoder) = + (* leave space for pkt length: 4 bytes *) + encoder.pos <- pos + 4; k0 encoder; (* XXX(dinosaure): or [encoder.pos <- encoder.pos + 4]? *) let len = encoder.pos - pos in - Bytes.blit_string (Fmt.str "%04X" len) 0 encoder.payload pos 4; + Bytes.blit_string (Fmt.str "%04X" len) 0 payload pos 4; flush k1 encoder let kdone _encoder = Done diff --git a/src/not-so-smart/push.ml b/src/not-so-smart/push.ml index 0567e0679..7d0b56666 100644 --- a/src/not-so-smart/push.ml +++ b/src/not-so-smart/push.ml @@ -39,6 +39,8 @@ struct pp_error = Flow.pp_error; } + module Smart_flow = State_flow.Make (Smart) + let push ?(uses_git_transport = true) ~capabilities:client_caps cmds ~host path flow store access push_cfg pack = let fiber ctx = diff --git a/src/not-so-smart/smart.mli b/src/not-so-smart/smart.mli index 72f840b3b..c440612b1 100644 --- a/src/not-so-smart/smart.mli +++ b/src/not-so-smart/smart.mli @@ -156,7 +156,7 @@ module Shallow : sig val map : f:('a -> 'b) -> 'a t -> 'b t end -type ('a, 'err) t = +type ('a, 'err) t = ('a, 'err) State.t = | Read of { buffer : bytes; off : int; diff --git a/src/not-so-smart/smart_flow.ml b/src/not-so-smart/smart_flow.ml deleted file mode 100644 index 1d70336ba..000000000 --- a/src/not-so-smart/smart_flow.ml +++ /dev/null @@ -1,52 +0,0 @@ -open Sigs - -module Log = (val let src = Logs.Src.create "smart_flow" in - Logs.src_log src : Logs.LOG) - -let io_buffer_size = 65536 - -type ('a, 's) raise = exn -> ('a, 's) io - -let run : - type fl s. - s scheduler -> - ('a, s) raise -> - (fl, 'error, s) flow -> - fl -> - ('res, [ `Protocol of Smart.error ]) Smart.t -> - ('res, s) io = - fun { bind; return } raise { recv; send; pp_error } flow fiber -> - let ( >>= ) = bind in - let tmp = Cstruct.create io_buffer_size in - let failwithf fmt = Format.kasprintf (fun err -> raise (Failure err)) fmt in - let rec go = function - | Smart.Read { k; buffer; off; len; eof } -> ( - let max = min (Cstruct.len tmp) len in - Log.debug (fun m -> m "Start to read %d byte(s)." max); - recv flow (Cstruct.sub tmp 0 max) >>= function - | Ok `End_of_flow -> - Log.debug (fun m -> m "Got end of input."); - go (eof ()) - | Ok (`Input len) -> - Log.debug (fun m -> m "Got %d/%d byte(s)." len max); - Cstruct.blit_to_bytes tmp 0 buffer off len; - go (k len) - | Error err -> - Log.err (fun m -> m "Got an error: %a." pp_error err); - failwithf "%a" pp_error err) - | Smart.Write { k; buffer; off; len } -> - let rec loop tmp = - if Cstruct.len tmp = 0 then go (k len) - else - send flow tmp >>= function - | Ok shift -> loop (Cstruct.shift tmp shift) - | Error err -> failwithf "%a" pp_error err - in - Log.debug (fun m -> m "Write %d byte(s)." len); - loop (Cstruct.of_string buffer ~off ~len) - | Smart.Return v -> return v - | Smart.Error (`Protocol err) -> - Log.err (fun m -> m "Got a protocol error: %a." Smart.pp_error err); - failwithf "%a" Smart.pp_error err - in - go fiber diff --git a/src/not-so-smart/smart_flow.mli b/src/not-so-smart/smart_flow.mli deleted file mode 100644 index fbcdcde6d..000000000 --- a/src/not-so-smart/smart_flow.mli +++ /dev/null @@ -1,13 +0,0 @@ -open Sigs - -val io_buffer_size : int - -type ('a, 's) raise = exn -> ('a, 's) Sigs.io - -val run : - 's scheduler -> - ('res, 's) raise -> - ('flow, 'error, 's) flow -> - 'flow -> - ('res, [ `Protocol of Smart.error ]) Smart.t -> - ('res, 's) io diff --git a/src/not-so-smart/smart_git.ml b/src/not-so-smart/smart_git.ml index 87ee4bdbd..098d62704 100644 --- a/src/not-so-smart/smart_git.ml +++ b/src/not-so-smart/smart_git.ml @@ -140,26 +140,22 @@ module Make (Uid : UID) (Ref : Sigs.REF) = struct - let src = Logs.Src.create "git-fetch" + module Log = (val let src = Logs.Src.create "git-fetch" in + Logs.src_log src : Logs.LOG) - module Log = (val Logs.src_log src : Logs.LOG) module Thin = Carton_lwt.Thin.Make (Uid) let fs = let open Rresult in let open Lwt.Infix in - Thin. - { - create = - (fun t path -> - Pack.create ~mode:Pack.RdWr t path - >|= R.reword_error (R.msgf "%a" Pack.pp_error)); - append = Pack.append; - map = Pack.map; - close = - (fun t fd -> - Pack.close t fd >|= R.reword_error (R.msgf "%a" Pack.pp_error)); - } + let create t path = + Pack.create ~mode:Pack.RdWr t path + >|= R.reword_error (R.msgf "%a" Pack.pp_error) + in + let close t fd = + Pack.close t fd >|= R.reword_error (R.msgf "%a" Pack.pp_error) + in + { Thin.create; append = Pack.append; map = Pack.map; close } (* XXX(dinosaure): abstract it? *) let digest : @@ -305,10 +301,18 @@ struct module Flow = Unixiz.Make (Mimic) module Fetch = Nss.Fetch.Make (Scheduler) (Lwt) (Flow) (Uid) (Ref) + module Fetch_v1 = Fetch.V1 module Push = Nss.Push.Make (Scheduler) (Lwt) (Flow) (Uid) (Ref) + (** [push_pack_str_alone push_pack (payload, off, len)] calls [push_pack] with + [push_pack (Some (String.sub payload off len), 0, len)] *) + let push_pack_new_str push_pack (payload, off, len) = + let v = String.sub payload off len in + push_pack (Some (v, 0, len)) + let fetch_v1 ?(uses_git_transport = false) ~push_stdout ~push_stderr - ~capabilities path ~ctx ?deepen ?want host store access fetch_cfg pack = + ~capabilities path ~ctx ?deepen ?want host store access fetch_cfg + push_pack = let open Lwt.Infix in Mimic.resolve ctx >>= function | Error _ as err -> @@ -317,21 +321,20 @@ struct | `Addr v -> Ipaddr.pp ppf v in Log.err (fun m -> m "%a not found" pp_host host); - pack None; + push_pack None; Lwt.return err | Ok flow -> Lwt.try_bind (fun () -> - Fetch.fetch_v1 ~uses_git_transport ~push_stdout ~push_stderr + Fetch_v1.fetch ~uses_git_transport ~push_stdout ~push_stderr ~capabilities ?deepen ?want ~host path (Flow.make flow) store - access fetch_cfg (fun (payload, off, len) -> - let v = String.sub payload off len in - pack (Some (v, 0, len)))) + access fetch_cfg + (push_pack_new_str push_pack)) (fun refs -> - pack None; + push_pack None; Mimic.close flow >>= fun () -> Lwt.return_ok refs) (fun exn -> - pack None; + push_pack None; Mimic.close flow >>= fun () -> Lwt.fail exn) module Flow_http = struct @@ -371,9 +374,11 @@ struct end module Fetch_http = Nss.Fetch.Make (Scheduler) (Lwt) (Flow_http) (Uid) (Ref) + module Fetch_v1_http = Fetch_http.V1 let http_fetch_v1 ~push_stdout ~push_stderr ~capabilities ~ctx uri - ?(headers = []) endpoint path ?deepen ?want store access fetch_cfg pack = + ?(headers = []) endpoint path ?deepen ?want store access fetch_cfg + push_pack = let open Rresult in let open Lwt.Infix in let uri0 = Fmt.str "%a/info/refs?service=git-upload-pack" Uri.pp uri in @@ -386,13 +391,11 @@ struct let flow = { Flow_http.ic = contents; pos = 0; oc = ""; uri = uri1; headers; ctx } in - Fetch_http.fetch_v1 ~push_stdout ~push_stderr ~capabilities ?deepen ?want + Fetch_v1_http.fetch ~push_stdout ~push_stderr ~capabilities ?deepen ?want ~host:endpoint path flow store access fetch_cfg - (fun (payload, off, len) -> - let v = String.sub payload off len in - pack (Some (v, 0, len))) + (push_pack_new_str push_pack) >>= fun refs -> - pack None; + push_pack None; Lwt.return_ok refs let default_capabilities = @@ -401,6 +404,8 @@ struct `Report_status; ] + module V2 = struct end + let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~ctx (access, light_load, heavy_load) store edn ?(version = `V1) ?(capabilities = default_capabilities) ?deepen want t_pck t_idx ~src ~dst @@ -428,7 +433,7 @@ struct let run = match version, edn.scheme with | `V1, ((`Git | `SSH _) as scheme) -> - let fetch_cfg = Nss.Fetch.configuration capabilities in + let fetch_cfg = Nss.Fetch.V1.configuration capabilities in let uses_git_transport = match scheme with `Git -> true | `SSH _ -> false in @@ -449,7 +454,7 @@ struct | `V1, ((`HTTP _ | `HTTPS _) as scheme) -> Log.debug (fun m -> m "Start an HTTP transmission."); let fetch_cfg = - Nss.Fetch.configuration ~stateless:true capabilities + Nss.Fetch.V1.configuration ~stateless:true capabilities in let pp_host ppf = function | `Domain v -> Domain_name.pp ppf v diff --git a/src/not-so-smart/state.ml b/src/not-so-smart/state.ml index 53502d9e6..13c38c033 100644 --- a/src/not-so-smart/state.ml +++ b/src/not-so-smart/state.ml @@ -78,10 +78,13 @@ struct in bind' - let ( let* ) m f = bind m ~f - let ( >>= ) m f = bind m ~f let return v = Return v let fail error = Error error + let map m ~f = bind m ~f:(fun v -> return (f v)) + let ( >>= ) m f = bind m ~f + let ( >|= ) m f = map m ~f + let ( let* ) m f = m >>= f + let ( let+ ) m f = m >|= f let reword_error f x = let rec map_error = function @@ -143,4 +146,18 @@ struct fun ctx w -> decode ctx w (fun _ctx v -> Return v) let error_msgf fmt = Fmt.kstr (fun err -> Error (`Msg err)) fmt + + module Infix = struct + let ( >>= ) = ( >>= ) + let ( >|= ) = ( >|= ) + let return = return + let fail = fail + end + + module Syntax = struct + let ( let* ) = ( let* ) + let ( let+ ) = ( let+ ) + let return = return + let fail = fail + end end diff --git a/src/not-so-smart/state.mli b/src/not-so-smart/state.mli index 2549d88cd..f5ec304f7 100644 --- a/src/not-so-smart/state.mli +++ b/src/not-so-smart/state.mli @@ -52,10 +52,13 @@ module Scheduler and type decoder = Context.decoder) : sig type error = Value.error + val return : 'v -> ('v, 'err) t val bind : ('a, 'err) t -> f:('a -> ('b, 'err) t) -> ('b, 'err) t - val ( let* ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t val ( >>= ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t - val return : 'v -> ('v, 'err) t + val map : ('a, 'err) t -> f:('a -> 'b) -> ('b, 'err) t + val ( let* ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t + val ( >|= ) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t + val ( let+ ) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t val fail : 'err -> ('v, 'err) t val reword_error : ('err0 -> 'err1) -> ('v, 'err0) t -> ('v, 'err1) t @@ -79,4 +82,18 @@ module Scheduler val error_msgf : ('a, Format.formatter, unit, ('b, [> `Msg of string ]) t) format4 -> 'a + + module Infix : sig + val ( >>= ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t + val ( >|= ) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t + val return : 'v -> ('v, 'err) t + val fail : 'err -> ('v, 'err) t + end + + module Syntax : sig + val ( let* ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t + val ( let+ ) : ('a, 'err) t -> ('a -> 'b) -> ('b, 'err) t + val return : 'v -> ('v, 'err) t + val fail : 'err -> ('v, 'err) t + end end diff --git a/src/not-so-smart/state_flow.ml b/src/not-so-smart/state_flow.ml new file mode 100644 index 000000000..a9a0217c7 --- /dev/null +++ b/src/not-so-smart/state_flow.ml @@ -0,0 +1,76 @@ +open Sigs + +module Log = (val let src = Logs.Src.create "state-flow" in + Logs.src_log src : Logs.LOG) + +let io_buffer_size = 65536 + +type ('a, 's) raise = exn -> ('a, 's) io + +module Make (Read_write : sig + type ('a, 'err) t = ('a, 'err) State.t + type error + + val pp_error : error Fmt.t +end) = +struct + type nonrec error = Read_write.error + + let run : + type fl s. + s scheduler -> + ('a, s) raise -> + (fl, 'error, s) flow -> + fl -> + ('res, [ `Protocol of error ]) Read_write.t -> + ('res, s) io = + fun scheduler io_raise _Flow flow state -> + let { bind; return } = scheduler in + let ( >>= ) = bind in + + let failwithf fmt = + Format.kasprintf (fun err -> io_raise (Failure err)) fmt + in + + let cbuff = Cstruct.create io_buffer_size in + + let rec unwrap = function + | State.Return v -> + Log.debug (fun m -> m "got return "); + return v + | Error (`Protocol err) -> + Log.err (fun m -> + m "Got a protocol error: %a." Read_write.pp_error err); + failwithf "%a" Read_write.pp_error err + | Read { k; buffer; off; len; eof } -> ( + let rd_n_bytes = min (Cstruct.len cbuff) len in + Log.debug (fun m -> m "Start to read %d byte(s)." rd_n_bytes); + _Flow.recv flow (Cstruct.sub cbuff 0 rd_n_bytes) >>= function + | Ok `End_of_flow -> + Log.debug (fun m -> m "Got end of input."); + unwrap (eof ()) + | Ok (`Input len) -> + Log.debug (fun m -> m "Got %d/%d byte(s)." len rd_n_bytes); + Cstruct.blit_to_bytes cbuff 0 buffer off len; + unwrap (k len) + | Error err -> + Log.err (fun m -> m "Got an error: %a." _Flow.pp_error err); + failwithf "%a" _Flow.pp_error err) + | Write { k; buffer; off; len } -> + (* TODO: Avoid writing by loop if we can; + otherwise, the loop writes once and terminates *) + let rec loop tmp = + if Cstruct.is_empty tmp then unwrap (k len) + else + _Flow.send flow tmp >>= function + | Ok shift -> + Log.debug (fun m -> + m "Wrote %d byte(s). %s" shift (Cstruct.to_string tmp)); + loop (Cstruct.shift tmp shift) + | Error err -> failwithf "%a" _Flow.pp_error err + in + Cstruct.of_string buffer ~off ~len |> loop + in + + unwrap state +end diff --git a/src/not-so-smart/state_flow.mli b/src/not-so-smart/state_flow.mli new file mode 100644 index 000000000..bab268386 --- /dev/null +++ b/src/not-so-smart/state_flow.mli @@ -0,0 +1,24 @@ +module Log : Logs.LOG + +val io_buffer_size : int + +type ('a, 's) raise = exn -> ('a, 's) Sigs.io + +module Make : functor + (Read_write : sig + type ('a, 'err) t = ('a, 'err) State.t + type error + + val pp_error : error Fmt.t + end) + -> sig + type nonrec error = Read_write.error + + val run : + 's Sigs.scheduler -> + ('res, 's) raise -> + ('fl, 'error, 's) Sigs.flow -> + 'fl -> + ('res, [ `Protocol of error ]) State.t -> + ('res, 's) Sigs.io +end diff --git a/src/not-so-smart/wire_proto_v2.ml b/src/not-so-smart/wire_proto_v2.ml new file mode 100644 index 000000000..4937513bb --- /dev/null +++ b/src/not-so-smart/wire_proto_v2.ml @@ -0,0 +1,111 @@ +module Capability = Capability_v2 +module Proto_vals_v2 = Proto_vals_v2 + +module Witness = struct + type 'a send = + | Proto_request : Proto_vals_v2.Proto_request.t send + | Ls_refs_req + : ([ `Client_caps of + Capability.t list + (* TODO: not really client_caps but not sure whose caps that are; so needs investigation *) + ] + * Proto_vals_v2.Ls_refs.request) + send + | Flush : unit send + + type 'a recv = + | Capability_advertisement : Capability.t list recv + | Ls_refs_res : Proto_vals_v2.Ls_refs.response recv +end + +(* TODO: copy of Smart.Context; remove duplication *) +module Context = struct + type capabilities = { + client_caps : Capability.t list; + server_caps : Capability.t list; + } + + let pp_capabilities _ppf _v = () + + include State.Context + + type nonrec t = capabilities t + + let make ~client_caps = make { client_caps; server_caps = [] } + let pp ppf v = pp pp_capabilities ppf v + let capabilities ctx = context ctx + + let replace_server_caps ctx caps = + update ~f:(fun ~old_ctx -> { old_ctx with server_caps = caps }) ctx + + let is_cap_shared ctx cap = + let { client_caps; server_caps } = capabilities ctx in + let is_cap_in caps = List.exists (fun c -> Capability.equal c cap) caps in + is_cap_in client_caps && is_cap_in server_caps +end + +type ('a, 'err) t = ('a, 'err) State.t = + | Read of { + buffer : bytes; + off : int; + len : int; + k : int -> ('a, 'err) t; + eof : unit -> ('a, 'err) t; + } + | Write of { buffer : string; off : int; len : int; k : int -> ('a, 'err) t } + | Return of 'a + | Error of 'err + +module Value = struct + include Witness + + type error = [ Proto_vals_v2.Encoder.error | Proto_vals_v2.Decoder.error ] + type encoder = Pkt_line.Encoder.encoder + type decoder = Pkt_line.Decoder.decoder + + let encode : type a. encoder -> a send -> a -> (unit, error) State.t = + fun encoder w v -> + let encoder_state = + let open Proto_vals_v2.Encoder in + match w with + | Proto_request -> encode_proto_request encoder v + | Ls_refs_req -> + let `Client_caps capabilities, req = v in + encode_ls_refs_request capabilities encoder req + | Flush -> encode_flush encoder + in + let rec translate_to_state_t = function + | Pkt_line.Encoder.Done -> State.Return () + | Write { continue; buffer; off; len } -> + let k i = continue i |> translate_to_state_t in + State.Write { k; buffer; off; len } + | Error err -> State.Error (err :> error) + in + translate_to_state_t encoder_state + + let decode : type a. decoder -> a recv -> (a, error) State.t = + fun decoder w -> + let rec transl : + (a, [> Proto_vals_v2.Decoder.error ]) Pkt_line.Decoder.state -> + (a, [> Proto_vals_v2.Decoder.error ]) State.t = function + | Pkt_line.Decoder.Done v -> State.Return v + | Read { buffer; off; len; continue; eof } -> + let k i = continue i |> transl in + let eof i = eof i |> transl in + State.Read { k; buffer; off; len; eof } + | Error { error; _ } -> State.Error error + in + transl + (match w with + | Capability_advertisement -> + Proto_vals_v2.Decoder.decode_capability_ads decoder + | Ls_refs_res -> Proto_vals_v2.Decoder.decode_ls_refs_response decoder) +end + +include State.Scheduler (Context) (Value) + +let pp_error ppf = function + | #Proto_vals_v2.Encoder.error as err -> + Proto_vals_v2.Encoder.pp_error ppf err + | #Proto_vals_v2.Decoder.error as err -> + Proto_vals_v2.Decoder.pp_error ppf err diff --git a/test/smart/dune b/test/smart/dune index 32231b33d..05af015fb 100644 --- a/test/smart/dune +++ b/test/smart/dune @@ -1,13 +1,13 @@ (executable (name test) (modules append fifo hTTP loopback lwt_backend ref store_backend test uid - unix_backend) + unix_backend pipe) (libraries bigarray-compat mirage-flow mimic git.nss.unixiz git git-unix result curl.lwt mirage-crypto-rng.unix digestif digestif.c domain-name - git.nss.git bos fpath carton-lwt bigstringaf git.nss.sigs git.nss.hkt fmt - git.nss.pck carton rresult alcotest git.nss.smart lwt.unix mmap astring - lwt cstruct uri fmt.tty logs.fmt alcotest-lwt cohttp-lwt-unix - git-cohttp-unix)) + git.nss git.nss.wire-proto-v2 git.nss.git bos fpath carton-lwt bigstringaf + git.nss.sigs git.nss.hkt fmt git.nss.pck carton rresult alcotest + git.nss.smart lwt.unix mmap astring lwt cstruct uri fmt.tty logs.fmt + alcotest-lwt cohttp-lwt-unix git-cohttp-unix)) (executable (name test_edn) diff --git a/test/smart/pipe.ml b/test/smart/pipe.ml new file mode 100644 index 000000000..61a6d890a --- /dev/null +++ b/test/smart/pipe.ml @@ -0,0 +1,69 @@ +type flow = { process : Lwt_process.process_full; buffer : Bytes.t } + +let io_buffer_size = 65536 + +type endpoint = { + cmd : string; + args : string array; + env : string array; + cwd : string option; +} + +type error = | +type write_error = [ `Couldn't_connect | `Closed ] + +let pp_error : error Fmt.t = fun _ppf -> function _ -> . +let closed_by_peer = "Closed by peer" + +let pp_write_error ppf = function + | `Closed -> Fmt.string ppf closed_by_peer + | `Couldn't_connect -> Fmt.string ppf "Couldn't connect" + +let connect ({ cmd; args; env; cwd } : endpoint) = + (try + let process = Lwt_process.open_process_full ?cwd ~env (cmd, args) in + let buffer = Bytes.create io_buffer_size in + Ok { process; buffer } + with _exn -> Error `Couldn't_connect) + |> Lwt.return + +let read { process; buffer } = + match process#state with + | Exited _ -> Lwt.return_ok `Eof + | Running -> ( + let open Lwt.Syntax in + let+ len = + Lwt_io.read_into process#stdout buffer 0 (Bytes.length buffer) + in + match len with + | 0 -> Ok `Eof + | len -> Ok (`Data (Cstruct.of_bytes buffer ~off:0 ~len))) + +let write { process; _ } cs = + match process#state with + | Exited _ -> Lwt.return_error `Closed + | Running -> + let rec loop ({ Cstruct.buffer; off; len } as cs) = + if len = 0 then Lwt.return_ok () + else + let open Lwt.Syntax in + let* len = Lwt_io.write_from_bigstring process#stdin buffer off len in + Cstruct.shift cs len |> loop + in + loop cs + +let writev t css = + let open Lwt.Infix in + let rec go = function + | [] -> Lwt.return_ok () + | hd :: tl -> ( + write t hd >>= function + | Ok () -> go tl + | Error _ as err -> Lwt.return err) + in + go css + +let close { process; _ } = + let open Lwt.Syntax in + let+ (_ : Unix.process_status) = process#close in + () diff --git a/test/smart/test.ml b/test/smart/test.ml index 2df6572a3..26495eed9 100644 --- a/test/smart/test.ml +++ b/test/smart/test.ml @@ -1,9 +1,10 @@ +open Astring +open Bos open Rresult open Lwt_backend open Store_backend (** logging: *) - let () = Printexc.record_backtrace true let reporter ppf = @@ -33,8 +34,19 @@ let ( >>? ) x f = let open Lwt.Infix in x >>= function Ok x -> f x | Error err -> Lwt.return_error err +module Option = struct + include Option + + let value_else o ~else_ = match o with Some v -> v | None -> else_ () +end + (** conduit-related setup for tests: *) +let pipe_value, pipe = Mimic.register ~name:"pipe" (module Pipe) + +let ctx_with_pipe ?cwd ?(env = [||]) ?(args = [||]) cmd = + Mimic.add pipe_value { cmd; args; env; cwd } Mimic.empty + let fifo_value, fifo = Mimic.register ~name:"fifo" (module Fifo) let ctx_with_fifo ic oc = Mimic.add fifo_value (ic, oc) Mimic.empty let loopback_value, loopback = Mimic.register ~name:"loopback" (module Loopback) @@ -54,7 +66,7 @@ let ref_contents = (** to keep track of directories created by unit tests and clean them up afterwards *) module Tmp_dirs = struct - let rm_r dir = Bos.OS.Dir.delete ~recurse:true dir |> ignore + let rm_r dir = OS.Dir.delete ~recurse:true dir |> ignore let t = ref Fpath.Set.empty let add file = t := Fpath.Set.add file !t @@ -68,11 +80,9 @@ end let () = at_exit (fun () -> if !Tmp_dirs.are_valid then Tmp_dirs.remove_all ()) let create_tmp_dir ?(mode = 0o700) ?prefix_path pat = - let dir = - match prefix_path with None -> Bos.OS.Dir.default_tmp () | Some d -> d - in + let dir = Option.value_else prefix_path ~else_:OS.Dir.default_tmp in let failed_too_many_times () = - Rresult.R.error_msgf + R.error_msgf "create temporary directory %s in %a: too many failing attempts" (Fmt.str pat "XXXXXX") Fpath.pp dir in @@ -91,7 +101,7 @@ let create_tmp_dir ?(mode = 0o700) ?prefix_path pat = | Unix.Unix_error (Unix.EEXIST, _, _) -> loop (count - 1) | Unix.Unix_error (Unix.EINTR, _, _) -> loop count | Unix.Unix_error (e, _, _) -> - Rresult.R.error_msgf "create temporary directory %s in %a: %s" + R.error_msgf "create temporary directory %s in %a: %s" (Fmt.str pat "XXXXXX") Fpath.pp dir (Unix.error_message e) in match loop 10000 with @@ -100,15 +110,60 @@ let create_tmp_dir ?(mode = 0o700) ?prefix_path pat = r | Error _ as e -> e +(* XXX(dinosaure): FIFO "à la BOS".*) + +(** to keep track of named pipes (aka FIFOs) created by unit tests + and clean them up afterwards *) +module Tmp_fifos = struct + let rec unlink fifo = + try Unix.unlink (Fpath.to_string fifo) with + | Unix.Unix_error (Unix.EINTR, _, _) -> unlink fifo + | Unix.Unix_error _ -> () + + let t = ref Fpath.Set.empty + let add fifo = t := Fpath.Set.add fifo !t + let unlink_all () = Fpath.Set.iter unlink !t +end + +let () = at_exit Tmp_fifos.unlink_all + +let create_fifo_path mode dir pat = + let err () = + R.error_msgf "create temporary fifo %s in %a: too many failing attempts" + (Fmt.str pat "XXXXXX") Fpath.pp dir + in + let rec loop count = + if count < 0 then err () + else + let file = + let rand = Random.bits () land 0xffffff in + Fpath.(dir / Fmt.str pat (Fmt.str "%06x" rand)) + in + let sfile = Fpath.to_string file in + try + Unix.mkfifo sfile mode; + Ok file + with + | Unix.Unix_error (Unix.EEXIST, _, _) -> loop (count - 1) + | Unix.Unix_error (Unix.EINTR, _, _) -> loop count + | Unix.Unix_error (e, _, _) -> + R.error_msgf "create temporary fifo %a: %s" Fpath.pp file + (Unix.error_message e) + in + loop 10000 + +let with_fifo ?(mode = 0o600) ?dir pat = + let dir = Option.value_else dir ~else_:OS.Dir.default_tmp in + create_fifo_path mode dir pat >>| fun file -> + Tmp_fifos.add file; + file + let create_new_git_store _sw = let create () = - let open Rresult in (* XXX(dinosaure): a hook is already added by [Bos] to delete the directory. *) create_tmp_dir "git-%s" >>= fun root -> - Bos.OS.Dir.with_current root - (fun () -> Bos.OS.Cmd.run Bos.Cmd.(v "git" % "init")) - () + OS.Dir.with_current root (fun () -> OS.Cmd.run Cmd.(v "git" % "init")) () |> R.join >>= fun () -> let access = access lwt in @@ -119,7 +174,7 @@ let create_new_git_store _sw = in match create () with | Ok res -> Lwt.return res - | Error err -> Fmt.failwith "%a" Rresult.R.pp_msg err + | Error err -> Fmt.failwith "%a" R.pp_msg err let empty_repository_fetch = [ @@ -250,8 +305,8 @@ let test_sync_fetch () = >|= store_err >>? fun () -> Smart_git.Endpoint.of_string "git://localhost/not-found.git" + |> bad_input_err |> Lwt.return - >|= bad_input_err >>? fun endpoint -> (* fetch HEAD and write it to refs/heads/master *) Sync.fetch ~ctx ~capabilities endpoint store @@ -304,9 +359,9 @@ let test_empty_clone () = Fpath.(path / ".git" / "objects" / "pack") ) in let ctx = ctx_with_payloads payloads in - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> - Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> + OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> Git.fetch ~ctx ~capabilities access store endpoint @@ -333,9 +388,9 @@ let test_simple_clone () = Fpath.(path / ".git" / "objects" / "pack") ) in let ctx = ctx_with_payloads payloads in - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> - Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> + OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> Git.fetch ~ctx ~capabilities access store endpoint `All pack index ~src:tmp0 @@ -350,13 +405,10 @@ let test_simple_clone () = let create_new_git_push_store _sw = let create () = - let open Rresult in (* XXX(dinosaure): a hook is already added by [Bos] to delete the directory. *) - Bos.OS.Dir.tmp "git-%s" >>= fun root -> - Bos.OS.Dir.with_current root - (fun () -> Bos.OS.Cmd.run Bos.Cmd.(v "git" % "init")) - () + OS.Dir.tmp "git-%s" >>= fun root -> + OS.Dir.with_current root (fun () -> OS.Cmd.run Cmd.(v "git" % "init")) () |> R.join >>= fun () -> let access = @@ -378,30 +430,27 @@ let create_new_git_push_store _sw = in match create () with | Ok res -> Lwt.return res - | Error err -> Fmt.failwith "%a" Rresult.R.pp_msg err + | Error err -> Fmt.failwith "%a" R.pp_msg err let commit_foo store = let { path; _ } = store_prj store in let commit = - let open Rresult in - Bos.OS.Dir.with_current path @@ fun () -> - Bos.OS.Cmd.run Bos.Cmd.(v "git" % "config" % "user.name" % "test") - >>= fun () -> - Bos.OS.Cmd.run - Bos.Cmd.(v "git" % "config" % "user.email" % "pseudo@pseudo.invalid") + OS.Dir.with_current path @@ fun () -> + OS.Cmd.run Cmd.(v "git" % "config" % "user.name" % "test") >>= fun () -> + OS.Cmd.run Cmd.(v "git" % "config" % "user.email" % "pseudo@pseudo.invalid") >>= fun () -> - Bos.OS.File.write (Fpath.v "foo") "" >>= fun () -> - Bos.OS.Cmd.run Bos.Cmd.(v "git" % "add" % "foo") >>= fun () -> - Bos.OS.Cmd.run Bos.Cmd.(v "git" % "commit" % "-m" % ".") >>= fun () -> + OS.File.write (Fpath.v "foo") "" >>= fun () -> + OS.Cmd.run Cmd.(v "git" % "add" % "foo") >>= fun () -> + OS.Cmd.run Cmd.(v "git" % "commit" % "-m" % ".") >>= fun () -> let out = - Bos.OS.Cmd.run_out - Bos.Cmd.(v "git" % "show" % "-s" % "--pretty=format:%H" % "HEAD") + OS.Cmd.run_out + Cmd.(v "git" % "show" % "-s" % "--pretty=format:%H" % "HEAD") in - Bos.OS.Cmd.out_lines ~trim:true out + OS.Cmd.out_lines ~trim:true out in - match Rresult.R.join (commit ()) with + match R.join (commit ()) with | Ok (head :: _, _) -> Lwt.return_ok head - | Ok ([], _) -> Lwt.return_error (Rresult.R.msgf "[commit_foo]") + | Ok ([], _) -> Lwt.return_error (R.msgf "[commit_foo]") | Error err -> Lwt.return_error err let test_simple_push () = @@ -503,9 +552,9 @@ let test_fetch_empty () = Fpath.(path / ".git" / "objects" / "pack") ) in let ctx = ctx_with_payloads payloads in - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> - Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> + OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> Git.fetch ~ctx ~capabilities access store endpoint `All pack index ~src:tmp0 @@ -522,7 +571,7 @@ let test_fetch_empty () = / "pack" / Fmt.str "pack-%a.pack" Uid.pp uid) in - Bos.OS.Path.move tmp1 dst |> Lwt.return >>? fun () -> + OS.Path.move tmp1 dst |> Lwt.return >>? fun () -> let dst = Fpath.( path @@ -531,15 +580,15 @@ let test_fetch_empty () = / "pack" / Fmt.str "pack-%a.idx" Uid.pp uid) in - Bos.OS.Path.move tmp2 dst |> Lwt.return >>? fun () -> + OS.Path.move tmp2 dst |> Lwt.return >>? fun () -> let update (refname, uid) = - Bos.OS.Dir.with_current path @@ fun () -> - Bos.OS.Cmd.run - Bos.Cmd.( + OS.Dir.with_current path @@ fun () -> + OS.Cmd.run + Cmd.( v "git" % "update-ref" % Ref.to_string refname % Uid.to_hex uid) in List.fold_right - (fun v -> function Ok a -> Rresult.R.join (update v a) | err -> err) + (fun v -> function Ok a -> R.join (update v a) | err -> err) refs (Ok ()) |> Lwt.return >>? fun () -> @@ -596,9 +645,9 @@ let test_fetch_empty () = ] in let ctx = ctx_with_payloads payloads in - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> - Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> + OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> @@ -615,15 +664,15 @@ let test_fetch_empty () = let update_testzone_0 store = let { path; _ } = store_prj store in let update = - Bos.OS.Dir.with_current path @@ fun () -> - Bos.OS.Cmd.run - Bos.Cmd.( + OS.Dir.with_current path @@ fun () -> + OS.Cmd.run + Cmd.( v "git" % "update-ref" % "refs/heads/master" % "f08d64523257528980115942481d5ddd13d2c1ba") in - match Rresult.R.join (update ()) with + match R.join (update ()) with | Ok () -> Lwt.return_ok () | Error err -> Lwt.return_error err @@ -1027,21 +1076,21 @@ let test_negotiation () = ( Fpath.(path / ".git" / "objects" / "pack"), Fpath.(path / ".git" / "objects" / "pack") ) in - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-0.pack") Fpath.(pack / "pack-4aae6e55c118eb1ab3d1e2cd5a7e4857faa23d4e.pack") |> Lwt.return >>? fun () -> - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-0.idx") Fpath.(pack / "pack-4aae6e55c118eb1ab3d1e2cd5a7e4857faa23d4e.idx") |> Lwt.return >>? fun () -> update_testzone_0 store >>? fun () -> let ctx = ctx_with_payloads payloads in - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> - Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> + OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> Git.fetch ~ctx ~capabilities access store endpoint `All pack index ~src:tmp0 @@ -1054,62 +1103,25 @@ let test_negotiation () = | Error (#Mimic.error as err) -> Alcotest.failf "%a" Mimic.pp_error err | Error `Invalid_flow -> Alcotest.fail "Invalid flow" -(* XXX(dinosaure): FIFO "à la BOS".*) - -let rec unlink_fifo fifo = - try Unix.unlink (Fpath.to_string fifo) with - | Unix.Unix_error (Unix.EINTR, _, _) -> unlink_fifo fifo - | Unix.Unix_error _ -> () - -let fifos = ref Fpath.Set.empty -let fifos_add fifo = fifos := Fpath.Set.add fifo !fifos -let unlink_fifos () = Fpath.Set.iter unlink_fifo !fifos -let () = at_exit unlink_fifos - -let create_fifo_path mode dir pat = - let err () = - Rresult.R.error_msgf - "create temporary fifo %s in %a: too many failing attempts" - (Fmt.str pat "XXXXXX") Fpath.pp dir - in - let rec loop count = - if count < 0 then err () - else - let file = - let rand = Random.bits () land 0xffffff in - Fpath.(dir / Fmt.str pat (Fmt.str "%06x" rand)) - in - let sfile = Fpath.to_string file in - try Ok (file, Unix.mkfifo sfile mode) with - | Unix.Unix_error (Unix.EEXIST, _, _) -> loop (count - 1) - | Unix.Unix_error (Unix.EINTR, _, _) -> loop count - | Unix.Unix_error (e, _, _) -> - Rresult.R.error_msgf "create temporary fifo %a: %s" Fpath.pp file - (Unix.error_message e) - in - loop 10000 - -let with_fifo ?(mode = 0o600) ?dir pat = - let dir = match dir with None -> Bos.OS.Dir.default_tmp () | Some d -> d in - create_fifo_path mode dir pat >>= fun (file, ()) -> - fifos_add file; - Ok file - let ( <.> ) f g x = f (g x) -let run_git_upload_pack ?(tmps_exit = true) store ic oc = +let run_git_upload_pack ?(git_proto_v = 1) ?(tmps_exit = true) store ic oc = let { path; _ } = store_prj store in let process = - Bos.OS.Dir.with_current path @@ fun () -> - let tee = Bos.Cmd.(v "tee" % Fpath.to_string ic) in - let cat = Bos.Cmd.(v "cat" % Fpath.to_string oc) in - let git_upload_pack = - Bos.Cmd.(v "git-upload-pack" % Fpath.to_string path) - in + OS.Dir.with_current path @@ fun () -> + let tee = Cmd.(v "tee" % Fpath.to_string ic) in + let cat = Cmd.(v "cat" % Fpath.to_string oc) in + let git_upload_pack = Cmd.(v "git-upload-pack" % Fpath.to_string path) in let pipe () = - Bos.OS.Cmd.run_out cat |> Bos.OS.Cmd.out_run_in >>= fun cat -> - Bos.OS.Cmd.run_io git_upload_pack cat |> Bos.OS.Cmd.out_run_in - >>= fun git -> Bos.OS.Cmd.run_in tee git + OS.Cmd.run_out cat |> OS.Cmd.out_run_in >>= fun cat -> + let env = + match git_proto_v with + | 1 -> String.Map.empty + | 2 -> String.Map.singleton "GIT_PROTOCOL" "version=2" + | _ -> assert false + in + OS.Cmd.run_io ~env git_upload_pack cat |> OS.Cmd.out_run_in >>= fun git -> + OS.Cmd.run_in tee git in match Unix.fork () with | 0 -> ( @@ -1123,7 +1135,7 @@ let run_git_upload_pack ?(tmps_exit = true) store ic oc = Logs.app (fun m -> m "git-upload-pack launched!"); Lwt.return_unit in - Rresult.R.failwith_error_msg <.> process + R.failwith_error_msg <.> process let always v _ = v @@ -1136,12 +1148,12 @@ let test_ssh () = create_new_git_store sw >>= fun (_access, store0) -> let { path; _ } = store_prj store0 in let pack = Fpath.(path / ".git" / "objects" / "pack") in - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-0.pack") Fpath.(pack / "pack-4aae6e55c118eb1ab3d1e2cd5a7e4857faa23d4e.pack") |> Lwt.return >>? fun () -> - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-0.idx") Fpath.(pack / "pack-4aae6e55c118eb1ab3d1e2cd5a7e4857faa23d4e.idx") |> Lwt.return @@ -1165,9 +1177,9 @@ let test_ssh () = in let capabilities = [] in let ctx = ctx_with_fifo ic_fifo oc_fifo in - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> - Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> + OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git@localhost:not-found.git" |> Lwt.return >>? fun endpoint -> Logs.app (fun m -> m "Waiting git-upload-pack."); @@ -1186,15 +1198,15 @@ let test_ssh () = let update_testzone_1 store = let { path; _ } = store_prj store in let update = - Bos.OS.Dir.with_current path @@ fun () -> - Bos.OS.Cmd.run - Bos.Cmd.( + OS.Dir.with_current path @@ fun () -> + OS.Cmd.run + Cmd.( v "git" % "update-ref" % "refs/heads/master" % "b88599cb4217c175110f6e2a810079d954524814") in - match Rresult.R.join (update ()) with + match R.join (update ()) with | Ok () -> Lwt.return_ok () | Error err -> Lwt.return_error err @@ -1207,12 +1219,12 @@ let test_negotiation_ssh () = create_new_git_store sw >>= fun (_access, store0) -> let { path; _ } = store_prj store0 in let pack = Fpath.(path / ".git" / "objects" / "pack") in - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-1.pack") Fpath.(pack / "pack-02e2924e51b624461d8ee6706a455c5ce1a6ad80.pack") |> Lwt.return >>? fun () -> - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-1.idx") Fpath.(pack / "pack-02e2924e51b624461d8ee6706a455c5ce1a6ad80.idx") |> Lwt.return @@ -1234,12 +1246,12 @@ let test_negotiation_ssh () = ( Fpath.(path / ".git" / "objects" / "pack"), Fpath.(path / ".git" / "objects" / "pack") ) in - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-0.pack") Fpath.(pack / "pack-4aae6e55c118eb1ab3d1e2cd5a7e4857faa23d4e.pack") |> Lwt.return >>? fun () -> - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-0.idx") Fpath.(pack / "pack-4aae6e55c118eb1ab3d1e2cd5a7e4857faa23d4e.idx") |> Lwt.return @@ -1249,9 +1261,9 @@ let test_negotiation_ssh () = [ `Side_band_64k; `Multi_ack_detailed; `Thin_pack; `Ofs_delta ] in let ctx = ctx_with_fifo ic_fifo oc_fifo in - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> - Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> + OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git@localhost:not-found.git" |> Lwt.return >>? fun endpoint -> Logs.app (fun m -> m "Waiting git-upload-pack."); @@ -1270,20 +1282,18 @@ let test_negotiation_ssh () = let run_git_receive_pack store ic oc = let { path; _ } = store_prj store in let process = - Bos.OS.Dir.with_current path @@ fun () -> - let tee = Bos.Cmd.(v "tee" % Fpath.to_string ic) in - let cat = Bos.Cmd.(v "cat" % Fpath.to_string oc) in - let git_receive_pack = - Bos.Cmd.(v "git-receive-pack" % Fpath.to_string path) - in + OS.Dir.with_current path @@ fun () -> + let tee = Cmd.(v "tee" % Fpath.to_string ic) in + let cat = Cmd.(v "cat" % Fpath.to_string oc) in + let git_receive_pack = Cmd.(v "git-receive-pack" % Fpath.to_string path) in let pipe () = - Bos.OS.Cmd.run - Bos.Cmd.( + OS.Cmd.run + Cmd.( v "git" % "config" % "--add" % "receive.denyCurrentBranch" % "ignore") >>= fun () -> - Bos.OS.Cmd.run_out cat |> Bos.OS.Cmd.out_run_in >>= fun cat -> - Bos.OS.Cmd.run_io git_receive_pack cat |> Bos.OS.Cmd.out_run_in - >>= fun git -> Bos.OS.Cmd.run_in tee git + OS.Cmd.run_out cat |> OS.Cmd.out_run_in >>= fun cat -> + OS.Cmd.run_io git_receive_pack cat |> OS.Cmd.out_run_in >>= fun git -> + OS.Cmd.run_in tee git in match Unix.fork () with | 0 -> ( @@ -1297,7 +1307,7 @@ let run_git_receive_pack store ic oc = Logs.app (fun m -> m "git-receive-pack launched!"); Lwt.return_unit in - Rresult.R.failwith_error_msg <.> process + R.failwith_error_msg <.> process let test_push_ssh () = Alcotest_lwt.test_case "push over ssh" `Quick @@ fun sw () -> @@ -1308,12 +1318,12 @@ let test_push_ssh () = create_new_git_store sw >>= fun (_access, store0) -> let { path; _ } = store_prj store0 in let pack = Fpath.(path / ".git" / "objects" / "pack") in - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-0.pack") Fpath.(pack / "pack-4aae6e55c118eb1ab3d1e2cd5a7e4857faa23d4e.pack") |> Lwt.return >>? fun () -> - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-0.idx") Fpath.(pack / "pack-4aae6e55c118eb1ab3d1e2cd5a7e4857faa23d4e.idx") |> Lwt.return @@ -1326,12 +1336,12 @@ let test_push_ssh () = create_new_git_push_store sw >>= fun (access, store1) -> let { path; _ } = store_prj store1 in let pack = Fpath.(path / ".git" / "objects" / "pack") in - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-1.pack") Fpath.(pack / "pack-02e2924e51b624461d8ee6706a455c5ce1a6ad80.pack") |> Lwt.return >>? fun () -> - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-1.idx") Fpath.(pack / "pack-02e2924e51b624461d8ee6706a455c5ce1a6ad80.idx") |> Lwt.return @@ -1350,14 +1360,12 @@ let test_push_ssh () = run () >>= function | Ok path -> ( let run = - Bos.OS.Dir.with_current path @@ fun () -> - let cmd = - Bos.Cmd.(v "git" % "show-ref" % "--heads" % "master" % "-s") - in - let run = Bos.OS.Cmd.run_out cmd in - Bos.OS.Cmd.out_lines ~trim:true run + OS.Dir.with_current path @@ fun () -> + let cmd = Cmd.(v "git" % "show-ref" % "--heads" % "master" % "-s") in + let run = OS.Cmd.run_out cmd in + OS.Cmd.out_lines ~trim:true run in - match Rresult.R.join (run ()) with + match R.join (run ()) with | Ok ([ hash ], _) -> Alcotest.(check string) "push" hash "b88599cb4217c175110f6e2a810079d954524814"; @@ -1394,20 +1402,20 @@ let test_negotiation_http () = ( Fpath.(path / ".git" / "objects" / "pack"), Fpath.(path / ".git" / "objects" / "pack") ) in - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-0.pack") Fpath.(pack / "pack-4aae6e55c118eb1ab3d1e2cd5a7e4857faa23d4e.pack") |> Lwt.return >>? fun () -> - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-0.idx") Fpath.(pack / "pack-4aae6e55c118eb1ab3d1e2cd5a7e4857faa23d4e.idx") |> Lwt.return >>? fun () -> update_testzone_0 store >>? fun () -> - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> - Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> + OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "http://localhost/not-found.git" |> Lwt.return >>? fun endpoint -> let queue = Queue.create () in @@ -1431,12 +1439,12 @@ let test_partial_clone_ssh () = create_new_git_store sw >>= fun (_access, store0) -> let { path; _ } = store_prj store0 in let pack = Fpath.(path / ".git" / "objects" / "pack") in - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-0.pack") Fpath.(pack / "pack-4aae6e55c118eb1ab3d1e2cd5a7e4857faa23d4e.pack") |> Lwt.return >>? fun () -> - Bos.OS.Path.link + OS.Path.link ~target:(Fpath.v "pack-testzone-0.idx") Fpath.(pack / "pack-4aae6e55c118eb1ab3d1e2cd5a7e4857faa23d4e.idx") |> Lwt.return @@ -1460,9 +1468,9 @@ let test_partial_clone_ssh () = in let capabilities = [] in let ctx = ctx_with_fifo ic_fifo oc_fifo in - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> - Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> + OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Smart_git.Endpoint.of_string "git@localhost:not-found.git" |> Lwt.return >>? fun endpoint -> Logs.app (fun m -> m "Waiting git-upload-pack."); @@ -1495,16 +1503,15 @@ let test_partial_fetch_ssh () = let fiber = let open Rresult in OS.Dir.with_current path @@ fun () -> - OS.Cmd.run Bos.Cmd.(v "git" % "config" % "user.name" % "test") - >>= fun () -> + OS.Cmd.run Cmd.(v "git" % "config" % "user.name" % "test") >>= fun () -> OS.Cmd.run - Bos.Cmd.(v "git" % "config" % "user.email" % "pseudo@pseudo.invalid") + Cmd.(v "git" % "config" % "user.email" % "pseudo@pseudo.invalid") >>= fun () -> OS.Cmd.run Cmd.(v "touch" % "foo") >>= fun () -> OS.Cmd.run Cmd.(v "git" % "add" % "foo") >>= fun () -> OS.Cmd.run Cmd.(v "git" % "commit" % "-m" % ".") in - (Lwt.return <.> Rresult.R.join) (fiber ()) >>? fun () -> + (Lwt.return <.> R.join) (fiber ()) >>? fun () -> Lwt.return_ok (access, store) in let fill1 store = @@ -1513,10 +1520,9 @@ let test_partial_fetch_ssh () = let fiber = let open Rresult in OS.Dir.with_current path @@ fun () -> - OS.Cmd.run Bos.Cmd.(v "git" % "config" % "user.name" % "test") - >>= fun () -> + OS.Cmd.run Cmd.(v "git" % "config" % "user.name" % "test") >>= fun () -> OS.Cmd.run - Bos.Cmd.(v "git" % "config" % "user.email" % "pseudo@pseudo.invalid") + Cmd.(v "git" % "config" % "user.email" % "pseudo@pseudo.invalid") >>= fun () -> OS.Cmd.run Cmd.(v "touch" % "bar") >>= fun () -> OS.Cmd.run Cmd.(v "git" % "add" % "bar") >>= fun () -> @@ -1524,14 +1530,13 @@ let test_partial_fetch_ssh () = OS.Cmd.run Cmd.(v "git" % "rm" % "foo") >>= fun () -> OS.Cmd.run Cmd.(v "git" % "commit" % "-m" % ".") in - (Lwt.return <.> Rresult.R.join) (fiber ()) + (Lwt.return <.> R.join) (fiber ()) in let capabilities = [ `Side_band_64k; `Multi_ack_detailed; `Thin_pack; `Ofs_delta ] in let endpoint = - Rresult.R.get_ok - (Smart_git.Endpoint.of_string "git@localhost:not-found.git") + R.get_ok (Smart_git.Endpoint.of_string "git@localhost:not-found.git") in let run () = fill0 () >>? fun (_access, store0) -> @@ -1541,9 +1546,9 @@ let test_partial_fetch_ssh () = process () >>= fun () -> create_new_git_store sw >>= fun (access, store1) -> let ctx = ctx_with_fifo ic_fifo oc_fifo in - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> - Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> + OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> let pack, index = let { path; _ } = store_prj store1 in ( Fpath.(path / ".git" / "objects" / "pack"), @@ -1566,7 +1571,7 @@ let test_partial_fetch_ssh () = / "pack" / Fmt.str "pack-%a.pack" Uid.pp uid) in - Bos.OS.Path.move tmp1 dst |> Lwt.return >>? fun () -> + OS.Path.move tmp1 dst |> Lwt.return >>? fun () -> let dst = Fpath.( path @@ -1575,15 +1580,15 @@ let test_partial_fetch_ssh () = / "pack" / Fmt.str "pack-%a.idx" Uid.pp uid) in - Bos.OS.Path.move tmp2 dst |> Lwt.return >>? fun () -> + OS.Path.move tmp2 dst |> Lwt.return >>? fun () -> let update (refname, uid) = - Bos.OS.Dir.with_current path @@ fun () -> - Bos.OS.Cmd.run - Bos.Cmd.( + OS.Dir.with_current path @@ fun () -> + OS.Cmd.run + Cmd.( v "git" % "update-ref" % Ref.to_string refname % Uid.to_hex uid) in List.fold_right - (fun v -> function Ok a -> Rresult.R.join (update v a) | err -> err) + (fun v -> function Ok a -> R.join (update v a) | err -> err) refs (Ok ()) |> Lwt.return >>? fun () -> @@ -1595,9 +1600,9 @@ let test_partial_fetch_ssh () = in process () >>= fun () -> let ctx = ctx_with_fifo ic_fifo oc_fifo in - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> - Bos.OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> - Bos.OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp0 -> + OS.File.tmp "pack-%s.pack" |> Lwt.return >>? fun tmp1 -> + OS.File.tmp "pack-%s.idx" |> Lwt.return >>? fun tmp2 -> Logs.app (fun m -> m "Waiting git-upload-pack."); Logs.app (fun m -> m "Start to fetch repository with SSH."); Git.fetch ~ctx ~capabilities access store1 endpoint ~deepen:(`Depth 1) @@ -1653,18 +1658,174 @@ let test_push_empty () = let update_testzone_1 store = let { path; _ } = store_prj store in let update = - Bos.OS.Dir.with_current path @@ fun () -> - Bos.OS.Cmd.run - Bos.Cmd.( + OS.Dir.with_current path @@ fun () -> + OS.Cmd.run + Cmd.( v "git" % "update-ref" % "refs/heads/master" % "b88599cb4217c175110f6e2a810079d954524814") in - match Rresult.R.join (update ()) with + match R.join (update ()) with | Ok () -> Lwt.return_ok () | Error err -> Lwt.return_error err +module Proto_v2 = struct + module Scheduler = Hkt.Make_sched (Lwt) + + module Uid = struct + type t = string + + let of_hex v = v + let to_hex v = v + let compare = String.compare + end + + module Ref = struct + type t = string + + let v t = t + let equal = String.equal + let to_string s = s + end + + module Flow = Unixiz.Make (Mimic) + module Fetch = Nss.Fetch.Make (Scheduler) (Lwt) (Flow) (Uid) (Ref) + + let ( let*! ) x f = x >>? f + + let test_get_server_capabilities = + Alcotest_lwt.test_case "can connect and get server capabilities" `Quick + @@ fun sw () -> + let open Lwt.Syntax in + let* _access, store = create_new_git_store sw in + let { path; _ } = store_prj store in + let cwd = Fpath.to_string path in + let ctx = + ctx_with_pipe ~cwd + ~env:[| "GIT_PROTOCOL=version=2" |] + ~args:[| "git-upload-pack"; cwd |] + "" + in + let* flow = Mimic.resolve ctx in + match flow with + | Error e -> + Fmt.failwith "couldn't resolve flow; mimic error %a" Mimic.pp_error e + | Ok flow -> + let flow = Flow.make flow in + let host = + Domain_name.of_string_exn "localhost" |> Domain_name.host |> R.get_ok + in + let path = "not-found.git" in + let proto_ctx = Wire_proto_v2.Context.make ~client_caps:[] in + let* capabilities = + Fetch.V2.get_server_capabilities ~uses_git_transport:false ~host ~path + proto_ctx flow + in + Alcotest.(check bool) + "capability list is not empty" + (List.length capabilities > 0) + true; + Lwt.return () + + let test_ls_refs_request = + Alcotest_lwt.test_case + "can successfully run ls-refs command with no refs in store" `Quick + @@ fun sw () -> + let open Lwt.Syntax in + let* _access, store = create_new_git_store sw in + let { path; _ } = store_prj store in + let cwd = Fpath.to_string path in + let ctx = + ctx_with_pipe ~cwd + ~env:[| "GIT_PROTOCOL=version=2" |] + ~args:[| "git-upload-pack"; cwd |] + "" + in + let* flow = Mimic.resolve ctx in + match flow with + | Error e -> + Fmt.failwith "couldn't resolve flow; mimic error %a" Mimic.pp_error e + | Ok flow -> + let flow = Flow.make flow in + let host = + Domain_name.of_string_exn "localhost" |> Domain_name.host |> R.get_ok + in + let path = "not-found.git" in + let proto_ctx = Wire_proto_v2.Context.make ~client_caps:[] in + let* ref_list = + let request = + Wire_proto_v2.Proto_vals_v2.Ls_refs.make_request ~symrefs:false + ~peel:false [] + in + Fetch.V2.ls_refs_request ~uses_git_transport:false ~host ~path + proto_ctx flow request + in + Alcotest.(check bool) + "capability list is empty" + (List.length ref_list = 0) + true; + Lwt.return () + + let test_ls_refs_request_has_refs = + Alcotest_lwt.test_case + "can successfully run ls-refs command with a ref in store" `Quick + @@ fun sw () -> + let open Lwt.Syntax in + let* _access, store = create_new_git_store sw in + let { path; _ } = store_prj store in + match + let open Rresult in + OS.Dir.with_current path + (fun () -> + OS.Cmd.run Cmd.(v "touch" % "empty") >>= fun () -> + OS.Cmd.run Cmd.(v "git" % "add" % "empty") >>= fun () -> + OS.Cmd.run Cmd.(v "git" % "commit" % "-m" % "empty")) + () + |> Rresult.R.join + with + | Ok () -> ( + let cwd = Fpath.to_string path in + let ctx = + ctx_with_pipe ~cwd + ~env:[| "GIT_PROTOCOL=version=2" |] + ~args:[| "git-upload-pack"; cwd |] + "" + in + let* flow = Mimic.resolve ctx in + match flow with + | Error e -> + Fmt.failwith "couldn't resolve flow; mimic error %a" Mimic.pp_error + e + | Ok flow -> + let flow = Flow.make flow in + let host = + Domain_name.of_string_exn "localhost" + |> Domain_name.host + |> R.get_ok + in + let path = "not-found.git" in + let proto_ctx = Wire_proto_v2.Context.make ~client_caps:[] in + let* ref_list = + let request = + Wire_proto_v2.Proto_vals_v2.Ls_refs.make_request ~symrefs:false + ~peel:false [] + in + Fetch.V2.ls_refs_request ~uses_git_transport:false ~host ~path + proto_ctx flow request + in + List.iter + (fun ({ name; _ } : Wire_proto_v2.Proto_vals_v2.Ls_refs.ref_) -> + print_endline name) + ref_list; + Alcotest.(check bool) + "capability list is not empty" + (List.length ref_list > 0) + true; + Lwt.return ()) + | Error _ as e -> R.error_msg_to_invalid_arg e +end + let test = Alcotest_lwt.run "smart" [ @@ -1676,17 +1837,21 @@ let test = test_negotiation_http (); test_partial_clone_ssh (); test_partial_fetch_ssh (); test_sync_fetch (); test_push_empty (); ] ); + ( "protocol-v2", + Proto_v2. + [ + test_get_server_capabilities; test_ls_refs_request; + test_ls_refs_request_has_refs; + ] ); ] let tmp = "tmp" let () = - let open Rresult in let fiber = - Bos.OS.Dir.current () >>= fun current -> - Bos.OS.Dir.create Fpath.(current / tmp) >>= fun _ -> - R.ok Fpath.(current / tmp) + OS.Dir.current () >>= fun current -> + OS.Dir.create Fpath.(current / tmp) >>= fun _ -> R.ok Fpath.(current / tmp) in let tmp = R.failwith_error_msg fiber in - Bos.OS.Dir.set_default_tmp tmp; + OS.Dir.set_default_tmp tmp; Lwt_main.run test From c3942545bf313b6d872bd149326edcd8b25a1f83 Mon Sep 17 00:00:00 2001 From: Ulugbek Abdullaev Date: Mon, 8 Feb 2021 12:57:37 +0500 Subject: [PATCH 4/6] we want 'state_flow.ml' (previously 'smart_flow.ml'), a module that translates state read-write monad into 'flow' operations, to be usable both by 'Smart' and 'Wire_proto_v2'; hence, they shouldn't have own copies of Context --- fuzz/dune | 2 +- src/git/dune | 9 ++++---- src/not-so-smart/dune | 25 ++++++++++++-------- src/not-so-smart/fetch.mli | 2 +- src/not-so-smart/smart.ml | 28 ++--------------------- src/not-so-smart/state.ml | 38 +++++++++++++++++++------------ src/not-so-smart/state.mli | 21 ++++++++++------- src/not-so-smart/state_flow.ml | 16 ++++++------- src/not-so-smart/wire_proto_v2.ml | 28 ++--------------------- test/smart/dune | 12 +++++----- 10 files changed, 78 insertions(+), 103 deletions(-) diff --git a/fuzz/dune b/fuzz/dune index 2958a4957..a31aa53a6 100644 --- a/fuzz/dune +++ b/fuzz/dune @@ -11,7 +11,7 @@ (executable (name smart) (modules smart) - (libraries fmt crowbar digestif.c git.nss.smart)) + (libraries capability fmt crowbar digestif.c git.nss.smart)) (rule (alias runtest) diff --git a/src/git/dune b/src/git/dune index a2751b0ae..1cc46266a 100644 --- a/src/git/dune +++ b/src/git/dune @@ -1,7 +1,8 @@ (library (name git) (public_name git) - (libraries bigarray-compat mimic rresult git.nss.sigs git.nss.pck optint - loose decompress.de decompress.zl result git.nss.smart logs lwt cstruct - angstrom bigstringaf carton ke fmt checkseum git.nss.git git.nss.hkt - ocamlgraph astring fpath loose_git carton-lwt carton-git digestif encore)) + (libraries bigarray-compat capability mimic rresult git.nss.sigs git.nss.pck + optint loose decompress.de decompress.zl result git.nss.smart logs lwt + cstruct angstrom bigstringaf carton ke fmt checkseum git.nss.git + git.nss.hkt ocamlgraph astring fpath loose_git carton-lwt carton-git + digestif encore)) diff --git a/src/not-so-smart/dune b/src/not-so-smart/dune index 38b30d3de..7f3913559 100644 --- a/src/not-so-smart/dune +++ b/src/not-so-smart/dune @@ -8,14 +8,20 @@ (name state) (public_name git.nss.state) (modules state) - (libraries git.nss.pkt-line fmt)) + (libraries git.nss.capability git.nss.pkt-line fmt)) + +(library + (name capability) + (public_name git.nss.capability) + (modules capability) + (libraries astring fmt)) (library (name smart) (public_name git.nss.smart) - (modules smart filter capability protocol) - (libraries git.nss.pkt-line git.nss.state result rresult ipaddr domain-name - astring fmt)) + (modules smart filter protocol) + (libraries git.nss.pkt-line git.nss.state capability result rresult ipaddr + domain-name astring fmt)) (library (name wire_proto_v2) @@ -52,14 +58,14 @@ (name pck) (public_name git.nss.pck) (modules pck) - (libraries sigs psq logs smart)) + (libraries sigs capability psq logs smart)) (library (name nss) (public_name git.nss) (modules nss fetch push) (libraries fmt result rresult logs ipaddr domain-name smart sigs neg pck - git.nss.state-flow git.nss.state wire_proto_v2)) + capability git.nss.state-flow git.nss.state wire_proto_v2)) (library (name unixiz) @@ -72,6 +78,7 @@ (name smart_git) (public_name git.nss.git) (modules smart_git smart_git_intf) - (libraries bigarray-compat mimic mirage-flow unixiz ipaddr decompress.de - decompress.zl cstruct logs astring result rresult bigstringaf fmt emile - lwt domain-name uri sigs smart pck nss digestif carton carton-lwt)) + (libraries bigarray-compat capability mimic mirage-flow unixiz ipaddr + decompress.de decompress.zl cstruct logs astring result rresult + bigstringaf fmt emile lwt domain-name uri sigs smart pck nss digestif + carton carton-lwt)) diff --git a/src/not-so-smart/fetch.mli b/src/not-so-smart/fetch.mli index 33dfec5dc..b13dbf88e 100644 --- a/src/not-so-smart/fetch.mli +++ b/src/not-so-smart/fetch.mli @@ -44,7 +44,7 @@ module Make ?uses_git_transport:bool -> host:[ `host ] Domain_name.t -> path:string -> - Wire_proto_v2.Context.capabilities State.Context.t -> + State.Context.t -> Flow.t -> Wire_proto_v2.Proto_vals_v2.Ls_refs.request -> Wire_proto_v2.Proto_vals_v2.Ls_refs.response IO.t diff --git a/src/not-so-smart/smart.ml b/src/not-so-smart/smart.ml index be2127b81..b462d549b 100644 --- a/src/not-so-smart/smart.ml +++ b/src/not-so-smart/smart.ml @@ -110,31 +110,7 @@ type ('a, 'err) t = ('a, 'err) State.t = | Return of 'a | Error of 'err -module Context = struct - type capabilities = { - client_caps : Capability.t list; - server_caps : Capability.t list; - } - - let pp_capabilities _ppf _v = () - - include State.Context - - type nonrec t = capabilities t - - let make ~client_caps = make { client_caps; server_caps = [] } - let pp ppf v = pp pp_capabilities ppf v - let capabilities ctx = context ctx - - let replace_server_caps ctx caps = - update ~f:(fun ~old_ctx -> { old_ctx with server_caps = caps }) ctx - - let is_cap_shared ctx cap = - let { client_caps; server_caps } = capabilities ctx in - let is_cap_in caps = List.exists (fun c -> Capability.equal c cap) caps in - is_cap_in client_caps && is_cap_in server_caps -end - +module Context = State.Context include Witness let proto_request = Proto_request @@ -159,7 +135,7 @@ let send_pack ?(stateless = false) side_band = let packet ~trim = Packet trim let send_advertised_refs : _ send = Advertised_refs -include State.Scheduler (Context) (Value) +include State.Scheduler (Value) let pp_error ppf = function | #Protocol.Encoder.error as err -> Protocol.Encoder.pp_error ppf err diff --git a/src/not-so-smart/state.ml b/src/not-so-smart/state.ml index 13c38c033..371e23776 100644 --- a/src/not-so-smart/state.ml +++ b/src/not-so-smart/state.ml @@ -34,33 +34,43 @@ module type VALUE = sig end module Context = struct - open Pkt_line + type capabilities = { + client_caps : Capability.t list; + server_caps : Capability.t list; + } - type 'ctx t = { - encoder : Encoder.encoder; - decoder : Decoder.decoder; - mutable ctx : 'ctx; + type t = { + encoder : Pkt_line.Encoder.encoder; + decoder : Pkt_line.Decoder.decoder; + mutable capabilities : capabilities; } - type encoder = Encoder.encoder - type decoder = Decoder.decoder + type encoder = Pkt_line.Encoder.encoder + type decoder = Pkt_line.Decoder.decoder let pp _pp_ctx _ppf _t = () - let make ctx = - { encoder = Encoder.create (); decoder = Decoder.create (); ctx } + let make ~client_caps = + let capabilities = { client_caps; server_caps = [] } in + { + encoder = Pkt_line.Encoder.create (); + decoder = Pkt_line.Decoder.create (); + capabilities; + } let encoder { encoder; _ } = encoder let decoder { decoder; _ } = decoder - let context { ctx; _ } = ctx + let capabilities { capabilities; _ } = capabilities + + let replace_server_caps ctx server_caps = + ctx.capabilities <- { ctx.capabilities with server_caps } - let update t ~(f : old_ctx:'ctx -> 'ctx) = - let new_ctx = f ~old_ctx:t.ctx in - t.ctx <- new_ctx + let is_cap_shared { capabilities = { client_caps; server_caps }; _ } cap = + let is_cap_in caps = List.exists (fun c -> Capability.equal c cap) caps in + is_cap_in client_caps && is_cap_in server_caps end module Scheduler - (Context : CONTEXT) (Value : VALUE with type encoder = Context.encoder and type decoder = Context.decoder) = diff --git a/src/not-so-smart/state.mli b/src/not-so-smart/state.mli index f5ec304f7..9b382edbf 100644 --- a/src/not-so-smart/state.mli +++ b/src/not-so-smart/state.mli @@ -33,20 +33,25 @@ module type VALUE = sig end module Context : sig - type 'ctx t + type t type encoder = Pkt_line.Encoder.encoder type decoder = Pkt_line.Decoder.decoder - val pp : 'ctx Fmt.t -> 'ctx t Fmt.t - val encoder : 'ctx t -> encoder - val decoder : 'ctx t -> decoder - val make : 'ctx -> 'ctx t - val context : 'ctx t -> 'ctx - val update : 'ctx t -> f:(old_ctx:'ctx -> 'ctx) -> unit + type capabilities = { + client_caps : Capability.t list; + server_caps : Capability.t list; + } + + val pp : Capability.t Fmt.t -> t Fmt.t + val make : client_caps:Capability.t list -> t + val encoder : t -> encoder + val decoder : t -> decoder + val capabilities : t -> capabilities + val replace_server_caps : t -> Capability.t list -> unit + val is_cap_shared : t -> Capability.t -> bool end module Scheduler - (Context : CONTEXT) (Value : VALUE with type encoder = Context.encoder and type decoder = Context.decoder) : sig diff --git a/src/not-so-smart/state_flow.ml b/src/not-so-smart/state_flow.ml index a9a0217c7..a9bb6ef67 100644 --- a/src/not-so-smart/state_flow.ml +++ b/src/not-so-smart/state_flow.ml @@ -24,7 +24,7 @@ struct fl -> ('res, [ `Protocol of error ]) Read_write.t -> ('res, s) io = - fun scheduler io_raise _Flow flow state -> + fun scheduler io_raise flow_ops flow state -> let { bind; return } = scheduler in let ( >>= ) = bind in @@ -45,7 +45,7 @@ struct | Read { k; buffer; off; len; eof } -> ( let rd_n_bytes = min (Cstruct.len cbuff) len in Log.debug (fun m -> m "Start to read %d byte(s)." rd_n_bytes); - _Flow.recv flow (Cstruct.sub cbuff 0 rd_n_bytes) >>= function + flow_ops.recv flow (Cstruct.sub cbuff 0 rd_n_bytes) >>= function | Ok `End_of_flow -> Log.debug (fun m -> m "Got end of input."); unwrap (eof ()) @@ -54,20 +54,20 @@ struct Cstruct.blit_to_bytes cbuff 0 buffer off len; unwrap (k len) | Error err -> - Log.err (fun m -> m "Got an error: %a." _Flow.pp_error err); - failwithf "%a" _Flow.pp_error err) + Log.err (fun m -> m "Got an error: %a." flow_ops.pp_error err); + failwithf "%a" flow_ops.pp_error err) | Write { k; buffer; off; len } -> - (* TODO: Avoid writing by loop if we can; - otherwise, the loop writes once and terminates *) + (* TODO: almost always we can write in one go instead of calling a loop, + so we should try writing and call loop if we aren't done *) let rec loop tmp = if Cstruct.is_empty tmp then unwrap (k len) else - _Flow.send flow tmp >>= function + flow_ops.send flow tmp >>= function | Ok shift -> Log.debug (fun m -> m "Wrote %d byte(s). %s" shift (Cstruct.to_string tmp)); loop (Cstruct.shift tmp shift) - | Error err -> failwithf "%a" _Flow.pp_error err + | Error err -> failwithf "%a" flow_ops.pp_error err in Cstruct.of_string buffer ~off ~len |> loop in diff --git a/src/not-so-smart/wire_proto_v2.ml b/src/not-so-smart/wire_proto_v2.ml index 4937513bb..2b537b82f 100644 --- a/src/not-so-smart/wire_proto_v2.ml +++ b/src/not-so-smart/wire_proto_v2.ml @@ -18,31 +18,7 @@ module Witness = struct | Ls_refs_res : Proto_vals_v2.Ls_refs.response recv end -(* TODO: copy of Smart.Context; remove duplication *) -module Context = struct - type capabilities = { - client_caps : Capability.t list; - server_caps : Capability.t list; - } - - let pp_capabilities _ppf _v = () - - include State.Context - - type nonrec t = capabilities t - - let make ~client_caps = make { client_caps; server_caps = [] } - let pp ppf v = pp pp_capabilities ppf v - let capabilities ctx = context ctx - - let replace_server_caps ctx caps = - update ~f:(fun ~old_ctx -> { old_ctx with server_caps = caps }) ctx - - let is_cap_shared ctx cap = - let { client_caps; server_caps } = capabilities ctx in - let is_cap_in caps = List.exists (fun c -> Capability.equal c cap) caps in - is_cap_in client_caps && is_cap_in server_caps -end +module Context = State.Context type ('a, 'err) t = ('a, 'err) State.t = | Read of { @@ -102,7 +78,7 @@ module Value = struct | Ls_refs_res -> Proto_vals_v2.Decoder.decode_ls_refs_response decoder) end -include State.Scheduler (Context) (Value) +include State.Scheduler (Value) let pp_error ppf = function | #Proto_vals_v2.Encoder.error as err -> diff --git a/test/smart/dune b/test/smart/dune index 05af015fb..6fefe972a 100644 --- a/test/smart/dune +++ b/test/smart/dune @@ -2,12 +2,12 @@ (name test) (modules append fifo hTTP loopback lwt_backend ref store_backend test uid unix_backend pipe) - (libraries bigarray-compat mirage-flow mimic git.nss.unixiz git git-unix - result curl.lwt mirage-crypto-rng.unix digestif digestif.c domain-name - git.nss git.nss.wire-proto-v2 git.nss.git bos fpath carton-lwt bigstringaf - git.nss.sigs git.nss.hkt fmt git.nss.pck carton rresult alcotest - git.nss.smart lwt.unix mmap astring lwt cstruct uri fmt.tty logs.fmt - alcotest-lwt cohttp-lwt-unix git-cohttp-unix)) + (libraries bigarray-compat capability git.nss.state mirage-flow mimic + git.nss.unixiz git git-unix result curl.lwt mirage-crypto-rng.unix + digestif digestif.c domain-name git.nss git.nss.wire-proto-v2 git.nss.git + bos fpath carton-lwt bigstringaf git.nss.sigs git.nss.hkt fmt git.nss.pck + carton rresult alcotest git.nss.smart lwt.unix mmap astring lwt cstruct + uri fmt.tty logs.fmt alcotest-lwt cohttp-lwt-unix git-cohttp-unix)) (executable (name test_edn) From d2830dccf26f80cda909d6f596d4387cc16dd911 Mon Sep 17 00:00:00 2001 From: Ulugbek Abdullaev Date: Mon, 8 Feb 2021 16:38:27 +0500 Subject: [PATCH 5/6] merge proto v1 and v2 capabilities into one 'capability.ml/i' --- src/git/dune | 6 +- src/git/sync.ml | 4 +- src/git/sync.mli | 8 +- src/not-so-smart/capability.ml | 168 +++++------------------- src/not-so-smart/capability.mli | 184 ++------------------------ src/not-so-smart/capability_v1.ml | 150 +++++++++++++++++++++ src/not-so-smart/capability_v1.mli | 201 +++++++++++++++++++++++++++++ src/not-so-smart/capability_v2.ml | 8 +- src/not-so-smart/capability_v2.mli | 2 +- src/not-so-smart/dune | 12 +- src/not-so-smart/fetch.mli | 2 +- src/not-so-smart/proto_vals_v2.ml | 3 +- src/not-so-smart/smart_git.ml | 2 + src/not-so-smart/smart_git_intf.ml | 4 +- src/not-so-smart/wire_proto_v2.ml | 1 - 15 files changed, 421 insertions(+), 334 deletions(-) create mode 100644 src/not-so-smart/capability_v1.ml create mode 100644 src/not-so-smart/capability_v1.mli diff --git a/src/git/dune b/src/git/dune index 1cc46266a..a8c41bf9d 100644 --- a/src/git/dune +++ b/src/git/dune @@ -1,8 +1,8 @@ (library (name git) (public_name git) - (libraries bigarray-compat capability mimic rresult git.nss.sigs git.nss.pck - optint loose decompress.de decompress.zl result git.nss.smart logs lwt - cstruct angstrom bigstringaf carton ke fmt checkseum git.nss.git + (libraries bigarray-compat git.nss.capability mimic rresult git.nss.sigs + git.nss.pck optint loose decompress.de decompress.zl result git.nss.smart + logs lwt cstruct angstrom bigstringaf carton ke fmt checkseum git.nss.git git.nss.hkt ocamlgraph astring fpath loose_git carton-lwt carton-git digestif encore)) diff --git a/src/git/sync.ml b/src/git/sync.ml index ad39b3f65..685d7322a 100644 --- a/src/git/sync.ml +++ b/src/git/sync.ml @@ -33,7 +33,7 @@ module type S = sig ctx:Mimic.ctx -> Smart_git.Endpoint.t -> store -> - ?version:[> `V1 ] -> + ?version:[> `V1 | `V2 ] -> ?capabilities:Smart.Capability.t list -> ?deepen:[ `Depth of int | `Timestamp of int64 ] -> [ `All | `Some of (Reference.t * Reference.t) list | `None ] -> @@ -43,7 +43,7 @@ module type S = sig ctx:Mimic.ctx -> Smart_git.Endpoint.t -> store -> - ?version:[> `V1 ] -> + ?version:[> `V1 | `V2 ] -> ?capabilities:Smart.Capability.t list -> [ `Create of Reference.t | `Delete of Reference.t diff --git a/src/git/sync.mli b/src/git/sync.mli index 4af896d6c..cb934bdb4 100644 --- a/src/git/sync.mli +++ b/src/git/sync.mli @@ -32,7 +32,7 @@ module type S = sig ctx:Mimic.ctx -> Smart_git.Endpoint.t -> store -> - ?version:[> `V1 ] -> + ?version:[> `V1 | `V2 ] -> ?capabilities:Smart.Capability.t list -> ?deepen:[ `Depth of int | `Timestamp of int64 ] -> [ `All | `Some of (Reference.t * Reference.t) list | `None ] -> @@ -42,7 +42,7 @@ module type S = sig ctx:Mimic.ctx -> Smart_git.Endpoint.t -> store -> - ?version:[> `V1 ] -> + ?version:[> `V1 | `V2 ] -> ?capabilities:Smart.Capability.t list -> [ `Create of Reference.t | `Delete of Reference.t @@ -71,7 +71,7 @@ module Make ctx:Mimic.ctx -> Smart_git.Endpoint.t -> store -> - ?version:[> `V1 ] -> + ?version:[> `V1 | `V2 ] -> ?capabilities:Smart.Capability.t list -> ?deepen:[ `Depth of int | `Timestamp of int64 ] -> [ `All @@ -98,7 +98,7 @@ module Make ctx:Mimic.ctx -> Smart_git.Endpoint.t -> store -> - ?version:[> `V1 ] -> + ?version:[> `V1 | `V2 ] -> ?capabilities:Smart.Capability.t list -> [ `Create of Reference.t | `Delete of Reference.t diff --git a/src/not-so-smart/capability.ml b/src/not-so-smart/capability.ml index cf770f03c..bd56d18ac 100644 --- a/src/not-so-smart/capability.ml +++ b/src/not-so-smart/capability.ml @@ -1,150 +1,42 @@ -type t = - [ `Multi_ack - | `Multi_ack_detailed - | `No_done - | `Thin_pack - | `Side_band - | `Side_band_64k - | `Ofs_delta - | `Agent of string - | `Shallow - | `Deepen_since - | `Deepen_not - | `No_progress - | `Include_tag - | `Report_status - | `Delete_refs - | `Quiet - | `Atomic - | `Push_options - | `Allow_tip_sha1_in_want - | `Allow_reachable_sha1_in_want - | `Push_cert of string - | `Symref of string * string - | `Other of string - | `Parameter of string * string ] +type t = [ Capability_v1.t | Capability_v2.t ] + +let filter_by ~protocol_v lst = + let filter = + match protocol_v with + | `V1 -> ( function #Capability_v1.t as c -> Some c | _ -> None) + | `V2 -> ( function #Capability_v2.t as c -> Some c | _ -> None) + | _ -> invalid_arg "unsupported protocol version" + in + List.filter_map filter lst let to_string = function - | `Multi_ack -> "multi_ack" - | `Multi_ack_detailed -> "multi_ack_detailed" - | `No_done -> "no-done" - | `Thin_pack -> "thin-pack" - | `Side_band -> "side-band" - | `Side_band_64k -> "side-band-64k" - | `Ofs_delta -> "ofs-delta" - | `Agent agent -> Fmt.str "agent=%s" agent - | `Shallow -> "shallow" - | `Deepen_since -> "deepen-since" - | `Deepen_not -> "deepen-not" - | `No_progress -> "no-progress" - | `Include_tag -> "include-tag" - | `Report_status -> "report-status" - | `Delete_refs -> "delete-refs" - | `Quiet -> "quiet" - | `Atomic -> "atomic" - | `Push_options -> "push-options" - | `Allow_tip_sha1_in_want -> "allow-tip-sha1-in-want" - | `Allow_reachable_sha1_in_want -> "allow-reachable-sha1-in-want" - | `Push_cert cert -> Fmt.str "push-cert=%s" cert - | `Symref (ref0, ref1) -> Fmt.str "symref=%s:%s" ref0 ref1 - | `Other capability -> capability - | `Parameter (key, value) -> Fmt.str "%s=%s" key value + | #Capability_v1.t as c -> Capability_v1.to_string c + | #Capability_v2.t as c -> Capability_v2.to_string c exception Capability_expect_value of string -let of_string ?value = function - | "multi_ack" -> `Multi_ack - | "multi_ack_detailed" -> `Multi_ack_detailed - | "no-done" -> `No_done - | "thin-pack" -> `Thin_pack - | "side-band" -> `Side_band - | "side-band-64k" -> `Side_band_64k - | "ofs-delta" -> `Ofs_delta - | "shallow" -> `Shallow - | "deepen-since" -> `Deepen_since - | "deepen-not" -> `Deepen_not - | "no-progress" -> `No_progress - | "include-tag" -> `Include_tag - | "report-status" -> `Report_status - | "delete-refs" -> `Delete_refs - | "quiet" -> `Quiet - | "atomic" -> `Atomic - | "push-options" -> `Push_options - | "allow-tip-sha1-in-want" -> `Allow_tip_sha1_in_want - | "allow-reachable-sha1-in-want" -> `Allow_reachable_sha1_in_want - | "push-cert" -> ( - match value with - | Some value -> `Push_cert value - | None -> raise (Capability_expect_value "push-cert")) - | "agent" -> ( - match value with - | Some value -> `Agent value - | None -> raise (Capability_expect_value "agent")) - | "symref" -> ( - match Option.bind value (Astring.String.cut ~sep:":") with - | Some (ref0, ref1) -> `Symref (ref0, ref1) - | None -> raise (Capability_expect_value "symref")) - | capability -> ( - match value with - | Some value -> `Parameter (capability, value) - | None -> `Other capability) +let of_string ?(protocol_v = `V1) ?value s = + match protocol_v with + | `V1 -> (Capability_v1.of_string ?value s :> t) + | `V2 -> (Capability_v2.of_string s :> t) + | _ -> invalid_arg "unsupported protocol version" let pp ppf = function - | `Multi_ack -> Fmt.pf ppf "Multi-ACK" - | `Multi_ack_detailed -> Fmt.pf ppf "Multi-ACK-detailed" - | `No_done -> Fmt.pf ppf "No-done" - | `Thin_pack -> Fmt.pf ppf "Thin-PACK" - | `Side_band -> Fmt.pf ppf "Side-Band" - | `Side_band_64k -> Fmt.pf ppf "Side-Band-64K" - | `Ofs_delta -> Fmt.pf ppf "Offset-delta" - | `Agent agent -> Fmt.pf ppf "(Agent %s)" agent - | `Shallow -> Fmt.pf ppf "Shallow" - | `Deepen_since -> Fmt.pf ppf "Deepen-Since" - | `Deepen_not -> Fmt.pf ppf "Deepen-Not" - | `No_progress -> Fmt.pf ppf "No-Progress" - | `Include_tag -> Fmt.pf ppf "Include-Tag" - | `Report_status -> Fmt.pf ppf "Report-Status" - | `Delete_refs -> Fmt.pf ppf "Delete-Refs" - | `Quiet -> Fmt.pf ppf "Quiet" - | `Atomic -> Fmt.pf ppf "Atomic" - | `Push_options -> Fmt.pf ppf "Push-Options" - | `Allow_tip_sha1_in_want -> Fmt.pf ppf "Allow-Tip-SHA1-in-Want" - | `Allow_reachable_sha1_in_want -> Fmt.pf ppf "Allow-Reachable-SHA1-in-Want" - | `Push_cert cert -> Fmt.pf ppf "(Push Cert %s)" cert - | `Symref (ref0, ref1) -> Fmt.pf ppf "(Symref (%s, %s))" ref0 ref1 - | `Other capability -> Fmt.pf ppf "(other %s)" capability - | `Parameter (key, value) -> Fmt.pf ppf "(%s %s)" key value + | #Capability_v1.t as c -> Capability_v1.pp ppf c + | #Capability_v2.t as c -> Capability_v2.pp ppf c let compare a b = match a, b with - | `Multi_ack, `Multi_ack - | `Multi_ack_detailed, `Multi_ack_detailed - | `No_done, `No_done - | `Thin_pack, `Thin_pack - | `Side_band, `Side_band - | `Side_band_64k, `Side_band_64k - | `Ofs_delta, `Ofs_delta - | `Shallow, `Shallow - | `Deepen_since, `Deepen_since - | `Deepen_not, `Deepen_not - | `No_progress, `No_progress - | `Include_tag, `Include_tag - | `Report_status, `Report_status - | `Delete_refs, `Delete_refs - | `Quiet, `Quiet - | `Atomic, `Atomic - | `Push_options, `Push_options - | `Allow_tip_sha1_in_want, `Allow_tip_sha1_in_want - | `Allow_reachable_sha1_in_want, `Allow_reachable_sha1_in_want -> - 0 - | `Push_cert a, `Push_cert b | `Agent a, `Agent b | `Other a, `Other b -> - String.compare a b - | `Symref (refa0, refa1), `Symref (refb0, refb1) -> - let res = String.compare refa0 refb0 in - if res = 0 then String.compare refa1 refb1 else res - | `Parameter (ka, va), `Parameter (kb, vb) -> - let res = String.compare ka kb in - if res = 0 then String.compare va vb else res - | a, b -> if a > b then 1 else -1 + | (#Capability_v1.t as a), (#Capability_v1.t as b) -> + Capability_v1.compare a b + | (#Capability_v2.t as a), (#Capability_v2.t as b) -> + if Capability_v2.equal a b then 0 + else + invalid_arg + "Capability.compare: comparison for capabilities for git wire \ + protocol v2 is undefined" + | _ -> + invalid_arg + "Capability.compare: comparison between such capabilities is undefined" let equal a b = compare a b = 0 diff --git a/src/not-so-smart/capability.mli b/src/not-so-smart/capability.mli index d9144cc7f..d8df4e454 100644 --- a/src/not-so-smart/capability.mli +++ b/src/not-so-smart/capability.mli @@ -9,177 +9,7 @@ not allow [`Shallow] objects, we permit to define shallow objects on the API of the fetch command but we don't use them to notice to the server. *) -type t = - [ `Multi_ack - (** The [`Multi-ack] capability allows the server to return - ["ACK obj-id continue"] as soon as it finds a commit that it can use as - a common base, between the client's wants and the client's have set. - - By sending this early, the server can potentially head off the client - from walking any further down that particular branch of the client's - repository history. The client may still need to walk down other - branches, sending have lines for those, until the server has a complete - cut across the DAG, or the client has said ["done"]. *) - | `Multi_ack_detailed - (** This is an extension of [`Multi_ack] that permits client to better - understand ther server's in-memory state. *) - | `No_done - (** This capability should only be used with the smart HTTP protocol. If - [`Multi_ack_detailed] and [`No_done] are both present, then the sender - is free to immediately send a pack following its first - ["ACK obj-id ready"] message. - - Without [`No_done] in the smart HTTP protocol, the server session would - end and the client has to make another trip to send ["done"] before the - server can send the pack. [`No_done] removes the last round and thus - slightly reduces latency. *) - | `Thin_pack - (** A thin pack is one with deltas which reference base objects not - contained within the pack (but are known to exist at the receiving end). - This can reduce the network traffic significantly, but it requires the - receiving end to know how to "thicken" these packs by adding the missing - bases to the pack. - - The [`UploadPack] server advertises [`Thin_pack] when it can generate - and send a thin pack. A client requests the [`Thin_pack] capability when - it understands how to ["thicken"] it, notifying the server that it can - receive such a pack. A client MUST NOT request the [`Thin_pack] - capability if it cannot turn a thin pack into a self-contained pack. - - [`ReceivePack], on the other hand, is assumed by default to be able to - handle thin packs, but can ask the client not to use the feature by - advertising the [`No_thin] capability. A client MUST NOT send a thin - pack if the server advertises the [`No_thin] capability. *) - | `Side_band (** See {!`Side_band_64k}. *) - | `Side_band_64k - (** This capability means that server can send, and client understand - multiplexed progress reports and error into interleaved with the - packfile itself. - - These two options are mutually exclusive. A modern client always favors - [`Side_band_64k]. - - Either mode indicates that the packfile data will be streamed broken up - into packets of up to either 1000 bytes in the case of [`Side_band], or - 65520 bytes in the case of [`Side_band_64k]. Each packet is made up of a - leading 4-byte {i pkt-line} length of how much data is in the packet, - followed by a 1-byte stream code, followed by the actual data. - - Further, with [`Side_band] and its up to 1000-byte messages, it's - actually 999 bytes of payload and 1 byte for the stream code. With - [`Side_band_64k], same deal, you have up to 65519 bytes of data and 1 - byte for the stream code. - - The client MUST send only maximum of one of [`Side_band] and - [`Side_band_64k]. Server MUST diagnose it as an error if client requests - both. *) - | `Ofs_delta - (** Server can send, and client understand PACKv2 with delta referring to - its base by position in path rather than by an obj-id. That is, they can - send/read OBJ_OFS_DETLA (aka type 6) in a packfile. *) - | `Agent of string - (** The server may optionnaly send a capability of the form ["agent=X"] to - notify the client that the server is running version ["X"]. The client - may optionnaly return its own agent string by responding with an - ["agent=Y"] capability (but it MUST NOT do so if the server did not - mention the agent capability). the ["X"] and ["Y"] strings may contain - any printable ASCII characters except space (i.e. the byte range - [32 < x < 127]), and are typically of the form ["package/version"] - (e.g., ["git/1.8.3.1"]). The agent strings are purely informative for - statistics and debugging purposes, and MUST NOT be used to - programmatically assume the presence or absence of particular features. *) - | `Shallow - (** This capability adds ["deepen"], ["shallow"] and ["unshallow"] commands - to the fetch-pack/upload-pack protocol so clients can request shallow - clones. *) - | `Deepen_since - (** This capability adds ["deepen-since"] command to fetch-pack/upload-pack - protocol so the client can request shallow clones that are cut at a - specific time, instead of depth. Internally it's equivalent of doing - ["git rev-list --max-age="] on the server side. - [`Deepen_since] cannot be used with [`Deepen]. *) - | `Deepen_not - (** This capability adds [`Deepen_not] command to fetch-pacj/upload-pack - protocol so the client can request shallow clones that are cut at a - specific revision, instead of depth. Internanlly it's equivalent of - doing ["git rev-list --not "] on the server side. [`Deepen_not] - cannot be used with [`Deepen], but can be used with [`Deepen_since]. *) - | `No_progress - (** The client was started with ["git clone -q"] or something, and does not - want that side band 2. Basically the client just says - ["I do not wish to receive stream 2 on sideband, so do not send it to - me, and if you did, I will drop it on the floor anyway"]. However, the - sideband channel 3 is still used for error responses. *) - | `Include_tag - (** The [`Include_tag] capability is about sending annotated tags if we are - sending objects they point to. If we pack an object to the client, and a - tag object points exactly at that object, we pack the tag object too. In - general this allows a client to get all new annotated tags when it - fetches a branch, in a single network connection. - - Clients MAY always send [`Include_tags], hardcoding it into a request - when the server advertises this capability. The decision for a client to - request [`Include_tag] only has to do with the client's desires for tag - ["refs/tags/*"] namespace. - - Servers MUST pack the tags if their referrant is packed and the client - has requested [`Include_tag]. - - Clients MUST be prepared for the case where a server has ignored - [`Include_tag] and has not actually sent tags in the pack. In such cases - the client SHOULD issue a subsequent fetch to acquire the tags that - [`Include_tag] would have otherwise given the client. - - The server SHOULD send [`Include_tag], if it supports it, regardless of - whether or not there are tags available. *) - | `Report_status - (** The [`ReceivePack] process can receive a [`Report_status] capability, - which tells it that the client wants a report of what happened after a - packfile upload and reference update. If the pushing client requests - this capability, after unpacking and updating references the server will - respond with whether the packfile unpacked successfully and if each - reference was updated successfully. If any of those were not successful, - it will send back an error message. *) - | `Delete_refs - (** If the server sends back the [`Delete_refs] capability, it means that it - is capable of accepting a zero-id value as the target value of a - reference update. It is not sent back by the client, it simply informs - the client that it can be sent zero-id values to delete references. *) - | `Quiet - (** If the [`ReceivePack] server advertises the [`Quiet] capability, it is - capable of silencing human-readable progress output which otherwise may - be shown when processing the receiving pack. A send-pack client should - respond with the [`Quiet] capability to suppress server-side progress - reporting if the local progress reporting is also being suppressed - (e.g., via ["git push -q"], or if [stderr] does not go to a tty). *) - | `Atomic - (** If the server sends the [`Atomic] capability it is capable of acceping - atomic pushes. If the pushing client requests this capability, the - server will update the refs in one atomic transaction. Either all refs - are updated or none. *) - | `Push_options - (** If the server sends the [`Push_options] capability it is able to accept - push options after the update commands have been sent, but before the - packfile is streamed. If the pushing client requests this capability, - the server will pass the options to the pre- and post- receive hooks - that process this push request. *) - | `Allow_tip_sha1_in_want - (** If the upload-pack server advertises this capability, fetch-pack may - send ["want"] lines with hashes that exists at the server but are not - advertised by upload-pack. *) - | `Allow_reachable_sha1_in_want - (** If the upload-pack server advertises this capability, fetch-pack may - send ["want"] lines with hashes that exists at the server but are not - advertised by upload-pack. *) - | `Push_cert of string - (** The receive-pack server that advertises this capability is willing to - accept a signed push certificate, and asks the to be included in - the push certificate. A send-pack client MUST NOT send a push-cert - packet unless the receive-pack server advertises this capability. *) - | `Symref of string * string - | `Other of string (** Unrecognized capability. *) - | `Parameter of string * string (** Unrecognized capability with a value. *) - ] +type t = [ Capability_v1.t | Capability_v2.t ] val to_string : t -> string (** [to_string c] returns a string representaiton of the capability [c]. *) @@ -187,13 +17,21 @@ val to_string : t -> string exception Capability_expect_value of string (** Exception to inform than the capability expects a value. *) -val of_string : ?value:string -> string -> t +val of_string : ?protocol_v:[> `V1 | `V2 ] -> ?value:string -> string -> t (** [of_capability s] tries to decode [s] to a capability. If the capability - excepts a value, we raise [Capability_expect_value]. *) + excepts a value, we raise [Capability_expect_value]. + + [protocol_v] has default value [`V1]. + + @raise Capability_expect_value if capability (for protocol v1) expects a value + but value argument isn't given. *) val pp : t Fmt.t (** Pretty-printer of {!t}. *) +val filter_by : protocol_v:[> `V1 | `V2 ] -> t list -> t list +(** filters a capability list by protocol version *) + val compare : t -> t -> int (** Comparison function of {!t}. *) diff --git a/src/not-so-smart/capability_v1.ml b/src/not-so-smart/capability_v1.ml new file mode 100644 index 000000000..cf770f03c --- /dev/null +++ b/src/not-so-smart/capability_v1.ml @@ -0,0 +1,150 @@ +type t = + [ `Multi_ack + | `Multi_ack_detailed + | `No_done + | `Thin_pack + | `Side_band + | `Side_band_64k + | `Ofs_delta + | `Agent of string + | `Shallow + | `Deepen_since + | `Deepen_not + | `No_progress + | `Include_tag + | `Report_status + | `Delete_refs + | `Quiet + | `Atomic + | `Push_options + | `Allow_tip_sha1_in_want + | `Allow_reachable_sha1_in_want + | `Push_cert of string + | `Symref of string * string + | `Other of string + | `Parameter of string * string ] + +let to_string = function + | `Multi_ack -> "multi_ack" + | `Multi_ack_detailed -> "multi_ack_detailed" + | `No_done -> "no-done" + | `Thin_pack -> "thin-pack" + | `Side_band -> "side-band" + | `Side_band_64k -> "side-band-64k" + | `Ofs_delta -> "ofs-delta" + | `Agent agent -> Fmt.str "agent=%s" agent + | `Shallow -> "shallow" + | `Deepen_since -> "deepen-since" + | `Deepen_not -> "deepen-not" + | `No_progress -> "no-progress" + | `Include_tag -> "include-tag" + | `Report_status -> "report-status" + | `Delete_refs -> "delete-refs" + | `Quiet -> "quiet" + | `Atomic -> "atomic" + | `Push_options -> "push-options" + | `Allow_tip_sha1_in_want -> "allow-tip-sha1-in-want" + | `Allow_reachable_sha1_in_want -> "allow-reachable-sha1-in-want" + | `Push_cert cert -> Fmt.str "push-cert=%s" cert + | `Symref (ref0, ref1) -> Fmt.str "symref=%s:%s" ref0 ref1 + | `Other capability -> capability + | `Parameter (key, value) -> Fmt.str "%s=%s" key value + +exception Capability_expect_value of string + +let of_string ?value = function + | "multi_ack" -> `Multi_ack + | "multi_ack_detailed" -> `Multi_ack_detailed + | "no-done" -> `No_done + | "thin-pack" -> `Thin_pack + | "side-band" -> `Side_band + | "side-band-64k" -> `Side_band_64k + | "ofs-delta" -> `Ofs_delta + | "shallow" -> `Shallow + | "deepen-since" -> `Deepen_since + | "deepen-not" -> `Deepen_not + | "no-progress" -> `No_progress + | "include-tag" -> `Include_tag + | "report-status" -> `Report_status + | "delete-refs" -> `Delete_refs + | "quiet" -> `Quiet + | "atomic" -> `Atomic + | "push-options" -> `Push_options + | "allow-tip-sha1-in-want" -> `Allow_tip_sha1_in_want + | "allow-reachable-sha1-in-want" -> `Allow_reachable_sha1_in_want + | "push-cert" -> ( + match value with + | Some value -> `Push_cert value + | None -> raise (Capability_expect_value "push-cert")) + | "agent" -> ( + match value with + | Some value -> `Agent value + | None -> raise (Capability_expect_value "agent")) + | "symref" -> ( + match Option.bind value (Astring.String.cut ~sep:":") with + | Some (ref0, ref1) -> `Symref (ref0, ref1) + | None -> raise (Capability_expect_value "symref")) + | capability -> ( + match value with + | Some value -> `Parameter (capability, value) + | None -> `Other capability) + +let pp ppf = function + | `Multi_ack -> Fmt.pf ppf "Multi-ACK" + | `Multi_ack_detailed -> Fmt.pf ppf "Multi-ACK-detailed" + | `No_done -> Fmt.pf ppf "No-done" + | `Thin_pack -> Fmt.pf ppf "Thin-PACK" + | `Side_band -> Fmt.pf ppf "Side-Band" + | `Side_band_64k -> Fmt.pf ppf "Side-Band-64K" + | `Ofs_delta -> Fmt.pf ppf "Offset-delta" + | `Agent agent -> Fmt.pf ppf "(Agent %s)" agent + | `Shallow -> Fmt.pf ppf "Shallow" + | `Deepen_since -> Fmt.pf ppf "Deepen-Since" + | `Deepen_not -> Fmt.pf ppf "Deepen-Not" + | `No_progress -> Fmt.pf ppf "No-Progress" + | `Include_tag -> Fmt.pf ppf "Include-Tag" + | `Report_status -> Fmt.pf ppf "Report-Status" + | `Delete_refs -> Fmt.pf ppf "Delete-Refs" + | `Quiet -> Fmt.pf ppf "Quiet" + | `Atomic -> Fmt.pf ppf "Atomic" + | `Push_options -> Fmt.pf ppf "Push-Options" + | `Allow_tip_sha1_in_want -> Fmt.pf ppf "Allow-Tip-SHA1-in-Want" + | `Allow_reachable_sha1_in_want -> Fmt.pf ppf "Allow-Reachable-SHA1-in-Want" + | `Push_cert cert -> Fmt.pf ppf "(Push Cert %s)" cert + | `Symref (ref0, ref1) -> Fmt.pf ppf "(Symref (%s, %s))" ref0 ref1 + | `Other capability -> Fmt.pf ppf "(other %s)" capability + | `Parameter (key, value) -> Fmt.pf ppf "(%s %s)" key value + +let compare a b = + match a, b with + | `Multi_ack, `Multi_ack + | `Multi_ack_detailed, `Multi_ack_detailed + | `No_done, `No_done + | `Thin_pack, `Thin_pack + | `Side_band, `Side_band + | `Side_band_64k, `Side_band_64k + | `Ofs_delta, `Ofs_delta + | `Shallow, `Shallow + | `Deepen_since, `Deepen_since + | `Deepen_not, `Deepen_not + | `No_progress, `No_progress + | `Include_tag, `Include_tag + | `Report_status, `Report_status + | `Delete_refs, `Delete_refs + | `Quiet, `Quiet + | `Atomic, `Atomic + | `Push_options, `Push_options + | `Allow_tip_sha1_in_want, `Allow_tip_sha1_in_want + | `Allow_reachable_sha1_in_want, `Allow_reachable_sha1_in_want -> + 0 + | `Push_cert a, `Push_cert b | `Agent a, `Agent b | `Other a, `Other b -> + String.compare a b + | `Symref (refa0, refa1), `Symref (refb0, refb1) -> + let res = String.compare refa0 refb0 in + if res = 0 then String.compare refa1 refb1 else res + | `Parameter (ka, va), `Parameter (kb, vb) -> + let res = String.compare ka kb in + if res = 0 then String.compare va vb else res + | a, b -> if a > b then 1 else -1 + +let equal a b = compare a b = 0 diff --git a/src/not-so-smart/capability_v1.mli b/src/not-so-smart/capability_v1.mli new file mode 100644 index 000000000..ef2548265 --- /dev/null +++ b/src/not-so-smart/capability_v1.mli @@ -0,0 +1,201 @@ +(** Capabilities module. + + When the client talks with the server, it needs to inform capabilities (what + it can handle). This is the exhaustive list of capabilities on the current + Smart protocol. Then, the server responds too with capabilities. + + The common part between the client and the server of capabilities should + diverge how we handle the Smart protocol. For example, if the client does + not allow [`Shallow] objects, we permit to define shallow objects on the API + of the fetch command but we don't use them to notice to the server. *) + +type t = + [ `Multi_ack + (** The [`Multi-ack] capability allows the server to return + ["ACK obj-id continue"] as soon as it finds a commit that it can use as + a common base, between the client's wants and the client's have set. + + By sending this early, the server can potentially head off the client + from walking any further down that particular branch of the client's + repository history. The client may still need to walk down other + branches, sending have lines for those, until the server has a complete + cut across the DAG, or the client has said ["done"]. *) + | `Multi_ack_detailed + (** This is an extension of [`Multi_ack] that permits client to better + understand ther server's in-memory state. *) + | `No_done + (** This capability should only be used with the smart HTTP protocol. If + [`Multi_ack_detailed] and [`No_done] are both present, then the sender + is free to immediately send a pack following its first + ["ACK obj-id ready"] message. + + Without [`No_done] in the smart HTTP protocol, the server session would + end and the client has to make another trip to send ["done"] before the + server can send the pack. [`No_done] removes the last round and thus + slightly reduces latency. *) + | `Thin_pack + (** A thin pack is one with deltas which reference base objects not + contained within the pack (but are known to exist at the receiving end). + This can reduce the network traffic significantly, but it requires the + receiving end to know how to "thicken" these packs by adding the missing + bases to the pack. + + The [`UploadPack] server advertises [`Thin_pack] when it can generate + and send a thin pack. A client requests the [`Thin_pack] capability when + it understands how to ["thicken"] it, notifying the server that it can + receive such a pack. A client MUST NOT request the [`Thin_pack] + capability if it cannot turn a thin pack into a self-contained pack. + + [`ReceivePack], on the other hand, is assumed by default to be able to + handle thin packs, but can ask the client not to use the feature by + advertising the [`No_thin] capability. A client MUST NOT send a thin + pack if the server advertises the [`No_thin] capability. *) + | `Side_band (** See {!`Side_band_64k}. *) + | `Side_band_64k + (** This capability means that server can send, and client understand + multiplexed progress reports and error into interleaved with the + packfile itself. + + These two options are mutually exclusive. A modern client always favors + [`Side_band_64k]. + + Either mode indicates that the packfile data will be streamed broken up + into packets of up to either 1000 bytes in the case of [`Side_band], or + 65520 bytes in the case of [`Side_band_64k]. Each packet is made up of a + leading 4-byte {i pkt-line} length of how much data is in the packet, + followed by a 1-byte stream code, followed by the actual data. + + Further, with [`Side_band] and its up to 1000-byte messages, it's + actually 999 bytes of payload and 1 byte for the stream code. With + [`Side_band_64k], same deal, you have up to 65519 bytes of data and 1 + byte for the stream code. + + The client MUST send only maximum of one of [`Side_band] and + [`Side_band_64k]. Server MUST diagnose it as an error if client requests + both. *) + | `Ofs_delta + (** Server can send, and client understand PACKv2 with delta referring to + its base by position in path rather than by an obj-id. That is, they can + send/read OBJ_OFS_DETLA (aka type 6) in a packfile. *) + | `Agent of string + (** The server may optionnaly send a capability of the form ["agent=X"] to + notify the client that the server is running version ["X"]. The client + may optionnaly return its own agent string by responding with an + ["agent=Y"] capability (but it MUST NOT do so if the server did not + mention the agent capability). the ["X"] and ["Y"] strings may contain + any printable ASCII characters except space (i.e. the byte range + [32 < x < 127]), and are typically of the form ["package/version"] + (e.g., ["git/1.8.3.1"]). The agent strings are purely informative for + statistics and debugging purposes, and MUST NOT be used to + programmatically assume the presence or absence of particular features. *) + | `Shallow + (** This capability adds ["deepen"], ["shallow"] and ["unshallow"] commands + to the fetch-pack/upload-pack protocol so clients can request shallow + clones. *) + | `Deepen_since + (** This capability adds ["deepen-since"] command to fetch-pack/upload-pack + protocol so the client can request shallow clones that are cut at a + specific time, instead of depth. Internally it's equivalent of doing + ["git rev-list --max-age="] on the server side. + [`Deepen_since] cannot be used with [`Deepen]. *) + | `Deepen_not + (** This capability adds [`Deepen_not] command to fetch-pacj/upload-pack + protocol so the client can request shallow clones that are cut at a + specific revision, instead of depth. Internanlly it's equivalent of + doing ["git rev-list --not "] on the server side. [`Deepen_not] + cannot be used with [`Deepen], but can be used with [`Deepen_since]. *) + | `No_progress + (** The client was started with ["git clone -q"] or something, and does not + want that side band 2. Basically the client just says + ["I do not wish to receive stream 2 on sideband, so do not send it to + me, and if you did, I will drop it on the floor anyway"]. However, the + sideband channel 3 is still used for error responses. *) + | `Include_tag + (** The [`Include_tag] capability is about sending annotated tags if we are + sending objects they point to. If we pack an object to the client, and a + tag object points exactly at that object, we pack the tag object too. In + general this allows a client to get all new annotated tags when it + fetches a branch, in a single network connection. + + Clients MAY always send [`Include_tags], hardcoding it into a request + when the server advertises this capability. The decision for a client to + request [`Include_tag] only has to do with the client's desires for tag + ["refs/tags/*"] namespace. + + Servers MUST pack the tags if their referrant is packed and the client + has requested [`Include_tag]. + + Clients MUST be prepared for the case where a server has ignored + [`Include_tag] and has not actually sent tags in the pack. In such cases + the client SHOULD issue a subsequent fetch to acquire the tags that + [`Include_tag] would have otherwise given the client. + + The server SHOULD send [`Include_tag], if it supports it, regardless of + whether or not there are tags available. *) + | `Report_status + (** The [`ReceivePack] process can receive a [`Report_status] capability, + which tells it that the client wants a report of what happened after a + packfile upload and reference update. If the pushing client requests + this capability, after unpacking and updating references the server will + respond with whether the packfile unpacked successfully and if each + reference was updated successfully. If any of those were not successful, + it will send back an error message. *) + | `Delete_refs + (** If the server sends back the [`Delete_refs] capability, it means that it + is capable of accepting a zero-id value as the target value of a + reference update. It is not sent back by the client, it simply informs + the client that it can be sent zero-id values to delete references. *) + | `Quiet + (** If the [`ReceivePack] server advertises the [`Quiet] capability, it is + capable of silencing human-readable progress output which otherwise may + be shown when processing the receiving pack. A send-pack client should + respond with the [`Quiet] capability to suppress server-side progress + reporting if the local progress reporting is also being suppressed + (e.g., via ["git push -q"], or if [stderr] does not go to a tty). *) + | `Atomic + (** If the server sends the [`Atomic] capability it is capable of acceping + atomic pushes. If the pushing client requests this capability, the + server will update the refs in one atomic transaction. Either all refs + are updated or none. *) + | `Push_options + (** If the server sends the [`Push_options] capability it is able to accept + push options after the update commands have been sent, but before the + packfile is streamed. If the pushing client requests this capability, + the server will pass the options to the pre- and post- receive hooks + that process this push request. *) + | `Allow_tip_sha1_in_want + (** If the upload-pack server advertises this capability, fetch-pack may + send ["want"] lines with hashes that exists at the server but are not + advertised by upload-pack. *) + | `Allow_reachable_sha1_in_want + (** If the upload-pack server advertises this capability, fetch-pack may + send ["want"] lines with hashes that exists at the server but are not + advertised by upload-pack. *) + | `Push_cert of string + (** The receive-pack server that advertises this capability is willing to + accept a signed push certificate, and asks the to be included in + the push certificate. A send-pack client MUST NOT send a push-cert + packet unless the receive-pack server advertises this capability. *) + | `Symref of string * string + | `Other of string (** Unrecognized capability. *) + | `Parameter of string * string (** Unrecognized capability with a value. *) + ] + +val to_string : t -> string +(** [to_string c] returns a string representaiton of the capability [c]. *) + +exception Capability_expect_value of string +(** Exception to inform than the capability expects a value. *) + +val of_string : ?value:string -> string -> t +(** [of_capability s] tries to decode [s] to a capability. If the capability + excepts a value, we raise [Capability_expect_value]. *) + +val pp : t Fmt.t +(** Pretty-printer of {!t}. *) + +val compare : t -> t -> int +(** Comparison function of {!t}. *) + +val equal : t -> t -> bool +(** Equal function of {!t}. *) diff --git a/src/not-so-smart/capability_v2.ml b/src/not-so-smart/capability_v2.ml index c65d7a01a..1b1389757 100644 --- a/src/not-so-smart/capability_v2.ml +++ b/src/not-so-smart/capability_v2.ml @@ -5,6 +5,12 @@ type t = | `Key_value of string * string | `Command_features of string * string list ] +let pp ppf = function + | `Atom s -> Fmt.pf ppf "%s" s + | `Key_value (k, v) -> Fmt.pf ppf "%s=%s" k v + | `Command_features (s, s_lst) -> + Fmt.pf ppf "%s=%s" s (String.concat ~sep:" " s_lst) + (* TODO: integrate better support for known capabilities and commands e.g., ls-refs, etc. *) let of_string s = @@ -12,7 +18,7 @@ let of_string s = | None -> `Atom s | Some (k, v) -> ( match String.cuts ?rev:None ?empty:None ~sep:" " v with - | [] -> raise @@ Invalid_argument s + | [] -> invalid_arg s | [ v ] -> `Key_value (k, v) | command :: features -> `Command_features (command, features)) diff --git a/src/not-so-smart/capability_v2.mli b/src/not-so-smart/capability_v2.mli index 864c6c8ef..0a07a146d 100644 --- a/src/not-so-smart/capability_v2.mli +++ b/src/not-so-smart/capability_v2.mli @@ -1,9 +1,9 @@ type t = - private [ `Atom of string | `Key_value of string * string | `Command_features of string * string list ] +val pp : t Fmt.t val of_string : string -> t val to_string : t -> string val equal : t -> t -> bool diff --git a/src/not-so-smart/dune b/src/not-so-smart/dune index 7f3913559..7e5baa221 100644 --- a/src/not-so-smart/dune +++ b/src/not-so-smart/dune @@ -13,22 +13,22 @@ (library (name capability) (public_name git.nss.capability) - (modules capability) + (modules capability capability_v1 capability_v2) (libraries astring fmt)) (library (name smart) (public_name git.nss.smart) (modules smart filter protocol) - (libraries git.nss.pkt-line git.nss.state capability result rresult ipaddr - domain-name astring fmt)) + (libraries git.nss.pkt-line git.nss.state git.nss.capability result rresult + ipaddr domain-name astring fmt)) (library (name wire_proto_v2) (public_name git.nss.wire-proto-v2) - (modules capability_v2 proto_vals_v2 wire_proto_v2) - (libraries astring domain-name emile fmt git.nss.pkt-line git.nss.sigs - git.nss.state logs mimic result rresult uri)) + (modules proto_vals_v2 wire_proto_v2) + (libraries astring git.nss.capability domain-name emile fmt git.nss.pkt-line + git.nss.sigs git.nss.state logs mimic result rresult uri)) (library (name sigs) diff --git a/src/not-so-smart/fetch.mli b/src/not-so-smart/fetch.mli index b13dbf88e..384965594 100644 --- a/src/not-so-smart/fetch.mli +++ b/src/not-so-smart/fetch.mli @@ -38,7 +38,7 @@ module Make path:string -> Wire_proto_v2.Context.t -> Flow.t -> - Wire_proto_v2.Capability.t list IO.t + Capability.t list IO.t val ls_refs_request : ?uses_git_transport:bool -> diff --git a/src/not-so-smart/proto_vals_v2.ml b/src/not-so-smart/proto_vals_v2.ml index 85c67aa76..63530316f 100644 --- a/src/not-so-smart/proto_vals_v2.ml +++ b/src/not-so-smart/proto_vals_v2.ml @@ -1,5 +1,4 @@ open Astring -module Capability = Capability_v2 module Proto_request = struct type t = { @@ -132,7 +131,7 @@ module Extended_pkt_line_decoder = struct match read_pkt decoder with | Pkt (_, s0) when String.equal s0 s -> return () decoder | Pkt (_, s0) -> Fmt.failwith "expected: %s\nfound: %s\n" s s0 - | _ -> raise @@ Invalid_argument "expected but didn't get a packet line" + | _ -> invalid_arg "expected but didn't get a packet line" let error { buffer; pos; _ } error = Error { error; buffer; committed = pos } diff --git a/src/not-so-smart/smart_git.ml b/src/not-so-smart/smart_git.ml index 098d62704..104bea575 100644 --- a/src/not-so-smart/smart_git.ml +++ b/src/not-so-smart/smart_git.ml @@ -412,6 +412,7 @@ struct ~idx = let open Rresult in let open Lwt.Infix in + let capabilities = Capability.filter_by ~protocol_v:version capabilities in let host = edn.Endpoint.host in let path = edn.path in let stream, pusher = Lwt_stream.create () in @@ -593,6 +594,7 @@ struct let push ~ctx (access, light_load, heavy_load) store edn ?(version = `V1) ?(capabilities = default_capabilities) cmds = let ctx = Mimic.add git_capabilities `Wr (Endpoint.to_ctx edn ctx) in + let capabilities = Capability.filter_by ~protocol_v:version capabilities in let open Rresult in match version, edn.Endpoint.scheme with | `V1, ((`Git | `SSH _) as scheme) -> diff --git a/src/not-so-smart/smart_git_intf.ml b/src/not-so-smart/smart_git_intf.ml index b43588157..c831614e6 100644 --- a/src/not-so-smart/smart_git_intf.ml +++ b/src/not-so-smart/smart_git_intf.ml @@ -123,7 +123,7 @@ module type SMART_GIT = sig * Uid.t Carton_lwt.Thin.heavy_load -> (Uid.t, Uid.t * int ref * int64, 'g) Sigs.store -> Endpoint.t -> - ?version:[> `V1 ] -> + ?version:[> `V1 | `V2 ] -> ?capabilities:Smart.Capability.t list -> ?deepen:[ `Depth of int | `Timestamp of int64 ] -> [ `All | `Some of Ref.t list | `None ] -> @@ -144,7 +144,7 @@ module type SMART_GIT = sig * Uid.t Carton_lwt.Thin.heavy_load -> (Uid.t, Uid.t Pck.t, 'g) Sigs.store -> Endpoint.t -> - ?version:[> `V1 ] -> + ?version:[> `V1 | `V2 ] -> ?capabilities:Smart.Capability.t list -> [ `Create of Ref.t | `Delete of Ref.t | `Update of Ref.t * Ref.t ] list -> (unit, ([> `Exn of exn | Mimic.error ] as 'err)) result Lwt.t diff --git a/src/not-so-smart/wire_proto_v2.ml b/src/not-so-smart/wire_proto_v2.ml index 2b537b82f..0fa3c7063 100644 --- a/src/not-so-smart/wire_proto_v2.ml +++ b/src/not-so-smart/wire_proto_v2.ml @@ -1,4 +1,3 @@ -module Capability = Capability_v2 module Proto_vals_v2 = Proto_vals_v2 module Witness = struct From 285dce3c49535a922b2475ccd42467359de02aea Mon Sep 17 00:00:00 2001 From: Ulugbek Abdullaev Date: Mon, 8 Feb 2021 17:01:29 +0500 Subject: [PATCH 6/6] de-functorize 'State_flow' --- src/not-so-smart/fetch.ml | 17 ++--- src/not-so-smart/find_common.ml | 27 ++++--- src/not-so-smart/push.ml | 16 +++-- src/not-so-smart/smart.ml | 8 +-- src/not-so-smart/state.ml | 3 + src/not-so-smart/state.mli | 2 + src/not-so-smart/state_flow.ml | 116 ++++++++++++++---------------- src/not-so-smart/state_flow.mli | 26 +++---- src/not-so-smart/wire_proto_v2.ml | 12 ++-- 9 files changed, 110 insertions(+), 117 deletions(-) diff --git a/src/not-so-smart/fetch.ml b/src/not-so-smart/fetch.ml index 585a4fb17..fbd091ded 100644 --- a/src/not-so-smart/fetch.ml +++ b/src/not-so-smart/fetch.ml @@ -75,8 +75,6 @@ struct List.fold_left fold [] have |> List.split module V1 = struct - module Smart_flow = State_flow.Make (Smart) - let fetch ?(uses_git_transport = false) ?(push_stdout = ignore) ?(push_stderr = ignore) ~capabilities ?deepen ?want:(refs = `None) ~host path flow store access fetch_cfg push_pack = @@ -106,7 +104,7 @@ struct let ctx = Smart.Context.make ~client_caps in - Smart_flow.run sched io_raise io flow (prelude ctx) |> prj + State_flow.run sched io_raise Smart.pp_error io flow (prelude ctx) |> prj >>= fun (uids, refs) -> let hex = { Neg.to_hex = Uid.to_hex; of_hex = Uid.of_hex; compare = Uid.compare } @@ -131,7 +129,9 @@ struct if res < 0 then Log.warn (fun m -> m "No common commits"); let rec read_pack () = Log.debug (fun m -> m "Reading PACK file..."); - Smart_flow.run sched io_raise io flow (recv_pack_state ctx) |> prj + State_flow.run sched io_raise Smart.pp_error io flow + (recv_pack_state ctx) + |> prj >>= fun should_continue -> if should_continue then read_pack () else return () in @@ -140,8 +140,6 @@ struct end module V2 = struct - module State_flow = State_flow.Make (Wire_proto_v2) - let connect ?(uses_git_transport = false) ~host ~path ctx = let open Wire_proto_v2.Syntax in let return = Wire_proto_v2.return in @@ -162,7 +160,9 @@ struct let* () = Wire_proto_v2.send ctx Flush () in Wire_proto_v2.return caps in - State_flow.run sched io_raise io flow (get_caps ctx) |> prj + State_flow.run sched io_raise Wire_proto_v2.pp_error io flow + (get_caps ctx) + |> prj let ls_refs_request ?(uses_git_transport = false) ~host ~path ctx flow req = let ls_refs_resp = @@ -172,6 +172,7 @@ struct let* () = Wire_proto_v2.send ctx Ls_refs_req (`Client_caps caps, req) in Wire_proto_v2.recv ctx Ls_refs_res in - State_flow.run sched io_raise io flow ls_refs_resp |> prj + State_flow.run sched io_raise Wire_proto_v2.pp_error io flow ls_refs_resp + |> prj end end diff --git a/src/not-so-smart/find_common.ml b/src/not-so-smart/find_common.ml index d425ad1cf..5407c90c5 100644 --- a/src/not-so-smart/find_common.ml +++ b/src/not-so-smart/find_common.ml @@ -61,8 +61,6 @@ let io_monad (type t) { bind; return } = with Smart.v1 and implement a state of the art synchronisation algorithm, I translated as is [fetch-pack.c:find_common] in OCaml. *) -module Smart_flow = State_flow.Make (Smart) - let tips (type t) scheduler access store negotiator = let open (val io_monad scheduler : Io_monad with type s = t) in access.locals store >>= fun ref_lst -> @@ -76,13 +74,15 @@ let consume_shallow_list (type t) scheduler io flow cfg deepen { of_hex; _ } ctx = let open (val io_monad scheduler : Io_monad with type s = t) in if cfg.stateless && Option.is_some deepen then - Smart_flow.run scheduler raise io flow Smart.(recv ctx shallows) + State_flow.run scheduler raise Smart.pp_error io flow + Smart.(recv ctx shallows) >>| fun shallows -> List.map (Smart.Shallow.map ~f:of_hex) shallows else return [] let handle_shallow (type t) scheduler io flow { of_hex; _ } access store ctx = let open (val io_monad scheduler : Io_monad with type s = t) in - Smart_flow.run scheduler raise io flow Smart.(recv ctx shallows) + State_flow.run scheduler raise Smart.pp_error io flow + Smart.(recv ctx shallows) >>= fun shallows -> let shallows = List.map (Smart.Shallow.map ~f:of_hex) shallows in fold_left_s shallows ~init:() ~f:(fun () -> function @@ -115,13 +115,14 @@ let find_common (type t) scheduler io flow cfg >>= function | [] -> Log.debug (fun m -> m "Nothing to download."); - Smart_flow.run scheduler raise io flow Smart.(send ctx flush ()) + State_flow.run scheduler raise Smart.pp_error io flow + Smart.(send ctx flush ()) >>= fun () -> return `Close | (uid, _) :: others as refs -> Log.debug (fun m -> m "We want %d commit(s)." (List.length refs)); access.shallowed store >>= fun shallowed -> let shallowed = List.map to_hex shallowed in - Smart_flow.run scheduler raise io flow + State_flow.run scheduler raise Smart.pp_error io flow Smart.( let uid = to_hex uid in let others = List.map (fun (uid, _) -> to_hex uid) others in @@ -164,7 +165,8 @@ let find_common (type t) scheduler io flow cfg m "count: %d, in-vain: %d, flush-at: %d.\n%!" !count !in_vain !flush_at); if !flush_at <= !count then ( - Smart_flow.run scheduler raise io flow Smart.(send ctx flush ()) + State_flow.run scheduler raise Smart.pp_error io flow + Smart.(send ctx flush ()) >>= fun () -> incr flushes; flush_at := next_flush stateless !count; @@ -173,7 +175,8 @@ let find_common (type t) scheduler io flow cfg consume_shallow_list scheduler io flow cfg None hex ctx >>= fun _shallows -> let rec loop () = - Smart_flow.run scheduler raise io flow Smart.(recv ctx ack) + State_flow.run scheduler raise Smart.pp_error io flow + Smart.(recv ctx ack) >>| Smart.Negotiation.map ~f:of_hex >>= fun ack -> match ack with @@ -238,7 +241,7 @@ let find_common (type t) scheduler io flow cfg Log.debug (fun m -> m "Negotiation (got ready: %b, no-done: %b)." !got_ready no_done); (if (not !got_ready) || not no_done then - Smart_flow.run scheduler raise io flow + State_flow.run scheduler raise Smart.pp_error io flow Smart.(send ctx negotiation_done ()) else return ()) >>= fun () -> @@ -247,14 +250,16 @@ let find_common (type t) scheduler io flow cfg incr flushes); (if (not !got_ready) || not no_done then ( Log.debug (fun m -> m "Negotiation is done!"); - Smart_flow.run scheduler raise io flow Smart.(recv ctx shallows) + State_flow.run scheduler raise Smart.pp_error io flow + Smart.(recv ctx shallows) >>= fun _shallows -> return ()) else return ()) >>= fun () -> let rec go () = if !flushes > 0 || cfg.multi_ack = `Some || cfg.multi_ack = `Detailed then ( - Smart_flow.run scheduler raise io flow Smart.(recv ctx ack) + State_flow.run scheduler raise Smart.pp_error io flow + Smart.(recv ctx ack) >>| Smart.Negotiation.map ~f:of_hex >>= fun ack -> match ack with diff --git a/src/not-so-smart/push.ml b/src/not-so-smart/push.ml index 7d0b56666..aa6264408 100644 --- a/src/not-so-smart/push.ml +++ b/src/not-so-smart/push.ml @@ -39,8 +39,6 @@ struct pp_error = Flow.pp_error; } - module Smart_flow = State_flow.Make (Smart) - let push ?(uses_git_transport = true) ~capabilities:client_caps cmds ~host path flow store access push_cfg pack = let fiber ctx = @@ -57,7 +55,7 @@ struct return (Smart.Advertised_refs.map ~fuid:Uid.of_hex ~fref:Ref.v v) in let ctx = Smart.Context.make ~client_caps in - Smart_flow.run sched fail io flow (fiber ctx) |> prj + State_flow.run sched fail Smart.pp_error io flow (fiber ctx) |> prj >>= fun advertised_refs -> Pck.commands sched ~capabilities:(Smart.Advertised_refs.capabilities advertised_refs) @@ -66,10 +64,12 @@ struct |> prj >>= function | None -> - Smart_flow.run sched fail io flow Smart.(send ctx flush ()) |> prj + State_flow.run sched fail Smart.pp_error io flow + Smart.(send ctx flush ()) + |> prj >>= fun () -> return () | Some cmds -> ( - Smart_flow.run sched fail io flow + State_flow.run sched fail Smart.pp_error io flow Smart.( send ctx commands (Commands.map ~fuid:Uid.to_hex ~fref:Ref.to_string cmds)) @@ -101,14 +101,16 @@ struct Log.debug (fun m -> m "report-status capability: %b." report_status); if report_status then - Smart_flow.run sched fail io flow Smart.(recv ctx status) + State_flow.run sched fail Smart.pp_error io flow + Smart.(recv ctx status) |> prj >>| Smart.Status.map ~f:Ref.v else let cmds = List.map R.ok (Smart.Commands.commands cmds) in return (Smart.Status.v cmds) | Some payload -> - Smart_flow.run sched fail io flow Smart.(send ctx pack payload) + State_flow.run sched fail Smart.pp_error io flow + Smart.(send ctx pack payload) |> prj >>= fun () -> go () in diff --git a/src/not-so-smart/smart.ml b/src/not-so-smart/smart.ml index b462d549b..4b5690111 100644 --- a/src/not-so-smart/smart.ml +++ b/src/not-so-smart/smart.ml @@ -50,6 +50,10 @@ module Value = struct type error = [ Protocol.Encoder.error | Protocol.Decoder.error ] + let pp_error ppf = function + | #Protocol.Encoder.error as err -> Protocol.Encoder.pp_error ppf err + | #Protocol.Decoder.error as err -> Protocol.Decoder.pp_error ppf err + let encode : type a. encoder -> a send -> a -> (unit, [> Encoder.error ]) State.t = fun encoder w v -> @@ -137,10 +141,6 @@ let send_advertised_refs : _ send = Advertised_refs include State.Scheduler (Value) -let pp_error ppf = function - | #Protocol.Encoder.error as err -> Protocol.Encoder.pp_error ppf err - | #Protocol.Decoder.error as err -> Protocol.Decoder.pp_error ppf err - module Unsafe = struct let write context packet = let encoder = Context.encoder context in diff --git a/src/not-so-smart/state.ml b/src/not-so-smart/state.ml index 371e23776..231ba7249 100644 --- a/src/not-so-smart/state.ml +++ b/src/not-so-smart/state.ml @@ -29,6 +29,7 @@ module type VALUE = sig type encoder type decoder + val pp_error : error Fmt.t val encode : encoder -> 'a send -> 'a -> (unit, error) t val decode : decoder -> 'a recv -> ('a, error) t end @@ -77,6 +78,8 @@ module Scheduler struct type error = Value.error + let pp_error = Value.pp_error + let bind : ('a, 'err) t -> f:('a -> ('b, 'err) t) -> ('b, 'err) t = let rec bind' m ~f = match m with diff --git a/src/not-so-smart/state.mli b/src/not-so-smart/state.mli index 9b382edbf..e864d2bfc 100644 --- a/src/not-so-smart/state.mli +++ b/src/not-so-smart/state.mli @@ -28,6 +28,7 @@ module type VALUE = sig type encoder type decoder + val pp_error : error Fmt.t val encode : encoder -> 'a send -> 'a -> (unit, error) t val decode : decoder -> 'a recv -> ('a, error) t end @@ -57,6 +58,7 @@ module Scheduler and type decoder = Context.decoder) : sig type error = Value.error + val pp_error : error Fmt.t val return : 'v -> ('v, 'err) t val bind : ('a, 'err) t -> f:('a -> ('b, 'err) t) -> ('b, 'err) t val ( >>= ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t diff --git a/src/not-so-smart/state_flow.ml b/src/not-so-smart/state_flow.ml index a9bb6ef67..f32ac3796 100644 --- a/src/not-so-smart/state_flow.ml +++ b/src/not-so-smart/state_flow.ml @@ -7,70 +7,60 @@ let io_buffer_size = 65536 type ('a, 's) raise = exn -> ('a, 's) io -module Make (Read_write : sig - type ('a, 'err) t = ('a, 'err) State.t - type error +let run : + type fl s err. + s scheduler -> + ('a, s) raise -> + err Fmt.t -> + (fl, 'error, s) flow -> + fl -> + ('res, [ `Protocol of err ]) State.t -> + ('res, s) io = + fun scheduler io_raise pp_error flow_ops flow state -> + let { bind; return } = scheduler in + let ( >>= ) = bind in - val pp_error : error Fmt.t -end) = -struct - type nonrec error = Read_write.error + let failwithf fmt = + Format.kasprintf (fun err -> io_raise (Failure err)) fmt + in - let run : - type fl s. - s scheduler -> - ('a, s) raise -> - (fl, 'error, s) flow -> - fl -> - ('res, [ `Protocol of error ]) Read_write.t -> - ('res, s) io = - fun scheduler io_raise flow_ops flow state -> - let { bind; return } = scheduler in - let ( >>= ) = bind in + let cbuff = Cstruct.create io_buffer_size in - let failwithf fmt = - Format.kasprintf (fun err -> io_raise (Failure err)) fmt - in + let rec unwrap = function + | State.Return v -> + Log.debug (fun m -> m "got return "); + return v + | Error (`Protocol err) -> + Log.err (fun m -> m "Got a protocol error: %a." pp_error err); + failwithf "%a" pp_error err + | Read { k; buffer; off; len; eof } -> ( + let rd_n_bytes = min (Cstruct.len cbuff) len in + Log.debug (fun m -> m "Start to read %d byte(s)." rd_n_bytes); + flow_ops.recv flow (Cstruct.sub cbuff 0 rd_n_bytes) >>= function + | Ok `End_of_flow -> + Log.debug (fun m -> m "Got end of input."); + unwrap (eof ()) + | Ok (`Input len) -> + Log.debug (fun m -> m "Got %d/%d byte(s)." len rd_n_bytes); + Cstruct.blit_to_bytes cbuff 0 buffer off len; + unwrap (k len) + | Error err -> + Log.err (fun m -> m "Got an error: %a." flow_ops.pp_error err); + failwithf "%a" flow_ops.pp_error err) + | Write { k; buffer; off; len } -> + (* TODO: almost always we can write in one go instead of calling a loop, + so we should try writing and call loop if we aren't done *) + let rec loop tmp = + if Cstruct.is_empty tmp then unwrap (k len) + else + flow_ops.send flow tmp >>= function + | Ok shift -> + Log.debug (fun m -> + m "Wrote %d byte(s). %s" shift (Cstruct.to_string tmp)); + loop (Cstruct.shift tmp shift) + | Error err -> failwithf "%a" flow_ops.pp_error err + in + Cstruct.of_string buffer ~off ~len |> loop + in - let cbuff = Cstruct.create io_buffer_size in - - let rec unwrap = function - | State.Return v -> - Log.debug (fun m -> m "got return "); - return v - | Error (`Protocol err) -> - Log.err (fun m -> - m "Got a protocol error: %a." Read_write.pp_error err); - failwithf "%a" Read_write.pp_error err - | Read { k; buffer; off; len; eof } -> ( - let rd_n_bytes = min (Cstruct.len cbuff) len in - Log.debug (fun m -> m "Start to read %d byte(s)." rd_n_bytes); - flow_ops.recv flow (Cstruct.sub cbuff 0 rd_n_bytes) >>= function - | Ok `End_of_flow -> - Log.debug (fun m -> m "Got end of input."); - unwrap (eof ()) - | Ok (`Input len) -> - Log.debug (fun m -> m "Got %d/%d byte(s)." len rd_n_bytes); - Cstruct.blit_to_bytes cbuff 0 buffer off len; - unwrap (k len) - | Error err -> - Log.err (fun m -> m "Got an error: %a." flow_ops.pp_error err); - failwithf "%a" flow_ops.pp_error err) - | Write { k; buffer; off; len } -> - (* TODO: almost always we can write in one go instead of calling a loop, - so we should try writing and call loop if we aren't done *) - let rec loop tmp = - if Cstruct.is_empty tmp then unwrap (k len) - else - flow_ops.send flow tmp >>= function - | Ok shift -> - Log.debug (fun m -> - m "Wrote %d byte(s). %s" shift (Cstruct.to_string tmp)); - loop (Cstruct.shift tmp shift) - | Error err -> failwithf "%a" flow_ops.pp_error err - in - Cstruct.of_string buffer ~off ~len |> loop - in - - unwrap state -end + unwrap state diff --git a/src/not-so-smart/state_flow.mli b/src/not-so-smart/state_flow.mli index bab268386..75e05f2ea 100644 --- a/src/not-so-smart/state_flow.mli +++ b/src/not-so-smart/state_flow.mli @@ -4,21 +4,11 @@ val io_buffer_size : int type ('a, 's) raise = exn -> ('a, 's) Sigs.io -module Make : functor - (Read_write : sig - type ('a, 'err) t = ('a, 'err) State.t - type error - - val pp_error : error Fmt.t - end) - -> sig - type nonrec error = Read_write.error - - val run : - 's Sigs.scheduler -> - ('res, 's) raise -> - ('fl, 'error, 's) Sigs.flow -> - 'fl -> - ('res, [ `Protocol of error ]) State.t -> - ('res, 's) Sigs.io -end +val run : + 's Sigs.scheduler -> + ('res, 's) raise -> + 'err Fmt.t -> + ('fl, 'error, 's) Sigs.flow -> + 'fl -> + ('res, [ `Protocol of 'err ]) State.t -> + ('res, 's) Sigs.io diff --git a/src/not-so-smart/wire_proto_v2.ml b/src/not-so-smart/wire_proto_v2.ml index 0fa3c7063..691ade9bb 100644 --- a/src/not-so-smart/wire_proto_v2.ml +++ b/src/not-so-smart/wire_proto_v2.ml @@ -38,6 +38,12 @@ module Value = struct type encoder = Pkt_line.Encoder.encoder type decoder = Pkt_line.Decoder.decoder + let pp_error ppf = function + | #Proto_vals_v2.Encoder.error as err -> + Proto_vals_v2.Encoder.pp_error ppf err + | #Proto_vals_v2.Decoder.error as err -> + Proto_vals_v2.Decoder.pp_error ppf err + let encode : type a. encoder -> a send -> a -> (unit, error) State.t = fun encoder w v -> let encoder_state = @@ -78,9 +84,3 @@ module Value = struct end include State.Scheduler (Value) - -let pp_error ppf = function - | #Proto_vals_v2.Encoder.error as err -> - Proto_vals_v2.Encoder.pp_error ppf err - | #Proto_vals_v2.Decoder.error as err -> - Proto_vals_v2.Decoder.pp_error ppf err