# HG changeset patch
# User David Scott <dave.scott@xxxxxxxxxxxxx>
# Date 1279903578 -3600
# Node ID 815d0a9b3661be23e76be25b95e9b0d7fd9641c9
# Parent  5f9ab87260fcdad5df85ce576d019690adbd67b5
First cut at a 'tapctl' module which wraps the 'tap-ctl' command

(Original version by Jon Ludlam <jonathan.ludlam@xxxxxxxxxxxxx>)
Signed-off-by: David Scott <dave.scott@xxxxxxxxxxxxx>

diff -r 5f9ab87260fc -r 815d0a9b3661 Makefile.in
--- a/Makefile.in	Thu Jul 22 15:37:45 2010 +0100
+++ b/Makefile.in	Fri Jul 23 17:46:18 2010 +0100
@@ -45,6 +45,7 @@
 	$(MAKE) -C eventchn
 	$(MAKE) -C cpuid
 	$(MAKE) -C vhd
+	$(MAKE) -C tapctl
 endif
 
 install:
@@ -84,6 +85,7 @@
 	$(MAKE) -C eventchn install
 	$(MAKE) -C cpuid install
 	$(MAKE) -C vhd install
+	$(MAKE) -C tapctl install
 endif
 
 uninstall:
@@ -123,6 +125,7 @@
 	$(MAKE) -C mmap uninstall
 	$(MAKE) -C cpuid uninstall
 	$(MAKE) -C vhd uninstall
+	$(MAKE) -C tapctl uninstall
 endif
 
 bins:
@@ -173,6 +176,7 @@
 	$(MAKE) -C mlvm doc
 	$(MAKE) -C cpuid doc
 	$(MAKE) -C vhd doc
+	$(MAKE) -C tapctl doc
 	$(MAKE) -C xen-utils doc
 
 .PHONY: clean
@@ -195,6 +199,7 @@
 	$(MAKE) -C mlvm clean
 	$(MAKE) -C cpuid clean
 	$(MAKE) -C vhd clean
+	$(MAKE) -C tapctl clean
 	$(MAKE) -C xen-utils clean
 
 cleanxen:
diff -r 5f9ab87260fc -r 815d0a9b3661 tapctl/META.in
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tapctl/META.in	Fri Jul 23 17:46:18 2010 +0100
@@ -0,0 +1,5 @@
+version = "@VERSION@"
+description = "tapctl ocaml interface"
+requires = "unix,stdext,rpc-light.json"
+archive(byte) = "tapctl.cma"
+archive(native) = "tapctl.cmxa"
diff -r 5f9ab87260fc -r 815d0a9b3661 tapctl/Makefile
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tapctl/Makefile	Fri Jul 23 17:46:18 2010 +0100
@@ -0,0 +1,68 @@
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/usr/lib/ocaml
+OCAMLC = ocamlc -g
+OCAMLOPT = ocamlopt
+
+FEPP = camlp4o -I ../rpc-light -I $(shell ocamlfind query type-conv) pa_type_conv.cmo pa_rpc.cma
+
+LDFLAGS = -cclib -L./
+
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+OCAMLOPTFLAGS = -g -dtypes
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = tapctl
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = tapctl.cma tapctl.cmxa
+
+DOCDIR = /myrepos/xen-api-libs.hg/doc
+
+OCAMLFLAGS = -pp '${FEPP}' -I ../rpc-light -I ../stdext
+
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+tapctl.cmxa: $(foreach obj,$(OBJS),$(obj).cmx)
+	$(OCAMLOPT) $(OCAMLOPTFLAGS) $(OCAMLFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx)
+
+tapctl.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+	$(OCAMLC) $(OCAMLOPTFLAGS) $(OCAMLFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+%.cmo: %.ml
+	$(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
+
+%.cmi: %.mli
+	$(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
+
+%.cmx: %.ml
+	$(OCAMLOPT) $(OCAMLOPTFLAGS) $(OCAMLFLAGS) -c -o $@ $<
+
+%.o: %.c
+	$(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+	sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
+install: $(LIBS) META
+	mkdir -p $(path)
+	ocamlfind install -destdir $(path) -ldconf ignore tapctl META $(INTF) $(LIBS) *.a *.cmx
+
+.PHONY: uninstall
+uninstall:
+	ocamlfind remove tapctl
+
+.PHONY: doc
+doc: $(INTF)
+	python ../doc/doc.py $(DOCDIR) "tapctl" "package" "$(OBJS)" "." "" ""
+
+clean:
+	rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
diff -r 5f9ab87260fc -r 815d0a9b3661 tapctl/tapctl.ml
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tapctl/tapctl.ml	Fri Jul 23 17:46:18 2010 +0100
@@ -0,0 +1,130 @@
+open Stringext
+open Listext
+open Threadext
+open Forkhelpers
+
+type tapdev = {
+	minor : int;
+	tapdisk_pid : int;
+} with rpc
+
+type t = tapdev * string * (string * string) option
+
+type context = {
+	host_local_dir: string;
+	dummy: bool;
+}
+
+let create () = { host_local_dir = ""; dummy = false }
+
+let get_devnode_dir ctx =
+	let d = Printf.sprintf "%s/dev/xen/blktap-2" ctx.host_local_dir in
+	Unixext.mkdir_rec d 0o755;
+	d
+let get_blktapstem ctx = Printf.sprintf "%s/dev/xen/blktap-2/blktap" ctx.host_local_dir
+let get_tapdevstem ctx = Printf.sprintf "%s/dev/xen/blktap-2/tapdev" ctx.host_local_dir
+
+type driver = | Vhd | Aio
+
+let string_of_driver = function
+| Vhd -> "vhd"
+| Aio -> "aio"
+
+let invoke_tap_ctl ctx cmd args =
+	if ctx.dummy then
+		match cmd with
+			| "allocate" ->
+				let path = Printf.sprintf "%s%d" (get_blktapstem ctx) (Random.int max_int) in
+				Unixext.mkdir_rec (Filename.dirname path) 0o700;
+				Unix.close (Unix.openfile path [Unix.O_RDWR; Unix.O_CREAT; Unix.O_EXCL] 0o700);
+				path
+			| _ -> ""
+	else
+		let stdout, stderr = execute_command_get_output ~env:[|"PATH=" ^ (Sys.getenv "PATH") |] "/usr/sbin/tap-ctl" (cmd::args) in
+		stdout
+
+let allocate ctx =
+	let result = invoke_tap_ctl ctx "allocate" [] in
+	let stem = get_tapdevstem ctx in
+	let stemlen = String.length stem in
+	assert(String.startswith stem result);
+	let minor_str = (String.sub result stemlen (String.length result - stemlen)) in
+	let minor = Scanf.sscanf minor_str "%d" (fun d -> d) in
+	minor
+
+let devnode ctx minor =
+	Printf.sprintf "%s%d" (get_tapdevstem ctx) minor
+
+let spawn ctx =
+	let result = invoke_tap_ctl ctx "spawn" [] in
+	let pid = Scanf.sscanf result "%d" (fun d -> d) in
+	pid
+
+let attach ctx pid minor =
+	let _ = invoke_tap_ctl ctx "attach" ["-p"; string_of_int pid; "-m"; string_of_int minor] in
+	{minor=minor; tapdisk_pid=pid}
+
+let args tapdev =
+	["-p"; string_of_int tapdev.tapdisk_pid; "-m"; string_of_int tapdev.minor]
+
+let _open ctx t leaf_path driver =
+	ignore(invoke_tap_ctl ctx "open" (args t @ ["-a"; Printf.sprintf "%s:%s" (string_of_driver driver) leaf_path]))
+
+let close ctx t =
+	ignore(invoke_tap_ctl ctx "close" (args t))
+
+let pause ctx t =
+	ignore(invoke_tap_ctl ctx "pause" (args t))
+
+let unpause ctx t leaf_path driver =
+	ignore(invoke_tap_ctl ctx "unpause" (args t @ [ "-a"; Printf.sprintf "%s:%s" (string_of_driver driver) leaf_path ]))
+
+let detach ctx t =
+	ignore(invoke_tap_ctl ctx "detach" (args t))
+
+let free ctx minor =
+	ignore(invoke_tap_ctl ctx "free" ["-m"; string_of_int minor])
+
+let list ?t ctx =
+	let args = match t with
+		| Some tapdev -> args tapdev
+		| None -> []
+	in
+	let result = invoke_tap_ctl ctx "list" args in
+	let lines = String.split '\n' result in
+	List.filter_map (fun line ->
+		try 
+			let fields = String.split_f String.isspace line in
+			let assoc = List.filter_map (fun field -> 
+				match String.split '=' field with
+					| x::ys -> 
+						Some (x,String.concat "=" ys)
+					| _ -> 
+						None) fields
+			in
+			let args = 
+				match String.split ':' (List.assoc "args" assoc) with
+					| ty::arguments ->
+						Some (ty,String.concat ":" arguments)
+					| _ -> None
+			in
+			Some ({tapdisk_pid=int_of_string (List.assoc "pid" assoc); minor=int_of_string (List.assoc "minor" assoc)},(List.assoc "state" assoc),args)
+		with _ -> None) lines
+
+let is_paused ctx t =
+	let result = list ~t ctx in
+	match result with
+		| [(tapdev,state,args)] -> state="0x2a"
+		| _ -> failwith "Unknown device"
+
+let is_active ctx t =
+	let result = list ~t ctx in
+	match result with
+		| [(tapdev,state,Some _ )] -> true
+		| _ -> false
+
+let of_device ctx path =
+	let minor = (Unix.stat path).Unix.st_rdev mod 256 in
+	match List.filter (fun (tapdev, _, _) -> tapdev.minor = minor) (list ctx) with
+		| [ t ] -> t
+		| _ -> raise Not_found
diff -r 5f9ab87260fc -r 815d0a9b3661 tapctl/tapctl.mli
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tapctl/tapctl.mli	Fri Jul 23 17:46:18 2010 +0100
@@ -0,0 +1,30 @@
+(** Represents an active tapdisk instance *)
+type tapdev
+val tapdev_of_rpc : Rpc.t -> tapdev
+val rpc_of_tapdev : tapdev -> Rpc.t
+
+type t = tapdev * string * (string * string) option
+
+type context
+val create : unit -> context
+
+type driver = Vhd | Aio
+val string_of_driver : driver -> string
+
+val allocate : context -> int
+val devnode : context -> int -> string
+val spawn : context -> int
+val attach : context -> int -> int -> tapdev
+val args : tapdev -> string list
+val _open : context -> tapdev -> string -> driver -> unit
+val close : context -> tapdev -> unit
+val pause : context -> tapdev -> unit
+val unpause : context -> tapdev -> string -> driver -> unit
+val detach : context -> tapdev -> unit
+val free : context -> int -> unit
+val list : ?t:tapdev -> context -> t list
+val is_paused : context -> tapdev -> bool
+val is_active : context -> tapdev -> bool
+
+(** Given a path to a device, return the corresponding tap information *)
+val of_device : context -> string -> t
diff -r 5f9ab87260fc -r 815d0a9b3661 xapi-libs.spec
--- a/xapi-libs.spec	Thu Jul 22 15:37:45 2010 +0100
+++ b/xapi-libs.spec	Fri Jul 23 17:46:18 2010 +0100
@@ -292,6 +292,12 @@
    /usr/lib/ocaml/cpuid/cpuid.cmxa
    /usr/lib/ocaml/cpuid/dllcpuid_stubs.so
    /usr/lib/ocaml/cpuid/libcpuid_stubs.a
+   /usr/lib/ocaml/tapctl/META
+   /usr/lib/ocaml/tapctl/tapctl.a
+   /usr/lib/ocaml/tapctl/tapctl.cma
+   /usr/lib/ocaml/tapctl/tapctl.cmi
+   /usr/lib/ocaml/tapctl/tapctl.cmx
+   /usr/lib/ocaml/tapctl/tapctl.cmxa
    /usr/lib/ocaml/netdev/*
    /usr/lib/ocaml/eventchn/META
    /usr/lib/ocaml/eventchn/dlleventchn_stubs.so