robur/git-kv
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Romain Calascibetta 2022-10-19 13:00:04 +02:00
parent 7323b8f065
commit 83be2b3f25
8 changed files with 303 additions and 241 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
.gitignore vendored Normal file
View file

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

17
.ocamlformat Normal file
View file

@ -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

2
app/dune
View file

@ -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))

9
app/mgit.ml
View file

@ -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 =

2
git-kv.opam
View file

@ -12,6 +12,8 @@ depends: [
"git" {>= "3.9.0"}
"mirage-kv" {>= "4.0.0"}
"git-unix"
"mirage-clock-unix"
"mirage-clock"
"ptime"
]

2
src/dune
View file

@ -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))

72
src/git_kv.ml
View file

@ -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

59
src/git_kv.mli
View file

@ -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
with type write_error = [ `Msg of string
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 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 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
val size : t -> key -> (int, error) result Lwt.t
end