add progress reporting capability to fetch

src/git-unix/git_unix.ml

@@ -718,14 +718,15 @@ module Sync (Git_store : Git.S) (HTTP : Smart_git.HTTP) = struct
     Lwt.async fill;
     fun () -> Lwt_stream.get stream
 
-  let fetch ~resolvers edn store ?version ?capabilities want =
+  let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~resolvers edn store
+      ?version ?capabilities want =
     let dotgit = Git_store.dotgit store in
     let temp = Fpath.(dotgit / "tmp") in
     tmp temp "pack-%s.pack" >>= fun src ->
     tmp temp "pack-%s.pack" >>= fun dst ->
     tmp temp "pack-%s.idx" >>= fun idx ->
-    fetch ~resolvers edn store ?version ?capabilities want ~src ~dst ~idx temp
-      temp
+    fetch ~push_stdout ~push_stderr ~resolvers edn store ?version ?capabilities
+      want ~src ~dst ~idx temp temp
     >>? function
     | `Empty -> Lwt.return_ok None
     | `Pack (hash, refs) ->

src/git/mem.ml

@@ -473,14 +473,15 @@ struct
     Lwt.async fill;
     fun () -> Lwt_stream.get stream
 
-  let fetch ~resolvers edn store ?version ?capabilities want =
+  let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~resolvers edn store
+      ?version ?capabilities want =
     let t_idx = Carton.Dec.Idx.Device.device () in
     let t_pck = Cstruct_append.device () in
     let index = Carton.Dec.Idx.Device.create t_idx in
     let src = Cstruct_append.key t_pck in
     let dst = Cstruct_append.key t_pck in
-    fetch ~resolvers edn store ?version ?capabilities want ~src ~dst ~idx:index
-      t_pck t_idx
+    fetch ~push_stdout ~push_stderr ~resolvers edn store ?version ?capabilities
+      want ~src ~dst ~idx:index t_pck t_idx
     >>? function
     | `Empty -> Lwt.return_ok None
     | `Pack (hash, refs) ->

src/git/sync.ml

@@ -28,6 +28,8 @@ module type S = sig
   val pp_error : error Fmt.t
 
   val fetch :
+    ?push_stdout:(string -> unit) ->
+    ?push_stderr:(string -> unit) ->
     resolvers:Conduit.resolvers ->
     Smart_git.endpoint ->
     store ->
@@ -170,10 +172,10 @@ struct
   include Smart_git.Make (Scheduler) (Pack) (Index) (Conduit) (HTTP) (Hash)
             (Reference)
 
-  let fetch ~resolvers endpoint t ?version ?capabilities want ~src ~dst ~idx
-      t_pck t_idx =
+  let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~resolvers endpoint
+      t ?version ?capabilities want ~src ~dst ~idx t_pck t_idx =
     let ministore = Ministore.inj (t, Hashtbl.create 0x100) in
-    fetch ~resolvers
+    fetch ~push_stdout ~push_stderr ~resolvers
       (access, lightly_load t, heavily_load t)
       ministore endpoint ?version ?capabilities want t_pck t_idx ~src ~dst ~idx
 

src/git/sync.mli

@@ -25,6 +25,8 @@ module type S = sig
   val pp_error : error Fmt.t
 
   val fetch :
+    ?push_stdout:(string -> unit) ->
+    ?push_stderr:(string -> unit) ->
     resolvers:Conduit.resolvers ->
     Smart_git.endpoint ->
     store ->
@@ -65,6 +67,8 @@ module Make
   val pp_error : error Fmt.t
 
   val fetch :
+    ?push_stdout:(string -> unit) ->
+    ?push_stderr:(string -> unit) ->
     resolvers:Conduit.resolvers ->
     Smart_git.endpoint ->
     store ->

src/not-so-smart/fetch.ml

@@ -69,8 +69,9 @@ struct
         in
         List.fold_left fold [] have |> List.split
 
-  let fetch_v1 ?(prelude = true) ~capabilities ?want:(refs = `None) ~host path
-      flow store access fetch_cfg pack =
+  let fetch_v1 ?(prelude = true) ?(push_stdout = ignore) ?(push_stderr = ignore)
+      ~capabilities ?want:(refs = `None) ~host path flow store access fetch_cfg
+      pack =
     let capabilities =
       (* XXX(dinosaure): HTTP ([stateless]) enforces no-done capabilities. Otherwise, you never
          will receive the PACK file. *)
@@ -115,8 +116,7 @@ struct
             Smart.shared `Side_band ctx || Smart.shared `Side_band_64k ctx
           in
           recv ctx
-            (recv_pack ~side_band ~push_stdout:ignore ~push_stderr:ignore
-               ~push_pack:pack)
+            (recv_pack ~side_band ~push_stdout ~push_stderr ~push_pack:pack)
         in
         if res < 0 then Log.warn (fun m -> m "No common commits");
         let rec go () =

src/not-so-smart/fetch.mli

@@ -12,6 +12,8 @@ module Make
     (Ref : REF) : sig
   val fetch_v1 :
     ?prelude:bool ->
+    ?push_stdout:(string -> unit) ->
+    ?push_stderr:(string -> unit) ->
     capabilities:Smart.Capability.t list ->
     ?want:[ `All | `Some of Ref.t list | `None ] ->
     host:[ `host ] Domain_name.t ->

src/not-so-smart/smart_git.ml

@@ -320,14 +320,15 @@ struct
   module Fetch = Nss.Fetch.Make (Scheduler) (Lwt) (Flow) (Uid) (Ref)
   module Push = Nss.Push.Make (Scheduler) (Lwt) (Flow) (Uid) (Ref)
 
-  let fetch_v1 ?prelude ~capabilities path ~resolvers ?want domain_name store
-      access fetch_cfg pack =
+  let fetch_v1 ?prelude ~push_stdout ~push_stderr ~capabilities path ~resolvers
+      ?want domain_name store access fetch_cfg pack =
     let open Lwt.Infix in
     Conduit.resolve resolvers domain_name >>? fun flow ->
     Lwt.try_bind
       (fun () ->
-        Fetch.fetch_v1 ?prelude ~capabilities ?want ~host:domain_name path flow
-          store access fetch_cfg (fun (payload, off, len) ->
+        Fetch.fetch_v1 ?prelude ~push_stdout ~push_stderr ~capabilities ?want
+          ~host:domain_name path flow store access fetch_cfg
+          (fun (payload, off, len) ->
             let v = String.sub payload off len in
             pack (Some (v, 0, len))))
       (fun refs ->
@@ -375,8 +376,8 @@ struct
 
   module Fetch_http = Nss.Fetch.Make (Scheduler) (Lwt) (Flow_http) (Uid) (Ref)
 
-  let http_fetch_v1 ~capabilities uri ?(headers = []) domain_name path
-      ~resolvers ?want store access fetch_cfg pack =
+  let http_fetch_v1 ~push_stdout ~push_stderr ~capabilities uri ?(headers = [])
+      domain_name path ~resolvers ?want store access fetch_cfg pack =
     let open Rresult in
     let open Lwt.Infix in
     let uri0 = Fmt.strf "%a/info/refs?service=git-upload-pack" Uri.pp uri in
@@ -396,8 +397,9 @@ struct
         headers;
       }
     in
-    Fetch_http.fetch_v1 ~prelude:false ~capabilities ?want ~host:domain_name
-      path flow store access fetch_cfg (fun (payload, off, len) ->
+    Fetch_http.fetch_v1 ~prelude:false ~push_stdout ~push_stderr ~capabilities
+      ?want ~host:domain_name path flow store access fetch_cfg
+      (fun (payload, off, len) ->
         let v = String.sub payload off len in
         pack (Some (v, 0, len)))
     >>= fun refs ->
@@ -410,9 +412,9 @@ struct
       `Report_status;
     ]
 
-  let fetch ~resolvers (access, light_load, heavy_load) store edn
-      ?(version = `V1) ?(capabilities = default_capabilities) want t_pck t_idx
-      ~src ~dst ~idx =
+  let fetch ?(push_stdout = ignore) ?(push_stderr = ignore) ~resolvers
+      (access, light_load, heavy_load) store edn ?(version = `V1)
+      ?(capabilities = default_capabilities) want t_pck t_idx ~src ~dst ~idx =
     let open Rresult in
     let open Lwt.Infix in
     let domain_name = edn.domain_name in
@@ -435,8 +437,8 @@ struct
           (* XXX(dinosaure): [prelude] is the only tweak needed between git:// and SSH. *)
           let run () =
             Lwt.both
-              (fetch_v1 ~prelude ~capabilities path ~resolvers ~want domain_name
-                 store access fetch_cfg pusher)
+              (fetch_v1 ~push_stdout ~push_stderr ~prelude ~capabilities path
+                 ~resolvers ~want domain_name store access fetch_cfg pusher)
               (run ~light_load ~heavy_load stream t_pck t_idx ~src ~dst ~idx)
             >>= fun (refs, idx) ->
             match refs, idx with
@@ -464,8 +466,9 @@ struct
           in
           let run () =
             Lwt.both
-              (http_fetch_v1 ~capabilities uri ~headers domain_name path
-                 ~resolvers ~want store access fetch_cfg pusher)
+              (http_fetch_v1 ~push_stdout ~push_stderr ~capabilities uri
+                 ~headers domain_name path ~resolvers ~want store access
+                 fetch_cfg pusher)
               (run ~light_load ~heavy_load stream t_pck t_idx ~src ~dst ~idx)
             >>= fun (refs, idx) ->
             match refs, idx with

src/not-so-smart/smart_git.mli

@@ -73,6 +73,8 @@ module Make
     (Uid : UID)
     (Ref : Sigs.REF) : sig
   val fetch :
+    ?push_stdout:(string -> unit) ->
+    ?push_stderr:(string -> unit) ->
     resolvers:Conduit.resolvers ->
     (Uid.t, _, Uid.t * int ref * int64, 'g, Scheduler.t) Sigs.access
     * Uid.t Carton_lwt.Thin.light_load