Merge pull request #2047 from metanivek/simple_storage

CHANGES.md

@@ -1,3 +1,14 @@
+## Unreleased
+
+### Added
+
+- **irmin**
+  - Add `Storage` module for creating custom storage layers (#2047, @metanivek)
+
+### Changed
+
+### Fixed
+
 ## 3.4.0 (2022-08-25)
 
 ### Added

examples/custom_storage.ml

@@ -0,0 +1,101 @@
+(*
+ * Copyright (c) 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.
+ *)
+
+open Lwt.Syntax
+
+(** Create a configuration module for our storage. Here we demonstrate a simple
+    configuration for setting the initial size of the hash table. *)
+
+module Hashtbl_config = struct
+  module Conf = Irmin.Backend.Conf
+
+  let spec = Conf.Spec.v "hashtbl"
+  let init_size = Conf.key ~spec "init-size" Irmin.Type.int 8
+  let empty = Conf.empty spec
+end
+
+(** Create a {!Irmin.Storage.Make} functor for our hash table storage. *)
+
+module Hashtbl_storage : Irmin.Storage.Make =
+functor
+  (Key : Irmin.Type.S)
+  (Value : Irmin.Type.S)
+  ->
+  struct
+    module Tbl = Hashtbl.Make (struct
+      type t = Key.t
+
+      let equal a b = Irmin.Type.(unstage (equal Key.t)) a b
+      let hash k = Irmin.Type.(unstage (short_hash Key.t)) k
+    end)
+
+    (** Types *)
+
+    type t = { t : Value.t Tbl.t; l : Mutex.t }
+    type key = Key.t
+    type value = Value.t
+
+    (** Initialisation / Closing *)
+
+    let v config =
+      let init_size = Irmin.Backend.Conf.get config Hashtbl_config.init_size in
+      { t = Tbl.create init_size; l = Mutex.create () } |> Lwt.return
+
+    let close _t = Lwt.return_unit
+
+    (** Operations *)
+
+    let set { t; _ } key value = Tbl.replace t key value |> Lwt.return
+    let mem { t; _ } key = Tbl.mem t key |> Lwt.return
+    let find { t; _ } key = Tbl.find_opt t key |> Lwt.return
+    let keys { t; _ } = Tbl.to_seq_keys t |> List.of_seq |> Lwt.return
+    let remove { t; _ } key = Tbl.remove t key |> Lwt.return
+    let clear { t; _ } = Tbl.clear t |> Lwt.return
+
+    let batch t f =
+      Mutex.lock t.l;
+      let+ x =
+        Lwt.catch
+          (fun () -> f t)
+          (fun exn ->
+            Mutex.unlock t.l;
+            raise exn)
+      in
+      Mutex.unlock t.l;
+      x
+  end
+
+(** Create an Irmin store using our hash table with a specified hash type and
+    content type. Irmin will create one {!Irmin.Content_addressable} store for
+    storing data (keys, content, commits) and one {!Irmin.Atomic_write} store
+    for storing branches. Each store will have its own hash table. *)
+
+module Store =
+  Irmin.Of_storage (Hashtbl_storage) (Irmin.Hash.SHA256) (Irmin.Contents.String)
+
+let config ?(config = Hashtbl_config.empty) ?(init_size = 42) () =
+  Irmin.Backend.Conf.add config Hashtbl_config.init_size init_size
+
+let main () =
+  let* repo = Store.Repo.v (config ()) in
+  let* main = Store.main repo in
+  let info () = Store.Info.v 0L in
+  let key = "Hello" in
+  let* () = Store.set_exn main [ key ] ~info "world!" in
+  let* v = Store.get main [ key ] in
+  Printf.printf "%s, %s" key v |> Lwt.return
+
+let () = Lwt_main.run @@ main ()

examples/dune

@@ -9,6 +9,7 @@
   custom_merge
   push
   custom_graphql
+  custom_storage
   fold
   gc)
  (libraries
@@ -37,7 +38,8 @@
   custom_merge.exe
   custom_graphql.exe
   fold.exe
-  gc.exe))
+  gc.exe
+  custom_storage.exe))
 
 (alias
  (name runtest)

src/irmin/irmin.ml

@@ -224,3 +224,21 @@ let remote_store (type t) (module M : Generic_key.S with type t = t) (t : t) =
 module Metadata = Metadata
 module Json_tree = Store.Json_tree
 module Export_for_backends = Export_for_backends
+module Storage = Storage
+
+module Of_storage (M : Storage.Make) (H : Hash.S) (V : Contents.S) = struct
+  module CA = Storage.Content_addressable (M)
+  module AW = Storage.Atomic_write (M)
+  module Maker = Maker (CA) (AW)
+
+  include Maker.Make (struct
+    module Hash = H
+    module Contents = V
+    module Info = Info.Default
+    module Metadata = Metadata.None
+    module Path = Path.String_list
+    module Branch = Branch.String
+    module Node = Node.Make (Hash) (Path) (Metadata)
+    module Commit = Commit.Make (Hash)
+  end)
+end

src/irmin/irmin.mli

@@ -128,6 +128,7 @@ module Contents = Contents
 module Branch = Branch
 module Node = Node
 module Commit = Commit
+module Key = Key
 
 type remote = Remote.t = ..
 (** The type for remote stores. *)
@@ -155,10 +156,17 @@ module Backend : sig
   module Remote = Remote
 
   module type S = Backend.S
-  (** The complete collection of backend implementations. *)
+  (** The modules that define a complete Irmin backend. Apply an implementation
+      to {!Of_backend} to create an Irmin store. *)
 end
 
-module Key = Key
+module Storage = Storage
+(** [Storage] provides {!Storage.Make} for defining a custom storage layer that
+    can be used to create Irmin stores. Unlike {!Backend.S}, an implementation
+    of {!Storage.Make} is only concerned with storing and retrieving keys and
+    values. It can be used to create stores for {!Backend.S} through something
+    like {!Storage.Content_addressable} or, primarily, with {!Of_storage} to
+    automatically construct an Irmin store. *)
 
 (** {1 High-level Stores}
 
@@ -199,17 +207,16 @@ module Schema = Schema
 (** Store schemas *)
 
 (** [Maker] is the signature exposed by any backend providing {!S}
-    implementations. [M] is the implementation of user-defined metadata, [C] is
-    the one for user-defined contents, [B] is the implementation for branches
-    and [H] is the implementation for object (blobs, trees, commits) hashes. It
-    does not use any native synchronization primitives. *)
+    implementations. {!Maker.Make} is parameterised by {!Schema.S}. It does not
+    use any native synchronization primitives. *)
 module type Maker = sig
   include Store.Maker
   (** @inline *)
 end
 
 (** [KV_maker] is like {!Maker} but where everything except the contents is
-    replaced by sensible default implementations. *)
+    replaced by sensible default implementations. {!KV_maker.Make} is
+    parameterised by {!Contents.S} *)
 module type KV_maker = sig
   include Store.KV_maker
   (** @inline *)
@@ -462,26 +469,34 @@ module Dot (S : Generic_key.S) : Dot.S with type db = S.t
     either a concrete implementation of {!S} or a functor providing {!S} once
     applied.
 
-    There are two ways to create a concrete {!Irmin.S} implementation:
+    Ways to create a concrete {!Irmin.S} implementation:
 
-    - {!Make} creates a store where all the objects are stored in the same
-      store, using the same internal keys format and a custom binary format
-      based on {{:https://github.com/janestreet/bin_prot} bin_prot}, with no
-      native synchronization primitives: it is usually what is needed to quickly
-      create a new backend.
-    - {!Make_ext} creates a store with a {e deep} embedding of each of the
-      internal stores into separate store, with total control over the binary
-      format and using the native synchronization protocols when available. *)
+    - Define a {!Storage.Make} for a custom storage layer and apply to
+      {!Of_storage} along with desired {!Hash.S} and {!Contents.S}.
+    - Define a {!Backend.S} and apply to {!Of_backend}.
+    - Define a {!Content_addressable.Maker} for an object store and a
+      {!Atomic_write.Maker} for a reference store. Apply to {!module-Maker} and
+      call {!Maker.Make} with a defined {!Schema.S} or apply to
+      {!module-KV_maker} and call {!KV_maker.Make} with the desired
+      {!Contents.S}. *)
 
-(** Simple store creator. Use the same type of all of the internal keys and
-    store all the values in the same store. *)
+(** [Maker] uses the same type for all internal keys and store all the values in
+    the same store. *)
 module Maker (CA : Content_addressable.Maker) (AW : Atomic_write.Maker) :
   Maker with type endpoint = unit
 
+(** [KV_maker] is like {!module-Maker} but uses sensible default implementations
+    for everything except the contents type. *)
 module KV_maker (CA : Content_addressable.Maker) (AW : Atomic_write.Maker) :
   KV_maker with type endpoint = unit and type metadata = unit
 
-(** Advanced store creator. *)
+(** [Of_storage] uses a custom storage layer and chosen hash and contents type
+    to create a key-value store. *)
+module Of_storage (M : Storage.Make) (H : Hash.S) (V : Contents.S) :
+  KV with type hash = H.t and module Schema.Contents = V
+
+(** [Of_backend] gives full control over store creation through definining a
+    {!Backend.S}. *)
 module Of_backend (B : Backend.S) :
   Generic_key.S
     with module Schema = B.Schema