diff --git a/fuzz/dune b/fuzz/dune index 2c7cbf54e..f8df25cbf 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 86bbf1ce0..717a97630 100644 --- a/src/git/dune +++ b/src/git/dune @@ -2,34 +2,37 @@ (name git) (public_name git) (libraries - hxd.core - hxd.string - mimic - rresult - git.nss.sigs - git.nss.pck - optint - loose - decompress.de - decompress.zl - result - git.nss.smart - logs - lwt - cstruct + git_paf angstrom + astring bigstringaf carton - ke - fmt + carton-git + carton-lwt checkseum + cstruct + decompress.de + decompress.zl + digestif + encore + fmt + fpath + git.nss.capability git.nss.git git.nss.hkt - ocamlgraph - astring - fpath + git.nss.pck + git.nss.sigs + git.nss.smart + hxd.core + hxd.string + ke + logs + loose loose_git - carton-lwt - carton-git - digestif - encore)) + lwt + mimic + ocamlgraph + optint + result + rresult +)) diff --git a/src/git/sync.ml b/src/git/sync.ml index 0dbc27511..bc3591965 100644 --- a/src/git/sync.ml +++ b/src/git/sync.ml @@ -34,7 +34,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 ] -> @@ -44,7 +44,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 @@ -181,6 +181,8 @@ struct Lwt.return (Carton.Dec.v ~kind raw) | None -> Lwt.fail Not_found + (* module Http = Git_paf *) + include Smart_git.Make (Scheduler) (Pack) (Index) (Hash) (Reference) let ( >>? ) x f = diff --git a/src/git/sync.mli b/src/git/sync.mli index 35cb107dd..83ab0ed2c 100644 --- a/src/git/sync.mli +++ b/src/git/sync.mli @@ -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 @@ -72,7 +72,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 @@ -99,7 +99,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 69b152c53..bd56d18ac 100644 --- a/src/not-so-smart/capability.ml +++ b/src/not-so-smart/capability.ml @@ -1,155 +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 -> ( - match Astring.String.cut ~sep:"=" capability with - | Some ("push-cert", v) -> `Push_cert v - | Some ("agent", v) -> `Agent v - | Some (k, v) -> `Parameter (k, v) - | 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 0e85807e1..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..69b152c53 --- /dev/null +++ b/src/not-so-smart/capability_v1.ml @@ -0,0 +1,155 @@ +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 -> ( + match Astring.String.cut ~sep:"=" capability with + | Some ("push-cert", v) -> `Push_cert v + | Some ("agent", v) -> `Agent v + | Some (k, v) -> `Parameter (k, v) + | 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 new file mode 100644 index 000000000..1b1389757 --- /dev/null +++ b/src/not-so-smart/capability_v2.ml @@ -0,0 +1,38 @@ +open Astring + +type t = + [ `Atom of string + | `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 = + match String.cut ?rev:None ~sep:"=" s with + | None -> `Atom s + | Some (k, v) -> ( + match String.cuts ?rev:None ?empty:None ~sep:" " v with + | [] -> invalid_arg 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..0a07a146d --- /dev/null +++ b/src/not-so-smart/capability_v2.mli @@ -0,0 +1,9 @@ +type t = + [ `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/decoder.ml b/src/not-so-smart/decoder.ml index effac1fe0..5d017946c 100644 --- a/src/not-so-smart/decoder.ml +++ b/src/not-so-smart/decoder.ml @@ -1,3 +1,6 @@ +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 @@ -266,11 +269,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 diff --git a/src/not-so-smart/decoder.mli b/src/not-so-smart/decoder.mli index b64fe2a0e..500015fc9 100644 --- a/src/not-so-smart/decoder.mli +++ b/src/not-so-smart/decoder.mli @@ -91,6 +91,29 @@ 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 @@ -98,6 +121,11 @@ val junk_pkt : decoder -> unit @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) -> diff --git a/src/not-so-smart/dune b/src/not-so-smart/dune index d6374a147..5d1d4d678 100644 --- a/src/not-so-smart/dune +++ b/src/not-so-smart/dune @@ -2,13 +2,33 @@ (name pkt_line) (public_name git.nss.pkt-line) (modules decoder encoder) + (libraries astring fmt logs)) + +(library + (name state) + (public_name git.nss.state) + (modules state) + (libraries git.nss.capability git.nss.pkt-line fmt)) + +(library + (name capability) + (public_name git.nss.capability) + (modules capability capability_v1 capability_v2) (libraries astring 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 protocol) + (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 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) @@ -17,10 +37,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,30 +52,20 @@ (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) (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.smart-flow)) + (libraries fmt result rresult logs ipaddr domain-name smart sigs neg pck + capability git.nss.state-flow git.nss.state wire_proto_v2)) (library (name unixiz) @@ -67,29 +77,7 @@ (name smart_git) (public_name git.nss.git) (modules smart_git smart_git_intf) - (libraries - base64 - 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 capability base64 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.ml b/src/not-so-smart/fetch.ml index 57e8fee93..8b6dc8de9 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 @@ -44,7 +46,7 @@ struct return = (fun x -> inj (return x)); } - let fail exn = + let io_raise exn = let fail = IO.fail exn in inj fail @@ -76,61 +78,110 @@ 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 + + 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 + + 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 } + 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 ~push_stdout ~push_stderr side_band) + 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..."); + State_flow.run sched io_raise Smart.pp_error io flow + (recv_pack_state ctx) + |> prj + >>= function + | `End_of_transmission -> return () + | `Payload (str, off, len) -> + push_pack (str, off, len) >>= read_pack + | `Stdout -> read_pack () + | `Stderr -> read_pack () + in + Log.debug (fun m -> m "Start to download PACK file."); + read_pack () >>= fun () -> return (List.combine refs uids) + end + + module V2 = struct + 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 - Smart.Context.replace_server_caps ctx - (Smart.Advertised_refs.capabilities v); - 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 recv_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 ~push_stdout ~push_stderr side_band) - in - if res < 0 then Log.warn (fun m -> m "No common commits"); - let rec go () = - Smart_flow.run sched fail io flow (recv_pack ctx) |> prj >>= function - | `End_of_transmission -> return () - | `Payload (str, off, len) -> pack (str, off, len) >>= go - | `Stdout -> go () - | `Stderr -> go () - 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 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 = + 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 Wire_proto_v2.pp_error 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 17d0d99fd..0f8542960 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:string -> - 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 IO.t) -> - (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:string -> + 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 IO.t) -> + (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 -> + Capability.t list IO.t + + val ls_refs_request : + ?uses_git_transport:bool -> + host:[ `host ] Domain_name.t -> + path:string -> + 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 59f7b537b..8af2e5357 100644 --- a/src/not-so-smart/find_common.ml +++ b/src/not-so-smart/find_common.ml @@ -77,13 +77,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 @@ -116,13 +118,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 @@ -165,7 +168,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; @@ -174,7 +178,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 @@ -239,23 +244,25 @@ 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 - Smart.(send ctx negotiation_done ()) - else return ()) + State_flow.run scheduler raise Smart.pp_error io flow + Smart.(send ctx negotiation_done ()) + else return ()) >>= fun () -> if !retval <> 0 then ( cfg.multi_ack <- `None; 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) - >>= fun _shallows -> return ()) - else return ()) + Log.debug (fun m -> m "Negotiation is done!"); + 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/proto_vals_v2.ml b/src/not-so-smart/proto_vals_v2.ml new file mode 100644 index 000000000..ced5e19e8 --- /dev/null +++ b/src/not-so-smart/proto_vals_v2.ml @@ -0,0 +1,671 @@ +open Astring + +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.((const string " host=") ++ pp_host) + host + Fmt.((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 + | _ -> invalid_arg "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/push.ml b/src/not-so-smart/push.ml index 6dd5b9e07..869175569 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 = false) ~capabilities:client_caps cmds ~host - path flow store access { stateless } 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,11 +50,12 @@ struct else return () in let* v = recv ctx advertised_refs in - Context.replace_server_caps 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 ~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:client_caps ~equal:Ref.equal ~deref:access.Sigs.deref store cmds @@ -62,10 +63,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)) @@ -87,7 +90,7 @@ struct Smart.Context.is_cap_shared ctx `Side_band || Smart.Context.is_cap_shared ctx `Side_band_64k in - let pack = Smart.send_pack ~stateless side_band in + let pack = Smart.send_pack ~stateless:push_cfg.stateless side_band in let rec go () = stream () >>= function | None -> @@ -97,12 +100,13 @@ struct Log.debug (fun m -> m "report-status capability: %b." report_status); if report_status then - Smart_flow.run sched fail io flow + State_flow.run sched fail Smart.pp_error io flow Smart.(recv ctx (status side_band)) |> prj >>| Smart.Status.map ~f:Ref.v else if uses_git_transport then - Smart_flow.run sched fail io flow Smart.(recv ctx recv_flush) + State_flow.run sched fail Smart.pp_error io flow + Smart.(recv ctx recv_flush) |> prj >>= fun () -> let cmds = List.map R.ok (Smart.Commands.commands cmds) in @@ -111,7 +115,8 @@ struct 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 8b92c5589..a258ef386 100644 --- a/src/not-so-smart/smart.ml +++ b/src/not-so-smart/smart.ml @@ -55,6 +55,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 -> @@ -117,21 +121,7 @@ type ('a, 'err) t = ('a, 'err) State.t = | Return of 'a | Error of 'err -module Context = struct - type t = State.Context.t - - type capabilities = State.Context.capabilities = { - client_caps : Capability.t list; - server_caps : Capability.t list; - } - - let make = State.Context.make - let with_decoder = State.Context.with_decoder - let replace_server_caps = State.Context.replace_server_caps - let is_cap_shared = State.Context.is_cap_shared - let capabilities = State.Context.capabilities -end - +module Context = State.Context include Witness let proto_request = Proto_request @@ -157,14 +147,10 @@ let packet ~trim = Packet trim let send_advertised_refs : _ send = Advertised_refs let recv_commands : _ recv = Commands -include State.Scheduler (State.Context) (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 +include State.Scheduler (Context)(Value) 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 221cd0480..4a4488fba 100644 --- a/src/not-so-smart/smart.mli +++ b/src/not-so-smart/smart.mli @@ -146,7 +146,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 9985fc0c4..000000000 --- a/src/not-so-smart/smart_flow.ml +++ /dev/null @@ -1,54 +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.length 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.length 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 058d21502..0926dae23 100644 --- a/src/not-so-smart/smart_git.ml +++ b/src/not-so-smart/smart_git.ml @@ -183,12 +183,13 @@ module Make (Scheduler : Sigs.SCHED with type +'a s = 'a Lwt.t) (Pack : APPEND with type +'a fiber = 'a Lwt.t) (Index : APPEND with type +'a fiber = 'a Lwt.t) + (* (HTTP : HTTP) *) (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 = @@ -356,27 +357,98 @@ 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 flow ?deepen ?want hostname store access fetch_cfg pack - = + ~capabilities path flow ?deepen ?want hostname store access fetch_cfg pack + = let open Lwt.Infix in Lwt.try_bind (fun () -> - Fetch.fetch_v1 ~uses_git_transport ~push_stdout ~push_stderr - ~capabilities ?deepen ?want ~host:hostname 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))) + Fetch.V1.fetch ~uses_git_transport ~push_stdout ~push_stderr + ~capabilities ?deepen ?want ~host:hostname 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))) (fun refs -> - pack None >>= fun () -> - Mimic.close flow >>= fun () -> Lwt.return_ok refs) + pack None >>= fun () -> + Mimic.close flow >>= fun () -> Lwt.return_ok refs) @@ fun exn -> pack None >>= fun () -> Mimic.close flow >>= fun () -> Lwt.fail exn + (* module Flow_http = struct *) + + (* type +'a fiber = 'a Lwt.t *) + + (* type t = { *) + (* mutable ic : string; *) + (* mutable oc : string; *) + (* mutable pos : int; *) + (* uri : Uri.t; *) + (* headers : (string * string) list; *) + (* ctx : Mimic.ctx; *) + (* } *) + + (* type error = [ `Msg of string ] *) + + (* let pp_error = Rresult.R.pp_msg *) + + (* let send t raw = *) + (* let oc = t.oc ^ Cstruct.to_string raw in *) + (* t.oc <- oc; *) + (* Lwt.return_ok (Cstruct.length raw) *) + + (* let rec recv t raw = *) + (* if t.pos = String.length t.ic then ( *) + (* let open Lwt.Infix in *) + (* (HTTP.post ~ctx:t.ctx ~headers:t.headers t.uri t.oc *) + (* >|= Rresult.(R.reword_error (R.msgf "%a" HTTP.pp_error))) *) + (* >>? fun (_resp, contents) -> *) + (* t.ic <- t.ic ^ contents; *) + (* recv t raw) *) + (* else *) + (* let len = min (String.length t.ic - t.pos) (Cstruct.length raw) in *) + (* Cstruct.blit_from_string t.ic t.pos raw 0 len; *) + (* t.pos <- t.pos + len; *) + (* Lwt.return_ok (`Input len) *) + + (* 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 *) + (* 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 *) + (* let uri0 = Uri.of_string uri0 in *) + (* Log.debug (fun m -> m "GET %a" Uri.pp uri0); *) + (* HTTP.get ~ctx ~headers uri0 >|= R.reword_error (R.msgf "%a" HTTP.pp_error) *) + (* >>? fun (_resp, contents) -> *) + (* let uri1 = Fmt.str "%a/git-upload-pack" Uri.pp uri in *) + (* let uri1 = Uri.of_string uri1 in *) + (* let flow = *) + (* { Flow_http.ic = contents; pos = 0; oc = ""; uri = uri1; headers; ctx } *) + (* in *) + (* Fetch_v1_http.fetch ~push_stdout ~push_stderr ~capabilities ?deepen ?want *) + (* ~host:endpoint path flow store access fetch_cfg *) + (* (push_pack_new_str push_pack) *) + (* >>= fun refs -> *) + (* push_pack None >>= fun () -> *) + (* Lwt.return_ok refs *) + (* [@@warning "-32"] *) + let default_capabilities = [ `Side_band_64k; @@ -386,6 +458,8 @@ struct `Report_status; ] + module V2 = struct end + type transmission = [ `Git | `Exec ] let rec get_transmission : @@ -426,6 +500,7 @@ struct ~idx = let open Rresult in let open Lwt.Infix in + let capabilities = Capability.filter_by ~protocol_v:version capabilities in let hostname = edn.Endpoint.hostname in let path = edn.Endpoint.path in let stream, emitter = Lwt_stream.create_bounded bounds in @@ -446,7 +521,7 @@ struct Mimic.connect ress >>= fun flow -> match flow, get_transmission ress, version with | Ok flow, Some (#transmission as transmission), `V1 -> ( - let fetch_cfg = Nss.Fetch.configuration capabilities in + let fetch_cfg = Nss.Fetch.V1.configuration capabilities in let uses_git_transport = match transmission with `Git -> true | `Exec -> false in @@ -464,7 +539,7 @@ struct | Ok _refs, (Error _ as err) -> Lwt.return err) | Ok flow, Some (`HTTP (uri, handshake)), `V1 -> ( let fetch_cfg = - Nss.Fetch.configuration ~stateless:true capabilities + Nss.Fetch.V1.configuration ~stateless:true capabilities in let uri0 = Fmt.str "%a/info/refs?service=git-upload-pack" Uri.pp uri @@ -618,6 +693,8 @@ 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 let open Lwt.Infix in let hostname = edn.Endpoint.hostname in diff --git a/src/not-so-smart/smart_git_intf.ml b/src/not-so-smart/smart_git_intf.ml index a67bed37c..f3a07979c 100644 --- a/src/not-so-smart/smart_git_intf.ml +++ b/src/not-so-smart/smart_git_intf.ml @@ -123,6 +123,7 @@ module type SMART_GIT = sig (Scheduler : Sigs.SCHED with type +'a s = 'a Lwt.t) (Pack : APPEND with type +'a fiber = 'a Lwt.t) (Index : APPEND with type +'a fiber = 'a Lwt.t) + (* (HTTP : HTTP) *) (Uid : UID) (Ref : Sigs.REF) : sig val fetch : @@ -136,7 +137,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 ] -> @@ -157,7 +158,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/state.ml b/src/not-so-smart/state.ml index caa220b61..5c840f1a0 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 @@ -85,6 +86,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 a2a8c794f..a40d5eb78 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 @@ -60,6 +61,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 map : ('a, 'err) t -> f:('a -> 'b) -> ('b, 'err) t diff --git a/src/not-so-smart/state_flow.ml b/src/not-so-smart/state_flow.ml new file mode 100644 index 000000000..436c29613 --- /dev/null +++ b/src/not-so-smart/state_flow.ml @@ -0,0 +1,68 @@ +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 + +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 + + 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." pp_error err); + failwithf "%a" pp_error err + | Read { k; buffer; off; len; eof } -> ( + let rd_n_bytes = min (Cstruct.length 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 diff --git a/src/not-so-smart/state_flow.mli b/src/not-so-smart/state_flow.mli new file mode 100644 index 000000000..75e05f2ea --- /dev/null +++ b/src/not-so-smart/state_flow.mli @@ -0,0 +1,14 @@ +module Log : Logs.LOG + +val io_buffer_size : int + +type ('a, 's) raise = exn -> ('a, 's) Sigs.io + +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 new file mode 100644 index 000000000..ebf0333c9 --- /dev/null +++ b/src/not-so-smart/wire_proto_v2.ml @@ -0,0 +1,86 @@ +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 + +module Context = State.Context + +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 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 = + 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) diff --git a/test/smart/dune b/test/smart/dune index 42605220d..627d75b97 100644 --- a/test/smart/dune +++ b/test/smart/dune @@ -13,45 +13,49 @@ unix_backend pipe) (libraries - git_version - git.nss.pkt-line - ptime - ptime.clock.os - mirage-flow - mimic - git.nss.unixiz - git - git-unix - result - mirage-crypto-rng - mirage-crypto-rng.unix + alcotest + alcotest-lwt + astring + bigstringaf + bos + carton + carton-lwt + capability + cstruct digestif digestif.c domain-name + fmt + fmt.tty + fpath + git git.nss git.nss.git - bos - fpath - carton-lwt - bigstringaf - git.nss.sigs git.nss.hkt - fmt git.nss.pck - carton - rresult - alcotest + git.nss.pkt-line + git.nss.sigs git.nss.smart - lwt.unix - astring - lwt - cstruct - uri - fmt.tty + git.nss.state + git.nss.unixiz + git.nss.wire-proto-v2 + git-unix + git_version logs logs.fmt - alcotest-lwt - unix)) + lwt + lwt.unix + mimic + mirage-crypto-rng + mirage-crypto-rng.unix + mirage-flow + ptime + ptime.clock.os + result + rresult + unix + uri +)) (executable (name test_edn) diff --git a/test/smart/test.ml b/test/smart/test.ml index e03aadc61..04b960807 100644 --- a/test/smart/test.ml +++ b/test/smart/test.ml @@ -1,3 +1,4 @@ +open Astring open Bos open Rresult open Lwt_backend @@ -1140,7 +1141,7 @@ let test_negotiation () = 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 = OS.Dir.with_current path @@ fun () -> @@ -1149,7 +1150,13 @@ let run_git_upload_pack ?(tmps_exit = true) store ic oc = let git_upload_pack = Cmd.(v "git-upload-pack" % Fpath.to_string path) in let pipe () = OS.Cmd.run_out cat |> OS.Cmd.out_run_in >>= fun cat -> - OS.Cmd.run_io git_upload_pack cat |> OS.Cmd.out_run_in >>= fun git -> + 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 @@ -1811,6 +1818,164 @@ let update_testzone_1 store = | 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 + let dir_sep = "/" + let segs p = Astring.String.cuts ~sep:dir_sep p + 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" [ @@ -1832,6 +1997,12 @@ let test = test_push_empty (); test_push_capabilities (); ] ); + ( "protocol-v2", + Proto_v2. + [ + test_get_server_capabilities; test_ls_refs_request; + test_ls_refs_request_has_refs; + ] ); ] let tmp = "tmp"