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

Don't try to push if the tree_root still is the same

Browse source 
If the user just read into the batched function and does not change anything,
we just return the result.
This commit is contained in:
Romain Calascibetta 2022-10-29 22:30:12 +02:00
parent b5fa25d9a5
commit 64fc2402ab
1 changed files with 20 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

37
src/git_kv.ml
View file

@ -630,23 +630,26 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
(* 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 (tree_root_hash, _) = t'.committed 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 committer = author ~now in
let author = author ~now 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, _) ->
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 )
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 () ;