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