From 65f850cf4405ea87b1cca0797989164978ee8073 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Fri, 25 Oct 2024 11:47:35 +0200 Subject: [PATCH 01/12] Refactor test/dune and add a failing test The failing test shows how writes during a change_and_push are not readable. --- test/dune | 11 +++++++++-- test/fold2.t | 16 ++++++++++++++++ 2 files changed, 25 insertions(+), 2 deletions(-) create mode 100644 test/fold2.t diff --git a/test/dune b/test/dune index 1c0a228..45a02f5 100644 --- a/test/dune +++ b/test/dune @@ -1,14 +1,21 @@ +(env (_ (binaries (../app/mgit.exe as mgit)))) (cram (package git-kv) (applies_to simple) (locks p9418) - (deps %{exe:../app/mgit.exe})) + (deps %{bin:mgit})) (cram (package git-kv) (applies_to fold) (locks p9418) - (deps %{exe:../app/mgit.exe})) + (deps %{bin:mgit})) + +(cram + (package git-kv) + (applies_to fold2) + (locks p9418) + (deps %{bin:mgit})) (executable (name git_daemon_exists) diff --git a/test/fold2.t b/test/fold2.t new file mode 100644 index 0000000..5cd2548 --- /dev/null +++ b/test/fold2.t @@ -0,0 +1,16 @@ +Reading during batch operation + $ mkdir simple + $ git init --bare -q simple 2> /dev/null + $ git daemon --base-path=. --export-all --enable=receive-pack --reuseaddr --pid-file=pid --detach + $ mgit git://localhost/simple#main << EOF + > fold + > set /bar "Git rocks!" + > get /bar + > quit + > quit + 00000000: 4769 7420 726f 636b 7321 Git rocks! + $ cd simple + $ git log main --pretty=oneline | wc -l + 1 + $ cd .. + $ kill $(cat pid) From 4f93219f1d3610f2095a3eafe6fd4084519584e0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Fri, 25 Oct 2024 13:03:30 +0200 Subject: [PATCH 02/12] Read staged files --- src/git_kv.ml | 40 +++++++++++++++++++++------------------- test/fold.t | 2 +- test/fold2.t | 2 ++ 3 files changed, 24 insertions(+), 20 deletions(-) diff --git a/src/git_kv.ml b/src/git_kv.ml index 3e72f27..af3094e 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -395,25 +395,26 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct | `Reference_not_found _ | `Msg _ as err -> Store.pp_error ppf err | `Hash_not_found hash -> Store.pp_error ppf (`Not_found hash) + let noppp t key = + match t.committed, t.head with + | None, None -> Lwt.return None + | Some (tree_root_hash, _), _ -> + Search.find t.store tree_root_hash (`Path (Mirage_kv.Key.segments key)) + | None, Some commit -> + Search.find t.store commit (`Commit (`Path (Mirage_kv.Key.segments key))) + let exists t key = let open Lwt.Infix in - match t.head with + noppp t key >>= function | None -> Lwt.return (Ok None) - | Some head -> - Search.mem t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function - | false -> Lwt.return (Ok None) - | true -> - Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) - >|= Option.get >>= Store.read_exn t.store >>= function + | Some tree_hash -> + Store.read_exn t.store tree_hash >>= function | Blob _ -> Lwt.return (Ok (Some `Value)) | Tree _ | Commit _ | Tag _ -> Lwt.return (Ok (Some `Dictionary)) let get t key = let open Lwt.Infix in - match t.head with - | None -> Lwt.return (Error (`Not_found key)) - | Some head -> - Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function + noppp t key >>= function | None -> Lwt.return (Error (`Not_found key)) | Some blob -> Store.read_exn t.store blob >|= function @@ -434,10 +435,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let list t key = let open Lwt.Infix in - match t.head with - | None -> Lwt.return (Error (`Not_found key)) - | Some head -> - Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function + noppp t key >>= function | None -> Lwt.return (Error (`Not_found key)) | Some tree -> Store.read_exn t.store tree >>= function @@ -455,6 +453,8 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let last_modified t key = let open Lwt.Infix in + noppp t key >>= + (* FIXME *) Option.fold ~none:(Lwt.return (Error (`Not_found key))) ~some:(fun head -> @@ -478,13 +478,14 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct in Ok ts | _ -> assert false) - t.head let digest t key = + let open Lwt.Infix in + noppp t key >>= + (* FIXME *) Option.fold - ~none:(Error (`Not_found key)) - ~some:(fun x -> Ok (Store.Hash.to_raw_string x)) - t.head |> Lwt.return + ~none:(Lwt.return (Error (`Not_found key))) + ~some:(fun x -> Lwt.return (Ok (Store.Hash.to_raw_string x))) let size t key = let open Lwt_result.Infix in @@ -593,6 +594,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let remove ?and_commit t key = let segs = Mirage_kv.Key.segments key in + (* FIXME: t.head *) match List.rev segs, t.head with | [], _ -> assert false | _, None -> Lwt.return_ok () (* XXX(dinosaure): or [`Not_found]? *) diff --git a/test/fold.t b/test/fold.t index 5e8b846..10428a2 100644 --- a/test/fold.t +++ b/test/fold.t @@ -11,7 +11,7 @@ Batch operation > exists /bar > quit > quit - /bar does not exists + /bar exists as a value $ mgit git://localhost/simple#main < list / > get /bar diff --git a/test/fold2.t b/test/fold2.t index 5cd2548..e95f27c 100644 --- a/test/fold2.t +++ b/test/fold2.t @@ -5,9 +5,11 @@ Reading during batch operation $ mgit git://localhost/simple#main << EOF > fold > set /bar "Git rocks!" + > list / > get /bar > quit > quit + - /bar 00000000: 4769 7420 726f 636b 7321 Git rocks! $ cd simple $ git log main --pretty=oneline | wc -l From f1c7403a7f33d9107925c81a36fe199de7bdc828 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 26 Oct 2024 17:34:04 +0200 Subject: [PATCH 03/12] minor nits to get tests running on FreeBSD --- test/fold.t | 4 ++-- test/fold2.t | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/test/fold.t b/test/fold.t index 10428a2..cf67cb3 100644 --- a/test/fold.t +++ b/test/fold.t @@ -5,7 +5,7 @@ Batch operation $ cd .. $ git daemon --base-path=. --export-all --enable=receive-pack --reuseaddr --pid-file=pid --detach $ mgit git://localhost/simple#main < fold + > fold > set /bar "Git rocks!" > set /foo "Hello World!" > exists /bar @@ -22,7 +22,7 @@ Batch operation 00000000: 4769 7420 726f 636b 7321 Git rocks! 00000000: 4865 6c6c 6f20 576f 726c 6421 Hello World! $ cd simple - $ git log main --pretty=oneline | wc -l + $ git log main --pretty=oneline | wc -l | tr -d ' ' 1 $ cd .. $ kill $(cat pid) diff --git a/test/fold2.t b/test/fold2.t index e95f27c..932de0a 100644 --- a/test/fold2.t +++ b/test/fold2.t @@ -12,7 +12,7 @@ Reading during batch operation - /bar 00000000: 4769 7420 726f 636b 7321 Git rocks! $ cd simple - $ git log main --pretty=oneline | wc -l + $ git log main --pretty=oneline | wc -l | tr -d ' ' 1 $ cd .. $ kill $(cat pid) From b1e995532b810160f306cc08ad7d6365799c2b0b Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Mon, 28 Oct 2024 09:45:49 +0100 Subject: [PATCH 04/12] add alcotest --- git-kv.opam | 2 ++ test/dune | 5 +++++ test/tests.ml | 45 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 52 insertions(+) create mode 100644 test/tests.ml diff --git a/git-kv.opam b/git-kv.opam index eba381c..155ae63 100644 --- a/git-kv.opam +++ b/git-kv.opam @@ -21,6 +21,8 @@ depends: [ "conf-git" {with-test} "mirage-clock-unix" {with-test} "git-unix" {>= "3.10.0" & with-test} + "alcotest" {>= "1.8.0" & with-test} + "bos" {>= "0.2.1" & with-test} ] build: [ diff --git a/test/dune b/test/dune index 45a02f5..a7a3709 100644 --- a/test/dune +++ b/test/dune @@ -25,3 +25,8 @@ (with-stdout-to git-daemon (run ./git_daemon_exists.exe))) + +(test + (name tests) + (libraries git-kv alcotest bos) + (modules tests)) \ No newline at end of file diff --git a/test/tests.ml b/test/tests.ml new file mode 100644 index 0000000..e32ff76 --- /dev/null +++ b/test/tests.ml @@ -0,0 +1,45 @@ +let ( let* ) = Result.bind + +let run_it cmd = + let* status = Bos.OS.Cmd.run_status cmd in + if status = `Exited 0 then Ok () else + Error (`Msg ("status not 0, but " ^ Fmt.to_to_string Bos.OS.Cmd.pp_status status)) + +let empty_repo () = + let* cwd = Bos.OS.Dir.current () in + let* tmpdir = Bos.OS.Dir.tmp "git-kv-%s" in + let* () = Bos.OS.Dir.set_current tmpdir in + let cmd = Bos.Cmd.(v "git" % "init" % "-q") in + let* () = run_it cmd in + let* () = Bos.OS.Dir.set_current cwd in + let cmd = Bos.Cmd.(v "git" % "daemon" % "--base-path=." % "--export-all" % "--reuseaddr" % "--pid-file=pid" % "--detach") in + let* () = run_it cmd in + let* pid = Bos.OS.File.read (Fpath.v "pid") in + Ok (tmpdir, String.trim pid) + +let kill_git pid = + Unix.kill (int_of_string pid) Sys.sigterm + +let simple () = + match + let* (tmpdir, pid) = empty_repo () in + print_endline ("git started with " ^ Fpath.to_string tmpdir); + print_endline ("git pid " ^ pid); + Unix.sleep 2; + kill_git pid; + print_endline "git killed"; + Ok () + with + | Ok () -> Alcotest.(check bool __LOC__ true true) + | Error `Msg msg -> + print_endline ("got an error from bos: " ^ msg) + +let basic_tests = [ + "Simple", `Quick, simple ; +] + +let tests = [ + "Basic tests", basic_tests ; +] + +let () = Alcotest.run "Git-KV alcotest tests" tests From e91bd44cb8b581b19eb1d0be6453780d8223c59f Mon Sep 17 00:00:00 2001 From: Robur Team Date: Mon, 28 Oct 2024 12:04:35 +0000 Subject: [PATCH 05/12] Added tests for change_and_push and parallel modifications MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixed last_modified (when running inside change_and_push), and change_and_push. Co-Authored-By: Reynir Björnsson Co-Authored-By: Hannes Mehnert --- src/dune | 1 - src/git_kv.ml | 92 ++++++++++++++------------ test/dune | 4 +- test/tests.ml | 178 ++++++++++++++++++++++++++++++++++++++++++++++---- 4 files changed, 216 insertions(+), 59 deletions(-) diff --git a/src/dune b/src/dune index ea051e2..a7fc8c6 100644 --- a/src/dune +++ b/src/dune @@ -1,5 +1,4 @@ (library (name git_kv) (public_name git-kv) - (flags (-w -32)) (libraries git ptime mirage-clock mirage-kv fmt)) diff --git a/src/git_kv.ml b/src/git_kv.ml index af3094e..a8c9363 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -8,8 +8,8 @@ type t = ; edn : Smart_git.Endpoint.t ; branch : Git.Reference.t ; store : Store.t - ; mutable committed : (Digestif.SHA1.t * unit Lwt.t) option - ; in_closure : bool + ; mutable committed : Digestif.SHA1.t option + ; mutable change_and_push_waiter : unit Lwt.t option ; mutable head : Store.hash option } let init_store () = @@ -102,7 +102,7 @@ let connect ctx endpoint = init_store () >>= fun store -> let store = to_invalid store in let edn, branch = split_url endpoint in - let t = { ctx ; edn ; branch ; store ; committed= None; in_closure= false; head= None } in + let t = { ctx ; edn ; branch ; store ; committed= None; change_and_push_waiter= None; head= None } in pull t >>= fun r -> let _r = to_invalid r in Lwt.return t @@ -370,8 +370,8 @@ let of_octets ctx ~remote data = Result.fold ~ok:Fun.id ~error:(function `Msg msg -> failwith msg) >>= fun store -> analyze store data >>= fun head -> let edn, branch = split_url remote in - Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; in_closure= false; head; }) - (fun exn -> + Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; change_and_push_waiter= None; head; }) + (fun _exn -> Lwt.return_error (`Msg "Invalid PACK file")) module Make (Pclock : Mirage_clock.PCLOCK) = struct @@ -395,17 +395,19 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct | `Reference_not_found _ | `Msg _ as err -> Store.pp_error ppf err | `Hash_not_found hash -> Store.pp_error ppf (`Not_found hash) - let noppp t key = + let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))) + + let find_blob t key = match t.committed, t.head with | None, None -> Lwt.return None - | Some (tree_root_hash, _), _ -> + | Some tree_root_hash, _ -> Search.find t.store tree_root_hash (`Path (Mirage_kv.Key.segments key)) | None, Some commit -> Search.find t.store commit (`Commit (`Path (Mirage_kv.Key.segments key))) let exists t key = let open Lwt.Infix in - noppp t key >>= function + find_blob t key >>= function | None -> Lwt.return (Ok None) | Some tree_hash -> Store.read_exn t.store tree_hash >>= function @@ -414,7 +416,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let get t key = let open Lwt.Infix in - noppp t key >>= function + find_blob t key >>= function | None -> Lwt.return (Error (`Not_found key)) | Some blob -> Store.read_exn t.store blob >|= function @@ -435,7 +437,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let list t key = let open Lwt.Infix in - noppp t key >>= function + find_blob t key >>= function | None -> Lwt.return (Error (`Not_found key)) | Some tree -> Store.read_exn t.store tree >>= function @@ -453,8 +455,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let last_modified t key = let open Lwt.Infix in - noppp t key >>= - (* FIXME *) + find_blob t key >>= Option.fold ~none:(Lwt.return (Error (`Not_found key))) ~some:(fun head -> @@ -477,12 +478,14 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct ~some:Fun.id (Ptime.of_float_s (Int64.to_float secs)) in Ok ts - | _ -> assert false) + | _ -> + Ok (Option.fold + ~none:Ptime.epoch + ~some:Fun.id (Ptime.of_float_s (Int64.to_float (now ()))))) let digest t key = let open Lwt.Infix in - noppp t key >>= - (* FIXME *) + find_blob t key >>= Option.fold ~none:(Lwt.return (Error (`Not_found key))) ~some:(fun x -> Lwt.return (Ok (Store.Hash.to_raw_string x))) @@ -492,7 +495,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct get t key >|= fun data -> Optint.Int63.of_int (String.length data) - let author ?(name = "Git KV") ?(email = "git@mirage.io") now = + let author ?(name = "Git KV") ?(email = "git-noreply@robur.coop") now = { Git.User.name ; email ; date = now (), None } let rec unroll_tree t ~tree_root_hash (pred_perm, pred_name, pred_hash) rpath = @@ -521,7 +524,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let tree_root_hash_of_store t = match t.committed, t.head with - | Some (tree_root_hash, _), _ -> Lwt.return_ok tree_root_hash + | Some tree_root_hash, _ -> Lwt.return_ok tree_root_hash | None, None -> let open Lwt_result.Infix in let tree = Store.Value.Tree.v [] in @@ -534,7 +537,6 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct | _ -> Lwt.return_error (`Msg (Fmt.str "The current HEAD value (%a) is not a commit" Digestif.SHA1.pp commit)) let ( >>? ) = Lwt_result.bind - let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))) let set ?and_commit t key contents = let segs = Mirage_kv.Key.segments key in @@ -549,14 +551,14 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct tree_root_hash_of_store t >>= fun tree_root_hash -> unroll_tree t ~tree_root_hash (`Normal, name, hash) (List.tl rpath) >>= fun tree_root_hash -> match and_commit with - | Some (_old_tree_root_hash, th) -> - t.committed <- Some (tree_root_hash, th) ; + | Some _old_tree_root_hash -> + t.committed <- Some tree_root_hash ; Lwt.return_ok () | None -> let committer = author now in let author = author now in let action = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head in - let parents = Option.value ~default:[] (Option.map (fun head -> [ head ]) t.head) in + let parents = Option.to_list t.head in let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer ~parents (Some "Committed by git-kv") in Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> @@ -594,11 +596,9 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let remove ?and_commit t key = let segs = Mirage_kv.Key.segments key in - (* FIXME: t.head *) - match List.rev segs, t.head with - | [], _ -> assert false - | _, None -> Lwt.return_ok () (* XXX(dinosaure): or [`Not_found]? *) - | name :: [], Some head -> + match List.rev segs with + | [] -> assert false + | name :: [] -> let open Lwt_result.Infix in tree_root_hash_of_store t >>= fun tree_root_hash -> Store.read_exn t.store tree_root_hash >>! fun tree_root -> @@ -607,12 +607,13 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let open Lwt_result.Infix in Store.write t.store (Git.Value.Tree tree_root) >>= fun (tree_root_hash, _) -> ( match and_commit with - | Some (_old_tree_root_hash, th) -> t.committed <- Some (tree_root_hash, th) ; Lwt.return_ok () + | Some _old_tree_root_hash -> t.committed <- Some tree_root_hash ; Lwt.return_ok () | None -> let committer = author now in let author = author now in + let parents = Option.to_list t.head in let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer - ~parents:[ head ] (Some "Committed by git-kv") in + ~parents (Some "Committed by git-kv") in Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () -> Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] @@ -620,7 +621,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct Git.Reference.pp t.branch Sync.pp_error err)) >>? fun () -> Store.shallow t.store hash >|= Result.ok) >>= fun () -> t.head <- Some hash ; Lwt.return_ok () ) - | name :: pred_name :: rest, Some head -> + | name :: pred_name :: rest -> let open Lwt_result.Infix in tree_root_hash_of_store t >>= fun tree_root_hash -> Search.find t.store tree_root_hash (`Path (List.rev (pred_name :: rest))) >>! function @@ -631,12 +632,13 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct Store.write t.store (Git.Value.Tree tree) >>= fun (pred_hash, _) -> unroll_tree t ~tree_root_hash (`Dir, pred_name, pred_hash) rest >>= fun tree_root_hash -> ( match and_commit with - | Some (_old_tree_root_hash, th) -> t.committed <- Some (tree_root_hash, th) ; Lwt.return_ok () + | Some _old_tree_root_hash -> t.committed <- Some tree_root_hash ; Lwt.return_ok () | None -> let committer = author now in let author = author now in + let parents = Option.to_list t.head in let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer - ~parents:[ head ] (Some "Committed by git-kv") in + ~parents (Some "Committed by git-kv") in Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () -> Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] @@ -672,36 +674,39 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let change_and_push t ?author:name ?author_email:email ?(message = "Committed by git-kv") f = let open Lwt.Infix in - if t.in_closure then - Lwt.return_error (`Msg "Nested change_and_push") - else + match t.committed with + | Some _ -> Lwt.return_error (`Msg "Nested change_and_push") + | None -> (* XXX(dinosaure): serialize [change_and_push]. If we do [Lwt.both (change_and_push ..) (change_and_push ..)], they can not run concurrently! The second will waiting the first to finish. *) - ( match t.committed with - | None -> Lwt.return_unit - | Some (_tree_root_hash, th) -> th ) >>= fun () -> let th, wk = Lwt.wait () in + let th' = t.change_and_push_waiter in + t.change_and_push_waiter <- Some th; + ( match th' with + | None -> Lwt.return_unit + | Some th -> th ) >>= fun () -> ( let open Lwt_result.Infix in tree_root_hash_of_store t >>= fun tree_root_hash -> - t.committed <- Some (tree_root_hash, th) ; - let t' = { t with in_closure= true } in + t.change_and_push_waiter <- Some th ; + let t' = { t with committed = Some tree_root_hash } in f t' >>! fun res -> (* XXX(dinosaure): we assume that only [change_and_push] can reset [t.committed] to [None] and we ensured that [change_and_push] can not be called into [f]. So we are sure that [t'.committed] must be [Some _] in anyway. *) - let[@warning "-8"] Some (new_tree_root_hash, _) = t'.committed in + let[@warning "-8"] Some new_tree_root_hash = t'.committed in if Digestif.SHA1.equal new_tree_root_hash tree_root_hash then Lwt.return_ok res (* XXX(dinosaure): nothing to send! *) + else if not (Option.equal Digestif.SHA1.equal t.head t'.head) then + Lwt.return (Error (`Msg "store was modified outside of change_and_push, please retry")) else let action = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head in - let parents = Option.value ~default:[] (Option.map (fun head -> [ head ]) t.head) in + let parents = Option.to_list t.head in let author = author ?name ?email now in let committer = author in let commit = Store.Value.Commit.make ~tree:new_tree_root_hash ~author ~committer ~parents (Some message) in Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> - t.head <- Some hash ; Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () -> Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ action ] >|= Result.map_error (fun err -> @@ -709,11 +714,12 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct Git.Reference.pp t.branch Sync.pp_error err)) >>? fun () -> Store.shallow t.store hash >|= Result.ok) >>= fun () -> + t.head <- Some hash ; Lwt.return_ok res ) >|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing %a" Store.pp_error err)) >>= fun res -> Lwt.wakeup_later wk () ; - t.committed <- None ; + t.change_and_push_waiter <- None ; Lwt.return res end diff --git a/test/dune b/test/dune index a7a3709..819ebe9 100644 --- a/test/dune +++ b/test/dune @@ -28,5 +28,5 @@ (test (name tests) - (libraries git-kv alcotest bos) - (modules tests)) \ No newline at end of file + (libraries git-kv alcotest bos mirage-clock-unix lwt.unix git-unix) + (modules tests)) diff --git a/test/tests.ml b/test/tests.ml index e32ff76..2229bb9 100644 --- a/test/tests.ml +++ b/test/tests.ml @@ -7,35 +7,187 @@ let run_it cmd = let empty_repo () = let* cwd = Bos.OS.Dir.current () in - let* tmpdir = Bos.OS.Dir.tmp "git-kv-%s" in + let* tmpdir = Bos.OS.Dir.tmp ~dir:cwd "git-kv-%s" in let* () = Bos.OS.Dir.set_current tmpdir in - let cmd = Bos.Cmd.(v "git" % "init" % "-q") in + let cmd = Bos.Cmd.(v "git" % "init" % "--bare" % "-q") in let* () = run_it cmd in let* () = Bos.OS.Dir.set_current cwd in - let cmd = Bos.Cmd.(v "git" % "daemon" % "--base-path=." % "--export-all" % "--reuseaddr" % "--pid-file=pid" % "--detach") in + let cmd = Bos.Cmd.(v "git" % "daemon" % "--base-path=." % "--export-all" % "--reuseaddr" % "--pid-file=pid" % "--detach" % "--port=9419" % "--enable=receive-pack") in let* () = run_it cmd in - let* pid = Bos.OS.File.read (Fpath.v "pid") in - Ok (tmpdir, String.trim pid) + let pid = Result.get_ok (Bos.OS.File.read (Fpath.v "pid")) in + Ok (Fpath.basename tmpdir, String.trim pid) let kill_git pid = Unix.kill (int_of_string pid) Sys.sigterm -let simple () = +module Store = Git_kv.Make (Pclock) + +open Lwt.Infix + +let read_in_change_and_push () = match let* (tmpdir, pid) = empty_repo () in - print_endline ("git started with " ^ Fpath.to_string tmpdir); - print_endline ("git pid " ^ pid); - Unix.sleep 2; - kill_git pid; - print_endline "git killed"; + Fun.protect ~finally:(fun () -> kill_git pid) (fun () -> + Lwt_main.run + ( + Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx -> + Git_kv.connect ctx ("git://localhost:9419/" ^ tmpdir) >>= fun t -> + Store.change_and_push t (fun t -> + Store.set t (Mirage_kv.Key.v "/foo") "value" >>= fun r -> + if Result.is_error r then Alcotest.fail "failure writing"; + Store.get t (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure reading"; + Alcotest.(check string) "Store.get" "value" (Result.get_ok r); + Lwt.return_unit) >>= fun r -> + if Result.is_error r then Alcotest.fail "failure change_and_push"; + Store.get t (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure reading outside"; + Alcotest.(check string) "Store.get" "value" (Result.get_ok r); + Lwt.return_unit)); Ok () with - | Ok () -> Alcotest.(check bool __LOC__ true true) + | Ok () -> () | Error `Msg msg -> print_endline ("got an error from bos: " ^ msg) +let set_outside_change_and_push () = + match + let* (tmpdir, pid) = empty_repo () in + Fun.protect ~finally:(fun () -> kill_git pid) (fun () -> + Lwt_main.run + ( + Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx -> + Git_kv.connect ctx ("git://localhost:9419/" ^ tmpdir) >>= fun t -> + Store.change_and_push t (fun t' -> + Store.set t' (Mirage_kv.Key.v "/foo") "value" >>= fun r -> + if Result.is_error r then Alcotest.fail "failure writing foo"; + Store.set t (Mirage_kv.Key.v "/bar") "other value" >>= fun r -> + if Result.is_error r then Alcotest.fail "failure writing bar"; + Lwt.return_unit) >>= fun r -> + if Result.is_ok r then Alcotest.fail "expected change_and_push failure"; + Store.get t (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_ok r then Alcotest.fail "expected failure reading foo"; + Store.get t (Mirage_kv.Key.v "/bar") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure reading outside bar"; + Alcotest.(check string) "Store.get bar" "other value" (Result.get_ok r); + Lwt.return_unit)); + Ok () + with + | Ok () -> () + | Error `Msg msg -> + print_endline ("got an error from bos: " ^ msg) + +let remove_in_change_and_push () = + match + let* (tmpdir, pid) = empty_repo () in + Fun.protect ~finally:(fun () -> kill_git pid) (fun () -> + Lwt_main.run + ( + Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx -> + Git_kv.connect ctx ("git://localhost:9419/" ^ tmpdir) >>= fun t -> + Store.set t (Mirage_kv.Key.v "/foo") "value" >>= fun r -> + if Result.is_error r then Alcotest.fail "failure writing"; + Store.change_and_push t (fun t' -> + Store.get t' (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure reading inside"; + Alcotest.(check string) "Store.get" "value" (Result.get_ok r); + Store.remove t' (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure removing"; + Store.get t (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure reading the outer t"; + Alcotest.(check string) "Store.get" "value" (Result.get_ok r); + Lwt.return_unit) >>= fun r -> + if Result.is_error r then Alcotest.fail "failure change_and_push"; + Store.get t (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_ok r then Alcotest.fail "expected failure reading outside"; + Lwt.return_unit)); + Ok () + with + | Ok () -> () + | Error `Msg msg -> + print_endline ("got an error from bos: " ^ msg) + +let last_modified_in_change_and_push () = + match + let* (tmpdir, pid) = empty_repo () in + Fun.protect ~finally:(fun () -> kill_git pid) (fun () -> + Lwt_main.run + ( + Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx -> + Git_kv.connect ctx ("git://localhost:9419/" ^ tmpdir) >>= fun t -> + Store.set t (Mirage_kv.Key.v "/foo") "value" >>= fun r -> + if Result.is_error r then Alcotest.fail "failure writing"; + Store.last_modified t (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure last_modified"; + let lm = Result.get_ok r in + Store.change_and_push t (fun t' -> + Store.last_modified t' (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure last_modified inside"; + let lm' = Result.get_ok r in + Alcotest.(check bool) "last modified is later or equal" true (Ptime.is_later ~than:lm lm' || Ptime.equal lm lm'); + Store.set t' (Mirage_kv.Key.v "/foo") "new value" >>= fun r -> + if Result.is_error r then Alcotest.fail "failure writing inside"; + Store.last_modified t' (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure last_modified inside after set"; + let lm2 = Result.get_ok r in + Alcotest.(check bool) "last modified is later" true (Ptime.is_later ~than:lm' lm2 || Ptime.equal lm' lm2); + Lwt.return lm2) >>= fun r -> + if Result.is_error r then Alcotest.fail "failure change_and_push"; + let lm2 = Result.get_ok r in + Store.last_modified t (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure last_modified after change_and_push"; + let lm3 = Result.get_ok r in + Alcotest.(check bool) "last modified is later" true (Ptime.is_later ~than:lm lm3 || Ptime.equal lm lm3); + Alcotest.(check bool) "last modified is later outside than inside" true (Ptime.is_later ~than:lm2 lm3 || Ptime.equal lm2 lm3); + Lwt.return_unit)); + Ok () + with + | Ok () -> () + | Error `Msg msg -> + print_endline ("got an error from bos: " ^ msg) + +let digest_in_change_and_push () = + match + let* (tmpdir, pid) = empty_repo () in + Fun.protect ~finally:(fun () -> kill_git pid) (fun () -> + Lwt_main.run + ( + Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx -> + Git_kv.connect ctx ("git://localhost:9419/" ^ tmpdir) >>= fun t -> + Store.set t (Mirage_kv.Key.v "/foo") "value" >>= fun r -> + if Result.is_error r then Alcotest.fail "failure writing"; + Store.digest t (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure digest"; + let digest = Result.get_ok r in + Store.change_and_push t (fun t' -> + Store.digest t' (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure digest inside"; + Alcotest.(check string) "Store.digest" digest (Result.get_ok r); + Store.set t' (Mirage_kv.Key.v "/foo") "something else" >>= fun r -> + if Result.is_error r then Alcotest.fail "failure set"; + Store.digest t' (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure digest inside"; + Alcotest.(check bool) "Store.digest" false (String.equal digest (Result.get_ok r)); + Lwt.return_unit) >>= fun r -> + if Result.is_error r then Alcotest.fail "failure change_and_push"; + Store.digest t (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure digest outside"; + Alcotest.(check bool) "Store.digest" false (String.equal digest (Result.get_ok r)); + Lwt.return_unit)); + Ok () + with + | Ok () -> () + | Error `Msg msg -> + print_endline ("got an error from bos: " ^ msg) + + + let basic_tests = [ - "Simple", `Quick, simple ; + "Read in change_and_push", `Quick, read_in_change_and_push ; + "Set outside change_and_push", `Quick, set_outside_change_and_push ; + "Remove in change_and_push", `Quick, remove_in_change_and_push ; + "Last modified in change_and_push", `Quick, last_modified_in_change_and_push ; + "Digest in change_and_push", `Quick, digest_in_change_and_push ; ] let tests = [ From 750ec11b5f6bc29adfbc1ee2618abf3c80b20733 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 29 Oct 2024 09:50:53 +0100 Subject: [PATCH 06/12] remove superfluous assignment, spotted by @dinosaure --- src/git_kv.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/git_kv.ml b/src/git_kv.ml index a8c9363..33fa5fc 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -688,7 +688,6 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct | Some th -> th ) >>= fun () -> ( let open Lwt_result.Infix in tree_root_hash_of_store t >>= fun tree_root_hash -> - t.change_and_push_waiter <- Some th ; let t' = { t with committed = Some tree_root_hash } in f t' >>! fun res -> (* XXX(dinosaure): we assume that only [change_and_push] can reset [t.committed] to [None] and From 9afb8e29e22a49f271f06144a1799de40c59a415 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reynir=20Bj=C3=B6rnsson?= Date: Tue, 29 Oct 2024 10:10:17 +0100 Subject: [PATCH 07/12] Document change_and_push_waiter details --- src/git_kv.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/git_kv.ml b/src/git_kv.ml index 33fa5fc..a510974 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -679,7 +679,11 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct | None -> (* XXX(dinosaure): serialize [change_and_push]. If we do [Lwt.both (change_and_push ..) (change_and_push ..)], they can not run - concurrently! The second will waiting the first to finish. *) + concurrently! The second will waiting the first to finish. + (reynir): Furthermore, we need to create a new task and update + [change_and_push_waiter] before we wait on the existing + [change_and_push_waiter] task without any yield point in between to + ensure serializability. *) let th, wk = Lwt.wait () in let th' = t.change_and_push_waiter in t.change_and_push_waiter <- Some th; From 931c0481d7213c392172e0c2a8f41fd4d45f9beb Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 29 Oct 2024 10:44:40 +0100 Subject: [PATCH 08/12] add task a task b task c test, and a fix --- src/git_kv.ml | 4 ++- test/tests.ml | 74 ++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 76 insertions(+), 2 deletions(-) diff --git a/src/git_kv.ml b/src/git_kv.ml index a510974..d77cee4 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -723,6 +723,8 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct (fun err -> `Msg (Fmt.str "error pushing %a" Store.pp_error err)) >>= fun res -> Lwt.wakeup_later wk () ; - t.change_and_push_waiter <- None ; + (match t.change_and_push_waiter with + | Some th' -> if th' == th then t.change_and_push_waiter <- None + | None -> ()); Lwt.return res end diff --git a/test/tests.ml b/test/tests.ml index 2229bb9..ddb8dd1 100644 --- a/test/tests.ml +++ b/test/tests.ml @@ -180,7 +180,78 @@ let digest_in_change_and_push () = | Error `Msg msg -> print_endline ("got an error from bos: " ^ msg) - +let multiple_change_and_push () = + match + let* (tmpdir, pid) = empty_repo () in + Fun.protect ~finally:(fun () -> kill_git pid) (fun () -> + Lwt_main.run + ( + Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx -> + Git_kv.connect ctx ("git://localhost:9419/" ^ tmpdir) >>= fun t -> + let wait = Lwt_mvar.create_empty () in + let task_c () = + Store.change_and_push t (fun t''' -> + print_endline "running 3"; + print_endline "running 3 - now get"; + Store.get t''' (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then failwith "failure reading foo in third change_and_push"; + assert (String.equal "value 2" (Result.get_ok r)); + print_endline "running 3 - now set"; + Store.set t''' (Mirage_kv.Key.v "/foo") "value 3" >>= fun r -> + if Result.is_error r then failwith "failure writing foo in third change_and_push"; + print_endline "running 3 - now get again"; + Store.get t''' (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then failwith "failure reading foo in third change_and_push adter the write"; + assert (String.equal "value 3" (Result.get_ok r)); + print_endline "running 3 - now finished"; + Lwt.return_unit) >>= fun r -> + if Result.is_error r then failwith "failure second change_and_push"; + Lwt_mvar.put wait () + in + let task_b () = + Store.change_and_push t (fun t'' -> + print_endline "running 2"; + Lwt.async task_c; + print_endline "running 2 - now get"; + Store.get t'' (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then failwith "failure reading foo in second change_and_push"; + assert (String.equal "value" (Result.get_ok r)); + print_endline "running 2 - now set"; + Store.set t'' (Mirage_kv.Key.v "/foo") "value 2" >>= fun r -> + if Result.is_error r then failwith "failure writing foo in second change_and_push"; + print_endline "running 2 - now get again"; + Store.get t'' (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then failwith "failure reading foo in second change_and_push adter the write"; + assert (String.equal "value 2" (Result.get_ok r)); + print_endline "running 2 - finished"; + Lwt.return_unit) >|= fun r -> + if Result.is_error r then failwith "failure second change_and_push" + in + let task_a () = + Store.change_and_push t (fun t' -> + print_endline "running 1"; + Lwt.async task_b; + print_endline "running 1 - now set"; + Store.set t' (Mirage_kv.Key.v "/foo") "value" >>= fun r -> + if Result.is_error r then Alcotest.fail "failure writing foo in first change_and_push"; + print_endline "running 1 - now get"; + Store.get t' (Mirage_kv.Key.v "/foo") >>= fun r -> + if Result.is_error r then Alcotest.fail "failure reading foo in first change_and_push, after the write"; + Alcotest.(check string) "Store.get foo" "value" (Result.get_ok r); + print_endline "running 1 - finished"; + Lwt.return_unit) >|= fun r -> + if Result.is_error r then Alcotest.fail "failure first change_and_push" + in + task_a () >>= fun () -> + Lwt_mvar.take wait >>= fun () -> + Store.get t (Mirage_kv.Key.v "/foo") >|= fun r -> + if Result.is_error r then Alcotest.fail "failure reading outside foo"; + Alcotest.(check string) "Store.get bar" "value 3" (Result.get_ok r))); + Ok () + with + | Ok () -> () + | Error `Msg msg -> + print_endline ("got an error from bos: " ^ msg) let basic_tests = [ "Read in change_and_push", `Quick, read_in_change_and_push ; @@ -188,6 +259,7 @@ let basic_tests = [ "Remove in change_and_push", `Quick, remove_in_change_and_push ; "Last modified in change_and_push", `Quick, last_modified_in_change_and_push ; "Digest in change_and_push", `Quick, digest_in_change_and_push ; + "Multiple change_and_push", `Quick, multiple_change_and_push ; ] let tests = [ From 1327cc4f94b814ef28c75baf4d2d60b01d1ed906 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 29 Oct 2024 10:51:46 +0100 Subject: [PATCH 09/12] add comment about the reset of the waiter --- src/git_kv.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/git_kv.ml b/src/git_kv.ml index d77cee4..a6be55b 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -723,6 +723,9 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct (fun err -> `Msg (Fmt.str "error pushing %a" Store.pp_error err)) >>= fun res -> Lwt.wakeup_later wk () ; + (* (hannes) since some other task may have mutated the + change_and_push_waiter, we only reset it to None if there's a physical + equality between its value and our created task above. *) (match t.change_and_push_waiter with | Some th' -> if th' == th then t.change_and_push_waiter <- None | None -> ()); From 3cae0f77655667f86c99f119903e495d4438f838 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 29 Oct 2024 11:03:15 +0100 Subject: [PATCH 10/12] Use Lwt_{condition,mutex} instead of lwt tasks to serialize change_and_push --- src/git_kv.ml | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/git_kv.ml b/src/git_kv.ml index a6be55b..6f43245 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -9,7 +9,9 @@ type t = ; branch : Git.Reference.t ; store : Store.t ; mutable committed : Digestif.SHA1.t option - ; mutable change_and_push_waiter : unit Lwt.t option + ; mutable change_and_push_running : bool + ; condition : unit Lwt_condition.t + ; mutex : Lwt_mutex.t ; mutable head : Store.hash option } let init_store () = @@ -102,7 +104,7 @@ let connect ctx endpoint = init_store () >>= fun store -> let store = to_invalid store in let edn, branch = split_url endpoint in - let t = { ctx ; edn ; branch ; store ; committed= None; change_and_push_waiter= None; head= None } in + let t = { ctx ; edn ; branch ; store ; committed= None; change_and_push_running= false; condition= Lwt_condition.create (); mutex= Lwt_mutex.create (); head= None } in pull t >>= fun r -> let _r = to_invalid r in Lwt.return t @@ -370,7 +372,7 @@ let of_octets ctx ~remote data = Result.fold ~ok:Fun.id ~error:(function `Msg msg -> failwith msg) >>= fun store -> analyze store data >>= fun head -> let edn, branch = split_url remote in - Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; change_and_push_waiter= None; head; }) + Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; change_and_push_running= false; condition= Lwt_condition.create (); mutex= Lwt_mutex.create (); head; }) (fun _exn -> Lwt.return_error (`Msg "Invalid PACK file")) @@ -684,12 +686,13 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct [change_and_push_waiter] before we wait on the existing [change_and_push_waiter] task without any yield point in between to ensure serializability. *) - let th, wk = Lwt.wait () in - let th' = t.change_and_push_waiter in - t.change_and_push_waiter <- Some th; - ( match th' with - | None -> Lwt.return_unit - | Some th -> th ) >>= fun () -> + let open Lwt.Syntax in + let* () = Lwt_mutex.with_lock t.mutex @@ fun () -> + let rec await () = + if t.change_and_push_running + then Lwt_condition.wait ~mutex:t.mutex t.condition >>= await + else begin t.change_and_push_running <- true; Lwt.return_unit end in + await () in ( let open Lwt_result.Infix in tree_root_hash_of_store t >>= fun tree_root_hash -> let t' = { t with committed = Some tree_root_hash } in @@ -722,12 +725,9 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct >|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing %a" Store.pp_error err)) >>= fun res -> - Lwt.wakeup_later wk () ; - (* (hannes) since some other task may have mutated the - change_and_push_waiter, we only reset it to None if there's a physical - equality between its value and our created task above. *) - (match t.change_and_push_waiter with - | Some th' -> if th' == th then t.change_and_push_waiter <- None - | None -> ()); + let* () = Lwt_mutex.with_lock t.mutex @@ fun () -> + t.change_and_push_running <- false; + Lwt_condition.signal t.condition (); + Lwt.return_unit in Lwt.return res end From 681e4f23677ef44817d280e7a694ec69c3954213 Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Tue, 29 Oct 2024 11:03:44 +0100 Subject: [PATCH 11/12] Add expected EOF on cram tests (otherwise, tests fails on Archlinux) --- test/fold.t | 2 ++ test/fold2.t | 1 + test/simple.t | 3 +++ 3 files changed, 6 insertions(+) diff --git a/test/fold.t b/test/fold.t index cf67cb3..d6da500 100644 --- a/test/fold.t +++ b/test/fold.t @@ -11,12 +11,14 @@ Batch operation > exists /bar > quit > quit + > EOF /bar exists as a value $ mgit git://localhost/simple#main < list / > get /bar > get /foo > quit + > EOF - /bar - /foo 00000000: 4769 7420 726f 636b 7321 Git rocks! diff --git a/test/fold2.t b/test/fold2.t index 932de0a..b96663a 100644 --- a/test/fold2.t +++ b/test/fold2.t @@ -9,6 +9,7 @@ Reading during batch operation > get /bar > quit > quit + > EOF - /bar 00000000: 4769 7420 726f 636b 7321 Git rocks! $ cd simple diff --git a/test/simple.t b/test/simple.t index ff2c22e..8cf6147 100644 --- a/test/simple.t +++ b/test/simple.t @@ -17,6 +17,7 @@ Simple test of our Git Key-Value store > get /foo > save db.pack > quit + > EOF 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. $ tail -c20 db.pack | hxd.xxd 00000000: e4b2 3437 2e7e 3d7e 8508 3912 3d87 11cd ..47.~=~..9.=... @@ -24,6 +25,7 @@ Simple test of our Git Key-Value store $ mgit git://localhost/simple db.pack < get /foo > quit + > EOF 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. $ cd simple $ echo "Git rocks!" > bar @@ -35,6 +37,7 @@ Simple test of our Git Key-Value store > get /bar > get /foo > quit + > EOF + /bar * / 00000000: 4769 7420 726f 636b 7321 0a Git rocks!. From 0b330178e190c9e3ecdd8c85ed8c76b54c4de4c9 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 29 Oct 2024 11:51:55 +0100 Subject: [PATCH 12/12] as suggested by @reynir @dinosaure, use a single Lwt_mutex.t --- src/git_kv.ml | 89 ++++++++++++++++++++------------------------------- 1 file changed, 34 insertions(+), 55 deletions(-) diff --git a/src/git_kv.ml b/src/git_kv.ml index 6f43245..fcfeb4e 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -9,8 +9,6 @@ type t = ; branch : Git.Reference.t ; store : Store.t ; mutable committed : Digestif.SHA1.t option - ; mutable change_and_push_running : bool - ; condition : unit Lwt_condition.t ; mutex : Lwt_mutex.t ; mutable head : Store.hash option } @@ -104,7 +102,7 @@ let connect ctx endpoint = init_store () >>= fun store -> let store = to_invalid store in let edn, branch = split_url endpoint in - let t = { ctx ; edn ; branch ; store ; committed= None; change_and_push_running= false; condition= Lwt_condition.create (); mutex= Lwt_mutex.create (); head= None } in + let t = { ctx ; edn ; branch ; store ; committed= None; mutex= Lwt_mutex.create (); head= None } in pull t >>= fun r -> let _r = to_invalid r in Lwt.return t @@ -372,7 +370,7 @@ let of_octets ctx ~remote data = Result.fold ~ok:Fun.id ~error:(function `Msg msg -> failwith msg) >>= fun store -> analyze store data >>= fun head -> let edn, branch = split_url remote in - Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; change_and_push_running= false; condition= Lwt_condition.create (); mutex= Lwt_mutex.create (); head; }) + Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; mutex= Lwt_mutex.create (); head; }) (fun _exn -> Lwt.return_error (`Msg "Invalid PACK file")) @@ -679,55 +677,36 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct match t.committed with | Some _ -> Lwt.return_error (`Msg "Nested change_and_push") | None -> - (* XXX(dinosaure): serialize [change_and_push]. If we do - [Lwt.both (change_and_push ..) (change_and_push ..)], they can not run - concurrently! The second will waiting the first to finish. - (reynir): Furthermore, we need to create a new task and update - [change_and_push_waiter] before we wait on the existing - [change_and_push_waiter] task without any yield point in between to - ensure serializability. *) - let open Lwt.Syntax in - let* () = Lwt_mutex.with_lock t.mutex @@ fun () -> - let rec await () = - if t.change_and_push_running - then Lwt_condition.wait ~mutex:t.mutex t.condition >>= await - else begin t.change_and_push_running <- true; Lwt.return_unit end in - await () in - ( let open Lwt_result.Infix in - tree_root_hash_of_store t >>= fun tree_root_hash -> - let t' = { t with committed = Some tree_root_hash } in - f t' >>! fun res -> - (* XXX(dinosaure): we assume that only [change_and_push] can reset [t.committed] to [None] and - we ensured that [change_and_push] can not be called into [f]. So we are sure that [t'.committed] - must be [Some _] in anyway. *) - let[@warning "-8"] Some new_tree_root_hash = t'.committed in - if Digestif.SHA1.equal new_tree_root_hash tree_root_hash - then Lwt.return_ok res (* XXX(dinosaure): nothing to send! *) - else if not (Option.equal Digestif.SHA1.equal t.head t'.head) then - Lwt.return (Error (`Msg "store was modified outside of change_and_push, please retry")) - else - let action = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head in - let parents = Option.to_list t.head in - let author = author ?name ?email now in - let committer = author in - let commit = Store.Value.Commit.make ~tree:new_tree_root_hash ~author ~committer - ~parents (Some message) in - Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> - Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () -> - Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ action ] - >|= Result.map_error (fun err -> - `Msg (Fmt.str "error pushing branch %a: %a" - Git.Reference.pp t.branch Sync.pp_error err)) - >>? fun () -> - Store.shallow t.store hash >|= Result.ok) >>= fun () -> - t.head <- Some hash ; - Lwt.return_ok res ) - >|= Result.map_error - (fun err -> `Msg (Fmt.str "error pushing %a" Store.pp_error err)) - >>= fun res -> - let* () = Lwt_mutex.with_lock t.mutex @@ fun () -> - t.change_and_push_running <- false; - Lwt_condition.signal t.condition (); - Lwt.return_unit in - Lwt.return res + Lwt_mutex.with_lock t.mutex (fun () -> + (let open Lwt_result.Infix in + tree_root_hash_of_store t >>= fun tree_root_hash -> + let t' = { t with committed = Some tree_root_hash } in + f t' >>! fun res -> + (* XXX(dinosaure): we assume that only [change_and_push] can reset [t.committed] to [None] and + we ensured that [change_and_push] can not be called into [f]. So we are sure that [t'.committed] + must be [Some _] in anyway. *) + let[@warning "-8"] Some new_tree_root_hash = t'.committed in + if Digestif.SHA1.equal new_tree_root_hash tree_root_hash + then Lwt.return_ok res (* XXX(dinosaure): nothing to send! *) + else if not (Option.equal Digestif.SHA1.equal t.head t'.head) then + Lwt.return (Error (`Msg "store was modified outside of change_and_push, please retry")) + else + let action = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head in + let parents = Option.to_list t.head in + let author = author ?name ?email now in + let committer = author in + let commit = Store.Value.Commit.make ~tree:new_tree_root_hash ~author ~committer + ~parents (Some message) in + Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> + Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () -> + Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ action ] + >|= Result.map_error (fun err -> + `Msg (Fmt.str "error pushing branch %a: %a" + Git.Reference.pp t.branch Sync.pp_error err)) + >>? fun () -> + Store.shallow t.store hash >|= Result.ok) >>= fun () -> + t.head <- Some hash ; + Lwt.return_ok res) + >|= Result.map_error + (fun err -> `Msg (Fmt.str "error pushing %a" Store.pp_error err))) end