From 70ff0adfbea5beb5ef6d1f25b28dc819fd16d896 Mon Sep 17 00:00:00 2001 From: Ulugbek Abdullaev Date: Mon, 28 Sep 2020 14:42:03 +0200 Subject: [PATCH] add progress reporting capability to fetch --- src/git-unix/git_unix.ml | 7 ++++--- src/git/mem.ml | 7 ++++--- src/git/sync.ml | 8 +++++--- src/git/sync.mli | 4 ++++ src/not-so-smart/fetch.ml | 8 ++++---- src/not-so-smart/fetch.mli | 2 ++ src/not-so-smart/smart_git.ml | 33 ++++++++++++++++++--------------- src/not-so-smart/smart_git.mli | 2 ++ 8 files changed, 43 insertions(+), 28 deletions(-) diff --git a/src/git-unix/git_unix.ml b/src/git-unix/git_unix.ml index 5ae087e37..e0b8dce41 100644 --- a/src/git-unix/git_unix.ml +++ b/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) -> diff --git a/src/git/mem.ml b/src/git/mem.ml index 39db6e39f..9e57472ce 100644 --- a/src/git/mem.ml +++ b/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) -> diff --git a/src/git/sync.ml b/src/git/sync.ml index ef82d8a48..b2a548164 100644 --- a/src/git/sync.ml +++ b/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 diff --git a/src/git/sync.mli b/src/git/sync.mli index 296ad0d26..20436a53b 100644 --- a/src/git/sync.mli +++ b/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 -> diff --git a/src/not-so-smart/fetch.ml b/src/not-so-smart/fetch.ml index 52d2db5d8..3fc93ff56 100644 --- a/src/not-so-smart/fetch.ml +++ b/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 () = diff --git a/src/not-so-smart/fetch.mli b/src/not-so-smart/fetch.mli index 117701966..cbf353c3c 100644 --- a/src/not-so-smart/fetch.mli +++ b/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 -> diff --git a/src/not-so-smart/smart_git.ml b/src/not-so-smart/smart_git.ml index 79068659d..006336665 100644 --- a/src/not-so-smart/smart_git.ml +++ b/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 diff --git a/src/not-so-smart/smart_git.mli b/src/not-so-smart/smart_git.mli index bb1f2023c..1a90814c7 100644 --- a/src/not-so-smart/smart_git.mli +++ b/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