change_and_push may return an error, report it

app/mgit.ml

@@ -140,7 +140,7 @@ let repl store fd_in =
     | [ "quit"; ] -> Lwt.return ()
     | [ "fold"; ] ->
       Store.change_and_push store0 (fun store1 -> go store1)
-      >>= fun () -> go store0
+      >>= fun _ -> go store0
     | [ "save"; filename ] ->
       save store0 filename >|= ignore
       >>= fun _ -> if is_a_tty then Fmt.pr "\n%!" ; go store0

src/git_kv.ml

@@ -614,44 +614,47 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
 
   let change_and_push t f =
     let open Lwt.Infix in
-    if t.in_closure then Fmt.invalid_arg "Nested change_and_push" ;
+    if t.in_closure then
-    (* XXX(dinosaure): serialize [batch]. If we do [Lwt.both (batch ..) (batch ..)], they
+      Lwt.return_error (`Msg "Nested change_and_push")
-       can not run concurrently! The second will waiting the first to finish. *)
+    else
-    ( match t.committed with
+      (* XXX(dinosaure): serialize [batch]. If we do [Lwt.both (batch ..) (batch ..)], they
-    | None -> Lwt.return_unit
+         can not run concurrently! The second will waiting the first to finish. *)
-    | Some (_tree_root_hash, th) -> th ) >>= fun () ->
+      ( match t.committed with
-    let th, wk = Lwt.wait () in
+        | None -> Lwt.return_unit
-    ( let open Lwt_result.Infix in
+        | Some (_tree_root_hash, th) -> th ) >>= fun () ->
-      tree_root_hash_of_store t >>= fun tree_root_hash ->
+      let th, wk = Lwt.wait () in
-      t.committed <- Some (tree_root_hash, th) ;
+      ( let open Lwt_result.Infix in
-      let t' = { t with in_closure= true } in
+        tree_root_hash_of_store t >>= fun tree_root_hash ->
-      f t' >>! fun res ->
+        t.committed <- Some (tree_root_hash, th) ;
-      (* XXX(dinosaure): we assume that only [batch] can reset [t.committed] to [None] and
+        let t' = { t with in_closure= true } in
-         we ensured that [batch] can not be called into [f]. So we are sure that [t'.committed]
+        f t' >>! fun res ->
-         must be [Some _] in anyway. *)
+        (* XXX(dinosaure): we assume that only [batch] can reset [t.committed] to [None] and
-      let[@warning "-8"] Some (new_tree_root_hash, _) = t'.committed in
+           we ensured that [batch] can not be called into [f]. So we are sure that [t'.committed]
-      if Digestif.SHA1.equal new_tree_root_hash tree_root_hash
+           must be [Some _] in anyway. *)
-      then Lwt.return_ok res (* XXX(dinosaure): nothing to send! *)
+        let[@warning "-8"] Some (new_tree_root_hash, _) = t'.committed in
-      else
+        if Digestif.SHA1.equal new_tree_root_hash tree_root_hash
-        let action    = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head in
+        then Lwt.return_ok res (* XXX(dinosaure): nothing to send! *)
-        let parents   = Option.value ~default:[] (Option.map (fun head -> [ head ]) t.head) in
+        else
-        let committer = author ~now in
+          let action    = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head 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:new_tree_root_hash ~author ~committer
+          let committer = author ~now in
-          ~parents (Some "Committed by git-kv") in
+          let author    = author ~now in
-        Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
+          let commit    = Store.Value.Commit.make ~tree:new_tree_root_hash ~author ~committer
-        t.head <- Some hash ;
+              ~parents (Some "Committed by git-kv") in
-        Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
+          Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
-        Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ action ]
+          t.head <- Some hash ;
-          >|= Result.map_error (fun err ->
+          Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
-            `Msg (Fmt.str "error pushing branch %a: %a"
+          Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ action ]
-            Git.Reference.pp t.branch Sync.pp_error err))
+                     >|= Result.map_error (fun err ->
-          >>? fun () ->
+                         `Msg (Fmt.str "error pushing branch %a: %a"
-          Store.shallow t.store hash >|= Result.ok) >>= fun () ->
+                                 Git.Reference.pp t.branch Sync.pp_error err))
+                     >>? fun () ->
+                     Store.shallow t.store hash >|= Result.ok) >>= fun () ->
           Lwt.return_ok res )
-    >|= Result.map_error (Fmt.to_to_string Store.pp_error)
+      >|= Result.map_error
-    >|= Result.get_ok >>= fun res ->
+        (fun err -> `Msg (Fmt.str "error pushing %a" Store.pp_error err))
-    Lwt.wakeup_later wk () ;
+      >>= fun res ->
-    t.committed <- None ;
+      Lwt.wakeup_later wk () ;
-    Lwt.return res
+      t.committed <- None ;
+      Lwt.return res
 end

src/git_kv.mli

@@ -67,5 +67,5 @@ 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
+  val change_and_push : t -> (t -> 'a Lwt.t) -> ('a, [> `Msg of string ]) result Lwt.t
 end