Merge pull request #14 from samoht/rw

New RO and RW signatures

.travis.yml

@@ -6,6 +6,6 @@ env:
   global:
   - PINS="mirage-kv.dev:. mirage-kv-lwt.dev:."
   matrix:
-  - OCAML_VERSION=4.03 PACKAGE="mirage-kv-lwt"
-  - OCAML_VERSION=4.04 PACKAGE="mirage-kv-lwt"
   - OCAML_VERSION=4.05 PACKAGE="mirage-kv-lwt"
+  - OCAML_VERSION=4.06 PACKAGE="mirage-kv-lwt"
+  - OCAML_VERSION=4.07 PACKAGE="mirage-kv-lwt"

lwt/mirage_kv_lwt.ml

@@ -22,4 +22,8 @@
 
 module type RO = Mirage_kv.RO
   with type 'a io = 'a Lwt.t
-   and type page_aligned_buffer = Cstruct.t
+   and type value = string
+
+module type RW = Mirage_kv.RW
+  with type 'a io = 'a Lwt.t
+   and type value = string

mirage-kv.opam

@@ -12,12 +12,14 @@ build: [
   ["dune" "subst"] {pinned}
   ["dune" "build" "-p" name "-j" jobs]
 ]
-
+build-test: [
+  ["dune" "runtest" "-p" name]
+]
 depends: [
-  "ocaml" {>= "4.03.0"}
+  "ocaml" {>= "4.05.0"}
   "dune"     {build}
   "mirage-device" {>= "1.0.0"}
   "fmt"
+  "alcotest" {test}
 ]
-
-synopsis: "MirageOS signatures for key/value devices"
+synopsis: "MirageOS signatures for key/value devices"

src/mirage_kv.ml

@@ -16,18 +16,74 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
-type error = [`Unknown_key of string]
+module Key = struct
+
+  type t = string list
+  (* Store the path as a reverse list to optimise basename and (/)
+     operations *)
+
+  let err_invalid_segment x = Fmt.failwith "%S is not a valid segment" x
+
+  let check_segment x =
+    String.iter (function '/' -> err_invalid_segment x | _ -> ()) x;
+    x
+
+  let empty = []
+  let v s = List.filter ((<>)"") @@ List.rev (String.split_on_char '/' s)
+  let add t v = (check_segment v) :: t
+  let ( / ) = add
+  let append x y = y @ x
+  let ( // ) = append
+  let segments = List.rev
+  let basename = List.hd
+  let parent = List.tl
+  let compare = compare
+  let equal = (=)
+  let pp ppf l = Fmt.pf ppf "/%a" Fmt.(list ~sep:(unit "/") string) (List.rev l)
+  let to_string = Fmt.to_to_string pp
+end
+
+type key = Key.t
+
+type error = [
+  | `Not_found           of key
+  | `Dictionary_expected of key
+  | `Value_expected      of key
+]
 
 let pp_error ppf = function
-  | `Unknown_key k -> Fmt.pf ppf "key %s not present in the store" k
+  | `Not_found k           -> Fmt.pf ppf "Cannot find the key %a" Key.pp k
+  | `Dictionary_expected k ->
+    Fmt.pf ppf "Expecting a dictionary for the key %a" Key.pp k
+  | `Value_expected k      ->
+    Fmt.pf ppf "Expecting a value for the key %a" Key.pp k
 
 module type RO = sig
-  type error = private [> `Unknown_key of string]
+  type nonrec error = private [> error]
   val pp_error: error Fmt.t
   include Mirage_device.S
-  type page_aligned_buffer
-  val read: t -> string -> int64 -> int64 ->
-    (page_aligned_buffer list, error) result io
-  val mem: t -> string -> (bool, error) result io
-  val size: t -> string -> (int64, error) result io
+  type key = Key.t
+  type value
+  val exists: t -> key -> ([`Value | `Dictionary] option, error) result io
+  val get: t -> key -> (value, error) result io
+  val list: t -> key -> ((string * [`Value | `Dictionary]) list, error) result io
+  val last_modified: t -> key -> (int * int64, error) result io
+  val digest: t -> key -> (string, error) result io
+end
+
+type write_error = [ error | `No_space | `Too_many_retries of int ]
+
+let pp_write_error ppf = function
+  | #error as e -> pp_error ppf e
+  | `No_space   -> Fmt.pf ppf "No space left on device"
+  | `Too_many_retries n ->
+    Fmt.pf ppf "Aborting after %d attempts to apply the batch operations." n
+
+module type RW = sig
+  include RO
+  type nonrec write_error = private [> write_error]
+  val pp_write_error: write_error Fmt.t
+  val set: t -> key -> value -> (unit, write_error) result io
+  val remove: t -> key -> (unit, write_error) result io
+  val batch: t -> ?retries:int -> (t -> 'a io) -> 'a io
 end

src/mirage_kv.mli

@@ -22,36 +22,201 @@
 
 (** {1 Mirage_kv} *)
 
-type error = [`Unknown_key of string]
+(** MirageOS key-value stores are nested dictionaries, associating
+   structured {{!Key}keys} to either dictionaries or values. *)
+
+module Key: sig
+
+  (** {1 Structured keys} *)
+
+  type t
+  (** The type for structured keys. *)
+
+  val empty: t
+  (** [empty] is the empty key. It refers to the top-level
+     dictionary. *)
+
+  val v : string -> t
+  (** [v s] is the string [s] as a key. A key ["/foo/bar"] is
+     decomposed into the segments ["foo"] and ["bar"]. The initial
+     ["/"] is always ignored so ["foo/bar"] and ["/foo/bar"] are
+     equal. *)
+
+  val add : t -> string -> t
+  (** [add t s] is the concatenated key [t/s]. Raise
+     [Invalid_argument] if [s] contains ["/"]. *)
+
+  val ( / ) : t -> string -> t
+  (** [t / x] is [add t x]. *)
+
+  val append : t -> t -> t
+  (** [append x y] is the concatenated key [x/y]. *)
+
+  val ( // ) : t -> t -> t
+  (** [x // y] is [append x y]. *)
+
+  val segments : t-> string list
+  (** [segments t] is [t]'s list of segments. *)
+
+  val basename : t -> string
+  (** [basename t] is the last segment of [t]. [basename empty] is
+     the empty string [""]. *)
+
+  val parent : t -> t
+  (** [parent t] is the key without the last segment. [parent empty]
+     is [empty].
+
+      For any [t], the invariant have [parent t / basename t] is [t].
+     *)
+
+  val compare : t-> t -> int
+  (** The comparison function for keys. *)
+
+  val equal : t -> t -> bool
+  (** The equality function for keys. *)
+
+  val pp : t Fmt.t
+  (** The pretty printer for keys. *)
+
+  val to_string: t -> string
+  (** [to_string t] is the string representation of [t]. ["/"] is used
+     as separator between segements and it always starts with
+     ["/"]. *)
+
+end
+
+type key = Key.t
+(** The type for keys. *)
+
+type error = [
+  | `Not_found           of key (** key not found *)
+  | `Dictionary_expected of key (** key does not refer to a dictionary. *)
+  | `Value_expected      of key (** key does not refer to a value. *)
+]
 (** The type for errors. *)
 
 val pp_error: error Fmt.t
 (** [pp_error] is the pretty-printer for errors. *)
 
 module type RO = sig
 
-  type error = private [> `Unknown_key of string]
+  (** {1 Read-only key-value stores} *)
+
+  type nonrec error = private [> error]
   (** The type for errors. *)
 
   val pp_error: error Fmt.t
   (** [pp_error] is the pretty-printer for errors. *)
 
   include Mirage_device.S
 
-  type page_aligned_buffer
-  (** The type for memory buffers.*)
+  type key = Key.t
+  (** The type for keys. *)
+
+  type value
+  (** The type for values. *)
+
+ val exists: t -> key -> ([`Value | `Dictionary] option, error) result io
+ (** [exists t k] is [Some `Value] if [k] is bound to a value in [t],
+    [Some `Dictionary] if [k] is a prefix of a valid key in [t] and
+    [None] if no key with that prefix exists in [t].
+
+     {!exists} answers two questions: does the key exist and is it
+    referring to a value or a dictionary.
+
+     An error occurs when the underlying storage layer fails. *)
+
+ val get: t -> key -> (value, error) result io
+ (** [get t k] is the value bound to [k] in [t].
+
+     The result is [Error (`Value_expected k)] if [k] refers to a
+    dictionary in [t]. *)
+
+  val list: t -> key -> ((string * [`Value | `Dictionary]) list, error) result io
+  (** [list t k] is the list of entries and their types in the
+     dictionary referenced by [k] in [t].
+
+      The result is [Error (`Dictionary_expected k)] if [k] refers to a
+     value in [t]. *)
+
+  val last_modified: t -> key -> (int * int64, error) result io
+  (** [last_modified t k] is the last time the value bound to [k] in
+     [t] has been modified.
+
+      The modification time [(d, ps)] is a span for the signed POSIX
+     picosecond span [d] * 86_400e12 + [ps]. [d] is a signed number of
+     POSIX days and [ps] a number of picoseconds in the range
+     \[[0];[86_399_999_999_999_999L]\].
+
+      When the value bound to [k] is a dictionary, the modification
+     time is the latest modification of all entries in that
+     dictionary. This behaviour is only one level deep and not recursive. *)
+
+  val digest: t -> key -> (string, error) result io
+  (** [digest t k] is the unique digest of the value bound to [k] in
+     [t].
+
+      When the value bound to [k] is a dictionary, the digest is a
+     unique and deterministic digest of its entries. *)
+
+end
+
+type write_error = [
+  | error
+  | `No_space                (** No space left on the device. *)
+  | `Too_many_retries of int (** {!batch} has been trying to commit [n] times
+                                 without success. *)
+]
+
+val pp_write_error: write_error Fmt.t
+(** [pp_write_error] is the pretty-printer for write errors. *)
+
+module type RW = sig
+
+  (** {1 Read-write Stores} *)
+
+  (** There is a trade-off between durability and performance. If you
+     want performance, use the {!batch} operation with a chain of sets
+     and removes. They will be applied on the underlying storage layer
+     all at once. Otherwise {!set} and {!remove} will cause a flush in
+     the underlying storage layer every time, which could degrade
+     performance. *)
+
+  include RO
+
+  type nonrec write_error = private [> write_error]
+  (** The type for write errors. *)
+
+  val pp_write_error: write_error Fmt.t
+  (** The pretty-printer for [pp_write_error]. *)
+
+  val set: t -> key -> value -> (unit, write_error) result io
+  (** [set t k v] replaces the binding [k -> v] in [t].
+
+      Durability is guaranteed unless [set] is run inside an enclosing
+     {!batch} operation, where durability will be guaranteed at the
+     end of the batch. *)
+
+  val remove: t -> key -> (unit, write_error) result io
+  (** [remove t k] removes any binding of [k] in [t]. If [k] was bound
+     to a dictionary, the full dictionary will be removed.
+
+      Durability is guaranteed unless [remove] is run inside an
+     enclosing {!batch} operation, where durability will be guaranteed
+     at the end of the batch. *)
 
-  val read: t -> string -> int64 -> int64 ->
-    (page_aligned_buffer list, error) result io
-  (** [read t key offset length] reads up to [length] bytes from the
-      value associated with [key]. If less data is returned than
-      requested, this indicates the end of the value. *)
+  val batch: t -> ?retries:int -> (t -> 'a io) -> 'a io
+  (** [batch t f] run [f] in batch. Ensure the durability of
+     operations.
 
-  val mem: t -> string -> (bool, error) result io
-  (** [mem t key] returns [true] if a value is set for [key] in [t],
-      and [false] if not so. *)
+      Since a batch is applied at once, the readings inside a batch
+     will return the state before the entire batch. Concurrent
+     operations will not affect other ones executed during the batch.
 
-  val size: t -> string -> (int64, error) result io
-  (** Get the value size. *)
+      Batch applications can fail to apply if other operations are
+     happening concurrently. In case of failure, [f] will run again
+     with the most recent version of [t]. The result is [Error
+     `Too_many_retries] if [f] is run for more then [retries] attemps
+     (default is [13]). *)
 
 end

test/dune

@@ -0,0 +1,4 @@
+(test
+  (name      test)
+  (package   mirage-kv)
+  (libraries mirage-kv alcotest))

test/test.ml

@@ -0,0 +1,50 @@
+open Mirage_kv
+
+let key = Alcotest.testable Key.pp Key.equal
+
+let path_v () =
+  let check s e =  Alcotest.(check string) s e Key.(to_string @@ v s) in
+  check "/foo/bar" "/foo/bar";
+  check "/foo"     "/foo";
+  check "/"        "/";
+  check "foo/bar"  "/foo/bar";
+  check ""         "/"
+
+let path_add () =
+  let check p b exp =
+    let f = p ^ "/" ^ b in
+    let vp = Key.v p in
+    Alcotest.(check string) f exp Key.(to_string @@ vp / b);
+    Alcotest.(check key)    f vp  Key.(parent @@ vp / b);
+    Alcotest.(check string) f b   Key.(basename @@ vp / b)
+  in
+  let check_exn p b =
+    try
+      let _ = Key.(v p / b) in
+      Alcotest.failf "%s is not a valid segment, should fail" b
+    with Failure _ -> ()
+  in
+  check ""         "bar"  "/bar";
+  check "/"        "foo"  "/foo";
+  check "/foo"     "bar"  "/foo/bar";
+  check "/foo/bar" "toto" "/foo/bar/toto";
+  check_exn "" "foo/bar"
+
+let path_append () =
+  let check x y =
+    let f = x ^ "/" ^ y in
+    let vf = Key.v f in
+    Alcotest.(check key)    f vf                Key.(v x // v y);
+    Alcotest.(check string) x Key.(basename vf) Key.(basename @@ v y)
+  in
+  check ""         "/foo/bar";
+  check "/foo"     "bar";
+  check "/foo/bar" "/toto/foox/ko"
+
+let () = Alcotest.run "mirage-kv" [
+    "path", [
+      "Path.v"      , `Quick, path_v;
+      "Path.add_seg", `Quick, path_add;
+      "Path.append" , `Quick, path_append;
+    ]
+  ]