This commit is contained in:
parent
aa2ff7b2f0
commit
2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
3
unikernel/duniverse/mirage-kv-mem/.gitignore
vendored
Normal file
3
unikernel/duniverse/mirage-kv-mem/.gitignore
vendored
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
_build/
|
||||
mirage-kv-mem.install
|
||||
*/.merlin
|
||||
33
unikernel/duniverse/mirage-kv-mem/CHANGES.md
Normal file
33
unikernel/duniverse/mirage-kv-mem/CHANGES.md
Normal 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
|
||||
3
unikernel/duniverse/mirage-kv-mem/LICENSE.md
Normal file
3
unikernel/duniverse/mirage-kv-mem/LICENSE.md
Normal 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.
|
||||
2
unikernel/duniverse/mirage-kv-mem/README.md
Normal file
2
unikernel/duniverse/mirage-kv-mem/README.md
Normal 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:
|
||||
3
unikernel/duniverse/mirage-kv-mem/dune-project
Normal file
3
unikernel/duniverse/mirage-kv-mem/dune-project
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
(lang dune 1.3)
|
||||
(name mirage-kv-mem)
|
||||
(version v4.0.1)
|
||||
41
unikernel/duniverse/mirage-kv-mem/mirage-kv-mem.opam
Normal file
41
unikernel/duniverse/mirage-kv-mem/mirage-kv-mem.opam
Normal 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)" ]
|
||||
4
unikernel/duniverse/mirage-kv-mem/src/dune
Normal file
4
unikernel/duniverse/mirage-kv-mem/src/dune
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
(library
|
||||
(name mirage_kv_mem)
|
||||
(public_name mirage-kv-mem)
|
||||
(libraries mirage-kv fmt ptime mirage-ptime optint))
|
||||
280
unikernel/duniverse/mirage-kv-mem/src/mirage_kv_mem.ml
Normal file
280
unikernel/duniverse/mirage-kv-mem/src/mirage_kv_mem.ml
Normal 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 ()
|
||||
30
unikernel/duniverse/mirage-kv-mem/src/mirage_kv_mem.mli
Normal file
30
unikernel/duniverse/mirage-kv-mem/src/mirage_kv_mem.mli
Normal 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
|
||||
6
unikernel/duniverse/mirage-kv-mem/test/dune
Normal file
6
unikernel/duniverse/mirage-kv-mem/test/dune
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
(test
|
||||
(name test_pure)
|
||||
(modules test_pure)
|
||||
(libraries alcotest mirage-kv-mem ptime optint)
|
||||
(package mirage-kv-mem)
|
||||
)
|
||||
241
unikernel/duniverse/mirage-kv-mem/test/test_pure.ml
Normal file
241
unikernel/duniverse/mirage-kv-mem/test/test_pure.ml
Normal 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
|
||||
Loading…
Add table
Add a link
Reference in a new issue