From 374a6eb921a5784f2f3330a4afb8a38bd7d23e51 Mon Sep 17 00:00:00 2001 From: Prashanth Mundkur Date: Tue, 28 Jul 2009 15:10:08 -0700 Subject: [PATCH] [common] add dbus_server utility module --- common/dbus_server.ml | 373 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 373 insertions(+) create mode 100644 common/dbus_server.ml diff --git a/common/dbus_server.ml b/common/dbus_server.ml new file mode 100644 index 0000000..fcabbdf --- /dev/null +++ b/common/dbus_server.ml @@ -0,0 +1,373 @@ +(* + * Copyright (C) 2009 Citrix Ltd. + * Author Prashanth Mundkur + * + * 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 () -- 2.39.5