This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions

View file

@ -0,0 +1,3 @@
_build/
mirage-kv-mem.install
*/.merlin

View file

@ -0,0 +1,33 @@
### v4.0.1 (2025-10-01)
* Make listing tail-recursive (#7 @Firobe @reynir)
* Add x-maintenance-intent opam field (@hannesm)
### v4.0.0 (2025-02-10)
* Use dune variants and mirage-ptime instead of functorising over PCLOCK
(#6 @hannesm)
### v3.2.1 (2022-12-14)
* Adhere to mirage-kv documented allocate semantics (@hannesm)
### v3.2.0 (2022-12-14)
* upgrade to mirage-kv 6.0.0 interface (#5 @hannesm)
### v3.1.0 (2022-10-27)
* upgrade to mirage-kv 5.0.0 interface (#4 @hannesm)
### v3.0.0 (2019-10-30)
* upgrade to mirage-kv 3.0.0 interface (#3 @hannesm)
### v2.0.0 (2019-02-25)
* released as mirage-kv-mem implementing the mirage-kv 2.0.0 interface
### 0.1.0 (2018-11-12)
* initial release

View file

@ -0,0 +1,3 @@
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.

View file

@ -0,0 +1,2 @@
# mirage-kv-mem
An in-memory key value store implementing the mirage-kv-lwt interface. Not persistent, be careful. :smiley:

View file

@ -0,0 +1,3 @@
(lang dune 1.3)
(name mirage-kv-mem)
(version v4.0.1)

View file

@ -0,0 +1,41 @@
version: "4.0.1"
opam-version: "2.0"
maintainer: [
"Stefanie Schirmer @linse"
"Hannes Mehnert"
]
authors: [
"Stefanie Schirmer @linse"
"Hannes Mehnert"
]
homepage: "https://github.com/mirage/mirage-kv-mem"
doc: "https://mirage.github.io/mirage-kv-mem/"
bug-reports: "https://github.com/mirage/mirage-kv-mem/issues"
dev-repo: "git+https://github.com/mirage/mirage-kv-mem.git"
tags: [ "org:mirage" "org:robur" ]
license: "ISC"
build: [
["dune" "subst"] {dev}
["dune" "build" "-p" name "-j" jobs]
["dune" "runtest" "-p" name "-j" jobs] {with-test}
]
depends: [
"ocaml" {>= "4.08.0"}
"dune" {>= "1.3.0"}
"alcotest" {with-test}
"mirage-ptime" {>= "5.0.0"}
"mirage-kv" {>= "6.0.0"}
"fmt" {>= "0.9.0"}
"ptime" {>= "1.1.0"}
"optint" {>= "0.3.0"}
]
conflicts: [ "result" {< "1.5"} ]
synopsis: "In-memory key value store for MirageOS"
description: """
Implements the mirage-kv interface, but does not provide a persistent data storage.
Use for testing or amnesia.
"""
x-maintenance-intent: [ "(latest)" ]

View file

@ -0,0 +1,4 @@
(library
(name mirage_kv_mem)
(public_name mirage-kv-mem)
(libraries mirage-kv fmt ptime mirage-ptime optint))

View file

@ -0,0 +1,280 @@
type write_error = Mirage_kv.write_error
let pp_write_error = Mirage_kv.pp_write_error
type error = Mirage_kv.error
let pp_error = Mirage_kv.pp_error
module Pure = struct
module M = Map.Make(String)
let ( let* ) = Result.bind
type t =
| Dictionary of Ptime.t * t M.t
| Value of Ptime.t * string
type key = Mirage_kv.Key.t
let empty now () = Dictionary (now, M.empty)
let get_node t key =
let rec find t = function
| [] -> Ok t
| hd::tl -> match t with
| Value _ -> Error (`Dictionary_expected key)
| Dictionary (_, m) ->
match M.find_opt hd m with
| Some t' -> find t' tl
| None -> Error (`Not_found key)
in
find t (Mirage_kv.Key.segments key)
let get t key =
let* v = get_node t key in
match v with
| Dictionary _ -> Error (`Value_expected key)
| Value (_, value) -> Ok value
let size t key =
let* v = get t key in
Ok (Optint.Int63.of_int (String.length v))
let get_partial t key ~offset ~length =
let* v = get t key in
if Int64.of_int (String.length v) < Optint.Int63.to_int64 offset then
Ok ""
else
let off = Optint.Int63.to_int offset in
Ok (String.sub v off (min (String.length v - off) length))
let last_modified t key =
let* v = get_node t key in
match v with
| Dictionary (mtime, _) -> Ok mtime
| Value (mtime, _) -> Ok mtime
let remove t key now =
let rec remove t = function
| [] -> Ok (Dictionary (now, M.empty))
| [x] -> begin match t with
| Value _ -> Error (`Dictionary_expected key)
| Dictionary (_, m) ->
let m' = M.remove x m in
Ok (Dictionary (now, m'))
end
| hd::tl -> match t with
| Value _ -> Error (`Dictionary_expected key)
| Dictionary (mtime, m) ->
let* node =
match M.find_opt hd m with
| None -> Error (`Dictionary_expected key)
| Some t' -> Ok t'
in
let* t' = remove node tl in
let m' = M.add hd t' m in
Ok (Dictionary (mtime, m'))
in
remove t (Mirage_kv.Key.segments key)
(* TODO: replace with normal List.map when support
for OCaml 4.14 is dropped *)
let tailrec_map f = List.filter_map (fun x -> Some (f x))
let list t key =
let* v = get_node t key in
match v with
| Value _ -> Error (`Dictionary_expected key)
| Dictionary (_, m) ->
let name_and_kind (k, v) =
Mirage_kv.Key.add key k,
match v with Value _ -> `Value | Dictionary _ -> `Dictionary
in
Ok (tailrec_map name_and_kind @@ M.bindings m)
let set t key now data =
let value = Value (now, data) in
let rec add t' = function
| [] -> Ok value
| [x] ->
begin match t' with
| Value _ -> Error (`Dictionary_expected key)
| Dictionary (_, m) -> Ok (Dictionary (now, M.add x value m))
end
| hd::tl ->
begin
match t' with
| Value _ -> Error (`Dictionary_expected key)
| Dictionary (mtime, m) ->
let node = match M.find_opt hd m with
| None -> Dictionary (now, M.empty)
| Some t'' -> t''
in
let* t''' = add node tl in
let m' = M.add hd t''' m in
Ok (Dictionary (mtime, m'))
end
in
add t (Mirage_kv.Key.segments key)
let set_partial t key now ~offset data =
match get t key with
| Ok v ->
let off = Optint.Int63.to_int offset in
let v' = String.sub v 0 (min off (String.length v)) in
let v'' =
let start = min (String.length v) (off + String.length data) in
String.sub v start (String.length v - start)
in
set t key now (v' ^ data ^ v'')
| Error (`Not_found _) -> set t key now data
| Error _ as e -> e
let rename t ~source ~dest now =
match get_node t source with
| Error _ as e -> e
| Ok (Value (n, v)) ->
let* t = remove t source now in
begin match get_node t dest with
| Error _ -> set t dest n v
| Ok (Value _) -> set t dest n v
| Ok (Dictionary _) ->
let* last_seg = match List.rev (Mirage_kv.Key.segments source) with
| hd::_ -> Ok hd
| [] -> Error (`Rename_source_prefix (source, dest))
in
set t (Mirage_kv.Key.add dest last_seg) n v
end
| Ok (Dictionary _ as d) ->
let set_dictionary t name =
let rec go t' = function
| [] -> Ok d
| [x] ->
begin match t' with
| Value _ -> Error (`Dictionary_expected name)
| Dictionary (_, m) -> Ok (Dictionary (now, M.add x d m))
end
| hd::tl ->
begin
match t' with
| Value _ -> Error (`Dictionary_expected name)
| Dictionary (mtime, m) ->
let node = match M.find_opt hd m with
| None -> Dictionary (now, M.empty)
| Some t'' -> t''
in
let* t''' = go node tl in
let m' = M.add hd t''' m in
Ok (Dictionary (mtime, m'))
end
in
go t (Mirage_kv.Key.segments name)
in
match get_node t dest with
| Error _ ->
let* t = remove t source now in
set_dictionary t dest
| Ok (Value _) -> Error (`Value_expected source)
| Ok (Dictionary _) ->
let srcstr = Mirage_kv.Key.to_string source in
let dststr = Mirage_kv.Key.to_string dest in
if String.length dststr >= String.length srcstr &&
String.(equal srcstr (String.sub dststr 0 (String.length srcstr)))
then
Error (`Rename_source_prefix (source, dest))
else
let* last_seg =
match List.rev (Mirage_kv.Key.segments source) with
| [] -> Error (`Rename_source_prefix (source, dest))
| last_seg :: _ -> Ok last_seg
in
let* t = remove t source now in
set_dictionary t (Mirage_kv.Key.add dest last_seg)
let pp fmt t =
let rec pp_things ?(prefix = "") () fmt = function
| Value (mtime, v) -> Fmt.pf fmt "Value %s %d (modified %a): %s@."
prefix (String.length v) (Ptime.pp_rfc3339 ()) mtime v
| Dictionary (_, m) ->
List.iter (fun (k, v) ->
pp_things ~prefix:(prefix ^ "/" ^ k) () fmt v)
(M.bindings m)
in
pp_things () fmt t
let rec equal t t' = match t, t' with
| Value (_, v), Value (_, v') -> String.equal v v'
| Dictionary (_, m), Dictionary (_, m') -> M.equal equal m m'
| _ -> false
end
type key = Mirage_kv.Key.t
type t = Pure.t ref * (unit -> Ptime.t)
let connect ?(now = Mirage_ptime.now) () =
Lwt.return (ref (Pure.empty (now ()) ()), now)
let disconnect _t = Lwt.return ()
let last_modified dict key =
Lwt.return @@ Pure.last_modified !(fst dict) key
let digest dict key =
Lwt.return @@ match Pure.get_node !(fst dict) key with
| Ok (Value (_, data)) -> Ok (Digest.string data)
| Ok (Dictionary (mtime, dict)) ->
let data = Fmt.to_to_string Pure.pp (Dictionary (mtime, dict)) in
Ok (Digest.string data)
| Error e -> Error e
let exists dict key =
Lwt.return @@ match Pure.get_node !(fst dict) key with
| Ok (Value _) -> Ok (Some `Value)
| Ok (Dictionary _) -> Ok (Some `Dictionary)
| Error (`Not_found _) -> Ok None
| Error e -> Error e
let get dict key = Lwt.return @@ Pure.get !(fst dict) key
let get_partial dict key ~offset ~length =
Lwt.return @@ Pure.get_partial !(fst dict) key ~offset ~length
let size dict key = Lwt.return @@ Pure.size !(fst dict) key
let remove dict key = Lwt.return @@ match Pure.remove !(fst dict) key ((snd dict) ()) with
| Error e -> Error e
| Ok dict' -> fst dict := dict'; Ok ()
let list dict key = Lwt.return @@ Pure.list !(fst dict) key
let set dict key data = Lwt.return @@ match Pure.set !(fst dict) key ((snd dict) ()) data with
| Error e -> Error e
| Ok dict' -> fst dict := dict'; Ok ()
let set_partial dict key ~offset data =
Lwt.return @@ match Pure.set_partial !(fst dict) key ((snd dict) ()) ~offset data with
| Error e -> Error e
| Ok dict' -> fst dict := dict'; Ok ()
let rename dict ~source ~dest =
Lwt.return @@ match Pure.rename !(fst dict) ~source ~dest ((snd dict) ()) with
| Error e -> Error e
| Ok dict' -> fst dict := dict'; Ok ()
let pp fmt dict = Pure.pp fmt !(fst dict)
let equal a b = Pure.equal !(fst a) !(fst b)
let allocate dict key ?last_modified size =
let open Lwt.Infix in
exists dict key >|= function
| Error _ as e -> e
| Ok Some _ -> Error (`Already_present key)
| Ok None ->
let data = String.make (Optint.Int63.to_int size) '\000' in
let now = Option.value ~default:((snd dict) ()) last_modified in
match Pure.set !(fst dict) key now data with
| Error e -> Error e
| Ok dict' -> fst dict := dict'; Ok ()

View file

@ -0,0 +1,30 @@
type error = Mirage_kv.error
type write_error = Mirage_kv.write_error
module Pure : sig
type t
type key = Mirage_kv.Key.t
val empty : Ptime.t -> unit -> t
val get : t -> key -> (string, error) result
val size : t -> key -> (Optint.Int63.t, error) result
val get_partial : t -> key -> offset:Optint.Int63.t -> length:int -> (string, error) result
val last_modified : t -> key -> (Ptime.t, error) result
val remove : t -> key -> Ptime.t -> (t, write_error) result
val list : t -> key -> ((key * [`Value | `Dictionary]) list, error) result
val set : t -> key -> Ptime.t -> string -> (t, write_error) result
val set_partial : t -> key -> Ptime.t -> offset:Optint.Int63.t -> string -> (t, write_error) result
val rename : t -> source:key -> dest:key -> Ptime.t -> (t, write_error) result
val equal : t -> t -> bool
val pp : t Fmt.t
end
include Mirage_kv.RW
with type write_error := write_error
and type error := error
val connect : ?now:(unit -> Ptime.t) -> unit -> t Lwt.t
val pp : t Fmt.t
val equal : t -> t -> bool

View file

@ -0,0 +1,6 @@
(test
(name test_pure)
(modules test_pure)
(libraries alcotest mirage-kv-mem ptime optint)
(package mirage-kv-mem)
)

View file

@ -0,0 +1,241 @@
module Pure = Mirage_kv_mem.Pure
let compare_t =
let module M = Pure in (module M: Alcotest.TESTABLE with type t = Pure.t)
let we =
let module M = struct
type t = Mirage_kv_mem.write_error
let pp = Mirage_kv_mem.pp_write_error
let equal a b = compare a b = 0
end in
(module M: Alcotest.TESTABLE with type t = M.t)
let compare_write_res = Alcotest.result compare_t we
let e =
let module M = struct
type t = Mirage_kv.error
let pp = Mirage_kv.pp_error
let equal a b = compare a b = 0
end in
(module M: Alcotest.TESTABLE with type t = M.t)
let compare_read_res = Alcotest.result Alcotest.string e
let key_test =
let module M = struct
type t = Mirage_kv.Key.t
let pp = Mirage_kv.Key.pp
let equal = Mirage_kv.Key.equal
end in
(module M: Alcotest.TESTABLE with type t = M.t)
let int63_test =
let module M = struct
type t = Optint.Int63.t
let pp = Optint.Int63.pp
let equal = Optint.Int63.equal
end in
(module M: Alcotest.TESTABLE with type t = M.t)
let now = Ptime.epoch
let bc = "bc"
let neu = "NEU"
let add k v m = match Pure.set m k now v with
| Error _ -> assert false
| Ok m -> m
let empty_m = Pure.empty now ()
let key_of_str = Mirage_kv.Key.v
let key_a = key_of_str "a"
let map = add key_a bc empty_m
let empty () =
let expected = empty_m in
Alcotest.check compare_t "hello" expected (Pure.empty now ())
let read () =
let expected = Ok bc in
Alcotest.check compare_read_res "hello" expected (Pure.get map key_a)
let read_partial () =
Alcotest.check compare_read_res "hello" (Ok "bc")
(Pure.get_partial map key_a ~offset:(Optint.Int63.of_int 0) ~length:2);
Alcotest.check compare_read_res "hello" (Ok "c")
(Pure.get_partial map key_a ~offset:(Optint.Int63.of_int 1) ~length:1);
Alcotest.check compare_read_res "hello" (Ok "b")
(Pure.get_partial map key_a ~offset:(Optint.Int63.of_int 0) ~length:1);
Alcotest.check compare_read_res "hello" (Ok "")
(Pure.get_partial map key_a ~offset:(Optint.Int63.of_int 3) ~length:1);
Alcotest.check compare_read_res "hello" (Ok "c")
(Pure.get_partial map key_a ~offset:(Optint.Int63.of_int 1) ~length:4)
let destroy () =
let expected = empty_m in
Alcotest.check compare_write_res "hello" (Ok expected)
(Pure.remove map key_a now)
type node = [ `Value | `Dictionary ]
let pp_node ppf = function
| `Value -> Fmt.string ppf "value"
| `Dictionary -> Fmt.string ppf "dictionary"
let equal_node a b = match a, b with
| `Value, `Value | `Dictionary, `Dictionary -> true
| _ -> false
let list () =
let map_of_three = add (key_of_str "b") "" (add (key_of_str "c") "" map) in
let expected = Ok [ (key_of_str "a", `Value) ; (key_of_str "b", `Value) ; (key_of_str "c", `Value) ] in
Alcotest.check
Alcotest.(result (slist (pair key_test (testable pp_node equal_node)) compare) e)
"hello" expected (Pure.list map_of_three Mirage_kv.Key.empty)
let write () =
let expected = Ok (add key_a bc empty_m) in
Alcotest.check compare_write_res "hello" expected
(Pure.set empty_m key_a now bc)
let write_partial () =
let expected = Ok (add key_a bc empty_m) in
Alcotest.check compare_write_res __LOC__ expected
(Pure.set_partial empty_m key_a now ~offset:(Optint.Int63.of_int 1) bc);
Alcotest.check compare_write_res __LOC__ expected
(Pure.set_partial empty_m key_a now ~offset:(Optint.Int63.of_int 2) bc);
match Pure.set empty_m key_a now bc with
| Error _ -> Alcotest.fail "unexpected set result"
| Ok m ->
let exp = Ok (add key_a "bbc" empty_m) in
Alcotest.check compare_write_res __LOC__ exp
(Pure.set_partial m key_a now ~offset:(Optint.Int63.of_int 1) bc);
let exp = Ok (add key_a "bcbc" empty_m) in
Alcotest.check compare_write_res __LOC__ exp
(Pure.set_partial m key_a now ~offset:(Optint.Int63.of_int 2) bc);
Alcotest.check compare_write_res __LOC__ exp
(Pure.set_partial m key_a now ~offset:(Optint.Int63.of_int 10) bc)
let write_multiple () =
let expected = Ok (add key_a bc (add (key_of_str "b") bc empty_m)) in
match Pure.set empty_m (key_of_str "b") now bc with
| Ok m -> Alcotest.check compare_write_res "hello" expected
(Pure.set m key_a now bc)
| Error _ -> Alcotest.fail "Unexpected map write result"
let size () =
let size = Pure.size map key_a in
Alcotest.(check (result int63_test e) __LOC__ (Ok (Optint.Int63.of_int 2)) size)
let rename () =
let expected = Ok (add key_a bc empty_m) in
match Pure.set empty_m (key_of_str "b") now bc with
| Ok m -> Alcotest.check compare_write_res "hello" expected
(Pure.rename m ~source:(key_of_str "b") ~dest:key_a now)
| Error _ -> Alcotest.fail "Unexpected map write result"
let rename_replace () =
let expected = Ok (add key_a bc empty_m) in
match Pure.set empty_m (key_of_str "b") now bc with
| Error _ -> Alcotest.fail "Unexpected map write result"
| Ok m ->
match Pure.set m (key_of_str "a") now neu with
| Error _ -> Alcotest.fail "Unexpected map write result"
| Ok m ->
Alcotest.check compare_write_res "hello" expected
(Pure.rename m ~source:(key_of_str "b") ~dest:key_a now)
let rename_value_to_dict () =
let expected =
Ok (add (key_of_str "a/b") bc
(add (key_of_str "a/a") neu empty_m))
in
match Pure.set empty_m (key_of_str "b") now bc with
| Error _ -> Alcotest.fail "Unexpected map write result"
| Ok m ->
match Pure.set m (key_of_str "a/a") now neu with
| Ok m ->
Alcotest.check compare_write_res "hello" expected
(Pure.rename m ~source:(key_of_str "b") ~dest:key_a now)
| Error _ -> Alcotest.fail "Unexpected map write result"
let rename_dict () =
let expected =
Ok (add (key_of_str "b/b") neu
(add (key_of_str "b/a") bc empty_m))
in
match Pure.set empty_m (key_of_str "a/a") now bc with
| Error _ -> Alcotest.fail "Unexpected map write result"
| Ok m ->
match Pure.set m (key_of_str "a/b") now neu with
| Ok m ->
Alcotest.check compare_write_res "hello" expected
(Pure.rename m ~source:(key_of_str "a") ~dest:(key_of_str "b") now)
| Error _ -> Alcotest.fail "Unexpected map write result"
let rename_dict_to_value () =
let expected = Error (`Value_expected (key_of_str "a")) in
match Pure.set empty_m (key_of_str "a/a") now bc with
| Error _ -> Alcotest.fail "Unexpected map write result"
| Ok m ->
match Pure.set m (key_of_str "b") now neu with
| Ok m ->
Alcotest.check compare_write_res "hello" expected
(Pure.rename m ~source:(key_of_str "a") ~dest:(key_of_str "b") now)
| Error _ -> Alcotest.fail "Unexpected map write result"
let rename_dict_to_dict () =
let expected =
Ok (add (key_of_str "b/b") neu
(add (key_of_str "b/a/a") bc empty_m))
in
match Pure.set empty_m (key_of_str "a/a") now bc with
| Error _ -> Alcotest.fail "Unexpected map write result"
| Ok m ->
match Pure.set m (key_of_str "b/b") now neu with
| Ok m ->
Alcotest.check compare_write_res "hello" expected
(Pure.rename m ~source:(key_of_str "a") ~dest:(key_of_str "b") now)
| Error _ -> Alcotest.fail "Unexpected map write result"
let rename_dict_to_subdir () =
let expected = Error (`Rename_source_prefix (key_of_str "a", key_of_str "a/b")) in
match Pure.set empty_m (key_of_str "a/a") now bc with
| Error _ -> Alcotest.fail "Unexpected map write result"
| Ok m ->
match Pure.set m (key_of_str "a/b/b") now bc with
| Error _ -> Alcotest.fail "Unexpected map write result"
| Ok m ->
Alcotest.check compare_write_res "hello" expected
(Pure.rename m ~source:(key_of_str "a") ~dest:(key_of_str "a/b") now)
let tests = [
"create empty key value store", `Quick, empty;
"reading a value", `Quick, read;
"partial reading a value", `Quick, read_partial;
"remove value", `Quick, destroy;
"list entries for dictionary", `Quick, list;
"writing a value", `Quick, write;
"write partial", `Quick, write_partial;
"writing multiple values", `Quick, write_multiple;
"size", `Quick, size;
"rename", `Quick, rename;
"rename replace", `Quick, rename_replace;
"rename value to dict", `Quick, rename_value_to_dict;
"rename dict", `Quick, rename_dict;
"rename dict to value", `Quick, rename_dict_to_value;
"rename dict to dict", `Quick, rename_dict_to_dict;
"rename dict to subdir", `Quick, rename_dict_to_subdir;
]
let tests = [
"tests", tests;
]
let () =
Printexc.record_backtrace true;
Alcotest.run "mirage-kv-mem test" tests