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

Don't retry if push fail into the batch function

Browse source
This commit is contained in:
Romain Calascibetta 2022-10-28 14:14:40 +02:00
parent 6bf4dc7f07
commit 993db937f8
1 changed files with 8 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
src/git_kv.ml
View file

@ -602,26 +602,21 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
remove ~and_push t source >>= fun () -> remove ~and_push t source >>= fun () ->
set ~and_push t dest contents set ~and_push t dest contents
let batch t ?(retries= 3) f = let batch t ?retries:_ f =
let open Lwt.Infix in let open Lwt.Infix in
if retries < 0
then Fmt.invalid_arg "Git_kv.Make.batch: retries must be equal or greater than 0" ;
( match t.batch with ( match t.batch with
| None -> Lwt.return_unit | None -> Lwt.return_unit
| Some th -> th ) >>= fun () -> | Some th -> th ) >>= fun () ->
let th, wk = Lwt.wait () in let th, wk = Lwt.wait () in
t.batch <- Some th ; t.batch <- Some th ;
f t >>= fun res -> f t >>= fun res ->
let rec force_push limit = ( Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] >>= function
Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] >>= function
| Ok () -> | Ok () ->
( match t.head with ( match t.head with
| None -> Lwt.return_unit | None -> Lwt.return_unit
| Some hash -> Store.shallow t.store hash ) | Some hash -> Store.shallow t.store hash )
| Error _ when limit > 0 -> force_push (pred limit)
| Error err -> | Error err ->
Fmt.failwith "error pushing branch %a: %a" Git.Reference.pp t.branch Sync.pp_error err in Fmt.failwith "error pushing branch %a: %a" Git.Reference.pp t.branch Sync.pp_error err ) >>= fun () ->
force_push retries >>= fun () ->
Lwt.wakeup_later wk () ; Lwt.wakeup_later wk () ;
Lwt.return res Lwt.return res