Merge pull request #236 from dinosaure/fix-fetch

Fixed the fetch command
mirage · Dec 11, 2017 · 887a833 · 887a833
2 parents c108fbe + b51661d
commit 887a833
Show file tree

Hide file tree

Showing 9 changed files with 465 additions and 333 deletions.
diff --git a/src/git-http/sync.ml b/src/git-http/sync.ml
diff --git a/src/git-http/sync.mli b/src/git-http/sync.mli
@@ -75,13 +75,13 @@ module type S_EXT = sig
     -> string -> string -> (Decoder.advertised_refs, error) result Lwt.t
 
   type command =
-    [ `Create of (Store.Hash.t * string)
-    | `Delete of (Store.Hash.t * string)
-    | `Update of (Store.Hash.t * Store.Hash.t * string) ]
+    [ `Create of (Store.Hash.t * Store.Reference.t)
+    | `Delete of (Store.Hash.t * Store.Reference.t)
+    | `Update of (Store.Hash.t * Store.Hash.t * Store.Reference.t) ]
 
   val push:
     Store.t
-    -> push:(Store.t -> (Store.Hash.t * string * bool) list -> (Store.Hash.t list * command list) Lwt.t)
+    -> push:((Store.Hash.t * Store.Reference.t * bool) list -> (Store.Hash.t list * command list) Lwt.t)
     -> ?headers:Web.HTTP.headers
     -> ?https:bool
     -> ?port:int
@@ -98,7 +98,7 @@ module type S_EXT = sig
     -> ?capabilities:Git.Capability.t list
     -> negociate:((Decoder.acks -> 'state -> ([ `Ready | `Done | `Again of Store.Hash.t list ] * 'state) Lwt.t) * 'state)
     -> has:Store.Hash.t list
-    -> want:((Store.Hash.t * string * bool) list -> (Store.Reference.t * Store.Hash.t) list Lwt.t)
+    -> want:((Store.Hash.t * Store.Reference.t * bool) list -> (Store.Reference.t * Store.Hash.t) list Lwt.t)
     -> ?deepen:[ `Depth of int | `Timestamp of int64 | `Ref of string ]
     -> ?port:int
     -> string -> string -> ((Store.Reference.t * Store.Hash.t) list * int, error) result Lwt.t
@@ -114,26 +114,135 @@ module type S_EXT = sig
     -> ?capabilities:Git.Capability.t list
     -> string -> string -> (Store.Hash.t, error) result Lwt.t
 
+  val fetch_some:
+    Store.t -> ?locks:Store.Lock.t ->
+    ?capabilities:Git.Capability.t list ->
+    references:Store.Reference.t list Store.Reference.Map.t ->
+    Uri.t -> (Store.Hash.t Store.Reference.Map.t
+              * Store.Reference.t list Store.Reference.Map.t, error) result Lwt.t
+  (** [fetch_some git ?locks ?capabilities ~references repository] will
+      fetch some remote references specified by [references].
+
+      [references] is a map which:
+      {ul
+      {- the key is the {b remote} reference.}
+      {- the value is a list of {b local} references - which may not
+      exist yet.}}
+
+      Then, the function will try to download all of these remote
+      references and returns 2 maps:
+
+      {ul
+      {- the first map contains all local references updated by the
+      new hash. This new hash is come from the server as the
+      downloaded remote reference asked by the client by [references].
+      Then, from associated local references with remote references,
+      we updated them with the associated hash.
+
+      For example, if [references] is:
+      {[ { "refs/heads/master": [ "refs/remotes/origin/master"
+                                ; "refs/heads/master" ] } ]}
+
+      We will update (or create) "refs/remotes/origin/master" and
+      "refs/heads/master" with the new hash downloaded from the remote
+      reference "refs/heads/master" only if it's necessary (only if we
+      did not find the hash referenced by "refs/heads/master" in the
+      local store).}
+
+      {- the second map is a {b subset} of [references] which contains
+      all binder of:
+
+      {ul
+      {- remote references which does not exist on the server side.}
+      {- remote references which references to an already existing in
+      the local store hash.}}}}
+
+      The client should not put the same local reference as a value of
+      some remote references. The client can define non-existing
+      remote references (then, they appear on the second map). The
+      client can want to set non-existing local references - we will
+      create them.
+
+      If the processus encountered an error when it updates
+      references, it leaves but, it did partially some update on some
+      local references. *)
+
   val fetch_all:
     Store.t -> ?locks:Store.Lock.t ->
     ?capabilities:Git.Capability.t list ->
-    Uri.t -> (unit, error) result Lwt.t
+    references:Store.Reference.t list Store.Reference.Map.t ->
+    Uri.t -> (Store.Hash.t Store.Reference.Map.t
+              * Store.Reference.t list Store.Reference.Map.t
+              * Store.Hash.t Store.Reference.Map.t, error) result Lwt.t
+  (** [fetch_all git ?locks ?capabilities ~references repository] has
+      the same semantic than {!fetch_some} for any remote references found
+      on [references]. However, [fetch all] will download all remote
+      references available on the server (and whose hash is not available
+      on the local store). If these remote references are not associated
+      with some local references, we return a third map which contains
+      these remote references binded with the new hash downloaded.
+
+      We {b don't} notice any non-downloaded remote references not
+      found on the [references] map and whose hash already exists on
+      the local store.
+
+      Then, the client can bind these new hashes with specific local
+      references or just give up. *)
 
   val fetch_one:
     Store.t -> ?locks:Store.Lock.t ->
     ?capabilities:Git.Capability.t list ->
-    reference:Store.Reference.t -> Uri.t -> (unit, error) result Lwt.t
+    reference:(Store.Reference.t * Store.Reference.t list) ->
+    Uri.t -> ([ `AlreadySync | `Sync of Store.Hash.t Store.Reference.Map.t ], error) result Lwt.t
+  (** [fetch_one git ?locks ?capabilities ~reference repository] is a
+      specific call of {!fetch_some} with only one reference. Then, it
+      retuns:
+
+      {ul
+      {- [`AlreadySync] if the hash of the requested reference already
+      exists on the local store}
+      {- [`Sync updated] if we downloaded [new_hash] and
+      set [local_ref] with this new hash.}} *)
 
   val clone:
     Store.t -> ?locks:Store.Lock.t ->
     ?capabilities:Git.Capability.t list ->
-    reference:Store.Reference.t -> Uri.t -> (unit, error) result Lwt.t
+    reference:(Store.Reference.t * Store.Reference.t) ->
+    Uri.t -> (unit, error) result Lwt.t
 
-  val update: Store.t ->
+  val update_and_create: Store.t ->
     ?capabilities:Git.Capability.t list ->
-    reference:Store.Reference.t -> Uri.t ->
+    references:Store.Reference.t list Store.Reference.Map.t-> Uri.t ->
     ((Store.Reference.t, Store.Reference.t * string) result list, error) result Lwt.t
+    (** As {!fetch_some}, [update git ?capabilities ~references
+        repository] is the other side of the communication with a Git
+        server and update and create remote references when it
+        uploads local hashes.
+
+        [reference] is a map which:
+        {ul
+        {- the key is the {b local} reference.}
+        {- the value is a list of {b remote} references - which may
+        not exist yet.}}
+
+        Then, the function will try to upload all of these local
+        references to the binded remote references. If binded remote
+        reference does not exist on the server, we ask to the server
+        to create and set it to the local hash.
+
+        For each update action, we check if the local store has the
+        remote hash. In other case, we miss this action - that means,
+        the local store is not synchronized with the server (and the
+        client probably needs to {!fetch_some} before).
+
+        Then, it returns a list of results. The [Ok] case with the
+        remote reference which the server updated correctly and the
+        [Error] case with the remote reference which the server
+        encountered an error with a description of this error.
 
+        At this final stage, the function does not encountered any
+        error during the commmunication - if it's the case, we did not
+        do any modification on the server and return an {!error}. *)
 end
 
 module Make_ext

diff --git a/src/git-unix/ogit-http-fetch-all/main.ml b/src/git-unix/ogit-http-fetch-all/main.ml
@@ -94,91 +94,19 @@ let pp_error ppf = function
 
 exception Write of Git_unix.FS.Ref.error
 
-let main ppf progress directory repository =
+let main directory repository =
   let root = option_map_default Fpath.(v (Sys.getcwd ())) Fpath.v directory in
 
   let open Lwt_result in
 
   let ( >!= ) v f = map_err f v in
 
-  let stdout =
-    if progress
-    then Some (fun raw -> Fmt.pf ppf "%s%!" (Cstruct.to_string raw); Lwt.return ())
-    else None
-  in
-
-  let stderr =
-    if progress
-    then Some (fun raw -> Fmt.(pf stderr) "%s%!" (Cstruct.to_string raw); Lwt.return ())
-    else None
-  in
-
-  let https =
-    match Uri.scheme repository with
-    | Some "https" -> true
-    | _ -> false
-  in
-
-  let want refs =
-    List.filter (function
-        | (_, _, false) -> true
-        | _ -> false)
-      refs
-    |> List.map (fun (hash, refname, _) -> (Git_unix.FS.Reference.of_string refname, hash))
-    |> Lwt.return
-  in
-
   Log.debug (fun l -> l ~header:"main" "root:%a, repository:%a.\n"
                 Fpath.pp root Uri.pp_hum repository);
 
   (Git_unix.FS.create ~root () >!= fun err -> `Store err) >>= fun git ->
-  (ok (Negociator.find_common git)) >>= fun (has, state, continue) ->
-  let continue { Sync_http.Decoder.acks; shallow; unshallow } state = continue { Git.Negociator.acks; shallow; unshallow } state in
-  (* structural typing god! *)
-
-  (Sync_http.fetch git ?stdout ?stderr ~https ~negociate:(continue, state) ~has ~want ?port:(Uri.port repository)
-     (option_value_exn
-        (fun () -> raise (Failure "Invalid repository: no host."))
-        (Uri.host repository))
-     (Uri.path_and_query repository)
-   >!= fun err -> `Sync err) >>= function
-  | [], 0 ->
-    Log.debug (fun l -> l ~header:"main" "Git repository already updated.");
-    Lwt.return (Ok ())
-  | updated, n ->
-    Log.debug (fun l -> l ~header:"main" "New version (%d object(s) added): %a."
-                  n (Fmt.hvbox (Fmt.Dump.list (Fmt.pair Git_unix.FS.Reference.pp Git_unix.FS.Hash.pp)))
-                  updated);
-
-    Lwt.try_bind
-      (fun () ->
-         Lwt_list.iter_s
-           (fun (dst, hash) ->
-              let open Lwt.Infix in
-
-              Git_unix.FS.Ref.write git ~locks:(Git_unix.FS.dotgit git) dst
-                (Git_unix.FS.Reference.Hash hash)
-              >>= function Error err -> Lwt.fail (Write err)
-                         | Ok _ ->
-                           Log.debug (fun l -> l ~header:"main" "Reference %a updated: %a."
-                                         Git_unix.FS.Reference.pp dst
-                                         Git_unix.FS.Hash.pp hash);
-                           Lwt.return ())
-           updated)
-      (fun () ->
-         try
-           let (_, master) = List.find (fun (dst, _) -> Git_unix.FS.Reference.(equal dst master)) updated in
-           let (_, head) = List.find (fun (dst, _) -> Git_unix.FS.Reference.(equal dst head)) updated in
-
-           let ( >!= ) = Lwt_result.bind_lwt_err in
-
-           if Git_unix.FS.Hash.equal master head
-           then Git_unix.FS.Ref.write git ~locks:(Git_unix.FS.dotgit git) Git_unix.FS.Reference.head
-             (Git_unix.FS.Reference.(Ref master)) >!= (fun err -> Lwt.return (`Reference err))
-           else Lwt.return (Ok ())
-         with Not_found -> Lwt.return (Ok ()))
-      (function Write err -> Lwt.return (Error (`Reference err))
-              | exn -> Lwt.fail exn) (* XXX(dinosaure): should never happen *)
+  (Sync_http.fetch_all git ~locks:Fpath.(root / ".locks") ~references:Git_unix.FS.Reference.Map.empty repository
+   >!= fun err -> `Sync err) >>= fun _ -> Lwt.return (Ok ())
 
 open Cmdliner
 
@@ -243,8 +171,8 @@ end
 let setup_log =
   Term.(const setup_logs $ Fmt_cli.style_renderer () $ Logs_cli.level () $ Flag.output)
 
-let main progress directory repository (quiet, ppf) =
-  match Lwt_main.run (main ppf (not quiet && progress) directory repository) with
+let main _ directory repository _ =
+  match Lwt_main.run (main directory repository) with
   | Ok () -> `Ok ()
   | Error (#error as err) -> `Error (false, Fmt.strf "%a" pp_error err)
 

diff --git a/src/git-unix/ogit-http-fetch/main.ml b/src/git-unix/ogit-http-fetch/main.ml
@@ -90,77 +90,28 @@ let pp_error ppf = function
 
 exception Write of Git_unix.FS.Ref.error
 
-let main ppf progress references directory repository =
+let main references directory repository =
   let root = option_map_default Fpath.(v (Sys.getcwd ())) Fpath.v directory in
 
   let open Lwt_result in
 
   let ( >!= ) v f = map_err f v in
 
-  let stdout =
-    if progress
-    then Some (fun raw -> Fmt.pf ppf "%s%!" (Cstruct.to_string raw); Lwt.return ())
-    else None
-  in
-
-  let stderr =
-    if progress
-    then Some (fun raw -> Fmt.(pf stderr) "%s%!" (Cstruct.to_string raw); Lwt.return ())
-    else None
-  in
-
-  let https =
-    match Uri.scheme repository with
-    | Some "https" -> true
-    | _ -> false
-  in
-
-  let want =
-    Lwt_list.filter_map_p (fun (refname, hash, _) ->
-        let reference = Git_unix.FS.Reference.of_string refname in
-
-        Lwt.try_bind
-          (fun () -> Lwt_list.find_s (fun (src, _) -> Lwt.return (Git_unix.FS.Reference.equal reference src)) references)
-          (fun (_, dst) -> Lwt.return (Some (dst, hash)))
-          (fun _ -> Lwt.return None))
+  let references =
+    List.fold_left
+      (fun references (remote_ref, local_ref) ->
+         try let local_refs = Git_unix.FS.Reference.Map.find remote_ref references in
+           if List.exists (Git_unix.FS.Reference.equal local_ref) local_refs
+           then references
+           else Git_unix.FS.Reference.Map.add remote_ref (local_ref :: local_refs) references
+         with Not_found ->
+           Git_unix.FS.Reference.Map.add remote_ref [ local_ref ] references)
+      Git_unix.FS.Reference.Map.empty references
   in
 
-  Log.debug (fun l -> l ~header:"main" "root:%a, repository:%a.\n"
-                Fpath.pp root Uri.pp_hum repository);
-
   (Git_unix.FS.create ~root () >!= fun err -> `Store err) >>= fun git ->
-  (ok (Negociator.find_common git)) >>= fun (has, state, continue) ->
-  let continue { Sync_http.Decoder.acks; shallow; unshallow } state = continue { Git.Negociator.acks; shallow; unshallow } state in
-  (* structural typing god! *)
-
-  (Sync_http.fetch git ?stdout ?stderr ~https ~negociate:(continue, state) ~has ~want ?port:(Uri.port repository)
-     (option_value_exn
-        (fun () -> raise (Failure "Invalid repository: no host."))
-        (Uri.host repository))
-     (Uri.path_and_query repository)
-   >!= fun err -> `Sync err) >>= function
-  | [], 0 ->
-    Log.debug (fun l -> l ~header:"main" "Git repository already updated.");
-    Lwt.return (Ok ())
-  | updated, n ->
-    Log.debug (fun l -> l ~header:"main" "New version (%d object(s) added): %a."
-                  n (Fmt.hvbox (Fmt.Dump.list (Fmt.pair Git_unix.FS.Reference.pp Git_unix.FS.Hash.pp)))
-                  updated);
-
-    Lwt.try_bind
-      (fun () ->
-         Lwt_list.iter_p
-           (fun (dst, hash) ->
-              let open Lwt.Infix in
-
-              Git_unix.FS.Ref.write git ~locks:(Git_unix.FS.dotgit git) dst
-                (Git_unix.FS.Reference.Hash hash)
-              >>= function Error err -> Lwt.fail (Write err)
-                         | Ok _ -> Lwt.return ())
-           updated)
-      (fun () -> Lwt.return (Ok ()))
-      (function Write err -> Lwt.return (Error (`Reference err))
-              | exn -> Lwt.fail exn) (* XXX(dinosaure): should never happen. *)
+  (Sync_http.fetch_some git ~locks:Fpath.(Git_unix.FS.root git / ".locks") ~references repository
+   >!= fun err -> `Sync err) >>= fun _ -> Lwt.return (Ok ())
 
 open Cmdliner
 
@@ -225,8 +176,8 @@ end
 let setup_log =
   Term.(const setup_logs $ Fmt_cli.style_renderer () $ Logs_cli.level () $ Flag.output)
 
-let main progress references directory repository (quiet, ppf) =
-  match Lwt_main.run (main ppf (not quiet && progress) references directory repository) with
+let main _ references directory repository _ =
+  match Lwt_main.run (main references directory repository) with
   | Ok () -> `Ok ()
   | Error (#error as err) -> `Error (false, Fmt.strf "%a" pp_error err)