--- /dev/null
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@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.
+ *)
+
+open Stringext
+
+(* Utilities *)
+
+let dump_msg m =
+ Opt.iter (fun s -> Printf.printf " Sender: %s\n" s) (DBus.Message.get_sender m);
+ Opt.iter (fun s -> Printf.printf " Destination: %s\n" s) (DBus.Message.get_destination m);
+ Opt.iter (fun s -> Printf.printf " Path: %s\n" s) (DBus.Message.get_path m);
+ Opt.iter (fun s -> Printf.printf " Interface: %s\n" s) (DBus.Message.get_interface m);
+ Opt.iter (fun s -> Printf.printf " Member: %s\n" s) (DBus.Message.get_member m);
+ List.iter (fun arg ->
+ Printf.printf " Arg: %s\n" (DBus.string_of_ty arg)
+ ) (DBus.Message.get m);
+ Printf.printf "%!"
+
+(* Connection *)
+
+let dbus_conn_ref = ref (None : Dbus_conn.t option)
+let set_connection conn =
+ dbus_conn_ref := Some conn
+
+(* Client interface *)
+
+type resp_handler = DBus.message -> unit
+module PendingCalls = Map.Make (struct type t = int32 let compare = compare end)
+
+let pending_calls = ref (PendingCalls.empty : (resp_handler PendingCalls.t))
+
+let send_request msg resp_handler =
+ Printf.printf "Sending request...\n%!";
+ dump_msg msg;
+ let serial = Dbus_conn.send (Opt.unbox !dbus_conn_ref) msg in
+ pending_calls := PendingCalls.add serial resp_handler !pending_calls
+
+let dispatch_response resp =
+ let reply_serial = DBus.Message.get_reply_serial resp in
+ let handler = (try Some (PendingCalls.find reply_serial !pending_calls)
+ with Not_found -> None) in
+ match handler with
+ | Some h ->
+ pending_calls := PendingCalls.remove reply_serial !pending_calls;
+ h resp
+ | None ->
+ (* TODO: handle error messages specially here? *)
+ ()
+
+let send_error req err_name err_msg =
+ let err_msg = DBus.Message.new_error req err_name err_msg in
+ Printf.printf "Sending error message...\n%!";
+ dump_msg err_msg;
+ ignore (Dbus_conn.send (Opt.unbox !dbus_conn_ref) err_msg)
+
+let send_msg msg =
+ Printf.printf "Sending message...\n%!";
+ dump_msg msg;
+ ignore (Dbus_conn.send (Opt.unbox !dbus_conn_ref) msg)
+
+(* Signal interface *)
+
+type signal_handler = DBus.message -> (* member *) string -> (* path *) string -> unit
+type signal_interface = ((* signal name *) string * signal_handler) list
+
+let signal_interfaces = ref ([] : ((* interface name *) string * signal_interface) list)
+
+let register_signal_interface name interface =
+ signal_interfaces := (name, interface) :: !signal_interfaces
+
+let remove_signal_interface name =
+ signal_interfaces := List.filter (fun (n, _) -> n <> name) !signal_interfaces
+
+let dispatch_signal msg =
+ let opt_intf = DBus.Message.get_interface msg in
+ let opt_member = DBus.Message.get_member msg in
+ let opt_path = DBus.Message.get_path msg in
+ match opt_intf, opt_member, opt_path with
+ | Some i, Some m, Some p ->
+ let handler = (try let sig_intf = List.assoc i !signal_interfaces in
+ Some (List.assoc m sig_intf)
+ with Not_found -> None) in
+ (match handler with
+ | None -> ()
+ | Some h -> h msg m p
+ )
+ | _, _, _ ->
+ (* Invalid signal *)
+ ()
+
+(* Server interface *)
+
+(* The response of a method call can either be sent synchronously
+ using Done, or later asynchronously using Pending.
+
+ No state is kept in this module for Pending results; the
+ implementation of the method is responsible to eventually send a
+ response. The message can be sent later either from the main
+ thread using send_msg is usual, or from another thread using
+ async_send_msg. async_send_msg should _not_ be used from the main
+ thread (this will cause a deadlock), and send_msg should _not_ be
+ used from another thread (this is not thread-safe).
+*)
+type meth_result =
+ | Done of DBus.message
+ | Pending
+type meth = DBus.message -> DBus.ty list -> meth_result
+
+(* A return of None indicates a response has been sent by the prop callback. *)
+type prop_getter = DBus.message -> DBus.ty option
+type prop_setter = DBus.message -> DBus.ty -> unit option
+type property = prop_getter * prop_setter
+
+type interface =
+{
+ mutable methods : ((* meth name *) string * meth) list;
+}
+type node =
+{
+ mutable interfaces : ((* interface name *) string * interface) list;
+ mutable properties : ((* prop name *) string * property) list;
+}
+
+let apis = ref ([] : ((* node name *) string * node) list)
+
+let register_node name node =
+ Printf.printf "Registering node \"%s\" ...\n%!" name;
+ apis := (name, node) :: !apis
+
+let remove_node name =
+ (* Remove child nodes as well. *)
+ Printf.printf "Removing node \"%s\" and its children...\n%!" name;
+ apis := List.filter (fun (n, _) -> not (String.startswith name n)) !apis
+
+let dispatch_get req node prop =
+ let rval = (fst prop) req in
+ match rval with
+ | None -> ()
+ | Some v ->
+ let resp = DBus.Message.new_method_return req in
+ DBus.Message.append resp [ v ];
+ send_msg resp
+
+let dispatch_set req node prop to_val =
+ let rval = (snd prop) req to_val in
+ match rval with
+ | None -> ()
+ | Some v ->
+ (* Send an empty Ack message. *)
+ let resp = DBus.Message.new_method_return req in
+ send_msg resp
+
+let dispatch_getall req node props =
+ let pvals, send_resp =
+ List.fold_left (fun ((pvals, send_resp) as acc) prop ->
+ if send_resp then
+ match (fst prop) req with
+ | None -> pvals, false
+ | Some v -> (v :: pvals), true
+ else
+ acc
+ ) ([], true) props
+ in
+ if send_resp then
+ let resp = DBus.Message.new_method_return req in
+ DBus.Message.append resp (List.rev pvals);
+ send_msg resp
+
+let dispatch_property_interface req node m =
+ let send_unknown_property_error pname =
+ send_error req DBus.ERR_FAILED pname in
+ let send_invalid_property_arg_error () =
+ send_error req DBus.ERR_FAILED "Unexpected arg(s)" in
+ let send_unknown_method () =
+ send_error req DBus.ERR_FAILED m in
+ let lookup_prop pname =
+ try Some (List.assoc pname node.properties)
+ with Not_found -> None in
+ let props_helper (sent_error, acc) arg =
+ if sent_error then sent_error, acc
+ else (match arg with
+ | DBus.String pname ->
+ (match lookup_prop pname with
+ | None ->
+ send_unknown_property_error pname;
+ true, []
+ | Some prop ->
+ false, (prop :: acc)
+ )
+ | _ ->
+ send_invalid_property_arg_error ();
+ true, []
+ ) in
+ let lookup_props prop_names =
+ List.fold_left props_helper (false,[]) prop_names
+ in
+ (match m with
+ | "Get" ->
+ (match DBus.Message.get req with
+ | [ DBus.String pname ] ->
+ (match lookup_prop pname with
+ | None ->
+ send_unknown_property_error pname
+ | Some prop ->
+ dispatch_get req node prop
+ )
+ | _ ->
+ send_invalid_property_arg_error ()
+ )
+ | "Set" ->
+ (match DBus.Message.get req with
+ | DBus.String pname :: to_val :: [] ->
+ (match lookup_prop pname with
+ | None ->
+ send_unknown_property_error pname
+ | Some prop ->
+ dispatch_set req node prop to_val
+ )
+ | _ ->
+ send_invalid_property_arg_error ()
+ )
+ | "GetAll" ->
+ let prop_names = DBus.Message.get req in
+ let sent_error, props = lookup_props prop_names in
+ if not sent_error then
+ dispatch_getall req node (List.rev props)
+ | _ ->
+ send_unknown_method ()
+ )
+
+let dispatch_interface req node interface m =
+ let send_unknown_method () =
+ send_error req DBus.ERR_FAILED m in
+ let meth = (try Some (List.assoc m interface.methods)
+ with Not_found -> None) in
+ match meth with
+ | None ->
+ Printf.printf "Unknown method \"%s\" ...\n%!" m;
+ send_unknown_method ()
+ | Some m ->
+ (match m req (DBus.Message.get req) with
+ | Done resp -> send_msg resp
+ | Pending -> ()
+ )
+
+let dispatch_api req n i m =
+ let send_unknown_node_error () =
+ send_error req DBus.ERR_FAILED n in
+ let send_invalid_interface_error () =
+ send_error req DBus.ERR_FAILED i in
+ let opt_node =
+ try Some (List.assoc n !apis)
+ with Not_found -> None in
+ let opt_interface =
+ try (match opt_node with None -> None | Some node -> Some (List.assoc i node.interfaces))
+ with Not_found -> None
+ in
+ match opt_node, i, opt_interface with
+ | None, _, _ ->
+ Printf.printf "Unknown node \"%s\" ...\n%!" n;
+ send_unknown_node_error ()
+ | Some node, "org.freedesktop.DBus.Properties", _ ->
+ dispatch_property_interface req node m
+ | _, _, None ->
+ Printf.printf "Unknown interface \"%s\" for node \"%s\"...\n%!" i n;
+ send_invalid_interface_error ()
+ | Some node, _, Some interface ->
+ dispatch_interface req node interface m
+
+let dispatch_request msg =
+ let node = DBus.Message.get_path msg in
+ let intf = DBus.Message.get_interface msg in
+ let meth = DBus.Message.get_member msg in
+ match node, intf, meth with
+ | _, _, None ->
+ Printf.printf "Missing method\n%!";
+ send_error msg DBus.ERR_INVALID_ARGS "Missing method"
+ | _, None, _ ->
+ Printf.printf "Missing interface\n%!";
+ send_error msg DBus.ERR_INVALID_ARGS "Missing interface"
+ | None, _, _ ->
+ Printf.printf "Missing object\n%!";
+ send_error msg DBus.ERR_INVALID_ARGS "Missing object"
+ | Some n, Some i, Some m ->
+ dispatch_api msg n i m
+
+(* Incoming callbacks from connection *)
+
+let error_callback conn err =
+ Printf.printf "Received error.\n%!"
+
+let msg_received_callback conn m =
+ Printf.printf "Received %s:\n" (DBus.Message.string_of_message_ty (DBus.Message.get_type m));
+ dump_msg m;
+ (match DBus.Message.get_type m with
+ | DBus.Message.Invalid -> ()
+ | DBus.Message.Method_call -> dispatch_request m
+ | DBus.Message.Signal -> dispatch_signal m
+
+ (* Use same handler to process responses as well as errors
+ (which could be responses).
+ *)
+ | DBus.Message.Error
+ | DBus.Message.Method_return -> dispatch_response m
+ )
+
+let init_connection ?use_session_bus:(session=false) el =
+ let callbacks =
+ {
+ Dbus_conn.msg_received_callback = msg_received_callback;
+ Dbus_conn.error_callback = error_callback;
+ } in
+ let bus = DBus.Bus.get (if session then DBus.Bus.Session else DBus.Bus.System) in
+ let conn = Dbus_conn.attach bus el callbacks in
+ set_connection conn;
+ Dbus_conn.enable_recv conn;
+ conn
+
+(* To allow threads to send messages (usually responses)
+ asynchronously on the DBus connection, without sharing the
+ connection across all the possible threads, we use an event
+ channel.
+
+ Threads will need to call 'async_send_msg msg' to post (in a blocking
+ manner) the message to the event channel. The eventloop will
+ monitor the event channel in a non-blocking manner using
+ Event.poll. If any message is retrieved, then it is sent as is on
+ the underlying shared DBus connection.
+*)
+
+let async_message_channel = (Event.new_channel () : DBus.message Event.channel)
+
+(* This blocks the calling thread. Do _not_ use this from the main
+ thread; this will cause deadlock. *)
+let async_send_msg msg =
+ Event.sync (Event.send async_message_channel msg)
+
+let dispatch () =
+ (* Dispatch a completely received message (if any) in the
+ libdbus incoming message queue. If there is more than one
+ such message, then we will dispatch them in subsequent
+ calls. We cannot dispatch them all here since the
+ libdbus API does not provide a way to distinguish a
+ completely received message (which can be dispatched) and
+ an incompletely received message (which cannot be
+ dispatched).
+ *)
+ Dbus_conn.dispatch (Opt.unbox !dbus_conn_ref);
+
+ (* Now, check if we have any messages posted from other
+ threads that we can send now. *)
+ let rec sender () =
+ match Event.poll (Event.receive async_message_channel) with
+ | Some msg ->
+ send_msg msg;
+ (* Check if we have any more to send. *)
+ sender ()
+ | None ->
+ (* We've emptied out the queue, and we're done. *)
+ ()
+ in sender ()
projects / xenclient / toolstack.git / commitdiff