Functorize git-kv with Pclock to save the right time when we commit

.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

@@ -12,6 +12,8 @@ depends: [
   "git"               {>= "3.9.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,7 +341,25 @@ 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
+  type nonrec t = t
+  type key = Mirage_kv.Key.t
+
+  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 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
+    | `Hash_not_found hash -> Store.pp_error ppf (`Not_found hash)
+
+  let exists t key =
     let open Lwt.Infix in
     match t.head with
     | None -> Lwt.return (Ok None)
@@ -369,7 +372,7 @@ let exists t key =
         | Blob _ -> Lwt.return (Ok (Some `Value))
         | Tree _ | Commit _ | Tag _ -> Lwt.return (Ok (Some `Dictionary))
   
-let get t key =
+  let get t key =
     let open Lwt.Infix in
     match t.head with
     | None -> Lwt.return (Error (`Not_found key))
@@ -381,7 +384,7 @@ let get t key =
         | Blob b -> Ok (Git.Blob.to_string b)
         | _ -> Error (`Value_expected key)
   
-let get_partial t key ~offset ~length =
+  let get_partial t key ~offset ~length =
     let open Lwt_result.Infix in
     get t key >|= fun data ->
     if String.length data < offset then
@@ -390,7 +393,7 @@ let get_partial t key ~offset ~length =
       let l = min length (String.length data - offset) in
       String.sub data offset l
   
-let list t key =
+  let list t key =
     let open Lwt.Infix in
     match t.head with
     | None -> Lwt.return (Error (`Not_found key))
@@ -407,7 +410,7 @@ let list t key =
           (Store.Value.Tree.to_list t) >|= Result.ok
         | _ -> Lwt.return (Error (`Dictionary_expected key))
   
-let last_modified t key =
+  let last_modified t key =
     let open Lwt.Infix in
     Option.fold
       ~none:(Lwt.return (Error (`Not_found key)))
@@ -432,23 +435,23 @@ let last_modified t key =
           | _ -> assert false)
       t.head
   
-let digest t key =
+  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 size t key =
     let open Lwt_result.Infix in
     get t key >|= fun data ->
     String.length data
   
-let author ~now =
+  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 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
@@ -481,9 +484,9 @@ let rec unroll_tree t ?head (pred_name, pred_hash) rpath =
           unroll_tree t ?head (name, hash) rest
           | _ -> assert false )
   
-let set t key contents =
+  let set t key contents =
     let segs = Mirage_kv.Key.segments key in
-  let now () = 0L (* TODO(dinosaure): functorize? *) in
+    let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))) in
     match segs with
     | [] -> assert false
     | path ->
@@ -501,17 +504,17 @@ let set t key contents =
       Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
       t.head <- Some hash ; Lwt.return_ok ()
   
-let to_write_error (error : Store.error) = match error with
+  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
   
-let set t key contents =
+  let set t key contents =
     let open Lwt.Infix in
     set t key contents >|= Rresult.R.reword_error to_write_error
   
-let set_partial t key ~offset chunk =
+  let set_partial t key ~offset chunk =
     let open Lwt_result.Infix in
     get t key >>= fun contents ->
     let len = String.length contents in
@@ -521,11 +524,11 @@ let set_partial t key ~offset chunk =
     Bytes.blit_string chunk 0 res offset add ;
     set t key (Bytes.unsafe_to_string res)
   
-let batch t ?retries:_ f = f t
+  let batch t ?retries:_ f = f t
   
-let remove t key =
+  let remove t key =
     let segs = Mirage_kv.Key.segments key in
-  let now () = 0L (* TODO(dinosaure): functorize? *) 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]? *)
@@ -561,13 +564,14 @@ let remove t key =
           t.head <- Some hash ; Lwt.return_ok ()
         | _ -> Lwt.return_ok ()
   
-let remove t key =
+  let remove t key =
     let open Lwt.Infix in
     remove t key >|= Rresult.R.reword_error to_write_error
   
-let rename t ~source ~dest =
+  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
+end

src/git_kv.mli

@@ -3,24 +3,51 @@
    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. *)
+type t
 
-include Mirage_kv.RW
+val connect : Mimic.ctx -> string -> t Lwt.t
-  with type write_error = [ `Msg of string
+(** [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 Mirage_kv.Key.t
+              | `Remove of Mirage_kv.Key.t
+              | `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
+(** [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 connect : Mimic.ctx -> string -> t Lwt.t
+  val size : t -> key -> (int, error) result Lwt.t
-
+end
-val to_octets : t -> string Lwt.t
-
-val of_octets : Mimic.ctx -> remote:string -> string ->
-  (t, [> `Msg of string]) result Lwt.t
-
-type change = [ `Add of key
-              | `Remove of key
-              | `Change of key ]
-
-val pull : t -> (change list, [> `Msg of string ]) result Lwt.t
-val push : t -> (unit, [> `Msg of string ]) result Lwt.t
-val size : t -> key -> (int, error) result Lwt.t