From 385fff7ff4b9fb8e69367dfc11609ca010c2b745 Mon Sep 17 00:00:00 2001 From: Prashanth Mundkur Date: Wed, 29 Jul 2009 15:37:53 -0700 Subject: [PATCH] [dbus_server] restructure properties interface to reduce boilerplate --- common/dbus_server.ml | 284 +++++++++++++++++++++++++++++------------- 1 file changed, 197 insertions(+), 87 deletions(-) diff --git a/common/dbus_server.ml b/common/dbus_server.ml index 9ec7e7b..8337e75 100644 --- a/common/dbus_server.ml +++ b/common/dbus_server.ml @@ -13,6 +13,7 @@ * GNU Lesser General Public License for more details. *) +open Pervasiveext open Stringext module D=Debug.Debugger(struct let name="dbus-server" end) @@ -62,8 +63,9 @@ let dispatch_response resp = (* TODO: handle error messages specially here? *) () -let send_error req err_name err_msg = +let send_error req err_name ?(err_args=[]) err_msg = let err_msg = DBus.Message.new_error req err_name err_msg in + DBus.Message.append err_msg err_args; info "Sending error message..."; dump_msg err_msg; ignore (Dbus_conn.send (Opt.unbox !dbus_conn_ref) err_msg) @@ -73,6 +75,11 @@ let send_msg msg = dump_msg msg; ignore (Dbus_conn.send (Opt.unbox !dbus_conn_ref) msg) +let send_response req args = + let resp = DBus.Message.new_method_return req in + DBus.Message.append resp args; + send_msg resp + (* Signal interface *) type signal_handler = DBus.message -> (* member *) string -> (* path *) string -> unit @@ -103,6 +110,138 @@ let dispatch_signal msg = (* Invalid signal *) () +(* Internal property interface *) + +module Property = struct + (* only scalars supported for now *) + type getter = + | Get_Byte of (unit -> char) + | Get_Bool of (unit -> bool) + | Get_Int16 of (unit -> int) + | Get_UInt16 of (unit -> int) + | Get_Int32 of (unit -> int32) + | Get_UInt32 of (unit -> int32) + | Get_Int64 of (unit -> int64) + | Get_UInt64 of (unit -> int64) + | Get_Double of (unit -> float) + | Get_String of (unit -> string) + | Get_ObjectPath of (unit -> string) + + type setter = + | Set_Byte of (char -> unit) + | Set_Bool of (bool -> unit) + | Set_Int16 of (int -> unit) + | Set_UInt16 of (int -> unit) + | Set_Int32 of (int32 -> unit) + | Set_UInt32 of (int32 -> unit) + | Set_Int64 of (int64 -> unit) + | Set_UInt64 of (int64 -> unit) + | Set_Double of (float -> unit) + | Set_String of (string -> unit) + | Set_ObjectPath of (string -> unit) + + let getter_argtype_str = function + | Get_Byte _ -> "byte" + | Get_Bool _ -> "bool" + | Get_Int16 _ -> "int16" + | Get_UInt16 _ -> "uint16" + | Get_Int32 _ -> "int32" + | Get_UInt32 _ -> "uint32" + | Get_Int64 _ -> "int64" + | Get_UInt64 _ -> "uint64" + | Get_Double _ -> "double" + | Get_String _ -> "string" + | Get_ObjectPath _ -> "objectpath" + + let setter_argtype_str = function + | Set_Byte _ -> "byte" + | Set_Bool _ -> "bool" + | Set_Int16 _ -> "int16" + | Set_UInt16 _ -> "uint16" + | Set_Int32 _ -> "int32" + | Set_UInt32 _ -> "uint32" + | Set_Int64 _ -> "int64" + | Set_UInt64 _ -> "uint64" + | Set_Double _ -> "double" + | Set_String _ -> "string" + | Set_ObjectPath _ -> "objectpath" + + type t = getter * setter + + let separate_errors_rvals results = + let errors, rvals = (List.fold_left + (fun (errors, rvals) r -> + match r with + | Left ((c,m,a) as e) -> (e :: errors), rvals + | Right r -> errors, (r :: rvals) + ) ([],[]) results) + in List.rev errors, List.rev rvals + + let dispatch_get properties pname = + let opt_getter = (try Some (fst (List.assoc pname properties)) + with Not_found -> None) + in match opt_getter with + | Some (Get_Byte f) -> Right (DBus.Byte (f ())) + | Some (Get_Bool f) -> Right (DBus.Bool (f ())) + | Some (Get_Int16 f) -> Right (DBus.Int16 (f ())) + | Some (Get_UInt16 f) -> Right (DBus.UInt16 (f ())) + | Some (Get_Int32 f) -> Right (DBus.Int32 (f ())) + | Some (Get_UInt32 f) -> Right (DBus.UInt32 (f ())) + | Some (Get_Int64 f) -> Right (DBus.Int64 (f ())) + | Some (Get_UInt64 f) -> Right (DBus.UInt64 (f ())) + | Some (Get_Double f) -> Right (DBus.Double (f ())) + | Some (Get_String f) -> Right (DBus.String (f ())) + | Some (Get_ObjectPath f) -> Right (DBus.ObjectPath (f ())) + | None -> + Left (DBus.ERR_INVALID_ARGS, + (Printf.sprintf "Unknown property \"%s\"" pname), + []) + + let dispatch_getall properties pnames = + let results = (try List.map (fun p -> dispatch_get properties p) pnames + with e -> [ Left (DBus.ERR_FAILED, "exception", + [DBus.String (Printexc.to_string e)]) ]) in + let errors, rvals = separate_errors_rvals results + in match errors, rvals with + | _ :: _, _ -> Left errors + | [], _ -> Right rvals + + let dispatch_set properties pname dbus_ty = + let opt_setter = (try Some (snd (List.assoc pname properties)) + with Not_found -> None) + in match opt_setter, dbus_ty with + | Some (Set_Byte f), DBus.Byte v -> f v; Right [] + | Some (Set_Bool f), DBus.Bool v -> f v; Right [] + | Some (Set_Int16 f), DBus.Int16 v -> f v; Right [] + | Some (Set_UInt16 f), DBus.UInt16 v -> f v; Right [] + | Some (Set_Int32 f), DBus.Int32 v -> f v; Right [] + | Some (Set_UInt32 f), DBus.UInt32 v -> f v; Right [] + | Some (Set_Int64 f), DBus.Int64 v -> f v; Right [] + | Some (Set_UInt64 f), DBus.UInt64 v -> f v; Right [] + | Some (Set_Double f), DBus.Double v -> f v; Right [] + | Some (Set_String f), DBus.String v -> f v; Right [] + | Some (Set_ObjectPath f), DBus.ObjectPath v -> f v; Right [] + | Some g, _ -> + Left (DBus.ERR_INVALID_ARGS, "invalid arg(s)", + [ DBus.String ( + Printf.sprintf "Invalid arg for property \"%s\": %s received, %s expected" + pname (DBus.string_of_ty dbus_ty) (setter_argtype_str g) + ) + ]) + | None, _ -> + Left (DBus.ERR_INVALID_ARGS, "Unknown property", + [ DBus.String (Printf.sprintf "Unknown property \"%s\"" pname) ]) + + let dispatch_setall properties pargs = + let results = (try List.map (fun (p, a) -> dispatch_set properties p a) pargs + with e -> [ Left (DBus.ERR_FAILED, "exception", + [DBus.String (Printexc.to_string e)]) ]) in + let errors, rvals = separate_errors_rvals results + in match errors, rvals with + | _ :: _, _ -> Left errors + | [], _ -> Right (List.concat rvals) +end + (* Server interface *) (* The response of a method call can either be sent synchronously @@ -121,11 +260,6 @@ type meth_result = | 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; @@ -133,8 +267,8 @@ type interface = type node = { mutable interfaces : ((* interface name *) string * interface) list; - mutable properties : ((* prop name *) string * property) list; -} + mutable properties : ((* prop name *) string * Property.t) list; +} let apis = ref ([] : ((* node name *) string * node) list) @@ -147,101 +281,77 @@ let remove_node name = debug "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 + match Property.dispatch_getall node.properties props with + | Left ((err_name, err_msg, err_args) :: _) -> + send_error req err_name ~err_args err_msg + | Left [] -> + (* We should always have at least one error in error cases. *) + assert false + | Right rvals -> + send_response req rvals + +let dispatch_setall req node prop_args = + match Property.dispatch_setall node.properties prop_args with + | Left ((err_name, err_msg, err_args) :: _) -> + send_error req err_name ~err_args err_msg + | Left [] -> + (* We should always have at least one error in error cases. *) + assert false + | Right rvals -> + send_response req rvals 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 - ) + let args = DBus.Message.get req in + let to_prop_names args = + let helper acc arg = + match acc, arg with + | Some pnames, DBus.String pname -> Some (pname :: pnames) + | _, _ -> None + in List.fold_left helper (Some []) args in + let to_prop_name_arg_pairs args = + let rec helper acc args = + match acc, args with + | Some pairs, ((DBus.String pname) :: pval :: rest) -> + helper (Some ((pname, pval) :: pairs)) rest + | _, [] -> acc + | _, _ -> None + in helper (Some []) args + in match m with + | "Get" -> + (match to_prop_names args with + | Some [ pname ] -> + dispatch_getall req node [ pname ] | _ -> - send_invalid_property_arg_error () + 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 - ) + (match to_prop_name_arg_pairs args with + | Some [ pname, pval ] -> + dispatch_setall req node [ pname, pval ] | _ -> 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) + (match to_prop_names args with + | Some pnames -> + dispatch_getall req node (List.rev pnames) + | _ -> + send_invalid_property_arg_error () + ) + | "SetAll" -> + (match to_prop_name_arg_pairs args with + | Some pargs -> + dispatch_setall req node (List.rev pargs) + | _ -> + send_invalid_property_arg_error () + ) | _ -> send_unknown_method () - ) let dispatch_interface req node interface m = let send_unknown_method () = -- 2.39.5