initial

dune-project

@@ -0,0 +1,3 @@
+(lang dune 2.6)
+(name git-kv)
+(formatting disabled)

src/dune

@@ -0,0 +1,4 @@
+(library
+  (name git_kv)
+  (public_name git-kv)
+  (libraries git mirage-kv))

src/git_kv.ml

@@ -0,0 +1,125 @@
+
+module Store = Git.Mem.Make(Digestif.SHA1)
+module Sync = Git.Mem.Sync(Store)
+module Search = Git.Search.Make(Digestif.SHA1)(Store)
+module Git_commit = Git.Commit.Make(Store.Hash)
+
+type t = {
+  store : Store.t ;
+  mutable head : Store.hash option ;
+}
+
+let init_store () =
+  let open Lwt.Infix in
+  Store.v (Fpath.v ".") >|= fun r ->
+  Result.map_error
+    (fun e -> `Msg (Fmt.str "error setting up store %a" Store.pp_error e))
+    r
+
+let main = Git.Reference.v "refs/heads/main"
+
+let capabilities =
+  [ `Side_band_64k; `Multi_ack_detailed; `Ofs_delta; `Thin_pack; `Report_status ]
+
+let to_invalid = function
+  | Ok x -> x
+  | Error `Msg m -> invalid_arg m
+
+let split_url s =
+  match String.split_on_char '#' s with
+  | [ edn; branch ] ->
+    Smart_git.Endpoint.of_string edn |> to_invalid,
+    Git.Reference.of_string branch |> to_invalid
+  | _ ->
+    Smart_git.Endpoint.of_string s |> to_invalid, main
+
+let connect ctx endpoint =
+  let open Lwt.Infix in
+  init_store () >>= fun store ->
+  let store = to_invalid store in
+  let edn, branch = split_url endpoint in
+  Sync.fetch ~capabilities ~ctx edn store ~deepen:(`Depth 1) `All >>= fun r ->
+  let data =
+    Result.map_error
+      (fun e -> `Msg (Fmt.str "error fetching: %a" Sync.pp_error e))
+      r |> to_invalid
+  in
+  match data with
+  | None -> Lwt.return { store ; head = None }
+  | Some (_, _) ->
+    Store.Ref.resolve store branch >>= fun r ->
+    let head =
+      Result.map_error
+        (fun e -> `Msg (Fmt.str "error resolving branch %s: %a"
+                          (Git.Reference.to_string branch) Store.pp_error e))
+        r |> to_invalid
+    in
+    Lwt.return { store ; head = Some head }
+
+type error = Mirage_kv.error
+
+let pp_error ppf = Mirage_kv.pp_error ppf
+
+let disconnect _t = Lwt.return_unit
+
+let to_octets t =
+  let open Lwt.Infix in
+  let head = Option.get t.head in
+  Store.read_exn t.store head >|= function
+  | Commit c ->
+    let l = Encore.to_lavoisier Git_commit.format in
+    Encore.Lavoisier.emit_string c l
+  | _ -> assert false
+
+let of_octets data =
+  let open Lwt_result.Infix in
+  let l = Encore.to_angstrom Git_commit.format in
+  Lwt.return
+    (Result.map_error (fun e -> `Msg e)
+       (Angstrom.parse_string ~consume:All l data)) >>= fun head ->
+  let head = Git_commit.tree head in
+  init_store () >|= fun store ->
+  { store ; head = Some head }
+
+type key = Mirage_kv.Key.t
+
+let exists _t _key =
+  (*  Search.find t.store t.head (`Path (Mirage_kv.Key.segments key)) >>= function *)
+  (* ([`Value | `Dictionary] option, error) result Lwt.t *)
+  assert false
+
+let get t key =
+  let open Lwt.Infix in
+  let head = Option.get t.head in
+  Search.find t.store head (`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)
+    | _ -> assert false
+
+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 =
+  (* ((string * [`Value | `Dictionary]) list, error) result Lwt.t *)
+  assert false
+
+let last_modified _t _key =
+  (* (int * int64, error) result Lwt.t *)
+  assert false
+
+let digest t _key =
+  let head = Option.get t.head in
+  Digestif.SHA1.to_hex head
+
+let size t key =
+  let open Lwt_result.Infix in
+  get t key >|= fun data ->
+  String.length data

src/git_kv.mli

@@ -0,0 +1,13 @@
+(* 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. *)
+
+include Mirage_kv.RO
+
+val connect : Mimic.ctx -> string -> t Lwt.t
+
+val to_octets : t -> string Lwt.t
+
+val of_octets : string -> (t, [`Msg of string]) result Lwt.t