Merge pull request 'minor refactorings and updates' (#24) from more into main
Reviewed-on: https://git.robur.io/robur/git-kv/pulls/24
This commit is contained in:
commit
fc2e17f4c2
5 changed files with 72 additions and 72 deletions
|
|
@ -22,7 +22,6 @@ let () = Logs.set_reporter (reporter Fmt.stderr)
|
|||
let () = Logs.set_level ~all:true (Some Logs.Debug)
|
||||
*)
|
||||
|
||||
open Rresult
|
||||
open Lwt.Infix
|
||||
|
||||
let get ~quiet store key =
|
||||
|
|
@ -141,6 +140,7 @@ let repl store fd_in =
|
|||
| [ "quit"; ] -> Lwt.return ()
|
||||
| [ "fold"; ] ->
|
||||
Store.change_and_push store0 (fun store1 -> go store1)
|
||||
>|= Result.fold ~ok:Fun.id ~error:(function `Msg msg -> Fmt.epr "%s.\n%!" msg)
|
||||
>>= fun () -> go store0
|
||||
| [ "save"; filename ] ->
|
||||
save store0 filename >|= ignore
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ depends: [
|
|||
"mirage-kv" {>= "4.0.0"}
|
||||
"git-unix" {>= "3.10.0"}
|
||||
"carton" {>= "0.6.0"}
|
||||
"fmt" {>= "0.8.7"}
|
||||
"mirage-clock-unix"
|
||||
"mirage-clock"
|
||||
"ptime"
|
||||
|
|
|
|||
2
src/dune
2
src/dune
|
|
@ -2,4 +2,4 @@
|
|||
(name git_kv)
|
||||
(public_name git-kv)
|
||||
(flags (-w -32))
|
||||
(libraries git ptime mirage-clock mirage-kv))
|
||||
(libraries git ptime mirage-clock mirage-kv fmt))
|
||||
|
|
|
|||
|
|
@ -19,9 +19,6 @@ let init_store () =
|
|||
(fun e -> `Msg (Fmt.str "error setting up store %a" Store.pp_error e))
|
||||
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 ]
|
||||
|
||||
|
|
@ -35,7 +32,7 @@ let split_url s =
|
|||
Smart_git.Endpoint.of_string edn |> to_invalid,
|
||||
Git.Reference.of_string ("refs/heads/" ^ branch) |> to_invalid
|
||||
| _ ->
|
||||
Smart_git.Endpoint.of_string s |> to_invalid, main
|
||||
Smart_git.Endpoint.of_string s |> to_invalid, Git.Reference.main
|
||||
|
||||
let fpath_to_key ~root v =
|
||||
if Fpath.equal root v
|
||||
|
|
@ -334,9 +331,8 @@ let of_octets ctx ~remote data =
|
|||
(* TODO maybe recover edn and branch from data as well? *)
|
||||
Lwt.catch
|
||||
(fun () ->
|
||||
init_store ()
|
||||
>|= Rresult.R.reword_error (Rresult.R.msgf "%a" Store.pp_error)
|
||||
>|= Rresult.R.failwith_error_msg >>= fun store ->
|
||||
init_store () >|=
|
||||
Result.fold ~ok:Fun.id ~error:(function `Msg msg -> failwith msg) >>= fun store ->
|
||||
analyze store data >>= fun head ->
|
||||
let edn, branch = split_url remote in
|
||||
Lwt.return_ok { ctx ; edn ; branch ; store ; committed= None; in_closure= false; head; })
|
||||
|
|
@ -492,7 +488,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
|
|||
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)
|
||||
| _ -> Lwt.return_error (`Msg (Fmt.str "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 ())))
|
||||
|
|
@ -532,12 +528,12 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
|
|||
| `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
|
||||
| err -> `Msg (Fmt.to_to_string Store.pp_error err)
|
||||
|
||||
let set t key contents =
|
||||
let open Lwt.Infix in
|
||||
set ?and_commit:t.committed t key contents
|
||||
>|= Rresult.R.reword_error to_write_error
|
||||
>|= Result.map_error to_write_error
|
||||
|
||||
let set_partial t key ~offset chunk =
|
||||
let open Lwt_result.Infix in
|
||||
|
|
@ -604,7 +600,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
|
|||
|
||||
let remove t key =
|
||||
let open Lwt.Infix in
|
||||
remove ?and_commit:t.committed t key >|= Rresult.R.reword_error to_write_error
|
||||
remove ?and_commit:t.committed t key >|= Result.map_error to_write_error
|
||||
|
||||
let rename t ~source ~dest =
|
||||
(* TODO(dinosaure): optimize it! It was done on the naive way. *)
|
||||
|
|
@ -617,44 +613,47 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
|
|||
|
||||
let change_and_push t f =
|
||||
let open Lwt.Infix in
|
||||
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 (_tree_root_hash, th) -> th ) >>= fun () ->
|
||||
let th, wk = Lwt.wait () in
|
||||
( 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 () ->
|
||||
if t.in_closure then
|
||||
Lwt.return_error (`Msg "Nested change_and_push")
|
||||
else
|
||||
(* 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 (_tree_root_hash, th) -> th ) >>= fun () ->
|
||||
let th, wk = Lwt.wait () in
|
||||
( 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
|
||||
>|= Result.map_error
|
||||
(fun err -> `Msg (Fmt.str "error pushing %a" Store.pp_error err))
|
||||
>>= fun res ->
|
||||
Lwt.wakeup_later wk () ;
|
||||
t.committed <- None ;
|
||||
Lwt.return res
|
||||
end
|
||||
|
|
|
|||
|
|
@ -67,5 +67,5 @@ module Make (Pclock : Mirage_clock.PCLOCK) : sig
|
|||
| `Reference_not_found of Git.Reference.t
|
||||
| Mirage_kv.write_error ]
|
||||
|
||||
val change_and_push : t -> (t -> 'a Lwt.t) -> 'a Lwt.t
|
||||
val change_and_push : t -> (t -> 'a Lwt.t) -> ('a, [> `Msg of string ]) result Lwt.t
|
||||
end
|
||||
|
|
|
|||
Loading…
Reference in a new issue