Merge pull request #2256 from metanivek/latest-mirage-kv

irmin-mirage-git.opam

@@ -16,7 +16,7 @@ depends: [
   "dune"         {>= "2.9.0"}
   "irmin-mirage" {= version}
   "irmin-git"    {= version}
-  "mirage-kv"    {>= "3.0.0" & < "5.0.0"}
+  "mirage-kv"    {>= "6.0.0"}
   "fmt"
   "git"          {>= "3.7.0"}
   "lwt"          {>= "5.3.0"}

src/irmin-mirage/git/irmin_mirage_git.ml

@@ -120,7 +120,7 @@ module KV_RO (G : Git.S) = struct
       let l =
         List.map
           (fun (s, k) ->
-            ( s,
+            ( Mirage_kv.Key.v s,
               match S.Tree.destruct k with
               | `Contents _ -> `Value
               | `Node _ -> `Dictionary ))
@@ -138,6 +138,20 @@ module KV_RO (G : Git.S) = struct
       S.Tree.find t.tree (path key) >|= function
       | None -> err_not_found key
       | Some v -> Ok v
+
+    let get_partial t key ~offset ~length =
+      let open Lwt_result.Infix in
+      get t key >|= fun data ->
+      let len = String.length data in
+      let off = Optint.Int63.to_int offset in
+      if off >= len || off < 0 || length < 0 then ""
+      else
+        let l = min length (len - off) in
+        String.sub data off l
+
+    let size t key =
+      let open Lwt_result.Infix in
+      get t key >|= fun data -> Optint.Int63.of_int (String.length data)
   end
 
   type t = { root : S.path; t : S.t }
@@ -154,7 +168,7 @@ module KV_RO (G : Git.S) = struct
     let key' = path key in
     S.last_modified t.t key' >|= function
     | [] -> Error (`Not_found key)
-    | h :: _ -> Ok (0, S.Info.date (S.Commit.info h))
+    | h :: _ -> Ok (Ptime.v (0, S.Info.date (S.Commit.info h)))
 
   let connect ?depth ?(branch = "main") ?(root = Mirage_kv.Key.empty) ?ctx
       ?headers t uri =
@@ -175,8 +189,13 @@ module KV_RO (G : Git.S) = struct
 
   let exists t k = tree t >>= fun t -> Tree.exists t k
   let get t k = tree t >>= fun t -> Tree.get t k
+
+  let get_partial t k ~offset ~length =
+    tree t >>= fun t -> Tree.get_partial t k ~offset ~length
+
   let list t k = tree t >>= fun t -> Tree.list t k
   let digest t k = tree t >>= fun t -> Tree.digest t k
+  let size t k = tree t >>= fun t -> Tree.size t k
 
   let get t k =
     match Key.segments k with
@@ -243,16 +262,17 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct
     | Batch b -> Lwt.return { Tree.tree = b.tree; repo = repo t }
 
   let digest t k = tree t >>= fun t -> Tree.digest t k
+  let size t k = tree t >>= fun t -> Tree.size t k
   let exists t k = tree t >>= fun t -> Tree.exists t k
   let get t k = tree t >>= fun t -> Tree.get t k
+
+  let get_partial t k ~offset ~length =
+    tree t >>= fun t -> Tree.get_partial t k ~offset ~length
+
   let list t k = tree t >>= fun t -> Tree.list t k
 
   type write_error = [ RO.error | Mirage_kv.write_error | RO.Sync.push_error ]
 
-  let write_error = function
-    | Ok _ -> Ok ()
-    | Error e -> Error (e :> write_error)
-
   let pp_write_error ppf = function
     | #RO.error as e -> RO.pp_error ppf e
     | #RO.Sync.push_error as e -> RO.Sync.pp_push_error ppf e
@@ -261,30 +281,57 @@ module KV_RW (G : Irmin_git.G) (C : Mirage_clock.PCLOCK) = struct
   let info t op = Info.f ~author:(t.author ()) "%s" (t.msg op)
   let path = RO.path
 
+  let ( >?= ) r f =
+    r >>= function
+    | Error e -> Lwt.return_error (e :> write_error)
+    | Ok r -> f r
+
   let set t k v =
     let info = info t (`Set k) in
     match t.store with
-    | Store s -> (
-        S.set ~info s.t (path k) v >>= function
-        | Ok _ -> RO.Sync.push s.t t.remote >|= write_error
-        | Error e -> Lwt.return (Error (e :> write_error)))
+    | Store s ->
+        S.set ~info s.t (path k) v >?= fun () ->
+        RO.Sync.push s.t t.remote >?= fun _ -> Lwt.return_ok ()
     | Batch b ->
         S.Tree.add b.tree (path k) v >|= fun tree ->
         b.tree <- tree;
         Ok ()
 
+  let set_partial t k ~offset v =
+    let off = Optint.Int63.to_int offset in
+    if off < 0 then Lwt.return_ok ()
+    else
+      get t k >?= fun data ->
+      let data_len = String.length data in
+      let v_len = String.length v in
+      let buf = Bytes.make (max data_len (off + v_len)) '\000' in
+      Bytes.blit_string data 0 buf 0 data_len;
+      Bytes.blit_string v 0 buf off v_len;
+      set t k (Bytes.unsafe_to_string buf)
+
   let remove t k =
     let info = info t (`Remove k) in
     match t.store with
-    | Store s -> (
-        S.remove ~info s.t (path k) >>= function
-        | Ok _ -> RO.Sync.push s.t t.remote >|= write_error
-        | Error e -> Lwt.return (Error (e :> write_error)))
+    | Store s ->
+        S.remove ~info s.t (path k) >?= fun () ->
+        RO.Sync.push s.t t.remote >?= fun _ -> Lwt.return_ok ()
     | Batch b ->
         S.Tree.remove b.tree (path k) >|= fun tree ->
         b.tree <- tree;
         Ok ()
 
+  let rename t ~source ~dest =
+    get t source >?= fun data ->
+    remove t source >?= fun () -> set t dest data
+
+  let allocate t k ?last_modified:_ size =
+    let size = Optint.Int63.to_int size in
+    if size < 0 then Lwt.return_ok ()
+    else
+      exists t k >?= function
+      | Some _ -> Lwt.return_error (`Already_present k)
+      | None -> set t k (String.make size '\000')
+
   let get_store_tree (t : RO.t) =
     S.Head.find t.t >>= function
     | None -> Lwt.return_none

src/irmin-mirage/git/irmin_mirage_git_intf.ml

@@ -83,6 +83,18 @@ module type KV_RW = sig
 
   include Mirage_kv.RW
 
+  val batch : t -> ?retries:int -> (t -> 'a Lwt.t) -> 'a Lwt.t
+  (** [batch t f] run [f] in batch. Ensure the durability of operations.
+
+      Since a batch is applied at once, the readings inside a batch will return
+      the state before the entire batch. Concurrent operations will not affect
+      other ones executed during the batch.
+
+      Batch applications can fail to apply if other operations are happening
+      concurrently. In case of failure, [f] will run again with the most recent
+      version of [t]. The result is [Error `Too_many_retries] if [f] is run for
+      more then [retries] attemps (default is [42]). *)
+
   val connect :
     ?depth:int ->
     ?branch:string ->