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 +391 -90
8 changed files with 391 additions and 90 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
git-kv.opam
View file

@ -21,6 +21,8 @@ depends: [
"conf-git" {with-test} "conf-git" {with-test}
"mirage-clock-unix" {with-test} "mirage-clock-unix" {with-test}
"git-unix" {>= "3.10.0" & with-test} "git-unix" {>= "3.10.0" & with-test}
"alcotest" {>= "1.8.0" & with-test}
"bos" {>= "0.2.1" & with-test}
] ]
build: [ build: [

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

163
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 ; mutex : Lwt_mutex.t
; 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; mutex= Lwt_mutex.create (); 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; mutex= Lwt_mutex.create (); 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,25 +395,28 @@ 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 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 exists t key =
let open Lwt.Infix in let open Lwt.Infix in
match t.head with find_blob t key >>= function
| None -> Lwt.return (Ok None) | None -> Lwt.return (Ok None)
| Some head -> | Some tree_hash ->
Search.mem t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function Store.read_exn t.store tree_hash >>= 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
| Blob _ -> Lwt.return (Ok (Some `Value)) | Blob _ -> Lwt.return (Ok (Some `Value))
| Tree _ | Commit _ | Tag _ -> Lwt.return (Ok (Some `Dictionary)) | Tree _ | Commit _ | Tag _ -> Lwt.return (Ok (Some `Dictionary))
let get t key = let get t key =
let open Lwt.Infix in let open Lwt.Infix in
match t.head with find_blob t key >>= function
| None -> Lwt.return (Error (`Not_found key))
| Some head ->
Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments 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
@ -434,10 +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
match t.head with find_blob t key >>= function
| None -> Lwt.return (Error (`Not_found key))
| Some head ->
Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments 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
@ -455,6 +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
find_blob t key >>=
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,21 +478,24 @@ 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) | _ ->
t.head 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
find_blob t key >>=
Option.fold Option.fold
~none:(Error (`Not_found key)) ~none:(Lwt.return (Error (`Not_found key)))
~some:(fun x -> Ok (Store.Hash.to_raw_string x)) ~some:(fun x -> Lwt.return (Ok (Store.Hash.to_raw_string x)))
t.head |> Lwt.return
let size t key = let size t key =
let open Lwt_result.Infix in let open Lwt_result.Infix in
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 =
@ -520,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
@ -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)) | _ -> 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
@ -548,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, _) ->
@ -593,10 +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
match List.rev segs, t.head with match List.rev segs with
| [], _ -> assert false | [] -> assert false
| _, None -> Lwt.return_ok () (* XXX(dinosaure): or [`Not_found]? *) | name :: [] ->
| 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 ->
@ -605,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) ]
@ -618,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
@ -629,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) ]
@ -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 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 Lwt_mutex.with_lock t.mutex (fun () ->
[Lwt.both (change_and_push ..) (change_and_push ..)], they can not run (let open Lwt_result.Infix in
concurrently! The second will waiting the first to finish. *) tree_root_hash_of_store t >>= fun tree_root_hash ->
( match t.committed with let t' = { t with committed = Some tree_root_hash } in
| None -> Lwt.return_unit f t' >>! fun res ->
| Some (_tree_root_hash, th) -> th ) >>= fun () -> (* XXX(dinosaure): we assume that only [change_and_push] can reset [t.committed] to [None] and
let th, wk = Lwt.wait () in we ensured that [change_and_push] can not be called into [f]. So we are sure that [t'.committed]
( let open Lwt_result.Infix in must be [Some _] in anyway. *)
tree_root_hash_of_store t >>= fun tree_root_hash -> let[@warning "-8"] Some new_tree_root_hash = t'.committed in
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.
t.committed <- Some (tree_root_hash, th) ; if Digestif.SHA1.equal new_tree_root_hash tree_root_hash
let t' = { t with in_closure= true } in then Lwt.return_ok res (* XXX(dinosaure): nothing to send! *)
f t' >>! fun res -> else if not (Option.equal Digestif.SHA1.equal t.head t'.head) then
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
(* XXX(dinosaure): we assume that only [change_and_push] can reset [t.committed] to [None] and Lwt.return (Error (`Msg "store was modified outside of change_and_push, please retry"))
we ensured that [change_and_push] can not be called into [f]. So we are sure that [t'.committed] else
must be [Some _] in anyway. *) let action = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head in
let[@warning "-8"] Some (new_tree_root_hash, _) = t'.committed in let parents = Option.to_list t.head in
if Digestif.SHA1.equal new_tree_root_hash tree_root_hash let author = author ?name ?email now in
then Lwt.return_ok res (* XXX(dinosaure): nothing to send! *) let committer = author in
else let commit = Store.Value.Commit.make ~tree:new_tree_root_hash ~author ~committer
let action = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head in ~parents (Some message) in
let parents = Option.value ~default:[] (Option.map (fun head -> [ head ]) t.head) in Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
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`.
let author = author ?name ?email now in Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
let committer = author in Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ action ]
let commit = Store.Value.Commit.make ~tree:new_tree_root_hash ~author ~committer >|= Result.map_error (fun err ->
~parents (Some message) in `Msg (Fmt.str "error pushing branch %a: %a"
Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> Git.Reference.pp t.branch Sync.pp_error err))
t.head <- Some hash ; >>? fun () ->
Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () -> Store.shallow t.store hash >|= Result.ok) >>= fun () ->
Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ action ] t.head <- Some hash ;
>|= Result.map_error (fun err -> Lwt.return_ok res)
`Msg (Fmt.str "error pushing branch %a: %a" >|= Result.map_error
Git.Reference.pp t.branch Sync.pp_error err)) (fun err -> `Msg (Fmt.str "error pushing %a" Store.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
end end

16
test/dune
View file

@ -1,14 +1,21 @@
(env (_ (binaries (../app/mgit.exe as mgit))))
(cram (cram
(package git-kv) (package git-kv)
(applies_to simple) (applies_to simple)
(locks p9418) (locks p9418)
(deps %{exe:../app/mgit.exe})) (deps %{bin:mgit}))
(cram (cram
(package git-kv) (package git-kv)
(applies_to fold) (applies_to fold)
(locks p9418) (locks p9418)
(deps %{exe:../app/mgit.exe})) (deps %{bin:mgit}))
(cram
(package git-kv)
(applies_to fold2)
(locks p9418)
(deps %{bin:mgit}))
(executable (executable
(name git_daemon_exists) (name git_daemon_exists)
@ -18,3 +25,8 @@
(with-stdout-to (with-stdout-to
git-daemon git-daemon
(run ./git_daemon_exists.exe))) (run ./git_daemon_exists.exe)))
(test
(name tests)
(libraries git-kv alcotest bos mirage-clock-unix lwt.unix git-unix)
(modules tests))

6
test/fold.t
View file

@ -11,18 +11,20 @@ Batch operation
> exists /bar > exists /bar
> quit > quit
> quit > quit
/bar does not exists > EOF
/bar exists as a value
$ mgit git://localhost/simple#main <<EOF $ mgit git://localhost/simple#main <<EOF
> list / > list /
> get /bar > get /bar
> get /foo > get /foo
> quit > quit
> EOF
- /bar - /bar
- /foo - /foo
00000000: 4769 7420 726f 636b 7321 Git rocks! 00000000: 4769 7420 726f 636b 7321 Git rocks!
00000000: 4865 6c6c 6f20 576f 726c 6421 Hello World! 00000000: 4865 6c6c 6f20 576f 726c 6421 Hello World!
$ cd simple $ cd simple
$ git log main --pretty=oneline | wc -l $ git log main --pretty=oneline | wc -l | tr -d ' '
1 1
$ cd .. $ cd ..
$ kill $(cat pid) $ kill $(cat pid)

19
test/fold2.t Normal file
View file

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

3
test/simple.t
View file

@ -17,6 +17,7 @@ Simple test of our Git Key-Value store
> get /foo > get /foo
> save db.pack > save db.pack
> quit > quit
> EOF
00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!.
$ tail -c20 db.pack | hxd.xxd $ tail -c20 db.pack | hxd.xxd
00000000: e4b2 3437 2e7e 3d7e 8508 3912 3d87 11cd ..47.~=~..9.=... 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 <<EOF $ mgit git://localhost/simple db.pack <<EOF
> get /foo > get /foo
> quit > quit
> EOF
00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!.
$ cd simple $ cd simple
$ echo "Git rocks!" > bar $ echo "Git rocks!" > bar
@ -35,6 +37,7 @@ Simple test of our Git Key-Value store
> get /bar > get /bar
> get /foo > get /foo
> quit > quit
> EOF
+ /bar + /bar
* / * /
00000000: 4769 7420 726f 636b 7321 0a Git rocks!. 00000000: 4769 7420 726f 636b 7321 0a Git rocks!.

269
test/tests.ml Normal file
View file

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