From e16dcce930d0c458fdae8f7e4843a865e503ea9e Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Fri, 28 Oct 2022 16:38:32 +0200 Subject: [PATCH 1/4] Rename batch to change_and_push and re-instantiate batch as a noop function --- README.md | 13 +++++++------ src/git_kv.ml | 4 +++- src/git_kv.mli | 15 ++++++++++----- 3 files changed, 20 insertions(+), 12 deletions(-) diff --git a/README.md b/README.md index d9c3bb1..45ae3ed 100644 --- a/README.md +++ b/README.md @@ -47,10 +47,11 @@ let _ = The user can manipulate the repository as an [RW][mirage-kv-rw] repository. Any change to the repository requires a new commit. These changes will be sent to -the remote repository by default. If the user does not want to push modifications, -they can use `Git_kv.Make.Local` which provide functions without `push`. If the -user knows that they will do many changes and they don't want to change all of -them and do a `push` only at the end, they can use `Git_kv.Make.batch`. +the remote repository by default. If the user does not want to push +modifications, they can use `Git_kv.Make.Local` which provide functions without +`push`. If the user knows that they will do many changes and they don't want to +change all of them and do a `push` only at the end, they can use +`Git_kv.Make.change_and_push`. ```ocaml module Store = Git_kv.Make (Pclock) @@ -63,8 +64,8 @@ let new_file_locally t = Store.Local.set t Mirage_kv.Key.(empty / "foo") "foo" >>= fun () -> ... -let batch_operations t = - Store.batch t @@ fun t -> +let push_operations t = + Store.change_and_push t @@ fun t -> Store.set t Mirage_kv.Key.(empty / "bar") "bar" >>= fun () -> Store.remove t Mirage_kv.Key.(empty / "foo") ``` diff --git a/src/git_kv.ml b/src/git_kv.ml index 4fc0178..4d0433b 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -607,7 +607,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct remove ~and_push t source >>= fun () -> set ~and_push t dest contents - let batch t ?retries:_ f = + let change_and_push t f = let open Lwt.Infix in ( match t.batch with | None -> Lwt.return_unit @@ -625,6 +625,8 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct Lwt.wakeup_later wk () ; Lwt.return res + let batch t ?retries:_ f = f t + module Local = struct let set_partial t k ~offset v = set_partial ~and_push:false t k ~offset v let set t k v = set ~and_push:false t k v diff --git a/src/git_kv.mli b/src/git_kv.mli index 13837b6..2c04b6f 100644 --- a/src/git_kv.mli +++ b/src/git_kv.mli @@ -31,11 +31,11 @@ remotely, the commit-graph given by the transmission, and your last commit. In that way, our [push] is most similar to a [git push --force]! - To save I/O, the {!val:Make.batch} operation allows you to do some change - into a closure and the implementation will push only at the end of this - closure. By this way, you can {!val:Make.set}, {!val:Make.rename} or - {!val:Make.remove} without a systematic [push] on these actions. Only one - will be done at the end of your closure. + To save I/O, the {!val:Make.change_and_push} operation allows you to do + some change into a closure and the implementation will push only at the end + of this closure. By this way, you can {!val:Make.set}, {!val:Make.rename} + or {!val:Make.remove} without a systematic [push] on these actions. Only + one will be done at the end of your closure. {2: Serialization of the Git repository.} @@ -84,6 +84,11 @@ module Make (Pclock : Mirage_clock.PCLOCK) : sig | `Reference_not_found of Git.Reference.t | Mirage_kv.write_error ] + val change_and_push : t -> (t -> 'a Lwt.t) -> 'a Lwt.t + (** [change_and_push store f] lets the user to do some changes into [f] and + only push commits at the end of [f]. It saves I/O if the user wants to + do multiple changes without pushing every times. *) + module Local : sig val set : t -> key -> string -> (unit, write_error) result Lwt.t val remove : t -> key -> (unit, write_error) result Lwt.t From b5fa25d9a551f29dc48785c203218821078f579b Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Sat, 29 Oct 2022 21:18:10 +0200 Subject: [PATCH 2/4] Implement the batch function according to the documentation This implementation is much more close to the documentation & fold all changes into one commit. Then, it pushes this commit remotely. This commit deleted local changes which complexify the codebase for a questionable interest. As the documentation said, any changes are delayed and not directly "committed" until the end of the given function. For instance: > batch > set /bar "Bar" > exists /bar /bar does not exists is an expected behavior. Only after a quit (which delimit the end of the batch process), /bar will be committed and will exist! --- app/mgit.ml | 78 +++++++++++++--- dune-project | 2 +- src/git_kv.ml | 248 ++++++++++++++++++++++++++----------------------- src/git_kv.mli | 12 --- test/batch.t | 28 ++++++ test/dune | 8 ++ test/simple.t | 13 +-- 7 files changed, 239 insertions(+), 150 deletions(-) create mode 100644 test/batch.t diff --git a/app/mgit.ml b/app/mgit.ml index 2f20408..8d4412f 100644 --- a/app/mgit.ml +++ b/app/mgit.ml @@ -35,6 +35,42 @@ let get ~quiet store key = if not quiet then Fmt.epr "%a.\n%!" Store.pp_error err ; Lwt.return (Ok 1) +let exists ~quiet store key = + Store.exists store key >>= function + | Ok k when not quiet -> + ( match k with + | None -> Fmt.pr "%a does not exists\n%!" Mirage_kv.Key.pp key + | Some `Dictionary -> Fmt.pr "%a exists as a dictionary\n%!" Mirage_kv.Key.pp key + | Some `Value -> Fmt.pr "%a exists as a value\n%!" Mirage_kv.Key.pp key ) ; + Lwt.return (Ok 0) + | Ok _ -> Lwt.return (Ok 0) + | Error err -> + if not quiet then Fmt.epr "%a.\n%!" Store.pp_error err ; + Lwt.return (Ok 1) + +let value_of_string str = + let v = ref None in + match Scanf.sscanf str "%S" (fun str -> v := Some str) with + | () -> Option.get !v + | exception _ -> + Scanf.sscanf str "%s" (fun str -> v := Some str) ; + Option.get !v + +let set ~quiet store key str = + let value = value_of_string str in + Store.set store key value >>= function + | Ok () -> Lwt.return (Ok 0) + | Error err -> + if not quiet then Fmt.epr "%a.\n%!" Store.pp_write_error err ; + Lwt.return (Ok 1) + +let remove ~quiet store key = + Store.remove store key >>= function + | Ok () -> Lwt.return (Ok 0) + | Error err -> + if not quiet then Fmt.epr "%a.\n%!" Store.pp_write_error err ; + Lwt.return (Ok 1) + let list ~quiet store key = Store.list store key >>= function | Ok lst when not quiet -> @@ -77,28 +113,48 @@ let with_key ~f key = Fmt.epr "Invalid key: %S.\n%!" key ; Lwt.return (Ok 1) -let repl store ic = - let rec go () = Fmt.pr "# %!" ; match String.split_on_char ' ' (input_line ic) |> trim with +let repl store fd_in = + let is_a_tty = Unix.isatty fd_in in + let ic = Unix.in_channel_of_descr fd_in in + let rec go store0 = + if is_a_tty then Fmt.pr "# %!" ; + match String.split_on_char ' ' (input_line ic) |> trim with | [ "get"; key; ] -> - with_key ~f:(get ~quiet:false store) key >|= ignore >>= go + with_key ~f:(get ~quiet:false store0) key + >|= ignore >>= fun () -> go store0 + | [ "exists"; key; ] -> + with_key ~f:(exists ~quiet:false store0) key + >|= ignore >>= fun () -> go store0 + | "set" :: key :: data -> + let data = String.concat " " data in + with_key ~f:(fun key -> set ~quiet:false store0 key data) key + >|= ignore >>= fun () -> go store0 + | [ "remove"; key; ] -> + with_key ~f:(remove ~quiet:false store0) key + >|= ignore >>= fun () -> go store0 | [ "list"; key; ] -> - with_key ~f:(list ~quiet:false store) key >|= ignore >>= go + with_key ~f:(list ~quiet:false store0) key + >|= ignore >>= fun () -> go store0 | [ "pull"; ] -> - Fmt.pr "\n%!" ; pull ~quiet:false store >|= ignore >>= go + if is_a_tty then Fmt.pr "\n%!" ; pull ~quiet:false store0 + >|= ignore >>= fun () -> go store0 | [ "quit"; ] -> Lwt.return () + | [ "batch"; ] -> + Store.batch store0 (fun store1 -> go store1) + >>= fun () -> go store0 | [ "save"; filename ] -> - save store filename >|= ignore >>= fun _ -> - Fmt.pr "\n%!" ; go () - | _ -> Fmt.epr "Invalid command.\n%!" ; go () + save store0 filename >|= ignore + >>= fun _ -> if is_a_tty then Fmt.pr "\n%!" ; go store0 + | _ -> Fmt.epr "Invalid command.\n%!" ; go store0 | exception End_of_file -> Lwt.return () in - go () + go store let run remote = function | None -> Lwt_main.run @@ (Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx -> Git_kv.connect ctx remote >>= fun t -> - repl t stdin) + repl t Unix.stdin) | Some filename -> let contents = let ic = open_in filename in @@ -109,7 +165,7 @@ let run remote = function Lwt_main.run ( Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx -> Git_kv.of_octets ctx ~remote contents >>= function - | Ok t -> repl t stdin + | Ok t -> repl t Unix.stdin | Error (`Msg err) -> Fmt.failwith "%s." err ) let () = match Sys.argv with diff --git a/dune-project b/dune-project index 9a0a39f..52257fa 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 2.8) +(lang dune 2.9) (name git-kv) (formatting disabled) (cram enable) diff --git a/src/git_kv.ml b/src/git_kv.ml index 4d0433b..de3e0f6 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -8,7 +8,8 @@ type t = ; edn : Smart_git.Endpoint.t ; branch : Git.Reference.t ; store : Store.t - ; mutable batch : unit Lwt.t option + ; mutable committed : (Digestif.SHA1.t * unit Lwt.t) option + ; in_closure : bool ; mutable head : Store.hash option } let init_store () = @@ -19,6 +20,7 @@ let init_store () = r let main = Git.Reference.v "refs/heads/main" +let msgf fmt = Fmt.kstr (fun msg -> `Msg msg) fmt let capabilities = [ `Side_band_64k; `Multi_ack_detailed; `Ofs_delta; `Thin_pack; `Report_status ] @@ -103,7 +105,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 ; batch= None; head= None } in + let t = { ctx ; edn ; branch ; store ; committed= None; in_closure= false; head= None } in pull t >>= fun r -> let _r = to_invalid r in Lwt.return t @@ -180,6 +182,7 @@ let ( <.> ) f g = fun x -> f (g x) let ( >>? ) x f = let open Lwt.Infix in match x with | Some x -> f x >>= fun v -> Lwt.return_some v | None -> Lwt.return_none +let ( >>! ) x f = Lwt.Infix.(x >>= f) let pack t ~commit stream = let open Lwt.Infix in @@ -336,7 +339,7 @@ let of_octets ctx ~remote data = >|= Rresult.R.failwith_error_msg >>= fun store -> analyze store data >>= fun head -> let edn, branch = split_url remote in - Lwt.return_ok { ctx ; edn ; branch ; store ; batch= None; head; }) + Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; in_closure= false; head; }) (fun exn -> Fmt.epr ">>> Got an exception: %s.\n%!" (Printexc.to_string exn) ; Fmt.epr ">>> %s.\n%!" @@ -453,73 +456,77 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct ; email= "git@mirage.io" ; date= now (), None } - let rec unroll_tree t ?head (pred_perm, pred_name, pred_hash) rpath = + let rec unroll_tree t ~tree_root_hash (pred_perm, pred_name, pred_hash) rpath = let open Lwt.Infix in let ( >>? ) = Lwt_result.bind in - let ( >>! ) x f = match x with - | Some x -> f x - | None -> Lwt.return_none in match rpath with | [] -> - ( match head with - | None -> - let tree = Git.Tree.(v [ entry ~name:pred_name pred_perm pred_hash ]) in + ( Store.read_exn t.store tree_root_hash >>= function + | Git.Value.Tree tree -> + let tree = Git.Tree.(add (entry ~name:pred_name pred_perm pred_hash) (remove ~name:pred_name tree)) in Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> Lwt.return_ok hash - | Some head -> - Search.find t.store head (`Commit (`Path [])) >|= Option.get >>= fun tree_root_hash -> - ( Store.read_exn t.store tree_root_hash >>= function - | Git.Value.Tree tree -> - let tree = Git.Tree.(add (entry ~name:pred_name pred_perm pred_hash) (remove ~name:pred_name tree)) in - Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> Lwt.return_ok hash - | _ -> assert false ) ) + | _ -> assert false ) | name :: rest -> - (head >>! fun head -> Search.find t.store head (`Commit (`Path (List.rev rpath)))) >>= function + Search.find t.store tree_root_hash (`Path (List.rev rpath)) >>= function | None -> let tree = Git.Tree.(v [ entry ~name:pred_name pred_perm pred_hash ]) in Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> - unroll_tree t ?head (`Dir, name, hash) rest + unroll_tree t ~tree_root_hash (`Dir, name, hash) rest | Some tree_hash -> ( Store.read_exn t.store tree_hash >>= function | Git.Value.Tree tree -> let tree = Git.Tree.(add (entry ~name:pred_name pred_perm pred_hash) (remove ~name:pred_name tree)) in Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> - unroll_tree t ?head (`Dir, name, hash) rest + unroll_tree t ~tree_root_hash (`Dir, name, hash) rest | _ -> assert false ) - let no_batch = function - | None -> true - | Some th -> match Lwt.state th with - | Sleep -> true - | Return _ | Fail _ -> false + let tree_root_hash_of_store t = + match t.committed, t.head with + | 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 + Store.write t.store (Git.Value.Tree tree) >>= fun (hash, _) -> + Lwt.return_ok hash + | None, Some commit -> + let open Lwt.Infix in + Store.read_exn t.store commit >>= function + | Git.Value.Commit commit -> Lwt.return_ok (Store.Value.Commit.tree commit) + | _ -> Lwt.return_error (msgf "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_push t key contents = + let set ?and_commit t key contents = let segs = Mirage_kv.Key.segments key in - let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))) in match segs with - | [] -> assert false + | [] -> assert false (* TODO *) | path -> let blob = Git.Blob.of_string contents in let rpath = List.rev path in let name = List.hd rpath in let open Lwt_result.Infix in Store.write t.store (Git.Value.Blob blob) >>= fun (hash, _) -> - unroll_tree t ?head:t.head (`Normal, name, hash) (List.tl rpath) >>= fun tree_root_hash -> - let committer = author ~now in - let author = author ~now in - let parents = Option.value ~default:[] (Option.map (fun head -> [ head ]) 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, _) -> - Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () -> - Lwt.Infix.(if and_push then - Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] - >|= 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) - else Lwt.return_ok ()) >>= fun () -> - t.head <- Some hash ; Lwt.return_ok () + 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) ; + 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 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, _) -> + 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 () let to_write_error (error : Store.error) = match error with | `Not_found hash -> `Hash_not_found hash @@ -527,115 +534,122 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct | `Msg err -> `Msg err | err -> Rresult.R.msgf "%a" Store.pp_error err - let set ?(and_push= true) t key contents = + let set t key contents = let open Lwt.Infix in - let and_push = no_batch t.batch && and_push in - set ~and_push t key contents >|= Rresult.R.reword_error to_write_error + set ?and_commit:t.committed t key contents + >|= Rresult.R.reword_error to_write_error - let set_partial ?(and_push= true) t key ~offset chunk = + let set_partial t key ~offset chunk = let open Lwt_result.Infix in - let and_push = no_batch t.batch && and_push in get t key >>= fun contents -> let len = String.length contents in let add = String.length chunk in let res = Bytes.make (max len (offset + add)) '\000' in Bytes.blit_string contents 0 res 0 len ; Bytes.blit_string chunk 0 res offset add ; - set ~and_push t key (Bytes.unsafe_to_string res) + set t key (Bytes.unsafe_to_string res) - let remove ~and_push t key = + let remove ?and_commit t key = let segs = Mirage_kv.Key.segments key in - let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))) in match List.rev segs, t.head with | [], _ -> assert false | _, None -> Lwt.return_ok () (* XXX(dinosaure): or [`Not_found]? *) | name :: [], Some head -> - let open Lwt.Infix in - Search.find t.store head (`Commit (`Path [])) >|= Option.get >>= fun tree_root_hash -> - Store.read_exn t.store tree_root_hash >>= fun tree_root -> + 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 -> let[@warning "-8"] Git.Value.Tree tree_root = tree_root in let tree_root = Git.Tree.remove ~name tree_root in let open Lwt_result.Infix in Store.write t.store (Git.Value.Tree tree_root) >>= fun (tree_root_hash, _) -> - let committer = author ~now in - let author = author ~now in - let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer - ~parents:[ head ] (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.(if and_push then - Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] - >|= 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 - else Lwt.return_ok ()) >>= fun () -> - t.head <- Some hash ; Lwt.return_ok () + ( match and_commit with + | Some (_old_tree_root_hash, th) -> t.committed <- Some (tree_root_hash, th) ; Lwt.return_ok () + | None -> + let committer = author ~now in + let author = author ~now in + let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer + ~parents:[ head ] (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) ] + >|= 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 () ) | name :: pred_name :: rest, Some head -> - let open Lwt.Infix in - Search.find t.store head (`Commit (`Path (List.rev (pred_name :: rest)))) >>= function + 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 | None -> Lwt.return_ok () - | Some hash -> Store.read_exn t.store hash >>= function + | Some hash -> Store.read_exn t.store hash >>! function | Git.Value.Tree tree -> let tree = Git.Tree.remove ~name tree in - let open Lwt_result.Infix in Store.write t.store (Git.Value.Tree tree) >>= fun (pred_hash, _) -> - unroll_tree t ~head (`Dir, pred_name, pred_hash) rest >>= fun tree_root_hash -> - let committer = author ~now in - let author = author ~now in - let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer - ~parents:[ head ] (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.(if and_push then - Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] - >|= 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 - else Lwt.return_ok ()) >>= fun () -> - t.head <- Some hash ; Lwt.return_ok () + 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 () + | None -> + let committer = author ~now in + let author = author ~now in + let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer + ~parents:[ head ] (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) ] + >|= 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 () ) | _ -> Lwt.return_ok () - let remove ?(and_push= true) t key = + let remove t key = let open Lwt.Infix in - let and_push = no_batch t.batch && and_push in - remove ~and_push t key >|= Rresult.R.reword_error to_write_error + remove ?and_commit:t.committed t key >|= Rresult.R.reword_error to_write_error - let rename ?(and_push= true) t ~source ~dest = + let rename t ~source ~dest = (* TODO(dinosaure): optimize it! It was done on the naive way. *) let open Lwt_result.Infix in get t source >>= fun contents -> - remove ~and_push t source >>= fun () -> - set ~and_push t dest contents + remove t source >>= fun () -> + set t dest contents - let change_and_push t f = + let batch t ?retries:_ f = let open Lwt.Infix in - ( match t.batch with + if t.in_closure then Fmt.invalid_arg "Nested change_and_push" ; + (* XXX(dinosaure): serialize [batch]. If we do [Lwt.both (batch ..) (batch ..)], they + can not run concurrently! The second will waiting the first to finish. *) + ( match t.committed with | None -> Lwt.return_unit - | Some th -> th ) >>= fun () -> + | Some (_tree_root_hash, th) -> th ) >>= fun () -> let th, wk = Lwt.wait () in - t.batch <- Some th ; - f t >>= fun res -> - ( Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] >>= function - | Ok () -> - ( match t.head with - | None -> Lwt.return_unit - | Some hash -> Store.shallow t.store hash ) - | Error err -> - Fmt.failwith "error pushing branch %a: %a" Git.Reference.pp t.branch Sync.pp_error err ) >>= fun () -> + ( let open Lwt_result.Infix in + tree_root_hash_of_store t >>= fun tree_root_hash -> + t.committed <- Some (tree_root_hash, th) ; + let t' = { t with in_closure= true } in + f t' >>! fun res -> + (* XXX(dinosaure): we assume that only [batch] can reset [t.committed] to [None] and + we ensured that [batch] can not be called into [f]. So we are sure that [t'.committed] + must be [Some _] in anyway. *) + let[@warning "-8"] Some (tree_root_hash, _) = t'.committed 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 committer = author ~now in + let author = author ~now 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, _) -> + 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 ) + >|= Rresult.R.reword_error (msgf "%a" Store.pp_error) + >|= Rresult.R.failwith_error_msg >>= fun res -> Lwt.wakeup_later wk () ; + t.committed <- None ; Lwt.return res - - let batch t ?retries:_ f = f t - - module Local = struct - let set_partial t k ~offset v = set_partial ~and_push:false t k ~offset v - let set t k v = set ~and_push:false t k v - let remove t k = remove ~and_push:false t k - let rename t ~source ~dest = rename ~and_push:false t ~source ~dest - end - - let set_partial t k ~offset v = set_partial ~and_push:true t k ~offset v - let set t k v = set ~and_push:true t k v - let remove t k = remove ~and_push:true t k - let rename t ~source ~dest = rename ~and_push:true t ~source ~dest end diff --git a/src/git_kv.mli b/src/git_kv.mli index 2c04b6f..9fa4aac 100644 --- a/src/git_kv.mli +++ b/src/git_kv.mli @@ -83,16 +83,4 @@ module Make (Pclock : Mirage_clock.PCLOCK) : sig | `Hash_not_found of Digestif.SHA1.t | `Reference_not_found of Git.Reference.t | Mirage_kv.write_error ] - - val change_and_push : t -> (t -> 'a Lwt.t) -> 'a Lwt.t - (** [change_and_push store f] lets the user to do some changes into [f] and - only push commits at the end of [f]. It saves I/O if the user wants to - do multiple changes without pushing every times. *) - - module Local : sig - val set : t -> key -> string -> (unit, write_error) result Lwt.t - val remove : t -> key -> (unit, write_error) result Lwt.t - val rename : t -> source:key -> dest:key -> (unit, write_error) result Lwt.t - val set_partial : t -> key -> offset:int -> string -> (unit, write_error) result Lwt.t - end end diff --git a/test/batch.t b/test/batch.t new file mode 100644 index 0000000..499e2dd --- /dev/null +++ b/test/batch.t @@ -0,0 +1,28 @@ +Batch operation + $ mkdir simple + $ cd simple + $ git init --bare -q 2> /dev/null + $ cd .. + $ git daemon --base-path=. --export-all --enable=receive-pack --reuseaddr --pid-file=pid --detach + $ mgit git://localhost/simple#main < batch + > set /bar "Git rocks!" + > set /foo "Hello World!" + > exists /bar + > quit + > quit + /"bar" does not exists + $ mgit git://localhost/simple#main < list / + > get /bar + > get /foo + > quit + - 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 + 1 + $ cd .. + $ kill $(cat pid) diff --git a/test/dune b/test/dune index 18a03d6..feabbdc 100644 --- a/test/dune +++ b/test/dune @@ -1,3 +1,11 @@ (cram (package git-kv) + (applies_to simple) + (locks p9418) + (deps %{bin:mgit})) + +(cram + (package git-kv) + (applies_to batch) + (locks p9418) (deps %{bin:mgit})) diff --git a/test/simple.t b/test/simple.t index 54b00be..f85f407 100644 --- a/test/simple.t +++ b/test/simple.t @@ -17,9 +17,7 @@ Simple test of our Git Key-Value store > get /foo > save db.pack > quit - # 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. - # - # + 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. $ tail -c20 db.pack | hexdump 0000000 b2e4 3734 7e2e 7e3d 0885 1239 873d cd11 0000010 4299 4771 @@ -27,8 +25,7 @@ Simple test of our Git Key-Value store $ mgit git://localhost/simple db.pack < get /foo > quit - # 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. - # + 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. $ cd simple $ echo "Git rocks!" > bar $ git add bar @@ -39,10 +36,8 @@ Simple test of our Git Key-Value store > get /bar > get /foo > quit - # + /"bar" * / - # 00000000: 4769 7420 726f 636b 7321 0a Git rocks!. - # 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. - # + 00000000: 4769 7420 726f 636b 7321 0a Git rocks!. + 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!. $ kill $(cat pid) From 64fc2402ab2e2f6b5d98bec194df921424f1f012 Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Sat, 29 Oct 2022 22:30:12 +0200 Subject: [PATCH 3/4] Don't try to push if the tree_root still is the same If the user just read into the batched function and does not change anything, we just return the result. --- src/git_kv.ml | 37 ++++++++++++++++++++----------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/src/git_kv.ml b/src/git_kv.ml index de3e0f6..e3a3bec 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -630,23 +630,26 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct (* XXX(dinosaure): we assume that only [batch] can reset [t.committed] to [None] and we ensured that [batch] can not be called into [f]. So we are sure that [t'.committed] must be [Some _] in anyway. *) - let[@warning "-8"] Some (tree_root_hash, _) = t'.committed 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 committer = author ~now in - let author = author ~now 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, _) -> - 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 ) + 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 committer = author ~now in + let author = author ~now in + let commit = Store.Value.Commit.make ~tree:new_tree_root_hash ~author ~committer + ~parents (Some "Committed by git-kv") 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 ) >|= Rresult.R.reword_error (msgf "%a" Store.pp_error) >|= Rresult.R.failwith_error_msg >>= fun res -> Lwt.wakeup_later wk () ; From ed3bfa2dc37cda43bb404552371b743b33800882 Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Mon, 31 Oct 2022 16:47:52 +0100 Subject: [PATCH 4/4] Improve the documentation and the README.md --- README.md | 28 +++++++++++++--------------- src/git_kv.mli | 37 ++++++++++--------------------------- 2 files changed, 23 insertions(+), 42 deletions(-) diff --git a/README.md b/README.md index 45ae3ed..490850f 100644 --- a/README.md +++ b/README.md @@ -47,27 +47,25 @@ let _ = The user can manipulate the repository as an [RW][mirage-kv-rw] repository. Any change to the repository requires a new commit. These changes will be sent to -the remote repository by default. If the user does not want to push -modifications, they can use `Git_kv.Make.Local` which provide functions without -`push`. If the user knows that they will do many changes and they don't want to -change all of them and do a `push` only at the end, they can use -`Git_kv.Make.change_and_push`. +the remote repository. The user can _fold_ any changes into one commit if he/she +wants. ```ocaml module Store = Git_kv.Make (Pclock) -let new_file_locally_and_remotely t = +let new_file t = Store.set t Mirage_kv.Key.(empty / "foo") "foo" >>= fun () -> + (* XXX(dinosaure): a commit was created and sended to the + remote repository. *) ... -let new_file_locally t = - Git_kv.pull t >>= fun _diff -> - Store.Local.set t Mirage_kv.Key.(empty / "foo") "foo" >>= fun () -> - ... - -let push_operations t = - Store.change_and_push t @@ fun t -> - Store.set t Mirage_kv.Key.(empty / "bar") "bar" >>= fun () -> - Store.remove t Mirage_kv.Key.(empty / "foo") +let new_files_batched t = + Store.batch t @@ fun t -> + Store.set t Mirage_kv.Key.(empty / "foo" "foo") >>= fun () -> + Store.set t Mirage_kv.Key.(empty / "bar" "bar") +(* XXX(dinosaure): multiple files are added into the local repository + but they are committed only at the end of the given function + to [batch]. That's say, only one commit was made and sended to the + remote Git repository. *) ``` [mimic]: https://dinosaure.github.io/mimic/mimic/index.html diff --git a/src/git_kv.mli b/src/git_kv.mli index 9fa4aac..f481c64 100644 --- a/src/git_kv.mli +++ b/src/git_kv.mli @@ -15,37 +15,20 @@ {2: Pushing and synchronisation.} - The user can modify the repository (add files, remove files, etc.). They - can do this locally (with the {!module:Make.Local} module) and thus assume - a possible desynchronisation between the remote repository and what exists - locally or they can share these changes with the remote repository (default - behavior). - - In the latter case, the notion of {i merge} and conflicts is not handled by - our implementation. This means that if the remote repository is manipulated - by another instance than yours, it can result in conflicts that will make - the above functions fail. - - The only check done by the remote Git repository when you want to submit - your change is the ability to find a path between a commit available - remotely, the commit-graph given by the transmission, and your last commit. - In that way, our [push] is most similar to a [git push --force]! - - To save I/O, the {!val:Make.change_and_push} operation allows you to do - some change into a closure and the implementation will push only at the end - of this closure. By this way, you can {!val:Make.set}, {!val:Make.rename} - or {!val:Make.remove} without a systematic [push] on these actions. Only - one will be done at the end of your closure. + The user can modify the repository (add files, remove files, etc.). Each + change produces a commit and after each change we try to transfer them to + the remote Git repository. If you want to make multiple changes but contain + them in a single commit and only transfer those changes once, you should + use the {!val:Make.batch} function. {2: Serialization of the Git repository.} Finally, the KV-store tries to keep the minimal set of commits required - between you and the remote repository. In other words, only {i un}pushed - changes are kept by the KV-store. However, if these changes are not pushed, - they will be stored into the final state produced by {!val:to_octets}. In - other words, the more changes you make out of sync with the remote - repository (without pushing them), the bigger the state serialization will - be. *) + between you and the remote repository. Only {i un}pushed changes are kept + by the KV-store. However, if these changes are not pushed, they will be + stored into the final state produced by {!val:to_octets}. In other words, + the more changes you make out of sync with the remote repository (without + pushing them), the bigger the state serialization will be. *) type t (** The type of the Git store. *)