From 552a9821c4814471cefdb85a2cf59d9c25837d09 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 00:03:07 +0100 Subject: [PATCH 01/21] Do not send duplicate 'wants' --- lib/sync.ml | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/lib/sync.ml b/lib/sync.ml index 016e41ada..6f40b7df8 100644 --- a/lib/sync.ml +++ b/lib/sync.ml @@ -513,6 +513,7 @@ module Make (IO: IO) (Store: Store.S) = struct | None -> acc | Some x -> x::acc ) [] l + |> List.rev let filter_wants l = filter (function Want (x,y) -> Some (x,y) | _ -> None) l @@ -579,7 +580,7 @@ module Make (IO: IO) (Store: Store.S) = struct (* additional-want *) let msg = Printf.sprintf "want %s\n" (SHA.to_hex id) in if i <> 0 && c <> [] then - Log.warn "'additional-want' should have empty capabilities"; + Log.warn "additional-want: ignoring %s." (Capabilities.to_string c); PacketLine.output_line oc msg ) (filter_wants t) >>= fun () -> @@ -630,7 +631,12 @@ module Make (IO: IO) (Store: Store.S) = struct the new shallow state. *) let phase1 (ic, oc) ?deepen ~capabilities ~shallows ~wants = Log.debug "Upload.phase1"; - let wants = List.map (fun id -> Want (id, capabilities)) wants in + let wants = + let want id = Want (id, []) in + match wants with + | [] -> [] + | h::t -> Want (h, capabilities) :: List.map want t + in let shallows = List.map (fun id -> Shallow id) shallows in let deepen = match deepen with | None -> [] @@ -922,8 +928,13 @@ module Make (IO: IO) (Store: Store.S) = struct | _ -> [] in let wants = - SHA.of_commit head :: - Reference.Map.fold (fun _ s acc -> SHA.of_commit s::acc) references [] + let refs = + Reference.Map.fold (fun _ s acc -> + if SHA.Commit.equal s head then acc + else SHA.Set.add (SHA.of_commit s) acc + ) references SHA.Set.empty + in + SHA.of_commit head :: SHA.Set.elements refs in Log.debug "PHASE1"; Upload_request.phase1 (ic, oc) ?deepen ~capabilities From 9b8881c9394ed332fec25358db3e49e3f28cc714 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 11:34:43 +0100 Subject: [PATCH 02/21] Code style changes in Git.SHA --- lib/SHA.ml | 100 ++++++++++++++++++----------------------------------- 1 file changed, 33 insertions(+), 67 deletions(-) diff --git a/lib/SHA.ml b/lib/SHA.ml index 77528037c..991086e40 100644 --- a/lib/SHA.ml +++ b/lib/SHA.ml @@ -35,51 +35,37 @@ module type S = sig module Map: Misc.Map with type key = t end -type sha_t = { raw : string; - padded : bool; (* for hex of odd length *) - } +type sha_t = { + raw : string; + padded: bool; (* for hex of odd length *) +} exception Ambiguous let get_upper c = (Char.code c) land 0xf0 let sha_compare x y = - (*Log.debugf "sha_compare: %s vs %s" (sha_to_string x) (sha_to_string y);*) let nx = String.length x.raw in let ny = String.length y.raw in - let res = - if nx = ny && not x.padded && not y.padded then - String.compare x.raw y.raw - else begin - let len = min nx ny in - let rec scan i = - if i = len then - raise Ambiguous - else - if (x.padded && y.padded) || i < len then - let x0 = x.raw.[i] in - let y0 = y.raw.[i] in - if x0 < y0 then - -1 - else if x0 > y0 then - 1 - else - scan (i + 1) - else - let x0 = get_upper x.raw.[i] in - let y0 = get_upper y.raw.[i] in - if x0 < y0 then - -1 - else if x0 > y0 then - 1 - else - raise Ambiguous - in - scan 0 - end - in - (*Log.debugf "sha_compare: result=%d" res;*) - res + if nx = ny && not x.padded && not y.padded then String.compare x.raw y.raw + else + let len = min nx ny in + let rec scan i = + if i = len then raise Ambiguous + else if (x.padded && y.padded) || i < len then + let x0 = x.raw.[i] in + let y0 = y.raw.[i] in + if x0 < y0 then -1 + else if x0 > y0 then 1 + else scan (i + 1) + else + let x0 = get_upper x.raw.[i] in + let y0 = get_upper y.raw.[i] in + if x0 < y0 then -1 + else if x0 > y0 then 1 + else raise Ambiguous + in + scan 0 module SHA1_String = struct @@ -87,10 +73,7 @@ module SHA1_String = struct let length x = (* 0 <= length <= 40 *) let n = (String.length x.raw) * 2 in - if x.padded then - n - 1 - else - n + if x.padded then n - 1 else n let is_short x = (length x) < 40 @@ -103,26 +86,16 @@ module SHA1_String = struct let is_prefix p x = let np = length p in let nx = length x in - if np > nx then - false - else if np = nx then - equal p x + if np > nx then false + else if np = nx then equal p x else let n = - if p.padded then - (String.length p.raw) - 1 - else - String.length p.raw + if p.padded then String.length p.raw - 1 + else String.length p.raw in try - for i = 0 to n - 1 do - if p.raw.[i] <> x.raw.[i] then - raise Exit - done; - if p.padded then - (get_upper p.raw.[n]) = (get_upper x.raw.[n]) - else - true + for i = 0 to n - 1 do if p.raw.[i] <> x.raw.[i] then raise Exit done; + if p.padded then get_upper p.raw.[n] = get_upper x.raw.[n] else true with Exit -> false @@ -153,22 +126,15 @@ module SHA1_String = struct let of_hex h = let len = String.length h in let to_be_padded = (len mod 2) = 1 in - let h' = - if to_be_padded then - h ^ "0" - else - h - in - { raw = Hex.to_string (`Hex h'); - padded = to_be_padded; - } + let h' = if to_be_padded then h ^ "0" else h in + { raw = Hex.to_string (`Hex h'); padded = to_be_padded; } let zero = of_hex (String.make 40 '0') let pretty = to_hex - let pp_hum ppf t = Format.fprintf ppf "%s" (pretty t) + let pp ppf t = Format.fprintf ppf "%s" (pretty t) let input buf = { raw=Mstruct.get_string buf 20; padded=false; } From 8f2718c8bca0c0e5ad476256c2278014979df1db Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 11:36:08 +0100 Subject: [PATCH 03/21] Rename pp_hum into pp --- lib/blob.ml | 2 +- lib/commit.ml | 16 ++++++++-------- lib/index.ml | 22 +++++++++++----------- lib/index.mli | 8 ++++---- lib/object.mli | 2 +- lib/object_type.ml | 2 +- lib/pack.ml | 16 ++++++++-------- lib/pack_index.ml | 8 ++++---- lib/packed_refs.ml | 4 ++-- lib/packed_value.ml | 31 ++++++++++++++++--------------- lib/packed_value.mli | 4 ++-- lib/reference.ml | 2 +- lib/tag.ml | 8 ++++---- lib/top/git_top.ml | 39 ++++++++++++++++++++------------------- lib/tree.ml | 10 +++++----- lib/user.ml | 4 ++-- lib/value.ml | 12 ++++++------ 17 files changed, 96 insertions(+), 94 deletions(-) diff --git a/lib/blob.ml b/lib/blob.ml index d4be18550..43d56f861 100644 --- a/lib/blob.ml +++ b/lib/blob.ml @@ -30,7 +30,7 @@ let pretty t = (String.escaped (String.sub t 0 70)) (String.length t) -let pp_hum ppf t = Format.fprintf ppf "%s" (pretty t) +let pp ppf t = Format.fprintf ppf "%s" (pretty t) let input buf = Mstruct.get_string buf (Mstruct.length buf) diff --git a/lib/commit.ml b/lib/commit.ml index ca32bae9f..5aeab6282 100644 --- a/lib/commit.ml +++ b/lib/commit.ml @@ -30,12 +30,12 @@ let compare = compare let equal = (=) -let pp_hum_parents ppf parents = +let pp_parents ppf parents = List.iter (fun t -> - Format.fprintf ppf "\"%a\";@ " SHA.Commit.pp_hum t + Format.fprintf ppf "\"%a\";@ " SHA.Commit.pp t ) parents -let pp_hum ppf t = +let pp ppf t = Format.fprintf ppf "{@[\ tree = \"%a\";@ \ @@ -43,13 +43,13 @@ let pp_hum ppf t = author = %a;@ \ committer = %a;@.\ message = %S@]}" - SHA.Tree.pp_hum t.tree - pp_hum_parents t.parents - User.pp_hum t.author - User.pp_hum t.committer + SHA.Tree.pp t.tree + pp_parents t.parents + User.pp t.author + User.pp t.committer (String.trim t.message) -let pretty = Misc.pretty pp_hum +let pretty = Misc.pretty pp let add_parent buf parent = Buffer.add_string buf "parent "; diff --git a/lib/index.ml b/lib/index.ml index 024c45f42..f5fcbd721 100644 --- a/lib/index.ml +++ b/lib/index.ml @@ -34,7 +34,7 @@ let pretty_mode = function | `Link -> "link" | `Gitlink -> "gitlink" -let pp_hum_mode ppf t = +let pp_mode ppf t = Format.fprintf ppf "%s" (pretty_mode t) type stat_info = { @@ -48,7 +48,7 @@ type stat_info = { size : int32; } -let pp_hum_stats ppf t = +let pp_stats ppf t = Format.fprintf ppf "{@[\ ctime = (%ld, %ld);@ \ @@ -63,7 +63,7 @@ let pp_hum_stats ppf t = t.mtime.lsb32 t.mtime.nsec t.dev t.inode t.uid t.gid - t.size pp_hum_mode t.mode + t.size pp_mode t.mode type entry = { stats : stat_info; @@ -80,7 +80,7 @@ let compare_entries e1 e2 = | 0 -> compare e2.id e1.id | i -> i -let pp_hum_entry ppf t = +let pp_entry ppf t = Format.fprintf ppf "{@[\ name = %S@ \ @@ -88,8 +88,8 @@ let pp_hum_entry ppf t = stats =@ %a;@ \ stage = %d;@]}" t.name - SHA.Blob.pp_hum t.id - pp_hum_stats t.stats + SHA.Blob.pp t.id + pp_stats t.stats t.stage type extension_kind = @@ -131,10 +131,10 @@ let compare = compare let equal = (=) -let pp_hum ppf t = +let pp ppf t = Format.fprintf ppf "@["; List.iter (fun e -> - pp_hum_entry ppf e; + pp_entry ppf e; Format.fprintf ppf "@."; ) t.entries; Format.fprintf ppf "@]" @@ -142,10 +142,10 @@ let pp_hum ppf t = let pretty t = let buf = Buffer.create 1024 in let ppf = Format.formatter_of_buffer buf in - pp_hum ppf t; + pp ppf t; Buffer.contents buf -let pp_hum ppf t = Format.fprintf ppf "%s" (pretty t) +let pp ppf t = Format.fprintf ppf "%s" (pretty t) let input_time buf = let lsb32 = Mstruct.get_be_uint32 buf in @@ -241,7 +241,7 @@ let add_entry buf t = ); Buffer.add_string buf (Cstruct.to_string cstr) -let pp_hum_extension ppf e = +let pp_extension ppf e = Format.fprintf ppf "@[kind:%s@ size:%d]" (string_of_extension_kind e.kind) (String.length e.payload) diff --git a/lib/index.mli b/lib/index.mli index 347c3ed74..9f6656b58 100644 --- a/lib/index.mli +++ b/lib/index.mli @@ -34,7 +34,7 @@ type mode = | `Gitlink ] (** Permission for files in the index file. *) -val pp_hum_mode: Format.formatter -> mode -> unit +val pp_mode: Format.formatter -> mode -> unit (** Pretty print file modes. *) type stat_info = { @@ -60,7 +60,7 @@ type stat_info = { have no meaning to Git, besides exact match, except for the [mode] and [size] fields. *) -val pp_hum_stats: Format.formatter -> stat_info -> unit +val pp_stats: Format.formatter -> stat_info -> unit (** Pretty-print file stats. *) type entry = { @@ -70,7 +70,7 @@ type entry = { name : string; } -val pp_hum_entry: Format.formatter -> entry -> unit +val pp_entry: Format.formatter -> entry -> unit (** Human-readable representation of an index entry. *) type extension_kind = @@ -84,7 +84,7 @@ type extension = { payload: string; } -val pp_hum_extension: Format.formatter -> extension -> unit +val pp_extension: Format.formatter -> extension -> unit (** Human-readable representation of the extension. *) type t = private { diff --git a/lib/object.mli b/lib/object.mli index fbf0821fb..d07de3c43 100644 --- a/lib/object.mli +++ b/lib/object.mli @@ -33,7 +33,7 @@ module type S = sig val pretty: t -> string (** Human readable represenation of the object. *) - val pp_hum: Format.formatter -> t -> unit + val pp: Format.formatter -> t -> unit (** Same as {!pretty} but using a generic formatter. *) val input: Mstruct.t -> t diff --git a/lib/object_type.ml b/lib/object_type.ml index 1e75c28d4..0596af1b6 100644 --- a/lib/object_type.ml +++ b/lib/object_type.ml @@ -33,7 +33,7 @@ let to_string = function | Tree -> "tree" let pretty = to_string -let pp_hum ppf t = Format.fprintf ppf "%s" (pretty t) +let pp ppf t = Format.fprintf ppf "%s" (pretty t) let add buf ?level:_ t = Buffer.add_string buf (to_string t) diff --git a/lib/pack.ml b/lib/pack.ml index 5771fda23..61eb03290 100644 --- a/lib/pack.ml +++ b/lib/pack.ml @@ -47,13 +47,13 @@ module Raw = struct && SHA.equal t1.checksum t2.checksum && t1.values = t2.values - let pp_hum ppf t = - Format.fprintf ppf "%a@." SHA.pp_hum t.checksum; + let pp ppf t = + Format.fprintf ppf "%a@." SHA.pp t.checksum; List.iter (fun (offset, _, p) -> - Format.fprintf ppf "offset: %d@,%a" offset Packed_value.pp_hum p + Format.fprintf ppf "offset: %d@,%a" offset Packed_value.pp p ) t.values - let pretty = Misc.pretty pp_hum + let pretty = Misc.pretty pp let input_header buf = let header = Mstruct.get_string buf 4 in @@ -244,16 +244,16 @@ let compare = compare let equal = (=) -let pp_hum ppf t = +let pp ppf t = Format.fprintf ppf "@["; List.iter (fun (sha1, p) -> Format.fprintf ppf "@[%a@,%a@;@]" - SHA.pp_hum sha1 - Packed_value.PIC.pp_hum p + SHA.pp sha1 + Packed_value.PIC.pp p ) t; Format.fprintf ppf "@]" -let pretty = Misc.pretty pp_hum +let pretty = Misc.pretty pp let input ~read buf ~index = Log.debug "input"; diff --git a/lib/pack_index.ml b/lib/pack_index.ml index 247eec546..df6532e7e 100644 --- a/lib/pack_index.ml +++ b/lib/pack_index.ml @@ -50,8 +50,8 @@ module Raw = struct pack_checksum; } - let pp_hum ppf t = - Format.fprintf ppf "@[pack-checksum: %a@ " SHA.pp_hum t.pack_checksum; + let pp ppf t = + Format.fprintf ppf "@[pack-checksum: %a@ " SHA.pp t.pack_checksum; let l = ref [] in let offsets = SHA.Map.to_alist t.offsets in let crcs = SHA.Map.to_alist t.crcs in @@ -61,11 +61,11 @@ module Raw = struct ) offsets crcs; let l = List.sort (fun (_,o1,_) (_,o2,_) -> Pervasives.compare o1 o2) !l in List.iter (fun (sha1, offset, crc) -> - Format.fprintf ppf "@[%a@ off:%d@ crc:%ld@]" SHA.pp_hum sha1 offset crc + Format.fprintf ppf "@[%a@ off:%d@ crc:%ld@]" SHA.pp sha1 offset crc ) l; Format.fprintf ppf "@]" - let pretty = Misc.pretty pp_hum + let pretty = Misc.pretty pp let lengths { offsets; _ } = Log.debug "lengths"; diff --git a/lib/packed_refs.ml b/lib/packed_refs.ml index 1f83edcd4..5c717e448 100644 --- a/lib/packed_refs.ml +++ b/lib/packed_refs.ml @@ -48,8 +48,8 @@ let add buf ?level:_ t = let ppf = Format.formatter_of_buffer buf in List.iter (to_line ppf) t -let pp_hum ppf t = List.iter (to_line ppf) t -let pretty = Misc.pretty pp_hum +let pp ppf t = List.iter (to_line ppf) t +let pretty = Misc.pretty pp let input buf = let rec aux acc = diff --git a/lib/packed_value.ml b/lib/packed_value.ml index 05857ef2c..2af572488 100644 --- a/lib/packed_value.ml +++ b/lib/packed_value.ml @@ -24,20 +24,20 @@ type copy = { length: int; } -let pp_hum_copy ppf t = +let pp_copy ppf t = Format.fprintf ppf "@[off:%d@ len:%d@]" t.offset t.length type hunk = | Insert of string | Copy of copy -let pp_hum_hunk ppf = function +let pp_hunk ppf = function | Insert str -> Format.fprintf ppf "@[INSERT %S@]" str - | Copy copy -> Format.fprintf ppf "@[COPY %a@]" pp_hum_copy copy + | Copy copy -> Format.fprintf ppf "@[COPY %a@]" pp_copy copy -let pp_hum_hunks ppf l = +let pp_hunks ppf l = Format.fprintf ppf "@["; - List.iter (Format.fprintf ppf "%a@ " pp_hum_hunk) l; + List.iter (Format.fprintf ppf "%a@ " pp_hunk) l; Format.fprintf ppf "@]" type 'a delta = { @@ -47,7 +47,7 @@ type 'a delta = { hunks: hunk list; } -let pp_hum_delta ppf d = +let pp_delta ppf d = Format.fprintf ppf "@[\ source-length: %d@ \ @@ -55,7 +55,7 @@ let pp_hum_delta ppf d = %a@]" d.source_length d.result_length - pp_hum_hunks d.hunks + pp_hunks d.hunks type t = | Raw_value of string @@ -66,12 +66,12 @@ let hash = Hashtbl.hash let equal = (=) let compare = compare -let pp_hum ppf = function +let pp ppf = function | Raw_value s -> Format.fprintf ppf "%S@." s | Ref_delta d -> Format.fprintf ppf "@[source: %s@ %a@]" - (SHA.to_hex d.source) pp_hum_delta d + (SHA.to_hex d.source) pp_delta d | Off_delta d -> Format.fprintf ppf "@[source:%d@ %a@]" - d.source pp_hum_delta d + d.source pp_delta d let result_length = function | Ref_delta { result_length; _ } @@ -346,8 +346,9 @@ module Make (M: sig val version: int end) = struct let buf = Misc.with_buffer (fun buf -> add buf t) in Misc.crc32 buf - let pp_hum = pp_hum - let pretty = Misc.pretty pp_hum + let pp = pp + + let pretty = Misc.pretty pp end @@ -368,10 +369,10 @@ module PIC = struct | Raw _ -> "RAW" | Link d -> sprintf "link(%s)" (SHA.to_hex d.source.sha1) - let pp_hum ppf { kind; sha1 } = - Format.fprintf ppf "@[%a: %s@]" SHA.pp_hum sha1 (pretty_kind kind) + let pp ppf { kind; sha1 } = + Format.fprintf ppf "@[%a: %s@]" SHA.pp sha1 (pretty_kind kind) - let pretty = Misc.pretty pp_hum + let pretty = Misc.pretty pp let rec unpack pic = match Value.Cache.find_inflated pic.sha1 with diff --git a/lib/packed_value.mli b/lib/packed_value.mli index 826e51a79..c0060ec2d 100644 --- a/lib/packed_value.mli +++ b/lib/packed_value.mli @@ -42,7 +42,7 @@ type t = | Off_delta of int delta (** Packed values. *) -val pp_hum: Format.formatter -> t -> unit +val pp: Format.formatter -> t -> unit (** Human readable representation of a packed value. *) module V2: sig @@ -111,7 +111,7 @@ module PIC: sig sha1: SHA.t; } - val pp_hum: Format.formatter -> t -> unit + val pp: Format.formatter -> t -> unit (** Human readable representation. *) val pretty: t -> string diff --git a/lib/reference.ml b/lib/reference.ml index 7e5ae1c3d..cdba48360 100644 --- a/lib/reference.ml +++ b/lib/reference.ml @@ -31,7 +31,7 @@ let input _buf = let to_raw x = x let of_raw x = x let pretty x = String.escaped x -let pp_hum ppf x = Format.fprintf ppf "%s" (pretty x) +let pp ppf x = Format.fprintf ppf "%s" (pretty x) module Map = Misc.Map(Misc.S) diff --git a/lib/tag.ml b/lib/tag.ml index 174c96d59..8faf8918d 100644 --- a/lib/tag.ml +++ b/lib/tag.ml @@ -28,20 +28,20 @@ let hash = Hashtbl.hash let equal = (=) let compare = compare -let pp_hum ppf t = +let pp ppf t = Format.fprintf ppf "@[object: %a@ \ type : %s@ \ tag : %S@ \ tagger: %a@.\ %s@]" - SHA.pp_hum t.sha1 + SHA.pp t.sha1 (Object_type.to_string t.typ) t.tag - User.pp_hum t.tagger + User.pp t.tagger (String.trim t.message) -let pretty = Misc.pretty pp_hum +let pretty = Misc.pretty pp let add_key_value buf k v = Buffer.add_string buf k; diff --git a/lib/top/git_top.ml b/lib/top/git_top.ml index 074c4f426..3e5a59603 100644 --- a/lib/top/git_top.ml +++ b/lib/top/git_top.ml @@ -15,26 +15,27 @@ *) let printers = [ - "Git.SHA.pp_hum"; - "Git.SHA.Blob.pp_hum"; - "Git.SHA.Tree.pp_hum"; - "Git.SHA.Commit.pp_hum"; - "Git.Blob.pp_hum"; - "Git.Tree.pp_hum"; - "Git.Commit.pp_hum"; - "Git.Value.pp_hum"; - "Git.Index.pp_hum"; - "Git.Index.pp_hum_mode"; - "Git.Index.pp_hum_stats"; - "Git.Index.pp_hum_entry"; - "Git.Object_type.pp_hum"; - "Git.Pack.pp_hum"; + "Git.SHA.pp"; + "Git.SHA.Blob.pp"; + "Git.SHA.Tree.pp"; + "Git.SHA.Commit.pp"; + "Git.Blob.pp"; + "Git.Tree.pp"; + "Git.Commit.pp"; + "Git.Value.pp"; + "Git.Index.pp"; + "Git.Index.pp_mode"; + "Git.Index.pp_stats"; + "Git.Index.pp_entry"; + "Git.Object_type.pp"; + "Git.Pack.pp"; (* "Git.Pack_index.pp_hum"; *) - "Git.Packed_value.pp_hum"; - "Git.Packed_refs.pp_hum"; - "Git.Reference.pp_hum"; - "Git.Tag.pp_hum"; - "Git.User.pp_hum"; + "Git.Packed_value.pp"; + "Git.Packed_refs.pp"; + "Git.Reference.pp"; + "Git.Reference.pp_head_contents"; + "Git.Tag.pp"; + "Git.User.pp"; ] let eval_string diff --git a/lib/tree.ml b/lib/tree.ml index 38afb05e0..6527c9a54 100644 --- a/lib/tree.ml +++ b/lib/tree.ml @@ -43,18 +43,18 @@ let pretty_perm = function | `Dir -> "dir" | `Commit -> "commit" -let pp_hum_entry ppf e = +let pp_entry ppf e = Format.fprintf ppf "{@[perm = %s;@ node = \"%a\";@ name = %S;@]}" (pretty_perm e.perm) - SHA.pp_hum e.node + SHA.pp e.node e.name -let pp_hum ppf t = +let pp ppf t = Format.fprintf ppf "[@,"; - List.iter (Format.fprintf ppf "%a;@ " pp_hum_entry) t; + List.iter (Format.fprintf ppf "%a;@ " pp_entry) t; Format.fprintf ppf "@,@]]" -let pretty = Misc.pretty pp_hum +let pretty = Misc.pretty pp let perm_of_string buf = function | "44" diff --git a/lib/user.ml b/lib/user.ml index 6cc690a6a..8b09194af 100644 --- a/lib/user.ml +++ b/lib/user.ml @@ -59,11 +59,11 @@ let hash = Hashtbl.hash let equal = (=) let compare = compare -let pp_hum ppf t = +let pp ppf t = Format.fprintf ppf "{@[name=\"%s\";@ email=\"%s\";@ date=%a@]}" t.name t.email pp_date t.date -let pretty = Misc.pretty pp_hum +let pretty = Misc.pretty pp (* XXX needs to escape name/email/date *) let add buf ?level:_ t = diff --git a/lib/value.ml b/lib/value.ml index 887cdd267..8b3fd3a14 100644 --- a/lib/value.ml +++ b/lib/value.ml @@ -26,13 +26,13 @@ let equal = (=) let hash = Hashtbl.hash let compare = compare -let pp_hum ppf = function - | Blob b -> Format.fprintf ppf "@[Blob@ %a@]" Blob.pp_hum b - | Commit c -> Format.fprintf ppf "@[Commit@ %a@]" Commit.pp_hum c - | Tag t -> Format.fprintf ppf "@[Tag@ %a@]" Tag.pp_hum t - | Tree t -> Format.fprintf ppf "@[Tree@ %a@]" Tree.pp_hum t +let pp ppf = function + | Blob b -> Format.fprintf ppf "@[Blob@ %a@]" Blob.pp b + | Commit c -> Format.fprintf ppf "@[Commit@ %a@]" Commit.pp c + | Tag t -> Format.fprintf ppf "@[Tag@ %a@]" Tag.pp t + | Tree t -> Format.fprintf ppf "@[Tree@ %a@]" Tree.pp t -let pretty t = Misc.pretty pp_hum t +let pretty t = Misc.pretty pp t let commit c = Commit c let blob b = Blob b From c2a0ee1ee54b5866ba88e73cad57f062a47863ea Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 11:36:26 +0100 Subject: [PATCH 04/21] Add functions to work with Git.Reference.head_contents --- lib/reference.ml | 9 +++++++++ lib/reference.mli | 6 ++++++ 2 files changed, 15 insertions(+) diff --git a/lib/reference.ml b/lib/reference.ml index cdba48360..14fc83f91 100644 --- a/lib/reference.ml +++ b/lib/reference.ml @@ -48,6 +48,15 @@ type head_contents = | SHA of SHA.Commit.t | Ref of string +let pp_head_contents ppf = function + | SHA x -> Format.fprintf ppf "SHA %a" SHA.Commit.pp x + | Ref x -> Format.pp_print_string ppf x + +let equal_head_contents x y = match x, y with + | SHA x, SHA y -> SHA.Commit.equal x y + | Ref x, Ref y -> String.compare x y = 0 + | _ -> false + let is_head x = String.compare head x = 0 diff --git a/lib/reference.mli b/lib/reference.mli index bf473dbd1..89f3d3035 100644 --- a/lib/reference.mli +++ b/lib/reference.mli @@ -43,5 +43,11 @@ val head_contents: SHA.Commit.t Map.t -> SHA.Commit.t -> head_contents representation of the SHA or something like {i ref: } if the SHA has already a reference pointing to it. *) +val pp_head_contents: Format.formatter -> head_contents -> unit +(** Pretty-print head contents. *) + +val equal_head_contents: head_contents -> head_contents -> bool +(** Compare head contents. *) + val is_valid: t -> bool (** Check if a reference can be stored on disk properly. *) From a06701d89f7095f7a3e8de67987ae8e523b360e9 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 14:16:48 +0100 Subject: [PATCH 05/21] Add a failing test for reading/writing .git/HEAD --- lib_test/test_common.ml | 8 ++++++++ lib_test/test_store.ml | 10 ++++++++++ 2 files changed, 18 insertions(+) diff --git a/lib_test/test_common.ml b/lib_test/test_common.ml index 3dd5b464d..113cfa6f4 100644 --- a/lib_test/test_common.ml +++ b/lib_test/test_common.ml @@ -116,3 +116,11 @@ let rec_files dir = files dir >>= fun fs -> Lwt_list.fold_left_s aux (fs @ accu) ds in aux [] dir + +let head_contents = + let module M = struct + type t = Git.Reference.head_contents + let equal = Git.Reference.equal_head_contents + let pp = Git.Reference.pp_head_contents + end + in (module M: Alcotest.TESTABLE with type t = M.t) diff --git a/lib_test/test_store.ml b/lib_test/test_store.ml index 672e2e843..c0b0d313b 100644 --- a/lib_test/test_store.ml +++ b/lib_test/test_store.ml @@ -319,6 +319,16 @@ module Make (Store: Store.S) = struct Store.references t >>= fun rs -> assert_refs_equal "refs" [r1; r2] rs; + let commit = + Git.Reference.SHA ( + SHA.Commit.of_hex "21930ccb5f7b97e80a068371cb554b1f5ce8e55a" + ) in + Store.write_head t ( commit) >>= fun () -> + Store.read_head t >>= fun head -> + let () = match head with + | None -> Alcotest.fail "no head" + | Some h -> Alcotest.(check head_contents) "head" commit h + in Lwt.return_unit in run x test From 9154dd11fc1f98546da3a1a89441671dda03ee9b Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 14:17:46 +0100 Subject: [PATCH 06/21] Use Stringext.{cut,split} instead of buggy variants This fixes the isssue with reading/writing SHA1 in .git/HEAD --- lib/FS.ml | 2 +- lib/SHA.ml | 36 +++++++++--------------------------- lib/gri.ml | 4 ++-- lib/misc.ml | 29 +++-------------------------- lib/misc.mli | 4 ++-- lib/packed_refs.ml | 2 +- lib/sync.ml | 24 ++++++++++++------------ 7 files changed, 30 insertions(+), 71 deletions(-) diff --git a/lib/FS.ml b/lib/FS.ml index eb2fbe4ad..f3fb1095c 100644 --- a/lib/FS.ml +++ b/lib/FS.ml @@ -501,7 +501,7 @@ module Make (IO: IO) = struct change. *) IO.read_file file >>= fun str -> let str = Cstruct.to_string str in - let contents = match Misc.string_split ~on:' ' str with + let contents = match Stringext.split ~on:' ' str with | [sha1] -> Reference.SHA (SHA.Commit.of_hex sha1) | [_;ref] -> Reference.Ref (Reference.of_raw ref) | _ -> diff --git a/lib/SHA.ml b/lib/SHA.ml index 991086e40..7505549cf 100644 --- a/lib/SHA.ml +++ b/lib/SHA.ml @@ -75,12 +75,9 @@ module SHA1_String = struct let n = (String.length x.raw) * 2 in if x.padded then n - 1 else n - let is_short x = (length x) < 40 - - let equal x y = (x=y) - + let is_short x = length x < 40 + let equal x y = x.padded = y.padded && String.compare x.raw y.raw = 0 let hash x = Hashtbl.hash x.raw - let compare = sha_compare let is_prefix p x = @@ -100,9 +97,7 @@ module SHA1_String = struct Exit -> false let lt x y = compare x y < 0 - let to_raw x = x.raw - let of_raw x = { raw=x; padded=false; } let of_string str = @@ -118,10 +113,8 @@ module SHA1_String = struct let to_hex t = let `Hex h = Hex.of_string t.raw in - if t.padded then - String.sub h 0 ((String.length h) - 1) - else - h + if t.padded then String.sub h 0 ((String.length h) - 1) + else h let of_hex h = let len = String.length h in @@ -129,24 +122,13 @@ module SHA1_String = struct let h' = if to_be_padded then h ^ "0" else h in { raw = Hex.to_string (`Hex h'); padded = to_be_padded; } - let zero = - of_hex (String.make 40 '0') - + let zero = of_hex (String.make 40 '0') let pretty = to_hex - let pp ppf t = Format.fprintf ppf "%s" (pretty t) - - let input buf = - { raw=Mstruct.get_string buf 20; padded=false; } - - let add buf ?level:_ t = - Buffer.add_string buf t.raw - - let input_hex buf = - of_hex (Mstruct.get_string buf (Mstruct.length buf)) - - let add_hex buf t = - Buffer.add_string buf (to_hex t) + let input buf = { raw=Mstruct.get_string buf 20; padded=false; } + let add buf ?level:_ t = Buffer.add_string buf t.raw + let input_hex buf = of_hex (Mstruct.get_string buf (Mstruct.length buf)) + let add_hex buf t = Buffer.add_string buf (to_hex t) module X = struct type t = sha_t diff --git a/lib/gri.ml b/lib/gri.ml index 07eaee571..3d1b5ffae 100644 --- a/lib/gri.ml +++ b/lib/gri.ml @@ -24,11 +24,11 @@ let of_string str = match Uri.host uri with | Some _ -> uri | None -> - match Misc.string_lsplit2 str ~on:':' with + match Stringext.cut str ~on:":" with | None -> uri | Some (host, path) -> let userinfo, host = - match Misc.string_lsplit2 host ~on:'@' with + match Stringext.cut host ~on:"@" with | None -> None , host | Some (a,b) -> Some a, b in let scheme = "git+ssh" in diff --git a/lib/misc.ml b/lib/misc.ml index 7980ca36e..102c35323 100644 --- a/lib/misc.ml +++ b/lib/misc.ml @@ -114,6 +114,9 @@ let lf = '\x0a' let lt = '<' let gt = '>' +let sp_str = String.make 1 sp +let nul_str = String.make 1 nul + let input_key_value buf ~key:expected input_value = let error actual = Mstruct.parse_error_buf buf "keys: [actual: %s] [expected: %s]" actual expected in @@ -234,32 +237,6 @@ end module IntMap = Map(I) -let string_split str ~on = - let len = String.length str in - let rec loop acc i = - if i < 0 then acc else ( - let j = - try String.rindex_from str i on - with Not_found -> -42 - in - match j with - | -42 -> String.sub str 0 i :: acc - | _ -> - let sub = String.sub str (j + 1) (i - j) in - loop (sub :: acc) (j - 1) - ) - in - loop [] (len - 1) - -let string_lsplit2 str ~on = - try - let j = String.index str on in - let x = String.sub str 0 j in - let y = String.sub str (j + 1) (String.length str - j - 1) in - Some (x, y) - with Not_found -> - None - let string_forall f s = let rec aux i = i = String.length s || (f s.[i] && aux (i+1)) in aux 0 diff --git a/lib/misc.mli b/lib/misc.mli index 8c3871790..309ec40e6 100644 --- a/lib/misc.mli +++ b/lib/misc.mli @@ -64,6 +64,8 @@ val nul: char val lf: char val lt: char val gt: char +val sp_str: string +val nul_str: string module type OrderedType = sig include Set.OrderedType @@ -94,8 +96,6 @@ module Map (X: OrderedType): Map with type key = X.t module IntMap: Map with type key = int -val string_split: string -> on:char -> string list -val string_lsplit2: string -> on:char -> (string * string) option val string_forall: (char -> bool) -> string -> bool val string_exists: (char -> bool) -> string -> bool val string_mem: char -> string -> bool diff --git a/lib/packed_refs.ml b/lib/packed_refs.ml index 5c717e448..92f0a1f44 100644 --- a/lib/packed_refs.ml +++ b/lib/packed_refs.ml @@ -27,7 +27,7 @@ let of_line line = else if line.[0] = '#' then let str = String.sub line 1 (String.length line - 1) in Some (`Comment str) - else match Misc.string_lsplit2 line ~on:' ' with + else match Stringext.cut line ~on:" " with | None -> None | Some (sha1, ref) -> let sha1 = SHA.Commit.of_hex sha1 in diff --git a/lib/sync.ml b/lib/sync.ml index 6f40b7df8..38926597e 100644 --- a/lib/sync.ml +++ b/lib/sync.ml @@ -204,7 +204,7 @@ module Make (IO: IO) (Store: Store.S) = struct | "report-status" -> `Report_status | "delete-refs" -> `Delete_refs | x -> - match Misc.string_lsplit2 x ~on:'=' with + match Stringext.cut x ~on:"=" with | Some ("agent", a) -> `Agent a | _ -> `Other x @@ -248,7 +248,7 @@ module Make (IO: IO) (Store: Store.S) = struct type t = Capability.t list let of_string str = - List.map Capability.of_string (Misc.string_split str ~on:Misc.sp) + List.map Capability.of_string (Stringext.split str ~on:Misc.sp) let to_string l = String.concat " " (List.map Capability.to_string l) @@ -408,7 +408,7 @@ module Make (IO: IO) (Store: Store.S) = struct PacketLine.input ic >>= function | None -> error "missing # header." | Some line -> - match Misc.string_lsplit2 line ~on:Misc.sp with + match Stringext.cut line ~on:Misc.sp_str with | Some ("#", service) -> Log.debug "skipping %s" service; begin PacketLine.input ic >>= function @@ -422,7 +422,7 @@ module Make (IO: IO) (Store: Store.S) = struct PacketLine.input ic >>= function | None -> Lwt.return acc | Some line -> - match Misc.string_lsplit2 line ~on:Misc.sp with + match Stringext.cut line ~on:Misc.sp_str with | Some ("ERR", err) -> error "ERROR: %s" err | Some (sha1, ref) -> let add sha1 ref = @@ -431,7 +431,7 @@ module Make (IO: IO) (Store: Store.S) = struct in if is_empty acc then ( (* Read the capabilities on the first line *) - match Misc.string_lsplit2 ref ~on:Misc.nul with + match Stringext.cut ref ~on:Misc.nul_str with | Some (ref, caps) -> let ref = Reference.of_raw ref in let references = add sha1 ref in @@ -475,9 +475,9 @@ module Make (IO: IO) (Store: Store.S) = struct | None | Some "NAK" -> Lwt.return Nak | Some s -> - match Misc.string_lsplit2 s ~on:Misc.sp with + match Stringext.cut s ~on:Misc.sp_str with | Some ("ACK", r) -> - begin match Misc.string_lsplit2 r ~on:Misc.sp with + begin match Stringext.cut r ~on:Misc.sp_str with | None -> Lwt.return (Ack (SHA.of_hex r)) | Some (id, s) -> Lwt.return (Ack_multi (SHA.of_hex id, status_of_string s)) @@ -538,7 +538,7 @@ module Make (IO: IO) (Store: Store.S) = struct PacketLine.input_raw ic >>= function | None -> Lwt.return (List.rev acc) | Some l -> - match Misc.string_lsplit2 l ~on:Misc.sp with + match Stringext.cut l ~on:Misc.sp_str with | None -> error "input upload" | Some (kind, s) -> match kind with @@ -554,7 +554,7 @@ module Make (IO: IO) (Store: Store.S) = struct aux (Deepen d :: acc) | "want" -> let aux id c = aux (Want (SHA.of_hex id, c) :: acc) in - begin match Misc.string_lsplit2 s ~on:Misc.sp with + begin match Stringext.cut s ~on:Misc.sp_str with | Some (id,c) -> aux id (Capabilities.of_string c) | None -> match acc with | Want (_,c)::_ -> aux s c @@ -819,7 +819,7 @@ module Make (IO: IO) (Store: Store.S) = struct PacketLine.input ic >>= function | None -> Lwt.fail (Failure "Report_status.input: empty") | Some line -> - begin match Misc.string_lsplit2 line ~on:Misc.sp with + begin match Stringext.cut line ~on:Misc.sp_str with | Some ("unpack", "ok") -> Lwt.return `Ok | Some ("unpack", err ) -> Lwt.return (`Error err) | _ -> Lwt.fail (Failure "Report_status.input: unpack-status") @@ -828,11 +828,11 @@ module Make (IO: IO) (Store: Store.S) = struct PacketLine.input ic >>= function | None -> Lwt.return acc | Some line -> - match Misc.string_lsplit2 line ~on:Misc.sp with + match Stringext.cut line ~on:Misc.sp_str with | Some ("ok", name) -> Lwt.return ((Reference.of_raw name, `Ok) :: acc) | Some ("ng", cont) -> - begin match Misc.string_lsplit2 cont ~on:Misc.sp with + begin match Stringext.cut cont ~on:Misc.sp_str with | None -> Lwt.fail (Failure "Report_status.input: command-fail") | Some (name, err) -> Lwt.return ((Reference.of_raw name, `Error err) :: acc) From 08f396ae313e20a9b9fba721f88f0ab80ce67537 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 14:14:01 +0100 Subject: [PATCH 07/21] Add a `--branch` option to `ogit clone` --- bin/ogit.ml | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/bin/ogit.ml b/bin/ogit.ml index b8f9ec814..858882614 100644 --- a/bin/ogit.ml +++ b/bin/ogit.ml @@ -386,6 +386,9 @@ let read_tree = { Term.(mk read $ backend $ commit) } +let reference_of_raw branch = + Reference.of_raw ("refs/heads/" ^ Reference.to_raw branch) + (* CLONE *) let clone = { name = "clone"; @@ -399,7 +402,14 @@ let clone = { Arg.(some int) None in let bare = mk_flag ["bare"] "Do not expand the filesystem." in - let clone (module S: Store.S) deepen bare unpack remote dir = + let branch = + mk_opt ["b"; "branch"] "BRANCH" + "Instead of pointing the newly created HEAD to the branch pointed to by \ + the cloned repository's HEAD, point to $(b, name) branch instead. In a \ + non-bare repository, this is the branch that will be checked out." + Arg.(some reference) None + in + let clone (module S: Store.S) deepen bare branch unpack remote dir = let dir = match dir with | Some d -> d | None -> @@ -419,8 +429,12 @@ let clone = { let module Sync = Sync.Make(S) in run begin S.create ~root:dir () >>= fun t -> + let head = match branch with + | None -> None + | Some b -> Some (Reference.Ref (reference_of_raw b)) + in printf "Cloning into '%s' ...\n%!" (Filename.basename (S.root t)); - Sync.clone t ?deepen ~unpack remote >>= fun r -> + Sync.clone t ?deepen ~unpack ?head remote >>= fun r -> if not bare then match r.Result.head with | None -> Lwt.return_unit | Some head -> @@ -430,7 +444,8 @@ let clone = { else Lwt.return_unit end in - Term.(mk clone $ backend $ depth $ bare $ unpack $ remote $ directory) + Term.(mk clone $ backend $ depth $ bare $ branch $ + unpack $ remote $ directory) } (* FETCH *) @@ -486,8 +501,7 @@ let push = { S.create () >>= fun t -> S.read_reference t branch >>= fun b -> let branch = match b with - | None -> Reference.of_raw - ("refs/heads/" ^ Reference.to_raw branch) + | None -> reference_of_raw branch | Some _ -> branch in Sync.push t ~branch remote >>= fun s -> printf "%s\n" (Result.pretty_push s); From 5aabac99bce3f9334ba3bcea10aa5109bc2e6d72 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 12:19:31 +0100 Subject: [PATCH 08/21] Add some failing clone tests --- lib_test/test_store.ml | 45 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 43 insertions(+), 2 deletions(-) diff --git a/lib_test/test_store.ml b/lib_test/test_store.ml index c0b0d313b..9c62778a7 100644 --- a/lib_test/test_store.ml +++ b/lib_test/test_store.ml @@ -432,7 +432,7 @@ module Make (Store: Store.S) = struct module Sync = Sync.Make(Store) - let test_remote x () = + let test_basic_remote x () = let test () = let gri = Gri.of_string "git://localhost/" in create () >>= fun t -> @@ -442,6 +442,46 @@ module Make (Store: Store.S) = struct in run x test + let head_contents = + let module M = struct + type t = Git.Reference.head_contents + let equal = Git.Reference.equal_head_contents + let pp = Git.Reference.pp_head_contents + end + in (module M: Alcotest.TESTABLE with type t = M.t) + + let test_clones x () = + let test () = + let gri = Gri.of_string "git://github.com/mirage/ocaml-git.git" in + Store.create ~root () >>= fun t -> + let clone head = + x.clean () >>= fun () -> + Sync.clone t ?head gri >>= fun _ -> + if Store.kind = `Disk then + let cmd = Printf.sprintf "cd %s && git fsck" @@ Store.root t in + Alcotest.(check int) "fsck" 0 (Sys.command cmd); + let e = match head with + | None -> Git.Reference.(Ref (of_raw "refs/heads/master")) + | Some h -> h + in + Store.read_head t >>= function + | None -> Alcotest.fail "empty clone!" + | Some h -> + Alcotest.(check head_contents) "correct head contents" e h; + Lwt.return_unit + else + Lwt.return_unit + in + let gh_pages = Git.Reference.of_raw "refs/heads/gh-pages" in + let commit = + Git.SHA.Commit.of_hex "21930ccb5f7b97e80a068371cb554b1f5ce8e55a" + in + clone None >>= fun () -> + clone (Some (Git.Reference.Ref gh_pages)) >>= fun () -> + clone (Some (Git.Reference.SHA commit)) + in + run x test + let test_leaks x () = let runs = try int_of_string (Sys.getenv "TESTRUNS") @@ -494,8 +534,9 @@ let suite (speed, x) = "Operations on references" , speed, T.test_refs x; "Operations on index" , speed, T.test_index x; "Operations on pack files" , speed, T.test_packs x; - "Remote operations" , `Slow, T.test_remote x; "Resource leaks" , `Slow, T.test_leaks x; + "Basic Remote operations" , `Slow, T.test_basic_remote x; + "Clones" , `Slow, T.test_clones x; ] let ops = [ From ecb2e2c0361a3cc42df6797f808e4efbdf11c992 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 13:58:22 +0100 Subject: [PATCH 09/21] Properly clean the in-memory test between test runs --- lib/FS.ml | 5 +++-- lib/FS.mli | 3 +++ lib/memory.ml | 12 ++++-------- lib/memory.mli | 7 +++++++ lib/store.mli | 3 --- lib_test/test_fs.ml | 2 +- lib_test/test_memory.ml | 5 ++++- lib_test/test_store.ml | 8 +++++--- 8 files changed, 27 insertions(+), 18 deletions(-) diff --git a/lib/FS.ml b/lib/FS.ml index f3fb1095c..7a4fb38ef 100644 --- a/lib/FS.ml +++ b/lib/FS.ml @@ -43,6 +43,7 @@ end module type S = sig include Store.S + val remove: t -> unit Lwt.t val create_file: t -> string -> Tree.perm -> Blob.t -> unit Lwt.t val entry_of_file: t -> Index.t -> string -> Tree.perm -> SHA.Blob.t -> Blob.t -> Index.entry option Lwt.t @@ -130,8 +131,8 @@ module Make (IO: IO) = struct end >>= fun root -> Lwt.return { root; level } - let clear t = - Log.info "clear %s" t.root; + let remove t = + Log.info "remove %s" t.root; IO.remove (sprintf "%s/.git" t.root) (* Loose objects *) diff --git a/lib/FS.mli b/lib/FS.mli index d38ad9f02..30c6fffb4 100644 --- a/lib/FS.mli +++ b/lib/FS.mli @@ -20,6 +20,9 @@ module type S = sig include Store.S + val remove: t -> unit Lwt.t + (** Remove all the contents of the store. *) + val create_file: t -> string -> Tree.perm -> Blob.t -> unit Lwt.t (** Create a file on the filesystem, with the given mode. *) diff --git a/lib/memory.ml b/lib/memory.ml index 71c02e52f..4938ec3f3 100644 --- a/lib/memory.ml +++ b/lib/memory.ml @@ -34,12 +34,12 @@ let root t = t.root let level t = t.level let stores = Hashtbl.create 1024 +let default_root = "root" +let clear ?(root=default_root) () = Hashtbl.remove stores root +let clear_all () = Hashtbl.reset stores -let create ?root ?(level=6) () = +let create ?(root=default_root) ?(level=6) () = if level < 0 || level > 9 then failwith "level should be between 0 and 9"; - let root = match root with - | None -> "root" - | Some r -> r in let t = try Hashtbl.find stores root with Not_found -> @@ -53,10 +53,6 @@ let create ?root ?(level=6) () = t in Lwt.return t -let clear t = - Hashtbl.remove stores t.root; - Lwt.return_unit - let write t value = let inflated = Misc.with_buffer (fun buf -> Value.add_inflated buf value) in let sha1 = SHA.of_string inflated in diff --git a/lib/memory.mli b/lib/memory.mli index f57f5fff9..b2c5eaf67 100644 --- a/lib/memory.mli +++ b/lib/memory.mli @@ -17,3 +17,10 @@ (** Store Git objects in memory. *) include Store.S + +val clear: ?root:string -> unit -> unit +(** Remove all the contents store in memory for the given root. Use + the default root if the optional argument is not provided. *) + +val clear_all: unit -> unit +(** Remove all the contents store in memory for all roots. *) diff --git a/lib/store.mli b/lib/store.mli index 1bd8fb44a..016629455 100644 --- a/lib/store.mli +++ b/lib/store.mli @@ -36,9 +36,6 @@ module type S = sig equivalent to level 6) requests a default compromise between speed and compression. *) - val clear: t -> unit Lwt.t - (** Remove all the contents of the Git store. *) - val dump: t -> unit Lwt.t (** Dump the store contents to stderr. *) diff --git a/lib_test/test_fs.ml b/lib_test/test_fs.ml index 6d7d8f10c..9e9095ebd 100644 --- a/lib_test/test_fs.ml +++ b/lib_test/test_fs.ml @@ -21,7 +21,7 @@ module M = Git_unix.FS let init () = M.create ~root:"test-db" () >>= fun t -> - M.clear t + M.remove t let suite = { diff --git a/lib_test/test_memory.ml b/lib_test/test_memory.ml index 9f3e5cd82..b4ba77fa9 100644 --- a/lib_test/test_memory.ml +++ b/lib_test/test_memory.ml @@ -15,10 +15,13 @@ *) open Test_store +open Lwt.Infix + +let init () = Git.Memory.clear_all (); Lwt.return_unit let suite = { name = "MEM"; - init = unit; + init = init; clean = unit; store = (module Git.Memory); } diff --git a/lib_test/test_store.ml b/lib_test/test_store.ml index 9c62778a7..62ccaf003 100644 --- a/lib_test/test_store.ml +++ b/lib_test/test_store.ml @@ -435,7 +435,9 @@ module Make (Store: Store.S) = struct let test_basic_remote x () = let test () = let gri = Gri.of_string "git://localhost/" in - create () >>= fun t -> + create () >>= fun t -> + Store.read_head t >>= fun head -> + Alcotest.(check (option head_contents)) "no head" None head; Sync.fetch t gri >>= fun _ -> Sync.push t gri ~branch:Reference.master >>= fun _ -> Lwt.return_unit @@ -455,7 +457,7 @@ module Make (Store: Store.S) = struct let gri = Gri.of_string "git://github.com/mirage/ocaml-git.git" in Store.create ~root () >>= fun t -> let clone head = - x.clean () >>= fun () -> + x.init () >>= fun () -> Sync.clone t ?head gri >>= fun _ -> if Store.kind = `Disk then let cmd = Printf.sprintf "cd %s && git fsck" @@ Store.root t in @@ -536,7 +538,7 @@ let suite (speed, x) = "Operations on pack files" , speed, T.test_packs x; "Resource leaks" , `Slow, T.test_leaks x; "Basic Remote operations" , `Slow, T.test_basic_remote x; - "Clones" , `Slow, T.test_clones x; + "Cloning ocaml-git.git" , `Slow, T.test_clones x; ] let ops = [ From ac308eeb15e4f7a309fd2d45bde111daf03a3eef Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 14:18:19 +0100 Subject: [PATCH 10/21] Fix Sync.clone and Sync.fetch when specifying a specific branch/SHA1 --- lib/sync.ml | 142 ++++++++++++++++++++++++++++++--------------------- lib/sync.mli | 3 +- 2 files changed, 86 insertions(+), 59 deletions(-) diff --git a/lib/sync.ml b/lib/sync.ml index 38926597e..b65d476b0 100644 --- a/lib/sync.ml +++ b/lib/sync.ml @@ -158,7 +158,7 @@ module Make (IO: IO) (Store: Store.S) = struct error "PacketLine.input: the payload doesn't have a trailing LF" let input_raw ic: t Lwt.t = - Log.debug "PacketLine.input"; + Log.debug "PacketLine.input_raw"; IO.read_exactly ic 4 >>= fun size -> match size with | "0000" -> @@ -177,6 +177,7 @@ module Make (IO: IO) (Store: Store.S) = struct let niet = Lwt.return (Some "") let input ic = + Log.debug "PacketLine.input"; input_raw ic >>= function | None -> Lwt.return_none | Some "" -> niet @@ -912,7 +913,7 @@ module Make (IO: IO) (Store: Store.S) = struct ) let fetch_pack_with_head t (ic, oc) op references head = - Log.debug "Sync.fetch_pack_with_head"; + Log.debug "Sync.fetch_pack_with_head head=%s" (SHA.Commit.pretty head); let deepen = match op with | Clone { c_deepen = d; _ } | Fetch { f_deepen = d; _ } -> d @@ -927,15 +928,7 @@ module Make (IO: IO) (Store: Store.S) = struct | Clone { c_capabilites = c; _ } -> c | _ -> [] in - let wants = - let refs = - Reference.Map.fold (fun _ s acc -> - if SHA.Commit.equal s head then acc - else SHA.Set.add (SHA.of_commit s) acc - ) references SHA.Set.empty - in - SHA.of_commit head :: SHA.Set.elements refs - in + let wants = [SHA.of_commit head] in Log.debug "PHASE1"; Upload_request.phase1 (ic, oc) ?deepen ~capabilities ~shallows ~wants @@ -980,8 +973,22 @@ module Make (IO: IO) (Store: Store.S) = struct (List.length sha1s); Lwt.return { Result.head = Some head; references; sha1s } - let fetch_pack ?ctx t gri op = - Log.debug "Sync.fetch_pack"; + let write_heads t (ref, sha1) = + if Reference.is_valid ref then + let raw_ref = Reference.to_raw ref in + let prefix = "refs/heads/" in + match Misc.string_chop_prefix ~prefix raw_ref with + | None -> Lwt.return_unit + | Some _ -> + Store.mem t (SHA.of_commit sha1) >>= function + | false -> Lwt.return_unit + | true -> Store.write_reference t ref sha1 + else + Lwt.return_unit + + (* Query the remote store for its references and its HEAD. *) + let with_listing ?ctx gri k = + Log.debug "Sync.with_listing"; let init = Init.upload_pack ~discover:true gri in match Init.host init with | None -> todo "local-clone" @@ -999,64 +1006,82 @@ module Make (IO: IO) (Store: Store.S) = struct acc refs ) Reference.Map.empty - (SHA.Commit.Map.to_alist (Listing.references listing)) in - let head = Listing.head listing in - match op with - | Ls -> Lwt.return { Result.head; references; sha1s = [] } - | Fetch _ - | Clone _ -> - begin match op with - | Ls | Fetch { f_update_tags = false; _ } -> Lwt.return_unit - | Clone _ | Fetch _ -> - try - let write_ref (ref, sha1) = - if Reference.is_valid ref then - Store.write_reference t ref sha1 - else Lwt.return_unit in - let references_no_head = - Reference.Map.remove Reference.head references - in - Lwt_list.iter_p write_ref - (Reference.Map.to_alist references_no_head) - >>= fun () -> - let sha1 = Reference.Map.find Reference.head references in - let contents = Reference.head_contents references sha1 in - match op with - | Clone _ -> Store.write_head t contents - | _ -> Lwt.return_unit - with Not_found -> - Lwt.return_unit - end >>= fun () -> - match head with - | None -> Lwt.return { Result.head; references; sha1s = [] } - | Some head -> - if protocol = `Smart_HTTP then - let init = Init.upload_pack ~discover:false gri in - let uri = Init.uri init in - let init = Init.to_string init in - IO.with_connection ?ctx uri ?init (fun (ic, oc) -> - fetch_pack_with_head t (ic, oc) op references head - ) - else - fetch_pack_with_head t (ic, oc) op references head + (SHA.Commit.Map.to_alist (Listing.references listing)) + in + let head_commit = Listing.head listing in + k (protocol, ic, oc) head_commit references ) + let err_invalid_branch gri br = + error "%s has no branch called %s" (Gri.to_string gri) (Reference.pretty br) + + let pretty_head_opt = function + | None -> "" + | Some x -> Misc.pretty Reference.pp_head_contents x + + let fetch_pack ?ctx ?head t gri op = + Log.debug "Sync.fetch_pack head=%s" (pretty_head_opt head); + with_listing ?ctx gri (fun (protocol, ic, oc) remote_head references -> + match op with + | Ls -> Lwt.return { Result.head = remote_head; references; sha1s = [] } + | Fetch _ + | Clone _ -> + let head = match head with + | None -> Reference.Ref Reference.master + | Some (Reference.SHA x) -> Reference.SHA x + | Some (Reference.Ref r) -> + if Reference.Map.mem r references then Reference.Ref r + else err_invalid_branch gri r + in + let want = match head with + | Reference.SHA x -> x + | Reference.Ref r -> Reference.Map.find r references + in + let sync () = + if protocol = `Smart_HTTP then + let init = Init.upload_pack ~discover:false gri in + let uri = Init.uri init in + let init = Init.to_string init in + IO.with_connection ?ctx uri ?init (fun (ic, oc) -> + fetch_pack_with_head t (ic, oc) op references want + ) + else + fetch_pack_with_head t (ic, oc) op references want + in + let update_refs () = match op with + | Ls -> assert false + | Fetch { f_update_tags = false; _ } -> Lwt.return_unit + | Clone _ | Fetch _ -> + (* populate .git/refs/heads/ with the discovered tags. *) + Reference.Map.to_alist references + |> Lwt_list.iter_p (write_heads t) + >>= fun () -> + match op with + | Clone _ -> Store.write_head t head (* update .git/HEAD *) + | _ -> Lwt.return_unit + in + sync () >>= fun r -> + update_refs () >|= fun () -> + r + ) + let ls ?ctx t gri = fetch_pack ?ctx t gri Ls >>= function { Result.references; _ } -> Lwt.return references let clone ?ctx t ?deepen ?(unpack=false) ?(capabilities=Capabilities.default) - gri = + ?head gri = let op = { c_deepen = deepen; c_unpack = unpack; c_capabilites = capabilities; } in - fetch_pack ?ctx t gri (Clone op) + fetch_pack ?ctx ?head t gri (Clone op) let fetch ?ctx t ?deepen ?(unpack=false) ?(capabilities=Capabilities.default) gri = - Store.list t >>= fun haves -> + Store.list t >>= fun haves -> + Store.read_head t >>= fun head -> (* XXX: Store.shallows t >>= fun shallows *) let shallows = [] in let op = { @@ -1067,7 +1092,7 @@ module Make (IO: IO) (Store: Store.S) = struct f_capabilites = capabilities; f_update_tags = false; } in - fetch_pack ?ctx t gri (Fetch op) + fetch_pack ?ctx ?head t gri (Fetch op) type t = Store.t @@ -1079,7 +1104,8 @@ module type S = sig val ls: ?ctx:ctx -> t -> Gri.t -> SHA.Commit.t Reference.Map.t Lwt.t val push: ?ctx:ctx -> t -> branch:Reference.t -> Gri.t -> Result.push Lwt.t val clone: ?ctx:ctx -> t -> ?deepen:int -> ?unpack:bool -> - ?capabilities:capability list -> Gri.t -> Result.fetch Lwt.t + ?capabilities:capability list -> ?head:Reference.head_contents -> + Gri.t -> Result.fetch Lwt.t val fetch: ?ctx:ctx -> t -> ?deepen:int -> ?unpack:bool -> ?capabilities:capability list -> Gri.t -> Result.fetch Lwt.t end diff --git a/lib/sync.mli b/lib/sync.mli index f3cda1695..5f241445d 100644 --- a/lib/sync.mli +++ b/lib/sync.mli @@ -78,7 +78,8 @@ module type S = sig (** Push a local branch to a remote store. *) val clone: ?ctx:ctx -> t -> ?deepen:int -> ?unpack:bool -> - ?capabilities:capability list -> Gri.t -> Result.fetch Lwt.t + ?capabilities:capability list -> ?head:Reference.head_contents -> + Gri.t -> Result.fetch Lwt.t (** [clone t address] clones the contents of [address] into the store [t]. *) From 74f2646e77be379b3794f6765134ea37090650c0 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 14:01:11 +0100 Subject: [PATCH 11/21] Test revdeps in Travis --- .travis.yml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index cf78d7ec1..d38fe0551 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,7 +3,8 @@ install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/ma script: bash -ex .travis-opam.sh env: - OCAML_VERSION=4.01 DEPOTS=cohttp - - OCAML_VERSION=latest - - OCAML_VERSION=latest + - OCAML_VERSION=4.01 + - OCAML_VERSION=4.02 DEPOPTS="mirage-http mirage-flow mirage-types-lwt channel cmdliner" TESTS=false + - OCAML_VERSION=4.02 TESTS=false REVDEPS=* From 2abd048e6ea91057894b969529aab8a8736c4828 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 14:23:04 +0100 Subject: [PATCH 12/21] Add an explicit dependency to stringext --- _oasis | 2 +- _tags | 10 +++++++++- lib/META | 4 ++-- opam | 1 + setup.ml | 9 +++++---- 5 files changed, 18 insertions(+), 8 deletions(-) diff --git a/_oasis b/_oasis index cf8493520..79b5be853 100644 --- a/_oasis +++ b/_oasis @@ -26,7 +26,7 @@ Library git Object, Object_type, Store, Search, Gri, Memory, FS, Packed_refs BuildDepends: mstruct, dolog, ocamlgraph, zip, nocrypto, uri, - lwt, hex + lwt, hex, stringext Library git_top Path: lib/top diff --git a/_tags b/_tags index 738e87608..3d00f1507 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: a4a985c6ac5e966966f38c5311876856) +# DO NOT EDIT (digest: e091b6058d4207e403bc545d417f795e) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -47,6 +47,7 @@ true: annot, bin_annot : pkg_mstruct : pkg_nocrypto : pkg_ocamlgraph +: pkg_stringext : pkg_uri : pkg_zip # Library git_top @@ -61,6 +62,7 @@ true: annot, bin_annot : pkg_mstruct : pkg_nocrypto : pkg_ocamlgraph +: pkg_stringext : pkg_uri : pkg_uri.services : pkg_zip @@ -76,6 +78,7 @@ true: annot, bin_annot : pkg_mstruct : pkg_nocrypto : pkg_ocamlgraph +: pkg_stringext : pkg_uri : pkg_uri.services : pkg_zip @@ -97,6 +100,7 @@ true: annot, bin_annot : pkg_mstruct : pkg_nocrypto : pkg_ocamlgraph +: pkg_stringext : pkg_uri : pkg_uri.services : pkg_zip @@ -113,6 +117,7 @@ true: annot, bin_annot : pkg_mstruct : pkg_nocrypto : pkg_ocamlgraph +: pkg_stringext : pkg_uri : pkg_uri.services : pkg_zip @@ -129,6 +134,7 @@ true: annot, bin_annot : pkg_mstruct : pkg_nocrypto : pkg_ocamlgraph +: pkg_stringext : pkg_uri : pkg_uri.services : pkg_zip @@ -155,6 +161,7 @@ true: annot, bin_annot : pkg_mstruct : pkg_nocrypto : pkg_ocamlgraph +: pkg_stringext : pkg_uri : pkg_uri.services : pkg_zip @@ -181,6 +188,7 @@ true: annot, bin_annot : pkg_mstruct : pkg_nocrypto : pkg_ocamlgraph +: pkg_stringext : pkg_uri : pkg_uri.services : pkg_zip diff --git a/lib/META b/lib/META index b6ba87a3b..95f1bb875 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 104bec6eebe91ca92d23ea23f627a872) +# DO NOT EDIT (digest: 8847ba7a30c2866e2bac45bacf9e6280) version = "1.5.3" description = "A low-level interface to Git in pure OCaml" -requires = "mstruct dolog ocamlgraph zip nocrypto uri lwt hex" +requires = "mstruct dolog ocamlgraph zip nocrypto uri lwt hex stringext" archive(byte) = "git.cma" archive(byte, plugin) = "git.cma" archive(native) = "git.cmxa" diff --git a/opam b/opam index 670c0cfb3..2f94a3248 100644 --- a/opam +++ b/opam @@ -30,6 +30,7 @@ depends: [ "uri" {>= "1.3.12"} "lwt" {>= "2.4.7"} "hex" + "stringext" "alcotest" {test} "mirage-types-lwt" {test} "mirage-flow" {test} diff --git a/setup.ml b/setup.ml index 726dd46f1..1c3740122 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 434374ea4b73baee2cce0b41f0b3a46a) *) +(* DO NOT EDIT (digest: b3493ce8732bd122998052f4b7a82165) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6954,7 +6954,8 @@ let setup_t = FindlibPackage ("nocrypto", None); FindlibPackage ("uri", None); FindlibPackage ("lwt", None); - FindlibPackage ("hex", None) + FindlibPackage ("hex", None); + FindlibPackage ("stringext", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; bs_c_sources = []; @@ -7301,7 +7302,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "¨h\0174})OÜ);¹jc\139Dú"; + oasis_digest = Some "³Lò¾\022tÙÞÖ¡ªÍa?yF"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7309,6 +7310,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7313 "setup.ml" +# 7314 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 7e6e41446a5630802de822384847b4b8e5609a58 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 14:23:50 +0100 Subject: [PATCH 13/21] Require a recent version of alcotest --- opam | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/opam b/opam index 2f94a3248..03de919a5 100644 --- a/opam +++ b/opam @@ -53,7 +53,8 @@ depopts: [ "base-unix" ] conflicts: [ - "cohttp" {< "0.18.0"} - "conduit" {< "0.8.4"} + "cohttp" {< "0.18.0"} + "conduit" {< "0.8.4"} + "alcotest" {< "0.4.0"} ] available: [ocaml-version >= "4.01.0"] From 94264ff73cdf67e7a89564ffab986b1e04892e30 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 14:24:09 +0100 Subject: [PATCH 14/21] Bump version --- _oasis | 2 +- lib/META | 12 ++++++------ setup.ml | 6 +++--- 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/_oasis b/_oasis index 79b5be853..0e154cdba 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.4 Name: git -Version: 1.5.3 +Version: 1.6.0 Synopsis: A low-level interface to Git in pure OCaml Authors: Thomas Gazagnaire License: ISC diff --git a/lib/META b/lib/META index 95f1bb875..d2f372080 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 8847ba7a30c2866e2bac45bacf9e6280) -version = "1.5.3" +# DO NOT EDIT (digest: 12563177197ed08d09a3e54e388e995b) +version = "1.6.0" description = "A low-level interface to Git in pure OCaml" requires = "mstruct dolog ocamlgraph zip nocrypto uri lwt hex stringext" archive(byte) = "git.cma" @@ -9,7 +9,7 @@ archive(native) = "git.cmxa" archive(native, plugin) = "git.cmxs" exists_if = "git.cma" package "unix" ( - version = "1.5.3" + version = "1.6.0" description = "A low-level interface to Git in pure OCaml" requires = "git git.http lwt cohttp.lwt lwt.unix conduit.lwt-unix" archive(byte) = "git-unix.cma" @@ -20,7 +20,7 @@ package "unix" ( ) package "top" ( - version = "1.5.3" + version = "1.6.0" description = "Toplevel printers for Git values" requires = "git" archive(byte) = "git_top.cma" @@ -31,7 +31,7 @@ package "top" ( ) package "mirage" ( - version = "1.5.3" + version = "1.6.0" description = "A low-level interface to Git in pure OCaml" requires = "git git.http mirage-types.lwt io-page conduit.mirage dns.mirage mirage-http mirage-flow channel" @@ -43,7 +43,7 @@ package "mirage" ( ) package "http" ( - version = "1.5.3" + version = "1.6.0" description = "A low-level interface to Git in pure OCaml" requires = "git lwt cohttp.lwt uri.services" archive(byte) = "git-http.cma" diff --git a/setup.ml b/setup.ml index 1c3740122..8d87e9a9f 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: b3493ce8732bd122998052f4b7a82165) *) +(* DO NOT EDIT (digest: 1ed316ff096043450aa948a7e07b8d1d) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6861,7 +6861,7 @@ let setup_t = alpha_features = []; beta_features = []; name = "git"; - version = "1.5.3"; + version = "1.6.0"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -7302,7 +7302,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "³Lò¾\022tÙÞÖ¡ªÍa?yF"; + oasis_digest = Some "\145Þ|\004óu-\000Q\139mñ×Æ5\159"; oasis_exec = None; oasis_setup_args = []; setup_update = false From 8b6197af249c790c2fc1a86f49d994da51c5a94a Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 15:57:06 +0100 Subject: [PATCH 15/21] Allow to download all the heads from a remote store. The `wants` should only contain hashes of valid `refs/heads/..` references. --- lib/sync.ml | 65 ++++++++++++++++++++++++++++++++--------------------- 1 file changed, 39 insertions(+), 26 deletions(-) diff --git a/lib/sync.ml b/lib/sync.ml index b65d476b0..f9780c95f 100644 --- a/lib/sync.ml +++ b/lib/sync.ml @@ -499,7 +499,7 @@ module Make (IO: IO) (Store: Store.S) = struct module Upload_request = struct type message = - | Want of SHA.t * Capability.t list + | Want of SHA.Commit.t * Capability.t list | Shallow of SHA.t | Deepen of int | Unshallow of SHA.t @@ -554,7 +554,7 @@ module Make (IO: IO) (Store: Store.S) = struct in aux (Deepen d :: acc) | "want" -> - let aux id c = aux (Want (SHA.of_hex id, c) :: acc) in + let aux id c = aux (Want (SHA.Commit.of_hex id, c) :: acc) in begin match Stringext.cut s ~on:Misc.sp_str with | Some (id,c) -> aux id (Capabilities.of_string c) | None -> match acc with @@ -574,14 +574,15 @@ module Make (IO: IO) (Store: Store.S) = struct if i = 0 && c <> [] then (* first-want *) let msg = Printf.sprintf - "want %s %s\n" (SHA.to_hex id) (Capabilities.to_string c) + "want %s %s\n" (SHA.Commit.to_hex id) (Capabilities.to_string c) in PacketLine.output_line oc msg else (* additional-want *) - let msg = Printf.sprintf "want %s\n" (SHA.to_hex id) in + let msg = Printf.sprintf "want %s\n" (SHA.Commit.to_hex id) in if i <> 0 && c <> [] then - Log.warn "additional-want: ignoring %s." (Capabilities.to_string c); + Log.warn "additional-want: ignoring %s." + (Capabilities.to_string c); PacketLine.output_line oc msg ) (filter_wants t) >>= fun () -> @@ -912,8 +913,8 @@ module Make (IO: IO) (Store: Store.S) = struct Report_status.input ic ) - let fetch_pack_with_head t (ic, oc) op references head = - Log.debug "Sync.fetch_pack_with_head head=%s" (SHA.Commit.pretty head); + let fetch_pack_with_wants t (ic, oc) op references wants = + Log.debug "Sync.fetch_pack_with_head"; let deepen = match op with | Clone { c_deepen = d; _ } | Fetch { f_deepen = d; _ } -> d @@ -928,7 +929,6 @@ module Make (IO: IO) (Store: Store.S) = struct | Clone { c_capabilites = c; _ } -> c | _ -> [] in - let wants = [SHA.of_commit head] in Log.debug "PHASE1"; Upload_request.phase1 (ic, oc) ?deepen ~capabilities ~shallows ~wants @@ -962,27 +962,33 @@ module Make (IO: IO) (Store: Store.S) = struct let pack = Pack.Raw.input (Mstruct.of_cstruct pack) ~index:None in Store.write_pack t pack end >>= fun sha1s -> + let head = + try Some (Reference.Map.find Reference.head references) with Not_found -> None + in match SHA.Set.to_list sha1s with | [] -> Log.debug "NO NEW OBJECTS"; Log.info "Already up-to-date."; - Lwt.return { Result.head = Some head; references; sha1s = [] } + Lwt.return { Result.head; references; sha1s = [] } | sha1s -> Log.debug "NEW OBJECTS"; Log.info "remote: Counting objects: %d, done." (List.length sha1s); - Lwt.return { Result.head = Some head; references; sha1s } + Lwt.return { Result.head; references; sha1s } + + let is_head ref = + Reference.is_valid ref && + let raw_ref = Reference.to_raw ref in + let prefix = "refs/heads/" in + match Misc.string_chop_prefix ~prefix raw_ref with + | None -> false + | Some _ -> true let write_heads t (ref, sha1) = - if Reference.is_valid ref then - let raw_ref = Reference.to_raw ref in - let prefix = "refs/heads/" in - match Misc.string_chop_prefix ~prefix raw_ref with - | None -> Lwt.return_unit - | Some _ -> - Store.mem t (SHA.of_commit sha1) >>= function - | false -> Lwt.return_unit - | true -> Store.write_reference t ref sha1 + if is_head ref then + Store.mem t (SHA.of_commit sha1) >>= function + | false -> Lwt.return_unit + | true -> Store.write_reference t ref sha1 else Lwt.return_unit @@ -1026,16 +1032,23 @@ module Make (IO: IO) (Store: Store.S) = struct | Ls -> Lwt.return { Result.head = remote_head; references; sha1s = [] } | Fetch _ | Clone _ -> - let head = match head with + let local_head = match head with | None -> Reference.Ref Reference.master | Some (Reference.SHA x) -> Reference.SHA x | Some (Reference.Ref r) -> if Reference.Map.mem r references then Reference.Ref r else err_invalid_branch gri r in - let want = match head with - | Reference.SHA x -> x - | Reference.Ref r -> Reference.Map.find r references + let wants = match head with + | None -> + (* the user didn't specify a branch, download all + the tags. *) + Reference.Map.fold (fun r c acc -> + if is_head r then SHA.Commit.Set.add c acc else acc + ) references SHA.Commit.Set.empty + |> SHA.Commit.Set.elements + | Some (Reference.SHA x) -> [x] + | Some (Reference.Ref r) -> [Reference.Map.find r references] in let sync () = if protocol = `Smart_HTTP then @@ -1043,10 +1056,10 @@ module Make (IO: IO) (Store: Store.S) = struct let uri = Init.uri init in let init = Init.to_string init in IO.with_connection ?ctx uri ?init (fun (ic, oc) -> - fetch_pack_with_head t (ic, oc) op references want + fetch_pack_with_wants t (ic, oc) op references wants ) else - fetch_pack_with_head t (ic, oc) op references want + fetch_pack_with_wants t (ic, oc) op references wants in let update_refs () = match op with | Ls -> assert false @@ -1057,7 +1070,7 @@ module Make (IO: IO) (Store: Store.S) = struct |> Lwt_list.iter_p (write_heads t) >>= fun () -> match op with - | Clone _ -> Store.write_head t head (* update .git/HEAD *) + | Clone _ -> Store.write_head t local_head (* update .git/HEAD *) | _ -> Lwt.return_unit in sync () >>= fun r -> From 0a97e3951dec9d56f9c5f00600d191503302555b Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 15:58:05 +0100 Subject: [PATCH 16/21] Make the clone test also test the smart HTTP protocol. --- lib_test/test_store.ml | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/lib_test/test_store.ml b/lib_test/test_store.ml index 62ccaf003..f3fa1f4a9 100644 --- a/lib_test/test_store.ml +++ b/lib_test/test_store.ml @@ -454,9 +454,8 @@ module Make (Store: Store.S) = struct let test_clones x () = let test () = - let gri = Gri.of_string "git://github.com/mirage/ocaml-git.git" in Store.create ~root () >>= fun t -> - let clone head = + let clone gri head = x.init () >>= fun () -> Sync.clone t ?head gri >>= fun _ -> if Store.kind = `Disk then @@ -474,13 +473,23 @@ module Make (Store: Store.S) = struct else Lwt.return_unit in - let gh_pages = Git.Reference.of_raw "refs/heads/gh-pages" in + let git = Gri.of_string "git://github.com/mirage/ocaml-git.git" in + let https = Gri.of_string "https://github.com/mirage/ocaml-git.git" in + let gh_pages = + Some (Git.Reference.(Ref (of_raw "refs/heads/gh-pages"))) + in let commit = - Git.SHA.Commit.of_hex "21930ccb5f7b97e80a068371cb554b1f5ce8e55a" + let h = SHA.Commit.of_hex "21930ccb5f7b97e80a068371cb554b1f5ce8e55a" in + Some (Git.Reference.SHA h) in - clone None >>= fun () -> - clone (Some (Git.Reference.Ref gh_pages)) >>= fun () -> - clone (Some (Git.Reference.SHA commit)) + clone git None >>= fun () -> + clone https None >>= fun () -> + clone git gh_pages >>= fun () -> + clone https gh_pages >>= fun () -> + clone https commit >>= fun () -> + clone git commit >>= fun () -> + + Lwt.return_unit in run x test From d9ced7c7cece6cb108c8b3be68f0a5f0cff1208a Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 16:00:16 +0100 Subject: [PATCH 17/21] Update the Sync.clone description --- lib/sync.mli | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/sync.mli b/lib/sync.mli index 5f241445d..150da94a4 100644 --- a/lib/sync.mli +++ b/lib/sync.mli @@ -81,7 +81,10 @@ module type S = sig ?capabilities:capability list -> ?head:Reference.head_contents -> Gri.t -> Result.fetch Lwt.t (** [clone t address] clones the contents of [address] into the - store [t]. *) + store [t]. If [head] is set, only the history of the given SHA1 + or references will be downloaded. If [head] is not set + (default), all the whole history (corresponding to {i all} the + remote heads) will be downloaded. *) val fetch: ?ctx:ctx -> t -> ?deepen:int -> ?unpack:bool -> ?capabilities:capability list -> Gri.t -> Result.fetch Lwt.t From 34713c4a3ac67797ab5805c275cff03990dd19da Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 16:09:55 +0100 Subject: [PATCH 18/21] Give a name to the package to be able to test the REVDEPS --- .travis.yml | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index d38fe0551..11a9d579a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,9 +2,12 @@ language: c install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh script: bash -ex .travis-opam.sh env: - - OCAML_VERSION=4.01 DEPOTS=cohttp - - OCAML_VERSION=4.01 - - OCAML_VERSION=4.02 - DEPOPTS="mirage-http mirage-flow mirage-types-lwt channel cmdliner" - TESTS=false - - OCAML_VERSION=4.02 TESTS=false REVDEPS=* + global: + - PACKAGE=git + matrix: + - OCAML_VERSION=4.01 DEPOTS=cohttp + - OCAML_VERSION=4.01 + - OCAML_VERSION=4.02 + DEPOPTS="mirage-http mirage-flow mirage-types-lwt channel cmdliner" + TESTS=false + - OCAML_VERSION=4.02 TESTS=false REVDEPS=* From d31c44f9dc522db11cd490d5fd1ef4d03cf15a92 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 16:35:56 +0100 Subject: [PATCH 19/21] Avoid building too large strings. This should help with 32b OCaml where string size is limited to 16M Related to #97 --- lib/mirage/git_mirage.ml | 17 ++++++++--------- lib/sync.ml | 18 ++++++++++++------ lib/sync.mli | 2 +- lib/unix/git_unix.ml | 20 ++++++++++---------- 4 files changed, 31 insertions(+), 26 deletions(-) diff --git a/lib/mirage/git_mirage.ml b/lib/mirage/git_mirage.ml index 3af8b9ddb..1eb896f3b 100644 --- a/lib/mirage/git_mirage.ml +++ b/lib/mirage/git_mirage.ml @@ -186,19 +186,18 @@ module IO_helper (Channel: V1_LWT.CHANNEL) = struct Channel.flush oc let read_all ic = - let len = 4096 in - let res = Buffer.create len in - let rec aux () = + let len = 4 * 4096 in + let return l = Lwt.return (List.rev l) in + let rec aux acc = Channel.read_some ~len ic >>= fun buf -> match Cstruct.len buf with - | 0 -> Lwt.return_unit + | 0 -> return acc | i -> - Buffer.add_string res (Cstruct.to_string buf); - if len = i then Lwt.return_unit - else aux () + let buf = Cstruct.to_string buf in + if len = i then return (buf :: acc) + else aux (buf :: acc) in - aux () >>= fun () -> - Lwt.return (Buffer.contents res) + aux [] let read_exactly ic n = let res = Bytes.create n in diff --git a/lib/sync.ml b/lib/sync.ml index f9780c95f..1d879d6ca 100644 --- a/lib/sync.ml +++ b/lib/sync.ml @@ -87,7 +87,7 @@ module type IO = sig type ctx val with_connection: ?ctx:ctx -> Uri.t -> ?init:string -> (ic * oc -> 'a Lwt.t) -> 'a Lwt.t - val read_all: ic -> string Lwt.t + val read_all: ic -> string list Lwt.t val read_exactly: ic -> int -> string Lwt.t val write: oc -> string -> unit Lwt.t val flush: oc -> unit Lwt.t @@ -751,7 +751,7 @@ module Make (IO: IO) (Store: Store.S) = struct let input ~capabilities ic = if List.mem `Side_band_64k capabilities || List.mem `Side_band capabilities - then Side_band.input ic + then Side_band.input ic >|= fun x -> [x] else IO.read_all ic end @@ -945,10 +945,16 @@ module Make (IO: IO) (Store: Store.S) = struct Log.debug "PHASE3"; Log.info "Receiving data ..."; - Pack_file.input ~capabilities ic >>= fun raw -> - - Log.info "Received a pack file of %d bytes." (String.length raw); - let pack = Cstruct.of_string raw in + Pack_file.input ~capabilities ic >>= fun bufs -> + + let size = List.fold_left (fun acc s -> acc + String.length s) 0 bufs in + Log.info "Received a pack file of %d bytes." size; + let pack = Cstruct.create size in + let _size = List.fold_left (fun acc buf -> + let len = String.length buf in + Cstruct.blit_from_string buf 0 pack acc len; + acc + len + ) 0 bufs in let unpack = match op with | Clone { c_unpack = u; _ } diff --git a/lib/sync.mli b/lib/sync.mli index 150da94a4..a337552e7 100644 --- a/lib/sync.mli +++ b/lib/sync.mli @@ -115,7 +115,7 @@ module type IO = sig once the function returns. The [init] corresponds to an optional first message sent on the connection to set-it up. *) - val read_all: ic -> string Lwt.t + val read_all: ic -> string list Lwt.t (** Read all the channel contents (until the channel is closed by the other side). *) diff --git a/lib/unix/git_unix.ml b/lib/unix/git_unix.ml index 855f10ff7..a30d0e8d1 100644 --- a/lib/unix/git_unix.ml +++ b/lib/unix/git_unix.ml @@ -117,18 +117,18 @@ module M = struct Lwt.fail (Failure ("Unknown protocol. Must supply a scheme like git://")) let read_all ic = - let len = 4096 in - let buf = Bytes.create len in - let res = Buffer.create len in - let rec aux () = + let len = 4 * 4096 in + let return l = Lwt.return (List.rev l) in + let rec aux acc = + let buf = Bytes.create len in Lwt_io.read_into ic buf 0 len >>= function - | 0 -> Lwt.return_unit - | i -> Buffer.add_substring res buf 0 i; - if len = i then Lwt.return_unit - else aux () + | 0 -> return acc + | i -> + let buf = Bytes.sub buf 0 i in + if len = i then return (buf :: acc) + else aux (buf :: acc) in - aux () >>= fun () -> - Lwt.return (Buffer.contents res) + aux [] let read_exactly ic n = let res = Bytes.create n in From c13edc8594918910ac54bf256755ee8882c4200b Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 17:41:30 +0100 Subject: [PATCH 20/21] References can also contain pointers to other references In that case, just call read_reference recursively. Not tested, as I don't want to expose this in the API, but could happen on bare repositories. Shoud fix #96, but need more testing. --- lib/FS.ml | 28 ++++++++++++---------------- lib/memory.ml | 11 +++++++---- lib/reference.ml | 19 +++++++++++++------ lib/reference.mli | 11 +++++++---- 4 files changed, 39 insertions(+), 30 deletions(-) diff --git a/lib/FS.ml b/lib/FS.ml index 7a4fb38ef..006bf9fe9 100644 --- a/lib/FS.ml +++ b/lib/FS.ml @@ -473,16 +473,18 @@ module Make (IO: IO) = struct (fun () -> IO.remove file) (fun _ -> Lwt.return_unit) - let read_reference t ref = + let rec read_reference t ref = let file = file_of_ref t ref in - IO.file_exists file >>= function - | true -> + IO.file_exists file >>= fun exists -> + if exists then (* We use `IO.read_file` here as the contents of the file might change. *) - IO.read_file file >>= fun hex -> - let hex = String.trim (Cstruct.to_string hex) in - Lwt.return (Some (SHA.Commit.of_hex hex)) - | false -> + IO.read_file file >>= fun buf -> + let str = Cstruct.to_string buf in + match Reference.head_contents_of_string str with + | Reference.SHA x -> Lwt.return (Some x) + | Reference.Ref r -> read_reference t r + else let packed_refs = packed_refs t in IO.file_exists packed_refs >>= function | false -> Lwt.return_none @@ -500,15 +502,9 @@ module Make (IO: IO) = struct | true -> (* We use `IO.read_file` here as the contents of the file might change. *) - IO.read_file file >>= fun str -> - let str = Cstruct.to_string str in - let contents = match Stringext.split ~on:' ' str with - | [sha1] -> Reference.SHA (SHA.Commit.of_hex sha1) - | [_;ref] -> Reference.Ref (Reference.of_raw ref) - | _ -> - failwith (sprintf "read_head: %s is not a valid HEAD contents" str) - in - Lwt.return (Some contents) + IO.read_file file >|= fun buf -> + let str = Cstruct.to_string buf in + Some (Reference.head_contents_of_string str) | false -> Lwt.return None diff --git a/lib/memory.ml b/lib/memory.ml index 4938ec3f3..5fac48088 100644 --- a/lib/memory.ml +++ b/lib/memory.ml @@ -26,7 +26,7 @@ type t = { root : string; level : int; values : (SHA.t, Value.t) Hashtbl.t; - refs : (Reference.t, SHA.Commit.t) Hashtbl.t; + refs : (Reference.t, [`S of SHA.Commit.t | `R of Reference.t]) Hashtbl.t; mutable head : Reference.head_contents option; } @@ -124,9 +124,12 @@ let references t = let mem_reference t ref = Lwt.return (Hashtbl.mem t.refs ref) -let read_reference t ref = +let rec read_reference t ref = Log.info "Reading %s" (Reference.pretty ref); - try Lwt.return (Some (Hashtbl.find t.refs ref)) + try + match Hashtbl.find t.refs ref with + | `S s -> Lwt.return (Some s) + | `R r -> read_reference t r with Not_found -> Lwt.return_none let read_head t = @@ -149,7 +152,7 @@ let write_head t c = let write_reference t ref sha1 = Log.info "Writing %s" (Reference.pretty ref); - Hashtbl.replace t.refs ref sha1; + Hashtbl.replace t.refs ref (`S sha1); Lwt.return_unit let read_index _t = Lwt.return Index.empty diff --git a/lib/reference.ml b/lib/reference.ml index 14fc83f91..02f113b8a 100644 --- a/lib/reference.ml +++ b/lib/reference.ml @@ -22,11 +22,8 @@ let compare = String.compare let equal = (=) let hash = Hashtbl.hash -let add _buf ?level:_ _t = - failwith "TODO: Reference.add" - -let input _buf = - failwith "TODO: Reference.input" +let add _buf ?level:_ _t = failwith "TODO: Reference.add" +let input _buf = failwith "TODO: Reference.input" let to_raw x = x let of_raw x = x @@ -57,10 +54,20 @@ let equal_head_contents x y = match x, y with | Ref x, Ref y -> String.compare x y = 0 | _ -> false +let err_head_contents str = + let err = Printf.sprintf "%S is not a valid HEAD contents" str in + failwith err + +let head_contents_of_string str = + match Stringext.split ~on:' ' (String.trim str) with + | [sha1] -> SHA (SHA.Commit.of_hex sha1) + | [_;ref] -> Ref (of_raw ref) + | _ -> err_head_contents str + let is_head x = String.compare head x = 0 -let head_contents refs sha1 = +let head_contents_of_commit refs sha1 = let refs = Map.remove "HEAD" refs in let alist = Misc.inverse_assoc (Map.to_alist refs) in match Misc.try_assoc sha1 alist with diff --git a/lib/reference.mli b/lib/reference.mli index 89f3d3035..078721174 100644 --- a/lib/reference.mli +++ b/lib/reference.mli @@ -38,10 +38,13 @@ type head_contents = | Ref of t (** The possible HEAD contents. *) -val head_contents: SHA.Commit.t Map.t -> SHA.Commit.t -> head_contents -(** Compute the head contents. The result is either the hex - representation of the SHA or something like {i ref: } if the - SHA has already a reference pointing to it. *) +val head_contents_of_string: string -> head_contents +(** Parse the contents of HEAD *) + +val head_contents_of_commit: SHA.Commit.t Map.t -> SHA.Commit.t -> head_contents +(** Build a head contents from a commit hash. The result is either the + hex representation of the SHA or something like {i ref: } if + the SHA has already a reference pointing to it. *) val pp_head_contents: Format.formatter -> head_contents -> unit (** Pretty-print head contents. *) From 7c6760799c7845f565c9f29cccc02971e417f8c5 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 11 Jul 2015 14:27:19 +0100 Subject: [PATCH 21/21] Update CHANGES --- CHANGES.md | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 7d6873cbf..eb8142720 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,16 @@ +### 1.6.0 (2015-07-11) + +* Allow some references to contain pointer to other references (#96) +* Improve the support for 32bit architectures (#97) +* Add `Reference.pp_head_contents` and `Reference.equal_head_contents`. +* Remove `Store.clear` and replace it by `Memory.clear`, `Memory.clear_all` + and `FS.remove`. This let users have a finer control over the memory + consumption of the program over time (related to #90) +* Rename all `pp_hum` functions into `pp`. +* Fix regression in `Sync.fetch` and add unit-tests (running only in slow mode). +* Fix reading of `.git/HEAD` when the contents is a commit hash. +* Depends on `Stringext` for all the extra string function needed. + ### 1.5.3 (2015-07-10) * Fix listing of packed references (#98)