Merge pull request 'Functorize with PCLOCK' (#15) from functorize-pclock into main

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

.gitignore

@@ -0,0 +1,11 @@
+_build
+setup.data
+setup.log
+doc/*.html
+*.native
+*.byte
+*.so
+*.tar.gz
+_tests
+*.merlin
+*.install

.ocamlformat

@@ -0,0 +1,17 @@
+version=0.23.0
+profile=conventional
+break-struct=natural
+break-infix=fit-or-vertical
+break-sequences=false
+break-collection-expressions=wrap
+break-separators=before
+exp-grouping=preserve
+parens-tuple=multi-line-only
+space-around-lists=false
+space-around-records=false
+space-around-arrays=false
+break-fun-decl=smart
+cases-exp-indent=2
+sequence-style=before
+field-space=tight
+break-before-in=auto

app/dune

@@ -1,4 +1,4 @@
 (executable
  (name mgit)
  (public_name mgit)
- (libraries logs.fmt fmt.tty git-unix git-kv))
+ (libraries mirage-clock-unix logs.fmt fmt.tty git-unix git-kv))

app/mgit.ml

@@ -1,4 +1,5 @@
 let () = Printexc.record_backtrace true
+module Store = Git_kv.Make (Pclock)
 
 let reporter ppf =
   let report src level ~over k msgf =
@@ -25,17 +26,17 @@ open Rresult
 open Lwt.Infix
 
 let get ~quiet store key =
-  Git_kv.get store key >>= function
+  Store.get store key >>= function
   | Ok contents when not quiet ->
     Fmt.pr "@[<hov>%a@]\n%!" (Hxd_string.pp Hxd.default) contents ;
     Lwt.return (Ok 0)
   | Ok _ -> Lwt.return (Ok 0)
   | Error err ->
-    if not quiet then Fmt.epr "%a.\n%!" Git_kv.pp_error err ;
+    if not quiet then Fmt.epr "%a.\n%!" Store.pp_error err ;
     Lwt.return (Ok 1)
 
 let list ~quiet store key =
-  Git_kv.list store key >>= function
+  Store.list store key >>= function
   | Ok lst when not quiet ->
     List.iter (fun (name, k) -> match k with
     | `Dictionary -> Fmt.pr "d %s\n%!" name
@@ -43,7 +44,7 @@ let list ~quiet store key =
     Lwt.return (Ok 0)
   | Ok _ -> Lwt.return (Ok 0)
   | Error err ->
-    if not quiet then Fmt.epr "%a.\n%!" Git_kv.pp_error err ;
+    if not quiet then Fmt.epr "%a.\n%!" Store.pp_error err ;
     Lwt.return (Ok 1)
 
 let pull ~quiet store =

git-kv.opam

@@ -7,11 +7,13 @@ bug-reports: "https://git.robur.io/robur/git-kv"
 synopsis: "A Mirage_kv implementation using git"
 
 depends: [
-  "ocaml" {>= "4.08.0"}
+  "ocaml"             {>= "4.08.0"}
-  "dune" {>= "2.0.0"}
+  "dune"              {>= "2.0.0"}
-  "git" {>= "3.9.0"}
+  "git"               {>= "3.9.0"}
-  "mirage-kv" {>= "4.0.0"}
+  "mirage-kv"         {>= "4.0.0"}
   "git-unix"
+  "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-kv))
+  (libraries git ptime mirage-clock mirage-kv))

src/git_kv.ml

@@ -116,21 +116,6 @@ type change = [
   | `Change of key
 ]
 
-type error = Mirage_kv.error
-type write_error = [ `Msg of string
-                   | `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 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
-  | `Hash_not_found hash -> Store.pp_error ppf (`Not_found hash)
-
-let disconnect _t = Lwt.return_unit
-
 module SHA1 = struct
   include Digestif.SHA1
 
@@ -356,218 +341,240 @@ let of_octets ctx ~remote data =
          (Printexc.raw_backtrace_to_string (Printexc.get_raw_backtrace ())) ;
        Lwt.return_error (`Msg "Invalid PACK file"))
 
-let exists t key =
+module Make (Pclock : Mirage_clock.PCLOCK) = struct
-  let open Lwt.Infix in
+  type nonrec t = t
-  match t.head with
+  type key = Mirage_kv.Key.t
-  | None -> Lwt.return (Ok None)
-  | Some head ->
-    Search.mem t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function
-    | false -> Lwt.return (Ok None)
-    | true ->
-      Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key)))
-      >|= 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 =
+  type error = Mirage_kv.error
-  let open Lwt.Infix in
+  type write_error = [ `Msg of string
-  match t.head with
+                     | `Hash_not_found of Digestif.SHA1.t
-  | None -> Lwt.return (Error (`Not_found key))
+                     | `Reference_not_found of Git.Reference.t
-  | Some head ->
+                     | Mirage_kv.write_error ]
-    Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function
+  
-    | None -> Lwt.return (Error (`Not_found key))
+  let pp_error ppf = Mirage_kv.pp_error ppf
-    | Some blob ->
+  let disconnect _t = Lwt.return_unit
-      Store.read_exn t.store blob >|= function
+  
-      | Blob b -> Ok (Git.Blob.to_string b)
+  let pp_write_error ppf = function
-      | _ -> Error (`Value_expected key)
+    | #Mirage_kv.write_error as err -> Mirage_kv.pp_write_error ppf err
+    | `Reference_not_found _ | `Msg _ as err -> Store.pp_error ppf err
+    | `Hash_not_found hash -> Store.pp_error ppf (`Not_found hash)
 
-let get_partial t key ~offset ~length =
+  let exists t key =
-  let open Lwt_result.Infix in
+    let open Lwt.Infix in
-  get t key >|= fun data ->
+    match t.head with
-  if String.length data < offset then
+    | None -> Lwt.return (Ok None)
-    ""
-  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
-  | None -> Lwt.return (Error (`Not_found key))
-  | Some head ->
-    Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function
-    | None -> Lwt.return (Error (`Not_found key))
-    | Some tree ->
-      Store.read_exn t.store tree >>= function
-      | Tree t ->
-        Lwt_list.map_p (fun { Git.Tree.perm; name; _ } -> match perm with
-          | `Commit | `Dir -> Lwt.return (name, `Dictionary)
-          | `Everybody | `Exec | `Normal -> Lwt.return (name, `Value)
-          | `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
-    ~none:(Lwt.return (Error (`Not_found key)))
-    ~some:(fun head ->
-        Store.read_exn t.store head >|= function
-        | Commit c ->
-          let author = Git_commit.author c in
-          let secs, tz_offset = author.Git.User.date in
-          let secs =
-            Option.fold ~none:secs
-              ~some:(fun { Git.User.sign ; hours ; minutes } ->
-                  let tz_off = Int64.(mul (add (mul (of_int hours) 60L) (of_int minutes)) 60L) in
-                  match sign with
-                  | `Plus -> Int64.(sub secs tz_off)
-                  | `Minus -> Int64.(add secs tz_off))
-              tz_offset
-          in
-          let ts =
-            Option.fold ~none:Ptime.epoch ~some:Fun.id (Ptime.of_float_s (Int64.to_float secs))
-          in
-          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 ?head (pred_name, pred_hash) rpath =
-  let open Lwt.Infix in
-  let ( >>? ) = Lwt_result.bind in
-  let ( >>! ) x f = match x with
-    | Some x -> f x
-    | None -> Lwt.return_none in
-  match rpath with
-  | [] ->
-    ( match head with
-    | None ->
-      let tree = Git.Tree.(v [ entry ~name:pred_name `Dir pred_hash ]) in
-      Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> Lwt.return_ok hash
     | Some head ->
-      Search.find t.store head (`Commit (`Path [])) >|= Option.get >>= fun tree_root_hash ->
+      Search.mem t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function
-      ( Store.read_exn t.store tree_root_hash >>= function
+      | false -> Lwt.return (Ok None)
-      | Git.Value.Tree tree ->
+      | true ->
-        let tree = Git.Tree.(add (entry ~name:pred_name `Dir pred_hash) (remove ~name:pred_name tree)) in
+        Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key)))
+        >|= 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
+    | None -> Lwt.return (Error (`Not_found key))
+    | Some head ->
+      Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function
+      | None -> Lwt.return (Error (`Not_found key))
+      | Some blob ->
+        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 ->
+    if String.length data < offset then
+      ""
+    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
+    | None -> Lwt.return (Error (`Not_found key))
+    | Some head ->
+      Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function
+      | None -> Lwt.return (Error (`Not_found key))
+      | Some tree ->
+        Store.read_exn t.store tree >>= function
+        | Tree t ->
+          Lwt_list.map_p (fun { Git.Tree.perm; name; _ } -> match perm with
+            | `Commit | `Dir -> Lwt.return (name, `Dictionary)
+            | `Everybody | `Exec | `Normal -> Lwt.return (name, `Value)
+            | `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
+      ~none:(Lwt.return (Error (`Not_found key)))
+      ~some:(fun head ->
+          Store.read_exn t.store head >|= function
+          | Commit c ->
+            let author = Git_commit.author c in
+            let secs, tz_offset = author.Git.User.date in
+            let secs =
+              Option.fold ~none:secs
+                ~some:(fun { Git.User.sign ; hours ; minutes } ->
+                    let tz_off = Int64.(mul (add (mul (of_int hours) 60L) (of_int minutes)) 60L) in
+                    match sign with
+                    | `Plus -> Int64.(sub secs tz_off)
+                    | `Minus -> Int64.(add secs tz_off))
+                tz_offset
+            in
+            let ts =
+              Option.fold ~none:Ptime.epoch ~some:Fun.id (Ptime.of_float_s (Int64.to_float secs))
+            in
+            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 ?head (pred_name, pred_hash) rpath =
+    let open Lwt.Infix in
+    let ( >>? ) = Lwt_result.bind in
+    let ( >>! ) x f = match x with
+      | Some x -> f x
+      | None -> Lwt.return_none in
+    match rpath with
+    | [] ->
+      ( match head with
+      | None ->
+        let tree = Git.Tree.(v [ entry ~name:pred_name `Dir pred_hash ]) in
         Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> Lwt.return_ok hash
-      | _ -> assert false ) )
+      | Some head ->
-  | name :: rest ->
+        Search.find t.store head (`Commit (`Path [])) >|= Option.get >>= fun tree_root_hash ->
-    (head >>! fun head -> Search.find t.store head (`Commit (`Path (List.rev rpath)))) >>= function
+        ( Store.read_exn t.store tree_root_hash >>= function
-    | None ->
+        | Git.Value.Tree tree ->
-      let tree = Git.Tree.(v [ entry ~name:pred_name `Dir pred_hash ]) in
+          let tree = Git.Tree.(add (entry ~name:pred_name `Dir pred_hash) (remove ~name:pred_name tree)) in
-      Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) ->
+          Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> Lwt.return_ok hash
-      unroll_tree t ?head (name, hash) rest
+        | _ -> assert false ) )
-    | Some tree_hash ->
+    | name :: rest ->
-      ( Store.read_exn t.store tree_hash >>= function
+      (head >>! fun head -> Search.find t.store head (`Commit (`Path (List.rev rpath)))) >>= function
-      | Git.Value.Tree tree ->
+      | None ->
-        let tree = Git.Tree.(add (entry ~name:pred_name `Dir pred_hash) (remove ~name:pred_name tree)) in
+        let tree = Git.Tree.(v [ entry ~name:pred_name `Dir pred_hash ]) in
         Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) ->
         unroll_tree t ?head (name, hash) rest
-        | _ -> assert false )
+      | Some tree_hash ->
-
+        ( Store.read_exn t.store tree_hash >>= function
-let set t key contents =
+        | Git.Value.Tree tree ->
-  let segs = Mirage_kv.Key.segments key in
+          let tree = Git.Tree.(add (entry ~name:pred_name `Dir pred_hash) (remove ~name:pred_name tree)) in
-  let now () = 0L (* TODO(dinosaure): functorize? *) in
+          Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) ->
-  match segs with
+          unroll_tree t ?head (name, hash) rest
-  | [] -> assert false
+          | _ -> assert false )
-  | path ->
+  
-    let blob = Git.Blob.of_string contents in
+  let set t key contents =
-    let rpath = List.rev path in
+    let segs = Mirage_kv.Key.segments key in
-    let name = List.hd rpath in
+    let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))) in
-    let open Lwt_result.Infix in
+    match segs with
-    Store.write t.store (Git.Value.Blob blob) >>= fun (hash, _) ->
+    | [] -> assert false
-    unroll_tree t ?head:t.head (name, hash) (List.tl rpath) >>= fun tree_root_hash ->
+    | path ->
-    let committer = author ~now in
+      let blob = Git.Blob.of_string contents in
-    let author = author ~now in
+      let rpath = List.rev path in
-    let parents = Option.value ~default:[] (Option.map (fun head -> [ head ]) t.head) in
+      let name = List.hd rpath in
-    let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
+      let open Lwt_result.Infix in
-      ~parents (Some "Committed by git-kv") in
+      Store.write t.store (Git.Value.Blob blob) >>= fun (hash, _) ->
-    Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
+      unroll_tree t ?head:t.head (name, hash) (List.tl rpath) >>= fun tree_root_hash ->
-    t.head <- Some hash ; Lwt.return_ok ()
+      let committer = author ~now in
-
+      let author = author ~now in
-let to_write_error (error : Store.error) = match error with
+      let parents = Option.value ~default:[] (Option.map (fun head -> [ head ]) t.head) in
-  | `Not_found hash -> `Hash_not_found hash
+      let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
-  | `Reference_not_found ref -> `Reference_not_found ref
+        ~parents (Some "Committed by git-kv") in
-  | `Msg err -> `Msg err
+      Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
-  | err -> Rresult.R.msgf "%a" Store.pp_error err
+      Lwt.Infix.(Store.shallow t.store hash >|= Result.ok) >>= fun () ->
-
+      t.head <- Some hash ; Lwt.return_ok ()
-let set t key contents =
+  
-  let open Lwt.Infix in
+  let to_write_error (error : Store.error) = match error with
-  set t key contents >|= Rresult.R.reword_error to_write_error
+    | `Not_found hash -> `Hash_not_found hash
-
+    | `Reference_not_found ref -> `Reference_not_found ref
-let set_partial t key ~offset chunk =
+    | `Msg err -> `Msg err
-  let open Lwt_result.Infix in
+    | err -> Rresult.R.msgf "%a" Store.pp_error err
-  get t key >>= fun contents ->
+  
-  let len = String.length contents in
+  let set t key contents =
-  let add = String.length chunk in
-  let res = Bytes.make (max len (offset + add)) '\000' in
-  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 batch t ?retries:_ f = f t
-
-let remove t key =
-  let segs = Mirage_kv.Key.segments key in
-  let now () = 0L (* TODO(dinosaure): functorize? *) in
-  match List.rev segs, t.head with
-  | [], _ -> assert false
-  | _, None -> Lwt.return_ok () (* XXX(dinosaure): or [`Not_found]? *)
-  | name :: [], Some head ->
     let open Lwt.Infix in
-    Search.find t.store head (`Commit (`Path [])) >|= Option.get >>= fun tree_root_hash ->
+    set t key contents >|= Rresult.R.reword_error to_write_error
-    Store.read_exn t.store tree_root_hash >>= fun tree_root ->
+  
-    let[@warning "-8"] Git.Value.Tree tree_root = tree_root in
+  let set_partial t key ~offset chunk =
-    let tree_root = Git.Tree.remove ~name tree_root in
     let open Lwt_result.Infix in
-    Store.write t.store (Git.Value.Tree tree_root) >>= fun (tree_root_hash, _) ->
+    get t key >>= fun contents ->
-    let committer = author ~now in
+    let len = String.length contents in
-    let author = author ~now in
+    let add = String.length chunk in
-    let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
+    let res = Bytes.make (max len (offset + add)) '\000' in
-      ~parents:[ head ] (Some "Committed by git-kv") in
+    Bytes.blit_string contents 0 res 0 len ;
-    Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
+    Bytes.blit_string chunk 0 res offset add ;
-    t.head <- Some hash ; Lwt.return_ok ()
+    set t key (Bytes.unsafe_to_string res)
-  | name :: pred_name :: rest, Some head ->
+  
+  let batch t ?retries:_ f = f t
+  
+  let remove t key =
+    let segs = Mirage_kv.Key.segments key in
+    let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))) in
+    match List.rev segs, t.head with
+    | [], _ -> assert false
+    | _, None -> Lwt.return_ok () (* XXX(dinosaure): or [`Not_found]? *)
+    | name :: [], Some head ->
+      let open Lwt.Infix in
+      Search.find t.store head (`Commit (`Path [])) >|= Option.get >>= fun tree_root_hash ->
+      Store.read_exn t.store tree_root_hash >>= fun tree_root ->
+      let[@warning "-8"] Git.Value.Tree tree_root = tree_root in
+      let tree_root = Git.Tree.remove ~name tree_root in
+      let open Lwt_result.Infix in
+      Store.write t.store (Git.Value.Tree tree_root) >>= fun (tree_root_hash, _) ->
+      let committer = author ~now in
+      let author = author ~now in
+      let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
+        ~parents:[ head ] (Some "Committed by git-kv") in
+      Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
+      Lwt.Infix.(Store.shallow t.store hash >|= Result.ok) >>= fun () ->
+      t.head <- Some hash ; Lwt.return_ok ()
+    | name :: pred_name :: rest, Some head ->
+      let open Lwt.Infix in
+      Search.find t.store head (`Commit (`Path (List.rev (pred_name :: rest)))) >>= function
+      | None -> Lwt.return_ok ()
+      | Some hash -> Store.read_exn t.store hash >>= function
+        | Git.Value.Tree tree ->
+          let tree = Git.Tree.remove ~name tree in
+          let open Lwt_result.Infix in
+          Store.write t.store (Git.Value.Tree tree) >>= fun (pred_hash, _) ->
+          unroll_tree t ~head (pred_name, pred_hash) rest >>= fun tree_root_hash ->
+          let committer = author ~now in
+          let author = author ~now in
+          let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
+            ~parents:[ head ] (Some "Committed by git-kv") in
+          Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
+          Lwt.Infix.(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
-    Search.find t.store head (`Commit (`Path (List.rev (pred_name :: rest)))) >>= function
+    remove t key >|= Rresult.R.reword_error to_write_error
-    | None -> Lwt.return_ok ()
+  
-    | Some hash -> Store.read_exn t.store hash >>= function
+  let rename t ~source ~dest =
-      | Git.Value.Tree tree ->
+    (* TODO(dinosaure): optimize it! It was done on the naive way. *)
-        let tree = Git.Tree.remove ~name tree in
+    let open Lwt_result.Infix in
-        let open Lwt_result.Infix in
+    get t source >>= fun contents ->
-        Store.write t.store (Git.Value.Tree tree) >>= fun (pred_hash, _) ->
+    remove t source >>= fun () ->
-        unroll_tree t ~head (pred_name, pred_hash) rest >>= fun tree_root_hash ->
+    set t dest contents
-        let committer = author ~now in
+end
-        let author = author ~now in
-        let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
-          ~parents:[ head ] (Some "Committed by git-kv") in
-        Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
-        t.head <- Some hash ; Lwt.return_ok ()
-      | _ -> Lwt.return_ok ()
-
-let remove t key =
-  let open Lwt.Infix in
-  remove t key >|= Rresult.R.reword_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
-  get t source >>= fun contents ->
-  remove t source >>= fun () ->
-  set t dest contents

src/git_kv.mli

@@ -1,26 +1,73 @@
-(* The idea is to provide a Mirage_kv.RW interface that is backed by a git
+(** {1: A Git key-value store.}
-   repository. The git repository is always (manually) kept in sync with the
-   remote one: either this is the only writer (and thus only set/remove
-   operations need to be pushed, or the API client receives a callback that
-   some update was done, and proceeds with a pull. *)
 
-include Mirage_kv.RW
+    This module implements the ability to manipulate a Git repository as a
-  with type write_error = [ `Msg of string
+    Key-Value store. It allows you to create a local (in-memory) Git repository
-                          | `Hash_not_found of Digestif.SHA1.t
+    that can come from either:
-                          | `Reference_not_found of Git.Reference.t
+    - a remote Git repository
-                          | Mirage_kv.write_error ]
+    - a state serialized by the {!val:to_octets} function
+
+    The first case is interesting if you want to be synchronised with the
+    remote repository. The second case can be interesting if we {b don't} want
+    to create a connection at the beginning and desynchronisation between our
+    local and remote repositories {b is not} a problem.
+
+    In the second case, the synchronisation can be done later with {!val:pull}.
+
+    As far as {!val:push} is concerned, a synchronisation with the remote
+    repository is necessary before {b changing} and sending the new information
+    (a use of {!val:Make.set}/{!val:Make.rename} should be preceded by a
+    {!val:pull}). This is because we do not handle conflicts that may exist
+    between your local repository and the remote repository - in other words,
+    if you want to ensure consistency between reading ({!val:pull}) and writing
+    ({!val:push}) to a remote repository, the instance that uses this code
+    should be the only one to handle said remote repository. *)
+
+type t
+(** The type of the Git store. *)
 
 val connect : Mimic.ctx -> string -> t Lwt.t
+(** [connect ctx remote] creates a new Git store which synchronizes
+    with [remote] {i via} protocols available into the given [ctx].
+
+    @raise [Invalid_argument _] if we can not initialize the store, or if
+    we can not fetch the given [remote]. *)
 
 val to_octets : t -> string Lwt.t
+(** [to_octets store] returns a serialized version of the given [store]. *)
 
 val of_octets : Mimic.ctx -> remote:string -> string ->
   (t, [> `Msg of string]) result Lwt.t
+(** [of_octets ctx ~remote contents] tries to re-create a {!type:t} from its
+    serialized version [contents]. This function does not do I/O and the
+    returned {!type:t} can be out of sync with the given [remote]. We advise
+    to call {!val:pull} to be in-sync with [remote]. *)
 
-type change = [ `Add of key
+type change = [ `Add of Mirage_kv.Key.t
-              | `Remove of key
+              | `Remove of Mirage_kv.Key.t
-              | `Change of key ]
+              | `Change of Mirage_kv.Key.t ]
 
 val pull : t -> (change list, [> `Msg of string ]) result Lwt.t
+(** [pull store] tries to synchronize the remote Git repository with your local
+    [store] Git repository. It returns a list of changes between the old state
+    of your store and what you have remotely. *)
+
 val push : t -> (unit, [> `Msg of string ]) result Lwt.t
-val size : t -> key -> (int, error) result Lwt.t
+(** [push store] tries to push any changes from your local Git repository
+    [store] to the remoe Git repository. The [push] function can fails for many
+    reasons. Currently, we don't handle merge politics and how we can resolve
+    conflicts between local and remote Git repositories. That mostly means that
+    if you are the only one who push to the Git repository (into a specific
+    branch), everything should be fine. But, if someone else push into the same
+    remote Git repository, your change can be discarded by the remote server
+    (due to conflicts). *)
+
+module Make (Pclock : Mirage_clock.PCLOCK) : sig
+  include Mirage_kv.RW
+    with type t = t
+     and type write_error = [ `Msg of string
+                            | `Hash_not_found of Digestif.SHA1.t
+                            | `Reference_not_found of Git.Reference.t
+                            | Mirage_kv.write_error ]
+  
+  val size : t -> key -> (int, error) result Lwt.t
+end