diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b513267 --- /dev/null +++ b/.gitignore @@ -0,0 +1,11 @@ +_build +setup.data +setup.log +doc/*.html +*.native +*.byte +*.so +*.tar.gz +_tests +*.merlin +*.install diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000..a226ec0 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,17 @@ +version=0.23.0 +profile=conventional +break-struct=natural +break-infix=fit-or-vertical +break-sequences=false +break-collection-expressions=wrap +break-separators=before +exp-grouping=preserve +parens-tuple=multi-line-only +space-around-lists=false +space-around-records=false +space-around-arrays=false +break-fun-decl=smart +cases-exp-indent=2 +sequence-style=before +field-space=tight +break-before-in=auto diff --git a/app/dune b/app/dune index b9f9715..a9e2399 100644 --- a/app/dune +++ b/app/dune @@ -1,4 +1,4 @@ (executable (name mgit) (public_name mgit) - (libraries logs.fmt fmt.tty git-unix git-kv)) + (libraries mirage-clock-unix logs.fmt fmt.tty git-unix git-kv)) diff --git a/app/mgit.ml b/app/mgit.ml index 792768d..2f20408 100644 --- a/app/mgit.ml +++ b/app/mgit.ml @@ -1,4 +1,5 @@ let () = Printexc.record_backtrace true +module Store = Git_kv.Make (Pclock) let reporter ppf = let report src level ~over k msgf = @@ -25,17 +26,17 @@ open Rresult open Lwt.Infix let get ~quiet store key = - Git_kv.get store key >>= function + Store.get store key >>= function | Ok contents when not quiet -> Fmt.pr "@[%a@]\n%!" (Hxd_string.pp Hxd.default) contents ; Lwt.return (Ok 0) | Ok _ -> Lwt.return (Ok 0) | Error err -> - if not quiet then Fmt.epr "%a.\n%!" Git_kv.pp_error err ; + if not quiet then Fmt.epr "%a.\n%!" Store.pp_error err ; Lwt.return (Ok 1) let list ~quiet store key = - Git_kv.list store key >>= function + Store.list store key >>= function | Ok lst when not quiet -> List.iter (fun (name, k) -> match k with | `Dictionary -> Fmt.pr "d %s\n%!" name @@ -43,7 +44,7 @@ let list ~quiet store key = Lwt.return (Ok 0) | Ok _ -> Lwt.return (Ok 0) | Error err -> - if not quiet then Fmt.epr "%a.\n%!" Git_kv.pp_error err ; + if not quiet then Fmt.epr "%a.\n%!" Store.pp_error err ; Lwt.return (Ok 1) let pull ~quiet store = diff --git a/git-kv.opam b/git-kv.opam index 6e15412..addbe73 100644 --- a/git-kv.opam +++ b/git-kv.opam @@ -7,11 +7,13 @@ bug-reports: "https://git.robur.io/robur/git-kv" synopsis: "A Mirage_kv implementation using git" depends: [ - "ocaml" {>= "4.08.0"} - "dune" {>= "2.0.0"} - "git" {>= "3.9.0"} - "mirage-kv" {>= "4.0.0"} + "ocaml" {>= "4.08.0"} + "dune" {>= "2.0.0"} + "git" {>= "3.9.0"} + "mirage-kv" {>= "4.0.0"} "git-unix" + "mirage-clock-unix" + "mirage-clock" "ptime" ] diff --git a/src/dune b/src/dune index 2989d2f..2e78a7d 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-kv)) + (libraries git ptime mirage-clock mirage-kv)) diff --git a/src/git_kv.ml b/src/git_kv.ml index c4ce12a..06e0e5f 100644 --- a/src/git_kv.ml +++ b/src/git_kv.ml @@ -116,21 +116,6 @@ type change = [ | `Change of key ] -type error = Mirage_kv.error -type write_error = [ `Msg of string - | `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 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 - | `Hash_not_found hash -> Store.pp_error ppf (`Not_found hash) - -let disconnect _t = Lwt.return_unit - module SHA1 = struct include Digestif.SHA1 @@ -356,218 +341,240 @@ let of_octets ctx ~remote data = (Printexc.raw_backtrace_to_string (Printexc.get_raw_backtrace ())) ; Lwt.return_error (`Msg "Invalid PACK file")) -let exists t key = - let open Lwt.Infix in - match t.head with - | None -> Lwt.return (Ok None) - | Some head -> - Search.mem t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function - | false -> Lwt.return (Ok None) - | true -> - Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) - >|= Option.get >>= Store.read_exn t.store >>= function - | Blob _ -> Lwt.return (Ok (Some `Value)) - | Tree _ | Commit _ | Tag _ -> Lwt.return (Ok (Some `Dictionary)) +module Make (Pclock : Mirage_clock.PCLOCK) = struct + type nonrec t = t + type key = Mirage_kv.Key.t -let get t key = - let open Lwt.Infix in - match t.head with - | None -> Lwt.return (Error (`Not_found key)) - | Some head -> - Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function - | None -> Lwt.return (Error (`Not_found key)) - | Some blob -> - Store.read_exn t.store blob >|= function - | Blob b -> Ok (Git.Blob.to_string b) - | _ -> Error (`Value_expected key) + type error = Mirage_kv.error + type write_error = [ `Msg of string + | `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 + | `Hash_not_found hash -> Store.pp_error ppf (`Not_found hash) -let get_partial t key ~offset ~length = - let open Lwt_result.Infix in - get t key >|= fun data -> - if String.length data < offset then - "" - 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 - | None -> Lwt.return (Error (`Not_found key)) - | Some head -> - Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function - | None -> Lwt.return (Error (`Not_found key)) - | Some tree -> - Store.read_exn t.store tree >>= function - | Tree t -> - Lwt_list.map_p (fun { Git.Tree.perm; name; _ } -> match perm with - | `Commit | `Dir -> Lwt.return (name, `Dictionary) - | `Everybody | `Exec | `Normal -> Lwt.return (name, `Value) - | `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 - ~none:(Lwt.return (Error (`Not_found key))) - ~some:(fun head -> - Store.read_exn t.store head >|= function - | Commit c -> - let author = Git_commit.author c in - let secs, tz_offset = author.Git.User.date in - let secs = - Option.fold ~none:secs - ~some:(fun { Git.User.sign ; hours ; minutes } -> - let tz_off = Int64.(mul (add (mul (of_int hours) 60L) (of_int minutes)) 60L) in - match sign with - | `Plus -> Int64.(sub secs tz_off) - | `Minus -> Int64.(add secs tz_off)) - tz_offset - in - let ts = - Option.fold ~none:Ptime.epoch ~some:Fun.id (Ptime.of_float_s (Int64.to_float secs)) - in - 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 ?head (pred_name, pred_hash) rpath = - let open Lwt.Infix in - let ( >>? ) = Lwt_result.bind in - let ( >>! ) x f = match x with - | Some x -> f x - | None -> Lwt.return_none in - match rpath with - | [] -> - ( match head with - | None -> - let tree = Git.Tree.(v [ entry ~name:pred_name `Dir pred_hash ]) in - Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> Lwt.return_ok hash + let exists t key = + let open Lwt.Infix in + match t.head with + | None -> Lwt.return (Ok None) | Some head -> - Search.find t.store head (`Commit (`Path [])) >|= Option.get >>= fun tree_root_hash -> - ( Store.read_exn t.store tree_root_hash >>= function - | Git.Value.Tree tree -> - let tree = Git.Tree.(add (entry ~name:pred_name `Dir pred_hash) (remove ~name:pred_name tree)) in + Search.mem t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function + | false -> Lwt.return (Ok None) + | true -> + Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) + >|= 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 + | None -> Lwt.return (Error (`Not_found key)) + | Some head -> + Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function + | None -> Lwt.return (Error (`Not_found key)) + | Some blob -> + 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 -> + if String.length data < offset then + "" + 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 + | None -> Lwt.return (Error (`Not_found key)) + | Some head -> + Search.find t.store head (`Commit (`Path (Mirage_kv.Key.segments key))) >>= function + | None -> Lwt.return (Error (`Not_found key)) + | Some tree -> + Store.read_exn t.store tree >>= function + | Tree t -> + Lwt_list.map_p (fun { Git.Tree.perm; name; _ } -> match perm with + | `Commit | `Dir -> Lwt.return (name, `Dictionary) + | `Everybody | `Exec | `Normal -> Lwt.return (name, `Value) + | `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 + ~none:(Lwt.return (Error (`Not_found key))) + ~some:(fun head -> + Store.read_exn t.store head >|= function + | Commit c -> + let author = Git_commit.author c in + let secs, tz_offset = author.Git.User.date in + let secs = + Option.fold ~none:secs + ~some:(fun { Git.User.sign ; hours ; minutes } -> + let tz_off = Int64.(mul (add (mul (of_int hours) 60L) (of_int minutes)) 60L) in + match sign with + | `Plus -> Int64.(sub secs tz_off) + | `Minus -> Int64.(add secs tz_off)) + tz_offset + in + let ts = + Option.fold ~none:Ptime.epoch ~some:Fun.id (Ptime.of_float_s (Int64.to_float secs)) + in + 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 ?head (pred_name, pred_hash) rpath = + let open Lwt.Infix in + let ( >>? ) = Lwt_result.bind in + let ( >>! ) x f = match x with + | Some x -> f x + | None -> Lwt.return_none in + match rpath with + | [] -> + ( match head with + | None -> + let tree = Git.Tree.(v [ entry ~name:pred_name `Dir pred_hash ]) in Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> Lwt.return_ok hash - | _ -> assert false ) ) - | name :: rest -> - (head >>! fun head -> Search.find t.store head (`Commit (`Path (List.rev rpath)))) >>= function - | None -> - let tree = Git.Tree.(v [ entry ~name:pred_name `Dir pred_hash ]) in - Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> - unroll_tree t ?head (name, hash) rest - | Some tree_hash -> - ( Store.read_exn t.store tree_hash >>= function - | Git.Value.Tree tree -> - let tree = Git.Tree.(add (entry ~name:pred_name `Dir pred_hash) (remove ~name:pred_name tree)) in + | Some head -> + Search.find t.store head (`Commit (`Path [])) >|= Option.get >>= fun tree_root_hash -> + ( Store.read_exn t.store tree_root_hash >>= function + | Git.Value.Tree tree -> + let tree = Git.Tree.(add (entry ~name:pred_name `Dir pred_hash) (remove ~name:pred_name tree)) in + Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> Lwt.return_ok hash + | _ -> assert false ) ) + | name :: rest -> + (head >>! fun head -> Search.find t.store head (`Commit (`Path (List.rev rpath)))) >>= function + | None -> + let tree = Git.Tree.(v [ entry ~name:pred_name `Dir pred_hash ]) in Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> unroll_tree t ?head (name, hash) rest - | _ -> assert false ) - -let set t key contents = - let segs = Mirage_kv.Key.segments key in - let now () = 0L (* TODO(dinosaure): functorize? *) in - match segs with - | [] -> assert false - | path -> - let blob = Git.Blob.of_string contents in - let rpath = List.rev path in - let name = List.hd rpath in - let open Lwt_result.Infix in - Store.write t.store (Git.Value.Blob blob) >>= fun (hash, _) -> - unroll_tree t ?head:t.head (name, hash) (List.tl rpath) >>= fun tree_root_hash -> - let committer = author ~now in - let author = author ~now in - let parents = Option.value ~default:[] (Option.map (fun head -> [ head ]) t.head) 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 ; 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 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 -> - let len = String.length contents in - let add = String.length chunk in - let res = Bytes.make (max len (offset + add)) '\000' in - 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 batch t ?retries:_ f = f t - -let remove t key = - let segs = Mirage_kv.Key.segments key in - let now () = 0L (* TODO(dinosaure): functorize? *) in - match List.rev segs, t.head with - | [], _ -> assert false - | _, None -> Lwt.return_ok () (* XXX(dinosaure): or [`Not_found]? *) - | name :: [], Some head -> + | Some tree_hash -> + ( Store.read_exn t.store tree_hash >>= function + | Git.Value.Tree tree -> + let tree = Git.Tree.(add (entry ~name:pred_name `Dir pred_hash) (remove ~name:pred_name tree)) in + Store.write t.store (Git.Value.Tree tree) >>? fun (hash, _) -> + unroll_tree t ?head (name, hash) rest + | _ -> assert false ) + + let set t key contents = + let segs = Mirage_kv.Key.segments key in + let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))) in + match segs with + | [] -> assert false + | path -> + let blob = Git.Blob.of_string contents in + let rpath = List.rev path in + let name = List.hd rpath in + let open Lwt_result.Infix in + Store.write t.store (Git.Value.Blob blob) >>= fun (hash, _) -> + unroll_tree t ?head:t.head (name, hash) (List.tl rpath) >>= fun tree_root_hash -> + let committer = author ~now in + let author = author ~now in + let parents = Option.value ~default:[] (Option.map (fun head -> [ head ]) t.head) 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, _) -> + Lwt.Infix.(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 - Search.find t.store head (`Commit (`Path [])) >|= Option.get >>= fun tree_root_hash -> - Store.read_exn t.store tree_root_hash >>= fun tree_root -> - let[@warning "-8"] Git.Value.Tree tree_root = tree_root in - let tree_root = Git.Tree.remove ~name tree_root in + set t key contents >|= Rresult.R.reword_error to_write_error + + let set_partial t key ~offset chunk = let open Lwt_result.Infix in - Store.write t.store (Git.Value.Tree tree_root) >>= fun (tree_root_hash, _) -> - let committer = author ~now in - let author = author ~now in - let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer - ~parents:[ head ] (Some "Committed by git-kv") in - Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> - t.head <- Some hash ; Lwt.return_ok () - | name :: pred_name :: rest, Some head -> + get t key >>= fun contents -> + let len = String.length contents in + let add = String.length chunk in + let res = Bytes.make (max len (offset + add)) '\000' in + 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 batch t ?retries:_ f = f t + + let remove t key = + let segs = Mirage_kv.Key.segments key in + let now () = Int64.of_float (Ptime.to_float_s (Ptime.v (Pclock.now_d_ps ()))) in + match List.rev segs, t.head with + | [], _ -> assert false + | _, None -> Lwt.return_ok () (* XXX(dinosaure): or [`Not_found]? *) + | name :: [], Some head -> + let open Lwt.Infix in + Search.find t.store head (`Commit (`Path [])) >|= Option.get >>= fun tree_root_hash -> + Store.read_exn t.store tree_root_hash >>= fun tree_root -> + let[@warning "-8"] Git.Value.Tree tree_root = tree_root in + let tree_root = Git.Tree.remove ~name tree_root in + let open Lwt_result.Infix in + Store.write t.store (Git.Value.Tree tree_root) >>= fun (tree_root_hash, _) -> + let committer = author ~now in + let author = author ~now in + let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer + ~parents:[ head ] (Some "Committed by git-kv") in + Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> + Lwt.Infix.(Store.shallow t.store hash >|= Result.ok) >>= fun () -> + t.head <- Some hash ; Lwt.return_ok () + | name :: pred_name :: rest, Some head -> + let open Lwt.Infix in + Search.find t.store head (`Commit (`Path (List.rev (pred_name :: rest)))) >>= function + | None -> Lwt.return_ok () + | Some hash -> Store.read_exn t.store hash >>= function + | Git.Value.Tree tree -> + let tree = Git.Tree.remove ~name tree in + let open Lwt_result.Infix in + Store.write t.store (Git.Value.Tree tree) >>= fun (pred_hash, _) -> + unroll_tree t ~head (pred_name, pred_hash) rest >>= fun tree_root_hash -> + let committer = author ~now in + let author = author ~now in + let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer + ~parents:[ head ] (Some "Committed by git-kv") in + Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> + Lwt.Infix.(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 - Search.find t.store head (`Commit (`Path (List.rev (pred_name :: rest)))) >>= function - | None -> Lwt.return_ok () - | Some hash -> Store.read_exn t.store hash >>= function - | Git.Value.Tree tree -> - let tree = Git.Tree.remove ~name tree in - let open Lwt_result.Infix in - Store.write t.store (Git.Value.Tree tree) >>= fun (pred_hash, _) -> - unroll_tree t ~head (pred_name, pred_hash) rest >>= fun tree_root_hash -> - let committer = author ~now in - let author = author ~now in - let commit = Store.Value.Commit.make ~tree:tree_root_hash ~author ~committer - ~parents:[ head ] (Some "Committed by git-kv") in - Store.write t.store (Git.Value.Commit commit) >>= fun (hash, _) -> - t.head <- Some hash ; Lwt.return_ok () - | _ -> Lwt.return_ok () - -let remove t key = - let open Lwt.Infix in - remove 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 - get t source >>= fun contents -> - remove t source >>= fun () -> - set t dest contents + remove 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 + get t source >>= fun contents -> + remove t source >>= fun () -> + set t dest contents +end diff --git a/src/git_kv.mli b/src/git_kv.mli index 8bc0b36..dd731d9 100644 --- a/src/git_kv.mli +++ b/src/git_kv.mli @@ -1,26 +1,73 @@ -(* The idea is to provide a Mirage_kv.RW interface that is backed by a git - repository. The git repository is always (manually) kept in sync with the - remote one: either this is the only writer (and thus only set/remove - operations need to be pushed, or the API client receives a callback that - some update was done, and proceeds with a pull. *) +(** {1: A Git key-value store.} -include Mirage_kv.RW - with type write_error = [ `Msg of string - | `Hash_not_found of Digestif.SHA1.t - | `Reference_not_found of Git.Reference.t - | Mirage_kv.write_error ] + This module implements the ability to manipulate a Git repository as a + Key-Value store. It allows you to create a local (in-memory) Git repository + that can come from either: + - a remote Git repository + - a state serialized by the {!val:to_octets} function + + The first case is interesting if you want to be synchronised with the + remote repository. The second case can be interesting if we {b don't} want + to create a connection at the beginning and desynchronisation between our + local and remote repositories {b is not} a problem. + + In the second case, the synchronisation can be done later with {!val:pull}. + + As far as {!val:push} is concerned, a synchronisation with the remote + repository is necessary before {b changing} and sending the new information + (a use of {!val:Make.set}/{!val:Make.rename} should be preceded by a + {!val:pull}). This is because we do not handle conflicts that may exist + between your local repository and the remote repository - in other words, + if you want to ensure consistency between reading ({!val:pull}) and writing + ({!val:push}) to a remote repository, the instance that uses this code + should be the only one to handle said remote repository. *) + +type t +(** The type of the Git store. *) val connect : Mimic.ctx -> string -> t Lwt.t +(** [connect ctx remote] creates a new Git store which synchronizes + with [remote] {i via} protocols available into the given [ctx]. + + @raise [Invalid_argument _] if we can not initialize the store, or if + we can not fetch the given [remote]. *) val to_octets : t -> string Lwt.t +(** [to_octets store] returns a serialized version of the given [store]. *) val of_octets : Mimic.ctx -> remote:string -> string -> (t, [> `Msg of string]) result Lwt.t +(** [of_octets ctx ~remote contents] tries to re-create a {!type:t} from its + serialized version [contents]. This function does not do I/O and the + returned {!type:t} can be out of sync with the given [remote]. We advise + to call {!val:pull} to be in-sync with [remote]. *) -type change = [ `Add of key - | `Remove of key - | `Change of key ] +type change = [ `Add of Mirage_kv.Key.t + | `Remove of Mirage_kv.Key.t + | `Change of Mirage_kv.Key.t ] val pull : t -> (change list, [> `Msg of string ]) result Lwt.t +(** [pull store] tries to synchronize the remote Git repository with your local + [store] Git repository. It returns a list of changes between the old state + of your store and what you have remotely. *) + val push : t -> (unit, [> `Msg of string ]) result Lwt.t -val size : t -> key -> (int, error) result Lwt.t +(** [push store] tries to push any changes from your local Git repository + [store] to the remoe Git repository. The [push] function can fails for many + reasons. Currently, we don't handle merge politics and how we can resolve + conflicts between local and remote Git repositories. That mostly means that + if you are the only one who push to the Git repository (into a specific + branch), everything should be fine. But, if someone else push into the same + remote Git repository, your change can be discarded by the remote server + (due to conflicts). *) + +module Make (Pclock : Mirage_clock.PCLOCK) : sig + include Mirage_kv.RW + with type t = t + and type write_error = [ `Msg of string + | `Hash_not_found of Digestif.SHA1.t + | `Reference_not_found of Git.Reference.t + | Mirage_kv.write_error ] + + val size : t -> key -> (int, error) result Lwt.t +end