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

Be sure to shallow to our last commit after a push from batch

Browse source
This commit is contained in:
Romain Calascibetta 2022-10-28 11:02:49 +02:00
parent d7765ff6aa
commit 5aa887f48f
1 changed files with 9 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
src/git_kv.ml
View file

@ -487,6 +487,8 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
| Sleep -> true | Sleep -> true
| Return _ | Fail _ -> false | Return _ | Fail _ -> false
let ( >>? ) = Lwt_result.bind
let set ~and_push t key contents = let set ~and_push t key contents =
let segs = Mirage_kv.Key.segments key in let segs = Mirage_kv.Key.segments key in
let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))) in let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))) in
@ -510,7 +512,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] 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" >|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing branch %a: %a"
Git.Reference.pp t.branch Sync.pp_error err)) Git.Reference.pp t.branch Sync.pp_error err))
>>= Store.shallow t.store hash >|= Result.ok >>? fun () -> (Store.shallow t.store hash >|= Result.ok)
else Lwt.return_ok ()) >>= fun () -> else Lwt.return_ok ()) >>= fun () ->
t.head <- Some hash ; Lwt.return_ok () t.head <- Some hash ; Lwt.return_ok ()
@ -560,7 +562,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] 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" >|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing branch %a: %a"
Git.Reference.pp t.branch Sync.pp_error err)) Git.Reference.pp t.branch Sync.pp_error err))
>>= Store.shallow t.store hash >|= Result.ok >>? fun () -> Store.shallow t.store hash >|= Result.ok
else Lwt.return_ok ()) >>= fun () -> else Lwt.return_ok ()) >>= fun () ->
t.head <- Some hash ; Lwt.return_ok () t.head <- Some hash ; Lwt.return_ok ()
| name :: pred_name :: rest, Some head -> | name :: pred_name :: rest, Some head ->
@ -583,7 +585,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
Sync.push ~capabilities ~ctx:t.ctx t.edn t.store [ `Update (t.branch, t.branch) ] 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" >|= Result.map_error (fun err -> `Msg (Fmt.str "error pushing branch %a: %a"
Git.Reference.pp t.branch Sync.pp_error err)) Git.Reference.pp t.branch Sync.pp_error err))
>>= Store.shallow t.store hash >|= Result.ok >>? fun () -> Store.shallow t.store hash >|= Result.ok
else Lwt.return_ok ()) >>= fun () -> else Lwt.return_ok ()) >>= fun () ->
t.head <- Some hash ; Lwt.return_ok () t.head <- Some hash ; Lwt.return_ok ()
| _ -> Lwt.return_ok () | _ -> Lwt.return_ok ()
@ -612,7 +614,10 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct
f t >>= fun res -> f t >>= fun res ->
let rec force_push limit = 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 () -> Lwt.return_unit | Ok () ->
( match t.head with
| None -> Lwt.return_unit
| Some hash -> Store.shallow t.store hash )
| Error _ when limit > 0 -> force_push (pred limit) | 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 in