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

Merge pull request 'Rename batch to change_and_push and re-instantiate batch as a noop function' (#23) from fix-batch into main

Browse source 
Reviewed-on: https://git.robur.io/robur/git-kv/pulls/23
This commit is contained in:
dinosaure 2022-10-31 16:07:57 +00:00
commit 32c802e176
8 changed files with 263 additions and 182 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
README.md
View file

@ -47,26 +47,25 @@ let _ =
The user can manipulate the repository as an [RW][mirage-kv-rw] repository. Any
change to the repository requires a new commit. These changes will be sent to
the remote repository by default. If the user does not want to push modifications,
they can use `Git_kv.Make.Local` which provide functions without `push`. If the
user knows that they will do many changes and they don't want to change all of
them and do a `push` only at the end, they can use `Git_kv.Make.batch`.
the remote repository. The user can _fold_ any changes into one commit if he/she
wants.
```ocaml
module Store = Git_kv.Make (Pclock)
let new_file_locally_and_remotely t =
let new_file t =
Store.set t Mirage_kv.Key.(empty / "foo") "foo" >>= fun () ->
(* XXX(dinosaure): a commit was created and sended to the
remote repository. *)
...
let new_file_locally t =
Git_kv.pull t >>= fun _diff ->
Store.Local.set t Mirage_kv.Key.(empty / "foo") "foo" >>= fun () ->
...
let batch_operations t =
let new_files_batched t =
Store.batch t @@ fun t ->
Store.set t Mirage_kv.Key.(empty / "bar") "bar" >>= fun () ->
Store.remove t Mirage_kv.Key.(empty / "foo")
Store.set t Mirage_kv.Key.(empty / "foo" "foo") >>= fun () ->
Store.set t Mirage_kv.Key.(empty / "bar" "bar")
(* XXX(dinosaure): multiple files are added into the local repository
but they are committed only at the end of the given function
to [batch]. That's say, only one commit was made and sended to the
remote Git repository. *)
```
[mimic]: https://dinosaure.github.io/mimic/mimic/index.html

78
app/mgit.ml
View file

@ -35,6 +35,42 @@ let get ~quiet store key =
if not quiet then Fmt.epr "%a.\n%!" Store.pp_error err ;
Lwt.return (Ok 1)
let exists ~quiet store key =
Store.exists store key >>= function
| Ok k when not quiet ->
( match k with
| None -> Fmt.pr "%a does not exists\n%!" Mirage_kv.Key.pp key
| Some `Dictionary -> Fmt.pr "%a exists as a dictionary\n%!" Mirage_kv.Key.pp key
| Some `Value -> Fmt.pr "%a exists as a value\n%!" Mirage_kv.Key.pp key ) ;
Lwt.return (Ok 0)
| Ok _ -> Lwt.return (Ok 0)
| Error err ->
if not quiet then Fmt.epr "%a.\n%!" Store.pp_error err ;
Lwt.return (Ok 1)
let value_of_string str =
let v = ref None in
match Scanf.sscanf str "%S" (fun str -> v := Some str) with
| () -> Option.get !v
| exception _ ->
Scanf.sscanf str "%s" (fun str -> v := Some str) ;
Option.get !v
let set ~quiet store key str =
let value = value_of_string str in
Store.set store key value >>= function
| Ok () -> Lwt.return (Ok 0)
| Error err ->
if not quiet then Fmt.epr "%a.\n%!" Store.pp_write_error err ;
Lwt.return (Ok 1)
let remove ~quiet store key =
Store.remove store key >>= function
| Ok () -> Lwt.return (Ok 0)
| Error err ->
if not quiet then Fmt.epr "%a.\n%!" Store.pp_write_error err ;
Lwt.return (Ok 1)
let list ~quiet store key =
Store.list store key >>= function
| Ok lst when not quiet ->
@ -77,28 +113,48 @@ let with_key ~f key =
Fmt.epr "Invalid key: %S.\n%!" key ;
Lwt.return (Ok 1)
let repl store ic =
let rec go () = Fmt.pr "# %!" ; match String.split_on_char ' ' (input_line ic) |> trim with
let repl store fd_in =
let is_a_tty = Unix.isatty fd_in in
let ic = Unix.in_channel_of_descr fd_in in
let rec go store0 =
if is_a_tty then Fmt.pr "# %!" ;
match String.split_on_char ' ' (input_line ic) |> trim with
| [ "get"; key; ] ->
with_key ~f:(get ~quiet:false store) key >|= ignore >>= go
with_key ~f:(get ~quiet:false store0) key
>|= ignore >>= fun () -> go store0
| [ "exists"; key; ] ->
with_key ~f:(exists ~quiet:false store0) key
>|= ignore >>= fun () -> go store0
| "set" :: key :: data ->
let data = String.concat " " data in
with_key ~f:(fun key -> set ~quiet:false store0 key data) key
>|= ignore >>= fun () -> go store0
| [ "remove"; key; ] ->
with_key ~f:(remove ~quiet:false store0) key
>|= ignore >>= fun () -> go store0
| [ "list"; key; ] ->
with_key ~f:(list ~quiet:false store) key >|= ignore >>= go
with_key ~f:(list ~quiet:false store0) key
>|= ignore >>= fun () -> go store0
| [ "pull"; ] ->
Fmt.pr "\n%!" ; pull ~quiet:false store >|= ignore >>= go
if is_a_tty then Fmt.pr "\n%!" ; pull ~quiet:false store0
>|= ignore >>= fun () -> go store0
| [ "quit"; ] -> Lwt.return ()
| [ "batch"; ] ->
Store.batch store0 (fun store1 -> go store1)
>>= fun () -> go store0
| [ "save"; filename ] ->
save store filename >|= ignore >>= fun _ ->
Fmt.pr "\n%!" ; go ()
| _ -> Fmt.epr "Invalid command.\n%!" ; go ()
save store0 filename >|= ignore
>>= fun _ -> if is_a_tty then Fmt.pr "\n%!" ; go store0
| _ -> Fmt.epr "Invalid command.\n%!" ; go store0
| exception End_of_file -> Lwt.return () in
go ()
go store
let run remote = function
| None ->
Lwt_main.run @@
(Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx ->
Git_kv.connect ctx remote >>= fun t ->
repl t stdin)
repl t Unix.stdin)
| Some filename ->
let contents =
let ic = open_in filename in
@ -109,7 +165,7 @@ let run remote = function
Lwt_main.run
( Git_unix.ctx (Happy_eyeballs_lwt.create ()) >>= fun ctx ->
Git_kv.of_octets ctx ~remote contents >>= function
| Ok t -> repl t stdin
| Ok t -> repl t Unix.stdin
| Error (`Msg err) -> Fmt.failwith "%s." err )
let () = match Sys.argv with

2
dune-project
View file

@ -1,4 +1,4 @@
(lang dune 2.8)
(lang dune 2.9)
(name git-kv)
(formatting disabled)
(cram enable)

189
src/git_kv.ml
View file

@ -8,7 +8,8 @@ type t =
; edn : Smart_git.Endpoint.t
; branch : Git.Reference.t
; store : Store.t
; mutable batch : unit Lwt.t option
; mutable committed : (Digestif.SHA1.t * unit Lwt.t) option
; in_closure : bool
; mutable head : Store.hash option }
let init_store () =
@ -19,6 +20,7 @@ let init_store () =
r
let main = Git.Reference.v "refs/heads/main"
let msgf fmt = Fmt.kstr (fun msg -> `Msg msg) fmt
let capabilities =
[ `Side_band_64k; `Multi_ack_detailed; `Ofs_delta; `Thin_pack; `Report_status ]
@ -103,7 +105,7 @@ let connect ctx endpoint =
init_store () >>= fun store ->
let store = to_invalid store in
let edn, branch = split_url endpoint in
let t = { ctx ; edn ; branch ; store ; batch= None; head= None } in
let t = { ctx ; edn ; branch ; store ; committed= None; in_closure= false; head= None } in
pull t >>= fun r ->
let _r = to_invalid r in
Lwt.return t
@ -180,6 +182,7 @@ let ( <.> ) f g = fun x -> f (g x)
let ( >>? ) x f = let open Lwt.Infix in match x with
| Some x -> f x >>= fun v -> Lwt.return_some v
| None -> Lwt.return_none
let ( >>! ) x f = Lwt.Infix.(x >>= f)
let pack t ~commit stream =
let open Lwt.Infix in
@ -336,7 +339,7 @@ let of_octets ctx ~remote data =
>|= Rresult.R.failwith_error_msg >>= fun store ->
analyze store data >>= fun head ->
let edn, branch = split_url remote in
Lwt.return_ok { ctx ; edn ; branch ; store ; batch= None; head; })
Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; in_closure= false; head; })
(fun exn ->
Fmt.epr ">>> Got an exception: %s.\n%!" (Printexc.to_string exn) ;
Fmt.epr ">>> %s.\n%!"
@ -453,72 +456,76 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
; email= "git@mirage.io"
; date= now (), None }
let rec unroll_tree t ?head (pred_perm, pred_name, pred_hash) rpath =
let rec unroll_tree t ~tree_root_hash (pred_perm, 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 pred_perm 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 ->
( Store.read_exn t.store tree_root_hash >>= function
| Git.Value.Tree tree ->
let tree = Git.Tree.(add (entry ~name:pred_name pred_perm pred_hash) (remove ~name:pred_name tree)) in
Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> Lwt.return_ok hash
| _ -> assert false ) )
| _ -> assert false )
| name :: rest ->
(head >>! fun head -> Search.find t.store head (`Commit (`Path (List.rev rpath)))) >>= function
Search.find t.store tree_root_hash (`Path (List.rev rpath)) >>= function
| None ->
let tree = Git.Tree.(v [ entry ~name:pred_name pred_perm pred_hash ]) in
Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) ->
unroll_tree t ?head (`Dir, name, hash) rest
unroll_tree t ~tree_root_hash (`Dir, name, hash) rest
| Some tree_hash ->
( Store.read_exn t.store tree_hash >>= function
| Git.Value.Tree tree ->
let tree = Git.Tree.(add (entry ~name:pred_name pred_perm pred_hash) (remove ~name:pred_name tree)) in
Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) ->
unroll_tree t ?head (`Dir, name, hash) rest
unroll_tree t ~tree_root_hash (`Dir, name, hash) rest
| _ -> assert false )
let no_batch = function
| None -> true
| Some th -> match Lwt.state th with
| Sleep -> true
| Return _ | Fail _ -> false
let tree_root_hash_of_store t =
match t.committed, t.head with
| Some (tree_root_hash, _), _ -> Lwt.return_ok tree_root_hash
| None, None ->
let open Lwt_result.Infix in
let tree = Store.Value.Tree.v [] in
Store.write t.store (Git.Value.Tree tree) >>= fun (hash, _) ->
Lwt.return_ok hash
| None, Some commit ->
let open Lwt.Infix in
Store.read_exn t.store commit >>= function
| Git.Value.Commit commit -> Lwt.return_ok (Store.Value.Commit.tree commit)
| _ -> Lwt.return_error (msgf "The current HEAD value (%a) is not a commit" Digestif.SHA1.pp commit)
let ( >>? ) = Lwt_result.bind
let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ())))
let set ~and_push t key contents =
let set ?and_commit t key contents =
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 segs with
| [] -> assert false
| [] -> assert false (* TODO *)
| path ->
let blob = Git.Blob.of_string contents in
let rpath = List.rev path in
let name = List.hd rpath in
let open Lwt_result.Infix in
Store.write t.store (Git.Value.Blob blob) >>= fun (hash, _) ->
unroll_tree t ?head:t.head (`Normal, name, hash) (List.tl rpath) >>= fun tree_root_hash ->
tree_root_hash_of_store t >>= fun tree_root_hash ->
unroll_tree t ~tree_root_hash (`Normal, name, hash) (List.tl rpath) >>= fun tree_root_hash ->
match and_commit with
| Some (_old_tree_root_hash, th) ->
t.committed <- Some (tree_root_hash, th) ;
Lwt.return_ok ()
| None ->
let committer = author ~now in
let author = author ~now in
let action = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head in
let parents = Option.value ~default:[] (Option.map (fun head -> [ head ]) t.head) in
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, _) ->
Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
Lwt.Infix.(if and_push then
Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ]
Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ action ]
>|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing branch %a: %a"
Git.Reference.pp t.branch Sync.pp_error err))
>>? fun () -> (Store.shallow t.store hash >|= Result.ok)
else Lwt.return_ok ()) >>= fun () ->
>>? fun () -> 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
@ -527,113 +534,125 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
| `Msg err -> `Msg err
| err -> Rresult.R.msgf "%a" Store.pp_error err
let set ?(and_push= true) t key contents =
let set t key contents =
let open Lwt.Infix in
let and_push = no_batch t.batch && and_push in
set ~and_push t key contents >|= Rresult.R.reword_error to_write_error
set ?and_commit:t.committed t key contents
>|= Rresult.R.reword_error to_write_error
let set_partial ?(and_push= true) t key ~offset chunk =
let set_partial t key ~offset chunk =
let open Lwt_result.Infix in
let and_push = no_batch t.batch && and_push in
get t key >>= fun contents ->
let len = String.length contents in
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 ~and_push t key (Bytes.unsafe_to_string res)
set t key (Bytes.unsafe_to_string res)
let remove ~and_push t key =
let remove ?and_commit 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 open Lwt_result.Infix in
tree_root_hash_of_store t >>= 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, _) ->
( match and_commit with
| Some (_old_tree_root_hash, th) -> t.committed <- Some (tree_root_hash, th) ; Lwt.return_ok ()
| None ->
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, _) ->
Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
Lwt.Infix.(if and_push then
Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ]
Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ]
>|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing branch %a: %a"
Git.Reference.pp t.branch Sync.pp_error err))
>>? fun () -> Store.shallow t.store hash >|= Result.ok
else Lwt.return_ok ()) >>= fun () ->
t.head <- Some hash ; Lwt.return_ok ()
>>? fun () -> 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
let open Lwt_result.Infix in
tree_root_hash_of_store t >>= fun tree_root_hash ->
Search.find t.store tree_root_hash (`Path (List.rev (pred_name :: rest))) >>! function
| None -> Lwt.return_ok ()
| Some hash -> Store.read_exn t.store hash >>= function
| 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 (`Dir, pred_name, pred_hash) rest >>= fun tree_root_hash ->
unroll_tree t ~tree_root_hash (`Dir, pred_name, pred_hash) rest >>= fun tree_root_hash ->
( match and_commit with
| Some (_old_tree_root_hash, th) -> t.committed <- Some (tree_root_hash, th) ; Lwt.return_ok ()
| None ->
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, _) ->
Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
Lwt.Infix.(if and_push then
Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ]
Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ]
>|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing branch %a: %a"
Git.Reference.pp t.branch Sync.pp_error err))
>>? fun () -> Store.shallow t.store hash >|= Result.ok
else Lwt.return_ok ()) >>= fun () ->
t.head <- Some hash ; Lwt.return_ok ()
>>? fun () -> Store.shallow t.store hash >|= Result.ok)
>>= fun () -> t.head <- Some hash ; Lwt.return_ok () )
| _ -> Lwt.return_ok ()
let remove ?(and_push= true) t key =
let remove t key =
let open Lwt.Infix in
let and_push = no_batch t.batch && and_push in
remove ~and_push t key >|= Rresult.R.reword_error to_write_error
remove ?and_commit:t.committed t key >|= Rresult.R.reword_error to_write_error
let rename ?(and_push= true) 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 ~and_push t source >>= fun () ->
set ~and_push t dest contents
remove t source >>= fun () ->
set t dest contents
let batch t ?retries:_ f =
let open Lwt.Infix in
( match t.batch with
if t.in_closure then Fmt.invalid_arg "Nested change_and_push" ;
(* XXX(dinosaure): serialize [batch]. If we do [Lwt.both (batch ..) (batch ..)], they
can not run concurrently! The second will waiting the first to finish. *)
( match t.committed with
| None -> Lwt.return_unit
| Some th -> th ) >>= fun () ->
| Some (_tree_root_hash, th) -> th ) >>= fun () ->
let th, wk = Lwt.wait () in
t.batch <- Some th ;
f t >>= fun res ->
( Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] >>= function
| Ok () ->
( match t.head with
| None -> Lwt.return_unit
| Some hash -> Store.shallow t.store hash )
| Error err ->
Fmt.failwith "error pushing branch %a: %a" Git.Reference.pp t.branch Sync.pp_error err ) >>= fun () ->
( let open Lwt_result.Infix in
tree_root_hash_of_store t >>= fun tree_root_hash ->
t.committed <- Some (tree_root_hash, th) ;
let t' = { t with in_closure= true } in
f t' >>! fun res ->
(* XXX(dinosaure): we assume that only [batch] can reset [t.committed] to [None] and
we ensured that [batch] can not be called into [f]. So we are sure that [t'.committed]
must be [Some _] in anyway. *)
let[@warning "-8"] Some (new_tree_root_hash, _) = t'.committed in
if Digestif.SHA1.equal new_tree_root_hash tree_root_hash
then Lwt.return_ok res (* XXX(dinosaure): nothing to send! *)
else
let action = Option.fold ~none:(`Create t.branch) ~some:(fun _ -> `Update (t.branch, t.branch)) t.head in
let parents = Option.value ~default:[] (Option.map (fun head -> [ head ]) t.head) in
let committer = author ~now in
let author = author ~now in
let commit = Store.Value.Commit.make ~tree:new_tree_root_hash ~author ~committer
~parents (Some "Committed by git-kv") in
Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) ->
t.head <- Some hash ;
Store.Ref.write t.store t.branch (Git.Reference.uid hash) >>= fun () ->
Lwt.Infix.(Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ action ]
>|= Result.map_error (fun err ->
`Msg (Fmt.str "error pushing branch %a: %a"
Git.Reference.pp t.branch Sync.pp_error err))
>>? fun () ->
Store.shallow t.store hash >|= Result.ok) >>= fun () ->
Lwt.return_ok res )
>|= Rresult.R.reword_error (msgf "%a" Store.pp_error)
>|= Rresult.R.failwith_error_msg >>= fun res ->
Lwt.wakeup_later wk () ;
t.committed <- None ;
Lwt.return res
module Local = struct
let set_partial t k ~offset v = set_partial ~and_push:false t k ~offset v
let set t k v = set ~and_push:false t k v
let remove t k = remove ~and_push:false t k
let rename t ~source ~dest = rename ~and_push:false t ~source ~dest
end
let set_partial t k ~offset v = set_partial ~and_push:true t k ~offset v
let set t k v = set ~and_push:true t k v
let remove t k = remove ~and_push:true t k
let rename t ~source ~dest = rename ~and_push:true t ~source ~dest
end

44
src/git_kv.mli
View file

@ -15,37 +15,20 @@
{2: Pushing and synchronisation.}
The user can modify the repository (add files, remove files, etc.). They
can do this locally (with the {!module:Make.Local} module) and thus assume
a possible desynchronisation between the remote repository and what exists
locally or they can share these changes with the remote repository (default
behavior).
In the latter case, the notion of {i merge} and conflicts is not handled by
our implementation. This means that if the remote repository is manipulated
by another instance than yours, it can result in conflicts that will make
the above functions fail.
The only check done by the remote Git repository when you want to submit
your change is the ability to find a path between a commit available
remotely, the commit-graph given by the transmission, and your last commit.
In that way, our [push] is most similar to a [git push --force]!
To save I/O, the {!val:Make.batch} operation allows you to do some change
into a closure and the implementation will push only at the end of this
closure. By this way, you can {!val:Make.set}, {!val:Make.rename} or
{!val:Make.remove} without a systematic [push] on these actions. Only one
will be done at the end of your closure.
The user can modify the repository (add files, remove files, etc.). Each
change produces a commit and after each change we try to transfer them to
the remote Git repository. If you want to make multiple changes but contain
them in a single commit and only transfer those changes once, you should
use the {!val:Make.batch} function.
{2: Serialization of the Git repository.}
Finally, the KV-store tries to keep the minimal set of commits required
between you and the remote repository. In other words, only {i un}pushed
changes are kept by the KV-store. However, if these changes are not pushed,
they will be stored into the final state produced by {!val:to_octets}. In
other words, the more changes you make out of sync with the remote
repository (without pushing them), the bigger the state serialization will
be. *)
between you and the remote repository. Only {i un}pushed changes are kept
by the KV-store. However, if these changes are not pushed, they will be
stored into the final state produced by {!val:to_octets}. In other words,
the more changes you make out of sync with the remote repository (without
pushing them), the bigger the state serialization will be. *)
type t
(** The type of the Git store. *)
@ -83,11 +66,4 @@ module Make (Pclock : Mirage_clock.PCLOCK) : sig
| `Hash_not_found of Digestif.SHA1.t
| `Reference_not_found of Git.Reference.t
| Mirage_kv.write_error ]
module Local : sig
val set : t -> key -> string -> (unit, write_error) result Lwt.t
val remove : t -> key -> (unit, write_error) result Lwt.t
val rename : t -> source:key -> dest:key -> (unit, write_error) result Lwt.t
val set_partial : t -> key -> offset:int -> string -> (unit, write_error) result Lwt.t
end
end

28
test/batch.t Normal file
View file

@ -0,0 +1,28 @@
Batch operation
$ mkdir simple
$ cd simple
$ git init --bare -q 2> /dev/null
$ cd ..
$ git daemon --base-path=. --export-all --enable=receive-pack --reuseaddr --pid-file=pid --detach
$ mgit git://localhost/simple#main <<EOF
> batch
> set /bar "Git rocks!"
> set /foo "Hello World!"
> exists /bar
> quit
> quit
/"bar" does not exists
$ mgit git://localhost/simple#main <<EOF
> list /
> get /bar
> get /foo
> quit
- bar
- foo
00000000: 4769 7420 726f 636b 7321 Git rocks!
00000000: 4865 6c6c 6f20 576f 726c 6421 Hello World!
$ cd simple
$ git log main --pretty=oneline | wc -l
1
$ cd ..
$ kill $(cat pid)

8
test/dune
View file

@ -1,3 +1,11 @@
(cram
(package git-kv)
(applies_to simple)
(locks p9418)
(deps %{bin:mgit}))
(cram
(package git-kv)
(applies_to batch)
(locks p9418)
(deps %{bin:mgit}))

13
test/simple.t
View file

@ -17,9 +17,7 @@ Simple test of our Git Key-Value store
> get /foo
> save db.pack
> quit
# 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!.
#
#
00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!.
$ tail -c20 db.pack | hexdump
0000000 b2e4 3734 7e2e 7e3d 0885 1239 873d cd11
0000010 4299 4771
@ -27,8 +25,7 @@ Simple test of our Git Key-Value store
$ mgit git://localhost/simple db.pack <<EOF
> get /foo
> quit
# 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!.
#
00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!.
$ cd simple
$ echo "Git rocks!" > bar
$ git add bar
@ -39,10 +36,8 @@ Simple test of our Git Key-Value store
> get /bar
> get /foo
> quit
#
+ /"bar"
* /
# 00000000: 4769 7420 726f 636b 7321 0a Git rocks!.
# 00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!.
#
00000000: 4769 7420 726f 636b 7321 0a Git rocks!.
00000000: 4865 6c6c 6f20 576f 726c 6421 0a Hello World!.
$ kill $(cat pid)