plugins/ocaml/NBDKit.ml

   1 (* hey emacs, this is OCaml code: -*- tuareg -*- *)
   2 (* nbdkit OCaml interface
   3  * Copyright Red Hat
   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
  34 open Printf
  35
  36 type flags = flag list
  37 and flag = May_trim | FUA | Req_one
  38
  39 type fua_flag = FuaNone | FuaEmulate | FuaNative
  40
  41 type cache_flag = CacheNone | CacheEmulate | CacheNop
  42
  43 type thread_model =
  44 | THREAD_MODEL_SERIALIZE_CONNECTIONS
  45 | THREAD_MODEL_SERIALIZE_ALL_REQUESTS
  46 | THREAD_MODEL_SERIALIZE_REQUESTS
  47 | THREAD_MODEL_PARALLEL
  48
  49 type extent = {
  50   offset : int64;
  51   length : int64;
  52   is_hole : bool;
  53   is_zero : bool;
  54 }
  55
  56 type export = {
  57   name : string;
  58   description : string option;
  59 }
  60
  61 (* Set a named string field in the C plugin struct. *)
  62 external set_string_field : string -> string -> unit
  63   = "ocaml_nbdkit_set_string_field" [@@noalloc]
  64
  65 (* Set an arbitrary named function pointer field in the C plugin struct.
  66  *
  67  * Caution: There is no type checking here, the parameter type
  68  * declared in [NBDKit.mli] must match what the corresponding
  69  * [<field_name>_wrapper] function in [plugin.c] calls.
  70  *)
  71 external set_field : string -> 'a -> unit = "ocaml_nbdkit_set_field"
  72
  73 (* Register the plugin. *)
  74 let register_plugin ~name
  75                     ?longname
  76                     ?version
  77                     ?description
  78                     ?load
  79                     ?get_ready
  80                     ?after_fork
  81                     ?cleanup
  82                     ?unload
  83                     ?config
  84                     ?config_complete
  85                     ?config_help
  86                     ?thread_model
  87                     ?magic_config_key
  88                     ?preconnect
  89                     ~open_connection
  90                     ?close
  91                     ~get_size
  92                     ?block_size
  93                     ?can_cache
  94                     ?can_extents
  95                     ?can_fast_zero
  96                     ?can_flush
  97                     ?can_fua
  98                     ?can_multi_conn
  99                     ?can_trim
 100                     ?can_write
 101                     ?can_zero
 102                     ?is_rotational
 103                     ~pread
 104                     ?pwrite
 105                     ?flush
 106                     ?trim
 107                     ?zero
 108                     ?extents
 109                     ?cache
 110                     ?dump_plugin
 111                     ?list_exports
 112                     ?default_export
 113                     ?export_description
 114                     () =
 115   (* Set fields in the C plugin struct. *)
 116   set_string_field "name" name;
 117   set_field "open" open_connection;
 118   set_field "pread" pread;
 119   set_field "get_size" get_size;
 120
 121   let may f = function None -> () | Some a -> f a in
 122   may (set_string_field "longname") longname;
 123   may (set_string_field "version") version;
 124   may (set_string_field "description") description;
 125   may (set_string_field "config_help") config_help;
 126   may (set_string_field "magic_config_key") magic_config_key;
 127
 128   may (set_field "after_fork") after_fork;
 129   may (set_field "block_size") block_size;
 130   may (set_field "cache") cache;
 131   may (set_field "can_cache") can_cache;
 132   may (set_field "can_extents") can_extents;
 133   may (set_field "can_fast_zero") can_fast_zero;
 134   may (set_field "can_flush") can_flush;
 135   may (set_field "can_fua") can_fua;
 136   may (set_field "can_multi_conn") can_multi_conn;
 137   may (set_field "can_trim") can_trim;
 138   may (set_field "can_write") can_write;
 139   may (set_field "can_zero") can_zero;
 140   may (set_field "cleanup") cleanup;
 141   may (set_field "close") close;
 142   may (set_field "config") config;
 143   may (set_field "config_complete") config_complete;
 144   may (set_field "default_export") default_export;
 145   may (set_field "dump_plugin") dump_plugin;
 146   may (set_field "export_description") export_description;
 147   may (set_field "extents") extents;
 148   may (set_field "flush") flush;
 149   may (set_field "get_ready") get_ready;
 150   may (set_field "is_rotational") is_rotational;
 151   may (set_field "list_exports") list_exports;
 152   may (set_field "load") load;
 153   may (set_field "preconnect") preconnect;
 154   may (set_field "pwrite") pwrite;
 155   may (set_field "thread_model") thread_model;
 156   may (set_field "trim") trim;
 157   may (set_field "unload") unload;
 158   may (set_field "zero") zero
 159
 160 (* Bindings to nbdkit server functions. *)
 161 external set_error : Unix.error -> unit = "ocaml_nbdkit_set_error" [@@noalloc]
 162 external parse_size : string -> int64 = "ocaml_nbdkit_parse_size"
 163 external parse_bool : string -> bool = "ocaml_nbdkit_parse_bool"
 164 external read_password : string -> string = "ocaml_nbdkit_read_password"
 165 external realpath : string -> string = "ocaml_nbdkit_realpath"
 166 external nanosleep : int -> int -> unit = "ocaml_nbdkit_nanosleep"
 167 external export_name : unit -> string = "ocaml_nbdkit_export_name"
 168 external shutdown : unit -> unit = "ocaml_nbdkit_shutdown" [@@noalloc]
 169 external disconnect : bool -> unit = "ocaml_nbdkit_disconnect" [@@noalloc]
 170 external _debug : string -> unit = "ocaml_nbdkit_debug" [@@noalloc]
 171 let debug fs = ksprintf _debug fs
 172 external version : unit -> string = "ocaml_nbdkit_version"
 173 external api_version : unit -> int = "ocaml_nbdkit_api_version"
 174 external peer_pid : unit -> int64 = "ocaml_nbdkit_peer_pid"
 175 external peer_uid : unit -> int64 = "ocaml_nbdkit_peer_uid"
 176 external peer_gid : unit -> int64 = "ocaml_nbdkit_peer_gid"