├── .github └── workflows │ └── docs-pages.yml ├── .gitignore ├── .gitmodules ├── .ocamlformat ├── .travis.yml ├── Dockerfile ├── LICENSE.md ├── Makefile ├── README.md ├── book.toml ├── ci.sh ├── doc ├── CI-NOTES ├── SUMMARY.md ├── design.md ├── free-space.md ├── internals.md ├── intro.md ├── layout.md ├── proposed │ ├── git.md │ └── linear-layout.md ├── references.md ├── scope.md ├── semantics.md └── wodan-for-mirage.html ├── dune-project ├── examples ├── solo5-irmin │ ├── config.ml │ └── dispatch.ml ├── solo5-server │ ├── config.ml │ └── dispatch.ml └── solo5-unikernel │ ├── README.md │ ├── config.ml │ └── dispatch.ml ├── src ├── wodan-irmin │ ├── bin │ │ ├── dune │ │ ├── wodan_git_import.ml │ │ └── wodan_irmin_cli.ml │ ├── dune │ ├── wodan_irmin.ml │ └── wodan_irmin.mli ├── wodan-unix │ ├── dune │ ├── unikernel.ml │ └── wodanc.ml └── wodan │ ├── bitv64.ml │ ├── bitv64.mli │ ├── crc32c.ml │ ├── crc32c.mli │ ├── dune │ ├── keyedmap.ml │ ├── keyedmap.mli │ ├── location.ml │ ├── location.mli │ ├── statistics.ml │ ├── statistics.mli │ ├── wodan.ml │ └── wodan.mli ├── tests ├── wodan-irmin │ ├── bench.ml │ ├── dune │ ├── test.ml │ ├── test.mli │ └── test_wodan.ml └── wodan │ ├── bench.ml │ └── dune ├── wodan-irmin.opam ├── wodan-unix.opam └── wodan.opam /.github/workflows/docs-pages.yml: -------------------------------------------------------------------------------- 1 | name: Build docs. When updating master, publish to GitHub pages 2 | 3 | on: 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | 9 | jobs: 10 | deploy: 11 | runs-on: ubuntu-20.04 12 | steps: 13 | - uses: actions/checkout@v2 14 | 15 | - name: Setup mdBook 16 | uses: XAMPPRocky/get-github-release@v1 17 | with: 18 | owner: rust-lang 19 | repo: mdbook 20 | matches: x86_64-unknown-linux-gnu 21 | token: "${{ secrets.GITHUB_TOKEN }}" 22 | - name: Setup mdBook TOC postprocessor 23 | uses: XAMPPRocky/get-github-release@v1 24 | with: 25 | owner: badboy 26 | repo: mdbook-toc 27 | matches: x86_64-unknown-linux-gnu 28 | token: "${{ secrets.GITHUB_TOKEN }}" 29 | - run: mkdir -- "$GITHUB_WORKSPACE/bin" 30 | - run: mv -t "$GITHUB_WORKSPACE/bin" /tmp/mdbook /tmp/mdbook-toc 31 | - run: echo "$GITHUB_WORKSPACE/bin" >> $GITHUB_PATH 32 | - run: which mdbook 33 | 34 | - name: Setup OCaml 35 | uses: avsm/setup-ocaml@v1 36 | - run: opam exec which mdbook 37 | # Required through irmin-test -> metrics-unix -> conf-gnuplot 38 | - run: sudo apt install gnuplot-nox 39 | - run: make deps 40 | 41 | - run: opam exec make doc 42 | 43 | # Move things a bit for clean and durable urls 44 | - run: mkdir pages pages/doc 45 | - run: mv -t pages book 46 | - run: mv -t pages/doc doc/wodan-for-mirage.html 47 | - run: mv -T _build/default/_doc/_html pages/odoc 48 | 49 | - name: Deploy (master to gh-pages) 50 | uses: peaceiris/actions-gh-pages@v3 51 | if: github.event_name == 'push' && github.ref == 'refs/heads/master' 52 | with: 53 | github_token: ${{ secrets.GITHUB_TOKEN }} 54 | publish_dir: ./pages 55 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /_build/ 2 | /_opam/ 3 | /afl/output/ 4 | /wodan*.install 5 | .merlin 6 | *.img 7 | /wodanc 8 | /solution.json 9 | /book/ 10 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "afl/input"] 2 | path = afl/input 3 | url = https://github.com/g2p/wodan-fuzz-corpus.git 4 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.19.0 2 | break-cases=fit-or-vertical 3 | break-infix=fit-or-vertical 4 | space-around-lists=false 5 | space-around-records=false 6 | margin=79 7 | type-decl=sparse 8 | parse-docstrings 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh 4 | script: 5 | - PINS="wodan.dev:." bash -ex .travis-opam.sh 6 | env: 7 | global: 8 | - ALCOTEST_SHOW_ERRORS=1 9 | 10 | matrix: 11 | include: 12 | - env: OCAML_VERSION=4.11 PACKAGE=wodan 13 | - env: OCAML_VERSION=4.11 PACKAGE=wodan-unix 14 | - env: OCAML_VERSION=4.11 PACKAGE=wodan-irmin 15 | - env: OCAML_VERSION=4.10 PACKAGE=wodan 16 | - env: OCAML_VERSION=4.10 PACKAGE=wodan-unix 17 | - env: OCAML_VERSION=4.10 PACKAGE=wodan-irmin 18 | - env: OCAML_VERSION=4.09 PACKAGE=wodan 19 | - env: OCAML_VERSION=4.09 PACKAGE=wodan-unix 20 | - env: OCAML_VERSION=4.09 PACKAGE=wodan-irmin 21 | - env: OCAML_VERSION=4.08 PACKAGE=wodan 22 | - env: OCAML_VERSION=4.08 PACKAGE=wodan-unix 23 | - env: OCAML_VERSION=4.08 PACKAGE=wodan-irmin 24 | os: 25 | - linux 26 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | # As of 2020-10-01, the ocaml/opam2:latest tag wasn't updated for :4.11 2 | # Advice from @samoht: don't use ocaml/opam2 for now, switch to ocurrent/opam 3 | #FROM docker://docker.io/ocaml/opam2 4 | #FROM docker://docker.io/ocurrent/opam 5 | ARG OCAML_VERSION 6 | FROM docker://docker.io/ocurrent/opam:alpine-3.12-ocaml-${OCAML_VERSION} 7 | WORKDIR /home/opam/opam-repository 8 | #RUN git checkout master 9 | #RUN git pull -q origin master 10 | #RUN opam update --verbose 11 | RUN opam remove travis-opam 12 | # ocurrent is single-switch, use tags in the FROM line 13 | #RUN opam switch set $OCAML_VERSION 14 | #RUN opam upgrade -y 15 | RUN opam depext -ui --noninteractive travis-opam 16 | RUN cp $(opam var bin)/ci-opam -t ~ 17 | RUN opam remove -a travis-opam 18 | RUN mv ~/ci-opam -t $(opam var bin) 19 | VOLUME /repo 20 | WORKDIR /repo 21 | 22 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright 2017-2019 Gabriel de Perthuis 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR 13 | IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | 15 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | build: 3 | dune build 4 | ln -sf _build/default/src/wodan-unix/wodanc.exe wodanc 5 | 6 | deps: 7 | opam install --deps-only --with-doc --with-test . 8 | 9 | doc-deps: 10 | cargo install mdbook mdbook-toc 11 | 12 | sync: 13 | git submodule sync --recursive 14 | git submodule update --init --recursive 15 | 16 | ocamlformat: 17 | dune build @fmt --auto-promote 18 | 19 | fuzz: 20 | dune build src/wodan-unix/wodanc.exe 21 | afl-fuzz -i afl/input -o afl/output -- \ 22 | _build/default/src/wodan-unix/wodanc.exe fuzz @@ 23 | 24 | doc: 25 | dune build @doc 26 | mdbook build 27 | 28 | test: 29 | dune runtest tests 30 | 31 | install: 32 | dune install 33 | 34 | uninstall: 35 | dune uninstall 36 | 37 | clean: 38 | dune clean 39 | rm -f wodanc 40 | 41 | .PHONY: build deps doc-deps ocamlformat fuzz doc test install uninstall clean 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Wodan 2 | 3 | Wodan is a flash friendly, safe and flexible 4 | filesystem library for Mirage OS. 5 | 6 | It provides a key-value store as well as an Irmin backend. 7 | 8 | [![OCaml-CI Build Status](https://img.shields.io/endpoint?url=https%3A%2F%2Fci.ocamllabs.io%2Fbadge%2Fmirage%2Fwodan%2Fmaster&logo=ocaml)](https://ci.ocamllabs.io/github/mirage/wodan) 9 | [![Travis Build Status](https://travis-ci.org/mirage/wodan.svg?branch=master)](https://travis-ci.org/mirage/wodan) 10 | 11 | ## Status 12 | 13 | Wodan works, but still needs more hardening and more testing in 14 | concurrent environments. 15 | 16 | The store it provides is usable for basic tasks, but Wodan itself 17 | doesn't provide ways to serialize complex objects or deal with 18 | non-fixed size keys or values larger than 64k. You are expected 19 | to layer a higher-level store such as Irmin on top of it for such 20 | amenities. 21 | 22 | To get the best performance out of Wodan, you are also expected 23 | to understand some of the tradeoffs involved in flushing data to 24 | disk and picking a block size. 25 | 26 | ## Documentation 27 | 28 | Here is a [Wodan for Mirage users](https://mirage.github.io/wodan/doc/wodan-for-mirage.html) 29 | presentation. 30 | 31 | Unikernel usage is best explained through an example. 32 | 33 | See 34 | https://github.com/mato/camel-service/tree/master/counter-wodan 35 | and the README file it contains for an overview. 36 | 37 | There is also an [ICFP 2017 presentation which is more focused on the internals](https://g2p.github.io/research/wodan-slides.pdf). 38 | 39 | ## Paper 40 | 41 | This explains some of the design choices behind Wodan. 42 | 43 | [ICFP 2017](https://icfp17.sigplan.org/event/ocaml-2017-papers-wodan-a-pure-ocaml-flash-aware-filesystem-library) 44 | 45 | ## Building, installing and running 46 | 47 | Wodan requires [Opam 2][opam], [Dune][dune], [Mirage 3][mirage], 48 | and [OCaml 4.08 through 4.11][ocaml]. 49 | 50 | An opam switch with flambda is recommended for performance reasons. 51 | 52 | ``` 53 | opam switch 4.11.1+fp+flambda 54 | ``` 55 | 56 | ### Building the library, CLI, and Irmin bindings 57 | 58 | ``` 59 | make deps 60 | # Follow the opam instructions 61 | make 62 | ``` 63 | 64 | ## CLI usage 65 | 66 | ``` 67 | ./wodanc --help 68 | ``` 69 | 70 | If wodan-unix has been installed (or pinned) through Opam, 71 | you can instead type: 72 | 73 | ``` 74 | wodanc --help 75 | ``` 76 | 77 | When developping, you may prefer to use the following for 78 | immediate feedback on any changes: 79 | 80 | ``` 81 | dune exec src/wodan-unix/wodanc.exe 82 | ``` 83 | 84 | At the moment the CLI supports creating filesystems, dumping and 85 | restoring data into them, plus some more specialised features 86 | explained below. 87 | 88 | ### Creating an empty disk 89 | 90 | In order to be able to use the following commands, you need a disk for Wodan to 91 | operate on. 92 | 93 | The following commands create a zeroed image of size 512M named `disk.img`. 94 | 95 | ``` 96 | touch disk.img 97 | fallocate -z -l 512m disk.img 98 | ``` 99 | 100 | ### Micro-benchmarking 101 | 102 | ``` 103 | ./wodanc bench 104 | ``` 105 | 106 | ### Running tests 107 | 108 | ``` 109 | make test 110 | ./wodanc exercise 111 | ``` 112 | 113 | ### Running American Fuzzy Lop (AFL) 114 | 115 | This requires OCaml compiled with AFL support. 116 | 117 | ``` 118 | opam switch 4.11.1+afl 119 | sudo sysctl kernel.core_pattern=core 120 | echo performance |sudo tee /sys/devices/system/cpu/cpu*/cpufreq/scaling_governor 121 | make fuzz 122 | ``` 123 | 124 | ## Contributing 125 | 126 | You can rely on the CI for some checks, you can also run tests with 127 | `make test` and ensure the code is well formatted by running 128 | `make ocamlformat` before any commit. 129 | 130 | [opam]: https://opam.ocaml.org/ 131 | [dune]: https://github.com/ocaml/dune#installation 132 | [mirage]: https://mirage.io/ 133 | [ocaml]: https://ocaml.org/ 134 | 135 | -------------------------------------------------------------------------------- /book.toml: -------------------------------------------------------------------------------- 1 | [book] 2 | title = "Wodan book" 3 | src = "doc" 4 | 5 | [preprocessor.toc] 6 | command = "mdbook-toc" 7 | renderer = ["html"] 8 | -------------------------------------------------------------------------------- /ci.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Just a sketch 3 | # Useful for testing things without waiting on Travis, 4 | # but only slightly faster 5 | # Using rootless podman, should work similarly with docker 6 | # See doc/CI-NOTES. 7 | #podman build -v ~/.opam/download-cache:/home/opam/.opam/download-cache -v $PWD:/repo --tag local-build . 8 | buildah bud -v ~/.opam/download-cache:/home/opam/.opam/download-cache -v $PWD:/repo --tag local-build . 9 | podman run -it --userns=keep-id -v ~/.opam/download-cache:/home/opam/.opam/download-cache -v .:/repo -e PACKAGE=wodan-irmin local-build ci-opam 10 | -------------------------------------------------------------------------------- /doc/CI-NOTES: -------------------------------------------------------------------------------- 1 | sudo add-apt-repository ppa:projectatomic/ppa 2 | # Important: install fuse-overlayfs before first running buildah or podman 3 | # Otherwise it will auto-configure itself to use "vfs" storage rather than 4 | # "overlay", make a ton of copies and be dreadfully slow, and hard to migrate 5 | # from without blowing everything. 6 | # crun is not packaged, build manually from https://github.com/containers/crun 7 | # and add the path to the build product to ~/.config/containers/libpod.conf 8 | sudo apt install fuse-overlayfs podman 9 | podman run --rm docker://docker.io/hello-world 10 | -------------------------------------------------------------------------------- /doc/SUMMARY.md: -------------------------------------------------------------------------------- 1 | 2 | [Introduction](intro.md) 3 | 4 | # Design 5 | 6 | - [Scope](scope.md) 7 | - [Semantics](semantics.md) 8 | - [Design choices](design.md) 9 | 10 | # Internals 11 | 12 | - [On-disk layout](layout.md) 13 | - [Code organisation](internals.md) 14 | - [Free space and ENOSPC](free-space.md) 15 | 16 | # Proposed features 17 | 18 | - [Linear, growable layout](proposed/linear-layout.md) 19 | - [Git on top of Wodan](proposed/git.md) 20 | 21 | # Further reading 22 | 23 | - [References](references.md) 24 | -------------------------------------------------------------------------------- /doc/design.md: -------------------------------------------------------------------------------- 1 | # Design notes 2 | 3 | Notes about important choices in the filesystem and implementation design 4 | 5 | ## Caching 6 | 7 | Caching is done at the block level. 8 | 9 | ### Cache priority 10 | 11 | There's an LRU list that combines clean and dirty items. 12 | Flushing dirty items doesn't bump them or discard them from the cache. 13 | They become clean, their priority order stays the same. 14 | 15 | ### Hierarchical consistency 16 | 17 | The LRU can't be arbitrarily reordered as usual; 18 | we want it to preserve hierarchy, so that it only contains 19 | subtrees of the main tree sharing the same root. 20 | 21 | To do this, we make sure that a parent stays more recent than its child. 22 | Order LRU calls properly, and require the LRU to have room for a few 23 | paths from the tree root. 24 | 25 | ## Allocation and adressing cache items 26 | 27 | All cache items are accessed through an AllocID. These IDs, strongly 28 | typed to prevent some likely bugs, are pulled from an arbitrary sequence 29 | started at mount time. Whenever a node is loaded or created, it gets an 30 | AllocID, and when it is finally dropped from cache, that identifier 31 | isn't reused. Since nodes are only ever accessed from one path (no 32 | snapshots or subtree sharing, hierarchical consistency of the LRU), a 33 | node will only ever have one AllocID as long as it is in memory. 34 | 35 | Other choices of identifier that were considered and rejected: 36 | - locations: old location would introduce some ambiguities (wrapping 37 | reuses locations), require updating on flushes, and not cover new 38 | nodes. New one can't be predicted. 39 | - generations: same issues as locations mostly 40 | - direct ownership through references: that might work, but 41 | would interfere with lru ownership, probably requiring ephemerons 42 | somewhere 43 | 44 | When dropping items from cache, there is still some work required 45 | to record the location of nodes on their parents. 46 | Parents were only referencing them by their AllocIDs, and will 47 | switch back to using locations at this point. Only clean nodes 48 | can be dropped, so the location is known. 49 | 50 | The following can keep an alloc id alive: 51 | - it's been lent to the library user through a root handle 52 | - it's dirty 53 | - it's been recently used and is within the LRU list 54 | 55 | ## Single ownership 56 | 57 | Single ownership of nodes is necessary to track when a node is used, 58 | to enable bitmap tracking for gc purposes. 59 | Refcounting is out because we will never update in place. 60 | Mark and sweep is also out because it would cause a ton of IO. 61 | Single ownership also means a logical address is referenced by its parent 62 | exactly once (ghost trees don't matter to the cache), which means the cache 63 | can drop the logical address and use the alloc id instead. 64 | 65 | ## Garbage collection 66 | 67 | We keep track of blocks which we have explicitly stopped using (whenever 68 | we rewrite them to a new address). This allows periodically sending 69 | discards, which is useful for flash-backed stores or for thin 70 | provisioning. 71 | This is complemented by a full fstrim operation which trims everything 72 | not in use. 73 | 74 | ## Integrity 75 | 76 | Integrity checks are preferably done when mounting. This prevents 77 | bitrot and makes it easier to maintain integrity. With fast_scan 78 | enabled, we defer checks on leaves until they are loaded, but all inner 79 | nodes are checked at mount time. This ensures that the tree is well 80 | formed, and builds a reliable space map. 81 | 82 | ## Concurrency 83 | 84 | This is single-threaded at the moment. 85 | Add locking around node updates and some cache operations to change this, possibly. 86 | -------------------------------------------------------------------------------- /doc/free-space.md: -------------------------------------------------------------------------------- 1 | # Free space management 2 | 3 | ## ENOSPC 4 | 5 | The API ensures that flush can be called at all times, 6 | unless the generation limit has been reached. 7 | 8 | If an operation would succeed in-memory but would be impossible 9 | to flush, an error is returned and the operation is not performed. 10 | The actual error can be used to discriminate two cases: 11 | 12 | - NeedsFlush means that the operation would succeed if a flush is 13 | performed immediately before the operation is attempted again. 14 | - OutOfSpace means that the operation will not succeed after 15 | such a flush is performed. 16 | 17 | To emit the correct error, Wodan has a function called reserve_dirty. 18 | When an operation is about to dirty a node (which will propagate to 19 | any parents that are still clean), sometimes creating child or sibling 20 | nodes, it calls this function with the relevant info. 21 | reserve_dirty computes how many nodes would be newly created or dirtied. 22 | If the sum of both is below the count of free nodes, the operation 23 | will not succeed as-is. 24 | A second step can determine if it would work after flushing. 25 | Flushing will turn any new or dirty nodes (prior to the operation) 26 | into clean ones and reduce free space by the number of new nodes. 27 | After this, the operation would dirty everything anew along the 28 | node's parent path, and create new nodes as passed. 29 | -------------------------------------------------------------------------------- /doc/internals.md: -------------------------------------------------------------------------------- 1 | # Wodan internals 2 | 3 | ## Packages 4 | 5 | ### wodan 6 | 7 | The wodan package is at the bottom of the package hierarchy 8 | and implements the file-system, provided an abstract module 9 | that does IO. 10 | 11 | #### Implementation notes 12 | 13 | There are data structures and utility methods defined at the top level. 14 | 15 | There are cstructs defined for the layout of different types of blocks: 16 | superblock, root node or child node. Additionally, an anynode cstruct contains 17 | the fields common to root and child nodes. 18 | 19 | The main data structures are a cache, containing a LRU, and LRU entries. 20 | 21 | LRU entries are the in-memory representation of nodes. Nodes contain and index 22 | children and inline data. The childlink can contain an alloc id if the child 23 | has been loaded, which allows navigating the live tree. 24 | 25 | The cache structure contains the LRU, a subtree for dirty nodes, various counters 26 | which are used to allocate sequential numbers, counters used to track free 27 | space, a map of where free space is on the filesystem, other counters used to 28 | track statistics. 29 | 30 | The main user-facing module is a Make functor, which takes a block device and a 31 | set of parameters that control data layout. 32 | 33 | The API contains the verbs: 34 | 35 | - prepare_io for opening a device. Takes flags for either formatting an empty 36 | device, or opening an existing filesystem. This returns a set of filesystem 37 | roots indexed by their root id. Roots are references to a filesystem root. 38 | 39 | - insert for inserting data into a root. Currently deleting is done by 40 | inserting a zero-sized value. 41 | 42 | - lookup for reading the value associated with a key within a root. 43 | 44 | - flush for landing pending data on the disk. 45 | 46 | Opening the filesystem involves locating the root block (using a bisection that 47 | looks for the highest generation number of a root), checking the filesystem, 48 | and scanning the entirety of if to establish a free space map. This will be 49 | improved by maintaining a space map as part of a secondary metadata root. 50 | 51 | The implementation for insert is split into a half that reserves space, might 52 | rebalance the tree, might load nodes from disk, and a fast half that 53 | immediately inserts into already available space. The reserve implementation is 54 | sometimes called to reserve space for a batch of fast inserts; this is the case 55 | when a node spills into a lower node. This split allows better error reporting 56 | when there is no free space. 57 | 58 | ### wodan-unix 59 | 60 | The wodan-unix package depends on Wodan and Unix, 61 | so that the filesystem can be backed by standard files. 62 | 63 | It contains a wodanc command, which is a multitool 64 | that can create filesystems, dump and restore data 65 | from/into filesystems, and trim unused blocks. 66 | 67 | It can also run benchmarks, run other tests that 68 | attempt to exercise most of the code base, and 69 | fuzz the same tests. 70 | 71 | ### wodan-irmin 72 | 73 | The wodan-irmin package provides some Irmin database types 74 | that can be constructed from Wodan filesystems. 75 | -------------------------------------------------------------------------------- /doc/intro.md: -------------------------------------------------------------------------------- 1 | Wodan is a flash friendly, safe and flexible filesystem library for Mirage OS 2 | 3 | This documentation focuses on design choices and implementation choices. 4 | -------------------------------------------------------------------------------- /doc/layout.md: -------------------------------------------------------------------------------- 1 | # Layout 2 | 3 | ## Blocks 4 | 5 | Blocks are currently one of: 6 | - the superblock, which is the first block at offset 0 7 | - node blocks, representing serialized nodes 8 | - unallocated blocks, which are generally ignored 9 | when mounting (mounting starts with a bisect operation 10 | that will look for the newest valid root and ignore blocks 11 | that don't seem to belong to the filesystem; currently 12 | this looks at the fsid, the crc, and the type flag 13 | which must indicate a root). 14 | 15 | There is also a special kind of unallocated block, which 16 | looks like a root node block but is at generation zero 17 | (considered invalid). 18 | This is used to speed up bisection on freshly created filesystems. 19 | The bisection considers these blocks valid as lower bounds, 20 | but they are not valid root nodes. 21 | 22 | ## The superblock 23 | 24 | ``` 25 | (* 512 bytes. The rest of the block isn't crc-controlled. *) 26 | type%cstruct superblock = { 27 | magic : uint8_t; [@len 16] 28 | (* major version, all later fields may change if this does *) 29 | version : uint32_t; 30 | compat_flags : uint32_t; 31 | (* refuse to mount if unknown incompat_flags are set *) 32 | incompat_flags : uint32_t; 33 | block_size : uint32_t; 34 | key_size : uint8_t; 35 | first_block_written : uint64_t; 36 | logical_size : uint64_t; 37 | (* FSID is UUID-sized (128 bits) *) 38 | fsid : uint8_t; [@len 16] 39 | reserved : uint8_t; [@len 443] 40 | crc : uint32_t; 41 | } 42 | [@@little_endian] 43 | ``` 44 | 45 | The focus is on managing compatibility. 46 | This is written once at filesystem creation and never edited. 47 | 48 | The magic string must be "MIRAGE KVFS \xf0\x9f\x90\xaa". 49 | 50 | The major version must be 1. 51 | 52 | Compat flags is currently empty, but may be added to without the 53 | current implementation refusing to mount. 54 | 55 | Incompat flags must currently contain the following, tracking 56 | evolutions of the data layout: 57 | - sb_incompat_rdepth; nodes now track their rdepth (which 58 | is their height, starting with leaves at 0) 59 | - sb_incompat_fsid; all blocks now repeat the fsid to 60 | reduce risks of mixing two different filesystems or 61 | of parsing foreign or uninitialized data at the block 62 | level 63 | - sb_incompat_value_count; nodes now mark the end of the value 64 | data area by keeping a count of values, instead of relying 65 | on the previous redzone mechanism 66 | 67 | They may also contain the following optional flag: 68 | - sb_incompat_tombstones; this affects semantics but not layout 69 | 70 | Adding anything else to the incompat flags will prevent 71 | the current implementation from mounting. 72 | This is to prevent reading or writing newer formats that 73 | are not compatible. 74 | 75 | In the future, an sb_incompat_linear flag is considered for 76 | indicating a linear (as opposed to circular and bisectable) 77 | layout. 78 | 79 | The block size defines how large blocks are and how to map 80 | logical addresses (used for child pointers, from blocks to 81 | other blocks) to physical addresses. 82 | 83 | First block written points to the first block ever written 84 | (generally an empty root), and is used to guide the bisection 85 | process that finds the newest root. 86 | 87 | Logical size says how large the filesystem is. Resizing is not 88 | supported in the current, circular layout. 89 | The underlying device may grow, but the filesystem won't access 90 | beyond its original logical size. 91 | 92 | FSID is meant to uniquely identify a filesystem, and initialized 93 | to cryptographically random bytes. 94 | 95 | Reserved data is currently initialised to zero, but ignored when 96 | mounting so that new fields aren't necessarily introducing 97 | incompatible changes. 98 | 99 | The CRC controls the first 512 bytes. The first block may be larger than 100 | the superblock; the extra padding behaves like reserved data, currently 101 | initialised to zero but won't break mounting. 102 | 103 | The block size must be a multiple of the IO size. 104 | The IO size must match the page size which is the unit 105 | for direct IO, on platforms that require direct IO. 106 | The IO size must be a multiple of the sector size, 107 | the size at which writes are atomic, which must be a 108 | multiple of 512. 109 | 110 | ## Node blocks 111 | 112 | There are two types of nodes: root and child. 113 | A leaf is a child that doesn't have children; 114 | there is no longer a special type marker or a specific layout for leaves. 115 | 116 | The focus is on compacity and the ability to grow logged data and child data 117 | independently. 118 | 119 | ``` 120 | type%cstruct anynode_hdr = { 121 | nodetype : uint8_t; 122 | generation : uint64_t; 123 | fsid : uint8_t; [@len 16] 124 | value_count : uint32_t; 125 | } 126 | [@@little_endian] 127 | 128 | type%cstruct rootnode_hdr = { 129 | (* nodetype = 1 *) 130 | nodetype : uint8_t; 131 | (* will this wrap? there's no uint128_t. Nah, flash will wear out first. *) 132 | generation : uint64_t; 133 | fsid : uint8_t; [@len 16] 134 | value_count : uint32_t; 135 | depth : uint32_t; 136 | } 137 | [@@little_endian] 138 | 139 | (* Contents: logged data, and child node links *) 140 | (* All node types end with a CRC *) 141 | (* rootnode_hdr 142 | * logged data: (key, datalen, data)*, grow from the left end towards the right 143 | * 144 | * child links: (key, logical offset)*, grow from the right end towards the left 145 | * crc *) 146 | 147 | type%cstruct childnode_hdr = { 148 | (* nodetype = 2 *) 149 | nodetype : uint8_t; 150 | generation : uint64_t; 151 | fsid : uint8_t; [@len 16] 152 | value_count : uint32_t; 153 | } 154 | [@@little_endian] 155 | 156 | (* Contents: logged data, and child node links *) 157 | (* Layout: see above *) 158 | ``` 159 | 160 | All nodes start with a node type, a generation number, 161 | a fsid identifying the filesystem, and a count of inline values. 162 | 163 | The generation number uniquely identifies a block and its contents 164 | on disk. When the content changes, a new block is written at 165 | another location with a new, greater generation number. 166 | Children are written before the parents that reference them. 167 | When a node has children, their generation number is strictly 168 | lower. This prevents loops. 169 | 170 | All nodes end with a CRC (CRC32C) controlling the whole block. 171 | 172 | Root nodes (nodetype: 1) are tree roots. 173 | 174 | Child nodes have just the basic, generic header (nodetype, generation). 175 | Root nodes also store their height (currently misnamed depth); this is 176 | enough to compute the height (called rdepth in the code) of all nodes, 177 | as well as ensure that all leaves are at depth zero. 178 | 179 | Node content is made of two packed lists, one that grows towards higher 180 | addresses and contains logged data, one that grows towards lower addresses 181 | from just before the CRC and contains child data. The latter is empty in 182 | leaf nodes. 183 | 184 | Logged data is made of contiguous logged items. An item is a key followed 185 | by a data size and the data itself (forming a length-prefixed, Pascal-style string). 186 | 187 | Child data is made of contiguous child links. A child link is a key followed 188 | by the on-disk location of the child. All-zeroes is not a valid representation 189 | of a childlink, so the child data area ends either when running into 190 | logged data, or when a run of zeroes is found when trying to load a childlink. 191 | -------------------------------------------------------------------------------- /doc/proposed/git.md: -------------------------------------------------------------------------------- 1 | # Git design (DRAFT) 2 | 3 | ``` 4 | module type KEY = sig 5 | type t 6 | end 7 | 8 | module type AO_CONTAINER = sig 9 | type t 10 | type handle = t * KEY.t 11 | 12 | val exists : handle -> bool 13 | val get : handle -> Cstruct.t 14 | val set : handle -> Cstruct.t -> unit 15 | end 16 | 17 | module type RW_CONTAINER = sig 18 | include AO_CONTAINER 19 | 20 | val delete : handle -> () 21 | (* move is atomic *) 22 | val move : handle -> KEY.t -> () 23 | val list : () -> KEY.t list 24 | end 25 | 26 | module type DELAYED_CONTAINER = sig 27 | include AO_CONTAINER 28 | type delayed_handle 29 | 30 | val open_ao : () -> delayed_handle 31 | val append : delayed_handle -> Cstruct.t -> () 32 | val close : delayed_handle -> handle 33 | end 34 | 35 | module type HANDLE = sig 36 | type ref_handle = RW_CONTAINER.handle 37 | type object_handle = DELAYED_CONTAINER.handle 38 | type object_delayed_handle = DELAYED_CONTAINER.delayed_handle 39 | type pack_delayed_handle = DELAYED_CONTAINER.delayed_handle 40 | 41 | val ref : string -> ref_handle 42 | val object : hash -> object_handle 43 | val new_object : () -> object_delayed_handle 44 | val new_pack : () -> pack_delayed_handle 45 | (* commit is atomic *) 46 | val commit : () -> () 47 | end 48 | 49 | ``` 50 | 51 | The design doesn't include a scratch space as previous. 52 | Instead, it features delayed objects, which are not named yet but can be appended to. 53 | This is used when writing packfiles. 54 | To implement delayed objects, the chunking layer is extended. 55 | 56 | GC is not implemented currently. 57 | To add it, we need a graph walker that copies objects recursively, 58 | and a function that switches the filesystem between two partitions. 59 | 60 | The object and packfile containers may perform autocommit to flush data to disk 61 | when necessary. This will not commit any incomplete delayed objects; partial 62 | data may be written, but the root of the object won't be. 63 | Closing a delayed object will write a Merkle tree indexing it. 64 | The tree is built in memory by the chunking layer, but writing it is delayed 65 | to avoid unnecessary churn. 66 | 67 | -------------------------------------------------------------------------------- /doc/proposed/linear-layout.md: -------------------------------------------------------------------------------- 1 | # Linear layout 2 | 3 | This is a modification of the original circular layout. 4 | The goal is to enable growth of the backing device, 5 | making Wodan more convenient to use when the size of the 6 | data isn't known in advance. 7 | 8 | ## Changes to the layout 9 | 10 | Instead of allocating from a free space map, blocks are always 11 | allocated after the previously allocated space. 12 | 13 | When a block is replaced, once everything has been flushed and a 14 | barrier issued, the previous position of the block is discarded 15 | from the backing device. 16 | For performance reasons, this can be deferred. 17 | 18 | ## Changes to backing device commands 19 | 20 | There are two new commands (relative to what the circular layout uses) 21 | which mirage-block has to support: 22 | - discard, which will send a trim if the backing device is a block 23 | device, or a FALLOC_FL_PUNCH_HOLE / F_PUNCHHOLE if the backing 24 | device is a file on a Unix filesystem. 25 | - grow, which will require extra space from the backing device. 26 | 27 | Growing is already supported through `resize` (though it will likely 28 | require extra support so that LVM or such can know to provide extra 29 | blocks). 30 | Discard currently isn't, although there is a pull request: 31 | https://github.com/mirage/mirage-block-unix/pull/86 32 | 33 | ## Changes to Wodan commands 34 | 35 | A new command is introduced to trim freed blocks. 36 | This is user-triggered because it introduces latency. 37 | 38 | ## Changes to data structures 39 | 40 | Instead of tracking a free space map to allocate from, 41 | we track the size of the allocated space. 42 | 43 | We also track recently freed blocks so that they can be trimmed 44 | in a batch operation. Instead of using a bit vector (that 45 | can't grow), we use a HashMap or similar. 46 | 47 | ## Changes to the mount operation 48 | 49 | The newest root is found by scanning from the end of the device. 50 | This is instead of bisecting the device for the highest generation 51 | number. 52 | 53 | ## Growth and initialisation 54 | 55 | Depending on the backend, growing the device will either provide 56 | zero-initialised data (regular file backend) or uninitialised data 57 | (LVM, although this needs to be confirmed). 58 | We will assume zero-initialised data for now. 59 | If we have to deal with uninitialised data, we'll have two options: 60 | discarding the new data (which will have a performance impact), 61 | and extending the format to carry uuids on every node. 62 | The latter change would be useful on its own for making filesystem 63 | initialisation more fool-proof. 64 | 65 | -------------------------------------------------------------------------------- /doc/references.md: -------------------------------------------------------------------------------- 1 | 2 | # References 3 | 4 | [ICFP 2017 paper](https://g2p.github.io/research/wodan.pdf) explaining the design choices 5 | 6 | [ICFP 2017 presentation](https://g2p.github.io/research/wodan-slides.pdf), 7 | with visuals illustrating Bε trees 8 | -------------------------------------------------------------------------------- /doc/scope.md: -------------------------------------------------------------------------------- 1 | 2 | # Design targets 3 | 4 | This document describes a flash friendly, functional, safe and flexible 5 | filesystem library. 6 | 7 | 8 | 9 | ## Flash friendly and flash optimised 10 | 11 | The primary target of this filesystem is a flash translation layer. 12 | A secondary target is hybrid devices layered using a FTL (bcache and 13 | bcachefs included). 14 | 15 | Whenever possible, we pick a design that performs well on both raw flash and 16 | SSDs. For example, having a large block size means that the FTL's log is 17 | largely bypassed (thanks to the switch/merge optimisation). 18 | 19 | However, we take advantage of the FTL by assuming that it handles bad blocks. 20 | Neither is rewriting old blocks to prevent decay handled in the filesystem 21 | layer. Support for bad blocks and refreshing old blocks could be added 22 | (preventing decay is easy in the current design) but this is not a primary 23 | goal. 24 | 25 | The filesystem uses a block size that must be a multiple of the erase block 26 | size of the underlying flash (between 256k and 4M), and, ideally, the exact 27 | same size. 28 | Using a multiple guarantees that there is no write amplification and that the 29 | FTL's garbage collection can perform well. 30 | Using the exact same block size guarantees that writes aren't amplified at the 31 | filesystem level when nodes are split or when the library user does periodic 32 | checkpointing in order to get data durability. 33 | Larger block sizes (up to the cluster block size, around 16M) may be 34 | advantageous in order to take full advantage of the FTL's internal parallelism, 35 | however this is only useful at very high throughput and periodic checkpointing 36 | should not be used in those cases. 37 | 38 | Another characteristic that makes the filesystem flash-friendly is that writes 39 | are evenly distributed over the device. The only exception is the superblock, 40 | which is the first block, and is written to exactly once. The first write is 41 | to a random location, and every write after that is sequential. Once writes 42 | wrap around to used blocks, they skip over them. 43 | 44 | Resizing is not supported because it would interfere with the mount-time 45 | operation of locating the root block (which needs monotonic generation 46 | numbers for root nodes), or alternatively require large scale copying and 47 | rewriting. 48 | 49 | Thin provisioning may be supported in the future, with a garbage collection 50 | feature that periodically batches and discards blocks that are not in use 51 | (which also improves the performance of the FTL). 52 | 53 | The flip side of being flash friendly is that the filesystem can be optimised 54 | to take advantage of the performance characteristics of flash, such as fast 55 | random read access. Tree nodes are not required to be grouped according to 56 | access patterns. 57 | 58 | References 59 | 60 | * http://codecapsule.com/2014/02/12/coding-for-ssds-part-6-a-summary-what-every-programmer-should-know-about-solid-state-drives/ 61 | * https://www.usenix.org/system/files/conference/inflow14/inflow14-yang.pdf 62 | 63 | ## Functional 64 | 65 | On disk, the filesystem provides a functional key value map. 66 | 67 | The main advantage of being functional is that this is flash-friendly: there 68 | are no in-place rewrites. 69 | 70 | We use hitchhiker trees, which minimise the write amplification functional 71 | updates would cause by batching changes close to the root. 72 | 73 | While there may be multiple roots referring to a subtree on disk, for 74 | the live filesystem, only one of them is valid at any point. This is 75 | single ownership. It simplifies tracking whether a block on the disk is 76 | in use: once a block is written on disk, its previous instance can be 77 | re-used. 78 | 79 | With single ownership, the data structures in memory don't need to be 80 | functionally updated. We lose snapshot support, but this can be provided 81 | by Irmin. 82 | 83 | Mounting the filesystem provides a tree_id -> root map. 84 | 85 | Most operations: read key, write key, search key interval, flush are done on a root. 86 | 87 | ## Consistent 88 | 89 | The filesystem is such that loss of the backing device at any point will 90 | keep its contents in a consistent state. 91 | 92 | To prevent torn writes and corruption at the backing device level, every block 93 | of data is written with a valid CRC32C. 94 | 95 | To prevent out-of-order writes, a write barrier is issued before every write 96 | of a root block on devices that support it, so that the contents referenced 97 | by the root block are always available if the root block is. 98 | 99 | On file-backed devices, barriers are harder, though [not 100 | impossible](https://lwn.net/Articles/667788/ "see discussion"). Having 101 | journaled data makes this unnecessary, at a performance cost. 102 | 103 | ## Integrity validated 104 | 105 | The filesystem is checked at mount time. 106 | 107 | This guarantees that the filesystem checker code is maintained and matches 108 | every implemented feature. 109 | 110 | It also provides an opportunity to build in-memory data structures to help 111 | with filesystem access, particularly write access and garbage collection. 112 | 113 | Those data structures may later be serialised, in a way that doesn't increase 114 | the io bandwidth unreasonably and allows for faster, unverified mounts, but 115 | this is not a primary goal. Those unverified mounts will help support large 116 | filesystems and particularly hybrid devices. 117 | 118 | A possible help with barrier-less writes to the filesystem would be locating 119 | the newest root block that passes filesystem checks. When an inconsistency is 120 | detected, the search for a valid root block could continue immediately before 121 | the newest block with an inconsistency. Assuming the window for in-flight data 122 | isn't too large, the newest valid root block should still be fairly recent. 123 | 124 | Corruption of a rarely-updated leaf node (bitrot) cannot be corrected in such a way. 125 | Having filesystem checks at mount time gives early warning that backups or a 126 | higher-level redundancy mechanism should be used, increasing the chances that 127 | the data may be recovered. 128 | 129 | ## Domain specific 130 | 131 | The filesystem can be tailored for the target domain. 132 | 133 | It provides a key->value map, within some constraints. 134 | 135 | The filesystem has a fixed key size that is chosen by the user. 136 | This allows a better fit for the target domain. For example, 137 | the key size can be large to allow perfect/cryptographic hashing. 138 | Or, the key size can be much smaller, and the filesystem may be 139 | used as a hash table with open addressing. The user must then 140 | check for collisions before inserting and must implement 141 | collision handling such as robin hood hashing. 142 | 143 | The block size is also chosen by the user (taking into account FTL 144 | characteristics). 145 | 146 | The value size is bounded, the limit is such that a key value pair must 147 | fit into a single block after leaf overhead is taken into account. 148 | Large values won't pack well into leaf nodes, so values should all be 149 | either small or close to the maximum allowed. Large values will also 150 | force frequent leaf insertions, and performance will be closer to btree 151 | characteristics rather than fractal/hitchhiker tree characteristics. 152 | 153 | Layering a generic posix-ish filesystem over this might be left as an exercice 154 | for the library user. This filesystem is meant to be a good, efficient fit for 155 | domain-specific storage, and genericity is not a design goal at this level. 156 | 157 | ## Tunable performance 158 | 159 | Like the data layout, performance characteristics are user controlled. 160 | 161 | A root node will be written every time its in-memory representation fills up. 162 | Since that may take a while, the user may implement regular checkpoint 163 | intervals so that the on-flash data isn't stale. More frequent checkpointing 164 | will cause write amplification, but not enough to overwhelm or wear out the 165 | flash (which would otherwise be idle). Flushing without checkpointing (no FUA 166 | or fdatasync) is also an option. 167 | 168 | Write order (ascending or descending logical addresses) could also be chosen 169 | at filesystem creation time. Descending addresses may allow for more 170 | sequential checking in a bcache scenario. 171 | 172 | ## An Irmin backend 173 | 174 | The filesystem can be used as an Irmin backend. 175 | 176 | The layer immediately above it should be irmin-chunk, so that values are of 177 | bounded size. Irmin-chunk might be extended to do a compression pass. It 178 | could also be extended to provide deduplication by using content-defined 179 | chunking. 180 | 181 | At a minimum, this means providing an implementation of the AO_MAKER_RAW and 182 | LINK_MAKER signatures. 183 | 184 | ## Other considerations 185 | 186 | Tiering, parallelism (both of which involve splitting allocations into multiple 187 | pools) could conceivably be added to the existing design, but aren't design 188 | goals at the moment. FTLs already take advantage of internal parallelism and 189 | doing the same in another layer would simply fragment the write patterns. 190 | 191 | Redundancy (raid and other uptime preserving mechanisms) is not a design goal, 192 | and should be handled at a higher or lower level. 193 | -------------------------------------------------------------------------------- /doc/semantics.md: -------------------------------------------------------------------------------- 1 | # Semantics 2 | 3 | Wodan provides a persistent store containing ordered mappings. 4 | 5 | ## Persistence 6 | 7 | Updates affect the in-memory view of the store. 8 | They are not persisted until a flush is explicitly requested. 9 | 10 | ## Generations 11 | 12 | When flushing, a generation number is returned. 13 | Generations grow at every flush. 14 | 15 | ## Keys 16 | 17 | Keys are fixed-size byte sequences. 18 | 19 | Keys can be accessed in lexicographical order, with amenities such as 20 | range searches. 21 | 22 | ## Mappings 23 | 24 | Key-value mappings are mutable, and later updates shadow previous 25 | writes. 26 | 27 | ## Values 28 | 29 | Values are byte sequences of bounded size. 30 | 31 | ### Tombstones 32 | 33 | Values are generally treated as opaque. 34 | 35 | An exception is if tombstone support is enabled (at filesystem creation 36 | time); mapping to the empty value is then treated as absence of the 37 | mapping. 38 | 39 | Since tombstone semantics persist across mounts, when tombstones reach a 40 | leaf, they can be removed entirely. 41 | 42 | This allows tombstones to be used to provide an operation that deletes 43 | mappings. The caller will have to ensure that empty values don't become 44 | ambiguous. Some encodings never produce empty values, but when 45 | arbitrary data needs to be handled, a one-byte prefix is a good 46 | solution. 47 | 48 | In the future, upsert semantics could be added by using the first byte 49 | as a tag byte. Operations like appending would then be possible. 50 | -------------------------------------------------------------------------------- /doc/wodan-for-mirage.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Wodan: persistence for Mirage 6 | 7 | 20 | 21 | 22 | 357 | 359 | 362 | 368 | 369 | 370 | 371 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.3) 2 | (name wodan) 3 | (implicit_transitive_deps false) 4 | -------------------------------------------------------------------------------- /examples/solo5-irmin/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let stack = generic_stackv4 default_network 4 | 5 | (* set ~tls to false to get a plain-http server *) 6 | let http_srv = http_server (conduit_direct ~tls:false stack) 7 | 8 | let http_port = 9 | let doc = Key.Arg.info ~doc:"Listening HTTP port." ["http"] in 10 | Key.(create "http_port" Arg.(opt int 8080 doc)) 11 | 12 | let main = 13 | let packages = 14 | [ 15 | package "uri"; 16 | package "wodan-irmin"; 17 | package ~sublibs:["ocaml"] "checkseum"; 18 | ] 19 | in 20 | let keys = List.map Key.abstract [http_port] in 21 | foreign ~packages ~keys "Dispatch.HTTP" 22 | (time @-> pclock @-> http @-> block @-> job) 23 | 24 | let img = block_of_file "disk.img" 25 | 26 | let () = 27 | register "http-irmin" 28 | [main $ default_time $ default_posix_clock $ http_srv $ img] 29 | -------------------------------------------------------------------------------- /examples/solo5-irmin/dispatch.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Mirage_types_lwt 3 | 4 | module type HTTP = Cohttp_lwt.S.Server 5 | (** Common signature for http and https. *) 6 | 7 | (* Logging *) 8 | let http_src = Logs.Src.create "http" ~doc:"HTTP server" 9 | 10 | module Http_log = (val Logs.src_log http_src : Logs.LOG) 11 | 12 | module BlockCon = struct 13 | (* from mirage-block-solo5 *) 14 | include Block 15 | 16 | let discard _ _ _ = Lwt.return (Ok ()) 17 | end 18 | 19 | module DB = 20 | Wodan_irmin.DB_BUILDER (BlockCon) (Wodan_irmin.StandardSuperblockParams) 21 | module Wodan_Git_KV = Wodan_irmin.KV_git (DB) 22 | 23 | module Dispatch (S : HTTP) = struct 24 | (* given a URI, find the appropriate file, 25 | * and construct a response with its contents. *) 26 | let rec dispatcher repo uri = 27 | match Uri.path uri with 28 | | "" | "/" -> dispatcher repo (Uri.with_path uri "README.md") 29 | | "/README.md" -> 30 | let headers = Cohttp.Header.init_with "Content-Type" "text/plain" in 31 | Wodan_Git_KV.Head.list repo >>= fun commits -> 32 | List.iter 33 | (fun k -> 34 | Logs.debug (fun m -> m "Head %a" Wodan_Git_KV.Commit.pp_hash k)) 35 | commits; 36 | Wodan_Git_KV.master repo >>= fun t -> 37 | Wodan_Git_KV.list t [] >>= fun li -> 38 | List.iter (fun (k, _v) -> Logs.debug (fun m -> m "List %s" k)) li; 39 | Lwt.catch 40 | (fun () -> Wodan_Git_KV.get t ["counter-wodan"; "README.md"]) 41 | (fun err -> 42 | Logs.debug (fun m -> m "L %a" Fmt.exn err); 43 | raise err) 44 | >>= fun contents -> 45 | let body = Repr.to_string Wodan_Git_KV.contents_t contents in 46 | S.respond_string ~status:`OK ~body ~headers () 47 | | str when str.[0] = '/' -> 48 | let headers = Cohttp.Header.init_with "Content-Type" "text/plain" in 49 | let head = String.sub str 1 (pred (String.length str)) in 50 | let head = Repr.of_string Wodan_Git_KV.Commit.Hash.t head in 51 | let head = 52 | match head with 53 | | Error _ -> assert false 54 | | Ok x -> x 55 | in 56 | Wodan_Git_KV.Commit.of_hash repo head >>= fun commit -> 57 | let commit = 58 | match commit with 59 | | None -> assert false 60 | | Some x -> x 61 | in 62 | Wodan_Git_KV.of_commit commit >>= fun t -> 63 | Wodan_Git_KV.get t ["README.md"] >>= fun t -> 64 | let body = Repr.to_string Wodan_Git_KV.contents_t t in 65 | S.respond_string ~status:`OK ~body ~headers () 66 | | _ -> S.respond_not_found () 67 | 68 | let serve dispatch = 69 | let callback (_, cid) request _body = 70 | let uri = Cohttp.Request.uri request in 71 | let cid = Cohttp.Connection.to_string cid in 72 | Http_log.info (fun f -> f "[%s] serving %s." cid (Uri.to_string uri)); 73 | dispatch uri 74 | in 75 | let conn_closed (_, cid) = 76 | let cid = Cohttp.Connection.to_string cid in 77 | Http_log.info (fun f -> f "[%s] closing" cid) 78 | in 79 | S.make ~conn_closed ~callback () 80 | end 81 | 82 | module HTTP 83 | (Time : Mirage_types_lwt.TIME) 84 | (Pclock : Mirage_types.PCLOCK) 85 | (Http : HTTP) 86 | (B : BLOCK) = 87 | struct 88 | module D = Dispatch (Http) 89 | 90 | let start _time _clock http block = 91 | let http_port = Key_gen.http_port () in 92 | let tcp = `TCP http_port in 93 | let store_conf = 94 | Wodan_irmin.config ~path:"../git-import.img" ~create:false () 95 | in 96 | let http = 97 | Http_log.info (fun f -> f "listening on %d/TCP" http_port); 98 | Wodan_Git_KV.Repo.v store_conf >>= fun repo -> 99 | Http_log.info (fun f -> f "repo ready"); 100 | http tcp (D.serve (D.dispatcher repo)) 101 | in 102 | Lwt.join [http] 103 | end 104 | -------------------------------------------------------------------------------- /examples/solo5-server/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let stack = generic_stackv4 default_network 4 | 5 | (* set ~tls to false to get a plain-http server *) 6 | let http_srv = http_server (conduit_direct ~tls:false stack) 7 | 8 | let http_port = 9 | let doc = Key.Arg.info ~doc:"Listening HTTP port." ["http"] in 10 | Key.(create "http_port" Arg.(opt int 8080 doc)) 11 | 12 | let main = 13 | let packages = 14 | [ 15 | package "uri"; 16 | package "wodan"; 17 | package "hex"; 18 | package ~sublibs:["ocaml"] "checkseum"; 19 | ] 20 | in 21 | let keys = List.map Key.abstract [http_port] in 22 | foreign ~packages ~keys "Dispatch.HTTP" 23 | (time @-> pclock @-> http @-> block @-> job) 24 | 25 | let img = block_of_file "disk.img" 26 | 27 | let () = 28 | register "http-server" 29 | [main $ default_time $ default_posix_clock $ http_srv $ img] 30 | -------------------------------------------------------------------------------- /examples/solo5-server/dispatch.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Mirage_types_lwt 3 | 4 | module type HTTP = Cohttp_lwt.S.Server 5 | (** Common signature for http and https. *) 6 | 7 | (* Logging *) 8 | let http_src = Logs.Src.create "http" ~doc:"HTTP server" 9 | 10 | module Http_log = (val Logs.src_log http_src : Logs.LOG) 11 | 12 | module Dispatch (Store : Wodan.S) (S : HTTP) = struct 13 | let failf fmt = Fmt.kstrf Lwt.fail_with fmt 14 | 15 | let key = Store.key_of_string "12345678901234567890" 16 | 17 | let next_camel store = 18 | Store.lookup store key >>= function 19 | | Some counter -> 20 | let c = Int64.of_string (Store.string_of_value counter) in 21 | let c = Int64.succ c in 22 | Store.insert store key (Store.value_of_string (Int64.to_string c)) 23 | >>= fun () -> Lwt.return c 24 | | None -> 25 | Store.insert store key (Store.value_of_string "1") >>= fun () -> 26 | Lwt.return 1L 27 | 28 | (* given a URI, find the appropriate file, 29 | * and construct a response with its contents. *) 30 | let rec dispatcher store uri = 31 | match Uri.path uri with 32 | | "" | "/" -> dispatcher store (Uri.with_path uri "index.html") 33 | | "/index.html" -> 34 | let headers = Cohttp.Header.init_with "Content-Type" "text/html" in 35 | next_camel store >>= fun counter -> 36 | let body = 37 | Fmt.strf 38 | {html| 39 | 40 | 
 41 |                      ,,__
 42 |            ..  ..   / o._)                   .---.
 43 |           /--'/--\  \-'||        .----.    .'     '.
 44 |          /        \_/ / |      .'      '..'         '-.
 45 |        .'\  \__\  __.'.'     .'          ì-._
 46 |          )\ |  )\ |      _.'
 47 |         // \\ // \\
 48 |        ||_  \\|_  \\_
 49 |    mrf '--' '--'' '--'
 50 | 
 51 |        %Ld camels served!
 52 |
53 | 54 | |html} 55 | counter 56 | in 57 | S.respond_string ~status:`OK ~body ~headers () 58 | | str when str.[0] = '/' -> ( 59 | let headers = Cohttp.Header.init_with "Content-Type" "text/plain" in 60 | let head = String.sub str 1 (pred (String.length str)) in 61 | let head = Hex.to_string (`Hex head) in 62 | let head = Store.key_of_string head in 63 | Store.lookup store head >>= function 64 | | None -> assert false 65 | | Some x -> 66 | let x = Store.string_of_value x in 67 | S.respond_string ~status:`OK ~body:x ~headers () 68 | | _ -> S.respond_not_found ()) 69 | 70 | let serve dispatch = 71 | let callback (_, cid) request _body = 72 | let uri = Cohttp.Request.uri request in 73 | let cid = Cohttp.Connection.to_string cid in 74 | Http_log.info (fun f -> f "[%s] serving %s." cid (Uri.to_string uri)); 75 | dispatch uri 76 | in 77 | let conn_closed (_, cid) = 78 | let cid = Cohttp.Connection.to_string cid in 79 | Http_log.info (fun f -> f "[%s] closing" cid) 80 | in 81 | S.make ~conn_closed ~callback () 82 | end 83 | 84 | module HTTP 85 | (Time : Mirage_types_lwt.TIME) 86 | (Pclock : Mirage_types.PCLOCK) 87 | (Http : HTTP) 88 | (B : BLOCK) = 89 | struct 90 | module B = Wodan.BlockCompat (B) 91 | module Store = Wodan.Make (B) (Wodan.StandardSuperblockParams) 92 | module D = Dispatch (Store) (Http) 93 | 94 | let rec periodic_flush store = 95 | Time.sleep_ns 30_000_000_000L >>= fun () -> 96 | Store.flush store >>= fun _gen -> periodic_flush store 97 | 98 | let start _time _clock http block = 99 | let http_port = Key_gen.http_port () in 100 | let tcp = `TCP http_port in 101 | let http = 102 | Http_log.info (fun f -> f "listening on %d/TCP" http_port); 103 | Store.prepare_io Wodan.OpenExistingDevice block 104 | Wodan.standard_mount_options 105 | >>= fun (store, _) -> 106 | Lwt.async (fun () -> periodic_flush store); 107 | Http_log.info (fun f -> f "store done"); 108 | http tcp (D.serve (D.dispatcher store)) 109 | in 110 | Lwt.join [http] 111 | end 112 | -------------------------------------------------------------------------------- /examples/solo5-unikernel/README.md: -------------------------------------------------------------------------------- 1 | 2 | git clone https://github.com/g2p/wodan 3 | 4 | in wodan/: 5 | 6 | opam pin add -k path wodan.dev . 7 | opam pin add -k path wodan-unix.dev . 8 | 9 | edit $(opam config var prefix)/lib/wodan/META and: 10 | add checkseum.ocaml below checkseum 11 | 12 | to build the solo5 hvt unikernel: 13 | 14 | Add the following pins: 15 | 16 | opam pin add mirage-solo5.dev git+https://github.com/mato/mirage-solo5#fixes-for-wodan 17 | opam pin add mirage-block-solo5.dev git+https://github.com/mato/mirage-block-solo5#fixes-for-wodan 18 | 19 | Then: 20 | 21 | mirage configure -t hvt --http=80 22 | mirage build 23 | 24 | to run: 25 | 26 | (once) 27 | 28 | ip tuntap add tap100 mode tap 29 | ip addr add 10.0.0.1/24 dev tap100 30 | ip link set dev tap100 up 31 | 32 | (once to format image) 33 | 34 | rm disk.img; touch disk.img ; fallocate -z -l $((256*1024*3)) disk.img 35 | wodanc format disk.img; echo $? 36 | 37 | ./solo5-hvt --net=tap100 --disk=disk.img ./http.hvt --logs=wodan:debug 38 | -------------------------------------------------------------------------------- /examples/solo5-unikernel/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let stack = generic_stackv4 default_network 4 | 5 | (* set ~tls to false to get a plain-http server *) 6 | let http_srv = http_server (conduit_direct ~tls:false stack) 7 | 8 | let http_port = 9 | let doc = Key.Arg.info ~doc:"Listening HTTP port." ["http"] in 10 | Key.(create "http_port" Arg.(opt int 8080 doc)) 11 | 12 | let main = 13 | let packages = 14 | [package "uri"; package "wodan"; package ~sublibs:["ocaml"] "checkseum"] 15 | in 16 | let keys = List.map Key.abstract [http_port] in 17 | foreign ~packages ~keys "Dispatch.HTTP" 18 | (time @-> pclock @-> http @-> block @-> job) 19 | 20 | let img = block_of_file "disk.img" 21 | 22 | let () = 23 | register "http" [main $ default_time $ default_posix_clock $ http_srv $ img] 24 | -------------------------------------------------------------------------------- /examples/solo5-unikernel/dispatch.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Mirage_types_lwt 3 | 4 | module type HTTP = Cohttp_lwt.S.Server 5 | (** Common signature for http and https. *) 6 | 7 | (* Logging *) 8 | let http_src = Logs.Src.create "http" ~doc:"HTTP server" 9 | 10 | module Http_log = (val Logs.src_log http_src : Logs.LOG) 11 | 12 | module Dispatch (Store : Wodan.S) (S : HTTP) = struct 13 | let failf fmt = Fmt.kstrf Lwt.fail_with fmt 14 | 15 | let key = Store.key_of_string "12345678901234567890" 16 | 17 | let next_camel store = 18 | Store.lookup store key >>= function 19 | | Some counter -> 20 | let c = Int64.of_string (Store.string_of_value counter) in 21 | let c = Int64.succ c in 22 | Store.insert store key (Store.value_of_string (Int64.to_string c)) 23 | >>= fun () -> Lwt.return c 24 | | None -> 25 | Store.insert store key (Store.value_of_string "1") >>= fun () -> 26 | Lwt.return 1L 27 | 28 | (* given a URI, find the appropriate file, 29 | * and construct a response with its contents. *) 30 | let rec dispatcher store uri = 31 | match Uri.path uri with 32 | | "" | "/" -> dispatcher store (Uri.with_path uri "index.html") 33 | | "/index.html" -> 34 | let headers = Cohttp.Header.init_with "Content-Type" "text/html" in 35 | next_camel store >>= fun counter -> 36 | let body = 37 | Fmt.strf 38 | {html| 39 | 40 | 
 41 |                      ,,__
 42 |            ..  ..   / o._)                   .---.
 43 |           /--'/--\  \-'||        .----.    .'     '.
 44 |          /        \_/ / |      .'      '..'         '-.
 45 |        .'\  \__\  __.'.'     .'          ì-._
 46 |          )\ |  )\ |      _.'
 47 |         // \\ // \\
 48 |        ||_  \\|_  \\_
 49 |    mrf '--' '--'' '--'
 50 | 
 51 |        %Ld camels served!
 52 |
53 | 54 | |html} 55 | counter 56 | in 57 | S.respond_string ~status:`OK ~body ~headers () 58 | | _ -> S.respond_not_found () 59 | 60 | let serve dispatch = 61 | let callback (_, cid) request _body = 62 | let uri = Cohttp.Request.uri request in 63 | let cid = Cohttp.Connection.to_string cid in 64 | Http_log.info (fun f -> f "[%s] serving %s." cid (Uri.to_string uri)); 65 | dispatch uri 66 | in 67 | let conn_closed (_, cid) = 68 | let cid = Cohttp.Connection.to_string cid in 69 | Http_log.info (fun f -> f "[%s] closing" cid) 70 | in 71 | S.make ~conn_closed ~callback () 72 | end 73 | 74 | module HTTP 75 | (Time : Mirage_types_lwt.TIME) 76 | (Pclock : Mirage_types.PCLOCK) 77 | (Http : HTTP) 78 | (B : BLOCK) = 79 | struct 80 | module B = Wodan.BlockCompat (B) 81 | module Store = Wodan.Make (B) (Wodan.StandardSuperblockParams) 82 | module D = Dispatch (Store) (Http) 83 | 84 | let rec periodic_flush store = 85 | Time.sleep_ns 30_000_000_000L >>= fun () -> 86 | Store.flush store >>= fun _gen -> periodic_flush store 87 | 88 | let start _time _clock http block = 89 | let http_port = Key_gen.http_port () in 90 | let tcp = `TCP http_port in 91 | let http = 92 | Http_log.info (fun f -> f "listening on %d/TCP" http_port); 93 | Store.prepare_io Wodan.OpenExistingDevice block 94 | Wodan.standard_mount_options 95 | >>= fun (store, _) -> 96 | Lwt.async (fun () -> periodic_flush store); 97 | Http_log.info (fun f -> f "store done"); 98 | http tcp (D.serve (D.dispatcher store)) 99 | in 100 | Lwt.join [http] 101 | end 102 | -------------------------------------------------------------------------------- /src/wodan-irmin/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name wodan_irmin_cli) 3 | (modules wodan_irmin_cli) 4 | (public_name wodan-irmin) 5 | (preprocess 6 | (pps lwt_ppx)) 7 | (package wodan-irmin) 8 | (libraries wodan-irmin wodan irmin io-page-unix mirage-block-unix 9 | mirage-block-ramdisk nocrypto.lwt irmin-unix)) 10 | 11 | (executable 12 | (name wodan_git_import) 13 | (modules wodan_git_import) 14 | (public_name wodan-git-import) 15 | (preprocess 16 | (pps lwt_ppx)) 17 | (package wodan-irmin) 18 | (libraries wodan-irmin wodan irmin io-page-unix mirage-block-unix 19 | mirage-block-ramdisk nocrypto.lwt irmin-unix irmin-git logs lwt.unix)) 20 | -------------------------------------------------------------------------------- /src/wodan-irmin/bin/wodan_git_import.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright 2017-2019 Gabriel de Perthuis *) 3 | (* *) 4 | (* Permission to use, copy, modify, and/or 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 OR *) 14 | (* IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 15 | (* *) 16 | (********************************************************************************) 17 | 18 | module Wodan_DB = 19 | Wodan_irmin.DB_BUILDER 20 | (struct 21 | include Block 22 | 23 | let connect name = Block.connect name 24 | end) 25 | (Wodan_irmin.StandardSuperblockParams) 26 | 27 | module Wodan_nongit_S = 28 | Wodan_irmin.KV_chunked (Wodan_DB) (Irmin.Hash.SHA1) (Irmin.Contents.String) 29 | module Wodan_git_S = Wodan_irmin.KV_git_sha1 (Wodan_DB) 30 | module Wodan_S = Wodan_git_S 31 | 32 | let wodan_config = Wodan_irmin.config ~path:"git-import.img" ~create:true () 33 | 34 | module Git_S = Irmin_unix.Git.FS.KV (Irmin.Contents.String) 35 | 36 | (*let git_config = Irmin_git.config (Sys.getcwd ())*) 37 | (* Use a repo that doesn't have submodules *) 38 | let git_config = Irmin_git.config Sys.argv.(1) 39 | 40 | module Wodan_sync = Irmin.Sync (Wodan_S) 41 | 42 | module StrHash = Hashtbl.Make (struct 43 | include String 44 | 45 | let hash = Hashtbl.hash 46 | end) 47 | 48 | let run () = 49 | let%lwt () = Nocrypto_entropy_lwt.initialize () in 50 | Logs.info (fun m -> m "Loading Wodan repo"); 51 | let%lwt wodan_repo = Wodan_S.Repo.v wodan_config in 52 | Logs.info (fun m -> m "Loading Git repo"); 53 | let%lwt git_repo = Git_S.Repo.v git_config in 54 | Logs.info (fun m -> m "Loading Git master"); 55 | let%lwt git_branch = Git_S.of_branch git_repo Sys.argv.(2) in 56 | Logs.info (fun m -> m "Converting Git to a remote"); 57 | let remote = Irmin.remote_store (module Git_S) git_branch in 58 | Logs.info (fun m -> m "Loading Wodan master"); 59 | let%lwt wodan_master = Wodan_S.master wodan_repo in 60 | Logs.info (fun m -> m "Fetching from Git into Wodan"); 61 | let%lwt head_commit = Wodan_sync.fetch_exn wodan_master remote in 62 | match head_commit with 63 | | `Head commit -> 64 | let%lwt () = Wodan_S.Head.set wodan_master commit in 65 | let%lwt wodan_raw = Wodan_S.DB.v wodan_config in 66 | let%lwt _gen = Wodan_S.DB.flush wodan_raw in 67 | Lwt.return_unit 68 | | `Empty -> Lwt.return_unit 69 | 70 | let () = 71 | Logs.set_reporter (Logs.format_reporter ()); 72 | Logs.set_level (Some Logs.Info); 73 | Logs.info (fun m -> m "Pwd %s" (Sys.getcwd ())); 74 | Lwt_main.run (run ()) 75 | -------------------------------------------------------------------------------- /src/wodan-irmin/bin/wodan_irmin_cli.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright 2017-2019 Gabriel de Perthuis *) 3 | (* *) 4 | (* Permission to use, copy, modify, and/or 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 OR *) 14 | (* IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 15 | (* *) 16 | (********************************************************************************) 17 | 18 | open Irmin_unix 19 | 20 | module RamBlockCon = struct 21 | include Ramdisk 22 | 23 | let connect name = Ramdisk.connect ~name 24 | 25 | let discard _ _ _ = Lwt.return (Ok ()) 26 | end 27 | 28 | module DB_ram = 29 | Wodan_irmin.DB_BUILDER (RamBlockCon) (Wodan_irmin.StandardSuperblockParams) 30 | 31 | module FileBlockCon = struct 32 | include Block 33 | 34 | let connect name = Block.connect name 35 | end 36 | 37 | module DB_fs = 38 | Wodan_irmin.DB_BUILDER (FileBlockCon) (Wodan_irmin.StandardSuperblockParams) 39 | 40 | let _ = 41 | Resolver.Store.add "wodan-mem" 42 | (Resolver.Store.Variable_hash 43 | (fun hash contents -> 44 | Resolver.Store.v ?remote:None 45 | (module Wodan_irmin.KV (DB_ram) ((val hash)) ((val contents)) 46 | : Irmin.S))); 47 | Resolver.Store.add "wodan" ~default:true 48 | (Resolver.Store.Variable_hash 49 | (fun hash contents -> 50 | Resolver.Store.v ?remote:None 51 | (module Wodan_irmin.KV (DB_fs) ((val hash)) ((val contents)) 52 | : Irmin.S))) 53 | 54 | let () = Cli.(run ~default commands) 55 | -------------------------------------------------------------------------------- /src/wodan-irmin/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name wodan_irmin) 3 | (public_name wodan-irmin) 4 | (flags :standard -g) 5 | (ocamlopt_flags :standard -g -O3) 6 | (preprocess 7 | (pps lwt_ppx)) 8 | (libraries wodan irmin irmin-chunk irmin-git logs mirage-block fmt repr)) 9 | -------------------------------------------------------------------------------- /src/wodan-irmin/wodan_irmin.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright 2017-2019 Gabriel de Perthuis *) 3 | (* *) 4 | (* Permission to use, copy, modify, and/or 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 OR *) 14 | (* IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 15 | (* *) 16 | (********************************************************************************) 17 | 18 | open Lwt.Infix 19 | 20 | let src = Logs.Src.create "irmin.wodan" 21 | 22 | module Log = (val Logs.src_log src : Logs.LOG) 23 | 24 | let standard_mount_options = Wodan.standard_mount_options 25 | 26 | module StandardSuperblockParams : Wodan.SUPERBLOCK_PARAMS = struct 27 | include Wodan.StandardSuperblockParams 28 | 29 | let optional_flags = Wodan.OptionalSuperblockFlags.tombstones_enabled 30 | end 31 | 32 | module Conf = struct 33 | let path = 34 | Irmin.Private.Conf.key ~doc:"Path to filesystem image" "path" 35 | Irmin.Private.Conf.string "wodan.img" 36 | 37 | let create = 38 | Irmin.Private.Conf.key ~doc:"Whether to create a fresh filesystem" "create" 39 | Irmin.Private.Conf.bool false 40 | 41 | let cache_size = 42 | Irmin.Private.Conf.key ~doc:"How many cache items to keep in the LRU" 43 | "cache_size" Irmin.Private.Conf.int 1024 44 | 45 | let fast_scan = 46 | Irmin.Private.Conf.key ~doc:"Whether to mount without scanning the leaves" 47 | "fast_scan" Irmin.Private.Conf.bool true 48 | 49 | let list_key = 50 | Irmin.Private.Conf.key 51 | ~doc:"A special key used to store metadata for listing other keys" 52 | "list_key" Irmin.Private.Conf.string "meta:keys-list:00000" 53 | 54 | let autoflush = 55 | Irmin.Private.Conf.key 56 | ~doc: 57 | "Whether to flush automatically when necessary for writes to go \ 58 | through" 59 | "autoflush" Irmin.Private.Conf.bool false 60 | end 61 | 62 | let config ?(config = Irmin.Private.Conf.empty) ~path ~create ?cache_size 63 | ?fast_scan ?list_key ?autoflush () = 64 | let module C = Irmin.Private.Conf in 65 | let cache_size = 66 | match cache_size with 67 | | None -> C.default Conf.cache_size 68 | | Some cache_size -> cache_size 69 | in 70 | let fast_scan = 71 | match fast_scan with 72 | | None -> C.default Conf.fast_scan 73 | | Some fast_scan -> fast_scan 74 | in 75 | let list_key = 76 | match list_key with 77 | | None -> C.default Conf.list_key 78 | | Some list_key -> list_key 79 | in 80 | let autoflush = 81 | match autoflush with 82 | | None -> C.default Conf.autoflush 83 | | Some autoflush -> autoflush 84 | in 85 | C.add 86 | (C.add 87 | (C.add 88 | (C.add 89 | (C.add 90 | (C.add config Conf.autoflush autoflush) 91 | Conf.list_key list_key) 92 | Conf.fast_scan fast_scan) 93 | Conf.cache_size cache_size) 94 | Conf.path path) 95 | Conf.create create 96 | 97 | module type BLOCK_CON = sig 98 | include Mirage_block.S 99 | 100 | (* XXX mirage-block-unix and mirage-block-ramdisk don't have the 101 | * exact same signature *) 102 | (*val connect : name:string -> t io*) 103 | val connect : string -> t Lwt.t 104 | end 105 | 106 | module type DB = sig 107 | module Stor : Wodan.S 108 | 109 | type t 110 | 111 | val db_root : t -> Stor.root 112 | 113 | val may_autoflush : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 114 | 115 | val v : Irmin.config -> t Lwt.t 116 | 117 | val flush : t -> int64 Lwt.t 118 | end 119 | 120 | module Cache (X : sig 121 | type config 122 | 123 | type t 124 | 125 | type key 126 | 127 | val v : config -> t Lwt.t 128 | 129 | val key : config -> key 130 | end) : sig 131 | val read : X.config -> (X.config * X.t) Lwt.t 132 | end = struct 133 | type key = X.key 134 | 135 | module Key = struct 136 | type t = key 137 | 138 | let hash = Hashtbl.hash 139 | 140 | let equal = ( = ) 141 | end 142 | 143 | (* Weak in the values *) 144 | module ValueTab = Hashtbl.Make (Key) 145 | 146 | module Value = struct 147 | type t = X.t 148 | 149 | let hash = Hashtbl.hash 150 | 151 | let equal = ( == ) 152 | end 153 | 154 | (* Weak in the keys *) 155 | module ConfigTab = Ephemeron.K1.Make (Value) 156 | 157 | let value_cache = ValueTab.create 10 158 | 159 | let config_cache = ConfigTab.create 10 160 | 161 | let find config = 162 | Gc.full_major (); 163 | let key = X.key config in 164 | try 165 | let weak_t = ValueTab.find value_cache key in 166 | let opt_t = Weak.get weak_t 0 in 167 | match opt_t with 168 | | None -> None 169 | | Some t -> 170 | let config' = ConfigTab.find config_cache t in 171 | Some (config', t) 172 | with Not_found -> None 173 | 174 | let add config t = 175 | let weak_t = Weak.create 1 in 176 | let key = X.key config in 177 | Weak.set weak_t 0 (Some t); 178 | Gc.finalise (fun _ -> ValueTab.remove value_cache key) t; 179 | ValueTab.add value_cache key weak_t; 180 | ConfigTab.add config_cache t config 181 | 182 | let read config = 183 | match find config with 184 | | Some v -> Lwt.return v 185 | | None -> 186 | X.v config >|= fun t -> 187 | add config t; 188 | (config, t) 189 | end 190 | 191 | module DB_BUILDER : functor (_ : BLOCK_CON) (_ : Wodan.SUPERBLOCK_PARAMS) -> 192 | DB = 193 | functor 194 | (B : BLOCK_CON) 195 | (P : Wodan.SUPERBLOCK_PARAMS) 196 | -> 197 | struct 198 | module Stor = Wodan.Make (B) (P) 199 | 200 | type t = { 201 | root : Stor.root; 202 | autoflush : bool; 203 | } 204 | 205 | let db_root db = db.root 206 | 207 | let do_autoflush root op = 208 | try%lwt op () 209 | with Wodan.NeedsFlush -> ( 210 | Stor.flush root >>= function 211 | | _gen -> op ()) 212 | 213 | let may_autoflush db op = 214 | if db.autoflush then do_autoflush db.root op else op () 215 | 216 | let make ~path ~create ~mount_options ~autoflush = 217 | B.connect path >>= function 218 | | disk -> ( 219 | B.get_info disk >>= function 220 | | info -> 221 | let open_arg = 222 | if create then 223 | Wodan.FormatEmptyDevice 224 | { 225 | logical_size = 226 | Int64.( 227 | div 228 | (mul info.size_sectors (of_int info.sector_size)) 229 | (of_int P.block_size)); 230 | preroots_interval = Wodan.default_preroots_interval; 231 | } 232 | else Wodan.OpenExistingDevice 233 | in 234 | Stor.prepare_io open_arg disk mount_options 235 | >>= fun (root, _gen) -> Lwt.return {root; autoflush}) 236 | 237 | module Cache = Cache (struct 238 | type nonrec t = t 239 | 240 | type config = string * bool * Wodan.mount_options * bool 241 | 242 | type key = string 243 | 244 | let key (path, _, _, _) = path 245 | 246 | let v (path, create, mount_options, autoflush) = 247 | make ~path ~create ~mount_options ~autoflush 248 | end) 249 | 250 | (* Must support tombstones 251 | 252 | This is important for AW_BUILDER-derived stores. 253 | Since we have a Cache module allowing filesystems to be shared 254 | between multiple Irmin instances, we must enable tombstones in 255 | all cases, and extend values by one byte everywhere. *) 256 | let () = 257 | assert ( 258 | P.optional_flags = Wodan.OptionalSuperblockFlags.tombstones_enabled) 259 | 260 | let v config = 261 | let module C = Irmin.Private.Conf in 262 | let path = C.get config Conf.path in 263 | let create = C.get config Conf.create in 264 | let cache_size = C.get config Conf.cache_size in 265 | let fast_scan = C.get config Conf.fast_scan in 266 | let autoflush = C.get config Conf.autoflush in 267 | let mount_options = 268 | {standard_mount_options with fast_scan; cache_size} 269 | in 270 | Cache.read (path, create, mount_options, autoflush) 271 | >|= fun ((_, create', mount_options', autoflush'), t) -> 272 | assert (create = create'); 273 | assert (mount_options = mount_options'); 274 | assert (autoflush = autoflush'); 275 | t 276 | 277 | let flush db = Stor.flush (db_root db) 278 | end 279 | 280 | module CA_BUILDER : functor (DB : DB) -> 281 | Irmin.CONTENT_ADDRESSABLE_STORE_MAKER = 282 | functor 283 | (DB : DB) 284 | (K : Irmin.Hash.S) 285 | (V : Repr.S) 286 | -> 287 | struct 288 | type 'a t = DB.t 289 | 290 | type key = K.t 291 | 292 | type value = V.t 293 | 294 | let () = assert (K.hash_size = DB.Stor.P.key_size) 295 | 296 | let ser_val = Repr.unstage (Repr.to_bin_string V.t) 297 | 298 | let deser_val = Repr.unstage (Repr.of_bin_string V.t) 299 | 300 | let ser_key = Repr.unstage (Repr.to_bin_string K.t) 301 | 302 | let val_to_inner va = 303 | let raw_v = ser_val va in 304 | let k = K.hash (fun f -> f raw_v) in 305 | let raw_k = ser_key k in 306 | (k, DB.Stor.key_of_string raw_k, DB.Stor.value_of_string ("C" ^ raw_v)) 307 | 308 | let val_of_inner_val va = 309 | let va1 = DB.Stor.string_of_value va in 310 | assert (va1.[0] = 'C'); 311 | let va2 = String.sub va1 1 (String.length va1 - 1) in 312 | Result.get_ok (deser_val va2) 313 | 314 | let find db k = 315 | Log.debug (fun l -> l "CA.find %a" (Repr.pp K.t) k); 316 | DB.Stor.lookup (DB.db_root db) (DB.Stor.key_of_string (ser_key k)) 317 | >>= function 318 | | None -> Lwt.return_none 319 | | Some v -> Lwt.return_some (val_of_inner_val v) 320 | 321 | let mem db k = 322 | Log.debug (fun l -> l "CA.mem %a" (Repr.pp K.t) k); 323 | DB.Stor.mem (DB.db_root db) (DB.Stor.key_of_string (ser_key k)) 324 | 325 | let add db va = 326 | let k, ik, iv = val_to_inner va in 327 | Log.debug (fun m -> m "CA.add -> %a (%d)" (Repr.pp K.t) k K.hash_size); 328 | let root = DB.db_root db in 329 | DB.may_autoflush db (fun () -> DB.Stor.insert root ik iv) >>= function 330 | | () -> Lwt.return k 331 | 332 | let unsafe_add db k va = 333 | let raw_v = ser_val va in 334 | Log.debug (fun m -> 335 | m "CA.unsafe_add -> %a (%d)" (Repr.pp K.t) k K.hash_size); 336 | let raw_k = ser_key k in 337 | let root = DB.db_root db in 338 | DB.may_autoflush db (fun () -> 339 | DB.Stor.insert root 340 | (DB.Stor.key_of_string raw_k) 341 | (DB.Stor.value_of_string raw_v)) 342 | 343 | let v = DB.v 344 | 345 | let cast t = (t :> [ `Read | `Write ] t) 346 | 347 | let batch t f = f (cast t) 348 | 349 | let close _t = Lwt.return_unit 350 | 351 | (* Clear the store of references 352 | 353 | Arguably this doesn't make sense for a content-addressable store, 354 | especially as other stores build on it by storing their own layer 355 | of data in the same place. 356 | *) 357 | let clear _t = Lwt.fail (Failure "Not implemented") 358 | end 359 | 360 | module AO_BUILDER : functor (_ : DB) -> Irmin.APPEND_ONLY_STORE_MAKER = 361 | functor 362 | (DB : DB) 363 | (K : Repr.S) 364 | (V : Repr.S) 365 | -> 366 | struct 367 | type 'a t = DB.t 368 | 369 | type key = K.t 370 | 371 | type value = V.t 372 | 373 | let ser_val = Repr.unstage (Repr.to_bin_string V.t) 374 | 375 | let deser_val = Repr.unstage (Repr.of_bin_string V.t) 376 | 377 | let ser_key = Repr.unstage (Repr.to_bin_string K.t) 378 | 379 | let val_to_inner_val va = DB.Stor.value_of_string ("A" ^ ser_val va) 380 | 381 | let val_of_inner_val va = 382 | let va1 = DB.Stor.string_of_value va in 383 | assert (va1.[0] = 'A'); 384 | let va2 = String.sub va1 1 (String.length va1 - 1) in 385 | Result.get_ok (deser_val va2) 386 | 387 | let find db k = 388 | Log.debug (fun l -> l "AO.find %a" (Repr.pp K.t) k); 389 | DB.Stor.lookup (DB.db_root db) (DB.Stor.key_of_string (ser_key k)) 390 | >>= function 391 | | None -> Lwt.return_none 392 | | Some v -> Lwt.return_some (val_of_inner_val v) 393 | 394 | let mem db k = 395 | Log.debug (fun l -> l "AO.mem %a" (Repr.pp K.t) k); 396 | DB.Stor.mem (DB.db_root db) (DB.Stor.key_of_string (ser_key k)) 397 | 398 | let add db k va = 399 | let raw_k = ser_key k in 400 | let root = DB.db_root db in 401 | DB.may_autoflush db (fun () -> 402 | DB.Stor.insert root 403 | (DB.Stor.key_of_string raw_k) 404 | (val_to_inner_val va)) 405 | 406 | let v = DB.v 407 | 408 | let cast t = (t :> [ `Read | `Write ] t) 409 | 410 | let batch t f = f (cast t) 411 | 412 | let close _t = Lwt.return_unit 413 | 414 | (* Clear the store of references 415 | 416 | Arguably this doesn't make sense for an append-only store, 417 | especially as other stores build on it by storing their own layer 418 | of data in the same place. 419 | *) 420 | let clear _t = Lwt.fail (Failure "Not implemented") 421 | end 422 | 423 | module AW_BUILDER : functor (_ : DB) (_ : Irmin.Hash.S) -> 424 | Irmin.ATOMIC_WRITE_STORE_MAKER = 425 | functor 426 | (DB : DB) 427 | (H : Irmin.Hash.S) 428 | (K : Repr.S) 429 | (V : Repr.S) 430 | -> 431 | struct 432 | module BUILDER = DB 433 | module Stor = BUILDER.Stor 434 | module KeyHashtbl = Hashtbl.Make (Stor.Key) 435 | module W = Irmin.Private.Watch.Make (K) (V) 436 | module L = Irmin.Private.Lock.Make (K) 437 | 438 | type t = { 439 | nested : BUILDER.t; 440 | keydata : Stor.key KeyHashtbl.t; 441 | mutable magic_key : Stor.key; 442 | magic_key0 : Stor.key; 443 | watches : W.t; 444 | lock : L.t; 445 | } 446 | 447 | let db_root db = BUILDER.db_root db.nested 448 | 449 | let may_autoflush db = BUILDER.may_autoflush db.nested 450 | 451 | let () = assert (H.hash_size = Stor.P.key_size) 452 | 453 | type key = K.t 454 | 455 | type value = V.t 456 | 457 | let ser_hash = Repr.unstage (Repr.to_bin_string H.t) 458 | 459 | let ser_key = Repr.unstage (Repr.to_bin_string K.t) 460 | 461 | let ser_val = Repr.unstage (Repr.to_bin_string V.t) 462 | 463 | let deser_key = Repr.unstage (Repr.of_bin_string K.t) 464 | 465 | let deser_val = Repr.unstage (Repr.of_bin_string V.t) 466 | 467 | (* The outside layer is Irmin, the inner layer is Wodan, here are some conversions *) 468 | let key_to_inner_key k = 469 | Stor.key_of_string (ser_hash (H.hash (fun f -> f (ser_key k)))) 470 | 471 | (* Prefix values so that we can use both tombstones and empty values 472 | 473 | Repr.to_bin_string can produce empty values, unlike some 474 | other Irmin serializers that encode length up-front *) 475 | let val_to_inner_val va = Stor.value_of_string ("V" ^ ser_val va) 476 | 477 | let key_to_inner_val k = Stor.value_of_string (ser_key k) 478 | 479 | let key_of_inner_val va = 480 | Result.get_ok (deser_key (Stor.string_of_value va)) 481 | 482 | let val_of_inner_val va = 483 | let va1 = Stor.string_of_value va in 484 | assert (va1.[0] = 'V'); 485 | let va2 = String.sub va1 1 (String.length va1 - 1) in 486 | Result.get_ok (deser_val va2) 487 | 488 | (* Convert a Wodan value to a Wodan key 489 | Used to traverse the linked list that lists all keys stored through the AW interface *) 490 | let inner_val_to_inner_key va = 491 | Stor.key_of_string 492 | (ser_hash (H.hash (fun f -> f (Stor.string_of_value va)))) 493 | 494 | let make ~list_key ~config = 495 | let%lwt db = BUILDER.v config in 496 | let root = BUILDER.db_root db in 497 | let magic_key = Bytes.make H.hash_size '\000' in 498 | Bytes.blit_string list_key 0 magic_key 0 (String.length list_key); 499 | let magic_key = Stor.key_of_string (Bytes.unsafe_to_string magic_key) in 500 | let db = 501 | { 502 | nested = db; 503 | keydata = KeyHashtbl.create 10; 504 | magic_key; 505 | magic_key0 = magic_key; 506 | watches = W.v (); 507 | lock = L.v (); 508 | } 509 | in 510 | (try%lwt 511 | while%lwt true do 512 | Stor.lookup root db.magic_key >>= function 513 | | None -> Lwt.fail Exit 514 | | Some va -> 515 | let ik = inner_val_to_inner_key va in 516 | KeyHashtbl.add db.keydata ik db.magic_key; 517 | db.magic_key <- Stor.next_key db.magic_key; 518 | Lwt.return_unit 519 | done 520 | with Exit -> Lwt.return_unit) 521 | >|= fun () -> db 522 | 523 | module Cache = Cache (struct 524 | type nonrec t = t 525 | 526 | type config = string * string * Irmin.Private.Conf.t 527 | 528 | type key = string 529 | 530 | let key (path, _, _) = path 531 | 532 | let v (_, list_key, config) = make ~list_key ~config 533 | end) 534 | 535 | let v config = 536 | let module C = Irmin.Private.Conf in 537 | let list_key = C.get config Conf.list_key in 538 | let path = C.get config Conf.path in 539 | Cache.read (path, list_key, config) >|= fun ((_, list_key', _), t) -> 540 | assert (list_key = list_key'); 541 | t 542 | 543 | let set_and_list db ik iv ikv = 544 | assert (not (Stor.is_tombstone iv)); 545 | (if not (KeyHashtbl.mem db.keydata ik) then ( 546 | KeyHashtbl.add db.keydata ik db.magic_key; 547 | may_autoflush db (fun () -> Stor.insert (db_root db) db.magic_key ikv) 548 | >>= fun () -> 549 | db.magic_key <- Stor.next_key db.magic_key; 550 | Lwt.return_unit) 551 | else Lwt.return_unit) 552 | >>= fun () -> may_autoflush db (fun () -> Stor.insert (db_root db) ik iv) 553 | 554 | let set db k va = 555 | Log.debug (fun m -> m "AW.set -> %a" (Repr.pp K.t) k); 556 | let ik = key_to_inner_key k in 557 | let iv = val_to_inner_val va in 558 | L.with_lock db.lock k (fun () -> 559 | set_and_list db ik iv (key_to_inner_val k)) 560 | >>= fun () -> W.notify db.watches k (Some va) 561 | 562 | type watch = W.watch 563 | 564 | let watch db = W.watch db.watches 565 | 566 | let watch_key db = W.watch_key db.watches 567 | 568 | let unwatch db = W.unwatch db.watches 569 | 570 | let opt_equal f x y = 571 | match (x, y) with 572 | | None, None -> true 573 | | Some x, Some y -> f x y 574 | | _ -> false 575 | 576 | (* XXX With autoflush, this might flush some data without finishing the insert *) 577 | let test_and_set db k ~test ~set = 578 | Log.debug (fun m -> m "AW.test_and_set -> %a" (Repr.pp K.t) k); 579 | let ik = key_to_inner_key k in 580 | let root = db_root db in 581 | let test = 582 | match test with 583 | | Some va -> Some (val_to_inner_val va) 584 | | None -> None 585 | in 586 | L.with_lock db.lock k (fun () -> 587 | Stor.lookup root ik >>= function 588 | | v0 -> 589 | if opt_equal Stor.value_equal v0 test then 590 | (match set with 591 | | Some va -> 592 | set_and_list db ik (val_to_inner_val va) 593 | (key_to_inner_val k) 594 | | None -> 595 | may_autoflush db (fun () -> 596 | Stor.insert root ik (Stor.value_of_string ""))) 597 | >>= fun () -> Lwt.return_true 598 | else Lwt.return_false) 599 | >>= fun updated -> 600 | (if updated then W.notify db.watches k set else Lwt.return_unit) 601 | >>= fun () -> Lwt.return updated 602 | 603 | let tombstone = Stor.value_of_string "" 604 | 605 | let remove db k = 606 | Log.debug (fun l -> l "AW.remove %a" (Repr.pp K.t) k); 607 | let ik = key_to_inner_key k in 608 | let root = db_root db in 609 | L.with_lock db.lock k (fun () -> 610 | may_autoflush db (fun () -> Stor.insert root ik tombstone)) 611 | >>= fun () -> W.notify db.watches k None 612 | 613 | let list db = 614 | Log.debug (fun l -> l "AW.list"); 615 | let root = db_root db in 616 | KeyHashtbl.fold 617 | (fun ik mk io -> 618 | io >>= function 619 | | l -> ( 620 | Stor.mem root ik >>= function 621 | | true -> ( 622 | Stor.lookup root mk >>= function 623 | | None -> Lwt.fail (Failure "Missing metadata key") 624 | | Some iv -> Lwt.return (key_of_inner_val iv :: l)) 625 | | false -> Lwt.return l)) 626 | db.keydata (Lwt.return []) 627 | 628 | let find db k = 629 | Log.debug (fun l -> l "AW.find %a" (Repr.pp K.t) k); 630 | Stor.lookup (db_root db) (key_to_inner_key k) >>= function 631 | | None -> Lwt.return_none 632 | | Some va -> Lwt.return_some (val_of_inner_val va) 633 | 634 | let mem db k = Stor.mem (db_root db) (key_to_inner_key k) 635 | 636 | let close _t = Lwt.return_unit 637 | 638 | (* Clear the store of references 639 | 640 | Non-reference data is kept. 641 | *) 642 | let clear db = 643 | let root = db_root db in 644 | KeyHashtbl.fold 645 | (fun _ik mk io -> 646 | io >>= function 647 | | () -> Stor.insert root mk tombstone) 648 | db.keydata Lwt.return_unit 649 | >>= fun () -> 650 | KeyHashtbl.clear db.keydata; 651 | db.magic_key <- db.magic_key0; 652 | Lwt.return_unit 653 | end 654 | 655 | module Make 656 | (DB : DB) 657 | (M : Irmin.Metadata.S) 658 | (C : Irmin.Contents.S) 659 | (P : Irmin.Path.S) 660 | (B : Irmin.Branch.S) 661 | (H : Irmin.Hash.S) = 662 | struct 663 | module DB = DB 664 | module CA = CA_BUILDER (DB) 665 | module AW = AW_BUILDER (DB) (H) 666 | include Irmin.Make (CA) (AW) (M) (C) (P) (B) (H) 667 | 668 | let flush = DB.flush 669 | end 670 | 671 | (* XXX Stable chunking or not? *) 672 | module Make_chunked 673 | (DB : DB) 674 | (M : Irmin.Metadata.S) 675 | (C : Irmin.Contents.S) 676 | (P : Irmin.Path.S) 677 | (B : Irmin.Branch.S) 678 | (H : Irmin.Hash.S) = 679 | struct 680 | module CA = Irmin_chunk.Content_addressable (AO_BUILDER (DB)) 681 | module DB = DB 682 | module AW = AW_BUILDER (DB) (H) 683 | include Irmin.Make (CA) (AW) (M) (C) (P) (B) (H) 684 | 685 | let flush = DB.flush 686 | end 687 | 688 | module KV (DB : DB) (H : Irmin.Hash.S) (C : Irmin.Contents.S) = 689 | Make (DB) (Irmin.Metadata.None) (C) (Irmin.Path.String_list) 690 | (Irmin.Branch.String) 691 | (H) 692 | 693 | module KV_git (DB : DB) (H : Irmin.Hash.S) = struct 694 | module DB = DB 695 | 696 | (*module AO = AO_BUILDER(DB)*) 697 | (*module AO = Irmin_chunk.AO(AO_BUILDER(DB))*) 698 | module CA = Irmin_chunk.Content_addressable (AO_BUILDER (DB)) 699 | module AW = AW_BUILDER (DB) (H) 700 | include Irmin_git.Generic_KV (CA) (AW) (Irmin.Contents.String) 701 | 702 | let flush = DB.flush 703 | end 704 | 705 | module KV_git_sha1 (DB : DB) = KV_git (DB) (Irmin.Hash.SHA1) 706 | module KV_chunked (DB : DB) (H : Irmin.Hash.S) (C : Irmin.Contents.S) = 707 | Make_chunked (DB) (Irmin.Metadata.None) (C) (Irmin.Path.String_list) 708 | (Irmin.Branch.String) 709 | (H) 710 | -------------------------------------------------------------------------------- /src/wodan-irmin/wodan_irmin.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright 2017-2019 Gabriel de Perthuis *) 3 | (* *) 4 | (* Permission to use, copy, modify, and/or 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 OR *) 14 | (* IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 15 | (* *) 16 | (********************************************************************************) 17 | 18 | module Log : Logs.LOG 19 | 20 | val standard_mount_options : Wodan.mount_options 21 | 22 | module StandardSuperblockParams : Wodan.SUPERBLOCK_PARAMS 23 | (** Defaults for {!SUPERBLOCK_PARAMS} 24 | 25 | Unlike {!Wodan.SUPERBLOCK_PARAMS}, this has tombstones enabled *) 26 | 27 | module Conf : sig 28 | val path : string Irmin.Private.Conf.key 29 | 30 | val create : bool Irmin.Private.Conf.key 31 | 32 | val cache_size : int Irmin.Private.Conf.key 33 | 34 | val fast_scan : bool Irmin.Private.Conf.key 35 | 36 | val list_key : string Irmin.Private.Conf.key 37 | 38 | val autoflush : bool Irmin.Private.Conf.key 39 | end 40 | 41 | val config : 42 | ?config:Irmin.config -> 43 | path:string -> 44 | create:bool -> 45 | ?cache_size:int -> 46 | ?fast_scan:bool -> 47 | ?list_key:string -> 48 | ?autoflush:bool -> 49 | unit -> 50 | Irmin.config 51 | 52 | module type BLOCK_CON = sig 53 | include Mirage_block.S 54 | 55 | val connect : string -> t Lwt.t 56 | end 57 | 58 | module type DB = sig 59 | module Stor : Wodan.S 60 | 61 | type t 62 | 63 | val db_root : t -> Stor.root 64 | 65 | val may_autoflush : t -> (unit -> 'a Lwt.t) -> 'a Lwt.t 66 | 67 | val v : Irmin.config -> t Lwt.t 68 | 69 | val flush : t -> int64 Lwt.t 70 | end 71 | 72 | (** Builds a Wodan-backed database, that can be used to build higher-level 73 | Irmin interfaces *) 74 | module DB_BUILDER : functor (_ : BLOCK_CON) (_ : Wodan.SUPERBLOCK_PARAMS) -> DB 75 | 76 | (** Builds an {!Irmin.APPEND_ONLY_STORE}, storing key to value mappings *) 77 | module AO_BUILDER : functor (_ : DB) -> Irmin.APPEND_ONLY_STORE_MAKER 78 | 79 | (** Builds an {!Irmin.CONTENT_ADDRESSABLE_STORE}, storing values through stable 80 | hashing *) 81 | module CA_BUILDER : functor (_ : DB) -> Irmin.CONTENT_ADDRESSABLE_STORE_MAKER 82 | 83 | (** Builds an {!Irmin.ATOMIC_WRITE_STORE}, storing key to value mappings with 84 | extra features 85 | 86 | Extra features currently incude: atomicity and watches, listing all keys, 87 | deleting keys. *) 88 | module AW_BUILDER : functor (_ : DB) (_ : Irmin.Hash.S) -> 89 | Irmin.ATOMIC_WRITE_STORE_MAKER 90 | 91 | module Make 92 | (DB : DB) 93 | (M : Irmin.Metadata.S) 94 | (C : Irmin.Contents.S) 95 | (P : Irmin.Path.S) 96 | (B : Irmin.Branch.S) 97 | (H : Irmin.Hash.S) : sig 98 | module DB : DB 99 | 100 | include 101 | Irmin.S 102 | with type key = P.t 103 | and type step = P.step 104 | and type metadata = M.t 105 | and type contents = C.t 106 | and type branch = B.t 107 | and type hash = H.t 108 | 109 | val flush : DB.t -> int64 Lwt.t 110 | end 111 | 112 | module Make_chunked 113 | (DB : DB) 114 | (M : Irmin.Metadata.S) 115 | (C : Irmin.Contents.S) 116 | (P : Irmin.Path.S) 117 | (B : Irmin.Branch.S) 118 | (H : Irmin.Hash.S) : sig 119 | module DB : DB 120 | 121 | include 122 | Irmin.S 123 | with type key = P.t 124 | and type step = P.step 125 | and type metadata = M.t 126 | and type contents = C.t 127 | and type branch = B.t 128 | and type hash = H.t 129 | 130 | val flush : DB.t -> int64 Lwt.t 131 | end 132 | 133 | module KV (DB : DB) (H : Irmin.Hash.S) (C : Irmin.Contents.S) : sig 134 | module DB : DB 135 | 136 | include Irmin.KV with type contents = C.t and type hash = H.t 137 | 138 | val flush : DB.t -> int64 Lwt.t 139 | end 140 | 141 | module KV_git (DB : DB) (H : Irmin.Hash.S) : sig 142 | module DB : DB 143 | 144 | include Irmin.KV with type contents = Irmin.Contents.String.t 145 | 146 | val flush : DB.t -> int64 Lwt.t 147 | end 148 | 149 | module KV_git_sha1 (DB : DB) : sig 150 | module DB : DB 151 | 152 | include Irmin.KV with type contents = Irmin.Contents.String.t 153 | 154 | val flush : DB.t -> int64 Lwt.t 155 | end 156 | 157 | module KV_chunked (DB : DB) (H : Irmin.Hash.S) (C : Irmin.Contents.S) : sig 158 | module DB : DB 159 | 160 | include Irmin.KV with type contents = C.t 161 | 162 | val flush : DB.t -> int64 Lwt.t 163 | end 164 | -------------------------------------------------------------------------------- /src/wodan-unix/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name wodanc) 3 | (public_name wodanc) 4 | (flags :standard -g) 5 | (ocamlopt_flags :standard -g -O3) 6 | (package wodan-unix) 7 | (libraries base64 benchmark csv cmdliner wodan io-page-unix logs cstruct 8 | mirage-block mirage-block-unix mirage-block-ramdisk nocrypto.lwt 9 | afl-persistent lwt.unix) 10 | (preprocess 11 | (pps lwt_ppx))) 12 | -------------------------------------------------------------------------------- /src/wodan-unix/unikernel.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright 2017-2019 Gabriel de Perthuis *) 3 | (* *) 4 | (* Permission to use, copy, modify, and/or 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 OR *) 14 | (* IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 15 | (* *) 16 | (********************************************************************************) 17 | 18 | open Lwt.Infix 19 | open Mirage_block 20 | 21 | let unwrap_opt = function 22 | | None -> failwith "Expected Some" 23 | | Some x -> x 24 | 25 | module Client (B : Mirage_block.S) = struct 26 | let trim disk = 27 | Wodan.open_for_reading (module B) disk Wodan.standard_mount_options 28 | >>= function 29 | | Wodan.OPEN_RET ((module Stor), root, _gen) -> Stor.fstrim root 30 | 31 | let format disk ks bs = 32 | let module Stor = 33 | Wodan.Make 34 | (B) 35 | (struct 36 | include Wodan.StandardSuperblockParams 37 | 38 | let key_size = ks 39 | 40 | let block_size = bs 41 | end) 42 | in 43 | let%lwt info = B.get_info disk in 44 | let%lwt _root, _gen = 45 | Stor.prepare_io 46 | (Wodan.FormatEmptyDevice 47 | { 48 | logical_size = 49 | Int64.( 50 | div 51 | (mul info.size_sectors (of_int info.sector_size)) 52 | (of_int Stor.P.block_size)); 53 | preroots_interval = Wodan.default_preroots_interval; 54 | }) 55 | disk Wodan.standard_mount_options 56 | in 57 | Lwt.return_unit 58 | 59 | let restore disk = 60 | Wodan.open_for_reading (module B) disk Wodan.standard_mount_options 61 | >>= function 62 | | Wodan.OPEN_RET ((module Stor), root, _gen) -> 63 | let csv_in = Csv.of_channel ~separator:'\t' stdin in 64 | let compl = ref [] in 65 | Csv.iter 66 | ~f:(fun l -> 67 | match l with 68 | | [k; v] -> 69 | compl := 70 | (try%lwt 71 | Stor.insert root 72 | (Stor.key_of_string (Base64.decode_exn k)) 73 | (Stor.value_of_string (Base64.decode_exn v)) 74 | with Wodan.NeedsFlush -> 75 | let%lwt _gen = Stor.flush root in 76 | Lwt.return_unit) 77 | :: !compl 78 | | _ -> failwith "Bad CSV format") 79 | csv_in; 80 | Lwt.join !compl >>= fun () -> 81 | let%lwt _gen = Stor.flush root in 82 | Lwt.return_unit 83 | 84 | let dump disk = 85 | Wodan.open_for_reading (module B) disk Wodan.standard_mount_options 86 | >>= function 87 | | Wodan.OPEN_RET ((module Stor), root, _gen) -> 88 | let out_csv = Csv.to_channel ~separator:'\t' stdout in 89 | Stor.iter root (fun k v -> 90 | Csv.output_record out_csv 91 | [ 92 | Base64.encode_exn (Stor.string_of_key k); 93 | Base64.encode_exn (Stor.string_of_value v); 94 | ]) 95 | >>= fun () -> 96 | Csv.close_out out_csv; 97 | Lwt.return_unit 98 | 99 | let exercise disk block_size = 100 | let bs = 101 | match block_size with 102 | | None -> Wodan.StandardSuperblockParams.block_size 103 | | Some block_size -> block_size 104 | in 105 | let module Stor = 106 | Wodan.Make 107 | (B) 108 | (struct 109 | include Wodan.StandardSuperblockParams 110 | 111 | let block_size = bs 112 | end) 113 | in 114 | let ios = ref 0 in 115 | let time0 = ref 0. in 116 | let%lwt info = B.get_info disk in 117 | (*Logs.info (fun m -> 118 | m "Sectors %Ld %d" info.size_sectors info.sector_size);*) 119 | let%lwt rootval, _gen0 = 120 | Stor.prepare_io 121 | (Wodan.FormatEmptyDevice 122 | { 123 | logical_size = 124 | Int64.( 125 | div 126 | (mul info.size_sectors (of_int info.sector_size)) 127 | (of_int Stor.P.block_size)); 128 | preroots_interval = Wodan.default_preroots_interval; 129 | }) 130 | disk Wodan.standard_mount_options 131 | in 132 | (let root = ref rootval in 133 | let key = Stor.key_of_string "abcdefghijklmnopqrst" in 134 | let cval = Stor.value_of_string "sqnlnfdvulnqsvfjlllsvqoiuuoezr" in 135 | Stor.insert !root key cval >>= fun () -> 136 | Stor.flush !root >>= function 137 | | gen1 -> ( 138 | Stor.lookup !root key >>= function 139 | | cval1_opt -> ( 140 | let cval1 = unwrap_opt cval1_opt in 141 | (*Cstruct.hexdump cval1;*) 142 | assert ( 143 | Cstruct.equal 144 | (Stor.cstruct_of_value cval) 145 | (Stor.cstruct_of_value cval1)); 146 | let%lwt rootval, gen2 = 147 | Stor.prepare_io Wodan.OpenExistingDevice disk 148 | Wodan.standard_mount_options 149 | in 150 | root := rootval; 151 | Stor.lookup !root key >>= function 152 | | cval2_opt -> 153 | let cval2 = unwrap_opt cval2_opt in 154 | assert ( 155 | Cstruct.equal 156 | (Stor.cstruct_of_value cval) 157 | (Stor.cstruct_of_value cval2)); 158 | if gen1 <> gen2 then ( 159 | Logs.err (fun m -> m "Generation fail %Ld %Ld" gen1 gen2); 160 | assert false); 161 | time0 := Unix.gettimeofday (); 162 | let should_continue = ref true in 163 | while%lwt !should_continue do 164 | let key = Stor.key_of_cstruct (Nocrypto.Rng.generate 20) 165 | and cval = 166 | Stor.value_of_cstruct (Nocrypto.Rng.generate 40) 167 | in 168 | (try%lwt 169 | ios := succ !ios; 170 | Stor.insert !root key cval 171 | with 172 | | Wodan.NeedsFlush -> ( 173 | Logs.info (fun m -> m "Emergency flushing"); 174 | Stor.flush !root >>= function 175 | | _gen -> Stor.insert !root key cval) 176 | | Wodan.OutOfSpace -> 177 | Logs.info (fun m -> m "Final flush"); 178 | Stor.flush !root >|= ignore >>= fun () -> 179 | should_continue := false; 180 | Lwt.return_unit) 181 | >>= fun () -> 182 | if%lwt Lwt.return (Nocrypto.Rng.Int.gen 16384 = 0) then ( 183 | (* Infrequent re-opening *) 184 | Stor.flush !root >>= function 185 | | gen3 -> 186 | let%lwt rootval, gen4 = 187 | Stor.prepare_io Wodan.OpenExistingDevice disk 188 | Wodan.standard_mount_options 189 | in 190 | root := rootval; 191 | assert (gen3 = gen4); 192 | Lwt.return_unit) 193 | else 194 | if%lwt Lwt.return (false && Nocrypto.Rng.Int.gen 8192 = 0) 195 | then ( 196 | (* Infrequent flushing *) 197 | Stor.log_statistics !root; 198 | Stor.flush !root >|= ignore) 199 | done))) 200 | [%lwt.finally 201 | let time1 = Unix.gettimeofday () in 202 | let iops = float_of_int !ios /. (time1 -. !time0) in 203 | (*Stor.log_statistics root;*) 204 | Logs.info (fun m -> m "IOPS %f" iops); 205 | Lwt.return_unit] 206 | 207 | let bench0 count = 208 | (* Ignore original disk, build a ramdisk instead *) 209 | (* A tempfile would also work, to match the Rust version *) 210 | (* Constants matching Rust and the RocksDB benchmark suite *) 211 | (* Next line obscures the create function *) 212 | (*let module Ramdisk = Wodan.BlockCompat(Ramdisk) in*) 213 | let module Ramdisk = struct 214 | include Ramdisk 215 | 216 | let discard _ _ _ = Lwt.return (Ok ()) 217 | end in 218 | let module Stor = 219 | Wodan.Make 220 | (Ramdisk) 221 | (struct 222 | include Wodan.StandardSuperblockParams 223 | 224 | let key_size = 20 225 | 226 | let block_size = 256 * 1024 227 | end) 228 | in 229 | let value_size = 400 in 230 | let disk_size = 32 * 1024 * 1024 in 231 | let init () = 232 | let%lwt disk_res = 233 | Ramdisk.create ~name:"bench" 234 | ~size_sectors:Int64.(div (of_int disk_size) 512L) 235 | ~sector_size:512 236 | in 237 | let disk = Result.get_ok disk_res in 238 | let%lwt info = Ramdisk.get_info disk in 239 | Lwt.return (disk, info) 240 | in 241 | Nocrypto_entropy_unix.initialize (); 242 | let disk, info = Lwt_main.run (init ()) in 243 | let data = 244 | let rec gen count = 245 | if count = 0 then [] 246 | else 247 | ( Stor.key_of_cstruct (Nocrypto.Rng.generate Stor.P.key_size), 248 | Stor.value_of_string (String.make value_size '\x00') ) 249 | :: gen (pred count) 250 | in 251 | gen count 252 | in 253 | let iter () = 254 | let%lwt root, _gen = 255 | Stor.prepare_io 256 | (Wodan.FormatEmptyDevice 257 | { 258 | logical_size = 259 | Int64.( 260 | div 261 | (mul info.size_sectors (of_int info.sector_size)) 262 | (of_int Stor.P.block_size)); 263 | preroots_interval = Wodan.default_preroots_interval; 264 | }) 265 | disk Wodan.standard_mount_options 266 | in 267 | (* Sequential, otherwise expect bugs *) 268 | Lwt_list.iter_s (fun (k, v) -> Stor.insert root k v) data 269 | in 270 | let _samples = 271 | Benchmark.latency1 10L 272 | ~name:(Printf.sprintf "%d inserts" count) 273 | (fun () -> Lwt_main.run (iter ())) 274 | () 275 | in 276 | () 277 | 278 | let bench () = bench0 10_000 279 | 280 | (*bench0 30_000;*) 281 | 282 | let fuzz disk = 283 | Wodan.read_superblock_params 284 | (module B) 285 | disk 286 | {magic_crc = true; magic_crc_write = false} 287 | >>= function 288 | | sb_params -> 289 | let module Stor = Wodan.Make (B) ((val sb_params)) in 290 | let%lwt info = B.get_info disk in 291 | let logical_size = 292 | Int64.( 293 | to_int 294 | (div 295 | (mul info.size_sectors (of_int info.sector_size)) 296 | (of_int Stor.P.block_size))) 297 | in 298 | let cstr = Cstruct.create Stor.P.block_size in 299 | let%lwt _res = B.read disk 0L [cstr] in 300 | if%lwt 301 | Lwt.return 302 | (Wodan.Testing.cstruct_cond_reset 303 | (Cstruct.sub cstr 0 Wodan.sizeof_superblock)) 304 | then ( 305 | B.write disk 0L [cstr] >|= ignore >>= fun _ -> 306 | for%lwt i = 1 to logical_size - 1 do 307 | let doffset = Int64.(mul (of_int i) (of_int Stor.P.block_size)) in 308 | let%lwt _res = B.read disk doffset [cstr] in 309 | if%lwt Lwt.return (Wodan.Testing.cstruct_cond_reset cstr) then 310 | B.write disk doffset [cstr] >|= ignore 311 | done 312 | >>= fun _ -> 313 | let%lwt root, _rgen = 314 | Stor.prepare_io Wodan.OpenExistingDevice disk 315 | Wodan.standard_mount_options 316 | in 317 | let key = Stor.key_of_string "abcdefghijklmnopqrst" in 318 | let cval = Stor.value_of_string "sqnlnfdvulnqsvfjlllsvqoiuuoezr" in 319 | Stor.insert root key cval >>= fun () -> 320 | Stor.flush root >>= fun _gen -> 321 | let%lwt cval1 = Stor.lookup root key >|= unwrap_opt in 322 | assert ( 323 | Cstruct.equal 324 | (Stor.cstruct_of_value cval) 325 | (Stor.cstruct_of_value cval1)); 326 | let%lwt root, _rgen = 327 | Stor.prepare_io Wodan.OpenExistingDevice disk 328 | Wodan.standard_mount_options 329 | in 330 | let%lwt cval2 = Stor.lookup root key >|= unwrap_opt in 331 | assert ( 332 | Cstruct.equal 333 | (Stor.cstruct_of_value cval) 334 | (Stor.cstruct_of_value cval2)); 335 | Lwt.return_unit) 336 | end 337 | -------------------------------------------------------------------------------- /src/wodan-unix/wodanc.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright 2017-2019 Gabriel de Perthuis *) 3 | (* *) 4 | (* Permission to use, copy, modify, and/or 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 OR *) 14 | (* IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 15 | (* *) 16 | (********************************************************************************) 17 | 18 | open Lwt.Infix 19 | open Cmdliner 20 | 21 | (* Arg, Manpage, Term *) 22 | 23 | let _ = Printexc.record_backtrace true 24 | 25 | module Unikernel1 = Unikernel.Client (Block) 26 | 27 | let () = Logs.set_reporter (Logs.format_reporter ()) 28 | 29 | (*let () = Logs.set_level (Some Logs.Info)*) 30 | 31 | (* Implementations *) 32 | 33 | type copts = {disk : string} 34 | 35 | let dump copts _prefix = 36 | Lwt_main.run 37 | ( Block.connect copts.disk >>= fun bl -> 38 | Nocrypto_entropy_lwt.initialize () >>= fun _nc -> Unikernel1.dump bl ) 39 | 40 | let restore copts = 41 | Lwt_main.run 42 | ( Block.connect copts.disk >>= fun bl -> 43 | Nocrypto_entropy_lwt.initialize () >>= fun _nc -> Unikernel1.restore bl 44 | ) 45 | 46 | let format copts key_size block_size = 47 | Lwt_main.run 48 | ( Block.connect copts.disk >>= fun bl -> 49 | Nocrypto_entropy_lwt.initialize () >>= fun _nc -> 50 | Unikernel1.format bl key_size block_size ) 51 | 52 | let trim copts = 53 | Lwt_main.run 54 | ( Block.connect copts.disk >>= fun bl -> 55 | Nocrypto_entropy_lwt.initialize () >>= fun _nc -> 56 | Unikernel1.trim bl >|= ignore ) 57 | 58 | let exercise copts block_size = 59 | Lwt_main.run 60 | ( Block.connect copts.disk >>= fun bl -> 61 | Nocrypto_entropy_lwt.initialize () >>= fun _nc -> 62 | Unikernel1.exercise bl block_size >|= ignore ) 63 | 64 | let bench _copts = 65 | (* Unlike the other functions, don't run within Lwt 66 | Also ignore the disk in copts to use our own ramdisk *) 67 | Unikernel1.bench () 68 | 69 | let fuzz copts = 70 | (* Persistent mode disabled, results are not stable, 71 | maybe due to CRC munging. *) 72 | AflPersistent.run (fun () -> 73 | Lwt_main.run (Block.connect copts.disk >>= fun bl -> Unikernel1.fuzz bl)) 74 | 75 | let help _copts man_format cmds topic = 76 | match topic with 77 | | None -> `Help (`Pager, None) (* help about the program. *) 78 | | Some topic -> ( 79 | let topics = "topics" :: cmds in 80 | let conv, _ = Arg.enum (List.rev_map (fun s -> (s, s)) topics) in 81 | match conv topic with 82 | | `Error e -> `Error (false, e) 83 | | `Ok t when t = "topics" -> 84 | List.iter print_endline topics; 85 | `Ok () 86 | | `Ok t when List.mem t cmds -> `Help (man_format, Some t) 87 | | `Ok _t -> 88 | let page = ((topic, 7, "", "", ""), [`S topic; `P "Placeholder"]) in 89 | `Ok (Manpage.print man_format Format.std_formatter page)) 90 | 91 | (* Options common to all commands *) 92 | 93 | (* TODO: support ramdisks *) 94 | let copts disk = {disk} 95 | 96 | let copts_t = 97 | let docs = Manpage.s_common_options in 98 | let disk = 99 | let doc = "Disk to operate on." in 100 | Arg.(required & pos 0 (some string) None & info [] ~docv:"DISK" ~docs ~doc) 101 | in 102 | Term.(const copts $ disk) 103 | 104 | (* Commands *) 105 | 106 | let dump_cmd = 107 | let prefix = 108 | Arg.(value & pos 1 (some string) None & info [] ~docv:"PREFIX") 109 | in 110 | let doc = "dump filesystem to standard output" in 111 | let exits = Term.default_exits in 112 | let man = 113 | [ 114 | `S Manpage.s_description; 115 | `P 116 | "Dumps the current filesystem to standard output.\n\ 117 | \ Format is base64-encoded tab-separated values."; 118 | ] 119 | in 120 | ( Term.(const dump $ copts_t $ prefix), 121 | Term.info "dump" ~doc ~sdocs:Manpage.s_common_options ~exits ~man ) 122 | 123 | let restore_cmd = 124 | let doc = "load filesystem contents from standard input" in 125 | let exits = Term.default_exits in 126 | let man = 127 | [ 128 | `S Manpage.s_description; 129 | `P 130 | "Loads dump output from standard input, inserts it\n\ 131 | \ as filesystem contents."; 132 | ] 133 | in 134 | ( Term.(const restore $ copts_t), 135 | Term.info "restore" ~doc ~sdocs:Manpage.s_common_options ~exits ~man ) 136 | 137 | let format_cmd = 138 | let doc = "Use a key size of $(docv) bytes." in 139 | let key_size = 140 | Arg.( 141 | value 142 | & opt int Wodan.StandardSuperblockParams.key_size 143 | & info ["key-size"] ~docv:"BYTES" ~doc) 144 | in 145 | let doc = "Use a block size of $(docv) bytes." in 146 | let block_size = 147 | Arg.( 148 | value 149 | & opt int Wodan.StandardSuperblockParams.block_size 150 | & info ["block-size"] ~docv:"BYTES" ~doc) 151 | in 152 | let doc = "Format a zeroed filesystem" in 153 | let exits = Term.default_exits in 154 | let man = 155 | [ 156 | `S Manpage.s_description; 157 | `P "Format a filesystem that has been zeroed beforehand."; 158 | ] 159 | in 160 | ( Term.(const format $ copts_t $ key_size $ block_size), 161 | Term.info "format" ~doc ~sdocs:Manpage.s_common_options ~exits ~man ) 162 | 163 | let trim_cmd = 164 | let doc = "Trim an existing filesystem" in 165 | let exits = Term.default_exits in 166 | let man = 167 | [ 168 | `S Manpage.s_description; 169 | `P 170 | "Discard unused blocks from an existing filesystem.\n\ 171 | \ This scans the disk for in-use blocks and discards\n\ 172 | \ the rest."; 173 | ] 174 | in 175 | ( Term.(const trim $ copts_t), 176 | Term.info "trim" ~doc ~sdocs:Manpage.s_common_options ~exits ~man ) 177 | 178 | let exercise_cmd = 179 | let block_size = 180 | Arg.(value & pos 1 (some int) None & info [] ~docv:"block_size") 181 | in 182 | let doc = "Create a fresh filesystem, exercise and fill it" in 183 | let man = 184 | [ 185 | `S Manpage.s_description; 186 | `P 187 | "Create a fresh filesystem, exercise and fill it.\n\ 188 | \ This creates a filesystem, runs a few pre-defined operations\n\ 189 | \ and fills it with random data."; 190 | ] 191 | in 192 | (Term.(const exercise $ copts_t $ block_size), Term.info "exercise" ~doc ~man) 193 | 194 | let bench_cmd = 195 | let doc = "Run a standardised micro-benchmark" in 196 | let man = 197 | [ 198 | `S Manpage.s_description; 199 | `P "Run a micro-benchmark that does bulk insertions without flushing."; 200 | ] 201 | in 202 | (Term.(const bench $ copts_t), Term.info "bench" ~doc ~man) 203 | 204 | let fuzz_cmd = 205 | let doc = "Fuzz a filesystem" in 206 | let exits = Term.default_exits in 207 | let man = 208 | [ 209 | `S Manpage.s_description; 210 | `P "Runs a few operations on a fuzzer-generated filesystem."; 211 | ] 212 | in 213 | ( Term.(const fuzz $ copts_t), 214 | Term.info "fuzz" ~doc ~sdocs:Manpage.s_common_options ~exits ~man ) 215 | 216 | let help_cmd = 217 | let topic = 218 | let doc = "The topic to get help on. `topics' lists the topics." in 219 | Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) 220 | in 221 | let doc = "display help about wodanc and wodanc subcommands" in 222 | let man = 223 | [ 224 | `S Manpage.s_description; 225 | `P "Prints help about wodanc commands and other subjects..."; 226 | ] 227 | in 228 | ( Term.( 229 | ret (const help $ copts_t $ Arg.man_format $ Term.choice_names $ topic)), 230 | Term.info "help" ~doc ~exits:Term.default_exits ~man ) 231 | 232 | let default_cmd = 233 | let doc = "CLI for Wodan filesystems" in 234 | let sdocs = Manpage.s_common_options in 235 | let exits = Term.default_exits in 236 | ( Term.(ret (const (fun _ -> `Help (`Pager, None)) $ copts_t)), 237 | Term.info "wodanc" ~doc ~sdocs ~exits ) 238 | 239 | let cmds = 240 | [ 241 | restore_cmd; 242 | dump_cmd; 243 | format_cmd; 244 | trim_cmd; 245 | exercise_cmd; 246 | bench_cmd; 247 | fuzz_cmd; 248 | help_cmd; 249 | ] 250 | 251 | let () = Term.(exit (eval_choice default_cmd cmds)) 252 | -------------------------------------------------------------------------------- /src/wodan/bitv64.ml: -------------------------------------------------------------------------------- 1 | type t = Bitv.t 2 | 3 | let create size bit = 4 | if Int64.compare size (Int64.of_int max_int) > 0 then 5 | raise (Invalid_argument "Bitv64.create"); 6 | Bitv.create (Int64.to_int size) bit 7 | 8 | let set vec off bit = Bitv.set vec (Location.to_int off) bit 9 | 10 | let get vec off = Bitv.get vec (Location.to_int off) 11 | 12 | let length vec = Int64.of_int (Bitv.length vec) 13 | 14 | let iter = Bitv.iter 15 | 16 | let iteri f t = Bitv.iteri (fun i b -> f (Location.of_int i) b) t 17 | -------------------------------------------------------------------------------- /src/wodan/bitv64.mli: -------------------------------------------------------------------------------- 1 | (** Bitv64 is a wrapper around Bitv, for easier use with Location.t indexes and 2 | int64 sizes. *) 3 | 4 | type t 5 | (** The type for [Location.t] indexed [Bitv]s *) 6 | 7 | val create : int64 -> bool -> t 8 | (** [create n b] creates a new bit vector of length [n], initialized with [b]. 9 | [n] must be smaller than [max_int], otherwise raises Invalid_argument. *) 10 | 11 | val set : t -> Location.t -> bool -> unit 12 | (** [Bitv.set v n b] sets the [n]th bit of [v] to the value [b]. *) 13 | 14 | val get : t -> Location.t -> bool 15 | (** [Bitv.get v n] returns the [n]th bit of [v]. *) 16 | 17 | val length : t -> int64 18 | (** [length] returns the length of the given vector. *) 19 | 20 | val iter : (bool -> unit) -> t -> unit 21 | (** [iter f v] applies [f] to every element in [v]. *) 22 | 23 | val iteri : (Location.t -> bool -> unit) -> t -> unit 24 | (** [iteri] is like [iter], but applies f to the index of the element, as first 25 | argument, and to the element itself, as second argument. *) 26 | -------------------------------------------------------------------------------- /src/wodan/crc32c.ml: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright 2017-2019 Gabriel de Perthuis *) 3 | (* *) 4 | (* Permission to use, copy, modify, and/or 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 OR *) 14 | (* IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 15 | (* *) 16 | (********************************************************************************) 17 | 18 | (* Copyright (c) 2016-2017, Gabriel de Perthuis - ISC licensed *) 19 | 20 | let ( ~~~ ) = Int32.lognot 21 | 22 | (* XXX x64 only *) 23 | let optint_sign = Optint.of_int 0x8000_0000 24 | 25 | let optint_of_uint32 i = 26 | if i < 0l then Optint.(logor optint_sign (of_int32 (Int32.neg i))) 27 | else Optint.of_int32 i 28 | 29 | let optint_to_uint32 i = Optint.to_int32 i 30 | 31 | let cstruct ?(crc = 0l) cstr = 32 | optint_to_uint32 33 | (Checkseum.Crc32c.digest_bigstring (Cstruct.to_bigarray cstr) 0 34 | (Cstruct.length cstr) (optint_of_uint32 crc)) 35 | 36 | let cstruct_valid str = ~~~(cstruct str) = 0l 37 | 38 | (*$T cstruct_reset 39 | let cstr = Cstruct.of_string "123456789...." in begin cstruct_reset cstr; cstruct_valid cstr end 40 | *) 41 | let cstruct_reset str = 42 | let sublen = Cstruct.length str - 4 in 43 | let crc = cstruct (Cstruct.sub str 0 sublen) in 44 | Cstruct.LE.set_uint32 str sublen ~~~crc 45 | -------------------------------------------------------------------------------- /src/wodan/crc32c.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright 2017-2019 Gabriel de Perthuis *) 3 | (* *) 4 | (* Permission to use, copy, modify, and/or 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 OR *) 14 | (* IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 15 | (* *) 16 | (********************************************************************************) 17 | 18 | (* Copyright 2014 Citrix - ISC licensed *) 19 | 20 | val cstruct_valid : Cstruct.t -> bool 21 | (** [cstruct_valid cstruct] returns whether the CRC32C of cstruct is 22 | 0xffffffffl *) 23 | 24 | val cstruct_reset : Cstruct.t -> unit 25 | (** [cstruct_reset cstruct] rewrites the last four bytes of cstruct so that 26 | [cstruct_valid cstruct] is true *) 27 | -------------------------------------------------------------------------------- /src/wodan/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name wodan) 3 | (public_name wodan) 4 | (flags :standard -g) 5 | (ocamlopt_flags :standard -g -O3) 6 | (preprocess 7 | (pps lwt_ppx ppx_cstruct)) 8 | (libraries cstruct mirage-block lwt io-page lru logs nocrypto bitv diet 9 | checkseum optint metrics)) 10 | -------------------------------------------------------------------------------- /src/wodan/keyedmap.ml: -------------------------------------------------------------------------------- 1 | module type OrderedType = sig 2 | type t 3 | 4 | val compare : t -> t -> int 5 | end 6 | 7 | module Make (Ord : OrderedType) = struct 8 | exception Already_exists 9 | 10 | module M = Map.Make (Ord) 11 | 12 | type 'a t = 'a M.t ref 13 | 14 | type key = Ord.t 15 | 16 | let create () = ref M.empty 17 | 18 | let length m = M.cardinal !m 19 | 20 | let clear m = m := M.empty 21 | 22 | let is_empty m = !m = M.empty 23 | 24 | let find m k = M.find k !m 25 | 26 | let find_opt m k = M.find_opt k !m 27 | 28 | let mem m k = M.mem k !m 29 | 30 | let add m k v = m := M.add k v !m 31 | 32 | let update m k f = m := M.update k f !m 33 | 34 | let replace_existing m k v = 35 | m := 36 | M.update k 37 | (function 38 | | Some _ -> Some v 39 | | None -> raise Not_found) 40 | !m 41 | 42 | let xadd m k v = 43 | m := 44 | M.update k 45 | (function 46 | | Some _ -> raise Already_exists 47 | | None -> Some v) 48 | !m 49 | 50 | let remove m k = m := M.remove k !m 51 | 52 | let iter f m = M.iter f !m 53 | 54 | let iter_range f m start end_excl = 55 | try 56 | M.to_seq_from start !m 57 | |> Seq.iter (fun (k, v) -> 58 | if Ord.compare k end_excl < 0 then f k v else raise Exit) 59 | with Exit -> () 60 | 61 | let iter_inclusive_range f m start end_incl = 62 | try 63 | M.to_seq_from start !m 64 | |> Seq.iter (fun (k, v) -> 65 | if Ord.compare k end_incl <= 0 then f k v else raise Exit) 66 | with Exit -> () 67 | 68 | let fold f m acc = M.fold f !m acc 69 | 70 | let exists f m = M.exists f !m 71 | 72 | let min_binding m = M.min_binding !m 73 | 74 | let max_binding m = M.max_binding !m 75 | 76 | let find_first_opt m k = 77 | M.find_first_opt (fun k' -> Ord.compare k k' <= 0) !m 78 | 79 | let find_last_opt m k = M.find_last_opt (fun k' -> Ord.compare k' k < 0) !m 80 | 81 | let find_first m k = M.find_first (fun k' -> Ord.compare k k' <= 0) !m 82 | 83 | let find_last m k = M.find_last (fun k' -> Ord.compare k' k < 0) !m 84 | 85 | let split_off_after m k = 86 | let m1, m2 = M.partition (fun k' _v -> Ord.compare k k' >= 0) !m in 87 | m := m1; 88 | ref m2 89 | 90 | let split_off_le m k = 91 | let m1, m2 = M.partition (fun k' _v -> Ord.compare k k' < 0) !m in 92 | m := m1; 93 | ref m2 94 | 95 | let carve_inclusive_range m start end_incl = 96 | let m1, m2 = 97 | M.partition 98 | (fun k _v -> Ord.compare start k > 0 || Ord.compare k end_incl > 0) 99 | !m 100 | in 101 | m := m1; 102 | ref m2 103 | 104 | let keys m = List.rev (fold (fun k _v acc -> k :: acc) m []) 105 | 106 | let swap m1 m2 = 107 | let m = !m1 in 108 | m1 := !m2; 109 | m2 := m 110 | 111 | let copy_in m1 m2 = 112 | let () = clear m2 in 113 | M.iter (add m2) !m1 114 | end 115 | -------------------------------------------------------------------------------- /src/wodan/keyedmap.mli: -------------------------------------------------------------------------------- 1 | module type OrderedType = sig 2 | type t 3 | 4 | val compare : t -> t -> int 5 | end 6 | 7 | module Make (Ord : OrderedType) : sig 8 | type 'a t 9 | (** The type for maps *) 10 | 11 | type key = Ord.t 12 | (** The type for keys *) 13 | 14 | val create : unit -> 'a t 15 | (** Creates a new empty map *) 16 | 17 | val length : 'a t -> int 18 | (** Returns the length of the map *) 19 | 20 | val clear : 'a t -> unit 21 | (** Clears the map *) 22 | 23 | val is_empty : 'a t -> bool 24 | (** [is_empty m] returns whether map [m] is empty *) 25 | 26 | val find : 'a t -> key -> 'a 27 | (** [find m x] returns the binding of x in [m] or raises [Not_found] if [x] 28 | is not bind. *) 29 | 30 | val find_opt : 'a t -> key -> 'a option 31 | (** Same as [find] but wrapped in an option *) 32 | 33 | val min_binding : 'a t -> key * 'a 34 | (** Returns the binding with the minimum key, or raises Not_found if the map 35 | is empty. *) 36 | 37 | val max_binding : 'a t -> key * 'a 38 | (** Returns the binding with the maximum key, or raises Not_found if the map 39 | is empty. *) 40 | 41 | val find_first : 'a t -> key -> key * 'a 42 | (** [find_first_opt m k] finds the binding with the smallest key that is 43 | greater than [k], or raises [Not_found] if empty *) 44 | 45 | val find_last : 'a t -> key -> key * 'a 46 | (** [find_first_opt m k] finds the binding with the greatest key that is 47 | smaller than [k], or raises [Not_found] if empty *) 48 | 49 | val find_first_opt : 'a t -> key -> (key * 'a) option 50 | (** Same as [find_first] but wrapped in an option *) 51 | 52 | val find_last_opt : 'a t -> key -> (key * 'a) option 53 | (** Same as [find_last] but wrapped in an option *) 54 | 55 | val mem : 'a t -> key -> bool 56 | (** [mem m x] checks whether [x] is bind in [m] *) 57 | 58 | val exists : (key -> 'a -> bool) -> 'a t -> bool 59 | (** [exists f m] checks whether there exists a binding in [m] satisfying the 60 | predicate [f] *) 61 | 62 | val add : 'a t -> key -> 'a -> unit 63 | (** [add m k v] adds a binding from [k] to [v] in [m], replacing the previous 64 | binding if any*) 65 | 66 | val remove : 'a t -> key -> unit 67 | (** [remove m k] removes the binding of [k] in [m] *) 68 | 69 | val replace_existing : 'a t -> key -> 'a -> unit 70 | (** [replace_existing m k v] replaces the binding of [k] in [m] with the 71 | value [v] if any, otherwise raises [Not_found] *) 72 | 73 | val xadd : 'a t -> key -> 'a -> unit 74 | (** [xadd m k v] adds a binding from [k] to [v], or raises [Already_exists] 75 | if there is already one *) 76 | 77 | val update : 'a t -> key -> ('a option -> 'a option) -> unit 78 | (** [update m x f] returns a map containing the same bindings as [m], except 79 | for the binding of [x]. Depending on the value of y where y is 80 | [f (find_opt x m)], the binding of [x] is added, removed or updated. If y 81 | is [None], the binding is removed if it exists; otherwise, if y is 82 | [Some z] then [x] is associated to [z] in the resulting map. If [x] was 83 | already bound in [m] to a value that is physically equal to [z], [m] is 84 | left unchanged *) 85 | 86 | val keys : 'a t -> key list 87 | (** Returns the list of the keys of the map, in ascending order *) 88 | 89 | val iter : (key -> 'a -> unit) -> 'a t -> unit 90 | (** [iter f m] applies [f] to all bindings in [m] *) 91 | 92 | val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b 93 | (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], where [k1 ... kN] 94 | are the keys of all bindings in [m] (in increasing order), and 95 | [d1 ... dN] are the associated data. *) 96 | 97 | val iter_range : (key -> 'a -> unit) -> 'a t -> key -> key -> unit 98 | (** [iter f m start stop] applies [f] to all bindings [(x, d)] in [m] such 99 | that start <= x < stop *) 100 | 101 | val iter_inclusive_range : (key -> 'a -> unit) -> 'a t -> key -> key -> unit 102 | (** [iter f m start stop] applies [f] to all bindings [(x, d)] in [m] such 103 | that start <= x <= stop *) 104 | 105 | val split_off_after : 'a t -> key -> 'a t 106 | (** [split_off_after m k] removes all the bindings [(x, v)] in [m] such that 107 | [x > k] and returns them in a new map *) 108 | 109 | val split_off_le : 'a t -> key -> 'a t 110 | (** [split_off_le m k] removes all the bindings [(x, v)] in [m] such that 111 | [x <= k] and returns them in a new map *) 112 | 113 | val carve_inclusive_range : 'a t -> key -> key -> 'a t 114 | (** [carve_inclusive_range m start stop] removes all the bindings [(x, v)] in 115 | [m] such that [x < start] or [stop < x] and returns them in a new map *) 116 | 117 | val swap : 'a t -> 'a t -> unit 118 | (** [swap m1 m2] swaps the bindings of [m1] and [m2] *) 119 | 120 | val copy_in : 'a t -> 'a t -> unit 121 | (** [copy_in m1 m2] clears [m2] and copies the contents of [m1] in it *) 122 | end 123 | -------------------------------------------------------------------------------- /src/wodan/location.ml: -------------------------------------------------------------------------------- 1 | (* Limited to max_int until Bitv adds support for int64 indexes *) 2 | include Int64 3 | 4 | exception TooLarge 5 | 6 | exception NotUnsigned 7 | 8 | let of_int64 v = 9 | if Int64.compare v (Int64.of_int Stdlib.max_int) > 0 then raise TooLarge 10 | else if Int64.compare v 0L < 0 then raise NotUnsigned 11 | else v 12 | 13 | let of_int v = if v < 0 then raise NotUnsigned else Int64.of_int v 14 | 15 | let to_int64 v = v 16 | 17 | let pp fmt v = Format.fprintf fmt "L:%Ld" v 18 | -------------------------------------------------------------------------------- /src/wodan/location.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | exception TooLarge 4 | 5 | exception NotUnsigned 6 | 7 | val zero : t 8 | 9 | val one : t 10 | 11 | val succ : t -> t 12 | 13 | val add : t -> t -> t 14 | 15 | val sub : t -> t -> t 16 | 17 | val pred : t -> t 18 | 19 | val compare : t -> t -> int 20 | 21 | val shift_right_logical : t -> int -> t 22 | 23 | val rem : t -> t -> t 24 | 25 | val pp : Format.formatter -> t -> unit 26 | 27 | val to_string : t -> string 28 | 29 | val of_int64 : int64 -> t 30 | 31 | val to_int64 : t -> int64 32 | 33 | (* Provided until Bitv adds support for int64 indexes *) 34 | val of_int : int -> t 35 | 36 | (* Provided until Bitv adds support for int64 indexes *) 37 | val to_int : t -> int 38 | -------------------------------------------------------------------------------- /src/wodan/statistics.ml: -------------------------------------------------------------------------------- 1 | module type STATISTICS = sig 2 | type t 3 | 4 | val pp : Format.formatter -> t -> unit 5 | 6 | val data : t -> Metrics.Data.t 7 | end 8 | 9 | module HighLevel = struct 10 | type t = { 11 | mutable inserts : int; 12 | mutable lookups : int; 13 | mutable range_searches : int; 14 | mutable iters : int; 15 | } 16 | 17 | let create () = {inserts = 0; lookups = 0; range_searches = 0; iters = 0} 18 | 19 | let pp fmt {inserts; lookups; range_searches; iters} = 20 | Format.fprintf fmt "Ops: %d inserts %d lookups %d range searches %d iters" 21 | inserts lookups range_searches iters 22 | 23 | let data t = 24 | let open Metrics in 25 | Data.v 26 | [ 27 | int "inserts" t.inserts; 28 | int "lookups" t.lookups; 29 | int "range_searches" t.range_searches; 30 | int "iters" t.iters; 31 | ] 32 | end 33 | 34 | module LowLevel = struct 35 | type t = { 36 | mutable reads : int; 37 | mutable writes : int; 38 | mutable discards : int; 39 | mutable barriers : int; 40 | block_size : int; 41 | } 42 | 43 | let create block_size = 44 | {reads = 0; writes = 0; discards = 0; barriers = 0; block_size} 45 | 46 | let pp fmt {reads; writes; discards; barriers; _} = 47 | Format.fprintf fmt "Ops: %d reads %d writes %d discards %d barriers" reads 48 | writes discards barriers 49 | 50 | let data t = 51 | let open Metrics in 52 | Data.v 53 | [ 54 | int "reads" t.reads; 55 | int "writes" t.writes; 56 | int "discards" t.discards; 57 | int "barriers" t.barriers; 58 | ] 59 | end 60 | 61 | module Amplification = struct 62 | type t = { 63 | mutable read_ops : float; 64 | mutable read_bytes : float; 65 | mutable write_ops : float; 66 | mutable write_bytes : float; 67 | } 68 | 69 | let build (hl : HighLevel.t) (ll : LowLevel.t) = 70 | { 71 | read_ops = Float.of_int hl.lookups /. Float.of_int ll.reads; 72 | (* next one would require tracking sizes of values read; 73 | including for mem which normally ignores it *) 74 | read_bytes = 0.; 75 | write_ops = Float.of_int hl.inserts /. Float.of_int ll.writes; 76 | (* next one would require tracking sizes of values written *) 77 | write_bytes = 0.; 78 | } 79 | 80 | let pp fmt {read_ops; read_bytes; write_ops; write_bytes} = 81 | Format.fprintf fmt "Amplification: R %f [%f] W %f [%f]" read_bytes read_ops 82 | write_bytes write_ops 83 | 84 | let data t = 85 | let open Metrics in 86 | Data.v 87 | [ 88 | float "read_ops" t.read_ops; 89 | float "read_bytes" t.read_bytes; 90 | float "write_ops" t.write_ops; 91 | float "write_bytes" t.write_bytes; 92 | ] 93 | end 94 | -------------------------------------------------------------------------------- /src/wodan/statistics.mli: -------------------------------------------------------------------------------- 1 | (** A generic interface for statistics *) 2 | module type STATISTICS = sig 3 | type t 4 | 5 | val pp : Format.formatter -> t -> unit 6 | 7 | val data : t -> Metrics.Data.t 8 | end 9 | 10 | (** stats of high-level Wodan operations *) 11 | module HighLevel : sig 12 | (* A very reduced, read-only view *) 13 | type t = { 14 | mutable inserts : int; 15 | mutable lookups : int; 16 | mutable range_searches : int; 17 | mutable iters : int; 18 | } 19 | 20 | include STATISTICS with type t := t 21 | 22 | val create : unit -> t 23 | end 24 | 25 | (** Stats of operations on the backing store *) 26 | module LowLevel : sig 27 | (* A very reduced, read-only view *) 28 | type t = { 29 | mutable reads : int; 30 | mutable writes : int; 31 | mutable discards : int; 32 | mutable barriers : int; 33 | block_size : int; 34 | } 35 | 36 | include STATISTICS with type t := t 37 | 38 | val create : int -> t 39 | end 40 | 41 | (** Stats of amplification between high-level and low-level operations *) 42 | module Amplification : sig 43 | include STATISTICS 44 | 45 | val build : HighLevel.t -> LowLevel.t -> t 46 | end 47 | -------------------------------------------------------------------------------- /src/wodan/wodan.mli: -------------------------------------------------------------------------------- 1 | (********************************************************************************) 2 | (* Copyright 2017-2019 Gabriel de Perthuis *) 3 | (* *) 4 | (* Permission to use, copy, modify, and/or 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 OR *) 14 | (* IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) 15 | (* *) 16 | (********************************************************************************) 17 | 18 | (** The Wodan module allows access to Wodan filesystems 19 | 20 | The entry point is {!Wodan.Make}, which returns a {!Wodan.S} module 21 | supporting filesystem operations *) 22 | 23 | (** This module is used to look at Wodan performance *) 24 | module Statistics : sig 25 | (** A generic interface for statistics *) 26 | module type STATISTICS = sig 27 | type t 28 | 29 | val pp : Format.formatter -> t -> unit 30 | 31 | val data : t -> Metrics.Data.t 32 | end 33 | 34 | (** stats of high-level Wodan operations *) 35 | module HighLevel : sig 36 | (* A very reduced, read-only view *) 37 | include STATISTICS 38 | 39 | val create : unit -> t 40 | end 41 | 42 | (** Stats of operations on the backing store *) 43 | module LowLevel : sig 44 | (* A very reduced, read-only view *) 45 | type t = private { 46 | mutable reads : int; 47 | mutable writes : int; 48 | mutable discards : int; 49 | mutable barriers : int; 50 | block_size : int; 51 | } 52 | 53 | include STATISTICS with type t := t 54 | 55 | val create : int -> t 56 | end 57 | 58 | (** Stats of amplification between high-level and low-level operations *) 59 | module Amplification : sig 60 | include STATISTICS 61 | 62 | val build : HighLevel.t -> LowLevel.t -> t 63 | end 64 | end 65 | 66 | exception BadMagic 67 | (** Raised when trying to open a superblock and it doesn't have the magic tag 68 | for Wodan filesystems *) 69 | 70 | exception BadVersion 71 | (** Raised when trying to open a superblock and it doesn't have a supported 72 | version for Wodan filesystems *) 73 | 74 | exception BadFlags 75 | (** Raised when trying to open a superblock and it sets must-support flags that 76 | this version doesn't support *) 77 | 78 | exception BadCRC of int64 79 | (** Raised when a block doesn't have the expected CRC 80 | 81 | The exception carries the logical offset of the block. *) 82 | 83 | exception BadParams 84 | (** Raised when {!SUPERBLOCK_PARAMS} passed to the Make functor don't match 85 | actual settings saved in the superblock *) 86 | 87 | exception ReadError 88 | (** Raised on IO failures reading a block *) 89 | 90 | exception WriteError 91 | (** Raised on IO failures writing a block *) 92 | 93 | exception OutOfSpace 94 | (** Raised when the filesystem doesn't have enough space to perform the 95 | operation *) 96 | 97 | exception NeedsFlush 98 | (** Raised when the filesystem doesn't have enough space to perform an 99 | operation that would be possible if pending operations were flushed first *) 100 | 101 | exception BadKey of string 102 | (** Raised when converting to a key is impossible, eg because the input doesn't 103 | have the expected length 104 | 105 | The exception carries the original input. *) 106 | 107 | exception ValueTooLarge of string 108 | (** Raised when converting to a value is impossible, because the input would 109 | not fit on a single block 110 | 111 | Note that Wodan expects the user to chunk values if arbitrary lengths are 112 | to be supported. See also {!Wodan_irmin}'s relationship to irmin-chunk. 113 | 114 | The exception carries the original input *) 115 | 116 | exception BadNodeType of int 117 | (** Raised when a block doesn't have a known and expected node type 118 | 119 | The exception carries the type tag that couldn't be handled. *) 120 | 121 | (** Extends a Mirage_block.S backend to keep track of low-level statistics *) 122 | module BlockWithStats (B : Mirage_block.S) : sig 123 | include Mirage_block.S 124 | 125 | val v : B.t -> int -> t 126 | (** Build a high-level block device with stats from a low-devel block device 127 | and a block size in bytes *) 128 | 129 | val stats : t -> Statistics.LowLevel.t 130 | end 131 | 132 | val sizeof_superblock : int 133 | (** A constant that represents the size of Wodan superblocks 134 | 135 | Will be a power of two and a multiple of a standard sector size *) 136 | 137 | type relax = { 138 | magic_crc : bool; 139 | (** CRC errors ignored on any read where the magic CRC is used *) 140 | magic_crc_write : bool; (** Write non-superblock blocks with the magic CRC *) 141 | } 142 | (** Flags representing integrity features that will be relaxed 143 | 144 | Passed at mount time through {!mount_options} *) 145 | 146 | type mount_options = { 147 | fast_scan : bool; 148 | (** If enabled, instead of checking the entire filesystem when opening, 149 | leaf nodes won't be scanned. They will be scanned on open instead. *) 150 | cache_size : int; (** How many blocks to keep in cache *) 151 | relax : relax; (** Integrity invariants to relax *) 152 | } 153 | (** All parameters that can't be read from the superblock *) 154 | 155 | (** Superblock flags that are supported but not required by this Wodan version *) 156 | module OptionalSuperblockFlags : sig 157 | type t 158 | (** A set of flags *) 159 | 160 | val empty : t 161 | (** The empty set of flags *) 162 | 163 | val tombstones_enabled : t 164 | (** The flag for tombstone support 165 | 166 | If set, the empty value will be considered a tombstone, meaning that 167 | functions that query values (mem, lookup, iter, search_range…) will treat 168 | it as if there was no value. 169 | 170 | This enables optimisations on the write path, allowing tombstones to 171 | fully disappear from storage eventually *) 172 | 173 | val intersect : t -> t -> t 174 | (** Take two sets of flags, return the common subset *) 175 | end 176 | 177 | (** All parameters that can be read from the superblock *) 178 | module type SUPERBLOCK_PARAMS = sig 179 | val block_size : int 180 | (** Size of blocks, in bytes *) 181 | 182 | val key_size : int 183 | (** The exact size of all keys, in bytes *) 184 | 185 | val optional_flags : OptionalSuperblockFlags.t 186 | (** The set of optional superblock flags *) 187 | end 188 | 189 | (** Operations used when testing and fuzzing *) 190 | module Testing : sig 191 | val cstruct_cond_reset : Cstruct.t -> bool 192 | end 193 | 194 | module StandardSuperblockParams : SUPERBLOCK_PARAMS 195 | (** Defaults for {!SUPERBLOCK_PARAMS} *) 196 | 197 | val standard_mount_options : mount_options 198 | (** Defaults for {!mount_options} *) 199 | 200 | val read_superblock_params : 201 | (module Mirage_block.S with type t = 'a) -> 202 | 'a -> 203 | relax -> 204 | (module SUPERBLOCK_PARAMS) Lwt.t 205 | (** Read static filesystem parameters 206 | 207 | These are set at creation time and recorded in the superblock. See 208 | {!open_for_reading} if all you need is to mount the filesystem. *) 209 | 210 | type format_params = { 211 | logical_size : int64; 212 | (** The number of blocks, including the superblock, that are part of the 213 | filesystem *) 214 | preroots_interval : int64; 215 | (** The (maximum) interval between pre-roots. Pre-roots are used to 216 | ensure that bisection will not be slow on freshly-formatted devices. *) 217 | } 218 | (** Parameters passed when creating a filesystem *) 219 | 220 | val default_preroots_interval : int64 221 | 222 | (** Modes for opening a device, see {!S.prepare_io} *) 223 | type deviceOpenMode = 224 | | OpenExistingDevice 225 | (** Open an existing device, read logical size from superblock *) 226 | | FormatEmptyDevice of format_params 227 | (** Format a device, which must contain only zeroes, and use the given 228 | format_params *) 229 | 230 | (** Filesystem operations 231 | 232 | This module is specialized for a given set of superblock parameters, with 233 | key and value types also being specialized to match. *) 234 | module type S = sig 235 | type key 236 | (** An opaque type for fixed-size keys 237 | 238 | Conversion from/to strings is free *) 239 | 240 | type value 241 | (** An opaque type for bounded-size values 242 | 243 | Conversion from/to strings is free *) 244 | 245 | type disk 246 | (** A backing device *) 247 | 248 | type root 249 | (** A filesystem root *) 250 | 251 | (** Operations over keys *) 252 | module Key : sig 253 | type t = key 254 | 255 | val equal : t -> t -> bool 256 | 257 | val hash : t -> int 258 | 259 | val compare : t -> t -> int 260 | end 261 | 262 | module P : SUPERBLOCK_PARAMS 263 | (** The parameter module that was used to create this module *) 264 | 265 | val key_of_cstruct : Cstruct.t -> key 266 | 267 | val key_of_string : string -> key 268 | 269 | val key_of_string_padded : string -> key 270 | 271 | val cstruct_of_key : key -> Cstruct.t 272 | 273 | val string_of_key : key -> string 274 | 275 | val value_of_cstruct : Cstruct.t -> value 276 | 277 | val value_of_string : string -> value 278 | 279 | val value_equal : value -> value -> bool 280 | 281 | val cstruct_of_value : value -> Cstruct.t 282 | 283 | val string_of_value : value -> string 284 | 285 | val next_key : key -> key 286 | (** The next highest key 287 | 288 | Raises {!Invalid_argument} if already at the highest possible key *) 289 | 290 | val is_tombstone : value -> bool 291 | (** Whether a value is a tombstone *) 292 | 293 | val insert : root -> key -> value -> unit Lwt.t 294 | (** Store data in the filesystem 295 | 296 | Any previously stored value will be silently overwritten *) 297 | 298 | val lookup : root -> key -> value option Lwt.t 299 | (** Read data from the filesystem *) 300 | 301 | val mem : root -> key -> bool Lwt.t 302 | (** Check whether a key has been set within the filesystem *) 303 | 304 | val flush : root -> int64 Lwt.t 305 | (** Send changes to disk *) 306 | 307 | val fstrim : root -> int64 Lwt.t 308 | (** Discard all blocks which the filesystem doesn't explicitly use *) 309 | 310 | val live_trim : root -> int64 Lwt.t 311 | (** Discard blocks that have been unused since mounting or since the last 312 | live_trim call *) 313 | 314 | val log_statistics : root -> unit 315 | (** Send statistics about operations to the log *) 316 | 317 | val stats : root -> Statistics.HighLevel.t 318 | (** Grab a snapshot of statistics about high-level operations *) 319 | 320 | val search_range : root -> key -> key -> (key -> value -> unit) -> unit Lwt.t 321 | (** Call back a function for all elements in the range from start inclusive 322 | to end_ exclusive 323 | 324 | Results are in no particular order. *) 325 | 326 | val iter : root -> (key -> value -> unit) -> unit Lwt.t 327 | (** Call back a function for all elements in the filesystem *) 328 | 329 | val prepare_io : 330 | deviceOpenMode -> disk -> mount_options -> (root * int64) Lwt.t 331 | (** Open a filesystem 332 | 333 | Returns a root and its generation number. When integrating Wodan as part 334 | of a distributed system, you may want to check here that the generation 335 | number has grown since the last flush *) 336 | end 337 | 338 | (** Build a {!Wodan.S} module given a backing device and parameters 339 | 340 | This is the main entry point to Wodan. {!open_for_reading} is another entry 341 | point, used when you have an existing filesystem and do not care about the 342 | superblock parameters. *) 343 | module Make (B : Mirage_block.S) (P : SUPERBLOCK_PARAMS) : 344 | S with type disk = B.t 345 | 346 | (** This is a type that packages together a {!Wodan.S} with an opened root and 347 | the generation number read when mounting *) 348 | type open_ret = 349 | | OPEN_RET : (module S with type root = 'a) * 'a * int64 -> open_ret (** *) 350 | 351 | val open_for_reading : 352 | (module Mirage_block.S with type t = 'a) -> 353 | 'a -> 354 | mount_options -> 355 | open_ret Lwt.t 356 | (** Open an existing Wodan filesystem, getting static parameters from the 357 | superblock *) 358 | -------------------------------------------------------------------------------- /tests/wodan-irmin/bench.ml: -------------------------------------------------------------------------------- 1 | module BlockCon = struct 2 | include Ramdisk 3 | 4 | let devices = Hashtbl.create 1 5 | 6 | (* This is Ramdisk.connect but with a different default size *) 7 | let connect name = 8 | if Hashtbl.mem devices name then Lwt.return (Hashtbl.find devices name) 9 | else 10 | Lwt.bind (create ~name ~size_sectors:131072L ~sector_size:512) 11 | (fun device -> 12 | let device = Result.get_ok device in 13 | Hashtbl.replace devices name device; 14 | Lwt.return device) 15 | 16 | let discard _ _ _ = Lwt.return (Ok ()) 17 | end 18 | 19 | module DB_ram = 20 | Wodan_irmin.DB_BUILDER (BlockCon) (Wodan_irmin.StandardSuperblockParams) 21 | module KV_chunked = 22 | Wodan_irmin.KV_chunked (DB_ram) (Irmin.Hash.SHA1) (Irmin.Contents.String) 23 | module Bench = Irmin_bench.Make (KV_chunked) 24 | 25 | let config ~root:_ = Wodan_irmin.config ~path:"disk.img" ~create:true () 26 | 27 | let size ~root:_ = 0 28 | 29 | let () = Lwt_main.run (Nocrypto_entropy_lwt.initialize ()) 30 | 31 | let () = Bench.run ~config ~size 32 | -------------------------------------------------------------------------------- /tests/wodan-irmin/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (modules test test_wodan) 4 | (package wodan-irmin) 5 | (libraries alcotest irmin-test io-page-unix nocrypto.lwt 6 | mirage-block-ramdisk wodan wodan-irmin lwt irmin)) 7 | 8 | (executable 9 | (name bench) 10 | (modules bench) 11 | (libraries wodan-irmin irmin-test.bench mirage-block-ramdisk io-page-unix 12 | lwt lwt.unix nocrypto.lwt irmin)) 13 | 14 | (rule 15 | (alias runbench) 16 | (package wodan-irmin) 17 | (deps bench.exe) 18 | (action 19 | (run ./bench.exe))) 20 | -------------------------------------------------------------------------------- /tests/wodan-irmin/test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2017 Thomas Gazagnaire 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 | let misc = 18 | [ (*"link", [ 19 | Test_link.test "wodan" Test_wodan.link; 20 | ]*) ] 21 | 22 | let () = Irmin_test.Store.run "irmin" ~misc [(`Quick, Test_wodan.suite)] 23 | -------------------------------------------------------------------------------- /tests/wodan-irmin/test.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2017 Thomas Gazagnaire 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 | (* left empty on purpose *) 18 | -------------------------------------------------------------------------------- /tests/wodan-irmin/test_wodan.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2013-2017 Thomas Gazagnaire 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Lwt.Infix 18 | 19 | module BlockCon = struct 20 | include Ramdisk 21 | 22 | let connect name = 23 | (* Ramdisk.connect ~name defaults to 32K sectors (16MiB), we need more for wide inode tests *) 24 | Ramdisk.create ~name ~size_sectors:131072L ~sector_size:512 25 | >|= Result.get_ok 26 | 27 | let discard _ _ _ = Lwt.return (Ok ()) 28 | end 29 | 30 | module DB_ram = 31 | Wodan_irmin.DB_BUILDER (BlockCon) (Wodan_irmin.StandardSuperblockParams) 32 | 33 | (* let store = Irmin_test.store (module Wodan_irmin.Make(DB_ram)) (module Irmin.Metadata.None) *) 34 | let store = 35 | (module Wodan_irmin.KV_chunked (DB_ram) (Irmin.Hash.SHA1) 36 | (Irmin.Contents.String) : Irmin_test.S) 37 | 38 | let config = Wodan_irmin.config ~path:"disk.img" ~create:true () 39 | 40 | let clean () = 41 | let (module S : Irmin_test.S) = store in 42 | S.Repo.v config >>= fun repo -> 43 | S.Repo.branches repo >>= Lwt_list.iter_p (S.Branch.remove repo) 44 | 45 | let init () = Nocrypto_entropy_lwt.initialize () 46 | 47 | let stats = None 48 | 49 | let suite = 50 | { 51 | Irmin_test.name = "WODAN"; 52 | Irmin_test.layered_store = None; 53 | init; 54 | clean; 55 | config; 56 | store; 57 | stats; 58 | } 59 | -------------------------------------------------------------------------------- /tests/wodan/bench.ml: -------------------------------------------------------------------------------- 1 | (* Defaults: 2 | BENCH_NB_ENTRIES (10_000_000 for index, lowered to 1M here) entries, with key_size=32 and value_size=13 -> large *) 3 | 4 | open Lwt.Infix 5 | 6 | module SBParams = struct 7 | include Wodan.StandardSuperblockParams 8 | 9 | let key_size = 32 10 | 11 | (*let block_size = 64*1024*) 12 | end 13 | 14 | let key_size = SBParams.key_size 15 | 16 | let value_size = 13 17 | 18 | let entry_size = key_size + value_size 19 | 20 | let ( // ) = Filename.concat 21 | 22 | let random_char () = char_of_int (33 + Random.int 94) 23 | 24 | let random_string string_size = 25 | String.init string_size (fun _i -> random_char ()) 26 | 27 | let replace_sampling_interval = ref 0 28 | 29 | module Context = struct 30 | module Key = struct 31 | type t = string [@@deriving repr] 32 | 33 | let v () = random_string key_size 34 | 35 | let hash = Hashtbl.hash 36 | 37 | let hash_size = 30 38 | 39 | let encode s = s 40 | 41 | let decode s off = String.sub s off key_size 42 | 43 | let encoded_size = key_size 44 | 45 | let equal = String.equal 46 | end 47 | 48 | module Value = struct 49 | type t = string [@@deriving repr] 50 | 51 | let v () = random_string value_size 52 | 53 | let encode s = s 54 | 55 | let decode s off = String.sub s off value_size 56 | 57 | let encoded_size = value_size 58 | end 59 | end 60 | 61 | (* merge two Metrics.Data.t *) 62 | let merge_data d1 d2 = 63 | let rec aux d = function 64 | | [] -> d 65 | | f :: fl -> aux (Metrics.Data.cons f d) fl 66 | in 67 | aux d1 (Metrics.Data.fields d2) 68 | 69 | module Backing = Wodan.BlockWithStats (Block) 70 | module Stor = Wodan.Make (Backing) (SBParams) 71 | 72 | let make_bindings_pool nb_entries = 73 | Array.init nb_entries (fun _ -> 74 | let k = Stor.key_of_string (random_string key_size) in 75 | let v = Stor.value_of_string (random_string value_size) in 76 | (k, v)) 77 | 78 | let bindings_pool = ref [||] 79 | 80 | let absent_bindings_pool = ref [||] 81 | 82 | let sorted_bindings_pool = ref [||] 83 | 84 | module Benchmark = struct 85 | type result = { 86 | time : float; 87 | ops_per_sec : float; 88 | mbs_per_sec : float; 89 | read_amplification_calls : float; 90 | read_amplification_size : float; 91 | write_amplification_calls : float; 92 | write_amplification_size : float; 93 | } 94 | [@@deriving yojson] 95 | 96 | let run ~nb_entries f stor backing = 97 | let t0 = Sys.time () in 98 | f stor () >>= fun () -> 99 | let time = Sys.time () -. t0 in 100 | let backing_stats = Backing.stats backing in 101 | (* XXX high-level data is not that useful when all calls are explicit in the bench suite *) 102 | let _stats_data = 103 | merge_data 104 | (Wodan.Statistics.HighLevel.data (Stor.stats stor)) 105 | (Wodan.Statistics.LowLevel.data backing_stats) 106 | in 107 | 108 | let nb_entriesf = float_of_int nb_entries in 109 | let entry_sizef = float_of_int entry_size in 110 | let read_amplification_size = 111 | float_of_int (backing_stats.reads * backing_stats.block_size) 112 | /. (entry_sizef *. nb_entriesf) 113 | in 114 | let read_amplification_calls = 115 | float_of_int backing_stats.reads /. nb_entriesf 116 | in 117 | let write_amplification_size = 118 | float_of_int (backing_stats.writes * backing_stats.block_size) 119 | /. (entry_sizef *. nb_entriesf) 120 | in 121 | let write_amplification_calls = 122 | float_of_int backing_stats.writes /. nb_entriesf 123 | in 124 | let ops_per_sec = nb_entriesf /. time in 125 | let mbs_per_sec = entry_sizef *. nb_entriesf /. 1_048_576. /. time in 126 | Lwt.return 127 | { 128 | time; 129 | ops_per_sec; 130 | mbs_per_sec; 131 | read_amplification_calls; 132 | read_amplification_size; 133 | write_amplification_calls; 134 | write_amplification_size; 135 | } 136 | 137 | let pp_list times = String.concat "; " (List.map string_of_float times) 138 | 139 | let pp_result fmt result = 140 | Format.fprintf fmt 141 | "Total time: %f@\n\ 142 | Operations per second: %f@\n\ 143 | Mbytes per second: %f@\n\ 144 | Read amplification in syscalls: %f@\n\ 145 | Read amplification in bytes: %f@\n\ 146 | Write amplification in syscalls: %f@\n\ 147 | Write amplification in bytes: %f@\n" 148 | result.time result.ops_per_sec result.mbs_per_sec 149 | result.read_amplification_calls result.read_amplification_size 150 | result.write_amplification_calls result.write_amplification_size 151 | end 152 | 153 | (* from https://erratique.ch/software/logs/doc/Logs/index.html#ex1 *) 154 | let stamp_tag : Mtime.span Logs.Tag.def = 155 | Logs.Tag.def "stamp" ~doc:"Relative monotonic time stamp" Mtime.Span.pp 156 | 157 | let stamp c = Logs.Tag.(empty |> add stamp_tag (Mtime_clock.count c)) 158 | 159 | (* Switched to use Logs_fmt.pp_header, a valid format string, 160 | the default app/dst, and not show timestamps when no tag is given; 161 | minimal changes because this is clearly complex *) 162 | let reporter () = 163 | let report _src level ~over k msgf = 164 | let k _ = 165 | over (); 166 | k () 167 | in 168 | let with_stamp h tags k ppf fmt = 169 | let stamp = 170 | match tags with 171 | | None -> None 172 | | Some tags -> Logs.Tag.find stamp_tag tags 173 | in 174 | match stamp with 175 | | None -> 176 | Format.kfprintf k ppf 177 | ("%a @[" ^^ fmt ^^ "@]@.") 178 | Logs_fmt.pp_header (level, h) 179 | | Some s -> 180 | Format.kfprintf k ppf 181 | ("%a[%a] @[" ^^ fmt ^^ "@]@.") 182 | Logs_fmt.pp_header (level, h) Mtime.Span.pp s 183 | in 184 | let ppf = 185 | if level = App then Format.std_formatter else Format.err_formatter 186 | in 187 | msgf @@ fun ?header ?tags fmt -> with_stamp header tags k ppf fmt 188 | in 189 | {Logs.report} 190 | 191 | module Index = struct 192 | let write ?(with_flush = false) bindings rw = 193 | Lwt_list.iteri_s 194 | (fun i (k, v) -> 195 | let r = Stor.insert rw k v in 196 | if with_flush || i mod 250_000 = 0 then 197 | r >>= fun () -> Stor.flush rw >|= ignore 198 | else r) 199 | (Array.to_list bindings) 200 | 201 | let read bindings r = 202 | (* assert presence? *) 203 | Lwt_list.iter_s 204 | (fun (k, _) -> Stor.lookup r k >|= ignore) 205 | (Array.to_list bindings) 206 | 207 | let read_absent bindings r = 208 | (* assert absence? *) 209 | Lwt_list.iter_s 210 | (fun (k, _) -> Stor.lookup r k >|= ignore) 211 | (Array.to_list bindings) 212 | 213 | let write_random t () = write !bindings_pool t 214 | 215 | let write_seq t = 216 | Array.sort 217 | (fun a b -> 218 | String.compare 219 | (Stor.string_of_key (fst a)) 220 | (Stor.string_of_key (fst b))) 221 | !sorted_bindings_pool; 222 | fun () -> write !sorted_bindings_pool t 223 | 224 | let write_sync t () = write ~with_flush:true !bindings_pool t 225 | 226 | let iter t () = Stor.iter t (fun _ _ -> ()) 227 | 228 | let find_random t () = read !bindings_pool t 229 | 230 | let find_absent t () = read_absent !absent_bindings_pool t 231 | 232 | let run ~nb_entries ~root ~name ~fresh ~clock b = 233 | let path = root // name in 234 | let size = Int64.mul 1048576L 1024L in 235 | let sector_size = 512 in 236 | assert (Int64.(rem size (of_int sector_size) = 0L)); 237 | let sectors = Int64.(div size (of_int sector_size)) in 238 | (try Unix.mkdir root 0o700 with Unix.Unix_error (EEXIST, _, _) -> ()); 239 | let fd = Unix.openfile path [Unix.O_CREAT] 0o600 in 240 | Unix.close fd; 241 | (*Ramdisk.create ~name:path ~size_sectors:sectors ~sector_size >|= Result.get_ok >>= fun disk ->*) 242 | Block.connect path >>= fun disk -> 243 | Block.resize disk sectors >|= Result.get_ok >>= fun () -> 244 | Block.get_info disk >>= fun info -> 245 | assert (info.sector_size = sector_size); 246 | assert (info.size_sectors = sectors); 247 | assert (Int64.(rem size (of_int Stor.P.block_size)) = 0L); 248 | let block_count = Int64.(div size (of_int Stor.P.block_size)) in 249 | let disk = Backing.v disk Stor.P.block_size in 250 | Stor.prepare_io 251 | (if fresh then 252 | Wodan.FormatEmptyDevice 253 | { 254 | logical_size = block_count; 255 | preroots_interval = Wodan.default_preroots_interval; 256 | } 257 | else Wodan.OpenExistingDevice) 258 | disk 259 | {Wodan.standard_mount_options with fast_scan = true; cache_size = 1024} 260 | >>= fun (stor, _gen) -> 261 | Logs.app (fun m -> m "Opened device for %s" name ~tags:(stamp clock)); 262 | let result = Benchmark.run ~nb_entries b stor disk in 263 | Stor.flush stor >>= fun _gen -> result 264 | 265 | type suite_elt = { 266 | name : string; 267 | synopsis : string; 268 | readonly : bool; 269 | fresh : bool; 270 | benchmark : Stor.root -> unit -> unit Lwt.t; 271 | dependency : string option; 272 | speed : [ `Quick | `Slow ]; 273 | } 274 | 275 | let suite = 276 | [ 277 | { 278 | name = "replace_random"; 279 | synopsis = "Replace in random order"; 280 | readonly = false; 281 | fresh = true; 282 | benchmark = write_random; 283 | dependency = None; 284 | speed = `Quick; 285 | }; 286 | { 287 | name = "replace_random_sync"; 288 | synopsis = "Replace in random order with sync"; 289 | readonly = false; 290 | fresh = true; 291 | benchmark = write_sync; 292 | dependency = None; 293 | speed = `Slow; 294 | }; 295 | { 296 | name = "replace_increasing_keys"; 297 | synopsis = "Replace in increasing order of keys"; 298 | readonly = false; 299 | fresh = true; 300 | benchmark = write_seq; 301 | dependency = None; 302 | speed = `Slow; 303 | }; 304 | { 305 | name = "iter_rw"; 306 | synopsis = "[RW] Iter"; 307 | readonly = false; 308 | fresh = false; 309 | benchmark = iter; 310 | dependency = Some "replace_random"; 311 | speed = `Slow; 312 | }; 313 | { 314 | name = "find_random_ro"; 315 | synopsis = "[RO] Find in random order"; 316 | readonly = true; 317 | fresh = false; 318 | benchmark = find_random; 319 | dependency = Some "replace_random"; 320 | speed = `Quick; 321 | }; 322 | { 323 | name = "find_random_rw"; 324 | synopsis = "[RW] Find in random order"; 325 | readonly = false; 326 | fresh = false; 327 | benchmark = find_random; 328 | dependency = Some "replace_random"; 329 | speed = `Quick; 330 | }; 331 | { 332 | name = "find_absent_ro"; 333 | synopsis = "[RO] Find absent values"; 334 | readonly = true; 335 | fresh = false; 336 | benchmark = find_absent; 337 | dependency = Some "replace_random"; 338 | speed = `Slow; 339 | }; 340 | { 341 | name = "find_absent_rw"; 342 | synopsis = "[RW] Find absent values"; 343 | readonly = false; 344 | fresh = false; 345 | benchmark = find_absent; 346 | dependency = Some "replace_random"; 347 | speed = `Slow; 348 | }; 349 | ] 350 | end 351 | 352 | let list_benches () = 353 | let pp_bench ppf b = Fmt.pf ppf "%s\t-- %s" b.Index.name b.synopsis in 354 | Index.suite |> Fmt.(pr "%a" (list ~sep:Fmt.(const string "\n") pp_bench)) 355 | 356 | let schedule p s = 357 | let todos = List.map fst in 358 | let init = ref (s |> List.map (fun b -> (p b.Index.name, b))) in 359 | let apply_dep s = 360 | let deps = 361 | s 362 | |> List.fold_left 363 | (fun acc (todo, b) -> 364 | if todo then 365 | match b.Index.dependency with 366 | | Some s -> s :: acc 367 | | None -> acc 368 | else acc) 369 | [] 370 | in 371 | s |> List.map (fun (todo, b) -> (todo || List.mem b.Index.name deps, b)) 372 | in 373 | let next = ref (apply_dep !init) in 374 | while todos !init <> todos !next do 375 | init := !next; 376 | next := apply_dep !init 377 | done; 378 | let r = List.filter fst !init |> List.map snd in 379 | r 380 | 381 | type config = { 382 | key_size : int; 383 | value_size : int; 384 | nb_entries : int; 385 | log_size : int; 386 | seed : int; 387 | with_metrics : bool; 388 | sampling_interval : int; 389 | minimal_flag : bool; 390 | } 391 | [@@deriving yojson] 392 | 393 | let pp_config fmt config = 394 | Format.fprintf fmt 395 | "Key size: %d@\n\ 396 | Value size: %d@\n\ 397 | Number of bindings: %d@\n\ 398 | Log size: %d@\n\ 399 | Seed: %d@\n\ 400 | Metrics: %b@\n\ 401 | Sampling interval: %d" config.key_size config.value_size config.nb_entries 402 | config.log_size config.seed config.with_metrics config.sampling_interval 403 | 404 | let cleanup root = 405 | let files = ["data"; "log"; "lock"; "log_async"; "merge"] in 406 | List.iter 407 | (fun (b : Index.suite_elt) -> 408 | let dir = root // b.name // "index" in 409 | List.iter 410 | (fun file -> 411 | let file = dir // file in 412 | if Sys.file_exists file then Unix.unlink file) 413 | files) 414 | Index.suite 415 | 416 | let init config = 417 | Printexc.record_backtrace true; 418 | Random.init config.seed; 419 | Lwt_main.run (Nocrypto_entropy_lwt.initialize ()); 420 | if config.with_metrics then ( 421 | Metrics.enable_all (); 422 | Metrics_gnuplot.set_reporter (); 423 | Metrics_unix.monitor_gc 0.1); 424 | bindings_pool := make_bindings_pool config.nb_entries; 425 | if not config.minimal_flag then ( 426 | absent_bindings_pool := make_bindings_pool config.nb_entries; 427 | sorted_bindings_pool := Array.copy !bindings_pool; 428 | replace_sampling_interval := config.sampling_interval) 429 | 430 | let print fmt (config, results) = 431 | let pp_bench fmt (b, result) = 432 | Format.fprintf fmt "%s [%s]@\n @[%a@]" b.Index.synopsis b.Index.name 433 | Benchmark.pp_result result 434 | in 435 | Format.fprintf fmt 436 | "Configuration:@\n @[%a@]@\n@\nResults:@\n @[%a@]@\n" pp_config 437 | config 438 | Fmt.(list ~sep:(any "@\n@\n") pp_bench) 439 | results 440 | 441 | let print_json fmt (config, results) = 442 | let open Yojson.Safe in 443 | let obj = 444 | `Assoc 445 | [ 446 | ("config", config_to_yojson config); 447 | ( "results", 448 | `List 449 | (List.map 450 | (fun (b, result) -> 451 | `Assoc 452 | [ 453 | ("name", `String b.Index.name); 454 | ("metrics", Benchmark.result_to_yojson result); 455 | ]) 456 | results) ); 457 | ] 458 | in 459 | pretty_print fmt obj 460 | 461 | let get_suite_list minimal_flag = 462 | if minimal_flag then 463 | List.filter (fun bench -> bench.Index.speed = `Quick) Index.suite 464 | else Index.suite 465 | 466 | let run filter root output seed with_metrics log_size nb_entries json 467 | sampling_interval minimal_flag = 468 | Memtrace.trace_if_requested (); 469 | Fmt_tty.setup_std_outputs (); 470 | Logs.set_reporter (reporter ()); 471 | Logs.set_level (Some Logs.Info); 472 | let config = 473 | { 474 | key_size; 475 | value_size; 476 | nb_entries; 477 | log_size; 478 | seed; 479 | with_metrics; 480 | sampling_interval; 481 | minimal_flag; 482 | } 483 | in 484 | cleanup root; 485 | init config; 486 | let current_suite = get_suite_list config.minimal_flag in 487 | let name_filter = 488 | match filter with 489 | | None -> fun _ -> true 490 | | Some re -> Re.execp re 491 | in 492 | let clock = Mtime_clock.counter () in 493 | current_suite 494 | |> schedule name_filter 495 | |> List.map (fun (b : Index.suite_elt) -> 496 | let name = 497 | match b.dependency with 498 | | None -> b.name 499 | | Some name -> name 500 | in 501 | Logs.app (fun m -> 502 | m "Benching %s with %d entries" b.name nb_entries 503 | ~tags:(stamp clock)); 504 | let result = 505 | Lwt_main.run 506 | (Index.run ~nb_entries ~root ~name ~fresh:b.fresh ~clock 507 | b.benchmark) 508 | in 509 | (b, result)) 510 | |> fun results -> 511 | let fmt = 512 | (match output with 513 | | None -> stdout 514 | | Some filename -> open_out filename) 515 | |> Format.formatter_of_out_channel 516 | in 517 | Fmt.pf fmt "%a@." (if json then print_json else print) (config, results) 518 | 519 | open Cmdliner 520 | 521 | let env_var s = Arg.env_var ("BENCH_" ^ s) 522 | 523 | let new_file = 524 | let parse s = 525 | match Sys.file_exists s && Sys.is_directory s with 526 | | false -> `Ok s 527 | | true -> `Error (Printf.sprintf "Error: `%s' is a directory" s) 528 | in 529 | (parse, Format.pp_print_string) 530 | 531 | let regex = 532 | let parse s = 533 | try Ok Re.(compile @@ Pcre.re ~flags:[`ANCHORED] s) with 534 | | Re.Perl.Parse_error -> Error (`Msg "Perl-compatible regexp parse error") 535 | | Re.Perl.Not_supported -> Error (`Msg "unsupported regexp feature") 536 | in 537 | let print = Re.pp_re in 538 | Arg.conv (parse, print) 539 | 540 | let name_filter = 541 | let doc = 542 | "A regular expression matching the names of benchmarks to run. For more \ 543 | information about the regexp syntax, please visit \ 544 | https://perldoc.perl.org/perlre.html#Regular-Expressions." 545 | in 546 | let env = env_var "NAME_FILTER" in 547 | Arg.( 548 | value 549 | & opt (some regex) None 550 | & info ["f"; "filter"] ~env ~doc ~docv:"NAME_REGEX") 551 | 552 | let data_dir = 553 | let doc = "Set directory for the data files" in 554 | let env = env_var "DATA_DIR" in 555 | Arg.(value & opt dir "_bench" & info ["d"; "data-dir"] ~env ~doc) 556 | 557 | let output = 558 | let doc = "Specify an output file where the results should be written" in 559 | let env = env_var "OUTPUT" in 560 | Arg.(value & opt (some new_file) None & info ["o"; "output"] ~env ~doc) 561 | 562 | let seed = 563 | let doc = "The seed used to generate random data." in 564 | let env = env_var "SEED" in 565 | Arg.(value & opt int 0 & info ["s"; "seed"] ~env ~doc) 566 | 567 | let metrics_flag = 568 | let doc = "Use Metrics; note that it has an impact on performance" in 569 | let env = env_var "WITH_METRICS" in 570 | Arg.(value & flag & info ["m"; "with-metrics"] ~env ~doc) 571 | 572 | let log_size = 573 | let doc = "The log size of the index." in 574 | let env = env_var "LOG_SIZE" in 575 | Arg.(value & opt int 500_000 & info ["log-size"] ~env ~doc) 576 | 577 | let nb_entries = 578 | let doc = "The number of bindings." in 579 | let env = env_var "NB_ENTRIES" in 580 | Arg.(value & opt int 1_000_000 & info ["nb-entries"] ~env ~doc) 581 | 582 | let list_cmd = 583 | let doc = "List all available benchmarks." in 584 | (Term.(pure list_benches $ const ()), Term.info "list" ~doc) 585 | 586 | let json_flag = 587 | let doc = "Output the results as a json object." in 588 | let env = env_var "JSON" in 589 | Arg.(value & flag & info ["j"; "json"] ~env ~doc) 590 | 591 | let sampling_interval = 592 | let doc = "Sampling interval for the duration of replace operations." in 593 | let env = env_var "REPLACE_DURATION_SAMPLING_INTERVAL" in 594 | Arg.(value & opt int 10 & info ["sampling-interval"] ~env ~doc) 595 | 596 | let minimal_flag = 597 | let doc = "Run a set of minimal benchmarks" in 598 | let env = env_var "MINIMAL" in 599 | Arg.(value & flag & info ["minimal"] ~env ~doc) 600 | 601 | let cmd = 602 | let doc = "Run all the benchmarks." in 603 | ( Term.( 604 | const run 605 | $ name_filter 606 | $ data_dir 607 | $ output 608 | $ seed 609 | $ metrics_flag 610 | $ log_size 611 | $ nb_entries 612 | $ json_flag 613 | $ sampling_interval 614 | $ minimal_flag), 615 | Term.info "run" ~doc ~exits:Term.default_exits ) 616 | 617 | let () = 618 | let choices = [list_cmd] in 619 | Term.(exit @@ eval_choice cmd choices) 620 | -------------------------------------------------------------------------------- /tests/wodan/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name bench) 3 | (modules bench) 4 | (preprocess 5 | (pps ppx_repr ppx_deriving_yojson)) 6 | (libraries wodan mirage-block mirage-block-unix io-page-unix metrics fmt lwt 7 | lwt.unix nocrypto.lwt metrics-unix yojson re cmdliner memtrace fmt.tty 8 | logs logs.fmt mtime mtime.clock.os)) 9 | 10 | (rule 11 | (alias runbench) 12 | (package wodan) 13 | (deps bench.exe) 14 | (action 15 | (run ./bench.exe))) 16 | -------------------------------------------------------------------------------- /wodan-irmin.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "g2p.code@gmail.com" 3 | authors: [ "Gabriel de Perthuis" ] 4 | homepage: "https://github.com/mirage/wodan" 5 | dev-repo: "git+https://github.com/mirage/wodan.git" 6 | bug-reports: "https://github.com/mirage/wodan/issues" 7 | name: "wodan-irmin" 8 | synopsis: "Wodan as an Irmin store" 9 | 10 | build: [ 11 | ["dune" "subst"] {pinned} 12 | [ 13 | "dune" 14 | "build" 15 | "-p" 16 | name 17 | "-j" 18 | jobs 19 | "@install" 20 | "@runtest" {with-test} 21 | "@doc" {with-doc} 22 | ] 23 | ] 24 | 25 | depends: [ 26 | "ocaml" 27 | "dune" {>= "2.3.0"} 28 | "alcotest" {with-test} 29 | "irmin-test" {with-test} 30 | "mirage-block-unix" {with-test} 31 | "checkseum" {>= "0.0.2"} 32 | "digestif" 33 | "io-page-unix" 34 | "irmin" {>= "2.4.0"} 35 | "irmin-chunk" 36 | "irmin-git" 37 | "irmin-unix" 38 | "lwt" 39 | "lwt_ppx" 40 | "mirage-block-ramdisk" 41 | "mirage-block-unix" 42 | "nocrypto" 43 | "wodan" 44 | ] 45 | 46 | tags: "org:mirage" 47 | pin-depends: [ 48 | ["mirage-block.dev" "git+https://github.com/g2p/mirage-block#e0d74f1a37cc543cff4588270b548fa488ce7210"] 49 | ["mirage-block-combinators.dev" "git+https://github.com/g2p/mirage-block#e0d74f1a37cc543cff4588270b548fa488ce7210"] 50 | ["mirage-block-unix.dev" "git+https://github.com/g2p/mirage-block-unix#c993fef086b645175e45bd6c991b1dbaa95db714"] 51 | ["mirage-block-ramdisk.dev" "git+https://github.com/g2p/mirage-block-ramdisk#b86f03c200f74138d9a0eab5f7e0b0cbf8a48294"] 52 | ] 53 | -------------------------------------------------------------------------------- /wodan-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "g2p.code@gmail.com" 3 | authors: [ "Gabriel de Perthuis" ] 4 | homepage: "https://github.com/mirage/wodan" 5 | dev-repo: "git+https://github.com/mirage/wodan.git" 6 | bug-reports: "https://github.com/mirage/wodan/issues" 7 | name: "wodan-unix" 8 | synopsis: "Wodan clients with Unix integration" 9 | 10 | build: [ 11 | ["dune" "subst"] {pinned} 12 | [ 13 | "dune" 14 | "build" 15 | "-p" 16 | name 17 | "-j" 18 | jobs 19 | "@install" 20 | "@runtest" {with-test} 21 | "@doc" {with-doc} 22 | ] 23 | ] 24 | 25 | depends: [ 26 | "ocaml" 27 | "dune" {>= "2.3.0"} 28 | "afl-persistent" 29 | "base64" {>= "3.0.0"} 30 | "benchmark" 31 | "cmdliner" 32 | "csv" 33 | "lwt_ppx" 34 | "mirage-block-ramdisk" 35 | "mirage-block-unix" 36 | "nocrypto" 37 | "wodan" 38 | ] 39 | 40 | tags: "org:mirage" 41 | pin-depends: [ 42 | ["mirage-block.dev" "git+https://github.com/g2p/mirage-block#e0d74f1a37cc543cff4588270b548fa488ce7210"] 43 | ["mirage-block-combinators.dev" "git+https://github.com/g2p/mirage-block#e0d74f1a37cc543cff4588270b548fa488ce7210"] 44 | ["mirage-block-unix.dev" "git+https://github.com/g2p/mirage-block-unix#c993fef086b645175e45bd6c991b1dbaa95db714"] 45 | ["mirage-block-ramdisk.dev" "git+https://github.com/g2p/mirage-block-ramdisk#b86f03c200f74138d9a0eab5f7e0b0cbf8a48294"] 46 | ] 47 | -------------------------------------------------------------------------------- /wodan.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "g2p.code@gmail.com" 3 | authors: [ "Gabriel de Perthuis" ] 4 | homepage: "https://github.com/mirage/wodan" 5 | dev-repo: "git+https://github.com/mirage/wodan.git" 6 | bug-reports: "https://github.com/mirage/wodan/issues" 7 | name: "wodan" 8 | synopsis: "A flash-friendly, safe and flexible filesystem library" 9 | 10 | build: [ 11 | ["dune" "subst"] {pinned} 12 | [ 13 | "dune" 14 | "build" 15 | "-p" 16 | name 17 | "-j" 18 | jobs 19 | "@install" 20 | "@runtest" {with-test} 21 | "@doc" {with-doc} 22 | ] 23 | ] 24 | 25 | depends: [ 26 | "ocaml" {>= "4.08.0"} 27 | "dune" {>= "1.7"} 28 | "bitv" 29 | "checkseum" {>= "0.0.2"} 30 | "cstruct" {>= "6.0.0"} 31 | "diet" {>= "0.4"} 32 | "fmt" {with-test} 33 | "io-page" 34 | "logs" 35 | "lru" {= "0.3.0"} 36 | "lwt" {>= "3.1.0"} 37 | "lwt_ppx" 38 | "metrics" 39 | "mirage-block" {>= "2.0.0"} 40 | "nocrypto" 41 | "odoc" {with-doc} 42 | "ppx_cstruct" 43 | "ppx_deriving_yojson" {with-test} 44 | ] 45 | 46 | pin-depends: [ 47 | ["mirage-block.dev" "git+https://github.com/g2p/mirage-block#e0d74f1a37cc543cff4588270b548fa488ce7210"] 48 | ["mirage-block-combinators.dev" "git+https://github.com/g2p/mirage-block#e0d74f1a37cc543cff4588270b548fa488ce7210"] 49 | ["mirage-block-unix.dev" "git+https://github.com/g2p/mirage-block-unix#c993fef086b645175e45bd6c991b1dbaa95db714"] 50 | ["mirage-block-ramdisk.dev" "git+https://github.com/g2p/mirage-block-ramdisk#b86f03c200f74138d9a0eab5f7e0b0cbf8a48294"] 51 | ] 52 | 53 | tags: "org:mirage" 54 | --------------------------------------------------------------------------------