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 =
@@ -54,7 +53,7 @@ let value_of_string str =
   | () -> Option.get !v
   | exception _ ->
     Scanf.sscanf str "%s" (fun str -> v := Some str) ;
-    Option.get !v 
+    Option.get !v
 
 let set ~quiet store key str =
   let value = value_of_string str in
@@ -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; })
@@ -355,10 +351,10 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
                      | `Hash_not_found of Digestif.SHA1.t
                      | `Reference_not_found of Git.Reference.t
                      | Mirage_kv.write_error ]
-  
+
   let pp_error ppf = Mirage_kv.pp_error ppf
   let disconnect _t = Lwt.return_unit
-  
+
   let pp_write_error ppf = function
     | #Mirage_kv.write_error as err -> Mirage_kv.pp_write_error ppf err
     | `Reference_not_found _ | `Msg _ as err -> Store.pp_error ppf err
@@ -376,7 +372,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
         >|= Option.get >>= Store.read_exn t.store >>= function
         | Blob _ -> Lwt.return (Ok (Some `Value))
         | Tree _ | Commit _ | Tag _ -> Lwt.return (Ok (Some `Dictionary))
-  
+
   let get t key =
     let open Lwt.Infix in
     match t.head with
@@ -388,7 +384,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
         Store.read_exn t.store blob >|= function
         | Blob b -> Ok (Git.Blob.to_string b)
         | _ -> Error (`Value_expected key)
-  
+
   let get_partial t key ~offset ~length =
     let open Lwt_result.Infix in
     get t key >|= fun data ->
@@ -397,7 +393,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
     else
       let l = min length (String.length data - offset) in
       String.sub data offset l
-  
+
   let list t key =
     let open Lwt.Infix in
     match t.head with
@@ -414,7 +410,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
             | `Link -> failwith "Unimplemented link follow")
           (Store.Value.Tree.to_list t) >|= Result.ok
         | _ -> Lwt.return (Error (`Dictionary_expected key))
-  
+
   let last_modified t key =
     let open Lwt.Infix in
     Option.fold
@@ -439,23 +435,23 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
             Ok (Ptime.(Span.to_d_ps (to_span ts)))
           | _ -> assert false)
       t.head
-  
+
   let digest t key =
     Option.fold
       ~none:(Error (`Not_found key))
       ~some:(fun x -> Ok (Store.Hash.to_hex x))
       t.head |> Lwt.return
-  
+
   let size t key =
     let open Lwt_result.Infix in
     get t key >|= fun data ->
     String.length data
-  
+
   let author ~now =
     { Git.User.name= "Git KV"
     ; email= "git@mirage.io"
     ; date= now (), None }
-  
+
   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
@@ -492,11 +488,11 @@ 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 ())))
-  
+
   let set ?and_commit t key contents =
     let segs = Mirage_kv.Key.segments key in
     match segs with
@@ -527,18 +523,18 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
             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
     | `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
     get t key >>= fun contents ->
@@ -548,7 +544,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
     Bytes.blit_string contents 0 res 0 len ;
     Bytes.blit_string chunk 0 res offset add ;
     set t key (Bytes.unsafe_to_string res)
-  
+
   let remove ?and_commit t key =
     let segs = Mirage_kv.Key.segments key in
     match List.rev segs, t.head with
@@ -601,11 +597,11 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
               >>? fun () -> Store.shallow t.store hash >|= Result.ok)
             >>= fun () -> t.head <- Some hash ; Lwt.return_ok () )
         | _ -> Lwt.return_ok ()
-  
+
   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. *)
     let open Lwt_result.Infix in
@@ -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

@@ -22,7 +22,7 @@
     use the {!val:Make.change_and_push} function.
 
     {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. Only {i un}pushed changes are kept
     by the KV-store. However, if these changes are not pushed, they will be
@@ -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