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,7 +613,9 @@ 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
+      Lwt.return_error (`Msg "Nested change_and_push")
+    else
       (* 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
@@ -652,8 +650,9 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
                      >>? 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))
+      >>= fun res ->
       Lwt.wakeup_later wk () ;
       t.committed <- None ;
       Lwt.return res

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