1(* hey emacs, this is OCaml code: -*- tuareg -*- *) 2(* nbdkit OCaml interface 3 * Copyright (C) 2014-2020 Red Hat Inc. 4 * 5 * Redistribution and use in source and binary forms, with or without 6 * modification, are permitted provided that the following conditions are 7 * met: 8 * 9 * * Redistributions of source code must retain the above copyright 10 * notice, this list of conditions and the following disclaimer. 11 * 12 * * Redistributions in binary form must reproduce the above copyright 13 * notice, this list of conditions and the following disclaimer in the 14 * documentation and/or other materials provided with the distribution. 15 * 16 * * Neither the name of Red Hat nor the names of its contributors may be 17 * used to endorse or promote products derived from this software without 18 * specific prior written permission. 19 * 20 * THIS SOFTWARE IS PROVIDED BY RED HAT AND CONTRIBUTORS ''AS IS'' AND 21 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 22 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23 * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL RED HAT OR 24 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF 27 * USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 28 * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 29 * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 30 * OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 31 * SUCH DAMAGE. 32 *) 33 34open Printf 35 36type flags = flag list 37and flag = May_trim | FUA | Req_one 38 39type fua_flag = FuaNone | FuaEmulate | FuaNative 40 41type cache_flag = CacheNone | CacheEmulate | CacheNop 42 43type thread_model = 44| THREAD_MODEL_SERIALIZE_CONNECTIONS 45| THREAD_MODEL_SERIALIZE_ALL_REQUESTS 46| THREAD_MODEL_SERIALIZE_REQUESTS 47| THREAD_MODEL_PARALLEL 48 49type extent = { 50 offset : int64; 51 length : int64; 52 is_hole : bool; 53 is_zero : bool; 54} 55 56type 'a plugin = { 57 name : string; 58 longname : string; 59 version : string; 60 description : string; 61 62 load : (unit -> unit) option; 63 unload : (unit -> unit) option; 64 65 dump_plugin : (unit -> unit) option; 66 67 config : (string -> string -> unit) option; 68 config_complete : (unit -> unit) option; 69 config_help : string; 70 thread_model : (unit -> thread_model) option; 71 72 get_ready : (unit -> unit) option; 73 74 preconnect : (bool -> unit) option; 75 open_connection : (bool -> 'a) option; 76 close : ('a -> unit) option; 77 78 get_size : ('a -> int64) option; 79 80 can_cache : ('a -> cache_flag) option; 81 can_extents : ('a -> bool) option; 82 can_fast_zero : ('a -> bool) option; 83 can_flush : ('a -> bool) option; 84 can_fua : ('a -> fua_flag) option; 85 can_multi_conn : ('a -> bool) option; 86 can_trim : ('a -> bool) option; 87 can_write : ('a -> bool) option; 88 can_zero : ('a -> bool) option; 89 is_rotational : ('a -> bool) option; 90 91 pread : ('a -> int32 -> int64 -> flags -> string) option; 92 pwrite : ('a -> string -> int64 -> flags -> unit) option; 93 flush : ('a -> flags -> unit) option; 94 trim : ('a -> int32 -> int64 -> flags -> unit) option; 95 zero : ('a -> int32 -> int64 -> flags -> unit) option; 96 extents : ('a -> int32 -> int64 -> flags -> extent list) option; 97 cache : ('a -> int32 -> int64 -> flags -> unit) option; 98} 99 100let default_callbacks = { 101 name = ""; 102 longname = ""; 103 version = ""; 104 description = ""; 105 106 load = None; 107 unload = None; 108 109 dump_plugin = None; 110 111 config = None; 112 config_complete = None; 113 config_help = ""; 114 thread_model = None; 115 116 get_ready = None; 117 118 preconnect = None; 119 open_connection = None; 120 close = None; 121 122 get_size = None; 123 124 can_cache = None; 125 can_extents = None; 126 can_fast_zero = None; 127 can_flush = None; 128 can_fua = None; 129 can_multi_conn = None; 130 can_trim = None; 131 can_write = None; 132 can_zero = None; 133 is_rotational = None; 134 135 pread = None; 136 pwrite = None; 137 flush = None; 138 trim = None; 139 zero = None; 140 extents = None; 141 cache = None; 142} 143 144external set_name : string -> unit = "ocaml_nbdkit_set_name" "noalloc" 145external set_longname : string -> unit = "ocaml_nbdkit_set_longname" "noalloc" 146external set_version : string -> unit = "ocaml_nbdkit_set_version" "noalloc" 147external set_description : string -> unit = "ocaml_nbdkit_set_description" "noalloc" 148 149external set_load : (unit -> unit) -> unit = "ocaml_nbdkit_set_load" 150external set_unload : (unit -> unit) -> unit = "ocaml_nbdkit_set_unload" 151 152external set_dump_plugin : (unit -> unit) -> unit = "ocaml_nbdkit_set_dump_plugin" "noalloc" 153 154external set_config : (string -> string -> unit) -> unit = "ocaml_nbdkit_set_config" 155external set_config_complete : (unit -> unit) -> unit = "ocaml_nbdkit_set_config_complete" 156external set_config_help : string -> unit = "ocaml_nbdkit_set_config_help" "noalloc" 157external set_thread_model : (unit -> thread_model) -> unit = "ocaml_nbdkit_set_thread_model" 158 159external set_get_ready : (unit -> unit) -> unit = "ocaml_nbdkit_set_get_ready" 160 161external set_preconnect : (bool -> unit) -> unit = "ocaml_nbdkit_set_preconnect" 162external set_open : (bool -> 'a) -> unit = "ocaml_nbdkit_set_open" 163external set_close : ('a -> unit) -> unit = "ocaml_nbdkit_set_close" 164 165external set_get_size : ('a -> int64) -> unit = "ocaml_nbdkit_set_get_size" 166 167external set_can_cache : ('a -> cache_flag) -> unit = "ocaml_nbdkit_set_can_cache" 168external set_can_extents : ('a -> bool) -> unit = "ocaml_nbdkit_set_can_extents" 169external set_can_fast_zero : ('a -> bool) -> unit = "ocaml_nbdkit_set_can_fast_zero" 170external set_can_flush : ('a -> bool) -> unit = "ocaml_nbdkit_set_can_flush" 171external set_can_fua : ('a -> fua_flag) -> unit = "ocaml_nbdkit_set_can_fua" 172external set_can_multi_conn : ('a -> bool) -> unit = "ocaml_nbdkit_set_can_multi_conn" 173external set_can_trim : ('a -> bool) -> unit = "ocaml_nbdkit_set_can_trim" 174external set_can_write : ('a -> bool) -> unit = "ocaml_nbdkit_set_can_write" 175external set_can_zero : ('a -> bool) -> unit = "ocaml_nbdkit_set_can_zero" 176external set_is_rotational : ('a -> bool) -> unit = "ocaml_nbdkit_set_is_rotational" 177 178external set_pread : ('a -> int32 -> int64 -> flags -> string) -> unit = "ocaml_nbdkit_set_pread" 179external set_pwrite : ('a -> string -> int64 -> flags -> unit) -> unit = "ocaml_nbdkit_set_pwrite" 180external set_flush : ('a -> flags -> unit) -> unit = "ocaml_nbdkit_set_flush" 181external set_trim : ('a -> int32 -> int64 -> flags -> unit) -> unit = "ocaml_nbdkit_set_trim" 182external set_zero : ('a -> int32 -> int64 -> flags -> unit) -> unit = "ocaml_nbdkit_set_zero" 183external set_extents : ('a -> int32 -> int64 -> flags -> extent list) -> unit = "ocaml_nbdkit_set_extents" 184external set_cache : ('a -> int32 -> int64 -> flags -> unit) -> unit = "ocaml_nbdkit_set_cache" 185 186let may f = function None -> () | Some a -> f a 187 188let register_plugin plugin = 189 (* Check the required fields have been set by the caller. *) 190 let required fieldname = 191 function 192 | true -> () 193 | false -> 194 if plugin.name = "" then 195 failwith (sprintf "NBDKit.plugin.%s field is not set" fieldname) 196 else 197 failwith (sprintf "%s: NBDKit.plugin.%s field is not set" 198 plugin.name fieldname) 199 in 200 required "name" (plugin.name <> ""); 201 required "open_connection" (plugin.open_connection <> None); 202 required "get_size" (plugin.get_size <> None); 203 required "pread" (plugin.pread <> None); 204 205 (* Set the fields in the C code. *) 206 set_name plugin.name; 207 if plugin.longname <> "" then set_longname plugin.longname; 208 if plugin.version <> "" then set_version plugin.version; 209 if plugin.description <> "" then set_description plugin.description; 210 211 may set_load plugin.load; 212 may set_unload plugin.unload; 213 214 may set_dump_plugin plugin.dump_plugin; 215 216 may set_config plugin.config; 217 may set_config_complete plugin.config_complete; 218 if plugin.config_help <> "" then set_config_help plugin.config_help; 219 may set_thread_model plugin.thread_model; 220 221 may set_get_ready plugin.get_ready; 222 223 may set_preconnect plugin.preconnect; 224 may set_open plugin.open_connection; 225 may set_close plugin.close; 226 227 may set_get_size plugin.get_size; 228 229 may set_can_cache plugin.can_cache; 230 may set_can_extents plugin.can_extents; 231 may set_can_fast_zero plugin.can_fast_zero; 232 may set_can_flush plugin.can_flush; 233 may set_can_fua plugin.can_fua; 234 may set_can_multi_conn plugin.can_multi_conn; 235 may set_can_trim plugin.can_trim; 236 may set_can_write plugin.can_write; 237 may set_can_zero plugin.can_zero; 238 may set_is_rotational plugin.is_rotational; 239 240 may set_pread plugin.pread; 241 may set_pwrite plugin.pwrite; 242 may set_flush plugin.flush; 243 may set_trim plugin.trim; 244 may set_zero plugin.zero; 245 may set_extents plugin.extents; 246 may set_cache plugin.cache 247 248external _set_error : int -> unit = "ocaml_nbdkit_set_error" "noalloc" 249 250let set_error unix_error = 251 (* There's an awkward triple translation going on here, because 252 * OCaml Unix.error codes, errno on the host system, and NBD_* 253 * errnos are not all the same integer value. Plus we cannot 254 * read the host system errno values from OCaml. 255 *) 256 let nbd_error = 257 match unix_error with 258 | Unix.EPERM -> 1 259 | Unix.EIO -> 2 260 | Unix.ENOMEM -> 3 261 | Unix.EINVAL -> 4 262 | Unix.ENOSPC -> 5 263 | Unix.ESHUTDOWN -> 6 264 | Unix.EOVERFLOW -> 7 265 | Unix.EOPNOTSUPP -> 8 266 | Unix.EROFS -> 9 267 | Unix.EFBIG -> 10 268 | _ -> 4 (* EINVAL *) in 269 270 _set_error nbd_error 271 272external parse_size : string -> int64 = "ocaml_nbdkit_parse_size" 273external parse_bool : string -> bool = "ocaml_nbdkit_parse_bool" 274external read_password : string -> string = "ocaml_nbdkit_read_password" 275external realpath : string -> string = "ocaml_nbdkit_realpath" 276external nanosleep : int -> int -> unit = "ocaml_nbdkit_nanosleep" 277external export_name : unit -> string = "ocaml_nbdkit_export_name" 278external shutdown : unit -> unit = "ocaml_nbdkit_shutdown" "noalloc" 279 280external _debug : string -> unit = "ocaml_nbdkit_debug" "noalloc" 281 282let debug fs = 283 ksprintf _debug fs 284