WIP: Lavyek backend

irmin-lavyek.opam

@@ -0,0 +1,32 @@
+opam-version: "2.0"
+maintainer:   "thomas@gazagnaire.org"
+authors:      ["Vincent Balat"]
+license:      "ISC"
+homepage:     "https://github.com/mirage/irmin"
+bug-reports:  "https://github.com/mirage/irmin/issues"
+dev-repo:     "git+https://github.com/mirage/irmin.git"
+doc:          "https://mirage.github.io/irmin/"
+
+build: [
+ ["dune" "subst"] {dev}
+ ["dune" "build" "-p" name "-j" jobs]
+ ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+
+depends: [
+  "ocaml"      {>= "5.1.0"}
+  "dune"       {>= "3.5.0"}
+  "irmin"      {= version}
+  "logs"
+  "lavyek"
+  "eio"        {>= "1.0"}
+  "alcotest"   {with-test}
+  "irmin-test" {with-test & = version}
+]
+
+pin-depends: [
+  [ "irmin-watcher.dev" "git+https://github.com/patricoferris/irmin-watcher#d0e92b4ba5631b5f4dc0f3c00d97e79542dba45d" ]
+]
+
+synopsis: "Generic lavyek backend for Irmin"
+x-maintenance-intent: [ "(latest)" ]

src/irmin-lavyek/conf.ml

@@ -0,0 +1,67 @@
+module Default = struct
+  let fresh = false
+  let sync = false
+end
+
+open Irmin.Backend.Conf
+
+let sw_typ : Eio.Switch.t Typ.t = Typ.create ()
+let fs_typ : Eio.Fs.dir_ty Eio.Path.t Typ.t = Typ.create ()
+let spec = Spec.v "lavyek"
+
+module Key = struct
+  let fresh =
+    key ~spec ~doc:"Start with a fresh disk." "fresh" Irmin.Type.bool
+      Default.fresh
+
+  let root = root spec
+
+  let sync =
+    key ~spec ~doc:"Whether lavyek should sync additions on disk" "use-sync"
+      Irmin.Type.bool Default.sync
+end
+
+let fresh config = get config Key.fresh
+
+let root config =
+  match find_root config with
+  | None ->
+      failwith
+        "unintialised root, call [Irmin_pack.Conf.init root] before opening \
+         the store"
+  | Some root -> root
+
+let sync config = get config Key.sync
+let switch config = find_key config "sw" sw_typ
+let fs config = find_key config "fs" fs_typ
+
+let spec ~sw ~fs =
+  let spec = Spec.copy spec in
+  let _sw_key =
+    let to_string _ = "Eio.Switch.t" in
+    let of_string _ = Ok sw in
+    let of_json_string _ = Ok sw in
+    serialized_key ~typ:sw_typ ~spec ~typename:"Eio.Switch.t" ~to_string
+      ~of_string ~of_json_string "sw" sw
+  in
+  let fs = (fs :> Eio.Fs.dir_ty Eio.Path.t) in
+  let _fs_key =
+    let to_string fs = Eio.Path.native_exn fs in
+    let of_string str = Ok Eio.Path.(fs / str) in
+    let of_json_string str =
+      match Irmin.Type.(of_json_string string) str with
+      | Ok str -> Ok Eio.Path.(fs / str)
+      | Error e -> Error e
+    in
+    serialized_key ~typ:fs_typ ~spec ~typename:"_ Eio.Path.t" ~to_string
+      ~of_string ~of_json_string "fs" fs
+  in
+  spec
+
+let init ~sw ~fs ?(fresh = Default.fresh) ?(sync = Default.sync) root =
+  let root = Eio.Path.native_exn root in
+  let config = empty (spec ~sw ~fs) in
+  let config = add config Key.root root in
+  let config = add config Key.fresh fresh in
+  let config = add config Key.sync sync in
+  verify config

src/irmin-lavyek/conf.mli

@@ -0,0 +1,50 @@
+(*
+ * Copyright (c) 2018-2022 Tarides <contact@tarides.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+val spec : sw:Eio.Switch.t -> fs:_ Eio.Path.t -> Irmin.Backend.Conf.Spec.t
+
+module Key : sig
+  val fresh : bool Irmin.Backend.Conf.key
+  val root : string Irmin.Backend.Conf.key
+  val sync : bool Irmin.Backend.Conf.key
+end
+
+val fresh : Irmin.Backend.Conf.t -> bool
+(** Flag to indicate that the store will start with fresh data on disk. Warning:
+    setting this to [true] will delete existing data. Default is [false]. *)
+
+val root : Irmin.Backend.Conf.t -> string
+(** Location of directory for saving data on disk. *)
+
+val sync : Irmin.Backend.Conf.t -> bool
+(** Flag to indicate that sync should be used to enforce lavyek's flush to disk.
+    Default [false]. *)
+
+val switch : Irmin.Backend.Conf.t -> Eio.Switch.t
+(** Eio switch *)
+
+val fs : Irmin.Backend.Conf.t -> Eio.Fs.dir_ty Eio.Path.t
+(** Eio filesystem *)
+
+val init :
+  sw:Eio.Switch.t ->
+  fs:_ Eio.Path.t ->
+  ?fresh:bool ->
+  ?sync:bool ->
+  Eio.Fs.dir_ty Eio.Path.t ->
+  Irmin.config
+(** [init root] creates a backend configuration for storing data with default
+    configuration parameters and stored at [root]. *)

src/irmin-lavyek/dune

@@ -0,0 +1,6 @@
+(library
+ (name irmin_lavyek)
+ (public_name irmin-lavyek)
+ (libraries irmin logs lavyek)
+ (preprocess
+  (pps ppx_irmin.internal)))

src/irmin-lavyek/import.ml

@@ -0,0 +1,18 @@
+(*
+ * Copyright (c) 2021 Craig Ferguson <craig@tarides.com>
+ * Copyright (c) 2018-2022 Tarides <contact@tarides.com>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+include Irmin.Export_for_backends

src/irmin-lavyek/irmin_lavyek.ml

@@ -0,0 +1,214 @@
+include Irmin.Export_for_backends
+
+let src = Logs.Src.create "irmin.lavyek" ~doc:"Irmin Lavyek store"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+module Conf = Conf
+
+let config = Conf.init
+
+module Read_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct
+  type key = K.t
+  type value = V.t
+  type 'a t = { t : Lavyek.t; config : Irmin.config }
+
+  let create ~sw path =
+    [%log.debug "create store at %s" (Eio.Path.native_exn path)];
+    Lavyek.create ~sw path
+
+  let open_ ~sw path =
+    [%log.debug "opening store at %s" (Eio.Path.native_exn path)];
+    Lavyek.open_out ~sw path
+
+  let v config =
+    let root = Conf.root config in
+    let path = Eio.Path.(Conf.fs config / root) in
+    let sw = Conf.switch config in
+    let fresh = Conf.fresh config in
+    let t = if fresh then create ~sw path else open_ ~sw path in
+    { t; config }
+
+  let close t =
+    [%log.debug "close"];
+    Lavyek.close t.t
+
+  let clear _t =
+    [%log.debug "clear store"];
+    failwith "not implemented list"
+
+  let cast t = (t :> read_write t)
+  let batch t f = f (cast t)
+  let of_bin_string = Irmin.Type.(unstage (of_bin_string V.t))
+  let pp_key = Irmin.Type.pp K.t
+
+  let find t key =
+    [%log.debug "find %a" pp_key key];
+    Option.map
+      (fun v -> Result.get_ok (of_bin_string v))
+      (Lavyek.find t.t ~key:(Repr.to_string K.t key))
+
+  let mem t key =
+    [%log.debug "mem %a" pp_key key];
+    Lavyek.find t.t ~key:(Repr.to_string K.t key) <> None
+end
+
+module Append_only (K : Irmin.Type.S) (V : Irmin.Type.S) = struct
+  include Read_only (K) (V)
+
+  let to_bin_string = Irmin.Type.(unstage (to_bin_string V.t))
+
+  let add t key value =
+    [%log.debug "add %a" pp_key key];
+    let sync = Conf.sync t.config in
+    Lavyek.put t.t ~sync (Repr.to_string K.t key) (to_bin_string value)
+end
+
+module Atomic_write (K : Irmin.Type.S) (V : Irmin.Type.S) = struct
+  module RO = Read_only (K) (V)
+  module W = Irmin.Backend.Watch.Make (K) (V)
+
+  type t = { t : unit RO.t; w : W.t }
+  type key = RO.key
+  type value = RO.value
+  type watch = W.watch
+
+  let watches = W.v ()
+
+  let v config =
+    let t = RO.v config in
+    { t; w = watches }
+
+  let close t =
+    W.clear t.w;
+    RO.close t.t
+
+  let find t = RO.find t.t
+  let mem t = RO.mem t.t
+  let watch_key t = W.watch_key t.w
+  let watch t = W.watch t.w
+  let unwatch t = W.unwatch t.w
+
+  let list t =
+    [%log.debug "list"];
+    let keys, _ = List.split @@ Lavyek.list t.t.t in
+    List.map (fun k -> Result.get_ok @@ Repr.of_string K.t k) keys
+
+  let to_bin_string = Irmin.Type.(unstage (to_bin_string V.t))
+
+  let set t key value =
+    [%log.debug "update %a" RO.pp_key key];
+    let sync = Conf.sync t.t.config in
+
+    Lavyek.put ~sync t.t.t (Repr.to_string K.t key) (to_bin_string value)
+
+  let remove t key =
+    [%log.debug "remove %a" RO.pp_key key];
+    let sync = Conf.sync t.t.config in
+    Lavyek.remove ~sync t.t.t (Repr.to_string K.t key)
+
+  let equal_v_opt = Irmin.Type.(unstage (equal (option V.t)))
+
+  let test_and_set t key ~test ~set:set_value =
+    [%log.debug "test_and_set"];
+    let updated =
+      let v = find t key in
+      if equal_v_opt test v then
+        let () =
+          match set_value with None -> remove t key | Some v -> set t key v
+        in
+        true
+      else false
+    in
+    if updated then W.notify t.w key set_value;
+    updated
+
+  let clear t = RO.clear t.t
+end
+
+module Content_addressable = Irmin.Content_addressable.Make (Append_only)
+
+module Make
+    (CA : Irmin.Content_addressable.Maker)
+    (AW : Irmin.Atomic_write.Maker) =
+struct
+  module type Config = sig
+    val suffix : string
+  end
+
+  module Indexable_store (S : Config) = struct
+    type 'h key = 'h
+
+    module Key = Irmin.Key.Of_hash
+
+    module Make (Hash : Irmin.Hash.S) (Value : Irmin.Type.S) = struct
+      module CA = Irmin.Content_addressable.Check_closed (CA) (Hash) (Value)
+      include Irmin.Indexable.Of_content_addressable (Hash) (CA)
+
+      let v config =
+        let root = Irmin.Backend.Conf.get config Conf.Key.root in
+        let suffix = S.suffix in
+        let config =
+          Irmin.Backend.Conf.add config Conf.Key.root (root ^ "/" ^ suffix)
+        in
+        CA.v config
+    end
+  end
+
+  module Atomic_write (S : Config) (Hash : Irmin.Type.S) (Value : Irmin.Type.S) =
+  struct
+    module AW = Irmin.Atomic_write.Check_closed (AW) (Hash) (Value)
+    include AW
+
+    let v config =
+      let root = Irmin.Backend.Conf.get config Conf.Key.root in
+      let suffix = S.suffix in
+      let config =
+        Irmin.Backend.Conf.add config Conf.Key.root (root ^ "/" ^ suffix)
+      in
+      AW.v config
+  end
+
+  module Maker_args = struct
+    module Contents_store =
+    Irmin.Indexable.Maker_concrete_key2_of_1 (Indexable_store (struct
+      let suffix = "contents"
+    end))
+
+    module Node_store = Indexable_store (struct
+      let suffix = "node"
+    end)
+
+    module Commit_store = Indexable_store (struct
+      let suffix = "commit"
+    end)
+
+    module Branch_store = Atomic_write (struct
+      let suffix = "branch"
+    end)
+  end
+
+  include Irmin.Generic_key.Maker (Maker_args)
+end
+
+module Maker = Make (Content_addressable) (Atomic_write)
+
+module KV_maker
+    (CA : Irmin.Content_addressable.Maker)
+    (AW : Irmin.Atomic_write.Maker) =
+struct
+  type metadata = unit
+  type hash = Irmin.Schema.default_hash
+  type info = Irmin.Info.default
+
+  module Maker = Maker
+  include Maker
+  module Make (C : Irmin.Contents.S) = Maker.Make (Irmin.Schema.KV (C))
+end
+
+module KV = KV_maker (Content_addressable) (Atomic_write)
+
+(* Enforce that {!S} is a sub-type of {!Irmin.Maker}. *)
+module Maker_is_a_maker : Irmin.Maker = Maker
+
+(* Enforce that {!KV} is a sub-type of {!Irmin.KV_maker}. *)
+module KV_is_a_KV : Irmin.KV_maker = KV