Merge pull request 'Rename batch to change_and_push and re-instantiate batch as a noop function' (#23) from fix-batch into main
Reviewed-on: https://git.robur.io/robur/git-kv/pulls/23
This commit is contained in:
commit
32c802e176
8 changed files with 263 additions and 182 deletions
25
README.md
25
README.md
|
|
@ -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
78
app/mgit.ml
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(lang dune 2.8)
|
||||
(lang dune 2.9)
|
||||
(name git-kv)
|
||||
(formatting disabled)
|
||||
(cram enable)
|
||||
|
|
|
|||
247
src/git_kv.ml
247
src/git_kv.ml
|
|
@ -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,73 +456,77 @@ 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.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
|
||||
| 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 ->
|
||||
let committer = author ~now in
|
||||
let author = author ~now 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) ]
|
||||
>|= 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 ()
|
||||
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.(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 () ->
|
||||
t.head <- Some hash ; Lwt.return_ok ()
|
||||
|
||||
let to_write_error (error : Store.error) = match error with
|
||||
| `Not_found hash -> `Hash_not_found hash
|
||||
|
|
@ -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, _) ->
|
||||
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) ]
|
||||
>|= 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 ()
|
||||
( 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.(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)
|
||||
>>= 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 ->
|
||||
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) ]
|
||||
>|= 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 ()
|
||||
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.(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)
|
||||
>>= 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
|
||||
|
|
|
|||
|
|
@ -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
28
test/batch.t
Normal 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)
|
||||
|
|
@ -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}))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue