#!/usr/bin/env ocaml
(* hey emacs, this is OCaml code: -*- tuareg -*- *)
(* nbd client library in userspace: generator
 * Copyright (C) 2013-2019 Red Hat Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 *)

(* This script generates the state machine and language
 * bindings.  After editing this file, run:
 *
 *   generator/generator
 *
 * from the top source directory to regenerate output files.
 *)

#load "str.cma" ;;
#load "unix.cma" ;;

open Unix
open Printf ;;

if not (Sys.file_exists "lib/handle.c") then
  failwith "Wrong directory!  Don't run this script by hand." ;;

(*----------------------------------------------------------------------*)

(* The state machine.
 *
 * Each state has some associated C code which is called when
 * the state is entered, or when the state is re-entered because
 * of an external event.  That code is not in this file, it's
 * in [generator/states*.c].
 *
 * Each handle starts in the top level START state.
 *
 * When you enter a state, the associated C code for that state
 * runs.  If the C code calls SET_NEXT_STATE and returns 0 then
 * the connection enters the next state without blocking.  If the
 * C code calls SET_NEXT_STATE_AND_BLOCK and returns 0 then the
 * connection blocks, but will resume with the code for the next
 * state on the next external event.  If the C code does _not_
 * call either macro but returns 0, the state machine is blocked
 * and will not be re-entered until an external event happens
 * (see below), where the same C code will be executed again on
 * re-entry.  If the C code calls returns -1 after using
 * set_error(), then the state machine blocks and the caller
 * should report failure; the next external event will resume the
 * state machine according to whether SET_NEXT_STATE was used.
 *
 * There are various end states such as CLOSED and DEAD.  These
 * are not special in relation to the above state transition rules,
 * it's just that they have no way to move to another state.  However,
 * the DEAD state expects that set_error() was used in the previous
 * state, and will return -1 itself after performing cleanup actions;
 * the earlier state that wants to transition to DEAD should return 0
 * rather than -1, so as not to bypass this cleanup.
 *
 * An external event is something like the file descriptor being
 * ready to read or write, or the main program calling a function
 * such as [nbd_aio_connect].  Possible external events, and the
 * next state resulting, are listed in the states table below.
 *
 * An empty string [""] for an external event’s next state means
 * the same state is re-entered.  The same C code for the state
 * will be run again.
 *
 * States can be grouped hierarchically.  States can be referred
 * to by an absolute path from the top level, such as ".DEAD",
 * or by a relative path from the current level, such as "CONNECT"
 * (another state at the same level), "REPLY.START" (a state in
 * a sub-group), or "^FINISH_COMMAND" (a state in the level above
 * the current one).  When entering a group you must enter at the
 * START state.  When leaving a group and going to a higher level
 * in the state tree there is no restriction on the next state.
 *)

type external_event =
  | NotifyRead                  (* fd becomes ready to read *)
  | NotifyWrite                 (* fd becomes ready to write *)
  | CmdCreate                   (* [nbd_create] function called *)
  | CmdConnectSockAddr          (* [nbd_aio_connect] function called *)
  | CmdConnectUnix              (* [nbd_aio_connect_unix] *)
  | CmdConnectTCP               (* [nbd_aio_connect_tcp] *)
  | CmdConnectCommand           (* [nbd_aio_connect_command] *)
  | CmdIssue                    (* issuing an NBD command *)

type location = string * int    (* source location: file, line number *)
let noloc = ("", 0)

type state = {
  (* The state name (without prefix).  If this has the special name
   * "START" then it is the start state of the current group.  Each
   * group can only have one start state.
   *)
  name : string;

  comment : string;             (* comment about the state *)

  (* Possible transitions from this state to a next state.  The
   * external events are coded into the state table below.  The
   * internal transitions are parsed out of the C code.
   *)
  external_events : (external_event * string) list;

  (* After flattening the state machine, the generator fills
   * in the extra fields in [state.parsed].
   *)
  mutable parsed : parsed_state;
}

and parsed_state = {
  (* The hierarchy group prefix.  For states in the top level
   * state machine this is an empty list.  For states in the
   * next level down this is a single element, and so on.
   *)
  prefix : string list;

  (* Hierarchical state name, like "NEWSTYLE.OPT_STARTTLS.CHECK_REPLY"
   * for use in debug messages etc.
   *)
  display_name : string;

  (* The STATE_* enum used in the generated C code. *)
  state_enum : string;

  (* The C code implementing this state. *)
  loc : location;
  code : string;

  (* Internal transitions, parsed out of the C code. *)
  internal_transitions : state list;

  (* External events after resolving them to the destination states. *)
  events : (external_event * state) list;
}

let default_state = { name = ""; comment = ""; external_events = [];
                      parsed = { prefix = []; display_name = "";
                                 state_enum = ""; loc = noloc; code = "";
                                 internal_transitions = []; events = [] } }

(* The type of the hierarchical state machine. *)
type state_machine = state_group list
and state_group =
  | Group of string * state_machine (* string is name/prefix of the group *)
  | State of state

(* Top level state machine. *)
let rec state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Handle after being initially created";
    external_events = [ CmdCreate, "";
                        CmdConnectSockAddr, "CONNECT.START";
                        CmdConnectUnix, "CONNECT_UNIX.START";
                        CmdConnectTCP, "CONNECT_TCP.START";
                        CmdConnectCommand, "CONNECT_COMMAND.START" ];
  };

  Group ("CONNECT", connect_state_machine);
  Group ("CONNECT_UNIX", connect_unix_state_machine);
  Group ("CONNECT_TCP", connect_tcp_state_machine);
  Group ("CONNECT_COMMAND", connect_command_state_machine);

  Group ("MAGIC", magic_state_machine);
  Group ("OLDSTYLE", oldstyle_state_machine);
  Group ("NEWSTYLE", newstyle_state_machine);

  State {
    default_state with
    name = "READY";
    comment = "Connection is ready to process NBD commands";
    external_events = [ CmdIssue, "ISSUE_COMMAND.START";
                        NotifyRead, "REPLY.START" ];
  };

  Group ("ISSUE_COMMAND", issue_command_state_machine);
  Group ("REPLY", reply_state_machine);

  State {
    default_state with
    name = "DEAD";
    comment = "Connection is in an unrecoverable error state, can only be closed";
  };

  State {
    default_state with
    name = "CLOSED";
    comment = "Connection is closed";
  };
]

(* State machine implementing [nbd_aio_connect]. *)
and connect_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Initial call to connect(2) on the socket";
    external_events = [ NotifyWrite, "CONNECTING" ];
  };

  State {
    default_state with
    name = "CONNECTING";
    comment = "Connecting to the remote server";
    external_events = [ NotifyWrite, "" ];
  };
]

(* State machine implementing [nbd_aio_connect_unix]. *)
and connect_unix_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Connect to a Unix domain socket";
    external_events = [];
  };
]

(* State machine implementing [nbd_aio_connect_tcp]. *)
and connect_tcp_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Connect to a remote TCP server";
    external_events = [];
  };

  State {
    default_state with
    name = "CONNECT";
    comment = "Initial call to connect(2) on a TCP socket";
    external_events = [ NotifyWrite, "CONNECTING" ];
  };

  State {
    default_state with
    name = "CONNECTING";
    comment = "Connecting to the remote server over a TCP socket";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "NEXT_ADDRESS";
    comment = "Connecting to the next address over a TCP socket";
    external_events = [];
  };
]

(* State machine implementing [nbd_aio_connect_command]. *)
and connect_command_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Connect to a subprocess";
    external_events = [];
  };
]

(* Parse initial magic string from the server. *)
and magic_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Prepare to receive the magic identification from remote";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_MAGIC";
    comment = "Receive initial magic identification from remote";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "CHECK_MAGIC";
    comment = "Check magic and version sent by remote";
  };
]

(* Oldstyle handshake. *)
and oldstyle_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Prepare to receive remainder of oldstyle header";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_REMAINING";
    comment = "Receive remainder of oldstyle header";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "CHECK";
    comment = "Check oldstyle header";
    external_events = [];
  };
]

(* Fixed newstyle handshake. *)
and newstyle_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Prepare to receive newstyle gflags from remote";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_GFLAGS";
    comment = "Receive newstyle gflags from remote";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "CHECK_GFLAGS";
    comment = "Check global flags sent by remote";
  };

  State {
    default_state with
    name = "SEND_CFLAGS";
    comment = "Send newstyle client flags to remote";
    external_events = [ NotifyWrite, "" ];
  };

  (* Options.  These state groups are always entered unconditionally,
   * in this order.  The START state in each group will check if the
   * state needs to run and skip to the next state in the list if not.
   *)
  Group ("OPT_STARTTLS", newstyle_opt_starttls_state_machine);
  Group ("OPT_STRUCTURED_REPLY", newstyle_opt_structured_reply_state_machine);
  Group ("OPT_SET_META_CONTEXT", newstyle_opt_set_meta_context_state_machine);
  Group ("OPT_GO", newstyle_opt_go_state_machine);
  Group ("OPT_EXPORT_NAME", newstyle_opt_export_name_state_machine);
]

(* Fixed newstyle NBD_OPT_STARTTLS option. *)
and newstyle_opt_starttls_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Try to send newstyle NBD_OPT_STARTTLS to upgrade to TLS";
    external_events = [];
  };

  State {
    default_state with
    name = "SEND";
    comment = "Send newstyle NBD_OPT_STARTTLS to upgrade to TLS";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "RECV_REPLY";
    comment = "Receive newstyle NBD_OPT_STARTTLS reply";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "RECV_REPLY_PAYLOAD";
    comment = "Receive any newstyle NBD_OPT_STARTTLS reply payload";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "CHECK_REPLY";
    comment = "Check newstyle NBD_OPT_STARTTLS reply";
    external_events = [];
  };

  State {
    default_state with
    name = "TLS_HANDSHAKE_READ";
    comment = "TLS handshake (reading)";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "TLS_HANDSHAKE_WRITE";
    comment = "TLS handshake (writing)";
    external_events = [ NotifyWrite, "" ];
  };
]

(* Fixed newstyle NBD_OPT_STRUCTURED_REPLY option. *)
and newstyle_opt_structured_reply_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Try to negotiate newstyle NBD_OPT_STRUCTURED_REPLY";
    external_events = [];
  };

  State {
    default_state with
    name = "SEND";
    comment = "Send newstyle NBD_OPT_STRUCTURED_REPLY negotiation request";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "RECV_REPLY";
    comment = "Receive newstyle NBD_OPT_STRUCTURED_REPLY option reply";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "RECV_REPLY_PAYLOAD";
    comment = "Receive any newstyle NBD_OPT_STRUCTURED_REPLY reply payload";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "CHECK_REPLY";
    comment = "Check newstyle NBD_OPT_STRUCTURED_REPLY option reply";
    external_events = [];
  };
]

(* Fixed newstyle NBD_OPT_SET_META_CONTEXT option. *)
and newstyle_opt_set_meta_context_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Try to negotiate newstyle NBD_OPT_SET_META_CONTEXT";
    external_events = [];
  };

  State {
    default_state with
    name = "SEND";
    comment = "Send newstyle NBD_OPT_SET_META_CONTEXT";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "SEND_EXPORTNAMELEN";
    comment = "Send newstyle NBD_OPT_SET_META_CONTEXT export name length";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "SEND_EXPORTNAME";
    comment = "Send newstyle NBD_OPT_SET_META_CONTEXT export name";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "SEND_NRQUERIES";
    comment = "Send newstyle NBD_OPT_SET_META_CONTEXT number of queries";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "PREPARE_NEXT_QUERY";
    comment = "Prepare to send newstyle NBD_OPT_SET_META_CONTEXT query";
    external_events = [];
  };

  State {
    default_state with
    name = "SEND_QUERYLEN";
    comment = "Send newstyle NBD_OPT_SET_META_CONTEXT query length";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "SEND_QUERY";
    comment = "Send newstyle NBD_OPT_SET_META_CONTEXT query";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "PREPARE_FOR_REPLY";
    comment = "Prepare to receive newstyle NBD_OPT_SET_META_CONTEXT option reply";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_REPLY";
    comment = "Receive newstyle NBD_OPT_SET_META_CONTEXT option reply";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "RECV_REPLY_PAYLOAD";
    comment = "Receive newstyle NBD_OPT_SET_META_CONTEXT option reply payload";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "CHECK_REPLY";
    comment = "Check newstyle NBD_OPT_SET_META_CONTEXT option reply";
    external_events = [];
  };
]

(* Fixed newstyle NBD_OPT_GO option. *)
and newstyle_opt_go_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Try to send newstyle NBD_OPT_GO to end handshake";
    external_events = [];
  };

  State {
    default_state with
    name = "SEND";
    comment = "Send newstyle NBD_OPT_GO to end handshake";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "SEND_EXPORTNAMELEN";
    comment = "Send newstyle NBD_OPT_GO export name length";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "SEND_EXPORT";
    comment = "Send newstyle NBD_OPT_GO export name";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "SEND_NRINFOS";
    comment = "Send newstyle NBD_OPT_GO number of infos";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "RECV_REPLY";
    comment = "Receive newstyle NBD_OPT_GO reply";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "RECV_REPLY_PAYLOAD";
    comment = "Receive newstyle NBD_OPT_GO reply payload";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "CHECK_REPLY";
    comment = "Check newstyle NBD_OPT_GO reply";
    external_events = [];
  };
]

(* Newstyle NBD_OPT_EXPORT_NAME option. *)
and newstyle_opt_export_name_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Try to send newstyle NBD_OPT_EXPORT_NAME to end handshake";
    external_events = [];
  };

  State {
    default_state with
    name = "SEND";
    comment = "Send newstyle NBD_OPT_EXPORT_NAME to end handshake";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "SEND_EXPORT";
    comment = "Send newstyle NBD_OPT_EXPORT_NAME export name";
    external_events = [ NotifyWrite, "" ];
  };

  State {
    default_state with
    name = "RECV_REPLY";
    comment = "Receive newstyle NBD_OPT_EXPORT_NAME reply";
    external_events = [ NotifyRead, "" ];
  };

  State {
    default_state with
    name = "CHECK_REPLY";
    comment = "Check newstyle NBD_OPT_EXPORT_NAME reply";
    external_events = [];
  };
]

(* Sending a command to the server. *)
and issue_command_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Begin issuing a command to the remote server";
    external_events = [];
  };

  State {
    default_state with
    name = "SEND_REQUEST";
    comment = "Sending a request to the remote server";
    external_events = [ NotifyWrite, "";
                        NotifyRead, "PAUSE_SEND_REQUEST" ];
  };

  State {
    default_state with
    name = "PAUSE_SEND_REQUEST";
    comment = "Interrupt send request to receive an earlier command's reply";
    external_events = [];
  };

  State {
    default_state with
    name = "PREPARE_WRITE_PAYLOAD";
    comment = "Prepare the write payload to send to the remote server";
    external_events = [];
  };

  State {
    default_state with
    name = "SEND_WRITE_PAYLOAD";
    comment = "Sending the write payload to the remote server";
    external_events = [ NotifyWrite, "";
                        NotifyRead, "PAUSE_WRITE_PAYLOAD" ];
  };

State {
    default_state with
    name = "PAUSE_WRITE_PAYLOAD";
    comment = "Interrupt write payload to receive an earlier command's reply";
    external_events = [];
  };

State {
    default_state with
    name = "FINISH";
    comment = "Finish issuing a command";
    external_events = [];
  };
]

(* Receiving a reply from the server. *)
and reply_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Prepare to receive a reply from the remote server";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_REPLY";
    comment = "Receive a reply from the remote server";
    external_events = [];
  };

  State {
    default_state with
    name = "CHECK_SIMPLE_OR_STRUCTURED_REPLY";
    comment = "Check if the reply is a simple or structured reply";
    external_events = [];
  };

  Group ("SIMPLE_REPLY", simple_reply_state_machine);
  Group ("STRUCTURED_REPLY", structured_reply_state_machine);

  State {
    default_state with
    name = "FINISH_COMMAND";
    comment = "Finish receiving a command";
    external_events = [];
  };
]

(* Receiving a simple reply from the server. *)
and simple_reply_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Parse a simple reply from the server";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_READ_PAYLOAD";
    comment = "Receiving the read payload for a simple reply";
    external_events = [];
  };
]

(* Receiving a structured reply from the server. *)
and structured_reply_state_machine = [
  State {
    default_state with
    name = "START";
    comment = "Prepare to receive the remaining part of a structured reply";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_REMAINING";
    comment = "Receiving the remaining part of a structured reply";
    external_events = [];
  };

  State {
    default_state with
    name = "CHECK";
    comment = "Parse a structured reply from the server";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_ERROR";
    comment = "Receive a structured reply error header";
    external_events = []
  };

  State {
    default_state with
    name = "RECV_ERROR_MESSAGE";
    comment = "Receive a structured reply error message";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_ERROR_TAIL";
    comment = "Receive a structured reply error tail";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_OFFSET_DATA";
    comment = "Receive a structured reply offset-data header";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_OFFSET_DATA_DATA";
    comment = "Receive a structured reply offset-data block of data";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_OFFSET_HOLE";
    comment = "Receive a structured reply offset-hole header";
    external_events = [];
  };

  State {
    default_state with
    name = "RECV_BS_ENTRIES";
    comment = "Receive a structured reply block-status payload";
    external_events = [];
  };

  State {
    default_state with
    name = "FINISH";
    comment = "Finish receiving a structured reply";
    external_events = [];
  };
]

(*----------------------------------------------------------------------*)

(* The API. *)

type call = {
  args : arg list;         (* parameters (except handle) *)
  ret : ret;               (* return value *)
  shortdesc : string;      (* short description *)
  longdesc : string;       (* long description *)
  (* List of permitted states for making this call.  [[]] = Any state. *)
  permitted_states : permitted_state list;
  (* Most functions must take a lock.  The only known exceptions are:
   * - functions which return a constant (eg. [nbd_supports_uri])
   * - functions which {b only} read from the atomic
   *   [get_public_state] and do nothing else with the handle.
   *)
  is_locked : bool;
  (* Most functions can call set_error.  For functions which are
   * {b guaranteed} never to do that we can save a bit of time by
   * setting this to false.
   *)
  may_set_error : bool;
}
and arg =
| ArrayAndLen of arg * string (* array + number of entries *)
| Bool of string           (* bool *)
| BytesIn of string * string (* byte array + size passed in to the function *)
| BytesOut of string * string(* byte array + size specified by caller,
                              written by the function *)
| BytesPersistIn of string * string (* same as above, but buffer persists *)
| BytesPersistOut of string * string
| Closure of closure       (* function pointer + void *opaque *)
| Flags of string          (* NBD_CMD_FLAG_* flags *)
| Int of string            (* small int *)
| Int64 of string          (* 64 bit signed int *)
| Mutable of arg           (* mutable argument, eg. int* *)
| Path of string           (* filename or path *)
| SockAddrAndLen of string * string (* struct sockaddr * + socklen_t *)
| String of string         (* string *)
| StringList of string     (* argv-style NULL-terminated array of strings *)
| UInt of string           (* small unsigned int *)
| UInt32 of string         (* 32 bit unsigned int *)
| UInt64 of string         (* 64 bit unsigned int *)
and closure = {
  cbname : string;         (* name of callback function *)
  cbargs : arg list;       (* all closures return int for now *)
}
and ret =
| RBool                    (* return a boolean, or error *)
| RConstString             (* return a const string, NULL for error *)
| RErr                     (* return 0 = ok, -1 = error *)
| RFd                      (* return a file descriptor, or error *)
| RInt                     (* return a small int, -1 = error *)
| RInt64                   (* 64 bit int, -1 = error *)
| RString                  (* return a newly allocated string, caller frees *)
| RUInt                    (* return a bitmask, no error possible *)
and permitted_state =
| Created                  (* can be called in the START state *)
| Connecting               (* can be called when connecting/handshaking *)
| Connected                (* when connected and READY or processing, but
                              not including CLOSED or DEAD *)
| Closed | Dead            (* can be called when the handle is CLOSED or DEAD *)

let default_call = { args = []; ret = RErr;
                     shortdesc = ""; longdesc = "";
                     permitted_states = [];
                     is_locked = true; may_set_error = true }

(* Calls.
 *
 * The first parameter [struct nbd_handle *nbd] is implicit.
 *
 * Disable:
 * Warning 23: all the fields are explicitly listed in this record:
 *)
let [@warning "-23"] handle_calls = [
  "set_debug", {
    default_call with
    args = [ Bool "debug" ]; ret = RErr;
    shortdesc = "set or clear the debug flag";
    longdesc = "\
Set or clear the debug flag.  When debugging is enabled,
debugging messages from the library are printed to stderr,
unless a debugging callback has been defined too
(see C<nbd_set_debug_callback>) in which case they are
sent to that function.  This flag defaults to false on
newly created handles, except if C<LIBNBD_DEBUG=1> is
set in the environment in which case it defaults to true.";
  };

  "get_debug", {
    default_call with
    args = []; ret = RBool;
    shortdesc = "return the state of the debug flag";
    longdesc = "\
Return the state of the debug flag on this handle.";
  };

  "set_debug_callback", {
    default_call with
    args = [ Closure { cbname="debug_fn";
                       cbargs=[String "context"; String "msg"] } ];
    ret = RErr;
    shortdesc = "set the debug callback";
    longdesc = "\
Set the debug callback.  This function is called when the library
emits debug messages, when debugging is enabled on a handle.  The
callback parameters are C<user_data> passed to this function, the
name of the libnbd function emitting the debug message (C<context>),
and the message itself (C<msg>).  If no debug callback is set on
a handle then messages are printed on C<stderr>.

The callback should not call C<nbd_*> APIs on the same handle since it can
be called while holding the handle lock and will cause a deadlock.";
};

  "set_export_name", {
    default_call with
    args = [ String "export_name" ]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "set the export name";
    longdesc = "\
For servers which require an export name or can serve different
content on different exports, set the C<export_name> to
connect to.  This is only relevant for the newstyle protocol.
This call may be skipped if using C<nbd_connect_uri> to connect
to a URI that includes an export name.  The default is to use
the empty string.";
  };

  "get_export_name", {
    default_call with
    args = []; ret = RString;
    shortdesc = "get the export name";
    longdesc = "\
Get the export name associated with the handle.";
  };

  "set_tls", {
    default_call with
    args = [Int "tls"]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "enable or require TLS (authentication and encryption)";
    longdesc = "\
Enable or require TLS (authenticated and encrypted connections) to the
NBD server.  The possible settings are:

=over 4

=item C<tls=0>

Disable TLS.  (The default setting, unless using C<nbd_connect_uri> with
a URI that requires TLS)

=item C<tls=1>

Enable TLS if possible.  In some cases this will fall back
to an unencrypted and/or unauthenticated connection if
TLS could not be established.  However some servers will
drop the connection if TLS fails so fallback may not be
possible.

=item C<tls=2>

Require an encrypted and authenticated TLS connection.
Always fail to connect if the connection is not encrypted
and authenticated.

=back

As well as calling this you may also need to supply
the path to the certificates directory (C<nbd_set_tls_certificates>),
the username (C<nbd_set_tls_username>) and/or
the Pre-Shared Keys (PSK) file (C<nbd_set_tls_psk_file>).  For now,
when using C<nbd_connect_uri>, any URI query parameters related to
TLS are not handled automatically.  Setting the level higher than
zero will fail if libnbd was not compiled against gnutls; you can
test whether this is the case with C<nbd_supports_tls>.

For more information see L<libnbd(3)/ENCRYPTION AND AUTHENTICATION>.";
  };

  "get_tls", {
    default_call with
    args = []; ret = RInt;
    shortdesc = "get the current TLS setting";
    longdesc = "\
Get the current TLS setting.  See C<nbd_set_tls>.";
  };

  "set_tls_certificates", {
    default_call with
    args = [Path "dir"]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "set the path to the TLS certificates directory";
    longdesc = "\
Set the path to the TLS certificates directory.  If not
set and TLS is used then a compiled in default is used.
For root this is C</etc/pki/libnbd/>.  For non-root this is
C<$HOME/.pki/libnbd> and C<$HOME/.config/pki/libnbd>.  If
none of these directories can be found then the system
trusted CAs are used.

This function may be called regardless of whether TLS is
supported, but will have no effect unless C<nbd_set_tls>
is also used to request or require TLS.";
  };

(* Can't implement this because we need a way to return string that
   can be NULL.
  "get_tls_certificates", {
    default_call with
    args = []; ret = RString;
    shortdesc = "get the current TLS certificates directory";
    longdesc = "\
Get the current TLS directory.  See C<nbd_set_tls_certificates>.";
  };
*)

  "set_tls_verify_peer", {
    default_call with
    args = [Bool "verify"]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "set whether we verify the identity of the server";
    longdesc = "\
Set this flag to control whether libnbd will verify the identity
of the server from the server's certificate and the certificate
authority.  This defaults to true when connecting to TCP servers
using TLS certificate authentication, and false otherwise.

This function may be called regardless of whether TLS is
supported, but will have no effect unless C<nbd_set_tls>
is also used to request or require TLS.";
  };

  "get_tls_verify_peer", {
    default_call with
    args = []; ret = RBool;
    shortdesc = "get whether we verify the identity of the server";
    longdesc = "\
Get the verify peer flag.";
  };

  "set_tls_username", {
    default_call with
    args = [String "username"]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "set the TLS username";
    longdesc = "\
Set the TLS client username.  This is used
if authenticating with PSK over TLS is enabled.
If not set then the local username is used.

This function may be called regardless of whether TLS is
supported, but will have no effect unless C<nbd_set_tls>
is also used to request or require TLS.";
  };

  "get_tls_username", {
    default_call with
    args = []; ret = RString;
    shortdesc = "get the current TLS username";
    longdesc = "\
Get the current TLS username.  See C<nbd_set_tls_username>.";
  };

  "set_tls_psk_file", {
    default_call with
    args = [Path "filename"]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "set the TLS Pre-Shared Keys (PSK) filename";
    longdesc = "\
Set the TLS Pre-Shared Keys (PSK) filename.  This is used
if trying to authenticate to the server using with a pre-shared
key.  There is no default so if this is not set then PSK
authentication cannot be used to connect to the server.

This function may be called regardless of whether TLS is
supported, but will have no effect unless C<nbd_set_tls>
is also used to request or require TLS.";
  };

(* Can't implement this because we need a way to return string that
   can be NULL.
  "get_tls_psk_file", {
    default_call with
    args = []; ret = RString;
    shortdesc = "get the current TLS PSK filename";
    longdesc = "\
Get the current TLS PSK filename.  See C<nbd_set_tls_psk_file>.";
  };
*)

  "add_meta_context", {
    default_call with
    args = [ String "name" ]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "ask server to negotiate metadata context";
    longdesc = "\
During connection libnbd can negotiate zero or more metadata
contexts with the server.  Metadata contexts are features (such
as C<\"base:allocation\">) which describe information returned
by the C<nbd_block_status> command (for C<\"base:allocation\">
this is whether blocks of data are allocated, zero or sparse).

This call adds one metadata context to the list to be negotiated.
You can call it as many times as needed.  The list is initially
empty when the handle is created.

Not all servers support all metadata contexts.  To learn if a context
was actually negotiated, call C<nbd_can_meta_context> after
connecting.

The single parameter is the name of the metadata context,
for example C<LIBNBD_CONTEXT_BASE_ALLOCATION>.
B<E<lt>libnbd.hE<gt>> includes defined constants beginning with
C<LIBNBD_CONTEXT_> for some well-known contexts, but you are free
to pass in other contexts.

Other metadata contexts are server-specific, but include
C<\"qemu:dirty-bitmap:...\"> for qemu-nbd
(see qemu-nbd I<-B> option).  See also C<nbd_block_status>.";
  };

  "connect_uri", {
    default_call with
    args = [ String "uri" ]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "connect to NBD URI";
    longdesc = "\
Connect (synchronously) to an NBD server and export by specifying
the NBD URI.  This call parses the URI and may call
C<nbd_set_export_name> and C<nbd_set_tls> as needed, followed by
C<nbd_connect_tcp> or C<nbd_connect_unix>.  This call returns when
the connection has been made.

This call will fail if libnbd was not compiled with libxml2; you can
test whether this is the case with C<nbd_supports_uri>.  Support for
URIs that require TLS will fail if libnbd was not compiled with
gnutls; you can test whether this is the case with C<nbd_supports_tls>.";
  };

  "connect_unix", {
    default_call with
    args = [ Path "unixsocket" ]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "connect to NBD server over a Unix domain socket";
    longdesc = "\
Connect (synchronously) over the named Unix domain socket (C<unixsocket>)
to an NBD server running on the same machine.  This call returns
when the connection has been made.";
  };

  "connect_tcp", {
    default_call with
    args = [ String "hostname"; String "port" ]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "connect to NBD server over a TCP port";
    longdesc = "\
Connect (synchronously) to the NBD server listening on
C<hostname:port>.  The C<port> may be a port name such
as C<\"nbd\">, or it may be a port number as a string
such as C<\"10809\">.  This call returns when the connection
has been made.";
  };

  "connect_command", {
    default_call with
    args = [ StringList "argv" ]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "connect to NBD server command";
    longdesc = "\
Run the command as a subprocess and connect to it over
stdin/stdout.  This is for use with NBD servers which can
behave like inetd clients, such as C<nbdkit --single>.

See also C<nbd_kill_command>.";
  };

  "read_only", {
    default_call with
    args = []; ret = RBool;
    permitted_states = [ Connected; Closed ];
    shortdesc = "is the NBD export read-only?";
    longdesc = "\
Returns true if the NBD export is read-only; writes and
write-like operations will fail.";
  };

  "can_flush", {
    default_call with
    args = []; ret = RBool;
    permitted_states = [ Connected; Closed ];
    shortdesc = "does the server support the flush command?";
    longdesc = "\
Returns true if the server supports the flush command
(see C<nbd_flush>, C<nbd_aio_flush>).  Returns false if
the server does not.";
  };

  "can_fua", {
    default_call with
    args = []; ret = RBool;
    permitted_states = [ Connected; Closed ];
    shortdesc = "does the server support the FUA flag?";
    longdesc = "\
Returns true if the server supports the FUA flag on
certain commands (see C<nbd_pwrite>).";
  };

  "is_rotational", {
    default_call with
    args = []; ret = RBool;
    permitted_states = [ Connected; Closed ];
    shortdesc = "is the NBD disk rotational (like a disk)?";
    longdesc = "\
Returns true if the disk exposed over NBD is rotational
(like a traditional floppy or hard disk).  Returns false if
the disk has no penalty for random access (like an SSD or
RAM disk).";
  };

  "can_trim", {
    default_call with
    args = []; ret = RBool;
    permitted_states = [ Connected; Closed ];
    shortdesc = "does the server support the trim command?";
    longdesc = "\
Returns true if the server supports the trim command
(see C<nbd_trim>, C<nbd_aio_trim>).  Returns false if
the server does not.";
  };

  "can_zero", {
    default_call with
    args = []; ret = RBool;
    permitted_states = [ Connected; Closed ];
    shortdesc = "does the server support the zero command?";
    longdesc = "\
Returns true if the server supports the zero command
(see C<nbd_zero>, C<nbd_aio_zero>).  Returns false if
the server does not.";
  };

  "can_df", {
    default_call with
    args = []; ret = RBool;
    shortdesc = "does the server support the don't fragment flag to pread?";
    longdesc = "\
Returns true if the server supports structured reads with an
ability to request a non-fragmented read (see C<nbd_pread_structured>,
C<nbd_aio_pread_structured>).  Returns false if the server either lacks
structured reads or if it does not support a non-fragmented read request.";
  };

  "can_multi_conn", {
    default_call with
    args = []; ret = RBool;
    permitted_states = [ Connected; Closed ];
    shortdesc = "does the server support multi-conn?";
    longdesc = "\
Returns true if the server supports multi-conn.  Returns
false if the server does not.

It is not safe to open multiple handles connecting to the
same server if you will write to the server and the
server does not advertize multi-conn support.  The safe
way to check for this is to open one connection, check
this flag is true, then open further connections as
required.";
  };

  "can_cache", {
    default_call with
    args = []; ret = RBool;
    permitted_states = [ Connected; Closed ];
    shortdesc = "does the server support the cache command?";
    longdesc = "\
Returns true if the server supports the cache command
(see C<nbd_cache>, C<nbd_aio_cache>).  Returns false if
the server does not.";
  };

  "can_meta_context", {
    default_call with
    args = [String "metacontext"]; ret = RBool;
    permitted_states = [ Connected; Closed ];
    shortdesc = "does the server support a specific meta context?";
    longdesc = "\
Returns true if the server supports the given meta context
(see C<nbd_add_meta_context>).  Returns false if
the server does not.

The single parameter is the name of the metadata context,
for example C<LIBNBD_CONTEXT_BASE_ALLOCATION>.
B<E<lt>libnbd.hE<gt>> includes defined constants for well-known
namespace contexts beginning with C<LIBNBD_CONTEXT_>, but you
are free to pass in other contexts.";
  };

  "get_size", {
    default_call with
    args = []; ret = RInt64;
    permitted_states = [ Connected; Closed ];
    shortdesc = "return the export size";
    longdesc = "\
Returns the size in bytes of the NBD export.";
  };

  "pread", {
    default_call with
    args = [ BytesOut ("buf", "count"); UInt64 "offset"; Flags "flags" ];
    ret = RErr;
    permitted_states = [ Connected ];
    shortdesc = "read from the NBD server";
    longdesc = "\
Issue a read command to the NBD server for the range starting
at C<offset> and ending at C<offset> + C<count> - 1.  NBD
can only read all or nothing using this call.  The call
returns when the data has been read fully into C<buf> or there is an
error.  See also C<nbd_pread_structured>, if finer visibility is
required into the server's replies, or if you want to use
C<LIBNBD_CMD_FLAG_DF>.

The C<flags> parameter must be C<0> for now (it exists for future NBD
protocol extensions).";
  };

  "pread_structured", {
    default_call with
    args = [ BytesOut ("buf", "count"); UInt64 "offset";
             Closure { cbname="chunk";
                       cbargs=[BytesIn ("subbuf", "count");
                               UInt64 "offset"; UInt "status";
                               Mutable (Int "error")] };
             Flags "flags" ];
    ret = RErr;
    permitted_states = [ Connected ];
    shortdesc = "read from the NBD server";
    longdesc = "\
Issue a read command to the NBD server for the range starting
at C<offset> and ending at C<offset> + C<count> - 1.  The server's
response may be subdivided into chunks which may arrive out of order
before reassembly into the original buffer; the C<chunk> callback
is used for notification after each chunk arrives, and may perform
additional sanity checking on the server's reply. The callback cannot
call C<nbd_*> APIs on the same handle since it holds the handle lock
and will cause a deadlock.  If the callback returns C<-1>, and no
earlier error has been detected, then the overall read command will
fail with any non-zero value stored into the callback's C<error>
parameter (with a default of C<EPROTO>); but any further chunks will
still invoke the callback.

The C<chunk> function is called once per chunk of data received, with
the C<user_data> passed to this function.  The
C<subbuf> and C<count> parameters represent the subset of the original
buffer which has just been populated by results from the server (in C,
C<subbuf> always points within the original C<buf>; but this guarantee
may not extend to other language bindings). The C<offset> parameter
represents the absolute offset at which C<subbuf> begins within the
image (note that this is not the relative offset of C<subbuf> within
the original buffer C<buf>). Changes to C<error> on output are ignored
unless the callback fails. The input meaning of the C<error> parameter
is controlled by the C<status> parameter, which is one of

=over 4

=item C<LIBNBD_READ_DATA> = 1

C<subbuf> was populated with C<count> bytes of data. On input, C<error>
contains the errno value of any earlier detected error, or zero.

=item C<LIBNBD_READ_HOLE> = 2

C<subbuf> represents a hole, and contains C<count> NUL bytes. On input,
C<error> contains the errno value of any earlier detected error, or zero.

=item C<LIBNBD_READ_ERROR> = 3

C<count> is 0, so C<subbuf> is unusable. On input, C<error> contains the
errno value reported by the server as occurring while reading that
C<offset>, regardless if any earlier error has been detected.

=back

Future NBD extensions may permit other values for C<status>, but those
will not be returned to a client that has not opted in to requesting
such extensions. If the server is non-compliant, it is possible for
the C<chunk> function to be called more times than you expect or with
C<count> 0 for C<LIBNBD_READ_DATA> or C<LIBNBD_READ_HOLE>. It is also
possible that the C<chunk> function is not called at all (in
particular, C<LIBNBD_READ_ERROR> is used only when an error is
associated with a particular offset, and not when the server reports a
generic error), but you are guaranteed that the callback was called at
least once if the overall read succeeds. Libnbd does not validate that
the server obeyed the requirement that a read call must not have
overlapping chunks and must not succeed without enough chunks to cover
the entire request.

The C<flags> parameter may be C<0> for no flags, or may contain
C<LIBNBD_CMD_FLAG_DF> meaning that the server should not reply with
more than one fragment (if that is supported - some servers cannot do
this, see C<nbd_can_df>). Libnbd does not validate that the server
actually obeys the flag.";
  };

  "pwrite", {
    default_call with
    args = [ BytesIn ("buf", "count"); UInt64 "offset"; Flags "flags" ];
    ret = RErr;
    permitted_states = [ Connected ];
    shortdesc = "write to the NBD server";
    longdesc = "\
Issue a write command to the NBD server, writing the data in
C<buf> to the range starting at C<offset> and ending at
C<offset> + C<count> - 1.  NBD can only write all or nothing
using this call.  The call returns when the command has been
acknowledged by the server, or there is an error.

The C<flags> parameter may be C<0> for no flags, or may contain
C<LIBNBD_CMD_FLAG_FUA> meaning that the server should not
return until the data has been committed to permanent storage
(if that is supported - some servers cannot do this, see
C<nbd_can_fua>).";
  };

  "shutdown", {
    default_call with
    args = []; ret = RErr;
    permitted_states = [ Connected ];
    shortdesc = "disconnect from the NBD server";
    longdesc = "\
Issue the disconnect command to the NBD server.  This is
a nice way to tell the server we are going away, but from the
client's point of view has no advantage over abruptly closing
the connection (see C<nbd_close>).

This function works whether or not the handle is ready for
transmission of commands, and as such does not take a C<flags>
parameter. If more fine-grained control is needed, see
C<nbd_aio_disconnect>.";
  };

  "flush", {
    default_call with
    args = [ Flags "flags" ]; ret = RErr;
    permitted_states = [ Connected ];
    shortdesc = "send flush command to the NBD server";
    longdesc = "\
Issue the flush command to the NBD server.  The function should
return when all write commands which have completed have been
committed to permanent storage on the server.  Note this will
return an error if C<nbd_can_flush> is false.

The C<flags> parameter must be C<0> for now (it exists for future NBD
protocol extensions).";
  };

  "trim", {
    default_call with
    args = [ UInt64 "count"; UInt64 "offset"; Flags "flags" ];
    ret = RErr;
    permitted_states = [ Connected ];
    shortdesc = "send trim command to the NBD server";
    longdesc = "\
Issue a trim command to the NBD server, which if supported
by the server causes a hole to be punched in the backing
store starting at C<offset> and ending at C<offset> + C<count> - 1.
The call returns when the command has been acknowledged by the server,
or there is an error.

The C<flags> parameter may be C<0> for no flags, or may contain
C<LIBNBD_CMD_FLAG_FUA> meaning that the server should not
return until the data has been committed to permanent storage
(if that is supported - some servers cannot do this, see
C<nbd_can_fua>).";
  };

  "cache", {
    default_call with
    args = [ UInt64 "count"; UInt64 "offset"; Flags "flags" ];
    ret = RErr;
    permitted_states = [ Connected ];
    shortdesc = "send cache (prefetch) command to the NBD server";
    longdesc = "\
Issue the cache (prefetch) command to the NBD server, which
if supported by the server causes data to be prefetched
into faster storage by the server, speeding up a subsequent
C<nbd_pread> call.  The server can also silently ignore
this command.  Note this will return an error if
C<nbd_can_cache> is false.

The C<flags> parameter must be C<0> for now (it exists for future NBD
protocol extensions).";
  };

  "zero", {
    default_call with
    args = [ UInt64 "count"; UInt64 "offset"; Flags "flags" ];
    ret = RErr;
    permitted_states = [ Connected ];
    shortdesc = "send write zeroes command to the NBD server";
    longdesc = "\
Issue a write zeroes command to the NBD server, which if supported
by the server causes a zeroes to be written efficiently
starting at C<offset> and ending at C<offset> + C<count> - 1.
The call returns when the command has been acknowledged by the server,
or there is an error.

The C<flags> parameter may be C<0> for no flags, or may contain
C<LIBNBD_CMD_FLAG_FUA> meaning that the server should not
return until the data has been committed to permanent storage
(if that is supported - some servers cannot do this, see
C<nbd_can_fua>), and/or C<LIBNBD_CMD_FLAG_NO_HOLE> meaning that
the server should favor writing actual allocated zeroes over
punching a hole.";
  };

  "block_status", {
    default_call with
    args = [ UInt64 "count"; UInt64 "offset";
             Closure { cbname="extent";
                       cbargs=[String "metacontext";
                               UInt64 "offset";
                               ArrayAndLen (UInt32 "entries",
                                            "nr_entries");
                               Mutable (Int "error")]};
             Flags "flags" ];
    ret = RErr;
    permitted_states = [ Connected ];
    shortdesc = "send block status command to the NBD server";
    longdesc = "\
Issue the block status command to the NBD server.  If
supported by the server, this causes metadata context
information about blocks beginning from the specified
offset to be returned. The C<count> parameter is a hint: the
server may choose to return less status, or the final block
may extend beyond the requested range. If multiple contexts
are supported, the number of blocks and cumulative length
of those blocks need not be identical between contexts.

Depending on which metadata contexts were enabled before
connecting (see C<nbd_add_meta_context>) and which are
supported by the server (see C<nbd_can_meta_context>) this call
returns information about extents by calling back to the
C<extent> function.  The callback cannot call C<nbd_*> APIs on the
same handle since it holds the handle lock and will
cause a deadlock.  If the callback returns C<-1>, and no earlier
error has been detected, then the overall block status command
will fail with any non-zero value stored into the callback's
C<error> parameter (with a default of C<EPROTO>); but any further
contexts will still invoke the callback.

The C<extent> function is called once per type of metadata available,
with the C<user_data> passed to this function.  The C<metacontext>
parameter is a string such as C<\"base:allocation\">.  The C<entries>
array is an array of pairs of integers with the first entry in each
pair being the length (in bytes) of the block and the second entry
being a status/flags field which is specific to the metadata context.
(The number of pairs passed to the function is C<nr_entries/2>.)  The
NBD protocol document in the section about
C<NBD_REPLY_TYPE_BLOCK_STATUS> describes the meaning of this array;
for contexts known to libnbd, B<E<lt>libnbd.hE<gt>> contains constants
beginning with C<LIBNBD_STATE_> that may help decipher the values.
On entry to the callback, the C<error> parameter contains the errno
value of any previously detected error.

It is possible for the extent function to be called
more times than you expect (if the server is buggy),
so always check the C<metacontext> field to ensure you
are receiving the data you expect.  It is also possible
that the extent function is not called at all, even for
metadata contexts that you requested.  This indicates
either that the server doesn't support the context
or for some other reason cannot return the data.

The C<flags> parameter may be C<0> for no flags, or may contain
C<LIBNBD_CMD_FLAG_REQ_ONE> meaning that the server should
return only one extent per metadata context where that extent
does not exceed C<count> bytes; however, libnbd does not
validate that the server obeyed the flag.";
  };

  "poll", {
    default_call with
    args = [ Int "timeout" ]; ret = RInt;
    shortdesc = "poll the handle once";
    longdesc = "\
This is a simple implementation of L<poll(2)> which is used
internally by synchronous API calls.  On success, it returns
C<0> if the C<timeout> (in milliseconds) occurs, or C<1> if
the poll completed and the state machine progressed. Set
C<timeout> to C<-1> to block indefinitely (but be careful
that eventual action is actually expected - for example, if
the connection is established but there are no commands in
flight, using an infinite timeout will permanently block).

This function is mainly useful as an example of how you might
integrate libnbd with your own main loop, rather than being
intended as something you would use.";
  };

  "aio_connect", {
    default_call with
    args = [ SockAddrAndLen ("addr", "addrlen") ]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "connect to the NBD server";
    longdesc = "\
Begin connecting to the NBD server.  Parameters behave as documented
in C<nbd_connect>.

You can check if the connection is still connecting by calling
C<nbd_aio_is_connecting>, or if it has connected to the server
and completed the NBD handshake by calling C<nbd_aio_is_ready>,
on the connection.";
  };

  "aio_connect_uri", {
    default_call with
    args = [ String "uri" ]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "connect to an NBD URI";
    longdesc = "\
Begin connecting to the NBD URI C<uri>.  Parameters behave as
documented in C<nbd_connect_uri>.

You can check if the connection is still connecting by calling
C<nbd_aio_is_connecting>, or if it has connected to the server
and completed the NBD handshake by calling C<nbd_aio_is_ready>,
on the connection.

This call will fail if libnbd was not compiled with libxml2; you can
test whether this is the case with C<nbd_supports_uri>.  Support for
URIs that require TLS will fail if libnbd was not compiled with
gnutls; you can test whether this is the case with C<nbd_supports_tls>.";
  };

  "aio_connect_unix", {
    default_call with
    args = [ Path "unixsocket" ]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "connect to the NBD server over a Unix domain socket";
    longdesc = "\
Begin connecting to the NBD server over Unix domain socket
(C<unixsocket>).  Parameters behave as documented in
C<nbd_connect_unix>.

You can check if the connection is still connecting by calling
C<nbd_aio_is_connecting>, or if it has connected to the server
and completed the NBD handshake by calling C<nbd_aio_is_ready>,
on the connection.";
  };

  "aio_connect_tcp", {
    default_call with
    args = [ String "hostname"; String "port" ]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "connect to the NBD server over a TCP port";
    longdesc = "\
Begin connecting to the NBD server listening on C<hostname:port>.
Parameters behave as documented in C<nbd_connect_tcp>.

You can check if the connection is still connecting by calling
C<nbd_aio_is_connecting>, or if it has connected to the server
and completed the NBD handshake by calling C<nbd_aio_is_ready>,
on the connection.";
  };

  "aio_connect_command", {
    default_call with
    args = [ StringList "argv" ]; ret = RErr;
    permitted_states = [ Created ];
    shortdesc = "connect to the NBD server";
    longdesc = "\
Run the command as a subprocess and begin connecting to it over
stdin/stdout.  Parameters behave as documented in
C<nbd_connect_command>.

You can check if the connection is still connecting by calling
C<nbd_aio_is_connecting>, or if it has connected to the server
and completed the NBD handshake by calling C<nbd_aio_is_ready>,
on the connection.";
  };

  "aio_pread", {
    default_call with
    args = [ BytesPersistOut ("buf", "count"); UInt64 "offset";
             Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "read from the NBD server";
    longdesc = "\
Issue a read command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  To check if the command completed, call
C<nbd_aio_command_completed>, or use C<nbd_aio_pread_callback>.
Note that you must ensure C<buf> is valid until the command
has completed.  Other parameters behave as documented in
C<nbd_pread>.";
  };

  "aio_pread_callback", {
    default_call with
    args = [ BytesPersistOut ("buf", "count"); UInt64 "offset";
             Closure { cbname="callback";
                       cbargs=[Int64 "cookie"; Mutable (Int "error")] };
             Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "read from the NBD server, with callback on completion";
    longdesc = "\
Issue a read command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  If this command returns a cookie, then C<callback>
will be invoked as described in L<libnbd(3)/Completion callbacks>.
Note that you must ensure C<buf> is valid until the command has
completed.  Other parameters behave as documented in C<nbd_pread>.";
  };

  "aio_pread_structured", {
    default_call with
    args = [ BytesPersistOut ("buf", "count"); UInt64 "offset";
             Closure { cbname="chunk";
                       cbargs=[BytesIn ("subbuf", "count");
                               UInt64 "offset";
                               UInt "status";
                               Mutable (Int "error");]};
             Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "read from the NBD server";
    longdesc = "\
Issue a read command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  To check if the command completed, call
C<nbd_aio_command_completed>, or use
C<nbd_aio_pread_structured_callback>.  Parameters behave as
documented in C<nbd_pread_structured>.";
  };

  "aio_pread_structured_callback", {
    default_call with
    args = [ BytesPersistOut ("buf", "count"); UInt64 "offset";
             Closure { cbname="chunk";
                       cbargs=[BytesIn ("subbuf", "count");
                               UInt64 "offset";
                               UInt "status";
                               Mutable (Int "error"); ]};
             Closure { cbname="callback";
                       cbargs=[Int64 "cookie";
                               Mutable (Int "error"); ]};
             Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "read from the NBD server, with callback on completion";
    longdesc = "\
Issue a read command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  If this command returns a cookie, then C<callback>
will be invoked as described in L<libnbd(3)/Completion callbacks>.
Other parameters behave as documented in C<nbd_pread_structured>.";
  };

  "aio_pwrite", {
    default_call with
    args = [ BytesPersistIn ("buf", "count"); UInt64 "offset"; Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "write to the NBD server";
    longdesc = "\
Issue a write command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  To check if the command completed, call
C<nbd_aio_command_completed>, or use C<nbd_aio_pwrite_callback>.
Note that you must ensure C<buf> is valid until the command
has completed.  Other parameters behave as documented in
C<nbd_pwrite>.";
  };

  "aio_pwrite_callback", {
    default_call with
    args = [ BytesPersistIn ("buf", "count"); UInt64 "offset";
             Closure { cbname="callback";
                       cbargs=[Int64 "cookie"; Mutable (Int "error")]};
             Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "write to the NBD server, with callback on completion";
    longdesc = "\
Issue a write command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  If this command returns a cookie, then C<callback>
will be invoked as described in L<libnbd(3)/Completion callbacks>.
Note that you must ensure C<buf> is valid until the command has
completed.  Other parameters behave as documented in C<nbd_pwrite>.";
  };

  "aio_disconnect", {
    default_call with
    args = [ Flags "flags" ]; ret = RErr;
    permitted_states = [ Connected ];
    shortdesc = "disconnect from the NBD server";
    longdesc = "\
Issue the disconnect command to the NBD server.  This is
not a normal command because NBD servers are not obliged
to send a reply.  Instead you should wait for
C<nbd_aio_is_closed> to become true on the connection.  Once this
command is issued, you cannot issue any further commands.

Although libnbd does not prevent you from issuing this command while
still waiting on the replies to previous commands, the NBD protocol
recommends that you wait until there are no other commands in flight
(see C<nbd_aio_in_flight>), to give the server a better chance at a
clean shutdown.

The C<flags> parameter must be C<0> for now (it exists for future NBD
protocol extensions).  There is no direct synchronous counterpart;
however, C<nbd_shutdown> will call this function if appropriate.";
  };

  "aio_flush", {
    default_call with
    args = [ Flags "flags" ]; ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "send flush command to the NBD server";
    longdesc = "\
Issue the flush command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  To check if the command completed, call
C<nbd_aio_command_completed>, or use C<nbd_aio_flush_callback>.
Parameters behave as documented in C<nbd_flush>.";
  };

  "aio_flush_callback", {
    default_call with
    args = [ Closure { cbname="callback";
                       cbargs=[Int64 "cookie"; Mutable (Int "error")]};
             Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "send flush command to the NBD server, with callback on completion";
    longdesc = "\
Issue the flush command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  If this command returns a cookie, then C<callback>
will be invoked as described in L<libnbd(3)/Completion callbacks>.
Other parameters behave as documented in C<nbd_flush>.";
  };

  "aio_trim", {
    default_call with
    args = [ UInt64 "count"; UInt64 "offset"; Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "send trim command to the NBD server";
    longdesc = "\
Issue a trim command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  To check if the command completed, call
C<nbd_aio_command_completed>, or use C<nbd_aio_trim_callback>.
Parameters behave as documented in C<nbd_trim>.";
  };

  "aio_trim_callback", {
    default_call with
    args = [ UInt64 "count"; UInt64 "offset";
             Closure { cbname="callback";
                       cbargs=[Int64 "cookie"; Mutable (Int "error")]};
             Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "send trim command to the NBD server, with callback on completion";
    longdesc = "\
Issue a trim command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  If this command returns a cookie, then C<callback>
will be invoked as described in L<libnbd(3)/Completion callbacks>.
Other parameters behave as documented in C<nbd_trim>.";
  };

  "aio_cache", {
    default_call with
    args = [ UInt64 "count"; UInt64 "offset"; Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "send cache (prefetch) command to the NBD server";
    longdesc = "\
Issue the cache (prefetch) command to the NBD server.  This
returns the unique positive 64 bit cookie for this command, or
C<-1> on error.  To check if the command completed, call
C<nbd_aio_command_completed>, or use C<nbd_aio_cache_callback>.
Parameters behave as documented in C<nbd_cache>.";
  };

  "aio_cache_callback", {
    default_call with
    args = [ UInt64 "count"; UInt64 "offset";
             Closure { cbname="callback";
                       cbargs=[Int64 "cookie"; Mutable (Int "error")]};
             Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "send cache (prefetch) command to the NBD server, with callback on completion";
    longdesc = "\
Issue the cache (prefetch) command to the NBD server.  This
returns the unique positive 64 bit cookie for this command, or
C<-1> on error.  If this command returns a cookie, then C<callback>
will be invoked as described in L<libnbd(3)/Completion callbacks>.
Other parameters behave as documented in C<nbd_cache>.";
  };

  "aio_zero", {
    default_call with
    args = [ UInt64 "count"; UInt64 "offset"; Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "send write zeroes command to the NBD server";
    longdesc = "\
Issue a write zeroes command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  To check if the command completed, call
C<nbd_aio_command_completed>, or use C<nbd_aio_zero_callback>.
Parameters behave as documented in C<nbd_zero>.";
  };

  "aio_zero_callback", {
    default_call with
    args = [ UInt64 "count"; UInt64 "offset";
             Closure { cbname="callback";
                       cbargs=[Int64 "cookie"; Mutable (Int "error")]};
             Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "send write zeroes command to the NBD server, with callback on completion";
    longdesc = "\
Issue a write zeroes command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  If this command returns a cookie, then C<callback>
will be invoked as described in L<libnbd(3)/Completion callbacks>.
Other parameters behave as documented in C<nbd_zero>.";
  };

  "aio_block_status", {
    default_call with
    args = [ UInt64 "count"; UInt64 "offset";
             Closure { cbname="extent";
                       cbargs=[String "metacontext"; UInt64 "offset";
                               ArrayAndLen (UInt32 "entries",
                                            "nr_entries");
                               Mutable (Int "error")] };
             Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "send block status command to the NBD server";
    longdesc = "\
Send the block status command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  To check if the command completed, call
C<nbd_aio_command_completed>, or use C<nbd_aio_block_status_callback>.
Parameters behave as documented in C<nbd_block_status>.";
  };

  "aio_block_status_callback", {
    default_call with
    args = [ UInt64 "count"; UInt64 "offset";
             Closure { cbname="extent";
                       cbargs=[String "metacontext"; UInt64 "offset";
                               ArrayAndLen (UInt32 "entries",
                                            "nr_entries");
                               Mutable (Int "error")]};
             Closure { cbname="callback";
                       cbargs=[Int64 "cookie"; Mutable (Int "error")]};
             Flags "flags" ];
    ret = RInt64;
    permitted_states = [ Connected ];
    shortdesc = "send block status command to the NBD server, with callback on completion";
    longdesc = "\
Send the block status command to the NBD server.  This returns the
unique positive 64 bit cookie for this command, or C<-1> on
error.  If this command returns a cookie, then C<callback>
will be invoked as described in L<libnbd(3)/Completion callbacks>.
Other parameters behave as documented in C<nbd_block_status>.";
  };

  "aio_get_fd", {
    default_call with
    args = []; ret = RFd;
    shortdesc = "return file descriptor associated with this connection";
    longdesc = "\
Return the underlying file descriptor associated with this
connection.  You can use this to check if the file descriptor
is ready for reading or writing and call C<nbd_aio_notify_read>
or C<nbd_aio_notify_write>.  See also C<nbd_aio_get_direction>.
Do not do anything else with the file descriptor.";
  };

  "aio_get_direction", {
    default_call with
    args = []; ret = RUInt; is_locked = false; may_set_error = false;
    shortdesc = "return the read or write direction";
    longdesc = "\
Return the current direction of this connection, which means
whether we are next expecting to read data from the server, write
data to the server, or both.  It returns

=over 4

=item 0

We are not expected to interact with the server file descriptor from
the current state. It is not worth attempting to use L<poll(2)>; if
the connection is not dead, then state machine progress must instead
come from some other means such as C<nbd_aio_connect>.

=item C<LIBNBD_AIO_DIRECTION_READ> = 1

We are expected next to read from the server.  If using L<poll(2)>
you would set C<events = POLLIN>.  If C<revents> returns C<POLLIN>
or C<POLLHUP> you would then call C<nbd_aio_notify_read>.

Note that once libnbd reaches C<nbd_aio_is_ready>, this direction is
returned even when there are no commands in flight (see
C<nbd_aio_in_flight>). In a single-threaded use of libnbd, it is not
worth polling until after issuing a command, as otherwise the server
will never wake up the poll. In a multi-threaded scenario, you can
have one thread begin a polling loop prior to any commands, but any
other thread that issues a command will need a way to kick the
polling thread out of poll in case issuing the command changes the
needed polling direction. Possible ways to do this include polling
for activity on a pipe-to-self, or using L<pthread_kill(3)> to send
a signal that is masked except during L<ppoll(2)>.

=item C<LIBNBD_AIO_DIRECTION_WRITE> = 2

We are expected next to write to the server.  If using L<poll(2)>
you would set C<events = POLLOUT>.  If C<revents> returns C<POLLOUT>
you would then call C<nbd_aio_notify_write>.

=item C<LIBNBD_AIO_DIRECTION_BOTH> = 3

We are expected next to either read or write to the server.  If using
L<poll(2)> you would set C<events = POLLIN|POLLOUT>.  If only one of
C<POLLIN> or C<POLLOUT> is returned, then see above.  However, if both
are returned, it is better to call only C<nbd_aio_notify_read>, as
processing the server's reply may change the state of the connection
and invalidate the need to write more commands.

=back";
  };

  "aio_notify_read", {
    default_call with
    args = []; ret = RErr;
    shortdesc = "notify that the connection is readable";
    longdesc = "\
Send notification to the state machine that the connection
is readable.  Typically this is called after your main loop
has detected that the file descriptor associated with this
connection is readable.";
  };

  "aio_notify_write", {
    default_call with
    args = []; ret = RErr;
    shortdesc = "notify that the connection is writable";
    longdesc = "\
Send notification to the state machine that the connection
is writable.  Typically this is called after your main loop
has detected that the file descriptor associated with this
connection is writable.";
  };

  "aio_is_created", {
    default_call with
    args = []; ret = RBool; is_locked = false; may_set_error = false;
    shortdesc = "check if the connection has just been created";
    longdesc = "\
Return true if this connection has just been created.  This
is the state before the handle has started connecting to a
server.  In this state the handle can start to be connected
by calling functions such as C<nbd_aio_connect>.";
  };

  "aio_is_connecting", {
    default_call with
    args = []; ret = RBool; is_locked = false; may_set_error = false;
    shortdesc = "check if the connection is connecting or handshaking";
    longdesc = "\
Return true if this connection is connecting to the server
or in the process of handshaking and negotiating options
which happens before the handle becomes ready to
issue commands (see C<nbd_aio_is_ready>).";
  };

  "aio_is_ready", {
    default_call with
    args = []; ret = RBool; is_locked = false; may_set_error = false;
    shortdesc = "check if the connection is in the ready state";
    longdesc = "\
Return true if this connection is connected to the NBD server,
the handshake has completed, and the connection is idle or
waiting for a reply.  In this state the handle is ready to
issue commands.";
  };

  "aio_is_processing", {
    default_call with
    args = []; ret = RBool; is_locked = false; may_set_error = false;
    shortdesc = "check if the connection is processing a command";
    longdesc = "\
Return true if this connection is connected to the NBD server,
the handshake has completed, and the connection is processing
commands (either writing out a request or reading a reply).

Note the ready state (C<nbd_aio_is_ready>) is not included.
In the ready state commands may be I<in flight> (the I<server>
is processing them), but libnbd is not processing them.";
  };

  "aio_is_dead", {
    default_call with
    args = []; ret = RBool; is_locked = false; may_set_error = false;
    shortdesc = "check if the connection is dead";
    longdesc = "\
Return true if the connection has encountered a fatal
error and is dead.  In this state the handle may only be closed.
There is no way to recover a handle from the dead state.";
  };

  "aio_is_closed", {
    default_call with
    args = []; ret = RBool; is_locked = false; may_set_error = false;
    shortdesc = "check if the connection is closed";
    longdesc = "\
Return true if the connection has closed.  There is no way to
reconnect a closed connection.  Instead you must close the
whole handle.";
  };

  "aio_command_completed", {
    default_call with
    args = [Int64 "cookie"]; ret = RBool;
    shortdesc = "check if the command completed";
    longdesc = "\
Return true if the command completed.  If this function returns
true then the command was successful and it has been retired.
Return false if the command is still in flight.  This can also
fail with an error in case the command failed (in this case
the command is also retired).  A command is retired either via
this command, or by using a completion callback which returns
C<1> (completion callbacks are registered via
C<nbd_aio_pread_callback> and similar).

The C<cookie> parameter is the positive unique 64 bit cookie
for the command, as returned by a call such as C<nbd_aio_pread>.";
  };

  "aio_peek_command_completed", {
    default_call with
    args = []; ret = RInt64;
    shortdesc = "check if any command has completed";
    longdesc = "\
Return the unique positive 64 bit cookie of the first non-retired but
completed command, C<0> if there are in-flight commands but none of
them are awaiting retirement, or C<-1> on error including when there
are no in-flight commands. Any cookie returned by this function must
still be passed to C<nbd_aio_command_completed> to actually retire
the command and learn whether the command was successful.";
  };

  "aio_in_flight", {
    default_call with
    args = []; ret = RInt;
    permitted_states = [ Connected; Closed; Dead ];
    (* XXX is_locked = false ? *)
    shortdesc = "check how many aio commands are still in flight";
    longdesc = "\
Return the number of in-flight aio commands that are still awaiting a
response from the server before they can be retired.  If this returns
a non-zero value when requesting a disconnect from the server (see
C<nbd_aio_disconnect> and C<nbd_shutdown>), libnbd does not try to
wait for those commands to complete gracefully; if the server strands
commands while shutting down, C<nbd_aio_command_completed> will report
those commands as failed with a status of C<ENOTCONN>.";
  };

  "connection_state", {
    default_call with
    args = []; ret = RConstString;
    shortdesc = "return a descriptive string for the state of the connection";
    longdesc = "\
Returns a descriptive string for the state of the connection.  This
can be used for debugging or troubleshooting, but you should not
rely on the state of connections since it may change in future
versions.";
  };

  "get_package_name", {
    default_call with
    args = []; ret = RConstString; is_locked = false; may_set_error = false;
    shortdesc = "return the name of the library";
    longdesc = "\
Returns the name of the library, always C<\"libnbd\"> unless
the library was modified with another name at compile time.";
  };

  "get_version", {
    default_call with
    args = []; ret = RConstString; is_locked = false; may_set_error = false;
    shortdesc = "return a descriptive string for the state of the connection";
    longdesc = "\
Return the version of libnbd.  This is returned as a string
in the form C<\"major.minor.release\"> where each of major, minor
and release is a small positive integer.  For example C<\"1.0.3\">.

The major number is C<0> for the early experimental versions of
libnbd where we still had an unstable API, or C<1> for the versions
of libnbd with a long-term stable API and ABI.

The minor number is even (C<0>, C<2>, etc) for stable releases,
and odd (C<1>, C<3>, etc) for development versions.  Note that
new APIs added in a development version remain experimental
and subject to change in that branch until they appear in a stable
release.

The release number is incremented for each release along a particular
branch.";
  };

  "kill_command", {
    default_call with
    args = [ Int "signum" ]; ret = RErr;
    shortdesc = "kill server running as a subprocess";
    longdesc = "\
This call may be used to kill the server running as a subprocess
that was previously created using C<nbd_connect_command>.  You
do not need to use this call.  It is only needed if the server
does not exit when the socket is closed.

The C<signum> parameter is the optional signal number to send
(see L<signal(7)>).  If C<signum> is C<0> then C<SIGTERM> is sent.";
  };

  "supports_tls", {
    default_call with
    args = []; ret = RBool; is_locked = false; may_set_error = false;
    shortdesc = "return true if libnbd was compiled with support for TLS";
    longdesc = "\
Returns true if libnbd was compiled with gnutls which is required
to support TLS encryption, or false if not.  See C<nbd_set_tls>.";
  };

  "supports_uri", {
    default_call with
    args = []; ret = RBool; is_locked = false; may_set_error = false;
    shortdesc = "return true if libnbd was compiled with support for NBD URIs";
    longdesc = "\
Returns true if libnbd was compiled with libxml2 which is required
to support NBD URIs, or false if not.  See C<nbd_connect_uri> and
C<nbd_aio_connect_uri>.";
  };

]

(* Constants, flags, etc. *)
let constants = [
  "AIO_DIRECTION_READ",  1;
  "AIO_DIRECTION_WRITE", 2;
  "AIO_DIRECTION_BOTH",  3;

  "CMD_FLAG_FUA",        1 lsl 0;
  "CMD_FLAG_NO_HOLE",    1 lsl 1;
  "CMD_FLAG_DF",         1 lsl 2;
  "CMD_FLAG_REQ_ONE",    1 lsl 3;

  "READ_DATA",           1;
  "READ_HOLE",           2;
  "READ_ERROR",          3;
]

let metadata_namespaces = [
  "base", [ "allocation", [
    "STATE_HOLE", 1 lsl 0;
    "STATE_ZERO", 1 lsl 1;
  ] ];
]

(*----------------------------------------------------------------------*)

(* Helper functions. *)

let failwithf fs = ksprintf failwith fs

let rec filter_map f = function
  | [] -> []
  | x :: xs ->
      match f x with
      | Some y -> y :: filter_map f xs
      | None -> filter_map f xs

let chan = ref Pervasives.stdout
let pr fs = ksprintf (fun str -> output_string !chan str) fs

type comment_style =
  | CStyle | CPlusPlusStyle | HashStyle | OCamlStyle | HaskellStyle
  | PODCommentStyle

let generate_header ?(extra_sources = []) comment_style =
  let inputs = "generator/generator" :: extra_sources in
  let c = match comment_style with
    | CStyle ->         pr "/* "; " *"
    | CPlusPlusStyle -> pr "// "; "//"
    | HashStyle ->      pr "# ";  "#"
    | OCamlStyle ->     pr "(* "; " *"
    | HaskellStyle ->   pr "{- "; "  "
    | PODCommentStyle -> pr "=begin comment\n\n "; "" in
  pr "NBD client library in userspace\n";
  pr "%s WARNING: THIS FILE IS GENERATED FROM\n" c;
  pr "%s %s\n" c (String.concat " " inputs);
  pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
  pr "%s\n" c;
  pr "%s Copyright (C) 2013-2019 Red Hat Inc.\n" c;
  pr "%s\n" c;
  pr "%s This library is free software; you can redistribute it and/or\n" c;
  pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
  pr "%s License as published by the Free Software Foundation; either\n" c;
  pr "%s version 2 of the License, or (at your option) any later version.\n" c;
  pr "%s\n" c;
  pr "%s This library is distributed in the hope that it will be useful,\n" c;
  pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
  pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
  pr "%s Lesser General Public License for more details.\n" c;
  pr "%s\n" c;
  pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
  pr "%s License along with this library; if not, write to the Free Software\n" c;
  pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
  (match comment_style with
   | CStyle -> pr " */\n"
   | CPlusPlusStyle
   | HashStyle -> ()
   | OCamlStyle -> pr " *)\n"
   | HaskellStyle -> pr "-}\n"
   | PODCommentStyle -> pr "\n=end comment\n"
  );
  pr "\n"

let quote = Filename.quote

let files_equal n1 n2 =
  let cmd = sprintf "cmp -s %s %s" (quote n1) (quote n2) in
  match Sys.command cmd with
  | 0 -> true
  | 1 -> false
  | i -> failwithf "%s: failed with error code %d" cmd i

let output_to filename k =
  let filename_new = filename ^ ".new" in
  chan := open_out filename_new;
  k ();
  close_out !chan;
  chan := Pervasives.stdout;

  (* Is the new file different from the current file? *)
  if Sys.file_exists filename && files_equal filename filename_new then
    unlink filename_new                 (* same, so skip it *)
  else (
    (* different, overwrite old one *)
    (try chmod filename 0o644 with Unix_error _ -> ());
    rename filename_new filename;
    chmod filename 0o444;
    printf "written %s\n%!" filename;
  )

let string_of_location (file, lineno) = sprintf "%s:%d" file lineno
let line_directive_of_location (file, lineno) =
  sprintf "#line %d \"%s\"" lineno file

(*----------------------------------------------------------------------*)

(* Convert POD fragments into plain text.
 *
 * For man pages and Perl documentation we can simply use the POD
 * directly, and that is the best solution.  However for other
 * programming languages we have to convert the POD fragments to
 * plain text by running it through pod2text.
 *
 * The problem is that pod2text is very slow so we must cache
 * the converted fragments to disk.
 *
 * Increment the version in the filename whenever the cache
 * type changes.
 *)

type cache_key = string (* longdesc *)
type cache_value = string list (* list of plain text lines *)

let (cache : (cache_key, cache_value) Hashtbl.t), save_cache =
  let cachefile = "generator/generator-cache.v1" in
  let cache =
    try
      let chan = open_in cachefile in
      let ret = input_value chan in
      close_in chan;
      ret
    with _ ->
      printf "Regenerating the cache, this could take a little while ...\n%!";
      Hashtbl.create 13 in
  let save_cache () =
    let chan = open_out cachefile in
    output_value chan cache;
    close_out chan
  in
  cache, save_cache

let pod2text longdesc =
  let key : cache_key = longdesc in
  try Hashtbl.find cache key
  with Not_found ->
    let filename, chan = Filename.open_temp_file "pod2text" ".tmp" in
    fprintf chan "=encoding utf8\n\n";
    fprintf chan "=head1 NAME\n\n%s\n" longdesc;
    close_out chan;
    let cmd = sprintf "pod2text -w 60 %s" (quote filename) in
    let chan = open_process_in cmd in
    let lines = ref [] in
    let rec loop i =
      let line = input_line chan in
      if i = 1 then (* discard first line of output *)
        loop (i+1)
      else (
        lines := line :: !lines;
        loop (i+1)
      ) in
    let lines : cache_value =
      try loop 1 with End_of_file -> List.rev !lines in
    unlink filename;
    (match close_process_in chan with
     | WEXITED 0 -> ()
     | WEXITED i ->
        failwithf "pod2text: process exited with non-zero status (%d)" i
     | WSIGNALED i | WSTOPPED i ->
        failwithf "pod2text: process signalled or stopped by signal %d" i
    );
    Hashtbl.add cache key lines;
    save_cache ();
    lines

(*----------------------------------------------------------------------*)

(* Implement state machine. *)

module StateMachine : sig
  val generate_lib_states_h : unit -> unit
  val generate_lib_states_c : unit -> unit
end = struct

let all_external_events =
  [NotifyRead; NotifyWrite;
   CmdCreate;
   CmdConnectSockAddr; CmdConnectUnix; CmdConnectTCP; CmdConnectCommand;
   CmdIssue]

let string_of_external_event = function
  | NotifyRead -> "NotifyRead"
  | NotifyWrite -> "NotifyWrite"
  | CmdCreate -> "CmdCreate"
  | CmdConnectSockAddr -> "CmdConnectSockAddr"
  | CmdConnectUnix -> "CmdConnectUnix"
  | CmdConnectTCP -> "CmdConnectTCP"
  | CmdConnectCommand -> "CmdConnectCommand"
  | CmdIssue -> "CmdIssue"

let c_string_of_external_event = function
  | NotifyRead -> "notify_read"
  | NotifyWrite -> "notify_write"
  | CmdCreate -> "cmd_create"
  | CmdConnectSockAddr -> "cmd_connect_sockaddr"
  | CmdConnectUnix -> "cmd_connect_unix"
  | CmdConnectTCP -> "cmd_connect_tcp"
  | CmdConnectCommand -> "cmd_connect_command"
  | CmdIssue -> "cmd_issue"

(* Find a state in the state machine hierarchy by path.  The [path]
 * parameter is a list like [["READY"]] or [["MAGIC"; "START"]].
 *)
let find_state path =
  let rec find sm = function
    | [] -> raise Not_found
    | [n] ->
       (* Find a state leaf node. *)
       let rec loop = function
         | [] -> raise Not_found
         | State ({ name } as ret) :: _ when n = name -> ret
         | _ :: rest -> loop rest
       in
       loop sm
    | g :: path ->
       (* Find a state machine group. *)
       let rec loop = function
         | [] -> raise Not_found
         | Group (name, group) :: _ when g = name -> find group path
         | _ :: rest -> loop rest
       in
       loop sm
  in
  try (find state_machine path : state)
  with Not_found ->
       failwithf "find_state: ‘%s’ not found" (String.concat "." path)

let dot_rex = Str.regexp "\\."

(* Resolve a stringified path to a state.
 *
 * [prefix] parameter is the current prefix.  We resolve paths
 * relative to this.
 *
 * Stringified paths can be:
 * ["STATE"] => state relative to current level
 * ["GROUP.STATE"] => state below group at current level (to any depth)
 * [".TOP"] => state at the top level
 * ["^UP"] => state at a level above this one
 *)
let rec resolve_state prefix str =
  let len = String.length str in
  if len >= 1 && String.sub str 0 1 = "." then
    resolve_state [] (String.sub str 1 (len-1))
  else if len >= 1 && String.sub str 0 1 = "^" then (
    let parent =
      match List.rev prefix with
      | [] -> failwithf "resolve_state: %s (^) used from top level group" str
      | _ :: rest -> List.rev rest in
    resolve_state parent (String.sub str 1 (len-1))
  )
  else (
    let path = Str.split_delim dot_rex str in
    find_state (prefix @ path)
  )

(* Flatten the state machine hierarchy.  This sets the [parsed.prefix],
 * [parsed.state_enum], [parsed.events] fields in the state.
 *)
let states : state list =
  let rec flatten prefix = function
    | [] -> []
    | State st :: rest ->
       st.parsed <-
         { st.parsed with
           prefix = prefix;
           display_name = (
             match prefix with
             | [] -> st.name
             | prefix -> String.concat "." prefix ^ "." ^ st.name
           );
           state_enum = (
             let path = String.concat "" (List.map ((^) "_") prefix) in
             "STATE" ^ path ^ "_" ^ st.name
           );
           events = (
             List.map (
               fun (ev, str) ->
                 (* In external_events,
                  * special string [""] means current state.
                  *)
                 if str = "" then ev, st
                 else ev, resolve_state prefix str
             ) st.external_events
           )
         };
       st :: flatten prefix rest
    | Group (name, group) :: rest ->
       let states = flatten (prefix @ [name]) group in
       states @ flatten prefix rest
  in
  flatten [] state_machine

(* Read and parse the state machine C code. *)
let state_machine_prologue =
  let parse_states_file filename =
    let chan = open_in filename in
    let lines = ref [] in
    let lineno = ref 1 in
    (try while true do
           let line = input_line chan in
           let loc : location = filename, !lineno in
           incr lineno;
           lines := (loc, line) :: !lines
         done
     with End_of_file -> ());
    close_in chan;
    (* Note this list is initially in reverse order. *)
    let lines = !lines in

    (* The last line in the file must have a particular form, check
     * and remove.
     *)
    if List.length lines = 0 ||
         snd (List.hd lines) <> "} /* END STATE MACHINE */" then
      failwithf "%s: unexpected file ending" filename;
    let lines = List.tl lines in
    let lines = List.rev lines in

    (* Find the start of the state machine and split the list into
     * the prologue and the list of state code fragments.
     *)
    let rec loop acc = function
      | [] -> failwithf "%s: could not find state machine" filename
      | (_, "/* STATE MACHINE */ {") :: lines -> ((filename, 1), acc), lines
      | (_, line) :: lines -> loop (acc ^ line ^ "\n") lines
    in
    let prologue, lines = loop "" lines in

    let statecodes = ref [] in
    let curr_state = ref None in
    let rex = Str.regexp "^ \\([A-Z0-9][A-Z0-9_\\.]*\\):$" in
    List.iter (
      fun (loc, line) ->
        if Str.string_match rex line 0 then ( (* new case *)
          (match !curr_state with
           | None -> ()
           | Some state -> statecodes := state :: !statecodes);
          curr_state := Some (Str.matched_group 1 line, "", loc);
        )
        else (
          (match !curr_state with
           | None ->
              failwithf "%s: missing label" (string_of_location loc)
           | Some (name, code, loc) ->
              curr_state := Some (name, code ^ "\n" ^ line, loc)
          )
        );
      ) lines;
    (match !curr_state with
     | None -> ()
     | Some state -> statecodes := state :: !statecodes);
    let statecodes = List.rev !statecodes in

    prologue, statecodes
  in

  (* Read all the input files, called [generator/states*.c] *)
  let files = List.sort compare (Array.to_list (Sys.readdir "generator")) in
  let files = List.filter (
    fun filename ->
      let len = String.length filename in
      len >= 8 && String.sub filename 0 6 = "states" &&
        String.sub filename (len-2) 2 = ".c"
  ) files in
  let files = List.map ((^) "generator/") files in
  let files = List.map parse_states_file files in

  (* Mash together the prologues and the state codes. *)
  let prologue =
    String.concat "" (
      List.map (
        fun ((loc, prologue), _) ->
          line_directive_of_location loc ^ "\n" ^ prologue ^ "\n"
       ) files
     ) in
  let statecodes = List.concat (List.map snd files) in

  (* Resolve the state names in the code to paths. *)
  let statecodes =
    List.map (
      fun (name, code, loc) ->
        let path = Str.split_delim dot_rex name in
        let state = find_state path in
        state, code, loc
    ) statecodes in

  (* Parse the state code fragments to get internal state
   * transitions, marked by "%STATE".
   *)
  let rex = Str.regexp "%\\([\\^\\.]*[A-Z0-9][A-Z0-9_\\.]*\\)" in
  List.iter (
    fun (state, code, loc) ->
      let code = Str.full_split rex code in
      let code =
        List.map (
          function
          | Str.Delim str ->
             Str.Delim (String.sub str 1 (String.length str - 1))
          | (Str.Text _) as c -> c
      ) code in

      (* Create the list of internal transitions. *)
      state.parsed <-
        { state.parsed with
          internal_transitions = (
            filter_map (
              function
              | Str.Delim str ->
                 let next_state = resolve_state state.parsed.prefix str in
                 Some next_state
              | Str.Text _ -> None
            ) code
        )
        };

      (* Create the final C code fragment. *)
      state.parsed <-
        { state.parsed with
          loc = loc;
          code =
            String.concat "" (
              List.map (
                function
                | Str.Delim str ->
                   let next_state = resolve_state state.parsed.prefix str in
                   next_state.parsed.state_enum
                | Str.Text text -> text
                ) code
            )
        }
  ) statecodes;

  prologue

(* Verify state transitions are permitted. *)
let () =
  let verify_state_transition from_state to_state =
    let from_prefix = from_state.parsed.prefix
    and to_prefix = to_state.parsed.prefix in
    (* Going from state to state within the same group is always allowed. *)
    if from_prefix = to_prefix then
      ()
    (* Going upwards to any state is always allowed. *)
    else if List.length from_prefix > List.length to_prefix then
      ()
    (* When going downwards (even into an adjacent tree) you must
     * always enter a group at the START state.
     *)
    else if to_state.name <> "START" then (
      failwithf "non-permitted state transition: %s.%s -> %s.%s"
                (String.concat "." from_prefix) from_state.name
                (String.concat "." to_prefix) to_state.name
    )
  in
  List.iter (
    fun ({ parsed = { internal_transitions; events } } as state) ->
      List.iter (verify_state_transition state) internal_transitions;
      List.iter (fun (_, next_state) -> verify_state_transition state next_state) events
  ) states

(* Write the state machine code. *)
let generate_lib_states_h () =
  generate_header ~extra_sources:["generator/states*.c"] CStyle;
  pr "enum state {\n";
  List.iter (
    fun ({ comment; parsed = { display_name; state_enum } }) ->
      pr "  /* %s: %s */\n" display_name comment;
      pr "  %s,\n" state_enum;
      pr "\n";
  ) states;
  pr "};\n";
  pr "\n";
  pr "/* These correspond to the external events in generator/generator. */\n";
  pr "enum external_event {\n";
  List.iter (
    fun e -> pr "  %s,\n" (c_string_of_external_event e)
  ) all_external_events;
  pr "};\n";
  pr "\n";
  pr "/* State groups. */\n";
  pr "enum state_group {\n";
  pr "  GROUP_TOP,\n";
  let rec loop prefix = function
    | [] -> ()
    | State _ :: rest ->
       loop prefix rest
    | Group (name, group) :: rest ->
       let enum =
         "GROUP" ^ String.concat "" (List.map ((^) "_") prefix) ^ "_" ^ name in
       pr "  %s,\n" enum;
       loop (prefix @ [name]) group;
       loop prefix rest
  in
  loop [] state_machine;
  pr "};\n"

let generate_lib_states_c () =
  generate_header ~extra_sources:["generator/states*.c"] CStyle;

  pr "%s\n" state_machine_prologue;
  pr "\n";
  pr "#define SET_NEXT_STATE(s) (*blocked = false, *next_state = (s))\n";
  pr "#define SET_NEXT_STATE_AND_BLOCK(s) (*next_state = (s))\n";
  pr "\n";

  (* The state machine C code fragments. *)
  List.iter (
    fun ({ comment; parsed = { display_name; state_enum; loc; code } }) ->
      pr "/* %s: %s */\n" display_name comment;
      pr "static int\n";
      pr "_enter_%s (struct nbd_handle *h,\n" state_enum;
      pr "             enum state *next_state,\n";
      pr "             bool *blocked)\n";
      pr "{\n";
      if code <> "" then (
        pr "%s\n" (line_directive_of_location loc);
        pr "%s\n" code
      )
      else
        pr "  return 0;\n";
      pr "}\n";
      pr "\n";
      pr "static int\n";
      pr "enter_%s (struct nbd_handle *h, bool *blocked)\n" state_enum;
      pr "{\n";
      pr "  int r;\n";
      pr "  enum state next_state = %s;\n" state_enum;
      pr "\n";
      pr "  r = _enter_%s (h, &next_state, blocked);\n" state_enum;
      pr "  if (get_next_state (h) != next_state) {\n";
      pr "    debug (h, \"transition: %%s -> %%s\",\n";
      pr "           \"%s\",\n" display_name;
      pr "           nbd_internal_state_short_string (next_state));\n";
      pr "    set_next_state (h, next_state);\n";
      pr "  }\n";
      pr "  return r;\n";
      pr "}\n";
      pr "\n";
  ) states;

  pr "/* Run the state machine based on an external event until it would block. */\n";
  pr "int\n";
  pr "nbd_internal_run (struct nbd_handle *h, enum external_event ev)\n";
  pr "{\n";
  pr "  int r;\n";
  pr "  bool blocked;\n";
  pr "\n";
  pr "  /* Validate and handle the external event. */\n";
  pr "  switch (get_next_state (h))\n";
  pr "  {\n";
  List.iter (
    fun ({ parsed = { display_name; state_enum; events } } as state) ->
      pr "  case %s:\n" state_enum;
      if events <> [] then (
        pr "    switch (ev)\n";
        pr "    {\n";
        List.iter (
          fun (e, next_state) ->
            pr "    case %s:\n" (c_string_of_external_event e);
            if state != next_state then (
              pr "      set_next_state (h, %s);\n" next_state.parsed.state_enum;
              pr "      debug (h, \"event %%s: %%s -> %%s\",\n";
              pr "             \"%s\", \"%s\", \"%s\");\n"
                 (string_of_external_event e)
                 display_name next_state.parsed.display_name;
            );
            pr "      goto ok;\n";
        ) events;
        pr "    default: ; /* nothing, silence GCC warning */\n";
        pr "    }\n";
      );
      pr "    break;\n";
  ) states;
  pr "  }\n";
  pr "\n";
  pr "  set_error (EINVAL, \"external event %%d is invalid in state %%s\",\n";
  pr "             ev, nbd_internal_state_short_string (get_next_state (h)));\n";
  pr "  return -1;\n";
  pr "\n";
  pr " ok:\n";
  pr "  do {\n";
  pr "    blocked = true;\n";
  pr "\n";
  pr "    /* Run a single step. */\n";
  pr "    switch (get_next_state (h))\n";
  pr "    {\n";
  List.iter (
    fun { parsed = { state_enum } } ->
      pr "    case %s:\n" state_enum;
      pr "      r = enter_%s (h, &blocked);\n" state_enum;
      pr "      break;\n"
  ) states;
  pr "    default:\n";
  pr "      abort (); /* Should never happen, but keeps GCC happy. */\n";
  pr "    }\n";
  pr "\n";
  pr "    if (r == -1) {\n";
  pr "      assert (nbd_get_error () != NULL);\n";
  pr "      return -1;\n";
  pr "    }\n";
  pr "  } while (!blocked);\n";
  pr "  return 0;\n";
  pr "}\n";
  pr "\n";

  pr "/* Returns whether in the given state read or write would be valid.\n";
  pr " * NB: is_locked = false, may_set_error = false.\n";
  pr " */\n";
  pr "int\n";
  pr "nbd_internal_aio_get_direction (enum state state)\n";
  pr "{\n";
  pr "  int r = 0;\n";
  pr "\n";
  pr "  switch (state)\n";
  pr "  {\n";
  List.iter (
    fun ({ parsed = { state_enum; events } }) ->
      pr "  case %s:\n" state_enum;
      List.iter (
        fun (e, _) ->
          match e with
          | NotifyRead ->  pr "    r |= LIBNBD_AIO_DIRECTION_READ;\n"
          | NotifyWrite -> pr "    r |= LIBNBD_AIO_DIRECTION_WRITE;\n"
          | CmdCreate
          | CmdConnectSockAddr
          | CmdConnectUnix | CmdConnectTCP | CmdConnectCommand
          | CmdIssue -> ()
      ) events;
      pr "    break;\n";
  ) states;
  pr "  }\n";
  pr "\n";
  pr "  return r;\n";
  pr "}\n";
  pr "\n";

  pr "/* Other functions associated with the state machine. */\n";
  pr "const char *\n";
  pr "nbd_internal_state_short_string (enum state state)\n";
  pr "{\n";
  pr "  switch (state)\n";
  pr "  {\n";
  List.iter (
    fun ({ parsed = { display_name; state_enum } }) ->
      pr "  case %s:\n" state_enum;
      pr "    return \"%s\";\n" display_name
  ) states;
  pr "  }\n";
  pr "\n";
  pr "  /* This function is only used for debug messages, and\n";
  pr "   * this should never happen.\n";
  pr "   */\n";
  pr "  return \"UNKNOWN!\";\n";
  pr "}\n";
  pr "\n";

  pr "const char *\n";
  pr "nbd_unlocked_connection_state (struct nbd_handle *h)\n";
  pr "{\n";
  pr "  switch (get_next_state (h))\n";
  pr "  {\n";
  List.iter (
    fun ({ comment; parsed = { display_name; state_enum } }) ->
      pr "  case %s:\n" state_enum;
      pr "    return \"%s\" \": \"\n" display_name;
      pr "           \"%s\";\n" comment;
      pr "\n";
  ) states;
  pr "  }\n";
  pr "\n";
  pr "  return NULL;\n";
  pr "}\n";
  pr "\n";

  pr "/* Map a state to its group name. */\n";
  pr "enum state_group\n";
  pr "nbd_internal_state_group (enum state state)\n";
  pr "{\n";
  pr "  switch (state) {\n";
  List.iter (
    fun ({ parsed = { prefix; state_enum } }) ->
      pr "  case %s:\n" state_enum;
      if prefix = [] then
        pr "    return GROUP_TOP;\n"
      else
        pr "    return GROUP%s;\n"
           (String.concat "" (List.map ((^) "_") prefix))
  ) states;
  pr "  default:\n";
  pr "    abort (); /* Should never happen, but keeps GCC happy. */\n";
  pr "  }\n";
  pr "}\n";
  pr "\n";

  pr "/* Map a state group to its parent group. */\n";
  pr "enum state_group\n";
  pr "nbd_internal_state_group_parent (enum state_group group)\n";
  pr "{\n";
  pr "  switch (group) {\n";
  pr "  case GROUP_TOP:\n";
  pr "    return GROUP_TOP;\n";
  let rec loop prefix = function
    | [] -> ()
    | State _ :: rest ->
       loop prefix rest
    | Group (name, group) :: rest ->
       let enum =
         "GROUP" ^ String.concat "" (List.map ((^) "_") prefix) ^ "_" ^ name in
       pr "  case %s:\n" enum;
       if prefix = [] then
         pr "    return GROUP_TOP;\n"
       else (
         let parent = "GROUP" ^ String.concat "" (List.map ((^) "_") prefix) in
         pr "    return %s;\n" parent
       );
       loop (prefix @ [name]) group;
       loop prefix rest
  in
  loop [] state_machine;
  pr "  default:\n";
  pr "    abort (); /* Should never happen, but keeps GCC happy. */\n";
  pr "  }\n";
  pr "};\n"
end

(*----------------------------------------------------------------------*)

(* Generate C API. *)

module C : sig
  val generate_lib_libnbd_syms : unit -> unit
  val generate_include_libnbd_h : unit -> unit
  val generate_lib_unlocked_h : unit -> unit
  val generate_lib_api_c : unit -> unit
  val generate_docs_libnbd_api_pod : unit -> unit
  val print_arg_list : ?handle:bool -> ?valid_flag:bool -> ?user_data:bool ->
                       ?types:bool -> arg list -> unit
end = struct

(* Check the API definition. *)
let () =
  (* Flags must only appear once in the final argument position. *)
  List.iter (
    fun (name, { args }) ->
      let args = List.rev args in
      match args with
      | [] -> ()
      | Flags _ :: xs
      | xs ->
         if List.exists (function Flags _ -> true | _ -> false) xs then
           failwithf "%s: Flags must appear in final argument position only"
                     name
  ) handle_calls;

  (* !may_set_error is incompatible with permitted_states != [] because
   * an incorrect state will result in set_error being called by the
   * generated wrapper.  It is also incompatible with RUint.
   *)
  List.iter (
    function
    | name, { permitted_states = (_::_); may_set_error = false } ->
       failwithf "%s: if may_set_error is false, permitted_states must be empty (any permitted state)"
                 name
    | name, { ret = RUInt; may_set_error = true } ->
       failwithf "%s: if ret is RUInt, may_set_error must be false" name
    | _ -> ()
  ) handle_calls

let generate_lib_libnbd_syms () =
  generate_header HashStyle;

  pr "{\n";
  pr "  global:\n";
  pr "    nbd_create;\n";
  pr "    nbd_close;\n";
  pr "    nbd_get_errno;\n";
  pr "    nbd_get_error;\n";
  List.iter (fun (name, _) -> pr "    nbd_%s;\n" name) handle_calls;
  pr "\n";
  pr "  # Everything else is hidden.\n";
  pr "  local: *;\n";
  pr "};\n"

let rec name_of_arg = function
| ArrayAndLen (arg, n) -> name_of_arg arg @ [n]
| Bool n -> [n]
| BytesIn (n, len) -> [n; len]
| BytesOut (n, len) -> [n; len]
| BytesPersistIn (n, len) -> [n; len]
| BytesPersistOut (n, len) -> [n; len]
| Closure { cbname } -> [cbname; sprintf "%s_user_data" cbname ]
| Flags n -> [n]
| Int n -> [n]
| Int64 n -> [n]
| Mutable arg -> name_of_arg arg
| Path n -> [n]
| SockAddrAndLen (n, len) -> [n; len]
| String n -> [n]
| StringList n -> [n]
| UInt n -> [n]
| UInt32 n -> [n]
| UInt64 n -> [n]

let rec print_arg_list ?(handle = false) ?(valid_flag = false)
                       ?(user_data = false)
                       ?(types = true) args =
  pr "(";
  let comma = ref false in
  if handle then (
    comma := true;
    if types then pr "struct nbd_handle *";
    pr "h"
  );
  if valid_flag then (
    if !comma then pr ", ";
    comma := true;
    if types then pr "unsigned ";
    pr "valid_flag";
  );
  if user_data then (
    if !comma then pr ", ";
    comma := true;
    if types then pr "void *";
    pr "user_data";
  );
  List.iter (
    fun arg ->
      if !comma then pr ", ";
      comma := true;
      match arg with
      | ArrayAndLen (UInt32 n, len) ->
         if types then pr "uint32_t *";
         pr "%s, " n;
         if types then pr "size_t ";
         pr "%s" len
      | ArrayAndLen _ -> assert false
      | Bool n ->
         if types then pr "bool ";
         pr "%s" n
      | BytesIn (n, len)
      | BytesPersistIn (n, len) ->
         if types then pr "const void *";
         pr "%s, " n;
         if types then pr "size_t ";
         pr "%s" len
      | BytesOut (n, len)
      | BytesPersistOut (n, len) ->
         if types then pr "void *";
         pr "%s, " n;
         if types then pr "size_t ";
         pr "%s" len
      | Closure { cbname; cbargs } ->
         if types then (
           pr "int (*%s) " cbname;
           print_arg_list ~valid_flag:true ~user_data:true cbargs;
         )
         else
           pr "%s" cbname;
         pr ", ";
         if types then pr "void *";
         pr "%s_user_data" cbname
      | Flags n ->
         if types then pr "uint32_t ";
         pr "%s" n
      | Int n ->
         if types then pr "int ";
         pr "%s" n
      | Int64 n ->
         if types then pr "int64_t ";
         pr "%s" n
      | Mutable (Int n) ->
         if types then pr "int *";
         pr "%s" n
      | Mutable arg -> assert false
      | Path n
      | String n ->
         if types then pr "const char *";
         pr "%s" n
      | StringList n ->
         if types then pr "char **";
         pr "%s" n
      | SockAddrAndLen (n, len) ->
         if types then pr "const struct sockaddr *";
         pr "%s, " n;
         if types then pr "socklen_t ";
         pr "%s" len
      | UInt n ->
         if types then pr "unsigned ";
         pr "%s" n
      | UInt32 n ->
         if types then pr "uint32_t ";
         pr "%s" n
      | UInt64 n ->
         if types then pr "uint64_t ";
         pr "%s" n
  ) args;
  pr ")"

let print_call name args ret =
  (match ret with
   | RBool
   | RErr
   | RFd
   | RInt -> pr "int "
   | RConstString -> pr "const char *"
   | RInt64 -> pr "int64_t "
   | RString -> pr "char *"
   | RUInt -> pr "unsigned "
  );
  pr "nbd_%s " name;
  print_arg_list ~handle:true args

let print_extern name args ret =
  pr "extern ";
  print_call name args ret;
  pr ";\n"

let print_extern_and_define name args ret =
  let name_upper = String.uppercase_ascii name in
  print_extern name args ret;
  pr "#define LIBNBD_HAVE_NBD_%s 1\n" name_upper;
  pr "\n"

let print_ns_ctxt ns ns_upper ctxt consts =
  let ctxt_upper = String.uppercase_ascii ctxt in
  pr "#define LIBNBD_CONTEXT_%s_%s \"%s:%s\"\n"
    ns_upper ctxt_upper ns ctxt;
  pr "\n";
  pr "/* \"%s:%s\" context related constants */\n" ns ctxt;
  List.iter (fun (n, i) -> pr "#define LIBNBD_%-30s %d\n" n i) consts

let print_ns ns ctxts =
  let ns_upper = String.uppercase_ascii ns in
  pr "/* \"%s\" namespace */\n" ns;
  pr "#define LIBNBD_NAMESPACE_%s \"%s:\"\n" ns_upper ns;
  pr "\n";
  pr "/* \"%s\" namespace contexts */\n" ns;
  List.iter (
    fun (ctxt, consts) -> print_ns_ctxt ns ns_upper ctxt consts
  ) ctxts;
  pr "\n"

let generate_include_libnbd_h () =
  generate_header CStyle;

  pr "#ifndef LIBNBD_H\n";
  pr "#define LIBNBD_H\n";
  pr "\n";
  pr "#include <stdbool.h>\n";
  pr "#include <stdint.h>\n";
  pr "#include <sys/socket.h>\n";
  pr "\n";
  pr "struct nbd_handle;\n";
  pr "\n";
  pr "typedef void (*nbd_close_callback) (void *user_data);\n";
  pr "\n";
  List.iter (fun (n, i) -> pr "#define LIBNBD_%-30s %d\n" n i) constants;
  pr "\n";
  pr "#define LIBNBD_CALLBACK_VALID 1\n";
  pr "#define LIBNBD_CALLBACK_FREE  2\n";
  pr "\n";
  pr "extern struct nbd_handle *nbd_create (void);\n";
  pr "#define LIBNBD_HAVE_NBD_CREATE 1\n";
  pr "\n";
  pr "extern void nbd_close (struct nbd_handle *h);\n";
  pr "#define LIBNBD_HAVE_NBD_CLOSE 1\n";
  pr "\n";
  pr "extern const char *nbd_get_error (void);\n";
  pr "#define LIBNBD_HAVE_NBD_GET_ERROR 1\n";
  pr "\n";
  pr "extern int nbd_get_errno (void);\n";
  pr "#define LIBNBD_HAVE_NBD_GET_ERRNO 1\n";
  pr "\n";
  List.iter (
    fun (name, { args; ret }) -> print_extern_and_define name args ret
  ) handle_calls;
  pr "\n";
  List.iter (
    fun (ns, ctxts) -> print_ns ns ctxts
  ) metadata_namespaces;
  pr "\n";
  pr "#endif /* LIBNBD_H */\n"

let generate_lib_unlocked_h () =
  generate_header CStyle;

  pr "#ifndef LIBNBD_UNLOCKED_H\n";
  pr "#define LIBNBD_UNLOCKED_H\n";
  pr "\n";
  List.iter (
    fun (name, { args; ret }) ->
      print_extern ("unlocked_" ^ name) args ret
  ) handle_calls;
  pr "\n";
  pr "#endif /* LIBNBD_UNLOCKED_H */\n"

let permitted_state_text permitted_states =
  assert (permitted_states <> []);
  String.concat
    ", or "
    (List.map (
         function
         | Created -> "newly created"
         | Connecting -> "connecting"
         | Connected -> "connected and finished handshaking with the server"
         | Closed -> "closed"
         | Dead -> "dead"
       ) permitted_states
    )

(* Generate wrappers around each API call which are a place to
 * grab the thread mutex (lock) and do logging.
 *)
let generate_lib_api_c () =
  let print_wrapper (name, {args; ret; permitted_states;
                            is_locked; may_set_error}) =
    if permitted_states <> [] then (
      pr "static inline bool\n";
      pr "%s_in_permitted_state (struct nbd_handle *h)\n" name;
      pr "{\n";
      pr "  const enum state state = get_public_state (h);\n";
      pr "\n";
      let tests =
        List.map (
          function
          | Created -> "nbd_internal_is_state_created (state)"
          | Connecting -> "nbd_internal_is_state_connecting (state)"
          | Connected -> "nbd_internal_is_state_ready (state) || nbd_internal_is_state_processing (state)"
          | Closed -> "nbd_internal_is_state_closed (state)"
          | Dead -> "nbd_internal_is_state_dead (state)"
        ) permitted_states in
      pr "  if (!(%s)) {\n" (String.concat " ||\n        " tests);
      pr "    set_error (nbd_internal_is_state_created (state) ? ENOTCONN : EINVAL,\n";
      pr "               \"invalid state: %%s: the handle must be %%s\",\n";
      pr "               nbd_internal_state_short_string (state),\n";
      pr "               \"%s\");\n" (permitted_state_text permitted_states);
      pr "    return false;\n";
      pr "  }\n";
      pr "  return true;\n";
      pr "}\n";
      pr "\n"
    );

    let ret_c_type, errcode =
      match ret with
      | RBool
      | RErr
      | RFd
      | RInt -> "int", Some "-1"
      | RConstString -> "const char *", Some "NULL"
      | RInt64 -> "int64_t", Some "-1"
      | RString -> "char *", Some "NULL"
      | RUInt -> "unsigned", None in

    pr "%s\n" ret_c_type;
    pr "nbd_%s " name;
    print_arg_list ~handle:true args;
    pr "\n";
    pr "{\n";
    (match ret with
     | RBool
     | RErr
     | RFd
     | RInt -> pr "  int ret;\n"
     | RConstString -> pr "  const char *ret;\n"
     | RInt64 -> pr "  int64_t ret;\n"
     | RString -> pr "  char *ret;\n"
     | RUInt -> pr "  unsigned ret;\n"
    );
    pr "\n";
    if may_set_error then (
      pr "  nbd_internal_reset_error (\"nbd_%s\");\n" name;
      pr "\n"
    );
    if is_locked then
      pr "  pthread_mutex_lock (&h->lock);\n";
    if permitted_states <> [] then (
      let value = match errcode with
        | Some value -> value
        | None -> assert false in
      pr "  if (!%s_in_permitted_state (h)) {\n" name;
      pr "    ret = %s;\n" value;
      pr "    goto out;\n";
      pr "  }\n"
    );
    pr "  ret = nbd_unlocked_%s " name;
    print_arg_list ~types:false ~handle:true args;
    pr ";\n";
    if permitted_states <> [] then
      pr " out:\n";
    if is_locked then (
      pr "  if (h->public_state != get_next_state (h))\n";
      pr "    h->public_state = get_next_state (h);\n";
      pr "  pthread_mutex_unlock (&h->lock);\n"
    );
    pr "  return ret;\n";
    pr "}\n";
    pr "\n";
  in

  generate_header CStyle;

  pr "#include <config.h>\n";
  pr "\n";
  pr "#include <stdio.h>\n";
  pr "#include <stdlib.h>\n";
  pr "#include <errno.h>\n";
  pr "\n";
  pr "#include <pthread.h>\n";
  pr "\n";
  pr "#include \"libnbd.h\"\n";
  pr "#include \"internal.h\"\n";
  pr "\n";
  List.iter print_wrapper handle_calls

let print_api (name, { args; ret; permitted_states; shortdesc; longdesc;
                       may_set_error }) =
  pr "=head2 %s —\n" name;
  pr "%s\n" shortdesc;
  pr "\n";
  pr " ";
  print_call name args ret; pr ";";
  pr "\n";
  pr "\n";
  pr "%s\n" longdesc;
  pr "\n";
  if permitted_states <> [] then (
    pr "The handle must be\n";
    pr "%s,\n" (permitted_state_text permitted_states);
    pr "otherwise this call will return an error.\n";
    pr "\n"
  );
  let errcode =
    match ret with
    | RBool ->
       pr "This call returns a boolean value.\n";
       Some "-1"
   | RConstString ->
       pr "This call returns a statically allocated string.\n";
       pr "You B<must not> try to free the string.\n";
       Some "NULL"
   | RErr ->
       pr "If the call is successful the function returns C<0>.\n";
       Some "-1"
   | RFd ->
       pr "This call returns a file descriptor.\n";
       Some "-1"
   | RInt ->
       pr "This call returns an integer E<ge> 0.\n";
       Some "-1"
   | RInt64 ->
       pr "This call returns a 64 bit signed integer E<ge> 0.\n";
       Some "-1"
   | RString ->
       pr "This call returns a string.  The caller must free the\n";
       pr "returned string to avoid a memory leak.\n";
       Some "NULL"
   | RUInt ->
       pr "This call returns a bitmask.\n";
       None
  in
  pr "\n";
  if may_set_error then (
    let value = match errcode with
      | Some value -> value
      | None -> assert false in
    pr "On error C<%s> is returned.\n" value;
    pr "See L<libnbd(3)/ERROR HANDLING> for how to get further details\n";
    pr "of the error.\n"
  )
  else
    pr "This function does not fail.\n";
  pr "\n"

let generate_docs_libnbd_api_pod () =
  pr "
=head1 NAME

libnbd-api - libnbd C API

=head1 SYNOPSIS

 #include <libnbd.h>
 
 struct nbd_handle *nbd;
 char buf[512];
 
 if ((nbd = nbd_create ()) == NULL ||
     nbd_connect_tcp (nbd, \"server.example.com\", \"nbd\") == -1 ||
     nbd_pread (nbd, buf, sizeof buf, 0, 0) == -1)
   fprintf (stderr, \"%%s\\n\", nbd_get_error ());
   exit (EXIT_FAILURE);
 }
 nbd_close (nbd);

 cc prog.c -o prog -lnbd
or:
 cc prog.c -o prog `pkg-config libnbd --cflags --libs`

=head1 DESCRIPTION

This manual page describes all of the libnbd API calls from C
in detail.  If you want an overview of using the API, or to see
how to call the API from other programming languages, start
with libnbd(3).

For the sake of conditional compilation across a range of libnbd
versions, where a client may take advantage of newer API when present
but gracefully continue to compile even when it is not, all functions
declared in B<E<lt>libnbd.hE<gt>> have a corresponding witness macro
with prefix C<LIBNBD_HAVE_>. For example, C<nbd_create> has a
counterpart macro C<LIBNBD_HAVE_NBD_CREATE> defined to C<1>.

=head1 CREATE, GET AND CLOSE HANDLES

 struct nbd_handle *nbd;

This opaque structure describes an NBD client handle and
connection to an NBD server.

 struct nbd_handle *nbd_create (void);

Create a new handle.  Returns a pointer to the opaque handle
structure.

On error this returns C<NULL>.  See L<libnbd(3)/ERROR HANDLING>
for how to get further details of the error.

 void nbd_close (struct nbd_handle *nbd);

Closes the handle and frees any associated resources.  The final
status of any command that has not been retired (whether by
C<nbd_aio_command_completed> or by a low-level completion callback
returning C<1>) is lost.  This function is not safe to call while
any other thread is still using any C<nbd_*> API on the same handle.

=head1 GETTING THE LATEST ERROR MESSAGE IN THE THREAD

See L<libnbd(3)/ERROR HANDLING> for more discussion of how
error handling works in libnbd.

 const char *nbd_get_error (void);

Return the most recent error message in the current thread.
The error message is only valid if called immediately after
the failing call, from the same thread.  The error string
returned will be freed up next time any libnbd API is called
from the same thread, so if you need to keep it you must make
a copy.

This should never return C<NULL> provided there was an error
returned from the immediately preceding libnbd call in the
current thread.

 int nbd_get_errno (void);

Return the most recent C<errno> in the current thread.  Not all
errors have corresponding errnos, so even if there has been an error
this may return C<0>.  Error codes are the standard ones from
C<E<lt>errno.hE<gt>>.

";

  pr "=head1 API CALLS\n";
  pr "\n";

  List.iter print_api handle_calls;

  pr "\
=head1 SEE ALSO

L<libnbd(3)>.

=head1 AUTHORS

Eric Blake

Richard W.M. Jones

=head1 COPYRIGHT

Copyright (C) 2019 Red Hat Inc.
"
end

(*----------------------------------------------------------------------*)

(* Python bindings. *)

module Python : sig
  val generate_python_methods_h : unit -> unit
  val generate_python_libnbdmod_c : unit -> unit
  val generate_python_methods_c : unit -> unit
  val generate_python_nbd_py : unit -> unit
end = struct

let generate_python_methods_h () =
  generate_header CStyle;

  pr "#ifndef LIBNBD_METHODS_H\n";
  pr "#define LIBNBD_METHODS_H\n";
  pr "\n";
  pr "#define PY_SSIZE_T_CLEAN 1\n";
  pr "#include <Python.h>\n";
  pr "\n";
  pr "#include <assert.h>\n";
  pr "\n";
  pr "\
struct py_aio_buffer {
  Py_ssize_t len;
  void *data;
};

extern char **nbd_internal_py_get_string_list (PyObject *);
extern void nbd_internal_py_free_string_list (char **);
extern struct py_aio_buffer *nbd_internal_py_get_aio_buffer (PyObject *);

static inline struct nbd_handle *
get_handle (PyObject *obj)
{
  assert (obj);
  assert (obj != Py_None);
  return (struct nbd_handle *) PyCapsule_GetPointer(obj, \"nbd_handle\");
}

/* nbd.Error exception. */
extern PyObject *nbd_internal_py_Error;

static inline void
raise_exception ()
{
  PyObject *args = Py_BuildValue (\"si\", nbd_get_error (), nbd_get_errno ());

  if (args != NULL)
    PyErr_SetObject (nbd_internal_py_Error, args);
}

";

  List.iter (
    fun name ->
      pr "extern PyObject *nbd_internal_py_%s (PyObject *self, PyObject *args);\n"
         name;
  ) ([ "create"; "close";
       "alloc_aio_buffer"; "aio_buffer_from_bytearray";
       "aio_buffer_to_bytearray" ] @ List.map fst handle_calls);

  pr "\n";
  pr "#endif /* LIBNBD_METHODS_H */\n"

let generate_python_libnbdmod_c () =
  generate_header CStyle;

  pr "#include <config.h>\n";
  pr "\n";
  pr "#define PY_SSIZE_T_CLEAN 1\n";
  pr "#include <Python.h>\n";
  pr "\n";
  pr "#include <stdio.h>\n";
  pr "#include <stdlib.h>\n";
  pr "#include <assert.h>\n";
  pr "\n";
  pr "#include <libnbd.h>\n";
  pr "\n";
  pr "#include \"methods.h\"\n";
  pr "\n";
  pr "static PyMethodDef methods[] = {\n";
  List.iter (
    fun name ->
      pr "  { (char *) \"%s\", nbd_internal_py_%s, METH_VARARGS, NULL },\n"
         name name;
  ) ([ "create"; "close";
       "alloc_aio_buffer"; "aio_buffer_from_bytearray";
       "aio_buffer_to_bytearray" ] @ List.map fst handle_calls);
  pr "  { NULL, NULL, 0, NULL }\n";
  pr "};\n";
  pr "\n";
  pr "\
static struct PyModuleDef moduledef = {
  PyModuleDef_HEAD_INIT,
  \"libnbdmod\",           /* m_name */
  \"libnbd module\",       /* m_doc */
  -1,                    /* m_size */
  methods,               /* m_methods */
  NULL,                  /* m_reload */
  NULL,                  /* m_traverse */
  NULL,                  /* m_clear */
  NULL,                  /* m_free */
};

/* nbd.Error exception. */
PyObject *nbd_internal_py_Error;

extern PyMODINIT_FUNC PyInit_libnbdmod (void);

PyMODINIT_FUNC
PyInit_libnbdmod (void)
{
  PyObject *mod;

  mod = PyModule_Create (&moduledef);
  if (mod == NULL)
    return NULL;

  nbd_internal_py_Error = PyErr_NewException (\"nbd.Error\", NULL, NULL);
  if (nbd_internal_py_Error == NULL)
    return NULL;
  PyModule_AddObject (mod, \"Error\", nbd_internal_py_Error);

  return mod;
}
"

let print_python_binding name { args; ret; may_set_error } =
  (* Functions with a Closure parameter are special because we
   * have to generate wrapper functions which translate the
   * callbacks back to Python.
   *)
  List.iter (
    function
    | Closure { cbname; cbargs } ->
       pr "/* Wrapper for %s callback of %s. */\n" cbname name;
       pr "static int\n";
       pr "%s_%s_wrapper " name cbname;
       C.print_arg_list ~valid_flag:true ~user_data:true cbargs;
       pr "\n";
       pr "{\n";
       pr "  int ret = 0;\n";
       pr "\n";
       pr "  if (valid_flag & LIBNBD_CALLBACK_VALID) {\n";
       pr "    PyGILState_STATE py_save = PyGILState_UNLOCKED;\n";
       pr "    PyObject *py_args, *py_ret;\n";
       List.iter (
         function
         | ArrayAndLen (UInt32 n, len) ->
            pr "    PyObject *py_%s = PyList_New (%s);\n" n len;
            pr "    for (size_t i = 0; i < %s; ++i)\n" len;
            pr "      PyList_SET_ITEM (py_%s, i, PyLong_FromUnsignedLong (%s[i]));\n" n n
         | BytesIn _
         | Int _
         | Int64 _ -> ()
         | Mutable (Int n) ->
            pr "    PyObject *py_%s_modname = PyUnicode_FromString (\"ctypes\");\n" n;
            pr "    if (!py_%s_modname) { PyErr_PrintEx (0); return -1; }\n" n;
            pr "    PyObject *py_%s_mod = PyImport_Import (py_%s_modname);\n" n n;
            pr "    Py_DECREF (py_%s_modname);\n" n;
            pr "    if (!py_%s_mod) { PyErr_PrintEx (0); return -1; }\n" n;
            pr "    PyObject *py_%s = PyObject_CallMethod (py_%s_mod, \"c_int\", \"i\", *%s);\n" n n n;
            pr "    if (!py_%s) { PyErr_PrintEx (0); return -1; }\n" n;
         | String _
         | UInt _
         | UInt64 _ -> ()
         (* The following not yet implemented for callbacks XXX *)
         | ArrayAndLen _ | Bool _ | BytesOut _
         | BytesPersistIn _ | BytesPersistOut _
         | Closure _
         | Flags _ | Mutable _
         | Path _ | SockAddrAndLen _ | StringList _
         | UInt32 _ -> assert false
       ) cbargs;
       pr "\n";

       pr "    py_args = Py_BuildValue (\"(\"";
       List.iter (
         function
         | ArrayAndLen (UInt32 n, len) -> pr " \"O\""
         | BytesIn (n, len) -> pr " \"y#\""
         | Int n -> pr " \"i\""
         | Int64 n -> pr " \"L\""
         | Mutable (Int n) -> pr " \"O\""
         | String n -> pr " \"s\""
         | UInt n -> pr " \"I\""
         | UInt64 n -> pr " \"K\""
         (* The following not yet implemented for callbacks XXX *)
         | ArrayAndLen _ | Bool _ | BytesOut _
         | BytesPersistIn _ | BytesPersistOut _
         | Closure _
         | Flags _ | Mutable _
         | Path _ | SockAddrAndLen _ | StringList _
         | UInt32 _ -> assert false
       ) cbargs;
       pr " \")\"";
       List.iter (
         function
         | ArrayAndLen (UInt32 n, _) -> pr ", py_%s" n
         | BytesIn (n, len) -> pr ", %s, (int) %s" n len
         | Mutable (Int n) -> pr ", py_%s" n
         | Int n | Int64 n
         | String n
         | UInt n | UInt64 n -> pr ", %s" n
         (* The following not yet implemented for callbacks XXX *)
         | ArrayAndLen _ | Bool _ | BytesOut _
         | BytesPersistIn _ | BytesPersistOut _
         | Closure _
         | Flags _ | Mutable _
         | Path _ | SockAddrAndLen _ | StringList _
         | UInt32 _ -> assert false
       ) cbargs;
       pr ");\n";
       pr "    Py_INCREF (py_args);\n";
       pr "\n";
       pr "    if (PyEval_ThreadsInitialized ())\n";
       pr "      py_save = PyGILState_Ensure ();\n";
       pr "\n";
       pr "    py_ret = PyObject_CallObject ((PyObject *)user_data, py_args);\n";
       pr "\n";
       pr "    if (PyEval_ThreadsInitialized ())\n";
       pr "      PyGILState_Release (py_save);\n";
       pr "\n";
       pr "    Py_DECREF (py_args);\n";
       pr "\n";
       pr "    if (py_ret != NULL) {\n";
       pr "      Py_DECREF (py_ret); /* return value is discarded */\n";
       pr "    }\n";
       pr "    else {\n";
       pr "      ret = -1;\n";
       pr "      PyErr_PrintEx (0); /* print exception */\n";
       pr "    };\n";
       pr "\n";
       List.iter (
         function
         | ArrayAndLen (UInt32 n, _) ->
            pr "    Py_DECREF (py_%s);\n" n
         | Mutable (Int n) ->
            pr "    PyObject *py_%s_ret = PyObject_GetAttrString (py_%s, \"value\");\n" n n;
            pr "    *%s = PyLong_AsLong (py_%s_ret);\n" n n;
            pr "    Py_DECREF (py_%s_ret);\n" n;
            pr "    Py_DECREF (py_%s);\n" n
         | BytesIn _
         | Int _ | Int64 _
         | String _
         | UInt _ | UInt64 _ -> ()
         (* The following not yet implemented for callbacks XXX *)
         | ArrayAndLen _ | Bool _ | BytesOut _
         | BytesPersistIn _ | BytesPersistOut _
         | Closure _
         | Flags _ | Mutable _
         | Path _ | SockAddrAndLen _ | StringList _
         | UInt32 _ -> assert false
       ) cbargs;
       pr "  }\n";
       pr "\n";
       pr "  if (valid_flag & LIBNBD_CALLBACK_FREE)\n";
       pr "    Py_DECREF ((PyObject *)user_data);\n";
       pr "\n";
       pr "  return ret;\n";
       pr "}\n";
       pr "\n"
    | _ -> ()
  ) args;

  (* Generate the Python binding. *)
  pr "PyObject *\n";
  pr "nbd_internal_py_%s (PyObject *self, PyObject *args)\n" name;
  pr "{\n";
  pr "  PyObject *py_h;\n";
  pr "  struct nbd_handle *h;\n";
  (match ret with
   | RBool
   | RErr
   | RFd
   | RInt -> pr "  int ret;\n"
   | RConstString -> pr "  const char *ret;\n"
   | RInt64 -> pr "  int64_t ret;\n"
   | RString -> pr "  char *ret;\n";
   | RUInt -> pr "  unsigned ret;\n"
  );
  pr "  PyObject *py_ret;\n";
  List.iter (
    function
    | ArrayAndLen (UInt32 n, len) ->
       pr "  PyObject *py_%s;\n" n;
       pr "  uint32_t *%s;\n" n;
       pr "  size_t %s;\n" len;
    | ArrayAndLen _ -> assert false
    | Bool n -> pr "  int %s;\n" n
    | BytesIn (n, _) ->
       pr "  Py_buffer %s;\n" n
    | BytesOut (n, count) ->
       pr "  char *%s;\n" n;
       pr "  Py_ssize_t %s;\n" count
    | BytesPersistIn (n, _)
    | BytesPersistOut (n, _) ->
       pr "  PyObject *%s; /* PyCapsule pointing to struct py_aio_buffer */\n"
          n;
       pr "  struct py_aio_buffer *%s_buf;\n" n
    | Closure { cbname } ->
       pr "  PyObject *%s_user_data;\n" cbname
    | Flags n ->
       pr "  uint32_t %s_u32;\n" n;
       pr "  unsigned int %s; /* really uint32_t */\n" n
    | Int n -> pr "  int %s;\n" n
    | Int64 n ->
       pr "  int64_t %s_i64;\n" n;
       pr "  long long %s; /* really int64_t */\n" n
    | Mutable arg -> assert false
    | Path n ->
       pr "  PyObject *py_%s = NULL;\n" n;
       pr "  char *%s = NULL;\n" n
    | SockAddrAndLen (n, _) ->
       pr "  /* XXX Complicated - Python uses a tuple of different\n";
       pr "   * lengths for the different socket types.\n";
       pr "   */\n";
       pr "  PyObject *%s;\n" n
    | String n -> pr "  const char *%s;\n" n
    | StringList n ->
       pr "  PyObject *py_%s;\n" n;
       pr "  char **%s = NULL;\n" n
    | UInt n -> pr "  unsigned int %s;\n" n
    | UInt32 n ->
       pr "  uint32_t %s_u32;\n" n;
       pr "  unsigned int %s; /* really uint32_t */\n" n
    | UInt64 n ->
       pr "  uint64_t %s_u64;\n" n;
       pr "  unsigned long long %s; /* really uint64_t */\n" n
  ) args;
  pr "\n";

  (* Parse the Python parameters. *)
  pr "  if (!PyArg_ParseTuple (args, (char *) \"O\"";
  List.iter (
    function
    | ArrayAndLen _ -> pr " \"O\""
    | Bool n -> pr " \"b\""
    | BytesIn (n, _) -> pr " \"y*\""
    | BytesPersistIn (n, _) -> pr " \"O\""
    | BytesOut (_, count) -> pr " \"n\""
    | BytesPersistOut (_, count) -> pr " \"O\""
    | Closure _ -> pr " \"O\""
    | Flags n -> pr " \"I\""
    | Int n -> pr " \"i\""
    | Int64 n -> pr " \"L\""
    | Mutable _ -> pr " \"O\""
    | Path n -> pr " \"O&\""
    | SockAddrAndLen (n, _) -> pr " \"O\""
    | String n -> pr " \"s\""
    | StringList n -> pr " \"O\""
    | UInt n -> pr " \"I\""
    | UInt32 n -> pr " \"I\""
    | UInt64 n -> pr " \"K\""
  ) args;
  pr "\n";
  pr "                         \":nbd_%s\",\n" name;
  pr "                         &py_h";
  List.iter (
    function
    | ArrayAndLen (UInt32 n, _) -> pr ", &py_%s" n
    | ArrayAndLen _ -> assert false
    | Bool n -> pr ", &%s" n
    | BytesIn (n, _) | BytesPersistIn (n, _)
    | BytesPersistOut (n, _) -> pr ", &%s" n
    | BytesOut (_, count) -> pr ", &%s" count
    | Closure { cbname } -> pr ", &%s_user_data" cbname
    | Flags n -> pr ", &%s" n
    | Int n -> pr ", &%s" n
    | Int64 n -> pr ", &%s" n
    | Mutable arg -> assert false
    | Path n -> pr ", PyUnicode_FSConverter, &py_%s" n
    | SockAddrAndLen (n, _) -> pr ", &%s" n
    | String n -> pr ", &%s" n
    | StringList n -> pr ", &py_%s" n
    | UInt n -> pr ", &%s" n
    | UInt32 n -> pr ", &%s" n
    | UInt64 n -> pr ", &%s" n
  ) args;
  pr "))\n";
  pr "    return NULL;\n";

  pr "  h = get_handle (py_h);\n";
  List.iter (
    function
    | ArrayAndLen (UInt32 n, len) ->
       pr "  if (!PyList_Check (py_%s)) {\n" n;
       pr "    PyErr_SetString (PyExc_TypeError, \"expecting a list\");\n";
       pr "    return NULL;\n";
       pr "  }\n";
       pr "  %s = PyList_Size (py_%s);\n" len n;
       pr "  if (%s == -1) {\n" len;
       pr "    PyErr_SetString (PyExc_RuntimeError, \"PyList_Size failed\");\n";
       pr "    return NULL;\n";
       pr "  }\n";
       pr "  %s = malloc (sizeof (uint32_t) * %s);\n" n len;
       pr "  if (%s == NULL) {\n" n;
       pr "    PyErr_NoMemory ();\n";
       pr "    return NULL;\n";
       pr "  }\n";
       pr "  for (size_t _i = 0; _i < %s; ++_i)\n" len;
       pr "    %s[_i] = PyLong_AsUnsignedLong (PyList_GetItem (%s, _i));\n" n n
    | ArrayAndLen _ -> assert false
    | Bool _ -> ()
    | BytesIn _ -> ()
    | BytesOut (n, count) ->
       pr "  %s = malloc (%s);\n" n count
    | BytesPersistIn (n, _) | BytesPersistOut (n, _) ->
       pr "  %s_buf = nbd_internal_py_get_aio_buffer (%s);\n" n n
    | Closure { cbname } ->
       pr "  /* Increment refcount since pointer may be saved by libnbd. */\n";
       pr "  Py_INCREF (%s_user_data);\n" cbname;
       pr "  if (!PyCallable_Check (%s_user_data)) {\n" cbname;
           pr "    PyErr_SetString (PyExc_TypeError,\n";
           pr "                     \"callback parameter %s is not callable\");\n" cbname;
           pr "    return NULL;\n";
           pr "  }\n"
    | Flags n -> pr "  %s_u32 = %s;\n" n n
    | Int _ -> ()
    | Int64 n -> pr "  %s_i64 = %s;\n" n n
    | Mutable _ ->
       pr "  abort (); /* Mutable for normal Python parameters not impl */\n"
    | Path n ->
       pr "  %s = PyBytes_AS_STRING (py_%s);\n" n n;
       pr "  assert (%s != NULL);\n" n
    | SockAddrAndLen _ ->
       pr "  abort (); /* XXX SockAddrAndLen not implemented */\n";
    | String _ -> ()
    | StringList n ->
       pr "  %s = nbd_internal_py_get_string_list (py_%s);\n" n n;
       pr "  if (!%s) { py_ret = NULL; goto out; }\n" n
    | UInt _ -> ()
    | UInt32 n -> pr "  %s_u32 = %s;\n" n n
    | UInt64 n -> pr "  %s_u64 = %s;\n" n n
  ) args;

  (* Call the underlying C function. *)
  pr "  ret = nbd_%s (h" name;
  List.iter (
    function
    | ArrayAndLen (UInt32 n, len) -> pr ", %s, %s" n len
    | ArrayAndLen _ -> assert false
    | Bool n -> pr ", %s" n
    | BytesIn (n, _) -> pr ", %s.buf, %s.len" n n
    | BytesOut (n, count) -> pr ", %s, %s" n count
    | BytesPersistIn (n, _)
    | BytesPersistOut (n, _) -> pr ", %s_buf->data, %s_buf->len" n n
    | Closure { cbname } ->
       pr ", %s_%s_wrapper" name cbname;
       pr ", %s_user_data" cbname
    | Flags n -> pr ", %s_u32" n
    | Int n -> pr ", %s" n
    | Int64 n -> pr ", %s_i64" n
    | Mutable arg -> assert false
    | Path n -> pr ", %s" n
    | SockAddrAndLen (n, _) -> pr ", /* XXX */ (void *) %s, 0" n
    | String n -> pr ", %s" n
    | StringList n -> pr ", %s" n
    | UInt n -> pr ", %s" n
    | UInt32 n -> pr ", %s_u32" n
    | UInt64 n -> pr ", %s_u64" n
  ) args;
  pr ");\n";
  if may_set_error then (
    (match ret with
     | RBool | RErr | RFd | RInt | RInt64 -> pr "  if (ret == -1) {\n";
     | RConstString | RString -> pr "  if (ret == NULL) {\n";
     | RUInt -> assert false
    );
    pr "    raise_exception ();\n";
    pr "    py_ret = NULL;\n";
    pr "    goto out;\n";
    pr "  }\n"
  );

  (* Convert the result back to a Python object and return it. *)
  let use_ret = ref true in
  List.iter (
    function
    | BytesOut (n, count) ->
       pr "  py_ret = PyBytes_FromStringAndSize (%s, %s);\n" n count;
       use_ret := false
    | ArrayAndLen _
    | Bool _
    | BytesIn _
    | BytesPersistIn _ | BytesPersistOut _
    | Closure _
    | Flags _
    | Int _
    | Int64 _
    | Mutable _
    | Path _
    | SockAddrAndLen _
    | String _
    | StringList _
    | UInt _
    | UInt32 _
    | UInt64 _ -> ()
  ) args;
  if !use_ret then (
    match ret with
    | RBool ->
       pr "  py_ret = ret ? Py_True : Py_False;\n";
       pr "  Py_INCREF (py_ret);\n"
    | RConstString ->
       pr "  py_ret = PyUnicode_FromString (ret);\n"
    | RErr ->
       pr "  py_ret = Py_None;\n";
       pr "  Py_INCREF (py_ret);\n"
    | RFd
    | RInt
    | RUInt ->
       pr "  py_ret = PyLong_FromLong (ret);\n"
    | RInt64 ->
       pr "  py_ret = PyLong_FromLongLong (ret);\n"
    | RString ->
       pr "  py_ret = PyUnicode_FromString (ret);\n";
       pr "  free (ret);\n"
  );

  pr "\n";
  if may_set_error then
    pr " out:\n";
  List.iter (
    function
    | ArrayAndLen (UInt32 n, len) -> pr "  free (%s);\n" n
    | ArrayAndLen _ -> assert false
    | Bool _ -> ()
    | BytesIn (n, _) -> pr "  PyBuffer_Release (&%s);\n" n
    | BytesPersistIn _ | BytesOut _ | BytesPersistOut _ -> ()
    | Closure _ -> ()
    | Flags _ -> ()
    | Int _ -> ()
    | Int64 _ -> ()
    | Mutable _ -> ()
    | Path n ->
       pr "  Py_XDECREF (py_%s);\n" n
    | SockAddrAndLen _ -> ()
    | String n -> ()
    | StringList n -> pr "  nbd_internal_py_free_string_list (%s);\n" n
    | UInt _ -> ()
    | UInt32 _ -> ()
    | UInt64 _ -> ()
  ) args;
  pr "  return py_ret;\n";
  pr "}\n";
  pr "\n"

let generate_python_methods_c () =
  generate_header CStyle;

  pr "#define PY_SSIZE_T_CLEAN 1\n";
  pr "#include <Python.h>\n";
  pr "\n";
  pr "#include <stdio.h>\n";
  pr "#include <stdlib.h>\n";
  pr "#include <stdint.h>\n";
  pr "#include <stdbool.h>\n";
  pr "\n";
  pr "#include <libnbd.h>\n";
  pr "\n";
  pr "#include <methods.h>\n";
  pr "\n";
  List.iter (
    fun (name, fn) ->
      print_python_binding name fn
  ) handle_calls

let py_fn_rex = Str.regexp "C<nbd_"
let py_const_rex = Str.regexp "C<LIBNBD_"

let generate_python_nbd_py () =
  generate_header HashStyle;

  pr "\
'''
Python bindings for libnbd

import nbd
h = nbd.NBD ()
h.connect_tcp (\"localhost\", \"nbd\")
buf = h.pread (512, 0)

Read the libnbd(3) man page to find out how to use the API.
'''

import libnbdmod

# Re-export Error exception as nbd.Error, adding some methods.
from libnbdmod import Error

Error.__doc__ = '''
Exception thrown when the underlying libnbd call fails.

This exception has three properties to query the error.  Use
the .string property to return a printable string containing
the error message.  Use the .errnum property for the associated
numeric error value (which may be 0 if the error did not
correspond to a system call failure), or the .errno property to
return a string containing the Python errno name if one is known
(which may be None if the numeric value does not correspond to
a known errno name).
'''

Error.string = property (lambda self: self.args[0])

def _errno (self):
    import errno
    try:
        return errno.errorcode[self.args[1]]
    except KeyError:
        return None
Error.errno = property (_errno)

Error.errnum = property (lambda self: self.args[1])

def _str (self):
    if self.errno:
        return (\"%%s (%%s)\" %% (self.string, self.errno))
    else:
        return (\"%%s\" %% self.string)
Error.__str__ = _str

";

  List.iter (fun (n, i) -> pr "%-30s = %d\n" n i) constants;
  List.iter (
    fun (ns, ctxts) ->
      let ns_upper = String.uppercase_ascii ns in
      pr "NAMESPACE_%-20s = \"%s:\"\n" ns_upper ns;
      List.iter (
        fun (ctxt, consts) ->
          let ctxt_upper = String.uppercase_ascii ctxt in
          pr "%-30s = \"%s:%s\"\n"
             (sprintf "CONTEXT_%s_%s" ns_upper ctxt_upper) ns ctxt;
          List.iter (fun (n, i) -> pr "%-30s = %d\n" n i) consts
      ) ctxts;
  ) metadata_namespaces;

  pr "\

# AIO buffer functions.
def aio_buffer (len):
    '''allocate an AIO buffer used for nbd.aio_pread and nbd.aio_pwrite'''
    return libnbdmod.alloc_aio_buffer (len)

def aio_buffer_from_bytearray (ba):
    '''create an AIO buffer from a bytearray'''
    return libnbdmod.aio_buffer_from_bytearray (ba)
def aio_buffer_to_bytearray (buf):
    '''copy an AIO buffer into a bytearray'''
    return libnbdmod.aio_buffer_to_bytearray (buf)

class NBD (object):
    '''NBD handle'''

    def __init__ (self):
        '''create a new NBD handle'''
        self._o = libnbdmod.create ()

    def __del__ (self):
        '''close the NBD handle and underlying connection'''
        libnbdmod.close (self._o)

";

  List.iter (
    fun (name, { args; shortdesc; longdesc }) ->
      let args =
        List.map (
            function
            | ArrayAndLen (UInt32 n, _) -> [n, None]
            | ArrayAndLen _ -> assert false
            | Bool n -> [n, None]
            | BytesIn (n, _) | BytesPersistIn (n, _) -> [n, None]
            | BytesPersistOut (n, _) -> [n, None]
            | BytesOut (_, count) -> [count, None]
            | Closure { cbname } -> [cbname, None]
            | Flags n -> [n, Some "0"]
            | Int n -> [n, None]
            | Int64 n -> [n, None]
            | Mutable arg -> assert false
            | Path n -> [n, None]
            | SockAddrAndLen (n, _) -> [n, None]
            | String n -> [n, None]
            | StringList n -> [n, None]
            | UInt n -> [n, None]
            | UInt32 n -> [n, None]
            | UInt64 n -> [n, None]
        ) args in
      let args = List.flatten args in
      let () =
        let args = List.map (
          function
          | n, None -> sprintf ", %s" n
          | n, Some def -> sprintf ", %s=%s" n def
        ) args in
        let args = String.concat "" args in
        pr "    def %s (self%s):\n" name args in
      let () =
        let longdesc = Str.global_replace py_fn_rex "C<nbd." longdesc in
        let longdesc = Str.global_replace py_const_rex "C<" longdesc in
        let longdesc = pod2text longdesc in
        pr "        '''▶ %s\n\n%s'''\n"
           shortdesc (String.concat "\n" longdesc) in
      let () =
        let args = List.map fst args in
        let args = List.map ((^) ", ") args in
        let args = String.concat "" args in
        pr "        return libnbdmod.%s (self._o%s)\n" name args in
      pr "\n"
  ) handle_calls;

  (* For nbdsh. *)
  pr "\
package_name = NBD().get_package_name()
__version__ = NBD().get_version()

if __name__ == \"__main__\":
    import nbdsh

    nbdsh.shell()
"
end

(*----------------------------------------------------------------------*)

(* OCaml bindings. *)

module OCaml : sig
  val generate_ocaml_nbd_mli : unit -> unit
  val generate_ocaml_nbd_ml : unit -> unit
  val generate_ocaml_nbd_c : unit -> unit
end = struct

(* We convert the list of generic args to an OCaml-specific list
 * because the mapping between them is complicated.
 *)
type ocaml_arg =
  | OCamlHandle                 (* The NBD handle (NBD.t) *)
  | OCamlFlags of string        (* Optional ?flags parameter *)
  | OCamlArg of arg             (* Other arg (string = name). *)

let args_to_ocaml_args args =
  (* Flags argument, if present, is always placed first. *)
  let flags, args =
    match List.rev args with
    | Flags n :: rest -> Some (OCamlFlags n), List.rev rest
    | _ -> None, args in
  let args =
    List.map (fun a -> [OCamlArg a]) args in
  let args = List.flatten args in
  match flags with
  | Some f -> f :: OCamlHandle :: args
  | None -> OCamlHandle :: args

(* String representation of args and return value. *)
let rec ocaml_fundecl_to_string args ret =
  let args = List.map ocaml_arg_to_string args in
  let ret = ocaml_ret_to_string ret in
  String.concat " -> " (args @ [ret])

(* String representation of a single OCaml arg. *)
and ocaml_arg_to_string = function
  | OCamlHandle -> "t"
  | OCamlFlags n -> sprintf "?%s:int32 list" n
  | OCamlArg (ArrayAndLen (t, _)) ->
     sprintf "%s array" (ocaml_arg_to_string (OCamlArg t))
  | OCamlArg (Bool _) -> "bool"
  | OCamlArg (BytesIn _) -> "bytes"
  | OCamlArg (BytesPersistIn _) -> "Buffer.t"
  | OCamlArg (BytesOut _) -> "bytes"
  | OCamlArg (BytesPersistOut _) -> "Buffer.t"
  | OCamlArg (Closure { cbargs }) ->
     sprintf "(%s)"
             (ocaml_fundecl_to_string (List.map (fun a -> OCamlArg a) cbargs)
                                      RErr)
  | OCamlArg (Flags _) -> assert false (* see above *)
  | OCamlArg (Int _) -> "int"
  | OCamlArg (Int64 _) -> "int64"
  | OCamlArg (Mutable arg) -> ocaml_arg_to_string (OCamlArg arg) ^ " ref"
  | OCamlArg (Path _) -> "string"
  | OCamlArg (SockAddrAndLen _) -> "string" (* XXX not impl *)
  | OCamlArg (String _) -> "string"
  | OCamlArg (StringList _) -> "string list"
  | OCamlArg (UInt _) -> "int"
  | OCamlArg (UInt32 _) -> "int32"
  | OCamlArg (UInt64 _) -> "int64"

and ocaml_ret_to_string = function
  | RBool -> "bool"
  | RConstString -> "string"
  | RErr -> "unit"
  | RFd -> "Unix.file_descr"
  | RInt -> "int"
  | RInt64 -> "int64"
  | RString -> "string"
  | RUInt -> "int"

let rec name_of_ocaml_arg = function
  | OCamlHandle -> "h"
  | OCamlFlags n -> n
  | OCamlArg a ->
     match a with
     | ArrayAndLen (arg, n) -> name_of_ocaml_arg (OCamlArg arg)
     | Bool n -> n
     | BytesIn (n, len) -> n
     | BytesOut (n, len) -> n
     | BytesPersistIn (n, len) -> n
     | BytesPersistOut (n, len) -> n
     | Closure { cbname } -> cbname
     | Flags n -> n
     | Int n -> n
     | Int64 n -> n
     | Mutable arg -> name_of_ocaml_arg (OCamlArg arg)
     | Path n -> n
     | SockAddrAndLen (n, len) -> n
     | String n -> n
     | StringList n -> n
     | UInt n -> n
     | UInt32 n -> n
     | UInt64 n -> n

let generate_ocaml_nbd_mli () =
  generate_header OCamlStyle;

  pr "\
(** OCaml bindings for libnbd.

    These bindings work like the C API, so the primary documentation
    for them is libnbd(3) and libnbd-api(3).

    For examples written in OCaml see the libnbd source code
    [ocaml/examples] subdirectory.
*)

exception Error of string * int
(** Exception thrown when an API call fails.

    The string is the error message, and the int is the raw errno
    (if available).
*)

exception Closed of string
(** Exception thrown if you call a closed handle. *)

";

  List.iter (
    fun (n, _) -> pr "val %s : int32\n" (String.lowercase_ascii n)
  ) constants;
  List.iter (
    fun (ns, ctxts) ->
      pr "val namespace_%s : string\n" ns;
      List.iter (
        fun (ctxt, consts) ->
          pr "val context_%s_%s : string\n" ns ctxt;
          List.iter (fun (n, _) ->
              pr "val %s : int32\n" (String.lowercase_ascii n)
          ) consts
      ) ctxts;
  ) metadata_namespaces;
  pr "\n";

  pr "\
module Buffer : sig
  type t
  (** Persistent, mutable C-compatible malloc'd buffer, used in AIO calls. *)

  val to_bytes : t -> bytes
  (** Copy buffer to an OCaml [bytes] object. *)

  val of_bytes : bytes -> t
  (** Copy an OCaml [bytes] object to a newly allocated buffer. *)
end
(** Persistent buffer used in AIO calls. *)

type t
(** The handle. *)

val create : unit -> t
(** Create a new handle. *)

val close : t -> unit
(** Close a handle.

    Handles can also be closed by the garbage collector when
    they become unreachable.  This call is used only if you want
    to force the handle to close now and reclaim resources
    immediately.
*)

";

  List.iter (
    fun (name, { args; ret; shortdesc; longdesc }) ->
      pr "val %s : %s\n" name
         (ocaml_fundecl_to_string (args_to_ocaml_args args) ret);

      pr "(** %s\n" shortdesc;
      pr "\n";
      pr "%s" (String.concat "\n" (pod2text longdesc));
      pr "*)\n";
      pr "\n";

  ) handle_calls

let generate_ocaml_nbd_ml () =
  generate_header OCamlStyle;

  pr "\
exception Error of string * int
exception Closed of string

(* Give the exceptions names so that can be raised from the C code. *)
let () =
  Callback.register_exception \"nbd_internal_ocaml_error\" (Error (\"\", 0));
  Callback.register_exception \"nbd_internal_ocaml_closed\" (Closed \"\")

";

  List.iter (
    fun (n, i) -> pr "let %s = %d_l\n" (String.lowercase_ascii n) i
  ) constants;
  List.iter (
    fun (ns, ctxts) ->
      pr "let namespace_%s = \"%s:\"\n" ns ns;
      List.iter (
        fun (ctxt, consts) ->
          pr "let context_%s_%s = \"%s:%s\"\n" ns ctxt ns ctxt;
          List.iter (fun (n, i) ->
              pr "let %s = %d_l\n" (String.lowercase_ascii n) i
          ) consts
      ) ctxts;
  ) metadata_namespaces;
  pr "\n";

  pr "\
module Buffer = struct
  type t
  external to_bytes : t -> bytes = \"nbd_internal_ocaml_buffer_to_bytes\"
  external of_bytes : bytes -> t = \"nbd_internal_ocaml_buffer_of_bytes\"
end

type t

external create : unit -> t = \"nbd_internal_ocaml_nbd_create\"
external close : t -> unit = \"nbd_internal_ocaml_nbd_close\"

";

  List.iter (
    fun (name, { args; ret }) ->
      let oargs = args_to_ocaml_args args in
      pr "external %s : %s\n" name (ocaml_fundecl_to_string oargs ret);
      pr "    = ";
      (* In OCaml, argument lists longer than 5 elements require
       * special handling in the C bindings.
       *)
      if List.length oargs > 5 then
        pr "\"nbd_internal_ocaml_nbd_%s_byte\" " name;
      pr "\"nbd_internal_ocaml_nbd_%s\"\n" name
  ) handle_calls

let print_ocaml_binding (name, { args; ret }) =
  (* Functions with a callback parameter require special handling. *)
  List.iter (
    function
    | Closure { cbname; cbargs } ->
       let argnames =
         List.map (
           function
           | ArrayAndLen (UInt32 n, _) | BytesIn (n, _)
           | Int n | Int64 n
           | Mutable (Int n) | String n | UInt n | UInt64 n ->
              n ^ "v"
           (* The following not yet implemented for callbacks XXX *)
           | ArrayAndLen _ | Bool _ | BytesOut _
           | BytesPersistIn _ | BytesPersistOut _
           | Closure _
           | Flags _ | Path _ | Mutable _
           | SockAddrAndLen _ | StringList _
           | UInt32 _ -> assert false
         ) cbargs in

       pr "/* Wrapper for %s callback of %s. */\n" cbname name;
       pr "static int\n";
       pr "%s_%s_wrapper_locked " name cbname;
       C.print_arg_list ~user_data:true cbargs;
       pr "\n";
       pr "{\n";
       pr "  CAMLparam0 ();\n";
       assert (List.length argnames <= 5);
       pr "  CAMLlocal%d (%s);\n" (List.length argnames)
          (String.concat ", " argnames);
       pr "  CAMLlocal2 (fnv, rv);\n";
       pr "  value args[%d];\n" (List.length argnames);
       pr "\n";

       List.iter (
         function
         | ArrayAndLen (UInt32 n, count) ->
            pr "  %sv = nbd_internal_ocaml_alloc_int32_array (%s, %s);\n"
               n n count;
         | BytesIn (n, len) ->
            pr "  %sv = caml_alloc_string (%s);\n" n len;
            pr "  memcpy (String_val (%sv), %s, %s);\n" n n len
         | Int n | UInt n ->
            pr "  %sv = Val_int (%s);\n" n n
         | Int64 n ->
            pr "  %sv = caml_copy_int64 (%s);\n" n n
         | String n ->
            pr "  %sv = caml_copy_string (%s);\n" n n
         | UInt64 n ->
            pr "  %sv = caml_copy_int64 (%s);\n" n n
         | Mutable (Int n) ->
            pr "  %sv = caml_alloc_tuple (1);\n" n;
            pr "  Store_field (%sv, 0, Val_int (*%s));\n" n n
         (* The following not yet implemented for callbacks XXX *)
         | ArrayAndLen _ | Bool _ | BytesOut _
         | BytesPersistIn _ | BytesPersistOut _
         | Closure _
         | Flags _ | Mutable _
         | Path _ | SockAddrAndLen _ | StringList _
         | UInt32 _ -> assert false
       ) cbargs;

       List.iteri (fun i n -> pr "  args[%d] = %s;\n" i n) argnames;

       pr "  fnv = * (value *) user_data;\n";

       pr "  rv = caml_callbackN_exn (fnv, %d, args);\n"
          (List.length argnames);

       List.iter (
         function
         | ArrayAndLen (UInt32 _, _)
         | BytesIn _
         | Int _
         | Int64 _
         | String _
         | UInt _
         | UInt64 _ -> ()
         | Mutable (Int n) ->
            pr "  *%s = Int_val (Field (%sv, 0));\n" n n
         (* The following not yet implemented for callbacks XXX *)
         | ArrayAndLen _ | Bool _ | BytesOut _
         | BytesPersistIn _ | BytesPersistOut _
         | Closure _
         | Flags _ | Mutable _
         | Path _ | SockAddrAndLen _ | StringList _
         | UInt32 _ -> assert false
       ) cbargs;

       pr "  if (Is_exception_result (rv)) {\n";
       pr "    /* XXX This is not really an error as callbacks can return\n";
       pr "     * an error indication.  But perhaps we should direct this\n";
       pr "     * to a more suitable place or formalize what exception\n";
       pr "     * means error versus unexpected failure.\n";
       pr "     */\n";
       pr "    fprintf (stderr,\n";
       pr "             \"libnbd: uncaught OCaml exception: %%s\\n\",\n";
       pr "             caml_format_exception (Extract_exception (rv)));\n";
       pr "    CAMLreturnT (int, -1);\n";
       pr "  }\n";

       pr "\n";
       pr "  CAMLreturnT (int, 0);\n";
       pr "}\n";
       pr "\n";
       pr "static int\n";
       pr "%s_%s_wrapper " name cbname;
       C.print_arg_list ~valid_flag:true ~user_data:true cbargs;
       pr "\n";
       pr "{\n";
       pr "  int ret = 0;\n";
       pr "\n";
       pr "  if (valid_flag & LIBNBD_CALLBACK_VALID) {\n";
       pr "  caml_leave_blocking_section ();\n";
       pr "  ret = %s_%s_wrapper_locked " name cbname;
       C.print_arg_list ~user_data:true ~types:false cbargs;
       pr ";\n";
       pr "  caml_enter_blocking_section ();\n";
       pr "  }\n";
       pr "\n";
       pr "  if (valid_flag & LIBNBD_CALLBACK_FREE) {\n";
       pr "    caml_remove_generational_global_root ((value *)user_data);\n";
       pr "    free (user_data);\n";
       pr "  }\n";
       pr "\n";
       pr "  return ret;\n";
       pr "}\n";
       pr "\n"
    | _ -> ()
  ) args;

  (* Convert the generic args to OCaml args. *)
  let oargs = args_to_ocaml_args args in

  (* Create the binding. *)
  pr "value\n";
  pr "nbd_internal_ocaml_nbd_%s (" name;
  let comma = ref false in
  List.iter (
    fun oarg ->
      if !comma then pr ", ";
      comma := true;
      pr "value %sv" (name_of_ocaml_arg oarg)
  ) oargs;
  pr ")";
  pr "\n";
  pr "{\n";
  (* CAMLparam<N> can only take up to 5 parameters.  Further parameters
   * have to be passed in groups of 5 to CAMLxparam<N> calls.
   *)
  (match List.map (fun oarg -> name_of_ocaml_arg oarg ^ "v") oargs with
   | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
      pr "  CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
      let rec loop = function
        | [] -> ()
        | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
           pr "  CAMLxparam5 (%s);\n"
              (String.concat ", " [p1; p2; p3; p4; p5]);
           loop rest
        | rest ->
           pr "  CAMLxparam%d (%s);\n"
              (List.length rest) (String.concat ", " rest)
      in
      loop rest
   | ps ->
      pr "  CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
  );
  pr "  CAMLlocal1 (rv);\n";
  pr "\n";

  List.iter (
    function
    | OCamlHandle ->
       pr "  struct nbd_handle *h = NBD_val (hv);\n";
       pr "  if (h == NULL)\n";
       pr "    nbd_internal_ocaml_raise_closed (\"NBD.%s\");\n" name
    | OCamlFlags n ->
       pr "  uint32_t %s;\n" n;
       pr "  if (%sv != Val_int (0)) /* Some flags */\n" n;
       pr "    %s = Flags_val (Field (%sv, 0));\n" n n;
       pr "  else /* None */\n";
       pr "    %s = 0;\n" n
    | OCamlArg (ArrayAndLen (t, _)) -> (* XXX *) ()
    | OCamlArg (Bool n) ->
       pr "  bool %s = Bool_val (%sv);\n" n n
    | OCamlArg (BytesIn (n, count)) ->
       pr "  const void *%s = Bytes_val (%sv);\n" n n;
       pr "  size_t %s = caml_string_length (%sv);\n" count n
    | OCamlArg (BytesPersistIn (n, count)) ->
       pr "  struct nbd_buffer %s_buf = NBD_buffer_val (%sv);\n" n n;
       pr "  const void *%s = %s_buf.data;\n" n n;
       pr "  size_t %s = %s_buf.len;\n" count n
    | OCamlArg (BytesOut (n, count)) ->
       pr "  void *%s = Bytes_val (%sv);\n" n n;
       pr "  size_t %s = caml_string_length (%sv);\n" count n
    | OCamlArg (BytesPersistOut (n, count)) ->
       pr "  struct nbd_buffer %s_buf = NBD_buffer_val (%sv);\n" n n;
       pr "  void *%s = %s_buf.data;\n" n n;
       pr "  size_t %s = %s_buf.len;\n" count n
    | OCamlArg (Closure { cbname }) ->
       pr "  /* The function may save a reference to the closure, so we\n";
       pr "   * must treat it as a possible GC root.\n";
       pr "   */\n";
       pr "  value *%s_user_data;\n" cbname;
       pr "  %s_user_data = malloc (sizeof (value));\n" cbname;
       pr "  if (%s_user_data == NULL) caml_raise_out_of_memory ();\n" cbname;
       pr "  caml_register_generational_global_root (%s_user_data);\n" cbname;
       pr "  *%s_user_data = %sv;\n" cbname cbname;
       pr "  const void *%s = %s_%s_wrapper;\n" cbname name cbname
    | OCamlArg (Flags _) -> assert false (* see above *)
    | OCamlArg (Int n) ->
       pr "  int %s = Int_val (%sv);\n" n n
    | OCamlArg (Int64 n) ->
       pr "  int64_t %s = Int64_val (%sv);\n" n n
    | OCamlArg (Mutable _) -> assert false
    | OCamlArg (Path n) | OCamlArg (String n) ->
       pr "  const char *%s = String_val (%sv);\n" n n
    | OCamlArg (SockAddrAndLen (n, len)) ->
       pr "  const struct sockaddr *%s;\n" n;
       pr "  socklen_t %s;\n" len;
       pr "  abort ();\n" (* XXX *)
    | OCamlArg (StringList n) ->
       pr "  char **%s = nbd_internal_ocaml_string_list (%sv);\n" n n
    | OCamlArg (UInt n) ->
       pr "  unsigned %s = Int_val (%sv);\n" n n
    | OCamlArg (UInt32 n) ->
       pr "  uint32_t %s = Int32_val (%sv);\n" n n
    | OCamlArg (UInt64 n) ->
       pr "  uint64_t %s = Int64_val (%sv);\n" n n
  ) oargs;

  let errcode =
    match ret with
    | RBool | RErr | RFd | RInt | RInt64 -> pr "  int r;\n"; Some "-1"
    | RConstString -> pr "  const char *r;\n"; Some "NULL"
    | RString -> pr "  char *r;\n"; Some "NULL"
    | RUInt -> pr "  unsigned r;\n"; None in
  pr "\n";
  pr "  caml_enter_blocking_section ();\n";
  pr "  r =  nbd_%s " name;
  C.print_arg_list ~handle:true ~types:false args;
  pr ";\n";
  pr "  caml_leave_blocking_section ();\n";
  pr "\n";
  (match errcode with
   | Some code ->
      pr "  if (r == %s)\n" code;
      pr "    nbd_internal_ocaml_raise_error ();\n";
      pr "\n"
   | None -> ()
  );
  (match ret with
   | RBool -> pr "  rv = Val_bool (r);\n"
   | RErr -> pr "  rv = Val_unit;\n"
   | RFd | RInt | RUInt -> pr "  rv = Val_int (r);\n"
   | RInt64 -> pr "  rv = caml_copy_int64 (r);\n"
   | RConstString -> pr "  rv = caml_copy_string (r);\n"
   | RString ->
      pr "  rv = caml_copy_string (r);\n";
      pr "  free (r);\n"
  );

  (* Any parameters which need to be freed. *)
  List.iter (
    function
    | OCamlArg (StringList n) -> pr "  free (%s);\n" n
    | OCamlHandle
    | OCamlFlags _
    | OCamlArg (ArrayAndLen _)
    | OCamlArg (Bool _)
    | OCamlArg (BytesIn _)
    | OCamlArg (BytesPersistIn _)
    | OCamlArg (BytesOut _)
    | OCamlArg (BytesPersistOut _)
    | OCamlArg (Closure _)
    | OCamlArg (Flags _)
    | OCamlArg (Int _)
    | OCamlArg (Int64 _)
    | OCamlArg (Mutable _)
    | OCamlArg (Path _)
    | OCamlArg (String _)
    | OCamlArg (SockAddrAndLen _)
    | OCamlArg (UInt _)
    | OCamlArg (UInt32 _)
    | OCamlArg (UInt64 _) -> ()
  ) oargs;

  pr "  CAMLreturn (rv);\n";
  pr "}\n";
  pr "\n";

  if List.length oargs > 5 then (
    pr "/* Byte-code compat function because this method has > 5 parameters.\n";
    pr " */\n";
    pr "value\n";
    pr "nbd_internal_ocaml_nbd_%s_byte (value *argv, int argn)\n" name;
    pr "{\n";
    pr "  return nbd_internal_ocaml_nbd_%s (" name;
    let comma = ref false in
    List.iteri (
      fun i _ ->
        if !comma then pr ", ";
        comma := true;
        pr "argv[%d]" i
    ) oargs;
    pr ");\n";
    pr "}\n";
    pr "\n"
  )

let generate_ocaml_nbd_c () =
  generate_header CStyle;

  pr "#include <config.h>\n";
  pr "\n";
  pr "#include <stdio.h>\n";
  pr "#include <stdlib.h>\n";
  pr "#include <string.h>\n";
  pr "\n";
  pr "#include <libnbd.h>\n";
  pr "\n";
  pr "#include \"nbd-c.h\"\n";
  pr "\n";
  pr "#include <caml/alloc.h>\n";
  pr "#include <caml/callback.h>\n";
  pr "#include <caml/fail.h>\n";
  pr "#include <caml/memory.h>\n";
  pr "#include <caml/mlvalues.h>\n";
  pr "#include <caml/printexc.h>\n";
  pr "#include <caml/threads.h>\n";
  pr "\n";
  pr "#pragma GCC diagnostic ignored \"-Wmissing-prototypes\"\n";
  pr "\n";

  List.iter print_ocaml_binding handle_calls
end

(*----------------------------------------------------------------------*)

(* Write the output files. *)
let () =
  output_to "lib/states.h" StateMachine.generate_lib_states_h;
  output_to "lib/states.c" StateMachine.generate_lib_states_c;
  output_to "lib/libnbd.syms" C.generate_lib_libnbd_syms;
  output_to "include/libnbd.h" C.generate_include_libnbd_h;
  output_to "lib/unlocked.h" C.generate_lib_unlocked_h;
  output_to "lib/api.c" C.generate_lib_api_c;
  output_to "docs/libnbd-api.pod" C.generate_docs_libnbd_api_pod;
  output_to "python/methods.h" Python.generate_python_methods_h;
  output_to "python/libnbdmod.c" Python.generate_python_libnbdmod_c;
  output_to "python/methods.c" Python.generate_python_methods_c;
  output_to "python/nbd.py" Python.generate_python_nbd_py;
  output_to "ocaml/NBD.mli" OCaml.generate_ocaml_nbd_mli;
  output_to "ocaml/NBD.ml" OCaml.generate_ocaml_nbd_ml;
  output_to "ocaml/nbd-c.c" OCaml.generate_ocaml_nbd_c;
