├── .gitignore ├── .ocamlformat ├── LICENSE ├── README.md ├── cli ├── commands.ml ├── common_args.ml ├── context.ml ├── dune └── notafs_cli.ml ├── dune ├── dune-project ├── index-notafs.opam ├── index-notafs.opam.template ├── index-notafs ├── dune └── index_notafs.ml ├── irmin-pack-notafs.opam ├── irmin-pack-notafs.opam.template ├── irmin-pack-notafs ├── async.ml ├── dune ├── io.ml ├── io.mli └── irmin_pack_notafs.ml ├── lwt_direct.opam ├── lwt_direct ├── dune └── lwt_direct.ml ├── notafs-cli.opam ├── notafs.opam ├── src ├── checksum.ml ├── context.ml ├── diet.ml ├── diet.mli ├── dune ├── files.ml ├── files.mli ├── fs.ml ├── header.ml ├── id.ml ├── kv.ml ├── kv.mli ├── lru.ml ├── lru.mli ├── notafs.ml ├── notafs.mli ├── queue.ml ├── queue.mli ├── root.ml ├── rope.ml ├── schema.ml ├── sector.ml └── sector.mli ├── tests ├── bench_kv.ml ├── block_viz.ml ├── dune ├── test_fs.ml ├── test_irmin.ml └── test_large_notafs.ml ├── unikernel-bench ├── kv_4 │ ├── config.ml │ └── unikernel.ml ├── kv_6 │ ├── config.ml │ ├── docteur │ │ └── init_docteur.sh │ └── unikernel.ml └── script.gpt ├── unikernel-irmin ├── config.ml └── unikernel.ml └── unikernel-kv ├── config.ml └── unikernel.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | .merlin 12 | *.install 13 | *.coverage 14 | *.sw[lmnop] 15 | 16 | _build/ 17 | _doc/ 18 | _coverage/ 19 | _opam/ 20 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.26.0 2 | profile = janestreet 3 | let-binding-spacing = compact 4 | sequence-style = separator 5 | doc-comments = after-when-possible 6 | exp-grouping = preserve 7 | break-cases = toplevel 8 | cases-exp-indent = 4 9 | cases-matching-exp-indent = normal 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | ## ISC License 2 | 3 | Copyright (c) 2023 Tarides 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | **:warning: Experimental! Do not use if you can't afford to loose data! :warning:** 2 | 3 | Notafs is a pseudo filesystem for Mirage block devices. It can handle a small number of large files. While the limited number of filenames is unsatisfying for general usage, it can be used to run the [`irmin-pack` backend of Irmin](https://mirage.github.io/irmin/irmin-pack/) which only requires a dozen of very large files. By running Irmin, one gets for free a filesystem-on-steroid for MirageOS: it supports an arbitrary large number of filenames; is optimized for small and large file contents; performs files deduplication; includes a git-like history with branching and merging, ... and it even provides a garbage collector to avoid running out of disk space (by deleting older commits). Since the Irmin filesystem is versioned by merkle hashes, one can imagine deploying [reproducible unikernels](https://robur.coop/Projects/Reproducible_builds) on reproducible filesystem states! 4 | 5 | At its core, Notafs provides a memory allocator for disk pages allowing copy-on-write everywhere in a safe way. Some nice properties are derived from there: 6 | 7 | - **Fail-safe:** All updates are written to new pages of the disk, rather than mutating existing sectors in place. This guarantees that previous versions of the filesystem are always recoverable -- typically in case of a harsh power-off, with disk writes not completing and/or creating corrupted sectors. During boot, the latest filesystem is checksummed to validate its coherency -- if not, a previous valid version of the files is used. 8 | - **Transactional semantics:** Since updates generate a shallow copy of the new filesystem (like a purely functional datastructure), one can reveal a large set of changes at once by persisting the freshly created copy. This permits updating multiple files and doing complex mutations involving several operations in a way that appears atomic (either all changes are visible, or none are). 9 | - **Relatively efficient:** A number of optimizations are running behind the scene, including dynamic sector pointer sizes (to use less space on smaller disks), batching writes of consecutive sectors, and flushing writes to disk early to avoid blowing up memory when performing a large update. 10 | 11 | As a work-in-progress demo, `notafs` includes a partial implementation of the [`mirage-kv`](https://ocaml.org/p/mirage-kv) interface. It supports large file contents represented by append-optimized B-tree ropes, but it is not optimized for a large number of filenames (no hard limit though). Benchmarks on `solo5-hvt` with a 2gb disk with 4kb sectors (512b for fat/docteur), and 1gb of available ram, with different filesystems failing sooner or later depending on their use of memory: 12 | 13 | ![benchmark `set/get/get_partial` on large files](https://art-w.github.io/notafs/bench.png) 14 | 15 | ## Unikernel demos 16 | 17 | To run the unikernel demos, you'll need to pin the `notafs` library, copy the `unikernel-kv` folder out of the project (to avoid recursive issues with `opam-monorepo`), compile it for your prefered Mirage target and create a disk to use: 18 | 19 | ```shell 20 | # Pin the library 21 | $ cd notafs 22 | notafs/ $ opam pin add notafs . --with-version=dev 23 | 24 | # Copy the mirage-kv demo to another folder 25 | notafs/ $ cp -r unikernel-kv ../unikernel-kv 26 | notafs/ $ cd ../unikernel-kv 27 | 28 | # Build the unikernel for your prefered target 29 | unikernel-kv/ $ mirage config -t hvt 30 | unikernel-kv/ $ make depends 31 | unikernel-kv/ $ make build 32 | 33 | # Create an empty disk 34 | $ truncate -s 400K /tmp/storage 35 | 36 | # And run! 37 | unikernel-kv/ $ solo5-hvt --block:storage=/tmp/storage -- ./dist/block_test.hvt 38 | ``` 39 | 40 | The integration with Irmin relies on OCaml 5 support for algebraic effects: While the `irmin-pack` backend abstracts its IO syscalls behind a direct-style API, interacting with Mirage block devices is done through Lwt. To bridge this gap, the small `lwt_direct` library hides Lwt operation behind a direct-style interface usable by `irmin-pack` (it plays a similar purpose to [`lwt_eio`](https://github.com/ocaml-multicore/lwt_eio) without a unix dependency). Perhaps surprisingly, this indirection trick doesn't work well when Irmin itself uses Lwt internally -- so the experimental Eio fork of `irmin-pack` is used instead (with the `eio.mock` handler). Note that [OCaml 5 support in solo5 is also experimental](https://github.com/mirage/ocaml-solo5/pull/124): 41 | 42 | ```shell 43 | $ opam switch 5.0.0 44 | 45 | # Enable experimental support for OCaml 5 on solo5: 46 | $ opam pin 'https://github.com/mirage/ocaml-solo5.git#500-cleaned' 47 | 48 | notafs/ $ opam pin . --with-version=dev 49 | ``` 50 | 51 | The Irmin unikernel demo on solo5 can be run by following the same steps as for the `mirage-kv` one above. You may have to set `solo5` version to `0.8.0` in `mirage/block_test-hvt.opam` before running `make depends`. 52 | 53 | The tests include a visualization of Irmin running on a Mirage block device, performing commits and garbage collection. Each 1kb sector is represented by a 32x32 pixel square (colored pages contain live data, grey crossed ones are free). Epilepsy warning: the slowed recording of the test below contains flashing lights. 54 | 55 | ``` 56 | # Run the test with a graphic visualization of blocks operations: 57 | notafs/ $ truncate -s 200K /tmp/notafs-irmin 58 | notafs/ $ dune exec -- ./tests/test_irmin.exe # --help for options 59 | ``` 60 | 61 | https://github.com/art-w/notafs/assets/4807590/915f6967-d26e-47fe-b53c-467762c24f05 62 | 63 | ## Notafs-CLI 64 | 65 | A command-line tool is available to facilitate the creation of a disk usable with the `mirage-kv` interface: 66 | 67 | ```shell 68 | # Install the executable 69 | notafs/ $ opam pin add notafs-cli . --with-version=dev 70 | 71 | # Create an empty disk 72 | $ truncate -s 400K /tmp/storage 73 | ``` 74 | 75 | Before we can use it, the freshly created disk needs to be formatted. The flag `-p` represents the size of the sectors (512, 1024, 4096). It is optional and set to 512 by default. 76 | 77 | ```shell 78 | # Format a disk 79 | $ notafs-cli format -d/tmp/storage -p4096 80 | 81 | # Display general informations about a formatted disk: 82 | $ notafs-cli info /tmp/storage 83 | ``` 84 | 85 | To copy local files into the disk and extract them afterward: (paths on the disk have to be prefixed with the character `@` when using the `copy` operation) 86 | 87 | ```shell 88 | # Copy a local file `foo` into the disk as `dir/foo`: 89 | $ notafs-cli copy -d/tmp/storage foo @dir/foo 90 | 91 | # Duplicate a disk file `dir/foo` as `bar`: 92 | $ notafs-cli copy -d/tmp/storage @dir/foo @bar 93 | 94 | # Extract a disk file `bar` and name it `goo`: 95 | $ notafs-cli copy -d/tmp/storage @bar goo 96 | 97 | # Dump a file `bar` from the disk into the standard output: 98 | $ notafs-cli cat -d/tmp/storage bar 99 | ``` 100 | 101 | To list the contents and metadatas of files: 102 | 103 | ```shell 104 | # Get the size of a file `foo`: 105 | notafs/ $ notafs-cli stats -d/tmp/storage foo 106 | 107 | # List all the files/subdirectories of the folder `dir`: 108 | notafs/ $ notafs-cli list -d/tmp/storage dir 109 | 110 | # Recursively list all the files/directories of the folder `dir`: 111 | notafs/ $ notafs-cli tree -d/tmp/storage dir 112 | ``` 113 | 114 | And to perform maintenance operations: 115 | 116 | ```shell 117 | # Create an empty file named 'foo' 118 | $ notafs-cli touch -d/tmp/storage foo 119 | 120 | # Rename file 'foo' to 'bar': 121 | $ notafs-cli rename -d/tmp/storage foo bar 122 | 123 | # Remove the 'bar' file: 124 | $ notafs-cli remove -d/tmp/storage bar 125 | ``` 126 | -------------------------------------------------------------------------------- /cli/commands.ml: -------------------------------------------------------------------------------- 1 | open Lwt_result.Syntax 2 | open Context 3 | 4 | let on_error s = function 5 | | Ok () -> () 6 | | Error err -> Fmt.pr "Encountered error in %S: %a@." s Disk.pp_error err 7 | 8 | let format path page_size = 9 | let format () = 10 | let* block = 11 | Lwt_result.ok (Block.connect ~prefered_sector_size:(Some page_size) path) 12 | in 13 | let+ _disk = Disk.format block in 14 | Fmt.pr "Disk at %S succesfully formatted@." path 15 | in 16 | on_error "format" @@ Lwt_main.run (format ()) 17 | 18 | let string_of_disk_space space = 19 | let kb = 1024L in 20 | let mb = Int64.mul 1024L kb in 21 | let gb = Int64.mul 1024L mb in 22 | if space < kb 23 | then Int64.to_string space ^ "b" 24 | else if space < mb 25 | then Int64.to_string (Int64.div space kb) ^ "kb" 26 | else if space < gb 27 | then Int64.to_string (Int64.div space mb) ^ "mb" 28 | else Int64.to_string (Int64.div space gb) ^ "gb" 29 | 30 | let info_cmd block = 31 | let infos () = 32 | let+ config = Notafs.get_config (module Block) block in 33 | let disk_size = Int64.mul config.disk_size (Int64.of_int config.page_size) in 34 | Fmt.pr "Sector size: %s@." (string_of_disk_space @@ Int64.of_int config.page_size) ; 35 | Fmt.pr 36 | "Disk space: %s (%a sectors)@." 37 | (string_of_disk_space disk_size) 38 | Fmt.int64 39 | config.disk_size ; 40 | Fmt.pr 41 | "Checksum: %s with %i bits@." 42 | config.checksum_algorithm 43 | (8 * config.checksum_byte_size) 44 | in 45 | on_error "info" @@ Lwt_main.run (infos ()) 46 | 47 | let touch disk path = 48 | let touch () = 49 | let k = Mirage_kv.Key.v path in 50 | let+ () = Disk.set disk k "" in 51 | Fmt.pr "File %S created@." path 52 | in 53 | on_error "touch" @@ Lwt_main.run (touch ()) 54 | 55 | let remove disk path = 56 | let remove () = 57 | let k = Mirage_kv.Key.v path in 58 | let+ () = Disk.remove disk k in 59 | Fmt.pr "File %S removed@." path 60 | in 61 | on_error "remove" @@ Lwt_main.run (remove ()) 62 | 63 | let rename disk path_from path_to = 64 | let rename () = 65 | let source = Mirage_kv.Key.v path_from in 66 | let dest = Mirage_kv.Key.v path_to in 67 | let+ () = Disk.rename disk ~source ~dest in 68 | Fmt.pr "File %S renamed to %S@." path_from path_to 69 | in 70 | on_error "rename" @@ Lwt_main.run (rename ()) 71 | 72 | let cat disk path = 73 | let cat () = 74 | let key = Mirage_kv.Key.v path in 75 | let+ get = Disk.get disk key in 76 | Fmt.pr "%s" get 77 | in 78 | on_error "cat" @@ Lwt_main.run (cat ()) 79 | 80 | let copy_to_disk disk path_from path_to = 81 | let key = Mirage_kv.Key.v path_to in 82 | let size = (Unix.stat path_from).st_size in 83 | let bytes = Bytes.create size in 84 | let fd = Unix.openfile path_from Unix.[ O_RDONLY ] 0o0 in 85 | let rec fill_bytes off rem_size = 86 | let read = Unix.read fd bytes off rem_size in 87 | if read < rem_size then fill_bytes (off + read) (rem_size - read) 88 | in 89 | fill_bytes 0 size ; 90 | let+ () = Disk.set disk key (Bytes.to_string bytes) in 91 | Fmt.pr "File %S has been copied to key %S@." path_from path_to ; 92 | Unix.close fd 93 | 94 | let copy_from_disk disk path_from path_to = 95 | let key = Mirage_kv.Key.v path_from in 96 | let+ get = Disk.get disk key in 97 | let fd = Unix.openfile path_to Unix.[ O_WRONLY; O_CREAT; O_TRUNC ] 0o664 in 98 | let size = String.length get in 99 | let bytes = String.to_bytes get in 100 | let rec dump_bytes off rem_size = 101 | let write = Unix.write fd bytes off rem_size in 102 | if write < rem_size then dump_bytes (off + write) (rem_size - write) 103 | in 104 | dump_bytes 0 size ; 105 | Fmt.pr "Key %S has been copied to file %S@." path_from path_to ; 106 | Unix.close fd 107 | 108 | let copy_from_disk_to_disk disk path_from path_to = 109 | let key_from = Mirage_kv.Key.v path_from in 110 | let key_to = Mirage_kv.Key.v path_to in 111 | let* from = Disk.get disk key_from in 112 | let+ () = Disk.set disk key_to from in 113 | Fmt.pr "Key %S has been copied to key %S@." path_from path_to 114 | 115 | let copy disk path_from path_to = 116 | let copy () = 117 | let disk_id = "@" in 118 | let disk_id_len = String.length disk_id in 119 | match 120 | ( String.starts_with ~prefix:disk_id path_from 121 | , String.starts_with ~prefix:disk_id path_to ) 122 | with 123 | | true, true -> 124 | copy_from_disk_to_disk 125 | disk 126 | (String.sub path_from disk_id_len (String.length path_from - disk_id_len)) 127 | (String.sub path_to disk_id_len (String.length path_to - disk_id_len)) 128 | | true, false -> 129 | copy_from_disk 130 | disk 131 | (String.sub path_from disk_id_len (String.length path_from - disk_id_len)) 132 | path_to 133 | | false, true -> 134 | copy_to_disk 135 | disk 136 | path_from 137 | (String.sub path_to disk_id_len (String.length path_to - disk_id_len)) 138 | | false, false -> 139 | Lwt_result.fail 140 | (`Unsupported_operation 141 | (Fmt.str "No disk paths (prefix disk paths with %S)@." disk_id)) 142 | in 143 | on_error "copy" @@ Lwt_main.run (copy ()) 144 | 145 | let stats disk path = 146 | let cat () = 147 | let key = Mirage_kv.Key.v path in 148 | let* last_modified = Disk.last_modified disk key in 149 | let+ size = Disk.size disk key in 150 | Fmt.pr "Size: %a@." Optint.Int63.pp size ; 151 | Fmt.pr "Last modified: %a@." (Ptime.pp_human ()) last_modified 152 | in 153 | on_error "stats" @@ Lwt_main.run (cat ()) 154 | 155 | let list disk path = 156 | let list () = 157 | let open Lwt_result.Syntax in 158 | let k = Mirage_kv.Key.v path in 159 | let+ files = Disk.list disk k in 160 | let styled t pp = 161 | match t with 162 | | `Value -> pp 163 | | `Dictionary -> Fmt.styled `Bold (Fmt.styled (`Fg `Blue) pp) 164 | in 165 | List.iter (fun (key, t) -> Fmt.pr "%a@." (styled t Mirage_kv.Key.pp) key) files 166 | in 167 | on_error "list" @@ Lwt_main.run (list ()) 168 | 169 | let tree disk path = 170 | let styled t pp = 171 | match t with 172 | | `Value -> pp 173 | | `Dictionary -> Fmt.styled `Bold (Fmt.styled (`Fg `Blue) pp) 174 | in 175 | let rec tree (i, indent_tl) key = 176 | let open Lwt_result.Syntax in 177 | let* files = Disk.list disk key in 178 | let n = List.length files in 179 | let dump j (key, t) () = 180 | let basename = Mirage_kv.Key.basename key in 181 | let indent_hd = if j <> n - 1 then "├── " else "└── " in 182 | Fmt.pr "%s%s%a@." indent_tl indent_hd (styled t Fmt.string) basename ; 183 | let indent_tl = indent_tl ^ if j <> n - 1 then "│ " else " " in 184 | if t = `Dictionary then tree (i + 1, indent_tl) key else Lwt_result.return () 185 | in 186 | List.fold_left Lwt_result.bind (Lwt_result.return ()) @@ List.mapi dump files 187 | in 188 | let tree () = 189 | let key = Mirage_kv.Key.v path in 190 | let* t = Disk.exists disk key in 191 | match t with 192 | | Some `Dictionary -> 193 | Fmt.pr "%a@." (styled `Dictionary Mirage_kv.Key.pp) key ; 194 | tree (0, "") key 195 | | Some `Value | None -> 196 | Fmt.pr "%a [error opening dir]@." (styled `Value Mirage_kv.Key.pp) key ; 197 | Lwt_result.return () 198 | in 199 | on_error "tree" @@ Lwt_main.run (tree ()) 200 | 201 | open Cmdliner 202 | (** Commands *) 203 | 204 | open Common_args 205 | 206 | (* Format *) 207 | let page_size = 208 | Arg.( 209 | value 210 | & opt int 512 211 | & info [ "p"; "page_size" ] ~docv:"page_size" ~doc:"size of the disk's page") 212 | 213 | let format_cmd = 214 | let doc = "formats a disk for further use" in 215 | let info = Cmd.info "format" ~doc in 216 | Cmd.v info Term.(const format $ disk_path $ page_size) 217 | 218 | (* Info *) 219 | let info_cmd = 220 | let doc = "show available disk space" in 221 | let info = Cmd.info "info" ~doc in 222 | Cmd.v info Term.(const info_cmd $ block) 223 | 224 | (* Touch *) 225 | let touch_cmd = 226 | let doc = "create a file in a formatted disk" in 227 | let info = Cmd.info "touch" ~doc in 228 | Cmd.v info Term.(const touch $ disk $ file_path) 229 | 230 | (* Remove *) 231 | let remove_cmd = 232 | let doc = "remove a file from a formatted disk" in 233 | let info = Cmd.info "remove" ~doc in 234 | Cmd.v info Term.(const remove $ disk $ file_path) 235 | 236 | (* Rename *) 237 | let old_path = 238 | Arg.( 239 | required 240 | & pos 0 (some string) None 241 | & info [] ~docv:"OLD_PATH" ~doc:"path to rename from") 242 | 243 | let new_path = 244 | Arg.( 245 | required 246 | & pos 1 (some string) None 247 | & info [] ~docv:"NEW_PATH" ~doc:"path to rename to") 248 | 249 | let rename_cmd = 250 | let doc = "rename a file in a formatted disk" in 251 | let info = Cmd.info "rename" ~doc in 252 | Cmd.v info Term.(const rename $ disk $ old_path $ new_path) 253 | 254 | (* Cat *) 255 | let cat_cmd = 256 | let doc = "dump a file from a formatted disk" in 257 | let info = Cmd.info "cat" ~doc in 258 | Cmd.v info Term.(const cat $ disk $ file_path) 259 | 260 | (* Stats *) 261 | let stats_cmd = 262 | let doc = "gives some stats about a file from a formatted disk" in 263 | let info = Cmd.info "stats" ~doc in 264 | Cmd.v info Term.(const stats $ disk $ file_path) 265 | 266 | (* Copy *) 267 | let file_path n = 268 | Arg.( 269 | required 270 | & pos n (some string) None 271 | & info 272 | [] 273 | ~docv:"FILE_PATH" 274 | ~doc:"path to copy from/to (prefix with '@' for disk paths)") 275 | 276 | let copy_cmd = 277 | let doc = "copies a file from/to a formatted disk, disk paths need the prefix '@'" in 278 | let info = Cmd.info "copy" ~doc in 279 | Cmd.v info Term.(const copy $ disk $ file_path 0 $ file_path 1) 280 | 281 | (* List *) 282 | let path = 283 | Arg.(value & pos ~rev:true 0 string "/" & info [] ~docv:"PATH" ~doc:"path to list") 284 | 285 | let list_cmd = 286 | let doc = "lists the files available on a disk" in 287 | let info = Cmd.info "list" ~doc in 288 | Cmd.v info Term.(const list $ disk $ path) 289 | 290 | (* Tree *) 291 | let path = 292 | Arg.( 293 | value 294 | & pos ~rev:true 0 string "/" 295 | & info [] ~docv:"PATH" ~doc:"path to list recursively") 296 | 297 | let tree_cmd = 298 | let doc = "lists recursively the files available on a disk" in 299 | let info = Cmd.info "tree" ~doc in 300 | Cmd.v info Term.(const tree $ disk $ path) 301 | -------------------------------------------------------------------------------- /cli/common_args.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | open Context 3 | 4 | let return_disk = function 5 | | Error err -> 6 | Fmt.pr "Disk connect failed: %a@." Disk.pp_error err ; 7 | exit 1 8 | | Ok disk -> Lwt.return disk 9 | 10 | let connect_block disk_path = Lwt_main.run (Block.connect disk_path) 11 | 12 | let connect_disk disk_path = 13 | let make_disk = 14 | let open Lwt.Syntax in 15 | let* block = Block.connect disk_path in 16 | let disk = Disk.connect block in 17 | Lwt.bind disk (function 18 | | Error (`Wrong_page_size page_size) -> 19 | let* () = Block.disconnect block in 20 | let* block = Block.connect ~prefered_sector_size:(Some page_size) disk_path in 21 | let disk = Disk.connect block in 22 | Lwt.bind disk return_disk 23 | | r -> return_disk r) 24 | in 25 | Lwt_main.run make_disk 26 | 27 | (* Disk *) 28 | 29 | let disk_path = 30 | Arg.( 31 | required 32 | & opt (some file) None 33 | & info [ "d"; "disk" ] ~docv:"DISK_PATH" ~doc:"path to a disk") 34 | 35 | let disk_path_pos = 36 | Arg.(required & pos 0 (some file) None & info [] ~doc:"path to a disk") 37 | 38 | let disk = Term.(const connect_disk $ disk_path) 39 | let block = Term.(const connect_block $ disk_path_pos) 40 | 41 | let file_path = 42 | Arg.( 43 | required 44 | & pos ~rev:true 0 (some string) None 45 | & info [] ~docv:"FILE_PATH" ~doc:"path to a file") 46 | -------------------------------------------------------------------------------- /cli/context.ml: -------------------------------------------------------------------------------- 1 | module Disk = Notafs.KV (Pclock) (Notafs.Adler32) (Block) 2 | -------------------------------------------------------------------------------- /cli/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name notafs_cli) 3 | (public_name notafs-cli) 4 | (package notafs-cli) 5 | (modules notafs_cli commands common_args context) 6 | (libraries notafs fmt fmt.tty cmdliner mirage-block-unix mirage-clock-unix)) 7 | -------------------------------------------------------------------------------- /cli/notafs_cli.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | open Commands 3 | 4 | let setup () = 5 | let style_renderer = `Ansi_tty in 6 | Fmt_tty.setup_std_outputs ~style_renderer () 7 | 8 | (* Main command *) 9 | let main_cmd = 10 | let doc = "cli for notafs disks" in 11 | let info = Cmd.info "notafs-cli" ~version:"%%VERSION%%" ~doc in 12 | let default = Term.(ret (const (`Help (`Pager, None)))) in 13 | let commands = 14 | Cmd.group 15 | info 16 | ~default 17 | [ format_cmd 18 | ; info_cmd 19 | ; touch_cmd 20 | ; remove_cmd 21 | ; rename_cmd 22 | ; cat_cmd 23 | ; copy_cmd 24 | ; stats_cmd 25 | ; list_cmd 26 | ; tree_cmd 27 | ] 28 | in 29 | commands 30 | 31 | let () = 32 | setup () ; 33 | exit (Cmd.eval ~catch:false main_cmd) 34 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (vendored_dirs vendor) 2 | 3 | (data_only_dirs unikernel-*) 4 | 5 | (env 6 | (release 7 | (flags 8 | (:standard -noassert)))) 9 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.1) 2 | 3 | (generate_opam_files true) 4 | 5 | (name notafs) 6 | (source (github tarides/notafs)) 7 | (license ISC) 8 | (authors "Arthur Wendling" "Gwenaëlle Lecat" "Charlène Gros") 9 | (maintainers "arthur@tarides.com") 10 | (version 0.1) 11 | 12 | (package 13 | (name notafs) 14 | (synopsis "Not a filesystem for MirageOS block devices") 15 | (depends 16 | (ocaml (>= "4.12.0")) 17 | checkseum 18 | mirage-block 19 | (mirage-kv (>= "6.1.1")) 20 | mirage-clock 21 | optint 22 | repr 23 | ppx_repr 24 | (mirage-block-unix :with-test) 25 | (mirage-clock-unix :with-test) 26 | (tar-mirage :with-test) 27 | (graphics :with-test) 28 | (color :with-test))) 29 | 30 | (package 31 | (name notafs-cli) 32 | (synopsis "Notafs command-line tool") 33 | (depends 34 | (notafs :=version) 35 | mirage-block-unix 36 | mirage-clock-unix 37 | cmdliner 38 | fmt)) 39 | 40 | (package 41 | (name lwt_direct) 42 | (synopsis "Direct style for Lwt") 43 | (depends 44 | (ocaml (>= "5.0.0")) 45 | lwt)) 46 | 47 | (package 48 | (name index-notafs) 49 | (synopsis "Index using notafs") 50 | (depends 51 | (index (= "dev")) 52 | (notafs :=version) 53 | lwt_direct)) 54 | 55 | (package 56 | (name irmin-pack-notafs) 57 | (synopsis "Irmin-pack using notafs") 58 | (depends 59 | (irmin-pack (= "dev")) 60 | (index-notafs :=version) 61 | ppx_irmin 62 | lwt_direct)) 63 | -------------------------------------------------------------------------------- /index-notafs.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.1" 4 | synopsis: "Index using notafs" 5 | maintainer: ["arthur@tarides.com"] 6 | authors: ["Arthur Wendling" "Gwenaëlle Lecat" "Charlène Gros"] 7 | license: "ISC" 8 | homepage: "https://github.com/tarides/notafs" 9 | bug-reports: "https://github.com/tarides/notafs/issues" 10 | depends: [ 11 | "dune" {>= "3.1"} 12 | "index" {= "dev"} 13 | "notafs" {=version} 14 | "lwt_direct" 15 | "odoc" {with-doc} 16 | ] 17 | build: [ 18 | ["dune" "subst"] {dev} 19 | [ 20 | "dune" 21 | "build" 22 | "-p" 23 | name 24 | "-j" 25 | jobs 26 | "@install" 27 | "@runtest" {with-test} 28 | "@doc" {with-doc} 29 | ] 30 | ] 31 | dev-repo: "git+https://github.com/tarides/notafs.git" 32 | pin-depends: [ 33 | [ "index.dev" "git+https://github.com/art-w/index#mirage-io" ] 34 | ] 35 | -------------------------------------------------------------------------------- /index-notafs.opam.template: -------------------------------------------------------------------------------- 1 | pin-depends: [ 2 | [ "index.dev" "git+https://github.com/art-w/index#mirage-io" ] 3 | ] 4 | -------------------------------------------------------------------------------- /index-notafs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name index-notafs) 3 | (name index_notafs) 4 | (libraries mirage-clock optint index notafs mtime lwt_direct)) 5 | -------------------------------------------------------------------------------- /index-notafs/index_notafs.ml: -------------------------------------------------------------------------------- 1 | module Int63 = Optint.Int63 2 | 3 | module Make 4 | (Mclock : Mirage_clock.MCLOCK) 5 | (Pclock : Mirage_clock.PCLOCK) 6 | (B : Mirage_block.S) = 7 | struct 8 | module Fs = Notafs.FS (Pclock) (Notafs.Adler32) (B) 9 | 10 | module IO = struct 11 | open Lwt.Syntax 12 | 13 | type t = Fs.file 14 | 15 | let fs = ref None 16 | 17 | let init block = 18 | let+ filesystem = Fs.connect block in 19 | fs := Some filesystem 20 | 21 | let fs () = 22 | match !fs with 23 | | Some fs -> fs 24 | | None -> failwith "expected fs?" 25 | 26 | let exists filename = Fs.exists (fs ()) filename = Some `Value 27 | 28 | module Header_raw = struct 29 | let max_fan_index = 0 30 | let max_fan_size = Int63.encoded_size 31 | let version_index = max_fan_index + max_fan_size 32 | let version_size = Int63.encoded_size 33 | let generation_index = version_index + version_size 34 | let generation_size = Int63.encoded_size 35 | let fan_size_index = generation_index + generation_size 36 | let fan_size_size = Int63.encoded_size 37 | let size = fan_size_index + fan_size_size 38 | 39 | let encode_int63 n = 40 | let buf = Bytes.create Int63.encoded_size in 41 | Int63.encode buf ~off:0 n ; 42 | Bytes.unsafe_to_string buf 43 | 44 | let decode_int63 buf = Int63.decode ~off:0 buf 45 | 46 | let read file off len = 47 | let bytes = Bytes.create len in 48 | let q = Lwt_direct.direct (fun () -> Fs.blit_to_bytes file ~off ~len bytes) in 49 | assert (q = len) ; 50 | Bytes.to_string bytes 51 | 52 | let get_max_fan str = decode_int63 (read str max_fan_index max_fan_size) 53 | let get_version str = decode_int63 (read str version_index version_size) 54 | let get_generation str = decode_int63 (read str generation_index generation_size) 55 | 56 | let get_fan_size str = 57 | Int63.to_int (decode_int63 (read str fan_size_index fan_size_size)) 58 | 59 | let get_fan file = 60 | let len = get_fan_size file in 61 | read file size len 62 | 63 | let set_max_fan file v = 64 | Fs.blit_from_string file ~off:max_fan_index ~len:max_fan_size (encode_int63 v) 65 | 66 | let set_version file v = 67 | Fs.blit_from_string file ~off:version_index ~len:version_size (encode_int63 v) 68 | 69 | let set_generation file v = 70 | Fs.blit_from_string 71 | file 72 | ~off:generation_index 73 | ~len:generation_size 74 | (encode_int63 v) 75 | 76 | let set_fan_size file v = 77 | let v = Int63.of_int v in 78 | Fs.blit_from_string file ~off:fan_size_index ~len:fan_size_size (encode_int63 v) 79 | 80 | let set_fan file str = 81 | let len = String.length str in 82 | let out = encode_int63 (Int63.of_int len) ^ str in 83 | assert (fan_size_size + len = String.length out) ; 84 | Fs.blit_from_string file ~off:fan_size_index ~len:(String.length out) out 85 | 86 | let do_make_string ~offset:_ ~version ~generation ~max_fan ~fan = 87 | let fan_size = String.length fan in 88 | encode_int63 max_fan 89 | ^ encode_int63 version 90 | ^ encode_int63 generation 91 | ^ encode_int63 (Int63.of_int fan_size) 92 | ^ fan 93 | ^ String.make (Int63.to_int max_fan - fan_size) '~' 94 | 95 | let header_size _rope = size + 0 (* Int63.to_int (get_max_fan rope) *) 96 | end 97 | 98 | let v ?flush_callback:_ ~fresh ~generation ~fan_size filename = 99 | let ex = exists filename in 100 | if not (fresh || not ex) 101 | then ( 102 | match Fs.find (fs ()) filename with 103 | | None -> Printf.ksprintf failwith "Not_found: Index.v %S" filename 104 | | Some file -> file) 105 | else begin 106 | let header = 107 | Header_raw.do_make_string 108 | ~version:Int63.zero 109 | ~offset:Int63.zero 110 | ~generation 111 | ~max_fan:fan_size 112 | ~fan:"" 113 | in 114 | if ex then Lwt_direct.direct (fun () -> Fs.remove (fs ()) filename) ; 115 | Lwt_direct.direct (fun () -> Fs.touch (fs ()) filename header) 116 | end 117 | 118 | let v_readonly filename = 119 | match Fs.find (fs ()) filename with 120 | | None -> Error `No_file_on_disk 121 | | Some file -> Ok file 122 | 123 | let size_header file = Header_raw.header_size file 124 | 125 | let offset filename = 126 | let size = Lwt_direct.direct (fun () -> Fs.size filename) in 127 | let hs = size_header filename in 128 | Int63.of_int (size - hs) 129 | 130 | let read file ~off ~len bytes = 131 | let off = Int63.to_int off in 132 | let header_size = size_header file in 133 | let q = 134 | Lwt_direct.direct (fun () -> 135 | Fs.blit_to_bytes file ~off:(off + header_size) ~len bytes) 136 | in 137 | assert (q = len) ; 138 | q 139 | 140 | let clear ~generation ?hook:_ ~reopen file = 141 | let reopen = 142 | if not reopen 143 | then None 144 | else begin 145 | let len = Header_raw.header_size file in 146 | let bytes = Bytes.create len in 147 | let q = Lwt_direct.direct (fun () -> Fs.blit_to_bytes file ~off:0 ~len bytes) in 148 | assert (q = len) ; 149 | Some (Bytes.to_string bytes) 150 | end 151 | in 152 | Lwt_direct.direct 153 | @@ fun () -> 154 | match reopen with 155 | | None -> 156 | let* () = Fs.remove (fs ()) (Fs.filename file) in 157 | Lwt.return () 158 | | Some header -> 159 | let* () = Fs.rename (fs ()) ~src:(Fs.filename file) ~dst:header in 160 | Header_raw.set_generation file generation 161 | 162 | let flush ?no_callback:_ ?with_fsync:_ _ = () 163 | let get_generation filename = Header_raw.get_generation filename 164 | let set_fanout file v = Lwt_direct.direct (fun () -> Header_raw.set_fan file v) 165 | let get_fanout file = Header_raw.get_fan file 166 | let get_fanout_size file = Int63.of_int (Header_raw.get_fan_size file) 167 | 168 | let rename ~src ~dst = 169 | Lwt_direct.direct (fun () -> 170 | Fs.rename (fs ()) ~src:(Fs.filename src) ~dst:(Fs.filename dst)) 171 | 172 | let append_substring file str ~off ~len = 173 | Lwt_direct.direct (fun () -> Fs.append_substring file str ~off ~len) 174 | 175 | let append filename str = 176 | append_substring filename str ~off:0 ~len:(String.length str) 177 | 178 | let close _filename = () 179 | 180 | module Lock = struct 181 | type t = string 182 | 183 | let lock str = str 184 | let unlock _lc = () 185 | let pp_dump _str = None 186 | end 187 | 188 | module Header = struct 189 | type header = 190 | { offset : Int63.t 191 | ; generation : Int63.t 192 | } 193 | 194 | let set _file _header = failwith "Header.set" (* unused? *) 195 | let get file = { offset = offset file; generation = get_generation file } 196 | end 197 | 198 | let size _file = failwith "Header.size" (* unused? *) 199 | end 200 | 201 | module Semaphore = struct 202 | type t = Lwt_mutex.t 203 | 204 | let make bool = 205 | let t = Lwt_mutex.create () in 206 | if not bool then Lwt_direct.direct (fun () -> Lwt_mutex.lock t) ; 207 | t 208 | 209 | let acquire _str t = Lwt_direct.direct (fun () -> Lwt_mutex.lock t) 210 | let release t = Lwt_mutex.unlock t 211 | 212 | let with_acquire _str t fn = 213 | Lwt_direct.direct (fun () -> 214 | Lwt_mutex.with_lock t (fun () -> Lwt_direct.indirect fn)) 215 | 216 | let is_held t = Lwt_mutex.is_locked t 217 | end 218 | 219 | module Clock = struct 220 | type counter = int64 221 | 222 | let counter () = Mclock.elapsed_ns () 223 | 224 | let count t = 225 | let now = Mclock.elapsed_ns () in 226 | Mtime.Span.of_uint64_ns (Int64.sub now t) 227 | 228 | let start = counter () 229 | let elapsed () = count start 230 | 231 | let now () = 232 | let now = Mclock.elapsed_ns () in 233 | Mtime.of_uint64_ns (Int64.sub now start) 234 | end 235 | 236 | (* TODO: this triggers a race condition in index merge (?) 237 | 238 | module Thread_lwt = struct 239 | type 'a t = ('a, [ `Async_exn of exn ]) result Lwt.t 240 | 241 | let async fn = 242 | Lwt.catch 243 | (fun () -> 244 | let open Lwt.Syntax in 245 | let+ x = Lwt_direct.indirect fn in 246 | Ok x) 247 | (fun exn -> Lwt.return (Error (`Async_exn exn))) 248 | 249 | let await t = Lwt_direct.direct (fun () -> t) 250 | let return x = Lwt.return (Ok x) 251 | let yield () = Lwt_direct.direct (fun () -> Lwt.pause ()) 252 | end 253 | *) 254 | 255 | module Thread = struct 256 | type 'a t = ('a, [ `Async_exn of exn ]) result 257 | 258 | let async fn = 259 | Lwt_direct.direct (fun () -> 260 | Lwt.catch 261 | (fun () -> 262 | let open Lwt.Syntax in 263 | let+ x = Lwt_direct.indirect fn in 264 | Ok x) 265 | (fun exn -> Lwt.return (Error (`Async_exn exn)))) 266 | 267 | let await t = t 268 | let return x = Ok x 269 | let yield () = Lwt_direct.direct Lwt.pause 270 | end 271 | 272 | module Progress = Progress_engine.Make (struct 273 | module Clock = Clock 274 | 275 | module Terminal_width = struct 276 | let set_changed_callback _ = () 277 | let get () = None 278 | end 279 | end) 280 | 281 | module Fmt_tty = struct 282 | let setup_std_outputs ?style_renderer ?(utf_8 = false) () = 283 | let config formatter = 284 | Option.iter (Fmt.set_style_renderer formatter) style_renderer ; 285 | Fmt.set_utf_8 formatter utf_8 286 | in 287 | config Format.std_formatter ; 288 | config Format.err_formatter 289 | end 290 | end 291 | -------------------------------------------------------------------------------- /irmin-pack-notafs.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.1" 4 | synopsis: "Irmin-pack using notafs" 5 | maintainer: ["arthur@tarides.com"] 6 | authors: ["Arthur Wendling" "Gwenaëlle Lecat" "Charlène Gros"] 7 | license: "ISC" 8 | homepage: "https://github.com/tarides/notafs" 9 | bug-reports: "https://github.com/tarides/notafs/issues" 10 | depends: [ 11 | "dune" {>= "3.1"} 12 | "irmin-pack" {= "dev"} 13 | "index-notafs" {=version} 14 | "ppx_irmin" 15 | "lwt_direct" 16 | "odoc" {with-doc} 17 | ] 18 | build: [ 19 | ["dune" "subst"] {dev} 20 | [ 21 | "dune" 22 | "build" 23 | "-p" 24 | name 25 | "-j" 26 | jobs 27 | "@install" 28 | "@runtest" {with-test} 29 | "@doc" {with-doc} 30 | ] 31 | ] 32 | dev-repo: "git+https://github.com/tarides/notafs.git" 33 | pin-depends: [ 34 | [ "irmin.dev" "git+https://github.com/art-w/irmin#mirage-io" ] 35 | [ "irmin-pack.dev" "git+https://github.com/art-w/irmin#mirage-io" ] 36 | [ "ppx_irmin.dev" "git+https://github.com/art-w/irmin#mirage-io" ] 37 | ] 38 | -------------------------------------------------------------------------------- /irmin-pack-notafs.opam.template: -------------------------------------------------------------------------------- 1 | pin-depends: [ 2 | [ "irmin.dev" "git+https://github.com/art-w/irmin#mirage-io" ] 3 | [ "irmin-pack.dev" "git+https://github.com/art-w/irmin#mirage-io" ] 4 | [ "ppx_irmin.dev" "git+https://github.com/art-w/irmin#mirage-io" ] 5 | ] 6 | -------------------------------------------------------------------------------- /irmin-pack-notafs/async.ml: -------------------------------------------------------------------------------- 1 | type outcome = 2 | [ `Success 3 | | `Cancelled 4 | | `Failure of string 5 | ] 6 | [@@deriving irmin] 7 | 8 | type status = 9 | [ `Success 10 | | `Cancelled 11 | | `Failure of string 12 | | `Running 13 | ] 14 | [@@deriving irmin] 15 | 16 | type t = outcome 17 | 18 | let async fn : t = 19 | try 20 | fn () ; 21 | `Success 22 | with 23 | | err -> `Failure (Printexc.to_string err) 24 | 25 | let await (#t as t) = t 26 | let status (#t as t) = t 27 | let cancel (_ : t) = false 28 | -------------------------------------------------------------------------------- /irmin-pack-notafs/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name irmin-pack-notafs) 3 | (name irmin_pack_notafs) 4 | (libraries 5 | lwt_direct 6 | index_notafs 7 | irmin 8 | irmin-pack 9 | irmin-pack.io 10 | mirage-clock 11 | progress.engine) 12 | (preprocess 13 | (pps ppx_irmin.internal))) 14 | -------------------------------------------------------------------------------- /irmin-pack-notafs/io.ml: -------------------------------------------------------------------------------- 1 | module Int63 = Optint.Int63 2 | 3 | module type S = Irmin_pack_io.Io_s 4 | 5 | module Make 6 | (Mclock : Mirage_clock.MCLOCK) 7 | (Pclock : Mirage_clock.PCLOCK) 8 | (B : Mirage_block.S) = 9 | struct 10 | module Index_platform = Index_notafs.Make (Mclock) (Pclock) (B) 11 | module Fs = Index_platform.Fs 12 | 13 | let init b = Index_platform.IO.init b 14 | let fs () = Index_platform.IO.fs () 15 | let notafs_flush () = Lwt_direct.direct (fun () -> Fs.flush (fs ())) 16 | 17 | type t = Index_platform.IO.t 18 | type misc_error = unit [@@deriving irmin] 19 | 20 | type create_error = 21 | [ `Io_misc of misc_error 22 | | `File_exists of string 23 | ] 24 | 25 | type open_error = 26 | [ `Io_misc of misc_error 27 | | `No_such_file_or_directory of string 28 | | `Not_a_file 29 | ] 30 | 31 | type read_error = 32 | [ `Io_misc of misc_error 33 | | `Read_out_of_bounds 34 | | `Closed 35 | | `Invalid_argument 36 | ] 37 | 38 | type write_error = 39 | [ `Io_misc of misc_error 40 | | `Ro_not_allowed 41 | | `Closed 42 | ] 43 | 44 | type close_error = 45 | [ `Io_misc of misc_error 46 | | `Double_close 47 | ] 48 | 49 | type mkdir_error = 50 | [ `Io_misc of misc_error 51 | | `File_exists of string 52 | | `No_such_file_or_directory of string 53 | | `Invalid_parent_directory 54 | ] 55 | 56 | let create ~path ~overwrite = 57 | Lwt_direct.direct 58 | @@ fun () -> 59 | let open Lwt.Syntax in 60 | let t = fs () in 61 | if overwrite 62 | then 63 | let* () = 64 | if Fs.exists t path = Some `Value then Fs.remove t path else Lwt.return_unit 65 | in 66 | let+ r = Fs.touch t path "" in 67 | Ok r 68 | else ( 69 | match Fs.find t path with 70 | | None -> 71 | let+ r = Fs.touch t path "" in 72 | Ok r 73 | | Some file -> Lwt.return (Ok file)) 74 | 75 | let open_ ~path ~readonly:_ = 76 | match Fs.find (fs ()) path with 77 | | None -> Error (`No_such_file_or_directory path) 78 | | Some file -> Ok file 79 | 80 | let close _t = 81 | notafs_flush () ; 82 | Ok () 83 | 84 | let write_string t ~off str = 85 | let off = Int63.to_int off in 86 | Ok 87 | (Lwt_direct.direct 88 | @@ fun () -> Fs.blit_from_string t ~off ~len:(String.length str) str) 89 | 90 | let fsync _t = 91 | notafs_flush () ; 92 | Ok () 93 | 94 | let move_file ~src ~dst = Ok (Lwt_direct.direct @@ fun () -> Fs.rename (fs ()) ~src ~dst) 95 | 96 | let copy_file ~src ~dst = 97 | let _ = failwith (Printf.sprintf "Io.copy_file ~src:%S ~dst:%S" src dst) in 98 | Error (`Sys_error "copy_file") 99 | 100 | let readdir _path = [] 101 | let rmdir _path = () 102 | let mkdir _path = Ok () 103 | let unlink path = Ok (Lwt_direct.direct @@ fun () -> Fs.remove (fs ()) path) 104 | 105 | let unlink_dont_wait ~on_exn:_ path = 106 | Lwt_direct.direct @@ fun () -> Fs.remove (fs ()) path 107 | 108 | let read_to_string t ~off ~len = 109 | Lwt_direct.direct 110 | @@ fun () -> 111 | let bytes = Bytes.create len in 112 | let open Lwt.Syntax in 113 | let off = Int63.to_int off in 114 | let+ _ = Fs.blit_to_bytes t ~off ~len bytes in 115 | Ok (Bytes.to_string bytes) 116 | 117 | let read_all_to_string t = 118 | Lwt_direct.direct 119 | @@ fun () -> 120 | let open Lwt.Syntax in 121 | let* len = Fs.size t in 122 | let bytes = Bytes.create len in 123 | let+ _ = Fs.blit_to_bytes t ~off:0 ~len bytes in 124 | Ok (Bytes.to_string bytes) 125 | 126 | let read_size t = 127 | Lwt_direct.direct 128 | @@ fun () -> 129 | let open Lwt.Syntax in 130 | let+ len = Fs.size t in 131 | Ok (Int63.of_int len) 132 | 133 | let size_of_path path = 134 | match Fs.find (fs ()) path with 135 | | None -> Error (`No_such_file_or_directory path) 136 | | Some file -> read_size file 137 | 138 | let classify_path path = 139 | match Fs.exists (fs ()) path with 140 | | Some `Value -> `File 141 | | Some `Dictionary -> `Directory 142 | | None -> `No_such_file_or_directory 143 | 144 | let readonly _t = false 145 | let path t = Fs.filename t 146 | let page_size = -1 147 | 148 | let read_exn t ~off ~len bytes = 149 | let off = Int63.to_int off in 150 | let q = Lwt_direct.direct @@ fun () -> Fs.blit_to_bytes t ~off ~len bytes in 151 | assert (q = len) 152 | 153 | let write_exn t ~off ~len str = 154 | let off = Int63.to_int off in 155 | Lwt_direct.direct @@ fun () -> Fs.blit_from_string t ~off ~len str 156 | 157 | exception Misc of misc_error 158 | 159 | let raise_misc_error misc_error = raise (Misc misc_error) 160 | 161 | let catch_misc_error fn = 162 | try Ok (fn ()) with 163 | | Misc m -> Error (`Io_misc m) 164 | 165 | module Stats = struct 166 | let get_wtime () = 0.0 167 | let get_stime () = 0.0 168 | let get_utime () = 0.0 169 | 170 | let get_rusage () = 171 | Irmin_pack_io.Stats_intf.Latest_gc. 172 | { maxrss = Int64.zero 173 | ; minflt = Int64.zero 174 | ; majflt = Int64.zero 175 | ; inblock = Int64.zero 176 | ; oublock = Int64.zero 177 | ; nvcsw = Int64.zero 178 | ; nivcsw = Int64.zero 179 | } 180 | end 181 | 182 | module Clock = struct 183 | type counter = int64 184 | 185 | let counter () = Mclock.elapsed_ns () 186 | 187 | let count t = 188 | let now = Mclock.elapsed_ns () in 189 | Mtime.Span.of_uint64_ns (Int64.sub now t) 190 | 191 | let start = counter () 192 | let elapsed () = count start 193 | 194 | let now () = 195 | let now = Mclock.elapsed_ns () in 196 | Mtime.of_uint64_ns (Int64.sub now start) 197 | end 198 | 199 | module Progress = Progress_engine.Make (struct 200 | module Clock = Clock 201 | 202 | module Terminal_width = struct 203 | let set_changed_callback _ = () 204 | let get () = None 205 | end 206 | end) 207 | end 208 | -------------------------------------------------------------------------------- /irmin-pack-notafs/io.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2022-2022 Tarides 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 | module Make 18 | (Mclock : Mirage_clock.MCLOCK) 19 | (Pclock : Mirage_clock.PCLOCK) 20 | (B : Mirage_block.S) : sig 21 | module Index_platform : Index.Platform.S 22 | 23 | val init : B.t -> unit Lwt.t 24 | val notafs_flush : unit -> unit 25 | 26 | module Fs : module type of Notafs.FS (Pclock) (Notafs.Adler32) (B) 27 | include Irmin_pack_io.Io_s 28 | end 29 | -------------------------------------------------------------------------------- /irmin-pack-notafs/irmin_pack_notafs.ml: -------------------------------------------------------------------------------- 1 | module Maker 2 | (Mclock : Mirage_clock.MCLOCK) 3 | (Pclock : Mirage_clock.PCLOCK) 4 | (Block : Mirage_block.S) 5 | (Config : Irmin_pack.Conf.S) = 6 | struct 7 | module Io = Io.Make (Mclock) (Pclock) (Block) 8 | module Fs = Io.Fs 9 | include Irmin_pack_io.Maker_io (Io) (Io.Index_platform) (Async) (Config) 10 | end 11 | -------------------------------------------------------------------------------- /lwt_direct.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.1" 4 | synopsis: "Direct style for Lwt" 5 | maintainer: ["arthur@tarides.com"] 6 | authors: ["Arthur Wendling" "Gwenaëlle Lecat" "Charlène Gros"] 7 | license: "ISC" 8 | homepage: "https://github.com/tarides/notafs" 9 | bug-reports: "https://github.com/tarides/notafs/issues" 10 | depends: [ 11 | "dune" {>= "3.1"} 12 | "ocaml" {>= "5.0.0"} 13 | "lwt" 14 | "odoc" {with-doc} 15 | ] 16 | build: [ 17 | ["dune" "subst"] {dev} 18 | [ 19 | "dune" 20 | "build" 21 | "-p" 22 | name 23 | "-j" 24 | jobs 25 | "@install" 26 | "@runtest" {with-test} 27 | "@doc" {with-doc} 28 | ] 29 | ] 30 | dev-repo: "git+https://github.com/tarides/notafs.git" 31 | -------------------------------------------------------------------------------- /lwt_direct/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name lwt_direct) 3 | (name lwt_direct) 4 | (libraries lwt)) 5 | -------------------------------------------------------------------------------- /lwt_direct/lwt_direct.ml: -------------------------------------------------------------------------------- 1 | open Effect.Deep 2 | 3 | type _ Effect.t += Lwt : (unit -> 'a Lwt.t) -> 'a Effect.t 4 | 5 | let direct lwt = Effect.perform (Lwt lwt) 6 | 7 | let indirect fn = 8 | match_with 9 | fn 10 | () 11 | { retc = Lwt.return 12 | ; exnc = (fun e -> raise e) 13 | ; effc = 14 | (fun (type a) (e : a Effect.t) -> 15 | match e with 16 | | Lwt lwt -> 17 | Some 18 | (fun k -> 19 | let open Lwt.Syntax in 20 | let* x = 21 | Lwt.catch 22 | (fun () -> 23 | let+ x = lwt () in 24 | Ok x) 25 | (fun e -> Lwt.return (Error e)) 26 | in 27 | match x with 28 | | Ok v -> continue k v 29 | | Error e -> discontinue k e) 30 | | _ -> None) 31 | } 32 | -------------------------------------------------------------------------------- /notafs-cli.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.1" 4 | synopsis: "Notafs command-line tool" 5 | maintainer: ["arthur@tarides.com"] 6 | authors: ["Arthur Wendling" "Gwenaëlle Lecat" "Charlène Gros"] 7 | license: "ISC" 8 | homepage: "https://github.com/tarides/notafs" 9 | bug-reports: "https://github.com/tarides/notafs/issues" 10 | depends: [ 11 | "dune" {>= "3.1"} 12 | "notafs" {=version} 13 | "mirage-block-unix" 14 | "mirage-clock-unix" 15 | "cmdliner" 16 | "fmt" 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/tarides/notafs.git" 34 | -------------------------------------------------------------------------------- /notafs.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.1" 4 | synopsis: "Not a filesystem for MirageOS block devices" 5 | maintainer: ["arthur@tarides.com"] 6 | authors: ["Arthur Wendling" "Gwenaëlle Lecat" "Charlène Gros"] 7 | license: "ISC" 8 | homepage: "https://github.com/tarides/notafs" 9 | bug-reports: "https://github.com/tarides/notafs/issues" 10 | depends: [ 11 | "dune" {>= "3.1"} 12 | "ocaml" {>= "4.12.0"} 13 | "checkseum" 14 | "mirage-block" 15 | "mirage-kv" {>= "6.1.1"} 16 | "mirage-clock" 17 | "optint" 18 | "repr" 19 | "ppx_repr" 20 | "mirage-block-unix" {with-test} 21 | "mirage-clock-unix" {with-test} 22 | "tar-mirage" {with-test} 23 | "graphics" {with-test} 24 | "color" {with-test} 25 | "odoc" {with-doc} 26 | ] 27 | build: [ 28 | ["dune" "subst"] {dev} 29 | [ 30 | "dune" 31 | "build" 32 | "-p" 33 | name 34 | "-j" 35 | jobs 36 | "@install" 37 | "@runtest" {with-test} 38 | "@doc" {with-doc} 39 | ] 40 | ] 41 | dev-repo: "git+https://github.com/tarides/notafs.git" 42 | -------------------------------------------------------------------------------- /src/checksum.ml: -------------------------------------------------------------------------------- 1 | (** Checksum signatures & default implementations. *) 2 | 3 | (** Signature for checksum modules. *) 4 | module type S = sig 5 | type t 6 | (** Representation of the checksum value. *) 7 | 8 | val name : string 9 | (** Name of the implementation. 10 | 11 | This will be used to check that the disk used the same algorithm. *) 12 | 13 | val byte_size : int 14 | (** Number of bytes used by the checksum. *) 15 | 16 | val default : t 17 | (** Default value of {!t}. *) 18 | 19 | val equal : t -> t -> bool 20 | (** [equal t1 t2] is the equality between [t1] and [t2]. *) 21 | 22 | val digest : Cstruct.t -> t 23 | (** [digest cs] computes the checksum of the cstruct [cs]. *) 24 | 25 | val read : Cstruct.t -> int -> t 26 | (** [read cs off] is the value {!t} read from the cstruct [cs] at offset [off]. 27 | It's guaranteed that at least {!byte_size} bytes are available at this offset. *) 28 | 29 | val write : Cstruct.t -> int -> t -> unit 30 | (** [write cs off t] writes the value {!t} into the cstruct [cs] at offset [off]. 31 | It's guaranteed that at least {!byte_size} bytes are available at this offset. *) 32 | end 33 | 34 | module No_checksum : S = struct 35 | type t = unit 36 | 37 | let name = "NO-CHECK" 38 | let byte_size = 0 39 | let default = () 40 | let equal = ( = ) 41 | let digest _ = () 42 | let read _ _ = () 43 | let write _ _ _ = () 44 | end 45 | 46 | module Adler32 : S = struct 47 | include Checkseum.Adler32 48 | 49 | let name = "ADLER-32" 50 | let byte_size = 4 51 | 52 | let digest cstruct = 53 | digest_bigstring (Cstruct.to_bigarray cstruct) 0 (Cstruct.length cstruct) default 54 | 55 | let read cstruct offset = of_int32 @@ Cstruct.HE.get_uint32 cstruct offset 56 | let write cstruct offset v = Cstruct.HE.set_uint32 cstruct offset (to_int32 v) 57 | end 58 | -------------------------------------------------------------------------------- /src/context.ml: -------------------------------------------------------------------------------- 1 | module type SIMPLE_DISK = sig 2 | type error 3 | type write_error 4 | type t 5 | 6 | val pp_error : Format.formatter -> error -> unit 7 | val pp_write_error : Format.formatter -> write_error -> unit 8 | val get_info : t -> Mirage_block.info Lwt.t 9 | val read : t -> int64 -> Cstruct.t list -> (unit, error) result Lwt.t 10 | val write : t -> int64 -> Cstruct.t list -> (unit, write_error) result Lwt.t 11 | end 12 | 13 | module type A_DISK = sig 14 | module Id : Id.S 15 | module Check : Checksum.S 16 | module Diet : module type of Diet.Make (Id) 17 | 18 | type read_error 19 | type write_error 20 | 21 | type error = 22 | [ `Read of read_error 23 | | `Write of write_error 24 | | `Invalid_checksum of Int64.t 25 | | `All_generations_corrupted 26 | | `Disk_not_formatted 27 | | `Disk_is_full 28 | | `Wrong_page_size of int 29 | | `Wrong_disk_size of Int64.t 30 | | `Wrong_checksum_algorithm of string * int 31 | ] 32 | 33 | val pp_error : Format.formatter -> error -> unit 34 | val page_size : int 35 | val header_size : int 36 | val nb_sectors : int64 37 | 38 | type sector 39 | 40 | val set_id : sector Lru.elt -> Id.t -> unit 41 | val lru : sector Lru.t 42 | val protect_lru : (unit -> 'a Lwt.t) -> 'a Lwt.t 43 | val cstruct : sector Lru.elt -> (Cstruct.t, [> `Read of read_error ]) Lwt_result.t 44 | val cstruct_in_memory : sector Lru.elt -> Cstruct.t 45 | val read : Id.t -> Cstruct.t -> (unit, [> `Read of read_error ]) Lwt_result.t 46 | val write : Id.t -> Cstruct.t list -> (unit, [> `Write of write_error ]) Lwt_result.t 47 | val discard : Id.t -> unit 48 | val discard_range : Id.t * int -> unit 49 | val acquire_discarded : unit -> (Id.t * int) list 50 | val allocator : (int -> ((Id.t * int) list, error) Lwt_result.t) ref 51 | val allocate : from:[ `Root | `Load ] -> unit -> (sector Lru.elt, error) Lwt_result.t 52 | val unallocate : sector Lru.elt -> unit 53 | val clear : unit -> (unit, error) Lwt_result.t 54 | 55 | val set_finalize 56 | : sector 57 | -> (unit 58 | -> ((int * (Id.t -> (unit, error) Lwt_result.t), Id.t) result, error) Lwt_result.t) 59 | -> unit 60 | end 61 | 62 | let of_impl 63 | (type t e we) 64 | (module B : SIMPLE_DISK with type t = t and type error = e and type write_error = we) 65 | (module Check : Checksum.S) 66 | (disk : t) 67 | = 68 | let open Lwt.Syntax in 69 | let+ info = B.get_info disk in 70 | (module struct 71 | module Id = (val Id.of_nb_pages info.size_sectors) 72 | module Check = Check 73 | module Diet = Diet.Make (Id) 74 | 75 | type page = 76 | | Cstruct of Cstruct.t 77 | | On_disk of Id.t 78 | | Freed 79 | 80 | type read_error = B.error 81 | type write_error = B.write_error 82 | 83 | type error = 84 | [ `Read of read_error 85 | | `Write of write_error 86 | | `Invalid_checksum of Int64.t 87 | | `All_generations_corrupted 88 | | `Disk_is_full 89 | | `Disk_not_formatted 90 | | `Wrong_page_size of int 91 | | `Wrong_disk_size of Int64.t 92 | | `Wrong_checksum_algorithm of string * int 93 | ] 94 | 95 | let pp_error h = function 96 | | `Read e -> B.pp_error h e 97 | | `Write e -> B.pp_write_error h e 98 | | `Invalid_checksum id -> 99 | Format.fprintf h "Invalid_checksum %s" (Int64.to_string id) 100 | | `All_generations_corrupted -> Format.fprintf h "All_generations_corrupted" 101 | | `Disk_not_formatted -> Format.fprintf h "Disk_not_formatted" 102 | | `Disk_is_full -> Format.fprintf h "Disk_is_full" 103 | | `Wrong_page_size s -> Format.fprintf h "Wrong_page_size %d" s 104 | | `Wrong_disk_size i -> Format.fprintf h "Wrong_disk_size %s" (Int64.to_string i) 105 | | `Wrong_checksum_algorithm (s, i) -> 106 | Format.fprintf h "Wrong_checksum_algorithm (%s, %d)" s i 107 | | `Unsupported_operation msg -> Format.fprintf h "Unsupported_operation %S" msg 108 | | `Disk_failed -> Format.fprintf h "Disk_failed" 109 | 110 | type sector = 111 | { mutable cstruct : page 112 | ; mutable finalize : 113 | unit 114 | -> ( (int * (Id.t -> (unit, error) Lwt_result.t), Id.t) result 115 | , error ) 116 | Lwt_result.t 117 | } 118 | 119 | let header_size = 1 120 | let page_size = info.sector_size 121 | let nb_sectors = info.size_sectors 122 | 123 | let read page_id cstruct = 124 | let page_id = Id.to_int64 page_id in 125 | let open Lwt.Syntax in 126 | let+ r = B.read disk page_id [ cstruct ] in 127 | Result.map_error (fun e -> `Read e) r 128 | 129 | let write page_id cstructs = 130 | let page_id = Id.to_int64 page_id in 131 | let open Lwt.Syntax in 132 | let+ result = B.write disk page_id cstructs in 133 | Result.map_error (fun e -> `Write e) result 134 | 135 | let discarded = ref Diet.empty 136 | let discard page_id = discarded := Diet.add !discarded page_id 137 | let discard_range r = discarded := Diet.add_range !discarded r 138 | 139 | let acquire_discarded () = 140 | let lst = Diet.to_range_list !discarded in 141 | discarded := Diet.empty ; 142 | lst 143 | 144 | let allocator = ref (fun _ -> failwith "no allocator") 145 | let lru = Lru.make () 146 | let safe_lru = ref true 147 | 148 | let protect_lru fn = 149 | assert !safe_lru ; 150 | safe_lru := false ; 151 | Lwt.map 152 | (fun v -> 153 | safe_lru := true ; 154 | v) 155 | (fn ()) 156 | 157 | let max_lru_size = 1024 158 | let min_lru_size = max_lru_size / 2 159 | let available_cstructs = ref [] 160 | let nb_available = ref 0 161 | 162 | let release_cstructs cstructs = 163 | if !nb_available < max_lru_size 164 | then begin 165 | nb_available := !nb_available + List.length cstructs ; 166 | available_cstructs := List.rev_append cstructs !available_cstructs 167 | end 168 | 169 | let unallocate elt = 170 | let t = Lru.value elt in 171 | begin 172 | match t.cstruct with 173 | | Cstruct cstruct -> 174 | release_cstructs [ cstruct ] ; 175 | t.cstruct <- Freed 176 | | On_disk _id -> () 177 | | Freed -> failwith "Context.unallocate Freed" 178 | end ; 179 | Lru.detach elt lru 180 | 181 | let set_id elt id = 182 | let t = Lru.value elt in 183 | begin 184 | match t.cstruct with 185 | | Cstruct cstruct -> 186 | release_cstructs [ cstruct ] ; 187 | t.cstruct <- On_disk id 188 | | On_disk id' -> assert (Id.equal id id') 189 | | Freed -> failwith "Context.set_id: Freed" 190 | end ; 191 | Lru.detach_remove elt lru 192 | 193 | let rec write_all = function 194 | | [] -> Lwt_result.return () 195 | | (id, cs) :: css -> 196 | let open Lwt_result.Syntax in 197 | let id_ = Int64.to_int @@ Id.to_int64 id in 198 | assert (id_ <> 0 && id_ <> 1) ; 199 | let* () = write id cs in 200 | write_all css 201 | 202 | let no_finalizer _ = failwith "no finalizer" 203 | 204 | let rec list_align_with acc rest n ss = 205 | match rest, ss with 206 | | ((_, len) as r) :: rest, _ when len = n -> list_align_with (r :: acc) rest 0 ss 207 | | _, _ :: ss -> list_align_with acc rest (succ n) ss 208 | | [], [] -> acc, rest 209 | | _, [] when n = 0 -> acc, rest 210 | | (id, len) :: rest, [] -> (id, n) :: acc, (Id.add id n, len - n) :: rest 211 | 212 | let rec lru_clear () = 213 | let open Lwt_result.Syntax in 214 | match Lru.pop_back lru with 215 | | None -> Lwt_result.return () 216 | | Some old -> 217 | let* () = 218 | match old.cstruct with 219 | | Freed -> failwith "Cstruct.lru_make_room: Freed" 220 | | On_disk _ -> Lwt_result.return () 221 | | Cstruct _cstruct -> begin 222 | let* fin = old.finalize () in 223 | match fin with 224 | | Error page_id -> 225 | release_cstructs [ _cstruct ] ; 226 | old.cstruct <- On_disk page_id ; 227 | Lwt_result.return () 228 | | Ok _ -> Lwt_result.return () 229 | end 230 | in 231 | lru_clear () 232 | 233 | let clear () = 234 | let open Lwt_result.Syntax in 235 | let+ () = lru_clear () in 236 | available_cstructs := [] ; 237 | nb_available := 0 238 | 239 | let rec lru_make_room acc = 240 | let open Lwt_result.Syntax in 241 | if (Lru.length lru < min_lru_size && !available_cstructs <> []) 242 | || 243 | match Lru.peek_back lru with 244 | | None -> true 245 | | Some e when e.finalize == no_finalizer -> true 246 | | _ -> false 247 | then begin 248 | match acc with 249 | | [] -> Lwt_result.return () 250 | | _ -> begin 251 | let nb = List.length acc in 252 | let* ids = !allocator nb in 253 | let acc = 254 | List.filter 255 | (fun (s, _, _) -> 256 | match s.cstruct with 257 | | Cstruct _ -> true 258 | | _ -> false) 259 | acc 260 | in 261 | let ids, ids_rest = list_align_with [] ids 0 acc in 262 | List.iter discard_range ids_rest ; 263 | let acc = 264 | List.sort 265 | (fun (_, a_depth, _) (_, b_depth, _) -> Int.compare b_depth a_depth) 266 | acc 267 | in 268 | let rec finalize acc css ids n ss = 269 | match ids, ss with 270 | | [], [] -> Lwt_result.return acc 271 | | (id, len) :: ids, _ when n = len -> 272 | finalize ((id, List.rev css) :: acc) [] ids 0 ss 273 | | (id, _) :: _, (s, _, finalizer) :: ss -> 274 | let* cstruct = 275 | match s.cstruct with 276 | | Cstruct cstruct -> 277 | let id = Id.add id n in 278 | let+ () = finalizer id in 279 | s.cstruct <- On_disk id ; 280 | cstruct 281 | | On_disk _ -> assert false 282 | | Freed -> assert false 283 | in 284 | finalize acc (cstruct :: css) ids (succ n) ss 285 | | _, [] | [], _ -> assert false 286 | in 287 | let* cstructs = finalize [] [] ids 0 acc in 288 | let+ () = write_all cstructs in 289 | let rec sanity_check ids n ss = 290 | match ids, ss with 291 | | [], [] -> () 292 | | (_, len) :: ids, _ when n = len -> sanity_check ids 0 ss 293 | | (id, _) :: _, (s, _, _) :: ss -> 294 | begin 295 | match s.cstruct with 296 | | On_disk id' -> assert (Id.add id n = id') 297 | | Cstruct _ -> failwith "Context.sanity_check: Cstruct" 298 | | Freed -> failwith "Context.sanity_check: Freed" 299 | end ; 300 | sanity_check ids (succ n) ss 301 | | _, [] | [], _ -> assert false 302 | in 303 | sanity_check ids 0 acc ; 304 | List.iter release_cstructs (List.map snd cstructs) 305 | end 306 | end 307 | else 308 | let* acc = 309 | match Lru.pop_back lru with 310 | | None -> assert false 311 | | Some old -> begin 312 | match old.cstruct with 313 | | Freed -> failwith "Cstruct.lru_make_room: Freed" 314 | | On_disk _ -> Lwt_result.return acc 315 | | Cstruct _cstruct -> begin 316 | let* fin = old.finalize () in 317 | match fin with 318 | | Error page_id -> 319 | release_cstructs [ _cstruct ] ; 320 | old.cstruct <- On_disk page_id ; 321 | (* 322 | let fake_cstruct = Cstruct.create page_size in 323 | let* () = read page_id fake_cstruct in 324 | if not (Cstruct.to_string cstruct = Cstruct.to_string fake_cstruct) 325 | then begin 326 | Format.printf "===== SECTOR %s =====@." (Id.to_string page_id) ; 327 | Format.printf "EXPECTED %S@." (Cstruct.to_string cstruct) ; 328 | Format.printf " GOT %S@." (Cstruct.to_string fake_cstruct) ; 329 | failwith "inconsistent" 330 | end ; 331 | *) 332 | Lwt_result.return acc 333 | | Ok (depth, finalizer) -> Lwt_result.return ((old, depth, finalizer) :: acc) 334 | end 335 | end 336 | in 337 | lru_make_room acc 338 | 339 | let cstruct_create () = 340 | match !available_cstructs with 341 | | [] -> 342 | assert (!nb_available = 0) ; 343 | Cstruct.create page_size 344 | | c :: css -> 345 | decr nb_available ; 346 | available_cstructs := css ; 347 | c 348 | 349 | let allocate ~from () = 350 | let sector () = 351 | { cstruct = Cstruct (cstruct_create ()); finalize = no_finalizer } 352 | in 353 | match from with 354 | | `Root -> Lwt_result.return (Lru.make_detached (sector ())) 355 | | `Load -> begin 356 | let open Lwt_result.Syntax in 357 | let make_room () = 358 | if (not !safe_lru) || Lru.length lru < max_lru_size 359 | then Lwt_result.return () 360 | else protect_lru (fun () -> lru_make_room []) 361 | in 362 | let+ () = make_room () in 363 | Lru.make_elt (sector ()) lru 364 | end 365 | 366 | let set_finalize s fn = s.finalize <- fn 367 | 368 | let cstruct_in_memory elt = 369 | let sector = Lru.value elt in 370 | match sector.cstruct with 371 | | Cstruct cstruct -> cstruct 372 | | On_disk _ -> failwith "Context.cstruct_in_memory: On_disk" 373 | | Freed -> failwith "Context.cstruct_in_memory: Freed" 374 | 375 | let cstruct elt = 376 | Lru.use elt lru ; 377 | let sector = Lru.value elt in 378 | match sector.cstruct with 379 | | Freed -> failwith "Context.cstruct: Freed" 380 | | Cstruct cstruct -> Lwt_result.return cstruct 381 | | On_disk page_id -> 382 | let cstruct = cstruct_create () in 383 | let open Lwt_result.Syntax in 384 | let+ () = read page_id cstruct in 385 | sector.cstruct <- Cstruct cstruct ; 386 | cstruct 387 | end : A_DISK 388 | with type read_error = e 389 | and type write_error = we) 390 | -------------------------------------------------------------------------------- /src/diet.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | 4 | val compare : t -> t -> int 5 | val to_string : t -> string 6 | val add : t -> int -> t 7 | end 8 | 9 | module Make (Id : S) = struct 10 | module Diet = Map.Make (Id) 11 | 12 | type t = int Diet.t 13 | 14 | let empty = Diet.empty 15 | 16 | let add_range t (k, len) = 17 | let mlo = 18 | match Diet.find_last (fun key -> Id.compare key (Id.add k len) < 0) t with 19 | | mlk, mlv -> begin 20 | match Id.compare k (Id.add mlk mlv) with 21 | | 0 -> Some mlv 22 | | r when r > 0 -> None 23 | | _ -> assert false 24 | end 25 | | exception Not_found -> None 26 | in 27 | let mro = Diet.find_opt (Id.add k len) t in 28 | match mlo, mro with 29 | | Some mlv, Some mrv -> 30 | let t = Diet.remove (Id.add k len) t in 31 | Diet.add (Id.add k (-mlv)) (mlv + len + mrv) t 32 | | Some mlv, None -> Diet.add (Id.add k (-mlv)) (mlv + len) t 33 | | None, Some mrv -> 34 | let t = Diet.remove (Id.add k len) t in 35 | Diet.add k (mrv + len) t 36 | | None, None -> Diet.add k len t 37 | 38 | let add t k = add_range t (k, 1) 39 | 40 | let to_list t = 41 | Diet.fold 42 | (fun s l acc -> 43 | let rec explode v n lst = 44 | if n = 0 then lst else explode (Id.add v 1) (n - 1) (v :: lst) 45 | in 46 | explode s l acc) 47 | t 48 | [] 49 | 50 | let of_list l = 51 | let t = empty in 52 | let rec adding t l = 53 | match l with 54 | | [] -> t 55 | | hd :: tl -> adding (add t hd) tl 56 | in 57 | adding t l 58 | 59 | let to_range_list t = Diet.bindings t 60 | 61 | let rec list_of_ranges l acc = 62 | match l with 63 | | [] -> acc 64 | | (id, len) :: rest -> 65 | let rec iter id n acc = 66 | if n = len 67 | then list_of_ranges rest acc 68 | else ( 69 | let succ = Id.add id 1 in 70 | iter succ (n + 1) (id :: acc)) 71 | in 72 | iter id 0 acc 73 | 74 | let list_of_ranges l = list_of_ranges l [] 75 | end 76 | -------------------------------------------------------------------------------- /src/diet.mli: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | 4 | val compare : t -> t -> int 5 | val to_string : t -> string 6 | val add : t -> int -> t 7 | end 8 | 9 | module Make (Id : S) : sig 10 | type t 11 | 12 | val empty : t 13 | val add : t -> Id.t -> t 14 | val add_range : t -> Id.t * int -> t 15 | val to_list : t -> Id.t list 16 | val of_list : Id.t list -> t 17 | val to_range_list : t -> (Id.t * int) list 18 | val list_of_ranges : (Id.t * int) list -> Id.t list 19 | end 20 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name notafs) 3 | (name notafs) 4 | (libraries 5 | lwt 6 | mirage-block 7 | mirage-clock 8 | ptime 9 | optint 10 | repr 11 | checkseum.c 12 | mirage-kv) 13 | (preprocess 14 | (pps ppx_repr))) 15 | -------------------------------------------------------------------------------- /src/files.ml: -------------------------------------------------------------------------------- 1 | module Make (Clock : Mirage_clock.PCLOCK) (B : Context.A_DISK) = struct 2 | module Sector = Sector.Make (B) 3 | module Queue = Queue.Make (B) 4 | module Rope = Rope.Make (B) 5 | open Lwt_result.Syntax 6 | 7 | type key = string list 8 | type file = Rope.t ref 9 | type raw_time = float [@@deriving repr] 10 | 11 | type raw_fs = 12 | | Raw_dir of (string * raw_time * raw_fs) list 13 | | Raw_file of Sector.ptr 14 | [@@deriving repr] 15 | 16 | module M = Map.Make (String) 17 | 18 | type time = Ptime.t 19 | 20 | type fs = 21 | | Dir of time * fs M.t 22 | | File of time * Rope.t ref 23 | 24 | type t = 25 | { mutable on_disk : Rope.t 26 | ; files : fs M.t 27 | ; mutable dirty : bool 28 | } 29 | 30 | let string_of_raw = Repr.(unstage (to_bin_string raw_fs_t)) 31 | let raw_of_string = Repr.(unstage (of_bin_string raw_fs_t)) 32 | 33 | let count_new fs = 34 | let rec count_new _segment fs acc = 35 | match fs with 36 | | Dir (_, fs') -> M.fold count_new fs' acc 37 | | File (_, rope) -> 38 | let* acc = acc in 39 | let* c = Rope.count_new !rope in 40 | Lwt_result.return (acc + c) 41 | in 42 | M.fold count_new fs (Lwt_result.return 0) 43 | 44 | let fake fs = 45 | let rec fake segment fs acc = 46 | match fs with 47 | | Dir (_, fs') -> (segment, 0., Raw_dir (M.fold fake fs' [])) :: acc 48 | | File (_, _rope) -> (segment, 0., Raw_file Sector.null_ptr) :: acc 49 | in 50 | Raw_dir (M.fold fake fs []) 51 | 52 | let count_new t = 53 | let* files_count = count_new t.files in 54 | let+ on_disk_count = 55 | if not t.dirty 56 | then begin 57 | assert (files_count = 0) ; 58 | Lwt_result.return 0 59 | end 60 | else begin 61 | let str = string_of_raw (fake t.files) in 62 | let* rope = Rope.of_string str in 63 | let* () = Rope.free t.on_disk in 64 | t.on_disk <- rope ; 65 | Rope.count_new rope 66 | end 67 | in 68 | files_count + on_disk_count 69 | 70 | let flush_ropes fs allocated = 71 | let rec flush_ropes segment fs acc = 72 | match fs with 73 | | Dir (time, fs') -> 74 | let* files, to_flush, allocated = acc in 75 | let+ files', to_flush', allocated' = 76 | M.fold flush_ropes fs' (Lwt_result.return ([], [], allocated)) 77 | in 78 | ( (segment, Ptime.to_float_s time, Raw_dir files') :: files 79 | , List.rev_append to_flush' to_flush 80 | , allocated' ) 81 | | File (time, rope) -> 82 | let* files, to_flush, allocated = acc in 83 | let* to_flush', allocated = 84 | if Sector.is_in_memory !rope 85 | then Sector.finalize !rope allocated 86 | else Lwt_result.return ([], allocated) 87 | in 88 | let ptr = Sector.to_ptr !rope in 89 | let acc = 90 | ( (segment, Ptime.to_float_s time, Raw_file ptr) :: files 91 | , List.rev_append to_flush' to_flush 92 | , allocated ) 93 | in 94 | Lwt_result.return acc 95 | in 96 | let+ files, to_flush, allocated = 97 | M.fold flush_ropes fs (Lwt_result.return ([], [], allocated)) 98 | in 99 | Raw_dir files, to_flush, allocated 100 | 101 | let to_payload t allocated = 102 | let* files, to_flush, allocated = flush_ropes t.files allocated in 103 | let str = string_of_raw files in 104 | let* on_disk_size = Rope.size t.on_disk in 105 | assert (String.length str = on_disk_size) ; 106 | let* rope = Rope.blit_from_string t.on_disk 0 str 0 (String.length str) in 107 | t.on_disk <- rope ; 108 | let+ to_flush', allocated = Sector.finalize t.on_disk allocated in 109 | assert (List.length to_flush' > 0) ; 110 | t.dirty <- false ; 111 | rope, List.rev_append to_flush' to_flush, allocated 112 | 113 | let of_raw raw = 114 | let rec of_raw acc = function 115 | | segment, time, Raw_dir lst -> 116 | let* acc = acc in 117 | let+ fs = List.fold_left of_raw (Lwt_result.return M.empty) lst in 118 | M.add segment (Dir (Option.get @@ Ptime.of_float_s time, fs)) acc 119 | | filename, time, Raw_file id -> 120 | let* acc = acc in 121 | let+ rope = Rope.load id in 122 | M.add filename (File (Option.get @@ Ptime.of_float_s time, ref rope)) acc 123 | in 124 | List.fold_left of_raw (Lwt_result.return M.empty) raw 125 | 126 | let of_disk_repr on_disk = 127 | let* str = Rope.to_string on_disk in 128 | let raw = raw_of_string str in 129 | match raw with 130 | | Ok (Raw_dir raw) -> 131 | let+ files = of_raw raw in 132 | files 133 | | Ok (Raw_file _) -> assert false (* root cannot be a file *) 134 | | Error (`Msg err) -> Lwt.fail_with err 135 | 136 | let make () = 137 | let+ on_disk = Rope.create () in 138 | { on_disk; files = M.empty; dirty = false } 139 | 140 | let load on_disk_ptr = 141 | if Sector.is_null_ptr on_disk_ptr 142 | then make () 143 | else 144 | let* on_disk = Rope.load on_disk_ptr in 145 | let+ files = of_disk_repr on_disk in 146 | { on_disk; files; dirty = false } 147 | 148 | let verify_checksum t = 149 | let rec check = function 150 | | Dir (_, fs) -> 151 | let check = M.map check fs in 152 | M.fold (fun _ a b -> Lwt_result.bind a (fun () -> b)) check (Lwt_result.return ()) 153 | | File (_, rope) -> Rope.verify_checksum !rope 154 | in 155 | let check = M.map check t.files in 156 | M.fold (fun _ a b -> Lwt_result.bind a (fun () -> b)) check (Lwt_result.return ()) 157 | 158 | let exists t filename = 159 | let rec exists fs = function 160 | | [] -> Some `Dictionary 161 | | segment :: [] -> 162 | (match M.find_opt segment fs with 163 | | None -> None 164 | | Some (Dir _) -> Some `Dictionary 165 | | Some (File _) -> Some `Value) 166 | | segment :: xs -> 167 | (match M.find_opt segment fs with 168 | | None | Some (File _) -> None 169 | | Some (Dir (_, fs)) -> exists fs xs) 170 | in 171 | exists t.files filename 172 | 173 | let last_modified t filename = 174 | let rec last_modified fs = function 175 | | [] -> raise Not_found 176 | | segment :: [] -> 177 | (match M.find segment fs with 178 | | Dir (time, _) -> time 179 | | File (time, _) -> time) 180 | | segment :: xs -> 181 | (match M.find segment fs with 182 | | Dir (_, fs) -> last_modified fs xs 183 | | File _ -> raise Not_found) 184 | in 185 | last_modified t.files filename 186 | 187 | let find_opt t filename = 188 | let rec find_opt fs = function 189 | | [] -> None 190 | | segment :: [] -> 191 | Option.bind (M.find_opt segment fs) (function 192 | | Dir _ -> None 193 | | File (_, r) -> Some r) 194 | | segment :: xs -> 195 | Option.bind (M.find_opt segment fs) (function 196 | | Dir (_, fs) -> find_opt fs xs 197 | | File _ -> None) 198 | in 199 | find_opt t.files filename 200 | 201 | let free fs = 202 | let rec free = function 203 | | Dir (_, fs) -> 204 | M.fold 205 | (fun _ fs acc -> 206 | let* () = acc in 207 | free fs) 208 | fs 209 | (Lwt_result.return ()) 210 | | File (_, rope) -> Rope.free !rope 211 | in 212 | free (Dir (Ptime.epoch, fs)) 213 | 214 | let add t filename rope = 215 | let time = Ptime.v @@ Clock.now_d_ps () in 216 | let rec create fs segment = function 217 | | [] -> M.add segment (File (time, rope)) fs 218 | | segment' :: xs -> 219 | let fs' = create M.empty segment' xs in 220 | M.add segment (Dir (time, fs')) fs 221 | in 222 | let rec add fs = function 223 | | [] -> assert false 224 | | segment :: [] -> 225 | (match M.find_opt segment fs with 226 | | None -> Lwt_result.return (M.add segment (File (time, rope)) fs) 227 | | Some (File (_, old_rope)) -> 228 | let+ () = Rope.free !old_rope in 229 | M.add segment (File (time, rope)) fs 230 | | Some (Dir (_, fs')) -> 231 | let+ () = free fs' in 232 | M.add segment (File (time, rope)) fs) 233 | | segment :: xs -> 234 | (match M.find_opt segment fs with 235 | | None -> Lwt_result.return (create fs segment xs) 236 | | Some (File (_, old_rope)) -> 237 | let+ () = Rope.free !old_rope in 238 | create fs segment xs 239 | | Some (Dir (_, fs')) -> 240 | let+ fs' = add fs' xs in 241 | M.add segment (Dir (time, fs')) fs) 242 | in 243 | let+ file = add t.files filename in 244 | t.dirty <- true ; 245 | { t with files = file } 246 | 247 | let remove t path = 248 | let time = Ptime.v @@ Clock.now_d_ps () in 249 | let rec remove fs = function 250 | | [] -> assert false 251 | | segment :: [] -> 252 | (match M.find_opt segment fs with 253 | | None -> Lwt_result.return fs 254 | | Some (Dir (_, fs')) -> 255 | let+ () = free fs' in 256 | M.remove segment fs 257 | | Some (File (_, rope)) -> 258 | let+ () = Rope.free !rope in 259 | M.remove segment fs) 260 | | segment :: xs -> 261 | (match M.find_opt segment fs with 262 | | None -> Lwt_result.return fs 263 | | Some (Dir (_, fs')) -> 264 | let+ fs' = remove fs' xs in 265 | M.add segment (Dir (time, fs')) fs 266 | | Some (File _) -> assert false) 267 | in 268 | t.dirty <- true ; 269 | let+ files = remove t.files path in 270 | { t with files } 271 | 272 | let rename t ~src ~dst = 273 | let time = Ptime.v @@ Clock.now_d_ps () in 274 | let rec find_and_remove_src fs = function 275 | | [] -> assert false (* cannot move root *) 276 | | segment :: [] -> 277 | let r = M.find segment fs in 278 | Lwt_result.return (r, M.remove segment fs) 279 | | segment :: xs -> 280 | (match M.find segment fs with 281 | | Dir (_, fs') -> 282 | let+ r, fs' = find_and_remove_src fs' xs in 283 | r, M.add segment (Dir (time, fs')) fs 284 | | File _ -> raise Not_found) 285 | in 286 | let rec create src_obj fs segment = function 287 | | [] -> M.add segment src_obj fs 288 | | segment' :: xs -> 289 | let fs' = create src_obj M.empty segment' xs in 290 | M.add segment (Dir (time, fs')) fs 291 | in 292 | let rec find_and_replace_dst src_obj fs = function 293 | | [] -> assert false (* cannot replace root *) 294 | | segment :: [] -> 295 | (match M.find_opt segment fs with 296 | | None -> Lwt_result.return (M.add segment src_obj fs) 297 | | Some (File (_, rope)) -> 298 | let+ () = Rope.free !rope in 299 | (match src_obj with 300 | | File (_, rope') -> 301 | rope := !rope' ; 302 | fs 303 | | Dir _ -> M.add segment src_obj fs) 304 | | Some (Dir (_, fs')) -> 305 | let+ () = free fs' in 306 | M.add segment src_obj fs) 307 | | segment :: xs -> 308 | (match M.find_opt segment fs with 309 | | None -> Lwt_result.return (create src_obj fs segment xs) 310 | | Some (File (_, rope)) -> 311 | let+ () = Rope.free !rope in 312 | create src_obj fs segment xs 313 | | Some (Dir (_, fs')) -> 314 | let+ fs' = find_and_replace_dst src_obj fs' xs in 315 | M.add segment (Dir (time, fs')) fs) 316 | in 317 | t.dirty <- true ; 318 | let* src_obj, files = find_and_remove_src t.files src in 319 | let+ files = find_and_replace_dst src_obj files dst in 320 | { t with files } 321 | 322 | let filename key = String.concat "/" key 323 | let size rope = Rope.size !rope 324 | 325 | let blit_to_bytes t rope ~off ~len bytes = 326 | t.dirty <- true ; 327 | Rope.blit_to_bytes !rope off bytes 0 len 328 | 329 | let blit_from_string t rope ~off ~len str = 330 | t.dirty <- true ; 331 | let+ t = Rope.blit_from_string !rope off str 0 len in 332 | rope := t 333 | 334 | let append_from t rope arg = 335 | t.dirty <- true ; 336 | let+ t_rope = Rope.append_from !rope arg in 337 | rope := t_rope 338 | 339 | let list t path = 340 | let to_v = function 341 | | s, Dir _ -> s, `Dictionary 342 | | s, File _ -> s, `Value 343 | in 344 | let rec list fs = function 345 | | [] -> List.map to_v @@ M.bindings fs 346 | | segment :: xs -> 347 | (match M.find segment fs with 348 | | Dir (_, fs) -> list fs xs 349 | | File _ -> raise Not_found) 350 | in 351 | list t.files path 352 | 353 | let reachable_size _t = failwith "to fix" 354 | (* if M.cardinal t.files = 0 355 | then Lwt_result.return 0 356 | else begin 357 | let* repr = Rope.reachable_size t.on_disk in 358 | let rec go acc = function 359 | | [] -> Lwt_result.return acc 360 | | (_, rope) :: rest -> 361 | let* s = Rope.reachable_size !rope in 362 | go (acc + s) rest 363 | in 364 | go repr @@ M.bindings t.files 365 | end *) 366 | 367 | let touch t filename str = 368 | let* rope = Rope.of_string str in 369 | let file = ref rope in 370 | let+ files = add t filename file in 371 | assert t.dirty ; 372 | files, file 373 | end 374 | -------------------------------------------------------------------------------- /src/files.mli: -------------------------------------------------------------------------------- 1 | module Make (Clock : Mirage_clock.PCLOCK) (B : Context.A_DISK) : sig 2 | module Sector : module type of Sector.Make (B) 3 | module Rope : module type of Rope.Make (B) 4 | 5 | type key = string list 6 | type file 7 | type t 8 | type 'a io := ('a, B.error) Lwt_result.t 9 | 10 | val load : Sector.ptr -> t io 11 | val verify_checksum : t -> unit io 12 | 13 | (* *) 14 | val exists : t -> key -> [> `Dictionary | `Value ] option 15 | val last_modified : t -> key -> Ptime.t 16 | val find_opt : t -> key -> file option 17 | val filename : key -> string 18 | val size : file -> int io 19 | val add : t -> key -> file -> t io 20 | val remove : t -> key -> t io 21 | val rename : t -> src:key -> dst:key -> t io 22 | val touch : t -> key -> string -> (t * file) io 23 | val blit_to_bytes : t -> file -> off:int -> len:int -> bytes -> int io 24 | val blit_from_string : t -> file -> off:int -> len:int -> string -> unit io 25 | val append_from : t -> file -> string * int * int -> unit io 26 | val list : t -> key -> (string * [> `Dictionary | `Value ]) list 27 | 28 | (* *) 29 | 30 | val count_new : t -> int io 31 | 32 | val to_payload 33 | : t 34 | -> Sector.id list 35 | -> (Rope.t * (Sector.id * Cstruct.t) list * Sector.id list) io 36 | 37 | val reachable_size : t -> int io 38 | end 39 | -------------------------------------------------------------------------------- /src/fs.ml: -------------------------------------------------------------------------------- 1 | open Lwt_result.Syntax 2 | 3 | module type CHECKSUM = Checksum.S 4 | 5 | module type S = sig 6 | module Disk : Context.A_DISK 7 | 8 | type t 9 | type error = Disk.error 10 | type 'a io := ('a, error) Lwt_result.t 11 | 12 | val pp_error : Format.formatter -> error -> unit 13 | val format : unit -> t io 14 | val connect : unit -> t io 15 | val flush : t -> unit io 16 | val clear : unit -> unit io 17 | val disk_space : t -> int64 18 | val free_space : t -> int64 19 | val page_size : t -> int 20 | 21 | type key = string list 22 | type file 23 | 24 | val filename : file -> string 25 | val size : file -> int io 26 | val exists : t -> key -> [> `Dictionary | `Value ] option 27 | val last_modified : t -> key -> Ptime.t 28 | val append_substring : t -> file -> string -> off:int -> len:int -> unit io 29 | val blit_from_string : t -> file -> off:int -> len:int -> string -> unit io 30 | val blit_to_bytes : t -> file -> off:int -> len:int -> bytes -> int io 31 | val rename : t -> src:key -> dst:key -> unit io 32 | val touch : t -> key -> string -> file io 33 | val remove : t -> key -> unit io 34 | val find_opt : t -> key -> file option 35 | val list : t -> key -> (string * [ `Value | `Dictionary ]) list 36 | val get : t -> key -> string option io 37 | val get_partial : t -> key -> offset:Optint.Int63.t -> length:int -> string option io 38 | val set_partial : t -> key -> offset:Optint.Int63.t -> string -> bool io 39 | end 40 | 41 | module Make_disk (Clock : Mirage_clock.PCLOCK) (B : Context.A_DISK) : 42 | S with module Disk = B = struct 43 | module Disk = B 44 | module Sector = Sector.Make (B) 45 | module Root = Root.Make (B) 46 | module Queue = Queue.Make (B) 47 | module Files = Files.Make (Clock) (B) 48 | module Rope = Rope.Make (B) 49 | 50 | type error = B.error 51 | 52 | let pp_error = B.pp_error 53 | 54 | type key = Files.key 55 | type file = key * Files.file 56 | 57 | type t = 58 | { root : Root.t 59 | ; mutable files : Files.t 60 | ; mutable free_queue : Queue.q 61 | ; lock : Lwt_mutex.t 62 | } 63 | 64 | let free_space t = t.free_queue.free_sectors 65 | let disk_space _ = B.nb_sectors 66 | let page_size _ = B.page_size 67 | 68 | let unsafe_of_root root = 69 | let* payload = Root.get_payload root in 70 | let* free_queue = Root.get_free_queue root in 71 | let* files = Files.load payload in 72 | let* free_queue = Queue.load free_queue in 73 | let* () = Files.verify_checksum files in 74 | let* () = Queue.verify_checksum free_queue in 75 | let+ () = B.clear () in 76 | let lock = Lwt_mutex.create () in 77 | { root; files; free_queue; lock } 78 | 79 | let reachable_size t = 80 | let roots = Root.reachable_size t.root in 81 | let* payload = 82 | let* root_payload = Root.get_payload t.root in 83 | if Sector.is_null_ptr root_payload 84 | then Lwt_result.return 0 85 | else Files.reachable_size t.files 86 | in 87 | let+ queue = 88 | let* _, root_queue, _ = Root.get_free_queue t.root in 89 | if Sector.is_null_ptr root_queue 90 | then Lwt_result.return 0 91 | else Queue.reachable_size t.free_queue 92 | in 93 | roots + queue + payload 94 | 95 | let check_size t = 96 | (* 97 | let* rs = reachable_size t in 98 | let+ s = Queue.size t.free_queue in 99 | let expected_free = 100 | Int64.add 101 | (Int64.sub B.nb_sectors (B.Id.to_int64 t.free_queue.free_start)) 102 | (Int64.of_int s) 103 | in 104 | let used_space = Int64.to_int (Int64.sub B.nb_sectors expected_free) in 105 | assert (used_space = rs) ; 106 | assert (Int64.equal t.free_queue.free_sectors expected_free) 107 | *) 108 | ignore reachable_size ; 109 | ignore t ; 110 | Lwt_result.return () 111 | 112 | let of_root root = 113 | let* t = unsafe_of_root root in 114 | let+ () = check_size t in 115 | (B.allocator 116 | := fun required -> 117 | let t_free_queue = t.free_queue in 118 | let+ free_queue, allocated = Queue.pop_front t_free_queue required in 119 | assert (t.free_queue == t_free_queue) ; 120 | t.free_queue <- free_queue ; 121 | allocated) ; 122 | t 123 | 124 | let format () = 125 | let* root = Root.format () in 126 | of_root root 127 | 128 | let connect () = Root.load ~check:of_root () 129 | let with_lock t fn = Lwt_mutex.with_lock t.lock fn 130 | let clear () = B.clear () 131 | 132 | let flush t = 133 | with_lock t 134 | @@ fun () -> 135 | B.protect_lru 136 | @@ fun () -> 137 | let* required = Files.count_new t.files in 138 | let* () = 139 | if required = 0 140 | then begin 141 | assert (B.acquire_discarded () = []) ; 142 | Lwt_result.return () 143 | end 144 | else begin 145 | let t_free_queue = t.free_queue in 146 | let* free_queue = Queue.push_discarded t.free_queue in 147 | let* free_queue, allocated = Queue.pop_front free_queue required in 148 | let allocated = B.Diet.list_of_ranges allocated in 149 | assert (List.length allocated = required) ; 150 | let* free_queue, to_flush_queue = Queue.self_allocate ~free_queue in 151 | let* payload_root, to_flush, allocated = Files.to_payload t.files allocated in 152 | assert (allocated = []) ; 153 | let* () = Root.flush (List.rev_append to_flush_queue to_flush) in 154 | let* free_queue = Root.update t.root ~queue:free_queue ~payload:payload_root in 155 | assert (B.acquire_discarded () = []) ; 156 | assert (t.free_queue == t_free_queue) ; 157 | t.free_queue <- free_queue ; 158 | check_size t 159 | end 160 | in 161 | B.clear () 162 | 163 | let filename t = Files.filename (fst t) 164 | 165 | let append_substring t ((_filename, rope) : file) str ~off ~len = 166 | with_lock t @@ fun () -> Files.append_from t.files rope (str, off, off + len) 167 | 168 | let rename t ~src ~dst = 169 | with_lock t 170 | @@ fun () -> 171 | let+ files = Files.rename t.files ~src ~dst in 172 | t.files <- files 173 | 174 | let size (_, file) = Files.size file 175 | let exists t filename = Files.exists t.files filename 176 | let last_modified t filename = Files.last_modified t.files filename 177 | 178 | let remove t filename = 179 | with_lock t 180 | @@ fun () -> 181 | let+ files = Files.remove t.files filename in 182 | t.files <- files 183 | 184 | let touch t filename str = 185 | with_lock t 186 | @@ fun () -> 187 | let+ files, rope = Files.touch t.files filename str in 188 | t.files <- files ; 189 | filename, rope 190 | 191 | let blit_to_bytes t (_, file) ~off ~len bytes = 192 | with_lock t @@ fun () -> Files.blit_to_bytes t.files file ~off ~len bytes 193 | 194 | let blit_from_string t (_, file) ~off ~len bytes = 195 | with_lock t @@ fun () -> Files.blit_from_string t.files file ~off ~len bytes 196 | 197 | let find_opt t filename = 198 | match Files.find_opt t.files filename with 199 | | None -> None 200 | | Some file -> Some (filename, file) 201 | 202 | let list t prefix = Files.list t.files prefix 203 | 204 | let get t filename = 205 | with_lock t 206 | @@ fun () -> 207 | match Files.find_opt t.files filename with 208 | | None -> Lwt_result.return None 209 | | Some file -> 210 | let* size = Files.size file in 211 | let bytes = Bytes.create size in 212 | let+ quantity = Files.blit_to_bytes t.files file bytes ~off:0 ~len:size in 213 | assert (quantity = size) ; 214 | Some (Bytes.unsafe_to_string bytes) 215 | 216 | let get_partial t filename ~offset ~length = 217 | with_lock t 218 | @@ fun () -> 219 | match Files.find_opt t.files filename with 220 | | None -> Lwt_result.return None 221 | | Some file -> 222 | let* size = Files.size file in 223 | let off = Optint.Int63.to_int offset in 224 | assert (off >= 0) ; 225 | assert (off + length <= size) ; 226 | let bytes = Bytes.create length in 227 | let+ quantity = Files.blit_to_bytes t.files file bytes ~off ~len:length in 228 | assert (quantity = size) ; 229 | Some (Bytes.unsafe_to_string bytes) 230 | 231 | let set_partial t filename ~offset contents = 232 | with_lock t 233 | @@ fun () -> 234 | match Files.find_opt t.files filename with 235 | | None -> Lwt_result.return false 236 | | Some file -> 237 | let off = Optint.Int63.to_int offset in 238 | let len = String.length contents in 239 | let+ () = Files.blit_from_string t.files file ~off ~len contents in 240 | true 241 | end 242 | 243 | module Make_check 244 | (Clock : Mirage_clock.PCLOCK) 245 | (Check : CHECKSUM) 246 | (Block : Mirage_block.S) = 247 | struct 248 | let debug = false 249 | 250 | type error = 251 | [ `Read of Block.error 252 | | `Write of Block.write_error 253 | | `Invalid_checksum of Int64.t 254 | | `All_generations_corrupted 255 | | `Disk_is_full 256 | | `Disk_not_formatted 257 | | `Wrong_page_size of int 258 | | `Wrong_disk_size of Int64.t 259 | | `Wrong_checksum_algorithm of string * int 260 | ] 261 | 262 | let pp_error h = function 263 | | `Read e -> Block.pp_error h e 264 | | `Write e -> Block.pp_write_error h e 265 | | `Invalid_checksum id -> Format.fprintf h "Invalid_checksum %s" (Int64.to_string id) 266 | | `All_generations_corrupted -> Format.fprintf h "All_generations_corrupted" 267 | | `Disk_is_full -> Format.fprintf h "Disk_is_full" 268 | | `Disk_not_formatted -> Format.fprintf h "Disk_not_formatted" 269 | | `Wrong_page_size size -> Format.fprintf h "Wrong_page_size %i" size 270 | | `Wrong_disk_size size -> 271 | Format.fprintf h "Wrong_disk_size %s" (Int64.to_string size) 272 | | `Wrong_checksum_algorithm (name, byte_size) -> 273 | Format.fprintf h "Wrong_checksum_algorithm (%S, %i)" name byte_size 274 | 275 | module type S = 276 | S 277 | with type Disk.read_error = Block.error 278 | and type Disk.write_error = Block.write_error 279 | 280 | type t = T : (module S with type t = 'a) * 'a -> t 281 | 282 | let make_disk block = 283 | let open Lwt.Syntax in 284 | let+ (module A_disk) = Context.of_impl (module Block) (module Check) block in 285 | Ok (module Make_disk (Clock) (A_disk) : S) 286 | 287 | exception Fs of error 288 | 289 | open Lwt.Syntax 290 | 291 | let or_fail pp s lwt = 292 | Lwt.map 293 | (function 294 | | Ok r -> r 295 | | Error err -> 296 | Format.printf "ERROR in %s: %a@." s pp err ; 297 | raise (Fs err)) 298 | lwt 299 | 300 | let split_filename filename = 301 | List.filter (fun s -> s <> "") @@ String.split_on_char '/' filename 302 | 303 | let format block = 304 | let or_fail _ lwt = 305 | Lwt.map 306 | (function 307 | | Ok r -> r 308 | | Error err -> raise (Fs err)) 309 | lwt 310 | in 311 | or_fail "Notafs.format" 312 | @@ 313 | let open Lwt_result.Syntax in 314 | let* (module S) = make_disk block in 315 | let+ (t : S.t) = S.format () in 316 | T ((module S), t) 317 | 318 | let connect block = 319 | let* (module A_disk) = Context.of_impl (module Block) (module Check) block in 320 | let (module S) = (module Make_disk (Clock) (A_disk) : S) in 321 | or_fail S.pp_error "Notafs.connect" 322 | @@ 323 | let open Lwt_result.Syntax in 324 | let+ (t : S.t) = S.connect () in 325 | T ((module S), t) 326 | 327 | let flush (T ((module S), t)) = or_fail S.pp_error "Notafs.flush" @@ S.flush t 328 | let clear (T ((module S), _)) = or_fail S.pp_error "Notafs.clear" @@ S.clear () 329 | let exists (T ((module S), t)) filename = S.exists t (split_filename filename) 330 | 331 | let last_modified (T ((module S), t)) filename = 332 | S.last_modified t (split_filename filename) 333 | 334 | type file = File : (module S with type t = 'a and type file = 'b) * 'a * 'b -> file 335 | 336 | let find (T ((module S), t)) filename = 337 | match S.find_opt t (split_filename filename) with 338 | | None -> None 339 | | Some file -> Some (File ((module S), t, file)) 340 | 341 | let filename (File ((module S), _, file)) = S.filename file 342 | 343 | let remove (T ((module S), t)) filename = 344 | or_fail S.pp_error "Notafs.remove" @@ S.remove t (split_filename filename) 345 | 346 | let touch (T ((module S), t)) filename contents = 347 | or_fail S.pp_error "Notafs.touch" 348 | @@ 349 | let open Lwt_result.Syntax in 350 | let filename = split_filename filename in 351 | let+ file = S.touch t filename contents in 352 | File ((module S), t, file) 353 | 354 | let rename (T ((module S), t)) ~src ~dst = 355 | if debug then Format.printf "Notafs.rename@." ; 356 | let src = split_filename src in 357 | let dst = split_filename dst in 358 | or_fail S.pp_error "Notafs.rename" @@ S.rename t ~src ~dst 359 | 360 | let append_substring (File ((module S), t, file)) str ~off ~len = 361 | or_fail S.pp_error "Notafs.append_substring" 362 | @@ S.append_substring t file str ~off ~len 363 | 364 | let blit_to_bytes (File ((module S), t, file)) ~off ~len bytes = 365 | or_fail S.pp_error "Notafs.blit_to_bytes" @@ S.blit_to_bytes t file ~off ~len bytes 366 | 367 | let blit_from_string (File ((module S), t, file)) ~off ~len string = 368 | or_fail S.pp_error "Notafs.blit_from_string" 369 | @@ S.blit_from_string t file ~off ~len string 370 | 371 | let size (File ((module S), _, file)) = 372 | or_fail S.pp_error "Notafs.size" 373 | @@ 374 | let open Lwt_result.Syntax in 375 | let+ r = S.size file in 376 | if debug then Format.printf "Notafs.size: %i@." r ; 377 | r 378 | end 379 | 380 | let get_config (type a) (module Block : Mirage_block.S with type t = a) (block : a) = 381 | let open Lwt.Syntax in 382 | let* (module A_disk) = 383 | Context.of_impl (module Block) (module Checksum.No_checksum) block 384 | in 385 | let (module H) = 386 | (module Header.Make (A_disk) : Header.CONFIG with type error = A_disk.error) 387 | in 388 | let+ result = H.load_config () in 389 | match result with 390 | | Ok config -> Ok config 391 | | Error `Disk_not_formatted -> Error `Disk_not_formatted 392 | | Error _ -> failwith "error" 393 | -------------------------------------------------------------------------------- /src/header.ml: -------------------------------------------------------------------------------- 1 | type config = 2 | { disk_size : Int64.t 3 | ; page_size : int 4 | ; checksum_algorithm : string 5 | ; checksum_byte_size : int 6 | } 7 | 8 | module type CONFIG = sig 9 | type error 10 | type 'a io := ('a, error) Lwt_result.t 11 | 12 | val load_config : unit -> config io 13 | end 14 | 15 | module Make (B : Context.A_DISK) : sig 16 | module Schema : module type of Schema.Make (B) 17 | module Sector = Schema.Sector 18 | 19 | type error = B.error 20 | type t = Sector.t 21 | type 'a io := ('a, error) Lwt_result.t 22 | 23 | val magic : int64 24 | val get_magic : t -> int64 io 25 | val get_disk_size : t -> int64 io 26 | val get_page_size : t -> int io 27 | val get_roots : t -> int io 28 | val get_format_uid : t -> int64 io 29 | val create : disk_size:int64 -> page_size:int -> Sector.t io 30 | val load : unit -> Sector.t io 31 | val load_config : unit -> config io 32 | end = struct 33 | module Schema = Schema.Make (B) 34 | module Sector = Schema.Sector 35 | open Lwt_result.Syntax 36 | 37 | type error = B.error 38 | type t = Sector.t 39 | 40 | type schema = 41 | { magic : int64 Schema.field 42 | ; disk_size : int64 Schema.field 43 | ; page_size : int Schema.field 44 | ; roots : int Schema.field 45 | ; checksum_byte_size : int Schema.field 46 | ; checksum_algorithm : int64 Schema.field 47 | ; format_uid : int64 Schema.field 48 | } 49 | 50 | let { magic 51 | ; disk_size 52 | ; page_size 53 | ; roots 54 | ; checksum_byte_size 55 | ; checksum_algorithm 56 | ; format_uid 57 | } 58 | = 59 | Schema.define 60 | @@ 61 | let open Schema.Syntax in 62 | let+ magic = Schema.uint64 63 | and+ disk_size = Schema.uint64 64 | and+ page_size = Schema.uint32 65 | and+ roots = Schema.uint32 66 | and+ checksum_byte_size = Schema.uint8 67 | and+ checksum_algorithm = Schema.uint64 68 | and+ format_uid = Schema.uint64 in 69 | { magic 70 | ; disk_size 71 | ; page_size 72 | ; roots 73 | ; checksum_byte_size 74 | ; checksum_algorithm 75 | ; format_uid 76 | } 77 | 78 | include struct 79 | open Schema.Infix 80 | 81 | let set_magic t v = t.@(magic) <- v 82 | let get_magic t = t.@(magic) 83 | let set_disk_size t v = t.@(disk_size) <- v 84 | let get_disk_size t = t.@(disk_size) 85 | let set_page_size t v = t.@(page_size) <- v 86 | let get_page_size t = t.@(page_size) 87 | let set_roots t v = t.@(roots) <- v 88 | let get_roots t = t.@(roots) 89 | let set_format_uid t v = t.@(format_uid) <- v 90 | let get_format_uid t = t.@(format_uid) 91 | end 92 | 93 | let int64_of_string s = 94 | let open Int64 in 95 | let ( + ) = logor in 96 | let get i = 97 | try shift_left (of_int (Char.code s.[i])) (i * 8) with 98 | | _ -> 0L 99 | in 100 | get 0 + get 1 + get 2 + get 3 + get 4 + get 5 + get 6 + get 7 101 | 102 | let string_of_int64 x = 103 | let open Int64 in 104 | let s = Bytes.create 8 in 105 | for i = 0 to 7 do 106 | Bytes.set s i @@ Char.chr (to_int (logand 0xFFL (shift_right x (i * 8)))) 107 | done ; 108 | Bytes.unsafe_to_string s 109 | 110 | let magic = 0x534641544F4EL (* NOTAFS *) 111 | let () = assert (magic = int64_of_string "NOTAFS") 112 | 113 | let random_format_uid () = 114 | let cstruct = Cstruct.create B.page_size in 115 | let+ () = B.read (B.Id.of_int 0) cstruct in 116 | let acc = ref 0L in 117 | for i = 0 to (Cstruct.length cstruct / 8) - 1 do 118 | let x = Cstruct.HE.get_uint64 cstruct (i * 8) in 119 | acc := Int64.logxor !acc x 120 | done ; 121 | !acc 122 | 123 | let create ~disk_size ~page_size = 124 | let open Schema.Infix in 125 | let* format_uid = random_format_uid () in 126 | let* s = Sector.create ~at:(Sector.root_loc @@ B.Id.of_int 0) () in 127 | let* () = set_magic s magic in 128 | let* () = set_disk_size s disk_size in 129 | let* () = set_page_size s page_size in 130 | let* () = set_roots s 4 in 131 | let* () = set_format_uid s format_uid in 132 | let* () = s.@(checksum_byte_size) <- B.Check.byte_size in 133 | let+ () = s.@(checksum_algorithm) <- int64_of_string B.Check.name in 134 | s 135 | 136 | let load_config () = 137 | let open Schema.Infix in 138 | let* s = Sector.load_root ~check:false (B.Id.of_int 0) in 139 | let* magic' = get_magic s in 140 | let* () = 141 | if magic' <> magic 142 | then Lwt_result.fail `Disk_not_formatted 143 | else Lwt_result.return () 144 | in 145 | let* disk_size = get_disk_size s in 146 | let* page_size = get_page_size s in 147 | let* checksum_byte_size = s.@(checksum_byte_size) in 148 | let+ checksum_algorithm = s.@(checksum_algorithm) in 149 | let config = 150 | { disk_size 151 | ; page_size 152 | ; checksum_byte_size 153 | ; checksum_algorithm = string_of_int64 checksum_algorithm 154 | } 155 | in 156 | config, s 157 | 158 | let load () = 159 | let* config, s = load_config () in 160 | let* () = 161 | if config.page_size <> B.page_size 162 | then Lwt_result.fail (`Wrong_page_size config.page_size) 163 | else Lwt_result.return () 164 | in 165 | let* () = 166 | if config.disk_size <> B.nb_sectors 167 | then Lwt_result.fail (`Wrong_disk_size config.disk_size) 168 | else Lwt_result.return () 169 | in 170 | let* () = 171 | if config.checksum_byte_size <> B.Check.byte_size 172 | || config.checksum_algorithm <> B.Check.name 173 | then 174 | Lwt_result.fail 175 | (`Wrong_checksum_algorithm 176 | (config.checksum_algorithm, config.checksum_byte_size)) 177 | else Lwt_result.return () 178 | in 179 | let+ () = Sector.verify_checksum s in 180 | s 181 | 182 | let load_config () = 183 | let+ config, _ = load_config () in 184 | config 185 | end 186 | -------------------------------------------------------------------------------- /src/id.ml: -------------------------------------------------------------------------------- 1 | module type FIELD = sig 2 | type t 3 | 4 | val byte_size : int 5 | val read : Cstruct.t -> int -> t 6 | val write : Cstruct.t -> int -> t -> unit 7 | end 8 | 9 | module type S = sig 10 | type t [@@deriving repr] 11 | 12 | include FIELD with type t := t 13 | 14 | val to_string : t -> string 15 | val of_int : int -> t 16 | val of_int64 : Int64.t -> t 17 | val add : t -> int -> t 18 | val succ : t -> t 19 | val equal : t -> t -> bool 20 | val compare : t -> t -> int 21 | val to_int64 : t -> Int64.t 22 | end 23 | 24 | module I8 : S = struct 25 | type t = int 26 | 27 | let t = 28 | Repr.map 29 | (Repr.string_of (`Fixed 1)) 30 | (fun s -> Char.code s.[0]) 31 | (fun i -> String.make 1 (Char.chr i)) 32 | 33 | let byte_size = 1 34 | let read cstruct offset = Cstruct.get_uint8 cstruct offset 35 | let write cstruct offset v = Cstruct.set_uint8 cstruct offset v 36 | let to_string = string_of_int 37 | let of_int i = i 38 | let of_int64 = Int64.to_int 39 | let add t x = t + x 40 | let succ x = x + 1 41 | let equal = Int.equal 42 | let compare = Int.compare 43 | let to_int64 = Int64.of_int 44 | end 45 | 46 | module I16 : S = struct 47 | type t = int 48 | 49 | let t = 50 | Repr.map 51 | (Repr.string_of (`Fixed 2)) 52 | (fun s -> Bytes.get_uint16_le (Bytes.unsafe_of_string s) 0) 53 | (fun i -> 54 | let bytes = Bytes.create 2 in 55 | Bytes.set_uint16_le bytes 0 i ; 56 | Bytes.unsafe_to_string bytes) 57 | 58 | let byte_size = 2 59 | let read cstruct offset = Cstruct.HE.get_uint16 cstruct offset 60 | let write cstruct offset v = Cstruct.HE.set_uint16 cstruct offset v 61 | let to_string = string_of_int 62 | let of_int i = i 63 | let of_int64 = Int64.to_int 64 | let add t x = t + x 65 | let succ x = x + 1 66 | let equal = Int.equal 67 | let compare = Int.compare 68 | let to_int64 = Int64.of_int 69 | end 70 | 71 | module I32 : S = struct 72 | type t = Optint.t 73 | 74 | let t = 75 | Repr.map 76 | (Repr.string_of (`Fixed 4)) 77 | (fun s -> Optint.decode s ~off:0) 78 | (fun i -> 79 | let bytes = Bytes.create 4 in 80 | Optint.encode bytes ~off:0 i ; 81 | Bytes.unsafe_to_string bytes) 82 | 83 | let byte_size = 4 84 | let read cstruct offset = Optint.of_int32 @@ Cstruct.HE.get_uint32 cstruct offset 85 | let write cstruct offset v = Cstruct.HE.set_uint32 cstruct offset (Optint.to_int32 v) 86 | let to_string = Optint.to_string 87 | let of_int i = Optint.of_int i 88 | let of_int64 = Optint.of_int64 89 | let add t x = Optint.add t (of_int x) 90 | let succ = Optint.succ 91 | let equal = Optint.equal 92 | let compare = Optint.compare 93 | let to_int64 = Optint.to_int64 94 | end 95 | 96 | module I63 : S = struct 97 | module Int63 = Optint.Int63 98 | 99 | type t = Int63.t [@@deriving repr] 100 | 101 | let byte_size = 8 102 | let read cstruct offset = Int63.of_int64 @@ Cstruct.HE.get_uint64 cstruct offset 103 | let write cstruct offset v = Cstruct.HE.set_uint64 cstruct offset (Int63.to_int64 v) 104 | let to_string = Int63.to_string 105 | let of_int i = Int63.of_int i 106 | let of_int64 i = Int63.of_int64 i 107 | let add t x = Int63.add t (of_int x) 108 | let succ = Int63.succ 109 | let equal = Int63.equal 110 | let compare = Int63.compare 111 | let to_int64 x = Int63.to_int64 x 112 | end 113 | 114 | module I64 : S = struct 115 | type t = Int64.t [@@deriving repr] 116 | 117 | let byte_size = 8 118 | let read cstruct offset = Cstruct.HE.get_uint64 cstruct offset 119 | let write cstruct offset v = Cstruct.HE.set_uint64 cstruct offset v 120 | let to_string = Int64.to_string 121 | let of_int i = Int64.of_int i 122 | let of_int64 i = i 123 | let add t x = Int64.add t (of_int x) 124 | let succ = Int64.succ 125 | let equal = Int64.equal 126 | let compare = Int64.compare 127 | let to_int64 x = x 128 | end 129 | 130 | let rec log2 x = 131 | if Int64.compare x Int64.one <= 0 then 1 else 1 + log2 (Int64.shift_right x 1) 132 | 133 | let of_nb_pages nb = 134 | match log2 nb with 135 | | bits when bits <= 8 -> (module I8 : S) 136 | | bits when bits <= 16 -> (module I16 : S) 137 | | bits when bits <= 32 -> (module I32 : S) 138 | | bits when bits <= 63 -> (module I63 : S) 139 | | 64 -> (module I64 : S) 140 | | bits -> Printf.ksprintf invalid_arg "Disk too large: %i bits" bits 141 | -------------------------------------------------------------------------------- /src/kv.ml: -------------------------------------------------------------------------------- 1 | open Lwt_result.Syntax 2 | 3 | module Make (Clock : Mirage_clock.PCLOCK) (Check : Checksum.S) (Block : Mirage_block.S) = 4 | struct 5 | type error = 6 | [ `Read of Block.error 7 | | `Write of Block.write_error 8 | | Mirage_kv.error 9 | | Mirage_kv.write_error 10 | | `Invalid_checksum of Int64.t 11 | | `All_generations_corrupted 12 | | `Disk_not_formatted 13 | | `Wrong_page_size of int 14 | | `Wrong_disk_size of Int64.t 15 | | `Wrong_checksum_algorithm of string * int 16 | | `Unsupported_operation of string 17 | ] 18 | 19 | type write_error = error 20 | 21 | let pp_error h = function 22 | | `Read e -> Block.pp_error h e 23 | | `Write e -> Block.pp_write_error h e 24 | | #Mirage_kv.error as e -> Mirage_kv.pp_error h e 25 | | #Mirage_kv.write_error as e -> Mirage_kv.pp_write_error h e 26 | | `Invalid_checksum id -> Format.fprintf h "Invalid_checksum %s" (Int64.to_string id) 27 | | `All_generations_corrupted -> Format.fprintf h "All_generations_corrupted" 28 | | `Disk_not_formatted -> Format.fprintf h "Disk_not_formatted" 29 | | `Wrong_page_size s -> Format.fprintf h "Wrong_page_size %d" s 30 | | `Wrong_disk_size s -> Format.fprintf h "Wrong_disk_size %s" (Int64.to_string s) 31 | | `Wrong_checksum_algorithm (name, byte_size) -> 32 | Format.fprintf h "Wrong_checksum_algorithm (%S, %i)" name byte_size 33 | | `Unsupported_operation msg -> Format.fprintf h "Unsupported_operation %S" msg 34 | 35 | let pp_write_error = pp_error 36 | 37 | let lift_error lwt : (_, error) Lwt_result.t = 38 | let open Lwt.Syntax in 39 | let+ r = lwt in 40 | match r with 41 | | Ok v -> Ok v 42 | | Error `Disk_is_full -> Error `No_space 43 | | Error (#error as e) -> Error e 44 | 45 | module type S = 46 | Fs.S 47 | with type Disk.read_error = Block.error 48 | and type Disk.write_error = Block.write_error 49 | 50 | type t = T : (module S with type t = 'a) * 'a -> t 51 | 52 | let make_disk block = 53 | let open Lwt.Syntax in 54 | let+ (module A_disk) = Context.of_impl (module Block) (module Check) block in 55 | Ok (module Fs.Make_disk (Clock) (A_disk) : S) 56 | 57 | let format block = 58 | let open Lwt_result.Syntax in 59 | let* (module S) = make_disk block in 60 | let+ (t : S.t) = lift_error @@ S.format () in 61 | T ((module S), t) 62 | 63 | let connect block = 64 | let open Lwt_result.Syntax in 65 | let* (module S) = make_disk block in 66 | let+ (t : S.t) = lift_error @@ S.connect () in 67 | T ((module S), t) 68 | 69 | let flush (T ((module S), t)) = lift_error @@ S.flush t 70 | let clear (T ((module S), _)) = lift_error @@ S.clear () 71 | let disk_space (T ((module S), t)) = S.disk_space t 72 | let free_space (T ((module S), t)) = S.free_space t 73 | let page_size (T ((module S), t)) = S.page_size t 74 | 75 | type key = Mirage_kv.Key.t 76 | 77 | let exists (T ((module S), t)) key = 78 | let filename = Mirage_kv.Key.segments key in 79 | Lwt.return_ok (S.exists t filename) 80 | 81 | let last_modified (T ((module S), t)) key = 82 | let filename = Mirage_kv.Key.segments key in 83 | Lwt.return_ok (S.last_modified t filename) 84 | 85 | let get (T ((module S), t)) key = 86 | let filename = Mirage_kv.Key.segments key in 87 | let* result = lift_error @@ S.get t filename in 88 | match result with 89 | | None -> Lwt_result.fail (`Not_found key) 90 | | Some contents -> Lwt_result.return contents 91 | 92 | let get_partial (T ((module S), t)) key ~offset ~length = 93 | let filename = Mirage_kv.Key.segments key in 94 | let* result = lift_error @@ S.get_partial t filename ~offset ~length in 95 | match result with 96 | | None -> Lwt_result.fail (`Not_found key) 97 | | Some contents -> Lwt_result.return contents 98 | 99 | let list (T ((module S), t)) key = 100 | let filename = Mirage_kv.Key.segments key in 101 | let lst = S.list t filename in 102 | let lst = 103 | List.map 104 | (fun (filename, kind) -> 105 | if kind = `Value && filename = "" 106 | then key, kind 107 | else Mirage_kv.Key.( / ) key filename, kind) 108 | lst 109 | in 110 | Lwt.return_ok lst 111 | 112 | let size (T ((module S), t)) key = 113 | let filename = Mirage_kv.Key.segments key in 114 | match S.find_opt t filename with 115 | | None -> Lwt_result.fail (`Not_found key) 116 | | Some file -> 117 | let+ size = lift_error @@ S.size file in 118 | Optint.Int63.of_int size 119 | 120 | let allocate (T ((module S), t)) key ?last_modified:_ size = 121 | let filename = Mirage_kv.Key.segments key in 122 | match S.find_opt t filename with 123 | | Some _ -> Lwt_result.fail (`Already_present key) 124 | | None -> 125 | let size = Optint.Int63.to_int size in 126 | let contents = String.make size '\000' in 127 | let+ _ = lift_error @@ S.touch t filename contents in 128 | () 129 | 130 | let set (T ((module S), t)) key contents = 131 | let filename = Mirage_kv.Key.segments key in 132 | let* _ = lift_error @@ S.touch t filename contents in 133 | lift_error @@ S.flush t 134 | 135 | let set_partial (T ((module S), t)) key ~offset contents = 136 | let filename = Mirage_kv.Key.segments key in 137 | let* ok = lift_error @@ S.set_partial t filename ~offset contents in 138 | if ok then lift_error @@ S.flush t else Lwt_result.fail (`Not_found key) 139 | 140 | let remove (T ((module S), t)) key = 141 | let filename = Mirage_kv.Key.segments key in 142 | let* () = lift_error @@ S.remove t filename in 143 | lift_error @@ S.flush t 144 | 145 | let rename (T ((module S), t)) ~source ~dest = 146 | let src = Mirage_kv.Key.segments source in 147 | let dst = Mirage_kv.Key.segments dest in 148 | let* () = lift_error @@ S.rename t ~src ~dst in 149 | lift_error @@ S.flush t 150 | 151 | let digest _ _ = Lwt_result.fail (`Unsupported_operation "digest") 152 | let disconnect _ = Lwt.return_unit 153 | end 154 | -------------------------------------------------------------------------------- /src/kv.mli: -------------------------------------------------------------------------------- 1 | module Make 2 | (Clock : Mirage_clock.PCLOCK) 3 | (Check : Checksum.S) 4 | (Block : Mirage_block.S) : sig 5 | type t 6 | 7 | type error = 8 | [ `Read of Block.error 9 | | `Write of Block.write_error 10 | | Mirage_kv.error 11 | | Mirage_kv.write_error 12 | | `Invalid_checksum of Int64.t 13 | | `All_generations_corrupted 14 | | `Disk_not_formatted 15 | | `Wrong_page_size of int 16 | | `Wrong_disk_size of Int64.t 17 | | `Wrong_checksum_algorithm of string * int 18 | | `Unsupported_operation of string 19 | ] 20 | 21 | type write_error = error 22 | 23 | include 24 | Mirage_kv.RW 25 | with type t := t 26 | and type error := error 27 | and type write_error := write_error 28 | 29 | val format : Block.t -> (t, write_error) Lwt_result.t 30 | val connect : Block.t -> (t, error) Lwt_result.t 31 | 32 | (* many are unnecessary, clean me up *) 33 | val flush : t -> (unit, write_error) Lwt_result.t 34 | val clear : t -> (unit, write_error) Lwt_result.t 35 | val disk_space : t -> int64 36 | val free_space : t -> int64 37 | val page_size : t -> int 38 | end 39 | -------------------------------------------------------------------------------- /src/lru.ml: -------------------------------------------------------------------------------- 1 | type 'a elt = 2 | | Nil 3 | | Removed 4 | | Detached of 'a 5 | | Elt of 6 | { value : 'a 7 | ; mutable prev : 'a elt 8 | ; mutable next : 'a elt 9 | } 10 | 11 | type 'a t = 12 | { mutable first : 'a elt 13 | ; mutable last : 'a elt 14 | ; mutable length : int 15 | } 16 | 17 | let make () = { first = Nil; last = Nil; length = 0 } 18 | 19 | let push_front elt_elt t = 20 | match elt_elt with 21 | | Detached _ | Removed -> assert false 22 | | Nil -> assert false 23 | | Elt elt -> 24 | elt.prev <- Nil ; 25 | elt.next <- t.first ; 26 | begin 27 | match t.first with 28 | | Detached _ | Removed -> assert false 29 | | Nil -> 30 | assert (t.last = Nil) ; 31 | t.last <- elt_elt 32 | | Elt next -> 33 | assert (next.prev = Nil) ; 34 | next.prev <- elt_elt 35 | end ; 36 | t.first <- elt_elt 37 | 38 | let peek_back t = 39 | match t.last with 40 | | Detached _ | Removed -> assert false 41 | | Nil -> 42 | assert (t.first = Nil) ; 43 | assert (t.length = 0) ; 44 | None 45 | | Elt e -> Some e.value 46 | 47 | let pop_back t = 48 | match t.last with 49 | | Detached _ | Removed -> assert false 50 | | Nil -> 51 | assert (t.first = Nil) ; 52 | assert (t.length = 0) ; 53 | None 54 | | Elt elt as elt_elt -> 55 | assert (t.length > 0) ; 56 | t.length <- t.length - 1 ; 57 | t.last <- elt.prev ; 58 | begin 59 | match elt.prev with 60 | | Detached _ | Removed -> assert false 61 | | Nil -> 62 | assert (t.length = 0) ; 63 | assert (t.first == elt_elt) ; 64 | assert (t.last == Nil) ; 65 | t.first <- Nil 66 | | Elt prev -> prev.next <- Nil 67 | end ; 68 | assert (elt.next = Nil) ; 69 | elt.prev <- Removed ; 70 | elt.next <- Removed ; 71 | Some elt.value 72 | 73 | let detach elt_elt t = 74 | match elt_elt with 75 | | Detached _ | Removed | Nil -> assert false 76 | | Elt { prev = Detached p; next = Detached n; value } -> 77 | assert (p == value) ; 78 | assert (n == value) 79 | | Elt ({ prev = Removed; next = Removed; _ } as elt) -> 80 | elt.next <- Detached elt.value ; 81 | elt.prev <- Detached elt.value 82 | | Elt elt -> 83 | begin 84 | match elt.prev with 85 | | Nil -> 86 | assert (t.first == elt_elt) ; 87 | t.first <- elt.next 88 | | Elt prev -> prev.next <- elt.next 89 | | Removed -> failwith "Lru.detach: Removed" 90 | | Detached _ -> failwith "Lru.detach: Detached" 91 | end ; 92 | begin 93 | match elt.next with 94 | | Nil -> 95 | assert (t.last == elt_elt) ; 96 | t.last <- elt.prev 97 | | Elt next -> next.prev <- elt.prev 98 | | Removed -> failwith "Lru.detach: Removed" 99 | | Detached _ -> failwith "Lru.detach: Detached" 100 | end ; 101 | assert (t.length > 0) ; 102 | t.length <- t.length - 1 ; 103 | elt.next <- Detached elt.value ; 104 | elt.prev <- Detached elt.value 105 | 106 | let detach_remove elt_elt t = 107 | match elt_elt with 108 | | Detached _ | Removed | Nil -> assert false 109 | | Elt { prev = Detached p; next = Detached n; value } -> 110 | assert (p == value) ; 111 | assert (n == value) ; 112 | failwith "Lru.detached_remove: Detached" 113 | | Elt { prev = Removed; next = Removed; _ } -> () 114 | | Elt elt -> 115 | begin 116 | match elt.prev with 117 | | Nil -> 118 | assert (t.first == elt_elt) ; 119 | t.first <- elt.next 120 | | Elt prev -> prev.next <- elt.next 121 | | Removed -> failwith "Lru.detach: Removed" 122 | | Detached _ -> failwith "Lru.detach: Detached" 123 | end ; 124 | begin 125 | match elt.next with 126 | | Nil -> 127 | assert (t.last == elt_elt) ; 128 | t.last <- elt.prev 129 | | Elt next -> next.prev <- elt.prev 130 | | Removed -> failwith "Lru.detach: Removed" 131 | | Detached _ -> failwith "Lru.detach: Detached" 132 | end ; 133 | assert (t.length > 0) ; 134 | t.length <- t.length - 1 ; 135 | elt.next <- Removed ; 136 | elt.prev <- Removed 137 | 138 | let use elt_elt t = 139 | match elt_elt with 140 | | Detached _ -> () 141 | | Removed -> assert false 142 | | Nil -> invalid_arg "Lru.use: Nil element" 143 | | Elt { prev = Removed; next = Removed; _ } -> 144 | (* do something to repair?.. *) 145 | t.length <- t.length + 1 ; 146 | push_front elt_elt t 147 | | Elt { prev = Nil; _ } -> assert (t.first == elt_elt) 148 | | Elt ({ prev = Elt prev as elt_prev; _ } as elt) -> 149 | prev.next <- elt.next ; 150 | begin 151 | match elt.next with 152 | | Detached _ | Removed -> assert false 153 | | Nil -> 154 | assert (t.last == elt_elt) ; 155 | t.last <- elt_prev 156 | | Elt next -> next.prev <- elt_prev 157 | end ; 158 | let prev_length = t.length in 159 | push_front elt_elt t ; 160 | assert (t.length = prev_length) 161 | | Elt { prev = Detached p; next = Detached n; value } -> 162 | assert (p == value) ; 163 | assert (n == value) ; 164 | failwith "Lru.use: unallocated" 165 | | Elt _ -> assert false 166 | 167 | let make_elt value t = 168 | let elt = Elt { value; prev = Nil; next = t.first } in 169 | push_front elt t ; 170 | t.length <- t.length + 1 ; 171 | elt 172 | 173 | let make_detached value = Detached value 174 | 175 | let value = function 176 | | Removed -> invalid_arg "Lru.value: Removed" 177 | | Nil -> invalid_arg "Lru.value: Nil" 178 | | Elt { value; _ } -> value 179 | | Detached value -> value 180 | 181 | let length t = t.length 182 | 183 | let iter fn t = 184 | let rec go = function 185 | | Nil -> () 186 | | Elt { value; next; _ } -> 187 | fn value ; 188 | go next 189 | | _ -> assert false 190 | in 191 | go t.first 192 | 193 | let clear t = 194 | let rec go = function 195 | | Nil -> () 196 | | Elt elt -> 197 | let next = elt.next in 198 | elt.prev <- Removed ; 199 | elt.next <- Removed ; 200 | go next 201 | | _ -> assert false 202 | in 203 | go t.first ; 204 | t.first <- Nil ; 205 | t.last <- Nil ; 206 | t.length <- 0 207 | -------------------------------------------------------------------------------- /src/lru.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | type 'a elt 3 | 4 | val make : unit -> 'a t 5 | val make_elt : 'a -> 'a t -> 'a elt 6 | val make_detached : 'a -> 'a elt 7 | val use : 'a elt -> 'a t -> unit 8 | val peek_back : 'a t -> 'a option 9 | val pop_back : 'a t -> 'a option 10 | val detach : 'a elt -> 'a t -> unit 11 | val detach_remove : 'a elt -> 'a t -> unit 12 | val value : 'a elt -> 'a 13 | val length : 'a t -> int 14 | val iter : ('a -> unit) -> 'a t -> unit 15 | val clear : 'a t -> unit 16 | -------------------------------------------------------------------------------- /src/notafs.ml: -------------------------------------------------------------------------------- 1 | module type CHECKSUM = Checksum.S 2 | 3 | module No_checksum = Checksum.No_checksum 4 | module Adler32 = Checksum.Adler32 5 | module KV = Kv.Make 6 | module FS = Fs.Make_check 7 | 8 | type config = Header.config = 9 | { disk_size : Int64.t 10 | ; page_size : int 11 | ; checksum_algorithm : string 12 | ; checksum_byte_size : int 13 | } 14 | 15 | let get_config = Fs.get_config 16 | -------------------------------------------------------------------------------- /src/notafs.mli: -------------------------------------------------------------------------------- 1 | (** File system for Mirage block devices *) 2 | 3 | (** {1:checksum Checksum interface & implementations} *) 4 | 5 | (** Signature for checksum modules. *) 6 | module type CHECKSUM = sig 7 | include Checksum.S 8 | end 9 | 10 | module Adler32 : CHECKSUM 11 | (** [Adler32] implementation, built around {!Checkseum}'s implementation. *) 12 | 13 | module No_checksum : CHECKSUM 14 | (** Fake implementation, does nothing. 15 | Use it only where integrity checks does not matter (mostly specific tests). *) 16 | 17 | (** {1:stores Notafs stores} *) 18 | 19 | (** The [Notafs] library provides two entry points, depending on your needs: 20 | - {!KV}, a simple key-value implementation, which follows the {!Mirage_kv} signatures. 21 | It should be the best entry point for anyone wishing to use [Notafs] alongside MirageOS. 22 | - {!FS}, a lower-level implementation, with a more usual file system approach. *) 23 | 24 | (** {2:store-kv KV, hierarchical Key-Value store} *) 25 | 26 | (** Simple key-value implementation, based on {!Mirage_kv.RW}. 27 | 28 | It also provides a [format] & [connect] functions for disks creation & opening. 29 | This functor requires several arguments: 30 | - [Clock] is a {!Mirage_clock.PCLOCK}. It will be used for the files and folders timestamps. 31 | - [Check] is a {!CHECKSUM}. It will be used for the integrity verifications. 32 | - [Block] is a {!Mirage_block.S}. It is the block device the filesystem will be built upon. *) 33 | module KV (Clock : Mirage_clock.PCLOCK) (Check : CHECKSUM) (Block : Mirage_block.S) : sig 34 | type t 35 | (** Representation of the kv filesystem. *) 36 | 37 | type error = 38 | [ `Read of Block.error (** Mirage_block default errors *) 39 | | `Write of Block.write_error (** Mirage_block default write errors *) 40 | | Mirage_kv.error 41 | | Mirage_kv.write_error 42 | | `Invalid_checksum of Int64.t 43 | (** Integrity checksum failed for the returned sector id, indicates that the sector was corrupted/probably not written *) 44 | | `All_generations_corrupted 45 | (** None of the generations could be retrieved, disk is beyond repair *) 46 | | `Disk_not_formatted (** The disk is not formatted or the header was corrupted *) 47 | | `Wrong_page_size of int 48 | (** The disk header gives a different page size than what was expected by the disk *) 49 | | `Wrong_disk_size of Int64.t 50 | (** The disk header gives a different disk size than what was expected by the disk *) 51 | | `Wrong_checksum_algorithm of string * int 52 | (** The disk header gives a different algorithm name/size than what was expected by the checksum parameter *) 53 | | `Unsupported_operation of string (** Operation not implemented yet *) 54 | ] 55 | (** The type for errors. *) 56 | 57 | type write_error = error 58 | (** The type for write errors (See {!error}). *) 59 | 60 | val format : Block.t -> (t, write_error) Lwt_result.t 61 | (** [format block] will format the [block] device into a usable filesystem [t]. *) 62 | 63 | val connect : Block.t -> (t, error) Lwt_result.t 64 | (** [connect block] connects to the filesystem [t] stored in the [block] device. *) 65 | 66 | val free_space : t -> int64 67 | (** [free_space t] returns the number of unused sectors of the filesystem [t]. *) 68 | 69 | include 70 | Mirage_kv.RW 71 | with type t := t 72 | and type error := error 73 | and type write_error := write_error 74 | end 75 | 76 | (** {2:store-fs FS, filesystem approach} *) 77 | 78 | (** Filesystem implementation with a lower-level approach. 79 | 80 | It was written specifically to allow {!Index} and {!Irmin_pack} to run on Mirage block devices. 81 | This functor requires several arguments: 82 | - [Clock] is a {!Mirage_clock.PCLOCK}. It will be used for the files and folders timestamps. 83 | - [Check] is a {!CHECKSUM}. It will be used for the integrity verifications. 84 | - [Block] is a {!Mirage_block.S}. It is the block device the filesystem will be built upon. *) 85 | module FS (Clock : Mirage_clock.PCLOCK) (Check : CHECKSUM) (Block : Mirage_block.S) : sig 86 | type error = 87 | [ `All_generations_corrupted 88 | (** None of the generations could be retrieved, disk is beyond repair *) 89 | | `Disk_is_full (** The disk does not have enough available space left *) 90 | | `Disk_not_formatted (** The disk is not formatted or the header was corrupted *) 91 | | `Invalid_checksum of Int64.t 92 | (** Integrity checksum failed for the returned sector id, indicates that the sector was corrupted/probably not written *) 93 | | `Read of Block.error (** Mirage_block default errors *) 94 | | `Write of Block.write_error (** Mirage_block default write errors *) 95 | | `Wrong_checksum_algorithm of string * int 96 | (** The disk header gives a different algorithm name/size than what was expected by the checksum functor *) 97 | | `Wrong_disk_size of Int64.t 98 | (** The disk header gives a different disk size than what was expected by the disk *) 99 | | `Wrong_page_size of int 100 | (** The disk header gives a different page size than what was expected by the disk *) 101 | ] 102 | (** The type for errors. *) 103 | 104 | val pp_error : Format.formatter -> error -> unit 105 | (** [pp_error] is a pretty printer for the type [error]. *) 106 | 107 | exception Fs of error 108 | (** Exception for filesystem errors. All of the functions below may raise this exception. *) 109 | 110 | type t 111 | (** Representation of the filesystem. *) 112 | 113 | val format : Block.t -> t Lwt.t 114 | (** [format block] will format the [block] device. *) 115 | 116 | val connect : Block.t -> t Lwt.t 117 | (** [connect block] connects to the {{!t} [filesystem]} stored in the [block] device. *) 118 | 119 | val flush : t -> unit Lwt.t 120 | (** [flush t] forces the flush of all the pending writes to the disk. 121 | This must be called after a series of update operations to guarantee 122 | that the changes are committed to disk. *) 123 | 124 | type file 125 | (** Representation of the filesystem file handles. *) 126 | 127 | (** {3 Read-only functions} *) 128 | 129 | val filename : file -> string 130 | (** [filename file] returns the name of the given {!file}. *) 131 | 132 | val size : file -> int Lwt.t 133 | (** [size file] returns the size of the given {!file}. *) 134 | 135 | val exists : t -> string -> [> `Dictionary | `Value ] option 136 | (** [exists t path] returns: 137 | - [None] if [path] is not associated to anything in the filesystem {!t}. 138 | - [Some `Dictionary] if [path] is a folder/dictionary. 139 | - [Some `Value] if [path] is a file. *) 140 | 141 | val find : t -> string -> file option 142 | (** [find t path] returns the [file] associated to [path] in the filesystem {!t}. Result is: 143 | - [None] if [path] is missing or points to a dictionary. 144 | - [Some file] if [path] is associated to a [file]. *) 145 | 146 | (** {3 Read-write functions} *) 147 | 148 | val touch : t -> string -> string -> file Lwt.t 149 | (** [touch t path str] creates a {!file} containing [str], at [path] in the filesystem {!t}, 150 | and returns its handle. *) 151 | 152 | val append_substring : file -> string -> off:int -> len:int -> unit Lwt.t 153 | (** [append_substring file s ~off ~len] appends to [file] the substring of [s], 154 | starting at the offset [off] and with length [len]. *) 155 | 156 | val blit_from_string : file -> off:int -> len:int -> string -> unit Lwt.t 157 | (** [blit_from_string file ~off ~len s] replaces [len] bytes of [file] at the offset [off] with 158 | the content of [s]. If it would overflow the length of [file], then the remaining bytes will 159 | be appended at the end of the file. *) 160 | 161 | val blit_to_bytes : file -> off:int -> len:int -> bytes -> int Lwt.t 162 | (** [blit_to_bytes file ~off ~len b] copies [len] characters starting at the offset [off] of [file] 163 | into [bytes]. Returns the number of bytes read. *) 164 | 165 | val remove : t -> string -> unit Lwt.t 166 | (** [remove disk path] removes the [path] from the filesystem {!t}. 167 | If [path] was associated with a file, the file will be removed. If [path] was 168 | associated to a folder/dictionary, it will recursively remove all of its files. *) 169 | 170 | val rename : t -> src:string -> dst:string -> unit Lwt.t 171 | (** [rename disk ~src ~dst] renames a dictionary/file found under the path [src], moving it to the path [dst]. 172 | If [dst] was previously a folder, all of its files will be removed. 173 | Any active [file] handle to [src] will be implicitly renamed. *) 174 | end 175 | 176 | (** {2:general_fun Configuration infos} *) 177 | 178 | type config = 179 | { disk_size : Int64.t (** Number of pages of the disk *) 180 | ; page_size : int (** Size of the disk's pages in bytes *) 181 | ; checksum_algorithm : string (** Name of the checksum used by the disk *) 182 | ; checksum_byte_size : int (** Byte size of the checksum used by the disk *) 183 | } 184 | (** Representation of a Notafs filesystem configuration. *) 185 | 186 | val get_config 187 | : (module Mirage_block.S with type t = 'block) 188 | -> 'block 189 | -> (config, [> `Disk_not_formatted ]) result Lwt.t 190 | (** [get_config block] reads the configuration of the filesystem stored 191 | on the [block] device, if it was previously formatted. 192 | Otherwise, returns the error [`Disk_not_formatted]. 193 | 194 | After formatting a disk, it is not possible to resize the block device, 195 | change its page size, or switch to a different checksum algorithm. *) 196 | -------------------------------------------------------------------------------- /src/queue.ml: -------------------------------------------------------------------------------- 1 | module Make (B : Context.A_DISK) = struct 2 | module Sector = Sector.Make (B) 3 | module Schema = Schema.Make (B) 4 | 5 | type t = Sector.t 6 | type range = Sector.id * int 7 | 8 | type schema = 9 | { height : int Schema.field 10 | ; children : Schema.child Schema.dyn_array (* if height > 0 *) 11 | ; free_sectors : range Schema.field Schema.dyn_array (* if height = 0 *) 12 | } 13 | 14 | let ({ height; children; free_sectors } as schema) = 15 | Schema.define 16 | @@ 17 | let open Schema.Syntax in 18 | let* height = Schema.uint8 in 19 | let| children = Schema.array Schema.child 20 | and| free_sectors = Schema.(array (field_pair id uint32)) in 21 | { height; children; free_sectors } 22 | 23 | include struct 24 | open Schema 25 | open Schema.Infix 26 | 27 | let set_height t v = t.@(height) <- v 28 | let height t = t.@(height) 29 | let nb_children t = t.@(children.length) 30 | let set_nb_children t v = t.@(children.length) <- v 31 | let set_child t i v = t.@(nth children i) <- v 32 | let get_child t i = t.@(nth children i) 33 | let nb_free_sectors t = t.@(free_sectors.length) 34 | let set_nb_free_sectors t v = t.@(free_sectors.length) <- v 35 | let get_free_sector t i = t.@(nth free_sectors i) 36 | let set_free_sector t i v = t.@(nth free_sectors i) <- v 37 | end 38 | 39 | open Lwt_result.Syntax 40 | 41 | let create () = 42 | let* t = Sector.create () in 43 | let* () = set_height t 0 in 44 | let+ () = set_nb_children t 0 in 45 | t 46 | 47 | type push_back = 48 | | Ok_push 49 | | Overflow of range list 50 | 51 | let rec do_push_back t (children : range list) = 52 | assert (children <> []) ; 53 | let* h = height t in 54 | if h = 0 55 | then begin 56 | let* n = nb_free_sectors t in 57 | let max_length = free_sectors.max_length in 58 | let rec go i = function 59 | | [] -> 60 | let+ () = set_nb_free_sectors t i in 61 | Ok_push 62 | | children when i >= max_length -> 63 | let+ () = set_nb_free_sectors t i in 64 | Overflow children 65 | | (child_ptr : range) :: children -> 66 | let* () = set_free_sector t i child_ptr in 67 | go (i + 1) children 68 | in 69 | go n children 70 | end 71 | else begin 72 | let* n = nb_children t in 73 | let max_length = schema.children.max_length in 74 | assert (n > 0) ; 75 | assert (n <= max_length) ; 76 | let rec go i children = 77 | if i >= max_length 78 | then Lwt_result.return (Overflow children) 79 | else begin 80 | let* last = create () in 81 | let* () = set_nb_children t (i + 1) in 82 | let* () = set_child t i last in 83 | let* res = do_push_back last children in 84 | match res with 85 | | Ok_push -> Lwt_result.return Ok_push 86 | | Overflow children -> go (i + 1) children 87 | end 88 | in 89 | let i = n - 1 in 90 | let* last = get_child t i in 91 | let* res = do_push_back last children in 92 | match res with 93 | | Ok_push -> Lwt_result.return Ok_push 94 | | Overflow children -> go (i + 1) children 95 | end 96 | 97 | let rec push_back_list t (children : range list) = 98 | let* res = do_push_back t children in 99 | match res with 100 | | Ok_push -> Lwt_result.return t 101 | | Overflow children -> 102 | let* root = create () in 103 | let* t_height = height t in 104 | let* () = set_height root (t_height + 1) in 105 | let* () = set_nb_children root 1 in 106 | let* () = set_child root 0 t in 107 | push_back_list root children 108 | 109 | let size ptr = 110 | let rec size queue = 111 | let* height = height queue in 112 | if height = 0 113 | then nb_free_sectors queue 114 | else 115 | let* nb_children = nb_children queue in 116 | let rec go i acc = 117 | if i > nb_children - 1 118 | then Lwt_result.return acc 119 | else 120 | let* queue = get_child queue i in 121 | let* s = size queue in 122 | go (i + 1) (acc + s) 123 | in 124 | go 0 0 125 | in 126 | size ptr 127 | 128 | let rec push_discarded ~quantity t = 129 | match B.acquire_discarded () with 130 | | [] -> Lwt_result.return (t, quantity) 131 | | lst -> 132 | let* t = push_back_list t lst in 133 | push_discarded ~quantity:(quantity + List.length lst) t 134 | 135 | let push_discarded t = push_discarded ~quantity:0 t 136 | 137 | type pop_front = 138 | | Ok_pop 139 | | Underflow of int 140 | 141 | let shift_left t nb = 142 | let off = schema.free_sectors.Schema.location in 143 | let len = nb * schema.free_sectors.Schema.size_of_thing in 144 | let* () = Sector.erase_region t ~off ~len in 145 | let* t_nb_free_sectors = nb_free_sectors t in 146 | assert (t_nb_free_sectors - nb > 0) ; 147 | set_nb_free_sectors t (t_nb_free_sectors - nb) 148 | 149 | let shift_left_children t nb = 150 | let off = schema.children.Schema.location in 151 | let len = nb * schema.children.Schema.size_of_thing in 152 | let* () = Sector.erase_region t ~off ~len in 153 | let* t_nb_children = nb_children t in 154 | assert (t_nb_children - nb > 0) ; 155 | set_nb_children t (t_nb_children - nb) 156 | 157 | let rec do_pop_front t nb acc = 158 | assert (nb > 0) ; 159 | let* h = height t in 160 | if h = 0 161 | then begin 162 | let* list_len = nb_free_sectors t in 163 | let rec go i nb acc = 164 | if i = list_len 165 | then Lwt_result.return (nb, i, acc) 166 | else 167 | let* id, len = get_free_sector t i in 168 | match nb with 169 | | nb when nb = len -> Lwt_result.return (0, i + 1, (id, len) :: acc) 170 | | nb when nb > len -> go (i + 1) (nb - len) ((id, len) :: acc) 171 | | _ -> 172 | let* () = set_free_sector t i (B.Id.add id nb, len - nb) in 173 | Lwt_result.return (0, i, (id, nb) :: acc) 174 | in 175 | let* nb_rest, i, acc = go 0 nb acc in 176 | if i >= list_len 177 | then begin 178 | let+ () = set_nb_free_sectors t 0 in 179 | acc, Underflow nb_rest 180 | end 181 | else begin 182 | assert (nb_rest = 0) ; 183 | let+ () = shift_left t i in 184 | acc, Ok_pop 185 | end 186 | end 187 | else begin 188 | let* len = nb_children t in 189 | let rec go i nb acc = 190 | assert (nb >= 0) ; 191 | if i >= len 192 | then begin 193 | let* () = set_height t 0 in 194 | let+ () = set_nb_children t 0 in 195 | acc, Underflow nb 196 | end 197 | else if nb = 0 198 | then begin 199 | assert (i > 0) ; 200 | let+ () = shift_left_children t i in 201 | acc, Ok_pop 202 | end 203 | else 204 | let* first = get_child t i in 205 | let* acc, res = do_pop_front first nb acc in 206 | match res with 207 | | Ok_pop -> 208 | let+ () = if i > 0 then shift_left_children t i else Lwt_result.return () in 209 | acc, Ok_pop 210 | | Underflow rest -> 211 | Sector.free first ; 212 | go (i + 1) rest acc 213 | in 214 | go 0 nb acc 215 | end 216 | 217 | let pop_front t nb = 218 | let* acc, res = do_pop_front t nb [] in 219 | let* t, nb_discarded = push_discarded t in 220 | match res with 221 | | Ok_pop -> Lwt_result.return (t, acc, Int64.of_int (nb - nb_discarded)) 222 | | Underflow _ -> Lwt_result.fail `Disk_is_full 223 | 224 | type q = 225 | { free_start : Sector.id 226 | ; free_queue : t 227 | ; free_sectors : Int64.t 228 | } 229 | 230 | let push_back { free_start; free_queue; free_sectors } lst = 231 | let* free_queue = push_back_list free_queue lst in 232 | let+ free_queue, nb = push_discarded free_queue in 233 | { free_start 234 | ; free_queue 235 | ; free_sectors = Int64.add free_sectors (Int64.of_int (nb + List.length lst)) 236 | } 237 | 238 | let push_discarded { free_start; free_queue; free_sectors } = 239 | let+ free_queue, nb = push_discarded free_queue in 240 | { free_start; free_queue; free_sectors = Int64.add free_sectors (Int64.of_int nb) } 241 | 242 | let pop_front { free_start; free_queue; free_sectors } quantity = 243 | let easy_alloc = 244 | min quantity Int64.(to_int (sub B.nb_sectors (B.Id.to_int64 free_start))) 245 | in 246 | assert (easy_alloc >= 0) ; 247 | let rest_alloc = quantity - easy_alloc in 248 | let head = [ free_start, easy_alloc ] in 249 | let+ free_queue, tail, quantity = 250 | if rest_alloc <= 0 251 | then Lwt_result.return (free_queue, [], 0L) 252 | else pop_front free_queue rest_alloc 253 | in 254 | let quantity = Int64.add quantity (Int64.of_int easy_alloc) in 255 | let q = 256 | { free_start = B.Id.add free_start easy_alloc 257 | ; free_queue 258 | ; free_sectors = Int64.sub free_sectors quantity 259 | } 260 | in 261 | q, head @ tail 262 | 263 | let count_new { free_queue = q; _ } = Sector.count_new q 264 | 265 | let finalize { free_start = f; free_queue = q; free_sectors } ids = 266 | let+ ts, rest = Sector.finalize q ids in 267 | assert (rest = []) ; 268 | { free_start = f; free_queue = q; free_sectors }, ts 269 | 270 | let allocate ~free_queue sector = 271 | let* count = Sector.count_new sector in 272 | if count = 0 273 | then Lwt_result.return (free_queue, []) 274 | else 275 | let* free_queue, allocated = pop_front free_queue count in 276 | let+ to_flush, ids = Sector.finalize sector (B.Diet.list_of_ranges allocated) in 277 | assert (ids = []) ; 278 | free_queue, to_flush 279 | 280 | let self_allocate ~free_queue = 281 | let rec alloc_queue allocated count free_queue = 282 | assert (count > 0) ; 283 | let* free_queue, new_allocated = pop_front free_queue count in 284 | let new_allocated = B.Diet.list_of_ranges new_allocated in 285 | assert (List.length new_allocated = count) ; 286 | let allocated = List.rev_append new_allocated allocated in 287 | assert (B.acquire_discarded () = []) ; 288 | let* new_count = count_new free_queue in 289 | let allocated_count = List.length allocated in 290 | if allocated_count = new_count 291 | then finalize free_queue allocated 292 | else if allocated_count < new_count 293 | then alloc_queue allocated (new_count - allocated_count) free_queue 294 | else begin 295 | let rec give_back ~free_queue allocated_count = function 296 | | [] -> assert false 297 | | (id : Sector.id) :: (allocated : Sector.id list) -> 298 | let* free_queue = push_back free_queue [ id, 1 ] in 299 | let allocated_count = allocated_count - 1 in 300 | let* new_count = count_new free_queue in 301 | if allocated_count = new_count 302 | then finalize free_queue allocated 303 | else if allocated_count > new_count 304 | then give_back ~free_queue allocated_count allocated 305 | else alloc_queue allocated allocated_count free_queue 306 | in 307 | give_back ~free_queue allocated_count allocated 308 | end 309 | in 310 | assert (B.acquire_discarded () = []) ; 311 | let* count = count_new free_queue in 312 | if count > 0 313 | then alloc_queue [] count free_queue 314 | else Lwt_result.return (free_queue, []) 315 | 316 | let load (free_start, ptr, free_sectors) = 317 | let+ free_queue = if Sector.is_null_ptr ptr then create () else Sector.load ptr in 318 | { free_start; free_queue; free_sectors } 319 | 320 | let verify_checksum { free_queue = ptr; _ } = 321 | let rec verify_queue queue = 322 | let* () = Sector.verify_checksum queue in 323 | let* height = height queue in 324 | if height > 0 325 | then 326 | let* nb_children = nb_children queue in 327 | let rec check_child i = 328 | if i > nb_children - 1 329 | then Lwt_result.return () 330 | else 331 | let* queue = get_child queue i in 332 | let* () = verify_queue queue in 333 | check_child (i + 1) 334 | in 335 | check_child 0 336 | else Lwt_result.return () 337 | in 338 | verify_queue ptr 339 | 340 | let size { free_queue; _ } = size free_queue 341 | 342 | let rec reachable_size queue = 343 | let* height = height queue in 344 | if height = 0 345 | then Lwt_result.return 1 346 | else 347 | let* nb_children = nb_children queue in 348 | let rec go i acc = 349 | if i > nb_children - 1 350 | then Lwt_result.return acc 351 | else 352 | let* queue = get_child queue i in 353 | let* s = reachable_size queue in 354 | go (i + 1) (acc + s) 355 | in 356 | go 0 1 357 | 358 | let reachable_size { free_queue; _ } = reachable_size free_queue 359 | end 360 | -------------------------------------------------------------------------------- /src/queue.mli: -------------------------------------------------------------------------------- 1 | module Make (B : Context.A_DISK) : sig 2 | module Sector : module type of Sector.Make (B) 3 | 4 | type range = Sector.id * int 5 | 6 | type q = 7 | { free_start : Sector.id 8 | ; free_queue : Sector.t 9 | ; free_sectors : Int64.t 10 | } 11 | 12 | type 'a r := ('a, B.error) Lwt_result.t 13 | 14 | val load : Sector.id * Sector.ptr * Int64.t -> q r 15 | val verify_checksum : q -> unit r 16 | val push_back : q -> range list -> q r 17 | val push_discarded : q -> q r 18 | val pop_front : q -> int -> (q * range list) r 19 | val finalize : q -> Sector.id list -> (q * (Sector.id * Cstruct.t) list) r 20 | val allocate : free_queue:q -> Sector.t -> (q * (Sector.id * Cstruct.t) list) r 21 | val self_allocate : free_queue:q -> (q * (Sector.id * Cstruct.t) list) r 22 | val size : q -> int r 23 | val reachable_size : q -> int r 24 | end 25 | -------------------------------------------------------------------------------- /src/root.ml: -------------------------------------------------------------------------------- 1 | module Leaf (B : Context.A_DISK) : sig 2 | module Schema : module type of Schema.Make (B) 3 | module Sector = Schema.Sector 4 | module Queue : module type of Queue.Make (B) 5 | 6 | type t = Sector.t 7 | type 'a io := ('a, B.error) Lwt_result.t 8 | type q := Sector.id * Sector.ptr * int64 9 | 10 | val get_free_queue : t -> q io 11 | val get_payload : t -> Sector.ptr io 12 | val get_format_uid : t -> int64 io 13 | val generation : t -> int64 io 14 | 15 | val create 16 | : format_uid:int64 17 | -> gen:int64 18 | -> at:B.Id.t 19 | -> q 20 | -> Sector.ptr 21 | -> Sector.t io 22 | end = struct 23 | module Schema = Schema.Make (B) 24 | module Sector = Schema.Sector 25 | module Queue = Queue.Make (B) 26 | open Lwt_result.Syntax 27 | 28 | type t = Sector.t 29 | 30 | type schema = 31 | { format_uid : int64 Schema.field 32 | ; generation : int64 Schema.field 33 | ; free_start : Sector.id Schema.field 34 | ; free_queue : Schema.ptr 35 | ; free_sectors : int64 Schema.field 36 | ; payload : Schema.ptr 37 | } 38 | 39 | let { format_uid; generation; free_start; free_queue; free_sectors; payload } = 40 | Schema.define 41 | @@ 42 | let open Schema.Syntax in 43 | let+ format_uid = Schema.uint64 44 | and+ generation = Schema.uint64 45 | and+ free_start = Schema.id 46 | and+ free_queue = Schema.ptr 47 | and+ free_sectors = Schema.uint64 48 | and+ payload = Schema.ptr in 49 | { format_uid; generation; free_start; free_queue; free_sectors; payload } 50 | 51 | include struct 52 | open Schema.Infix 53 | 54 | let set_format_uid t v = t.@(format_uid) <- v 55 | let format_uid t = t.@(format_uid) 56 | let set_generation t v = t.@(generation) <- v 57 | let generation t = t.@(generation) 58 | let set_free_start t v = t.@(free_start) <- v 59 | let get_free_start t = t.@(free_start) 60 | let set_free_queue t v = t.@(free_queue) <- v 61 | let free_queue t = t.@(free_queue) 62 | let set_free_sectors t v = t.@(free_sectors) <- v 63 | let free_sectors t = t.@(free_sectors) 64 | let get_payload t = t.@(payload) 65 | let set_payload t v = t.@(payload) <- v 66 | end 67 | 68 | let get_free_queue t = 69 | let* queue = free_queue t in 70 | let* free_start = get_free_start t in 71 | let+ free_sectors = free_sectors t in 72 | free_start, queue, free_sectors 73 | 74 | let get_format_uid t = format_uid t 75 | 76 | let create ~format_uid ~gen ~at (free_start, free_queue, free_sectors) payload = 77 | let* s = Sector.create ~at:(Sector.root_loc at) () in 78 | let* () = set_format_uid s format_uid in 79 | let* () = set_generation s gen in 80 | let* () = set_free_start s free_start in 81 | let* () = set_free_queue s free_queue in 82 | let* () = set_free_sectors s free_sectors in 83 | let+ () = set_payload s payload in 84 | s 85 | end 86 | 87 | module Make (B : Context.A_DISK) = struct 88 | module Leaf = Leaf (B) 89 | module Schema = Leaf.Schema 90 | module Sector = Leaf.Sector 91 | module Header = Header.Make (B) 92 | module Queue = Leaf.Queue 93 | open Lwt_result.Syntax 94 | 95 | let rec regroup (first, last, cs, acc) = function 96 | | [] -> List.rev ((first, List.rev cs) :: acc) 97 | | (id, c) :: rest -> 98 | if B.Id.(equal (succ last) id) 99 | then regroup (first, id, c :: cs, acc) rest 100 | else regroup (id, id, [ c ], (first, List.rev cs) :: acc) rest 101 | 102 | let regroup = function 103 | | [] -> [] 104 | | (id, c) :: rest -> regroup (id, id, [ c ], []) rest 105 | 106 | let regroup lst = 107 | regroup @@ List.sort (fun (a_id, _) (b_id, _) -> B.Id.compare a_id b_id) lst 108 | 109 | let rec flush = function 110 | | [] -> Lwt_result.return () 111 | | (id, cs) :: css -> 112 | let id_ = Int64.to_int @@ B.Id.to_int64 id in 113 | assert (id_ <> 0 && id_ <> 1) ; 114 | let* () = B.write id cs in 115 | flush css 116 | 117 | let flush lst = 118 | let lst = regroup lst in 119 | flush lst 120 | 121 | type t = 122 | { nb_roots : int 123 | ; format_uid : int64 124 | ; mutable generation : Int64.t 125 | ; mutable current : Leaf.t 126 | ; mutable parent_at : int 127 | ; mutable parent : Sector.t 128 | ; mutable current_idx : int 129 | } 130 | 131 | type schema = 132 | { first_generation : int64 Schema.field 133 | ; generations : Schema.id Schema.dyn_array 134 | } 135 | 136 | let { first_generation; generations } = 137 | Schema.define 138 | @@ 139 | let open Schema.Syntax in 140 | let+ first_generation = Schema.uint64 141 | and+ generations = Schema.array Schema.id in 142 | { first_generation; generations } 143 | 144 | let rec find_latest_generation ~check = function 145 | | [] -> Lwt_result.return None 146 | | g :: gs -> 147 | Lwt.bind (check g) (function 148 | | Ok v -> Lwt_result.return (Some v) 149 | | Error _ -> find_latest_generation ~check gs) 150 | 151 | let nb = 8 152 | 153 | let rec split_at n acc = function 154 | | rest when n = 0 -> List.rev acc, rest 155 | | x :: xs -> split_at (n - 1) (x :: acc) xs 156 | | [] -> List.rev acc, [] 157 | 158 | let rec load_gens ~format_uid nb_roots nb s i expected_gen acc = 159 | let open Schema.Infix in 160 | if i >= nb 161 | then Lwt_result.return acc 162 | else 163 | let* at = s.@(Schema.nth generations i) in 164 | let* acc = 165 | Lwt.map 166 | (function 167 | | Ok (g, generation) -> 168 | let g = 169 | { nb_roots 170 | ; generation = g 171 | ; current = generation 172 | ; parent_at = Int64.to_int @@ B.Id.to_int64 @@ Sector.force_id s 173 | ; parent = s 174 | ; current_idx = i 175 | ; format_uid 176 | } 177 | in 178 | Ok (g :: acc) 179 | | Error _ -> Ok acc) 180 | (let* generation = Sector.load_root at in 181 | let* g = Leaf.generation generation in 182 | let* () = 183 | if expected_gen <> g 184 | then Lwt_result.fail `Disk_not_formatted 185 | else Lwt_result.return () 186 | in 187 | let* fuid = Leaf.get_format_uid generation in 188 | let+ () = 189 | if fuid <> format_uid 190 | then Lwt_result.fail `Disk_not_formatted 191 | else Lwt_result.return () 192 | in 193 | g, generation) 194 | in 195 | load_gens ~format_uid nb_roots nb s (i + 1) (Int64.succ expected_gen) acc 196 | 197 | let rec load_roots nb_roots i acc = 198 | if i >= nb_roots 199 | then Lwt_result.return acc 200 | else 201 | let* s = Sector.load_root (B.Id.of_int (i + B.header_size)) in 202 | let open Schema.Infix in 203 | let* first_gen = s.@(first_generation) in 204 | load_roots nb_roots (i + 1) ((first_gen, s) :: acc) 205 | 206 | let load ~check () = 207 | let* header = Header.load () in 208 | let* nb_roots = Header.get_roots header in 209 | let* format_uid = Header.get_format_uid header in 210 | let* roots = load_roots nb_roots 0 [] in 211 | let roots = List.sort (fun (a, _) (b, _) -> Int64.compare b a) roots in 212 | let rec find_latest = function 213 | | [] -> failwith "Root.load: no valid generation" 214 | | (first_gen, parent) :: rest -> 215 | let open Schema.Infix in 216 | let* nb = parent.@(generations.length) in 217 | let* generations = load_gens ~format_uid nb_roots nb parent 0 first_gen [] in 218 | let* found = find_latest_generation ~check generations in 219 | begin 220 | match found with 221 | | None -> find_latest rest 222 | | Some r -> Lwt_result.return r 223 | end 224 | in 225 | find_latest roots 226 | 227 | let create_header ~disk_size ~page_size = 228 | let+ h = Header.create ~disk_size ~page_size in 229 | h 230 | 231 | let rec create_roots nb_roots i acc = 232 | if i >= nb_roots 233 | then Lwt_result.return acc 234 | else 235 | let* s = 236 | Sector.create ~at:(Sector.root_loc @@ B.Id.of_int (i + B.header_size)) () 237 | in 238 | let open Schema.Infix in 239 | let* () = s.@(first_generation) <- Int64.zero in 240 | let* () = s.@(generations.length) <- 0 in 241 | create_roots nb_roots (i + 1) (s :: acc) 242 | 243 | let format () = 244 | let* header = create_header ~page_size:B.page_size ~disk_size:B.nb_sectors in 245 | let* nb_roots = Header.get_roots header in 246 | let* format_uid = Header.get_format_uid header in 247 | let used = nb_roots + nb + B.header_size in 248 | let free_start = B.Id.of_int used in 249 | let free_sectors = Int64.sub B.nb_sectors (Int64.of_int used) in 250 | let* roots = create_roots nb_roots 0 [] in 251 | let s0 = List.hd roots in 252 | let open Schema.Infix in 253 | let* () = s0.@(first_generation) <- Int64.one in 254 | let* () = s0.@(generations.length) <- nb in 255 | let rec go i = 256 | if i >= nb 257 | then Lwt_result.return () 258 | else 259 | let* () = 260 | s0.@(Schema.nth generations i) <- B.Id.of_int (i + nb_roots + B.header_size) 261 | in 262 | go (i + 1) 263 | in 264 | let* () = go 0 in 265 | let* at = s0.@(Schema.nth generations 0) in 266 | let* first = 267 | Leaf.create 268 | ~format_uid 269 | ~gen:Int64.one 270 | ~at 271 | (free_start, Sector.null_ptr, free_sectors) 272 | Sector.null_ptr 273 | in 274 | let rec write_all = function 275 | | [] -> Lwt_result.return () 276 | | r :: rs -> 277 | let* () = Sector.write_root r in 278 | write_all rs 279 | in 280 | let* () = Sector.write_root header in 281 | let+ () = write_all (first :: roots) in 282 | { nb_roots 283 | ; generation = Int64.one 284 | ; current = first 285 | ; parent_at = 0 286 | ; parent = s0 287 | ; current_idx = 0 288 | ; format_uid 289 | } 290 | 291 | let current_idx t = Int64.rem t.generation (Int64.of_int nb) 292 | 293 | let update t ~queue ~payload = 294 | t.generation <- Int64.succ t.generation ; 295 | t.current_idx <- t.current_idx + 1 ; 296 | let open Schema.Infix in 297 | let* max_gens = t.parent.@(generations.length) in 298 | let* queue = 299 | if t.current_idx < max_gens 300 | then Lwt_result.return queue 301 | else begin 302 | t.parent_at <- (t.parent_at + 1) mod t.nb_roots ; 303 | let* s1 = 304 | Sector.create 305 | ~at:(Sector.root_loc @@ B.Id.of_int (t.parent_at + B.header_size)) 306 | () 307 | in 308 | t.parent <- s1 ; 309 | let* queue, free_gens = Queue.pop_front queue nb in 310 | let* () = s1.@(generations.length) <- nb in 311 | let* () = s1.@(first_generation) <- t.generation in 312 | let rec go i = function 313 | | [] -> 314 | assert (i = nb) ; 315 | Lwt_result.return () 316 | | g :: gens -> 317 | let* () = s1.@(Schema.nth generations i) <- g in 318 | go (i + 1) gens 319 | in 320 | let* () = go 0 (B.Diet.list_of_ranges free_gens) in 321 | let+ () = Sector.write_root s1 in 322 | t.current_idx <- 0 ; 323 | t.parent <- s1 ; 324 | queue 325 | end 326 | in 327 | let previous_generation = Sector.force_id t.current in 328 | let* queue = 329 | let* queue = Queue.push_back queue [ previous_generation, 1 ] in 330 | let* queue, to_flush_queue = Queue.self_allocate ~free_queue:queue in 331 | let+ () = flush to_flush_queue in 332 | queue 333 | in 334 | let { Queue.free_start = new_free_start 335 | ; free_queue = new_free_root 336 | ; free_sectors = new_free_sectors 337 | } 338 | = 339 | queue 340 | in 341 | let* at = t.parent.@(Schema.nth generations t.current_idx) in 342 | let* current = 343 | Leaf.create 344 | ~format_uid:t.format_uid 345 | ~gen:t.generation 346 | ~at 347 | (new_free_start, Sector.to_ptr new_free_root, new_free_sectors) 348 | (Sector.to_ptr payload) 349 | in 350 | t.current <- current ; 351 | let+ () = Sector.write_root current in 352 | queue 353 | 354 | let get_free_queue t = Leaf.get_free_queue t.current 355 | let get_payload t = Leaf.get_payload t.current 356 | let reachable_size t = t.nb_roots + nb - t.current_idx 357 | end 358 | -------------------------------------------------------------------------------- /src/rope.ml: -------------------------------------------------------------------------------- 1 | module Make (B : Context.A_DISK) = struct 2 | module Sector = Sector.Make (B) 3 | module Schema = Schema.Make (B) 4 | open Lwt_result.Syntax 5 | 6 | type t = Sector.t 7 | 8 | let count_new = Sector.count_new 9 | let height_index = 0 10 | let nb_children_index = 2 11 | let header_size = 4 12 | let get_height t = Sector.get_uint16 t height_index 13 | let set_height t v = Sector.set_uint16 t height_index v 14 | let get_nb_children t = Sector.get_uint16 t nb_children_index 15 | let set_nb_children t v = Sector.set_uint16 t nb_children_index v 16 | let key_size = 4 17 | let child_size = key_size + Sector.ptr_size 18 | let key_index i = header_size + (child_size * i) 19 | let child_index i = key_index i + key_size 20 | let max_children = (B.page_size - header_size) / child_size 21 | let get_key t i = Sector.get_uint32 t (key_index i) 22 | let set_key t i v = Sector.set_uint32 t (key_index i) v 23 | let get_child t i = Sector.get_child t (child_index i) 24 | let set_child t i v = Sector.set_child t (child_index i) v 25 | let get_child_ptr t i = Sector.get_child_ptr t (child_index i) 26 | 27 | type append_result = 28 | | Ok 29 | | Rest of int 30 | 31 | module Leaf = struct 32 | type nonrec t = t 33 | 34 | let max_length = B.page_size - header_size 35 | let get_length = get_nb_children 36 | let set_length = set_nb_children 37 | 38 | let create () = 39 | let* t = Sector.create () in 40 | let* () = set_height t 0 in 41 | let+ () = set_length t 0 in 42 | t 43 | 44 | let append t (str, i, str_len) = 45 | let* len = get_length t in 46 | let capacity = max_length - len in 47 | if capacity <= 0 48 | then Lwt_result.return (t, Rest i) 49 | else begin 50 | let rest = str_len - i in 51 | let quantity = min rest capacity in 52 | let* () = Sector.blit_from_string str i t (header_size + len) quantity in 53 | let+ () = set_length t (len + quantity) in 54 | let res = if quantity < rest then Rest (i + quantity) else Ok in 55 | t, res 56 | end 57 | 58 | let blit_to_bytes t offs bytes i quantity = 59 | let* len = get_length t in 60 | let quantity = min quantity (len - offs) in 61 | if quantity = 0 62 | then Lwt_result.return 0 63 | else begin 64 | assert (quantity > 0) ; 65 | assert (offs >= 0) ; 66 | assert (offs < len) ; 67 | assert (offs + quantity <= len) ; 68 | assert (i >= 0) ; 69 | assert (i + quantity <= Bytes.length bytes) ; 70 | let+ () = Sector.blit_to_bytes t (offs + header_size) bytes i quantity in 71 | quantity 72 | end 73 | 74 | let blit_from_string t offs str i quantity = 75 | let* len = get_length t in 76 | assert (quantity > 0) ; 77 | assert (offs >= 0) ; 78 | assert (offs < len) ; 79 | assert (offs + quantity <= len) ; 80 | Sector.blit_from_string str i t (offs + header_size) quantity 81 | end 82 | 83 | let size t = 84 | let* height = get_height t in 85 | if height = 0 86 | then Leaf.get_length t 87 | else 88 | let* nb = get_nb_children t in 89 | if nb = 0 then Lwt_result.return 0 else get_key t (nb - 1) 90 | 91 | let create () = 92 | let* t = Sector.create () in 93 | let* () = set_height t 0 in 94 | let+ () = set_nb_children t 0 in 95 | t 96 | 97 | let load ptr = if Sector.is_null_ptr ptr then create () else Sector.load ptr 98 | 99 | let rec verify_checksum t = 100 | let* () = Sector.verify_checksum t in 101 | let* height = get_height t in 102 | if height > 0 103 | then 104 | let* nb_children = get_nb_children t in 105 | let rec check_child i = 106 | if i > nb_children - 1 107 | then Lwt_result.return () 108 | else begin 109 | let* t = get_child t i in 110 | let* () = verify_checksum t in 111 | check_child (i + 1) 112 | end 113 | in 114 | check_child 0 115 | else Lwt_result.return () 116 | 117 | let rec do_append t (str, i, str_len) = 118 | assert (i < str_len) ; 119 | let* height = get_height t in 120 | if height = 0 121 | then Leaf.append t (str, i, str_len) 122 | else begin 123 | let* len = get_nb_children t in 124 | assert (len > 0) ; 125 | let last_index = len - 1 in 126 | let* last_child = get_child t last_index in 127 | let* last_child', res = do_append last_child (str, i, str_len) in 128 | assert (last_child' == last_child) ; 129 | match res with 130 | | Ok -> 131 | let* key_last_index = get_key t last_index in 132 | let* () = set_key t last_index (key_last_index + str_len - i) in 133 | Lwt_result.return (t, Ok) 134 | | Rest i' when i = i' -> 135 | (* no progress, child is full *) 136 | if len >= max_children 137 | then begin 138 | let* retry = compact t in 139 | if retry then do_append t (str, i, str_len) else Lwt_result.return (t, Rest i) 140 | end 141 | else begin 142 | let* leaf = Leaf.create () in 143 | let* () = set_nb_children t (len + 1) in 144 | let* () = set_child t len leaf in 145 | let* key_last_index = get_key t last_index in 146 | let* () = set_key t len key_last_index in 147 | do_append t (str, i, str_len) 148 | end 149 | | Rest i' -> 150 | let* key_last_index = get_key t last_index in 151 | let* () = set_key t last_index (key_last_index + i' - i) in 152 | do_append t (str, i', str_len) 153 | end 154 | 155 | and compact t = 156 | let* height = get_height t in 157 | assert (height > 0) ; 158 | if height = 1 159 | then Lwt_result.return false 160 | else begin 161 | let* len = get_nb_children t in 162 | assert (len = max_children) ; 163 | let last_index = len - 1 in 164 | let* last_child = get_child t last_index in 165 | let* child_height = get_height last_child in 166 | if height = child_height + 1 167 | then Lwt_result.return false 168 | else begin 169 | let rec go i nb acc = 170 | if i < 0 171 | then Lwt_result.return (nb, acc) 172 | else begin 173 | let* child = get_child t i in 174 | let* h = get_height child in 175 | assert (h >= child_height) ; 176 | if h > child_height 177 | then Lwt_result.return (nb, acc) 178 | else go (i - 1) (nb + 1) (child :: acc) 179 | end 180 | in 181 | let* nb, children = go (last_index - 1) 1 [ last_child ] in 182 | let off = key_index (len - nb) in 183 | let* () = Sector.detach_region t ~off ~len:(nb * child_size) in 184 | let* () = set_nb_children t (len - nb + 1) in 185 | let* new_parent = create () in 186 | let* () = set_height new_parent (child_height + 1) in 187 | let* () = set_child t (len - nb) new_parent in 188 | let* () = set_nb_children new_parent nb in 189 | let rec go i at = function 190 | | [] -> Lwt_result.return () 191 | | c :: cs -> 192 | let* s = size c in 193 | let at = at + s in 194 | let* () = set_key new_parent i at in 195 | let* () = set_child new_parent i c in 196 | go (i + 1) at cs 197 | in 198 | let* () = go 0 0 children in 199 | let* prev_at = 200 | if len - nb = 0 then Lwt_result.return 0 else get_key t (len - nb - 1) 201 | in 202 | let* s = size new_parent in 203 | let* () = set_key t (len - nb) (prev_at + s) in 204 | Lwt_result.return true 205 | end 206 | end 207 | 208 | let rec append_from t (str, i, str_len) = 209 | let* t', res = do_append t (str, i, str_len) in 210 | assert (t == t') ; 211 | match res with 212 | | Ok -> Lwt_result.return t 213 | | Rest i -> 214 | let* root = create () in 215 | let* t_height = get_height t in 216 | let* () = set_height root (t_height + 1) in 217 | let* () = set_nb_children root 1 in 218 | let* key = size t in 219 | let* () = set_child root 0 t in 220 | let* () = set_key root 0 key in 221 | append_from root (str, i, str_len) 222 | 223 | let append t str = append_from t (str, 0, String.length str) 224 | 225 | let rec blit_to_bytes ~depth t i bytes j n = 226 | assert (i >= 0) ; 227 | assert (j >= 0) ; 228 | let* height = get_height t in 229 | assert (n >= 0) ; 230 | if n = 0 231 | then Lwt_result.return 0 232 | else if height = 0 233 | then Leaf.blit_to_bytes t i bytes j n 234 | else begin 235 | let requested_read_length = n in 236 | let* t_nb_children = get_nb_children t in 237 | let rec go k j n = 238 | if k >= t_nb_children || n <= 0 239 | then Lwt_result.return n 240 | else begin 241 | let* offs_stop = get_key t k in 242 | let* offs_start = if k = 0 then Lwt_result.return 0 else get_key t (k - 1) in 243 | let len = offs_stop - offs_start in 244 | assert (len >= 0) ; 245 | let sub_i = max 0 (i - offs_start) in 246 | let quantity = min n (len - sub_i) in 247 | assert (quantity <= 0 = (i >= offs_stop)) ; 248 | let* j, n = 249 | if i >= offs_stop 250 | then Lwt_result.return (j, n) 251 | else begin 252 | let* child = get_child t k in 253 | assert (sub_i >= 0) ; 254 | let+ q = blit_to_bytes ~depth:(depth + 1) child sub_i bytes j quantity in 255 | assert (q = quantity) ; 256 | j + quantity, n - quantity 257 | end 258 | in 259 | go (k + 1) j n 260 | end 261 | in 262 | let+ rest = go 0 j n in 263 | assert (rest >= 0) ; 264 | requested_read_length - rest 265 | end 266 | 267 | let blit_to_bytes t i bytes j n = blit_to_bytes ~depth:0 t i bytes j n 268 | 269 | let rec blit_from_string t i bytes j n = 270 | let* height = get_height t in 271 | if height = 0 272 | then Leaf.blit_from_string t i bytes j n 273 | else begin 274 | let j = ref j in 275 | let n = ref n in 276 | let* t_nb_children = get_nb_children t in 277 | let rec go k = 278 | if k >= t_nb_children || !n <= 0 279 | then Lwt_result.return () 280 | else begin 281 | let* offs_stop = get_key t k in 282 | let* () = 283 | if i >= offs_stop 284 | then Lwt_result.return () 285 | else begin 286 | let* offs_start = 287 | if k = 0 then Lwt_result.return 0 else get_key t (k - 1) 288 | in 289 | let len = offs_stop - offs_start in 290 | assert (len >= 0) ; 291 | let sub_i = max 0 (i - offs_start) in 292 | let quantity = min !n (len - sub_i) in 293 | let* child = get_child t k in 294 | let+ () = blit_from_string child sub_i bytes !j quantity in 295 | j := !j + quantity ; 296 | n := !n - quantity 297 | end 298 | in 299 | go (k + 1) 300 | end 301 | in 302 | let+ () = go 0 in 303 | assert (!n = 0) 304 | end 305 | 306 | let blit_from_string t i str j n = 307 | let* len = size t in 308 | if i + n <= len 309 | then 310 | let+ () = blit_from_string t i str j n in 311 | t 312 | else 313 | let* rest = 314 | if i < len 315 | then begin 316 | let m = len - i in 317 | let+ () = blit_from_string t i str j m in 318 | j + m 319 | end 320 | else Lwt_result.return j 321 | in 322 | append_from t (str, rest, j + n) 323 | 324 | let to_string rope = 325 | let* len = size rope in 326 | if len = 0 327 | then Lwt_result.return "" 328 | else begin 329 | let bytes = Bytes.create len in 330 | let+ q = blit_to_bytes rope 0 bytes 0 len in 331 | assert (q = len) ; 332 | Bytes.to_string bytes 333 | end 334 | 335 | let of_string str = 336 | let* t = create () in 337 | if str = "" then Lwt_result.return t else append t str 338 | 339 | let rec free t = 340 | let* height = get_height t in 341 | let+ () = 342 | if height = 0 343 | then Lwt_result.return () 344 | else begin 345 | let* n = get_nb_children t in 346 | let rec go i = 347 | if i >= n 348 | then Lwt_result.return () 349 | else if height = 1 350 | then begin 351 | let* child_ptr = get_child_ptr t i in 352 | Sector.free_ptr child_ptr ; 353 | go (i + 1) 354 | end 355 | else begin 356 | let* child = get_child t i in 357 | let* () = free child in 358 | go (i + 1) 359 | end 360 | in 361 | go 0 362 | end 363 | in 364 | Sector.free t 365 | 366 | let rec reachable_size t = 367 | let* height = get_height t in 368 | if height = 0 369 | then Lwt_result.return 1 370 | else 371 | let* nb = get_nb_children t in 372 | let rec go i acc = 373 | if i >= nb 374 | then Lwt_result.return acc 375 | else begin 376 | let* child = get_child t i in 377 | let* s = reachable_size child in 378 | go (i + 1) (acc + s) 379 | end 380 | in 381 | go 0 1 382 | end 383 | -------------------------------------------------------------------------------- /src/schema.ml: -------------------------------------------------------------------------------- 1 | module Make (B : Context.A_DISK) = struct 2 | module Sector = Sector.Make (B) 3 | 4 | type 'a field = 5 | { get : Sector.t -> ('a, B.error) Lwt_result.t 6 | ; set : Sector.t -> 'a -> (unit, B.error) Lwt_result.t 7 | } 8 | (* let bifield_map f g t = { get = (fun s -> f (t.get s)); set = (fun s x -> t.set s (g x)) } *) 9 | 10 | let bifield_pair x y = 11 | let open Lwt_result.Syntax in 12 | { get = 13 | (fun s -> 14 | let* a = x.get s in 15 | let+ b = y.get s in 16 | a, b) 17 | ; set = 18 | (fun s (a, b) -> 19 | let* () = x.set s a in 20 | let+ () = y.set s b in 21 | ()) 22 | } 23 | 24 | module Infix = struct 25 | let ( .@() ) t i = i.get t 26 | let ( .@()<- ) t i v = i.set t v 27 | end 28 | 29 | type 'a t = max_size:int -> int -> int * 'a 30 | 31 | let define t = 32 | let max_size = B.page_size in 33 | let ofs, x = t ~max_size 0 in 34 | if ofs > max_size then failwith "Schema size is larger than Cstruct max size" ; 35 | x 36 | 37 | let map fn t ~max_size ofs = 38 | let ofs, a = t ~max_size ofs in 39 | ofs, fn a 40 | 41 | let map2 fn x y ~max_size ofs = 42 | let ofs, x = x ~max_size ofs in 43 | let ofs, y = y ~max_size ofs in 44 | ofs, fn x y 45 | 46 | let pair x y ~max_size ofs = 47 | let ofs, x = x ~max_size ofs in 48 | let ofs, y = y ~max_size ofs in 49 | ofs, (x, y) 50 | 51 | let bind fn t ~max_size ofs = 52 | let ofs, x = t ~max_size ofs in 53 | fn x ~max_size ofs 54 | 55 | module Syntax = struct 56 | let ( let+ ) t fn = map fn t 57 | let ( and+ ) = pair 58 | let ( let* ) t fn = bind fn t 59 | let ( let| ) t fn = map fn t 60 | 61 | let ( and| ) a b ~max_size ofs = 62 | let a_ofs, a = a ~max_size ofs 63 | and b_ofs, b = b ~max_size ofs in 64 | max a_ofs b_ofs, (a, b) 65 | end 66 | 67 | let field_pair x y ~max_size ofs = 68 | let ofs, x = x ~max_size ofs in 69 | let ofs, y = y ~max_size ofs in 70 | ofs, bifield_pair x y 71 | 72 | let make size get set : 'a t = 73 | fun ~max_size:_ ofs -> 74 | ofs + size, { get = (fun cs -> get cs ofs); set = (fun cs v -> set cs ofs v) } 75 | 76 | let char = make 1 Sector.get_uint8 Sector.set_uint8 77 | let uint8 = make 1 Sector.get_uint8 Sector.set_uint8 78 | let uint16 = make 2 Sector.get_uint16 Sector.set_uint16 79 | let uint32 = make 4 Sector.get_uint32 Sector.set_uint32 80 | let uint64 = make 8 Sector.get_uint64 Sector.set_uint64 81 | 82 | type 'a dyn_array = 83 | { length : int field 84 | ; max_length : int 85 | ; location : int 86 | ; size_of_thing : int 87 | ; thing : 'a t 88 | } 89 | 90 | let size_of ~max_size thing = 91 | let size, _ = thing ~max_size 0 in 92 | size 93 | 94 | let array thing : 'a dyn_array t = 95 | fun ~max_size ofs -> 96 | let ofs, length = uint16 ~max_size ofs in 97 | let rest = max_size - ofs in 98 | let size_of_thing = size_of ~max_size:rest thing in 99 | let max_length = rest / size_of_thing in 100 | let end_ofs = ofs + (max_length * size_of_thing) in 101 | end_ofs, { length; max_length; location = ofs; size_of_thing; thing } 102 | 103 | let string = array char 104 | 105 | let nth array i = 106 | let _, t = array.thing ~max_size:0 (array.location + (array.size_of_thing * i)) in 107 | t 108 | 109 | type child = Sector.t field 110 | 111 | let child : child t = make Sector.ptr_size Sector.get_child Sector.set_child 112 | 113 | type id = Sector.id field 114 | 115 | let id : id t = make Sector.id_size Sector.read_id Sector.write_id 116 | 117 | type ptr = Sector.ptr field 118 | 119 | let ptr : ptr t = make Sector.ptr_size Sector.get_child_ptr Sector.set_child_ptr 120 | end 121 | -------------------------------------------------------------------------------- /src/sector.mli: -------------------------------------------------------------------------------- 1 | module Make (B : Context.A_DISK) : sig 2 | type 'a r := ('a, B.error) Lwt_result.t 3 | type id = B.Id.t [@@deriving repr] 4 | 5 | val id_size : int 6 | 7 | type ptr [@@deriving repr] 8 | 9 | val null_ptr : ptr 10 | val is_null_ptr : ptr -> bool 11 | val ptr_size : int 12 | 13 | type t 14 | 15 | val force_id : t -> id 16 | val to_ptr : t -> ptr 17 | 18 | type loc 19 | 20 | val root_loc : id -> loc 21 | val create : ?at:loc -> unit -> t r 22 | val load_root : ?check:bool -> id -> t r 23 | val load : ptr -> t r 24 | val verify_checksum : t -> unit r 25 | 26 | (* *) 27 | val write_root : t -> unit r 28 | val to_write : t -> (id * Cstruct.t) r 29 | val count_new : t -> int r 30 | val is_in_memory : t -> bool 31 | val finalize : t -> id list -> ((id * Cstruct.t) list * id list) r 32 | val free : t -> unit 33 | val free_ptr : ptr -> unit 34 | 35 | (* *) 36 | val get_uint8 : t -> int -> int r 37 | val set_uint8 : t -> int -> int -> unit r 38 | val get_uint16 : t -> int -> int r 39 | val set_uint16 : t -> int -> int -> unit r 40 | val get_uint32 : t -> int -> int r 41 | val set_uint32 : t -> int -> int -> unit r 42 | val get_uint64 : t -> int -> Int64.t r 43 | val set_uint64 : t -> int -> Int64.t -> unit r 44 | val read_id : t -> int -> id r 45 | val write_id : t -> int -> id -> unit r 46 | val get_child : t -> int -> t r 47 | val set_child : t -> int -> t -> unit r 48 | val get_child_ptr : t -> int -> ptr r 49 | val set_child_ptr : t -> int -> ptr -> unit r 50 | val erase_region : t -> off:int -> len:int -> unit r 51 | val detach_region : t -> off:int -> len:int -> unit r 52 | val blit_from_string : string -> int -> t -> int -> int -> unit r 53 | val blit_to_bytes : t -> int -> bytes -> int -> int -> unit r 54 | end 55 | -------------------------------------------------------------------------------- /tests/bench_kv.ml: -------------------------------------------------------------------------------- 1 | (* TODO: Create 100mb file and 1gb disk 2 | 3 | $ dd if=/dev/zero of=/tmp/large-disk count=2000000 4 | $ dd if=/dev/random of=/tmp/large-file count=200000 5 | *) 6 | 7 | let disk = "/tmp/large-disk" 8 | let input = "/tmp/large-file" 9 | let sector_size = 4096 10 | 11 | let input_contents = 12 | let t0 = Unix.gettimeofday () in 13 | let h = open_in input in 14 | let len = in_channel_length h in 15 | let bytes = Bytes.create len in 16 | let rec go i = 17 | let chunk = min sector_size (len - i) in 18 | if chunk = 0 19 | then () 20 | else ( 21 | let quantity = Stdlib.input h bytes i chunk in 22 | go (i + quantity)) 23 | in 24 | go 0 ; 25 | close_in h ; 26 | let result = Bytes.unsafe_to_string bytes in 27 | let t1 = Unix.gettimeofday () in 28 | Format.printf 29 | "Unix read in %fs, %#i bytes, %#i sectors@." 30 | (t1 -. t0) 31 | (String.length result) 32 | (String.length result / sector_size) ; 33 | result 34 | 35 | module Block = struct 36 | include Block 37 | 38 | let nb_writes = ref 0 39 | let sectors_written = ref 0 40 | 41 | let write t i cs = 42 | incr nb_writes ; 43 | sectors_written := !sectors_written + List.length cs ; 44 | write t i cs 45 | 46 | let nb_reads = ref 0 47 | let sectors_read = ref 0 48 | 49 | let read t i cs = 50 | incr nb_reads ; 51 | sectors_read := !sectors_read + List.length cs ; 52 | read t i cs 53 | 54 | let stats () = 55 | Format.printf 56 | "nb_writes = %#i (%#i sectors written), nb_reads = %#i (%#i sectors read)@." 57 | !nb_writes 58 | !sectors_written 59 | !nb_reads 60 | !sectors_read ; 61 | nb_writes := 0 ; 62 | nb_reads := 0 ; 63 | sectors_written := 0 ; 64 | sectors_read := 0 65 | end 66 | 67 | open Lwt.Syntax 68 | 69 | let no_error pp lwt = 70 | Lwt.map 71 | (function 72 | | Ok v -> v 73 | | Error e -> 74 | Format.printf "ERROR: %a@." pp e ; 75 | failwith "unexpected error") 76 | lwt 77 | 78 | module Test (Kv : Mirage_kv.RW) = struct 79 | let filename = Mirage_kv.Key.v "test" 80 | 81 | let write fs = 82 | let t0 = Unix.gettimeofday () in 83 | let+ () = no_error Kv.pp_write_error @@ Kv.set fs filename input_contents in 84 | let t1 = Unix.gettimeofday () in 85 | Format.printf "Write: %fs@." (t1 -. t0) ; 86 | Block.stats () 87 | 88 | let read fs = 89 | let t0 = Unix.gettimeofday () in 90 | let+ contents = no_error Kv.pp_error @@ Kv.get fs filename in 91 | let t1 = Unix.gettimeofday () in 92 | Format.printf "Read: %fs@." (t1 -. t0) ; 93 | assert (String.length contents = String.length input_contents) ; 94 | assert (contents = input_contents) ; 95 | Block.stats () 96 | 97 | let main fs = 98 | let* () = write fs in 99 | let* () = read fs in 100 | let* () = write fs in 101 | let* () = read fs in 102 | let* () = write fs in 103 | let* () = read fs in 104 | Lwt.return_unit 105 | end 106 | 107 | module Notafs_kv = Notafs.KV (Pclock) (Notafs.No_checksum) (Block) 108 | module Notafs_kv_crc = Notafs.KV (Pclock) (Notafs.Adler32) (Block) 109 | module Test_notafs = Test (Notafs_kv) 110 | module Test_notafs_crc = Test (Notafs_kv_crc) 111 | module Tar_kv = Tar_mirage.Make_KV_RW (Pclock) (Block) 112 | module Test_tar = Test (Tar_kv) 113 | 114 | let reset block = 115 | let zero = Cstruct.create sector_size in 116 | no_error Block.pp_write_error 117 | @@ Block.write block Int64.zero (List.init 16 (fun _ -> zero)) 118 | 119 | let main () = 120 | let* block = Block.connect ~prefered_sector_size:(Some sector_size) disk in 121 | let* () = 122 | let* fs = no_error Notafs_kv.pp_error @@ Notafs_kv.format block in 123 | Format.printf "@.--- Notafs without checksum:@." ; 124 | let* () = Test_notafs.main fs in 125 | Lwt.return () 126 | in 127 | let* () = 128 | let* fs = no_error Notafs_kv.pp_error @@ Notafs_kv.connect block in 129 | Format.printf "@.--- Notafs without checksum with existing contents:@." ; 130 | let* () = Test_notafs.main fs in 131 | Lwt.return () 132 | in 133 | let* () = 134 | let* fs = no_error Notafs_kv_crc.pp_error @@ Notafs_kv_crc.format block in 135 | Format.printf "@.--- Notafs with checksum:@." ; 136 | let* () = Test_notafs_crc.main fs in 137 | Lwt.return () 138 | in 139 | let* () = reset block in 140 | let* () = 141 | let* fs = Tar_kv.connect block in 142 | Format.printf "@.--- Tar:@." ; 143 | let* () = Test_tar.main fs in 144 | Lwt.return () 145 | in 146 | Lwt.return () 147 | 148 | let () = Lwt_main.run (main ()) 149 | -------------------------------------------------------------------------------- /tests/block_viz.ml: -------------------------------------------------------------------------------- 1 | module Make (B : Mirage_block.S) : sig 2 | include Mirage_block.S 3 | 4 | val draw_status : t -> string -> unit 5 | val connect : ?factor:int -> B.t -> t Lwt.t 6 | val sleep : float ref 7 | val pause : bool ref 8 | val set_window_size : int * int -> unit 9 | val do_pause : unit -> unit 10 | end = struct 11 | type bitmap = int array array 12 | 13 | type vars = 14 | { factor : int 15 | ; true_size : int 16 | ; size : int 17 | ; border : int 18 | ; border_bottom : int 19 | ; size' : int 20 | } 21 | 22 | type t = 23 | { block : B.t 24 | ; mutable size : int * int 25 | ; nb_pages : int 26 | ; bitmaps : bitmap array 27 | ; write_count : int array 28 | ; read_count : int array 29 | ; vars : vars 30 | } 31 | 32 | type error = B.error 33 | type write_error = B.write_error 34 | 35 | let pp_error = B.pp_error 36 | let pp_write_error = B.pp_write_error 37 | let get_info t = B.get_info t.block 38 | 39 | let read t i cs = 40 | List.iteri 41 | (fun j _ -> 42 | let at = Int64.to_int i + j in 43 | t.read_count.(at) <- t.read_count.(at) + 1) 44 | cs ; 45 | B.read t.block i cs 46 | 47 | module G = Graphics 48 | 49 | let get_color i = Color.of_hsl (float i *. 360.0 /. 256.) 0.6 0.6 50 | 51 | let colors = 52 | Array.init 256 53 | @@ fun i -> 54 | let c = get_color i in 55 | let r, g, b = Gg.V4.x c, Gg.V4.y c, Gg.V4.z c in 56 | let i v = max 0 @@ min 255 @@ int_of_float (255.0 *. v) in 57 | let g = G.rgb (i r) (i g) (i b) in 58 | assert (g >= 0 && g <= 0xFFFFFF) ; 59 | assert (g <> G.transp) ; 60 | g 61 | 62 | let draw_status t msg : unit = 63 | let w, _ = t.size in 64 | (* let w, h = G.text_size msg in *) 65 | G.set_color G.white ; 66 | G.fill_rect 0 (t.vars.border_bottom - 15) w 15 ; 67 | G.set_color G.black ; 68 | G.moveto 10 (t.vars.border_bottom - 15) ; 69 | G.draw_string msg 70 | 71 | let draw_image img x y = 72 | let img = G.make_image img in 73 | G.draw_image img x y 74 | 75 | let refresh t = 76 | let ((w, _) as size) = Graphics.size_x (), Graphics.size_y () in 77 | if t.size <> size 78 | then begin 79 | t.size <- size ; 80 | G.clear_graph () ; 81 | for i = 0 to Array.length t.bitmaps - 1 do 82 | let nb_horz = (w - t.vars.border) / t.vars.size' in 83 | let x, y = i mod nb_horz, i / nb_horz in 84 | let x, y = 85 | t.vars.border + (x * t.vars.size'), t.vars.border_bottom + (y * t.vars.size') 86 | in 87 | let img = t.bitmaps.(i) in 88 | draw_image img x y 89 | done 90 | end 91 | 92 | let refresh_write_count t = 93 | let w, _ = t.size in 94 | let s = w / Array.length t.read_count in 95 | let worst = Array.fold_left max 0 t.write_count in 96 | let worst = max 10 worst in 97 | G.set_color G.black ; 98 | let above = 32 * t.vars.factor in 99 | G.moveto 5 above ; 100 | G.draw_string "write counts:" ; 101 | for i = 0 to Array.length t.write_count - 1 do 102 | let height = 32 * t.vars.factor * t.write_count.(i) / worst in 103 | G.fill_rect (s * i) 0 s height 104 | done 105 | 106 | let refresh_read_count t = 107 | let w, _ = t.size in 108 | let s = w / Array.length t.read_count in 109 | let worst = Array.fold_left max 0 t.read_count in 110 | let worst = max 10 worst in 111 | let wrote = ref false in 112 | G.set_color G.black ; 113 | let above = (64 + 32) * t.vars.factor in 114 | G.moveto 5 above ; 115 | G.draw_string "read counts:" ; 116 | for i = 0 to Array.length t.read_count - 1 do 117 | let height = 32 * t.vars.factor * t.read_count.(i) / worst in 118 | G.fill_rect (s * i) (64 * t.vars.factor) s height ; 119 | if (not !wrote) && t.read_count.(i) = worst 120 | then begin 121 | wrote := true ; 122 | G.moveto (s * i) ((64 + 32) * t.vars.factor) ; 123 | G.draw_string (Printf.sprintf "%ix of sector %i" worst i) 124 | end 125 | done 126 | 127 | let draw_sector t i sector = 128 | let w, _ = t.size in 129 | let nb_horz = (w - t.vars.border) / t.vars.size' in 130 | let x, y = i mod nb_horz, i / nb_horz in 131 | let x, y = 132 | t.vars.border + (x * t.vars.size'), t.vars.border_bottom + (y * t.vars.size') 133 | in 134 | let img = t.bitmaps.(i) in 135 | for y = 0 to t.vars.size - 1 do 136 | for x = 0 to t.vars.size - 1 do 137 | let x, y = x / t.vars.factor, y / t.vars.factor in 138 | let j = (y * t.vars.true_size) + x in 139 | let g = 140 | try Cstruct.get_uint8 sector j with 141 | | Invalid_argument _ -> 0 142 | in 143 | for y' = 0 to t.vars.factor - 1 do 144 | for x' = 0 to t.vars.factor - 1 do 145 | img.((y * t.vars.factor) + y').((x * t.vars.factor) + x') <- colors.(g) 146 | done 147 | done 148 | done 149 | done ; 150 | draw_image img x y ; 151 | G.moveto x y ; 152 | G.draw_string (string_of_int i) ; 153 | t.write_count.(i) <- t.write_count.(i) + 1 154 | 155 | let write t id lst = 156 | let id' = Int64.to_int id in 157 | List.iteri (fun i s -> draw_sector t (id' + i) s) lst ; 158 | B.write t.block id lst 159 | 160 | let draw_dead_sector t i = 161 | let w, _ = t.size in 162 | let nb_horz = (w - t.vars.border) / t.vars.size' in 163 | let i = Int32.to_int i in 164 | let x, y = i mod nb_horz, i / nb_horz in 165 | let x, y = 166 | t.vars.border + (x * t.vars.size'), t.vars.border_bottom + (y * t.vars.size') 167 | in 168 | let arr = t.bitmaps.(i) in 169 | for y = 0 to Array.length arr - 1 do 170 | for x = 0 to Array.length arr.(y) - 1 do 171 | let c = arr.(y).(x) in 172 | let r, g, b = c lsr 16, (c lsr 8) land 0xFF, c land 0xFF in 173 | let m = (r + g + b) / 3 in 174 | let m = m land 0xFF in 175 | arr.(y).(x) <- G.rgb m m m 176 | done 177 | done ; 178 | draw_image arr x y ; 179 | (* 180 | G.set_color G.black ; 181 | G.set_line_width 4 ; 182 | G.draw_rect (x + 2) (y + 2) (size - 4) (size - 4) ; 183 | G.moveto (x + 2) (y + 2) ; 184 | G.lineto (x + size - 4) (y + size - 4) ; 185 | G.moveto (x + 2) (y + size - 4) ; 186 | G.lineto (x + size - 4) (y + 2) ; 187 | G.set_line_width 1 ; 188 | *) 189 | () 190 | 191 | (* let discard t i = draw_dead_sector t (Int64.to_int32 i) *) 192 | 193 | let () = 194 | G.open_graph " " ; 195 | G.auto_synchronize false ; 196 | G.set_color G.white ; 197 | G.clear_graph () ; 198 | at_exit (fun () -> G.close_graph ()) 199 | 200 | let vars factor = 201 | let factor = max 1 factor in 202 | let true_size = 32 in 203 | let size = true_size * factor in 204 | let border = 2 in 205 | let border_bottom = 128 * factor in 206 | let size' = size + border in 207 | { factor; true_size; size; border; border_bottom; size' } 208 | 209 | let connect ?(factor = 1) block = 210 | let open Lwt.Syntax in 211 | let+ info = B.get_info block in 212 | let vars = vars factor in 213 | let w, h = G.size_x (), G.size_y () in 214 | let nb_pages = Int64.to_int info.size_sectors in 215 | let bitmaps = 216 | Array.init nb_pages (fun _ -> Array.make_matrix vars.size vars.size 0x555555) 217 | in 218 | let write_count = Array.make nb_pages 0 in 219 | let read_count = Array.make nb_pages 0 in 220 | let t = { block; size = w, h; nb_pages; bitmaps; write_count; read_count; vars } in 221 | for i = 0 to nb_pages - 1 do 222 | draw_dead_sector t (Int32.of_int i) 223 | done ; 224 | t 225 | 226 | let disconnect t = B.disconnect t.block 227 | let sleep = ref 0. 228 | let pause = ref false 229 | let set_window_size (x, y) = G.resize_window x y 230 | 231 | let do_pause () = 232 | let exception Resume in 233 | try 234 | while true do 235 | match Graphics.read_key () with 236 | | ' ' | 'p' -> 237 | Fmt.pr "Graphics: resume execution@." ; 238 | raise Resume 239 | | _ -> () 240 | done 241 | with 242 | | Resume -> () 243 | 244 | let flush t = 245 | refresh t ; 246 | while Graphics.key_pressed () do 247 | match Graphics.read_key () with 248 | | ' ' | 'p' -> 249 | Fmt.pr "Graphics: pause execution@." ; 250 | do_pause () 251 | | _ -> () 252 | done ; 253 | if !pause then do_pause () ; 254 | let w, _ = t.size in 255 | G.set_color G.white ; 256 | G.fill_rect 0 0 w (t.vars.border_bottom - 15) ; 257 | refresh_write_count t ; 258 | refresh_read_count t ; 259 | G.synchronize () ; 260 | Unix.sleepf !sleep ; 261 | () 262 | 263 | let write t i cs = 264 | let r = write t i cs in 265 | flush t ; 266 | r 267 | end 268 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test_irmin) 3 | (modules test_irmin) 4 | (package irmin-pack-notafs) 5 | (libraries 6 | lwt 7 | eio.mock 8 | irmin 9 | irmin_pack_notafs 10 | mirage-block-unix 11 | mirage-clock-unix 12 | mtime.clock.os 13 | block_viz)) 14 | 15 | (library 16 | (name block_viz) 17 | (modules block_viz) 18 | (libraries notafs graphics color unix)) 19 | 20 | (test 21 | (name bench_kv) 22 | (modules bench_kv) 23 | (package notafs) 24 | (libraries lwt notafs mirage-block-unix mirage-clock-unix tar-mirage)) 25 | 26 | (test 27 | (name test_large_notafs) 28 | (modules test_large_notafs) 29 | (package notafs) 30 | (libraries lwt notafs mirage-block-unix mirage-clock-unix mtime.clock.os)) 31 | 32 | (test 33 | (name test_fs) 34 | (modules test_fs) 35 | (package notafs) 36 | (libraries lwt notafs mirage-block-unix mirage-clock-unix cmdliner)) 37 | -------------------------------------------------------------------------------- /tests/test_fs.ml: -------------------------------------------------------------------------------- 1 | open Cmdliner 2 | module Disk = Notafs.KV (Pclock) (Notafs.Adler32) (Block) 3 | 4 | let on_error s = function 5 | | Ok () -> () 6 | | Error err -> Fmt.pr "Encountered error in %S: %a@." s Disk.pp_error err 7 | 8 | let prefered_sector_size = Some 1024 9 | 10 | let rec make_tree n acc = 11 | match n with 12 | | 0 -> 13 | let value = String.concat "/" (List.rev acc) in 14 | let key = Mirage_kv.Key.v value in 15 | [ key, value ] 16 | | n -> 17 | let l = 18 | List.init n (fun i -> 19 | let r = Random.int n in 20 | make_tree r (Fmt.str "%d" i :: acc)) 21 | in 22 | List.flatten l 23 | 24 | let make_tree n = make_tree n [] 25 | 26 | let fs_tests disk = 27 | let tree = make_tree 7 in 28 | Fmt.pr "Tree:@.%a@." Fmt.Dump.(list @@ pair Mirage_kv.Key.pp string) tree ; 29 | let r = List.map (fun (k, v) -> Disk.set disk k v) tree in 30 | List.fold_left (fun a b -> Lwt_result.bind a (fun () -> b)) (Lwt_result.return ()) r 31 | 32 | let main disk_path = 33 | let open Lwt_result.Syntax in 34 | let* block = Lwt_result.ok (Block.connect ~prefered_sector_size disk_path) in 35 | let* disk = Disk.format block in 36 | let* () = fs_tests disk in 37 | let* _disk = Disk.connect block in 38 | let* () = Lwt_result.ok (Disk.disconnect disk) in 39 | Lwt_result.ok (Block.disconnect block) 40 | 41 | let main disk_path = 42 | Random.self_init () ; 43 | on_error "test_fs" @@ Lwt_main.run (main disk_path) 44 | 45 | (* Disk *) 46 | let disk_path = 47 | Arg.( 48 | required 49 | & opt (some file) None 50 | & info [ "d"; "disk" ] ~docv:"DISK_PATH" ~doc:"path to a disk") 51 | 52 | let main_cmd = 53 | let info = Cmd.info "graphics" in 54 | Cmd.v info Term.(const main $ disk_path) 55 | 56 | let () = exit (Cmd.eval ~catch:false main_cmd) 57 | -------------------------------------------------------------------------------- /tests/test_irmin.ml: -------------------------------------------------------------------------------- 1 | (* TODO: Create a small disk 2 | 3 | $ dd if=/dev/zero of=/tmp/notafs-irmin count=400 4 | *) 5 | 6 | module B = Block_viz.Make (Block) 7 | 8 | module Mclock = struct 9 | let elapsed_ns () = Mtime.Span.to_uint64_ns (Mtime_clock.elapsed ()) 10 | let period_ns () = None 11 | end 12 | 13 | module Conf = struct 14 | let entries = 32 15 | let stable_hash = 256 16 | let contents_length_header = Some `Varint 17 | let inode_child_order = `Seeded_hash 18 | let forbid_empty_dir_persistence = true 19 | end 20 | 21 | module Schema = struct 22 | open Irmin 23 | module Metadata = Metadata.None 24 | module Contents = Contents.String_v2 25 | module Path = Path.String_list 26 | module Branch = Branch.String 27 | module Hash = Hash.SHA1 28 | module Node = Node.Generic_key.Make_v2 (Hash) (Path) (Metadata) 29 | module Commit = Commit.Generic_key.Make_v2 (Hash) 30 | module Info = Info.Default 31 | end 32 | 33 | module Store = struct 34 | module Maker = Irmin_pack_notafs.Maker (Mclock) (Pclock) (B) (Conf) 35 | include Maker.Make (Schema) 36 | 37 | let config ?(readonly = false) ?(fresh = true) root = 38 | Irmin_pack.config 39 | ~readonly 40 | ~fresh 41 | ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal 42 | root 43 | end 44 | 45 | let root = "/tmp/notafs-irmin" 46 | 47 | module Fs = Store.Maker.Fs 48 | module Io = Store.Maker.Io 49 | 50 | let main ~fresh ~factor ~stress () = 51 | let is_connected = ref false in 52 | let connect path = 53 | Lwt_direct.direct 54 | @@ fun () -> 55 | let open Lwt.Syntax in 56 | assert (not !is_connected) ; 57 | let* r = Block.connect ~prefered_sector_size:(Some 1024) path in 58 | let+ r = B.connect r ~factor in 59 | is_connected := true ; 60 | r 61 | in 62 | let disconnect block = 63 | assert !is_connected ; 64 | let _ = Lwt_direct.direct @@ fun () -> B.disconnect block in 65 | is_connected := false 66 | in 67 | let () = 68 | if fresh 69 | then begin 70 | let block = connect root in 71 | let _ = Lwt_direct.direct @@ fun () -> Fs.format block in 72 | disconnect block 73 | end 74 | in 75 | let store_root = "/foo/bar" in 76 | let block = connect root in 77 | let () = Lwt_direct.direct @@ fun () -> Io.init block in 78 | let repo = Store.Repo.v (Store.config ~fresh store_root) in 79 | Store.Repo.close repo ; 80 | Io.notafs_flush () ; 81 | disconnect block ; 82 | let with_store = 83 | if stress 84 | then 85 | fun fn -> 86 | let block = connect root in 87 | let () = Lwt_direct.direct @@ fun () -> Io.init block in 88 | let repo = Store.Repo.v (Store.config ~fresh:false store_root) in 89 | let main = Store.main repo in 90 | Fun.protect 91 | (fun () -> fn repo main) 92 | ~finally:(fun () -> 93 | Store.Repo.close repo ; 94 | disconnect block) 95 | else begin 96 | let block = connect root in 97 | let () = Lwt_direct.direct @@ fun () -> Io.init block in 98 | let repo = Store.Repo.v (Store.config ~fresh:false store_root) in 99 | fun fn -> 100 | let main = Store.main repo in 101 | fn repo main 102 | end 103 | in 104 | begin 105 | with_store 106 | @@ fun _repo main -> 107 | Store.set_exn 108 | main 109 | ~info:(fun () -> Store.Info.v Int64.zero ~message:"test") 110 | [ "hello" ] 111 | "world" 112 | end ; 113 | let gc_commits = ref [] in 114 | let gc_run = ref 0 in 115 | let do_gc () = 116 | incr gc_run ; 117 | B.draw_status block (Printf.sprintf "garbage collect START") ; 118 | match List.rev !gc_commits with 119 | | commit :: rest -> 120 | gc_commits := List.rev rest ; 121 | with_store 122 | @@ fun repo _main -> 123 | (match Store.Gc.start_exn ~unlink:true repo commit with 124 | | status -> 125 | Format.printf "GC run %d: %b@." !gc_run status ; 126 | B.draw_status block (Printf.sprintf "garbage collect FINALISE") ; 127 | let _ = Store.Gc.finalise_exn ~wait:false repo in 128 | B.draw_status block (Printf.sprintf "garbage collect DONE") ; 129 | ()) 130 | | [] -> failwith "no gc commits" 131 | in 132 | let prev = ref None in 133 | for i = 0 to 1_000 do 134 | begin 135 | with_store 136 | @@ fun repo main -> 137 | let hash_str = Repr.to_string (Store.Commit.t repo) (Store.Head.get main) in 138 | begin 139 | match !prev with 140 | | None -> () 141 | | Some h -> assert (h = hash_str) 142 | end ; 143 | Store.set_exn 144 | main 145 | ~info:(fun () -> Store.Info.v Int64.zero ~message:"more test") 146 | [ "a" ] 147 | (string_of_int i ^ String.make 500 (Char.chr (128 + (i mod 128)))) ; 148 | let new_hash_str = Repr.to_string (Store.Commit.t repo) (Store.Head.get main) in 149 | prev := Some new_hash_str ; 150 | Format.printf "New commit is %a@." Store.Commit.pp_hash (Store.Head.get main) ; 151 | B.draw_status block (Printf.sprintf "commit %i" i) ; 152 | let _str = Store.get main [ "a" ] in 153 | if i > 0 && i mod 20 = 0 154 | then begin 155 | B.draw_status block (Printf.sprintf "GC chunk split") ; 156 | Store.split repo ; 157 | let current_commit = Store.Commit.key @@ Store.Head.get main in 158 | gc_commits := current_commit :: !gc_commits 159 | end 160 | end ; 161 | if i > 100 && i mod 20 = 0 then do_gc () 162 | done ; 163 | () 164 | 165 | let main ~fresh ~factor ~stress () = 166 | try main ~fresh ~factor ~stress () with 167 | | Store.Maker.Fs.Fs err as exn -> 168 | Format.printf "ERROR: %a@." Store.Maker.Fs.pp_error err ; 169 | raise exn 170 | 171 | (* cmdliner *) 172 | open Cmdliner 173 | 174 | let sleep = 175 | Arg.( 176 | value 177 | & opt float 0. 178 | & info [ "s"; "sleep" ] ~docv:"sleep" ~doc:"sleep time in seconds") 179 | 180 | let pause = 181 | Arg.( 182 | value 183 | & opt bool false 184 | & info [ "p"; "pause" ] ~docv:"pause" ~doc:"automatically trigger a pause") 185 | 186 | let factor = 187 | Arg.(value & opt int 1 & info [ "f"; "factor" ] ~docv:"factor" ~doc:"ui factor") 188 | 189 | let stress = 190 | Arg.(value & opt bool false & info [ "stress" ] ~docv:"stress" ~doc:"stress test") 191 | 192 | let window_size = 193 | Arg.( 194 | value 195 | & opt (some (pair ~sep:',' int int)) None 196 | & info 197 | [ "w"; "window_size" ] 198 | ~docv:"window_size" 199 | ~doc:"size of the window, a pair of integers separated by a coma") 200 | 201 | let main sleep pause factor stress window_size = 202 | B.sleep := sleep ; 203 | B.pause := pause ; 204 | Option.iter B.set_window_size window_size ; 205 | Lwt_main.run 206 | @@ Lwt_direct.indirect 207 | @@ fun () -> Eio_mock.Backend.run @@ main ~fresh:true ~factor ~stress 208 | 209 | let main_cmd = 210 | let info = Cmd.info "graphics" in 211 | Cmd.v info Term.(const main $ sleep $ pause $ factor $ stress $ window_size) 212 | 213 | let () = exit (Cmd.eval ~catch:false main_cmd) 214 | -------------------------------------------------------------------------------- /tests/test_large_notafs.ml: -------------------------------------------------------------------------------- 1 | (* TODO: Create 100mb file and 1gb disk 2 | 3 | $ dd if=/dev/zero of=/tmp/large-disk count=2000000 4 | $ dd if=/dev/random of=/tmp/large-file count=200000 5 | *) 6 | 7 | let disk = "/tmp/large-disk" 8 | let input = "/tmp/large-file" 9 | let sector_size = 4096 10 | 11 | let input_contents = 12 | let t0 = Unix.gettimeofday () in 13 | let h = open_in input in 14 | let len = in_channel_length h in 15 | let bytes = Bytes.create len in 16 | let rec go i = 17 | let chunk = min sector_size (len - i) in 18 | if chunk = 0 19 | then () 20 | else ( 21 | let quantity = Stdlib.input h bytes i chunk in 22 | go (i + quantity)) 23 | in 24 | go 0 ; 25 | close_in h ; 26 | let result = Bytes.unsafe_to_string bytes in 27 | let t1 = Unix.gettimeofday () in 28 | Format.printf 29 | "Unix read in %fs, %#i bytes, %#i sectors@." 30 | (t1 -. t0) 31 | (String.length result) 32 | (String.length result / sector_size) ; 33 | result 34 | 35 | module Block = struct 36 | include Block 37 | 38 | (* let read t i l = 39 | let len = List.length l in 40 | let i' = Int64.to_int i in 41 | if i' + len > 6 && i' <= 6 42 | then 43 | Fmt.pr "reading sector 6@."; 44 | read t i l 45 | 46 | let write t i l = 47 | if List.length l > 5 48 | then 49 | (let s = List.nth l 4 in 50 | Fmt.pr "corrupting sector %a@." Fmt.int64 (Int64.add 4L i); 51 | Cstruct.set_uint8 s 345 13); 52 | write t i l *) 53 | end 54 | 55 | module Test (Check : Notafs.CHECKSUM) = struct 56 | module Fs = Notafs.FS (Pclock) (Check) (Block) 57 | open Lwt.Syntax 58 | 59 | let filename = "myfile" 60 | let connect () = Block.connect ~prefered_sector_size:(Some sector_size) disk 61 | 62 | let write ~fresh block = 63 | let* fs = if fresh then Fs.format block else Fs.connect block in 64 | let t0 = Unix.gettimeofday () in 65 | let* () = 66 | match Fs.find fs filename with 67 | | None -> Lwt.return_unit 68 | | Some _file -> Fs.remove fs filename 69 | in 70 | let* _ = Fs.touch fs filename input_contents in 71 | let* () = Fs.flush fs in 72 | let t1 = Unix.gettimeofday () in 73 | Format.printf "Write: %fs@." (t1 -. t0) ; 74 | (* Format.printf "%a@." (Repr.pp Notafs.Stats.ro_t) (Fs.stats fs) ; *) 75 | Lwt.return () 76 | 77 | let read fs = 78 | let t0 = Unix.gettimeofday () in 79 | let file = Option.get @@ Fs.find fs filename in 80 | let* size = Fs.size file in 81 | let bytes = Bytes.create size in 82 | let* _ = Fs.blit_to_bytes file ~off:0 ~len:size bytes in 83 | let t1 = Unix.gettimeofday () in 84 | Format.printf "Read: %fs@." (t1 -. t0) ; 85 | let result = Bytes.unsafe_to_string bytes in 86 | assert (result = input_contents) ; 87 | (* Format.printf "%a@." (Repr.pp Notafs.Stats.ro_t) (Fs.stats fs) ; *) 88 | Lwt.return () 89 | 90 | let main ~fresh () = 91 | let* block = connect () in 92 | let* () = write ~fresh block in 93 | let* () = Block.disconnect block in 94 | let* block = connect () in 95 | (* let* () = write ~fresh:false block in 96 | let* () = Block.disconnect block in 97 | let* block = connect () in *) 98 | let* fs = Fs.connect block in 99 | let* () = read fs in 100 | Block.disconnect block 101 | 102 | let main () = Lwt_main.run (main ~fresh:true ()) 103 | end 104 | 105 | module Test_nocheck = Test (Notafs.No_checksum) 106 | module Test_adler32 = Test (Notafs.Adler32) 107 | 108 | let () = 109 | Format.printf "--- without checksum:@." ; 110 | Test_nocheck.main () ; 111 | Format.printf "@." ; 112 | Format.printf "--- with adler32 checksum:@." ; 113 | Test_adler32.main () 114 | -------------------------------------------------------------------------------- /unikernel-bench/kv_4/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | (*let remote = "file://home/cha/Documents/github/unikernel-kv/monrepo"*) 4 | 5 | let main = 6 | main 7 | "Unikernel.Main" 8 | (block @-> job) 9 | ~packages: 10 | [ package "mirage-kv" 11 | ; package "fat-filesystem" 12 | ; package "chamelon" ~min:"0.1.1" ~sublibs:[ "kv" ] 13 | ] 14 | 15 | let img = if_impl Key.is_solo5 (block_of_file "storage") (block_of_file "/tmp/storage") 16 | let () = register "block_test" [ main $ img ] 17 | -------------------------------------------------------------------------------- /unikernel-bench/kv_4/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Syntax 2 | 3 | module Main (Block : Mirage_block.S) = struct 4 | let nb_run = 50 5 | 6 | let force lwt = 7 | let open Lwt.Infix in 8 | lwt 9 | >|= function 10 | | Ok v -> v 11 | | Error _ -> failwith "error" 12 | 13 | let median sorted_l = 14 | match sorted_l with 15 | | [] -> 0 16 | | _ -> 17 | let len = List.length sorted_l in 18 | if len mod 2 = 0 19 | then (List.nth sorted_l ((len - 1) / 2) + List.nth sorted_l (len / 2)) / 2 20 | else List.nth sorted_l (len / 2) 21 | 22 | let pp_perf acc n l = 23 | let l = List.sort compare l in 24 | let min = List.nth l 0 in 25 | let max = List.nth l (List.length l - 1) in 26 | Printf.sprintf "{min: %#d; max: %#d; avg: %#d; med: %#d}" min max (acc / n) (median l) 27 | 28 | let p_b_s = 16 29 | 30 | module type Formatted_kv = sig 31 | type t 32 | type write_error 33 | type error 34 | 35 | val set : t -> Mirage_kv.Key.t -> string -> (unit, write_error) result Lwt.t 36 | val get : t -> Mirage_kv.Key.t -> (string, error) result Lwt.t 37 | 38 | val get_partial 39 | : t 40 | -> Mirage_kv.Key.t 41 | -> offset:int 42 | -> length:int 43 | -> (string, error) result Lwt.t 44 | 45 | val connect : Block.t -> (t, error) result Lwt.t 46 | val format : Block.t -> (t, write_error) result Lwt.t 47 | val pp_write_error : Format.formatter -> write_error -> unit 48 | val pp_error : Format.formatter -> error -> unit 49 | end 50 | 51 | module Bench (Kv : Formatted_kv) = struct 52 | let force pp lwt = 53 | let open Lwt.Infix in 54 | lwt 55 | >|= function 56 | | Ok v -> v 57 | | Error e -> 58 | Format.printf "%a@." pp e ; 59 | failwith "error" 60 | 61 | let format block = 62 | let+ fs = force Kv.pp_write_error @@ Kv.format block in 63 | fs 64 | 65 | let bench pp f = 66 | let cl_start = Int64.to_int (Mclock.elapsed_ns ()) in 67 | let+ _ = force pp @@ f (Mirage_kv.Key.v "foo") in 68 | let cl_stop = Int64.to_int (Mclock.elapsed_ns ()) in 69 | cl_stop - cl_start 70 | 71 | let bench_set fs file_size c = 72 | bench Kv.pp_write_error (fun key -> Kv.set fs key (String.make file_size c)) 73 | 74 | let bench_get fs file_size = bench Kv.pp_error (fun key -> Kv.get fs key) 75 | 76 | let bench_get_partial fs file_size = 77 | bench Kv.pp_error (fun key -> 78 | Kv.get_partial fs key ~offset:(file_size / 2) ~length:1024) 79 | 80 | let rec n_bench_set acc l n block file_size f = 81 | if n = 0 82 | then Lwt.return (acc, l) 83 | else 84 | let* fs = format block in 85 | let* time = f fs file_size in 86 | n_bench_set (acc + time) (time :: l) (n - 1) block file_size f 87 | 88 | let n_bench_set n block file_size f = 89 | let+ acc, l = n_bench_set 0 [] n block file_size f in 90 | median (List.sort compare l) 91 | 92 | let rec n_bench_get acc l n block file_size f = 93 | if n = 0 94 | then Lwt.return (acc, l) 95 | else 96 | let* fs = force Kv.pp_error @@ Kv.connect block in 97 | let* time = f fs file_size in 98 | n_bench_get (acc + time) (time :: l) (n - 1) block file_size f 99 | 100 | let n_bench_get n block file_size f = 101 | let* fs = format block in 102 | let* _ = Kv.set fs (Mirage_kv.Key.v "foo") (String.make file_size 'g') in 103 | let+ acc, l = n_bench_get 0 [] n block file_size f in 104 | median (List.sort compare l) 105 | 106 | let rec iterate block file_size_l = 107 | if file_size_l = [] 108 | then Lwt.return () 109 | else ( 110 | let file_size = List.hd file_size_l in 111 | let* mediane_set = 112 | n_bench_set nb_run block file_size (fun fs file_size -> 113 | bench_set fs file_size 'n') 114 | in 115 | let* mediane_get = 116 | n_bench_get nb_run block file_size (fun fs file_size -> bench_get fs file_size) 117 | in 118 | let* mediane_get_partial = 119 | n_bench_get nb_run block file_size (fun fs file_size -> 120 | bench_get_partial fs file_size) 121 | in 122 | Format.printf 123 | "%d\t%d\t%d\t%d@." 124 | file_size 125 | mediane_set 126 | mediane_get 127 | mediane_get_partial ; 128 | iterate block (List.tl file_size_l)) 129 | end 130 | 131 | module Cha = Kv.Make (Block) (Pclock) 132 | 133 | module Bench_cha = Bench (struct 134 | include Cha 135 | 136 | let format block = 137 | let* _ = force @@ Cha.format ~program_block_size:p_b_s block in 138 | let+ fs = force @@ Cha.connect ~program_block_size:p_b_s block in 139 | Ok fs 140 | 141 | let connect block = 142 | let+ fs = force @@ Cha.connect ~program_block_size:p_b_s block in 143 | Ok fs 144 | end) 145 | 146 | module Fat = Fat.Make (Block) 147 | 148 | module Bench_fat = Bench (struct 149 | include Fat 150 | 151 | let connect block = 152 | let+ fs = Fat.connect block in 153 | Ok fs 154 | 155 | let format block = 156 | let* info = Block.get_info block in 157 | let+ fs = Fat.format block info.size_sectors in 158 | fs 159 | 160 | let set block key str = 161 | let name = Mirage_kv.Key.to_string key in 162 | let open Lwt_result.Syntax in 163 | let* () = Fat.create block name in 164 | Fat.write block name 0 (Cstruct.of_string str) 165 | 166 | let get block key = 167 | let name = Mirage_kv.Key.to_string key in 168 | let* info = force @@ Fat.stat block name in 169 | let* res = Fat.read block name 0 (Int64.to_int info.size) in 170 | let str = 171 | match res with 172 | | Ok [ cstruct ] -> Cstruct.to_string cstruct 173 | | _ -> failwith "ERROR" 174 | in 175 | Lwt.return (Ok str) 176 | 177 | let get_partial block key ~offset ~length = 178 | let name = Mirage_kv.Key.to_string key in 179 | let* info = force @@ Fat.stat block name in 180 | let* res = Fat.read block name offset length in 181 | let str = 182 | match res with 183 | | Ok [ cstruct ] -> Cstruct.to_string cstruct 184 | | _ -> failwith "ERROR" 185 | in 186 | Lwt.return (Ok str) 187 | end) 188 | 189 | let rec init_l l acc max step = 190 | if acc >= max then l else init_l (acc :: l) (acc + step) max step 191 | 192 | let init_fs_size_list min max step = List.rev (init_l [] min max step) 193 | 194 | let start block = 195 | let file_size_l = 196 | init_fs_size_list 1_000 100_000 10_000 197 | @ init_fs_size_list 100_000 1_000_000 100_000 198 | @ init_fs_size_list 1_000_000 10_000_000 1_000_000 199 | @ init_fs_size_list 10_000_000 100_000_000 20_000_000 200 | @ init_fs_size_list 100_000_000 180_000_001 20_000_000 201 | in 202 | Format.printf "#CHAMELON@." ; 203 | (* Expected to crash after 140M *) 204 | let* () = Bench_cha.iterate block file_size_l in 205 | Format.printf "@.@.#FAT@." ; 206 | let* () = Bench_fat.iterate block file_size_l in 207 | let+ () = Block.disconnect block in 208 | () 209 | end 210 | -------------------------------------------------------------------------------- /unikernel-bench/kv_6/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let remote = "relativize://docteur" 4 | 5 | let main = 6 | main 7 | "Unikernel.Main" 8 | (block @-> kv_ro @-> job) 9 | ~packages:[ package "notafs"; package "tar-mirage" ] 10 | 11 | let img = if_impl Key.is_solo5 (block_of_file "storage") (block_of_file "/tmp/storage") 12 | 13 | let () = 14 | register 15 | "block_test" 16 | [ main $ img $ docteur remote ~mode:`Fast ~branch:"refs/heads/master" ] 17 | -------------------------------------------------------------------------------- /unikernel-bench/kv_6/docteur/init_docteur.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | ## To initialize files at specific sizes within a git repository for Docteur's computation 3 | 4 | min=1000 5 | max=100000 6 | step=10000 7 | 8 | for ((size = "$min"; size <= "$max"; size += "$step")) 9 | do 10 | dd if=/dev/random of=$size count=$size bs=1000 iflag=count_bytes 11 | done 12 | 13 | min=$max 14 | max=1000000 15 | step=100000 16 | 17 | for ((size = "$min"; size <= "$max"; size += "$step")) 18 | do 19 | dd if=/dev/random of=$size count=$size bs=1000 iflag=count_bytes 20 | done 21 | -------------------------------------------------------------------------------- /unikernel-bench/kv_6/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Syntax 2 | 3 | module Main (Block : Mirage_block.S) (Doc : Mirage_kv.RO) = struct 4 | let nb_run = 50 5 | 6 | let force lwt = 7 | let open Lwt.Infix in 8 | lwt 9 | >|= function 10 | | Ok v -> v 11 | | Error _ -> failwith "error" 12 | 13 | let median sorted_l = 14 | match sorted_l with 15 | | [] -> 0 16 | | _ -> 17 | let len = List.length sorted_l in 18 | if len mod 2 = 0 19 | then (List.nth sorted_l ((len - 1) / 2) + List.nth sorted_l (len / 2)) / 2 20 | else List.nth sorted_l (len / 2) 21 | 22 | let pp_perf acc n l = 23 | let l = List.sort compare l in 24 | let min = List.nth l 0 in 25 | let max = List.nth l (List.length l - 1) in 26 | Printf.sprintf "{min: %#d; max: %#d; avg: %#d; med: %#d}" min max (acc / n) (median l) 27 | 28 | module type Formatted_kv = sig 29 | include Mirage_kv.RW 30 | 31 | val connect : Block.t -> (t, error) result Lwt.t 32 | val format : Block.t -> (t, write_error) result Lwt.t 33 | val pp_write_error : Format.formatter -> write_error -> unit 34 | val pp_error : Format.formatter -> error -> unit 35 | end 36 | 37 | module Bench (Kv : Formatted_kv) = struct 38 | let format block = 39 | let+ fs = force @@ Kv.format block in 40 | fs 41 | 42 | let force pp lwt = 43 | let open Lwt.Infix in 44 | lwt 45 | >|= function 46 | | Ok v -> v 47 | | Error e -> 48 | Format.printf "%a@." pp e ; 49 | failwith "error" 50 | 51 | let bench pp f = 52 | Gc.compact () ; 53 | let cl_start = Int64.to_int (Mclock.elapsed_ns ()) in 54 | let+ _ = force pp @@ f (Mirage_kv.Key.v "foo") in 55 | let cl_stop = Int64.to_int (Mclock.elapsed_ns ()) in 56 | cl_stop - cl_start 57 | 58 | let bench_set fs file_size c = 59 | bench Kv.pp_write_error (fun key -> Kv.set fs key (String.make file_size c)) 60 | 61 | let bench_get fs file_size = bench Kv.pp_error (fun key -> Kv.get fs key) 62 | 63 | let bench_get_partial fs file_size = 64 | bench Kv.pp_error (fun key -> 65 | Kv.get_partial fs key ~offset:(Optint.Int63.of_int (file_size / 2)) ~length:1024) 66 | 67 | let rec n_bench_set acc l n block file_size f = 68 | if n = 0 69 | then Lwt.return (acc, l) 70 | else 71 | let* fs = format block in 72 | let* time = f fs file_size in 73 | n_bench_set (acc + time) (time :: l) (n - 1) block file_size f 74 | 75 | let n_bench_set n block file_size f = 76 | let* acc, l = n_bench_set 0 [] n block file_size f in 77 | Lwt.return (median (List.sort compare l)) 78 | 79 | let rec n_bench_get acc l n block file_size f = 80 | if n = 0 81 | then Lwt.return (acc, l) 82 | else 83 | let* fs = force Kv.pp_error @@ Kv.connect block in 84 | let* time = f fs file_size in 85 | n_bench_get (acc + time) (time :: l) (n - 1) block file_size f 86 | 87 | let n_bench_get n block file_size f = 88 | let* fs = format block in 89 | let* () = 90 | force Kv.pp_write_error 91 | @@ Kv.set fs (Mirage_kv.Key.v "foo") (String.make file_size 'g') 92 | in 93 | let* acc, l = n_bench_get 0 [] n block file_size f in 94 | Lwt.return (median (List.sort compare l)) 95 | 96 | let rec iterate block file_size_l = 97 | if file_size_l = [] 98 | then Lwt.return () 99 | else ( 100 | let file_size = List.hd file_size_l in 101 | let* mediane_set = 102 | n_bench_set nb_run block file_size (fun fs file_size -> 103 | bench_set fs file_size 'n') 104 | in 105 | let* mediane_get = 106 | n_bench_get nb_run block file_size (fun fs file_size -> bench_get fs file_size) 107 | in 108 | let* mediane_get_partial = 109 | n_bench_get nb_run block file_size (fun fs file_size -> 110 | bench_get_partial fs file_size) 111 | in 112 | Format.printf 113 | "%d\t%d\t%d\t%d@." 114 | file_size 115 | mediane_set 116 | mediane_get 117 | mediane_get_partial ; 118 | iterate block (List.tl file_size_l)) 119 | end 120 | 121 | module type Formatted_kv_RO = Mirage_kv.RO 122 | 123 | module Bench_RO (Kv : Formatted_kv_RO) = struct 124 | let force lwt = 125 | let open Lwt.Infix in 126 | lwt 127 | >|= function 128 | | Ok v -> v 129 | | Error e -> 130 | Format.printf "%a@." Kv.pp_error e ; 131 | failwith "error" 132 | 133 | let bench f name = 134 | let cl_start = Int64.to_int (Mclock.elapsed_ns ()) in 135 | let+ res = force @@ f (Mirage_kv.Key.v name) in 136 | let cl_stop = Int64.to_int (Mclock.elapsed_ns ()) in 137 | cl_stop - cl_start 138 | 139 | let bench_get store _file_size name = bench (fun key -> Kv.get store key) name 140 | 141 | let bench_get_partial store file_size name = 142 | bench 143 | (fun key -> 144 | Kv.get_partial 145 | store 146 | key 147 | ~offset:(Optint.Int63.of_int (file_size / 2)) 148 | ~length:(file_size / 4)) 149 | name 150 | 151 | let rec n_bench_get acc l n store f = 152 | if n = 0 153 | then Lwt.return (acc, l) 154 | else 155 | let* time = f store in 156 | n_bench_get (acc + time) (time :: l) (n - 1) store f 157 | 158 | let n_bench_get n store f = 159 | let* acc, l = n_bench_get 0 [] n store f in 160 | Lwt.return (median (List.sort compare l)) 161 | 162 | let rec iterate store file_size_l = 163 | if file_size_l = [] 164 | then Lwt.return () 165 | else ( 166 | let file_size = List.hd file_size_l in 167 | let* mediane_get = 168 | n_bench_get nb_run store (fun store -> 169 | bench_get store file_size (string_of_int file_size)) 170 | in 171 | let* mediane_get_partial = 172 | n_bench_get nb_run store (fun store -> 173 | bench_get_partial store file_size (string_of_int file_size)) 174 | in 175 | Format.printf "%d\t%d\t%d@." file_size mediane_get mediane_get_partial ; 176 | iterate store (List.tl file_size_l)) 177 | end 178 | 179 | module Notaf = Notafs.KV (Pclock) (Notafs.No_checksum) (Block) 180 | module Tar = Tar_mirage.Make_KV_RW (Pclock) (Block) 181 | module Bench_notaf = Bench (Notaf) 182 | 183 | module Bench_tar = Bench (struct 184 | include Tar 185 | 186 | let format block = 187 | let* info = Block.get_info block in 188 | let* () = 189 | force @@ Block.write block Int64.zero [ Cstruct.create (info.sector_size * 2) ] 190 | in 191 | let+ fs = Tar.connect block in 192 | Ok fs 193 | 194 | let connect block = 195 | let* fs = Tar.connect block in 196 | Lwt.return (Ok fs) 197 | end) 198 | 199 | module Bench_doc = Bench_RO (Doc) 200 | 201 | let rec init_l l acc max step = 202 | if acc >= max then l else init_l (acc :: l) (acc + step) max step 203 | 204 | let init_fs_size_list min max step = List.rev (init_l [] min max step) 205 | 206 | let start block store = 207 | let file_size_l = 208 | init_fs_size_list 1_000 100_000 10_000 209 | @ init_fs_size_list 100_000 1_000_000 100_000 210 | @ init_fs_size_list 1_000_000 10_000_000 1_000_000 211 | @ init_fs_size_list 10_000_000 100_000_000 20_000_000 212 | @ init_fs_size_list 100_000_000 400_000_001 20_000_000 213 | in 214 | Format.printf "#NOTAFS@." ; 215 | let* () = Bench_notaf.iterate block file_size_l in 216 | Format.printf "@.@.#TAR@." ; 217 | let* () = Bench_tar.iterate block file_size_l in 218 | Format.printf "@.@.#DOCTEUR@." ; 219 | let* () = Bench_doc.iterate store file_size_l in 220 | let+ () = Block.disconnect block in 221 | () 222 | end 223 | -------------------------------------------------------------------------------- /unikernel-bench/script.gpt: -------------------------------------------------------------------------------- 1 | set terminal pngcairo truecolor size 1800,500 2 | set output './stats.png' 3 | set multiplot layout 1,3 4 | set format y "%3gms" 5 | set format x "%3.0s%cb" 6 | set xlabel 'file size' 7 | set xrange [0:400000000] 8 | set yrange [0:1000] 9 | set xtics font ", 10" 10 | set ytics font ", 10" 11 | 12 | set title 'set (write large file)' 13 | plot 'bench' index 0 using 1:($2 / 1e6) with lines lw 2 title 'Notafs',\ 14 | 'bench' index 1 using 1:($2 / 1e6) with lines lw 2 title 'Tar',\ 15 | 'bench' index 3 using 1:($2 / 1e6) with lines lw 2 title 'Chamelon',\ 16 | 'bench' index 4 using 1:($2 / 1e6) with lines lw 2 title 'Fat' 17 | set title 'Get partial' 18 | set logscale y 19 | plot 'bench' index 0 using 1:($4 / 1e6) with lines lw 2 title 'Notafs',\ 20 | 'bench' index 1 using 1:($4 / 1e6) with lines lw 2 title 'Tar',\ 21 | 'bench' index 3 using 1:($4 / 1e6) with lines lw 2 title 'Chamelon',\ 22 | 'bench' index 4 using 1:($4 / 1e6) with lines lw 2 title 'Fat',\ 23 | #'bench' index 2 using 1:($3 / 1e6) with lines lw 2 title 'Docteur' 24 | set title 'Get' 25 | unset logscale y 26 | set yrange [0:700] 27 | plot 'bench' index 0 using 1:($3 / 1e6) with lines lw 2 title 'Notafs',\ 28 | 'bench' index 1 using 1:($3 / 1e6) with lines lw 2 title 'Tar',\ 29 | 'bench' index 3 using 1:($3 / 1e6) with lines lw 2 title 'Chamelon',\ 30 | 'bench' index 4 using 1:($3 / 1e6) with lines lw 2 title 'Fat',\ 31 | 'bench' index 2 using 1:($2 / 1e6) with lines lw 2 lc "red" title 'Docteur' 32 | 33 | set title 'get\_partial (read 1kb in the middle)' 34 | unset yrange 35 | set logscale xy 36 | set xrange [1000:] 37 | plot 'bench' index 0 using 1:($4 / 1e6) with lines lw 2 title 'Notafs',\ 38 | 'bench' index 1 using 1:($4 / 1e6) with lines lw 2 title 'Tar',\ 39 | 'bench' index 3 using 1:($4 / 1e6) with lines lw 2 title 'Chamelon',\ 40 | 'bench' index 4 using 1:($4 / 1e6) with lines lw 2 title 'Fat',\ 41 | 'bench' index 2 using 1:($3 / 1e6) with lines lw 2 lc "red" title 'Docteur' 42 | unset logscale y 43 | -------------------------------------------------------------------------------- /unikernel-irmin/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = 4 | main 5 | "Unikernel.Main" 6 | (block @-> job) 7 | ~packages:[ package "eio" ~sublibs:[ "mock" ]; package "irmin-pack-notafs" ] 8 | 9 | let img = if_impl Key.is_solo5 (block_of_file "storage") (block_of_file "/tmp/storage") 10 | let () = register "block_test" [ main $ img ] 11 | -------------------------------------------------------------------------------- /unikernel-irmin/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Syntax 2 | 3 | module Main (Block : Mirage_block.S) = struct 4 | module Conf = struct 5 | let entries = 32 6 | let stable_hash = 256 7 | let contents_length_header = Some `Varint 8 | let inode_child_order = `Seeded_hash 9 | let forbid_empty_dir_persistence = true 10 | end 11 | 12 | module Schema = struct 13 | open Irmin 14 | module Metadata = Metadata.None 15 | module Contents = Contents.String_v2 16 | module Path = Path.String_list 17 | module Branch = Branch.String 18 | module Hash = Hash.SHA1 19 | module Node = Node.Generic_key.Make_v2 (Hash) (Path) (Metadata) 20 | module Commit = Commit.Generic_key.Make_v2 (Hash) 21 | module Info = Info.Default 22 | end 23 | 24 | module Store = struct 25 | module Maker = Irmin_pack_notafs.Maker (Mclock) (Pclock) (Block) (Conf) 26 | include Maker.Make (Schema) 27 | 28 | let config ?(readonly = false) ?(fresh = true) root = 29 | Irmin_pack.config 30 | ~readonly 31 | ~fresh 32 | ~indexing_strategy:Irmin_pack.Indexing_strategy.minimal 33 | root 34 | end 35 | 36 | module Fs = Store.Maker.Fs 37 | module Io = Store.Maker.Io 38 | 39 | let info () = Store.Info.v Int64.zero ~message:"test" 40 | 41 | let start block = 42 | let* fresh = 43 | Lwt.catch 44 | (fun () -> 45 | let+ _ = Fs.connect block in 46 | false) 47 | (function 48 | | _ -> 49 | let+ _ = Fs.format block in 50 | true) 51 | in 52 | let* () = Io.init block in 53 | Lwt_direct.indirect 54 | @@ fun () -> 55 | Eio_mock.Backend.run 56 | @@ fun () -> 57 | let repo = Store.Repo.v (Store.config ~fresh "/") in 58 | let main = Store.main repo in 59 | let counter = 60 | match Store.get main [ "counter" ] with 61 | | contents -> int_of_string contents 62 | | exception Invalid_argument _ -> 0 63 | in 64 | Format.printf "counter=%i@." counter ; 65 | Store.set_exn ~info main [ "counter" ] (string_of_int (counter + 1)) ; 66 | Format.printf "Latest commit is %a@." Store.Commit.pp_hash (Store.Head.get main) ; 67 | Store.Repo.close repo 68 | end 69 | -------------------------------------------------------------------------------- /unikernel-kv/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = main "Unikernel.Main" (block @-> job) ~packages:[ package "notafs" ] 4 | let img = if_impl Key.is_solo5 (block_of_file "storage") (block_of_file "/tmp/storage") 5 | let () = register "block_test" [ main $ img ] 6 | -------------------------------------------------------------------------------- /unikernel-kv/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Syntax 2 | 3 | module Main (Block : Mirage_block.S) = struct 4 | module Kv = Notafs.KV (Pclock) (Notafs.Adler32) (Block) 5 | 6 | let force lwt = 7 | let open Lwt.Infix in 8 | lwt 9 | >|= function 10 | | Ok v -> v 11 | | Error e -> 12 | Format.printf "ERROR: %a@." Kv.pp_error e ; 13 | failwith "error" 14 | 15 | let start block = 16 | let* fs = Kv.connect block in 17 | let* fs = 18 | match fs with 19 | | Ok fs -> Lwt.return fs 20 | | Error `Disk_not_formatted -> 21 | let* fs = force @@ Kv.format block in 22 | let+ () = force @@ Kv.set fs (Mirage_kv.Key.v "hello") "world!" in 23 | fs 24 | | Error e -> 25 | Format.printf "ERROR: %a@." Kv.pp_error e ; 26 | failwith "unexpected error" 27 | in 28 | let* contents = force @@ Kv.get fs (Mirage_kv.Key.v "hello") in 29 | Format.printf "%S@." contents ; 30 | let* () = Block.disconnect block in 31 | Lwt.return_unit 32 | end 33 | --------------------------------------------------------------------------------