* GNU Lesser General Public License for more details.
*)
+open Pervasiveext
open Stringext
module D=Debug.Debugger(struct let name="dbus-server" end)
(* 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)
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
(* 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
| 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;
-}
+ mutable properties : ((* prop name *) string * Property.t) list;
+}
let apis = ref ([] : ((* node name *) string * node) list)
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 () =
projects / xenclient / toolstack.git / commitdiff