Merge pull request 'Rename batch to change_and_push and re-instantiate batch as a noop function' (#23) from fix-batch into main

Reviewed-on: https://git.robur.io/robur/git-kv/pulls/23

README.md

@@ -47,26 +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,
+the remote repository. The user can _fold_ any changes into one commit if he/she
-they can use `Git_kv.Make.Local` which provide functions without `push`. If the
+wants.
-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`.
 ```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 =
+let new_files_batched t =
-  Git_kv.pull t >>= fun _diff ->
-  Store.Local.set t Mirage_kv.Key.(empty / "foo") "foo" >>= fun () ->
-  ...
-
-let batch_operations t =
   Store.batch t @@ fun t ->
-  Store.set t Mirage_kv.Key.(empty / "bar") "bar" >>= fun () ->
+  Store.set t Mirage_kv.Key.(empty / "foo" "foo") >>= fun () ->
-  Store.remove t Mirage_kv.Key.(empty / "foo")
+  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

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 repl store fd_in =
-  let rec go () = Fmt.pr "# %!" ; match String.split_on_char ' ' (input_line ic) |> trim with
+  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 _ ->
+      save store0 filename >|= ignore
-      Fmt.pr "\n%!" ; go ()
+      >>= fun _ -> if is_a_tty then Fmt.pr "\n%!" ; go store0
-    | _ -> Fmt.epr "Invalid command.\n%!" ; go ()
+    | _ -> 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

dune-project

@@ -1,4 +1,4 @@
-(lang dune 2.8)
+(lang dune 2.9)
 (name git-kv)
 (formatting disabled)
 (cram enable)

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
+      ( Store.read_exn t.store tree_root_hash >>= function
-      | None ->
+      | Git.Value.Tree tree ->
-        let tree = Git.Tree.(v [ entry ~name:pred_name pred_perm pred_hash ]) in
+        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 ->
+      | _ -> assert false )
-        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 ) )
     | 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
+  let tree_root_hash_of_store t =
-    | None -> true
+    match t.committed, t.head with
-    | Some th -> match Lwt.state th with
+    | Some (tree_root_hash, _), _ -> Lwt.return_ok tree_root_hash
-      | Sleep -> true
+    | None, None ->
-      | Return _ | Fail _ -> false
+      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 ->
+      tree_root_hash_of_store t >>= fun tree_root_hash ->
-      let committer = author ~now in
+      unroll_tree t ~tree_root_hash (`Normal, name, hash) (List.tl rpath) >>= fun tree_root_hash ->
-      let author = author ~now in
+      match and_commit with
-      let parents = Option.value ~default:[] (Option.map (fun head -> [ head ]) t.head) in
+      | Some (_old_tree_root_hash, th) ->
-      let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
+        t.committed <- Some (tree_root_hash, th) ;
-        ~parents (Some "Committed by git-kv") in
+        Lwt.return_ok ()
-      Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
+      | None ->
-      Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
+        let committer = author ~now in
-      Lwt.Infix.(if and_push then 
+        let author    = author ~now in
-        Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ]
+        let action    = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head in
-        >|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing branch %a: %a"
+        let parents   = Option.value ~default:[] (Option.map (fun head -> [ head ]) t.head) in
-          Git.Reference.pp t.branch Sync.pp_error err))
+        let commit    = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
-        >>? fun () -> (Store.shallow t.store hash >|= Result.ok)
+          ~parents (Some "Committed by git-kv") in
-        else Lwt.return_ok ()) >>= fun () ->
+        Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
-      t.head <- Some hash ; Lwt.return_ok ()
+        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,113 +534,125 @@ 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_commit:t.committed t key contents
-    set ~and_push t key contents >|= Rresult.R.reword_error to_write_error
+    >|= 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
+      let open Lwt_result.Infix in
-      Search.find t.store head (`Commit (`Path [])) >|= Option.get >>= 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 ->
       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
+      ( match and_commit with
-      let author = author ~now in
+      | Some (_old_tree_root_hash, th) -> t.committed <- Some (tree_root_hash, th) ; Lwt.return_ok ()
-      let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
+      | None ->
-        ~parents:[ head ] (Some "Committed by git-kv") in
+        let committer = author ~now in
-      Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
+        let author    = author ~now in
-      Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
+        let commit    = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
-      Lwt.Infix.(if and_push then 
+          ~parents:[ head ] (Some "Committed by git-kv") in
-        Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ]
+        Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
-        >|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing branch %a: %a"
+        Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
-          Git.Reference.pp t.branch Sync.pp_error err))
+        Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ]
-        >>? fun () -> Store.shallow t.store hash >|= Result.ok
+          >|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing branch %a: %a"
-        else Lwt.return_ok ()) >>= fun () ->
+            Git.Reference.pp t.branch Sync.pp_error err))
-      t.head <- Some hash ; Lwt.return_ok ()
+          >>? 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
+      let open Lwt_result.Infix in
-      Search.find t.store head (`Commit (`Path (List.rev (pred_name :: rest)))) >>= function
+      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 ->
+          unroll_tree t ~tree_root_hash (`Dir, pred_name, pred_hash) rest >>= fun tree_root_hash ->
-          let committer = author ~now in
+          ( match and_commit with
-          let author = author ~now in
+          | Some (_old_tree_root_hash, th) -> t.committed <- Some (tree_root_hash, th) ; Lwt.return_ok ()
-          let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
+          | None ->
-            ~parents:[ head ] (Some "Committed by git-kv") in
+            let committer = author ~now in
-          Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
+            let author    = author ~now in
-          Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
+            let commit    = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
-          Lwt.Infix.(if and_push then 
+              ~parents:[ head ] (Some "Committed by git-kv") in
-            Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ]
+            Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
-            >|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing branch %a: %a"
+            Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
-              Git.Reference.pp t.branch Sync.pp_error err))
+            Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ]
-            >>? fun () -> Store.shallow t.store hash >|= Result.ok
+              >|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing branch %a: %a"
-            else Lwt.return_ok ()) >>= fun () ->
+                Git.Reference.pp t.branch Sync.pp_error err))
-          t.head <- Some hash ; Lwt.return_ok ()
+              >>? 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_commit:t.committed t key >|= Rresult.R.reword_error to_write_error
-    remove ~and_push 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 () ->
+    remove t source >>= fun () ->
-    set ~and_push t dest contents
+    set t dest contents
 
   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 ;
+    ( let open Lwt_result.Infix in
-    f t >>= fun res ->
+      tree_root_hash_of_store t >>= fun tree_root_hash ->
-    ( Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] >>= function
+      t.committed <- Some (tree_root_hash, th) ;
-    | Ok () ->
+      let t' = { t with in_closure= true } in
-      ( match t.head with
+      f t' >>! fun res ->
-      | None -> Lwt.return_unit
+      (* XXX(dinosaure): we assume that only [batch] can reset [t.committed] to [None] and
-      | Some hash -> Store.shallow t.store hash )              
+         we ensured that [batch] can not be called into [f]. So we are sure that [t'.committed]
-    | Error err ->
+         must be [Some _] in anyway. *)
-      Fmt.failwith "error pushing branch %a: %a" Git.Reference.pp t.branch Sync.pp_error err ) >>= fun () ->
+      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 () ;
+    t.committed <- None ;
     Lwt.return res
-
-  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

src/git_kv.mli

@@ -15,37 +15,20 @@
 
     {2: Pushing and synchronisation.}
 
-    The user can modify the repository (add files, remove files, etc.). They
+    The user can modify the repository (add files, remove files, etc.). Each
-    can do this locally (with the {!module:Make.Local} module) and thus assume
+    change produces a commit and after each change we try to transfer them to
-    a possible desynchronisation between the remote repository and what exists
+    the remote Git repository. If you want to make multiple changes but contain
-    locally or they can share these changes with the remote repository (default
+    them in a single commit and only transfer those changes once, you should
-    behavior).
+    use the {!val:Make.batch} function.
-
-    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.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.
 
     {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
+    between you and the remote repository. Only {i un}pushed changes are kept
-    changes are kept by the KV-store. However, if these changes are not pushed,
+    by the KV-store. However, if these changes are not pushed, they will be
-    they will be stored into the final state produced by {!val:to_octets}. In
+    stored into the final state produced by {!val:to_octets}. In other words,
-    other words, the more changes you make out of sync with the remote
+    the more changes you make out of sync with the remote repository (without
-    repository (without pushing them), the bigger the state serialization will
+    pushing them), the bigger the state serialization will be. *)
-    be. *)
 
 type t
 (** The type of the Git store. *)
@@ -83,11 +66,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 ]
-
-  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

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 <<EOF
+  > batch
+  > set /bar "Git rocks!"
+  > set /foo "Hello World!"
+  > exists /bar
+  > quit
+  > quit
+  /"bar" does not exists
+  $ mgit git://localhost/simple#main <<EOF
+  > 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)

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

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 <<EOF
   > 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: 4769 7420 726f 636b 7321 0a              Git rocks!.
-  # 00000000: 4865 6c6c 6f20 576f 726c 6421 0a         Hello World!.
+  00000000: 4865 6c6c 6f20 576f 726c 6421 0a         Hello World!.
-  # 
   $ kill $(cat pid)