[PATCH v2 13/17] tools/ocaml/libs/xb: import gnttab stubs from mirage

["Edwin Török" <edvin.torok@citrix.com>]

Upstream URL: https://github.com/mirage/ocaml-gnt
Mirage is part of the Xen project and the license is compatible,
copyright headers are retained.

Changes from upstream:
* cut down dependencies: dropped Lwt, replaced Io_page with Xenmmap
* only import Gnttab and not Gntshr

This is for xenstored's use only which needs a way to grant map
the xenstore ring without using xenctrl.

The gnt code is added into libs/mmap because it uses mmap_stubs.h.
Also this makes it possible to mock out gnttab in the unit tests:
replace it with code that just mmaps /dev/zero.
For the mocking to work gnt.ml needs to be in a dir other than xenstored/.

Signed-off-by: Edwin Török <edvin.torok@citrix.com>
---
 tools/ocaml/Makefile                   |   1 +
 tools/ocaml/libs/mmap/Makefile         |  19 +++--
 tools/ocaml/libs/mmap/dune             |  10 +++
 tools/ocaml/libs/mmap/gnt.ml           |  60 ++++++++++++++
 tools/ocaml/libs/mmap/gnt.mli          |  86 ++++++++++++++++++++
 tools/ocaml/libs/mmap/gnttab_stubs.c   | 106 +++++++++++++++++++++++++
 tools/ocaml/xenstored/Makefile         |   1 +
 tools/ocaml/xenstored/dune             |   6 +-
 tools/ocaml/xenstored/test/gnt.ml      |  52 ++++++++++++
 tools/ocaml/xenstored/test/testable.ml |   3 +-
 tools/ocaml/xenstored/xenstored.ml     |  10 +--
 11 files changed, 339 insertions(+), 15 deletions(-)
 create mode 100644 tools/ocaml/libs/mmap/gnt.ml
 create mode 100644 tools/ocaml/libs/mmap/gnt.mli
 create mode 100644 tools/ocaml/libs/mmap/gnttab_stubs.c
 create mode 100644 tools/ocaml/xenstored/test/gnt.ml

diff --git a/tools/ocaml/Makefile b/tools/ocaml/Makefile
index de375820a3..1236b0e584 100644
--- a/tools/ocaml/Makefile
+++ b/tools/ocaml/Makefile
@@ -43,6 +43,7 @@ C_INCLUDE_PATH=$(XEN_libxenctrl)/include:$(XEN_libxengnttab)/include:$(XEN_libxe
 # in the parent directory (so it couldn't copy/use Config.mk)
 .PHONY: dune-pre
 dune-pre:
+	$(MAKE) clean
 	$(MAKE) -s -C ../../ build-tools-public-headers
 	$(MAKE) -s -C libs/xs paths.ml
 	$(MAKE) -s -C libs/xc xenctrl_abi_check.h
diff --git a/tools/ocaml/libs/mmap/Makefile b/tools/ocaml/libs/mmap/Makefile
index df45819df5..ed4903b48a 100644
--- a/tools/ocaml/libs/mmap/Makefile
+++ b/tools/ocaml/libs/mmap/Makefile
@@ -2,9 +2,7 @@ TOPLEVEL=$(CURDIR)/../..
 XEN_ROOT=$(TOPLEVEL)/../..
 include $(TOPLEVEL)/common.make
 
-OBJS = xenmmap
 INTF = $(foreach obj, $(OBJS),$(obj).cmi)
-LIBS = xenmmap.cma xenmmap.cmxa
 
 all: $(INTF) $(LIBS) $(PROGRAMS)
 
@@ -12,15 +10,26 @@ bins: $(PROGRAMS)
 
 libs: $(LIBS)
 
-xenmmap_OBJS = $(OBJS)
+# gnt is an internal library, not installed
+gnt_OBJS = gnt
+gnt_C_OBJS = gnttab_stubs
+gnt_LIBS = gnt.cma gnt.cmxa
+LIBS_gnt = $(LDLIBS_libxengnttab)
+CFLAGS += $(CFLAGS_libxengnttab)
+
+xenmmap_OBJS = xenmmap
 xenmmap_C_OBJS = xenmmap_stubs
-OCAML_LIBRARY = xenmmap
+xenmmap_LIBS = xenmmap.cma xenmmap.cmxa
+
+OCAML_LIBRARY = xenmmap gnt
+OBJS = $(xenmmap_OBJS) $(gnt_OBJS)
+LIBS = $(xenmmap_LIBS) $(gnt_LIBS)
 
 .PHONY: install
 install: $(LIBS) META
 	mkdir -p $(OCAMLDESTDIR)
 	$(OCAMLFIND) remove -destdir $(OCAMLDESTDIR) xenmmap
-	$(OCAMLFIND) install -destdir $(OCAMLDESTDIR) -ldconf ignore xenmmap META $(INTF) $(LIBS) *.a *.so *.cmx
+	$(OCAMLFIND) install -destdir $(OCAMLDESTDIR) -ldconf ignore xenmmap META *xenmmap*.cmi $(xenmmap_LIBS) *xenmmap*.a *xenmmap*.so *xenmmap*.cmx
 
 .PHONY: uninstall
 uninstall:
diff --git a/tools/ocaml/libs/mmap/dune b/tools/ocaml/libs/mmap/dune
index a47de44e47..f4c98153c4 100644
--- a/tools/ocaml/libs/mmap/dune
+++ b/tools/ocaml/libs/mmap/dune
@@ -3,6 +3,16 @@
   (language c)
   (names xenmmap_stubs))
  (name xenmmap)
+ (modules xenmmap)
  (public_name xen.mmap)
  (libraries unix)
  (install_c_headers mmap_stubs))
+
+(library
+ (foreign_stubs
+  (language c)
+  (names gnttab_stubs))
+ (name xengnt)
+ (modules gnt)
+ (wrapped false) 
+ (libraries unix xen.mmap))
diff --git a/tools/ocaml/libs/mmap/gnt.ml b/tools/ocaml/libs/mmap/gnt.ml
new file mode 100644
index 0000000000..65f0334b7c
--- /dev/null
+++ b/tools/ocaml/libs/mmap/gnt.ml
@@ -0,0 +1,60 @@
+(*
+ * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (C) 2012-2014 Citrix Inc
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+type gntref = int
+type domid = int
+
+let console = 0 (* public/grant_table.h:GNTTAB_RESERVED_CONSOLE *)
+let xenstore = 1 (* public/grant_table.h:GNTTAB_RESERVED_XENSTORE *)
+
+type grant_handle (* handle to a mapped grant *)
+
+module Gnttab = struct
+  type interface
+
+  external interface_open': unit -> interface = "stub_gnttab_interface_open"
+
+  let interface_open () =
+    try
+      interface_open' ()
+    with e ->
+      Printf.fprintf stderr "Failed to open grant table device: ENOENT\n";
+      Printf.fprintf stderr "Does this system have Xen userspace grant table support?\n";
+      Printf.fprintf stderr "On linux try:\n";
+      Printf.fprintf stderr "  sudo modprobe xen-gntdev\n%!";
+      raise e
+
+  external interface_close: interface -> unit = "stub_gnttab_interface_close"
+
+  type grant = {
+    domid: domid;
+    ref: gntref;
+  }
+
+  module Local_mapping = struct
+    type t = Xenmmap.mmap_interface
+
+    let to_pages t = t
+  end
+
+  external unmap_exn : interface -> Local_mapping.t -> unit = "stub_gnttab_unmap"
+
+  external map_fresh_exn: interface -> gntref -> domid -> bool -> Local_mapping.t = "stub_gnttab_map_fresh"
+
+  let map_exn interface grant writable =
+      map_fresh_exn interface grant.ref grant.domid writable
+end
diff --git a/tools/ocaml/libs/mmap/gnt.mli b/tools/ocaml/libs/mmap/gnt.mli
new file mode 100644
index 0000000000..302e13b05d
--- /dev/null
+++ b/tools/ocaml/libs/mmap/gnt.mli
@@ -0,0 +1,86 @@
+(*
+ * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (C) 2012-2014 Citrix Inc
+ * 
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+(** Allow a local xen domain to read/write memory exported ("granted")
+    from foreign domains. Safe memory sharing is a building block of all
+    xen inter-domain communication protocols such as those for virtual
+    network and disk devices.
+
+    Foreign domains will explicitly "grant" us access to certain memory
+    regions such as disk buffers. These regions are uniquely identified
+    by the pair of (foreign domain id, integer reference) which is
+    passed to us over some existing channel (typically via xenstore keys
+    or via structures in previously-shared memory region).
+*)
+
+(** {2 Common interface} *)
+
+type gntref = int
+(** Type of a grant table index, called a grant reference in
+    Xen's terminology. *)
+
+(** {2 Receiving foreign pages} *)
+
+module Gnttab : sig
+  type interface
+  (** A connection to the grant device, needed for mapping/unmapping *)
+
+  val interface_open: unit -> interface
+  (** Open a connection to the grant device. This must be done before any
+      calls to map or unmap. *)
+
+  val interface_close: interface -> unit
+  (** Close a connection to the grant device. Any future calls to map or
+      unmap will fail. *)
+
+  type grant = {
+    domid: int;
+    (** foreign domain who is exporting memory *)
+    ref: gntref;
+    (** id which identifies the specific export in the foreign domain *)
+  }
+  (** A foreign domain must explicitly "grant" us memory and send us the
+      "reference". The pair of (foreign domain id, reference) uniquely
+      identifies the block of memory. This pair ("grant") is transmitted
+      to us out-of-band, usually either via xenstore during device setup or
+      via a shared memory ring structure. *)
+
+  module Local_mapping : sig
+    type t
+    (** Abstract type representing a locally-mapped shared memory page *)
+
+    val to_pages: t -> Xenmmap.mmap_interface
+  end
+
+  val map_exn : interface -> grant -> bool -> Local_mapping.t
+  (** [map_exn if grant writable] creates a single mapping from
+      [grant] that will be writable if [writable] is [true]. *)
+
+  val unmap_exn: interface -> Local_mapping.t -> unit
+  (** Unmap a single mapping (which may involve multiple grants). Throws a
+      Failure if unsuccessful. *)
+end
+
+val console: gntref
+(** In xen-4.2 and later, the domain builder will allocate one of the
+    reserved grant table entries and use it to pre-authorise the console
+    backend domain. *)
+
+val xenstore: gntref
+(** In xen-4.2 and later, the domain builder will allocate one of the
+    reserved grant table entries and use it to pre-authorise the xenstore
+    backend domain. *)
diff --git a/tools/ocaml/libs/mmap/gnttab_stubs.c b/tools/ocaml/libs/mmap/gnttab_stubs.c
new file mode 100644
index 0000000000..f0b4ab237f
--- /dev/null
+++ b/tools/ocaml/libs/mmap/gnttab_stubs.c
@@ -0,0 +1,106 @@
+/*
+ * Copyright (C) 2012-2013 Citrix Inc
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ */
+
+#include <stdlib.h>
+#include <stdint.h>
+#include <string.h>
+#include <errno.h>
+
+/* For PROT_READ | PROT_WRITE */
+#include <sys/mman.h>
+
+#define CAML_NAME_SPACE
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+#include <caml/bigarray.h>
+
+#include "xengnttab.h"
+#include "mmap_stubs.h"
+
+#ifndef Data_abstract_val
+#define Data_abstract_val(v) ((void*) Op_val(v))
+#endif
+
+#define _G(__g) (*((xengnttab_handle**)Data_abstract_val(__g)))
+
+CAMLprim value stub_gnttab_interface_open(void)
+{
+	CAMLparam0();
+	CAMLlocal1(result);
+	xengnttab_handle *xgh;
+
+	xgh = xengnttab_open(NULL, 0);
+	if (xgh == NULL)
+		caml_failwith("Failed to open interface");
+	result = caml_alloc(1, Abstract_tag);
+	_G(result) = xgh;
+
+	CAMLreturn(result);
+}
+
+CAMLprim value stub_gnttab_interface_close(value xgh)
+{
+	CAMLparam1(xgh);
+
+	xengnttab_close(_G(xgh));
+
+	CAMLreturn(Val_unit);
+}
+
+#define _M(__m) ((struct mmap_interface*)Data_abstract_val(__m))
+#define XEN_PAGE_SHIFT 12
+
+CAMLprim value stub_gnttab_unmap(value xgh, value array)
+{
+	CAMLparam2(xgh, array);
+	int result;
+
+	caml_enter_blocking_section();
+	result = xengnttab_unmap(_G(xgh), _M(array)->addr, _M(array)->len >> XEN_PAGE_SHIFT);
+	caml_leave_blocking_section();
+
+	if(result!=0) {
+		caml_failwith("Failed to unmap grant");
+	}
+
+	CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_gnttab_map_fresh(
+	value xgh,
+	value reference,
+	value domid,
+	value writable
+	)
+{
+	CAMLparam4(xgh, reference, domid, writable);
+	CAMLlocal1(contents);
+	void *map;
+
+	caml_enter_blocking_section();
+	map = xengnttab_map_grant_ref(_G(xgh), Int_val(domid), Int_val(reference),
+		Bool_val(writable)?PROT_READ | PROT_WRITE:PROT_READ);
+	caml_leave_blocking_section();
+
+	if(map==NULL) {
+		caml_failwith("Failed to map grant ref");
+	}
+	contents = stub_mmap_alloc(map, 1 << XEN_PAGE_SHIFT);
+	CAMLreturn(contents);
+}
diff --git a/tools/ocaml/xenstored/Makefile b/tools/ocaml/xenstored/Makefile
index 9d2da206d8..689a8fb07d 100644
--- a/tools/ocaml/xenstored/Makefile
+++ b/tools/ocaml/xenstored/Makefile
@@ -67,6 +67,7 @@ XENSTOREDLIBS = \
 	-ccopt -L -ccopt . systemd.cmxa \
 	-ccopt -L -ccopt . poll.cmxa \
 	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/xenmmap.cmxa \
+	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/mmap $(OCAML_TOPLEVEL)/libs/mmap/gnt.cmxa \
 	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/eventchn $(OCAML_TOPLEVEL)/libs/eventchn/xeneventchn.cmxa \
 	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xc $(OCAML_TOPLEVEL)/libs/xc/xenctrl.cmxa \
 	-ccopt -L -ccopt $(OCAML_TOPLEVEL)/libs/xb $(OCAML_TOPLEVEL)/libs/xb/xenbus.cmxa \
diff --git a/tools/ocaml/xenstored/dune b/tools/ocaml/xenstored/dune
index 714a2ae07e..81a6bf7a4a 100644
--- a/tools/ocaml/xenstored/dune
+++ b/tools/ocaml/xenstored/dune
@@ -1,17 +1,17 @@
 (executable
- (modes byte exe)
+ (modes exe)
  (name xenstored_main)
  (modules (:standard \ syslog systemd))
  (public_name oxenstored)
  (package xenstored)
  (flags (:standard -w -52))
- (libraries unix xen.bus xen.mmap xen.ctrl xen.eventchn xenstubs))
+ (libraries unix xen.bus xen.mmap xen.ctrl xen.eventchn xenstubs xengnt))
 
 (library
  (foreign_stubs
   (language c)
   (names syslog_stubs systemd_stubs select_stubs)
-  (flags (-DHAVE_SYSTEMD)))
+  (flags (-DHAVE_SYSTEMD -I../libs/mmap/)))
  (modules syslog systemd)
  (name xenstubs)
  (wrapped false)
diff --git a/tools/ocaml/xenstored/test/gnt.ml b/tools/ocaml/xenstored/test/gnt.ml
new file mode 100644
index 0000000000..ae71e2aaef
--- /dev/null
+++ b/tools/ocaml/xenstored/test/gnt.ml
@@ -0,0 +1,52 @@
+(*
+ * Copyright (c) 2010 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (C) 2012-2014 Citrix Inc
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+type gntref = int
+type domid = int
+
+let console = 0 (* public/grant_table.h:GNTTAB_RESERVED_CONSOLE *)
+let xenstore = 1 (* public/grant_table.h:GNTTAB_RESERVED_XENSTORE *)
+
+type grant_handle (* handle to a mapped grant *)
+
+module Gnttab = struct
+  type interface = unit
+
+  let interface_open () = ()
+  let interface_close () = ()
+
+  type grant = {
+    domid: domid;
+    ref: gntref;
+  }
+
+  let unmap_exn () _ = () (* FIXME: leak *)
+  let devzero = Unix.openfile "/dev/zero" [] 0
+  let  nullmap () = Xenmmap.mmap devzero Xenmmap.RDWR Xenmmap.PRIVATE 4096 0
+  let map_fresh_exn () _ _ _ = Xenmmap.to_interface (nullmap())
+
+  module Local_mapping = struct
+    type t = Xenmmap.mmap_interface
+
+    let to_pages interface t =
+      Xenmmap.make t ~unmap:(unmap_exn interface)
+  end
+
+  let map_exn interface grant writable : Local_mapping.t =
+    map_fresh_exn interface grant.ref grant.domid writable
+
+end
diff --git a/tools/ocaml/xenstored/test/testable.ml b/tools/ocaml/xenstored/test/testable.ml
index 2fa749fbb3..37042356b8 100644
--- a/tools/ocaml/xenstored/test/testable.ml
+++ b/tools/ocaml/xenstored/test/testable.ml
@@ -169,7 +169,8 @@ let () =
 let create ?(live_update = false) () =
   let store = Store.create () in
   let cons = Connections.create () in
-  let doms = Domains.init (Event.init ()) ignore in
+  let gnt = Gnt.Gnttab.interface_open () in (* dummy *)
+  let doms = Domains.init (Event.init ()) gnt ignore in
   let dom0 = Domains.create0 doms in
   let txidtbl = Hashtbl.create 47 in
   Connections.add_domain cons dom0 ;
diff --git a/tools/ocaml/xenstored/xenstored.ml b/tools/ocaml/xenstored/xenstored.ml
index 34e706910e..a6b86b167c 100644
--- a/tools/ocaml/xenstored/xenstored.ml
+++ b/tools/ocaml/xenstored/xenstored.ml
@@ -166,9 +166,8 @@ let from_channel_f_compat chan global_f socket_f domain_f watch_f store_f =
 					global_f ~rw
 				| "socket" :: fd :: [] ->
 					socket_f ~fd:(int_of_string fd)
-				| "dom" :: domid :: mfn :: port :: []->
+				| "dom" :: domid :: _mfn :: port :: []->
 					domain_f (int_of_string domid)
-					         (Nativeint.of_string mfn)
 					         (int_of_string port)
 				| "watch" :: domid :: path :: token :: [] ->
 					watch_f (int_of_string domid)
@@ -208,10 +207,10 @@ let from_channel_compat ~live store cons doms chan =
 		else
 			warn "Ignoring invalid socket FD %d" fd
 	in
-	let domain_f domid mfn port =
+	let domain_f domid port =
 		let ndom =
 			if domid > 0 then
-				Domains.create doms domid mfn port
+				Domains.create doms domid port
 			else
 				Domains.create0 doms
 			in
@@ -270,8 +269,7 @@ let from_channel_bin ~live store cons doms chan =
 			Connections.find_domain cons 0
 		| LR.Domain d ->
 			debug "Recreating domain %d, port %d" d.id d.remote_port; 
-			(* FIXME: gnttab *)
-			Domains.create doms d.id 0n d.remote_port
+			Domains.create doms d.id d.remote_port
 			|> Connections.add_domain cons;
 			Connections.find_domain cons d.id
 		| LR.Socket fd ->
-- 
2.25.1