1 files changed, 290 insertions, 0 deletions
diff --git a/virt-ctrl/vc_dbus.ml b/virt-ctrl/vc_dbus.ml
index 5117482..278b1fc 100644
--- a/virt-ctrl/vc_dbus.ml
+++ b/virt-ctrl/vc_dbus.ml
@@ -19,3 +19,293 @@
    This file contains any code which needs optional package OCaml-DBUS.
 *)
 
+(* There is *zero* documentation for this.  I examined a lot of code
+ * to do this, and the following page was also very helpful:
+ * http://www.amk.ca/diary/2007/04/rough_notes_python_and_dbus.html
+ * See also the DBus API reference:
+ * http://dbus.freedesktop.org/doc/dbus/api/html/index.html
+ * See also Dan Berrange's Perl bindings:
+ * http://search.cpan.org/src/DANBERR/Net-DBus-0.33.5/lib/Net/
+ *
+ * This code is a complicated state machine because that's what
+ * D-Bus requires.  Enable debugging below to trace messages.
+ *
+ * It's also very unelegant and leaks memory.
+ *
+ * The code connects to D-Bus only the first time that the
+ * connection dialog is opened, and thereafter it attaches itself
+ * to the Gtk main loop, waiting for events.  It's probably not
+ * safe if the avahi or dbus daemon restarts.
+ *)
+
+open Printf
+open DBus
+
+let debug = true
+
+let service = "_libvirt._tcp"
+
+let rec print_msg msg =
+  (match Message.get_type msg with
+   | Message.Invalid ->
+       eprintf "Invalid";
+   | Message.Method_call ->
+       eprintf "Method_call";
+   | Message.Method_return ->
+       eprintf "Method_return";
+   | Message.Error ->
+       eprintf "Error";
+   | Message.Signal ->
+       eprintf "Signal");
+
+  let print_opt f name =
+    match f msg with
+    | None -> ()
+    | Some value -> eprintf "\n\t%s=%S" name value
+  in
+  print_opt Message.get_member "member";
+  print_opt Message.get_path "path";
+  print_opt Message.get_interface "interface";
+  print_opt Message.get_sender "sender";
+
+  let fields = Message.get msg in
+  eprintf "\n\t[";
+  print_fields fields;
+  eprintf "]\n%!";
+
+and print_fields fields =
+  eprintf "%s" (String.concat ", " (List.map string_of_ty fields))
+
+(* Perform a synchronous call to an object method. *)
+let call_method ~bus ~err ~name ~path ~interface ~methd args =
+  (* Create the method_call message. *)
+  let msg = Message.new_method_call name path interface methd in
+  Message.append msg args;
+  (* Send the message, get reply. *)
+  let r = Connection.send_with_reply_and_block bus msg (-1) err in
+  Message.get r
+
+(* Services we've found.
+ * This is a map from name -> URI.
+ * XXX We just assume Xen at the moment.
+ * XXX The same machine can appear on multiple interfaces, so this
+ * isn't right.
+ *)
+let services : (string, string) Hashtbl.t = Hashtbl.create 13
+
+(* Process a Found message, indicating that we've found and fully
+ * resolved a new service.
+ *)
+let add_service bus err msg =
+  (* match fields in the Found message from ServiceResolver. *)
+  match Message.get msg with
+  | Int32 _ ::				(* interface *)
+      Int32 (*protocol*)_ ::		(* 0 = IPv4, 1=IPv6 *)
+      String name ::			(* "Virtualization Host foo" *)
+      String _ ::			(* "_libvirt._tcp" *)
+      String _ ::			(* domain name *)
+      String hostname ::		(* this is the hostname as a string *)
+      Int32 _ ::			(* ? aprotocol *)
+      String address ::			(* IP address as a string *)
+      UInt16 (*port*)_ :: _ ->		(* port is set to 0 by libvirtd *)
+
+      let hostname = if hostname <> "" then hostname else address in
+      (*let protocol = if protocol = 1_l then IPv6 else IPv4 in*)
+
+      (* XXX *)
+      let uri = "xen://" ^ hostname ^ "/" in
+
+      if debug then eprintf "adding %s %s\n%!" name uri;
+
+      Hashtbl.replace services name uri
+
+  | _ ->
+      prerr_endline "warning: unexpected message contents of Found signal"
+
+(* Process an ItemRemove message, indicating that a service has
+ * gone away.
+ *)
+let remove_service bus err msg =
+  (* match fields in the ItemRemove message from ServiceBrowser. *)
+  match Message.get msg with
+  | Int32 _ ::				(* interface *)
+      Int32 _ ::			(* protocol *)
+      String name :: _ ->		(* name *)
+      if debug then eprintf "removing %s\n%!" name;
+      Hashtbl.remove services name
+
+  | _ ->
+      prerr_endline "warning: unexpected message contents of ItemRemove signal"
+
+(* A service has appeared on the network.  Resolve its IP address, etc. *)
+let start_resolve_service bus err sb_path msg =
+  (* match fields in the ItemNew message from ServiceBrowser. *)
+  match Message.get msg with
+  | ((Int32 _) as interface) ::
+      ((Int32 _) as protocol) ::
+      ((String _) as name) ::
+      ((String _) as service) ::
+      ((String _) as domain) :: _ ->
+      (* Create a new ServiceResolver object which is used to resolve
+       * the actual locations of network services found by the ServiceBrowser.
+       *)
+      let sr =
+	call_method ~bus ~err
+	  ~name:"org.freedesktop.Avahi"
+	  ~path:"/"
+	  ~interface:"org.freedesktop.Avahi.Server"
+	  ~methd:"ServiceResolverNew"
+	  [
+	    interface;
+	    protocol;
+	    name;
+	    service;
+	    domain;
+	    Int32 (-1_l);		(* AVAHI_PROTO_UNSPEC *)
+	    UInt32 0_l;			(* flags *)
+	  ] in
+      let sr_path =
+	match sr with
+	| [ ObjectPath path ] -> path
+	| _ -> assert false in
+
+      if debug then eprintf "ServiceResolver path = %S\n%!" sr_path;
+
+      (* Add a match rule so we see these all signals of interest. *)
+      Bus.add_match bus
+	(String.concat "," [
+	   "type='signal'";
+	   "sender='org.freedesktop.Avahi.ServiceResolver'";
+	   "path='" ^ sr_path ^ "'";
+	 ]) err;
+
+      ()
+
+  | _ ->
+      prerr_endline "warning: unexpected message contents of ItemNew signal"
+
+(* This is called when we get a message/signal.  Could be from the
+ * (global) ServiceBrowser or any of the ServiceResolver objects.
+ *)
+let got_message bus err sb_path msg =
+  if debug then print_msg msg;
+
+  let typ = Message.get_type msg in
+  let member = match Message.get_member msg with None -> "" | Some m -> m in
+  let interface =
+    match Message.get_interface msg with None -> "" | Some m -> m in
+
+  if typ = Message.Signal then (
+    match interface, member with
+    | "org.freedesktop.Avahi.ServiceBrowser", "CacheExhausted" -> ()
+    | "org.freedesktop.Avahi.ServiceBrowser", "AllForNow" -> ()
+    | "org.freedesktop.Avahi.ServiceBrowser", "ItemNew" ->
+	(* New service has appeared, start to resolve it. *)
+	start_resolve_service bus err sb_path msg
+    | "org.freedesktop.Avahi.ServiceResolver", "Found" ->
+	(* Resolver has finished resolving the name of a previously
+	 * appearing service.
+	 *)
+	add_service bus err msg
+    | "org.freedesktop.Avahi.ServiceBrowser", "ItemRemove" ->
+	(* Service has disappeared. *)
+	remove_service bus err msg
+    | "org.freedesktop.DBus", _ -> ()
+    | interface, member ->
+	eprintf "warning: ignored unknown message %s from %s\n%!"
+	  member interface
+  );
+  true
+
+(* Store the connection ((bus, err, io_id) tuple).  However don't bother
+ * connecting to D-Bus at all until the user opens the connection
+ * dialog for the first time.
+ *)
+let connection = ref None
+
+(* Create global error and system bus object, and create the service browser. *)
+let connect () =
+  match !connection with
+  | Some (bus, err, _) -> (bus, err, false)
+  | None ->
+      let err = Error.init () in
+      let bus = Bus.get Bus.System err in
+      if Error.is_set err then failwith "error set after getting System bus";
+
+      (* Create a new ServiceBrowser object which emits a signal whenever
+       * a new network service of the type specified is found on the network.
+       *)
+      let sb =
+	call_method ~bus ~err
+	  ~name:"org.freedesktop.Avahi"
+	  ~path:"/"
+	  ~interface:"org.freedesktop.Avahi.Server"
+	  ~methd:"ServiceBrowserNew"
+	  [
+	    Int32 (-1_l);	        (* interface, -1=AVAHI_IF_UNSPEC *)
+	    Int32 (-1_l);		(* AVAHI_PROTO_UNSPEC *)
+	    String service;		(* service type *)
+	    String "";			(* XXX call GetDomainName() *)
+	    UInt32 0_l;			(* flags *)
+	  ] in
+      let sb_path =
+	match sb with
+	| [ ObjectPath path ] -> path
+	| _ -> assert false in
+
+      if debug then eprintf "ServiceBrowser path = %S\n%!" sb_path;
+
+      (* Register a callback to accept the signals. *)
+      (* XXX This leaks memory because it is never freed. *)
+      Connection.add_filter bus (
+	fun bus msg -> got_message bus err sb_path msg
+      );
+
+      (* Add a match rule so we see these all signals of interest. *)
+      Bus.add_match bus
+	(String.concat "," [
+	   "type='signal'";
+	   "sender='org.freedesktop.Avahi.ServiceBrowser'";
+	   "path='" ^ sb_path ^ "'";
+	 ]) err;
+
+      (* This is called from the Gtk main loop whenever there is new
+       * data to read on the D-Bus socket.
+       *)
+      let callback _ =
+	if debug then eprintf "dbus callback\n%!";
+	if Connection.read_write_dispatch bus 0 then true
+	else (				(* Disconnected. *)
+	  connection := None;
+	  false
+	)
+      in
+
+      (* Get the file descriptor and attach to the Gtk main loop. *)
+      let fd = Connection.get_fd bus in
+      let channel = GMain.Io.channel_of_descr fd in
+      let io_id = GMain.Io.add_watch ~cond:[`IN] ~callback channel in
+
+      connection := Some (bus, err, io_id);
+      (bus, err, true)
+
+(* This function is called by the connection dialog and is expected
+ * to return a list of services we know about now.
+ *)
+let find_services () =
+  let bus, err, just_connected = connect () in
+
+  (* If we've just connected, wait briefly for the list to stablise. *)
+  if just_connected then (
+    let start_time = Unix.gettimeofday () in
+    while Unix.gettimeofday () -. start_time < 0.5 do
+      ignore (Connection.read_write_dispatch bus 500)
+    done
+  );
+
+  (* Return the services we know about. *)
+  Hashtbl.fold (fun k v vs -> (k, v) :: vs) services []
+
+;;
+
+Vc_connection_dlg.find_libvirtd_with_zeroconf := find_services