From e4db2a5093748c8c48fd83a205d93fd5ef2acb31 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 18 Jul 2014 15:34:20 +0100 Subject: [PATCH 1/6] Remove old files --- lib/git-fs.mldylib | 4 -- lib/git-fs.mllib | 4 -- lib/git-memory.mldylib | 4 -- lib/git-memory.mllib | 4 -- myocamlbuild.ml | 20 ++++----- setup.ml | 100 ++++++++++++++++++++--------------------- 6 files changed, 60 insertions(+), 76 deletions(-) delete mode 100644 lib/git-fs.mldylib delete mode 100644 lib/git-fs.mllib delete mode 100644 lib/git-memory.mldylib delete mode 100644 lib/git-memory.mllib diff --git a/lib/git-fs.mldylib b/lib/git-fs.mldylib deleted file mode 100644 index f72557032..000000000 --- a/lib/git-fs.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: ac7758905c6f56db4bf4ed50a53066bf) -Git_fs -# OASIS_STOP diff --git a/lib/git-fs.mllib b/lib/git-fs.mllib deleted file mode 100644 index f72557032..000000000 --- a/lib/git-fs.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: ac7758905c6f56db4bf4ed50a53066bf) -Git_fs -# OASIS_STOP diff --git a/lib/git-memory.mldylib b/lib/git-memory.mldylib deleted file mode 100644 index f5a444c25..000000000 --- a/lib/git-memory.mldylib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 937e6f7bd57961e50da141ed57698587) -Git_memory -# OASIS_STOP diff --git a/lib/git-memory.mllib b/lib/git-memory.mllib deleted file mode 100644 index f5a444c25..000000000 --- a/lib/git-memory.mllib +++ /dev/null @@ -1,4 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 937e6f7bd57961e50da141ed57698587) -Git_memory -# OASIS_STOP diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 6ff68aeb1..68defa84d 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 0880b83cc4b68403a7c1c42c38353cab) *) +(* DO NOT EDIT (digest: f96e52381f0d25b389b4124826caa8f0) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -39,10 +39,10 @@ module OASISExpr = struct open OASISGettext - type test = string + type test = string - type flag = string + type flag = string type t = @@ -52,10 +52,10 @@ module OASISExpr = struct | EOr of t * t | EFlag of flag | ETest of test * string - - type 'a choices = (t * 'a) list + + type 'a choices = (t * 'a) list let eval var_get t = @@ -430,10 +430,10 @@ module MyOCamlbuildBase = struct module OC = Ocamlbuild_pack.Ocaml_compiler - type dir = string - type file = string - type name = string - type tag = string + type dir = string + type file = string + type name = string + type tag = string (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) @@ -448,7 +448,7 @@ module MyOCamlbuildBase = struct * directory. *) includes: (dir * dir list) list; - } + } let env_filename = diff --git a/setup.ml b/setup.ml index 96ab22d72..eb4d89f97 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: 7a3ea25aa06e17c952d3e3e3442d1b56) *) +(* DO NOT EDIT (digest: 266158c020da3cc4558432af3b483e64) *) (* Regenerated by OASIS v0.4.4 Visit http://oasis.forge.ocamlcore.org for more information and @@ -739,7 +739,7 @@ module OASISVersion = struct type s = string - type t = string + type t = string type comparator = @@ -750,7 +750,7 @@ module OASISVersion = struct | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator - + (* Range of allowed characters *) @@ -945,17 +945,17 @@ module OASISLicense = struct - type license = string + type license = string - type license_exception = string + type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion - + type license_dep_5_unit = @@ -964,19 +964,19 @@ module OASISLicense = struct excption: license_exception option; version: license_version; } - + type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list - + type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) - + end @@ -991,10 +991,10 @@ module OASISExpr = struct open OASISGettext - type test = string + type test = string - type flag = string + type flag = string type t = @@ -1004,10 +1004,10 @@ module OASISExpr = struct | EOr of t * t | EFlag of flag | ETest of test * string - - type 'a choices = (t * 'a) list + + type 'a choices = (t * 'a) list let eval var_get t = @@ -1089,9 +1089,9 @@ module OASISText = struct | Para of string | Verbatim of string | BlankLine - - type t = elt list + + type t = elt list end @@ -1102,40 +1102,40 @@ module OASISTypes = struct - type name = string - type package_name = string - type url = string - type unix_dirname = string - type unix_filename = string - type host_dirname = string - type host_filename = string - type prog = string - type arg = string - type args = string list - type command_line = (prog * arg list) + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) - type findlib_name = string - type findlib_full = string + type findlib_name = string + type findlib_full = string type compiled_object = | Byte | Native | Best - + type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name - + type tool = | ExternalTool of name | InternalExecutable of name - + type vcs = @@ -1148,7 +1148,7 @@ module OASISTypes = struct | Arch | Monotone | OtherVCS of url - + type plugin_kind = @@ -1176,7 +1176,7 @@ module OASISTypes = struct ] - type 'a plugin = 'a * name * OASISVersion.t option + type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin @@ -1188,7 +1188,7 @@ module OASISTypes = struct (* # 115 "src/oasis/OASISTypes.ml" *) - type 'a conditional = 'a OASISExpr.choices + type 'a conditional = 'a OASISExpr.choices type custom = @@ -1196,7 +1196,7 @@ module OASISTypes = struct pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } - + type common_section = @@ -1205,7 +1205,7 @@ module OASISTypes = struct cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } - + type build_section = @@ -1225,7 +1225,7 @@ module OASISTypes = struct bs_byteopt: args conditional; bs_nativeopt: args conditional; } - + type library = @@ -1236,28 +1236,28 @@ module OASISTypes = struct lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; - } + } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; - } + } type executable = { exec_custom: bool; exec_main_is: unix_filename; - } + } type flag = { flag_description: string option; flag_default: bool conditional; - } + } type source_repository = @@ -1269,7 +1269,7 @@ module OASISTypes = struct src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; - } + } type test = @@ -1280,7 +1280,7 @@ module OASISTypes = struct test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; - } + } type doc_format = @@ -1291,7 +1291,7 @@ module OASISTypes = struct | Info of unix_filename | DVI | OtherDoc - + type doc = @@ -1307,7 +1307,7 @@ module OASISTypes = struct doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; - } + } type section = @@ -1318,7 +1318,7 @@ module OASISTypes = struct | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc - + type section_kind = @@ -1363,7 +1363,7 @@ module OASISTypes = struct disable_oasis_section: unix_filename list; schema_data: PropList.Data.t; plugin_data: plugin_data; - } + } end @@ -6257,7 +6257,7 @@ module OCamlbuildCommon = struct - type extra_args = string list + type extra_args = string list let ocamlbuild_clean_ev = "ocamlbuild-clean" @@ -6574,7 +6574,7 @@ module OCamlbuildDocPlugin = struct { extra_args: string list; run_path: unix_filename; - } + } let doc_build run pkg (cs, doc) argv = @@ -6636,7 +6636,7 @@ module CustomPlugin = struct cmd_main: command_line conditional; cmd_clean: (command_line option) conditional; cmd_distclean: (command_line option) conditional; - } + } let run = BaseCustom.run From ccd76ea59f0148ab3fc9fa214361fe8c136f5480 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Thu, 16 Oct 2014 17:42:02 +0100 Subject: [PATCH 2/6] Remove the dependency toward core_kernel --- _oasis | 8 +- _tags | 17 +-- bin/ogit.ml | 38 ++++--- lib/FS.ml | 152 +++++++++++++------------ lib/FS.mli | 6 +- lib/META | 4 +- lib/SHA.ml | 53 ++++++--- lib/SHA.mli | 14 ++- lib/blob.ml | 17 ++- lib/blob.mli | 3 + lib/cache.ml | 101 +++++++++-------- lib/commit.ml | 57 +++++----- lib/git_mirage.ml | 43 +++---- lib/git_mirage.mli | 2 - lib/git_unix.ml | 58 +++++----- lib/git_unix.mli | 1 - lib/global_graph.ml | 24 ++-- lib/global_graph.mli | 5 +- lib/gri.ml | 6 +- lib/memory.ml | 45 ++++---- lib/misc.ml | 243 +++++++++++++++++++++++++++++++--------- lib/misc.mli | 92 ++++++++++----- lib/object.mli | 15 ++- lib/object_type.ml | 26 ++--- lib/object_type.mli | 2 + lib/pack.ml | 168 +++++++++++++-------------- lib/pack.mli | 5 +- lib/pack_index.ml | 123 +++++++++++--------- lib/pack_index.mli | 4 +- lib/packed_value.ml | 191 +++++++++++++++---------------- lib/packed_value.mli | 32 +++--- lib/reference.ml | 32 ++++-- lib/reference.mli | 8 +- lib/search.ml | 5 +- lib/store.mli | 2 - lib/sync.ml | 138 ++++++++++++----------- lib/tag.ml | 47 ++++---- lib/tree.ml | 59 +++++----- lib/user.ml | 35 +++--- lib/value.ml | 62 +++++----- lib/value.mli | 7 +- lib_test/test_common.ml | 40 +++---- lib_test/test_mirage.ml | 2 +- lib_test/test_store.ml | 63 ++++++----- setup.ml | 9 +- 45 files changed, 1139 insertions(+), 925 deletions(-) diff --git a/_oasis b/_oasis index ae2adbec1..51e761bae 100644 --- a/_oasis +++ b/_oasis @@ -24,11 +24,11 @@ Library git Reference, Sync, Tag, Tree, User, Value, Object, Object_type, Store, Search, Gri, Memory, FS - BuildDepends: mstruct, dolog, core_kernel, ocamlgraph, - re.pcre, zip, sha, uri, lwt, - bin_prot.syntax, comparelib.syntax, sexplib.syntax, + BuildDepends: mstruct, dolog, ocamlgraph, + re.pcre, zip, sha1, uri, lwt, + sexplib.syntax, conduit.lwt, uri.services - XMETARequires: mstruct, dolog, core_kernel, ocamlgraph, + XMETARequires: mstruct, dolog, ocamlgraph, re.pcre, zip, sha, uri, lwt, conduit.lwt, uri.services diff --git a/_tags b/_tags index 9e7d8ecf7..f2684b15e 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 0216bcc876c5cc9c342039b0c69188fb) +# DO NOT EDIT (digest: 14436c0ca6aa90315cd309e2c2d5339b) # 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 @@ -42,10 +42,7 @@ : pkg_lwt.unix # Library git-mirage "lib/git-mirage.cmxs": use_git-mirage -: pkg_bin_prot.syntax -: pkg_comparelib.syntax : pkg_conduit.lwt -: pkg_core_kernel : pkg_dolog : pkg_io-page : pkg_lwt @@ -60,11 +57,8 @@ : pkg_zip : use_git # Executable ogit -: pkg_bin_prot.syntax : pkg_cmdliner -: pkg_comparelib.syntax : pkg_conduit.lwt -: pkg_core_kernel : pkg_dolog : pkg_lwt : pkg_lwt.unix @@ -78,11 +72,8 @@ : pkg_zip : use_git : use_git-unix -: pkg_bin_prot.syntax : pkg_cmdliner -: pkg_comparelib.syntax : pkg_conduit.lwt -: pkg_core_kernel : pkg_dolog : pkg_lwt : pkg_lwt.unix @@ -98,10 +89,7 @@ : use_git-unix # Executable test_git : pkg_alcotest -: pkg_bin_prot.syntax -: pkg_comparelib.syntax : pkg_conduit.lwt -: pkg_core_kernel : pkg_cryptokit : pkg_dolog : pkg_io-page @@ -122,10 +110,7 @@ : use_git-mirage : use_git-unix : pkg_alcotest -: pkg_bin_prot.syntax -: pkg_comparelib.syntax : pkg_conduit.lwt -: pkg_core_kernel : pkg_cryptokit : pkg_dolog : pkg_io-page diff --git a/bin/ogit.ml b/bin/ogit.ml index 15a765b53..21eacb79a 100644 --- a/bin/ogit.ml +++ b/bin/ogit.ml @@ -15,8 +15,8 @@ *) open Lwt -open Core_kernel.Std open Cmdliner +open Printf open Git open Git_unix @@ -130,8 +130,8 @@ let directory = Arg.(value & pos 1 (some string) None & doc) let reference = - let parse str = `Ok (Reference.of_string str) in - let print ppf name = Format.pp_print_string ppf (Reference.to_string name) in + let parse str = `Ok (Reference.of_raw str) in + let print ppf name = Format.pp_print_string ppf (Reference.to_raw name) in parse, print let branch = @@ -154,7 +154,7 @@ let run t = Lwt_unix.run ( Lwt.catch (fun () -> t) - (function e -> eprintf "%s\n%!" (Exn.to_string e); exit 1) + (function e -> eprintf "%s\n%!" (Printexc.to_string e); exit 1) ) (* CAT *) @@ -169,7 +169,7 @@ let cat = { Arg.(required & pos 0 (some string) None & doc) in let cat_file file = run begin - let buf = In_channel.read_all file in + Lwt_io.with_file ~mode:Lwt_io.input file Lwt_io.read >>= fun buf -> let v = Value.input (Mstruct.of_string buf) in Printf.printf "%s%!" (Value.pretty v); return_unit @@ -189,11 +189,11 @@ let ls_remote = { S.create () >>= fun t -> Sync.ls t remote >>= fun references -> Printf.printf "From %s\n" (Gri.to_string remote); - let print ~key:ref ~data:sha1 = + let print ref sha1 = Printf.printf "%s %s\n" (SHA.Commit.to_hex sha1) - (Reference.to_string ref) in - Map.iter ~f:print references; + (Reference.to_raw ref) in + Reference.Map.iter print references; return_unit end in Term.(mk ls $ backend $ remote) @@ -217,7 +217,7 @@ let ls_files = { printf "%s" (Cache.pretty cache) else List.iter - ~f:(fun e -> Printf.printf "%s\n" e.Cache.name) + (fun e -> Printf.printf "%s\n" e.Cache.name) cache.Cache.entries; return_unit end in @@ -242,8 +242,8 @@ let read_tree = { begin let (/) = Filename.concat in let ref = "refs" / "heads" / commit_str in - if List.exists refs ~f:(fun r -> Reference.to_string r = ref) then - S.read_reference_exn t (Reference.of_string ref) + if List.exists (fun r -> Reference.to_raw r = ref) refs then + S.read_reference_exn t (Reference.of_raw ref) else return (SHA.Commit.of_hex commit_str) end >>= fun commit -> @@ -329,8 +329,8 @@ let push = { S.create () >>= fun t -> S.read_reference t branch >>= fun b -> let branch = match b with - | None -> Reference.of_string - ("refs/heads/" ^ Reference.to_string branch) + | None -> Reference.of_raw + ("refs/heads/" ^ Reference.to_raw branch) | Some _ -> branch in Sync.push t ~branch remote >>= fun s -> printf "%s\n" (Result.pretty_push s); @@ -352,7 +352,11 @@ let graph = { let module Graph = Global_graph.Make(S) in run begin S.create () >>= fun t -> - Graph.to_dot t file + let buf = Buffer.create 1024 in + Graph.to_dot t buf >>= fun () -> + Lwt_io.with_file ~mode:Lwt_io.output file (fun oc -> + Lwt_io.write oc (Buffer.contents buf) + ) end in Term.(mk graph $ backend $ file) } @@ -373,10 +377,10 @@ let help = { | None -> `Help (`Pager, None) | Some topic -> let topics = "topics" :: cmds in - let conv, _ = Arg.enum (List.rev_map ~f:(fun s -> (s, s)) topics) in + let conv, _ = Arg.enum (List.rev_map (fun s -> (s, s)) topics) in match conv topic with | `Error e -> `Error (false, e) - | `Ok t when t = "topics" -> List.iter ~f:print_endline cmds; `Ok () + | `Ok t when t = "topics" -> List.iter print_endline cmds; `Ok () | `Ok t -> `Help (man_format, Some t) in Term.(ret (pure help $Term.man_format $Term.choice_names $topic)) } @@ -415,7 +419,7 @@ let default = ~doc ~man -let commands = List.map ~f:command [ +let commands = List.map command [ cat; ls_remote; ls_files; diff --git a/lib/FS.ml b/lib/FS.ml index 8009af7ad..34a9db4a8 100644 --- a/lib/FS.ml +++ b/lib/FS.ml @@ -14,9 +14,9 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std open Lwt open Misc.OP +open Printf module LogMake = Log.Make @@ -31,8 +31,8 @@ module type IO = sig val directories: string -> string list Lwt.t val files: string -> string list Lwt.t val rec_files: string -> string list Lwt.t - val read_file: string -> Bigstring.t Lwt.t - val write_file: string -> Bigstring.t -> unit Lwt.t + val read_file: string -> Cstruct.t Lwt.t + val write_file: string -> Cstruct.t -> unit Lwt.t val chmod: string -> int -> unit Lwt.t val stat_info: string -> Cache.stat_info end @@ -83,10 +83,10 @@ module Loose = struct | true -> IO.read_file file >>= fun buf -> try - let value = Value.input (Mstruct.of_bigarray buf) in + let value = Value.input (Mstruct.of_cstruct buf) in return (Some value) with Zlib.Error _ -> - fail (Zlib.Error (file, (Bigstring.to_string buf))) + fail (Zlib.Error (file, (Cstruct.to_string buf))) let write t value = Log.debugf "write"; @@ -96,7 +96,7 @@ module Loose = struct IO.file_exists file >>= function | true -> return sha1 | false -> - let deflated = Misc.deflate_bigstring (Bigstring.of_string inflated) in + let deflated = Misc.deflate_cstruct (Cstruct.of_string inflated) in IO.write_file file deflated >>= fun () -> return sha1 @@ -104,13 +104,13 @@ module Loose = struct Log.debugf "Loose.list %s" root; let objects = root / ".git" / "objects" in IO.directories objects >>= fun objects -> - let objects = List.map ~f:Filename.basename objects in - let objects = List.filter ~f:(fun s -> (s <> "info") && (s <> "pack")) objects in + let objects = List.map Filename.basename objects in + let objects = List.filter (fun s -> (s <> "info") && (s <> "pack")) objects in Lwt_list.map_s (fun prefix -> let dir = root / ".git" / "objects" / prefix in IO.files dir >>= fun suffixes -> - let suffixes = List.map ~f:Filename.basename suffixes in - let objects = List.map ~f:(fun suffix -> + let suffixes = List.map Filename.basename suffixes in + let objects = List.map (fun suffix -> SHA.of_hex (prefix ^ suffix) ) suffixes in return objects @@ -133,9 +133,9 @@ module Packed = struct Log.debugf "list %s" root; let packs = root / ".git" / "objects" / "pack" in IO.files packs >>= fun packs -> - let packs = List.map ~f:Filename.basename packs in - let packs = List.filter ~f:(fun f -> Filename.check_suffix f ".idx") packs in - let packs = List.map ~f:(fun f -> + let packs = List.map Filename.basename packs in + let packs = List.filter (fun f -> Filename.check_suffix f ".idx") packs in + let packs = List.map (fun f -> let p = Filename.chop_suffix f ".idx" in let p = String.sub p 5 (String.length p - 5) in SHA.of_hex p @@ -147,73 +147,71 @@ module Packed = struct let idx_file = "pack-" ^ (SHA.to_hex sha1) ^ ".idx" in pack_dir / idx_file - let indexes = SHA.Table.create () + let indexes = Hashtbl.create 1024 let write_index t sha1 idx = let file = index t sha1 in - if not (Hashtbl.mem indexes sha1) then Hashtbl.add_exn indexes ~key:sha1 ~data:idx; + if not (Hashtbl.mem indexes sha1) then Hashtbl.add indexes sha1 idx; IO.file_exists file >>= function | true -> return_unit | false -> - let buf = Bigbuffer.create 1024 in + let buf = Buffer.create 1024 in Pack_index.add buf idx; - IO.write_file file (Misc.buffer_contents buf) + IO.write_file file (Cstruct.of_string (Buffer.contents buf)) let read_index t sha1 = Log.debugf "read_index %s" (SHA.to_hex sha1); - match Hashtbl.find indexes sha1 with - | Some i -> return i - | None -> + try return (Hashtbl.find indexes sha1) + with Not_found -> let file = index t sha1 in IO.file_exists file >>= function | true -> IO.read_file file >>= fun buf -> - let buf = Mstruct.of_bigarray buf in + let buf = Mstruct.of_cstruct buf in let index = Pack_index.input buf in - Hashtbl.add_exn indexes ~key:sha1 ~data:index; + Hashtbl.add indexes sha1 index; return index | false -> Printf.eprintf "%s does not exist." file; fail (Failure "read_index") - let keys = SHA.Table.create () + let keys = Hashtbl.create 1024 let read_keys t sha1 = Log.debugf "read_keys %s" (SHA.to_hex sha1); - match Hashtbl.find keys sha1 with - | Some k -> return k - | None -> - begin match Hashtbl.find indexes sha1 with - | Some i -> + try return (Hashtbl.find keys sha1) + with Not_found -> + begin + try + let i = Hashtbl.find indexes sha1 in let keys = SHA.Set.of_list (SHA.Map.keys i.Pack_index.offsets) in return keys - | None -> + with Not_found -> let file = index t sha1 in IO.file_exists file >>= function | true -> IO.read_file file >>= fun buf -> - let keys = Pack_index.keys (Mstruct.of_bigarray buf) in + let keys = Pack_index.keys (Mstruct.of_cstruct buf) in return keys | false -> fail (Failure "Git_fs.Packed.read_keys") end >>= fun data -> - Hashtbl.add_exn keys ~key:sha1 ~data; + Hashtbl.add keys sha1 data; return data - let packs = SHA.Table.create () + let packs = Hashtbl.create 8 let read_pack t sha1 = - match Hashtbl.find packs sha1 with - | Some pack -> return pack - | None -> + try return (Hashtbl.find packs sha1) + with Not_found -> let file = file t sha1 in IO.file_exists file >>= function | true -> IO.read_file file >>= fun buf -> read_index t sha1 >>= fun index -> - let pack = Pack.Raw.input (Mstruct.of_bigarray buf) ~index:(Some index) in + let pack = Pack.Raw.input (Mstruct.of_cstruct buf) ~index:(Some index) in let pack = Pack.to_pic pack in - Hashtbl.add_exn packs ~key:sha1 ~data:pack; + Hashtbl.add packs sha1 pack; return pack | false -> Printf.eprintf "No file associated with the pack object %s.\n" (SHA.to_hex sha1); @@ -223,19 +221,18 @@ module Packed = struct let file = file t sha1 in if not (Hashtbl.mem packs sha1) then ( let pack = Pack.to_pic pack in - Hashtbl.add_exn packs ~key:sha1 ~data:pack; + Hashtbl.add packs sha1 pack; ); IO.file_exists file >>= function | true -> return_unit | false -> - let pack = Misc.with_bigbuffer (fun buf -> Pack.Raw.add buf pack) in + let pack = Misc.with_buffer' (fun buf -> Pack.Raw.add buf pack) in IO.write_file file pack let mem_in_pack t pack_sha1 sha1 = - Log.debugf "mem_in_pack %s:%s" - (SHA.to_hex pack_sha1) (SHA.to_hex sha1); + Log.debugf "mem_in_pack %s:%s" (SHA.to_hex pack_sha1) (SHA.to_hex sha1); read_keys t pack_sha1 >>= fun keys -> - return (Set.mem keys sha1) + return (SHA.Set.mem sha1 keys) let read_in_pack t pack_sha1 sha1 = Log.debugf "read_in_pack %s:%s" @@ -246,12 +243,11 @@ module Packed = struct read_pack t pack_sha1 >>= fun pack -> return (Pack.read pack sha1) - let values = SHA.Table.create () + let values = Hashtbl.create 1024 let read t sha1 = - match SHA.Table.find values sha1 with - | Some v -> return (Some v) - | None -> + try return (Some (Hashtbl.find values sha1)) + with Not_found -> begin match Value.Cache.find sha1 with | Some str -> return (Some (Value.input_inflated (Mstruct.of_string str))) | None -> @@ -264,7 +260,7 @@ module Packed = struct end >>= function | None -> return_none | Some v -> - ignore (SHA.Table.add values ~key:sha1 ~data:v); + ignore (Hashtbl.add values sha1 v); return (Some v) let mem t sha1 = @@ -281,7 +277,7 @@ let list t = Loose.list t >>= fun objects -> Packed.list t >>= fun packs -> Misc.list_map_p (fun p -> Packed.read_keys t p) packs >>= fun keys -> - let keys = SHA.Set.(union (of_list objects) (union_list keys)) in + let keys = List.fold_left SHA.Set.union (SHA.Set.of_list objects) keys in let keys = SHA.Set.to_list keys in return keys @@ -291,7 +287,14 @@ let read t sha1 = | Some v -> return (Some v) | None -> Packed.read t sha1 -let read = Memo.general read +let read = + let memo = Hashtbl.create 1024 in + fun t k -> + try Hashtbl.find memo k + with Not_found -> + let v = read t k in + Hashtbl.add memo k v; + v let read_exn t sha1 = read t sha1 >>= function @@ -315,7 +318,7 @@ let contents t = let dump t = contents t >>= fun contents -> - List.iter ~f:(fun (sha1, value) -> + List.iter (fun (sha1, value) -> let typ = Value.type_of value in Printf.eprintf "%s %s\n" (SHA.to_hex sha1) (Object_type.to_string typ); ) contents; @@ -325,14 +328,14 @@ let references t = let refs = t / ".git" / "refs" in IO.rec_files refs >>= fun files -> let n = String.length (t / ".git" / "") in - let refs = List.map ~f:(fun file -> + let refs = List.map (fun file -> let ref = String.sub file n (String.length file - n) in - Reference.of_string ref + Reference.of_raw ref ) files in return refs let file_of_ref t ref = - t / ".git" / Reference.to_string ref + t / ".git" / Reference.to_raw ref let mem_reference t ref = let file = file_of_ref t ref in @@ -350,7 +353,7 @@ let read_reference t ref = IO.file_exists file >>= function | true -> IO.read_file file >>= fun hex -> - let hex = String.strip (Bigstring.to_string hex) in + let hex = String.trim (Cstruct.to_string hex) in return (Some (SHA.Commit.of_hex hex)) | false -> return_none @@ -361,10 +364,10 @@ let read_head t = IO.file_exists file >>= function | true -> IO.read_file file >>= fun str -> - let str = Bigstring.to_string str in - let contents = match String.split ~on:' ' str with + let str = Cstruct.to_string str in + let contents = match Misc.string_split ~on:' ' str with | [sha1] -> Reference.SHA (SHA.Commit.of_hex sha1) - | [_;ref] -> Reference.Ref (Reference.of_string ref) + | [_;ref] -> Reference.Ref (Reference.of_raw ref) | _ -> failwith (sprintf "read_head: %s is not a valid HEAD contents" str) in return (Some contents) @@ -375,7 +378,7 @@ let read_reference_exn t ref = read_reference t ref >>= function | Some s -> return s | None -> - Log.debugf "read_reference_exn: Cannot read %s" (Reference.to_string ref); + Log.debugf "read_reference_exn: Cannot read %s" (Reference.pretty ref); fail Not_found let write t value = @@ -392,16 +395,16 @@ let write_pack t pack = return (Pack.Raw.keys pack) let write_reference t ref sha1 = - let file = t / ".git" / Reference.to_string ref in + let file = t / ".git" / Reference.to_raw ref in let contents = SHA.Commit.to_hex sha1 in - IO.write_file file (Bigstring.of_string contents) + IO.write_file file (Cstruct.of_string contents) let write_head t = function | Reference.SHA sha1 -> write_reference t Reference.head sha1 | Reference.Ref ref -> let file = t / ".git" / "HEAD" in - let contents = sprintf "ref: %s" (Reference.to_string ref) in - IO.write_file file (Bigstring.of_string contents) + let contents = sprintf "ref: %s" (Reference.to_raw ref) in + IO.write_file file (Cstruct.of_string contents) type 'a tree = | Leaf of 'a @@ -426,7 +429,7 @@ let load_filesystem t commit = | Value.Commit c -> aux (`Dir, SHA.of_tree c.Commit.tree) | Value.Tag t -> aux (mode, t.Tag.sha1) | Value.Tree t -> - Misc.list_map_p ~width:10 (fun e -> + Misc.list_map_p (fun e -> aux (e.Tree.perm, e.Tree.node) >>= fun t -> return (e.Tree.name, t) ) t @@ -446,11 +449,12 @@ let iter_blobs t ~f ~init = ) trie let create_file file mode blob = - let blob = Blob.to_string blob in + Log.debugf "create_file %s" file; + let blob = Blob.to_raw blob in match mode with | `Link -> (* Lwt_unix.symlink file ??? *) failwith "TODO" | _ -> - IO.write_file file (Bigstring.of_string blob) >>= fun () -> + IO.write_file file (Cstruct.of_string blob) >>= fun () -> match mode with | `Exec -> IO.chmod file 0o755 | _ -> return_unit @@ -460,7 +464,7 @@ let cache_file t = let read_cache t = IO.read_file (cache_file t) >>= fun buf -> - let buf = Mstruct.of_bigarray buf in + let buf = Mstruct.of_cstruct buf in return (Cache.input buf) let entry_of_file ?root file mode blob = @@ -479,9 +483,11 @@ let entry_of_file ?root file mode blob = let id = Value.sha1 (Value.Blob blob) in let stats = IO.stat_info file in let stage = 0 in - let name = String.chop_prefix_exn ~prefix:(root / "") file in - let entry = { Cache.stats; id; stage; name } in - return (Some entry) + match Misc.string_chop_prefix ~prefix:(root / "") file with + | None -> failwith ("entry_of_file: " ^ file) + | Some name -> + let entry = { Cache.stats; id; stage; name } in + return (Some entry) with Failure _ -> return_none @@ -491,17 +497,17 @@ let write_cache t head = let all = ref 0 in iter_blobs t ~init:head ~f:(fun (i,n) path mode blob -> all := n; - printf "\rChecking out files: %d%% (%d/%d), done.%!" Int.(100*i/n) i n; - let file = String.concat ~sep:Filename.dir_sep path in + printf "\rChecking out files: %d%% (%d/%d), done.%!" Pervasives.(100*i/n) i n; + let file = String.concat Filename.dir_sep path in Log.debugf "write_cache: blob:%s" file; entry_of_file ~root:t file mode blob >>= function | None -> return_unit | Some e -> entries := e :: !entries; return_unit ) >>= fun () -> let cache = { Cache.entries = !entries; extensions = [] } in - let buf = Bigbuffer.create 1024 in + let buf = Buffer.create 1024 in Cache.add buf cache; - IO.write_file (cache_file t) (Misc.buffer_contents buf) >>= fun () -> + IO.write_file (cache_file t) (Cstruct.of_string (Buffer.contents buf)) >>= fun () -> printf "\rChecking out files: 100%% (%d/%d), done.%!\n" !all !all; return_unit diff --git a/lib/FS.mli b/lib/FS.mli index f1f31e0f8..9f380eba7 100644 --- a/lib/FS.mli +++ b/lib/FS.mli @@ -16,8 +16,6 @@ (** Store Git objects on the local filesystem. *) -open Core_kernel.Std - module type S = sig include Store.S @@ -61,11 +59,11 @@ module type IO = sig val rec_files: string -> string list Lwt.t (** List of the subfiles, recursively. *) - val read_file: string -> Bigstring.t Lwt.t + val read_file: string -> Cstruct.t Lwt.t (** mmap a file and return a mutable C-like structure with its contents. *) - val write_file: string -> Bigstring.t -> unit Lwt.t + val write_file: string -> Cstruct.t -> unit Lwt.t (** Write a bigarray to a file. *) val chmod: string -> int -> unit Lwt.t diff --git a/lib/META b/lib/META index ed8024ebd..5802455c6 100644 --- a/lib/META +++ b/lib/META @@ -1,9 +1,9 @@ # OASIS_START -# DO NOT EDIT (digest: da6a915f8c1a760c9ea0e7b0c2d8b639) +# DO NOT EDIT (digest: 3a1de1ea966dac0d0c40c26e3713897e) version = "1.2.0" description = "A low-level interface to Git in pure OCaml" requires = -"mstruct dolog core_kernel ocamlgraph re.pcre zip sha uri lwt conduit.lwt uri.services" +"mstruct dolog ocamlgraph re.pcre zip sha uri lwt conduit.lwt uri.services" archive(byte) = "git.cma" archive(byte, plugin) = "git.cma" archive(native) = "git.cmxa" diff --git a/lib/SHA.ml b/lib/SHA.ml index ecc48e069..ac8a5dbaa 100644 --- a/lib/SHA.ml +++ b/lib/SHA.ml @@ -14,31 +14,45 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std +open Sexplib.Std + module Log = Log.Make(struct let section = "sha1" end) module type S = sig include Object.S val create: string -> t + val to_raw: t -> string + val of_raw: string -> t val to_hex: t -> string val of_hex: string -> t val input_hex: Mstruct.t -> t - val add_hex: Bigbuffer.t -> t -> unit + val add_hex: Buffer.t -> t -> unit val zero: t + module Set: Misc.Set with type elt = t + module Map: Misc.Map with type key = t end module SHA1_String = struct - include (String: Identifiable.S) + type t = string + + let equal x y = (x=y) + + let hash x = Hashtbl.hash x + + let compare x y = String.compare x y - let create str = - of_string (Sha1.(to_bin (string str))) + let to_raw x = x + + let of_raw x = x + + let create str = Sha1.(to_bin (string str)) let to_hex t = - Misc.hex_encode (to_string t) + Misc.hex_encode t let of_hex h = - of_string (Misc.hex_decode h) + Misc.hex_decode h let zero = of_hex (String.make 40 '0') @@ -53,17 +67,22 @@ module SHA1_String = struct let input buf = Mstruct.get_string buf 20 - |> of_string let add buf t = - Bigbuffer.add_string buf (to_string t) + Buffer.add_string buf t let input_hex buf = of_hex (Mstruct.get_string buf (Mstruct.length buf)) let add_hex buf t = - Bigbuffer.add_string buf (to_hex t) - + Buffer.add_string buf (to_hex t) + + module X = struct + type t = string with sexp + let compare = String.compare + end + module Map = Misc.Map(X) + module Set = Misc.Set(X) end include (SHA1_String: S) @@ -72,9 +91,9 @@ module Commit: S = SHA1_String module Tree: S = SHA1_String module Blob: S = SHA1_String -let of_commit c = of_string (Commit.to_string c) -let to_commit n = Commit.of_string (to_string n) -let of_tree t = of_string (Tree.to_string t) -let to_tree n = Tree.of_string (to_string n) -let of_blob b = of_string (Blob.to_string b) -let to_blob n = Blob.of_string (to_string n) +let of_commit c = of_raw (Commit.to_raw c) +let to_commit n = Commit.of_raw (to_raw n) +let of_tree t = of_raw (Tree.to_raw t) +let to_tree n = Tree.of_raw (to_raw n) +let of_blob b = of_raw (Blob.to_raw b) +let to_blob n = Blob.of_raw (to_raw n) diff --git a/lib/SHA.mli b/lib/SHA.mli index ba05f0f32..49ab32651 100644 --- a/lib/SHA.mli +++ b/lib/SHA.mli @@ -14,8 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std - module type S = sig (** Signature for SHA1 values *) @@ -25,6 +23,12 @@ module type S = sig val create: string -> t (** Build a node from a raw bigstring. *) + val to_raw: t -> string + (** Raw SHA1 value. *) + + val of_raw: string -> t + (** Abstract a raw SHA1 value. *) + val to_hex: t -> string (** Display the hex encoding of the SHA1 hash. *) @@ -34,14 +38,16 @@ module type S = sig val input_hex: Mstruct.t -> t (** Read an hex-encode SHA1 value. *) - val add_hex: Bigbuffer.t -> t -> unit + val add_hex: Buffer.t -> t -> unit (** Add the hex-encoding of the SHA1 value to the buffer. *) val zero: t (** A SHA1 full of zero. Useful for padding. *) -end + module Set: Misc.Set with type elt = t + module Map: Misc.Map with type key = t +end (** Unique object identifiers using SHA1. *) diff --git a/lib/blob.ml b/lib/blob.ml index 71bded477..07795ec66 100644 --- a/lib/blob.ml +++ b/lib/blob.ml @@ -14,17 +14,26 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std +open Printf +open Sexplib.Std + module Log = Log.Make(struct let section = "blob" end) -include String +include Misc.S + +let hash = Hashtbl.hash + +let equal x y = String.compare x y = 0 let pretty t = - if Int.(String.length t < 70) then sprintf "%S" t + if String.length t < 70 then sprintf "%S" t else sprintf "%S[%d]" (String.sub t 0 70) (String.length t) let input buf = Mstruct.get_string buf (Mstruct.length buf) let add buf t = - Bigbuffer.add_string buf t + Buffer.add_string buf t + +let to_raw x = x +let of_raw x = x diff --git a/lib/blob.mli b/lib/blob.mli index 976a3662c..b8020fac6 100644 --- a/lib/blob.mli +++ b/lib/blob.mli @@ -17,3 +17,6 @@ (** Binaray blobs. *) include Object.S + +val to_raw: t -> string +val of_raw: string -> t diff --git a/lib/cache.ml b/lib/cache.ml index 850748a04..514fb6347 100644 --- a/lib/cache.ml +++ b/lib/cache.ml @@ -17,38 +17,40 @@ (* XXX: we only implement index file cache format V2 *) open Lwt -open Core_kernel.Std +open Printf +open Sexplib.Std + module Log = Log.Make(struct let section = "cache" end) type time = { - lsb32: Int32.t; - nsec : Int32.t; -} with bin_io, compare, sexp + lsb32: int32; + nsec : int32; +} with sexp type mode = [ `Normal | `Exec | `Link | `Gitlink -] with bin_io, compare, sexp +] with sexp type stat_info = { ctime: time; mtime: time; - dev : Int32.t; - inode: Int32.t; + dev : int32; + inode: int32; mode : mode; - uid : Int32.t; - gid : Int32.t; - size : Int32.t; -} with bin_io, compare, sexp + uid : int32; + gid : int32; + size : int32; +} with sexp type entry = { stats : stat_info; id : SHA.t; stage : int; name : string; -} with bin_io, compare, sexp +} with sexp let pretty_entry t = sprintf @@ -65,23 +67,22 @@ let pretty_entry t = t.stats.uid t.stats.gid t.stats.size t.stage -module T = struct - type t = { - entries : entry list; - extensions: (Int32.t * string) list; - } - with bin_io, compare, sexp - let hash (t: t) = Hashtbl.hash t - include Sexpable.To_stringable (struct type nonrec t = t with sexp end) - let module_name = "Cache" -end -include T -include Identifiable.Make (T) +type t = { + entries : entry list; + extensions: (int32 * string) list; +} +with sexp + +let hash = Hashtbl.hash + +let compare = compare + +let equal = (=) let pretty t = let buf = Buffer.create 1024 in - List.iter ~f:(fun e -> - Buffer.add_string buf (pretty_entry e) + List.iter (fun e -> + Buffer.add_string buf (Sexplib.Sexp.to_string_hum (sexp_of_entry e)) ) t.entries; Buffer.contents buf @@ -168,21 +169,23 @@ let add_entry buf t = let pad = match len mod 8 with | 0 -> 0 | n -> 8-n in - let mstr = Mstruct.create (len+pad) in - add_stat_info mstr t.stats; - Mstruct.set_string mstr (SHA.to_string t.id); - let flags = (t.stage lsl 12 + String.length t.name) land 0x3FFF in - Mstruct.set_be_uint16 mstr flags; - Mstruct.set_string mstr t.name; - Mstruct.set_string mstr (String.make (1+pad) '\x00'); - let str = mstr |> Mstruct.to_bigarray |> Bigstring.to_string in - Bigbuffer.add_string buf str + let cstr = Cstruct.create (len+pad) in + Mstruct.with_mstruct cstr (fun mstr -> + add_stat_info mstr t.stats; + Mstruct.set_string mstr (SHA.to_raw t.id); + let flags = (t.stage lsl 12 + String.length t.name) land 0x3FFF in + Mstruct.set_be_uint16 mstr flags; + Mstruct.set_string mstr t.name; + Mstruct.set_string mstr (String.make (1+pad) '\x00'); + ); + Buffer.add_string buf (Cstruct.to_string cstr) let input_extensions _buf = (* TODO: actually read the extension contents *) [] let input buf = + let all = Mstruct.to_cstruct buf in let offset = Mstruct.offset buf in let total_length = Mstruct.length buf in let header = Mstruct.get_string buf 4 in @@ -198,19 +201,18 @@ let input buf = if Int32.(n = 0l) then List.rev acc else let entry = input_entry buf in - loop (entry :: acc) Int32.(n - 1l) in + loop (entry :: acc) Int32.(sub n 1l) in loop [] n in let extensions = input_extensions buf in let length = Mstruct.offset buf - offset in - if Int.(length <> total_length - 20) then ( + if length <> total_length - 20 then ( eprintf "Cache.input: more data to read! (total:%d current:%d)" (total_length - 20) length; failwith "Cache.input" ); let actual_checksum = - buf - |> Mstruct.to_bigarray - |> Bigstring.To_string.sub ~pos:offset ~len:length + Cstruct.sub all offset length + |> Cstruct.to_string |> SHA.create in let checksum = SHA.input buf in if SHA.(actual_checksum <> checksum) then ( @@ -223,14 +225,15 @@ let add buf t = let str = Misc.with_buffer (fun buf -> let n = List.length t.entries in Log.debugf "add %d entries" n; - let header = Mstruct.create 12 in - Mstruct.set_string header "DIRC"; - Mstruct.set_be_uint32 header 2l; - Mstruct.set_be_uint32 header (Int32.of_int_exn n); - let str = header |> Mstruct.to_bigarray |> Bigstring.to_string in - Bigbuffer.add_string buf str; - List.iter ~f:(add_entry buf) t.entries; + let header = Cstruct.create 12 in + Mstruct.with_mstruct header (fun header -> + Mstruct.set_string header "DIRC"; + Mstruct.set_be_uint32 header 2l; + Mstruct.set_be_uint32 header (Int32.of_int n); + ); + Buffer.add_string buf (Cstruct.to_string header); + List.iter (add_entry buf) t.entries; ) in let sha1 = SHA.create str in - Bigbuffer.add_string buf str; - Bigbuffer.add_string buf (SHA.to_string sha1) + Buffer.add_string buf str; + Buffer.add_string buf (SHA.to_raw sha1) diff --git a/lib/commit.ml b/lib/commit.ml index 0160aacac..3b5f33670 100644 --- a/lib/commit.ml +++ b/lib/commit.ml @@ -14,23 +14,24 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std +open Printf +open Sexplib.Std + module Log = Log.Make(struct let section = "commit" end) -module T = struct - type t = { - tree : SHA.Tree.t; - parents : SHA.Commit.t list; - author : User.t; - committer: User.t; - message : string; - } with bin_io, compare, sexp - let hash (t : t) = Hashtbl.hash t - include Sexpable.To_stringable (struct type nonrec t = t with sexp end) - let module_name = "Commit" -end -include T -include Identifiable.Make (T) +type t = { + tree : SHA.Tree.t; + parents : SHA.Commit.t list; + author : User.t; + committer: User.t; + message : string; +} with sexp + +let hash = Hashtbl.hash + +let compare = compare + +let equal = (=) let pretty t = sprintf @@ -40,29 +41,29 @@ let pretty t = committer: %s\n\n\ %s\n" (SHA.Tree.to_hex t.tree) - (String.concat ~sep:", " (List.map ~f:SHA.Commit.to_hex t.parents)) + (String.concat ", " (List.map SHA.Commit.to_hex t.parents)) (User.pretty t.author) (User.pretty t.committer) - (String.strip t.message) + (String.trim t.message) let add_parent buf parent = - Bigbuffer.add_string buf "parent "; + Buffer.add_string buf "parent "; SHA.Commit.add_hex buf parent; - Bigbuffer.add_char buf Misc.lf + Buffer.add_char buf Misc.lf let add buf t = - Bigbuffer.add_string buf "tree "; + Buffer.add_string buf "tree "; SHA.Tree.add_hex buf t.tree; - Bigbuffer.add_char buf Misc.lf; - List.iter ~f:(add_parent buf) t.parents; - Bigbuffer.add_string buf "author "; + Buffer.add_char buf Misc.lf; + List.iter (add_parent buf) t.parents; + Buffer.add_string buf "author "; User.add buf t.author; - Bigbuffer.add_char buf Misc.lf; - Bigbuffer.add_string buf "committer "; + Buffer.add_char buf Misc.lf; + Buffer.add_string buf "committer "; User.add buf t.committer; - Bigbuffer.add_char buf Misc.lf; - Bigbuffer.add_char buf Misc.lf; - Bigbuffer.add_string buf t.message + Buffer.add_char buf Misc.lf; + Buffer.add_char buf Misc.lf; + Buffer.add_string buf t.message let input_parents buf = let rec aux parents = diff --git a/lib/git_mirage.ml b/lib/git_mirage.ml index a82ea2c23..96f472e59 100644 --- a/lib/git_mirage.ml +++ b/lib/git_mirage.ml @@ -14,20 +14,17 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std open Lwt open Git module Log = Log.Make(struct let section = "mirage" end) - module type FS = sig include V1_LWT.FS with type page_aligned_buffer = Cstruct.t val connect: unit -> [`Error of error | `Ok of t ] Lwt.t val string_of_error: error -> string end - module FS (FS: FS) = struct let (>>|) x f = @@ -41,14 +38,13 @@ module FS (FS: FS) = struct module M = struct let file_exists t f = - Log.debugf "file_exists %S" f; + Log.debugf "file_exists %s" f; FS.stat t f >>= function | `Ok _ -> return true - | `Error e -> - Log.errorf "%s" (FS.string_of_error e); - return false + | `Error _ -> return false let is_directory t dir = + Log.debugf "is_directory %s" dir; FS.stat t dir >>| fun s -> return s.FS.directory @@ -57,6 +53,8 @@ module FS (FS: FS) = struct | "." -> None | s -> Some (Filename.dirname s) + let mkdir_pool = Lwt_pool.create 1 (fun () -> return_unit) + let mkdir t dirname = Log.debugf "mkdir %s" dirname; let rec aux dir = @@ -67,20 +65,18 @@ module FS (FS: FS) = struct | None -> return_unit | Some d -> aux d >>= fun () -> - file_exists t dir >>= function - | true -> return_unit - | false -> - FS.mkdir t dir >>| fun () -> - return_unit + FS.mkdir t dir >>| fun () -> + return_unit in - aux dirname + Lwt_pool.use mkdir_pool (fun () -> aux dirname) let list_files t kind dir = + Log.debugf "list_files %s" dir; file_exists t dir >>= function | true -> FS.listdir t dir >>| fun l -> - let l = List.filter ~f:(fun s -> s <> "." && s <> "..") l in - let l = List.map ~f:(Filename.concat dir) l in + let l = List.filter (fun s -> s <> "." && s <> "..") l in + let l = List.map (Filename.concat dir) l in Lwt_list.filter_s kind l | false -> return_nil @@ -121,16 +117,15 @@ module FS (FS: FS) = struct let read_file t file = Log.debugf "read_file %s" file; FS.stat t file >>| fun s -> - FS.read t file 0 (Int64.to_int_exn s.FS.size) >>| fun bs -> + FS.read t file 0 (Int64.to_int s.FS.size) >>| fun bs -> let s = Cstruct.copyv bs in - return (Bigstring.of_string s) + return (Cstruct.of_string s) let write_file t file b = - Log.debugf "write_file %s %S" file (Bigstring.to_string b); + Log.debugf "write_file %s" file; mkdir t (Filename.dirname file) >>= fun () -> - let c = Cstruct.of_bigarray b in FS.create t file >>| fun () -> - FS.write t file 0 c >>| fun () -> + FS.write t file 0 b >>| fun () -> return_unit let getcwd () = @@ -140,7 +135,7 @@ module FS (FS: FS) = struct return dir let realpath file = - realdir file + return file let stat_info file = failwith "TODO" @@ -148,12 +143,8 @@ module FS (FS: FS) = struct let chmod t file perm = return_unit - let mutex = Lwt_mutex.create () - let connect fn = - Lwt_mutex.with_lock mutex (fun () -> - FS.connect () >>| fn - ) + FS.connect () >>| fn let mkdir dir = connect (fun t -> mkdir t dir) diff --git a/lib/git_mirage.mli b/lib/git_mirage.mli index 3bb643d37..63ceeb29f 100644 --- a/lib/git_mirage.mli +++ b/lib/git_mirage.mli @@ -17,8 +17,6 @@ (** Mirage implementation of the Git file-system backend and protocol. *) -open Core_kernel.Std - module type FS = sig include V1_LWT.FS with type page_aligned_buffer = Cstruct.t diff --git a/lib/git_unix.ml b/lib/git_unix.ml index 8c0dddefb..8f44775b8 100644 --- a/lib/git_unix.ml +++ b/lib/git_unix.ml @@ -14,11 +14,16 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std open Lwt open Git +open Printf + module Log = Log.Make(struct let section = "unix" end) +(* Pool of opened files *) +let openfile_pool = Lwt_pool.create 200 (fun () -> return_unit) +let mkdir_pool = Lwt_pool.create 1 (fun () -> return_unit) + module M = struct type ic = Lwt_io.input_channel @@ -42,7 +47,7 @@ module M = struct let cmd = match init with | None -> [| "ssh"; user ^ host; |] | Some x -> [| "ssh"; user ^ host; x |] in - Log.debugf "Executing %s" (String.concat ~sep:" " (Array.to_list cmd)); + Log.debugf "Executing %s" (String.concat " " (Array.to_list cmd)); let env = Unix.environment () in let p = Lwt_process.open_process_full ~env ("ssh", cmd) in Lwt.finalize @@ -88,15 +93,10 @@ module D = struct if Sys.file_exists dir then return_unit else ( aux (Filename.dirname dir) >>= fun () -> - if Sys.file_exists dir then return_unit - else - catch - (fun () -> - Log.debugf "mkdir %s" dir; - Lwt_unix.mkdir dir 0o755) - (fun _ -> return_unit) + Log.debugf "mkdir %s" dir; + Lwt_unix.mkdir dir 0o755 ) in - aux dirname + Lwt_pool.use mkdir_pool (fun () -> aux dirname) let list_files kind dir = if Sys.file_exists dir then ( @@ -122,13 +122,13 @@ module D = struct Lwt_list.fold_left_s aux (fs @ accu) ds in aux [] dir - let write_bigstring fd b = + let write_cstruct fd b = let rec rwrite fd buf ofs len = Lwt_bytes.write fd buf ofs len >>= fun n -> if n = 0 then fail End_of_file else if n < len then rwrite fd buf (ofs + n) (len - n) else return () in - rwrite fd b 0 (Bigstring.length b) + rwrite fd (Cstruct.to_bigarray b) 0 (Cstruct.len b) let write_string fd b = let rec rwrite fd buf ofs len = @@ -141,23 +141,25 @@ module D = struct let with_write_file file fn = Log.infof "Writing %s" file; mkdir (Filename.dirname file) >>= fun () -> - Lwt_unix.(openfile file [O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC] 0o644) >>= fun fd -> - catch - (fun () -> fn fd >>= fun () -> Lwt_unix.close fd) - (fun _ -> Lwt_unix.close fd) + Lwt_pool.use openfile_pool (fun () -> + Lwt_unix.(openfile file [O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC] 0o644) >>= fun fd -> + catch + (fun () -> fn fd >>= fun () -> Lwt_unix.close fd) + (fun _ -> Lwt_unix.close fd)) let write_file file b = - with_write_file file (fun fd -> write_bigstring fd b) + with_write_file file (fun fd -> write_cstruct fd b) let read_file file = - let open Lwt in Log.infof "Reading %s" file; Unix.handle_unix_error (fun () -> - let fd = Unix.(openfile file [O_RDONLY; O_NONBLOCK] 0o644) in - let ba = Lwt_bytes.map_file ~fd ~shared:false () in - Unix.close fd; - return ba - ) () + Lwt_pool.use openfile_pool (fun () -> + let fd = Unix.(openfile file [O_RDONLY; O_NONBLOCK] 0o644) in + let ba = Lwt_bytes.map_file ~fd ~shared:false () in + Unix.close fd; + return (Cstruct.of_bigarray ba) + )) + () let realdir dir = if Sys.file_exists dir then ( @@ -182,16 +184,16 @@ module D = struct let stats = Unix.stat path in let ctime = { lsb32 = Int32.of_float stats.Unix.st_ctime; nsec = 0l } in let mtime = { lsb32 = Int32.of_float stats.Unix.st_mtime; nsec = 0l } in - let dev = Int32.of_int_exn stats.Unix.st_dev in - let inode = Int32.of_int_exn stats.Unix.st_ino in + let dev = Int32.of_int stats.Unix.st_dev in + let inode = Int32.of_int stats.Unix.st_ino in let mode = match stats.Unix.st_kind, stats.Unix.st_perm with | Unix.S_REG, 0o755 -> `Exec | Unix.S_REG, 0o644 -> `Normal | Unix.S_LNK, _ -> `Link | _ -> failwith (path ^ ": not supported kind of file.") in - let uid = Int32.of_int_exn stats.Unix.st_uid in - let gid = Int32.of_int_exn stats.Unix.st_gid in - let size = Int32.of_int_exn stats.Unix.st_size in + let uid = Int32.of_int stats.Unix.st_uid in + let gid = Int32.of_int stats.Unix.st_gid in + let size = Int32.of_int stats.Unix.st_size in { ctime; mtime; dev; inode; uid; gid; mode; size } let file_exists f = diff --git a/lib/git_unix.mli b/lib/git_unix.mli index 8f35c0320..c1b9ada16 100644 --- a/lib/git_unix.mli +++ b/lib/git_unix.mli @@ -16,7 +16,6 @@ (** Lwt_unix IO module. *) -open Core_kernel.Std open Git (** {2 Synchronisation primitives} *) diff --git a/lib/global_graph.ml b/lib/global_graph.ml index 8d04d3d23..7f2302142 100644 --- a/lib/global_graph.ml +++ b/lib/global_graph.ml @@ -14,7 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std open Lwt let to_string node = @@ -25,9 +24,9 @@ module C = Graph.Imperative.Digraph.ConcreteBidirectionalLabeled (struct type t = (SHA.t * Value.t) - let compare (x,_) (y,_) = String.compare (SHA.to_string x) (SHA.to_string y) - let hash (x,_) = Hashtbl.hash (SHA.to_string x) - let equal (x,_) (y,_) = (x = y) + let compare (x,_) (y,_) = SHA.compare x y + let hash (x,_) = SHA.hash x + let equal (x,_) (y,_) = SHA.equal x y end) (struct type t = string @@ -75,7 +74,7 @@ module Make (Store: Store.S) = struct Log.debugf "of_contents"; let g = C.create () in Store.contents t >>= fun nodes -> - List.iter ~f:(C.add_vertex g) nodes; + List.iter (C.add_vertex g) nodes; begin Misc.list_iter_p (fun (id, _ as src) -> Search.succ t id >>= fun succs -> @@ -97,7 +96,7 @@ module Make (Store: Store.S) = struct Log.debugf "of_keys"; let g = K.create () in Store.contents t >>= fun nodes -> - List.iter ~f:(fun (k, _) -> K.add_vertex g k) nodes; + List.iter (fun (k, _) -> K.add_vertex g k) nodes; begin Misc.list_iter_p (fun (src, _) -> Search.succ t src >>= fun succs -> @@ -110,18 +109,19 @@ module Make (Store: Store.S) = struct end >>= fun () -> return g - let to_dot t file = + let to_dot t buf = Log.debugf "to_dot"; + let fmt = Format.formatter_of_buffer buf in of_contents t >>= fun g -> - Out_channel.with_file file ~f:(fun oc -> Dot.output_graph oc g); + Dot.fprint_graph fmt g; return_unit (* XXX: From IrminGraph.closure *) let closure t ~min max = Log.debugf "closure"; let g = K.create ~size:1024 () in - let marks = SHA.Table.create () in - let mark key = Hashtbl.add_exn marks key true in + let marks = Hashtbl.create 1024 in + let mark key = Hashtbl.add marks key true in let has_mark key = Hashtbl.mem marks key in let min = SHA.Set.to_list min in Lwt_list.iter_p (fun k -> @@ -142,8 +142,8 @@ module Make (Store: Store.S) = struct | true -> if not (K.mem_vertex g key) then K.add_vertex g key; Search.succ t key >>= fun succs -> - let keys = List.map ~f:Search.sha1_of_succ succs in - List.iter ~f:(fun k -> K.add_edge g k key) keys; + let keys = List.map Search.sha1_of_succ succs in + List.iter (fun k -> K.add_edge g k key) keys; Lwt_list.iter_p add keys ) in let max = SHA.Set.to_list max in diff --git a/lib/global_graph.mli b/lib/global_graph.mli index 5419e4463..4cfce6577 100644 --- a/lib/global_graph.mli +++ b/lib/global_graph.mli @@ -32,7 +32,8 @@ module Make (S: Store.S): sig val pack: S.t -> min:SHA.Set.t -> SHA.Set.t -> Pack.t Lwt.t (** Return a packed (closed) collection of objects. *) - val to_dot: S.t -> string -> unit Lwt.t - (** Create a `.dot` file describing the Git graph. *) + val to_dot: S.t -> Buffer.t -> unit Lwt.t + (** [to_dot g buffer] fille [buffer] with the `.dot` representation + of the Git graph. *) end diff --git a/lib/gri.ml b/lib/gri.ml index a7bc2f08b..bd8d8efa9 100644 --- a/lib/gri.ml +++ b/lib/gri.ml @@ -14,8 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std - type t = Uri.t let to_uri x = x @@ -26,11 +24,11 @@ let of_string str = match Uri.host uri with | Some _ -> uri | None -> - match String.lsplit2 str ~on:':' with + match Misc.string_lsplit2 str ~on:':' with | None -> uri | Some (host, path) -> let userinfo, host = - match String.lsplit2 host ~on:'@' with + match Misc.string_lsplit2 host ~on:'@' with | None -> None , host | Some (a,b) -> Some a, b in let scheme = "git+ssh" in diff --git a/lib/memory.ml b/lib/memory.ml index 9721fc687..a90b98afd 100644 --- a/lib/memory.ml +++ b/lib/memory.ml @@ -14,7 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std open Lwt module Log = Log.Make(struct let section = "memory" end) @@ -28,22 +27,22 @@ type t = { let root t = t.root -let stores = String.Table.create () +let stores = Hashtbl.create 1024 let create ?root () = let root = match root with | None -> "root" | Some r -> r in - let t = match Hashtbl.find stores root with - | Some t -> t - | None -> + let t = + try Hashtbl.find stores root + with Not_found -> let t = { root; - values = SHA.Table.create (); - refs = Reference.Table.create (); + values = Hashtbl.create 1024; + refs = Hashtbl.create 8; head = None; } in - Hashtbl.add_exn stores ~key:root ~data:t; + Hashtbl.add stores root t; t in return t @@ -54,11 +53,12 @@ let clear t = let write t value = let inflated = Misc.with_buffer (fun buf -> Value.add_inflated buf value) in let sha1 = SHA.create inflated in - match Hashtbl.find t.values sha1 with - | Some _ -> return sha1 - | None -> + try + let _ = Hashtbl.find t.values sha1 in + return sha1 + with Not_found -> Log.infof "Writing %s" (SHA.to_hex sha1); - Hashtbl.add_exn t.values sha1 value; + Hashtbl.add t.values sha1 value; return sha1 let write_pack t pack = @@ -72,13 +72,15 @@ let write_pack t pack = >>= fun () -> return (Pack.keys pack) +let keys t = + Hashtbl.fold (fun k _ l -> k :: l) t [] + let list t = - return (Hashtbl.keys t.values) + return (keys t.values) let read t sha1 = - match Hashtbl.find t.values sha1 with - | Some _ as v -> return v - | None -> return_none + try return (Some (Hashtbl.find t.values sha1)) + with Not_found -> return_none let mem t sha1 = return (Hashtbl.mem t.values sha1) @@ -103,21 +105,22 @@ let contents t = let dump t = contents t >>= fun contents -> - List.iter ~f:(fun (sha1, value) -> + List.iter (fun (sha1, value) -> let typ = Value.type_of value in Printf.eprintf "%s %s\n" (SHA.to_hex sha1) (Object_type.to_string typ) ) contents; return_unit let references t = - return (Hashtbl.keys t.refs) + return (keys t.refs) let mem_reference t ref = return (Hashtbl.mem t.refs ref) let read_reference t ref = - Log.infof "Reading %s" (Reference.to_string ref); - return (Hashtbl.find t.refs ref) + Log.infof "Reading %s" (Reference.pretty ref); + try return (Some (Hashtbl.find t.refs ref)) + with Not_found -> return_none let read_head t = Log.infof "Reading HEAD"; @@ -138,7 +141,7 @@ let write_head t c = return_unit let write_reference t ref sha1 = - Log.infof "Writing %s" (Reference.to_string ref); + Log.infof "Writing %s" (Reference.pretty ref); Hashtbl.replace t.refs ref sha1; return_unit diff --git a/lib/misc.ml b/lib/misc.ml index 484ebf722..e64c9eee5 100644 --- a/lib/misc.ml +++ b/lib/misc.ml @@ -14,7 +14,8 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std +open Sexplib.Std + module Log = Log.Make(struct let section = "misc" end) (* From OCaml's stdlib. See [Digest.to_hex] *) @@ -36,16 +37,16 @@ let hex_decode h = ); let digit c = match c with - | '0'..'9' -> Char.to_int c - Char.to_int '0' - | 'A'..'F' -> Char.to_int c - Char.to_int 'A' + 10 - | 'a'..'f' -> Char.to_int c - Char.to_int 'a' + 10 + | '0'..'9' -> Char.code c - Char.code '0' + | 'A'..'F' -> Char.code c - Char.code 'A' + 10 + | 'a'..'f' -> Char.code c - Char.code 'a' + 10 | c -> let msg = Printf.sprintf "hex_decode: %S is invalid" (String.make 1 c) in raise (Invalid_argument msg) in let byte i = digit h.[i] lsl 4 + digit h.[i+1] in let result = String.create (n / 2) in for i = 0 to n/2 - 1 do - result.[i] <- Char.of_int_exn (byte (2 * i)); + result.[i] <- Char.chr (byte (2 * i)); done; result @@ -92,57 +93,44 @@ let uncompress_with_size ?header refill flush = !used_in let refill input = - let n = Bigstring.length input in + let n = Cstruct.len input in let toread = ref n in fun buf -> let m = min !toread (String.length buf) in - Bigstring.To_string.blit input (n - !toread) buf 0 m; + Cstruct.blit_to_string input (n - !toread) buf 0 m; toread := !toread - m; m let flush output buf len = - Bigbuffer.add_substring output buf 0 len - -let buffer_contents buf = - let len = Bigbuffer.length buf in - Bigstring.sub_shared ~len (Bigbuffer.volatile_contents buf) - -let bigstring_concat buffers = - let buf = Bigbuffer.create 1024 in - List.iter ~f:(fun b -> - Bigbuffer.add_string buf (Bigstring.to_string b) - ) buffers; - buffer_contents buf + Buffer.add_substring output buf 0 len -let deflate_bigstring input = - let output = Bigbuffer.create (Bigstring.length input) in +let deflate_cstruct input = + let output = Buffer.create (Cstruct.len input) in Zlib.compress (refill input) (flush output); - buffer_contents output + Cstruct.of_string (Buffer.contents output) let deflate_mstruct buf = - let inflated = Mstruct.to_bigarray buf in - let deflated = deflate_bigstring inflated in - Mstruct.of_bigarray deflated + let inflated = Mstruct.to_cstruct buf in + let deflated = deflate_cstruct inflated in + Mstruct.of_cstruct deflated let inflate_mstruct orig_buf = let buf = Mstruct.clone orig_buf in - let output = Bigbuffer.create (Mstruct.length orig_buf) in + let output = Buffer.create (Mstruct.length orig_buf) in let refill input = let n = min (Mstruct.length buf) (String.length input) in let s = Mstruct.get_string buf n in String.blit s 0 input 0 n; n in let flush buf len = - Bigbuffer.add_substring output buf 0 len in + Buffer.add_substring output buf 0 len in let size = uncompress_with_size refill flush in - let inflated = buffer_contents output in - let res = Mstruct.of_bigarray inflated in Mstruct.shift orig_buf size; - res + Mstruct.of_string (Buffer.contents output) -let inflate_bigstring str = - let buf = inflate_mstruct (Mstruct.of_bigarray str) in - Mstruct.to_bigarray buf +let inflate_cstruct str = + let buf = inflate_mstruct (Mstruct.of_cstruct str) in + Mstruct.to_cstruct buf let crc32 str = (* XXX: use ocaml-crc ? *) @@ -172,30 +160,30 @@ let input_key_value buf ~key:expected input_value = let str_buffer = String.create 4 let add_be_uint32 buf i = EndianString.BigEndian.set_int32 str_buffer 0 i; - Bigbuffer.add_string buf str_buffer - -let with_bigbuffer fn = - let buf = Bigbuffer.create 1024 in - fn buf; - buffer_contents buf + Buffer.add_string buf str_buffer let with_buffer fn = - let buf = Bigbuffer.create 1024 in + let buf = Buffer.create 1024 in fn buf; - Bigbuffer.contents buf + Buffer.contents buf + +let with_buffer' fn = + Cstruct.of_string (with_buffer fn) open Lwt -let rec list_iter_p ?(width=50) f l = - match List.split_n l width with - | [], [] -> return_unit - | h , t -> - Lwt_list.iter_p f h >>= fun () -> - list_iter_p ~width f t +let list_iter_p ?pool f l = + let pool = match pool with + | None -> Lwt_pool.create 50 (fun () -> return_unit) + | Some p -> p + in + Lwt_list.iter_p (fun x -> + Lwt_pool.use pool (fun () -> f x) + ) l -let list_map_p ?(width=50) f l = +let list_map_p ?pool f l = let res = ref [] in - list_iter_p ~width (fun x -> + list_iter_p ?pool (fun x -> f x >>= fun y -> res := y :: !res; return_unit @@ -209,12 +197,155 @@ module OP = struct end -let map_rev_find map d = - let r = ref None in +let inverse_assoc l = + List.rev_map (fun (k, v) -> (v, k)) l + +let try_assoc elt l = + try Some (List.assoc elt l) + with Not_found -> None + +module type OrderedType = sig + include Set.OrderedType + val sexp_of_t: t -> Sexplib.Type.t + val t_of_sexp: Sexplib.Type.t -> t +end + +module type Set = sig + include Set.S + val sexp_of_t: t -> Sexplib.Type.t + val t_of_sexp: Sexplib.Type.t -> t + val to_list: t -> elt list + val of_list: elt list -> t +end + +module type Map = sig + include Map.S + val sexp_of_t: ('a -> Sexplib.Type.t) -> 'a t -> Sexplib.Type.t + val t_of_sexp: (Sexplib.Type.t -> 'a) -> Sexplib.Type.t -> 'a t + val keys: 'a t -> key list + val to_alist: 'a t -> (key * 'a) list + val of_alist: (key * 'a) list -> 'a t + val add_multi: key -> 'a -> 'a list t -> 'a list t +end + + +module Set (X: OrderedType) = struct + + include Set.Make(X) + + let of_list l = + List.fold_left (fun set elt -> add elt set) empty l + + let to_list = elements + + let sexp_of_t t = + elements t + |> Sexplib.Conv.sexp_of_list X.sexp_of_t + + let t_of_sexp s = + Sexplib.Conv.list_of_sexp X.t_of_sexp s + |> of_list + +end + +module Map (X: OrderedType) = struct + + include Map.Make(X) + + let keys m = + List.map fst (bindings m) + + let of_alist l = + List.fold_left (fun map (k, v) -> add k v map) empty l + + let to_alist = bindings + + let sexp_of_t sexp_of_a t = + bindings t + |> Sexplib.Conv.(sexp_of_list (sexp_of_pair X.sexp_of_t sexp_of_a)) + + let t_of_sexp a_of_sexp s = + Sexplib.Conv.(list_of_sexp (pair_of_sexp X.t_of_sexp a_of_sexp) s) + |> of_alist + + let add_multi key data t = + try + let l = find key t in + add key (data :: l) t + with Not_found -> + add key [data] t + +end + +module I = struct + type t = int with sexp + let compare = compare +end + +module S = struct + type t = string with sexp + let compare = String.compare +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 - Map.iter - ~f:(fun ~key ~data -> if data = d then (r := Some key; raise Exit)) - map; + 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 - with Exit -> - !r + +let string_forall f s = + let rec aux i = i = String.length s || (f s.[i] && aux (i+1)) in + aux 0 + +let string_exists f s = + let rec aux i = i < String.length s && (f s.[i] || aux (i+1)) in + aux 0 + +let string_mem c s = + string_exists ((=) c) s + +let string_chop_prefix t ~prefix = + let lt = String.length t in + let lp = String.length prefix in + if lt < lp then None else + let p = String.sub t 0 lp in + if String.compare p prefix <> 0 then None + else Some (String.sub t lp (lt - lp)) + +let string_chop_suffix t ~suffix = + let lt = String.length t in + let ls = String.length suffix in + if lt < ls then None else + let p = String.sub t (lt-ls) ls in + if String.compare p suffix <> 0 then None + else Some (String.sub t 0 (lt - ls)) + +let list_filter_map f l = + List.fold_left (fun l elt -> + match f elt with + | None -> l + | Some x -> x :: l + ) [] l + |> List.rev diff --git a/lib/misc.mli b/lib/misc.mli index fc16437fb..40111d985 100644 --- a/lib/misc.mli +++ b/lib/misc.mli @@ -16,17 +16,15 @@ (** Miscellaneous functions. *) -open Core_kernel.Std - (** {2 Bounded parallelism} *) -val list_iter_p: ?width:int -> ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t -(** Same as [List_lwt.iter_p] but using a maximum width of - [width]. The default width is 50. *) +val list_iter_p: ?pool:unit Lwt_pool.t -> ('a -> unit Lwt.t) -> 'a list -> unit Lwt.t +(** Same as [List_lwt.iter_p] but using a maximum width equals to the + size of the [pool]. The default width is 50. *) -val list_map_p: ?width:int -> ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t -(** Same as [List_lwt.map_p] but using a maximum width of [width]. The - default width is 50. *) +val list_map_p: ?pool:unit Lwt_pool.t -> ('a -> 'b Lwt.t) -> 'a list -> 'b list Lwt.t +(** Same as [List_lwt.map_p] but using a maximum width equals to the + size of [pool]. The default width is 50. *) (** {2 Hexa encoding} *) @@ -36,44 +34,44 @@ val hex_encode: string -> string val hex_decode: string -> string (** Decode a string from base16. *) -val buffer_contents: Bigbuffer.t -> Bigstring.t -(** zero-copy buffer contents. *) - -val with_bigbuffer: (Bigbuffer.t -> unit) -> Bigstring.t -(** Create a temporarybuffer, apply a function to append stuff to - it, and return the buffer contents as a bigstring. *) - -val with_buffer: (Bigbuffer.t -> unit) -> string +val with_buffer: (Buffer.t -> unit) -> string (** Create a temporary buffer, apply a function to append stuff to it, and return the buffer contents. *) +val with_buffer': (Buffer.t -> unit) -> Cstruct.t +(** Create a temporary buffer, apply a function to append stuff to + it, and return the buffer contents as a cstruct. *) + (** {2 Zlib Compression} *) -val inflate_bigstring: Bigstring.t -> Bigstring.t -(** Inflate a buffer. *) +val inflate_cstruct: Cstruct.t -> Cstruct.t +(** Inflate a cstruct. *) -val deflate_bigstring: Bigstring.t -> Bigstring.t -(** Deflate a big string. *) +val deflate_cstruct: Cstruct.t -> Cstruct.t +(** Deflate a cstruct. *) val inflate_mstruct: Mstruct.t -> Mstruct.t -(** Inflate a buffer. *) +(** Inflate an mstruct. *) val deflate_mstruct: Mstruct.t -> Mstruct.t -(** Deflate a buffer. *) +(** Deflate an mstruct. *) (** {2 CRC-32} *) val crc32: string -> int32 (** Return the CRC-32 value of a bigstring. *) -(** {2 Maps} *) +(** {2 Association lists} *) -val map_rev_find: ('key, 'value, 'cmp) Map.t -> 'value -> 'key option -(** Reverse of [Map.find]. *) +val inverse_assoc: ('a * 'b) list -> ('b * 'a) list +(** Inverse the association map. *) + +val try_assoc: 'a -> ('a * 'b) list -> 'b option +(** Same as [List.assoc] but returns [None] if no element is found. *) (** {2 Marshaling helpers} *) -val add_be_uint32: Bigbuffer.t -> int32 -> unit +val add_be_uint32: Buffer.t -> int32 -> unit val input_key_value: Mstruct.t -> key:string -> (Mstruct.t -> 'a) -> 'a @@ -83,6 +81,48 @@ val lf: char val lt: char val gt: char +module type OrderedType = sig + include Set.OrderedType + val sexp_of_t: t -> Sexplib.Type.t + val t_of_sexp: Sexplib.Type.t -> t +end + +module I: OrderedType with type t = int +module S: OrderedType with type t = string + +module type Set = sig + include Set.S + val sexp_of_t: t -> Sexplib.Type.t + val t_of_sexp: Sexplib.Type.t -> t + val to_list: t -> elt list + val of_list: elt list -> t +end + +module type Map = sig + include Map.S + val sexp_of_t: ('a -> Sexplib.Type.t) -> 'a t -> Sexplib.Type.t + val t_of_sexp: (Sexplib.Type.t -> 'a) -> Sexplib.Type.t -> 'a t + val keys: 'a t -> key list + val to_alist: 'a t -> (key * 'a) list + val of_alist: (key * 'a) list -> 'a t + val add_multi: key -> 'a -> 'a list t -> 'a list t +end + +module Set (X: OrderedType): Set with type elt = X.t +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 +val string_chop_prefix: string -> prefix:string -> string option +val string_chop_suffix: string -> suffix:string -> string option + +val list_filter_map: ('a -> 'b option) -> 'a list -> 'b list + module OP: sig val (/): string -> string -> string diff --git a/lib/object.mli b/lib/object.mli index 4c601351d..547c43258 100644 --- a/lib/object.mli +++ b/lib/object.mli @@ -16,11 +16,18 @@ (** Signatures *) -open Core_kernel.Std - module type S = sig - include Identifiable.S + type t with sexp + + val equal: t -> t -> bool + (** Are two objects equal? *) + + val hash: t -> int + (** Hash an object. *) + + val compare: t -> t -> int + (** Compare two objects. *) val pretty: t -> string (** Human readable represenation of the object. *) @@ -28,7 +35,7 @@ module type S = sig val input: Mstruct.t -> t (** Build a value from an inflated contents. *) - val add: Bigbuffer.t -> t -> unit + val add: Buffer.t -> t -> unit (** Add the serialization of the value to an already existing buffer. *) diff --git a/lib/object_type.ml b/lib/object_type.ml index a4ea35f59..f8569b087 100644 --- a/lib/object_type.ml +++ b/lib/object_type.ml @@ -14,22 +14,18 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std module Log = Log.Make(struct let section = "object-type" end) -module T = struct - type t = - | Blob - | Commit - | Tag - | Tree - with bin_io, compare, sexp - let hash (t: t) = Hashtbl.hash t - include Sexpable.To_stringable (struct type nonrec t = t with sexp end) - let module_name = "Tag" -end -include T -include Identifiable.Make (T) +type t = + | Blob + | Commit + | Tag + | Tree +with sexp + +let hash = Hashtbl.hash +let equal = (=) +let compare = compare let to_string = function | Blob -> "blob" @@ -40,7 +36,7 @@ let to_string = function let pretty = to_string let add buf t = - Bigbuffer.add_string buf (to_string t) + Buffer.add_string buf (to_string t) let of_string = function | "blob" -> Some Blob diff --git a/lib/object_type.mli b/lib/object_type.mli index c0de0b3a7..922282b98 100644 --- a/lib/object_type.mli +++ b/lib/object_type.mli @@ -24,4 +24,6 @@ type t = include Object.S with type t := t +val to_string: t -> string + val of_string: string -> t option diff --git a/lib/pack.ml b/lib/pack.ml index cca8101ab..008cc5dd4 100644 --- a/lib/pack.ml +++ b/lib/pack.ml @@ -15,46 +15,38 @@ *) open Lwt -open Core_kernel.Std +open Sexplib.Std +open Printf -module Bigstring = struct - include Bigstring +module Raw = struct - let compare t1 t2 = - match Int.compare (Bigstring.length t1) (Bigstring.length t2) with - | 0 -> String.compare (Bigstring.to_string t1) (Bigstring.to_string t2) - | i -> i + module Log = Log.Make(struct let section = "pack-raw" end) - let pretty t = - if Int.(Bigstring.length t < 70) then sprintf "%S" (Bigstring.to_string t) - else sprintf "%S[%d]" (Bigstring.To_string.sub t 0 70) (Bigstring.length t) + type t = { + sha1 : SHA.t; + index : Pack_index.t; + buffer : Cstruct.t; + version : int; + checksum: SHA.t; + values : (int * Cstruct.t * Packed_value.t) list; + } with sexp -end + let hash = Hashtbl.hash -module Raw = struct + let compare = compare - module Log = Log.Make(struct let section = "pack-raw" end) - - module T = struct - type t = { - sha1 : SHA.t; - index : Pack_index.t; - buffer : Bigstring.t; - version : int; - checksum: SHA.t; - values : (int * Bigstring.t * Packed_value.t) list; - } with bin_io, compare, sexp - let hash (t: t) = Hashtbl.hash t - include Sexpable.To_stringable (struct type nonrec t = t with sexp end) - let module_name = "Pack.Raw" - end - include T - include Identifiable.Make (T) + let equal t1 t2 = + SHA.equal t1.sha1 t2.sha1 + && Pack_index.equal t1.index t2.index + && t1.buffer = t2.buffer + && t1.version = t2.version + && SHA.equal t1.checksum t2.checksum + && t1.values = t2.values let pretty t = let buf = Buffer.create 128 in bprintf buf "%s\n" (SHA.to_hex t.checksum); - List.iter ~f:(fun (offset, _, p) -> + List.iter (fun (offset, _, p) -> bprintf buf "offset: %d\n%s" offset (Packed_value.pretty p) ) t.values; Buffer.contents buf @@ -63,15 +55,15 @@ module Raw = struct let header = Mstruct.get_string buf 4 in if String.(header <> "PACK") then Mstruct.parse_error_buf buf "wrong header (%s)" header; - let version = Int32.to_int_exn (Mstruct.get_be_uint32 buf) in - if Int.(version <> 2 && version <> 3) then + let version = Int32.to_int (Mstruct.get_be_uint32 buf) in + if version <> 2 && version <> 3 then Mstruct.parse_error_buf buf "wrong pack version (%d)" version; - version, Int32.to_int_exn (Mstruct.get_be_uint32 buf) + version, Int32.to_int (Mstruct.get_be_uint32 buf) let add_header ~version buf count = - Bigbuffer.add_string buf "PACK"; - Misc.add_be_uint32 buf (Int32.of_int_exn version); - Misc.add_be_uint32 buf (Int32.of_int_exn count) + Buffer.add_string buf "PACK"; + Misc.add_be_uint32 buf (Int32.of_int version); + Misc.add_be_uint32 buf (Int32.of_int count) let input_packed_value ~version buf = match version with | 2 -> Packed_value.V2.input buf @@ -89,20 +81,20 @@ module Raw = struct let rec loop (offsets, index) = function | [] -> return index | (pos, raw, p) :: t -> - let raw = Bigstring.to_string raw in + let raw = Cstruct.to_string raw in let crc = Misc.crc32 raw in bind (sha1 ~offsets ~pos p) (fun sha1 -> let index = Pack_index.({ - offsets = SHA.Map.add index.offsets ~key:sha1 ~data:pos; - crcs = SHA.Map.add index.crcs ~key:sha1 ~data:crc; + offsets = SHA.Map.add sha1 pos index.offsets; + crcs = SHA.Map.add sha1 crc index.crcs; pack_checksum; }) in - let offsets = Int.Map.add offsets ~key:pos ~data:sha1 in + let offsets = Misc.IntMap.add pos sha1 offsets in loop (offsets, index) t) in - loop (Int.Map.empty, empty) values + loop (Misc.IntMap.empty, empty) values let lwt_monad = Lwt.return, Lwt.bind let id_monad = (fun x ->x), (fun x f -> f x) @@ -134,13 +126,14 @@ module Raw = struct random but stable one. *) let sha1_of_keys keys = keys - |> List.map ~f:SHA.to_hex - |> List.sort ~cmp:String.compare + |> List.map SHA.to_hex + |> List.sort String.compare |> List.rev - |> String.concat ~sep:"" + |> String.concat "" |> SHA.create let input buf ~index = + let all = Mstruct.to_cstruct buf in let offset = Mstruct.offset buf in let version, count = input_header buf in Log.debugf "input version:%d count:%d" version count; @@ -149,22 +142,19 @@ module Raw = struct let pos = Mstruct.offset buf in let v = input_packed_value version buf in let length = Mstruct.offset buf - pos in - let raw = Bigstring.sub_shared ~pos ~len:length (Mstruct.to_bigarray buf) in + let raw = Cstruct.sub all pos length in values := (pos, raw, v) :: !values done; - let str = Bigstring.sub_shared - ~len:(Mstruct.offset buf - offset) - (Mstruct.to_bigarray buf) in + let str = Cstruct.sub all 0 (Mstruct.offset buf - offset) in let pack_checksum = SHA.input buf in - (* XXX: SHA.of_bigstring *) - let checksum = SHA.create (Bigstring.to_string str) in - if SHA.(checksum <> pack_checksum) then ( + let checksum = SHA.create (Cstruct.to_string str) in + if checksum <> pack_checksum then ( eprintf "Pack.Raw.input: wrong file checksum. Got: %s, expecting %s." (SHA.to_hex checksum) (SHA.to_hex pack_checksum); failwith "Pack.input" ); Log.debugf "input checksum: %s" (SHA.to_hex pack_checksum); - if Int.(Mstruct.length buf <> 0) then ( + if Mstruct.length buf <> 0 then ( eprintf "Pack.input: unprocessed data."; failwith "Pack.input"; ); @@ -181,56 +171,52 @@ module Raw = struct let sha1 = sha1_of_keys (SHA.Map.keys index.Pack_index.offsets) in { sha1; index; values; - buffer = Bigstring.sub_shared ~pos:offset (Mstruct.to_bigarray buf); + buffer = Cstruct.sub all offset (Cstruct.len all - offset); version; checksum; } let add buf t = - Bigbuffer.add_string buf (Bigstring.to_string t.buffer) + Buffer.add_string buf (Cstruct.to_string t.buffer) let sha1 t = t.sha1 let index t = t.index let keys t = - SHA.Set.of_list - (SHA.Map.keys t.index.Pack_index.offsets) + SHA.Set.of_list (SHA.Map.keys t.index.Pack_index.offsets) end module Log = Log.Make(struct let section = "pack" end) -module T = struct - type t = (SHA.t * Packed_value.PIC.t) list with bin_io, compare, sexp - let hash (t: t) = Hashtbl.hash t - include Sexpable.To_stringable (struct type nonrec t = t with sexp end) - let module_name = "Pack" -end -include T -include Identifiable.Make (T) +type t = (SHA.t * Packed_value.PIC.t) list with sexp + +let hash = Hashtbl.hash + +let compare = compare + +let equal = (=) let pretty t = let buf = Buffer.create 1024 in - List.iter ~f:(fun (sha1, p) -> + List.iter (fun (sha1, p) -> bprintf buf "%s: %s---\n" (SHA.to_hex sha1) (Packed_value.PIC.pretty p) ) t; Buffer.contents buf let to_pic { Raw.values; index } = Log.debugf "to_pic"; - let inv_offsets = Int.Map.of_alist_exn - (List.Assoc.inverse (SHA.Map.to_alist index.Pack_index.offsets)) in + let inv_offsets = Misc.IntMap.of_alist + (Misc.inverse_assoc (SHA.Map.to_alist index.Pack_index.offsets)) in let _offsets, _sha1, pics = - List.fold_left ~f:(fun (offsets, sha1s, pics) (pos, _, p) -> - match Int.Map.find inv_offsets pos with - | None -> failwith "Pack.to_pick" - | Some sha1 -> - let pic = Packed_value.to_pic offsets sha1s (pos, sha1, p) in - Int.Map.add offsets ~key:pos ~data:pic, - SHA.Map.add sha1s ~key:sha1 ~data:pic, - (sha1, pic) :: pics + List.fold_left (fun (offsets, sha1s, pics) (pos, _, p) -> + let sha1 = Misc.IntMap.find pos inv_offsets in + let pic = Packed_value.to_pic offsets sha1s (pos, sha1, p) in + Misc.IntMap.add pos pic offsets , + SHA.Map.add sha1 pic sha1s, + (sha1, pic) :: pics ) - ~init:(Int.Map.empty, SHA.Map.empty, []) + (Misc.IntMap.empty, SHA.Map.empty, []) values in List.rev pics @@ -247,25 +233,25 @@ let add buf t = Log.debugf "add"; let version = 2 in Raw.add_header ~version buf (List.length t); - let _index = List.fold_left ~f:(fun index (_, pic) -> - let pos = Bigbuffer.length buf in + let _index = List.fold_left (fun index (_, pic) -> + let pos = Buffer.length buf in let p = Packed_value.of_pic index ~pos pic in add_packed_value ~version buf p; - Packed_value.PIC.Map.add index pic pos - ) ~init:Packed_value.PIC.Map.empty t in - let sha1 = SHA.create (Bigbuffer.contents buf) in + Packed_value.PIC.Map.add pic pos index + ) Packed_value.PIC.Map.empty t in + let sha1 = SHA.create (Buffer.contents buf) in Log.debugf "add sha1: %s" (SHA.to_hex sha1); SHA.add buf sha1 let keys t = - List.fold_left ~f:(fun set (key, _) -> - SHA.Set.add set key - ) ~init:SHA.Set.empty t + List.fold_left (fun set (key, _) -> + SHA.Set.add key set + ) SHA.Set.empty t let unpack ~write buf = Log.debugf "XXX unpack"; let i = ref 0 in - let pack = Raw.input (Mstruct.of_bigarray buf) ~index:None in + let pack = Raw.input (Mstruct.of_cstruct buf) ~index:None in let pack = to_pic pack in let size = List.length pack in Misc.list_iter_p (fun (_, pic) -> @@ -281,8 +267,8 @@ let unpack ~write buf = let pack contents = let uncompressed = - List.map ~f:(fun (k, v) -> - let raw = Misc.with_bigbuffer (fun buf -> Value.add_inflated buf v) in + List.map (fun (k, v) -> + let raw = Misc.with_buffer' (fun buf -> Value.add_inflated buf v) in k, Packed_value.PIC.raw k raw ) contents in (* XXX: Patience_diff.be_clever *) @@ -290,14 +276,14 @@ let pack contents = let of_pic t = Log.debugf "of_pic"; - let buf = Misc.with_bigbuffer (fun buf -> add buf t) in - Raw.input (Mstruct.of_bigarray buf) ~index:None + let buf = Misc.with_buffer (fun buf -> add buf t) in + Raw.input (Mstruct.of_string buf) ~index:None let read (t:t) sha1 = - match List.Assoc.find t sha1 with + match Misc.try_assoc sha1 t with | None -> None | Some pic -> Some (Packed_value.PIC.to_value pic) let read_exn (t:t) sha1 = - let pic = List.Assoc.find_exn t sha1 in + let pic = List.assoc sha1 t in Packed_value.PIC.to_value pic diff --git a/lib/pack.mli b/lib/pack.mli index b696949d3..d0fad3dac 100644 --- a/lib/pack.mli +++ b/lib/pack.mli @@ -16,8 +16,6 @@ (** Pack files. *) -open Core_kernel.Std - type t = (SHA.t * Packed_value.PIC.t) list (** A pack value is an ordered list of position-independant packed values and the SHA of the corresponding inflated objects. *) @@ -38,8 +36,7 @@ val read: t -> SHA.t -> Value.t option val read_exn: t -> SHA.t -> Value.t (** Return the value stored in the pack file. *) -val unpack: write:(Value.t -> SHA.t Lwt.t) -> - Bigstring.t -> SHA.Set.t Lwt.t +val unpack: write:(Value.t -> SHA.t Lwt.t) -> Cstruct.t -> SHA.Set.t Lwt.t (** Unpack a whole pack file. [write] should returns the SHA of the marshaled value. Return the IDs of the written objects. *) diff --git a/lib/pack_index.ml b/lib/pack_index.ml index f0e5ec6dd..8c41e2a1e 100644 --- a/lib/pack_index.ml +++ b/lib/pack_index.ml @@ -15,25 +15,36 @@ *) open Lwt -open Core_kernel.Std +open Sexplib.Std +open Printf + module Log = Log.Make(struct let section = "pack-index" end) -module T = struct - type t = { - offsets : int SHA.Map.t; - crcs : int32 SHA.Map.t; - pack_checksum: SHA.t; - } with bin_io, compare, sexp - let hash (t: t) = Hashtbl.hash t - include Sexpable.To_stringable (struct type nonrec t = t with sexp end) - let module_name = "Pack_index" -end -include T -include Identifiable.Make (T) +type t = { + offsets : int SHA.Map.t; + crcs : int32 SHA.Map.t; + pack_checksum: SHA.t; +} with sexp + +let hash = Hashtbl.hash + +let compare t1 t2 = + match SHA.compare t1.pack_checksum t2.pack_checksum with + | 0 -> begin + match SHA.Map.compare compare t1.offsets t2.offsets with + | 0 -> SHA.Map.compare Int32.compare t1.crcs t2.crcs + | i -> i + end + | i -> i + +let equal t1 t2 = + SHA.equal t1.pack_checksum t2.pack_checksum + && SHA.Map.equal (=) t1.offsets t2.offsets + && SHA.Map.equal (=) t1.crcs t2.crcs let empty ?pack_checksum () = let pack_checksum = match pack_checksum with - | None -> SHA.of_string "" (* XXX: ugly *) + | None -> SHA.of_raw "" (* XXX: ugly *) | Some c -> c in { offsets = SHA.Map.empty; @@ -45,13 +56,14 @@ let pretty t = let buf = Buffer.create 1024 in bprintf buf "pack-checksum: %s\n" (SHA.to_hex t.pack_checksum); let l = ref [] in - SHA.Map.iter2 ~f:(fun ~key ~data -> - match data with - | `Both (offset, crc) -> l := (key, offset, crc) :: !l - | _ -> assert false - ) t.offsets t.crcs; - let l = List.sort ~cmp:(fun (_,o1,_) (_,o2,_) -> Int.compare o1 o2) !l in - List.iter ~f:(fun (sha1, offset, crc) -> + let offsets = SHA.Map.to_alist t.offsets in + let crcs = SHA.Map.to_alist t.crcs in + List.iter2 (fun (key1, offset) (key2, crc) -> + assert (key1 = key2); + l := (key1, offset, crc) :: !l + ) offsets crcs; + let l = List.sort (fun (_,o1,_) (_,o2,_) -> Pervasives.compare o1 o2) !l in + List.iter (fun (sha1, offset, crc) -> bprintf buf "%s: off:%d crc:%ld\n" (SHA.to_hex sha1) offset crc ) l; Buffer.contents buf @@ -65,9 +77,9 @@ let lengths { offsets } = | [] -> List.rev acc | [h,_] -> aux ((h, None)::acc) [] | (h1,l1)::((_,l2)::_ as t) -> aux ((h1, Some (l2-l1))::acc) t in - let l = SHA.Map.to_alist offsets in - let l = List.sort ~cmp:(fun (_,x) (_,y) -> Int.compare x y) l in - SHA.Map.of_alist_exn (aux [] l) + let l = SHA.Map.bindings offsets in + let l = List.sort (fun (_,x) (_,y) -> Pervasives.compare x y) l in + SHA.Map.of_alist (aux [] l) let input_header buf = let magic = Mstruct.get_string buf 4 in @@ -79,7 +91,7 @@ let input_header buf = let input_keys buf n = Log.debugf "input: reading the %d objects IDs" n; - let a = Array.create n (SHA.of_string "") in + let a = Array.create n (SHA.of_raw "") in for i=0 to n - 1 do a.(i) <- SHA.input buf; done; @@ -89,8 +101,11 @@ let keys buf = Log.debugf "keys"; input_header buf; Mstruct.shift buf (255 * 4); - let n = Mstruct.get_be_uint32 buf in - SHA.Set.of_array (input_keys buf (Int32.to_int_exn n)) + Mstruct.get_be_uint32 buf + |> Int32.to_int + |> input_keys buf + |> Array.to_list + |> SHA.Set.of_list let input buf = Log.debugf "input"; @@ -104,7 +119,7 @@ let input buf = done; a in - let nb_objects = Int32.to_int_exn fanout.(255) in + let nb_objects = Int32.to_int fanout.(255) in (* Read the names *) let names = input_keys buf nb_objects in @@ -112,7 +127,7 @@ let input buf = (* Read the CRCs *) Log.debugf "input: reading the %d CRCs" nb_objects; let crcs = - let a = Array.create nb_objects (SHA.of_string "", 0l) in + let a = Array.create nb_objects (SHA.of_raw "", 0l) in for i=0 to nb_objects-1 do let crc = Mstruct.get_be_uint32 buf in a.(i) <- (names.(i), crc); @@ -126,7 +141,7 @@ let input buf = let a = Array.create nb_objects 0l in let b = Array.create nb_objects false in for i=0 to nb_objects-1 do - let more = match Int.(Mstruct.get_uint8 buf land 128) with + let more = match Mstruct.get_uint8 buf land 128 with | 0 -> false | _ -> true in let n = @@ -146,70 +161,72 @@ let input buf = let cont = conts.(i) in if cont then ( let offset = Mstruct.get_be_uint64 buf in - (name, Int64.to_int_exn offset) + (name, Int64.to_int offset) ) else - (name, Int32.to_int_exn offset) + (name, Int32.to_int offset) ) names in let pack_checksum = SHA.input buf in let _checksum = SHA.input buf in let offsets_alist = Array.to_list offsets in - let offsets = SHA.Map.of_alist_exn offsets_alist in - let crcs = SHA.Map.of_alist_exn (Array.to_list crcs) in + let offsets = SHA.Map.of_alist offsets_alist in + let crcs = SHA.Map.of_alist (Array.to_list crcs) in { offsets; crcs; pack_checksum } let add buf t = - let n = SHA.Map.length t.offsets in + let n = SHA.Map.cardinal t.offsets in Log.debugf "output: %d packed values" n; - Bigbuffer.add_string buf "\255tOc"; + Buffer.add_string buf "\255tOc"; Misc.add_be_uint32 buf 2l; let cmp (k1,_) (k2,_) = SHA.compare k1 k2 in - let offsets = List.sort ~cmp (SHA.Map.to_alist t.offsets) in - let crcs = List.sort ~cmp (SHA.Map.to_alist t.crcs) in + let offsets = List.sort cmp (SHA.Map.to_alist t.offsets) in + let crcs = List.sort cmp (SHA.Map.to_alist t.crcs) in Log.debugf "output: writing the first-level fanout"; let fanout = Array.create 256 0l in - List.iter ~f:(fun (key, _) -> - let str = SHA.to_string key in - let n = Char.to_int str.[0] in + List.iter (fun (key, _) -> + let str = SHA.to_raw key in + let n = Char.code str.[0] in for i = n to 255 do fanout.(i) <- Int32.succ fanout.(i) done; ) offsets; - Array.iter ~f:(Misc.add_be_uint32 buf) fanout; + Array.iter (Misc.add_be_uint32 buf) fanout; Log.debugf "output: writing the %d object IDs" n; - List.iter ~f:(fun (key, _) -> + List.iter (fun (key, _) -> SHA.add buf key ) offsets; Log.debugf "output: writing the %d CRCs" n; - List.iter ~f:(fun (_, crc) -> + List.iter (fun (_, crc) -> Misc.add_be_uint32 buf crc ) crcs; Log.debugf "output: writing the %d offsets" n; let conts = ref [] in - List.iter ~f:(fun (_, offset) -> - match Int32.of_int offset with - | Some i -> Misc.add_be_uint32 buf i - | None -> - conts := Int64.of_int_exn offset :: !conts; + List.iter (fun (_, offset) -> + if offset <= Int32.(to_int max_int) then ( + let i = Int32.of_int offset in + Misc.add_be_uint32 buf i + ) else ( + conts := Int64.of_int offset :: !conts; Misc.add_be_uint32 buf 0x80_00_00_00l + ) ) offsets; Log.debugf "output: writing the %d offset continuations" (List.length !conts); let str = String.create 8 in - List.iter ~f:(fun cont -> + List.iter (fun cont -> EndianString.BigEndian.set_int64 str 0 cont; - Bigbuffer.add_string buf str + Buffer.add_string buf str ) (List.rev !conts); SHA.add buf t.pack_checksum; (* XXX: SHA.of_bigstring *) - let str = Bigbuffer.contents buf in + let str = Buffer.contents buf in let checksum = SHA.create str in - Bigbuffer.add_string buf (SHA.to_string checksum) + Buffer.add_string buf (SHA.to_raw checksum) diff --git a/lib/pack_index.mli b/lib/pack_index.mli index c9960a8a7..ac170df5a 100644 --- a/lib/pack_index.mli +++ b/lib/pack_index.mli @@ -16,13 +16,11 @@ (** Pack indexes. *) -open Core_kernel.Std - type t = { offsets : int SHA.Map.t; crcs : int32 SHA.Map.t; pack_checksum: SHA.t; -} +} with sexp (** [offsests] is the positions of the SHA objects in the corresponding raw pack file. diff --git a/lib/packed_value.ml b/lib/packed_value.ml index a505b3a31..554107538 100644 --- a/lib/packed_value.ml +++ b/lib/packed_value.ml @@ -14,14 +14,15 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +open Printf +open Sexplib.Std -open Core_kernel.Std module Log = Log.Make(struct let section = "packed-value" end) type copy = { offset: int; length: int; -} with bin_io, compare, sexp +} with sexp let pretty_copy t = sprintf "off:%d len:%d" t.offset t.length @@ -29,7 +30,7 @@ let pretty_copy t = type hunk = | Insert of string | Copy of copy -with bin_io, compare, sexp +with sexp let pretty_hunk = function | Insert s -> sprintf "Insert %S" s @@ -40,7 +41,7 @@ type 'a delta = { source_length: int; result_length: int; hunks: hunk list; -} with bin_io, compare, sexp +} with sexp let pretty_delta d = let buf = Buffer.create 128 in @@ -49,30 +50,24 @@ let pretty_delta d = result-length: %d\n" d.source_length d.result_length; - List.iter ~f:(function + List.iter (function | Insert str -> bprintf buf " - INSERT %S\n" str | Copy copy -> bprintf buf " - COPY [%s]\n" (pretty_copy copy) ) d.hunks; Buffer.contents buf -module T = struct - module X = struct - type t = - | Raw_value of string - | Ref_delta of SHA.t delta - | Off_delta of int delta - with bin_io, compare, sexp - let hash (t: t) = Hashtbl.hash t - include Sexpable.To_stringable (struct type nonrec t = t with sexp end) - let module_name = "Packed_value" - end - include X - include Identifiable.Make (X) -end -include T +type t = + | Raw_value of string + | Ref_delta of SHA.t delta + | Off_delta of int delta +with sexp + +let hash = Hashtbl.hash +let equal = (=) +let compare = compare let pretty = function - | Raw_value s -> sprintf "%S" s + | Raw_value s -> sprintf "%S\n" s | Ref_delta d -> sprintf "source:%s\n%s" (SHA.to_hex d.source) (pretty_delta d) | Off_delta d -> sprintf "source:%d\n%s" d.source (pretty_delta d) @@ -87,8 +82,8 @@ let source_length = function | Raw_value str -> String.length str let add_hunk buf ~source ~pos = function - | Insert str -> Bigbuffer.add_string buf str - | Copy copy -> Bigbuffer.add_substring buf source (pos+copy.offset) copy.length + | Insert str -> Buffer.add_string buf str + | Copy copy -> Buffer.add_substring buf source (pos+copy.offset) copy.length let add_delta buf delta = let source = Mstruct.of_string delta.source in @@ -100,26 +95,30 @@ let add_delta buf delta = with Failure "int_of_string" -> eprintf "Packed_value.add_delta: %s is not a valid size.\n" s; failwith "Packed_value.add_delta" in - if Int.(size <> delta.source_length) then + if size <> delta.source_length then Mstruct.parse_error_buf source "size differs: delta:%d source:%d\n" delta.source_length size; - Bigbuffer.add_string buf (Object_type.to_string object_type); - Bigbuffer.add_char buf Misc.sp; - Bigbuffer.add_string buf (string_of_int delta.result_length); - Bigbuffer.add_char buf Misc.nul; + Buffer.add_string buf (Object_type.to_string object_type); + Buffer.add_char buf Misc.sp; + Buffer.add_string buf (string_of_int delta.result_length); + Buffer.add_char buf Misc.nul; let pos = Mstruct.offset source in - List.iter ~f:(add_hunk buf ~source:delta.source ~pos) delta.hunks + List.iter (add_hunk buf ~source:delta.source ~pos) delta.hunks module Make (M: sig val version: int end) = struct - open Int + let sexp_of_t = sexp_of_t + let t_of_sexp = t_of_sexp + let compare = compare + let hash = hash + let equal = equal let isset i bit = (i lsr bit) land 1 <> 0 let input_hunk source_length buf = let opcode = Mstruct.get_uint8 buf in - if Int.(opcode = 0) then + if opcode = 0 then Mstruct.parse_error_buf buf "0 as value of the first byte of a hunk is reserved."; match opcode land 0x80 with | 0 -> @@ -155,15 +154,15 @@ module Make (M: sig val version: int end) = struct let len = String.length contents in if len >= 0x80 then failwith ("invalid hunk: insert too large: " ^ string_of_int len); - Bigbuffer.add_char buf (Char.of_int_exn (String.length contents)); - Bigbuffer.add_string buf contents + Buffer.add_char buf (Char.chr (String.length contents)); + Buffer.add_string buf contents | Copy { offset; length } -> let length = if length = 0x10_000 then 0 else length in let bits = ref [] in let bit n shift = match (n lsr shift) land 0xFF with | 0 -> 0 - | n -> bits := Char.of_int_exn n :: !bits; 1 + | n -> bits := Char.chr n :: !bits; 1 in let o0 = bit offset 0 in let o1 = bit offset 8 in @@ -178,8 +177,8 @@ module Make (M: sig val version: int end) = struct 0x80 + o0 + (o1 lsl 1) + (o2 lsl 2) + (o3 lsl 3) + (l0 lsl 4) + (l1 lsl 5) + (l2 lsl 6) in - Bigbuffer.add_char buf (Char.of_int_exn n); - List.iter ~f:(Bigbuffer.add_char buf) (List.rev !bits) + Buffer.add_char buf (Char.chr n); + List.iter (Buffer.add_char buf) (List.rev !bits) let input_le_base_128 buf = let rec aux int shift = @@ -196,11 +195,10 @@ module Make (M: sig val version: int end) = struct let rec aux i = let more = if i < 0x80 then 0 else 0x80 in let byte = more lor (i land 0x7f) in - bytes := Char.of_int_exn byte :: !bytes; + bytes := Char.chr byte :: !bytes; if i >= 0x80 then aux (i lsr 7) in aux int; - let str = String.of_char_list (List.rev !bytes) in - Bigbuffer.add_string buf str + List.iter (Buffer.add_char buf) (List.rev !bytes) let input_hunks source buf = let source_length = input_le_base_128 buf in @@ -215,7 +213,7 @@ module Make (M: sig val version: int end) = struct let { source_length; result_length; hunks } = t in add_le_base_128 buf source_length; add_le_base_128 buf result_length; - List.iter ~f:(add_hunk buf) hunks + List.iter (add_hunk buf) hunks let input_be_modified_base_128 buf = let rec aux i first = @@ -235,11 +233,10 @@ module Make (M: sig val version: int end) = struct let more = if first then 0 else 0x80 in let i = if first then i else i-1 in let byte = more lor (i land 0x7f) in - bytes := (Char.of_int_exn byte) :: !bytes; + bytes := (Char.chr byte) :: !bytes; if i > 0x80 then aux (i lsr 7) false in aux int true; - let bytes = String.of_char_list !bytes in - Bigbuffer.add_string buf bytes + List.iter (Buffer.add_char buf) !bytes let with_inflated buf size fn = let buf = Misc.inflate_mstruct buf in @@ -253,7 +250,7 @@ module Make (M: sig val version: int end) = struct let with_inflated_buf buf size fn = with_inflated buf size (fun buf -> - let contents = Mstruct.to_bigarray buf in + let contents = Mstruct.to_cstruct buf in fn contents ) @@ -269,10 +266,10 @@ module Make (M: sig val version: int end) = struct else low in let mk typ str = - let size = Bigstring.length str in + let size = Cstruct.len str in let buf = Misc.with_buffer (fun buf -> Value.add_header buf typ size; - Bigbuffer.add_string buf (Bigstring.to_string str) + Buffer.add_string buf (Cstruct.to_string str) ) in Raw_value buf in @@ -295,28 +292,29 @@ module Make (M: sig val version: int end) = struct Ref_delta hunks | _ -> assert false - let inflated_buffer = Bigbuffer.create 1024 + let inflated_buffer = Buffer.create 1024 let with_deflated buf fn = - Bigbuffer.reset inflated_buffer; + Buffer.reset inflated_buffer; fn inflated_buffer; - let inflated = Misc.buffer_contents inflated_buffer in - let deflated = Misc.deflate_bigstring inflated in - Bigbuffer.add_string buf (Bigstring.to_string deflated); - Bigstring.length inflated + let inflated = Buffer.contents inflated_buffer in + let deflated = Misc.deflate_cstruct (Cstruct.of_string inflated) in + Buffer.add_string buf (Cstruct.to_string deflated); + String.length inflated - let tmp_buffer = Bigbuffer.create 1024 + let tmp_buffer = Buffer.create 1024 let add buf t = - Bigbuffer.reset tmp_buffer; + Buffer.reset tmp_buffer; let add_deflated_hunks buf hunks = with_deflated buf (fun b -> add_hunks b hunks) in let size = match t with | Raw_value str -> - begin match String.index str Misc.nul with - | None -> failwith (sprintf "Packed_value.add: %S" str) - | Some i -> - let s = String.subo ~pos:(i+1) str in - with_deflated tmp_buffer (fun b -> Bigbuffer.add_string b s) + begin + try + let i = String.index str Misc.nul in + let s = String.sub str (i+1) (String.length str-i-1) in + with_deflated tmp_buffer (fun b -> Buffer.add_string b s) + with Not_found -> failwith (sprintf "Packed_value.add: %S" str) end | Off_delta hunks -> add_be_modified_base_128 tmp_buffer hunks.source; @@ -338,11 +336,11 @@ module Make (M: sig val version: int end) = struct Log.debugf "add kind:%d size:%d (%b %d)" kind size (more=0x80) (size land 0x0f); let byte = more lor (kind lsl 4) lor (size land 0x0f) in - Bigbuffer.add_char buf (Char.of_int_exn byte); + Buffer.add_char buf (Char.chr byte); if size > 0x0f then add_le_base_128 buf (size lsr 4); - let str = Misc.buffer_contents tmp_buffer in - Bigbuffer.add_string buf (Bigstring.to_string str) + let str = Buffer.contents tmp_buffer in + Buffer.add_string buf str let crc32 t = let buf = Misc.with_buffer (fun buf -> add buf t) in @@ -350,28 +348,21 @@ module Make (M: sig val version: int end) = struct let pretty = pretty - include T - end module V2 = Make(struct let version = 2 end) module V3 = Make(struct let version = 3 end) module PIC = struct - module X = struct - type kind = - | Raw of string - | Link of t delta - and t = { - kind: kind; - sha1: SHA.t; - } - with bin_io, compare, sexp - let hash (t: t) = Hashtbl.hash t - include Sexpable.To_stringable (struct type nonrec t = t with sexp end) - let module_name = "Packed_value.PIC" - end - include X - include Identifiable.Make (X) + + type kind = + | Raw of string + | Link of t delta + + and t = { + kind: kind; + sha1: SHA.t; + } + with sexp let pretty_kind = function | Raw _ -> "RAW" @@ -401,16 +392,25 @@ module PIC = struct Value.input_inflated (Mstruct.of_string buf) let raw sha1 raw = - { sha1; kind = Raw (Bigstring.to_string raw) } + { sha1; kind = Raw (Cstruct.to_string raw) } + + module X = struct + type x = t with sexp + type t = x with sexp + let compare = compare + end + module Map = Misc.Map(X) + end let of_pic index ~pos t = match t.PIC.kind with | PIC.Raw x -> Raw_value x | PIC.Link d -> - match PIC.Map.find index d.source with - | Some o -> Off_delta { d with source = pos - o } - | None -> + try + let o = PIC.Map.find d.source index in + Off_delta { d with source = pos - o } + with Not_found -> eprintf "Packed_value.of_pic: cannot fallow the PIC chain.\n"; failwith "Packed_value.of_pic" @@ -418,9 +418,11 @@ let to_pic offsets sha1s (pos, sha1, t) = let kind = match t with | Raw_value x -> PIC.Raw x | Ref_delta d -> - begin match SHA.Map.find sha1s d.source with - | Some pic -> PIC.Link { d with source = pic } - | None -> + begin + try + let pic = SHA.Map.find d.source sha1s in + PIC.Link { d with source = pic } + with Not_found -> eprintf "Packed_value.to_pic: shallow pack are not supported.\n\ %s is not in the pack file!\n" @@ -429,20 +431,22 @@ let to_pic offsets sha1s (pos, sha1, t) = end | Off_delta d -> let offset = pos - d.source in - match Int.Map.find offsets offset with - | Some pic -> PIC.Link { d with source = pic } - | None -> + try + let pic = Misc.IntMap.find offset offsets in + PIC.Link { d with source = pic } + with Not_found -> eprintf "Cannot find offest %d in the index\n%s" d.source - (Sexp.to_string_hum (Int.Map.sexp_of_t PIC.sexp_of_t offsets)); + (Sexplib.Sexp.to_string_hum (Misc.IntMap.sexp_of_t PIC.sexp_of_t offsets)); failwith "Packed_value.to_pic" + in { PIC.sha1; kind } (* XXX: merge with PIC.unpack *) let add_inflated_value_aux (return, bind) ~read ~offsets ~pos buf = function | Raw_value x -> - Bigbuffer.add_string buf x; + Buffer.add_string buf x; return () | Ref_delta d -> bind @@ -453,9 +457,8 @@ let add_inflated_value_aux (return, bind) ~read ~offsets ~pos buf = function | Off_delta d -> let offset = pos - d.source in let base = - match Int.Map.find offsets offset with - | Some k -> k - | None -> + try Misc.IntMap.find offset offsets + with Not_found -> eprintf "Packed_value.add_inflated_value: cannot find any object at offset %d\n" offset; failwith "Packed_inflated_value" in diff --git a/lib/packed_value.mli b/lib/packed_value.mli index 7038390c6..3c7126d26 100644 --- a/lib/packed_value.mli +++ b/lib/packed_value.mli @@ -16,17 +16,16 @@ (** Packed values. *) -open Core_kernel.Std - type copy = { offset: int; length: int; -} +} with sexp (** Copy arguments. *) type hunk = | Insert of string | Copy of copy +with sexp (** A delta hunk can either insert a string of copy the contents of a base object. *) @@ -35,20 +34,19 @@ type 'a delta = { source_length: int; result_length: int; hunks : hunk list; -} +} with sexp (** Delta objects. *) type t = | Raw_value of string | Ref_delta of SHA.t delta | Off_delta of int delta +with sexp (** Packed values. *) val pretty: t -> string (** Human readable representation of a packed value. *) -include Identifiable.S with type t := t - module V2: sig include Object.S with type t := t @@ -77,26 +75,26 @@ val source_length: t -> int (** {2 Conversion to values} *) -val add_hunk: Bigbuffer.t -> source:string -> pos:int -> hunk -> unit +val add_hunk: Buffer.t -> source:string -> pos:int -> hunk -> unit (** Append a hunk to a buffer. [source] is the original object the hunk refers to (with the given offset). *) -val add_delta: Bigbuffer.t -> string delta -> unit +val add_delta: Buffer.t -> string delta -> unit (** Append a delta to a buffer. *) val add_inflated_value: read:(SHA.t -> string Lwt.t) -> - offsets:SHA.t Int.Map.t -> + offsets:SHA.t Misc.IntMap.t -> pos:int -> - Bigbuffer.t -> t -> unit Lwt.t + Buffer.t -> t -> unit Lwt.t (** Append the inflated representation of a packed value to a given buffer. Use the same paramaters as [to_value]. *) val add_inflated_value_sync: read:(SHA.t -> string) -> - offsets:SHA.t Int.Map.t -> + offsets:SHA.t Misc.IntMap.t -> pos:int -> - Bigbuffer.t -> t -> unit + Buffer.t -> t -> unit (** Same as [add_inflated_value] but with a synchronous read function. *) @@ -113,9 +111,7 @@ module PIC: sig and t = { kind: kind; sha1: SHA.t; - } - - include Identifiable.S with type t := t + } with sexp val pretty: t -> string (** Human readable representation. *) @@ -124,12 +120,14 @@ module PIC: sig (** [to_value p] unpacks the packed position-independant value [p]. *) - val raw: SHA.t -> Bigstring.t -> t + val raw: SHA.t -> Cstruct.t -> t (** Build a raw value. *) + module Map: Map.S with type key = t + end -val to_pic: PIC.t Int.Map.t -> PIC.t SHA.Map.t -> (int * SHA.t * t) -> PIC.t +val to_pic: PIC.t Misc.IntMap.t -> PIC.t SHA.Map.t -> (int * SHA.t * t) -> PIC.t (** Position-independant packed value. Convert [Off_delta] and [Ref_delta] to [PIC.Link] using the provided indexes. *) diff --git a/lib/reference.ml b/lib/reference.ml index 1d3b47153..8993dd65a 100644 --- a/lib/reference.ml +++ b/lib/reference.ml @@ -14,10 +14,27 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std +open Sexplib.Std + module Log = Log.Make(struct let section = "reference" end) -include String +type t = string with sexp + +let compare = String.compare +let equal = (=) +let hash = Hashtbl.hash + +let add buf t = + failwith "TODO: Reference.add" + +let input buf = + failwith "TODO: Reference.input" + +let to_raw x = x +let of_raw x = x +let pretty x = String.escaped x + +module Map = Misc.Map(Misc.S) let compare x y = match x, y with @@ -30,21 +47,22 @@ let head = "HEAD" type head_contents = | SHA of SHA.Commit.t - | Ref of t + | Ref of string let is_head x = - String.(head = x) + String.compare head x = 0 let head_contents refs sha1 = - let refs = Map.remove refs "HEAD" in - match Misc.map_rev_find refs sha1 with + let refs = Map.remove "HEAD" refs in + let alist = Misc.inverse_assoc (Map.to_alist refs) in + match Misc.try_assoc sha1 alist with | None -> SHA sha1 | Some r -> Ref r let master = "refs/heads/master" let is_valid r = - String.for_all ~f:(function + Misc.string_forall (function | '{' | '}' | '^' -> false diff --git a/lib/reference.mli b/lib/reference.mli index 20146a164..07bc85a70 100644 --- a/lib/reference.mli +++ b/lib/reference.mli @@ -16,9 +16,13 @@ (** Branch references. *) -open Core_kernel.Std +include Object.S -include Identifiable.S +val to_raw: t -> string +val of_raw: string -> t + +module Map: Misc.Map with type key = t +(** A map of references. *) val head: t (** The repository HEAD. *) diff --git a/lib/search.ml b/lib/search.ml index baf7685bb..e3782b8df 100644 --- a/lib/search.ml +++ b/lib/search.ml @@ -15,7 +15,6 @@ *) open Lwt -open Core_kernel.Std type succ = [ `Commit of SHA.t @@ -42,10 +41,10 @@ module Make (Store: Store.S) = struct | None -> return_nil | Some (Value.Blob _) -> return_nil | Some (Value.Commit c) -> - return (tree "" c.Commit.tree :: List.map ~f:commit c.Commit.parents) + return (tree "" c.Commit.tree :: List.map commit c.Commit.parents) | Some (Value.Tag t) -> return [tag t] | Some (Value.Tree t) -> - return (List.map ~f:(fun e -> `Tree (e.Tree.name, e.Tree.node)) t) + return (List.map (fun e -> `Tree (e.Tree.name, e.Tree.node)) t) (* XXX: not tail-rec *) let rec find t sha1 path = diff --git a/lib/store.mli b/lib/store.mli index 525face0b..8fa23b22b 100644 --- a/lib/store.mli +++ b/lib/store.mli @@ -14,8 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std - module type S = sig (** Signature for Git stores. *) diff --git a/lib/sync.ml b/lib/sync.ml index d98c80f0a..df394151a 100644 --- a/lib/sync.ml +++ b/lib/sync.ml @@ -14,8 +14,9 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std open Lwt +open Printf + module Log = Log.Make(struct let section = "remote" end) module Result = struct @@ -28,9 +29,11 @@ module Result = struct let pretty_fetch t = let buf = Buffer.create 1024 in - bprintf buf "HEAD: %s\n" (match t.head with None -> "" | Some x -> SHA.Commit.to_hex x); - Reference.Map.iter ~f:(fun ~key ~data -> - bprintf buf "%s %s\n" (Reference.to_string key) (SHA.Commit.to_hex data) + bprintf buf "HEAD: %s\n" (match t.head with + | None -> "" + | Some x -> SHA.Commit.to_hex x); + Reference.Map.iter (fun key data -> + bprintf buf "%s %s\n" (Reference.pretty key) (SHA.Commit.to_hex data) ) t.references; bprintf buf "Keys: %d\n" (List.length t.sha1s); Buffer.contents buf @@ -45,10 +48,10 @@ module Result = struct let pretty_push t = let buf = Buffer.create 1024 in let aux (ref, result) = match result with - | `Ok -> Printf.bprintf buf "* %s\n" (Reference.to_string ref) - | `Error e -> Printf.bprintf buf "! %s: %s\n" (Reference.to_string ref) e + | `Ok -> Printf.bprintf buf "* %s\n" (Reference.pretty ref) + | `Error e -> Printf.bprintf buf "! %s: %s\n" (Reference.pretty ref) e in - List.iter ~f:aux t.commands; + List.iter aux t.commands; Buffer.contents buf end @@ -195,20 +198,20 @@ module Make (IO: IO) (Store: Store.S) = struct type t = Capability.t list let of_string str = - List.map ~f:Capability.of_string (String.split str ~on:Misc.sp) + List.map Capability.of_string (Misc.string_split str ~on:Misc.sp) let to_string l = - String.concat ~sep:" " (List.map ~f:Capability.to_string l) + String.concat " " (List.map Capability.to_string l) let pretty l = - String.concat ~sep:", " (List.map ~f:Capability.to_string l) + String.concat ", " (List.map Capability.to_string l) (* XXX really ? *) let default = [] - let is_valid_push = List.for_all ~f:Capability.is_valid_push + let is_valid_push = List.for_all Capability.is_valid_push - let is_valid_fetch = List.for_all ~f:Capability.is_valid_fetch + let is_valid_fetch = List.for_all Capability.is_valid_fetch end @@ -293,26 +296,28 @@ module Make (IO: IO) (Store: Store.S) = struct } let is_empty t = - t.capabilities = [] && Map.is_empty t.references + t.capabilities = [] && SHA.Commit.Map.is_empty t.references let find_reference t ref = - Map.fold - ~f:(fun ~key ~data acc -> if List.mem data ref then Some key else acc) - ~init:None t.references + SHA.Commit.Map.fold + (fun key data acc -> if List.mem ref data then Some key else acc) + t.references None let head t = find_reference t Reference.head let pretty t = let buf = Buffer.create 1024 in - Printf.bprintf buf "CAPABILITIES:\n%s\n" (Capabilities.to_string t.capabilities); + Printf.bprintf buf "CAPABILITIES:\n%s\n" + (Capabilities.to_string t.capabilities); Printf.bprintf buf "\nREFERENCES:\n"; - Map.iter - ~f:(fun ~key ~data -> - List.iter ~f:(fun ref -> - Printf.bprintf buf "%s %s\n%!" (SHA.Commit.to_hex key) (Reference.to_string ref) - ) data - ) t.references; + SHA.Commit.Map.iter + (fun key data -> + List.iter (fun ref -> + Printf.bprintf buf "%s %s\n%!" + (SHA.Commit.to_hex key) (Reference.pretty ref) + ) data + ) t.references; Buffer.contents buf let input ic = @@ -321,27 +326,30 @@ module Make (IO: IO) (Store: Store.S) = struct PacketLine.input ic >>= function | None -> return acc | Some line -> - match String.lsplit2 line ~on:Misc.sp with + match Misc.string_lsplit2 line ~on:Misc.sp with | Some ("ERR", err) -> error "ERROR: %s" err | Some (sha1, ref) -> if is_empty acc then ( (* Read the capabilities on the first line *) - match String.lsplit2 ref ~on:Misc.nul with + match Misc.string_lsplit2 ref ~on:Misc.nul with | Some (ref, caps) -> - let ref = Reference.of_string ref in + let ref = Reference.of_raw ref in let references = - Map.add_multi ~key:(SHA.Commit.of_hex sha1) ~data:ref acc.references in + SHA.Commit.Map.add_multi (SHA.Commit.of_hex sha1) ref acc.references + in let capabilities = Capabilities.of_string caps in aux { references; capabilities; } | None -> - let ref = Reference.of_string ref in + let ref = Reference.of_raw ref in let references = - Map.add_multi ~key:(SHA.Commit.of_hex sha1) ~data:ref acc.references in + SHA.Commit.Map.add_multi (SHA.Commit.of_hex sha1) ref acc.references + in aux { references; capabilities = []; } ) else - let ref = Reference.of_string ref in + let ref = Reference.of_raw ref in let references = - Map.add_multi ~key:(SHA.Commit.of_hex sha1) ~data:ref acc.references in + SHA.Commit.Map.add_multi (SHA.Commit.of_hex sha1) ref acc.references + in aux { acc with references } | None -> error "%s is not a valid answer" line in @@ -372,9 +380,9 @@ module Make (IO: IO) (Store: Store.S) = struct | None | Some "NAK" -> return Nak | Some s -> - match String.lsplit2 s ~on:Misc.sp with + match Misc.string_lsplit2 s ~on:Misc.sp with | Some ("ACK", r) -> - begin match String.lsplit2 r ~on:Misc.sp with + begin match Misc.string_lsplit2 r ~on:Misc.sp with | None -> return (Ack (SHA.of_hex r)) | Some (id, s) -> return (Ack_multi (SHA.of_hex id, status_of_string s)) end @@ -404,11 +412,11 @@ module Make (IO: IO) (Store: Store.S) = struct type t = message list let filter fn l = - List.fold_left ~f:(fun acc elt -> + List.fold_left (fun acc elt -> match fn elt with | None -> acc | Some x -> x::acc - ) ~init:[] l + ) [] l let filter_wants l = filter (function Want (x,y) -> Some (x,y) | _ -> None) l @@ -435,7 +443,7 @@ module Make (IO: IO) (Store: Store.S) = struct PacketLine.input ic >>= function | None -> return (List.rev acc) | Some l -> - match String.lsplit2 l ~on:Misc.sp with + match Misc.string_lsplit2 l ~on:Misc.sp with | None -> error "input upload" | Some (kind, s) -> match kind with @@ -450,7 +458,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 String.lsplit2 s ~on:Misc.sp with + begin match Misc.string_lsplit2 s ~on:Misc.sp with | Some (id,c) -> aux id (Capabilities.of_string c) | None -> match acc with | Want (_,c)::_ -> aux s c @@ -510,7 +518,7 @@ module Make (IO: IO) (Store: Store.S) = struct end >>= fun () -> (* output done *) - if List.mem t Done then + if List.mem Done t then PacketLine.output_line oc "done" else PacketLine.flush oc @@ -524,8 +532,8 @@ module Make (IO: IO) (Store: Store.S) = struct the new shallow state. *) let phase1 (ic, oc) ?deepen ~shallows ~wants = Log.debugf "Upload.phase1"; - let wants = List.map ~f:(fun id -> Want (id, Capabilities.default)) wants in - let shallows = List.map ~f:(fun id -> Shallow id) shallows in + let wants = List.map (fun id -> Want (id, Capabilities.default)) wants in + let shallows = List.map (fun id -> Shallow id) shallows in let deepen = match deepen with | None -> [] | Some d -> [Deepen d] in @@ -561,7 +569,7 @@ module Make (IO: IO) (Store: Store.S) = struct else output oc (haves @ [Done]) in - let haves = List.map ~f:(fun id -> Have id) haves in + let haves = List.map (fun id -> Have id) haves in aux haves >>= fun () -> Ack.input ic >>= fun _ack -> return_unit @@ -576,7 +584,7 @@ module Make (IO: IO) (Store: Store.S) = struct | Update of Reference.t * SHA.Commit.t * SHA.Commit.t let pretty_command t = - let r = Reference.to_string in + let r = Reference.pretty in let c = SHA.Commit.to_hex in match t with | Create (name, new_id) -> sprintf "create %s %s" (r name) (c new_id) @@ -584,7 +592,7 @@ module Make (IO: IO) (Store: Store.S) = struct | Update (name, old_id, new_id) -> sprintf "update %s %s %s" (r name) (c old_id) (c new_id) let pretty_commands l = - String.concat ~sep:" & " (List.map ~f:pretty_command l) + String.concat " & " (List.map pretty_command l) let output_command buf t = let old_id, new_id, name = match t with @@ -594,7 +602,7 @@ module Make (IO: IO) (Store: Store.S) = struct Printf.bprintf buf "%s %s %s" (SHA.Commit.to_hex old_id) (SHA.Commit.to_hex new_id) - (Reference.to_string name) + (Reference.to_raw name) type t = { capabilities: Capabilities.t; @@ -632,7 +640,7 @@ module Make (IO: IO) (Store: Store.S) = struct PacketLine.input ic >>= function | None -> fail (Failure "Report_status.input: empty") | Some line -> - begin match String.lsplit2 line ~on:Misc.sp with + begin match Misc.string_lsplit2 line ~on:Misc.sp with | Some ("unpack", "ok") -> return `Ok | Some ("unpack", err ) -> return (`Error err) | _ -> fail (Failure "Report_status.input: unpack-status") @@ -641,12 +649,12 @@ module Make (IO: IO) (Store: Store.S) = struct PacketLine.input ic >>= function | None -> return acc | Some line -> - match String.lsplit2 line ~on:Misc.sp with - | Some ("ok", name) -> return ((Reference.of_string name, `Ok) :: acc) + match Misc.string_lsplit2 line ~on:Misc.sp with + | Some ("ok", name) -> return ((Reference.of_raw name, `Ok) :: acc) | Some ("ng", cont) -> - begin match String.lsplit2 cont ~on:Misc.sp with + begin match Misc.string_lsplit2 cont ~on:Misc.sp with | None -> fail (Failure "Report_status.input: command-fail") - | Some (name, err) -> return ((Reference.of_string name, `Error err) :: acc) + | Some (name, err) -> return ((Reference.of_raw name, `Error err) :: acc) end | _ -> fail (Failure "Report_status.input: command-status") in @@ -692,7 +700,7 @@ module Make (IO: IO) (Store: Store.S) = struct Store.read_reference t branch >>= fun new_obj -> let old_obj = Listing.find_reference listing branch in let command = match old_obj, new_obj with - | None , None -> failwith (Reference.to_string branch ^ ": unknown tag") + | None , None -> failwith (Reference.pretty branch ^ ": unknown tag") | Some x, None -> Update_request.Delete (branch, x) | None , Some x -> Update_request.Create (branch, x) | Some x, Some y -> Update_request.Update (branch, x, y) in @@ -702,8 +710,8 @@ module Make (IO: IO) (Store: Store.S) = struct | Update_request.Delete _ -> [Capability.Delete_refs] | _ -> [Capability.Ofs_delta ] in let commands = [ command ] in - let min = Map.keys (Listing.references listing) - |> List.map ~f:SHA.of_commit + let min = SHA.Commit.Map.keys (Listing.references listing) + |> List.map SHA.of_commit |> SHA.Set.of_list in let max = match new_obj with | None -> SHA.Set.empty @@ -726,29 +734,31 @@ module Make (IO: IO) (Store: Store.S) = struct Listing.input ic >>= fun listing -> Log.debugf "listing:\n %s" (Listing.pretty listing); let references = - List.fold_left ~f:(fun acc (sha1, refs) -> + List.fold_left (fun acc (sha1, refs) -> List.fold_left - ~f:(fun acc ref -> Reference.Map.add acc ~key:ref ~data:sha1) - ~init:acc + (fun acc ref -> Reference.Map.add ref sha1 acc) + acc refs - ) ~init:Reference.Map.empty - (Map.to_alist (Listing.references listing)) in + ) Reference.Map.empty + (SHA.Commit.Map.to_alist (Listing.references listing)) in let head = Listing.head listing in match op with | Ls -> return { Result.head; references; sha1s = [] } | Fetch _ | Clone _ -> - begin match Map.find references Reference.head with - | None -> return_unit - | Some sha1 -> + begin + try + let sha1 = Reference.Map.find Reference.head references in let contents = Reference.head_contents references sha1 in Store.write_head t contents + with Not_found -> + return_unit end >>= fun () -> let write_ref (ref, sha1) = if Reference.is_valid ref then Store.write_reference t ref sha1 else return_unit in - let references = Map.remove references Reference.head in - Misc.list_iter_p write_ref (Map.to_alist references) >>= fun () -> + let references = Reference.Map.remove Reference.head references in + Misc.list_iter_p write_ref (Reference.Map.to_alist references) >>= fun () -> match head with | None -> @@ -779,7 +789,7 @@ module Make (IO: IO) (Store: Store.S) = struct IO.read_all ic >>= fun raw -> printf " done.\n%!"; Log.debugf "Received a pack file of %d bytes." (String.length raw); - let pack = Bigstring.of_string raw in + let pack = Cstruct.of_string raw in let unpack = match op with | Clone { unpack } @@ -789,7 +799,7 @@ module Make (IO: IO) (Store: Store.S) = struct begin if unpack then Pack.unpack ~write:(Store.write t) pack else - let pack = Pack.Raw.input (Mstruct.of_bigarray pack) ~index:None in + let pack = Pack.Raw.input (Mstruct.of_cstruct pack) ~index:None in Store.write_pack t pack end >>= fun sha1s -> match SHA.Set.to_list sha1s with diff --git a/lib/tag.ml b/lib/tag.ml index cf002ead5..baefb823c 100644 --- a/lib/tag.ml +++ b/lib/tag.ml @@ -14,23 +14,22 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std +open Sexplib.Std +open Printf + module Log = Log.Make(struct let section = "tag" end) -module T = struct - type t = { - sha1 : SHA.t; - typ : Object_type.t; - tag : string; - tagger : User.t; - message: string; - } with bin_io, compare, sexp - let hash (t: t) = Hashtbl.hash t - include Sexpable.To_stringable (struct type nonrec t = t with sexp end) - let module_name = "Tag" -end -include T -include Identifiable.Make (T) +type t = { + sha1 : SHA.t; + typ : Object_type.t; + tag : string; + tagger : User.t; + message: string; +} with sexp + +let hash = Hashtbl.hash +let equal = (=) +let compare = compare let pretty t = sprintf @@ -43,13 +42,13 @@ let pretty t = (Object_type.to_string t.typ) t.tag (User.pretty t.tagger) - (String.strip t.message) + (String.trim t.message) let add_key_value buf k v = - Bigbuffer.add_string buf k; - Bigbuffer.add_char buf Misc.sp; - Bigbuffer.add_string buf v; - Bigbuffer.add_char buf Misc.lf + Buffer.add_string buf k; + Buffer.add_char buf Misc.sp; + Buffer.add_string buf v; + Buffer.add_char buf Misc.lf let input_object_type buf = let s = Mstruct.to_string buf in @@ -61,11 +60,11 @@ let add buf t = add_key_value buf "object" (SHA.to_hex t.sha1); add_key_value buf "type" (Object_type.to_string t.typ); add_key_value buf "tag" t.tag; - Bigbuffer.add_string buf "tagger "; + Buffer.add_string buf "tagger "; User.add buf t.tagger; - Bigbuffer.add_char buf Misc.lf; - Bigbuffer.add_char buf Misc.lf; - Bigbuffer.add_string buf t.message + Buffer.add_char buf Misc.lf; + Buffer.add_char buf Misc.lf; + Buffer.add_string buf t.message let input buf = let sha1 = Misc.input_key_value buf ~key:"object" SHA.input_hex in diff --git a/lib/tree.ml b/lib/tree.ml index 8d7baf5a5..e4a08678d 100644 --- a/lib/tree.ml +++ b/lib/tree.ml @@ -14,7 +14,9 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std +open Sexplib.Std +open Printf + module Log = Log.Make(struct let section = "tree" end) type perm = [ @@ -22,22 +24,19 @@ type perm = [ | `Exec | `Link | `Dir -] with bin_io, compare, sexp +] with sexp type entry = { perm: perm; name: string; node: SHA.t; -} with bin_io, compare, sexp +} with sexp + +type t = entry list with sexp -module T = struct - type t = entry list with bin_io, compare, sexp - let hash (t: t) = Hashtbl.hash t - include Sexpable.To_stringable (struct type nonrec t = t with sexp end) - let module_name = "Tree.Entry" -end -include T -include Identifiable.Make (T) +let hash = Hashtbl.hash +let compare = compare +let equal = (=) let pretty_perm = function | `Normal -> "normal" @@ -53,7 +52,7 @@ let pretty_entry e = let pretty t = let b = Buffer.create 1024 in - List.iter ~f:(fun e -> Buffer.add_string b (pretty_entry e)) t; + List.iter (fun e -> Buffer.add_string b (pretty_entry e)) t; Buffer.contents b let perm_of_string buf = function @@ -70,15 +69,15 @@ let string_of_perm = function | `Link -> "120000" | `Dir -> "40000" -let escape = Char.of_int_exn 42 +let escape = Char.chr 42 let escaped_chars = - escape :: List.map ~f:Char.of_int_exn [ 0x00; 0x2f ] + escape :: List.map Char.chr [ 0x00; 0x2f ] -let needs_escape = List.mem escaped_chars +let needs_escape x = List.mem x escaped_chars let encode path = - if not (String.exists ~f:needs_escape path) then + if not (Misc.string_exists needs_escape path) then path else let n = String.length path in @@ -86,41 +85,41 @@ let encode path = let last = ref 0 in for i = 0 to n - 1 do if needs_escape path.[i] then ( - let c = Char.of_int_exn (Char.to_int path.[i] + 1) in - if Int.(i - !last > 0) then Buffer.add_substring b path !last (i - !last); + let c = Char.chr (Char.code path.[i] + 1) in + if i - !last > 0 then Buffer.add_substring b path !last (i - !last); Buffer.add_char b escape; Buffer.add_char b c; last := i + 1; ) done; - if Int.(n - !last > 0) then + if n - !last > 0 then Buffer.add_substring b path !last (n - !last); Buffer.contents b let add_entry buf e = - Bigbuffer.add_string buf (string_of_perm e.perm); - Bigbuffer.add_char buf Misc.sp; - Bigbuffer.add_string buf (encode e.name); - Bigbuffer.add_char buf Misc.nul; + Buffer.add_string buf (string_of_perm e.perm); + Buffer.add_char buf Misc.sp; + Buffer.add_string buf (encode e.name); + Buffer.add_char buf Misc.nul; SHA.add buf e.node let decode path = - if not (String.mem path escape) then path + if not (Misc.string_mem escape path) then path else let n = String.length path in let b = Buffer.create n in let last = ref 0 in for i = 0 to n - 1 do if Char.(path.[i] = escape) then ( - if Int.(i - !last > 0) then Buffer.add_substring b path !last (i - !last); - if Int.(i + 1 < n) then ( - let c = Char.of_int_exn (Char.to_int path.[i+1] - 1) in + if i - !last > 0 then Buffer.add_substring b path !last (i - !last); + if i + 1 < n then ( + let c = Char.chr (Char.code path.[i+1] - 1) in Buffer.add_char b c; ); last := i + 2; ); done; - if Int.(n - !last > 0) then + if n - !last > 0 then Buffer.add_substring b path !last (n - !last); Buffer.contents b @@ -140,11 +139,11 @@ let input_entry buf = Some entry let add buf t = - List.iter ~f:(add_entry buf) t + List.iter (add_entry buf) t let input buf = let rec aux entries = - if Int.(Mstruct.length buf <= 0) then + if Mstruct.length buf <= 0 then List.rev entries else match input_entry buf with diff --git a/lib/user.ml b/lib/user.ml index 5a9883592..ed0defdd3 100644 --- a/lib/user.ml +++ b/lib/user.ml @@ -14,21 +14,20 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std +open Sexplib.Std +open Printf + module Log = Log.Make(struct let section = "user" end) -module T = struct - type t = { - name : string; - email: string; - date : string; - } with bin_io, compare, sexp - let hash (t : t) = Hashtbl.hash t - include Sexpable.To_stringable (struct type nonrec t = t with sexp end) - let module_name = "User" -end -include T -include Identifiable.Make (T) +type t = { + name : string; + email: string; + date : string; +} with sexp + +let hash = Hashtbl.hash +let equal = (=) +let compare = compare let pretty t = sprintf "[name: %s | email: %s | date: %s]" @@ -36,11 +35,11 @@ let pretty t = (* XXX needs to escape name/email/date *) let add buf t = - Bigbuffer.add_string buf t.name ; - Bigbuffer.add_string buf " <" ; - Bigbuffer.add_string buf t.email; - Bigbuffer.add_string buf "> " ; - Bigbuffer.add_string buf t.date + Buffer.add_string buf t.name ; + Buffer.add_string buf " <" ; + Buffer.add_string buf t.email; + Buffer.add_string buf "> " ; + Buffer.add_string buf t.date let input buf = let i = match Mstruct.index buf Misc.lt with diff --git a/lib/value.ml b/lib/value.ml index f0af0c2f9..da8259ff8 100644 --- a/lib/value.ml +++ b/lib/value.ml @@ -14,23 +14,22 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std +open Printf open Lwt +open Sexplib.Std + module Log = Log.Make(struct let section = "value" end) -module T = struct - type t = - | Blob of Blob.t - | Commit of Commit.t - | Tag of Tag.t - | Tree of Tree.t - with bin_io, compare, sexp - let hash (t: t) = Hashtbl.hash t - include Sexpable.To_stringable (struct type nonrec t = t with sexp end) - let module_name = "Value" -end -include T -include Identifiable.Make (T) +type t = + | Blob of Blob.t + | Commit of Commit.t + | Tag of Tag.t + | Tree of Tree.t +with sexp + +let equal = (=) +let hash = Hashtbl.hash +let compare = compare let pretty = function | Blob b -> sprintf "== Blob ==\n%s\n" (Blob.pretty b) @@ -56,28 +55,28 @@ let add_contents buf = function | Tree t -> Tree.add buf t let add_header buf typ size = - Bigbuffer.add_string buf (Object_type.to_string typ); - Bigbuffer.add_char buf Misc.sp; - Bigbuffer.add_string buf (string_of_int size); - Bigbuffer.add_char buf Misc.nul + Buffer.add_string buf (Object_type.to_string typ); + Buffer.add_char buf Misc.sp; + Buffer.add_string buf (string_of_int size); + Buffer.add_char buf Misc.nul let add_inflated buf t = Log.debugf "add_inflated"; - let tmp = Bigbuffer.create 1024 in + let tmp = Buffer.create 1024 in add_contents tmp t; - let size = Bigbuffer.length tmp in + let size = Buffer.length tmp in add_header buf (type_of t) size; - Bigbuffer.add_buffer buf tmp + Buffer.add_buffer buf tmp let sha1 t = let buf = Misc.with_buffer (fun buf -> add_inflated buf t) in SHA.create buf let add buf t = - Log.debugf "add %s" (to_string t); - let inflated = Misc.with_bigbuffer (fun buf -> add_inflated buf t) in - let deflated = Misc.deflate_bigstring inflated in - Bigbuffer.add_string buf (Bigstring.to_string deflated) + Log.debugf "add %s" (pretty t); + let inflated = Misc.with_buffer' (fun buf -> add_inflated buf t) in + let deflated = Misc.deflate_cstruct inflated in + Buffer.add_string buf (Cstruct.to_string deflated) let type_of_inflated buf = let obj_type = @@ -96,7 +95,7 @@ let input_inflated buf = | Some s -> try int_of_string s with _ -> Mstruct.parse_error_buf buf "%S is not a valid integer." s in - if Int.(size <> Mstruct.length buf) then + if size <> Mstruct.length buf then Mstruct.parse_error_buf buf "[expected-size: %d; actual-size: %d]\n" size (Mstruct.length buf); @@ -115,17 +114,18 @@ module Cache = struct (* XXX: this can go in Store.t if we want to avoid relying on a global state. But as the keys are always the SHA of the inflated contents, having a global cache is fine. *) - let cache = SHA.Table.create () + let cache = Hashtbl.create 1024 - let clear () = SHA.Table.clear cache + let clear () = Hashtbl.clear cache let find sha1: string option = - Hashtbl.find cache sha1 + try Some (Hashtbl.find cache sha1) + with Not_found -> None let find_exn sha1: string = - Hashtbl.find_exn cache sha1 + Hashtbl.find cache sha1 let add sha1 str = - ignore (Hashtbl.add cache ~key:sha1 ~data:str) + ignore (Hashtbl.add cache sha1 str) end diff --git a/lib/value.mli b/lib/value.mli index ff60a8ce1..ed2150cf7 100644 --- a/lib/value.mli +++ b/lib/value.mli @@ -16,13 +16,12 @@ (** Git objects. *) -open Core_kernel.Std - type t = | Blob of Blob.t | Commit of Commit.t | Tag of Tag.t | Tree of Tree.t +with sexp (** Loose git objects. *) val type_of: t -> Object_type.t @@ -49,10 +48,10 @@ val tag: Tag.t -> t (** {2 Inflated values} *) -val add_header: Bigbuffer.t -> Object_type.t -> int -> unit +val add_header: Buffer.t -> Object_type.t -> int -> unit (** Append the given object header to a buffer. *) -val add_inflated: Bigbuffer.t -> t -> unit +val add_inflated: Buffer.t -> t -> unit (** Append the inflated serialization of an object to a buffer. Similar to [add], but without deflating the contents. *) diff --git a/lib_test/test_common.ml b/lib_test/test_common.ml index 2e2ded9b6..84d354e6f 100644 --- a/lib_test/test_common.ml +++ b/lib_test/test_common.ml @@ -14,29 +14,18 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Core_kernel.Std open Git open Lwt - -module Bigstring = struct - include Bigstring - let compare t1 t2 = - match Int.compare (Bigstring.length t1) (Bigstring.length t2) with - | 0 -> String.compare (Bigstring.to_string t1) (Bigstring.to_string t2) - | i -> i - let equal t1 t2 = - Int.equal (Bigstring.length t1) (Bigstring.length t2) - && String.equal (Bigstring.to_string t1) (Bigstring.to_string t2) - - let pretty b = - sprintf "%S" (to_string b) -end +open Printf let () = Log.set_log_level Log.DEBUG; Log.color_on (); Log.set_output stderr +let pretty fn s = + Sexplib.Sexp.to_string_hum (fn s) + let cmp_opt fn x y = match x, y with | Some x, Some y -> fn x y @@ -56,7 +45,7 @@ let rec cmp_list fn x y = let printer_list f = function | [] -> "[]" - | l -> Printf.sprintf "[ %s ]" (String.concat ~sep:", " (List.map ~f l)) + | l -> Printf.sprintf "[ %s ]" (String.concat ", " (List.map f l)) let line msg = let line () = Alcotest.line stderr ~color:`Yellow '-' in @@ -81,31 +70,28 @@ module Make (S: Store.S) = struct mk SHA.equal SHA.compare SHA.to_hex let assert_value_equal, assert_value_opt_equal, assert_values_equal = - mk Value.equal Value.compare Value.to_string + mk Value.equal Value.compare (pretty Value.sexp_of_t) let assert_tag_equal, assert_tag_opt_equal, assert_tags_equal = - mk Tag.equal Tag.compare Tag.to_string + mk Tag.equal Tag.compare (pretty Tag.sexp_of_t) let assert_ref_equal, assert_ref_opt_equal, assert_refs_equal = - mk Reference.equal Reference.compare Reference.to_string + mk Reference.equal Reference.compare (pretty Reference.sexp_of_t) - let assert_bigstring_equal, assert_bigstring_opt_equal, assert_bigstrings_equal = - mk Bigstring.equal Bigstring.compare (fun b -> - if Bigstring.length b < 40 then Bigstring.pretty b - else sprintf "%S (%d)" (Bigstring.To_string.subo ~len:40 b) (Bigstring.length b) - ) + let assert_cstruct_equal, assert_cstruct_opt_equal, assert_cstructs_equal = + mk (=) compare Cstruct.debug let assert_pack_index_equal, assert_pack_index_opt_equal, assert_pack_indexes_equal = mk Pack_index.equal Pack_index.compare Pack_index.pretty let assert_pack_equal, assert_pack_opt_equal, assert_packs_equal = - mk Pack.equal Pack.compare Pack.to_string + mk Pack.equal Pack.compare Pack.pretty let assert_cache_equal, assert_cache_opt_equal, assert_caches_equal = - mk Cache.equal Cache.compare Cache.to_string + mk Cache.equal Cache.compare Cache.pretty let assert_raw_pack_equal, assert_raw_pack_opt_equal, assert_raw_packs_equal = - mk Pack.Raw.equal Pack.Raw.compare Pack.Raw.to_string + mk Pack.Raw.equal Pack.Raw.compare Pack.Raw.pretty end diff --git a/lib_test/test_mirage.ml b/lib_test/test_mirage.ml index 3446d2e94..03e7fdbee 100644 --- a/lib_test/test_mirage.ml +++ b/lib_test/test_mirage.ml @@ -51,7 +51,7 @@ module S = FS(M) let suite = { - name = "MIR-FAT"; + name = "MIR-FS-unix"; init = M.init; clean = unit; store = (module S); diff --git a/lib_test/test_store.ml b/lib_test/test_store.ml index abc963da7..af8d9ea93 100644 --- a/lib_test/test_store.ml +++ b/lib_test/test_store.ml @@ -17,7 +17,6 @@ open OUnit open Test_common open Lwt -open Core_kernel.Std open Git open Git_unix @@ -49,10 +48,10 @@ module Make (Store: Store.S) = struct raise e let long_random_string = Cryptokit.(Random.string (Random.device_rng "/dev/urandom") 1024) - let v1 = Value.blob (Blob.of_string long_random_string) + let v1 = Value.blob (Blob.of_raw long_random_string) let kv1 = Value.sha1 v1 - let v2 = Value.blob (Blob.of_string "") + let v2 = Value.blob (Blob.of_raw "") let kv2 = Value.sha1 v2 (* Create a node containing t1 -w-> v1 *) @@ -139,10 +138,10 @@ module Make (Store: Store.S) = struct let ktag2 = Value.sha1 tag2 (* r1: t4 *) - let r1 = Reference.of_string "refs/origin/head" + let r1 = Reference.of_raw "refs/origin/head" (* r2: c2 *) - let r2 = Reference.of_string "refs/upstream/head" + let r2 = Reference.of_raw "refs/upstream/head" let check_write t name k v = Store.write t v >>= fun k' -> @@ -272,17 +271,18 @@ module Make (Store: Store.S) = struct if x.name = "FS" then let test () = rec_files "." >>= fun files -> - Lwt_list.map_p (fun file -> - let blob = - file - |> In_channel.read_all - |> Blob.of_string in + let pool = Lwt_pool.create 200 (fun () -> return_unit) in + Git.Misc.list_map_p ~pool (fun file -> + Lwt_io.with_file ~mode:Lwt_io.input file (fun ic -> + Lwt_io.read ic >>= fun str -> + return (Blob.of_raw str) + ) >>= fun blob -> FS.entry_of_file file `Normal blob ) files >>= fun entries -> - let entries = List.filter_map ~f:(fun x -> x) entries in + let entries = Misc.list_filter_map (fun x -> x) entries in let cache = { Cache.entries; extensions = [] } in - let buf = Misc.with_bigbuffer (fun buf -> Cache.add buf cache) in - let cache2 = Cache.input (Mstruct.of_bigarray buf) in + let buf = Misc.with_buffer' (fun buf -> Cache.add buf cache) in + let cache2 = Cache.input (Mstruct.of_cstruct buf) in assert_cache_equal "cache" cache cache2; return_unit in @@ -294,39 +294,44 @@ module Make (Store: Store.S) = struct files "data/" >>= fun files -> if files = [] then failwith "Please run that test in lib_test/"; - let files = List.filter ~f:(fun file -> - String.is_suffix file ~suffix:".pack" + let files = List.filter (fun file -> + match Misc.string_chop_suffix file ~suffix:".pack" with + | None -> false + | Some _ -> true ) files in - let files = List.map ~f:(fun file -> - let name = String.chop_prefix_exn file ~prefix:"data/pack-" in - let name = String.chop_suffix_exn name ~suffix:".pack" in - file, "data/pack-" ^ name ^ ".idx" + let files = List.map (fun file -> + match Misc.string_chop_prefix file ~prefix:"data/pack-" with + | None -> failwith ("chop prefix " ^ file) + | Some name -> + match Misc.string_chop_suffix name ~suffix:".pack" with + | None -> failwith ("chop suffix " ^ name) + | Some name -> file, "data/pack-" ^ name ^ ".idx" ) files in - List.iter ~f:(fun (pack, index) -> + Lwt_list.iter_s (fun (pack, index) -> (* basic serialization of index files *) - let istr1 = In_channel.read_all index in + Lwt_io.with_file ~mode:Lwt_io.input index Lwt_io.read >>= fun istr1 -> let i1 = Pack_index.input (Mstruct.of_string istr1) in - let istr2 = Misc.with_bigbuffer (fun buf -> Pack_index.add buf i1) in - let i2 = Pack_index.input (Mstruct.of_bigarray istr2) in + let istr2 = Misc.with_buffer' (fun buf -> Pack_index.add buf i1) in + let i2 = Pack_index.input (Mstruct.of_cstruct istr2) in assert_pack_index_equal "pack-index" i1 i2; (* basic serialization of pack files *) - let pstr1 = In_channel.read_all pack in + Lwt_io.with_file ~mode:Lwt_io.input pack Lwt_io.read >>= fun pstr1 -> let rp1 = Pack.Raw.input (Mstruct.of_string pstr1) ~index:None in let rp1' = Pack.Raw.input (Mstruct.of_string pstr1) ~index:(Some i1) in assert_raw_pack_equal "raw-pack" rp1 rp1'; - let pstr2 = Misc.with_bigbuffer (fun buf -> Pack.Raw.add buf rp1) in - let rp2 = Pack.Raw.input (Mstruct.of_bigarray pstr2) ~index:None in + let pstr2 = Misc.with_buffer' (fun buf -> Pack.Raw.add buf rp1) in + let rp2 = Pack.Raw.input (Mstruct.of_cstruct pstr2) ~index:None in assert_pack_equal "pack" (Pack.to_pic rp1) (Pack.to_pic rp2); let i3 = Pack.Raw.index rp1 in assert_pack_index_equal "raw-pack-->>--pack-index" i1 i3; - ) files; + return_unit - return_unit + ) files in run x test @@ -360,5 +365,5 @@ let suite (speed, x) = ] let run name tl = - let tl = List.map ~f:suite tl in + let tl = List.map suite tl in Alcotest.run name tl diff --git a/setup.ml b/setup.ml index eb4d89f97..47aada336 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: 266158c020da3cc4558432af3b483e64) *) +(* DO NOT EDIT (digest: f4e61eb1ad24e28d0478fe4b58332cd7) *) (* Regenerated by OASIS v0.4.4 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6904,15 +6904,12 @@ let setup_t = [ FindlibPackage ("mstruct", None); FindlibPackage ("dolog", None); - FindlibPackage ("core_kernel", None); FindlibPackage ("ocamlgraph", None); FindlibPackage ("re.pcre", None); FindlibPackage ("zip", None); FindlibPackage ("sha", None); FindlibPackage ("uri", None); FindlibPackage ("lwt", None); - FindlibPackage ("bin_prot.syntax", None); - FindlibPackage ("comparelib.syntax", None); FindlibPackage ("sexplib.syntax", None); FindlibPackage ("conduit.lwt", None); FindlibPackage ("uri.services", None) @@ -7149,7 +7146,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.4"; - oasis_digest = Some "o2U/J0^\031$oã9¤èZ\""; + oasis_digest = Some "\144ËÄV\014\151j«T T\023\143ÔO´"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7157,6 +7154,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7161 "setup.ml" +# 7158 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 0e8250b243e5804b40173f2728330173df086553 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Thu, 16 Oct 2014 18:10:51 +0100 Subject: [PATCH 3/6] Use nocrypto instead of sha1 and cryptokit --- _oasis | 6 +++--- _tags | 12 +++++------- lib/FS.ml | 2 +- lib/META | 2 +- lib/SHA.ml | 12 ++++++++++-- lib/SHA.mli | 7 +++++-- lib/cache.ml | 6 +++--- lib/memory.ml | 2 +- lib/pack.ml | 8 ++++---- lib/pack_index.ml | 2 +- lib/value.ml | 2 +- lib_test/test_store.ml | 8 +++++++- setup.ml | 3 +-- 13 files changed, 43 insertions(+), 29 deletions(-) diff --git a/_oasis b/_oasis index 51e761bae..e20020c9d 100644 --- a/_oasis +++ b/_oasis @@ -25,11 +25,11 @@ Library git Object, Object_type, Store, Search, Gri, Memory, FS BuildDepends: mstruct, dolog, ocamlgraph, - re.pcre, zip, sha1, uri, lwt, + re.pcre, zip, nocrypto, uri, lwt, sexplib.syntax, conduit.lwt, uri.services XMETARequires: mstruct, dolog, ocamlgraph, - re.pcre, zip, sha, uri, lwt, + re.pcre, zip, nocrypto, uri, lwt, conduit.lwt, uri.services Library "git-unix" @@ -62,7 +62,7 @@ Executable test_git MainIs: test.ml CompiledObject: best Install: false - BuildDepends: alcotest, git, git.unix, cryptokit, + BuildDepends: alcotest, git, git.unix, git.mirage, io-page.unix, mirage-fs-unix Test test_git diff --git a/_tags b/_tags index f2684b15e..7bf1aa65c 100644 --- a/_tags +++ b/_tags @@ -48,10 +48,10 @@ : pkg_lwt : pkg_mirage-types.lwt : pkg_mstruct +: pkg_nocrypto : pkg_ocamlgraph : pkg_re.pcre : pkg_sexplib.syntax -: pkg_sha : pkg_uri : pkg_uri.services : pkg_zip @@ -63,10 +63,10 @@ : pkg_lwt : pkg_lwt.unix : pkg_mstruct +: pkg_nocrypto : pkg_ocamlgraph : pkg_re.pcre : pkg_sexplib.syntax -: pkg_sha : pkg_uri : pkg_uri.services : pkg_zip @@ -78,10 +78,10 @@ : pkg_lwt : pkg_lwt.unix : pkg_mstruct +: pkg_nocrypto : pkg_ocamlgraph : pkg_re.pcre : pkg_sexplib.syntax -: pkg_sha : pkg_uri : pkg_uri.services : pkg_zip @@ -90,7 +90,6 @@ # Executable test_git : pkg_alcotest : pkg_conduit.lwt -: pkg_cryptokit : pkg_dolog : pkg_io-page : pkg_io-page.unix @@ -99,10 +98,10 @@ : pkg_mirage-fs-unix : pkg_mirage-types.lwt : pkg_mstruct +: pkg_nocrypto : pkg_ocamlgraph : pkg_re.pcre : pkg_sexplib.syntax -: pkg_sha : pkg_uri : pkg_uri.services : pkg_zip @@ -111,7 +110,6 @@ : use_git-unix : pkg_alcotest : pkg_conduit.lwt -: pkg_cryptokit : pkg_dolog : pkg_io-page : pkg_io-page.unix @@ -120,10 +118,10 @@ : pkg_mirage-fs-unix : pkg_mirage-types.lwt : pkg_mstruct +: pkg_nocrypto : pkg_ocamlgraph : pkg_re.pcre : pkg_sexplib.syntax -: pkg_sha : pkg_uri : pkg_uri.services : pkg_zip diff --git a/lib/FS.ml b/lib/FS.ml index 34a9db4a8..368b33c73 100644 --- a/lib/FS.ml +++ b/lib/FS.ml @@ -91,7 +91,7 @@ module Loose = struct let write t value = Log.debugf "write"; let inflated = Misc.with_buffer (fun buf -> Value.add_inflated buf value) in - let sha1 = SHA.create inflated in + let sha1 = SHA.of_string inflated in let file = file t sha1 in IO.file_exists file >>= function | true -> return sha1 diff --git a/lib/META b/lib/META index 5802455c6..f9574515a 100644 --- a/lib/META +++ b/lib/META @@ -3,7 +3,7 @@ version = "1.2.0" description = "A low-level interface to Git in pure OCaml" requires = -"mstruct dolog ocamlgraph re.pcre zip sha uri lwt conduit.lwt uri.services" +"mstruct dolog ocamlgraph re.pcre zip nocrypto uri lwt conduit.lwt uri.services" archive(byte) = "git.cma" archive(byte, plugin) = "git.cma" archive(native) = "git.cmxa" diff --git a/lib/SHA.ml b/lib/SHA.ml index ac8a5dbaa..616365cc6 100644 --- a/lib/SHA.ml +++ b/lib/SHA.ml @@ -20,7 +20,8 @@ module Log = Log.Make(struct let section = "sha1" end) module type S = sig include Object.S - val create: string -> t + val of_string: string -> t + val of_cstruct: Cstruct.t -> t val to_raw: t -> string val of_raw: string -> t val to_hex: t -> string @@ -46,7 +47,14 @@ module SHA1_String = struct let of_raw x = x - let create str = Sha1.(to_bin (string str)) + let of_string str = + Cstruct.of_string str + |> Nocrypto.Hash.SHA1.digest + |> Cstruct.to_string + + let of_cstruct c = + Nocrypto.Hash.SHA1.digest c + |> Cstruct.to_string let to_hex t = Misc.hex_encode t diff --git a/lib/SHA.mli b/lib/SHA.mli index 49ab32651..c3011104b 100644 --- a/lib/SHA.mli +++ b/lib/SHA.mli @@ -20,8 +20,11 @@ module type S = sig include Object.S - val create: string -> t - (** Build a node from a raw bigstring. *) + val of_string: string -> t + (** Build a hash from a string. *) + + val of_cstruct: Cstruct.t -> t + (** Build a hash from a cstruct. *) val to_raw: t -> string (** Raw SHA1 value. *) diff --git a/lib/cache.ml b/lib/cache.ml index 514fb6347..8aae0b661 100644 --- a/lib/cache.ml +++ b/lib/cache.ml @@ -212,8 +212,8 @@ let input buf = ); let actual_checksum = Cstruct.sub all offset length - |> Cstruct.to_string - |> SHA.create in + |> SHA.of_cstruct + in let checksum = SHA.input buf in if SHA.(actual_checksum <> checksum) then ( eprintf "Cach.input: wrong checksum"; @@ -234,6 +234,6 @@ let add buf t = Buffer.add_string buf (Cstruct.to_string header); List.iter (add_entry buf) t.entries; ) in - let sha1 = SHA.create str in + let sha1 = SHA.of_string str in Buffer.add_string buf str; Buffer.add_string buf (SHA.to_raw sha1) diff --git a/lib/memory.ml b/lib/memory.ml index a90b98afd..e4a4ef755 100644 --- a/lib/memory.ml +++ b/lib/memory.ml @@ -52,7 +52,7 @@ let clear t = let write t value = let inflated = Misc.with_buffer (fun buf -> Value.add_inflated buf value) in - let sha1 = SHA.create inflated in + let sha1 = SHA.of_string inflated in try let _ = Hashtbl.find t.values sha1 in return sha1 diff --git a/lib/pack.ml b/lib/pack.ml index 008cc5dd4..d7efe6ebd 100644 --- a/lib/pack.ml +++ b/lib/pack.ml @@ -105,7 +105,7 @@ module Raw = struct let index_of_values ~pack_checksum values = let read sha1 = Value.Cache.find_exn sha1 in let write buffer = - let sha1 = SHA.create buffer in + let sha1 = SHA.of_string buffer in Value.Cache.add sha1 buffer; sha1 in let size = List.length values in @@ -130,7 +130,7 @@ module Raw = struct |> List.sort String.compare |> List.rev |> String.concat "" - |> SHA.create + |> SHA.of_string let input buf ~index = let all = Mstruct.to_cstruct buf in @@ -147,7 +147,7 @@ module Raw = struct done; let str = Cstruct.sub all 0 (Mstruct.offset buf - offset) in let pack_checksum = SHA.input buf in - let checksum = SHA.create (Cstruct.to_string str) in + let checksum = SHA.of_cstruct str in if checksum <> pack_checksum then ( eprintf "Pack.Raw.input: wrong file checksum. Got: %s, expecting %s." (SHA.to_hex checksum) (SHA.to_hex pack_checksum); @@ -239,7 +239,7 @@ let add buf t = add_packed_value ~version buf p; Packed_value.PIC.Map.add pic pos index ) Packed_value.PIC.Map.empty t in - let sha1 = SHA.create (Buffer.contents buf) in + let sha1 = SHA.of_string (Buffer.contents buf) in Log.debugf "add sha1: %s" (SHA.to_hex sha1); SHA.add buf sha1 diff --git a/lib/pack_index.ml b/lib/pack_index.ml index 8c41e2a1e..86de5bc9a 100644 --- a/lib/pack_index.ml +++ b/lib/pack_index.ml @@ -228,5 +228,5 @@ let add buf t = (* XXX: SHA.of_bigstring *) let str = Buffer.contents buf in - let checksum = SHA.create str in + let checksum = SHA.of_string str in Buffer.add_string buf (SHA.to_raw checksum) diff --git a/lib/value.ml b/lib/value.ml index da8259ff8..6daddf331 100644 --- a/lib/value.ml +++ b/lib/value.ml @@ -70,7 +70,7 @@ let add_inflated buf t = let sha1 t = let buf = Misc.with_buffer (fun buf -> add_inflated buf t) in - SHA.create buf + SHA.of_string buf let add buf t = Log.debugf "add %s" (pretty t); diff --git a/lib_test/test_store.ml b/lib_test/test_store.ml index af8d9ea93..af078c48e 100644 --- a/lib_test/test_store.ml +++ b/lib_test/test_store.ml @@ -47,7 +47,13 @@ module Make (Store: Store.S) = struct Lwt_unix.run (x.clean ()); raise e - let long_random_string = Cryptokit.(Random.string (Random.device_rng "/dev/urandom") 1024) + let long_random_string = + let t = Unix.gettimeofday () in + let cs = Cstruct.create 8 in + Cstruct.BE.set_uint64 cs 0 Int64.(of_float (t *. 1000.)) ; + Nocrypto.Rng.reseed cs; + Cstruct.to_string (Nocrypto.Rng.generate 1024) + let v1 = Value.blob (Blob.of_raw long_random_string) let kv1 = Value.sha1 v1 diff --git a/setup.ml b/setup.ml index 47aada336..5d9a33e3d 100644 --- a/setup.ml +++ b/setup.ml @@ -6907,7 +6907,7 @@ let setup_t = FindlibPackage ("ocamlgraph", None); FindlibPackage ("re.pcre", None); FindlibPackage ("zip", None); - FindlibPackage ("sha", None); + FindlibPackage ("nocrypto", None); FindlibPackage ("uri", None); FindlibPackage ("lwt", None); FindlibPackage ("sexplib.syntax", None); @@ -7090,7 +7090,6 @@ let setup_t = FindlibPackage ("alcotest", None); InternalLibrary "git"; InternalLibrary "git-unix"; - FindlibPackage ("cryptokit", None); InternalLibrary "git-mirage"; FindlibPackage ("io-page.unix", None); FindlibPackage ("mirage-fs-unix", None) From 69f88408636d74ad9d9de919a24f66345eabee0a Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Thu, 16 Oct 2014 18:11:12 +0100 Subject: [PATCH 4/6] Bump version --- CHANGES | 4 ++++ _oasis | 2 +- _tags | 2 +- lib/META | 8 ++++---- setup.ml | 8 ++++---- 5 files changed, 14 insertions(+), 10 deletions(-) diff --git a/CHANGES b/CHANGES index 590953aee..441f2a6e8 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,7 @@ +1.3.0 (2014-10-16) +* Remove the dependency towards core_kernel +* Use ocaml-nocrypto instead of ocaml-sha1 + 1.2.0: (2014-06-10) * Can consume Mirage's V1_LWT.FS signature to generate a persistent store. This allows to store Git repos directly diff --git a/_oasis b/_oasis index e20020c9d..530015582 100644 --- a/_oasis +++ b/_oasis @@ -1,6 +1,6 @@ OASISFormat: 0.4 Name: git -Version: 1.2.0 +Version: 1.3.0 Synopsis: A low-level interface to Git in pure OCaml Authors: Thomas Gazagnaire License: ISC diff --git a/_tags b/_tags index 7bf1aa65c..87d9f1188 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 14436c0ca6aa90315cd309e2c2d5339b) +# DO NOT EDIT (digest: 8fc45ce2777b5d3ac5333d6a01a5967a) # 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 diff --git a/lib/META b/lib/META index f9574515a..47844a40c 100644 --- a/lib/META +++ b/lib/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 3a1de1ea966dac0d0c40c26e3713897e) -version = "1.2.0" +# DO NOT EDIT (digest: cd4ea8a7a4cee228b31e56a1d87d95e0) +version = "1.3.0" description = "A low-level interface to Git in pure OCaml" requires = "mstruct dolog ocamlgraph re.pcre zip nocrypto uri lwt conduit.lwt uri.services" @@ -10,7 +10,7 @@ archive(native) = "git.cmxa" archive(native, plugin) = "git.cmxs" exists_if = "git.cma" package "unix" ( - version = "1.2.0" + version = "1.3.0" description = "A low-level interface to Git in pure OCaml" requires = "git lwt.unix" archive(byte) = "git-unix.cma" @@ -21,7 +21,7 @@ package "unix" ( ) package "mirage" ( - version = "1.2.0" + version = "1.3.0" description = "A low-level interface to Git in pure OCaml" requires = "git mirage-types.lwt io-page" archive(byte) = "git-mirage.cma" diff --git a/setup.ml b/setup.ml index 5d9a33e3d..a2b6520af 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: f4e61eb1ad24e28d0478fe4b58332cd7) *) +(* DO NOT EDIT (digest: d458c3f8fbab94f23580d63a392f9c46) *) (* Regenerated by OASIS v0.4.4 Visit http://oasis.forge.ocamlcore.org for more information and @@ -6816,7 +6816,7 @@ let setup_t = alpha_features = []; beta_features = []; name = "git"; - version = "1.2.0"; + version = "1.3.0"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit @@ -7145,7 +7145,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.4"; - oasis_digest = Some "\144ËÄV\014\151j«T T\023\143ÔO´"; + oasis_digest = Some "O³*\b\026×EÂ{å¥ÉÁ×Û¥"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7153,6 +7153,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7158 "setup.ml" +# 7157 "setup.ml" (* OASIS_STOP *) let () = setup ();; From a40342444734a4d3565e6bf04419012afc77c455 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Thu, 16 Oct 2014 19:05:11 +0100 Subject: [PATCH 5/6] Update Travis deps --- .travis-ci.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis-ci.sh b/.travis-ci.sh index 6326813a5..cd288cefd 100755 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -1,6 +1,6 @@ # OPAM packages needed to build tests. -OPAM_PACKAGES="camlzip dolog core_kernel cryptokit uri \ - cmdliner sha mstruct re ocamlgraph \ +OPAM_PACKAGES="camlzip dolog nocrypto uri \ + cmdliner mstruct re ocamlgraph \ alcotest lwt \ conduit uri mirage-fs-unix io-page ipaddr" From d272ef56daec87b9ca2aca81e2fb5e177cf8fbba Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Thu, 16 Oct 2014 19:23:57 +0100 Subject: [PATCH 6/6] Add the correct external deps in Travis scripts for zarith --- .travis-ci.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis-ci.sh b/.travis-ci.sh index cd288cefd..7ff3c71a7 100755 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -7,7 +7,7 @@ OPAM_PACKAGES="camlzip dolog nocrypto uri \ ppa=avsm/ocaml41+opam11 echo "yes" | sudo add-apt-repository ppa:$ppa sudo apt-get update -qq -sudo apt-get install -qq ocaml ocaml-native-compilers camlp4-extra opam +sudo apt-get install -qq ocaml ocaml-native-compilers camlp4-extra opam libgmp-dev export OPAMYES=1 opam init git://github.com/ocaml/opam-repository >/dev/null 2>&1