add support for "ls-refs" command (without args)

src/not-so-smart/fetch.ml

@@ -143,7 +143,7 @@ struct
     module State_flow = State_flow.Make (Wire_proto_v2)
 
     let connect ?(uses_git_transport = false) ~host ~path ctx =
-      let ( let* ) = Wire_proto_v2.( let* ) in
+      let open Wire_proto_v2.Syntax in
       let return = Wire_proto_v2.return in
       let* () =
         if uses_git_transport then
@@ -157,11 +157,21 @@ struct
     let get_server_capabilities ?(uses_git_transport = false) ~host ~path ctx
         flow =
       let get_caps ctx =
-        let ( let* ) = Wire_proto_v2.( let* ) in
+        let open Wire_proto_v2.Syntax in
         let* caps = connect ~uses_git_transport ~host ~path ctx in
         let* () = Wire_proto_v2.send ctx Flush () in
         Wire_proto_v2.return caps
       in
       State_flow.run sched io_raise io flow (get_caps ctx) |> prj
+
+    let ls_refs_request ?(uses_git_transport = false) ~host ~path ctx flow req =
+      let ls_refs_resp =
+        let open Wire_proto_v2.Syntax in
+        let* caps = connect ~uses_git_transport ~host ~path ctx in
+        (* TODO: how are server caps handled on the client side? *)
+        let* () = Wire_proto_v2.send ctx Ls_refs_req (`Client_caps caps, req) in
+        Wire_proto_v2.recv ctx Ls_refs_res
+      in
+      State_flow.run sched io_raise io flow ls_refs_resp |> prj
   end
 end

src/not-so-smart/fetch.mli

@@ -39,5 +39,14 @@ module Make
       Wire_proto_v2.Context.t ->
       Flow.t ->
       Wire_proto_v2.Capability.t list IO.t
+
+    val ls_refs_request :
+      ?uses_git_transport:bool ->
+      host:[ `host ] Domain_name.t ->
+      path:string ->
+      Wire_proto_v2.Context.capabilities State.Context.t ->
+      Flow.t ->
+      Wire_proto_v2.Proto_vals_v2.Ls_refs.request ->
+      Wire_proto_v2.Proto_vals_v2.Ls_refs.response IO.t
   end
 end

src/not-so-smart/proto_vals_v2.ml

@@ -34,6 +34,8 @@ module Proto_request = struct
       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 *)
@@ -48,6 +50,12 @@ module Ls_refs = struct
   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
@@ -538,8 +546,6 @@ module Decoder = struct
     decode_acknowledgements decoder
 end
 
-module Command = struct type t = { name : string; args : string list } end
-
 module Encoder = struct
   open Pkt_line.Encoder
 
@@ -648,4 +654,19 @@ module Encoder = struct
           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

src/not-so-smart/wire_proto_v2.ml

@@ -4,9 +4,18 @@ 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
+  type 'a recv =
+    | Capability_advertisement : Capability.t list recv
+    | Ls_refs_res : Proto_vals_v2.Ls_refs.response recv
 end
 
 (* TODO: copy of Smart.Context; remove duplication *)
@@ -60,6 +69,9 @@ module Value = struct
       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
@@ -86,7 +98,8 @@ module Value = struct
     transl
       (match w with
       | Capability_advertisement ->
-          Proto_vals_v2.Decoder.decode_capability_ads decoder)
+          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)

test/smart/dune

@@ -1,13 +1,56 @@
 (executable
  (name test)
- (modules append fifo hTTP loopback lwt_backend ref store_backend test uid
-   unix_backend pipe)
- (libraries bigarray-compat mirage-flow mimic git.nss.unixiz git git-unix
-   result curl.lwt mirage-crypto-rng.unix digestif digestif.c domain-name
-   git.nss git.nss.wire-proto-v2 git.nss.git bos fpath carton-lwt bigstringaf git.nss.sigs git.nss.hkt fmt
-   git.nss.pck carton rresult alcotest git.nss.smart lwt.unix mmap astring
-   lwt cstruct uri fmt.tty logs.fmt alcotest-lwt cohttp-lwt-unix
-   git-cohttp-unix))
+ (modules
+  append
+  fifo
+  hTTP
+  loopback
+  lwt_backend
+  ref
+  store_backend
+  test
+  uid
+  unix_backend
+  pipe)
+ (libraries
+  bigarray-compat
+  mirage-flow
+  mimic
+  git.nss.unixiz
+  git
+  git-unix
+  result
+  curl.lwt
+  mirage-crypto-rng.unix
+  digestif
+  digestif.c
+  domain-name
+  git.nss
+  git.nss.wire-proto-v2
+  git.nss.git
+  bos
+  fpath
+  carton-lwt
+  bigstringaf
+  git.nss.sigs
+  git.nss.hkt
+  fmt
+  git.nss.pck
+  carton
+  rresult
+  alcotest
+  git.nss.smart
+  lwt.unix
+  mmap
+  astring
+  lwt
+  cstruct
+  uri
+  fmt.tty
+  logs.fmt
+  alcotest-lwt
+  cohttp-lwt-unix
+  git-cohttp-unix))
 
 (executable
  (name test_edn)

test/smart/test.ml

@@ -1661,7 +1661,7 @@ module Proto_v2 = struct
 
   let ( let*! ) x f = x >>? f
 
-  let get_server_capabilities_test =
+  let test_get_server_capabilities =
     Alcotest_lwt.test_case "can connect and get server capabilities" `Quick
     @@ fun sw () ->
     let open Lwt.Syntax in
@@ -1694,18 +1694,122 @@ module Proto_v2 = struct
           (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"
     [
       ( "regression",
-        [ (* test_empty_clone (); test_simple_clone (); test_simple_push ();
-             test_push_error (); test_fetch_empty (); test_negotiation ();
-             test_ssh (); test_negotiation_ssh (); test_push_ssh ();
-             test_negotiation_http (); test_partial_clone_ssh ();
-             test_partial_fetch_ssh (); test_sync_fetch (); *) ] );
-      "protocol-v2", [ Proto_v2.get_server_capabilities_test ];
+        [
+          test_empty_clone (); test_simple_clone (); test_simple_push ();
+          test_push_error (); test_fetch_empty (); test_negotiation ();
+          test_ssh (); test_negotiation_ssh (); test_push_ssh ();
+          test_negotiation_http (); test_partial_clone_ssh ();
+          test_partial_fetch_ssh (); test_sync_fetch ();
+        ] );
+      ( "protocol-v2",
+        Proto_v2.
+          [
+            test_get_server_capabilities; test_ls_refs_request;
+            test_ls_refs_request_has_refs;
+          ] );
     ]
 
 let tmp = "tmp"