├── .gitignore ├── .ocamlformat ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── Makefile ├── README.md ├── dune-project ├── mirage-kv-unix.opam ├── src ├── dune ├── mirage_kv_unix.ml └── mirage_kv_unix.mli └── test ├── dune ├── test_directory ├── a_directory │ └── empty ├── big_file ├── content └── empty └── test_kv_unix.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | .*.swp 3 | *.cmo 4 | *.cma 5 | *.cmi 6 | *.a 7 | *.o 8 | *.cmx 9 | *.cmxs 10 | *.cmxa 11 | *.cmt 12 | _build 13 | test/*.output 14 | test/test_directory/*-[0-9]* 15 | *.native 16 | *.install 17 | *~ 18 | .merlin -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.26.1 2 | profile = conventional 3 | break-infix = fit-or-vertical 4 | parse-docstrings = true 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | sudo: false 7 | env: 8 | global: 9 | - PACKAGE="mirage-kv-unix" 10 | - TESTS="true" 11 | - DISTRO=alpine 12 | matrix: 13 | - OCAML_VERSION=4.06 14 | - OCAML_VERSION=4.07 15 | - OCAML_VERSION=4.08 16 | - OCAML_VERSION=4.09 17 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## v3.0.1 (2024-04-17) 2 | 3 | * Remove extra debugging statement (#8, @samoht) 4 | * Adress reviews from @reynir (#7, @samoht and @reynir) 5 | - Fail when keys contain '.' and '..' to match other `mirage-kv-*` 6 | implementations 7 | - Use failwith instead of Lwt.failwith 8 | - Use Lwt.reraise instead of Lwt.fail (requires lwt>=5.7) 9 | - `digest` on directories now return an error (requires mirage-kv>=6.1.1) 10 | - `set_partial` on directories return an error while `set` on directories work 11 | (and remove the directory) 12 | - fix fd leak in `set` and `set_partial` 13 | 14 | ## v3.0.0 (2024-04-16) 15 | 16 | * Update to mirage-kv>6 (#5, @samoht) 17 | 18 | ## v2.1.0 (2019-10-30) 19 | 20 | * adapt to mirage-kv 3.0.0 interface (#2 @hannesm) 21 | 22 | ## v2.0.0 (2019-02-25) 23 | 24 | * renamed to mirage-kv-unix 25 | * implementing the mirage-kv-lwt 2.0.0 interface 26 | 27 | ## v1.6.0 (2019-02-02) 28 | 29 | * upgrade to dune from jbuilder (@avsm) 30 | * test OCaml 4.07 as well (@avsm) 31 | * use latest cstruct-lwt package name (@avsm) 32 | 33 | ## v1.5.0 (2018-11-09) 34 | 35 | * fix `FS_unix.destroy` semantics: when given a directory, delete it 36 | * remove `open Result` 37 | 38 | ## v1.4.1 (2017-12-16) 39 | 40 | * fix compilation with safe-string 41 | 42 | ## v1.4.0 (2017-05-26) 43 | 44 | * Port to [Jbuilder](https://github.com/janestreet/jbuilder) for build. 45 | 46 | ## v1.3.0 (2017-02-16) 47 | 48 | * Port to MirageOS 3 interfaces. 49 | * Improve Travis CI distribution coverage for tests. 50 | 51 | ## v1.2.1 (2016-08-16) 52 | 53 | * Remove use of `lwt.syntax`. (#20, by @yomimono) 54 | * Remove unused `id` type. (#19, by @talex5) 55 | 56 | ## v1.2.0 (2015-07-22) 57 | 58 | * Remove the use of unescaped `Sys.command` (#12, by @hannesm) 59 | * Add tests for read, write, mkdir, size; make them pass (#10, by @yomimono) 60 | 61 | ## v1.1.4 (2015-03-08) 62 | 63 | * Add explicit `connect` signature into interface (#8). 64 | * Add an `opam` file for OPAM 1.2 pinning workflow. 65 | * Add Travis CI unit test file. 66 | 67 | ## v1.1.3 (2014-10-16) 68 | 69 | * Fix `FS_unix.create` and `FS_unix.write` 70 | 71 | ## v1.1.2 (2014-09-11) 72 | 73 | * Fix quadratic behavior (#5) 74 | 75 | ## v1.1.1 (2014-07-21) 76 | 77 | * Prohibit directory traversal outside of exposed base directory 78 | * Parent of base directory is base directory (/../ -> /) 79 | 80 | ## v1.1.0 (2014-06-09) 81 | 82 | * Add an `FS_unix` module which implements `V1_LWT.FS` 83 | 84 | ## v1.0.0 (2013-12-16) 85 | 86 | * First public release. 87 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Permission to use, copy, modify, and distribute this software for any 2 | purpose with or without fee is hereby granted, provided that the above 3 | copyright notice and this permission notice appear in all copies. 4 | 5 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 6 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 7 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 8 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 9 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 10 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 11 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 12 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | .PHONY: build clean test 3 | 4 | build: 5 | dune build 6 | 7 | test: 8 | dune runtest 9 | 10 | install: 11 | dune install 12 | 13 | uninstall: 14 | dune uninstall 15 | 16 | clean: 17 | rm -rf _build *.install 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## mirage-kv-unix -- key-value store for MirageOS backed by Unix filesystem 2 | 3 | This is a Mirage key-value store backed by an underlying Unix directory. 4 | 5 | The current version supports the `Mirage_kv.RO` and `Mirage_kv_lwt.RW` 6 | signatures defined in the [mirage-kv](https://github.com/mirage/mirage-kv) 7 | package. 8 | 9 | * WWW: 10 | * E-mail: 11 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.8) 2 | (name mirage-kv-unix) 3 | -------------------------------------------------------------------------------- /mirage-kv-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | authors: [ "Mindy Preston" "Hannes Mehnert" "Anil Madhavapeddy" 3 | "Thomas Gazagnaire" "Stefanie Schirmer" ] 4 | maintainer: [ "anil@recoil.org" "thomas@gazagnaire.org" ] 5 | homepage: "https://github.com/mirage/mirage-kv-unix" 6 | dev-repo: "git+https://github.com/mirage/mirage-kv-unix.git" 7 | bug-reports: "https://github.com/mirage/mirage-kv-unix/issues" 8 | doc: "https://mirage.github.io/mirage-kv-unix/" 9 | tags: [ "org:mirage" ] 10 | license: "ISC" 11 | build: [ 12 | ["dune" "subst" ] {dev} 13 | ["dune" "build" "-p" name "-j" jobs] 14 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 15 | ] 16 | 17 | depends: [ 18 | "dune" {>= "3.8"} 19 | "ocaml" {>= "4.08.0"} 20 | "mirage-kv" {>= "6.1.1"} 21 | "optint" 22 | "lwt" {>= "5.7.0"} 23 | "ptime" 24 | "cstruct" {with-test & >= "3.2.0"} 25 | "rresult" {with-test} 26 | "mirage-clock-unix" {with-test & >= "3.0.0"} 27 | "alcotest" {with-test & >= "0.8.1"} 28 | ] 29 | synopsis: "Key-value store for MirageOS backed by Unix filesystem" 30 | description: """ 31 | This is a Mirage key-value store backed by an underlying Unix directory. 32 | 33 | The current version supports the `Mirage_kv_lwt.RO` and `Mirage_kv_lwt.RW` 34 | signatures defined in the `mirage-kv-lwt` package. 35 | """ 36 | x-maintenance-intent: [ "(latest)" ] 37 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mirage_kv_unix) 3 | (public_name mirage-kv-unix) 4 | (libraries mirage-kv lwt.unix ptime optint)) 5 | -------------------------------------------------------------------------------- /src/mirage_kv_unix.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2014 Anil Madhavapeddy 3 | * Copyright (c) 2014 Thomas Gazagnaire 4 | * Copyright (c) 2014 Hannes Mehnert 5 | * 6 | * Permission to use, copy, modify, and distribute this software for any 7 | * purpose with or without fee is hereby granted, provided that the above 8 | * copyright notice and this permission notice appear in all copies. 9 | * 10 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 11 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 12 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 13 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 14 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 15 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 16 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 17 | *) 18 | 19 | open Lwt.Syntax 20 | open Optint 21 | 22 | let ( let*? ) = Lwt_result.bind 23 | let ( let+? ) x f = Lwt_result.map f x 24 | 25 | type key = Mirage_kv.Key.t 26 | type t = { base : string } 27 | type error = [ Mirage_kv.error | `Storage_error of Mirage_kv.Key.t * string ] 28 | 29 | exception Internal_error of error 30 | 31 | let internal_error = function 32 | | Error e -> Lwt.fail (Internal_error e) 33 | | _ -> assert false 34 | 35 | let storage_error key fmt = 36 | Format.ksprintf (fun str -> Error (`Storage_error (key, str))) fmt 37 | 38 | let err_read key size = storage_error key "could not read %d bytes" size 39 | let err_file_too_large key = storage_error key "file too large to process" 40 | let err_not_a_file key = storage_error key "not a regular file" 41 | let err_unix key e = storage_error key "%s" (Unix.error_message e) 42 | let err_mtime key = storage_error key "mtime parsing failed" 43 | let err_not_found key = Error (`Not_found key) 44 | let err_dict_expected key = Error (`Dictionary_expected key) 45 | let err_no_space = Error `No_space 46 | let err_value_expected key = Error (`Value_expected key) 47 | 48 | let pp_error ppf = function 49 | | #Mirage_kv.error as err -> Mirage_kv.pp_error ppf err 50 | | `Storage_error (key, msg) -> 51 | Format.fprintf ppf "storage error for %a: %s" Mirage_kv.Key.pp key msg 52 | 53 | type write_error = 54 | [ Mirage_kv.write_error 55 | | `Storage_error of Mirage_kv.Key.t * string 56 | | `Key_exists of Mirage_kv.Key.t ] 57 | 58 | let pp_write_error ppf = function 59 | | #Mirage_kv.write_error as err -> Mirage_kv.pp_write_error ppf err 60 | | `Key_exists key -> 61 | Format.fprintf ppf "key %a already exists and is a dictionary" 62 | Mirage_kv.Key.pp key 63 | | `Storage_error (key, msg) -> 64 | Format.fprintf ppf "storage error for %a: %s" Mirage_kv.Key.pp key msg 65 | 66 | let split_string delimiter name = 67 | let len = String.length name in 68 | let rec doit off acc = 69 | let open String in 70 | let idx = try index_from name off delimiter with _ -> len in 71 | let fst = sub name off (idx - off) in 72 | let idx' = idx + 1 in 73 | if idx' <= len then doit idx' (fst :: acc) else fst :: acc 74 | in 75 | List.rev (doit 0 []) 76 | 77 | let resolve_filename base key = 78 | let filename = Mirage_kv.Key.to_string key in 79 | let parts = split_string '/' filename in 80 | let ret = 81 | if List.exists (fun s -> s = "." || s = "..") parts then err_not_found key 82 | else Ok (Filename.concat base filename) 83 | in 84 | Lwt.return ret 85 | 86 | let get_aux { base } ?offset ?length key = 87 | let*? path = resolve_filename base key in 88 | let size stat = 89 | match length with 90 | | Some n -> Lwt.return n 91 | | None -> 92 | let size64 = stat.Lwt_unix.LargeFile.st_size in 93 | if size64 > Int64.of_int Sys.max_string_length then 94 | internal_error (err_file_too_large key) 95 | else Lwt.return (Int64.to_int size64) 96 | in 97 | let lseek fd = 98 | match offset with 99 | | None -> Lwt.return () 100 | | Some n -> 101 | let+ _ = Lwt_unix.LargeFile.lseek fd (Int63.to_int64 n) SEEK_SET in 102 | () 103 | in 104 | Lwt.catch 105 | (fun () -> 106 | let* fd = Lwt_unix.openfile path [ Lwt_unix.O_RDONLY ] 0 in 107 | Lwt.finalize 108 | (fun () -> 109 | let* stat = Lwt_unix.LargeFile.fstat fd in 110 | if stat.Lwt_unix.LargeFile.st_kind = Lwt_unix.S_REG then 111 | let* () = lseek fd in 112 | let* size = size stat in 113 | let buffer = Bytes.create size in 114 | let+ read_bytes = Lwt_unix.read fd buffer 0 size in 115 | if read_bytes = size then Ok (Bytes.unsafe_to_string buffer) 116 | else err_read key size 117 | else Lwt.return (err_value_expected key)) 118 | (fun () -> Lwt_unix.close fd)) 119 | (function 120 | | Internal_error e -> Lwt.return (Error e) 121 | | Unix.Unix_error (ENOENT, _, _) -> Lwt.return (err_not_found key) 122 | | Unix.Unix_error (e, _, _) -> Lwt.return (err_unix key e) 123 | | e -> Lwt.reraise e) 124 | 125 | let get_partial t key ~offset ~length = get_aux t key ~offset ~length 126 | let get t key = get_aux t key 127 | let disconnect _ = Lwt.return () 128 | 129 | (* all mkdirs are mkdir -p *) 130 | let rec create_directory t key = 131 | let*? path = resolve_filename t.base key in 132 | let check_type path = 133 | let+ stat = Lwt_unix.LargeFile.stat path in 134 | match stat.Lwt_unix.LargeFile.st_kind with 135 | | Lwt_unix.S_DIR -> Ok () 136 | | _ -> Error (`Dictionary_expected key) 137 | in 138 | if Sys.file_exists path then check_type path 139 | else 140 | let*? () = create_directory t (Mirage_kv.Key.parent key) in 141 | Lwt.catch 142 | (fun () -> 143 | let+ () = Lwt_unix.mkdir path 0o755 in 144 | Ok ()) 145 | (function 146 | | Unix.Unix_error (e, _, _) -> Lwt.return (err_unix key e) 147 | | e -> Lwt.reraise e) 148 | 149 | let open_file t key flags = 150 | let*? path = resolve_filename t.base key in 151 | let*? () = create_directory t (Mirage_kv.Key.parent key) in 152 | Lwt.catch 153 | (fun () -> 154 | let+ fd = Lwt_unix.openfile path flags 0o644 in 155 | Ok fd) 156 | (function 157 | | Unix.Unix_error (ENOSPC, _, _) -> Lwt.return err_no_space 158 | | Unix.Unix_error (e, _, _) -> Lwt.return (err_unix key e) 159 | | e -> Lwt.reraise e) 160 | 161 | let file_or_directory { base } key = 162 | let*? path = resolve_filename base key in 163 | let+ stat = Lwt_unix.LargeFile.stat path in 164 | match stat.Lwt_unix.LargeFile.st_kind with 165 | | Lwt_unix.S_DIR -> Ok `Dictionary 166 | | Lwt_unix.S_REG -> Ok `Value 167 | | _ -> err_not_a_file key 168 | 169 | (* TODO test this *) 170 | let exists t key = 171 | Lwt.catch 172 | (fun () -> 173 | let+? x = file_or_directory t key in 174 | Some x) 175 | (function 176 | | Unix.Unix_error (ENOENT, _, _) -> Lwt.return (Ok None) 177 | | Unix.Unix_error (e, _, _) -> Lwt.return (err_unix key e) 178 | | e -> Lwt.reraise e) 179 | 180 | let last_modified { base } key = 181 | let*? path = resolve_filename base key in 182 | Lwt.catch 183 | (fun () -> 184 | let+ stat = Lwt_unix.LargeFile.stat path in 185 | let mtime = stat.Lwt_unix.LargeFile.st_mtime in 186 | match Ptime.of_float_s mtime with 187 | | None -> err_mtime key 188 | | Some ts -> Ok ts) 189 | (function 190 | | Unix.Unix_error (e, _, _) -> Lwt.return (err_unix key e) 191 | | e -> Lwt.reraise e) 192 | 193 | let size { base } key = 194 | let*? path = resolve_filename base key in 195 | Lwt.catch 196 | (fun () -> 197 | let+ stat = Lwt_unix.LargeFile.stat path in 198 | if stat.Lwt_unix.LargeFile.st_kind = Lwt_unix.S_REG then 199 | let size = stat.Lwt_unix.LargeFile.st_size in 200 | let size = Int63.of_int64 size in 201 | Ok size 202 | else err_value_expected key) 203 | (function 204 | | Unix.Unix_error (ENOENT, _, _) -> Lwt.return (err_not_found key) 205 | | Unix.Unix_error (e, _, _) -> Lwt.return (err_unix key e) 206 | | e -> Lwt.reraise e) 207 | 208 | let connect id = 209 | try 210 | if Sys.is_directory id then Lwt.return { base = id } 211 | else failwith ("Not a directory " ^ id) 212 | with Sys_error _ -> failwith ("Not an entity " ^ id) 213 | 214 | let list t key = 215 | let*? path = resolve_filename t.base key in 216 | Lwt.catch 217 | (fun () -> 218 | let s = Lwt_unix.files_of_directory path in 219 | let s = Lwt_stream.filter (fun s -> s <> "." && s <> "..") s in 220 | let* l = Lwt_stream.to_list s in 221 | Lwt_list.fold_left_s 222 | (fun result filename -> 223 | let*? files = Lwt.return result in 224 | let path = Mirage_kv.Key.add key filename in 225 | let+? kind = file_or_directory t path in 226 | (path, kind) :: files) 227 | (Ok []) l) 228 | (function 229 | | Unix.Unix_error (ENOENT, _, _) -> Lwt.return (err_not_found key) 230 | | Unix.Unix_error (ENOTDIR, _, _) -> Lwt.return (err_dict_expected key) 231 | | Unix.Unix_error (e, _, _) -> Lwt.return (err_unix key e) 232 | | e -> Lwt.reraise e) 233 | 234 | let digest t key = 235 | let*? path = resolve_filename t.base key in 236 | Lwt.catch 237 | (fun () -> 238 | let*? v = file_or_directory t key in 239 | match v with 240 | | `Value -> Lwt.return (Ok (Digest.file path)) 241 | | `Dictionary -> Lwt.return (err_value_expected key)) 242 | (function 243 | | Unix.Unix_error (ENOENT, _, _) -> Lwt.return (err_not_found key) 244 | | Unix.Unix_error (e, _, _) -> Lwt.return (err_unix key e) 245 | | e -> Lwt.reraise e) 246 | 247 | let rec remove t key = 248 | let*? path = resolve_filename t.base key in 249 | Lwt.catch 250 | (fun () -> 251 | let*? file = file_or_directory t key in 252 | match file with 253 | | `Value -> 254 | let+ () = Lwt_unix.unlink path in 255 | Ok () 256 | | `Dictionary -> 257 | let*? files = list t key in 258 | let*? () = 259 | Lwt_list.fold_left_s 260 | (fun result (key, _) -> 261 | match result with 262 | | Error e -> Lwt.return (Error e) 263 | | Ok () -> remove t key) 264 | (Ok ()) files 265 | in 266 | if not Mirage_kv.Key.(equal empty key) then 267 | let+ () = Lwt_unix.rmdir path in 268 | Ok () 269 | else Lwt.return (Ok ())) 270 | (function 271 | | Unix.Unix_error (ENOENT, _, _) -> Lwt.return (err_not_found key) 272 | | e -> Lwt.reraise e) 273 | 274 | let set_aux t key ?offset value = 275 | let lseek fd = 276 | match offset with 277 | | None -> Lwt.return () 278 | | Some offset -> 279 | let+ _ = 280 | Lwt_unix.LargeFile.lseek fd (Optint.Int63.to_int64 offset) SEEK_SET 281 | in 282 | () 283 | in 284 | let* exists = exists t key in 285 | match exists with 286 | | Ok (Some `Dictionary) when offset <> None -> 287 | (* We are in the [set_partial] case *) 288 | Lwt.return (err_value_expected key) 289 | | _ -> ( 290 | let* ret = 291 | match offset with 292 | | None -> 293 | (* [set] always overwite the previous bindings, even if it 294 | is a directory. *) 295 | remove t key 296 | | Some _ -> Lwt.return (Ok ()) 297 | in 298 | match ret with 299 | | (Error (`Dictionary_expected _) | Error (`Storage_error _)) as e -> 300 | Lwt.return e 301 | | Ok () | Error (`Not_found _) -> 302 | Lwt.catch 303 | (fun () -> 304 | let*? fd = 305 | open_file t key Lwt_unix.[ O_WRONLY; O_NONBLOCK; O_CREAT ] 306 | in 307 | Lwt.finalize 308 | (fun () -> 309 | let* () = lseek fd in 310 | let buf = Bytes.unsafe_of_string value in 311 | let rec write_once off len = 312 | if len = 0 then Lwt.return () 313 | else 314 | let* n_written = Lwt_unix.write fd buf off len in 315 | if n_written = len + off then Lwt.return () 316 | else write_once (off + n_written) (len - n_written) 317 | in 318 | let+ () = write_once 0 (String.length value) in 319 | Ok ()) 320 | (fun () -> Lwt_unix.close fd)) 321 | (function 322 | | Unix.Unix_error (ENOSPC, _, _) -> Lwt.return err_no_space 323 | | Unix.Unix_error (e, _, _) -> Lwt.return (err_unix key e) 324 | | e -> Lwt.reraise e)) 325 | 326 | let set_partial t key ~offset value = set_aux t key ~offset value 327 | let set t key value = set_aux t key value 328 | 329 | let allocate t key ?last_modified length = 330 | let len = Int63.to_int length in 331 | let value = String.make len '\000' in 332 | let set_last_modified () = 333 | match last_modified with 334 | | None -> Lwt.return (Ok ()) 335 | | Some ts -> 336 | let*? path = resolve_filename t.base key in 337 | let date = Ptime.to_float_s ts in 338 | let+ () = Lwt_unix.utimes path date date in 339 | Ok () 340 | in 341 | let*? () = set t key value in 342 | set_last_modified () 343 | 344 | let rename t ~source ~dest = 345 | let*? source_path = resolve_filename t.base source in 346 | let*? dest_path = resolve_filename t.base dest in 347 | Lwt.catch 348 | (fun () -> 349 | let+ () = Lwt_unix.rename source_path dest_path in 350 | Ok ()) 351 | (function 352 | | Unix.Unix_error (e, _, _) -> Lwt.return (err_unix source e) 353 | | e -> Lwt.reraise e) 354 | -------------------------------------------------------------------------------- /src/mirage_kv_unix.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2014 Anil Madhavapeddy 3 | * Copyright (c) 2014 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | (** Loopback implementation of the FS signature. *) 19 | 20 | [@@@ocaml.warning "-34"] 21 | 22 | type error = [ Mirage_kv.error | `Storage_error of Mirage_kv.Key.t * string ] 23 | 24 | type write_error = 25 | [ Mirage_kv.write_error 26 | | `Storage_error of Mirage_kv.Key.t * string 27 | | `Key_exists of Mirage_kv.Key.t ] 28 | 29 | include 30 | Mirage_kv.RW with type error := error and type write_error := write_error 31 | 32 | val connect : string -> t Lwt.t 33 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (modes byte exe) 3 | (names test_kv_unix) 4 | (libraries 5 | unix 6 | ptime 7 | mirage-clock-unix 8 | alcotest 9 | mirage-kv 10 | mirage-kv-unix 11 | cstruct)) 12 | 13 | (rule 14 | (alias runtest) 15 | (deps 16 | (:< test_kv_unix.exe) 17 | (source_tree test_directory)) 18 | (action 19 | (run %{<}))) 20 | -------------------------------------------------------------------------------- /test/test_directory/a_directory/empty: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mirage/mirage-kv-unix/0065e6460adfeb29bf305722a992884ed8d0778a/test/test_directory/a_directory/empty -------------------------------------------------------------------------------- /test/test_directory/big_file: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/test_directory/content: -------------------------------------------------------------------------------- 1 | some content 2 | -------------------------------------------------------------------------------- /test/test_directory/empty: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mirage/mirage-kv-unix/0065e6460adfeb29bf305722a992884ed8d0778a/test/test_directory/empty -------------------------------------------------------------------------------- /test/test_kv_unix.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 Mindy Preston 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Lwt.Syntax 18 | module Int63 = Optint.Int63 19 | 20 | let test_kv = "test_directory" 21 | let empty_file = Mirage_kv.Key.v "empty" 22 | let content_file = Mirage_kv.Key.v "content" 23 | let big_file = Mirage_kv.Key.v "big_file" 24 | let directory = Mirage_kv.Key.v "a_directory" 25 | 26 | module KV = Mirage_kv_unix 27 | 28 | let lwt_run f () = Lwt_main.run (f ()) 29 | let assert_fail e = Alcotest.failf "%a" KV.pp_error e 30 | let assert_write_fail e = Alcotest.failf "%a" KV.pp_write_error e 31 | 32 | let get_ok = function 33 | | Ok x -> x 34 | | Error e -> Alcotest.failf "get_ok: %a" KV.pp_error e 35 | 36 | let get_ok' = function 37 | | Ok x -> x 38 | | Error e -> Alcotest.failf "get_ok: %a" KV.pp_write_error e 39 | 40 | let connect_present_dir () = 41 | let+ _ = KV.connect test_kv in 42 | () 43 | 44 | let append_timestamp s = 45 | let now = Ptime.v (Pclock.now_d_ps ()) in 46 | let str = Format.asprintf "%s-%a" s (Ptime.pp_rfc3339 ~space:false ()) now in 47 | Mirage_kv.Key.v str 48 | 49 | let full_path dirname filename = Mirage_kv.Key.add dirname filename 50 | 51 | let expect_error_connecting where () = 52 | Lwt.catch 53 | (fun () -> 54 | let* _ = KV.connect where in 55 | Lwt.fail_with "expected error") 56 | (fun _ -> Lwt.return_unit) 57 | 58 | let size kv key = 59 | let+ n = KV.size kv key in 60 | let n = get_ok n in 61 | Int63.to_int n 62 | 63 | let get kv ?offset key = 64 | let+ v = 65 | match offset with 66 | | None -> KV.get kv key 67 | | Some (offset, length) -> 68 | let offset = Int63.of_int offset in 69 | KV.get_partial kv key ~offset ~length 70 | in 71 | get_ok v 72 | 73 | let set kv key ?offset v = 74 | let+ w = 75 | match offset with 76 | | None -> KV.set kv key v 77 | | Some offset -> 78 | let offset = Int63.of_int offset in 79 | KV.set_partial kv key ~offset v 80 | in 81 | get_ok' w 82 | 83 | let connect_to_empty_string = expect_error_connecting "" 84 | let connect_to_dev_null = expect_error_connecting "/dev/null" 85 | 86 | let read_nonexistent_file file () = 87 | let key = Mirage_kv.Key.v file in 88 | let* kv = KV.connect test_kv in 89 | let+ v = KV.get kv key in 90 | match v with 91 | | Ok _ -> 92 | Alcotest.failf 93 | "read returned Ok when no file was expected. Please make sure there \ 94 | isn't actually a file named %a" 95 | Mirage_kv.Key.pp key 96 | | Error (`Not_found _) -> () 97 | | Error e -> 98 | Alcotest.failf 99 | "Unreasonable error response when trying to read a nonexistent file: %a" 100 | KV.pp_error e 101 | 102 | let read_empty_file () = 103 | let* kv = KV.connect test_kv in 104 | let+ v = KV.get kv empty_file in 105 | match v with 106 | | Ok buf when String.length buf = 0 -> () 107 | | Ok _ -> Alcotest.failf "reading an empty file returned some cstructs" 108 | | Error e -> 109 | Alcotest.failf "read failed for a present but empty file: %a" KV.pp_error 110 | e 111 | 112 | let read_big_file () = 113 | let* kv = KV.connect test_kv in 114 | let* size = size kv big_file in 115 | let+ buf = get kv big_file in 116 | if String.length buf <> size then 117 | Alcotest.failf "read returned nothing for a large file" 118 | 119 | let size_nonexistent_file () = 120 | let* kv = KV.connect test_kv in 121 | let filename = Mirage_kv.Key.v "^#$\000not a file!!!. &;" in 122 | let+ size = KV.size kv filename in 123 | match size with 124 | | Ok d -> Alcotest.failf "Got a size of %a for absent file" Int63.pp d 125 | | Error (`Not_found _) -> () 126 | | Error e -> assert_fail e 127 | 128 | let size_empty_file () = 129 | let* kv = KV.connect test_kv in 130 | let+ n = size kv empty_file in 131 | Alcotest.(check int) "size of an empty file" 0 n 132 | 133 | let size_small_file () = 134 | let* kv = KV.connect test_kv in 135 | let+ n = size kv content_file in 136 | Alcotest.(check int) "size of a small file" 13 n 137 | 138 | let size_a_directory () = 139 | let* kv = KV.connect test_kv in 140 | let+ size = KV.size kv directory in 141 | match size with 142 | | Error (`Value_expected _) -> () 143 | | Error e -> assert_fail e 144 | | Ok n -> Alcotest.failf "got size %a on a directory" Int63.pp n 145 | 146 | let size_big_file () = 147 | let* kv = KV.connect test_kv in 148 | let+ size = size kv big_file in 149 | Alcotest.(check int) __LOC__ 5000 size 150 | 151 | let write_not_a_dir () = 152 | let dirname = append_timestamp "write_not_a_dir" in 153 | let subdir = "not there" in 154 | let content = "puppies" in 155 | let full_path = Mirage_kv.Key.(dirname / subdir / "file") in 156 | let* kv = KV.connect test_kv in 157 | let* () = set kv full_path content in 158 | let* exists = KV.exists kv full_path in 159 | match exists with 160 | | Error e -> 161 | Alcotest.failf "Exists on an existing file failed %a" KV.pp_error e 162 | | Ok None -> Alcotest.failf "Exists on an existing file returned None" 163 | | Ok (Some `Dictionary) -> 164 | Alcotest.failf "Exists on an existing file returned a dictionary" 165 | | Ok (Some `Value) -> 166 | let+ buf = get kv full_path in 167 | Alcotest.(check string) __LOC__ content buf 168 | 169 | let write_zero_bytes () = 170 | let dirname = append_timestamp "mkdir_not_a_dir" in 171 | let subdir = "not there" in 172 | let full_path = Mirage_kv.Key.(dirname / subdir / "file") in 173 | let* kv = KV.connect test_kv in 174 | let* () = set kv full_path "" in 175 | (* make sure it's size 0 *) 176 | let+ n = KV.size kv full_path in 177 | match n with 178 | | Ok n -> Alcotest.(check int) __LOC__ 0 (Int63.to_int n) 179 | | Error e -> 180 | Alcotest.failf 181 | "write claimed to create a file that the kv then couldn't read: %a" 182 | KV.pp_error e 183 | 184 | let write_contents_correct () = 185 | let dirname = append_timestamp "write_contents_correct" in 186 | let full_path = full_path dirname "short_phrase" in 187 | let phrase = "standing here on this frozen lake" in 188 | let* kv = KV.connect test_kv in 189 | let* () = set kv full_path phrase in 190 | let* v = get kv full_path in 191 | Alcotest.(check string) __LOC__ phrase v; 192 | let* v = get kv ~offset:(6, 10) full_path in 193 | Alcotest.(check string) __LOC__ "ng here on" v; 194 | let* () = set kv full_path ~offset:9 "foo" in 195 | let+ v = get kv ~offset:(6, 10) full_path in 196 | Alcotest.(check string) __LOC__ "ng fooe on" v 197 | 198 | let write_overwrite_dir () = 199 | let dirname = append_timestamp "write_overwrite_dir" in 200 | let* kv = KV.connect test_kv in 201 | let subdir = Mirage_kv.Key.(dirname / "data") in 202 | let* () = set kv subdir "noooooo" in 203 | let+ w = KV.set kv dirname "noooooo" in 204 | match w with Ok () -> () | Error e -> assert_write_fail e 205 | 206 | let write_big_file () = 207 | let how_big = 4100 in 208 | let dirname = append_timestamp "write_big_file" in 209 | let full_path = full_path dirname "so many bytes!" in 210 | let zero_cstruct cs = 211 | let zero c = Cstruct.set_char c 0 '\000' in 212 | let i = Cstruct.iter (fun _ -> Some 1) zero cs in 213 | Cstruct.fold (fun b _ -> b) i cs 214 | in 215 | let first_page = zero_cstruct (Cstruct.create how_big) in 216 | Cstruct.set_char first_page 4097 'A'; 217 | Cstruct.set_char first_page 4098 'B'; 218 | Cstruct.set_char first_page 4099 'C'; 219 | let* kv = KV.connect test_kv in 220 | (* TODO get rid of cstruct *) 221 | let* () = set kv full_path (Cstruct.to_string first_page) in 222 | let* sz = size kv full_path in 223 | let check_chars str a b c = 224 | Alcotest.(check char) __LOC__ 'A' (String.get str a); 225 | Alcotest.(check char) __LOC__ 'B' (String.get str b); 226 | Alcotest.(check char) __LOC__ 'C' (String.get str c) 227 | in 228 | Alcotest.(check int) __LOC__ how_big sz; 229 | let+ s = get kv full_path in 230 | if s = "" then Alcotest.failf "claimed a big file was empty on read" 231 | else check_chars s 4097 4098 4099 232 | 233 | let populate num depth kv = 234 | let rec gen_d pref = function 235 | | 0 -> "foo" 236 | | x -> Filename.concat (pref ^ string_of_int x) (gen_d pref (pred x)) 237 | in 238 | let rec gen_l acc = function 239 | | 0 -> acc 240 | | x -> gen_l (gen_d (string_of_int x) depth :: acc) (pred x) 241 | in 242 | (* populate a bit *) 243 | Lwt_list.iteri_s 244 | (fun i x -> 245 | let+ () = 246 | set kv (append_timestamp ("foo" ^ x ^ string_of_int i)) "test content" 247 | in 248 | ()) 249 | (gen_l [] num) 250 | 251 | let destroy () = 252 | let files = 253 | Mirage_kv.Key.to_string (append_timestamp ("/tmp/" ^ test_kv ^ "2")) 254 | in 255 | let* () = Lwt_unix.mkdir files 0o755 in 256 | let cleanup () = Lwt_unix.rmdir files in 257 | let* kv = KV.connect files in 258 | let* () = populate 10 4 kv in 259 | let* r = KV.remove kv Mirage_kv.Key.empty in 260 | match r with 261 | | Error _ -> 262 | let+ () = cleanup () in 263 | Alcotest.failf "create failed" 264 | | Ok () -> ( 265 | let+ ls = KV.list kv Mirage_kv.Key.empty in 266 | match ls with 267 | | Ok [] -> () 268 | | Ok _ -> Alcotest.failf "something exists after destroy" 269 | | Error e -> Alcotest.failf "error %a in listdir" KV.pp_error e) 270 | 271 | let destroy_a_bit () = 272 | let files = 273 | Mirage_kv.Key.to_string (append_timestamp ("/tmp/" ^ test_kv ^ "3")) 274 | in 275 | let* () = Lwt_unix.mkdir files 0o755 in 276 | let cleanup () = 277 | let _ = Sys.command ("rm -rf " ^ files) in 278 | Lwt.return_unit 279 | in 280 | let* kv = KV.connect files in 281 | let* () = populate 10 4 kv in 282 | let* files = KV.list kv Mirage_kv.Key.empty in 283 | let files = 284 | match files with 285 | | Ok files -> List.length files 286 | | Error _ -> Alcotest.failf "error in list" 287 | in 288 | let* w = KV.set kv (Mirage_kv.Key.v "barf") "dummy content" in 289 | let* () = 290 | match w with 291 | | Error _ -> 292 | let+ () = cleanup () in 293 | Alcotest.failf "create failed" 294 | | Ok () -> Lwt.return () 295 | in 296 | let* r = KV.remove kv (Mirage_kv.Key.v "barf") in 297 | let* () = 298 | match r with 299 | | Error _ -> 300 | let+ () = cleanup () in 301 | Alcotest.failf "destroy failed" 302 | | Ok () -> Lwt.return () 303 | in 304 | let* xs = KV.list kv Mirage_kv.Key.empty in 305 | match xs with 306 | | Ok xs when List.length xs = files -> cleanup () 307 | | Ok _ -> 308 | Alcotest.failf 309 | "something wrong in destroy: destroy followed by create is not well \ 310 | behaving" 311 | | Error _ -> Alcotest.failf "error in listdir" 312 | 313 | let () = 314 | let connect = 315 | [ 316 | ("connect_to_empty_string", `Quick, lwt_run connect_to_empty_string); 317 | ("connect_to_dev_null", `Quick, lwt_run connect_to_dev_null); 318 | ("connect_present_dir", `Quick, lwt_run connect_present_dir); 319 | ] 320 | in 321 | let read = 322 | [ 323 | ( "read_nonexistent_file_from_root", 324 | `Quick, 325 | lwt_run (read_nonexistent_file "^$@thing_that_isn't_in root!!!.space") 326 | ); 327 | ( "read_nonexistent_file_from_dir", 328 | `Quick, 329 | lwt_run 330 | (read_nonexistent_file 331 | "not a *dir*?!?/thing_that_isn't_in root!!!.space") ); 332 | ("read_empty_file", `Quick, lwt_run read_empty_file); 333 | ("read_big_file", `Quick, lwt_run read_big_file); 334 | ] 335 | in 336 | let destroy = 337 | [ 338 | ("destroy_file", `Quick, lwt_run destroy); 339 | ("create_destroy_file", `Quick, lwt_run destroy_a_bit); 340 | ] 341 | in 342 | let size = 343 | [ 344 | ("size_nonexistent_file", `Quick, lwt_run size_nonexistent_file); 345 | ("size_empty_file", `Quick, lwt_run size_empty_file); 346 | ("size_small_file", `Quick, lwt_run size_small_file); 347 | ("size_a_directory", `Quick, lwt_run size_a_directory); 348 | ("size_big_file", `Quick, lwt_run size_big_file); 349 | ] 350 | in 351 | let listdir = [] in 352 | let write = 353 | [ 354 | ("write_not_a_dir", `Quick, lwt_run write_not_a_dir); 355 | ("write_zero_bytes", `Quick, lwt_run write_zero_bytes); 356 | ("write_contents_correct", `Quick, lwt_run write_contents_correct); 357 | ("write_overwrite_dir", `Quick, lwt_run write_overwrite_dir); 358 | ("write_big_file", `Quick, lwt_run write_big_file); 359 | ] 360 | in 361 | Alcotest.run "KV" 362 | [ 363 | ("connect", connect); 364 | ("read", read); 365 | ("size", size); 366 | ("destroy", destroy); 367 | ("listdir", listdir); 368 | ("write", write); 369 | ] 370 | --------------------------------------------------------------------------------