├── .docgen.sh ├── .github └── workflows │ └── ocaml-ci.yml ├── .gitignore ├── .ocamlformat ├── .travis-docker-docgen.sh ├── ChangeLog ├── INSTALL.md ├── LICENSE ├── MAINTAINERS ├── Makefile ├── README.md ├── benchmark.sh ├── cli ├── common.ml ├── dune └── main.ml ├── cli_test ├── dune ├── random_data.sh ├── suite.ml ├── test-nbd-client.sh └── test-qemu.sh ├── dune-project ├── lib ├── channel.ml ├── channel.mli ├── client.ml ├── client.mli ├── dune ├── mirror.ml ├── mirror.mli ├── mux.ml ├── protocol.ml ├── protocol.mli ├── s.ml ├── server.ml └── server.mli ├── lib_test ├── client_server_test.ml ├── cstruct_block.ml ├── dune ├── mux_test.ml ├── protocol_test.ml └── suite.ml ├── nbd-tool.opam ├── nbd-unix.opam ├── nbd.opam └── unix ├── dune ├── nbd_unix.ml └── nbd_unix.mli /.docgen.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Make sure we're not echoing any sensitive data 4 | set +x 5 | 6 | set -e 7 | 8 | opam install -y jbuilder odoc 9 | make doc 10 | 11 | if [ -z "$TRAVIS" -o "$TRAVIS_PULL_REQUEST" != "false" -o "$TRAVIS_BRANCH" != "master" ]; then 12 | echo "This is not a push Travis-ci build on the master branch, doing nothing..." 13 | exit 0 14 | else 15 | echo "Updating docs on Github pages..." 16 | fi 17 | 18 | # Error out if $GH_TOKEN is empty or unset 19 | if [ -z "$GH_TOKEN" ]; then 20 | echo "GH_TOKEN not found" 21 | exit 1 22 | fi 23 | 24 | DOCDIR=.gh-pages 25 | if [ -n "$KEEP" ]; then trap "rm -rf $DOCDIR" EXIT; fi 26 | rm -rf $DOCDIR 27 | 28 | # Don't expose GH_TOKEN 29 | git clone --quiet --branch=gh-pages https://${GH_TOKEN}@github.com/xapi-project/nbd $DOCDIR > /dev/null 2>&1 30 | git -C $DOCDIR rm -rf . 31 | cp -r _build/default/_doc/_html/* $DOCDIR 32 | git -C $DOCDIR config user.email "travis@travis-ci.org" 33 | git -C $DOCDIR config user.name "Travis" 34 | (cd $DOCDIR; git add *) 35 | git -C $DOCDIR commit --allow-empty -am "Travis build $TRAVIS_BUILD_NUMBER pushed docs to gh-pages" 36 | # Don't expose GH_TOKEN 37 | git -C $DOCDIR push origin gh-pages > /dev/null 2>&1 38 | -------------------------------------------------------------------------------- /.github/workflows/ocaml-ci.yml: -------------------------------------------------------------------------------- 1 | name: Build and test 2 | 3 | on: 4 | push: 5 | pull_request: 6 | 7 | jobs: 8 | ocaml-test: 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | include: 13 | - ocaml-compiler: 4.08.1 14 | publish-docs: false 15 | - ocaml-compiler: 4.14.0 16 | publish-docs: true 17 | 18 | name: Ocaml tests 19 | runs-on: ubuntu-20.04 20 | 21 | steps: 22 | - name: Checkout code 23 | uses: actions/checkout@v2 24 | 25 | - name: Use ocaml 26 | uses: avsm/setup-ocaml@v2 27 | with: 28 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 29 | 30 | - name: Install dependencies 31 | run: opam install . --deps-only --with-test --with-doc -v 32 | 33 | - name: Build 34 | run: opam exec -- make build 35 | 36 | - name: Build Docs 37 | run: opam exec -- make doc 38 | 39 | - name: Run tests 40 | run: opam exec -- dune runtest --instrument-with bisect_ppx --force 41 | 42 | - run: opam exec -- bisect-ppx-report send-to Coveralls 43 | env: 44 | COVERALLS_REPO_TOKEN: ${{ secrets.GITHUB_TOKEN }} 45 | PULL_REQUEST_NUMBER: ${{ github.event.number }} 46 | 47 | - name: Deploy Docs 48 | uses: peaceiris/actions-gh-pages@v3 49 | if: ${{ github.event_name == 'push' && github.ref_name == 'master' && matrix.publish-docs == true }} 50 | with: 51 | github_token: ${{ secrets.GITHUB_TOKEN }} 52 | publish_dir: _build/default/_doc/_html/ 53 | publish_branch: gh-pages 54 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | .merlin 3 | *.install 4 | .*.swp 5 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile=ocamlformat 2 | indicate-multiline-delimiters=closing-on-separate-line 3 | if-then-else=fit-or-vertical 4 | dock-collection-brackets=true 5 | break-struct=natural 6 | break-separators=before 7 | break-infix=fit-or-vertical 8 | break-infix-before-func=false 9 | sequence-blank-line=preserve-one 10 | -------------------------------------------------------------------------------- /.travis-docker-docgen.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash +x 2 | 3 | # SUMMARY: 4 | # Runs .docgen.sh in the Docker container started by .travis-docker.sh in 5 | # addition to the usual tests run by that script, to upload documentation to 6 | # GitHub pages, taking care to avoid exposing $GH_TOKEN and to pass the 7 | # necessary environment variables into the container. 8 | 9 | # Make sure we're not echoing any sensitive data 10 | set +x 11 | 12 | set -e 13 | set -o pipefail 14 | 15 | # Make sure .travis-docker.sh is not echoing any sensitive data 16 | if [ -z "$GH_TOKEN" ]; then 17 | bash +x -e ./.travis-docker.sh 18 | else 19 | POST_INSTALL_HOOK="env TRAVIS=$TRAVIS TRAVIS_PULL_REQUEST=$TRAVIS_PULL_REQUEST TRAVIS_BRANCH=$TRAVIS_BRANCH TRAVIS_BUILD_NUMBER=$TRAVIS_BUILD_NUMBER GH_TOKEN=$GH_TOKEN make gh-pages" bash +x -e ./.travis-docker.sh |& sed -e "s/$GH_TOKEN/!REDACTED!/g" 20 | fi 21 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | # 6.0.1 (2022-09-16): 2 | * Require mirage-block 3.0.0, drop io-page-unix. 3 | 4 | # 6.0.0 (2022-08-19): 5 | * Use Stdlib's Result type 6 | * BREAKING: Avoid unerasable optional arguments in init_tls_get_ctx 7 | * Update for cmdliner 1.1.0 compatibility 8 | * Update for cstruct 6.1.0 compatibility 9 | * ci: fix doc upload and coverage reporting 10 | 11 | # 5.0.0 (2021-05-19): 12 | * lib_test: make sure mux tests are run 13 | * nbd-unix: rename package nbd-lwt-unix 14 | * Update to mirage-block 2.0.0 15 | * maintenance: format code using ocamlformat 16 | * ci: remove travis ci and use github actions 17 | * ci: deploy docs for commits in master branch 18 | * CP-27269: enable code coverage 19 | 20 | # 4.0.3 (2020-12-11): 21 | * Fix opam files 22 | * Add support for cstruct 3.4.0 23 | 24 | # 4.0.2 (2020-07-10): 25 | * maintenance: update travis.yml 26 | * maintenance: upgrade alcotest to 1.1.0 27 | 28 | # 4.0.1 (2020-04-02): 29 | * CP-33058 force cipherstring parameter 30 | 31 | # 4.0.0+beta3 (2019-01-15): 32 | * CA-307773: initialize EC curves 33 | * Update urls in opam files to point to new version 34 | 35 | # 4.0.0+beta2 (2018-12-04): 36 | ## Added 37 | * CLI: Add exportname option to serve command 38 | * Server: Add benchmark.sh script for benchmarking 39 | * Enable coverage & coveralls 40 | * Add client<->server interop. unit tests 41 | * Add interop. test with qemu-img and nbd-client 42 | * Add stress test to test that misbehaving clients do not crash the server 43 | 44 | ## Changed 45 | * Make it compatible with Lwt 4 46 | * Convert tests to Alcotest 47 | * Update opam files for Opam 2 48 | * CP-29049: Move from jbuilder to dune 49 | 50 | ## Fixed 51 | * Client: CA-289145: close socket if error occurs when using lwt connect 52 | * Client & server: CP-29049: Fix list and abort behaviour 53 | 54 | # 4.0.0+beta1 (2017-12-08): 55 | ## Added 56 | * Server: CP-22631: TLS support 57 | * Server: support for read-only exports 58 | * Server: use dedicated exception for NBD_OPT_ABORT 59 | * Added `Server.with_connection`, `Nbd_lwt_unix.with_channel`, 60 | `Nbd_lwt_unix.with_block` functions 61 | 62 | ## Changed 63 | * Rename nbd-lwt to nbd-lwt-unix (opam package & ocamlfind library) 64 | * Rename lib/s.mli to lib/s.ml 65 | * Server: Use Lwt_log for and enhance logging 66 | * Port to jbuilder 67 | * Reorganize tests 68 | 69 | ## Removed 70 | * Mux: hide internal values and types behind signature 71 | * Delete obsolete nbd_test.ml 72 | * Remove unix/ folder, not compiled since a couple of years 73 | * Fix marshalling & unmarshalling of client flags 74 | 75 | ## Fixed 76 | * Server: handle NBD_CMD_DISC correctly instead of returning EINVAL 77 | * Server: set SO_REUSEADDR on the server socket 78 | * Server: don't stop when handling one client fails 79 | * Server: don't stop after write command 80 | * CLI: close the open file descriptors 81 | 82 | # 3.0.0 (2017-02-15): 83 | * Update to Mirage 3 APIs 84 | * Requires OCaml 4.03+ 85 | 86 | # 2.1.3 (2017-02-14): 87 | * Fix a memory leak in the dispatcher 88 | 89 | # 2.1.2 (2017-01-25): 90 | * Expose page_aligned_buffer as a Cstruct.t 91 | 92 | # 2.1.1 (2016-11-24): 93 | * opam: add dependency on ppx_sexp_conv 94 | * rename module Result to Nbd_result to avoid clashing with lwt 2.6.0 95 | 96 | # 2.1.0 (2016-05-12): 97 | * Uses cstruct.ppx rather than cstruct.syntax 98 | 99 | # 2.0.1 (2016-01-14): 100 | * fix an inexhaustive match exception if the server sends an unexpected 101 | response 102 | 103 | # 2.0.0 (13-Jan-2016): 104 | * New Mirage-style (i.e. Cstruct/Io_page-based) API 105 | * Support for v2 of the NBD protocol (i.e. multiple disks over the same port) 106 | * Preliminary support for disk mirroring 107 | * CLI tool to query the size of remote disks 108 | * travis: add lots of v1/v2 unit tests 109 | * travis: add code coverage testing via coveralls.io 110 | * travis: generate and upload API documentation 111 | 112 | # 1.0.1 (30-Jan-2014): 113 | * Switch to a polymorphic variant type for results 114 | * Include modules missing from 1.0.0 115 | 116 | # 1.0.0 (30-Jan-2014): 117 | * Switch build to OASIS. 118 | 119 | # 0.9.1 (23-Sep-2013): 120 | * switch to using out-of-heap bigarrays for data payloads 121 | * removed the plain-old-unix support 122 | * added support for writing NBD servers 123 | * removed plain-old-unix in favour of Lwt 124 | 125 | # 0.9.0 (29-May-2013): 126 | * first public release 127 | 128 | -------------------------------------------------------------------------------- /INSTALL.md: -------------------------------------------------------------------------------- 1 | The easiest way to fetch the dependencies and build is to use 2 | [opam](https://opam.ocaml.org/). 3 | 4 | To install the latest stable version: 5 | ``` 6 | opam install nbd 7 | ``` 8 | 9 | To install the latest unstable development version: 10 | ``` 11 | git clone git://github.com/xapi-project/nbd 12 | cd nbd 13 | opam pin add nbd . 14 | ``` 15 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This repository is distributed under the terms of the GNU Lesser General 2 | Public License version 2.1 (included below). 3 | 4 | As a special exception to the GNU Lesser General Public License, you 5 | may link, statically or dynamically, a "work that uses the Library" 6 | with a publicly distributed version of the Library to produce an 7 | executable file containing portions of the Library, and distribute 8 | that executable file under terms of your choice, without any of the 9 | additional requirements listed in clause 6 of the GNU Lesser General 10 | Public License. By "a publicly distributed version of the Library", 11 | we mean either the unmodified Library as distributed, or a 12 | modified version of the Library that is distributed under the 13 | conditions defined in clause 3 of the GNU Library General Public 14 | License. This exception does not however invalidate any other reasons 15 | why the executable file might be covered by the GNU Lesser General 16 | Public License. 17 | 18 | ------------ 19 | 20 | GNU LESSER GENERAL PUBLIC LICENSE 21 | Version 2.1, February 1999 22 | 23 | Copyright (C) 1991, 1999 Free Software Foundation, Inc. 24 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 25 | Everyone is permitted to copy and distribute verbatim copies 26 | of this license document, but changing it is not allowed. 27 | 28 | [This is the first released version of the Lesser GPL. It also counts 29 | as the successor of the GNU Library Public License, version 2, hence 30 | the version number 2.1.] 31 | 32 | Preamble 33 | 34 | The licenses for most software are designed to take away your 35 | freedom to share and change it. By contrast, the GNU General Public 36 | Licenses are intended to guarantee your freedom to share and change 37 | free software--to make sure the software is free for all its users. 38 | 39 | This license, the Lesser General Public License, applies to some 40 | specially designated software packages--typically libraries--of the 41 | Free Software Foundation and other authors who decide to use it. You 42 | can use it too, but we suggest you first think carefully about whether 43 | this license or the ordinary General Public License is the better 44 | strategy to use in any particular case, based on the explanations below. 45 | 46 | When we speak of free software, we are referring to freedom of use, 47 | not price. Our General Public Licenses are designed to make sure that 48 | you have the freedom to distribute copies of free software (and charge 49 | for this service if you wish); that you receive source code or can get 50 | it if you want it; that you can change the software and use pieces of 51 | it in new free programs; and that you are informed that you can do 52 | these things. 53 | 54 | To protect your rights, we need to make restrictions that forbid 55 | distributors to deny you these rights or to ask you to surrender these 56 | rights. These restrictions translate to certain responsibilities for 57 | you if you distribute copies of the library or if you modify it. 58 | 59 | For example, if you distribute copies of the library, whether gratis 60 | or for a fee, you must give the recipients all the rights that we gave 61 | you. You must make sure that they, too, receive or can get the source 62 | code. If you link other code with the library, you must provide 63 | complete object files to the recipients, so that they can relink them 64 | with the library after making changes to the library and recompiling 65 | it. And you must show them these terms so they know their rights. 66 | 67 | We protect your rights with a two-step method: (1) we copyright the 68 | library, and (2) we offer you this license, which gives you legal 69 | permission to copy, distribute and/or modify the library. 70 | 71 | To protect each distributor, we want to make it very clear that 72 | there is no warranty for the free library. Also, if the library is 73 | modified by someone else and passed on, the recipients should know 74 | that what they have is not the original version, so that the original 75 | author's reputation will not be affected by problems that might be 76 | introduced by others. 77 | 78 | Finally, software patents pose a constant threat to the existence of 79 | any free program. We wish to make sure that a company cannot 80 | effectively restrict the users of a free program by obtaining a 81 | restrictive license from a patent holder. Therefore, we insist that 82 | any patent license obtained for a version of the library must be 83 | consistent with the full freedom of use specified in this license. 84 | 85 | Most GNU software, including some libraries, is covered by the 86 | ordinary GNU General Public License. This license, the GNU Lesser 87 | General Public License, applies to certain designated libraries, and 88 | is quite different from the ordinary General Public License. We use 89 | this license for certain libraries in order to permit linking those 90 | libraries into non-free programs. 91 | 92 | When a program is linked with a library, whether statically or using 93 | a shared library, the combination of the two is legally speaking a 94 | combined work, a derivative of the original library. The ordinary 95 | General Public License therefore permits such linking only if the 96 | entire combination fits its criteria of freedom. The Lesser General 97 | Public License permits more lax criteria for linking other code with 98 | the library. 99 | 100 | We call this license the "Lesser" General Public License because it 101 | does Less to protect the user's freedom than the ordinary General 102 | Public License. It also provides other free software developers Less 103 | of an advantage over competing non-free programs. These disadvantages 104 | are the reason we use the ordinary General Public License for many 105 | libraries. However, the Lesser license provides advantages in certain 106 | special circumstances. 107 | 108 | For example, on rare occasions, there may be a special need to 109 | encourage the widest possible use of a certain library, so that it becomes 110 | a de-facto standard. To achieve this, non-free programs must be 111 | allowed to use the library. A more frequent case is that a free 112 | library does the same job as widely used non-free libraries. In this 113 | case, there is little to gain by limiting the free library to free 114 | software only, so we use the Lesser General Public License. 115 | 116 | In other cases, permission to use a particular library in non-free 117 | programs enables a greater number of people to use a large body of 118 | free software. For example, permission to use the GNU C Library in 119 | non-free programs enables many more people to use the whole GNU 120 | operating system, as well as its variant, the GNU/Linux operating 121 | system. 122 | 123 | Although the Lesser General Public License is Less protective of the 124 | users' freedom, it does ensure that the user of a program that is 125 | linked with the Library has the freedom and the wherewithal to run 126 | that program using a modified version of the Library. 127 | 128 | The precise terms and conditions for copying, distribution and 129 | modification follow. Pay close attention to the difference between a 130 | "work based on the library" and a "work that uses the library". The 131 | former contains code derived from the library, whereas the latter must 132 | be combined with the library in order to run. 133 | 134 | GNU LESSER GENERAL PUBLIC LICENSE 135 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 136 | 137 | 0. This License Agreement applies to any software library or other 138 | program which contains a notice placed by the copyright holder or 139 | other authorized party saying it may be distributed under the terms of 140 | this Lesser General Public License (also called "this License"). 141 | Each licensee is addressed as "you". 142 | 143 | A "library" means a collection of software functions and/or data 144 | prepared so as to be conveniently linked with application programs 145 | (which use some of those functions and data) to form executables. 146 | 147 | The "Library", below, refers to any such software library or work 148 | which has been distributed under these terms. A "work based on the 149 | Library" means either the Library or any derivative work under 150 | copyright law: that is to say, a work containing the Library or a 151 | portion of it, either verbatim or with modifications and/or translated 152 | straightforwardly into another language. (Hereinafter, translation is 153 | included without limitation in the term "modification".) 154 | 155 | "Source code" for a work means the preferred form of the work for 156 | making modifications to it. For a library, complete source code means 157 | all the source code for all modules it contains, plus any associated 158 | interface definition files, plus the scripts used to control compilation 159 | and installation of the library. 160 | 161 | Activities other than copying, distribution and modification are not 162 | covered by this License; they are outside its scope. The act of 163 | running a program using the Library is not restricted, and output from 164 | such a program is covered only if its contents constitute a work based 165 | on the Library (independent of the use of the Library in a tool for 166 | writing it). Whether that is true depends on what the Library does 167 | and what the program that uses the Library does. 168 | 169 | 1. You may copy and distribute verbatim copies of the Library's 170 | complete source code as you receive it, in any medium, provided that 171 | you conspicuously and appropriately publish on each copy an 172 | appropriate copyright notice and disclaimer of warranty; keep intact 173 | all the notices that refer to this License and to the absence of any 174 | warranty; and distribute a copy of this License along with the 175 | Library. 176 | 177 | You may charge a fee for the physical act of transferring a copy, 178 | and you may at your option offer warranty protection in exchange for a 179 | fee. 180 | 181 | 2. You may modify your copy or copies of the Library or any portion 182 | of it, thus forming a work based on the Library, and copy and 183 | distribute such modifications or work under the terms of Section 1 184 | above, provided that you also meet all of these conditions: 185 | 186 | a) The modified work must itself be a software library. 187 | 188 | b) You must cause the files modified to carry prominent notices 189 | stating that you changed the files and the date of any change. 190 | 191 | c) You must cause the whole of the work to be licensed at no 192 | charge to all third parties under the terms of this License. 193 | 194 | d) If a facility in the modified Library refers to a function or a 195 | table of data to be supplied by an application program that uses 196 | the facility, other than as an argument passed when the facility 197 | is invoked, then you must make a good faith effort to ensure that, 198 | in the event an application does not supply such function or 199 | table, the facility still operates, and performs whatever part of 200 | its purpose remains meaningful. 201 | 202 | (For example, a function in a library to compute square roots has 203 | a purpose that is entirely well-defined independent of the 204 | application. Therefore, Subsection 2d requires that any 205 | application-supplied function or table used by this function must 206 | be optional: if the application does not supply it, the square 207 | root function must still compute square roots.) 208 | 209 | These requirements apply to the modified work as a whole. If 210 | identifiable sections of that work are not derived from the Library, 211 | and can be reasonably considered independent and separate works in 212 | themselves, then this License, and its terms, do not apply to those 213 | sections when you distribute them as separate works. But when you 214 | distribute the same sections as part of a whole which is a work based 215 | on the Library, the distribution of the whole must be on the terms of 216 | this License, whose permissions for other licensees extend to the 217 | entire whole, and thus to each and every part regardless of who wrote 218 | it. 219 | 220 | Thus, it is not the intent of this section to claim rights or contest 221 | your rights to work written entirely by you; rather, the intent is to 222 | exercise the right to control the distribution of derivative or 223 | collective works based on the Library. 224 | 225 | In addition, mere aggregation of another work not based on the Library 226 | with the Library (or with a work based on the Library) on a volume of 227 | a storage or distribution medium does not bring the other work under 228 | the scope of this License. 229 | 230 | 3. You may opt to apply the terms of the ordinary GNU General Public 231 | License instead of this License to a given copy of the Library. To do 232 | this, you must alter all the notices that refer to this License, so 233 | that they refer to the ordinary GNU General Public License, version 2, 234 | instead of to this License. (If a newer version than version 2 of the 235 | ordinary GNU General Public License has appeared, then you can specify 236 | that version instead if you wish.) Do not make any other change in 237 | these notices. 238 | 239 | Once this change is made in a given copy, it is irreversible for 240 | that copy, so the ordinary GNU General Public License applies to all 241 | subsequent copies and derivative works made from that copy. 242 | 243 | This option is useful when you wish to copy part of the code of 244 | the Library into a program that is not a library. 245 | 246 | 4. You may copy and distribute the Library (or a portion or 247 | derivative of it, under Section 2) in object code or executable form 248 | under the terms of Sections 1 and 2 above provided that you accompany 249 | it with the complete corresponding machine-readable source code, which 250 | must be distributed under the terms of Sections 1 and 2 above on a 251 | medium customarily used for software interchange. 252 | 253 | If distribution of object code is made by offering access to copy 254 | from a designated place, then offering equivalent access to copy the 255 | source code from the same place satisfies the requirement to 256 | distribute the source code, even though third parties are not 257 | compelled to copy the source along with the object code. 258 | 259 | 5. A program that contains no derivative of any portion of the 260 | Library, but is designed to work with the Library by being compiled or 261 | linked with it, is called a "work that uses the Library". Such a 262 | work, in isolation, is not a derivative work of the Library, and 263 | therefore falls outside the scope of this License. 264 | 265 | However, linking a "work that uses the Library" with the Library 266 | creates an executable that is a derivative of the Library (because it 267 | contains portions of the Library), rather than a "work that uses the 268 | library". The executable is therefore covered by this License. 269 | Section 6 states terms for distribution of such executables. 270 | 271 | When a "work that uses the Library" uses material from a header file 272 | that is part of the Library, the object code for the work may be a 273 | derivative work of the Library even though the source code is not. 274 | Whether this is true is especially significant if the work can be 275 | linked without the Library, or if the work is itself a library. The 276 | threshold for this to be true is not precisely defined by law. 277 | 278 | If such an object file uses only numerical parameters, data 279 | structure layouts and accessors, and small macros and small inline 280 | functions (ten lines or less in length), then the use of the object 281 | file is unrestricted, regardless of whether it is legally a derivative 282 | work. (Executables containing this object code plus portions of the 283 | Library will still fall under Section 6.) 284 | 285 | Otherwise, if the work is a derivative of the Library, you may 286 | distribute the object code for the work under the terms of Section 6. 287 | Any executables containing that work also fall under Section 6, 288 | whether or not they are linked directly with the Library itself. 289 | 290 | 6. As an exception to the Sections above, you may also combine or 291 | link a "work that uses the Library" with the Library to produce a 292 | work containing portions of the Library, and distribute that work 293 | under terms of your choice, provided that the terms permit 294 | modification of the work for the customer's own use and reverse 295 | engineering for debugging such modifications. 296 | 297 | You must give prominent notice with each copy of the work that the 298 | Library is used in it and that the Library and its use are covered by 299 | this License. You must supply a copy of this License. If the work 300 | during execution displays copyright notices, you must include the 301 | copyright notice for the Library among them, as well as a reference 302 | directing the user to the copy of this License. Also, you must do one 303 | of these things: 304 | 305 | a) Accompany the work with the complete corresponding 306 | machine-readable source code for the Library including whatever 307 | changes were used in the work (which must be distributed under 308 | Sections 1 and 2 above); and, if the work is an executable linked 309 | with the Library, with the complete machine-readable "work that 310 | uses the Library", as object code and/or source code, so that the 311 | user can modify the Library and then relink to produce a modified 312 | executable containing the modified Library. (It is understood 313 | that the user who changes the contents of definitions files in the 314 | Library will not necessarily be able to recompile the application 315 | to use the modified definitions.) 316 | 317 | b) Use a suitable shared library mechanism for linking with the 318 | Library. A suitable mechanism is one that (1) uses at run time a 319 | copy of the library already present on the user's computer system, 320 | rather than copying library functions into the executable, and (2) 321 | will operate properly with a modified version of the library, if 322 | the user installs one, as long as the modified version is 323 | interface-compatible with the version that the work was made with. 324 | 325 | c) Accompany the work with a written offer, valid for at 326 | least three years, to give the same user the materials 327 | specified in Subsection 6a, above, for a charge no more 328 | than the cost of performing this distribution. 329 | 330 | d) If distribution of the work is made by offering access to copy 331 | from a designated place, offer equivalent access to copy the above 332 | specified materials from the same place. 333 | 334 | e) Verify that the user has already received a copy of these 335 | materials or that you have already sent this user a copy. 336 | 337 | For an executable, the required form of the "work that uses the 338 | Library" must include any data and utility programs needed for 339 | reproducing the executable from it. However, as a special exception, 340 | the materials to be distributed need not include anything that is 341 | normally distributed (in either source or binary form) with the major 342 | components (compiler, kernel, and so on) of the operating system on 343 | which the executable runs, unless that component itself accompanies 344 | the executable. 345 | 346 | It may happen that this requirement contradicts the license 347 | restrictions of other proprietary libraries that do not normally 348 | accompany the operating system. Such a contradiction means you cannot 349 | use both them and the Library together in an executable that you 350 | distribute. 351 | 352 | 7. You may place library facilities that are a work based on the 353 | Library side-by-side in a single library together with other library 354 | facilities not covered by this License, and distribute such a combined 355 | library, provided that the separate distribution of the work based on 356 | the Library and of the other library facilities is otherwise 357 | permitted, and provided that you do these two things: 358 | 359 | a) Accompany the combined library with a copy of the same work 360 | based on the Library, uncombined with any other library 361 | facilities. This must be distributed under the terms of the 362 | Sections above. 363 | 364 | b) Give prominent notice with the combined library of the fact 365 | that part of it is a work based on the Library, and explaining 366 | where to find the accompanying uncombined form of the same work. 367 | 368 | 8. You may not copy, modify, sublicense, link with, or distribute 369 | the Library except as expressly provided under this License. Any 370 | attempt otherwise to copy, modify, sublicense, link with, or 371 | distribute the Library is void, and will automatically terminate your 372 | rights under this License. However, parties who have received copies, 373 | or rights, from you under this License will not have their licenses 374 | terminated so long as such parties remain in full compliance. 375 | 376 | 9. You are not required to accept this License, since you have not 377 | signed it. However, nothing else grants you permission to modify or 378 | distribute the Library or its derivative works. These actions are 379 | prohibited by law if you do not accept this License. Therefore, by 380 | modifying or distributing the Library (or any work based on the 381 | Library), you indicate your acceptance of this License to do so, and 382 | all its terms and conditions for copying, distributing or modifying 383 | the Library or works based on it. 384 | 385 | 10. Each time you redistribute the Library (or any work based on the 386 | Library), the recipient automatically receives a license from the 387 | original licensor to copy, distribute, link with or modify the Library 388 | subject to these terms and conditions. You may not impose any further 389 | restrictions on the recipients' exercise of the rights granted herein. 390 | You are not responsible for enforcing compliance by third parties with 391 | this License. 392 | 393 | 11. If, as a consequence of a court judgment or allegation of patent 394 | infringement or for any other reason (not limited to patent issues), 395 | conditions are imposed on you (whether by court order, agreement or 396 | otherwise) that contradict the conditions of this License, they do not 397 | excuse you from the conditions of this License. If you cannot 398 | distribute so as to satisfy simultaneously your obligations under this 399 | License and any other pertinent obligations, then as a consequence you 400 | may not distribute the Library at all. For example, if a patent 401 | license would not permit royalty-free redistribution of the Library by 402 | all those who receive copies directly or indirectly through you, then 403 | the only way you could satisfy both it and this License would be to 404 | refrain entirely from distribution of the Library. 405 | 406 | If any portion of this section is held invalid or unenforceable under any 407 | particular circumstance, the balance of the section is intended to apply, 408 | and the section as a whole is intended to apply in other circumstances. 409 | 410 | It is not the purpose of this section to induce you to infringe any 411 | patents or other property right claims or to contest validity of any 412 | such claims; this section has the sole purpose of protecting the 413 | integrity of the free software distribution system which is 414 | implemented by public license practices. Many people have made 415 | generous contributions to the wide range of software distributed 416 | through that system in reliance on consistent application of that 417 | system; it is up to the author/donor to decide if he or she is willing 418 | to distribute software through any other system and a licensee cannot 419 | impose that choice. 420 | 421 | This section is intended to make thoroughly clear what is believed to 422 | be a consequence of the rest of this License. 423 | 424 | 12. If the distribution and/or use of the Library is restricted in 425 | certain countries either by patents or by copyrighted interfaces, the 426 | original copyright holder who places the Library under this License may add 427 | an explicit geographical distribution limitation excluding those countries, 428 | so that distribution is permitted only in or among countries not thus 429 | excluded. In such case, this License incorporates the limitation as if 430 | written in the body of this License. 431 | 432 | 13. The Free Software Foundation may publish revised and/or new 433 | versions of the Lesser General Public License from time to time. 434 | Such new versions will be similar in spirit to the present version, 435 | but may differ in detail to address new problems or concerns. 436 | 437 | Each version is given a distinguishing version number. If the Library 438 | specifies a version number of this License which applies to it and 439 | "any later version", you have the option of following the terms and 440 | conditions either of that version or of any later version published by 441 | the Free Software Foundation. If the Library does not specify a 442 | license version number, you may choose any version ever published by 443 | the Free Software Foundation. 444 | 445 | 14. If you wish to incorporate parts of the Library into other free 446 | programs whose distribution conditions are incompatible with these, 447 | write to the author to ask for permission. For software which is 448 | copyrighted by the Free Software Foundation, write to the Free 449 | Software Foundation; we sometimes make exceptions for this. Our 450 | decision will be guided by the two goals of preserving the free status 451 | of all derivatives of our free software and of promoting the sharing 452 | and reuse of software generally. 453 | 454 | NO WARRANTY 455 | 456 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 457 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 458 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 459 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 460 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 461 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 462 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 463 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 464 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 465 | 466 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 467 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 468 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 469 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 470 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 471 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 472 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 473 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 474 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 475 | DAMAGES. 476 | 477 | END OF TERMS AND CONDITIONS 478 | 479 | How to Apply These Terms to Your New Libraries 480 | 481 | If you develop a new library, and you want it to be of the greatest 482 | possible use to the public, we recommend making it free software that 483 | everyone can redistribute and change. You can do so by permitting 484 | redistribution under these terms (or, alternatively, under the terms of the 485 | ordinary General Public License). 486 | 487 | To apply these terms, attach the following notices to the library. It is 488 | safest to attach them to the start of each source file to most effectively 489 | convey the exclusion of warranty; and each file should have at least the 490 | "copyright" line and a pointer to where the full notice is found. 491 | 492 | 493 | Copyright (C) 494 | 495 | This library is free software; you can redistribute it and/or 496 | modify it under the terms of the GNU Lesser General Public 497 | License as published by the Free Software Foundation; either 498 | version 2.1 of the License, or (at your option) any later version. 499 | 500 | This library is distributed in the hope that it will be useful, 501 | but WITHOUT ANY WARRANTY; without even the implied warranty of 502 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 503 | Lesser General Public License for more details. 504 | 505 | You should have received a copy of the GNU Lesser General Public 506 | License along with this library; if not, write to the Free Software 507 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 508 | 509 | Also add information on how to contact you by electronic and paper mail. 510 | 511 | You should also get your employer (if you work as a programmer) or your 512 | school, if any, to sign a "copyright disclaimer" for the library, if 513 | necessary. Here is a sample; alter the names: 514 | 515 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 516 | library `Frob' (a library for tweaking knobs) written by James Random Hacker. 517 | 518 | , 1 April 1990 519 | Ty Coon, President of Vice 520 | 521 | That's all there is to it! 522 | -------------------------------------------------------------------------------- /MAINTAINERS: -------------------------------------------------------------------------------- 1 | How to submit changes to this project 2 | ===================================== 3 | 4 | Please submit changes as pull requests to the repository on github. 5 | Please ensure that all changes have descriptive commit comments and 6 | include a Signed-off-by: line. 7 | 8 | Maintainers list 9 | ---------------- 10 | 11 | * Jonathan Ludlam 12 | * David Scott 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build release install uninstall clean test doc reindent 2 | 3 | build: 4 | dune build @install 5 | 6 | release: 7 | dune build --profile release @install 8 | 9 | install: 10 | dune install 11 | 12 | uninstall: 13 | dune uninstall 14 | 15 | clean: 16 | dune clean 17 | 18 | test: 19 | dune runtest 20 | 21 | # requires qemu-img 22 | benchmark: build 23 | ./benchmark.sh 24 | 25 | # requires odoc 26 | doc: 27 | dune build @doc 28 | 29 | gh-pages: 30 | bash .docgen.sh 31 | 32 | format: 33 | dune build @fmt --auto-promote 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Network Block Device 2 | ==================== 3 | 4 | [![Coverage Status](https://coveralls.io/repos/xapi-project/nbd/badge.svg?branch=master)](https://coveralls.io/r/xapi-project/nbd?branch=master) 5 | 6 | A pure OCaml implementation of the [Network Block 7 | Device](http://en.wikipedia.org/wiki/Network_block_device) protocol, which is a 8 | client/server protocol for accessing block devices. 9 | 10 | This repository provides the following OPAM packages: 11 | 12 | * `nbd` : core protocol parsing library 13 | * `nbd-unix` : `Lwt_unix` implementation 14 | * `nbd-tool`: command line helper for serving and mirroring disks over NBD, and 15 | getting information about the disks exported by an NBD server 16 | 17 | Each of these OPAM packages installs an ocamlfind library with the same name as 18 | the OPAM package. 19 | 20 | Documentation 21 | ------------- 22 | 23 | The [API documentation is on github](https://xapi-project.github.io/nbd/index.html). 24 | -------------------------------------------------------------------------------- /benchmark.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Run this script to benchmark the NBD server using qemu-img. 4 | 5 | set -eux 6 | 7 | dd if=/dev/zero of=/tmp/test bs=1M count=100 8 | _build/default/cli/main.exe serve --exportname test --no-tls /tmp/test & 9 | SERVER_PROCESS=$! 10 | # Wait for the server to start the main loop 11 | sleep 0.1 12 | 13 | stop_server() { 14 | kill -9 $SERVER_PROCESS 15 | } 16 | trap stop_server EXIT 17 | 18 | qemu-img bench 'nbd:0.0.0.0:10809:exportname=test' 19 | -------------------------------------------------------------------------------- /cli/common.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2011-2013 Citrix Inc 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | type t = {debug: bool; verb: bool} 16 | 17 | let make debug verb = {debug; verb} 18 | -------------------------------------------------------------------------------- /cli/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (modes byte exe) 3 | (name main) 4 | (public_name nbd-tool) 5 | (package nbd-tool) 6 | (libraries 7 | cmdliner 8 | fmt 9 | lwt 10 | lwt.unix 11 | lwt_log 12 | mirage-block 13 | mirage-block-unix 14 | nbd 15 | nbd-unix 16 | ssl 17 | uri)) 18 | -------------------------------------------------------------------------------- /cli/main.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2011-2015 Citrix Inc 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | let project_url = "http://github.com/xapi-project/nbd" 16 | 17 | open Lwt.Infix 18 | 19 | module Device = struct 20 | type id = [`Nbd of Uri.t | `Local of string] 21 | 22 | type t = [`Nbd of Nbd_unix.Client.t | `Local of Block.t] 23 | 24 | type error = [Mirage_block.error | `Protocol_error of Nbd.Protocol.Error.t] 25 | 26 | type write_error = 27 | [Mirage_block.write_error | `Protocol_error of Nbd.Protocol.Error.t] 28 | 29 | let pp_error ppf = function 30 | | #Mirage_block.error as e -> 31 | Mirage_block.pp_error ppf e 32 | | `Protocol_error e -> 33 | Fmt.string ppf (Nbd.Protocol.Error.to_string e) 34 | 35 | let pp_write_error ppf = function 36 | | #Mirage_block.write_error as e -> 37 | Mirage_block.pp_write_error ppf e 38 | | `Protocol_error e -> 39 | Fmt.string ppf (Nbd.Protocol.Error.to_string e) 40 | 41 | let connect uri = 42 | match Uri.scheme uri with 43 | | Some "file" -> 44 | let path = Uri.path uri in 45 | Block.connect path >|= fun x -> `Local x 46 | | Some "nbd" -> ( 47 | match Uri.host uri with 48 | | Some host -> 49 | let port = match Uri.port uri with None -> 10809 | Some x -> x in 50 | Nbd_unix.connect host port >>= fun channel -> 51 | Nbd_unix.Client.negotiate channel (Uri.to_string uri) 52 | >>= fun (t, _, _) -> Lwt.return (`Nbd t) 53 | | None -> 54 | Lwt.fail_with "Cannot connect to nbd without a host" 55 | ) 56 | | _ -> 57 | Lwt.fail_with "unknown scheme" 58 | 59 | type info = {read_write: bool; sector_size: int; size_sectors: int64} 60 | 61 | let get_info = function 62 | | `Nbd t -> 63 | Nbd_unix.Client.get_info t 64 | | `Local t -> 65 | Block.get_info t 66 | 67 | let read t off bufs = 68 | match t with 69 | | `Nbd t -> 70 | Nbd_unix.Client.read t off bufs 71 | | `Local t -> ( 72 | Block.read t off bufs >>= function 73 | | Result.Error `Disconnected -> 74 | Lwt.return_error `Disconnected 75 | | Result.Error _ -> 76 | Lwt.return_error `Disconnected 77 | | Result.Ok x -> 78 | Lwt.return_ok x 79 | ) 80 | 81 | let write t off bufs = 82 | match t with 83 | | `Nbd t -> 84 | Nbd_unix.Client.write t off bufs 85 | | `Local t -> ( 86 | Block.write t off bufs >>= function 87 | | Result.Error `Disconnected -> 88 | Lwt.return_error `Disconnected 89 | | Result.Error `Is_read_only -> 90 | Lwt.return_error `Is_read_only 91 | | Result.Error _ -> 92 | Lwt.return_error `Disconnected 93 | | Result.Ok x -> 94 | Lwt.return_ok x 95 | ) 96 | 97 | let disconnect t = 98 | match t with 99 | | `Nbd t -> 100 | Nbd_unix.Client.disconnect t 101 | | `Local t -> 102 | Block.disconnect t 103 | end 104 | 105 | open Cmdliner 106 | 107 | (* Help sections common to all commands *) 108 | 109 | let common_options = "COMMON OPTIONS" 110 | 111 | let help = 112 | [ 113 | `S common_options 114 | ; `P "These options are common to all commands." 115 | ; `S "MORE HELP" 116 | ; `P "Use `$(mname) $(i,COMMAND) --help' for help on a single command." 117 | ; `Noblank 118 | ; `S "BUGS" 119 | ; `P (Printf.sprintf "Check bug reports at %s" project_url) 120 | ] 121 | 122 | (* Options common to all commands *) 123 | let common_options_t = 124 | let docs = common_options in 125 | let debug = 126 | let doc = "Give only debug output." in 127 | Arg.(value & flag & info ["debug"] ~docs ~doc) 128 | in 129 | let verb = 130 | let doc = "Give verbose output." in 131 | let verbose = (true, Arg.info ["v"; "verbose"] ~docs ~doc) in 132 | Arg.(last & vflag_all [false] [verbose]) 133 | in 134 | Term.(const Common.make $ debug $ verb) 135 | 136 | module Impl = struct 137 | open Nbd 138 | 139 | let require name arg = 140 | match arg with 141 | | None -> 142 | failwith (Printf.sprintf "Please supply a %s argument" name) 143 | | Some x -> 144 | x 145 | 146 | let require_str name arg = require name (if arg = "" then None else Some arg) 147 | 148 | let size host port export = 149 | let res = 150 | Nbd_unix.connect host port >>= fun client -> 151 | Client.negotiate client export 152 | in 153 | let _, size, _ = Lwt_main.run res in 154 | Printf.printf "%Ld\n%!" size ; 155 | `Ok () 156 | 157 | let list _common host port = 158 | let t = 159 | Nbd_unix.connect host port >>= fun channel -> 160 | Client.list channel >>= function 161 | | Result.Ok disks -> 162 | List.iter print_endline disks ; 163 | Lwt.return () 164 | | Result.Error `Unsupported -> 165 | Printf.fprintf stderr 166 | "The server does not support the query function.\n%!" ; 167 | exit 1 168 | | Result.Error `Policy -> 169 | Printf.fprintf stderr 170 | "The server configuration does not permit listing exports.\n%!" ; 171 | exit 2 172 | in 173 | `Ok (Lwt_main.run t) 174 | 175 | (* Helper function for use within this module *) 176 | let init_tls_get_server_ctx ~curve ~certfile ~ciphersuites no_tls = 177 | if no_tls then 178 | None 179 | else 180 | let certfile = require_str "certfile" certfile in 181 | let ciphersuites = require_str "ciphersuites" ciphersuites in 182 | Some 183 | (Nbd_unix.TlsServer 184 | (Nbd_unix.init_tls_get_ctx ~curve ~certfile ~ciphersuites ()) 185 | ) 186 | 187 | let ignore_exn t () = Lwt.catch t (fun _ -> Lwt.return_unit) 188 | 189 | let serve _common filename port exportname certfile curve ciphersuites no_tls 190 | = 191 | let tls_role = 192 | init_tls_get_server_ctx ~curve ~certfile ~ciphersuites no_tls 193 | in 194 | let filename = require "filename" filename in 195 | let validate ~client_exportname = 196 | match exportname with 197 | | Some exportname when exportname <> client_exportname -> 198 | Lwt.fail_with 199 | (Printf.sprintf 200 | "Client requested invalid exportname %s, name of the export is \ 201 | %s" 202 | client_exportname exportname 203 | ) 204 | | _ -> 205 | Lwt.return_unit 206 | in 207 | let handle_connection fd = 208 | Lwt.finalize 209 | (fun () -> 210 | Nbd_unix.with_channel fd tls_role (fun clearchan -> 211 | let offer = 212 | match exportname with 213 | | None -> 214 | None 215 | | Some exportname -> 216 | Some [exportname] 217 | in 218 | Server.with_connection ?offer clearchan 219 | (fun client_exportname svr -> 220 | validate ~client_exportname >>= fun () -> 221 | Nbd_unix.with_block filename 222 | (Server.serve svr ~read_only:false (module Block)) 223 | ) 224 | ) 225 | ) 226 | (ignore_exn (fun () -> Lwt_unix.close fd)) 227 | in 228 | let t = 229 | let sock = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 230 | Lwt.finalize 231 | (fun () -> 232 | Lwt_unix.setsockopt sock Lwt_unix.SO_REUSEADDR true ; 233 | let sockaddr = Lwt_unix.ADDR_INET (Unix.inet_addr_any, port) in 234 | Lwt_unix.bind sock sockaddr >>= fun () -> 235 | Lwt_unix.listen sock 5 ; 236 | let rec loop () = 237 | Lwt_unix.accept sock >>= fun (fd, _) -> 238 | (* Background thread per connection *) 239 | let _ = 240 | Lwt.catch 241 | (fun () -> handle_connection fd) 242 | (fun e -> 243 | Lwt_log.error_f 244 | "Caught exception %s while handling connection" 245 | (Printexc.to_string e) 246 | ) 247 | in 248 | loop () 249 | in 250 | loop () 251 | ) 252 | (ignore_exn (fun () -> Lwt_unix.close sock)) 253 | in 254 | Lwt_main.run t 255 | 256 | let mirror _common filename port secondary certfile curve ciphersuites no_tls 257 | = 258 | let tls_role = 259 | init_tls_get_server_ctx ~curve ~certfile ~ciphersuites no_tls 260 | in 261 | let filename = require "filename" filename in 262 | let secondary = require "secondary" secondary in 263 | let t = 264 | let sock = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 265 | let sockaddr = Lwt_unix.ADDR_INET (Unix.inet_addr_any, port) in 266 | Lwt_unix.bind sock sockaddr >>= fun () -> 267 | Lwt_unix.listen sock 5 ; 268 | let module M = Mirror.Make (Device) (Device) in 269 | ( Device.connect (Uri.of_string filename) >>= fun primary -> 270 | (* Connect to the secondary *) 271 | Device.connect (Uri.of_string secondary) >>= fun secondary -> 272 | let progress_cb = function 273 | | `Complete -> 274 | Printf.fprintf stderr "Mirror synchronised\n%!" 275 | | `Percent x -> 276 | Printf.fprintf stderr "Mirror %d %% complete\n%!" x 277 | in 278 | M.connect ~progress_cb primary secondary 279 | ) 280 | >>= fun m -> 281 | let rec loop () = 282 | Lwt_unix.accept sock >>= fun (fd, _) -> 283 | (* Background thread per connection *) 284 | let _ = 285 | let channel = Nbd_unix.cleartext_channel_of_fd fd tls_role in 286 | Server.connect channel () >>= fun (_name, t) -> 287 | Server.serve t (module M) m 288 | in 289 | loop () 290 | in 291 | loop () 292 | in 293 | Lwt_main.run t 294 | end 295 | 296 | let size_cmd = 297 | let doc = "Return the size of a disk served over NBD" in 298 | let host = 299 | let doc = "Hostname of NBD server" in 300 | Arg.(required & pos 0 (some string) None & info [] ~doc ~docv:"hostname") 301 | in 302 | let port = 303 | let doc = "Remote port" in 304 | Arg.(required & pos 1 (some int) None & info [] ~doc ~docv:"port") 305 | in 306 | let export = 307 | let doc = "Name of the export" in 308 | Arg.(value & opt string "export" & info ["export"] ~doc ~docv:"export") 309 | in 310 | ( Term.(ret (const Impl.size $ host $ port $ export)) 311 | , Cmd.info "size" ~version:"1.0.0" ~doc 312 | ) 313 | 314 | (* Used by both serve and mirror cmds *) 315 | let certfile = 316 | let doc = "Path to file containing TLS certificate." in 317 | Arg.(value & opt string "" & info ["certfile"] ~doc) 318 | 319 | let ciphersuites = 320 | let doc = 321 | "Set of ciphersuites for TLS (specified in the format accepted by OpenSSL, \ 322 | stunnel etc.)" 323 | in 324 | let parse_cipherstring_as_required = 325 | ( (fun s -> if s = "" then failwith "ciphersuite is required" else `Ok s) 326 | , Format.pp_print_string 327 | ) 328 | in 329 | Arg.( 330 | value & opt parse_cipherstring_as_required "" & info ["ciphersuites"] ~doc 331 | ) 332 | 333 | (* cli is only used for debugging, so assume user is providing a good cipherstring *) 334 | 335 | let curve = 336 | let doc = "EC curve to use" in 337 | Arg.(value & opt string "secp384r1" & info ["curve"] ~doc) 338 | 339 | let serve_cmd = 340 | let doc = "serve a disk over NBD" in 341 | let man = 342 | [ 343 | `S "DESCRIPTION" 344 | ; `P "Create a server which allows a client to access a disk using NBD." 345 | ] 346 | @ help 347 | in 348 | let filename = 349 | let doc = "Disk (file or block device) to expose" in 350 | Arg.(value & pos 0 (some file) None & info [] ~doc) 351 | in 352 | let port = 353 | let doc = "Local port to listen for connections on" in 354 | Arg.(value & opt int 10809 & info ["port"] ~doc) 355 | in 356 | let exportname = 357 | let doc = 358 | {|Export name to use when serving the file. If specified, clients 359 | will be able to list this export, and only this export name 360 | will be accepted. If unspecified, listing the exports will not 361 | be allowed, and all export names will be accepted when 362 | connecting.|} 363 | in 364 | Arg.(value & opt (some string) None & info ["exportname"] ~doc) 365 | in 366 | let no_tls = 367 | let doc = 368 | "Use NOTLS mode (refusing TLS) instead of the default FORCEDTLS." 369 | in 370 | Arg.(value & flag & info ["no-tls"] ~doc) 371 | in 372 | ( Term.( 373 | ret 374 | (const Impl.serve 375 | $ common_options_t 376 | $ filename 377 | $ port 378 | $ exportname 379 | $ certfile 380 | $ curve 381 | $ ciphersuites 382 | $ no_tls 383 | ) 384 | ) 385 | , Cmd.info "serve" ~sdocs:common_options ~doc ~man 386 | ) 387 | 388 | let mirror_cmd = 389 | let doc = "serve a disk over NBD while mirroring" in 390 | let man = 391 | [ 392 | `S "DESCRIPTION" 393 | ; `P "Create a server which allows a client to access a disk using NBD." 394 | ; `P 395 | "The server will pass I/O through to a primary disk underneath, while \ 396 | also mirroring the contents to a secondary." 397 | ; `S "EXAMPLES" 398 | ] 399 | @ help 400 | in 401 | let filename = 402 | let doc = "URI naming the primary disk" in 403 | Arg.(value & pos 0 (some string) None & info [] ~doc) 404 | in 405 | let secondary = 406 | let doc = "URI naming the secondary disk" in 407 | Arg.(value & pos 1 (some string) None & info [] ~doc) 408 | in 409 | let port = 410 | let doc = "Local port to listen for connections on" in 411 | Arg.(value & opt int 10809 & info ["port"] ~doc) 412 | in 413 | let no_tls = 414 | let doc = 415 | "Serve using NOTLS mode (refusing TLS) instead of the default FORCEDTLS." 416 | in 417 | Arg.(value & flag & info ["no-tls"] ~doc) 418 | in 419 | ( Term.( 420 | ret 421 | (const Impl.mirror 422 | $ common_options_t 423 | $ filename 424 | $ port 425 | $ secondary 426 | $ certfile 427 | $ curve 428 | $ ciphersuites 429 | $ no_tls 430 | ) 431 | ) 432 | , Cmd.info "mirror" ~sdocs:common_options ~doc ~man 433 | ) 434 | 435 | let list_cmd = 436 | let doc = "list the disks exported by an NBD server" in 437 | let man = 438 | [ 439 | `S "DESCRIPTION" 440 | ; `P 441 | "Queries a server and returns a list of known exports. Note older \ 442 | servers may not support the protocol option: this will result in an \ 443 | empty list." 444 | ] 445 | @ help 446 | in 447 | let host = 448 | let doc = "Hostname of NBD server" in 449 | Arg.(required & pos 0 (some string) None & info [] ~doc ~docv:"hostname") 450 | in 451 | let port = 452 | let doc = "Remote port" in 453 | Arg.(required & pos 1 (some int) None & info [] ~doc ~docv:"port") 454 | in 455 | ( Term.(ret (const Impl.list $ common_options_t $ host $ port)) 456 | , Cmd.info "list" ~sdocs:common_options ~doc ~man 457 | ) 458 | 459 | let cmds = 460 | [serve_cmd; list_cmd; size_cmd; mirror_cmd] 461 | |> List.map (fun (t, i) -> Cmd.v i t) 462 | 463 | let () = 464 | let default = 465 | Term.(ret (const (fun _ -> `Help (`Pager, None)) $ common_options_t)) 466 | in 467 | let doc = "manipulate NBD clients and servers" in 468 | let info = 469 | Cmd.info "nbd-tool" ~version:"1.0.0" ~sdocs:common_options ~doc ~man:help 470 | in 471 | let cmd = Cmd.group ~default info cmds in 472 | exit (Cmd.eval cmd) 473 | -------------------------------------------------------------------------------- /cli_test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (modes byte exe) 3 | (name suite) 4 | (libraries alcotest alcotest-lwt cmdliner)) 5 | 6 | (rule 7 | (alias runtest) 8 | (package nbd-tool) 9 | (deps 10 | (:suite suite.exe) 11 | (:cli ../cli/main.exe) 12 | ./test-qemu.sh 13 | ./test-nbd-client.sh 14 | ./random_data.sh) 15 | (action 16 | (run %{suite} --cli %{cli}))) 17 | -------------------------------------------------------------------------------- /cli_test/random_data.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # This test checks that misbehaving clients sending random data cannot cause 4 | # the server to crash. 5 | 6 | set -eux 7 | 8 | CLI=$1 9 | 10 | SCRATCH=$(mktemp -d) 11 | EXPORT=$SCRATCH/test 12 | DATA=$SCRATCH/data 13 | 14 | # Create the file we'll serve 15 | truncate --size=10M "$EXPORT" 16 | 17 | # Serve it 18 | $CLI serve --exportname test --no-tls "$EXPORT" & 19 | SERVER=$! 20 | # Wait for the server to start the main loop 21 | sleep 0.1 22 | 23 | stop_server() { 24 | kill -9 $SERVER 25 | } 26 | trap stop_server EXIT 27 | 28 | # Keep sending random data to the server 29 | # This loop tests the option handling of the server 30 | for i in $(seq 100) 31 | do 32 | echo "**** Option handling: iteration $i ****" 33 | dd if=/dev/urandom bs=1M count=20 | nc 0.0.0.0 10809 || true 34 | # Check if the server is still running 35 | stat /proc/$SERVER 36 | done 37 | 38 | # This loop tests the command handling of the server 39 | for i in $(seq 100) 40 | do 41 | echo "**** Command handling: iteration $i ****" 42 | rm -f "$DATA" 43 | # We connect to the export and then enter the transmission phase 44 | printf '\000\000\000\001IHAVEOPT\000\000\000\001\000\000\000\004test' > "$DATA" 45 | dd if=/dev/urandom bs=1M count=20 >> "$DATA" 46 | nc 0.0.0.0 10809 < "$DATA" || true 47 | # Check if the server is still running 48 | stat /proc/$SERVER 49 | done 50 | -------------------------------------------------------------------------------- /cli_test/suite.ml: -------------------------------------------------------------------------------- 1 | let with_command ~command ~strict test = 2 | match Sys.command ("command -v " ^ command) with 3 | | 0 -> 4 | test () 5 | | _ -> 6 | if strict then 7 | failwith ("Command " ^ command ^ " not present") 8 | else 9 | Printf.printf "!!! Skipping test because command %s is not available" 10 | command 11 | 12 | (* Each test script takes the path to the NBD CLI as its first command line argument *) 13 | let script name ~requires (cli, strict) = 14 | with_command ~command:requires ~strict (fun () -> 15 | Alcotest.(check int) name 0 (Sys.command (name ^ " " ^ cli)) 16 | ) 17 | 18 | let opts = 19 | let cli = 20 | let doc = "Path to nbd CLI should be first command-line argument" in 21 | Cmdliner.Arg.( 22 | required 23 | & opt ~vopt:None (some string) None 24 | & info ["cli"] ~docv:"CLI" ~doc 25 | ) 26 | in 27 | let strict = 28 | let doc = 29 | {|If present, the test will fail when the required program is not 30 | installed. Otherwise the test will simply be skipped.|} 31 | in 32 | let env = Cmdliner.Cmd.Env.info "STRICT" in 33 | Cmdliner.Arg.(value & flag & info ["strict"] ~env ~doc) 34 | in 35 | Cmdliner.Term.(const (fun cli strict -> (cli, strict)) $ cli $ strict) 36 | 37 | let () = 38 | Alcotest.run_with_args "Nbd CLI interoperability tests" opts 39 | [ 40 | ( "NBD CLI interoperability tests" 41 | , [ 42 | ( "data copying with qemu-img" 43 | , `Quick 44 | , script "./test-qemu.sh" ~requires:"qemu-img" 45 | ) 46 | ; ( "listing exports with nbd-client" 47 | , `Quick 48 | , script "./test-nbd-client.sh" ~requires:"nbd-client" 49 | ) 50 | ] 51 | ) 52 | ; ( "Stress tests" 53 | , [ 54 | ( "Misbehaving clients sending random data" 55 | , `Slow 56 | , script "./random_data.sh" ~requires:"nc" 57 | ) 58 | ] 59 | ) 60 | ] 61 | -------------------------------------------------------------------------------- /cli_test/test-nbd-client.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -eux 4 | 5 | CLI=$1 6 | 7 | SCRATCH=$(mktemp -d) 8 | EXPORT=$SCRATCH/test 9 | 10 | # Create a test file 11 | dd if=/dev/urandom of="$EXPORT" bs=1M count=40 12 | 13 | # Serve it 14 | $CLI serve --exportname test --no-tls "$EXPORT" & 15 | SERVER=$! 16 | # Wait for the server to start the main loop 17 | sleep 0.1 18 | 19 | stop_server() { 20 | kill -9 $SERVER 21 | } 22 | trap stop_server EXIT 23 | 24 | # Try listing the exports 25 | # This will fail if the server does not implement NBD_OPT_LIST correctly 26 | nbd-client -l 0.0.0.0 27 | -------------------------------------------------------------------------------- /cli_test/test-qemu.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -eux 4 | 5 | CLI=$1 6 | 7 | SCRATCH=$(mktemp -d) 8 | EXPORT=$SCRATCH/test 9 | OUTPUT=$SCRATCH/out 10 | 11 | # Create a test file 12 | dd if=/dev/urandom of="$EXPORT" bs=1M count=40 13 | 14 | # Serve it 15 | $CLI serve --exportname test --no-tls "$EXPORT" & 16 | SERVER=$! 17 | # Wait for the server to start the main loop 18 | sleep 0.1 19 | 20 | stop_server() { 21 | kill -9 $SERVER 22 | } 23 | trap stop_server EXIT 24 | 25 | # Download it as raw from the server 26 | qemu-img convert 'nbd:0.0.0.0:10809:exportname=test' -O raw "$OUTPUT" 27 | 28 | # Check that the two files are the same 29 | cmp --silent "$EXPORT" "$OUTPUT" 30 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (name nbd) 3 | 4 | (formatting 5 | (enabled_for ocaml)) 6 | -------------------------------------------------------------------------------- /lib/channel.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | type tls_channel = { 16 | read_tls: Cstruct.t -> unit Lwt.t 17 | ; write_tls: Cstruct.t -> unit Lwt.t 18 | ; close_tls: unit -> unit Lwt.t 19 | } 20 | 21 | type cleartext_channel = { 22 | read_clear: Cstruct.t -> unit Lwt.t 23 | ; write_clear: Cstruct.t -> unit Lwt.t 24 | ; close_clear: unit -> unit Lwt.t 25 | ; make_tls_channel: (unit -> tls_channel Lwt.t) option 26 | } 27 | 28 | type generic_channel = { 29 | is_tls: bool 30 | ; read: Cstruct.t -> unit Lwt.t 31 | ; write: Cstruct.t -> unit Lwt.t 32 | ; close: unit -> unit Lwt.t 33 | } 34 | 35 | type channel = generic_channel 36 | 37 | let generic_of_tls_channel ch = 38 | {read= ch.read_tls; write= ch.write_tls; close= ch.close_tls; is_tls= true} 39 | 40 | let generic_of_cleartext_channel ch = 41 | { 42 | read= ch.read_clear 43 | ; write= ch.write_clear 44 | ; close= ch.close_clear 45 | ; is_tls= false 46 | } 47 | -------------------------------------------------------------------------------- /lib/channel.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (** Channels represent connections between clients and servers. *) 16 | 17 | (** An open channel to an NBD client or server. *) 18 | 19 | type tls_channel = { 20 | read_tls: Cstruct.t -> unit Lwt.t 21 | ; write_tls: Cstruct.t -> unit Lwt.t 22 | ; close_tls: unit -> unit Lwt.t 23 | } 24 | 25 | type cleartext_channel = { 26 | read_clear: Cstruct.t -> unit Lwt.t 27 | ; write_clear: Cstruct.t -> unit Lwt.t 28 | ; close_clear: unit -> unit Lwt.t 29 | ; make_tls_channel: (unit -> tls_channel Lwt.t) option 30 | } 31 | 32 | type generic_channel = { 33 | is_tls: bool 34 | ; read: Cstruct.t -> unit Lwt.t 35 | ; write: Cstruct.t -> unit Lwt.t 36 | ; close: unit -> unit Lwt.t 37 | } 38 | 39 | type channel = generic_channel 40 | 41 | val generic_of_tls_channel : tls_channel -> generic_channel 42 | 43 | val generic_of_cleartext_channel : cleartext_channel -> generic_channel 44 | -------------------------------------------------------------------------------- /lib/client.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | open Lwt.Infix 16 | open Protocol 17 | open Channel 18 | 19 | type size = int64 20 | 21 | let get_handle = 22 | let next = ref 0L in 23 | fun () -> 24 | let this = !next in 25 | next := Int64.succ !next ; 26 | this 27 | 28 | module NbdRpc = struct 29 | type transport = channel 30 | 31 | type id = int64 32 | 33 | type request_hdr = Request.t 34 | 35 | type request_body = Cstruct.t option 36 | 37 | type response_hdr = Reply.t 38 | 39 | type response_body = Cstruct.t list 40 | 41 | let recv_hdr sock = 42 | let buf = Cstruct.create 16 in 43 | sock.read buf >>= fun () -> 44 | match Reply.unmarshal buf with 45 | | Ok x -> 46 | Lwt.return (Some x.Reply.handle, x) 47 | | Error e -> 48 | Lwt.fail e 49 | 50 | let recv_body sock req_hdr res_hdr response_body = 51 | match res_hdr.Reply.error with 52 | | Error e -> 53 | Lwt.return_error e 54 | | Ok () -> ( 55 | match req_hdr.Request.ty with 56 | | Command.Read -> 57 | (* TODO: use a page-aligned memory allocator *) 58 | Lwt_list.iter_s sock.read response_body >>= fun () -> Lwt.return_ok () 59 | | _ -> 60 | Lwt.return_ok () 61 | ) 62 | 63 | let send_one sock req_hdr req_body = 64 | let buf = Cstruct.create Request.sizeof in 65 | Request.marshal buf req_hdr ; 66 | sock.write buf >>= fun () -> 67 | match req_body with None -> Lwt.return () | Some data -> sock.write data 68 | 69 | let id_of_request req = req.Request.handle 70 | 71 | let handle_unrequested_packet _t reply = 72 | Lwt.fail_with 73 | (Printf.sprintf "Unexpected response from server: %s" 74 | (Reply.to_string reply) 75 | ) 76 | end 77 | 78 | module Rpc = Mux.Make (NbdRpc) 79 | 80 | type error = [Mirage_block.error | `Protocol_error of Protocol.Error.t] 81 | 82 | type write_error = 83 | [Mirage_block.write_error | `Protocol_error of Protocol.Error.t] 84 | 85 | let pp_error ppf = function 86 | | #Mirage_block.error as e -> 87 | Mirage_block.pp_error ppf e 88 | | `Protocol_error e -> 89 | Fmt.string ppf (Protocol.Error.to_string e) 90 | 91 | let pp_write_error ppf = function 92 | | #Mirage_block.write_error as e -> 93 | Mirage_block.pp_write_error ppf e 94 | | `Protocol_error e -> 95 | Fmt.string ppf (Protocol.Error.to_string e) 96 | 97 | type t = { 98 | client: Rpc.client 99 | ; info: Mirage_block.info 100 | ; mutable disconnected: bool 101 | } 102 | 103 | type id = unit 104 | 105 | let make channel size_bytes flags = 106 | Rpc.create channel >>= fun client -> 107 | let read_write = not (List.mem PerExportFlag.Read_only flags) in 108 | let sector_size = 1 in 109 | (* Note: NBD has no notion of a sector *) 110 | let size_sectors = size_bytes in 111 | let info = {Mirage_block.read_write; sector_size; size_sectors} in 112 | let disconnected = false in 113 | Lwt.return {client; info; disconnected} 114 | 115 | let list channel = 116 | let section = Lwt_log_core.Section.make "Client.list" in 117 | 118 | let buf = Cstruct.create Announcement.sizeof in 119 | channel.read buf >>= fun () -> 120 | match Announcement.unmarshal buf with 121 | | Error e -> 122 | Lwt.fail e 123 | | Ok kind -> ( 124 | let buf = Cstruct.create (Negotiate.sizeof kind) in 125 | channel.read buf >>= fun () -> 126 | match Negotiate.unmarshal buf kind with 127 | | Error e -> 128 | Lwt.fail e 129 | | Ok (Negotiate.V1 _) -> 130 | Lwt.return_error `Unsupported 131 | | Ok (Negotiate.V2 x) -> 132 | let buf = Cstruct.create NegotiateResponse.sizeof in 133 | let flags = 134 | if List.mem GlobalFlag.Fixed_newstyle x then 135 | [ClientFlag.Fixed_newstyle] 136 | else 137 | [] 138 | in 139 | NegotiateResponse.marshal buf flags ; 140 | channel.write buf >>= fun () -> 141 | let buf = Cstruct.create OptionRequestHeader.sizeof in 142 | OptionRequestHeader.(marshal buf {ty= Option.List; length= 0l}) ; 143 | channel.write buf >>= fun () -> 144 | let buf = Cstruct.create OptionResponseHeader.sizeof in 145 | let rec loop acc = 146 | channel.read buf >>= fun () -> 147 | match OptionResponseHeader.unmarshal buf with 148 | | Error e -> 149 | Lwt.fail e 150 | | Ok {OptionResponseHeader.response_type= OptionResponse.Ack; _} -> 151 | Lwt.return_ok acc 152 | | Ok {OptionResponseHeader.response_type= OptionResponse.Policy; _} 153 | -> 154 | Lwt.return_error `Policy 155 | | Ok 156 | { 157 | OptionResponseHeader.response_type= OptionResponse.Server 158 | ; length 159 | ; _ 160 | } -> ( 161 | let buf' = Cstruct.create (Int32.to_int length) in 162 | channel.read buf' >>= fun () -> 163 | match Server.unmarshal buf' with 164 | | Ok server -> 165 | loop (server.Server.name :: acc) 166 | | Error e -> 167 | Lwt.fail e 168 | ) 169 | | Ok _ -> 170 | Lwt.fail_with "Server's OptionResponse had an invalid type" 171 | in 172 | loop [] >>= fun result -> 173 | (* Send NBD_OPT_ABORT to terminate the option haggling *) 174 | let buf = Cstruct.create OptionRequestHeader.sizeof in 175 | OptionRequestHeader.(marshal buf {ty= Option.Abort; length= 0l}) ; 176 | channel.write buf >>= fun () -> 177 | (* The NBD protocol says: "the client SHOULD gracefully handle the 178 | * server closing the connection after receiving an NBD_OPT_ABORT 179 | * without it sending a reply" *) 180 | Lwt.catch 181 | (fun () -> 182 | (* Read ack from server *) 183 | let buf = Cstruct.create OptionResponseHeader.sizeof in 184 | channel.read buf >>= fun () -> 185 | match OptionResponseHeader.unmarshal buf with 186 | | Error e -> 187 | Lwt.fail e 188 | | Ok {OptionResponseHeader.response_type= OptionResponse.Ack; _} 189 | -> 190 | Lwt.return_unit 191 | | Ok _ -> 192 | Lwt.fail_with "Server's OptionResponse had an invalid type" 193 | ) 194 | (fun exn -> 195 | Lwt_log_core.warning ~section ~exn 196 | "Got exception while reading ack from server" 197 | ) 198 | >|= fun () -> result 199 | ) 200 | 201 | let negotiate channel export = 202 | let buf = Cstruct.create Announcement.sizeof in 203 | channel.read buf >>= fun () -> 204 | match Announcement.unmarshal buf with 205 | | Error e -> 206 | Lwt.fail e 207 | | Ok kind -> ( 208 | let buf = Cstruct.create (Negotiate.sizeof kind) in 209 | channel.read buf >>= fun () -> 210 | match Negotiate.unmarshal buf kind with 211 | | Error e -> 212 | Lwt.fail e 213 | | Ok (Negotiate.V1 x) -> 214 | make channel x.Negotiate.size x.Negotiate.flags >>= fun t -> 215 | Lwt.return (t, x.Negotiate.size, x.Negotiate.flags) 216 | | Ok (Negotiate.V2 x) -> ( 217 | let buf = Cstruct.create NegotiateResponse.sizeof in 218 | let flags = 219 | if List.mem GlobalFlag.Fixed_newstyle x then 220 | [ClientFlag.Fixed_newstyle] 221 | else 222 | [] 223 | in 224 | NegotiateResponse.marshal buf flags ; 225 | channel.write buf >>= fun () -> 226 | let buf = Cstruct.create OptionRequestHeader.sizeof in 227 | OptionRequestHeader.( 228 | marshal buf 229 | { 230 | ty= Option.ExportName 231 | ; length= Int32.of_int (String.length export) 232 | } 233 | ) ; 234 | channel.write buf >>= fun () -> 235 | let buf = Cstruct.create (ExportName.sizeof export) in 236 | ExportName.marshal buf export ; 237 | channel.write buf >>= fun () -> 238 | let buf = Cstruct.create DiskInfo.sizeof in 239 | channel.read buf >>= fun () -> 240 | match DiskInfo.unmarshal buf with 241 | | Error e -> 242 | Lwt.fail e 243 | | Ok x -> 244 | make channel x.DiskInfo.size x.DiskInfo.flags >>= fun t -> 245 | Lwt.return (t, x.DiskInfo.size, x.DiskInfo.flags) 246 | ) 247 | ) 248 | 249 | let get_info t = Lwt.return t.info 250 | 251 | let write_one t from buffer = 252 | let handle = get_handle () in 253 | let req_hdr = 254 | { 255 | Request.ty= Command.Write 256 | ; handle 257 | ; from 258 | ; len= Int32.of_int (Cstruct.length buffer) 259 | } 260 | in 261 | Rpc.rpc req_hdr (Some buffer) [] t.client 262 | 263 | let write t from buffers = 264 | if t.disconnected then 265 | Lwt.return_error `Disconnected 266 | else 267 | let rec loop from = function 268 | | [] -> 269 | Lwt.return_ok () 270 | | b :: bs -> ( 271 | write_one t from b >>= function 272 | | Ok () -> 273 | loop Int64.(add from (of_int (Cstruct.length b))) bs 274 | | Error e -> 275 | Lwt.return_error e 276 | ) 277 | in 278 | loop from buffers >>= function 279 | | Error e -> 280 | Lwt.return_error (`Protocol_error e) 281 | | Ok () -> 282 | Lwt.return_ok () 283 | 284 | let read t from buffers = 285 | if t.disconnected then 286 | Lwt.return_error `Disconnected 287 | else 288 | let handle = get_handle () in 289 | let len = 290 | Int32.of_int @@ List.fold_left ( + ) 0 @@ List.map Cstruct.length buffers 291 | in 292 | let req_hdr = {Request.ty= Command.Read; handle; from; len} in 293 | let req_body = None in 294 | Rpc.rpc req_hdr req_body buffers t.client >>= function 295 | | Error e -> 296 | Lwt.return_error (`Protocol_error e) 297 | | Ok () -> 298 | Lwt.return_ok () 299 | 300 | let disconnect t = 301 | t.disconnected <- true ; 302 | Lwt.return () 303 | -------------------------------------------------------------------------------- /lib/client.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (** An NBD client which allows you to connect to remote disks and 16 | perform I/O. *) 17 | 18 | include S.CLIENT 19 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name nbd) 3 | (public_name nbd) 4 | (flags 5 | (:standard -w -34-32)) 6 | (libraries 7 | cstruct 8 | fmt 9 | io-page 10 | lwt 11 | lwt_log 12 | lwt_log.core 13 | mirage-block 14 | rresult 15 | sexplib 16 | sexplib0 17 | ) 18 | (instrumentation (backend bisect_ppx)) 19 | (preprocess 20 | (pps ppx_cstruct ppx_sexp_conv -no-check))) 21 | -------------------------------------------------------------------------------- /lib/mirror.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | open Lwt.Infix 15 | open Result 16 | 17 | module Make (Primary : Mirage_block.S) (Secondary : Mirage_block.S) = struct 18 | type error = 19 | [ Mirage_block.error 20 | | `Primary of Primary.error 21 | | `Secondary of Secondary.error ] 22 | 23 | type write_error = 24 | [ Mirage_block.write_error 25 | | `Primary of Primary.write_error 26 | | `Secondary of Secondary.write_error ] 27 | 28 | type mirror_error = 29 | [`Primary of Primary.error | `Secondary of Secondary.write_error] 30 | 31 | let pp_error ppf = function 32 | | #Mirage_block.error as e -> 33 | Mirage_block.pp_error ppf e 34 | | `Primary p -> 35 | Primary.pp_error ppf p 36 | | `Secondary s -> 37 | Secondary.pp_error ppf s 38 | 39 | let pp_write_error ppf = function 40 | | #Mirage_block.write_error as e -> 41 | Mirage_block.pp_write_error ppf e 42 | | `Primary p -> 43 | Primary.pp_write_error ppf p 44 | | `Secondary s -> 45 | Secondary.pp_write_error ppf s 46 | 47 | let string_of_error x = 48 | let b = Buffer.create 32 in 49 | let f = Format.formatter_of_buffer b in 50 | pp_error f x ; Buffer.contents b 51 | 52 | module Region_lock = struct 53 | (* We need to prevent the background mirror thread racing with an I/O write 54 | to a particular region *) 55 | 56 | type region = int64 * int 57 | 58 | let overlap (start, length) (start', _length') = 59 | start' >= start && start' < Int64.(add start (of_int length)) 60 | 61 | let before (start, length) (start', _length') = 62 | Int64.(add start (of_int length)) < start' 63 | 64 | type t = { 65 | mutable exclusive_lock: region 66 | ; (* extent we're currently copying *) 67 | mutable active: region list 68 | ; (* extents which are being written to *) 69 | c: unit Lwt_condition.t 70 | ; m: Lwt_mutex.t 71 | } 72 | 73 | (* Exclusively lock up to [offset'] *) 74 | let extend_right t offset' = 75 | Lwt_mutex.with_lock t.m (fun () -> 76 | let rec wait () = 77 | let length = Int64.(to_int (sub offset' (fst t.exclusive_lock))) in 78 | if 79 | List.fold_left ( || ) false 80 | (List.map (overlap (fst t.exclusive_lock, length)) t.active) 81 | then 82 | Lwt_condition.wait ~mutex:t.m t.c >>= fun () -> wait () 83 | else 84 | Lwt.return length 85 | in 86 | wait () >>= fun length -> 87 | t.exclusive_lock <- (fst t.exclusive_lock, length) ; 88 | Lwt_condition.broadcast t.c () ; 89 | Lwt.return () 90 | ) 91 | 92 | (* Release lock up to [offset'] *) 93 | let release_left t offset' = 94 | Lwt_mutex.with_lock t.m (fun () -> 95 | let length = 96 | Int64.( 97 | to_int 98 | (sub 99 | (add (fst t.exclusive_lock) (of_int (snd t.exclusive_lock))) 100 | offset' 101 | ) 102 | ) 103 | in 104 | t.exclusive_lock <- (offset', length) ; 105 | Lwt_condition.broadcast t.c () ; 106 | Lwt.return () 107 | ) 108 | 109 | (* Exclude the background copying thread from [offset:offset+length]. This avoids updating 110 | a region while it is being actively mirrored, which could cause the old data 111 | to overtake and overwrite the new data. *) 112 | let with_lock t offset length f = 113 | Lwt_mutex.with_lock t.m (fun () -> 114 | let rec loop () = 115 | if overlap t.exclusive_lock (offset, length) then 116 | Lwt_condition.wait ~mutex:t.m t.c >>= fun () -> loop () 117 | else 118 | (* if the copy might catch up with us then mark the region as locked *) 119 | let unlock = 120 | if before t.exclusive_lock (offset, length) then ( 121 | t.active <- (offset, length) :: t.active ; 122 | fun () -> 123 | t.active <- 124 | List.filter 125 | (fun (o, l) -> o <> offset || l <> length) 126 | t.active ; 127 | Lwt_condition.broadcast t.c () 128 | ) else 129 | fun () -> () 130 | in 131 | Lwt.catch 132 | (fun () -> f () >>= fun r -> unlock () ; Lwt.return r) 133 | (fun e -> unlock () ; Lwt.fail e) 134 | in 135 | loop () 136 | ) 137 | 138 | let make () = 139 | let exclusive_lock = (0L, 0) in 140 | let active = [] in 141 | let c = Lwt_condition.create () in 142 | let m = Lwt_mutex.create () in 143 | {exclusive_lock; active; c; m} 144 | end 145 | 146 | type t = { 147 | primary: Primary.t 148 | ; secondary: Secondary.t 149 | ; primary_block_size: int 150 | ; (* number of primary sectors per info.sector_size *) 151 | secondary_block_size: int 152 | ; (* number of secondary sectors per info.sector_size *) 153 | info: Mirage_block.info 154 | ; lock: Region_lock.t 155 | ; result: (unit, mirror_error) result Lwt.t 156 | ; mutable percent_complete: int 157 | ; progress_cb: [`Percent of int | `Complete] -> unit 158 | ; mutable disconnected: bool 159 | } 160 | 161 | let start_copy t u = 162 | let buffer = Io_page.(to_cstruct (get 4096)) in 163 | (* round to the nearest sector *) 164 | let block = Cstruct.length buffer / t.info.Mirage_block.sector_size in 165 | let buffer = 166 | Cstruct.sub buffer 0 (block * t.info.Mirage_block.sector_size) 167 | in 168 | (* split into an array of slots *) 169 | let nr_slots = 8 in 170 | let block = block / nr_slots in 171 | let slots = Array.make nr_slots (Cstruct.create 0) in 172 | for i = 0 to nr_slots - 1 do 173 | slots.(i) <- 174 | Cstruct.sub buffer 175 | (i * block * t.info.Mirage_block.sector_size) 176 | (block * t.info.Mirage_block.sector_size) 177 | done ; 178 | (* treat the slots as a circular buffer *) 179 | let producer_idx = ref 0 in 180 | let consumer_idx = ref 0 in 181 | let c = Lwt_condition.create () in 182 | 183 | let rec reader sector = 184 | if t.disconnected || sector = t.info.Mirage_block.size_sectors then 185 | Lwt.return_ok () 186 | else if !producer_idx - !consumer_idx >= nr_slots then 187 | Lwt_condition.wait c >>= fun () -> reader sector 188 | else 189 | Region_lock.extend_right t.lock Int64.(add sector (of_int block)) 190 | >>= fun () -> 191 | Primary.read t.primary 192 | Int64.(mul sector (of_int t.primary_block_size)) 193 | [slots.(!producer_idx mod nr_slots)] 194 | >>= function 195 | | Error e -> 196 | t.disconnected <- true ; 197 | Lwt_condition.signal c () ; 198 | Lwt.return_error e 199 | | Ok () -> 200 | incr producer_idx ; 201 | Lwt_condition.signal c () ; 202 | reader Int64.(add sector (of_int block)) 203 | in 204 | let rec writer sector = 205 | let percent_complete = 206 | Int64.(to_int (div (mul sector 100L) t.info.Mirage_block.size_sectors)) 207 | in 208 | if percent_complete <> t.percent_complete then 209 | t.progress_cb 210 | ( if percent_complete = 100 then 211 | `Complete 212 | else 213 | `Percent percent_complete 214 | ) ; 215 | t.percent_complete <- percent_complete ; 216 | if t.disconnected || sector = t.info.Mirage_block.size_sectors then 217 | Lwt.return_ok () 218 | else if !consumer_idx = !producer_idx then 219 | Lwt_condition.wait c >>= fun () -> writer sector 220 | else 221 | Secondary.write t.secondary 222 | Int64.(mul sector (of_int t.secondary_block_size)) 223 | [slots.(!consumer_idx mod nr_slots)] 224 | >>= function 225 | | Error e -> 226 | t.disconnected <- true ; 227 | Lwt_condition.signal c () ; 228 | Lwt.return_error e 229 | | Ok () -> 230 | incr consumer_idx ; 231 | Region_lock.release_left t.lock Int64.(add sector (of_int block)) 232 | >>= fun () -> 233 | Lwt_condition.signal c () ; 234 | writer Int64.(add sector (of_int block)) 235 | in 236 | let read_t = reader 0L in 237 | let write_t = writer 0L in 238 | read_t >>= fun read_result -> 239 | write_t >>= fun write_result -> 240 | ( match (read_result, write_result) with 241 | | Ok (), Ok () -> 242 | Lwt.wakeup u (Ok ()) 243 | | Error e, _ -> 244 | Lwt.wakeup u (Error (`Primary e)) 245 | | Ok (), Error e -> 246 | Lwt.wakeup u (Error (`Secondary e)) 247 | ) ; 248 | Lwt.return () 249 | 250 | type _id = unit 251 | 252 | let get_info t = Lwt.return t.info 253 | 254 | let connect ?(progress_cb = fun _ -> ()) primary secondary = 255 | Primary.get_info primary >>= fun primary_info -> 256 | Secondary.get_info secondary >>= fun secondary_info -> 257 | let sector_size = 258 | max primary_info.Mirage_block.sector_size 259 | secondary_info.Mirage_block.sector_size 260 | in 261 | (* We need our chosen sector_size to be an integer multiple of 262 | both primary and secondary sector sizes. This should be the 263 | very common case e.g. 4096 and 512; 512 and 1 *) 264 | let primary_block_size = 265 | sector_size / primary_info.Mirage_block.sector_size 266 | in 267 | let secondary_block_size = 268 | sector_size / secondary_info.Mirage_block.sector_size 269 | in 270 | let primary_bytes = 271 | Int64.( 272 | mul primary_info.Mirage_block.size_sectors 273 | (of_int primary_info.Mirage_block.sector_size) 274 | ) 275 | in 276 | let secondary_bytes = 277 | Int64.( 278 | mul secondary_info.Mirage_block.size_sectors 279 | (of_int secondary_info.Mirage_block.sector_size) 280 | ) 281 | in 282 | 283 | (let open Rresult in 284 | ( if 285 | sector_size mod primary_info.Mirage_block.sector_size <> 0 286 | || sector_size mod secondary_info.Mirage_block.sector_size <> 0 287 | then 288 | Error 289 | (`Msg 290 | (Printf.sprintf 291 | "Incompatible sector sizes: either primary (%d) or secondary \ 292 | (%d) must be an integer multiple of the other" 293 | primary_info.Mirage_block.sector_size 294 | secondary_info.Mirage_block.sector_size 295 | ) 296 | ) 297 | else 298 | Ok () 299 | ) 300 | >>= fun () -> 301 | ( if primary_bytes <> secondary_bytes then 302 | Error 303 | (`Msg 304 | (Printf.sprintf 305 | "Incompatible overall sizes: primary (%Ld bytes) and secondary \ 306 | (%Ld bytes) must be the same size" 307 | primary_bytes secondary_bytes 308 | ) 309 | ) 310 | else 311 | Ok () 312 | ) 313 | >>= fun () -> 314 | if not secondary_info.Mirage_block.read_write then 315 | Error (`Msg "Cannot mirror to a read-only secondary device") 316 | else 317 | Ok () 318 | ) 319 | |> Lwt.return 320 | >>= function 321 | | Error (`Msg x) -> 322 | Lwt.fail_with x 323 | | Ok () -> 324 | let disconnected = false in 325 | let read_write = primary_info.Mirage_block.read_write in 326 | let size_sectors = Int64.(div primary_bytes (of_int sector_size)) in 327 | let info = {Mirage_block.read_write; sector_size; size_sectors} in 328 | let lock = Region_lock.make () in 329 | let result, u = Lwt.task () in 330 | let percent_complete = 0 in 331 | let t = 332 | { 333 | progress_cb 334 | ; primary 335 | ; secondary 336 | ; primary_block_size 337 | ; secondary_block_size 338 | ; info 339 | ; lock 340 | ; result 341 | ; percent_complete 342 | ; disconnected 343 | } 344 | in 345 | let (_ : unit Lwt.t) = start_copy t u in 346 | Lwt.return t 347 | 348 | let read t ofs bufs = 349 | Primary.read t.primary ofs bufs >>= function 350 | | Error e -> 351 | Lwt.return_error (`Primary e) 352 | | Ok x -> 353 | Lwt.return_ok x 354 | 355 | let write t ofs bufs = 356 | let total_length_bytes = 357 | List.(fold_left ( + ) 0 (map Cstruct.length bufs)) 358 | in 359 | let length = total_length_bytes / t.info.Mirage_block.sector_size in 360 | let primary_ofs = Int64.(mul ofs (of_int t.primary_block_size)) in 361 | let secondary_ofs = Int64.(mul ofs (of_int t.secondary_block_size)) in 362 | Region_lock.with_lock t.lock ofs length (fun () -> 363 | Primary.write t.primary primary_ofs bufs >>= function 364 | | Error e -> 365 | Lwt.return_error (`Primary e) 366 | | Ok () -> ( 367 | Secondary.write t.secondary secondary_ofs bufs >>= function 368 | | Error e -> 369 | Lwt.return_error (`Secondary e) 370 | | Ok () -> 371 | Lwt.return_ok () 372 | ) 373 | ) 374 | 375 | let disconnect t = 376 | t.disconnected <- true ; 377 | t.result >>= fun _ -> Lwt.return () 378 | end 379 | -------------------------------------------------------------------------------- /lib/mirror.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | module Make (Primary : Mirage_block.S) (Secondary : Mirage_block.S) : sig 16 | include Mirage_block.S 17 | 18 | val connect : 19 | ?progress_cb:([`Percent of int | `Complete] -> unit) 20 | -> Primary.t 21 | -> Secondary.t 22 | -> t Lwt.t 23 | (** [connect ?progress primary secondary] creates a block device which performs I/O 24 | against [primary], while building a mirror of [primary] on top of 25 | [secondary] in the background. Existing data in [secondary] will be 26 | destroyed. 27 | 28 | If [?progress_cb] is provided then it will be called on every percentage 29 | change in mirror progress. 30 | 31 | It is an error if the block size of either [primary] or [secondary] 32 | is not an integer multiple of the other. 33 | 34 | It is an error if [primary] and [secondary] have different lengths. 35 | 36 | It is an error if [secondary] is read-only. 37 | *) 38 | 39 | val string_of_error : error -> string 40 | end 41 | -------------------------------------------------------------------------------- /lib/mux.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (** Lwt connection multiplexer. Multiplexes between parallel requests from 16 | multiple clients over a single output channel to a server that may send 17 | responses out of order. Each request and response carries an [id] that is 18 | used to match responses to requests. *) 19 | 20 | open Lwt.Infix 21 | 22 | module type RPC = sig 23 | (** The transport mechanism used to send and receive messages *) 24 | type transport 25 | 26 | (** Each [request_hdr] and [response_hdr] carries an [id] that is used to 27 | match responses to requests. *) 28 | type id 29 | 30 | type request_hdr 31 | 32 | type request_body 33 | 34 | type response_hdr 35 | 36 | type response_body 37 | 38 | val recv_hdr : transport -> (id option * response_hdr) Lwt.t 39 | 40 | val recv_body : 41 | transport 42 | -> request_hdr 43 | -> response_hdr 44 | -> response_body 45 | -> (unit, Protocol.Error.t) result Lwt.t 46 | (** [recv_body transport request_hdr response_hdr response_body] returns [Ok ()] 47 | and receives and writes the body of the response into [response_body] if 48 | the request has been successful, otherwise returns an [Error]. The 49 | [request_hdr] parameter is the output of a preceding [recv_hdr] call. *) 50 | 51 | val send_one : transport -> request_hdr -> request_body -> unit Lwt.t 52 | (** Send a single request. Invocations of this function will not be interleaved 53 | because they are protected by a mutex *) 54 | 55 | val id_of_request : request_hdr -> id 56 | 57 | val handle_unrequested_packet : transport -> response_hdr -> unit Lwt.t 58 | end 59 | 60 | module Make (R : RPC) : sig 61 | type client 62 | 63 | val rpc : 64 | R.request_hdr 65 | -> R.request_body 66 | -> R.response_body 67 | -> client 68 | -> (unit, Protocol.Error.t) Result.t Lwt.t 69 | (** [rpc req_hdr req_body response_body client] sends a request to the server, and 70 | saves the response into [response_body]. Will block until a response to 71 | this request is received from the server. *) 72 | 73 | val create : R.transport -> client Lwt.t 74 | (** [create transport] creates a new client that manages parallel requests 75 | over the given transport channel. All communication over this channel 76 | must go through the returned client. *) 77 | end = struct 78 | exception Unexpected_id of R.id 79 | 80 | exception Shutdown 81 | 82 | type client = { 83 | transport: R.transport 84 | ; outgoing_mutex: Lwt_mutex.t 85 | ; id_to_wakeup: 86 | ( R.id 87 | , R.request_hdr 88 | * (unit, Protocol.Error.t) result Lwt.u 89 | * R.response_body 90 | ) 91 | Hashtbl.t 92 | ; mutable dispatcher_thread: unit Lwt.t 93 | ; mutable dispatcher_shutting_down: bool 94 | } 95 | 96 | let rec dispatcher t = 97 | let th = 98 | Lwt.catch 99 | (fun () -> 100 | R.recv_hdr t.transport >>= fun (id, pkt) -> 101 | match id with 102 | | None -> 103 | R.handle_unrequested_packet t.transport pkt 104 | | Some id -> 105 | if not (Hashtbl.mem t.id_to_wakeup id) then 106 | Lwt.fail (Unexpected_id id) 107 | else 108 | let request_hdr, waker, response_body = 109 | Hashtbl.find t.id_to_wakeup id 110 | in 111 | R.recv_body t.transport request_hdr pkt response_body 112 | >>= fun response -> 113 | Lwt.wakeup waker response ; 114 | Hashtbl.remove t.id_to_wakeup id ; 115 | Lwt.return () 116 | ) 117 | (fun e -> 118 | t.dispatcher_shutting_down <- true ; 119 | Hashtbl.iter 120 | (fun _ (_, u, _) -> Lwt.wakeup_later_exn u e) 121 | t.id_to_wakeup ; 122 | Lwt.fail e 123 | ) 124 | in 125 | th >>= fun () -> dispatcher t 126 | 127 | let rpc req_hdr req_body response_body t = 128 | let sleeper, waker = Lwt.wait () in 129 | if t.dispatcher_shutting_down then 130 | Lwt.fail Shutdown 131 | else 132 | let id = R.id_of_request req_hdr in 133 | Hashtbl.add t.id_to_wakeup id (req_hdr, waker, response_body) ; 134 | Lwt_mutex.with_lock t.outgoing_mutex (fun () -> 135 | R.send_one t.transport req_hdr req_body 136 | ) 137 | >>= fun () -> sleeper 138 | 139 | let create transport = 140 | let t = 141 | { 142 | transport 143 | ; outgoing_mutex= Lwt_mutex.create () 144 | ; id_to_wakeup= Hashtbl.create 10 145 | ; dispatcher_thread= Lwt.return () 146 | ; dispatcher_shutting_down= false 147 | } 148 | in 149 | t.dispatcher_thread <- dispatcher t ; 150 | Lwt.return t 151 | end 152 | -------------------------------------------------------------------------------- /lib/protocol.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (* NBD client library *) 16 | 17 | open Sexplib.Std 18 | 19 | (* We need to serialise/deserialise result values *) 20 | type ('a, 'b) _result = [`Ok of 'a | `Error of 'b] [@@deriving sexp] 21 | 22 | let result_of_sexp a b s = 23 | match _result_of_sexp a b s with `Ok x -> Ok x | `Error y -> Error y 24 | 25 | let sexp_of_result a b r = 26 | sexp_of__result a b (match r with Ok x -> `Ok x | Error y -> `Error y) 27 | 28 | let _nbd_cmd_read = 0l 29 | 30 | let _nbd_cmd_write = 1l 31 | 32 | let _nbd_cmd_disc = 2l 33 | 34 | let _nbd_cmd_flush = 3l 35 | 36 | let _nbd_cmd_trim = 4l 37 | 38 | let nbd_request_magic = 0x25609513l 39 | 40 | let nbd_reply_magic = 0x67446698l 41 | 42 | let nbd_flag_has_flags = 1 43 | 44 | let nbd_flag_read_only = 2 45 | 46 | let nbd_flag_send_flush = 4 47 | 48 | let nbd_flag_send_fua = 8 49 | 50 | let nbd_flag_rotational = 16 51 | 52 | let nbd_flag_send_trim = 32 53 | 54 | let nbd_flag_fixed_newstyle = 1 55 | 56 | let nbd_flag_no_zeroes = 2 57 | 58 | let nbd_flag_c_fixed_newstyle = 1 59 | 60 | let nbd_flag_c_no_zeroes = 2 61 | 62 | let zero buf = 63 | for i = 0 to Cstruct.length buf - 1 do 64 | Cstruct.set_uint8 buf i 0 65 | done 66 | 67 | module PerExportFlag = struct 68 | type t = Read_only | Send_flush | Send_fua | Rotational | Send_trim 69 | [@@deriving sexp] 70 | 71 | let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) 72 | 73 | let of_int32 x = 74 | let flags = Int32.to_int x in 75 | let is_set i mask = i land mask = mask in 76 | List.map snd 77 | (List.filter 78 | (fun (mask, _) -> is_set flags mask) 79 | [ 80 | (nbd_flag_read_only, Read_only) 81 | ; (nbd_flag_send_flush, Send_flush) 82 | ; (nbd_flag_send_fua, Send_fua) 83 | ; (nbd_flag_rotational, Rotational) 84 | ; (nbd_flag_send_trim, Send_trim) 85 | ] 86 | ) 87 | 88 | let to_int flags = 89 | let one = function 90 | | Read_only -> 91 | nbd_flag_read_only 92 | | Send_flush -> 93 | nbd_flag_send_flush 94 | | Send_fua -> 95 | nbd_flag_send_fua 96 | | Rotational -> 97 | nbd_flag_rotational 98 | | Send_trim -> 99 | nbd_flag_send_trim 100 | in 101 | List.fold_left ( lor ) nbd_flag_has_flags (List.map one flags) 102 | 103 | let to_int32 flags = Int32.of_int (to_int flags) 104 | end 105 | 106 | module GlobalFlag = struct 107 | type t = Fixed_newstyle | No_zeroes [@@deriving sexp] 108 | 109 | let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) 110 | 111 | let of_int flags = 112 | let is_set i mask = i land mask = mask in 113 | List.map snd 114 | (List.filter 115 | (fun (mask, _) -> is_set flags mask) 116 | [ 117 | (nbd_flag_fixed_newstyle, Fixed_newstyle) 118 | ; (nbd_flag_no_zeroes, No_zeroes) 119 | ] 120 | ) 121 | 122 | let to_int flags = 123 | let one = function 124 | | Fixed_newstyle -> 125 | nbd_flag_fixed_newstyle 126 | | No_zeroes -> 127 | nbd_flag_no_zeroes 128 | in 129 | List.fold_left ( lor ) 0 (List.map one flags) 130 | end 131 | 132 | module ClientFlag = struct 133 | type t = Fixed_newstyle | No_zeroes [@@deriving sexp] 134 | 135 | let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) 136 | 137 | let of_int32 flags = 138 | let flags = Int32.to_int flags in 139 | let is_set mask = mask land flags <> 0 in 140 | List.map snd 141 | (List.filter 142 | (fun (mask, _) -> is_set mask) 143 | [ 144 | (nbd_flag_c_fixed_newstyle, Fixed_newstyle) 145 | ; (nbd_flag_c_no_zeroes, No_zeroes) 146 | ] 147 | ) 148 | 149 | let to_int32 flags = 150 | let one = function 151 | | Fixed_newstyle -> 152 | nbd_flag_c_fixed_newstyle 153 | | No_zeroes -> 154 | nbd_flag_c_no_zeroes 155 | in 156 | Int32.of_int (List.fold_left ( lor ) 0 (List.map one flags)) 157 | end 158 | 159 | module Error = struct 160 | type t = [`EPERM | `EIO | `ENOMEM | `EINVAL | `ENOSPC | `Unknown of int32] 161 | [@@deriving sexp] 162 | 163 | let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) 164 | 165 | let of_int32 = function 166 | | 1l -> 167 | `EPERM 168 | | 5l -> 169 | `EIO 170 | | 12l -> 171 | `ENOMEM 172 | | 22l -> 173 | `EINVAL 174 | | 28l -> 175 | `ENOSPC 176 | | x -> 177 | `Unknown x 178 | 179 | let to_int32 = function 180 | | `EPERM -> 181 | 1l 182 | | `EIO -> 183 | 5l 184 | | `ENOMEM -> 185 | 12l 186 | | `EINVAL -> 187 | 22l 188 | | `ENOSPC -> 189 | 28l 190 | | `Unknown x -> 191 | x 192 | end 193 | 194 | module Command = struct 195 | type t = Read | Write | Disc | Flush | Trim | Unknown of int32 196 | [@@deriving sexp] 197 | 198 | let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) 199 | 200 | let of_int32 = function 201 | | 0l -> 202 | Read 203 | | 1l -> 204 | Write 205 | | 2l -> 206 | Disc 207 | | 3l -> 208 | Flush 209 | | 4l -> 210 | Trim 211 | | c -> 212 | Unknown c 213 | 214 | let to_int32 = function 215 | | Read -> 216 | 0l 217 | | Write -> 218 | 1l 219 | | Disc -> 220 | 2l 221 | | Flush -> 222 | 3l 223 | | Trim -> 224 | 4l 225 | | Unknown c -> 226 | c 227 | end 228 | 229 | module Option = struct 230 | type t = ExportName | Abort | List | StartTLS | Unknown of int32 231 | [@@deriving sexp] 232 | 233 | let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) 234 | 235 | let of_int32 = function 236 | | 1l -> 237 | ExportName 238 | | 2l -> 239 | Abort 240 | | 3l -> 241 | List 242 | (* 4 is not in use in the NBD protocol. *) 243 | | 5l -> 244 | StartTLS 245 | (* 6, 7, 8 are not supported in this implementation. *) 246 | | c -> 247 | Unknown c 248 | 249 | let to_int32 = function 250 | | ExportName -> 251 | 1l 252 | | Abort -> 253 | 2l 254 | | List -> 255 | 3l 256 | | StartTLS -> 257 | 5l 258 | | Unknown c -> 259 | c 260 | end 261 | 262 | module OptionResponse = struct 263 | type t = 264 | | Ack 265 | | Server 266 | | Unsupported 267 | | Policy 268 | | Invalid 269 | | Platform 270 | | TlsReqd 271 | | Unknown of int32 272 | [@@deriving sexp] 273 | 274 | let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) 275 | 276 | let of_int32 = function 277 | | 1l -> 278 | Ack 279 | | 2l -> 280 | Server 281 | | -2147483647l -> 282 | Unsupported 283 | | -2147483646l -> 284 | Policy 285 | | -2147483645l -> 286 | Invalid 287 | | -2147483644l -> 288 | Platform 289 | | -2147483643l -> 290 | TlsReqd 291 | | x -> 292 | Unknown x 293 | 294 | let to_int32 = function 295 | | Ack -> 296 | 1l 297 | | Server -> 298 | 2l 299 | | Unsupported -> 300 | -2147483647l 301 | | Policy -> 302 | -2147483646l 303 | | Invalid -> 304 | -2147483645l 305 | | Platform -> 306 | -2147483644l 307 | | TlsReqd -> 308 | -2147483643l 309 | | Unknown x -> 310 | x 311 | end 312 | 313 | (* Sent by the server to the client which includes an initial 314 | protocol choice *) 315 | module Announcement = struct 316 | type t = [`V1 | `V2] [@@deriving sexp] 317 | 318 | type%cstruct t = {passwd: uint8_t [@len 8]; magic: uint64_t} [@@big_endian] 319 | 320 | let sizeof = sizeof_t 321 | 322 | let expected_passwd = "NBDMAGIC" 323 | 324 | let v1_magic = 0x00420281861253L 325 | 326 | let v2_magic = 0x49484156454F5054L (* Ascii encoding of "IHAVEOPT" *) 327 | 328 | let marshal buf t = 329 | set_t_passwd expected_passwd 0 buf ; 330 | set_t_magic buf (match t with `V1 -> v1_magic | `V2 -> v2_magic) 331 | 332 | let unmarshal buf = 333 | let passwd = Cstruct.to_string (get_t_passwd buf) in 334 | if passwd <> expected_passwd then 335 | Error (Failure "Bad magic in negotiate") 336 | else 337 | let magic = get_t_magic buf in 338 | if magic = v1_magic then 339 | Ok `V1 340 | else if magic = v2_magic then 341 | Ok `V2 342 | else 343 | Error 344 | (Failure 345 | (Printf.sprintf "Bad magic; expected %Ld or %Ld got %Ld" v1_magic 346 | v2_magic magic 347 | ) 348 | ) 349 | end 350 | 351 | module Negotiate = struct 352 | type v1 = {size: int64; flags: PerExportFlag.t list} [@@deriving sexp] 353 | 354 | type v2 = GlobalFlag.t list [@@deriving sexp] 355 | 356 | type t = V1 of v1 | V2 of v2 [@@deriving sexp] 357 | 358 | let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) 359 | 360 | type%cstruct v1 = { 361 | size: uint64_t 362 | ; flags: uint32_t 363 | ; padding: uint8_t [@len 124] 364 | } 365 | [@@big_endian] 366 | 367 | type%cstruct v2 = {flags: uint16_t} [@@big_endian] 368 | 369 | let sizeof = function `V1 -> sizeof_v1 | `V2 -> sizeof_v2 370 | 371 | let marshal buf t = 372 | zero buf ; 373 | match t with 374 | | V1 t -> 375 | set_v1_size buf t.size ; 376 | set_v1_flags buf (PerExportFlag.to_int32 t.flags) 377 | | V2 t -> 378 | set_v2_flags buf (GlobalFlag.to_int t) 379 | 380 | let unmarshal buf t = 381 | match t with 382 | | `V1 -> 383 | let size = get_v1_size buf in 384 | let flags = PerExportFlag.of_int32 (get_v1_flags buf) in 385 | Ok (V1 {size; flags}) 386 | | `V2 -> 387 | let flags = GlobalFlag.of_int (get_v2_flags buf) in 388 | Ok (V2 flags) 389 | end 390 | 391 | module NegotiateResponse = struct 392 | type t = ClientFlag.t list [@@deriving sexp] 393 | 394 | let sizeof = 4 395 | 396 | let marshal buf t = Cstruct.BE.set_uint32 buf 0 (ClientFlag.to_int32 t) 397 | 398 | let unmarshal buf = ClientFlag.of_int32 (Cstruct.BE.get_uint32 buf 0) 399 | end 400 | 401 | (* In the 'new' and 'new fixed' protocols, options are preceeded by 402 | a common header which includes a type and a length. *) 403 | module OptionRequestHeader = struct 404 | type t = {ty: Option.t; length: int32} [@@deriving sexp] 405 | 406 | type%cstruct t = {magic: uint64_t; ty: uint32_t; length: uint32_t} 407 | [@@big_endian] 408 | 409 | let sizeof = sizeof_t 410 | 411 | let marshal buf t = 412 | set_t_magic buf Announcement.v2_magic ; 413 | set_t_ty buf (Option.to_int32 t.ty) ; 414 | set_t_length buf t.length 415 | 416 | let unmarshal buf = 417 | let open Rresult in 418 | let magic = get_t_magic buf in 419 | ( if Announcement.v2_magic <> magic then 420 | Error 421 | (Failure 422 | (Printf.sprintf "Bad reply magic: expected %Ld, got %Ld" 423 | Announcement.v2_magic magic 424 | ) 425 | ) 426 | else 427 | Ok () 428 | ) 429 | >>= fun () -> 430 | let ty = Option.of_int32 (get_t_ty buf) in 431 | let length = get_t_length buf in 432 | Ok {ty; length} 433 | end 434 | 435 | (* This is the option sent by the client to select a particular disk 436 | export. *) 437 | module ExportName = struct 438 | type t = string [@@deriving sexp] 439 | 440 | let sizeof = String.length 441 | 442 | let marshal buf x = Cstruct.blit_from_string x 0 buf 0 (String.length x) 443 | end 444 | 445 | (* In both the 'new' style handshake and the 'fixed new' style handshake, 446 | the server will reply to an ExportName option with either a connection 447 | close or a DiskInfo: *) 448 | module DiskInfo = struct 449 | type t = {size: int64; flags: PerExportFlag.t list} [@@deriving sexp] 450 | 451 | type%cstruct t = { 452 | size: uint64_t 453 | ; flags: uint16_t 454 | ; padding: uint8_t [@len 124] 455 | } 456 | [@@big_endian] 457 | 458 | let sizeof = sizeof_t 459 | 460 | let unmarshal buf = 461 | let size = get_t_size buf in 462 | let flags = PerExportFlag.of_int32 (Int32.of_int (get_t_flags buf)) in 463 | Ok {size; flags} 464 | 465 | let marshal buf t = 466 | set_t_size buf t.size ; 467 | set_t_flags buf (PerExportFlag.to_int t.flags) 468 | end 469 | 470 | (* In the 'fixed new' style handshake, all options apart from ExportName 471 | should result in reply packets as follows: *) 472 | module OptionResponseHeader = struct 473 | type%cstruct t = { 474 | magic: uint64_t 475 | ; request_type: uint32_t 476 | ; response_type: uint32_t 477 | ; length: uint32_t 478 | } 479 | [@@big_endian] 480 | 481 | type t = { 482 | request_type: Option.t 483 | ; response_type: OptionResponse.t 484 | ; length: int32 485 | } 486 | [@@deriving sexp] 487 | 488 | let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) 489 | 490 | let sizeof = sizeof_t 491 | 492 | let expected_magic = 0x3e889045565a9L 493 | 494 | let unmarshal buf = 495 | let open Rresult in 496 | let magic = get_t_magic buf in 497 | ( if expected_magic <> magic then 498 | Error 499 | (Failure 500 | (Printf.sprintf "Bad reply magic: expected %Ld, got %Ld" 501 | expected_magic magic 502 | ) 503 | ) 504 | else 505 | Ok () 506 | ) 507 | >>= fun () -> 508 | let request_type = Option.of_int32 (get_t_request_type buf) in 509 | let response_type = OptionResponse.of_int32 (get_t_response_type buf) in 510 | let length = get_t_length buf in 511 | Ok {request_type; response_type; length} 512 | 513 | let marshal buf t = 514 | set_t_magic buf expected_magic ; 515 | set_t_request_type buf (Option.to_int32 t.request_type) ; 516 | set_t_response_type buf (OptionResponse.to_int32 t.response_type) ; 517 | set_t_length buf t.length 518 | end 519 | 520 | (* A description of an export, sent in response to a List option *) 521 | module Server = struct 522 | type t = {name: string} [@@deriving sexp] 523 | 524 | type%cstruct t = {length: uint32_t} [@@big_endian] 525 | 526 | let sizeof t = sizeof_t + String.length t.name 527 | 528 | let unmarshal buf = 529 | let length = Int32.to_int (get_t_length buf) in 530 | let buf = Cstruct.shift buf sizeof_t in 531 | let name = Cstruct.to_string (Cstruct.sub buf 0 length) in 532 | Ok {name} 533 | end 534 | 535 | module Request = struct 536 | type t = {ty: Command.t; handle: int64; from: int64; len: int32} 537 | [@@deriving sexp] 538 | 539 | let to_string t = 540 | Printf.sprintf "{ Command = %s; handle = %Ld; from = %Ld; len = %ld }" 541 | (Command.to_string t.ty) t.handle t.from t.len 542 | 543 | type%cstruct t = { 544 | magic: uint32_t 545 | ; ty: uint32_t 546 | ; handle: uint64_t 547 | ; from: uint64_t 548 | ; len: uint32_t 549 | } 550 | [@@big_endian] 551 | 552 | let unmarshal (buf : Cstruct.t) = 553 | let open Rresult in 554 | let magic = get_t_magic buf in 555 | ( if nbd_request_magic <> magic then 556 | Error 557 | (Failure 558 | (Printf.sprintf "Bad request magic: expected %ld, got %ld" magic 559 | nbd_request_magic 560 | ) 561 | ) 562 | else 563 | Ok () 564 | ) 565 | >>= fun () -> 566 | let ty = Command.of_int32 (get_t_ty buf) in 567 | let handle = get_t_handle buf in 568 | let from = get_t_from buf in 569 | let len = get_t_len buf in 570 | Ok {ty; handle; from; len} 571 | 572 | let sizeof = sizeof_t 573 | 574 | let marshal (buf : Cstruct.t) t = 575 | set_t_magic buf nbd_request_magic ; 576 | set_t_ty buf (Command.to_int32 t.ty) ; 577 | set_t_handle buf t.handle ; 578 | set_t_from buf t.from ; 579 | set_t_len buf t.len 580 | end 581 | 582 | module Reply = struct 583 | type t = {error: (unit, Error.t) result; handle: int64} [@@deriving sexp] 584 | 585 | let to_string t = Sexplib.Sexp.to_string (sexp_of_t t) 586 | 587 | type%cstruct t = {magic: uint32_t; error: uint32_t; handle: uint64_t} 588 | [@@big_endian] 589 | 590 | let unmarshal (buf : Cstruct.t) = 591 | let open Rresult in 592 | let magic = get_t_magic buf in 593 | ( if nbd_reply_magic <> magic then 594 | Error 595 | (Failure 596 | (Printf.sprintf "Bad reply magic: expected %ld, got %ld" magic 597 | nbd_reply_magic 598 | ) 599 | ) 600 | else 601 | Ok () 602 | ) 603 | >>= fun () -> 604 | let error = get_t_error buf in 605 | let error = if error = 0l then Ok () else Error (Error.of_int32 error) in 606 | let handle = get_t_handle buf in 607 | Ok {error; handle} 608 | 609 | let sizeof = sizeof_t 610 | 611 | let marshal (buf : Cstruct.t) t = 612 | set_t_magic buf nbd_reply_magic ; 613 | let error = 614 | match t.error with Ok () -> 0l | Error e -> Error.to_int32 e 615 | in 616 | set_t_error buf error ; set_t_handle buf t.handle 617 | end 618 | -------------------------------------------------------------------------------- /lib/protocol.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (** Types representing NBD protocol requests and responses. *) 16 | 17 | module Error : sig 18 | (** Read and write requests can fail with an error response. *) 19 | 20 | (** Defined error codes which can be returned in response to a request 21 | in the data-pushing phase. *) 22 | type t = 23 | [ `EPERM (** Operation not permitted *) 24 | | `EIO (** Input/output error *) 25 | | `ENOMEM (** Cannot allocate memory *) 26 | | `EINVAL (** Invalid argument *) 27 | | `ENOSPC (** No space left on device *) 28 | | `Unknown of int32 ] 29 | [@@deriving sexp] 30 | 31 | val to_string : t -> string 32 | end 33 | 34 | module Command : sig 35 | (** Once a connection has been established, the client can submit commands. *) 36 | 37 | type t = 38 | | Read (** Read a block of data *) 39 | | Write (** Write a block of data *) 40 | | Disc 41 | (** Disconnect: server must flush all outstanding commands and then 42 | will close the connection *) 43 | | Flush 44 | (** A flush request or write barrier. All requests received before 45 | this one will have completed before this command is acknowledged. *) 46 | | Trim 47 | (** A hint that a data region is nolonger required and may be 48 | discarded. *) 49 | | Unknown of int32 50 | (** A command which this protocol implementation doesn't 51 | suport. *) 52 | [@@deriving sexp] 53 | 54 | val to_string : t -> string 55 | end 56 | 57 | module PerExportFlag : sig 58 | (** Every disk (or 'export') has a number of associated flags. This will 59 | be returned from the server when the negotiation is complete. *) 60 | 61 | (** Per-export flags *) 62 | type t = 63 | | Read_only (** export is read/only. Writes will receive EPERM *) 64 | | Send_flush (** server supports Command.Flush *) 65 | | Send_fua (** server supports NBD_CMD_FLAG_FUA *) 66 | | Rotational (** let the client schedule I/O for a rotational medium *) 67 | | Send_trim (** server supports Command.Trim *) 68 | [@@deriving sexp] 69 | 70 | val to_string : t -> string 71 | end 72 | 73 | module GlobalFlag : sig 74 | (** During the protocol negotiation there are some defined flags used 75 | to choose protocol variants. These flags are sent by the server. *) 76 | 77 | type t = 78 | | Fixed_newstyle (** server supports the fixed newstyle protocol *) 79 | | No_zeroes (** request to omit the 124 bytes of zeroes *) 80 | [@@deriving sexp] 81 | 82 | val to_string : t -> string 83 | end 84 | 85 | module ClientFlag : sig 86 | (** During the protocol negotiation there are some defined flags used 87 | to choose protocol variants. These flags are sent by the client. *) 88 | 89 | type t = 90 | | Fixed_newstyle (** client acknowledges use of fixed newstyle protocol *) 91 | | No_zeroes (** client acknowledges omission of 124 bytes of zeroes *) 92 | [@@deriving sexp] 93 | 94 | val to_string : t -> string 95 | end 96 | 97 | module Option : sig 98 | (** In the 'newstyle' negotiation there is an opportunity for the client 99 | to negotiate options with the server. These are the known options. *) 100 | 101 | type t = 102 | | ExportName 103 | (** The client would like to connect to a given disk/export by 104 | name *) 105 | | Abort (** The client would like to quit. *) 106 | | List 107 | (** The client would like to receive a list of known 108 | disk/exports. *) 109 | | StartTLS (** The client would like to protect the session with TLS. *) 110 | | Unknown of int32 (** This option is unknown to this implementation *) 111 | [@@deriving sexp] 112 | 113 | val to_string : t -> string 114 | end 115 | 116 | module OptionResponse : sig 117 | (** When the client sends an option request, the server must reply. *) 118 | 119 | type t = 120 | | Ack (** Option acknowledged *) 121 | | Server (** A description of an export (in reponse to [List]) *) 122 | | Unsupported (** The option is unsupported *) 123 | | Policy (** The option is blocked by an admin policy *) 124 | | Invalid (** The option was invalid (i.e. the client is buggy) *) 125 | | Platform (** The option is not supported in this platform. *) 126 | | TlsReqd 127 | (** The option is not allowed when the connection is not using TLS. *) 128 | | Unknown of int32 (** The response is unknown to this implementation. *) 129 | [@@deriving sexp] 130 | 131 | val to_string : t -> string 132 | end 133 | 134 | module Announcement : sig 135 | (** The server sends an initial greeting when the connectino is opened. It 136 | can be of two main types: the original [V1] and a 'newstyle' [V2]. *) 137 | 138 | type t = [`V1 | `V2] [@@deriving sexp] 139 | 140 | val sizeof : int 141 | 142 | val marshal : Cstruct.t -> t -> unit 143 | 144 | val unmarshal : Cstruct.t -> (t, exn) result 145 | end 146 | 147 | module Negotiate : sig 148 | (** The initial greeting sent by the server *) 149 | 150 | (** The original [V1] protocol supports only one disk. *) 151 | type v1 = { 152 | size: int64 (** The size of the disk *) 153 | ; flags: PerExportFlag.t list (** Flags associated with the disk *) 154 | } 155 | [@@deriving sexp] 156 | 157 | (** The 'newstyle' [V2] protocol supports an option negotiation 158 | phase and a number of sub-options [GlobalFlag.t]s *) 159 | type v2 = GlobalFlag.t list [@@deriving sexp] 160 | 161 | type t = V1 of v1 | V2 of v2 (** The initial greeting sent by the server *) 162 | 163 | val to_string : t -> string 164 | 165 | val sizeof : Announcement.t -> int 166 | 167 | val marshal : Cstruct.t -> t -> unit 168 | 169 | val unmarshal : Cstruct.t -> Announcement.t -> (t, exn) result 170 | end 171 | 172 | module NegotiateResponse : sig 173 | (** The client's initial response to the server's greeting *) 174 | 175 | (** The client can send some flags, in response to flags set by the server. *) 176 | type t = ClientFlag.t list [@@deriving sexp] 177 | 178 | val sizeof : int 179 | 180 | val marshal : Cstruct.t -> t -> unit 181 | 182 | val unmarshal : Cstruct.t -> t 183 | end 184 | 185 | module OptionRequestHeader : sig 186 | (** Every option the client requests has the same header. *) 187 | 188 | (** The header of an option request sent by the client *) 189 | type t = { 190 | ty: Option.t (** The option type *) 191 | ; length: int32 (** The length of the option data *) 192 | } 193 | [@@deriving sexp] 194 | 195 | val sizeof : int 196 | 197 | val marshal : Cstruct.t -> t -> unit 198 | 199 | val unmarshal : Cstruct.t -> (t, exn) result 200 | end 201 | 202 | module ExportName : sig 203 | (** An ExportName option payload *) 204 | 205 | (** The name of the export the client wishes to connect to *) 206 | type t = string [@@deriving sexp] 207 | 208 | val sizeof : t -> int 209 | 210 | val marshal : Cstruct.t -> t -> unit 211 | end 212 | 213 | module DiskInfo : sig 214 | (** Details about the export chosen by the client, sent in response 215 | to an [ExportName] option. *) 216 | 217 | (** Details about the export chosen by the client. *) 218 | type t = { 219 | size: int64 (** The size of the disk in bytes *) 220 | ; flags: PerExportFlag.t list (** Flags associated with the disk *) 221 | } 222 | [@@deriving sexp] 223 | 224 | val sizeof : int 225 | 226 | val unmarshal : Cstruct.t -> (t, exn) result 227 | 228 | val marshal : Cstruct.t -> t -> unit 229 | end 230 | 231 | module OptionResponseHeader : sig 232 | (** The server sends a response to every option request sent by the 233 | client (except [ExportName] which is followed by a [DiskInfo]. 234 | This is the header of the response. *) 235 | 236 | (** The header of the response sent by the server in response to 237 | the client requesting an option. *) 238 | type t = { 239 | request_type: Option.t (** The option type requested *) 240 | ; response_type: OptionResponse.t (** The response code *) 241 | ; length: int32 242 | (** The length of the payload associated with the response *) 243 | } 244 | [@@deriving sexp] 245 | 246 | val sizeof : int 247 | 248 | val to_string : t -> string 249 | 250 | val unmarshal : Cstruct.t -> (t, exn) result 251 | 252 | val marshal : Cstruct.t -> t -> unit 253 | end 254 | 255 | module Server : sig 256 | (** In response to a [List] option, the server sends a number of 257 | [Server] responses and then finally an [Ack] *) 258 | 259 | (** A reponse to a [List] option. Note this option is repeated, once 260 | per available disk. *) 261 | type t = {name: string (** The name of an available disk. *)} 262 | [@@deriving sexp] 263 | 264 | val sizeof : t -> int 265 | 266 | val unmarshal : Cstruct.t -> (t, exn) result 267 | end 268 | 269 | module Request : sig 270 | (** After the negotation phase, clients send I/O requests to the server. *) 271 | 272 | (** An I/O request sent by the client to the server. *) 273 | type t = { 274 | ty: Command.t (** The command type *) 275 | ; handle: int64 276 | (** A unique handle used to match requests with responses.*) 277 | ; from: int64 (** The start of the data region *) 278 | ; len: int32 (** The length of the data region *) 279 | } 280 | [@@deriving sexp] 281 | 282 | val to_string : t -> string 283 | 284 | val sizeof : int 285 | 286 | val marshal : Cstruct.t -> t -> unit 287 | 288 | val unmarshal : Cstruct.t -> (t, exn) result 289 | end 290 | 291 | module Reply : sig 292 | (** A reply sent from the server in response to a [Request]. Note 293 | these arrive out-of-order. *) 294 | 295 | type t = { 296 | error: (unit, Error.t) result (** Success or failure of the request *) 297 | ; handle: int64 (** The unique id in the [Request] *) 298 | } 299 | [@@deriving sexp] 300 | 301 | val to_string : t -> string 302 | 303 | val sizeof : int 304 | 305 | val marshal : Cstruct.t -> t -> unit 306 | 307 | val unmarshal : Cstruct.t -> (t, exn) result 308 | end 309 | -------------------------------------------------------------------------------- /lib/s.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | open Channel 15 | 16 | (** Common signatures used in the library. *) 17 | 18 | module type CLIENT = sig 19 | (** A Client allows you to list the disks available on a server, connect to 20 | a specific disk and then issue read and write requests. *) 21 | 22 | include 23 | Mirage_block.S 24 | with type error = 25 | [Mirage_block.error | `Protocol_error of Protocol.Error.t] 26 | and type write_error = 27 | [Mirage_block.write_error | `Protocol_error of Protocol.Error.t] 28 | 29 | (** The size of a remote disk *) 30 | type size = int64 31 | 32 | val list : channel -> (string list, [`Policy | `Unsupported]) result Lwt.t 33 | (** [list channel] returns a list of exports known by the server. 34 | [`Error `Policy] means the server has this function disabled deliberately. 35 | [`Error `Unsupported] means the server is old and does not support the query 36 | function. *) 37 | 38 | val negotiate : 39 | channel -> string -> (t * size * Protocol.PerExportFlag.t list) Lwt.t 40 | (** [negotiate channel export] takes an already-connected channel, 41 | performs the initial protocol negotiation and connects to 42 | the named export. Returns [disk * remote disk size * flags] *) 43 | end 44 | 45 | module type SERVER = sig 46 | (** A Server allows you to expose an existing block device to remote clients 47 | over NBD. *) 48 | 49 | (** An open connection to an NBD client *) 50 | type t 51 | 52 | (** The size of a remote disk *) 53 | type size = int64 54 | 55 | (** The name of an export. In the 'new style' protocol as used in nbd >= 2.9.17 56 | the client must select an export by name. *) 57 | type name = string 58 | 59 | (** The client terminated the option haggling phase by sending NBD_OPT_ABORT *) 60 | exception Client_requested_abort 61 | 62 | val connect : 63 | cleartext_channel -> ?offer:name list -> unit -> (name * t) Lwt.t 64 | (** [connect cleartext_channel ?offer ()] performs the 'new style' initial 65 | handshake and options negotiation. 66 | Note that FORCEDTLS mode will be used in the negotiation unless 67 | [cleartext_channel.make_tls_channel] is None, signifying NOTLS mode. 68 | If [?offer] is provided then these names will be returned if the client 69 | requests a list of exports, otherwise we will return EPERM. 70 | The client's choice of name is returned which must be looked up by the 71 | application. If the name is invalid, the only option is to close the connection. 72 | If the name is valid then use the [serve] function. 73 | 74 | Raises {!Client_requested_abort} if the client aborts the option haggilng 75 | phase instead of entering the transmission phase *) 76 | 77 | val serve : 78 | t 79 | -> ?read_only:bool 80 | -> (module Mirage_block.S with type t = 'b) 81 | -> 'b 82 | -> unit Lwt.t 83 | (** [serve t read_only block b] runs forever processing requests from [t], using [block] 84 | device type [b]. If [read_only] is true, which is the default, the 85 | [block] device [b] is served in read-only mode: the server will set the 86 | NBD_FLAG_READ_ONLY transmission flag, and if the client issues a write 87 | command, the server will send an EPERM error to the client and will 88 | terminate the session. *) 89 | 90 | val close : t -> unit Lwt.t 91 | (** [close t] shuts down the connection [t] and frees any allocated resources *) 92 | 93 | val with_connection : 94 | Channel.cleartext_channel 95 | -> ?offer:name list 96 | -> (string -> t -> unit Lwt.t) 97 | -> unit Lwt.t 98 | (** [with_connection clearchan ~offer f] calls [connect clearchan ~offer] and 99 | attempts to apply [f] to the resulting [t], with a guarantee to call 100 | [close t] afterwards. *) 101 | end 102 | -------------------------------------------------------------------------------- /lib/server.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | open Lwt.Infix 16 | open Protocol 17 | open Channel 18 | 19 | exception Client_requested_abort 20 | 21 | type name = string 22 | 23 | type t = { 24 | channel: channel 25 | ; request: Cstruct.t 26 | ; (* buffer used to read the request headers *) 27 | reply: Cstruct.t 28 | ; (* buffer used to write the response headers *) 29 | m: Lwt_mutex.t (* prevents partial message interleaving *) 30 | } 31 | 32 | type size = int64 33 | 34 | let close t = t.channel.close () 35 | 36 | let make channel = 37 | let request = Cstruct.create Request.sizeof in 38 | let reply = Cstruct.create Reply.sizeof in 39 | let m = Lwt_mutex.create () in 40 | {channel; request; reply; m} 41 | 42 | let connect channel ?offer () = 43 | let section = Lwt_log_core.Section.make "Server.connect" in 44 | Lwt_log_core.notice ~section "Starting fixed-newstyle negotiation" 45 | >>= fun () -> 46 | ( match offer with 47 | | Some offers -> 48 | Lwt_list.iter_s 49 | (fun name -> 50 | if String.length name > 4096 then 51 | Lwt.fail_with "export name must be no longer than 4096 bytes" 52 | else 53 | Lwt.return_unit 54 | ) 55 | offers 56 | | None -> 57 | Lwt.return_unit 58 | ) 59 | >>= fun () -> 60 | let buf = Cstruct.create Announcement.sizeof in 61 | Announcement.(marshal buf `V2) ; 62 | channel.write_clear buf >>= fun () -> 63 | let buf = Cstruct.create (Negotiate.sizeof `V2) in 64 | Negotiate.(marshal buf (V2 [GlobalFlag.Fixed_newstyle])) ; 65 | channel.write_clear buf >>= fun () -> 66 | let buf = Cstruct.create NegotiateResponse.sizeof in 67 | channel.read_clear buf >>= fun () -> 68 | (* Option negotiation *) 69 | let req = Cstruct.create OptionRequestHeader.sizeof in 70 | let res = Cstruct.create OptionResponseHeader.sizeof in 71 | let make_blank_payload hdr = 72 | Cstruct.create (Int32.to_int hdr.OptionRequestHeader.length) 73 | in 74 | let respond ?(len = 0) opt resp writefn = 75 | OptionResponseHeader.( 76 | marshal res 77 | {request_type= opt; response_type= resp; length= Int32.of_int len} 78 | ) ; 79 | writefn res 80 | in 81 | let send_ack opt writefn = respond opt OptionResponse.Ack writefn in 82 | let read_hdr_and_payload readfn = 83 | readfn req >>= fun () -> 84 | match OptionRequestHeader.unmarshal req with 85 | | Error e -> 86 | Lwt.fail e 87 | | Ok hdr -> 88 | let payload = make_blank_payload hdr in 89 | readfn payload >>= fun () -> 90 | Lwt.return (hdr.OptionRequestHeader.ty, payload) 91 | in 92 | let generic_loop chan = 93 | let rec loop () = 94 | read_hdr_and_payload chan.read >>= fun (opt, payload) -> 95 | match opt with 96 | | Option.StartTLS -> 97 | let resp = 98 | if chan.is_tls then 99 | OptionResponse.Invalid 100 | else 101 | OptionResponse.Policy 102 | in 103 | respond opt resp chan.write >>= loop 104 | | Option.ExportName -> 105 | Lwt.return (Cstruct.to_string payload, make chan) 106 | | Option.Abort -> 107 | Lwt.catch 108 | (fun () -> send_ack opt chan.write) 109 | (fun exn -> 110 | Lwt_log_core.warning ~section ~exn 111 | "Failed to send ack after receiving abort" 112 | ) 113 | >>= fun () -> Lwt.fail Client_requested_abort 114 | | Option.Unknown _ -> 115 | respond opt OptionResponse.Unsupported chan.write >>= loop 116 | | Option.List -> ( 117 | match offer with 118 | | None -> 119 | respond opt OptionResponse.Policy chan.write >>= loop 120 | | Some offers -> 121 | let rec advertise = function 122 | | [] -> 123 | send_ack opt chan.write 124 | | x :: xs -> 125 | let len = String.length x in 126 | respond ~len:(len + 4) opt OptionResponse.Server chan.write 127 | >>= fun () -> 128 | let name = Cstruct.create (len + 4) in 129 | Cstruct.BE.set_uint32 name 0 (Int32.of_int len) ; 130 | Cstruct.blit_from_string x 0 name 4 len ; 131 | chan.write name >>= fun () -> advertise xs 132 | in 133 | advertise offers >>= loop 134 | ) 135 | in 136 | loop () 137 | in 138 | let negotiate_tls make_tls_channel = 139 | let rec negotiate_tls () = 140 | read_hdr_and_payload channel.read_clear >>= fun (opt, _) -> 141 | match opt with 142 | | Option.ExportName -> 143 | Lwt.fail_with 144 | "Client requested export over cleartext channel but server is in \ 145 | FORCEDTLS mode." 146 | | Option.Abort -> 147 | Lwt.fail_with "Client requested abort (before negotiating TLS)." 148 | | Option.StartTLS -> 149 | send_ack opt channel.write_clear >>= make_tls_channel >>= fun tch -> 150 | generic_loop (Channel.generic_of_tls_channel tch) 151 | (* For any other option, respond saying TLS is required, then await next OptionRequest. *) 152 | | _ -> 153 | respond opt OptionResponse.TlsReqd channel.write_clear 154 | >>= negotiate_tls 155 | in 156 | negotiate_tls () 157 | in 158 | let client_flags = NegotiateResponse.unmarshal buf in 159 | (* Does the client support Fixed_newstyle? *) 160 | let old_client = not (List.mem ClientFlag.Fixed_newstyle client_flags) in 161 | match channel.make_tls_channel with 162 | | None -> 163 | (* We are in NOTLS mode *) 164 | ( if old_client then 165 | Lwt_log_core.warning ~section "Client doesn't report Fixed_newstyle" 166 | else 167 | Lwt.return_unit 168 | ) 169 | >>= fun () -> 170 | (* Continue regardless *) 171 | generic_loop (Channel.generic_of_cleartext_channel channel) 172 | | Some make_tls_channel -> 173 | if (* We are in FORCEDTLS mode *) 174 | old_client then 175 | Lwt_log_core.error ~section 176 | "Server rejecting connection: it wants to use TLS but client flags \ 177 | don't include Fixed_newstyle" 178 | >>= fun () -> 179 | Lwt.fail_with 180 | "client does not report Fixed_newstyle and server is in FORCEDTLS \ 181 | mode." 182 | else 183 | negotiate_tls make_tls_channel 184 | 185 | let with_connection clearchan ?offer f = 186 | connect clearchan ?offer () >>= fun (exportname, t) -> 187 | Lwt.finalize (fun () -> f exportname t) (fun () -> close t) 188 | 189 | let negotiate_end t size flags : t Lwt.t = 190 | let buf = Cstruct.create DiskInfo.sizeof in 191 | DiskInfo.(marshal buf {size; flags}) ; 192 | t.channel.write buf >>= fun () -> 193 | Lwt.return {channel= t.channel; request= t.request; reply= t.reply; m= t.m} 194 | 195 | let next t = 196 | t.channel.read t.request >>= fun () -> 197 | match Request.unmarshal t.request with 198 | | Ok r -> 199 | Lwt.return r 200 | | Error e -> 201 | Lwt.fail e 202 | 203 | let ok t handle payload = 204 | Lwt_mutex.with_lock t.m (fun () -> 205 | Reply.marshal t.reply {Reply.handle; error= Ok ()} ; 206 | t.channel.write t.reply >>= fun () -> 207 | match payload with 208 | | None -> 209 | Lwt.return () 210 | | Some data -> 211 | t.channel.write data 212 | ) 213 | 214 | let error t handle code = 215 | Lwt_mutex.with_lock t.m (fun () -> 216 | Reply.marshal t.reply {Reply.handle; error= Error code} ; 217 | t.channel.write t.reply 218 | ) 219 | 220 | let serve t (type t) ?(read_only = true) block (b : t) = 221 | let section = Lwt_log_core.Section.make "Server.serve" in 222 | let module Block = (val block : Mirage_block.S with type t = t) in 223 | Lwt_log_core.notice_f ~section "Serving new client, read_only = %b" read_only 224 | >>= fun () -> 225 | Block.get_info b >>= fun info -> 226 | let size = 227 | Int64.( 228 | mul info.Mirage_block.size_sectors (of_int info.Mirage_block.sector_size) 229 | ) 230 | in 231 | ( match (read_only, info.Mirage_block.read_write) with 232 | | true, _ -> 233 | Lwt.return true 234 | | false, true -> 235 | Lwt.return false 236 | | false, false -> 237 | Lwt_log_core.error ~section 238 | "Read-write access was requested, but block is read-only, sending \ 239 | NBD_FLAG_READ_ONLY transmission flag" 240 | >>= fun () -> Lwt.return true 241 | ) 242 | >>= fun read_only -> 243 | let flags = if read_only then [PerExportFlag.Read_only] else [] in 244 | negotiate_end t size flags >>= fun t -> 245 | let block = Io_page.(to_cstruct (get 128)) in 246 | let block_size = Cstruct.length block in 247 | let rec loop () = 248 | next t >>= fun request -> 249 | let open Request in 250 | match request with 251 | | {ty= Command.Write; from; len; handle} -> 252 | if read_only then 253 | error t handle `EPERM 254 | else if 255 | Int64.(rem from (of_int info.Mirage_block.sector_size)) <> 0L 256 | || Int64.( 257 | rem (of_int32 len) (of_int info.Mirage_block.sector_size) <> 0L 258 | ) 259 | then 260 | error t handle `EINVAL 261 | else 262 | let rec copy offset remaining = 263 | let n = min block_size remaining in 264 | let subblock = Cstruct.sub block 0 n in 265 | t.channel.Channel.read subblock >>= fun () -> 266 | Block.write b 267 | Int64.(div offset (of_int info.Mirage_block.sector_size)) 268 | [subblock] 269 | >>= function 270 | | Error e -> 271 | Lwt_log_core.debug_f ~section 272 | "Error while writing: %s; returning EIO error" 273 | (Fmt.to_to_string Block.pp_write_error e) 274 | >>= fun () -> error t handle `EIO 275 | | Ok () -> 276 | let remaining = remaining - n in 277 | if remaining > 0 then 278 | copy Int64.(add offset (of_int n)) remaining 279 | else 280 | ok t handle None >>= fun () -> loop () 281 | in 282 | copy from (Int32.to_int request.Request.len) 283 | | {ty= Command.Read; from; len; handle} -> 284 | (* It is okay to disconnect here in case of errors. The NBD protocol 285 | documentation says about NBD_CMD_READ: 286 | "If an error occurs, the server SHOULD set the appropriate error code 287 | in the error field. The server MAY then initiate a hard disconnect. 288 | If it chooses not to, it MUST NOT send any payload for this request. 289 | If an error occurs while reading after the server has already sent out 290 | the reply header with an error field set to zero (i.e., signalling no 291 | error), the server MUST immediately initiate a hard disconnect; it 292 | MUST NOT send any further data to the client." *) 293 | if 294 | Int64.(rem from (of_int info.Mirage_block.sector_size)) <> 0L 295 | || Int64.( 296 | rem (of_int32 len) (of_int info.Mirage_block.sector_size) <> 0L 297 | ) 298 | then 299 | error t handle `EINVAL 300 | else 301 | ok t handle None >>= fun () -> 302 | let rec copy offset remaining = 303 | let n = min block_size remaining in 304 | let subblock = Cstruct.sub block 0 n in 305 | Block.read b 306 | Int64.(div offset (of_int info.Mirage_block.sector_size)) 307 | [subblock] 308 | >>= function 309 | | Error e -> 310 | Lwt.fail_with 311 | (Printf.sprintf 312 | "Partial failure during a Block.read: %s; terminating the \ 313 | session" 314 | (Fmt.to_to_string Block.pp_error e) 315 | ) 316 | | Ok () -> 317 | t.channel.write subblock >>= fun () -> 318 | let remaining = remaining - n in 319 | if remaining > 0 then 320 | copy Int64.(add offset (of_int n)) remaining 321 | else 322 | loop () 323 | in 324 | copy from (Int32.to_int request.Request.len) 325 | | {ty= Command.Disc; _} -> 326 | Lwt_log.notice ~section "Received NBD_CMD_DISC, disconnecting" 327 | >>= fun () -> Lwt.return_unit 328 | | _ -> 329 | Lwt_log_core.warning ~section 330 | "Received unknown command, returning EINVAL" 331 | >>= fun () -> error t request.Request.handle `EINVAL 332 | in 333 | loop () 334 | -------------------------------------------------------------------------------- /lib/server.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (** A Server which allows you to expose an existing block device to 16 | remote clients over NBD. *) 17 | 18 | include S.SERVER 19 | -------------------------------------------------------------------------------- /lib_test/client_server_test.ml: -------------------------------------------------------------------------------- 1 | (** This module tests the NBD server and the NBD client provided by the core 2 | NBD library, by connecting their inputs and outputs together so that they 3 | communicate with each other through an in-memory pipe. 4 | The server and client IO is run in concurrently by Lwt, in the same 5 | process. *) 6 | 7 | open Lwt.Infix 8 | 9 | let with_channels f = 10 | let section = Lwt_log_core.Section.make "with_channels" in 11 | let make_channel name (ic, oc) = 12 | let read c = 13 | let len = Cstruct.length c in 14 | Lwt_log.debug_f ~section "%s read: %d" name len >>= fun () -> 15 | let b = Bytes.create len in 16 | Lwt_io.read_into_exactly ic b 0 len >>= fun () -> 17 | Cstruct.blit_from_bytes b 0 c 0 len ; 18 | Lwt_log.debug_f ~section "%s read: %d: %s finished" name len 19 | (String.escaped (Cstruct.to_string c)) 20 | in 21 | let write c = 22 | let len = Cstruct.length c in 23 | Lwt_log.debug_f ~section "%s write: %d: %s" name len 24 | (String.escaped (Cstruct.to_string c)) 25 | >>= fun () -> 26 | Lwt_io.write_from_string_exactly oc (Cstruct.to_string c) 0 len 27 | >>= fun () -> 28 | Lwt_log.debug_f ~section "%s write: %d: %s finished" name len 29 | (String.escaped (Cstruct.to_string c)) 30 | in 31 | (write, read) 32 | in 33 | let client_to_server = Lwt_io.pipe () in 34 | let server_to_client = Lwt_io.pipe () in 35 | let client_write, server_read = 36 | make_channel "client -> server" client_to_server 37 | in 38 | let server_write, client_read = 39 | make_channel "server -> client" server_to_client 40 | in 41 | let noop () = Lwt.return_unit in 42 | let client_channel = 43 | Nbd.Channel. 44 | {read= client_read; write= client_write; close= noop; is_tls= false} 45 | 46 | in 47 | 48 | let server_channel = 49 | Nbd.Channel. 50 | { 51 | read_clear= server_read 52 | ; write_clear= server_write 53 | ; close_clear= noop 54 | ; make_tls_channel= None 55 | } 56 | 57 | in 58 | 59 | Lwt_unix.with_timeout 0.5 (fun () -> f client_channel server_channel) 60 | 61 | (** Run the given server and client test sequences concurrently with channels 62 | connecting the server and the client together. *) 63 | let test ~server ~client () = 64 | Lwt_log.add_rule "*" Lwt_log.Debug ; 65 | with_channels (fun client_channel server_channel -> 66 | let test_server = server server_channel in 67 | let cancel, _ = Lwt.task () in 68 | let test_server = 69 | Lwt.catch 70 | (fun () -> Lwt.pick [test_server; cancel]) 71 | (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) 72 | in 73 | let test_client = 74 | client client_channel 75 | (* TODO: because Client.disconnect does not send NBD_CMD_DISC, 76 | the server loop will not stop - we have to stop it manually. 77 | Once this is fixed, this cancel mechanism should be removed. *) 78 | >|= 79 | fun () -> Lwt.cancel cancel 80 | in 81 | Lwt.join [test_server; test_client] 82 | ) 83 | 84 | (** We fail the test if an error occurs *) 85 | let check msg = function 86 | | Result.Ok a -> 87 | Lwt.return a 88 | | Result.Error _ -> 89 | Lwt.fail_with msg 90 | 91 | let test_connect_disconnect _switch = 92 | let test_block = Cstruct.of_string "asdf" in 93 | test 94 | ~server:(fun server_channel -> 95 | Nbd.Server.connect server_channel () >>= fun (export_name, svr) -> 96 | Alcotest.(check string) 97 | "export name received by server" "export1" export_name ; 98 | Nbd.Server.serve svr ~read_only:false 99 | (module Cstruct_block.Block) 100 | test_block 101 | ) 102 | ~client:(fun client_channel -> 103 | Nbd.Client.negotiate client_channel "export1" >>= fun (t, size, _flags) -> 104 | Alcotest.(check int64) 105 | "size received by client" 106 | (Int64.of_int (Cstruct.length test_block)) 107 | size ; 108 | Nbd.Client.disconnect t 109 | ) 110 | 111 | let test_list_exports _switch = 112 | test 113 | ~server:(fun server_channel -> 114 | Lwt.catch 115 | (fun () -> 116 | Nbd.Server.connect ~offer:["export1"; "export2"] server_channel () 117 | >>= fun _ -> Alcotest.fail "Server should not enter transmission mode" 118 | ) 119 | (function 120 | | Nbd.Server.Client_requested_abort -> 121 | Lwt.return_unit 122 | | e -> 123 | Lwt.fail e 124 | ) 125 | ) 126 | ~client:(fun client_channel -> 127 | Nbd.Client.list client_channel >|= fun exports -> 128 | Alcotest.(check (result (slist string String.compare) reject)) 129 | "Received correct export names" 130 | (Ok ["export1"; "export2"]) 131 | exports 132 | ) 133 | 134 | let test_read_write _switch = 135 | let test_block = Cstruct.of_string "asdf" in 136 | test 137 | ~server:(fun server_channel -> 138 | Nbd.Server.connect server_channel () >>= fun (_export_name, svr) -> 139 | Nbd.Server.serve svr ~read_only:false 140 | (module Cstruct_block.Block) 141 | test_block 142 | ) 143 | ~client:(fun client_channel -> 144 | Nbd.Client.negotiate client_channel "export1" 145 | >>= fun (t, _size, _flags) -> 146 | let buf = Cstruct.create 2 in 147 | Nbd.Client.read t 1L [buf] >>= check "1st read failed" >>= fun () -> 148 | Alcotest.(check string) "2 bytes at offset 1" "sd" (Cstruct.to_string buf) ; 149 | 150 | let buf = Cstruct.of_string "12" in 151 | Nbd.Client.write t 2L [buf] >>= check "Write failed" >>= fun () -> 152 | let buf = Cstruct.create 2 in 153 | Nbd.Client.read t 2L [buf] >>= check "2nd read failed" >>= fun () -> 154 | Alcotest.(check string) 155 | "2 modified bytes at offset 2" "12" (Cstruct.to_string buf) ; 156 | 157 | Nbd.Client.disconnect t 158 | ) 159 | 160 | let tests = 161 | let t = Alcotest_lwt.test_case in 162 | ( "Nbd client-server connection tests" 163 | , [ 164 | t "test_connect_disconnect" `Quick test_connect_disconnect 165 | ; t "test_list_exports" `Quick test_list_exports 166 | ; t "test_read_write" `Quick test_read_write 167 | ] 168 | ) 169 | -------------------------------------------------------------------------------- /lib_test/cstruct_block.ml: -------------------------------------------------------------------------------- 1 | (** A Mirage block module backed by a Cstruct for unit testing the NBD server *) 2 | module Block : Mirage_block.S with type t = Cstruct.t = struct 3 | type error = Mirage_block.error 4 | 5 | let pp_error = Mirage_block.pp_error 6 | 7 | type write_error = Mirage_block.write_error 8 | 9 | let pp_write_error = Mirage_block.pp_write_error 10 | 11 | type t = Cstruct.t 12 | 13 | let disconnect _ = Lwt.return_unit 14 | 15 | let get_info contents = 16 | Lwt.return 17 | Mirage_block. 18 | { 19 | read_write= true 20 | ; sector_size= 1 21 | ; size_sectors= Cstruct.length contents |> Int64.of_int 22 | } 23 | 24 | 25 | let read contents sector_start buffers = 26 | let sector_start = Int64.to_int sector_start in 27 | List.fold_left 28 | (fun contents buffer -> 29 | Cstruct.fillv ~src:[contents] ~dst:buffer |> ignore ; 30 | Cstruct.shift contents (Cstruct.length buffer) 31 | ) 32 | (Cstruct.shift contents sector_start) 33 | buffers 34 | |> ignore ; 35 | Lwt.return_ok () 36 | 37 | let write contents sector_start buffers = 38 | let sector_start = Int64.to_int sector_start in 39 | Cstruct.fillv ~src:buffers ~dst:(Cstruct.shift contents sector_start) 40 | |> ignore ; 41 | Lwt.return_ok () 42 | end 43 | -------------------------------------------------------------------------------- /lib_test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names suite mux_test) 3 | (package nbd) 4 | (libraries alcotest alcotest-lwt io-page lwt.unix lwt_log nbd)) 5 | -------------------------------------------------------------------------------- /lib_test/mux_test.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module TestPacket = struct 4 | type id = int 5 | 6 | type request_hdr = {req_id: int; req_payload: bytes} [@@deriving sexp] 7 | 8 | type request_body = bytes 9 | 10 | type response_hdr = {res_id: int option; res_payload: bytes} [@@deriving sexp] 11 | 12 | type response_body = bytes 13 | 14 | type seq = Request of request_hdr | Response of response_hdr 15 | 16 | type transport = { 17 | recv_cond: unit Lwt_condition.t 18 | ; mutex: Lwt_mutex.t 19 | ; recv_queue: response_hdr Queue.t 20 | ; mutable seq: seq list 21 | } 22 | 23 | let record_sequence = ref true 24 | 25 | let recv_hdr t = 26 | Lwt_mutex.with_lock t.mutex (fun () -> 27 | let loop () = 28 | if Queue.is_empty t.recv_queue then 29 | Lwt_condition.wait ~mutex:t.mutex t.recv_cond 30 | else 31 | Lwt.return () 32 | in 33 | loop () >>= fun () -> 34 | let res = Queue.pop t.recv_queue in 35 | if !record_sequence then t.seq <- Response res :: t.seq ; 36 | Lwt.return (res.res_id, res) 37 | ) 38 | 39 | let recv_body _t _req_hdr rsp_hdr rsp_body = 40 | Bytes.blit rsp_hdr.res_payload 0 rsp_body 0 41 | (Bytes.length rsp_hdr.res_payload) ; 42 | Lwt.return_ok () 43 | 44 | let send_one t x _ = 45 | Lwt_mutex.with_lock t.mutex (fun () -> 46 | if !record_sequence then t.seq <- Request x :: t.seq ; 47 | Lwt.return () 48 | ) 49 | 50 | let id_of_request r = r.req_id 51 | 52 | let handle_unrequested_packet _t p = 53 | if p.res_payload |> Bytes.to_string = "exception" then 54 | Lwt.fail_with "requested exception" 55 | else 56 | Lwt.return () 57 | 58 | let create () = 59 | { 60 | recv_cond= Lwt_condition.create () 61 | ; mutex= Lwt_mutex.create () 62 | ; recv_queue= Queue.create () 63 | ; seq= [] 64 | } 65 | 66 | let queue_response res t = 67 | Lwt_mutex.with_lock t.mutex (fun () -> 68 | Queue.push res t.recv_queue ; 69 | Lwt_condition.broadcast t.recv_cond () ; 70 | Lwt.return () 71 | ) 72 | end 73 | 74 | module T = Nbd.Mux.Make (TestPacket) 75 | 76 | (* Some helpful packets for all tests *) 77 | let p1 = TestPacket.{req_id= 1; req_payload= "p1" |> Bytes.of_string} 78 | 79 | let p2 = TestPacket.{req_id= 2; req_payload= "p2" |> Bytes.of_string} 80 | 81 | let r1 = TestPacket.{res_id= Some 1; res_payload= "r1" |> Bytes.of_string} 82 | 83 | let r2 = TestPacket.{res_id= Some 2; res_payload= "r2" |> Bytes.of_string} 84 | 85 | let ( >>|= ) m f = 86 | (* Check for an `Ok result in an Lwt thread, and fail the 87 | thread if it's an Error *) 88 | m >>= function 89 | | Ok x -> 90 | f x 91 | | Error x -> 92 | Lwt.fail_with (Nbd.Protocol.Error.to_string x) 93 | 94 | let test_rpc = 95 | ( "Basic test of the rpc function" 96 | , `Quick 97 | , fun () -> 98 | let t = 99 | let transport = TestPacket.create () in 100 | T.create transport >>= fun client -> 101 | let open TestPacket in 102 | let response = Bytes.create 2 in 103 | let t1 = T.rpc p1 p1.req_payload response client in 104 | TestPacket.queue_response r1 transport >>= fun () -> 105 | t1 >>|= fun () -> Lwt.return (response = r1.res_payload) 106 | in 107 | Alcotest.(check bool) "RPC response correct" true (Lwt_main.run t) 108 | ) 109 | 110 | let test_multi_rpc = 111 | ( "Test queuing of rpc calls in the mux" 112 | , `Quick 113 | , fun () -> 114 | let t = 115 | let transport = TestPacket.create () in 116 | T.create transport >>= fun client -> 117 | let open TestPacket in 118 | let response1 = Bytes.create 2 in 119 | let response2 = Bytes.create 2 in 120 | let t1 = T.rpc p1 p1.req_payload response1 client in 121 | let t2 = T.rpc p2 p2.req_payload response2 client in 122 | TestPacket.queue_response r1 transport >>= fun () -> 123 | TestPacket.queue_response r2 transport >>= fun () -> 124 | t1 >>|= fun () -> 125 | t2 >>|= fun () -> 126 | Lwt.return (response1 = r1.res_payload && response2 = r2.res_payload) 127 | in 128 | Alcotest.(check bool) "Both responses correct" true (Lwt_main.run t) 129 | ) 130 | 131 | let test_out_of_order_responses = 132 | ( "Test RPC functions work when responses are received out of order" 133 | , `Quick 134 | , fun () -> 135 | let t = 136 | let transport = TestPacket.create () in 137 | T.create transport >>= fun client -> 138 | let open TestPacket in 139 | let response1 = Bytes.create 2 in 140 | let response2 = Bytes.create 2 in 141 | let t1 = T.rpc p1 p1.req_payload response1 client in 142 | let t2 = T.rpc p2 p2.req_payload response2 client in 143 | TestPacket.queue_response r2 transport >>= fun () -> 144 | TestPacket.queue_response r1 transport >>= fun () -> 145 | t1 >>|= fun () -> 146 | t2 >>|= fun () -> 147 | Lwt.return (response1 = r1.res_payload && response2 = r2.res_payload) 148 | in 149 | Alcotest.(check bool) "Both responses correct" true (Lwt_main.run t) 150 | ) 151 | 152 | let test_memory_leak = 153 | ( "Check the mux does not have a memory leak" 154 | , `Quick 155 | , fun () -> 156 | let t = 157 | let transport = TestPacket.create () in 158 | T.create transport >>= fun client -> 159 | let open TestPacket in 160 | let response1 = Bytes.create 2 in 161 | TestPacket.record_sequence := false ; 162 | let rec megaqueue n = 163 | if n = 100000 then 164 | Lwt.return true 165 | else 166 | let t1 = T.rpc p1 p1.req_payload response1 client in 167 | TestPacket.queue_response r1 transport >>= fun () -> 168 | t1 >>= fun _ -> 169 | let ok = 170 | if n mod 10000 = 0 then ( 171 | Gc.compact () ; 172 | let test = Gc.stat () in 173 | test.Gc.live_words < 100000 174 | ) else 175 | true 176 | in 177 | if ok then megaqueue (n + 1) else Lwt.return false 178 | in 179 | megaqueue 0 180 | in 181 | Alcotest.(check bool) "Memory leak" true (Lwt_main.run t) 182 | ) 183 | 184 | let test_exception_handling = 185 | ( "Check that exceptions raised are handled correctly" 186 | , `Quick 187 | , fun () -> 188 | let t = 189 | let transport = TestPacket.create () in 190 | T.create transport >>= fun client -> 191 | let open TestPacket in 192 | let response1 = Bytes.create 2 in 193 | TestPacket.queue_response 194 | {res_id= None; res_payload= "exception" |> Bytes.of_string} 195 | transport 196 | >>= fun () -> 197 | let t1 = T.rpc p1 p1.req_payload response1 client in 198 | TestPacket.queue_response r2 transport >>= fun () -> 199 | Lwt.catch 200 | (fun () -> 201 | t1 >>= function 202 | | Ok _ -> 203 | Lwt.return false 204 | | Error _ -> 205 | Lwt.return true 206 | ) 207 | (fun e -> 208 | Printf.printf "Exception: %s\n%!" (Printexc.to_string e) ; 209 | Lwt.return true 210 | ) 211 | in 212 | Alcotest.(check bool) "Exception handled" true (Lwt_main.run t) 213 | ) 214 | 215 | let tests = 216 | ( "Mux tests" 217 | , [ 218 | test_rpc 219 | ; test_multi_rpc 220 | ; test_out_of_order_responses 221 | ; test_memory_leak 222 | ; test_exception_handling 223 | ] 224 | ) 225 | 226 | let () = Alcotest.run "Sync Nbd library test suite" [tests] 227 | -------------------------------------------------------------------------------- /lib_test/protocol_test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2015 Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (** Tests that the client and server correctly implement the NBD protocol: 16 | https://github.com/NetworkBlockDevice/nbd/blob/master/doc/proto.md 17 | 18 | This module tests the core NBD library by verifying that the communication 19 | between the client and the server exactly matches the specified test 20 | sequences. *) 21 | 22 | open Lwt.Infix 23 | 24 | (** An Alcotest TESTABLE for the data transmissions in the test sequences *) 25 | let transmission = 26 | let fmt = 27 | Fmt.of_to_string (function 28 | | `Server, x -> 29 | "Server: " ^ String.escaped x 30 | | `Client, x -> 31 | "Client: " ^ String.escaped x 32 | ) 33 | in 34 | Alcotest.testable fmt ( = ) 35 | 36 | (** The client or server wanted to read and there is no more data from the 37 | other side. *) 38 | exception Failed_to_read_empty_stream 39 | 40 | (** [make_channel role test_sequence] creates a channel for use by the NBD library 41 | from a test sequence containing the expected communication between the 42 | client and the server. Reads and writes will verify that the communication 43 | matches exactly what is in [test_sequence], which is a list of data 44 | transmission tuples, each specifying whether the client or the server is 45 | sending the data, and the actual data sent. [role] specifies whether the 46 | client or the server will use the created channel, the other side will be 47 | simulated by taking the responses from [test_sequence]. *) 48 | let make_channel role test_sequence = 49 | let next = ref test_sequence in 50 | let rec read buf = 51 | Lwt_io.printlf "Reading %d bytes" (Cstruct.length buf) >>= fun () -> 52 | (* Ignore reads and writes of length 0 and treat them as a no-op *) 53 | if Cstruct.length buf = 0 then 54 | Lwt.return_unit 55 | else 56 | match !next with 57 | | (source, x) :: rest -> 58 | if source = role then failwith "Tried to read but should have written" ; 59 | let available = min (Cstruct.length buf) (String.length x) in 60 | Cstruct.blit_from_string x 0 buf 0 available ; 61 | next := 62 | if available = String.length x then 63 | rest 64 | else 65 | (source, String.sub x available (String.length x - available)) 66 | :: rest ; 67 | Lwt_io.printlf "Read: %s" (x |> String.escaped) >>= fun () -> 68 | Lwt_io.flush_all () >>= fun () -> 69 | (* Ensure all debug messages get logged *) 70 | let buf = Cstruct.shift buf available in 71 | if Cstruct.length buf = 0 then 72 | Lwt.return () 73 | else 74 | read buf 75 | | [] -> 76 | Lwt.fail Failed_to_read_empty_stream 77 | in 78 | let rec write buf = 79 | Lwt_io.printlf "Writing: %s" (buf |> Cstruct.to_string |> String.escaped) 80 | >>= fun () -> 81 | (* Ignore reads and writes of length 0 and treat them as a no-op *) 82 | if Cstruct.length buf = 0 then 83 | Lwt.return_unit 84 | else 85 | match !next with 86 | | (source, x) :: rest -> 87 | if source <> role then failwith "Tried to write but should have read" ; 88 | let available = min (Cstruct.length buf) (String.length x) in 89 | let written = String.sub (Cstruct.to_string buf) 0 available in 90 | let expected = String.sub x 0 available in 91 | Alcotest.(check (of_pp (Fmt.of_to_string String.escaped))) 92 | "Wrote expected data" expected written ; 93 | Lwt_io.printlf "Wrote %s" (written |> String.escaped) >>= fun () -> 94 | Lwt_io.flush_all () >>= fun () -> 95 | (* Ensure all debug messages get logged *) 96 | next := 97 | if available = String.length x then 98 | rest 99 | else 100 | (source, String.sub x available (String.length x - available)) 101 | :: rest ; 102 | let buf = Cstruct.shift buf available in 103 | if Cstruct.length buf = 0 then 104 | Lwt.return () 105 | else 106 | write buf 107 | | [] -> 108 | Lwt.fail_with 109 | (Printf.sprintf "Tried to write %s but the stream was empty" 110 | (buf |> Cstruct.to_string |> String.escaped) 111 | ) 112 | in 113 | let close () = Lwt.return () in 114 | let assert_processed_complete_sequence () = 115 | Alcotest.(check (list transmission)) 116 | "did not process complete sequence" !next [] 117 | in 118 | (assert_processed_complete_sequence, (read, write, close)) 119 | 120 | (** Passes a channel for use by the NBD client to the given function, verifying 121 | that all communcation matches the given test sequence and that the complete 122 | sequence has been processed after the function returns. 123 | Returns a function that can be passed to create a Alcotest_lwt.test_case *) 124 | let with_client_channel s f _switch () = 125 | let assert_processed_complete_sequence, (read, write, close) = 126 | make_channel `Client s 127 | in 128 | f Nbd.Channel.{read; write; close; is_tls= false} >>= fun () -> 129 | assert_processed_complete_sequence () ; 130 | Lwt.return_unit 131 | 132 | (** Passes a channel for use by the NBD server to the given function, verifying 133 | that all communcation matches the given test sequence and that the complete 134 | sequence has been processed after the function returns. 135 | Returns a function that can be passed to create a Alcotest_lwt.test_case *) 136 | let with_server_channel s f _switch () = 137 | let assert_processed_complete_sequence, (read, write, close) = 138 | make_channel `Server s 139 | in 140 | f 141 | Nbd.Channel. 142 | { 143 | read_clear= read 144 | ; write_clear= write 145 | ; close_clear= close 146 | ; make_tls_channel= None 147 | } 148 | 149 | >>= fun () -> 150 | assert_processed_complete_sequence () ; 151 | Lwt.return_unit 152 | 153 | (* NBD constants used in the test sequences *) 154 | (* All the flags in the NBD protocol are in network byte order (big-endian) *) 155 | 156 | let option_reply_magic_number = "\x00\x03\xe8\x89\x04\x55\x65\xa9" 157 | 158 | let nbd_request_magic = "\x25\x60\x95\x13" 159 | 160 | let nbd_reply_magic = "\x67\x44\x66\x98" 161 | 162 | (* Shared test sequences used both for client and server tests *) 163 | 164 | let v2_negotiation_start = 165 | [ 166 | (`Server, "NBDMAGIC") 167 | ; (`Server, "IHAVEOPT") 168 | ; (`Server, "\000\001") 169 | ; (* handshake flags: NBD_FLAG_FIXED_NEWSTYLE *) 170 | (`Client, "\000\000\000\001") 171 | ; (* client flags: NBD_FLAG_C_FIXED_NEWSTYLE *) 172 | (`Client, "IHAVEOPT") 173 | ; (`Client, "\000\000\000\001") 174 | ; (* NBD_OPT_EXPORT_NAME *) 175 | (`Client, "\000\000\000\007") 176 | ; (* length of export name *) 177 | (`Client, "export1") 178 | ] 179 | 180 | let list_exports_disabled = 181 | [ 182 | (`Server, "NBDMAGIC") 183 | ; (* read *) 184 | (`Server, "IHAVEOPT") 185 | ; (`Server, "\000\001") 186 | ; (* handshake flags: NBD_FLAG_FIXED_NEWSTYLE *) 187 | (`Client, "\000\000\000\001") 188 | ; (* client flags: NBD_FLAG_C_FIXED_NEWSTYLE *) 189 | (`Client, "IHAVEOPT") 190 | ; (`Client, "\000\000\000\003") 191 | ; (* NBD_OPT_LIST *) 192 | (`Client, "\000\000\000\000") 193 | ; (`Server, option_reply_magic_number) 194 | ; (`Server, "\000\000\000\003") 195 | ; (`Server, "\128\000\000\002") 196 | ; (* NBD_REP_ERR_POLICY *) 197 | (`Server, "\000\000\000\000") 198 | ; (`Client, "IHAVEOPT") 199 | ; (`Client, "\000\000\000\002") 200 | ; (* NBD_OPT_ABORT *) 201 | (`Client, "\000\000\000\000") 202 | ; (`Server, option_reply_magic_number) 203 | ; (`Server, "\000\000\000\002") 204 | ; (`Server, "\000\000\000\001") 205 | ; (* NBD_REP_ACK *) 206 | (`Server, "\000\000\000\000") 207 | ] 208 | 209 | let list_exports_success = 210 | [ 211 | (`Server, "NBDMAGIC") 212 | ; (* read *) 213 | (`Server, "IHAVEOPT") 214 | ; (`Server, "\000\001") 215 | ; (* handshake flags: NBD_FLAG_FIXED_NEWSTYLE *) 216 | (`Client, "\000\000\000\001") 217 | ; (* client flags: NBD_FLAG_C_FIXED_NEWSTYLE *) 218 | (`Client, "IHAVEOPT") 219 | ; (`Client, "\000\000\000\003") 220 | ; (* NBD_OPT_LIST *) 221 | (`Client, "\000\000\000\000") 222 | ; (`Server, option_reply_magic_number) 223 | ; (`Server, "\000\000\000\003") 224 | ; (`Server, "\000\000\000\002") 225 | ; (* NBD_REP_SERVER *) 226 | (`Server, "\000\000\000\011") 227 | ; (`Server, "\000\000\000\007") 228 | ; (`Server, "export1") 229 | ; (`Server, option_reply_magic_number) 230 | ; (`Server, "\000\000\000\003") 231 | ; (`Server, "\000\000\000\002") 232 | ; (* NBD_REP_SERVER *) 233 | (`Server, "\000\000\000\011") 234 | ; (`Server, "\000\000\000\007") 235 | ; (`Server, "export2") 236 | ; (`Server, option_reply_magic_number) 237 | ; (`Server, "\000\000\000\003") 238 | ; (`Server, "\000\000\000\001") 239 | ; (* NBD_REP_ACK *) 240 | (`Server, "\000\000\000\000") 241 | ; (`Client, "IHAVEOPT") 242 | ; (`Client, "\000\000\000\002") 243 | ; (* NBD_OPT_ABORT *) 244 | (`Client, "\000\000\000\000") 245 | ; (`Server, option_reply_magic_number) 246 | ; (`Server, "\000\000\000\002") 247 | ; (`Server, "\000\000\000\001") 248 | ; (* NBD_REP_ACK *) 249 | (`Server, "\000\000\000\000") 250 | ] 251 | 252 | module ClientTests = struct 253 | let test_v2_negotiation = 254 | (* The server only sends this extra data after Nbd.Server.connect when we call Nbd.Server.serve *) 255 | let v2_negotiation = 256 | v2_negotiation_start 257 | @ [ 258 | (`Server, "\000\000\000\000\001\000\000\000") 259 | ; (* size *) 260 | (`Server, "\000\001") 261 | ; (* transmission flags: NBD_FLAG_HAS_FLAGS (bit 0) *) 262 | (`Server, String.make 124 '\000') 263 | ] 264 | in 265 | Alcotest_lwt.test_case 266 | "Perform a negotiation using the second version of the protocol from the\n\ 267 | \ client's side." `Quick 268 | (with_client_channel v2_negotiation (fun channel -> 269 | Nbd.Client.negotiate channel "export1" >>= fun _ -> Lwt.return () 270 | ) 271 | ) 272 | 273 | let test_list_exports_disabled = 274 | Alcotest_lwt.test_case 275 | "Check that if we request a list of exports and are denied, the error is\n\ 276 | \ reported properly." `Quick 277 | (with_client_channel list_exports_disabled (fun channel -> 278 | Nbd.Client.list channel >>= function 279 | | Error `Policy -> 280 | Lwt.return () 281 | | _ -> 282 | failwith "Expected to receive a Policy error" 283 | ) 284 | ) 285 | 286 | (** After a NBD_OPT_LIST, the client sends an abort, but the server 287 | * disconnects without sending an ack. The NBD protocol says: "the client 288 | * SHOULD gracefully handle the server closing the connection after receiving 289 | * an NBD_OPT_ABORT without it sending a reply" *) 290 | let test_no_ack_after_abort = 291 | let sequence = 292 | [ 293 | (`Server, "NBDMAGIC") 294 | ; (* read *) 295 | (`Server, "IHAVEOPT") 296 | ; (`Server, "\000\001") 297 | ; (* handshake flags: NBD_FLAG_FIXED_NEWSTYLE *) 298 | (`Client, "\000\000\000\001") 299 | ; (* client flags: NBD_FLAG_C_FIXED_NEWSTYLE *) 300 | (`Client, "IHAVEOPT") 301 | ; (`Client, "\000\000\000\003") 302 | ; (* NBD_OPT_LIST *) 303 | (`Client, "\000\000\000\000") 304 | ; (`Server, option_reply_magic_number) 305 | ; (`Server, "\000\000\000\003") 306 | ; (`Server, "\128\000\000\002") 307 | ; (* NBD_REP_ERR_POLICY *) 308 | (`Server, "\000\000\000\000") 309 | ; (`Client, "IHAVEOPT") 310 | ; (`Client, "\000\000\000\002") 311 | ; (* NBD_OPT_ABORT *) 312 | (`Client, "\000\000\000\000") 313 | ] 314 | in 315 | Alcotest_lwt.test_case 316 | "Server denies listing exports, and disconnects after abort without \ 317 | sending ack" 318 | `Quick 319 | (with_client_channel sequence (fun channel -> 320 | Nbd.Client.list channel >>= function 321 | | Error `Policy -> 322 | Lwt.return () 323 | | _ -> 324 | failwith "Expected to receive a Policy error" 325 | ) 326 | ) 327 | 328 | let test_list_exports_success = 329 | Alcotest_lwt.test_case "Client requests a list of exports" `Quick 330 | (with_client_channel list_exports_success (fun channel -> 331 | Nbd.Client.list channel >|= fun res -> 332 | Alcotest.(check (result (slist string String.compare) reject)) 333 | "Returned correct export names" 334 | (Ok ["export1"; "export2"]) 335 | res 336 | ) 337 | ) 338 | 339 | let test_list_exports_extra_data = 340 | let sequence = 341 | [ 342 | (`Server, "NBDMAGIC") 343 | ; (* read *) 344 | (`Server, "IHAVEOPT") 345 | ; (`Server, "\000\001") 346 | ; (* handshake flags: NBD_FLAG_FIXED_NEWSTYLE *) 347 | (`Client, "\000\000\000\001") 348 | ; (* client flags: NBD_FLAG_C_FIXED_NEWSTYLE *) 349 | (`Client, "IHAVEOPT") 350 | ; (`Client, "\000\000\000\003") 351 | ; (* NBD_OPT_LIST *) 352 | (`Client, "\000\000\000\000") 353 | ; (`Server, option_reply_magic_number) 354 | ; (`Server, "\000\000\000\003") 355 | ; (`Server, "\000\000\000\002") 356 | ; (* NBD_REP_SERVER *) 357 | (`Server, "\000\000\000\018") 358 | ; (`Server, "\000\000\000\007") 359 | ; (* The NBD protocol allows for extra implementation-specific data after the export name *) 360 | (`Server, "export2") 361 | ; (`Server, option_reply_magic_number) 362 | ; (`Server, "\000\000\000\003") 363 | ; (`Server, "\000\000\000\001") 364 | ; (* NBD_REP_ACK *) 365 | (`Server, "\000\000\000\000") 366 | ; (`Client, "IHAVEOPT") 367 | ; (`Client, "\000\000\000\002") 368 | ; (* NBD_OPT_ABORT *) 369 | (`Client, "\000\000\000\000") 370 | ; (`Server, option_reply_magic_number) 371 | ; (`Server, "\000\000\000\002") 372 | ; (`Server, "\000\000\000\001") 373 | ; (* NBD_REP_ACK *) 374 | (`Server, "\000\000\000\000") 375 | ] 376 | in 377 | Alcotest_lwt.test_case "List exports with extra data after export name" 378 | `Quick 379 | (with_client_channel sequence (fun channel -> 380 | Nbd.Client.list channel >>= function 381 | | Ok ["export2"] -> 382 | Lwt.return () 383 | | _ -> 384 | failwith "Expected to receive a list of exports" 385 | ) 386 | ) 387 | end 388 | 389 | module ServerTests = struct 390 | let test_v2_negotiation = 391 | Alcotest_lwt.test_case 392 | "Perform a negotiation using the second version of the protocol from the\n\ 393 | \ server's side." `Quick 394 | (with_server_channel v2_negotiation_start (fun channel -> 395 | Nbd.Server.connect channel () >|= fun (export_name, _svr) -> 396 | Alcotest.(check string) 397 | "The server did not receive the correct export name" "export1" 398 | export_name 399 | ) 400 | ) 401 | 402 | let test_abort = 403 | let sequence = 404 | [ 405 | (`Server, "NBDMAGIC") 406 | ; (`Server, "IHAVEOPT") 407 | ; (`Server, "\000\001") 408 | ; (* handshake flags: NBD_FLAG_FIXED_NEWSTYLE *) 409 | (`Client, "\000\000\000\001") 410 | ; (* client flags: NBD_FLAG_C_FIXED_NEWSTYLE *) 411 | (`Client, "IHAVEOPT") 412 | ; (`Client, "\000\000\000\002") 413 | ; (* NBD_OPT_ABORT *) 414 | (`Client, "\000\000\000\000") 415 | ; (`Server, option_reply_magic_number) 416 | ; (`Server, "\000\000\000\002") 417 | ; (`Server, "\000\000\000\001") 418 | ; (* NBD_REP_ACK *) 419 | (`Server, "\000\000\000\000") 420 | ] 421 | in 422 | Alcotest_lwt.test_case "Client connects then aborts" `Quick 423 | (with_server_channel sequence (fun channel -> 424 | Lwt.catch 425 | (fun () -> 426 | Nbd.Server.connect channel () >>= fun _ -> 427 | Alcotest.fail "Server should not enter transmission mode" 428 | ) 429 | (function 430 | | Nbd.Server.Client_requested_abort -> 431 | Lwt.return_unit 432 | | e -> 433 | Lwt.fail e 434 | ) 435 | ) 436 | ) 437 | 438 | (** The NBD protocol says: "the server SHOULD gracefully handle the client 439 | * sending an NBD_OPT_ABORT and closing the connection without waiting for a 440 | * reply." *) 441 | let test_abort_without_ack = 442 | let sequence = 443 | [ 444 | (`Server, "NBDMAGIC") 445 | ; (`Server, "IHAVEOPT") 446 | ; (`Server, "\000\001") 447 | ; (* handshake flags: NBD_FLAG_FIXED_NEWSTYLE *) 448 | (`Client, "\000\000\000\001") 449 | ; (* client flags: NBD_FLAG_C_FIXED_NEWSTYLE *) 450 | (`Client, "IHAVEOPT") 451 | ; (`Client, "\000\000\000\002") 452 | ; (* NBD_OPT_ABORT *) 453 | (`Client, "\000\000\000\000") 454 | ] 455 | in 456 | Alcotest_lwt.test_case "Client connects then aborts without reading ack" 457 | `Quick 458 | (with_server_channel sequence (fun channel -> 459 | Lwt.catch 460 | (fun () -> 461 | Nbd.Server.connect channel () >>= fun _ -> 462 | Alcotest.fail "Server should not enter transmission mode" 463 | ) 464 | (function 465 | | Nbd.Server.Client_requested_abort -> 466 | Lwt.return_unit 467 | | e -> 468 | Lwt.fail e 469 | ) 470 | ) 471 | ) 472 | 473 | let test_list_exports_disabled = 474 | Alcotest_lwt.test_case 475 | "Check that the server denies listing the exports, and the error is\n\ 476 | \ reported properly." `Quick 477 | (with_server_channel list_exports_disabled (fun channel -> 478 | Lwt.catch 479 | (fun () -> 480 | Nbd.Server.connect channel () >>= fun _ -> 481 | Alcotest.fail "Server should not enter transmission mode" 482 | ) 483 | (function 484 | | Nbd.Server.Client_requested_abort -> 485 | Lwt.return_unit 486 | | e -> 487 | Lwt.fail e 488 | ) 489 | ) 490 | ) 491 | 492 | let test_list_exports_success = 493 | Alcotest_lwt.test_case "Client requests a list of exports" `Quick 494 | (with_server_channel list_exports_success (fun channel -> 495 | Lwt.catch 496 | (fun () -> 497 | Nbd.Server.connect ~offer:["export1"; "export2"] channel () 498 | >>= fun _ -> 499 | Alcotest.fail "Server should not enter transmission mode" 500 | ) 501 | (function 502 | | Nbd.Server.Client_requested_abort -> 503 | Lwt.return_unit 504 | | e -> 505 | Lwt.fail e 506 | ) 507 | ) 508 | ) 509 | 510 | let test_read_only_export = 511 | let test_block = Cstruct.of_string "asdf" in 512 | let sequence = 513 | [ 514 | (`Server, "NBDMAGIC") 515 | ; (`Server, "IHAVEOPT") 516 | ; (`Server, "\000\001") 517 | ; (* handshake flags: NBD_FLAG_FIXED_NEWSTYLE *) 518 | (`Client, "\000\000\000\001") 519 | ; (* client flags: NBD_FLAG_C_FIXED_NEWSTYLE *) 520 | (`Client, "IHAVEOPT") 521 | ; (`Client, "\000\000\000\001") 522 | ; (* NBD_OPT_EXPORT_NAME *) 523 | (`Client, "\000\000\000\007") 524 | ; (* length of export name *) 525 | (`Client, "export1") 526 | ; (`Server, "\000\000\000\000\000\000\000\004") 527 | ; (* size: 4 bytes *) 528 | (`Server, "\000\003") 529 | ; (* transmission flags: NBD_FLAG_READ_ONLY (bit 1) + NBD_FLAG_HAS_FLAGS (bit 0) *) 530 | (`Server, String.make 124 '\000') 531 | ; (* Now we've entered transmission mode *) 532 | (`Client, nbd_request_magic) 533 | ; (`Client, "\000\000") 534 | ; (* command flags *) 535 | (`Client, "\000\000") 536 | ; (* request type: NBD_CMD_READ *) 537 | (`Client, "\000\000\000\000\000\000\000\000") 538 | ; (* handle: 4 bytes *) 539 | (`Client, "\000\000\000\000\000\000\000\001") 540 | ; (* offset *) 541 | (`Client, "\000\000\000\002") 542 | ; (* length *) 543 | 544 | (* We're allowed to read from a read-only export *) 545 | (`Server, nbd_reply_magic) 546 | ; (`Server, "\000\000\000\000") 547 | ; (* error: no error *) 548 | (`Server, "\000\000\000\000\000\000\000\000") 549 | ; (* handle *) 550 | (`Server, "sd") 551 | ; (* 2 bytes of data *) 552 | (`Client, nbd_request_magic) 553 | ; (`Client, "\000\000") 554 | ; (* command flags *) 555 | (`Client, "\000\001") 556 | ; (* request type: NBD_CMD_WRITE *) 557 | (`Client, "\000\000\000\000\000\000\000\001") 558 | ; (* handle: 4 bytes *) 559 | (`Client, "\000\000\000\000\000\000\000\000") 560 | ; (* offset *) 561 | (`Client, "\000\000\000\004") 562 | ; (* length *) 563 | (* The server should probably return the EPERM error immediately, and not 564 | read any data associated with the write request, as the client should 565 | recognize the error before transmitting the data, just like for EINVAL, 566 | which is sent for unaligned requests. *) 567 | (*`Client, "nope"; (* 4 bytes of data *)*) 568 | 569 | (* However, we're not allowed to write to it *) 570 | (`Server, nbd_reply_magic) 571 | ; (`Server, "\000\000\000\001") 572 | ; (* error: EPERM *) 573 | (`Server, "\000\000\000\000\000\000\000\001") (* handle *) 574 | (* TODO: currently the test fails with the below lines uncommented, because 575 | the server disconnects in case of write errors, but according to the NBD 576 | protocol it probably shouldn't, it should continue to process the 577 | client's requests *) 578 | (* 579 | `Client, nbd_request_magic; 580 | `Client, "\000\000"; (* command flags *) 581 | `Client, "\000\002"; (* request type: NBD_CMD_DISC *) 582 | `Client, "\000\000\000\000\000\000\000\002"; (* handle: 4 bytes *) 583 | `Client, "\000\000\000\000\000\000\000\000"; (* offset *) 584 | `Client, "\000\000\000\000"; (* length *) 585 | *) 586 | ] 587 | in 588 | Alcotest_lwt.test_case 589 | "Serve a read-only export and test that reads and writes are handled \ 590 | correctly." 591 | `Quick 592 | (with_server_channel sequence (fun channel -> 593 | Nbd.Server.connect channel () >>= fun (export_name, svr) -> 594 | Alcotest.(check string) 595 | "The server did not receive the correct export name" "export1" 596 | export_name ; 597 | Nbd.Server.serve svr ~read_only:true 598 | (module Cstruct_block.Block) 599 | test_block 600 | ) 601 | ) 602 | 603 | let test_read_write_export = 604 | let test_block = Cstruct.of_string "asdf" in 605 | let sequence = 606 | [ 607 | (`Server, "NBDMAGIC") 608 | ; (`Server, "IHAVEOPT") 609 | ; (`Server, "\000\001") 610 | ; (* handshake flags: NBD_FLAG_FIXED_NEWSTYLE *) 611 | (`Client, "\000\000\000\001") 612 | ; (* client flags: NBD_FLAG_C_FIXED_NEWSTYLE *) 613 | (`Client, "IHAVEOPT") 614 | ; (`Client, "\000\000\000\001") 615 | ; (* NBD_OPT_EXPORT_NAME *) 616 | (`Client, "\000\000\000\007") 617 | ; (* length of export name *) 618 | (`Client, "export1") 619 | ; (`Server, "\000\000\000\000\000\000\000\004") 620 | ; (* size: 4 bytes *) 621 | (`Server, "\000\001") 622 | ; (* transmission flags: NBD_FLAG_HAS_FLAGS (bit 0) *) 623 | (`Server, String.make 124 '\000') 624 | ; (* Now we've entered transmission mode *) 625 | (`Client, nbd_request_magic) 626 | ; (`Client, "\000\000") 627 | ; (* command flags *) 628 | (`Client, "\000\001") 629 | ; (* request type: NBD_CMD_WRITE *) 630 | (`Client, "\000\000\000\000\000\000\000\001") 631 | ; (* handle: 4 bytes *) 632 | (`Client, "\000\000\000\000\000\000\000\002") 633 | ; (* offset *) 634 | (`Client, "\000\000\000\002") 635 | ; (* length *) 636 | (`Client, "12") 637 | ; (* 2 bytes of data *) 638 | 639 | (* We're allowed to read from a read-only export *) 640 | (`Server, nbd_reply_magic) 641 | ; (`Server, "\000\000\000\000") 642 | ; (* error: no error *) 643 | (`Server, "\000\000\000\000\000\000\000\001") 644 | ; (* handle *) 645 | (`Client, nbd_request_magic) 646 | ; (`Client, "\000\000") 647 | ; (* command flags *) 648 | (`Client, "\000\002") 649 | ; (* request type: NBD_CMD_DISC *) 650 | (`Client, "\000\000\000\000\000\000\000\002") 651 | ; (* handle: 4 bytes *) 652 | (`Client, "\000\000\000\000\000\000\000\000") 653 | ; (* offset *) 654 | (`Client, "\000\000\000\000") 655 | (* length *) 656 | ] 657 | in 658 | Alcotest_lwt.test_case 659 | "Serve a read-write export and test that writes are handled correctly." 660 | `Quick 661 | (with_server_channel sequence (fun channel -> 662 | Nbd.Server.connect channel () >>= fun (export_name, svr) -> 663 | Alcotest.(check string) 664 | "The server did not receive the correct export name" "export1" 665 | export_name ; 666 | Nbd.Server.serve svr ~read_only:false 667 | (module Cstruct_block.Block) 668 | test_block 669 | >|= fun () -> 670 | Alcotest.(check string) 671 | "Data written by server" "as12" 672 | (Cstruct.to_string test_block) 673 | ) 674 | ) 675 | end 676 | 677 | let tests = 678 | ( "Nbd protocol tests" 679 | , [ 680 | ClientTests.test_v2_negotiation 681 | ; ServerTests.test_v2_negotiation 682 | ; ServerTests.test_abort 683 | ; ServerTests.test_abort_without_ack 684 | ; ClientTests.test_list_exports_disabled 685 | ; ServerTests.test_list_exports_disabled 686 | ; ClientTests.test_no_ack_after_abort 687 | ; ServerTests.test_abort_without_ack 688 | ; ClientTests.test_list_exports_success 689 | ; ServerTests.test_list_exports_success 690 | ; ClientTests.test_list_exports_extra_data 691 | ; ServerTests.test_read_only_export 692 | ; ServerTests.test_read_write_export 693 | ] 694 | ) 695 | -------------------------------------------------------------------------------- /lib_test/suite.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Lwt_main.run 3 | @@ Alcotest_lwt.run "Lwt Nbd library test suite" 4 | (* I found that running the protocol tests before the 5 | client server tests causes the test suite to hang 6 | *) 7 | [Client_server_test.tests; Protocol_test.tests] 8 | -------------------------------------------------------------------------------- /nbd-tool.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Network Block Device (NBD) protocol implementation" 3 | description: """ 4 | This library allows applications to export and consume block 5 | devices using the NBD protocol (as used by Linux, qemu etc)""" 6 | maintainer: "Xapi project maintainers" 7 | authors: ["Jonathan Ludlam" "David Scott" "Thomas Sanders"] 8 | license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" 9 | tags: ["org:mirage" "org:xapi-project"] 10 | homepage: "https://github.com/xapi-project/nbd" 11 | bug-reports: "https://github.com/xapi-project/nbd/issues" 12 | depends: [ 13 | "ocaml" {>= "4.08.0"} 14 | "dune" {>= "2.7.0"} 15 | "alcotest" {with-test} 16 | "alcotest-lwt" {with-test} 17 | "cmdliner" {>= "1.1.0"} 18 | "lwt" {>= "2.7.0"} 19 | "lwt_log" 20 | "mirage-block-unix" 21 | "nbd-unix" {=version} 22 | "odoc" {with-doc} 23 | "uri" 24 | ] 25 | depexts: [ 26 | ["qemu-img" "nbd" "nmap-ncat"] {with-test & os-family = "rhel"} 27 | ["qemu-utils" "nbd-client" "netcat-openbsd"] {with-test & os-family = "debian"} 28 | ] 29 | build: [ 30 | ["dune" "subst"] {dev} 31 | ["dune" "build" "-p" name "-j" jobs] 32 | ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} 33 | ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test} 34 | ] 35 | dev-repo: "git+https://github.com/xapi-project/nbd.git" 36 | -------------------------------------------------------------------------------- /nbd-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "Network Block Device (NBD) protocol implementation" 3 | description: """ 4 | This library allows applications to export and consume block 5 | devices using the NBD protocol (as used by Linux, qemu etc)""" 6 | maintainer: "Xapi project maintainers" 7 | authors: ["Jonathan Ludlam" "David Scott" "Thomas Sanders"] 8 | license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" 9 | tags: ["org:mirage" "org:xapi-project"] 10 | homepage: "https://github.com/xapi-project/nbd" 11 | doc: "https://xapi-project.github.io/nbd/nbd-unix/index.html" 12 | bug-reports: "https://github.com/xapi-project/nbd/issues" 13 | depends: [ 14 | "ocaml" {>= "4.08.0"} 15 | "bigarray-compat" 16 | "bisect_ppx" {dev & >= "2.5.0"} 17 | "dune" {>= "2.7.0"} 18 | "cstruct-lwt" 19 | "io-page" {>= "2.4.0"} 20 | "lwt" {>= "2.7.0"} 21 | "lwt_ssl" 22 | "mirage-block" {>= "2.0.0"} 23 | "mirage-block-unix" 24 | "nbd" {=version} 25 | "odoc" {with-doc} 26 | "ssl" 27 | ] 28 | build: [ 29 | ["dune" "subst"] {dev} 30 | ["dune" "build" "-p" name "-j" jobs] 31 | ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} 32 | ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test} 33 | ] 34 | dev-repo: "git+https://github.com/xapi-project/nbd.git" 35 | -------------------------------------------------------------------------------- /nbd.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Xapi project maintainers" 3 | authors: [ "Jonathan Ludlam" "David Scott" "Thomas Sanders" ] 4 | license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" 5 | homepage: "https://github.com/xapi-project/nbd" 6 | doc: "https://xapi-project.github.io/nbd/nbd/index.html" 7 | dev-repo: "git+https://github.com/xapi-project/nbd.git" 8 | bug-reports: "https://github.com/xapi-project/nbd/issues" 9 | build: [ 10 | ["dune" "subst"] {dev} 11 | ["dune" "build" "-p" name "-j" jobs] 12 | ["dune" "build" "-p" name "-j" jobs "@doc"] {with-doc} 13 | ["dune" "build" "-p" name "-j" jobs "@runtest"] {with-test} 14 | ] 15 | depends: [ 16 | "ocaml" {>= "4.08.0"} 17 | "bisect_ppx" {dev & >= "2.5.0"} 18 | "dune" {>= "2.7.0"} 19 | "alcotest" {with-test} 20 | "alcotest-lwt" {with-test} 21 | "cstruct" {>= "6.0.0"} 22 | "io-page" {>= "2.4.0"} 23 | "mirage-block" {>= "3.0.0"} 24 | "mirage-block-unix" 25 | "lwt" {>= "2.7.0"} 26 | "lwt_log" 27 | "odoc" {with-doc} 28 | "ppx_cstruct" {>= "3.1.0"} 29 | "ppx_sexp_conv" {>= "v0.9.0"} 30 | "rresult" 31 | "sexplib" 32 | "uri" 33 | ] 34 | conflicts: ["result" {< "1.5"}] 35 | tags: [ "org:mirage" "org:xapi-project" ] 36 | synopsis: "Network Block Device (NBD) protocol implementation" 37 | description: """ 38 | This library allows applications to export and consume block 39 | devices using the NBD protocol (as used by Linux, qemu etc)""" 40 | -------------------------------------------------------------------------------- /unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name nbd_unix) 3 | (public_name nbd-unix) 4 | (libraries 5 | bigarray-compat 6 | cstruct 7 | cstruct-lwt 8 | io-page 9 | lwt 10 | lwt.unix 11 | mirage-block 12 | mirage-block-unix 13 | ssl 14 | lwt_ssl 15 | nbd) 16 | (instrumentation (backend bisect_ppx))) 17 | -------------------------------------------------------------------------------- /unix/nbd_unix.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (** Mostly concrete implementations for creating various kinds of channels. 16 | * Also exposes Nbd.Client and Nbd.Server as Client and Server submodules. *) 17 | 18 | open Nbd 19 | open Channel 20 | 21 | let return = Lwt.return 22 | 23 | let ( >>= ) = Lwt.( >>= ) 24 | 25 | type tls_role = TlsClient of Ssl.context | TlsServer of Ssl.context 26 | 27 | (* XXX Consider moving this function into a library also used by vhd-tool. *) 28 | (* Also the read/write/close functions that are inside tls_channel_of_fd. *) 29 | 30 | (** Call the io function [op] repeatedly until it reports that in 31 | total it has handled enough data to reach the end of the [buffer] 32 | (or call [Lwt.fail End_of_file] if [op] ceases to make progress). 33 | * The function [op] is an operation (such as a read/write/skip) 34 | that takes [fd], a buffer, an offset and a length, and returns 35 | an [int Lwt.t] to say how much data it processed. 36 | * [fd] is an open file descriptor. 37 | * [buffer] contains [buffer.Cstruct.buffer] for the data to be processed, 38 | from offset [buffer.Cstruct.off] to the end ([buffer.Cstruct.len]). 39 | *) 40 | let io_complete op fd buffer = 41 | let ofs = buffer.Cstruct.off in 42 | let len = buffer.Cstruct.len in 43 | let buf = buffer.Cstruct.buffer in 44 | (* loop returns the total of the ints returned by the calls to [op] *) 45 | let rec loop acc ofs len = 46 | op fd buf ofs len >>= fun n -> 47 | let len' = len - n in 48 | let acc' = acc + n in 49 | if len' = 0 || n = 0 then 50 | return acc' 51 | else 52 | loop acc' (ofs + n) len' 53 | in 54 | loop 0 ofs len >>= fun n -> 55 | if n = 0 && len <> 0 then 56 | Lwt.fail End_of_file 57 | else 58 | return () 59 | 60 | let tls_channel_of_fd fd role () = 61 | let ctx, ssl_start = 62 | match role with 63 | | TlsClient ctx -> 64 | (ctx, Lwt_ssl.ssl_connect) 65 | | TlsServer ctx -> 66 | (ctx, Lwt_ssl.ssl_accept) 67 | in 68 | ssl_start fd ctx >>= fun sock -> 69 | let read_tls buf = 70 | io_complete Lwt_ssl.read_bytes sock buf >>= fun () -> return () 71 | in 72 | 73 | let write_tls buf = 74 | io_complete Lwt_ssl.write_bytes sock buf >>= fun () -> return () 75 | in 76 | 77 | let close_tls () = 78 | ignore (Lwt_ssl.ssl_shutdown sock) ; 79 | Lwt_ssl.close sock 80 | in 81 | 82 | return {read_tls; write_tls; close_tls} 83 | 84 | let cleartext_channel_of_fd fd role_opt = 85 | let read_clear = Lwt_cstruct.(complete (read fd)) in 86 | let write_clear = Lwt_cstruct.(complete (write fd)) in 87 | let close_clear () = Lwt_unix.close fd in 88 | let make_tls_channel = 89 | match role_opt with 90 | | None -> 91 | None 92 | | Some role -> 93 | Some (tls_channel_of_fd fd role) 94 | in 95 | {read_clear; write_clear; close_clear; make_tls_channel} 96 | 97 | let generic_channel_of_fd fd role = 98 | let ch = cleartext_channel_of_fd fd role in 99 | return (Channel.generic_of_cleartext_channel ch) 100 | 101 | (* This function is used by the client. The channel has no TLS ability. *) 102 | let connect hostname port = 103 | let socket = Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_STREAM 0 in 104 | Lwt_unix.gethostbyname hostname >>= fun host_info -> 105 | let server_address = host_info.Lwt_unix.h_addr_list.(0) in 106 | Lwt.catch 107 | (fun () -> 108 | Lwt_unix.connect socket (Lwt_unix.ADDR_INET (server_address, port)) 109 | ) 110 | (fun e -> Lwt_unix.close socket >>= fun () -> Lwt.fail e) 111 | >>= fun () -> generic_channel_of_fd socket None 112 | 113 | let init_tls_get_ctx ?curve ~certfile ~ciphersuites () = 114 | Ssl_threads.init () ; 115 | Ssl.init () ; 116 | let mk_ctx role_ctx = Ssl.create_context Ssl.TLSv1_2 role_ctx in 117 | let ctx = mk_ctx Ssl.Server_context in 118 | Ssl.use_certificate ctx certfile certfile ; 119 | (* Second one is being used as privkey filename *) 120 | Ssl.set_cipher_list ctx ciphersuites ; 121 | ( match curve with 122 | | None -> 123 | () 124 | | Some curve -> 125 | Ssl.init_ec_from_named_curve ctx curve 126 | ) ; 127 | ctx 128 | 129 | let with_block filename f = 130 | Block.connect filename >>= fun b -> 131 | Lwt.finalize (fun () -> f b) (fun () -> Block.disconnect b) 132 | 133 | let ignore_exn t () = Lwt.catch t (fun _ -> Lwt.return_unit) 134 | 135 | let with_channel fd tls_role f = 136 | let clearchan = cleartext_channel_of_fd fd tls_role in 137 | Lwt.finalize 138 | (fun () -> f clearchan) 139 | (* We use ignore_exn lest clearchan was closed already by f. *) 140 | (ignore_exn (fun () -> clearchan.close_clear ())) 141 | 142 | module Client = Nbd.Client 143 | module Server = Nbd.Server 144 | -------------------------------------------------------------------------------- /unix/nbd_unix.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) Citrix Systems Inc. 3 | * 4 | * This program is free software; you can redistribute it and/or modify 5 | * it under the terms of the GNU Lesser General Public License as published 6 | * by the Free Software Foundation; version 2.1 only. with the special 7 | * exception on linking described in file LICENSE. 8 | * 9 | * This program is distributed in the hope that it will be useful, 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | * GNU Lesser General Public License for more details. 13 | *) 14 | 15 | (** Network Block Device client and servers for Unix *) 16 | 17 | open Nbd 18 | 19 | type tls_role = TlsClient of Ssl.context | TlsServer of Ssl.context 20 | 21 | val connect : string -> int -> Channel.channel Lwt.t 22 | (** [connect hostname port] connects to host:port and returns 23 | a [generic_channel] with no TLS ability or potential. *) 24 | 25 | val cleartext_channel_of_fd : 26 | Lwt_unix.file_descr -> tls_role option -> Channel.cleartext_channel 27 | (** [cleartext_channel_of_fd fd role] returns a channel from an existing file descriptor. 28 | The channel will have a [make_tls_channel] value that corresponds to [role]. *) 29 | 30 | val init_tls_get_ctx : 31 | ?curve:string -> certfile:string -> ciphersuites:string -> unit -> Ssl.context 32 | (** Initialise the Ssl (TLS) library and then create and return a new context. *) 33 | 34 | val with_block : string -> (Block.t -> 'a Lwt.t) -> 'a Lwt.t 35 | (** [with_block filename f] calls [Block.connect filename] and applies [f] to the result, 36 | with a guarantee to call [Block.disconnect] afterwards. *) 37 | 38 | val with_channel : 39 | Lwt_unix.file_descr 40 | -> tls_role option 41 | -> (Nbd.Channel.cleartext_channel -> 'a Lwt.t) 42 | -> 'a Lwt.t 43 | (** [with_channel fd role f] calls [cleartext_channel_of_fd fd role] then 44 | applies [f] to the resulting channel, with a guarantee to call 45 | the channel's [close_clear] function afterwards. *) 46 | 47 | (** A client allows you to access remote disks *) 48 | module Client : S.CLIENT 49 | 50 | (** A server allows you to expose disks to remote clients *) 51 | module Server : S.SERVER 52 | --------------------------------------------------------------------------------