src/git_kv.ml

@@ -9,8 +9,6 @@ type t =
   ; branch : Git.Reference.t
   ; store : Store.t
   ; mutable committed : Digestif.SHA1.t option
-  ; mutable change_and_push_running : bool
-  ; condition : unit Lwt_condition.t
   ; mutex : Lwt_mutex.t
   ; mutable head : Store.hash option }
 
@@ -104,7 +102,7 @@ let connect ctx endpoint =
   init_store () >>= fun store ->
   let store = to_invalid store in
   let edn, branch = split_url endpoint in
-  let t = { ctx ; edn ; branch ; store ; committed= None; change_and_push_running= false; condition= Lwt_condition.create (); mutex= Lwt_mutex.create (); head= None } in
+  let t = { ctx ; edn ; branch ; store ; committed= None; mutex= Lwt_mutex.create (); head= None } in
   pull t >>= fun r ->
   let _r = to_invalid r in
   Lwt.return t
@@ -372,7 +370,7 @@ let of_octets ctx ~remote data =
        Result.fold ~ok:Fun.id ~error:(function `Msg msg -> failwith msg) >>= fun store ->
        analyze store data >>= fun head ->
        let edn, branch = split_url remote in
-       Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; change_and_push_running= false; condition= Lwt_condition.create (); mutex= Lwt_mutex.create (); head; })
+       Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; mutex= Lwt_mutex.create (); head; })
     (fun _exn ->
        Lwt.return_error (`Msg "Invalid PACK file"))
 
@@ -679,55 +677,36 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
     match t.committed with
     | Some _ -> Lwt.return_error (`Msg "Nested change_and_push")
     | 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 ->
-         (reynir): Furthermore, we need to create a new task and update
+           let t' = { t with committed = Some tree_root_hash } in
-         [change_and_push_waiter] before we wait on the existing
+           f t' >>! fun res ->
-         [change_and_push_waiter] task without any yield point in between to
+           (* XXX(dinosaure): we assume that only [change_and_push] can reset [t.committed] to [None] and
-         ensure serializability. *)
+              we ensured that [change_and_push] can not be called into [f]. So we are sure that [t'.committed]
-      let open Lwt.Syntax in
+              must be [Some _] in anyway. *)
-      let* () = Lwt_mutex.with_lock t.mutex @@ fun () ->
+           let[@warning "-8"] Some new_tree_root_hash = t'.committed in
-        let rec await () =
+           if Digestif.SHA1.equal new_tree_root_hash tree_root_hash
-          if t.change_and_push_running
+           then Lwt.return_ok res (* XXX(dinosaure): nothing to send! *)
-          then Lwt_condition.wait ~mutex:t.mutex t.condition >>= await
+           else if not (Option.equal Digestif.SHA1.equal t.head t'.head) then
-          else begin t.change_and_push_running <- true; Lwt.return_unit end in
+             Lwt.return (Error (`Msg "store was modified outside of change_and_push, please retry"))
-        await () in
+           else
-      ( let open Lwt_result.Infix in
+             let action    = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head in
-        tree_root_hash_of_store t >>= fun tree_root_hash ->
+             let parents   = Option.to_list t.head in
-        let t' = { t with committed = Some tree_root_hash } in
+             let author    = author ?name ?email now in
-        f t' >>! fun res ->
+             let committer = author in
-        (* XXX(dinosaure): we assume that only [change_and_push] can reset [t.committed] to [None] and
+             let commit    = Store.Value.Commit.make ~tree:new_tree_root_hash ~author ~committer
-           we ensured that [change_and_push] can not be called into [f]. So we are sure that [t'.committed]
+                 ~parents (Some message) in
-           must be [Some _] in anyway. *)
+             Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
-        let[@warning "-8"] Some new_tree_root_hash = t'.committed in
+             Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
-        if Digestif.SHA1.equal new_tree_root_hash tree_root_hash
+             Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ action ]
-        then Lwt.return_ok res (* XXX(dinosaure): nothing to send! *)
+                        >|= Result.map_error (fun err ->
-        else if not (Option.equal Digestif.SHA1.equal t.head t'.head) then
+                            `Msg (Fmt.str "error pushing branch %a: %a"
-          Lwt.return (Error (`Msg "store was modified outside of change_and_push, please retry"))
+                                    Git.Reference.pp t.branch Sync.pp_error err))
-        else
+                        >>? fun () ->
-          let action    = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head in
+                        Store.shallow t.store hash >|= Result.ok) >>= fun () ->
-          let parents   = Option.to_list t.head in
+             t.head <- Some hash ;
-          let author    = author ?name ?email now in
+             Lwt.return_ok res)
-          let committer = author in
+          >|= Result.map_error
-          let commit    = Store.Value.Commit.make ~tree:new_tree_root_hash ~author ~committer
+            (fun err -> `Msg (Fmt.str "error pushing %a" Store.pp_error err)))
-              ~parents (Some message) in
-          Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
-          Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
-          Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ action ]
-                     >|= Result.map_error (fun err ->
-                         `Msg (Fmt.str "error pushing branch %a: %a"
-                                 Git.Reference.pp t.branch Sync.pp_error err))
-                     >>? fun () ->
-                     Store.shallow t.store hash >|= Result.ok) >>= fun () ->
-          t.head <- Some hash ;
-          Lwt.return_ok res )
-      >|= Result.map_error
-        (fun err -> `Msg (Fmt.str "error pushing %a" Store.pp_error err))
-      >>= fun res ->
-      let* () = Lwt_mutex.with_lock t.mutex @@ fun () ->
-        t.change_and_push_running <- false;
-        Lwt_condition.signal t.condition ();
-        Lwt.return_unit in
-      Lwt.return res
 end