Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Be able to use relative or absolute path when we manipulate the Git index file #596

Open
wants to merge 1 commit into
base: main
Choose a base branch
from
Open

Be able to use relative or absolute path when we manipulate the Git index file #596

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
63 changes: 47 additions & 16 deletions src/git-index/git_index.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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 ->
{
Expand Down Expand Up @@ -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 =
Expand All @@ -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
Expand All @@ -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)
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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 =
Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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 :
Expand Down
9 changes: 7 additions & 2 deletions src/git-index/git_index.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
42 changes: 36 additions & 6 deletions test/index/test.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,15 +23,15 @@ 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 () ->
store_to_path ~hash:SHA1 Fpath.(v ".git" / "index") index >>= fun () ->
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: @[<hov>%a@]" Fmt.(Dump.list string) res
in
Expand All @@ -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
Expand Down Expand Up @@ -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 ".")
Expand Down Expand Up @@ -188,7 +188,7 @@ let delete_should_be_empty =
Bos.Cmd.(v "git" % "config" % "user.email" % "[email protected]")
>>= 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;
Expand Down Expand Up @@ -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 () ->
Expand Down Expand Up @@ -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 =
Expand All @@ -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 () ->
Expand All @@ -332,6 +361,7 @@ let store =
let () =
Alcotest.run_with_args "index" store
[
"usage", [ fold ];
( "index",
[
empty;
Expand Down