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

Reviewed-on: https://git.robur.io/robur/git-kv/pulls/15
This commit is contained in:
dinosaure 2022-10-19 13:20:09 +00:00
commit 781bc5b2d9
8 changed files with 330 additions and 245 deletions

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

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

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 =

View file

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

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

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,6 +341,24 @@ let of_octets ctx ~remote data =
(Printexc.raw_backtrace_to_string (Printexc.get_raw_backtrace ())) ;
Lwt.return_error (`Msg "Invalid PACK file"))
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
@ -483,7 +486,7 @@ let rec unroll_tree t ?head (pred_name, pred_hash) rpath =
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 ->
@ -499,6 +502,7 @@ let set t key contents =
let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer
~parents (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 ()
let to_write_error (error : Store.error) = match error with
@ -525,7 +529,7 @@ 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
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]? *)
@ -542,6 +546,7 @@ let remove t key =
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
@ -558,6 +563,7 @@ let remove t key =
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 ()
@ -571,3 +577,4 @@ let rename t ~source ~dest =
get t source >>= fun contents ->
remove t source >>= fun () ->
set t dest contents
end

View file

@ -1,26 +1,73 @@
(* The idea is to provide a Mirage_kv.RW interface that is backed by a git
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. *)
(** {1: A Git key-value store.}
This module implements the ability to manipulate a Git repository as a
Key-Value store. It allows you to create a local (in-memory) Git repository
that can come from either:
- a remote Git repository
- 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 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 write_error = [ `Msg of string
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
end