summaryrefslogtreecommitdiffstats
path: root/virt-ctrl/vc_dbus.ml
diff options
context:
space:
mode:
authorrjones@thinkpad <rjones@thinkpad>2008-04-17 11:13:39 +0100
committerrjones@thinkpad <rjones@thinkpad>2008-04-17 11:13:39 +0100
commit5fb80987ddf0f8af6cd479964f1c5bb8340c7ba8 (patch)
tree6774d8d7c9fb2ec1b6f4b5913636f5e36af1dae2 /virt-ctrl/vc_dbus.ml
parentf9d99e63272520c19bddc9e4b47731d57e5658e2 (diff)
parentf5f45d38269842b591a89ccaf2e6af7879d57aab (diff)
downloadvirt-top-5fb80987ddf0f8af6cd479964f1c5bb8340c7ba8.zip
virt-top-5fb80987ddf0f8af6cd479964f1c5bb8340c7ba8.tar.gz
virt-top-5fb80987ddf0f8af6cd479964f1c5bb8340c7ba8.tar.xz
Merge.
Diffstat (limited to 'virt-ctrl/vc_dbus.ml')
-rw-r--r--virt-ctrl/vc_dbus.ml311
1 files changed, 0 insertions, 311 deletions
diff --git a/virt-ctrl/vc_dbus.ml b/virt-ctrl/vc_dbus.ml
deleted file mode 100644
index 278b1fc..0000000
--- a/virt-ctrl/vc_dbus.ml
+++ /dev/null
@@ -1,311 +0,0 @@
-(* virt-ctrl: A graphical management tool.
- (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
- http://libvirt.org/
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- 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 General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- 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