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/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 3e72f27..fcfeb4e 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 + ; mutex : Lwt_mutex.t ; 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; mutex= Lwt_mutex.create (); 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; mutex= Lwt_mutex.create (); head; }) + (fun _exn -> Lwt.return_error (`Msg "Invalid PACK file")) module Make (Pclock : Mirage_clock.PCLOCK) = struct @@ -395,25 +395,28 @@ 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 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, _ -> + 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 + find_blob 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 + find_blob t key >>= function | None -> Lwt.return (Error (`Not_found key)) | Some blob -> Store.read_exn t.store blob >|= function @@ -434,10 +437,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 + find_blob t key >>= function | None -> Lwt.return (Error (`Not_found key)) | Some tree -> Store.read_exn t.store tree >>= function @@ -455,6 +455,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let last_modified t key = let open Lwt.Infix in + find_blob t key >>= Option.fold ~none:(Lwt.return (Error (`Not_found key))) ~some:(fun head -> @@ -477,21 +478,24 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct ~some:Fun.id (Ptime.of_float_s (Int64.to_float secs)) in Ok ts - | _ -> assert false) - t.head + | _ -> + 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 + find_blob t key >>= 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 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 = @@ -520,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 @@ -533,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 @@ -548,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, _) -> @@ -593,10 +596,9 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let remove ?and_commit t key = let segs = Mirage_kv.Key.segments key in - 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 -> @@ -605,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) ] @@ -618,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 @@ -629,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) ] @@ -670,48 +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 - (* 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 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 - 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 - 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 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 -> - `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 () -> - 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 ; - Lwt.return res + match t.committed with + | Some _ -> Lwt.return_error (`Msg "Nested change_and_push") + | None -> + 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 diff --git a/test/dune b/test/dune index 1c0a228..819ebe9 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) @@ -18,3 +25,8 @@ (with-stdout-to git-daemon (run ./git_daemon_exists.exe))) + +(test + (name tests) + (libraries git-kv alcotest bos mirage-clock-unix lwt.unix git-unix) + (modules tests)) diff --git a/test/fold.t b/test/fold.t index 5e8b846..d6da500 100644 --- a/test/fold.t +++ b/test/fold.t @@ -5,24 +5,26 @@ 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 > quit > quit - /bar does not exists + > 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! 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 new file mode 100644 index 0000000..b96663a --- /dev/null +++ b/test/fold2.t @@ -0,0 +1,19 @@ +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!" + > list / + > get /bar + > quit + > quit + > EOF + - /bar + 00000000: 4769 7420 726f 636b 7321 Git rocks! + $ cd simple + $ git log main --pretty=oneline | wc -l | tr -d ' ' + 1 + $ cd .. + $ kill $(cat pid) 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!. diff --git a/test/tests.ml b/test/tests.ml new file mode 100644 index 0000000..ddb8dd1 --- /dev/null +++ b/test/tests.ml @@ -0,0 +1,269 @@ +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 ~dir:cwd "git-kv-%s" in + let* () = Bos.OS.Dir.set_current tmpdir 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" % "--port=9419" % "--enable=receive-pack") in + let* () = run_it cmd in + 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 + +module Store = Git_kv.Make (Pclock) + +open Lwt.Infix + +let read_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.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 () -> () + | 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 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 ; + "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 ; + "Multiple change_and_push", `Quick, multiple_change_and_push ; +] + +let tests = [ + "Basic tests", basic_tests ; +] + +let () = Alcotest.run "Git-KV alcotest tests" tests