This commit is contained in:
Hannes Mehnert 2022-09-20 13:13:46 +02:00
commit 65c8202565
8 changed files with 145 additions and 0 deletions

0
CHANGES.md Normal file
View file

0
LICENSE.md Normal file
View file

0
README.md Normal file
View file

3
dune-project Normal file
View file

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

0
git-kv.opam Normal file
View file

4
src/dune Normal file
View file

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

125
src/git_kv.ml Normal file
View file

@ -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

13
src/git_kv.mli Normal file
View file

@ -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