robur/git-kv
4
0
Fork 0
Code Issues Pull requests 1 Projects Releases Packages Wiki Activity Actions

Added tests for change_and_push and parallel modifications

Browse source 
Fixed last_modified (when running inside change_and_push),
and change_and_push.

Co-Authored-By: Reynir Björnsson <reynir@reynir.dk>
Co-Authored-By: Hannes Mehnert <hannes@mehnert.org>
This commit is contained in:
Robur Team 2024-10-28 12:04:35 +00:00
parent b1e995532b
commit e91bd44cb8
4 changed files with 216 additions and 59 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
src/dune
View file

@ -1,5 +1,4 @@
(library
(name git_kv)
(public_name git-kv)
(flags (-w -32))
(libraries git ptime mirage-clock mirage-kv fmt))

92
src/git_kv.ml
View file

@ -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

2
test/dune
View file

@ -28,5 +28,5 @@
(test
(name tests)
(libraries git-kv alcotest bos)
(libraries git-kv alcotest bos mirage-clock-unix lwt.unix git-unix)
(modules tests))

178
test/tests.ml
View file

@ -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 = [