From 6fdede7310a7dd1879df0045091fc9945eb97151 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 4 Nov 2022 10:41:40 +0100 Subject: [PATCH 1/6] M-x whitespace-cleanup --- app/mgit.ml | 2 +- src/git_kv.ml | 34 +++++++++++++++++----------------- src/git_kv.mli | 2 +- 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/app/mgit.ml b/app/mgit.ml index 2400edd..434ca6e 100644 --- a/app/mgit.ml +++ b/app/mgit.ml @@ -54,7 +54,7 @@ let value_of_string str = | () -> Option.get !v | exception _ -> Scanf.sscanf str "%s" (fun str -> v := Some str) ; - Option.get !v + Option.get !v let set ~quiet store key str = let value = value_of_string str in diff --git a/src/git_kv.ml b/src/git_kv.ml index c2656db..c79ff70 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -355,10 +355,10 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct | `Hash_not_found of Digestif.SHA1.t | `Reference_not_found of Git.Reference.t | Mirage_kv.write_error ] - + let pp_error ppf = Mirage_kv.pp_error ppf let disconnect _t = Lwt.return_unit - + let pp_write_error ppf = function | #Mirage_kv.write_error as err -> Mirage_kv.pp_write_error ppf err | `Reference_not_found _ | `Msg _ as err -> Store.pp_error ppf err @@ -376,7 +376,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct >|= Option.get >>= Store.read_exn t.store >>= function | Blob _ -> Lwt.return (Ok (Some `Value)) | Tree _ | Commit _ | Tag _ -> Lwt.return (Ok (Some `Dictionary)) - + let get t key = let open Lwt.Infix in match t.head with @@ -388,7 +388,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct Store.read_exn t.store blob >|= function | Blob b -> Ok (Git.Blob.to_string b) | _ -> Error (`Value_expected key) - + let get_partial t key ~offset ~length = let open Lwt_result.Infix in get t key >|= fun data -> @@ -397,7 +397,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct else let l = min length (String.length data - offset) in String.sub data offset l - + let list t key = let open Lwt.Infix in match t.head with @@ -414,7 +414,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct | `Link -> failwith "Unimplemented link follow") (Store.Value.Tree.to_list t) >|= Result.ok | _ -> Lwt.return (Error (`Dictionary_expected key)) - + let last_modified t key = let open Lwt.Infix in Option.fold @@ -439,23 +439,23 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct Ok (Ptime.(Span.to_d_ps (to_span ts))) | _ -> assert false) t.head - + let digest t key = Option.fold ~none:(Error (`Not_found key)) ~some:(fun x -> Ok (Store.Hash.to_hex x)) t.head |> Lwt.return - + let size t key = let open Lwt_result.Infix in get t key >|= fun data -> String.length data - + let author ~now = { Git.User.name= "Git KV" ; email= "git@mirage.io" ; date= now (), None } - + 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 @@ -496,7 +496,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct let ( >>? ) = Lwt_result.bind let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))) - + let set ?and_commit t key contents = let segs = Mirage_kv.Key.segments key in match segs with @@ -527,18 +527,18 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct 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 | `Reference_not_found ref -> `Reference_not_found ref | `Msg err -> `Msg err | err -> Rresult.R.msgf "%a" 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 - + let set_partial t key ~offset chunk = let open Lwt_result.Infix in get t key >>= fun contents -> @@ -548,7 +548,7 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct Bytes.blit_string contents 0 res 0 len ; Bytes.blit_string chunk 0 res offset add ; set t key (Bytes.unsafe_to_string res) - + let remove ?and_commit t key = let segs = Mirage_kv.Key.segments key in match List.rev segs, t.head with @@ -601,11 +601,11 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct >>? fun () -> Store.shallow t.store hash >|= Result.ok) >>= fun () -> t.head <- Some hash ; Lwt.return_ok () ) | _ -> Lwt.return_ok () - + let remove t key = let open Lwt.Infix in remove ?and_commit:t.committed t key >|= Rresult.R.reword_error to_write_error - + let rename t ~source ~dest = (* TODO(dinosaure): optimize it! It was done on the naive way. *) let open Lwt_result.Infix in diff --git a/src/git_kv.mli b/src/git_kv.mli index 3e8e2ad..454977c 100644 --- a/src/git_kv.mli +++ b/src/git_kv.mli @@ -22,7 +22,7 @@ use the {!val:Make.change_and_push} 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. Only {i un}pushed changes are kept by the KV-store. However, if these changes are not pushed, they will be From 8c7562ea161031d377bd1f514dd12a6b7a94c7ae Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 4 Nov 2022 10:42:30 +0100 Subject: [PATCH 2/6] avoid rresult, use result instead --- app/mgit.ml | 1 - git-kv.opam | 1 + src/dune | 2 +- src/git_kv.ml | 16 ++++++++-------- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/app/mgit.ml b/app/mgit.ml index 434ca6e..8589470 100644 --- a/app/mgit.ml +++ b/app/mgit.ml @@ -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 = diff --git a/git-kv.opam b/git-kv.opam index 2728ea0..095378b 100644 --- a/git-kv.opam +++ b/git-kv.opam @@ -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" diff --git a/src/dune b/src/dune index 2e78a7d..ea051e2 100644 --- a/src/dune +++ b/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)) diff --git a/src/git_kv.ml b/src/git_kv.ml index c79ff70..e4fb57d 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -334,9 +334,9 @@ 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.map_error (Fmt.to_to_string Store.pp_error) >|= + Result.get_ok >>= 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; }) @@ -532,12 +532,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 +604,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. *) @@ -652,8 +652,8 @@ module Make (Pclock : Mirage_clock.PCLOCK) = struct >>? 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 -> + >|= Result.map_error (Fmt.to_to_string Store.pp_error) + >|= Result.get_ok >>= fun res -> Lwt.wakeup_later wk () ; t.committed <- None ; Lwt.return res From 8e14c13ddcb71d7bc70d1d76c30a6f2d11537d7c Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 4 Nov 2022 10:43:27 +0100 Subject: [PATCH 3/6] use Git.Reference.main, avoid msgf binding only used once --- src/git_kv.ml | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/git_kv.ml b/src/git_kv.ml index e4fb57d..d5d4d83 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -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 @@ -492,7 +489,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 ()))) From 45657fdf32fb3eb0d3928a0acba167a92a9b0156 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 4 Nov 2022 10:48:44 +0100 Subject: [PATCH 4/6] change_and_push may return an error, report it --- app/mgit.ml | 2 +- src/git_kv.ml | 81 ++++++++++++++++++++++++++------------------------ src/git_kv.mli | 2 +- 3 files changed, 44 insertions(+), 41 deletions(-) diff --git a/app/mgit.ml b/app/mgit.ml index 8589470..2c3c429 100644 --- a/app/mgit.ml +++ b/app/mgit.ml @@ -140,7 +140,7 @@ let repl store fd_in = | [ "quit"; ] -> Lwt.return () | [ "fold"; ] -> Store.change_and_push store0 (fun store1 -> go store1) - >>= fun () -> go store0 + >>= fun _ -> go store0 | [ "save"; filename ] -> save store0 filename >|= ignore >>= fun _ -> if is_a_tty then Fmt.pr "\n%!" ; go store0 diff --git a/src/git_kv.ml b/src/git_kv.ml index d5d4d83..82618df 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -614,44 +614,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 ) - >|= Result.map_error (Fmt.to_to_string Store.pp_error) - >|= Result.get_ok >>= 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 diff --git a/src/git_kv.mli b/src/git_kv.mli index 454977c..a55712f 100644 --- a/src/git_kv.mli +++ b/src/git_kv.mli @@ -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 From cb37018a8490ceb76be5a95e186eec17d0ce6ce5 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 5 Nov 2022 14:57:55 +0100 Subject: [PATCH 5/6] avoid Result.get_ok, as suggested by @reynir, to preserve the error --- src/git_kv.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/git_kv.ml b/src/git_kv.ml index 82618df..1123f25 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -332,8 +332,7 @@ let of_octets ctx ~remote data = Lwt.catch (fun () -> init_store () >|= - Result.map_error (Fmt.to_to_string Store.pp_error) >|= - Result.get_ok >>= fun 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; }) From ad55d4888e6dfc513a2d41e734dd07ffd5c4b944 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 5 Nov 2022 17:01:33 +0100 Subject: [PATCH 6/6] mgit: print error if change_and_push failed (as suggested by @reynir) --- app/mgit.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/app/mgit.ml b/app/mgit.ml index 2c3c429..4e21606 100644 --- a/app/mgit.ml +++ b/app/mgit.ml @@ -140,7 +140,8 @@ let repl store fd_in = | [ "quit"; ] -> Lwt.return () | [ "fold"; ] -> Store.change_and_push store0 (fun store1 -> go store1) - >>= fun _ -> go store0 + >|= Result.fold ~ok:Fun.id ~error:(function `Msg msg -> Fmt.epr "%s.\n%!" msg) + >>= fun () -> go store0 | [ "save"; filename ] -> save store0 filename >|= ignore >>= fun _ -> if is_a_tty then Fmt.pr "\n%!" ; go store0