From d988691d28e0db977810658366e9b0e6c36a6260 Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Mon, 17 Oct 2022 11:19:21 +0200 Subject: [PATCH] Be able to use relative or absolute path when we manipulate the Git index file --- src/git-index/git_index.ml | 63 +++++++++++++++++++++++++++---------- src/git-index/git_index.mli | 9 ++++-- test/index/test.ml | 42 +++++++++++++++++++++---- 3 files changed, 90 insertions(+), 24 deletions(-) diff --git a/src/git-index/git_index.ml b/src/git-index/git_index.ml index f5edd560f..a34f25e38 100644 --- a/src/git-index/git_index.ml +++ b/src/git-index/git_index.ml @@ -132,11 +132,19 @@ module Entry = struct | Unix.S_SOCK -> Fmt.invalid_arg "Git does not handle socket" let oid_of_blob : - type oid. hash:oid hash -> Fpath.t -> (oid, [> Rresult.R.msg ]) result = - fun ~hash path -> + type oid. + hash:oid hash -> + ?root:Fpath.t -> + Fpath.t -> + (oid, [> Rresult.R.msg ]) result = + fun ~hash ?root path -> let module Hash = (val module_of hash) in try - let ic = open_in_bin (Fpath.to_string path) in + let ic = + match root with + | Some root -> open_in_bin Fpath.(to_string (root // path)) + | None -> open_in_bin (Fpath.to_string path) + in let tmp = Bytes.create io_buffer_size in let ctx = Hash.empty in let rec go ctx = @@ -155,10 +163,19 @@ module Entry = struct Rresult.R.error_msgf "%a: %s" Fpath.pp path (Printexc.to_string exn) let oid_of_link : - type oid. hash:oid hash -> Fpath.t -> (oid, [> Rresult.R.msg ]) result = - fun ~hash path -> + type oid. + hash:oid hash -> + ?root:Fpath.t -> + Fpath.t -> + (oid, [> Rresult.R.msg ]) result = + fun ~hash ?root path -> let module Hash = (val module_of hash) in - let contents = Unix.readlink (Fpath.to_string path) in + let contents = + let path = + match root with Some root -> Fpath.(root // path) | None -> path + in + Unix.readlink (Fpath.to_string path) + in let contents = Astring.String.map (function '\\' -> '/' | c -> c) contents in @@ -169,7 +186,7 @@ module Entry = struct in Rresult.R.ok (Hash.get ctx) - let make ~hash path = + let make ~hash ?root path = try let stat = Unix.lstat (Fpath.to_string path) in let ctime_nsec, ctime_sec = Float.modf stat.Unix.st_ctime in @@ -181,8 +198,8 @@ module Entry = struct let open Rresult in (match stat.Unix.st_kind with | Unix.S_DIR -> Fmt.invalid_arg "Git sub-module are not implemented" - | Unix.S_REG -> oid_of_blob ~hash path - | Unix.S_LNK -> oid_of_link ~hash path + | Unix.S_REG -> oid_of_blob ~hash ?root path + | Unix.S_LNK -> oid_of_link ~hash ?root path | _kind -> Fmt.invalid_arg "Invalid kind") >>| fun oid -> { @@ -430,7 +447,11 @@ module Entry = struct ] end -type 'oid t = { mutable entries : 'oid Entry.t array; version : int } +type 'oid t = { + mutable entries : 'oid Entry.t array; + root : Fpath.t; + version : int; +} let empty_index_file : type oid. version:int -> hash:oid hash -> Bigstringaf.t * oid = @@ -446,10 +467,11 @@ let empty_index_file : ~len:Hash.digest_size; res, Hash.of_raw_string hash -let make : type oid. ?version:int -> oid hash -> oid t = - fun ?(version = 2) _ -> { entries = [||]; version } +let make : type oid. ?version:int -> oid hash -> root:Fpath.t -> oid t = + fun ?(version = 2) _ ~root -> { entries = [||]; root; version } let exists t path = + let path = Option.value ~default:path (Fpath.relativize ~root:t.root path) in let rec go n = if n >= Array.length t.entries then false else if Fpath.equal t.entries.(n).name path then true @@ -458,6 +480,7 @@ let exists t path = go 0 let find t path = + let path = Option.value ~default:path (Fpath.relativize ~root:t.root path) in let rec go n = if n >= Array.length t.entries then None else if Fpath.equal t.entries.(n).name path then Some t.entries.(n) @@ -466,6 +489,7 @@ let find t path = go 0 let pos_of_entry t path = + let path = Option.value ~default:path (Fpath.relativize ~root:t.root path) in let rec go first last = if last > first then let next = first + ((last - first) lsr 1) in @@ -500,8 +524,9 @@ let add : type oid. hash:oid hash -> Fpath.t -> oid t -> (unit, [> Rresult.R.msg ]) result = fun ~hash path t -> + let path = Option.value ~default:path (Fpath.relativize ~root:t.root path) in let open Rresult in - Entry.make ~hash path >>= fun entry -> + Entry.make ~hash ~root:t.root path >>= fun entry -> (* entry.ce_flags <- entry.ce_flags lor Entry._ce_intent_to_add ; XXX(dinosaure): [CE_INTENT_TO_ADD] adds [M] into [git status --porcelain] *) match find t path with @@ -528,6 +553,7 @@ let add : let rem : Fpath.t -> 'oid t -> unit = fun path t -> + let path = Option.value ~default:path (Fpath.relativize ~root:t.root path) in let pos = pos_of_entry t path in let pos = if pos < 0 then -pos - 1 else pos in let rec go pos = @@ -708,8 +734,12 @@ let load_extension ~off buffer = | ext -> Fmt.invalid_arg "Invalid or unsupported extension: %08lx" ext let load : - type oid. hash:oid hash -> Fpath.t -> (oid t, [> Rresult.R.msg ]) result = - fun ~hash path -> + type oid. + hash:oid hash -> + root:Fpath.t -> + Fpath.t -> + (oid t, [> Rresult.R.msg ]) result = + fun ~hash ~root path -> let open Rresult in let module Hash = (val module_of hash) in let load path = @@ -752,7 +782,8 @@ let load : let len = Hash.digest_size in Hash.of_raw_string (Bigstringaf.substring mmap ~off ~len) in - if Hash.equal oid0 oid1 then R.ok { entries = Array.of_list entries; version } + if Hash.equal oid0 oid1 then + R.ok { entries = Array.of_list entries; root; version } else R.error_msgf "Invalid hash (%a <> %a)" Hash.pp oid0 Hash.pp oid1 let store : diff --git a/src/git-index/git_index.mli b/src/git-index/git_index.mli index 41ca65b77..f83e66229 100644 --- a/src/git-index/git_index.mli +++ b/src/git-index/git_index.mli @@ -19,8 +19,13 @@ val add : hash:'oid hash -> Fpath.t -> 'oid t -> (unit, [> Rresult.R.msg ]) result val rem : Fpath.t -> 'oid t -> unit -val make : ?version:int -> 'oid hash -> 'oid t -val load : hash:'oid hash -> Fpath.t -> ('oid t, [> Rresult.R.msg ]) result +val make : ?version:int -> 'oid hash -> root:Fpath.t -> 'oid t + +val load : + hash:'oid hash -> + root:Fpath.t -> + Fpath.t -> + ('oid t, [> Rresult.R.msg ]) result val store : hash:'oid hash -> append:('fd -> Bigstringaf.t -> 'fd) -> 'fd -> 'oid t -> 'fd diff --git a/test/index/test.ml b/test/index/test.ml index c20383ae6..aa34b59ca 100644 --- a/test/index/test.ml +++ b/test/index/test.ml @@ -23,7 +23,7 @@ open Git_index let empty = Alcotest.test_case "empty" `Quick @@ fun path -> - let index = make SHA1 in + let index = make ~root:path SHA1 in let run path = let open Rresult in Bos.OS.Dir.with_current path @@ fun () -> @@ -31,7 +31,7 @@ let empty = let status = Bos.Cmd.(v "git" % "status" % "--porcelain") in let status = Bos.OS.Cmd.run_out status in Bos.OS.Cmd.out_lines status >>= function - | [], _ -> load ~hash:SHA1 Fpath.(v ".git" / "index") + | [], _ -> load ~hash:SHA1 ~root:path Fpath.(v ".git" / "index") | res, _ -> Alcotest.failf "git-status: @[%a@]" Fmt.(Dump.list string) res in @@ -45,7 +45,7 @@ let add_should_be_empty = let open Rresult in Bos.OS.Dir.with_current path @@ fun () -> Bos.OS.File.write Fpath.(v "should-be-empty") "" >>= fun () -> - let index = make SHA1 in + let index = make ~root:path SHA1 in add ~hash:SHA1 Fpath.(v "should-be-empty") index >>= fun () -> store_to_path ~hash:SHA1 Fpath.(v ".git" / "index") index >>= fun () -> let status = Bos.Cmd.(v "git" % "status" % "--porcelain") in @@ -128,7 +128,7 @@ let write_tree expect = let run path = let open Rresult in Bos.OS.Dir.with_current path @@ fun () -> - load ~hash:SHA1 Fpath.(v ".git" / "index") >>= fun t -> + load ~hash:SHA1 ~root:path Fpath.(v ".git" / "index") >>= fun t -> let fiber = let open Lwt.Infix in Git_unix.Store.v Fpath.(v ".") @@ -188,7 +188,7 @@ let delete_should_be_empty = Bos.Cmd.(v "git" % "config" % "user.email" % "pseudo@pseudo.invalid") >>= fun () -> Bos.OS.Cmd.run Bos.Cmd.(v "git" % "commit" % "-m" % ".") >>= fun () -> - load ~hash:SHA1 Fpath.(v ".git" / "index") >>= fun t -> + load ~hash:SHA1 ~root:path Fpath.(v ".git" / "index") >>= fun t -> (* XXX(dinosaure): [git] deletes [should-be-empty] into the index file **AND** concretely into the file-system. *) rem Fpath.(v "should-be-empty") t; @@ -258,7 +258,7 @@ let populate = link "hello path3/subp3/file3" ~target:Fpath.(v "path3" / "subp3" / "file3sym") >>= fun () -> - let index = make SHA1 in + let index = make ~root:path SHA1 in add ~hash:SHA1 Fpath.(v "path0") index >>= fun () -> add ~hash:SHA1 Fpath.(v "path2" / "file2") index >>= fun () -> add ~hash:SHA1 Fpath.(v "path3" / "file3") index >>= fun () -> @@ -297,6 +297,34 @@ let populate = | Error (`Store err) -> Alcotest.failf "git: %a" Git_unix.Store.pp_error err | Error (`Msg err) -> Alcotest.fail err +let fold = + Alcotest.test_case "fold and absolute path" `Quick @@ fun _path -> + let run () = + let open Rresult in + Fmt.pr ">>> create new Git repository (tmp: %a).\n%!" Fpath.pp + (Bos.OS.Dir.default_tmp ()); + Bos.OS.Dir.tmp "git-%s" >>= fun root -> + Fmt.pr ">>> New Git repository created: %a.\n%!" Fpath.pp root; + Bos.OS.Dir.with_current root + (fun () -> + Bos.OS.Cmd.run Bos.Cmd.(v "git" % "init") >>= fun () -> + Bos.OS.Cmd.run + Bos.Cmd.(v "git" % "config" % "init.defaultBranch" % "master") + >>= fun () -> + Bos.OS.Cmd.run Bos.Cmd.(v "git" % "checkout-index" % "-u") >>= fun _ -> + Bos.OS.File.write Fpath.(v "foo") "foo" >>= fun () -> + load ~hash:SHA1 ~root Fpath.(v ".git" / "index") >>= fun index -> + add ~hash:SHA1 Fpath.(root / "foo") index >>= fun () -> + Fmt.pr ">>> Start to fold.\n%!"; + Git_index.fold ~f:(fun _e _lst _acc -> Lwt_result.return ()) () index + |> Lwt_main.run) + () + in + match run () |> Rresult.R.join with + | Ok () -> () + | Error (`Store err) -> Alcotest.failf "git: %a" Git_unix.Store.pp_error err + | Error (`Msg err) -> Alcotest.fail err + open Cmdliner let store = @@ -313,6 +341,7 @@ let random = let create () = let open Rresult in Bos.OS.Dir.tmp "git-%s" >>= fun root -> + Fmt.pr ">>> New Git repository created: %a.\n%!" Fpath.pp root; Bos.OS.Dir.with_current root (fun () -> Bos.OS.Cmd.run Bos.Cmd.(v "git" % "init") >>= fun () -> @@ -332,6 +361,7 @@ let store = let () = Alcotest.run_with_args "index" store [ + "usage", [ fold ]; ( "index", [ empty;