(*
 * Copyright (C) 2009-2011 Citrix Ltd.
 * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
 *
 * This program 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; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program 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.
 *)

type ctx
type domid = int
type devid = int

(* @@LIBXL_TYPES@@ *)

exception Error of (error * string)

external ctx_alloc: Xentoollog.handle -> ctx = "stub_libxl_ctx_alloc"

external test_raise_exception: unit -> unit = "stub_raise_exception"

type event =
	| POLLIN (* There is data to read *)
	| POLLPRI (* There is urgent data to read *)
	| POLLOUT (* Writing now will not block *)
	| POLLERR (* Error condition (revents only) *)
	| POLLHUP (* Device has been disconnected (revents only) *)
	| POLLNVAL (* Invalid request: fd not open (revents only). *)

module Domain = struct
	external create_new : ctx -> Domain_config.t -> ?async:'a -> unit -> domid = "stub_libxl_domain_create_new"
	external create_restore : ctx -> Domain_config.t -> (Unix.file_descr * Domain_restore_params.t) ->
		?async:'a -> unit -> domid = "stub_libxl_domain_create_restore"
	external shutdown : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_shutdown"
	external reboot : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_reboot"
	external destroy : ctx -> domid -> ?async:'a -> unit -> unit = "stub_libxl_domain_destroy"
	external suspend : ctx -> domid -> Unix.file_descr -> ?async:'a -> unit -> unit = "stub_libxl_domain_suspend"
	external pause : ctx -> domid -> ?async:'a -> unit = "stub_libxl_domain_pause"
	external unpause : ctx -> domid -> ?async:'a -> unit = "stub_libxl_domain_unpause"

	external send_trigger : ctx -> domid -> trigger -> int -> ?async:'a -> unit = "stub_xl_send_trigger"
	external send_sysrq : ctx -> domid -> char -> unit = "stub_xl_send_sysrq"
end

module Host = struct
	type console_reader
	exception End_of_file

	external xen_console_read_start : ctx -> int -> console_reader  = "stub_libxl_xen_console_read_start"
	external xen_console_read_line : ctx -> console_reader -> string = "stub_libxl_xen_console_read_line"
	external xen_console_read_finish : ctx -> console_reader -> unit = "stub_libxl_xen_console_read_finish"

	external send_debug_keys : ctx -> string -> unit = "stub_xl_send_debug_keys"
end

module Async = struct
	type for_libxl
	type event_hooks
	type osevent_hooks

	external osevent_register_hooks' : ctx -> 'a -> osevent_hooks = "stub_libxl_osevent_register_hooks"
	external osevent_occurred_fd : ctx -> for_libxl -> Unix.file_descr -> event list -> event list -> unit = "stub_libxl_osevent_occurred_fd"
	external osevent_occurred_timeout : ctx -> for_libxl -> unit = "stub_libxl_osevent_occurred_timeout"

	let osevent_register_hooks ctx ~user ~fd_register ~fd_modify ~fd_deregister ~timeout_register ~timeout_fire_now =
		Callback.register "libxl_fd_register" fd_register;
		Callback.register "libxl_fd_modify" fd_modify;
		Callback.register "libxl_fd_deregister" fd_deregister;
		Callback.register "libxl_timeout_register" timeout_register;
		Callback.register "libxl_timeout_fire_now" timeout_fire_now;
		osevent_register_hooks' ctx user

	let async_register_callback ~async_callback =
		Callback.register "libxl_async_callback" async_callback

	external evenable_domain_death : ctx -> domid -> int -> unit = "stub_libxl_evenable_domain_death"
	external event_register_callbacks' : ctx -> 'a -> event_hooks = "stub_libxl_event_register_callbacks"

	let event_register_callbacks ctx ~user ~event_occurs_callback ~event_disaster_callback =
		Callback.register "libxl_event_occurs_callback" event_occurs_callback;
		Callback.register "libxl_event_disaster_callback" event_disaster_callback;
		event_register_callbacks' ctx user
end

let register_exceptions () =
	Callback.register_exception "Xenlight.Error" (Error(ERROR_FAIL, ""));
	Callback.register_exception "Xenlight.Host.End_of_file" (Host.End_of_file)