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

Refactor test/dune and add a failing test #2

Merged
reynir merged 12 commits from batch-test into main 2024-10-29 11:21:16 +00:00
Conversation 15 Commits 12 Files changed 8 +216 -59
4 changed files with 216 additions and 59 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files
Showing only changes of commit e91bd44cb8 - Show all commits

1
src/dune
View file

@ -1,5 +1,4 @@
(library (library
(name git_kv) (name git_kv)
(public_name git-kv) (public_name git-kv)
(flags (-w -32))
(libraries git ptime mirage-clock mirage-kv fmt)) (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 ; edn : Smart_git.Endpoint.t
; branch : Git.Reference.t ; branch : Git.Reference.t
; store : Store.t ; store : Store.t
; mutable committed : (Digestif.SHA1.t * unit Lwt.t) option ; mutable committed : Digestif.SHA1.t option
; in_closure : bool ; mutable change_and_push_waiter : unit Lwt.t option
; mutable head : Store.hash option } ; mutable head : Store.hash option }
reynir commented 2024-10-29 10:19:16 +00:00
Outdated
Review
Copy link

Could this be done with the mutex only instead of a bool, mutex and a condition?

Could this be done with the mutex only instead of a bool, mutex and a condition?
hannes commented 2024-10-29 10:24:21 +00:00
Outdated
Review
Copy link

Indeed, we can acquire the mutex at the begin of change_and_push -- which will wait (block) until the mutex is unused.

Indeed, we can acquire the mutex at the begin of change_and_push -- which will wait (block) until the mutex is unused.
dinosaure commented 2024-10-29 10:40:08 +00:00
Outdated
Review
Copy link

yes, basically protect the whole change_and_push with a mutex will solve all of our issues 😄

yes, basically protect the whole `change_and_push` with a mutex will solve all of our issues 😄
let init_store () = let init_store () =
@ -102,7 +102,7 @@ let connect ctx endpoint =
init_store () >>= fun store -> init_store () >>= fun store ->
let store = to_invalid store in let store = to_invalid store in
let edn, branch = split_url endpoint 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 -> pull t >>= fun r ->
let _r = to_invalid r in let _r = to_invalid r in
Lwt.return t 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 -> Result.fold ~ok:Fun.id ~error:(function `Msg msg -> failwith msg) >>= fun store ->
analyze store data >>= fun head -> analyze store data >>= fun head ->
let edn, branch = split_url remote in let edn, branch = split_url remote in
Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; in_closure= false; head; }) Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; change_and_push_waiter= None; head; })
(fun exn -> (fun _exn ->
Lwt.return_error (`Msg "Invalid PACK file")) Lwt.return_error (`Msg "Invalid PACK file"))
module Make (Pclock : Mirage_clock.PCLOCK) = struct 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 | `Reference_not_found _ | `Msg _ as err -> Store.pp_error ppf err
| `Hash_not_found hash -> Store.pp_error ppf (`Not_found hash) | `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 match t.committed, t.head with
| None, None -> Lwt.return None | 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)) Search.find t.store tree_root_hash (`Path (Mirage_kv.Key.segments key))
| None, Some commit -> | None, Some commit ->
Search.find t.store commit (`Commit (`Path (Mirage_kv.Key.segments key))) Search.find t.store commit (`Commit (`Path (Mirage_kv.Key.segments key)))
let exists t key = let exists t key =
let open Lwt.Infix in let open Lwt.Infix in
noppp t key >>= function find_blob t key >>= function
| None -> Lwt.return (Ok None) | None -> Lwt.return (Ok None)
| Some tree_hash -> | Some tree_hash ->
Store.read_exn t.store tree_hash >>= function Store.read_exn t.store tree_hash >>= function
@ -414,7 +416,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
let get t key = let get t key =
let open Lwt.Infix in let open Lwt.Infix in
noppp t key >>= function find_blob t key >>= function
| None -> Lwt.return (Error (`Not_found key)) | None -> Lwt.return (Error (`Not_found key))
| Some blob -> | Some blob ->
Store.read_exn t.store blob >|= function Store.read_exn t.store blob >|= function
@ -435,7 +437,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
let list t key = let list t key =
let open Lwt.Infix in let open Lwt.Infix in
noppp t key >>= function find_blob t key >>= function
| None -> Lwt.return (Error (`Not_found key)) | None -> Lwt.return (Error (`Not_found key))
| Some tree -> | Some tree ->
Store.read_exn t.store tree >>= function Store.read_exn t.store tree >>= function
@ -453,8 +455,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
let last_modified t key = let last_modified t key =
let open Lwt.Infix in let open Lwt.Infix in
noppp t key >>= find_blob t key >>=
(* FIXME *)
Option.fold Option.fold
~none:(Lwt.return (Error (`Not_found key))) ~none:(Lwt.return (Error (`Not_found key)))
~some:(fun head -> ~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)) ~some:Fun.id (Ptime.of_float_s (Int64.to_float secs))
in in
Ok ts Ok ts
| _ -> assert false) | _ ->
Ok (Option.fold
~none:Ptime.epoch
~some:Fun.id (Ptime.of_float_s (Int64.to_float (now ())))))
hannes commented 2024-10-29 08:56:21 +00:00
Review
Copy link

we don't have a commit in this case (we're in a change_and_push), so let's use the current timestamp. this is good enough for our definition of last_modified (which is the last commit)

we don't have a commit in this case (we're in a change_and_push), so let's use the current timestamp. this is good enough for our definition of last_modified (which is the last commit)
let digest t key = let digest t key =
let open Lwt.Infix in let open Lwt.Infix in
noppp t key >>= find_blob t key >>=
(* FIXME *)
Option.fold Option.fold
~none:(Lwt.return (Error (`Not_found key))) ~none:(Lwt.return (Error (`Not_found key)))
~some:(fun x -> Lwt.return (Ok (Store.Hash.to_raw_string x))) ~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 -> get t key >|= fun data ->
Optint.Int63.of_int (String.length 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 } { Git.User.name ; email ; date = now (), None }
let rec unroll_tree t ~tree_root_hash (pred_perm, pred_name, pred_hash) rpath = 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 = let tree_root_hash_of_store t =
match t.committed, t.head with 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 -> | None, None ->
let open Lwt_result.Infix in let open Lwt_result.Infix in
let tree = Store.Value.Tree.v [] 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)) | _ -> Lwt.return_error (`Msg (Fmt.str "The current HEAD value (%a) is not a commit" Digestif.SHA1.pp commit))
let ( >>? ) = Lwt_result.bind 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 set ?and_commit t key contents =
let segs = Mirage_kv.Key.segments key in 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 -> 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 -> unroll_tree t ~tree_root_hash (`Normal, name, hash) (List.tl rpath) >>= fun tree_root_hash ->
match and_commit with match and_commit with
| Some (_old_tree_root_hash, th) -> | Some _old_tree_root_hash ->
t.committed <- Some (tree_root_hash, th) ; t.committed <- Some tree_root_hash ;
Lwt.return_ok () Lwt.return_ok ()
| None -> | None ->
let committer = author now in let committer = author now in
let author = 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 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 let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
~parents (Some "Committed by git-kv") in ~parents (Some "Committed by git-kv") in
Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> 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 remove ?and_commit t key =
let segs = Mirage_kv.Key.segments key in let segs = Mirage_kv.Key.segments key in
(* FIXME: t.head *) match List.rev segs with
match List.rev segs, t.head with | [] -> assert false
| [], _ -> assert false | name :: [] ->
| _, None -> Lwt.return_ok () (* XXX(dinosaure): or [`Not_found]? *)
| name :: [], Some head ->
let open Lwt_result.Infix in let open Lwt_result.Infix in
tree_root_hash_of_store t >>= fun tree_root_hash -> tree_root_hash_of_store t >>= fun tree_root_hash ->
Store.read_exn t.store tree_root_hash >>! fun tree_root -> 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 let open Lwt_result.Infix in
Store.write t.store (Git.Value.Tree tree_root) >>= fun (tree_root_hash, _) -> Store.write t.store (Git.Value.Tree tree_root) >>= fun (tree_root_hash, _) ->
( match and_commit with ( 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 -> | None ->
let committer = author now in let committer = author now in
let author = 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 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.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () -> 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) ] 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)) Git.Reference.pp t.branch Sync.pp_error err))
>>? fun () -> Store.shallow t.store hash >|= Result.ok) >>? fun () -> Store.shallow t.store hash >|= Result.ok)
>>= fun () -> t.head <- Some hash ; Lwt.return_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 let open Lwt_result.Infix in
tree_root_hash_of_store t >>= fun tree_root_hash -> tree_root_hash_of_store t >>= fun tree_root_hash ->
Search.find t.store tree_root_hash (`Path (List.rev (pred_name :: rest))) >>! function 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, _) -> 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 -> unroll_tree t ~tree_root_hash (`Dir, pred_name, pred_hash) rest >>= fun tree_root_hash ->
( match and_commit with ( 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 -> | None ->
let committer = author now in let committer = author now in
let author = 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 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.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () -> 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) ] 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 change_and_push t ?author:name ?author_email:email ?(message = "Committed by git-kv") f =
let open Lwt.Infix in let open Lwt.Infix in
if t.in_closure then match t.committed with
Lwt.return_error (`Msg "Nested change_and_push") | Some _ -> Lwt.return_error (`Msg "Nested change_and_push")
else | None ->
(* XXX(dinosaure): serialize [change_and_push]. If we do (* XXX(dinosaure): serialize [change_and_push]. If we do
[Lwt.both (change_and_push ..) (change_and_push ..)], they can not run [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. *)
( match t.committed with
| None -> Lwt.return_unit
| Some (_tree_root_hash, th) -> th ) >>= fun () ->
let th, wk = Lwt.wait () in 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 () ->
hannes commented 2024-10-29 08:53:01 +00:00
Outdated
Review
Copy link

the reason for this change is: we may have one change_and_push that is active, and when there are then multiple other change_and_push that should be executed, each needs to wait for the next one.

previously, the code had all other change_and_push wait for the same task -- and thus there may have been multiple waiting change_and_push waken up at the same time, leading to races.

the reason for this change is: we may have one change_and_push that is active, and when there are then multiple other change_and_push that should be executed, each needs to wait for the next one. previously, the code had all other change_and_push wait for the same task -- and thus there may have been multiple waiting change_and_push waken up at the same time, leading to races.
( let open Lwt_result.Infix in ( let open Lwt_result.Infix in
tree_root_hash_of_store t >>= fun tree_root_hash -> tree_root_hash_of_store t >>= fun tree_root_hash ->
t.committed <- Some (tree_root_hash, th) ; t.change_and_push_waiter <- Some th ;
hannes marked this conversation as resolved Outdated
dinosaure commented 2024-10-29 08:48:07 +00:00
Outdated
Review
Copy link

t.change_and_push is already set 3 lines before.

`t.change_and_push` is already set 3 lines before.
hannes commented 2024-10-29 08:51:09 +00:00
Outdated
Review
Copy link

indeed, removed in 750ec11

indeed, removed in 750ec11
let t' = { t with in_closure= true } in let t' = { t with committed = Some tree_root_hash } in
f t' >>! fun res -> f t' >>! fun res ->
(* XXX(dinosaure): we assume that only [change_and_push] can reset [t.committed] to [None] and (* 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] we ensured that [change_and_push] can not be called into [f]. So we are sure that [t'.committed]
must be [Some _] in anyway. *) 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 if Digestif.SHA1.equal new_tree_root_hash tree_root_hash
then Lwt.return_ok res (* XXX(dinosaure): nothing to send! *) then Lwt.return_ok res (* XXX(dinosaure): nothing to send! *)
else if not (Option.equal Digestif.SHA1.equal t.head t'.head) then
hannes commented 2024-10-29 08:55:16 +00:00
Outdated
Review
Copy link

this change requires that the head didn't mutate since we started the change_and_push. we could as well do a rebase or merge, but we weren't able to find merge/rebase code.

this is illustrated by the test set_outside_change_and_push.

this change requires that the head didn't mutate since we started the change_and_push. we could as well do a rebase or merge, but we weren't able to find merge/rebase code. this is illustrated by the test `set_outside_change_and_push`.
Lwt.return (Error (`Msg "store was modified outside of change_and_push, please retry"))
else else
let action = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head 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 author = author ?name ?email now in let author = author ?name ?email now in
let committer = author in let committer = author in
let commit = Store.Value.Commit.make ~tree:new_tree_root_hash ~author ~committer let commit = Store.Value.Commit.make ~tree:new_tree_root_hash ~author ~committer
~parents (Some message) in ~parents (Some message) in
Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> 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 () -> 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 ] Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ action ]
>|= Result.map_error (fun err -> >|= 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)) Git.Reference.pp t.branch Sync.pp_error err))
>>? fun () -> >>? fun () ->
Store.shallow t.store hash >|= Result.ok) >>= fun () -> Store.shallow t.store hash >|= Result.ok) >>= fun () ->
t.head <- Some hash ;
Lwt.return_ok res ) Lwt.return_ok res )
>|= Result.map_error >|= Result.map_error
(fun err -> `Msg (Fmt.str "error pushing %a" Store.pp_error err)) (fun err -> `Msg (Fmt.str "error pushing %a" Store.pp_error err))
>>= fun res -> >>= fun res ->
Lwt.wakeup_later wk () ; Lwt.wakeup_later wk () ;
t.committed <- None ; t.change_and_push_waiter <- None ;
Lwt.return res Lwt.return res
end end

4
test/dune
View file

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

178
test/tests.ml
View file

@ -7,35 +7,187 @@ let run_it cmd =
let empty_repo () = let empty_repo () =
let* cwd = Bos.OS.Dir.current () in 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* () = 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* () = run_it cmd in
let* () = Bos.OS.Dir.set_current cwd 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* () = run_it cmd in
let* pid = Bos.OS.File.read (Fpath.v "pid") in let pid = Result.get_ok (Bos.OS.File.read (Fpath.v "pid")) in
Ok (tmpdir, String.trim pid) Ok (Fpath.basename tmpdir, String.trim pid)
let kill_git pid = let kill_git pid =
Unix.kill (int_of_string pid) Sys.sigterm 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 match
let* (tmpdir, pid) = empty_repo () in let* (tmpdir, pid) = empty_repo () in
print_endline ("git started with " ^ Fpath.to_string tmpdir); Fun.protect ~finally:(fun () -> kill_git pid) (fun () ->
print_endline ("git pid " ^ pid); Lwt_main.run
Unix.sleep 2; (
kill_git pid; Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx ->
print_endline "git killed"; 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 () Ok ()
with with
| Ok () -> Alcotest.(check bool __LOC__ true true) | Ok () -> ()
| Error `Msg msg -> | Error `Msg msg ->
print_endline ("got an error from bos: " ^ 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 = [ 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 = [ let tests = [