Merge pull request #629 from mirage/ack

Encoder for ACK

fuzz/smart.ml

@@ -193,7 +193,9 @@ let () =
   let wants = List.map Digestif.SHA1.to_hex wants in
   let v = Smart.Want.v ~capabilities:[] wants in
   let str = to_string v in
-  let res = of_string str in
-  Crowbar.check_eq ~pp:Smart.Want.pp
-    ~eq:(Smart.Want.equal ~uid:String.equal ~reference:String.equal)
-    v res
+  match of_string str with
+  | Some res ->
+      Crowbar.check_eq ~pp:Smart.Want.pp
+        ~eq:(Smart.Want.equal ~uid:String.equal ~reference:String.equal)
+        v res
+  | None -> Crowbar.failf "Invalid empty fetch request (%S)" str

src/not-so-smart/find_common.ml

@@ -172,7 +172,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)
+                  Smart_flow.run scheduler raise io flow
+                    Smart.(recv ctx recv_ack)
                   >>| Smart.Negotiation.map ~f:of_hex
                   >>= fun ack ->
                   match ack with
@@ -253,7 +254,7 @@ let find_common (type t) scheduler io flow cfg
       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)
+          Smart_flow.run scheduler raise io flow Smart.(recv ctx recv_ack)
           >>| Smart.Negotiation.map ~f:of_hex
           >>= fun ack ->
           match ack with

src/not-so-smart/protocol.ml

@@ -623,7 +623,9 @@ module Decoder = struct
         let v = peek_pkt decoder in
         if Sub.is_empty v then (
           junk_pkt decoder;
-          return (Want.v ~capabilities (first_want :: List.rev wants)) decoder
+          return
+            (Some (Want.v ~capabilities (first_want :: List.rev wants)))
+            decoder
           (* TODO else if start with shallow or depth request or filter request then *))
         else
           match Sub.cut ~sep:v_space v with
@@ -639,7 +641,8 @@ module Decoder = struct
 
     let decode_first_want decoder =
       let v = peek_pkt decoder in
-      if Sub.is_prefix v ~affix:v_want then (
+      if Sub.is_empty v then return None decoder
+      else if Sub.is_prefix v ~affix:v_want then (
         let v = v |> Sub.with_range ~first:(Sub.length v_want) in
         (* NOTE(dinosaure): we accept more than Git. The BNF syntax of
            [first-want] is:
@@ -1227,4 +1230,32 @@ module Encoder = struct
         flush (go buffer (off + len) (max - len)) encoder
     in
     go payload 0 (String.length payload) encoder
+
+  let encode_acks encoder acks =
+    (* TODO: Remove NACK from [Negotiation.t]. *)
+    let write_ack ack encoder =
+      let write_ack uid suffix =
+        write encoder "ACK";
+        write_space encoder;
+        write encoder uid;
+        match suffix with
+        | None -> ()
+        | Some s ->
+            write_space encoder;
+            write encoder s
+      in
+      match ack with
+      | Negotiation.ACK uid -> write_ack uid None
+      | ACK_continue uid -> write_ack uid (Some "continue")
+      | ACK_ready uid -> write_ack uid (Some "ready")
+      | ACK_common uid -> write_ack uid (Some "common")
+      | NAK -> write encoder "NAK"
+    in
+    let rec go acks encoder =
+      match acks with
+      | [] ->
+          delayed_write_pkt (write_ack Negotiation.NAK) (flush kdone) encoder
+      | hd :: tl -> delayed_write_pkt (write_ack hd) (go tl) encoder
+    in
+    go acks encoder
 end

src/not-so-smart/protocol.mli

@@ -205,7 +205,10 @@ module Decoder : sig
     ?sideband:bool -> decoder -> (string Status.t, [> error ]) state
 
   val decode_packet : trim:bool -> decoder -> (string, [> error ]) state
-  val decode_want : decoder -> ((string, string) Want.t, [> error ]) state
+
+  val decode_want :
+    decoder -> ((string, string) Want.t option, [> error ]) state
+
   val decode_have : decoder -> (string Have.t, [> error ]) state
 
   val decode_commands :
@@ -224,6 +227,9 @@ module Encoder : sig
   val encode_flush : encoder -> error state
   val encode_commands : encoder -> (string, string) Commands.t -> error state
 
+  val encode_acks : encoder -> string Negotiation.t list -> error state
+  (** Sends a list of [ACK]s and terminate with a [NAK]. *)
+
   val encode_advertised_refs :
     encoder -> (string, string) Advertised_refs.t -> error state
 

src/not-so-smart/smart.ml

@@ -24,6 +24,7 @@ module Witness = struct
     | Commands : (string, string) Commands.t send
     | Send_pack : { side_band : bool; stateless : bool } -> string send
     | Advertised_refs : (string, string) Advertised_refs.t send
+    | Acks : string Negotiation.t list send
 
   type 'a recv =
     | Advertised_refs : (string, string) Advertised_refs.t recv
@@ -44,7 +45,7 @@ module Witness = struct
     | Ack : string Negotiation.t recv
     | Flush : unit recv
     | Shallows : string Shallow.t list recv
-    | Want : (string, string) Want.t recv
+    | Want : (string, string) Want.t option recv
     | Have : string Have.t recv
 end
 
@@ -72,6 +73,7 @@ module Value = struct
           encode_pack ~side_band ~stateless encoder v
       | Flush -> encode_flush encoder
       | Advertised_refs -> encode_advertised_refs encoder v
+      | Acks -> encode_acks encoder v
     in
     let rec translate_to_state_t = function
       | Encoder.Done -> State.Return ()
@@ -152,7 +154,8 @@ let recv_pack ?(push_stdout = ignore) ?(push_stderr = ignore) side_band =
 let recv_flush : _ recv = Flush
 let status sideband = Status sideband
 let flush : _ send = Flush
-let ack = Ack
+let recv_ack : _ recv = Ack
+let send_acks : _ send = Acks
 let shallows = Shallows
 
 let send_pack ?(stateless = false) side_band =

src/not-so-smart/smart.mli

@@ -244,12 +244,13 @@ val recv_pack :
 
 val recv_flush : unit recv
 val recv_commands : (string, string) Commands.t option recv
-val ack : string Negotiation.t recv
+val send_acks : string Negotiation.t list send
+val recv_ack : string Negotiation.t recv
 val shallows : string Shallow.t list recv
 val status : bool -> string Status.t recv
 val packet : trim:bool -> string recv
 val send_advertised_refs : (string, string) Advertised_refs.t send
-val recv_want : (string, string) Want.t recv
+val recv_want : (string, string) Want.t option recv
 val recv_have : string Have.t recv
 val bind : ('a, 'err) t -> f:('a -> ('b, 'err) t) -> ('b, 'err) t
 val ( let* ) : ('a, 'err) t -> ('a -> ('b, 'err) t) -> ('b, 'err) t