Merge pull request 'minor refactorings and updates' (#24) from more into main

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

app/mgit.ml

@@ -22,7 +22,6 @@ let () = Logs.set_reporter (reporter Fmt.stderr)
 let () = Logs.set_level ~all:true (Some Logs.Debug)
 *)
 
-open Rresult
 open Lwt.Infix
 
 let get ~quiet store key =
@@ -141,6 +140,7 @@ let repl store fd_in =
     | [ "quit"; ] -> Lwt.return ()
     | [ "fold"; ] ->
       Store.change_and_push store0 (fun store1 -> go store1)
+      >|= Result.fold ~ok:Fun.id ~error:(function `Msg msg -> Fmt.epr "%s.\n%!" msg)
       >>= fun () -> go store0
     | [ "save"; filename ] ->
       save store0 filename >|= ignore

git-kv.opam

@@ -14,6 +14,7 @@ depends: [
   "mirage-kv"         {>= "4.0.0"}
   "git-unix"          {>= "3.10.0"}
   "carton"            {>= "0.6.0"}
+  "fmt"               {>= "0.8.7"}
   "mirage-clock-unix"
   "mirage-clock"
   "ptime"

src/dune

@@ -2,4 +2,4 @@
   (name git_kv)
   (public_name git-kv)
   (flags (-w -32))
-  (libraries git ptime mirage-clock mirage-kv))
+  (libraries git ptime mirage-clock mirage-kv fmt))

src/git_kv.ml

@@ -19,9 +19,6 @@ let init_store () =
     (fun e -> `Msg (Fmt.str "error setting up store %a" Store.pp_error e))
     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 ]
 
@@ -35,7 +32,7 @@ let split_url s =
     Smart_git.Endpoint.of_string edn |> to_invalid,
     Git.Reference.of_string ("refs/heads/" ^ branch) |> to_invalid
   | _ ->
-    Smart_git.Endpoint.of_string s |> to_invalid, main
+    Smart_git.Endpoint.of_string s |> to_invalid, Git.Reference.main
 
 let fpath_to_key ~root v =
   if Fpath.equal root v
@@ -334,9 +331,8 @@ let of_octets ctx ~remote data =
   (* TODO maybe recover edn and branch from data as well? *)
   Lwt.catch
     (fun () ->
-       init_store ()
+       init_store () >|=
-       >|= Rresult.R.reword_error (Rresult.R.msgf "%a" Store.pp_error)
+       Result.fold ~ok:Fun.id ~error:(function `Msg msg -> failwith msg) >>= fun store ->
-       >|= 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 ; committed= None; in_closure= false; head; })
@@ -492,7 +488,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
       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)
+      | _ -> Lwt.return_error (`Msg (Fmt.str "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 ())))
@@ -532,12 +528,12 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
     | `Not_found hash -> `Hash_not_found hash
     | `Reference_not_found ref -> `Reference_not_found ref
     | `Msg err -> `Msg err
-    | err -> Rresult.R.msgf "%a" Store.pp_error err
+    | err -> `Msg (Fmt.to_to_string Store.pp_error err)
 
   let set t key contents =
     let open Lwt.Infix in
     set ?and_commit:t.committed t key contents
-    >|= Rresult.R.reword_error to_write_error
+    >|= Result.map_error to_write_error
 
   let set_partial t key ~offset chunk =
     let open Lwt_result.Infix in
@@ -604,7 +600,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
 
   let remove t key =
     let open Lwt.Infix in
-    remove ?and_commit:t.committed t key >|= Rresult.R.reword_error to_write_error
+    remove ?and_commit:t.committed t key >|= Result.map_error to_write_error
 
   let rename t ~source ~dest =
     (* TODO(dinosaure): optimize it! It was done on the naive way. *)
@@ -617,44 +613,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 )
-    >|= Rresult.R.reword_error (msgf "%a" Store.pp_error)
+      >|= Result.map_error
-    >|= Rresult.R.failwith_error_msg >>= 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