diff options
Diffstat (limited to 'src/protocol')
47 files changed, 9642 insertions, 0 deletions
diff --git a/src/protocol/dune b/src/protocol/dune new file mode 100644 index 0000000..a7a9ccc --- /dev/null +++ b/src/protocol/dune @@ -0,0 +1,15 @@ +(library + (name obus) + (public_name obus) + (wrapped false) + (synopsis "Pure Ocaml implementation of the D-Bus protocol") + (libraries lwt.unix lwt_log lwt_react xmlm obus.internals) + (preprocess (pps lwt_ppx ppx_obus))) + +(ocamllex oBus_address_lexer oBus_match_rule_lexer) + +(rule + (targets oBus_interfaces.ml oBus_interfaces.mli) + (deps oBus_interfaces.obus) + (action + (run obus-gen-interface -keep-common -o oBus_interfaces %{deps}))) diff --git a/src/protocol/oBus_address.ml b/src/protocol/oBus_address.ml new file mode 100644 index 0000000..4d9f526 --- /dev/null +++ b/src/protocol/oBus_address.ml @@ -0,0 +1,135 @@ +(* + * oBus_address.ml + * --------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(address)" + +(* +-----------------------------------------------------------------+ + | Types | + +-----------------------------------------------------------------+ *) + +type guid = OBus_uuid.t + +type t = { + name : string; + args : (string * string) list; +} + +let name a = a.name +let args a = a.args + +let make ~name ~args = { name = name; args = args } + +let arg arg address = + OBus_util.assoc arg address.args + +let guid address = + match OBus_util.assoc "guid" address.args with + | Some guid -> Some(OBus_uuid.of_string guid) + | None -> None + +(* +-----------------------------------------------------------------+ + | Parsing/marshaling | + +-----------------------------------------------------------------+ *) + +exception Parse_failure of string * int * string + +let () = + Printexc.register_printer + (function + | Parse_failure(str, pos, msg) -> + Some(Printf.sprintf "failed to parse D-Bus addresses %S, at position %d: %s" str pos msg) + | _ -> + None) + +let of_string str = + try + List.map + (fun (name, args) -> { name = name; args = args }) + (OBus_address_lexer.addresses (Lexing.from_string str)) + with OBus_address_lexer.Fail(pos, msg) -> + raise (Parse_failure(str, pos, msg)) + +let to_string l = + let buf = Buffer.create 42 in + let escape = String.iter begin fun ch -> match ch with + | '0'..'9' | 'A'..'Z' | 'a'..'z' + | '_' | '-' | '/' | '.' | '\\' -> + Buffer.add_char buf ch + | _ -> + Printf.bprintf buf "%%%02x" (Char.code ch) + end in + let concat ch f = function + | [] -> () + | x :: l -> f x; List.iter (fun x -> Buffer.add_char buf ch; f x) l + in + concat ';' begin fun { name = name; args = args } -> + Buffer.add_string buf name; + Buffer.add_char buf ':'; + concat ',' + (fun (k, v) -> + Buffer.add_string buf k; + Buffer.add_char buf '='; + escape v) + args + end l; + Buffer.contents buf + +(* +-----------------------------------------------------------------+ + | Well known addresses | + +-----------------------------------------------------------------+ *) + +let system_bus_variable = "DBUS_SYSTEM_BUS_ADDRESS" +let session_bus_variable = "DBUS_SESSION_BUS_ADDRESS" +let xdg_runtime_dir_variable = "XDG_RUNTIME_DIR" + +let default_system = [{ name = "unix"; args = [("path", "/var/run/dbus/system_bus_socket")] }] +let default_session = [{ name = "autolaunch"; args = [] }] + +let system = lazy( + match try Some (Sys.getenv system_bus_variable) with Not_found -> None with + | Some str -> + Lwt.return (of_string str) + | None -> + let%lwt () = Lwt_log.info_f ~section "environment variable %s not found, using internal default" system_bus_variable in + Lwt.return default_system +) + +let xdg_fallback_session () = + match try Some (Sys.getenv xdg_runtime_dir_variable) with | Not_found -> None with + | None -> + Lwt.return_none + | Some path -> + Lwt.catch (fun () -> + let sock_path = Filename.concat path "bus" in + let%lwt stat = Lwt_unix.stat sock_path in + let uid = Unix.getuid () in + if stat.st_uid = uid && stat.st_kind = Lwt_unix.S_SOCK + then Lwt.return_some [{ name = "unix"; args = [("path", sock_path)] }] + else Lwt.return_none) + (fun _ -> Lwt.return_none) + +let session = lazy( + match try Some(Sys.getenv session_bus_variable) with Not_found -> None with + | Some line -> + Lwt.return (of_string line) + | None -> + let%lwt () = Lwt_log.info_f ~section "environment variable %s not found, trying XDG_RUNTIME_DIR/bus" session_bus_variable in + let%lwt xdg_session = xdg_fallback_session () in + match xdg_session with + | Some session -> + Lwt.return session + | None -> + let%lwt () = Lwt_log.info_f ~section "failed to connect to %s/bus, trying to get session bus address from launchd" xdg_runtime_dir_variable in + try%lwt + let%lwt path = Lwt_process.pread_line ("launchctl", [|"launchctl"; "getenv"; "DBUS_LAUNCHD_SESSION_BUS_SOCKET"|]) in + Lwt.return [{ name = "unix"; args = [("path", path)] }] + with exn -> + let%lwt () = Lwt_log.info_f ~exn ~section "failed to get session bus address from launchd, using internal default" in + Lwt.return default_session +) diff --git a/src/protocol/oBus_address.mli b/src/protocol/oBus_address.mli new file mode 100644 index 0000000..9062b07 --- /dev/null +++ b/src/protocol/oBus_address.mli @@ -0,0 +1,71 @@ +(* + * oBus_address.mli + * ---------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Manipulation of D-Bus addresses *) + +(** {6 Types} *) + +type guid = OBus_uuid.t + (** A unique address identifier. Each server's listening address + has a unique one. *) + +(** Type of an address *) +type t = { + name : string; + (** The transport name *) + + args : (string * string) list; + (** Arguments of the address *) +} + +val name : t -> string + (** [name] projection *) + +val args : t -> (string * string) list + (** [args] Projection *) + +val make : name : string -> args : (string * string) list -> t + (** Creates an address *) + +val arg : string -> t -> string option + (** [arg key address] returns the value of argument [key], if any *) + +val guid : t -> guid option + (** Returns the address guid, if any *) + +(** {6 To/from string conversion} *) + +exception Parse_failure of string * int * string + (** [Parse_failure(string, position, reason)] exception raised when + parsing a string failed. *) + +val of_string : string -> t list + (** [of_string str] parse [str] and return the list of addresses + defined in it. + + @raise Parse_failure if the string contains an invalid address + *) + +val to_string : t list -> string + (** [to_string addresses] return a string representation of a list + of addresses *) + +(** {6 Well-known addresses} *) + +val system : t list Lwt.t Lazy.t + (** The list of addresses for system bus *) + +val session : t list Lwt.t Lazy.t + (** The list of addresses for session bus *) + +val default_system : t list + (** The default addresses for the system bus *) + +val default_session : t list + (** The default addresses for the session bus *) diff --git a/src/protocol/oBus_address_lexer.mll b/src/protocol/oBus_address_lexer.mll new file mode 100644 index 0000000..db0a666 --- /dev/null +++ b/src/protocol/oBus_address_lexer.mll @@ -0,0 +1,106 @@ +(* + * oBus_address_lexer.mll + * ---------------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +{ + exception Fail of int * string + + let pos lexbuf = lexbuf.Lexing.lex_start_p.Lexing.pos_cnum + + let fail lexbuf fmt = + Printf.ksprintf + (fun msg -> raise (Fail(pos lexbuf, msg))) + fmt +} + +let name = [^ ':' ',' ';' '=']+ + +rule addresses = parse + | eof { [] } + | "" { address_plus lexbuf } + +and address_plus = parse + | name as name { + check_colon lexbuf; + let parameters = parameters lexbuf in + if semi_colon lexbuf then + (name, parameters) :: address_plus lexbuf + else begin + check_eof lexbuf; + [(name, parameters)] + end + } + | ":" { + fail lexbuf "empty transport name" + } + | eof { + fail lexbuf "address expected" + } + +and semi_colon = parse + | ";" { true } + | "" { false } + +and check_eof = parse + | eof { () } + | _ as ch { fail lexbuf "invalid character %C" ch } + +and check_colon = parse + | ":" { () } + | "" { fail lexbuf "colon expected after transport name" } + +and parameters = parse + | name as key { + check_equal lexbuf; + let value = value (Buffer.create 42) lexbuf in + if coma lexbuf then + (key, value) :: parameters_plus lexbuf + else + [(key, value)] + } + | "=" { fail lexbuf "empty key" } + | "" { [] } + +and parameters_plus = parse + | name as key { + check_equal lexbuf; + let value = value (Buffer.create 42) lexbuf in + if coma lexbuf then + (key, value) :: parameters_plus lexbuf + else + [(key, value)] + } + | "=" { fail lexbuf "empty key" } + | "" { fail lexbuf "parameter expected" } + +and coma = parse + | "," { true } + | "" { false } + +and check_equal = parse + | "=" { () } + | "" { fail lexbuf "equal expected after key" } + +and value buf = parse + | [ '0'-'9' 'A'-'Z' 'a'-'z' '_' '-' '/' '.' '\\' ] as ch { + Buffer.add_char buf ch; + value buf lexbuf + } + | "%" { + Buffer.add_string buf (unescape lexbuf); + value buf lexbuf + } + | "" { + Buffer.contents buf + } + +and unescape = parse + | [ '0'-'9' 'a'-'f' 'A'-'F' ] [ '0'-'9' 'a'-'f' 'A'-'F' ] as str + { OBus_util.hex_decode str } + | "" + { failwith "two hexdigits expected after '%'" } diff --git a/src/protocol/oBus_auth.ml b/src/protocol/oBus_auth.ml new file mode 100644 index 0000000..1bce780 --- /dev/null +++ b/src/protocol/oBus_auth.ml @@ -0,0 +1,856 @@ +(* + * oBus_auth.ml + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(auth)" + +open Printf +open Lwt.Infix + +type capability = [ `Unix_fd ] + +let capabilities = [`Unix_fd] + +(* Maximum line length, if line greated are received, authentication + will fail *) +let max_line_length = 42 * 1024 + +(* Maximum number of reject, if a client is rejected more than that, + authentication will fail *) +let max_reject = 42 + +exception Auth_failure of string +let auth_failure fmt = ksprintf (fun msg -> Lwt.fail (Auth_failure msg)) fmt + +let () = + Printexc.register_printer + (function + | Auth_failure msg -> + Some(Printf.sprintf "D-Bus authentication failed: %s" msg) + | _ -> + None) + +let hex_encode = OBus_util.hex_encode +let hex_decode str = + try + OBus_util.hex_decode str + with + | Invalid_argument _ -> failwith "invalid hex-encoded data" + +type data = string + +type client_command = + | Client_auth of (string * data option) option + | Client_cancel + | Client_begin + | Client_data of data + | Client_error of string + | Client_negotiate_unix_fd + +type server_command = + | Server_rejected of string list + | Server_ok of OBus_address.guid + | Server_data of data + | Server_error of string + | Server_agree_unix_fd + +(* +-----------------------------------------------------------------+ + | Keyring for the SHA-1 method | + +-----------------------------------------------------------------+ *) + +module Cookie = +struct + type t = { + id : int32; + time : int64; + cookie : string; + } + + let id c = c.id + let time c = c.time + let cookie c = c.cookie +end + +module Keyring : sig + + type context = string + (** A context for the SHA-1 method *) + + val load : context -> Cookie.t list Lwt.t + (** [load context] load all cookies for context [context] *) + + val save : context -> Cookie.t list -> unit Lwt.t + (** [save context cookies] save all cookies with context + [context] *) +end = struct + + type context = string + + let keyring_directory = lazy( + let%lwt homedir = Lazy.force OBus_util.homedir in + Lwt.return (Filename.concat homedir ".dbus-keyrings") + ) + + let keyring_file_name context = + let%lwt dir = Lazy.force keyring_directory in + Lwt.return (Filename.concat dir context) + + let parse_line line = + Scanf.sscanf line "%ld %Ld %[a-fA-F0-9]" + (fun id time cookie -> { Cookie.id = id; + Cookie.time = time; + Cookie.cookie = cookie }) + + let print_line cookie = + sprintf "%ld %Ld %s" (Cookie.id cookie) (Cookie.time cookie) (Cookie.cookie cookie) + + let load context = + let%lwt fname = keyring_file_name context in + if Sys.file_exists fname then + try%lwt + Lwt_stream.get_while (fun _ -> true) (Lwt_stream.map parse_line (Lwt_io.lines_of_file fname)) + with exn -> + let%lwt fname = keyring_file_name context in + let%lwt () = Lwt_log.error_f ~exn ~section "failed to load cookie file %s" fname in + Lwt.fail exn + else + Lwt.return [] + + let lock_file fname = + let really_lock () = + Lwt_unix.openfile fname + [Unix.O_WRONLY; + Unix.O_EXCL; + Unix.O_CREAT] 0o600 + >>= Lwt_unix.close + in + let rec aux = function + | 0 -> + let%lwt () = + try%lwt + let%lwt () = Lwt_unix.unlink fname in + Lwt_log.info_f ~section "stale lock file %s removed" fname + with Unix.Unix_error(error, _, _) as exn -> + let%lwt () = Lwt_log.error_f ~section "failed to remove stale lock file %s: %s" fname (Unix.error_message error) in + Lwt.fail exn + in + (try%lwt + really_lock () + with Unix.Unix_error(error, _, _) as exn -> + let%lwt () = Lwt_log.error_f ~section "failed to lock file %s after removing it: %s" fname (Unix.error_message error) in + Lwt.fail exn) + | n -> + try%lwt + really_lock () + with exn -> + let%lwt () = Lwt_log.info_f ~section "waiting for lock file (%d) %s" n fname in + let%lwt () = Lwt_unix.sleep 0.250 in + aux (n - 1) + in + aux 32 + + let unlock_file fname = + try%lwt + Lwt_unix.unlink fname + with Unix.Unix_error(error, _, _) as exn -> + let%lwt () = Lwt_log.error_f ~section "failed to unlink file %s: %s" fname (Unix.error_message error) in + Lwt.fail exn + + let save context cookies = + let%lwt fname = keyring_file_name context in + let tmp_fname = fname ^ "." ^ hex_encode (OBus_util.random_string 8) in + let lock_fname = fname ^ ".lock" in + let%lwt dir = Lazy.force keyring_directory in + let%lwt () = + (* Check that the keyring directory exists, or create it *) + if not (Sys.file_exists dir) then begin + try%lwt + Lwt_unix.mkdir dir 0o700 + with Unix.Unix_error(error, _, _) as exn -> + let%lwt () = Lwt_log.error_f ~section "failed to create directory %s with permissions 0600: %s" dir (Unix.error_message error) in + Lwt.fail exn + end else + Lwt.return () + in + let%lwt () = lock_file lock_fname in begin + let%lwt () = + try%lwt + Lwt_io.lines_to_file tmp_fname (Lwt_stream.map print_line (Lwt_stream.of_list cookies)) + with exn -> + let%lwt () = Lwt_log.error_f ~exn ~section "unable to write temporary keyring file %s" tmp_fname in + Lwt.fail exn + in + try + Lwt_unix.rename tmp_fname fname + with Unix.Unix_error(error, _, _) as exn -> + let%lwt () = Lwt_log.error_f ~section "unable to rename file %s to %s: %s" tmp_fname fname (Unix.error_message error) in + Lwt.fail exn + end + [%lwt.finally + unlock_file lock_fname] +end + +(* +-----------------------------------------------------------------+ + | Communication | + +-----------------------------------------------------------------+ *) + +type stream = { + recv : unit -> string Lwt.t; + send : string -> unit Lwt.t; +} + +let make_stream ~recv ~send = { + recv = (fun () -> + try%lwt + recv () + with + | Auth_failure _ as exn -> + Lwt.fail exn + | End_of_file -> + Lwt.fail (Auth_failure("input: premature end of input")) + | exn -> + Lwt.fail (Auth_failure("input: " ^ Printexc.to_string exn))); + send = (fun line -> + try%lwt + send line + with + | Auth_failure _ as exn -> + Lwt.fail exn + | exn -> + Lwt.fail (Auth_failure("output: " ^ Printexc.to_string exn))); +} + +let stream_of_channels (ic, oc) = + make_stream + ~recv:(fun () -> + let buf = Buffer.create 42 in + let rec loop last = + if Buffer.length buf > max_line_length then + Lwt.fail (Auth_failure "input: line too long") + else + Lwt_io.read_char_opt ic >>= function + | None -> + Lwt.fail (Auth_failure "input: premature end of input") + | Some ch -> + Buffer.add_char buf ch; + if last = '\r' && ch = '\n' then + Lwt.return (Buffer.contents buf) + else + loop ch + in + loop '\x00') + ~send:(fun line -> + let%lwt () = Lwt_io.write oc line in + Lwt_io.flush oc) + +let stream_of_fd fd = + make_stream + ~recv:(fun () -> + let buf = Buffer.create 42 and tmp = Bytes.create 1 in + let rec loop last = + if Buffer.length buf > max_line_length then + Lwt.fail (Auth_failure "input: line too long") + else + Lwt_unix.read fd tmp 0 1 >>= function + | 0 -> + Lwt.fail (Auth_failure "input: premature end of input") + | 1 -> + let ch = Bytes.get tmp 0 in + Buffer.add_char buf ch; + if last = '\r' && ch = '\n' then + Lwt.return (Buffer.contents buf) + else + loop ch + | n -> + assert false + in + loop '\x00') + ~send:(fun line -> + let rec loop ofs len = + if len = 0 then + Lwt.return () + else + Lwt_unix.write_string fd line ofs len >>= function + | 0 -> + Lwt.fail (Auth_failure "output: zero byte written") + | n -> + assert (n > 0 && n <= len); + loop (ofs + n) (len - n) + in + loop 0 (String.length line)) + +let send_line mode stream line = + ignore (Lwt_log.debug_f ~section "%s: sending: %S" mode line); + stream.send (line ^ "\r\n") + +let rec recv_line stream = + let%lwt line = stream.recv () in + let len = String.length line in + if len < 2 || not (line.[len - 2] = '\r' && line.[len - 1] = '\n') then + Lwt.fail (Auth_failure("input: invalid line received")) + else + Lwt.return (String.sub line 0 (len - 2)) + +let rec first f str pos = + if pos = String.length str then + pos + else match f str.[pos] with + | true -> pos + | false -> first f str (pos + 1) + +let rec last f str pos = + if pos = 0 then + pos + else match f str.[pos - 1] with + | true -> pos + | false -> first f str (pos - 1) + +let blank ch = ch = ' ' || ch = '\t' +let not_blank ch = not (blank ch) + +let sub_strip str i j = + let i = first not_blank str i in + let j = last not_blank str j in + if i < j then String.sub str i (j - i) else "" + +let split str = + let rec aux i = + let i = first not_blank str i in + if i = String.length str then + [] + else + let j = first blank str i in + String.sub str i (j - i) :: aux j + in + aux 0 + +let preprocess_line line = + (* Check for ascii-only *) + String.iter (function + | '\x01'..'\x7f' -> () + | _ -> failwith "non-ascii characters in command") line; + (* Extract the command *) + let i = first blank line 0 in + if i = 0 then failwith "empty command"; + (String.sub line 0 i, sub_strip line i (String.length line)) + +let rec recv mode command_parser stream = + let%lwt line = recv_line stream in + let%lwt () = Lwt_log.debug_f ~section "%s: received: %S" mode line in + + (* If a parse failure occur, return an error and try again *) + match + try + let command, args = preprocess_line line in + `Success(command_parser command args) + with exn -> + `Failure(exn) + with + | `Success x -> Lwt.return x + | `Failure(Failure msg) -> + let%lwt () = send_line mode stream ("ERROR \"" ^ msg ^ "\"") in + recv mode command_parser stream + | `Failure exn -> Lwt.fail exn + +let client_recv = recv "client" + (fun command args -> match command with + | "REJECTED" -> Server_rejected (split args) + | "OK" -> Server_ok(try OBus_uuid.of_string args with _ -> failwith "invalid hex-encoded guid") + | "DATA" -> Server_data(hex_decode args) + | "ERROR" -> Server_error args + | "AGREE_UNIX_FD" -> Server_agree_unix_fd + | _ -> failwith "invalid command") + +let server_recv = recv "server" + (fun command args -> match command with + | "AUTH" -> Client_auth(match split args with + | [] -> None + | [mech] -> Some(mech, None) + | [mech; data] -> Some(mech, Some(hex_decode data)) + | _ -> failwith "too many arguments") + | "CANCEL" -> Client_cancel + | "BEGIN" -> Client_begin + | "DATA" -> Client_data(hex_decode args) + | "ERROR" -> Client_error args + | "NEGOTIATE_UNIX_FD" -> Client_negotiate_unix_fd + | _ -> failwith "invalid command") + +let client_send chans cmd = send_line "client" chans + (match cmd with + | Client_auth None -> "AUTH" + | Client_auth(Some(mechanism, None)) -> sprintf "AUTH %s" mechanism + | Client_auth(Some(mechanism, Some data)) -> sprintf "AUTH %s %s" mechanism (hex_encode data) + | Client_cancel -> "CANCEL" + | Client_begin -> "BEGIN" + | Client_data data -> sprintf "DATA %s" (hex_encode data) + | Client_error msg -> sprintf "ERROR \"%s\"" msg + | Client_negotiate_unix_fd -> "NEGOTIATE_UNIX_FD") + +let server_send chans cmd = send_line "server" chans + (match cmd with + | Server_rejected mechs -> String.concat " " ("REJECTED" :: mechs) + | Server_ok guid -> sprintf "OK %s" (OBus_uuid.to_string guid) + | Server_data data -> sprintf "DATA %s" (hex_encode data) + | Server_error msg -> sprintf "ERROR \"%s\"" msg + | Server_agree_unix_fd -> "AGREE_UNIX_FD") + +(* +-----------------------------------------------------------------+ + | Client side authentication | + +-----------------------------------------------------------------+ *) + +module Client = +struct + + type mechanism_return = + | Mech_continue of data + | Mech_ok of data + | Mech_error of string + + class virtual mechanism_handler = object + method virtual init : mechanism_return Lwt.t + method data (chall : data) = Lwt.return (Mech_error("no data expected for this mechanism")) + method abort = () + end + + type mechanism = { + mech_name : string; + mech_exec : unit -> mechanism_handler; + } + + let mech_name m = m.mech_name + let mech_exec m = m.mech_exec + + (* +---------------------------------------------------------------+ + | Predefined client mechanisms | + +---------------------------------------------------------------+ *) + + class mech_external_handler = object + inherit mechanism_handler + method init = Lwt.return (Mech_ok(string_of_int (Unix.getuid ()))) + end + + class mech_anonymous_handler = object + inherit mechanism_handler + method init = Lwt.return (Mech_ok("obus " ^ OBus_info.version)) + end + + class mech_dbus_cookie_sha1_handler = object + method init = Lwt.return (Mech_continue(string_of_int (Unix.getuid ()))) + method data chal = + let%lwt () = Lwt_log.debug_f ~section "client: dbus_cookie_sha1: chal: %s" chal in + let context, id, chal = Scanf.sscanf chal "%[^/\\ \n\r.] %ld %[a-fA-F0-9]%!" (fun context id chal -> (context, id, chal)) in + let%lwt keyring = Keyring.load context in + let cookie = + try + List.find (fun cookie -> cookie.Cookie.id = id) keyring + with Not_found -> + ksprintf failwith "cookie %ld not found in context %S" id context + in + let rand = hex_encode (OBus_util.random_string 16) in + let resp = sprintf "%s %s" rand (hex_encode (OBus_util.sha_1 (sprintf "%s:%s:%s" chal rand cookie.Cookie.cookie))) in + let%lwt () = Lwt_log.debug_f ~section "client: dbus_cookie_sha1: resp: %s" resp in + Lwt.return (Mech_ok resp) + method abort = () + end + + let mech_external = { + mech_name = "EXTERNAL"; + mech_exec = (fun () -> new mech_external_handler); + } + let mech_anonymous = { + mech_name = "ANONYMOUS"; + mech_exec = (fun () -> new mech_anonymous_handler); + } + let mech_dbus_cookie_sha1 = { + mech_name = "DBUS_COOKIE_SHA1"; + mech_exec = (fun () -> new mech_dbus_cookie_sha1_handler); + } + + let default_mechanisms = [mech_external; + mech_dbus_cookie_sha1; + mech_anonymous] + + (* +---------------------------------------------------------------+ + | Client-side protocol | + +---------------------------------------------------------------+ *) + + type state = + | Waiting_for_data of mechanism_handler + | Waiting_for_ok + | Waiting_for_reject + + type transition = + | Transition of client_command * state * mechanism list + | Success of OBus_address.guid + | Failure + + (* Try to find a mechanism that can be initialised *) + let find_working_mech implemented_mechanisms available_mechanisms = + let rec aux = function + | [] -> + Lwt.return Failure + | { mech_name = name; mech_exec = f } :: mechs -> + match available_mechanisms with + | Some l when not (List.mem name l) -> + aux mechs + | _ -> + let mech = f () in + try%lwt + mech#init >>= function + | Mech_continue resp -> + Lwt.return (Transition(Client_auth(Some (name, Some resp)), + Waiting_for_data mech, + mechs)) + | Mech_ok resp -> + Lwt.return (Transition(Client_auth(Some (name, Some resp)), + Waiting_for_ok, + mechs)) + | Mech_error msg -> + aux mechs + with exn -> + aux mechs + in + aux implemented_mechanisms + + let initial mechs = find_working_mech mechs None + let next mechs available = find_working_mech mechs (Some available) + + let transition mechs state cmd = match state with + | Waiting_for_data mech -> begin match cmd with + | Server_data chal -> + begin + try%lwt + mech#data chal >>= function + | Mech_continue resp -> + Lwt.return (Transition(Client_data resp, + Waiting_for_data mech, + mechs)) + | Mech_ok resp -> + Lwt.return (Transition(Client_data resp, + Waiting_for_ok, + mechs)) + | Mech_error msg -> + Lwt.return (Transition(Client_error msg, + Waiting_for_data mech, + mechs)) + with exn -> + Lwt.return (Transition(Client_error(Printexc.to_string exn), + Waiting_for_data mech, + mechs)) + end + | Server_rejected am -> + mech#abort; + next mechs am + | Server_error _ -> + mech#abort; + Lwt.return (Transition(Client_cancel, + Waiting_for_reject, + mechs)) + | Server_ok guid -> + mech#abort; + Lwt.return (Success guid) + | Server_agree_unix_fd -> + mech#abort; + Lwt.return (Transition(Client_error "command not expected here", + Waiting_for_data mech, + mechs)) + end + + | Waiting_for_ok -> begin match cmd with + | Server_ok guid -> + Lwt.return (Success guid) + | Server_rejected am -> + next mechs am + | Server_data _ + | Server_error _ -> + Lwt.return (Transition(Client_cancel, + Waiting_for_reject, + mechs)) + | Server_agree_unix_fd -> + Lwt.return (Transition(Client_error "command not expected here", + Waiting_for_ok, + mechs)) + end + + | Waiting_for_reject -> begin match cmd with + | Server_rejected am -> next mechs am + | _ -> Lwt.return Failure + end + + let authenticate ?(capabilities=[]) ?(mechanisms=default_mechanisms) ~stream () = + let rec loop = function + | Transition(cmd, state, mechs) -> + let%lwt () = client_send stream cmd in + let%lwt cmd = client_recv stream in + transition mechs state cmd >>= loop + | Success guid -> + let%lwt caps = + if List.mem `Unix_fd capabilities then + let%lwt () = client_send stream Client_negotiate_unix_fd in + client_recv stream >>= function + | Server_agree_unix_fd -> + Lwt.return [`Unix_fd] + | Server_error _ -> + Lwt.return [] + | _ -> + (* This case is not covered by the + specification *) + Lwt.return [] + else + Lwt.return [] + in + let%lwt () = client_send stream Client_begin in + Lwt.return (guid, caps) + | Failure -> + auth_failure "authentication failure" + in + initial mechanisms >>= loop +end + +(* +-----------------------------------------------------------------+ + | Server-side authentication | + +-----------------------------------------------------------------+ *) + +module Server = +struct + + type mechanism_return = + | Mech_continue of data + | Mech_ok of int option + | Mech_reject + + class virtual mechanism_handler = object + method init = Lwt.return (None : data option) + method virtual data : data -> mechanism_return Lwt.t + method abort = () + end + + type mechanism = { + mech_name : string; + mech_exec : int option -> mechanism_handler; + } + + let mech_name m = m.mech_name + let mech_exec m = m.mech_exec + + (* +---------------------------------------------------------------+ + | Predefined server mechanisms | + +---------------------------------------------------------------+ *) + + class mech_external_handler user_id = object + inherit mechanism_handler + method data data = + match user_id, try Some(int_of_string data) with _ -> None with + | Some user_id, Some user_id' when user_id = user_id' -> + Lwt.return (Mech_ok(Some user_id)) + | _ -> + Lwt.return Mech_reject + end + + class mech_anonymous_handler = object + inherit mechanism_handler + method data _ = Lwt.return (Mech_ok None) + end + + class mech_dbus_cookie_sha1_handler = object + inherit mechanism_handler + + val context = "org_freedesktop_general" + val mutable state = `State1 + val mutable user_id = None + + method data resp = + try%lwt + let%lwt () = Lwt_log.debug_f ~section "server: dbus_cookie_sha1: resp: %s" resp in + match state with + | `State1 -> + user_id <- (try Some(int_of_string resp) with _ -> None); + let%lwt keyring = Keyring.load context in + let cur_time = Int64.of_float (Unix.time ()) in + (* Filter old and future keys *) + let keyring = List.filter (fun { Cookie.time = time } -> time <= cur_time && Int64.sub cur_time time <= 300L) keyring in + (* Find a working cookie *) + let%lwt id, cookie = match keyring with + | { Cookie.id = id; Cookie.cookie = cookie } :: _ -> + (* There is still valid cookies, just choose one *) + Lwt.return (id, cookie) + | [] -> + (* No one left, generate a new one *) + let id = Int32.abs (OBus_util.random_int32 ()) in + let cookie = hex_encode (OBus_util.random_string 24) in + let%lwt () = Keyring.save context [{ Cookie.id = id; Cookie.time = cur_time; Cookie.cookie = cookie }] in + Lwt.return (id, cookie) + in + let rand = hex_encode (OBus_util.random_string 16) in + let chal = sprintf "%s %ld %s" context id rand in + let%lwt () = Lwt_log.debug_f ~section "server: dbus_cookie_sha1: chal: %s" chal in + state <- `State2(cookie, rand); + Lwt.return (Mech_continue chal) + + | `State2(cookie, my_rand) -> + Scanf.sscanf resp "%s %s" + (fun its_rand comp_sha1 -> + if OBus_util.sha_1 (sprintf "%s:%s:%s" my_rand its_rand cookie) = hex_decode comp_sha1 then + Lwt.return (Mech_ok user_id) + else + Lwt.return Mech_reject) + + with _ -> + Lwt.return Mech_reject + + method abort = () + end + + let mech_anonymous = { + mech_name = "ANONYMOUS"; + mech_exec = (fun uid -> new mech_anonymous_handler); + } + let mech_external = { + mech_name = "EXTERNAL"; + mech_exec = (fun uid -> new mech_external_handler uid); + } + let mech_dbus_cookie_sha1 = { + mech_name = "DBUS_COOKIE_SHA1"; + mech_exec = (fun uid -> new mech_dbus_cookie_sha1_handler); + } + + let default_mechanisms = [mech_external; + mech_dbus_cookie_sha1; + mech_anonymous] + + (* +---------------------------------------------------------------+ + | Server-side protocol | + +---------------------------------------------------------------+ *) + + type state = + | Waiting_for_auth + | Waiting_for_data of mechanism_handler + | Waiting_for_begin of int option * capability list + + type server_machine_transition = + | Transition of server_command * state + | Accept of int option * capability list + | Failure + + let reject mechs = + Lwt.return (Transition(Server_rejected (List.map mech_name mechs), + Waiting_for_auth)) + + let error msg = + Lwt.return (Transition(Server_error msg, + Waiting_for_auth)) + + let transition user_id guid capabilities mechs state cmd = match state with + | Waiting_for_auth -> begin match cmd with + | Client_auth None -> + reject mechs + | Client_auth(Some(name, resp)) -> + begin match OBus_util.find_map (fun m -> if m.mech_name = name then Some m.mech_exec else None) mechs with + | None -> + reject mechs + | Some f -> + let mech = f user_id in + try%lwt + let%lwt init = mech#init in + match init, resp with + | None, None -> + Lwt.return (Transition(Server_data "", + Waiting_for_data mech)) + | Some chal, None -> + Lwt.return (Transition(Server_data chal, + Waiting_for_data mech)) + | Some chal, Some rest -> + reject mechs + | None, Some resp -> + mech#data resp >>= function + | Mech_continue chal -> + Lwt.return (Transition(Server_data chal, + Waiting_for_data mech)) + | Mech_ok uid -> + Lwt.return (Transition(Server_ok guid, + Waiting_for_begin(uid, []))) + | Mech_reject -> + reject mechs + with exn -> + reject mechs + end + | Client_begin -> Lwt.return Failure + | Client_error msg -> reject mechs + | _ -> error "AUTH command expected" + end + + | Waiting_for_data mech -> begin match cmd with + | Client_data "" -> + Lwt.return (Transition(Server_data "", + Waiting_for_data mech)) + | Client_data resp -> begin + try%lwt + mech#data resp >>= function + | Mech_continue chal -> + Lwt.return (Transition(Server_data chal, + Waiting_for_data mech)) + | Mech_ok uid -> + Lwt.return (Transition(Server_ok guid, + Waiting_for_begin(uid, []))) + | Mech_reject -> + reject mechs + with exn -> + reject mechs + end + | Client_begin -> mech#abort; Lwt.return Failure + | Client_cancel -> mech#abort; reject mechs + | Client_error _ -> mech#abort; reject mechs + | _ -> mech#abort; error "DATA command expected" + end + + | Waiting_for_begin(uid, caps) -> begin match cmd with + | Client_begin -> + Lwt.return (Accept(uid, caps)) + | Client_cancel -> + reject mechs + | Client_error _ -> + reject mechs + | Client_negotiate_unix_fd -> + if List.mem `Unix_fd capabilities then + Lwt.return(Transition(Server_agree_unix_fd, + Waiting_for_begin(uid, + if List.mem `Unix_fd caps then + caps + else + `Unix_fd :: caps))) + else + Lwt.return(Transition(Server_error "Unix fd passing is not supported by this server", + Waiting_for_begin(uid, caps))) + | _ -> + error "BEGIN command expected" + end + + let authenticate ?(capabilities=[]) ?(mechanisms=default_mechanisms) ?user_id ~guid ~stream () = + let rec loop state count = + let%lwt cmd = server_recv stream in + transition user_id guid capabilities mechanisms state cmd >>= function + | Transition(cmd, state) -> + let count = + match cmd with + | Server_rejected _ -> count + 1 + | _ -> count + in + (* Specification do not specify a limit for rejected, so + we choose one arbitrary *) + if count >= max_reject then + auth_failure "too many reject" + else + let%lwt () = server_send stream cmd in + loop state count + | Accept(uid, caps) -> + Lwt.return (uid, caps) + | Failure -> + auth_failure "authentication failure" + in + loop Waiting_for_auth 0 +end diff --git a/src/protocol/oBus_auth.mli b/src/protocol/oBus_auth.mli new file mode 100644 index 0000000..9aa297c --- /dev/null +++ b/src/protocol/oBus_auth.mli @@ -0,0 +1,186 @@ +(* + * oBus_auth.mli + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Handle authentication mechanisms *) + +type data = string + (** Data for an authentication mechanism *) + +exception Auth_failure of string + (** Exception raised when authentication fail *) + +(** List of capabilities clients/servers may support *) +type capability = + [ `Unix_fd + (** The transport supports unix fd passing *) ] + +val capabilities : capability list + (** List of all capabilities *) + +(** {6 Communication} *) + +type stream + (** A stream is a way of communication for an authentication + procedure *) + +val make_stream : recv : (unit -> string Lwt.t) -> send : (string -> unit Lwt.t) -> stream + (** Creates a stream for authentication. + + @param recv must read a complete line, ending with ["\r\n"], + @param send must send the given line. *) + +val stream_of_channels : Lwt_io.input_channel * Lwt_io.output_channel -> stream + (** Creates a stream from a pair of channels *) + +val stream_of_fd : Lwt_unix.file_descr -> stream + (** Creates a stream from a file descriptor. Note that the stream + created by this function is not really efficient because it has + to read characters one by one to ensure it does not consume too + much. *) + +val max_line_length : int + (** Maximum length accepted for lines of the authentication + protocol. Beyond this limit, authentication will fail. *) + +(** Client-side authentication *) +module Client : sig + + (** {6 Mechanisms} *) + + type mechanism_return = + (** Value returned by the client side of an auth mechanism *) + | Mech_continue of data + (** Continue the authentication with this response *) + | Mech_ok of data + (** Authentification done *) + | Mech_error of string + (** Authentification failed *) + + class virtual mechanism_handler : object + method virtual init : mechanism_return Lwt.t + (** Initial return value of the mechanism *) + + method data : data -> mechanism_return Lwt.t + (** [mech_data] must continue the mechanism process with the given + data. Default implementation fail with an error message. *) + + method abort : unit + (** Must abort the mechanism. *) + end + + (** An client-side authentication mechanism *) + type mechanism = { + mech_name : string; + (** Name of the mechanism *) + mech_exec : unit -> mechanism_handler; + (** Mechanism creator *) + } + + val mech_name : mechanism -> string + (** [mech_name] projection *) + + val mech_exec : mechanism -> unit -> mechanism_handler + (** [mech_exec] projection *) + + (** {8 Predefined mechanisms} *) + + val mech_external : mechanism + val mech_anonymous : mechanism + val mech_dbus_cookie_sha1 : mechanism + val default_mechanisms : mechanism list + + (** {6 Authentication} *) + + val authenticate : + ?capabilities : capability list -> + ?mechanisms : mechanism list -> + stream : stream -> unit -> (OBus_address.guid * capability list) Lwt.t + (** Launch client-side authentication on the given stream. On + success it returns the unique identifier of the server address + and capabilities that were successfully negotiated with the + server. + + Note: [authenticate] does not sends the initial null byte. You + have to handle it before calling [authenticate]. + + @param capabilities defaults to [] + @param mechanisms defualts to {!default_mechanisms} + *) +end + +(** Server-side authentication *) +module Server : sig + + (** {6 Mechanisms} *) + + type mechanism_return = + (** Value returned by the server-side of an auth mechanism *) + | Mech_continue of data + (** Continue the authentication with this challenge *) + | Mech_ok of int option + (** The client is authenticated. The argument is the user id + the client is authenticated with. *) + | Mech_reject + (** The client is rejected by the mechanism *) + + class virtual mechanism_handler : object + method init : data option Lwt.t + (** Initial challenge *) + + method virtual data : data -> mechanism_return Lwt.t + (** [mech_data] must continue the mechanism process with the given + response. *) + + method abort : unit + (** Must abort the mechanism *) + end + + (** A server-side authentication mechanism *) + type mechanism = { + mech_name : string; + (** The mechanism name *) + mech_exec : int option -> mechanism_handler; + (** The mechanism creator. It receive the user id of the client, + if available. *) + } + + val mech_name : mechanism -> string + (** [mech_name projection] *) + val mech_exec : mechanism -> int option -> mechanism_handler + (** [mech_exec projection] *) + + (** {8 Predefined mechanisms} *) + + val mech_anonymous : mechanism + val mech_external : mechanism + val mech_dbus_cookie_sha1 : mechanism + val default_mechanisms : mechanism list + + (** {6 Authentication} *) + + val authenticate : + ?capabilities : capability list -> + ?mechanisms : mechanism list -> + ?user_id : int -> + guid : OBus_address.guid -> + stream : stream -> unit -> (int option * capability list) Lwt.t + (** Launch server-side authentication on the given stream. On + success it returns the client uid and the list of capabilities + that were successfully negotiated. A client uid of {!None} + means that the client used anonymous authentication, and may + be disconnected according to server policy. + + Note: [authenticate] does not read the first zero byte. You + must read it by hand, and maybe use it to receive credentials. + + @param user_id is the user id determined by external method + @param capabilities defaults to [[]] + @param mechanisms default to {!default_mechanisms} + *) +end diff --git a/src/protocol/oBus_bus.ml b/src/protocol/oBus_bus.ml new file mode 100644 index 0000000..e69297c --- /dev/null +++ b/src/protocol/oBus_bus.ml @@ -0,0 +1,247 @@ +(* + * oBus_bus.ml + * ----------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(bus)" + +open Lwt_react +open Lwt.Infix +open OBus_interfaces.Org_freedesktop_DBus + +type t = OBus_connection.t + +(* +-----------------------------------------------------------------+ + | Local properties | + +-----------------------------------------------------------------+ *) + +module String_set = Set.Make(String) + +type info = { + names : String_set.t signal; + set_names : String_set.t -> unit; + connection : OBus_connection.t; +} + +let key = OBus_connection.new_key () + +let name = OBus_connection.name + +let names connection = + match OBus_connection.get connection key with + | Some info -> info.names + | None -> invalid_arg "OBus_bus.names: not connected to a message bus" + +(* +-----------------------------------------------------------------+ + | Message bus creation | + +-----------------------------------------------------------------+ *) + +let proxy bus = + OBus_proxy.make (OBus_peer.make bus OBus_protocol.bus_name) OBus_protocol.bus_path + +let exit_on_disconnect = function + | OBus_wire.Protocol_error msg -> + ignore (Lwt_log.error_f ~section "the D-Bus connection with the message bus has been closed due to a protocol error: %s" msg); + exit 1 + | OBus_connection.Connection_lost -> + ignore (Lwt_log.info ~section "disconnected from D-Bus message bus"); + exit 0 + | OBus_connection.Transport_error exn -> + ignore (Lwt_log.error_f ~section "the D-Bus connection with the message bus has been closed due to a transport error: %s" (Printexc.to_string exn)); + exit 1 + | exn -> + ignore (Lwt_log.error ~section ~exn "the D-Bus connection with the message bus has been closed due to this uncaught exception"); + exit 1 + +(* Handle name lost/acquired events *) +let update_names info message = + let open OBus_message in + let name = OBus_connection.name info.connection in + if name <> "" && message.destination = name then + match message with + | { sender = "org.freedesktop.DBus"; + typ = Signal(["org"; "freedesktop"; "DBus"], "org.freedesktop.DBus", "NameAcquired"); + body = [OBus_value.V.Basic(OBus_value.V.String name)] } -> + info.set_names (String_set.add name (S.value info.names)); + Some message + | { sender = "org.freedesktop.DBus"; + typ = Signal(["org"; "freedesktop"; "DBus"], "org.freedesktop.DBus", "NameLost"); + body = [OBus_value.V.Basic(OBus_value.V.String name)] } -> + info.set_names (String_set.remove name (S.value info.names)); + Some message + | _ -> + Some message + else + Some message + +let register_connection connection = + match OBus_connection.get connection key with + | None -> + let names, set_names = S.create String_set.empty in + let info = { names; set_names; connection } in + OBus_connection.set connection key (Some info); + let _ = Lwt_sequence.add_l (update_names info) (OBus_connection.incoming_filters connection) in + let%lwt name = OBus_method.call m_Hello (proxy connection) () in + OBus_connection.set_name connection name; + Lwt.return () + | Some _ -> + Lwt.return () + +let of_addresses ?switch addresses = + let%lwt bus = OBus_connection.of_addresses ?switch addresses ~shared:true in + let%lwt () = register_connection bus in + Lwt.return bus + +let session_bus = lazy( + try%lwt + let%lwt bus = Lazy.force OBus_address.session >>= of_addresses in + OBus_connection.set_on_disconnect bus exit_on_disconnect; + Lwt.return bus + with exn -> + let%lwt () = Lwt_log.warning ~exn ~section "Failed to open a connection to the session bus" in + Lwt.fail exn +) + +let session ?switch () = + Lwt_switch.check switch; + let%lwt bus = Lazy.force session_bus in + let%lwt () = Lwt_switch.add_hook_or_exec switch (fun () -> OBus_connection.close bus) in + Lwt.return bus + +let system_bus_state = ref None +let system_bus_mutex = Lwt_mutex.create () + +let system ?switch () = + Lwt_switch.check switch; + let%lwt bus = + Lwt_mutex.with_lock system_bus_mutex + (fun () -> + match !system_bus_state with + | Some bus when S.value (OBus_connection.active bus) -> + Lwt.return bus + | _ -> + try%lwt + let%lwt bus = Lazy.force OBus_address.system >>= of_addresses in + system_bus_state := Some bus; + Lwt.return bus + with exn -> + let%lwt () = Lwt_log.warning ~exn ~section "Failed to open a connection to the system bus" in + Lwt.fail exn) + in + let%lwt () = Lwt_switch.add_hook_or_exec switch (fun () -> OBus_connection.close bus) in + Lwt.return bus + +(* +-----------------------------------------------------------------+ + | Bindings to functions of the message bus | + +-----------------------------------------------------------------+ *) + +exception Access_denied of string + [@@obus "org.freedesktop.DBus.Error.AccessDenied"] + +exception Service_unknown of string + [@@obus "org.freedesktop.DBus.Error.ServiceUnknown"] + +exception Match_rule_not_found of string + [@@obus "org.freedesktop.DBus.Error.MatchRuleNotFound"] + +exception Match_rule_invalid of string + [@@obus "org.freedesktop.DBus.Error.MatchRuleInvalid"] + +exception Name_has_no_owner of string + [@@obus "org.freedesktop.DBus.Error.NameHasNoOwner"] + +exception Adt_audit_data_unknown of string + [@@obus "org.freedesktop.DBus.Error.AdtAuditDataUnknown"] + +exception Selinux_security_context_unknown of string + [@@obus "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown"] + +let hello bus = + OBus_method.call m_Hello (proxy bus) () + +type request_name_result = type_request_name_result + +let request_name bus ?(allow_replacement=false) ?(replace_existing=false) ?(do_not_queue=false) name = + let flags = [] in + let flags = if allow_replacement then `Allow_replacement :: flags else flags in + let flags = if replace_existing then `Replace_existing :: flags else flags in + let flags = if do_not_queue then `Do_not_queue :: flags else flags in + OBus_method.call m_RequestName (proxy bus) (name, cast_request_name_flags flags) >|= make_request_name_result + +type release_name_result = type_release_name_result + +let release_name bus name = + OBus_method.call m_ReleaseName (proxy bus) name >|= make_release_name_result + +type start_service_by_name_result = type_start_service_by_name_result + +let start_service_by_name bus name = + OBus_method.call m_StartServiceByName (proxy bus) (name, 0l) >|= make_start_service_by_name_result + +let name_has_owner bus name = + OBus_method.call m_NameHasOwner (proxy bus) name + +let list_names bus = + OBus_method.call m_ListNames (proxy bus) () + +let list_activatable_names bus = + OBus_method.call m_ListActivatableNames (proxy bus) () + +let get_name_owner bus name = + OBus_method.call m_GetNameOwner (proxy bus) name + +let list_queued_owners bus name = + OBus_method.call m_ListQueuedOwners (proxy bus) name + +let add_match bus rule = + OBus_method.call m_AddMatch (proxy bus) (OBus_match.string_of_rule rule) + +let remove_match bus rule = + OBus_method.call m_RemoveMatch (proxy bus) (OBus_match.string_of_rule rule) + +let update_activation_environment bus data = + OBus_method.call m_UpdateActivationEnvironment (proxy bus) data + +let get_connection_unix_user bus name = + OBus_method.call m_GetConnectionUnixUser (proxy bus) name >|= Int32.to_int + +let get_connection_unix_process_id bus name = + OBus_method.call m_GetConnectionUnixProcessID (proxy bus) name >|= Int32.to_int + +let get_adt_audit_session_data bus name = + OBus_method.call m_GetAdtAuditSessionData (proxy bus) name + +let get_connection_selinux_security_context bus name = + OBus_method.call m_GetConnectionSELinuxSecurityContext (proxy bus) name + +let reload_config bus = + OBus_method.call m_ReloadConfig (proxy bus) () + +let get_id bus = + OBus_method.call m_GetId (proxy bus) () >|= OBus_uuid.of_string + +let name_owner_changed bus = + OBus_signal.make s_NameOwnerChanged (proxy bus) + +let name_lost bus = + OBus_signal.make s_NameLost (proxy bus) + +let name_acquired bus = + OBus_signal.make s_NameAcquired (proxy bus) + +let get_peer bus name = + try%lwt + let%lwt unique_name = get_name_owner bus name in + Lwt.return (OBus_peer.make bus unique_name) + with Name_has_no_owner msg -> + let%lwt _ = start_service_by_name bus name in + let%lwt unique_name = get_name_owner bus name in + Lwt.return (OBus_peer.make bus unique_name) + +let get_proxy bus name path = + let%lwt peer = get_peer bus name in + Lwt.return (OBus_proxy.make peer path) diff --git a/src/protocol/oBus_bus.mli b/src/protocol/oBus_bus.mli new file mode 100644 index 0000000..5586d01 --- /dev/null +++ b/src/protocol/oBus_bus.mli @@ -0,0 +1,202 @@ +(* + * oBus_bus.mli + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Message buses management *) + +type t = OBus_connection.t + +(** {6 Well-known instances} *) + +val session : ?switch : Lwt_switch.t -> unit -> t Lwt.t + (** [session ?switch ()] returns a connection to the user session + message bus. Subsequent calls to {!session} will return the same + bus. OBus will automatically exit the program when an error + happens on the session bus. You can change this behavior by + calling {!OBus_connection.set_on_disconnect}. *) + +val system : ?switch : Lwt_switch.t -> unit -> t Lwt.t + (** [system ?switch ()] returns a connection to the system message + bus. As for {!session}, subsequent calls to {!system} will + return the same bus. However, if the connection is closed or + crashes, {!system} will try to reopen it. *) + +(** {6 Creation} *) + +val of_addresses : ?switch : Lwt_switch.t -> OBus_address.t list -> t Lwt.t + (** Establish a connection with a message bus. The bus must be + accessible with at least one of the given addresses *) + +val register_connection : OBus_connection.t -> unit Lwt.t + (** Register the given connection to a message bus. It has the side + effect of requesting a name to the message bus if not already + done. + + If the connection is a connection to a message bus, created with + one of the function of {!OBus_connection} then + {!register_connection} must be called on it before any other + functions. *) + +val exit_on_disconnect : exn -> 'a + (** Function which exit the program as follow: + + - if [exn] is {!OBus_connection.Connection_lost}, it exits the + program with a return code of 0 + + - if [exn] is a fatal error, it prints a message on stderr and + exits the program with an exit code of 1 + *) + +(** {6 Peer/proxy helpers} *) + +val get_peer : t -> OBus_name.bus -> OBus_peer.t Lwt.t + (** [get_peer bus name] returns the peer owning the bus name + [name]. If the service is not activated and is activable, then + it is started *) + +val get_proxy : t -> OBus_name.bus -> OBus_path.t -> OBus_proxy.t Lwt.t + (** [get_proxy bus name path] resolves [name] with {!get_peer} and + returns a proxy for the object with path [path] on this + service *) + +(** {6 Bus names} *) + +val name : t -> OBus_name.bus + (** Same as {!OBus_connection.name}. *) + +val names : t -> Set.Make(String).t React.signal + (** [names bus] is the signal holding the set of all names we + currently own. It raises [Invalid_argument] if the connection is + not a connection to a message bus. *) + +val hello : t -> OBus_name.bus Lwt.t + (** [hello connection] sends an hello message to the message bus, + which returns the unique connection name of the connection. Note + that if the hello message has already been sent, it will + fail. *) + +exception Access_denied of string + (** Exception raised when a name cannot be owned due to security + policies *) + +type request_name_result = + [ `Primary_owner + (** You are now the primary owner of the connection *) + | `In_queue + (** You will get the name when it will be available *) + | `Exists + (** Somebody else already have the name and nobody specified + what to do in this case *) + | `Already_owner + (** You already have the name *) ] + +val request_name : t -> + ?allow_replacement:bool -> + ?replace_existing:bool -> + ?do_not_queue:bool -> + OBus_name.bus -> request_name_result Lwt.t + (** Request a name to the bus. This is the way to acquire a + well-know name. + + All optional parameters default to [false], their meaning are: + + - [allow_replacement]: allow other application to steal this name from you + - [replace_existing]: replace any existing owner of the name + - [do_not_queue]: do not queue if not available + *) + +type release_name_result = + [ `Released + | `Non_existent + | `Not_owner ] + +val release_name : t -> OBus_name.bus -> release_name_result Lwt.t + +(** {6 Service starting/discovering} *) + +exception Service_unknown of string + (** Exception raised when a service is not present on a message bus + and can not be started automatically *) + +type start_service_by_name_result = + [ `Success + | `Already_running ] + +val start_service_by_name : t -> OBus_name.bus -> start_service_by_name_result Lwt.t + (** Start a service on the given bus by its name *) + +val name_has_owner : t -> OBus_name.bus -> bool Lwt.t + (** Returns [true] if the service is currently running, i.e. some + application offers it on the message bus *) + +val list_names : t -> OBus_name.bus list Lwt.t + (** List names currently running on the message bus *) + +val list_activatable_names : t -> OBus_name.bus list Lwt.t + (** List services that can be activated. A service is automatically + activated when you call one of its method or when you use + [start_service_by_name] *) + +exception Name_has_no_owner of string + +val get_name_owner : t -> OBus_name.bus -> OBus_name.bus Lwt.t + (** Return the connection unique name of the given service. Raise a + [Name_has_no_owner] if the given name does not have an owner. *) + +val list_queued_owners : t -> OBus_name.bus -> OBus_name.bus list Lwt.t + (** Return the connection unique names of the applications waiting for a + name *) + +(** {6 Messages routing} *) + +(** Note that you should prefer using {!OBus_match.export} and + {!OBus_match.remove} since they do not add duplicated rules + several times. *) + +exception Match_rule_invalid of string + (** Exception raised when the program tries to send an invalid match + rule. This should never happen since values of type + {!OBus_match.rule} are always valid. *) + +val add_match : t -> OBus_match.rule -> unit Lwt.t + (** Add a matching rule on a message bus. This means that every + message routed on the message bus matching this rule will be + sent to us. + + It can raise {!OBus_error.No_memory}. + *) + +exception Match_rule_not_found of string + +val remove_match : t -> OBus_match.rule -> unit Lwt.t + (** Remove a match rule from the message bus. It raises + {!Match_rule_not_found} if the rule does not exists *) + +(** {6 Other} *) + +(** These functions are also offered by the message bus *) + +exception Adt_audit_data_unknown of string +exception Selinux_security_context_unknown of string + +val update_activation_environment : t -> (string * string) list -> unit Lwt.t +val get_connection_unix_user : t -> OBus_name.bus -> int Lwt.t +val get_connection_unix_process_id : t -> OBus_name.bus -> int Lwt.t +val get_adt_audit_session_data : t -> OBus_name.bus -> string Lwt.t +val get_connection_selinux_security_context : t -> OBus_name.bus -> string Lwt.t +val reload_config : t -> unit Lwt.t +val get_id : t -> OBus_uuid.t Lwt.t + +(** {6 Signals} *) + +val name_owner_changed : t -> (OBus_name.bus * OBus_name.bus * OBus_name.bus) OBus_signal.t + (** This signal is emitted each time the owner of a name (unique + connection name or service name) changes. *) + +val name_lost : t -> OBus_name.bus OBus_signal.t +val name_acquired : t -> OBus_name.bus OBus_signal.t diff --git a/src/protocol/oBus_config.ml b/src/protocol/oBus_config.ml new file mode 100644 index 0000000..d4ff3b8 --- /dev/null +++ b/src/protocol/oBus_config.ml @@ -0,0 +1,14 @@ +(* -*- tuareg -*- + * OBus_config.ml + * -------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(* Localtion of the machine id file: *) +let machine_uuid_file = "/var/lib/dbus/machine-id" + +(* Version of obus: *) +let version = "1.2.0" diff --git a/src/protocol/oBus_connection.ml b/src/protocol/oBus_connection.ml new file mode 100644 index 0000000..5256c8d --- /dev/null +++ b/src/protocol/oBus_connection.ml @@ -0,0 +1,667 @@ +(* + * oBus_connection.ml + * ------------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(connection)" + +open Lwt_react +open Lwt.Infix + +(* +-----------------------------------------------------------------+ + | Exceptions | + +-----------------------------------------------------------------+ *) + +exception Connection_closed +exception Connection_lost +exception Transport_error of exn + +let () = + Printexc.register_printer + (function + | Connection_closed -> + Some "D-Bus connection closed" + | Connection_lost -> + Some "D-Bus connection lost" + | Transport_error exn -> + Some(Printf.sprintf "D-Bus transport failure: %s" (Printexc.to_string exn)) + | _ -> + None) + +(* +-----------------------------------------------------------------+ + | Types | + +-----------------------------------------------------------------+ *) + +module Serial_map = Map.Make + (struct + type t = OBus_message.serial + let compare : int32 -> int32 -> int = compare + end) + +module Int_map = Map.Make + (struct + type t = int + let compare : int -> int -> int = compare + end) + +type filter = OBus_message.t -> OBus_message.t option + (* Type of message filters *) + +(* Connection are wrapped into object in order to make them + comparable. In the code, wrapped connection are simply referred has + "connection" and internal connection details are referred as + "active". *) + +(* Type of active connections *) +type active_connection = { + mutable name : OBus_name.bus; + (* The name of the connection in case the endpoint is a message bus, + or [""] if not. *) + + transport : OBus_transport.t; + (* The transport used for messages *) + + mutable on_disconnect : exn -> unit Lwt.t; + (* [on_disconnect] is called the connection is closed + prematurely. This happen on transport errors. *) + + guid : OBus_address.guid option; + (* Guid of the connection. It may is [Some guid] if this is the + client-side part of a peer-to-peer connection and the connection + is shared. *) + + down : (unit Lwt.t * unit Lwt.u) option signal; + set_down : (unit Lwt.t * unit Lwt.u) option -> unit; + (* Waiting thread used to make the connection to stop dispatching + messages. *) + + state : [ `Up | `Down ] signal; + + abort_recv_wakener : OBus_message.t Lwt.u; + abort_send_wakener : unit Lwt.u; + abort_recv_waiter : OBus_message.t Lwt.t; + abort_send_waiter : unit Lwt.t; + (* Waiting threads wakeup when the connection is closed or + aborted. It is used to make the dispatcher/writer to exit. *) + + mutable next_serial : OBus_message.serial; + (* The first available serial, incremented for each message *) + + mutable outgoing_mutex : Lwt_mutex.t; + (* Mutex used to serialise message sending *) + + incoming_filters : filter Lwt_sequence.t; + outgoing_filters : filter Lwt_sequence.t; + + mutable reply_waiters : OBus_message.t Lwt.u Serial_map.t; + (* Mapping serial -> thread waiting for a reply *) + + mutable data : exn Int_map.t; + (* Set of locally stored values *) + + wrapper : t; + (* The wrapper containing the connection *) +} + +(* State of a connection *) +and connection_state = + | Active of active_connection + (* The connection is currently active *) + | Closed + (* The connection has been closed gracefully *) + | Killed + (* The connection has been killed after an error happened *) + +(* Connections are packed into objects to make them comparable *) +and t = < + state : connection_state; + (* Get the connection state *) + + set_state : connection_state -> unit; + (* Sets the state of the connection *) + + get : active_connection; + (* Returns the connection if it is active, and fail otherwise *) + + active : bool signal; + (* Signal holding the current connection state. *) +> + +let compare : t -> t -> int = Pervasives.compare + +(* +-----------------------------------------------------------------+ + | Guids | + +-----------------------------------------------------------------+ *) + +(* Mapping from server guid to connection. *) +module Guid_map = Map.Make(struct + type t = OBus_address.guid + let compare = Pervasives.compare + end) + +let guid_connection_map = ref Guid_map.empty + +(* +-----------------------------------------------------------------+ + | Filters | + +-----------------------------------------------------------------+ *) + +(* Apply a list of filter on a message, logging failure *) +let apply_filters typ message filters = + try + Lwt_sequence.fold_l + (fun filter message -> match message with + | Some message -> filter message + | None -> None) + filters (Some message) + with exn -> + ignore (Lwt_log.error_f ~section ~exn "an %s filter failed with" typ); + None + +(* +-----------------------------------------------------------------+ + | Connection closing | + +-----------------------------------------------------------------+ *) + +let cleanup active ~is_crash = + begin + match active.guid with + | Some guid -> + guid_connection_map := Guid_map.remove guid !guid_connection_map + | None -> + () + end; + + (* This make the dispatcher to exit if it is waiting on + [get_message] *) + Lwt.wakeup_exn active.abort_recv_wakener Connection_closed; + begin + match S.value active.down with + | Some(waiter, wakener) -> + Lwt.wakeup_exn wakener Connection_closed + | None -> + () + end; + + (* Wakeup all reply handlers so they will not wait forever *) + Serial_map.iter (fun _ wakener -> Lwt.wakeup_exn wakener Connection_closed) active.reply_waiters; + + (* If the connection is closed normally, flush it *) + let%lwt () = + if not is_crash then + Lwt_mutex.with_lock active.outgoing_mutex Lwt.return + else begin + Lwt.wakeup_exn active.abort_send_wakener Connection_closed; + Lwt.return () + end + in + + (* Shutdown the transport *) + try%lwt + OBus_transport.shutdown active.transport + with exn -> + Lwt_log.error ~section ~exn "failed to abort/shutdown the transport" + +let close connection = + match connection#state with + | Killed | Closed -> + Lwt.return () + | Active active -> + connection#set_state Closed; + cleanup active ~is_crash:false + +let kill connection exn = + match connection#state with + | Killed | Closed -> + Lwt.return () + | Active active -> + connection#set_state Killed; + let%lwt () = cleanup active ~is_crash:true in + try%lwt + active.on_disconnect exn + with exn -> + Lwt_log.error ~section ~exn "the error handler failed with" + +(* +-----------------------------------------------------------------+ + | Sending messages | + +-----------------------------------------------------------------+ *) + +(* Send a message, maybe adding a reply waiter and return + [return_thread] *) +let send_message_backend connection gen_serial reply_waiter_opt message = + let active = connection#get in + Lwt_mutex.with_lock active.outgoing_mutex + (fun () -> + let send_it, closed = match connection#state with + | Active _ -> + (true, false) + | Closed -> + (* Flush the connection if closed gracefully *) + (true, true) + | Killed -> + (false, true) + in + if send_it then begin + let message = if gen_serial then { message with OBus_message.serial = active.next_serial } else message in + match apply_filters "outgoing" message active.outgoing_filters with + | None -> + let%lwt () = Lwt_log.debug ~section "outgoing message dropped by filters" in + Lwt.fail (Failure "message dropped by filters") + + | Some message -> + if not closed then begin + match reply_waiter_opt with + | Some(waiter, wakener) -> + active.reply_waiters <- Serial_map.add (OBus_message.serial message) wakener active.reply_waiters; + Lwt.on_cancel waiter (fun () -> + match connection#state with + | Killed | Closed -> + () + | Active active -> + active.reply_waiters <- Serial_map.remove (OBus_message.serial message) active.reply_waiters) + | None -> + () + end; + + try%lwt + let%lwt () = Lwt.choose [active.abort_send_waiter; + (* Do not cancel a thread while it is marshaling message: *) + Lwt.protected (OBus_transport.send active.transport message)] in + (* Everything went OK, continue with a new serial *) + if gen_serial then active.next_serial <- Int32.succ active.next_serial; + Lwt.return () + with + | OBus_wire.Data_error _ as exn -> + (* The message can not be marshaled for some + reason. This is not a fatal error. *) + Lwt.fail exn + + | Lwt.Canceled -> + (* Message sending have been canceled by the + user. This is not a fatal error either. *) + Lwt.fail Lwt.Canceled + + | exn -> + (* All other errors are considered as fatal. They + are fatal because it is possible that a + message has been partially sent on the + connection, so the message stream is broken *) + let%lwt () = kill connection exn in + Lwt.fail exn + end else + match connection#state with + | Killed | Closed -> + Lwt.fail Connection_closed + | Active _ -> + Lwt.return ()) + +let send_message connection message = + send_message_backend connection true None message + +let send_message_with_reply connection message = + let (waiter, wakener) as v = Lwt.task () in + let%lwt () = send_message_backend connection true (Some v) message in + waiter + +let send_message_keep_serial connection message = + send_message_backend connection false None message + +let send_message_keep_serial_with_reply connection message = + let (waiter, wakener) as v = Lwt.task () in + let%lwt () = send_message_backend connection false (Some v) message in + waiter + +(* +-----------------------------------------------------------------+ + | Helpers for calling methods | + +-----------------------------------------------------------------+ *) + +let method_call_with_message ~connection ?destination ~path ?interface ~member ~i_args ~o_args args = + let i_msg = + OBus_message.method_call + ?destination + ~path + ?interface + ~member + (OBus_value.C.make_sequence i_args args) + in + let%lwt o_msg = send_message_with_reply connection i_msg in + match o_msg with + | { OBus_message.typ = OBus_message.Method_return _; body } -> begin + try + Lwt.return (o_msg, OBus_value.C.cast_sequence o_args body) + with OBus_value.C.Signature_mismatch -> + Lwt.fail (OBus_message.invalid_reply i_msg (OBus_value.C.type_sequence o_args) o_msg) + end + | { OBus_message.typ = OBus_message.Error(_, error_name); + OBus_message.body = OBus_value.V.Basic(OBus_value.V.String message) :: _ } -> + Lwt.fail (OBus_error.make error_name message) + | { OBus_message.typ = OBus_message.Error(_, error_name) } -> + Lwt.fail (OBus_error.make error_name "") + | _ -> + assert false + +let method_call ~connection ?destination ~path ?interface ~member ~i_args ~o_args args = + method_call_with_message ~connection ?destination ~path ?interface ~member ~i_args ~o_args args >|= snd + +let method_call_no_reply ~connection ?destination ~path ?interface ~member ~i_args args = + send_message connection + (OBus_message.method_call + ~flags:{ OBus_message.default_flags with OBus_message.no_reply_expected = true } + ?destination + ~path + ?interface + ~member + (OBus_value.C.make_sequence i_args args)) + +(* +-----------------------------------------------------------------+ + | Reading/dispatching | + +-----------------------------------------------------------------+ *) + +let dispatch_message active message = + let open OBus_message in + match message with + + (* For method return and errors, we lookup at the reply waiters. If + one is find then it get the reply, if none, then the reply is + dropped. *) + | { typ = Method_return(reply_serial) } + | { typ = Error(reply_serial, _) } -> begin + match try Some(Serial_map.find reply_serial active.reply_waiters) with Not_found -> None with + | Some w -> + active.reply_waiters <- Serial_map.remove reply_serial active.reply_waiters; + Lwt.wakeup w message; + Lwt.return () + | None -> + Lwt_log.debug_f ~section "reply to message with serial %ld dropped%s" + reply_serial + (match message with + | { typ = Error(_, error_name) } -> + Printf.sprintf ", the reply is the error: %S: %S" + error_name + (match message.body with + | OBus_value.V.Basic(OBus_value.V.String x) :: _ -> x + | _ -> "") + | _ -> + "") + end + + (* Handling of the special "org.freedesktop.DBus.Peer" interface *) + | { typ = Method_call(_, "org.freedesktop.DBus.Peer", member); body; sender; serial } -> begin + try%lwt + let%lwt body = + match member, body with + | "Ping", [] -> + Lwt.return [] + | "GetMachineId", [] -> begin + try%lwt + let%lwt uuid = Lazy.force OBus_info.machine_uuid in + Lwt.return [OBus_value.V.basic_string (OBus_uuid.to_string uuid)] + with exn -> + if OBus_error.name exn = OBus_error.ocaml then + Lwt.fail + (OBus_error.Failed + (Printf.sprintf + "Cannot read the machine uuid file (%s)" + OBus_config.machine_uuid_file)) + else + Lwt.fail exn + end + | _ -> + Lwt.fail + (OBus_error.Unknown_method + (Printf.sprintf + "Method %S with signature %S on interface \"org.freedesktop.DBus.Peer\" does not exist" + member + (OBus_value.string_of_signature (OBus_value.V.type_of_sequence body)))) + in + send_message active.wrapper { + flags = { no_reply_expected = true; no_auto_start = true }; + serial = 0l; + typ = Method_return serial; + destination = sender; + sender = ""; + body = body; + } + with exn -> + let name, msg = OBus_error.cast exn in + send_message active.wrapper { + flags = { no_reply_expected = true; no_auto_start = true }; + serial = 0l; + typ = Error(serial, name); + destination = sender; + sender = ""; + body = [OBus_value.V.basic_string msg]; + } + end + + | _ -> + (* Other messages are handled by specifics modules *) + Lwt.return () + +let rec dispatch_forever active = + let%lwt () = + (* Wait for the connection to become up *) + match S.value active.down with + | Some(waiter, wakener) -> + waiter + | None -> + Lwt.return () + in + let%lwt message = + try%lwt + Lwt.choose [OBus_transport.recv active.transport; active.abort_recv_waiter] + with exn -> + let%lwt () = kill active.wrapper (Transport_error exn) in + Lwt.fail exn + in + match apply_filters "incoming" message active.incoming_filters with + | None -> + let%lwt () = Lwt_log.debug ~section "incoming message dropped by filters" in + dispatch_forever active + | Some message -> + (* The internal dispatcher accepts only messages destined to + the current connection: *) + if active.name = "" || OBus_message.destination message = active.name then ignore ( + (try%lwt + dispatch_message active message + with exn -> + Lwt_log.error ~section ~exn "message dispatching failed with") + [%lwt.finally + OBus_value.V.sequence_close (OBus_message.body message)] + ); + dispatch_forever active + +(* +-----------------------------------------------------------------+ + | Connection creation | + +-----------------------------------------------------------------+ *) + +class connection () = + let active, set_active = S.create false in +object(self) + + method active = active + + val mutable state = Closed + + method state = state + + method set_state new_state = + state <- new_state; + match state with + | Closed | Killed -> + set_active false + | Active _ -> + set_active true + + method get = + match state with + | Closed | Killed -> raise Connection_closed + | Active active -> active +end + +let of_transport ?switch ?guid ?(up=true) transport = + Lwt_switch.check switch; + let make () = + let abort_recv_waiter, abort_recv_wakener = Lwt.wait () + and abort_send_waiter, abort_send_wakener = Lwt.wait () + and connection = new connection () + and down, set_down = S.create (if up then None else Some(Lwt.wait ())) in + let state = S.map (function None -> `Up | Some _ -> `Down) down in + let active = { + name = ""; + transport; + on_disconnect = (fun exn -> Lwt.return ()); + guid; + down; + set_down; + state; + abort_recv_waiter; + abort_send_waiter; + abort_recv_wakener = abort_recv_wakener; + abort_send_wakener = abort_send_wakener; + outgoing_mutex = Lwt_mutex.create (); + next_serial = 1l; + incoming_filters = Lwt_sequence.create (); + outgoing_filters = Lwt_sequence.create (); + reply_waiters = Serial_map.empty; + data = Int_map.empty; + wrapper = connection; + } in + connection#set_state (Active active); + (* Start the dispatcher *) + ignore (dispatch_forever active); + Lwt_switch.add_hook switch (fun () -> close connection); + connection + in + match guid with + | None -> + make () + | Some guid -> + match try Some(Guid_map.find guid !guid_connection_map) with Not_found -> None with + | Some connection -> + Lwt_switch.add_hook switch (fun () -> close connection); + connection + | None -> + let connection = make () in + guid_connection_map := Guid_map.add guid connection !guid_connection_map; + connection + +(* Capabilities turned on by default: *) +let capabilities = [`Unix_fd] + +let of_addresses ?switch ?(shared=true) addresses = + Lwt_switch.check switch; + match shared with + | false -> + let%lwt guid, transport = OBus_transport.of_addresses ~capabilities addresses in + Lwt.return (of_transport ?switch transport) + | true -> + (* Try to find a guid that we already have *) + let guids = OBus_util.filter_map OBus_address.guid addresses in + match OBus_util.find_map (fun guid -> try Some(Guid_map.find guid !guid_connection_map) with Not_found -> None) guids with + | Some connection -> + Lwt_switch.add_hook switch (fun () -> close connection); + Lwt.return connection + | None -> + (* We ask again a shared connection even if we know that + there is no other connection to a server with the same + guid, because during the authentication another + thread can add a new connection. *) + let%lwt guid, transport = OBus_transport.of_addresses ~capabilities addresses in + Lwt.return (of_transport ?switch ~guid transport) + +let loopback () = of_transport (OBus_transport.loopback ()) + +(* +-----------------------------------------------------------------+ + | Local storage | + +-----------------------------------------------------------------+ *) + +type 'a key = { + key_id : int; + key_make : 'a -> exn; + key_cast : exn -> 'a; +} + +let next_key_id = ref 0 + +let new_key (type t) () = + let key_id = !next_key_id in + next_key_id := key_id + 1; + let module M = struct exception E of t end in + { + key_id = key_id; + key_make = (fun x -> M.E x); + key_cast = (function M.E x -> x | _ -> assert false); + } + +let get connection key = + let active = connection#get in + try + let cell = Int_map.find key.key_id active.data in + Some(key.key_cast cell) + with Not_found -> + None + +let set connection key value = + let active = connection#get in + match value with + | Some x -> + active.data <- Int_map.add key.key_id (key.key_make x) active.data + | None -> + active.data <- Int_map.remove key.key_id active.data + +(* +-----------------------------------------------------------------+ + | Other | + +-----------------------------------------------------------------+ *) + +let name connection = connection#get.name +let set_name connection name = connection#get.name <- name + +let active connection = connection#active + +let guid connection = connection#get.guid +let transport connection = connection#get.transport + +let can_send_basic_type connection = function + | OBus_value.T.Unix_fd -> List.mem `Unix_fd (OBus_transport.capabilities connection#get.transport) + | _ -> true + +let rec can_send_single_type connection = function + | OBus_value.T.Basic t -> can_send_basic_type connection t + | OBus_value.T.Array t -> can_send_single_type connection t + | OBus_value.T.Dict(tk, tv) -> can_send_basic_type connection tk && can_send_single_type connection tv + | OBus_value.T.Structure tl -> List.for_all (can_send_single_type connection) tl + | OBus_value.T.Variant -> true + +let can_send_sequence_type connection tl = List.for_all (can_send_single_type connection) tl + +let set_on_disconnect connection f = + match connection#state with + | Closed | Killed -> + () + | Active active -> + active.on_disconnect <- f + +let state connection = connection#get.state + +let set_up connection = + let active = connection#get in + match S.value active.down with + | None -> + () + | Some(waiter, wakener) -> + active.set_down None; + Lwt.wakeup wakener () + +let set_down connection = + let active = connection#get in + match S.value active.down with + | Some _ -> + () + | None -> + active.set_down (Some(Lwt.wait ())) + +let incoming_filters connection = connection#get.incoming_filters +let outgoing_filters connection = connection#get.outgoing_filters diff --git a/src/protocol/oBus_connection.mli b/src/protocol/oBus_connection.mli new file mode 100644 index 0000000..ae34376 --- /dev/null +++ b/src/protocol/oBus_connection.mli @@ -0,0 +1,239 @@ +(* + * oBus_connection.mli + * ------------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus connections *) + +(** This module implements manipulation of a D-Bus connection. A D-Bus + connection is a channel opened with another application which also + implement the D-Bus protocol. It is used to exchange D-Bus + messages. *) + +type t + (** Type of D-Bus connections *) + +val compare : t -> t -> int + (** Same as [Pervasives.compare]. It allows this module to be used + as argument to the functors [Set.Make] and [Map.Make]. *) + +(** {6 Creation} *) + +(** The following functions will return a connection which is ready to + send and receive messages. You should use them only for direct + connection to another application without passing through a + message bus. + + Otherwise you should use [OBus_bus] or immediately call + [OBus_bus.register_connection] after the creation. *) + +val of_addresses : ?switch : Lwt_switch.t -> ?shared : bool -> OBus_address.t list -> t Lwt.t + (** [of_addresses ?switch ?shared addresses] try to get a working + D-Bus connection from a list of addresses. The server must be + accessible from at least one of these addresses. + + If [shared] is true and a connection to the same server is + already open, then it is used instead of [transport]. This is + the default behaviour. *) + +val loopback : unit -> t + (** Create a connection with a loopback transport *) + +val close : t -> unit Lwt.t + (** Close a connection. + + All thread waiting for a reply will fail with the exception + {!Connection_closed}. + + Notes: + - when a connection is closed, the transport it use is + closed too + - if the connection is already closed, it does nothing + *) + +val active : t -> bool React.signal + (** Returns whether a connection is active. *) + +exception Connection_closed + (** Raised when trying to use a closed connection *) + +exception Connection_lost + (** Raised when a connection has been lost *) + +exception Transport_error of exn + (** Raised when something wrong happens on the backend transport of + the connection *) + +(** {6 Informations} *) + +val name : t -> OBus_name.bus + (** Returns the unique name of the connection. This is only + meaningful is the other endpoint of the connection is a + message bus. If it is not the case it returns [""]. *) + +(**/**) +val set_name : t -> OBus_name.bus -> unit +(**/**) + +val transport : t -> OBus_transport.t + (** [transport connection] get the transport associated with a + connection *) + +val can_send_basic_type : t -> OBus_value.T.basic -> bool +val can_send_single_type : t -> OBus_value.T.single -> bool +val can_send_sequence_type : t -> OBus_value.T.sequence -> bool + (** [can_send_*_type connection typ] returns whether values of the + given type can be sent through the given connection. *) + +(** {6 Sending messages} *) + +(** These functions are the low-level functions for sending + messages. They take and return a complete message description *) + +val send_message : t -> OBus_message.t -> unit Lwt.t + (** [send_message connection message] send a message without + expecting a reply. *) + +val send_message_with_reply : t -> OBus_message.t -> OBus_message.t Lwt.t + (** [send_message_with_reply connection message] Send a message and + return a thread which waits for the reply (which is a method + return or an error) *) + +val send_message_keep_serial : t -> OBus_message.t -> unit Lwt.t + (** Same as {!send_message} but does not generate a serial for the + message. + + Warning: this is for implementing a D-Bus daemon only, not for + casual use. *) + +val send_message_keep_serial_with_reply : t -> OBus_message.t -> OBus_message.t Lwt.t + (** Same as {!send_message_with_reply} but does not generate a serial + for the message. + + Warning: this is for implementing a D-Bus daemon only, not for + casual use. *) + +(** {6 Helpers for calling methods} *) + +val method_call : + connection : t -> + ?destination : OBus_name.bus -> + path : OBus_path.t -> + ?interface : OBus_name.interface -> + member : OBus_name.member -> + i_args : 'a OBus_value.C.sequence -> + o_args : 'b OBus_value.C.sequence -> + 'a -> 'b Lwt.t + (** Calls a method using the given parameters, and waits for its + reply. *) + +val method_call_with_message : + connection : t -> + ?destination : OBus_name.bus -> + path : OBus_path.t -> + ?interface : OBus_name.interface -> + member : OBus_name.member -> + i_args : 'a OBus_value.C.sequence -> + o_args : 'b OBus_value.C.sequence -> + 'a -> (OBus_message.t * 'b) Lwt.t + (** Same as {!method_call}, but also returns the reply message so + you can extract informations from it. *) + +val method_call_no_reply : + connection : t -> + ?destination : OBus_name.bus -> + path : OBus_path.t -> + ?interface : OBus_name.interface -> + member : OBus_name.member -> + i_args : 'a OBus_value.C.sequence -> + 'a -> unit Lwt.t + (** Same as {!method_call} but does not expect a reply *) + +(** {6 General purpose filters} *) + +(** Filters are functions that are applied on all incoming and + outgoing messages. + + For incoming messages they are called before dispatching, for + outgoing ones, they are called just before being sent. +*) + +type filter = OBus_message.t -> OBus_message.t option + (** The result of a filter must be: + + - [Some msg] where [msg] is the message given to the filter + modified or not, which means that the message is replaced by + this one + + - [None] which means that the message will be dropped, i.e. not + dispatched or not sent *) + +val incoming_filters : t -> filter Lwt_sequence.t + (** Filters applied on incoming messages *) + +val outgoing_filters : t -> filter Lwt_sequence.t + (** Filters appllied on outgoing messages *) + +(** {6 Connection local Storage} *) + +(** Connection local storage allows to attach values to a + connection. It is internally used by modules of obus. *) + +type 'a key + (** Type of keys. Keys are used to identify a resource attached to a + connection. *) + +val new_key : unit -> 'a key + (** [new_key ()] generates a new key. *) + +val get : t -> 'a key -> 'a option + (** [get connection key] returns the data associated to [key] in + connection, if any. *) + +val set : t -> 'a key -> 'a option -> unit + (** [set connection key value] attach [value] to [connection] under + the key [key]. [set connection key None] will remove any + occurence of [key] from [connection]. *) + +(** {6 Errors handling} *) + +(** Note: when a filter/signal handler/method_call handler raise an + exception, it is just dropped. If {!OBus_info.debug} is set then a + message is printed on [stderr] *) + +val set_on_disconnect : t -> (exn -> unit Lwt.t) -> unit + (** Sets the function called when a fatal error happen or when the + conection is lost. + + Notes: + - the default function does nothing + - it is not called when the connection is closed using {!close} + - if the connection is closed, it does nothing + *) + +(** {6 Low-level} *) + +val of_transport : ?switch : Lwt_switch.t -> ?guid : OBus_address.guid -> ?up : bool -> OBus_transport.t -> t + (** Create a D-Bus connection on the given transport. If [guid] is + provided the connection will be shared. + + [up] tell whether the connection is initially up or down, + default is [true]. *) + +(** A connection can be up or down. Except for connections created with + [of_transport], newly created connections are always up. + + When a connection is down, messages will not be dispatched *) + +val state : t -> [ `Up | `Down ] React.signal + (** Signal holding the current state of the connection *) + +val set_up : t -> unit + (** Sets up the connection if it is not already up *) + +val set_down : t -> unit + (** Sets down the connection if it is not already down *) diff --git a/src/protocol/oBus_context.ml b/src/protocol/oBus_context.ml new file mode 100644 index 0000000..f7f9de6 --- /dev/null +++ b/src/protocol/oBus_context.ml @@ -0,0 +1,37 @@ +(* + * oBus_context.ml + * --------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +type t = { + connection : OBus_connection.t; + flags : OBus_message.flags; + sender : OBus_peer.t; + destination : OBus_peer.t; + serial : OBus_message.serial; +} + +let key = Lwt.new_key () + +let get () = + match Lwt.get key with + | Some ctx -> ctx + | None -> failwith "OBus_context.get: not in a method call handler" + +let make ~connection ~message = { + connection = connection; + flags = OBus_message.flags message; + sender = OBus_peer.make connection (OBus_message.sender message); + destination = OBus_peer.make connection (OBus_message.destination message); + serial = OBus_message.serial message; +} + +let connection ctx = ctx.connection +let flags ctx = ctx.flags +let serial ctx = ctx.serial +let sender ctx = ctx.sender +let destination ctx = ctx.destination diff --git a/src/protocol/oBus_context.mli b/src/protocol/oBus_context.mli new file mode 100644 index 0000000..c5917d3 --- /dev/null +++ b/src/protocol/oBus_context.mli @@ -0,0 +1,51 @@ +(* + * oBus_context.mli + * ---------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Message contexts *) + +(** {6 Types} *) + +(** A context contains information about the reception of a + message. *) + +type t + (** Type of a context. *) + +(** {6 Creation} *) + +val make : connection : OBus_connection.t -> message : OBus_message.t -> t + (** Creates a context from the given connection and message *) + +(** {6 Retreival} *) + +val get : unit -> t + (** In a method call handler, this returns the context of the method + call. *) + +val key : t Lwt.key + (** The key used for storing the context. *) + +(** {6 Projections} *) + +val connection : t -> OBus_connection.t + (** Returns the connection part of a context *) + +val sender : t -> OBus_peer.t + (** [sender context] returns the peer who sends the message *) + +val destination : t -> OBus_peer.t + (** [destinatino context] returns the peer to which the message was + sent *) + +val flags : t -> OBus_message.flags + (** [flags context] returns the flags of the message that was + received *) + +val serial : t -> OBus_message.serial + (** Returns the serial of the message *) diff --git a/src/protocol/oBus_error.ml b/src/protocol/oBus_error.ml new file mode 100644 index 0000000..6a70ef0 --- /dev/null +++ b/src/protocol/oBus_error.ml @@ -0,0 +1,124 @@ +(* + * oBus_error.ml + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +type name = string +type message = string + +type error = { + name : name; + make : message -> exn; + cast : exn -> message option; +} + +exception DBus of name * message + +let ocaml = "org.ocamlcore.forge.obus.OCamlException" + +let () = + Printexc.register_printer + (function + | DBus(name, message) -> Some(Printf.sprintf "%s: %s" name message) + | _ -> None) + +(* List of all registered D-Bus errors *) +let errors = ref [] + +(* +-----------------------------------------------------------------+ + | Creation/casting | + +-----------------------------------------------------------------+ *) + +let make name message = + let rec loop = function + | [] -> + DBus(name, message) + | error :: errors -> + if error.name = name then + error.make message + else + loop errors + in + loop !errors + +let cast exn = + let rec loop = function + | [] -> + (ocaml, Printexc.to_string exn) + | error :: errors -> + match error.cast exn with + | Some message -> (error.name, message) + | None -> loop errors + in + match exn with + | DBus(name, message) -> (name, message) + | _ -> loop !errors + +let name exn = + let rec loop = function + | [] -> + ocaml + | error :: errors -> + match error.cast exn with + | Some message -> error.name + | None -> loop errors + in + match exn with + | DBus(name, message) -> name + | _ -> loop !errors + +(* +-----------------------------------------------------------------+ + | Registration | + +-----------------------------------------------------------------+ *) + +module type Error = sig + exception E of string + val name : name +end + +module Register(Error : Error) = +struct + let () = + errors := { + name = Error.name; + make = (fun message -> Error.E message); + cast = (function + | Error.E message -> Some message + | _ -> None); + } :: !errors +end + +(* +-----------------------------------------------------------------+ + | Well-known exceptions | + +-----------------------------------------------------------------+ *) + +exception Failed of message + [@@obus "org.freedesktop.DBus.Error.Failed"] + +exception Invalid_args of message + [@@obus "org.freedesktop.DBus.Error.InvalidArgs"] + +exception Unknown_method of message + [@@obus "org.freedesktop.DBus.Error.UnknownMethod"] + +exception Unknown_object of message + [@@obus "org.freedesktop.DBus.Error.UnknownObject"] + +exception Unknown_interface of message + [@@obus "org.freedesktop.DBus.Error.UnknownInterface"] + +exception Unknown_property of message + [@@obus "org.freedesktop.DBus.Error.UnknownProperty"] + +exception Property_read_only of message + [@@obus "org.freedesktop.DBus.Error.PropertyReadOnly"] + +exception No_memory of message + [@@obus "org.freedesktop.DBus.Error.NoMemory"] + +exception No_reply of message + [@@obus "org.freedesktop.DBus.Error.NoReply"] diff --git a/src/protocol/oBus_error.mli b/src/protocol/oBus_error.mli new file mode 100644 index 0000000..8af22bf --- /dev/null +++ b/src/protocol/oBus_error.mli @@ -0,0 +1,120 @@ +(* + * oBus_error.mli + * -------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus errors management *) + +(** This module integrates D-Bus errors into OCaml exceptions, and + OCaml exceptions into D-Bus errors. + + To do this, an OCaml exception that maps a D-Bus error should be + registered with {!Register}. *) + +type name = OBus_name.error + (** An error name. For example: ["org.foo.bar.Error.Failed"] *) + +type message = string + (** An error message *) + +exception DBus of name * message + (** General exception for D-Bus errors. When the reply to a method + call is a D-Bus error that have not been registered, this + exception is raised. + + Arguments are: + - the D-Bus error name + - the error message + *) + +val ocaml : name + (** The name of the D-Bus error which is generated for uncaught + ocaml exceptions that have not been registered *) + +(** {6 D-Bus errors creating/casting} *) + +val name : exn -> name + (** [name exn] returns the D-Bus error name under which this + exception is registered. If the exception is not registered, + then [ocaml] is returned. *) + +val make : name -> message -> exn + (** [make exn message] creates an exception from an error name and + an error message. If the name is not registered, then + [DBus(name, message)] is returned. *) + +val cast : exn -> name * message + (** [cast exn] returns the D-Bus name and message of the given + exception. If the exception is not registered, [(ocaml, + Printexc.to_string exn)] is returned. *) + +(** {6 Errors registration} *) + +(** Signature for D-Bus error *) +module type Error = sig + exception E of string + (** The OCaml exception for this error *) + + val name : name + (** The D-Bus name if this error *) +end + +module Register(Error : Error) : sig end + (** Register an error. The typical use of the functor is: + + {[ + exception My_exception of string + let module M = + OBus_error.Register(struct + exception E = My_exception + let name = "my.exception.name" + end) + in () + ]} + + But you can also write this with the syntax extension: + + {[ + exception My_exception of string + [@@obus "my.exception.name"] + ]} + *) + +(** {6 Well-known dbus exception} *) + +(** The following errors can be raised by any service. You can also + raise them in a method your service implement. + + Note that the error message will normally be shown to the user so + they must be explicative. *) + +exception Failed of message + (** The [org.freedesktop.DBus.Error.Failed] error *) + +exception Invalid_args of message + (** The [org.freedesktop.DBus.Error.InvalidArgs] error *) + +exception Unknown_method of message + (** The [org.freedesktop.DBus.Error.UnknownMethod] error *) + +exception Unknown_object of message + (** The [org.freedesktop.DBus.Error.UnknownObject] error *) + +exception Unknown_interface of message + (** The [org.freedesktop.DBus.Error.UnknownInterface] error *) + +exception Unknown_property of message + (** The [org.freedesktop.DBus.Error.UnknownProperty] error *) + +exception Property_read_only of message + (** The [org.freedesktop.DBus.Error.PropertyReadOnly] error *) + +exception No_memory of message + (** The [org.freedesktop.DBus.Error.NoMemory] error *) + +exception No_reply of message + (** The [org.freedesktop.DBus.Error.NoReply] error *) diff --git a/src/protocol/oBus_info.ml b/src/protocol/oBus_info.ml new file mode 100644 index 0000000..d156910 --- /dev/null +++ b/src/protocol/oBus_info.ml @@ -0,0 +1,34 @@ +(* + * oBus_info.ml + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(info)" + +let version = OBus_config.version + +let protocol_version = 1 +let max_name_length = OBus_protocol.max_name_length +let max_message_size = OBus_protocol.max_message_size + +let read_uuid_file file = + try%lwt + let%lwt line = Lwt_io.with_file ~mode:Lwt_io.input file Lwt_io.read_line in + Lwt.return (OBus_uuid.of_string line) + with exn -> + ignore (Lwt_log.error_f ~section ~exn "failed to read the local machine uuid from file %S" file); + Lwt.fail exn + +let machine_uuid = lazy( + try%lwt + read_uuid_file OBus_config.machine_uuid_file + with exn -> + try%lwt + read_uuid_file "/etc/machine-id" + with _ -> + Lwt.fail exn +) diff --git a/src/protocol/oBus_info.mli b/src/protocol/oBus_info.mli new file mode 100644 index 0000000..1456696 --- /dev/null +++ b/src/protocol/oBus_info.mli @@ -0,0 +1,27 @@ +(* + * oBus_info.mli + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Various informations *) + +val version : string + (** version of obus *) + +val machine_uuid : OBus_uuid.t Lwt.t Lazy.t + (** UUID of the machine we are running on *) + +val protocol_version : int + (** The version of the D-Bus protocol implemented by the library *) + +val max_name_length : int + (** Maximum length of a name (=255). This limit applies to bus + names, interfaces, and members *) + +val max_message_size : int + (** Maximum size of a message. In this version of the protocol this + is 2^27 bytes (128MB). *) diff --git a/src/protocol/oBus_interfaces.obus b/src/protocol/oBus_interfaces.obus new file mode 100644 index 0000000..da5f8bb --- /dev/null +++ b/src/protocol/oBus_interfaces.obus @@ -0,0 +1,76 @@ +(* + * oBus_interfaces.obus + * -------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +interface org.freedesktop.DBus.Peer { + method Ping : () -> () + method GetMachineId : () -> (machine_id : string) +} + +interface org.freedesktop.DBus.Introspectable { + method Introspect : () -> (result : string) +} + +interface org.freedesktop.DBus.Properties { + method Get : (interface_name : string, member : string) -> (value : variant) + method Set : (interface_name : string, member : string, value : variant) -> () + method GetAll : (interface_name : string) -> (values : (string, variant) dict) + signal PropertiesChanged : (interface_name : string, updates : (string, variant) dict, invalidates : string array) +} + +interface org.freedesktop.DBus { + method Hello : () -> (name : string) + + flag request_name_flags : uint32 { + 0b001: allow_replacement + 0b010: replace_existing + 0b100: do_not_queue + } + + enum request_name_result : uint32 { + 1: primary_owner + 2: in_queue + 3: exists + 4: already_owner + } + + method RequestName : (name : string, flags : request_name_flags) -> (result : request_name_result) + + enum release_name_result : uint32 { + 1: released + 2: non_existent + 3: not_owner + } + + method ReleaseName : (name : string) -> (result : release_name_result) + + enum start_service_by_name_result : uint32 { + 1: success + 2: already_running + } + + method StartServiceByName : (name : string, flags : uint32) -> (result : start_service_by_name_result) + + method UpdateActivationEnvironment : (x1 : (string, string) dict) -> () + method NameHasOwner : (x1 : string) -> (x1 : boolean) + method ListNames : () -> (x1 : string array) + method ListActivatableNames : () -> (x1 : string array) + method AddMatch : (x1 : string) -> () + method RemoveMatch : (x1 : string) -> () + method GetNameOwner : (x1 : string) -> (x1 : string) + method ListQueuedOwners : (x1 : string) -> (x1 : string array) + method GetConnectionUnixUser : (x1 : string) -> (x1 : uint32) + method GetConnectionUnixProcessID : (x1 : string) -> (x1 : uint32) + method GetAdtAuditSessionData : (x1 : string) -> (x1 : byte array) + method GetConnectionSELinuxSecurityContext : (x1 : string) -> (x1 : byte array) + method ReloadConfig : () -> () + method GetId : () -> (x1 : string) + signal NameOwnerChanged : (x1 : string, x2 : string, x3 : string) + signal NameLost : (x1 : string) + signal NameAcquired : (x1 : string) +} diff --git a/src/protocol/oBus_match.ml b/src/protocol/oBus_match.ml new file mode 100644 index 0000000..d002460 --- /dev/null +++ b/src/protocol/oBus_match.ml @@ -0,0 +1,521 @@ +(* + * oBus_match.ml + * ------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(match)" + +(* +-----------------------------------------------------------------+ + | Types | + +-----------------------------------------------------------------+ *) + +type argument_filter = + | AF_string of string + | AF_string_path of string + | AF_namespace of string + +type arguments = (int * argument_filter) list + +type rule = { + typ : [ `Signal | `Error | `Method_call | `Method_return ] option; + sender : OBus_name.bus; + interface : OBus_name.interface; + member : OBus_name.member; + path : OBus_path.t option; + destination : OBus_name.bus; + arguments : arguments; + eavesdrop : bool option; +} + +let typ e = e.typ +let sender e = e.sender +let interface e = e.interface +let member e = e.member +let path e = e.path +let destination e = e.destination +let arguments e = e.arguments +let eavesdrop e = e.eavesdrop + +let rule ?typ ?(sender="") ?(interface="") ?(member="") ?path ?(destination="") ?(arguments=[]) ?eavesdrop () = { + typ = typ; + sender = sender; + interface = interface; + member = member; + path = path; + destination = destination; + arguments = arguments; + eavesdrop = eavesdrop; +} + +(* +-----------------------------------------------------------------+ + | Arguments lists | + +-----------------------------------------------------------------+ *) + +let rec insert_sorted num filter = function + | [] -> [(num, filter)] + | (num', _) as pair :: rest when num' < num -> + pair :: insert_sorted num filter rest + | (num', _) :: rest when num' = num -> + (num, filter) :: rest + | ((num', _) :: rest) as l -> + (num, filter) :: l + +let make_arguments list = + List.fold_left + (fun l (num, filter) -> + if num < 0 || num > 63 then + Printf.ksprintf invalid_arg "OBus_match.arguments_of_list: invalid argument number '%d': it must be in the rane [1..63]" num + else + insert_sorted num filter l) + [] list + +external cast_arguments : arguments -> (int * argument_filter) list = "%identity" + +(* +-----------------------------------------------------------------+ + | string <-> rule | + +-----------------------------------------------------------------+ *) + +let string_of_rule mr = + let buf = Buffer.create 42 in + let rec coma = ref (fun _ -> coma := fun _ -> Buffer.add_char buf ',') in + let add key value = + !coma (); + Buffer.add_string buf key; + Buffer.add_string buf "='"; + Buffer.add_string buf value; + Buffer.add_char buf '\'' + in + let add_string key test = function + | "" -> () + | str -> + match test str with + | Some error -> raise (OBus_string.Invalid_string error) + | None -> add key str + in + begin + match mr.typ with + | None -> () + | Some t -> + add "type" + (match t with + | `Method_call -> "method_call" + | `Method_return -> "method_return" + | `Error -> "error" + | `Signal -> "signal") + end; + add_string "sender" OBus_name.validate_bus mr.sender; + add_string "interface" OBus_name.validate_interface mr.interface; + add_string "member" OBus_name.validate_member mr.member; + begin match mr.path with + | None -> () + | Some [] -> + !coma (); + Buffer.add_string buf "path='/'" + | Some p -> + !coma (); + Buffer.add_string buf "path='"; + List.iter + (fun elt -> + match OBus_path.validate_element elt with + | Some error -> + raise (OBus_string.Invalid_string error) + | None -> + Buffer.add_char buf '/'; + Buffer.add_string buf elt) + p; + Buffer.add_char buf '\'' + end; + add_string "destination" OBus_name.validate_bus mr.destination; + List.iter (fun (n, filter) -> + !coma (); + match filter with + | AF_string str -> + Printf.bprintf buf "arg%d='%s'" n str + | AF_string_path str -> + Printf.bprintf buf "arg%dpath='%s'" n str + | AF_namespace str -> + Printf.bprintf buf "arg%dnamespace='%s'" n str) mr.arguments; + begin match mr.eavesdrop with + | None -> () + | Some true -> add "eavesdrop" "true" + | Some false -> add "eavesdrop" "false" + end; + Buffer.contents buf + +exception Parse_failure of string * int * string + +let () = + Printexc.register_printer + (function + | Parse_failure(str, pos, reason) -> + Some(Printf.sprintf "failed to parse D-Bus matching rule %S, at position %d: %s" str pos reason) + | _ -> + None) + +exception Fail = OBus_match_rule_lexer.Fail + +let rule_of_string str = + try + let l = match str with + | "" -> [] + | _ -> OBus_match_rule_lexer.match_rules (Lexing.from_string str) + in + let check pos validate value = + match validate value with + | None -> + () + | Some err -> + raise (Fail(pos, OBus_string.error_message err)) + in + let mr = { + typ = None; + sender = ""; + interface = ""; + member = ""; + path = None; + destination = ""; + arguments = []; + eavesdrop = None; + } in + List.fold_left begin fun mr (pos, key, value) -> + match key with + | "type" -> + { mr with typ = Some(match value with + | "method_call" -> `Method_call + | "method_return" -> `Method_return + | "signal" -> `Signal + | "error" -> `Error + | _ -> raise (Fail(pos, Printf.sprintf "invalid message type (%s)" value))) } + | "sender" -> + check pos OBus_name.validate_bus value; + { mr with sender = value } + | "destination" -> + check pos OBus_name.validate_bus value; + { mr with destination = value } + | "interface" -> + check pos OBus_name.validate_interface value; + { mr with interface = value } + | "member" -> + check pos OBus_name.validate_member value; + { mr with member = value } + | "path" -> begin + try + { mr with path = Some(OBus_path.of_string value) } + with OBus_string.Invalid_string err -> + raise (Fail(pos, OBus_string.error_message err)) + end + | "eavesdrop" -> begin + match value with + | "true" -> { mr with eavesdrop = Some true } + | "false" -> { mr with eavesdrop = Some false } + | _ -> raise (Fail(pos, Printf.sprintf "invalid value for eavesdrop (%s)" value)) + end + | _ -> + match OBus_match_rule_lexer.arg (Lexing.from_string key) with + | Some(n, kind) -> + { mr with arguments = + insert_sorted n + (match kind with + | `String -> AF_string value + | `Path -> AF_string_path value + | `Namespace -> AF_namespace value) + mr.arguments } + | None -> + raise (Fail(pos, Printf.sprintf "invalid key (%s)" key)) + end mr l + with Fail(pos, msg) -> + raise (Parse_failure(str, pos, msg)) + +(* +-----------------------------------------------------------------+ + | Matching | + +-----------------------------------------------------------------+ *) + +let match_key matcher value = match matcher with + | None -> true + | Some value' -> value = value' + +let match_string matcher value = match matcher with + | "" -> true + | value' -> value = value' + +let starts_with str prefix = + let str_len = String.length str and prefix_len = String.length prefix in + let rec loop i = + (i = prefix_len) || (i < str_len && str.[i] = prefix.[i] && loop (i + 1)) + in + loop 0 + +let ends_with_slash str = str <> "" && str.[String.length str - 1] = '/' + +let rec match_arguments num matcher arguments = match matcher with + | [] -> + true + | (num', filter) :: rest -> + match_arguments_aux num num' filter rest arguments + +and match_arguments_aux num num' filter matcher arguments = match arguments with + | [] -> + false + | value :: rest when num < num' -> + match_arguments_aux (num + 1) num' filter matcher rest + | OBus_value.V.Basic(OBus_value.V.String value) :: rest -> + (match filter with + | AF_string str -> + str = value + | AF_string_path str -> + (str = value) + || (ends_with_slash str && starts_with value str) + || (ends_with_slash value && starts_with str value) + | AF_namespace str -> + starts_with value str && + (String.length value = String.length str || + value.[String.length str] = '.')) + && match_arguments (num + 1) matcher rest + | OBus_value.V.Basic(OBus_value.V.Object_path value) :: rest -> + (match filter with + | AF_string str -> + false + | AF_string_path str -> + let value = OBus_path.to_string value in + (str = value) + || (ends_with_slash str && starts_with value str) + || (ends_with_slash value && starts_with str value) + | AF_namespace _ -> + false) + && match_arguments (num + 1) matcher rest + | _ -> + false + +let match_values filters values = + match_arguments 0 filters values + +let match_message mr msg = + (match OBus_message.typ msg, mr.typ with + | OBus_message.Method_call(path, interface, member), (Some `Method_call | None) -> + (match_key mr.path path) && + (match_string mr.interface interface) && + (match_string mr.member member) + | OBus_message.Method_return serial, (Some `Method_return | None)-> + true + | OBus_message.Signal(path, interface, member), (Some `Signal | None) -> + (match_key mr.path path) && + (match_string mr.interface interface) && + (match_string mr.member member) + | OBus_message.Error(serial, name), (Some `Error | None) -> + true + | _ -> + false) && + (match_string mr.sender (OBus_message.sender msg)) && + (match_string mr.destination (OBus_message.destination msg)) && + (match_arguments 0 mr.arguments (OBus_message.body msg)) + +(* +-----------------------------------------------------------------+ + | Comparison | + +-----------------------------------------------------------------+ *) + +type comparison_result = + | More_general + | Less_general + | Equal + | Incomparable + +let rec compare_arguments acc l1 l2 = + match acc, l1, l2 with + | acc, [], [] -> + acc + | (Less_general | Equal), _ :: _, [] -> + Less_general + | (More_general | Equal), [], _ :: _ -> + More_general + | acc, (pos1, filter1) :: rest1, (pos2, filter2) :: rest2 -> + if pos1 = pos2 && filter1 = filter2 then + compare_arguments acc rest1 rest2 + else if pos1 < pos2 && (acc = Less_general || acc = Equal) then + compare_arguments Less_general rest1 l2 + else if pos1 > pos2 && (acc = More_general || acc = Equal) then + compare_arguments More_general l1 rest2 + else + raise Exit + | _ -> + raise Exit + +let compare_option acc x1 x2 = + if x1 = x2 then + acc + else + match acc, x1, x2 with + | (Less_general | Equal), Some _, None -> + Less_general + | (More_general | Equal), None, Some _ -> + More_general + | _ -> + raise Exit + +let compare_string acc x1 x2 = + if x1 = x2 then + acc + else + match acc, x1, x2 with + | (Less_general | Equal), x, "" when x <> "" -> + Less_general + | (More_general | Equal), "", x when x <> "" -> + More_general + | _ -> + raise Exit + +let compare_rules r1 r2 = + try + if r1.typ = r2.typ then begin + let acc = Equal in + let acc = compare_string acc r1.sender r2.sender in + let acc = compare_string acc r1.destination r2.destination in + let acc = compare_option acc r1.path r2.path in + let acc = compare_string acc r1.interface r2.interface in + let acc = compare_string acc r1.member r2.member in + let acc = compare_arguments acc r1.arguments r2.arguments in + if r1.eavesdrop = r2.eavesdrop then + acc + else + match acc, r1.eavesdrop, r2.eavesdrop with + | _, None, Some false -> + acc + | _, Some false, None -> + acc + | (Less_general | Equal), (None | Some false), Some true -> + Less_general + | (More_general | Equal), Some true, (None | Some false) -> + More_general + | _ -> + Incomparable + end else + Incomparable + with Exit -> + Incomparable + +(* +-----------------------------------------------------------------+ + | Exporting rules on message buses | + +-----------------------------------------------------------------+ *) + +module String_set = Set.Make(String) + +(* Informations stored in connections *) +type info = { + mutable exported : String_set.t; + (* Rules that are currently exported on the message bus (as strings) *) + + mutable rules : rule list; + (* The list of all rules we want to export *) + + connection : OBus_connection.t; + (* The connection on which the rules are exported *) + + mutex : Lwt_mutex.t; + (* Mutex to prevent concurrent modifications of rules *) +} + +(* Add a matching rule to a list of incomparable most general rules *) +let rec insert_rule rule rules = + match rules with + | [] -> + [rule] + | rule' :: rest -> + match compare_rules rule rule' with + | Incomparable -> + rule' :: insert_rule rule rest + | Equal | Less_general -> + rules + | More_general -> + rule :: rest + +let do_export info rule_string = + let%lwt () = + OBus_connection.method_call + ~connection:info.connection + ~destination:OBus_protocol.bus_name + ~path:OBus_protocol.bus_path + ~interface:OBus_protocol.bus_interface + ~member:"AddMatch" + ~i_args:(OBus_value.C.seq1 OBus_value.C.basic_string) + ~o_args:OBus_value.C.seq0 + rule_string + in + info.exported <- String_set.add rule_string info.exported; + Lwt.return () + +let do_remove info rule_string = + info.exported <- String_set.remove rule_string info.exported; + try%lwt + OBus_connection.method_call + ~connection:info.connection + ~destination:OBus_protocol.bus_name + ~path:OBus_protocol.bus_path + ~interface:OBus_protocol.bus_interface + ~member:"RemoveMatch" + ~i_args:(OBus_value.C.seq1 OBus_value.C.basic_string) + ~o_args:OBus_value.C.seq0 + rule_string + with exn -> + match OBus_error.name exn with + | "org.freedesktop.DBus.Error.MatchRuleNotFound" -> + Lwt_log.info_f ~section "rule %S does not exists on the message bus" rule_string + | _ -> + Lwt.fail exn + +(* Commits rules changes on the message bus: *) +let commit info = + Lwt_mutex.with_lock info.mutex + (fun () -> + (* Computes the set of most general rules: *) + let rules = List.fold_left (fun acc rule -> insert_rule rule acc) [] info.rules in + + (* Turns them into a set of strings: *) + let rules = List.fold_left (fun acc rule -> String_set.add (string_of_rule rule) acc) String_set.empty rules in + + (* Computes the minimal set of operations to update the rules: *) + let new_rules = String_set.diff rules info.exported + and old_rules = String_set.diff info.exported rules in + + (* Does the update of rules on the message bus: *) + let threads = [] in + let threads = String_set.fold (fun rule acc -> do_export info rule :: acc) new_rules threads in + let threads = String_set.fold (fun rule acc -> do_remove info rule :: acc) old_rules threads in + + Lwt.join threads) + +let key = OBus_connection.new_key () + +let rec remove_first x l = + match l with + | [] -> [] + | x' :: l when x = x' -> l + | x' :: l -> x' :: remove_first x l + +let export ?switch connection rule = + Lwt_switch.check switch; + let info = + match OBus_connection.get connection key with + | Some info -> + info + | None -> + let info = { + exported = String_set.empty; + connection = connection; + rules = []; + mutex = Lwt_mutex.create (); + } in + OBus_connection.set connection key (Some info); + info + in + info.rules <- rule :: info.rules; + let%lwt () = commit info in + let%lwt () = + Lwt_switch.add_hook_or_exec switch + (fun () -> + info.rules <- remove_first rule info.rules; + commit info) + in + Lwt.return () diff --git a/src/protocol/oBus_match.mli b/src/protocol/oBus_match.mli new file mode 100644 index 0000000..c6884d6 --- /dev/null +++ b/src/protocol/oBus_match.mli @@ -0,0 +1,141 @@ +(* + * oBus_match.mli + * -------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Matching rules *) + +(** {6 Rules} *) + +(** Type of an argument filter. Argument filters are used in match + rules to match message arguments. *) +type argument_filter = + | AF_string of string + (** [AF_string str] matches any string argument which is equal + to [str] *) + | AF_string_path of string + (** [AF_string_path path] matches any string or object-path + argument [arg] such that one of the following conditions + hold: + + - [arg] is equal to [path] + - [path] ends with ['/'] and is a prefix of [arg] + - [arg] ends with ['/'] and is a prefix of [path] *) + | AF_namespace of string + (** [AF_namespace namespace] matches any string argument [arg] + such that [arg] is a bus or interface name in the namespace of + [namespace]. For example [AF_namespace "a.b.c"] matches any + string of the form ["a.b.c"], ["a.b.c.foo"], + ["a.b.c.foo.bar"], ... *) + +type arguments = private (int * argument_filter) list + (** Type of lists of argument filters. The private type ensures + that such lists are always sorted by argument number, do not + contain duplicates and indexes are in the range [0..63].. *) + +val make_arguments : (int * argument_filter) list -> arguments + (** Creates an arguments filter from a list of filters. It raises + [Invalid_argument] if one of the argument filters use a number + outside of the range [1..63] *) + +external cast_arguments : arguments -> (int * argument_filter) list = "%identity" + (** Returns the list of filters for the given arguments filter. *) + +(** Type of a rule used to match a message *) +type rule = { + typ : [ `Signal | `Error | `Method_call | `Method_return ] option; + sender : OBus_name.bus; + interface : OBus_name.interface; + member : OBus_name.member; + path : OBus_path.t option; + destination : OBus_name.bus; + arguments : arguments; + eavesdrop : bool option; +} + +(** {8 Rule projections} *) + +val typ : rule -> [ `Signal | `Error | `Method_call | `Method_return ] option +val sender : rule -> OBus_name.bus +val interface : rule -> OBus_name.interface +val member : rule -> OBus_name.member +val path : rule -> OBus_path.t option +val destination : rule -> OBus_name.bus +val arguments : rule -> arguments +val eavesdrop : rule -> bool option + +(** {8 Rule construction} *) + +val rule : + ?typ : [ `Signal | `Error | `Method_call | `Method_return ] -> + ?sender : OBus_name.bus -> + ?interface : OBus_name.interface -> + ?member : OBus_name.member -> + ?path : OBus_path.t -> + ?destination : OBus_name.bus -> + ?arguments : arguments -> + ?eavesdrop : bool -> + unit -> rule + (** Create a matching rule. *) + +(** {6 Matching} *) + +val match_message : rule -> OBus_message.t -> bool + (** [match_message rule message] returns wether [message] is matched + by [rule] *) + +val match_values : arguments -> OBus_value.V.sequence -> bool + (** [match_values filters values] returns whether [values] are + matched by the given list of argument filters. *) + +(** {6 Comparison} *) + +(** Result of the comparisong of two rules [r1] and [r2]: *) +type comparison_result = + | More_general + (** [r1] is more general than [r2], i.e. any message matched by + [r2] is also matched by [r1] *) + | Less_general + (** [r1] is less general than [r2], i.e. any message matched by + [r1] is also matched by [r2] *) + | Equal + (** [r1] and [r2] are equal *) + | Incomparable + (** [r1] and [r2] are incomparable, i.e. there exists two + message [m1] and [m2] such that: + + - [m1] is matched by [r1] but not by [r2] + - [m2] is matched by [r2] but not by [r1] + *) + +val compare_rules : rule -> rule -> comparison_result + (** [compare_rules r1 r2] compares the two matching rules [r1] and + [r2] *) + +(** {6 Parsing/printing} *) + +exception Parse_failure of string * int * string + (** [Parse_failure(string, position, reason)] is raised when parsing + a rule failed *) + +val string_of_rule : rule -> string + (** Returns a string representation of a matching rule. *) + +val rule_of_string : string -> rule + (** Parse a string representation of a matching rule. + + @raise Failure if the given string does not contain a valid + matching rule. *) + +(** {6 Rules and message buses} *) + +val export : ?switch : Lwt_switch.t -> OBus_connection.t -> rule -> unit Lwt.t + (** [export ?switch connection rule] registers [rule] on the message + bus. If another rule more general than [rule] is already + exported, then it does nothihng. + + You can provide a switch to manually disable the export. *) diff --git a/src/protocol/oBus_match_rule_lexer.mll b/src/protocol/oBus_match_rule_lexer.mll new file mode 100644 index 0000000..8f5ae2b --- /dev/null +++ b/src/protocol/oBus_match_rule_lexer.mll @@ -0,0 +1,60 @@ +(* + * oBus_match_rule_lexer.mll + * ------------------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +{ + exception Fail of int * string + + let pos lexbuf = lexbuf.Lexing.lex_start_p.Lexing.pos_cnum + + let fail lexbuf fmt = + Printf.ksprintf + (fun msg -> raise (Fail(pos lexbuf, msg))) + fmt +} + +rule match_rules = parse + | (['a'-'z' '_' '0'-'9']+ as key) "='" ([^ '\'']* as value) '\'' + { if comma lexbuf then + (pos lexbuf, key, value) :: match_rules lexbuf + else begin + check_eof lexbuf; + [(pos lexbuf, key, value)] + end } + | "=" { + fail lexbuf "empty key" + } + | eof { + fail lexbuf "match rule expected" + } + | _ as ch { + fail lexbuf "invalid character %C" ch + } + +and comma = parse + | ',' { true } + | "" { false } + +and check_eof = parse + | eof { () } + | _ as ch { fail lexbuf "invalid character %C" ch } + +and arg = parse + | "arg" (['0'-'9']+ as n) (("" | "path" | "namespace") as kind) eof { + let n = int_of_string n in + if n >= 0 && n <= 63 then + Some(n, + match kind with + | "" -> `String + | "path" -> `Path + | "namespace" -> `Namespace + | _ -> assert false) + else + fail lexbuf "invalid argument number '%d': it must be between 0 and 63" n + } + | "" { None } diff --git a/src/protocol/oBus_member.ml b/src/protocol/oBus_member.ml new file mode 100644 index 0000000..e4c7e9c --- /dev/null +++ b/src/protocol/oBus_member.ml @@ -0,0 +1,111 @@ +(* + * oBus_member.ml + * -------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open OBus_introspect + +let introspect_arguments args = + List.map2 + (fun name typ -> (name, typ)) + (OBus_value.arg_names args) + (OBus_value.C.type_sequence (OBus_value.arg_types args)) + +module Method = +struct + type ('a, 'b) t = { + interface : OBus_name.interface; + member : OBus_name.member; + i_args : 'a OBus_value.arguments; + o_args : 'b OBus_value.arguments; + annotations : OBus_introspect.annotation list; + } + + let make ~interface ~member ~i_args ~o_args ~annotations = { + interface = interface; + member = member; + i_args = i_args; + o_args = o_args; + annotations = annotations; + } + + let interface m = m.interface + let member m = m.member + let i_args m = m.i_args + let o_args m = m.o_args + let annotations m = m.annotations + + let introspect m = + Method(m.member, introspect_arguments m.i_args, introspect_arguments m.o_args, m.annotations) +end + +module Signal = +struct + type 'a t = { + interface : OBus_name.interface; + member : OBus_name.member; + args : 'a OBus_value.arguments; + annotations : OBus_introspect.annotation list; + } + + let make ~interface ~member ~args ~annotations = { + interface = interface; + member = member; + args = args; + annotations = annotations; + } + + let interface s = s.interface + let member s = s.member + let args s = s.args + let annotations s = s.annotations + + let introspect s = + Signal(s.member, introspect_arguments s.args, s.annotations) +end + +module Property = +struct + type 'a access = + | Readable + | Writable + | Readable_writable + + let readable = Readable + let writable = Writable + let readable_writable = Readable_writable + + type ('a, 'access) t = { + interface : OBus_name.interface; + member : OBus_name.member; + typ : 'a OBus_value.C.single; + access : 'access access; + annotations : OBus_introspect.annotation list; + } + + let make ~interface ~member ~typ ~access ~annotations = { + interface = interface; + member = member; + typ = typ; + access = access; + annotations = annotations; + } + + let interface p = p.interface + let member p = p.member + let typ p = p.typ + let access p = p.access + let annotations p = p.annotations + + let introspect p = + Property(p.member, OBus_value.C.type_single p.typ, + (match p.access with + | Readable -> Read + | Writable -> Write + | Readable_writable -> Read_write), + p.annotations) +end diff --git a/src/protocol/oBus_member.mli b/src/protocol/oBus_member.mli new file mode 100644 index 0000000..f901d1f --- /dev/null +++ b/src/protocol/oBus_member.mli @@ -0,0 +1,133 @@ +(* + * oBus_member.mli + * --------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus members description *) + +(** D-Bus Methods *) +module Method : sig + + (** D-Bus method description *) + + (** Type of a method description *) + type ('a, 'b) t = { + interface : OBus_name.interface; + member : OBus_name.member; + i_args : 'a OBus_value.arguments; + (** Input arguments *) + o_args : 'b OBus_value.arguments; + (** Output arguments *) + annotations : OBus_introspect.annotation list; + } + + (** {6 Creation} *) + + val make : + interface : OBus_name.interface -> + member : OBus_name.member -> + i_args : 'a OBus_value.arguments -> + o_args : 'b OBus_value.arguments -> + annotations : OBus_introspect.annotation list -> ('a, 'b) t + + (** {6 Projections} *) + + val interface : ('a, 'b) t -> OBus_name.interface + val member : ('a, 'b) t -> OBus_name.member + val i_args : ('a, 'b) t -> 'a OBus_value.arguments + val o_args : ('a, 'b) t -> 'b OBus_value.arguments + val annotations : ('a, 'b) t -> OBus_introspect.annotation list + + (** {6 Introspection} *) + + val introspect : ('a, 'b) t -> OBus_introspect.member +end + +(** D-Bus signals *) +module Signal : sig + + (** D-Bus signal description *) + + (** Type of a signal description *) + type 'a t = { + interface : OBus_name.interface; + member : OBus_name.member; + args : 'a OBus_value.arguments; + annotations : OBus_introspect.annotation list; + } + + (** {6 Creation} *) + + val make : + interface : OBus_name.interface -> + member : OBus_name.member -> + args : 'a OBus_value.arguments -> + annotations : OBus_introspect.annotation list -> 'a t + + (** {6 Projections} *) + + val interface : 'a t -> OBus_name.interface + val member : 'a t -> OBus_name.member + val args : 'a t -> 'a OBus_value.arguments + val annotations : 'a t -> OBus_introspect.annotation list + + (** {6 Introspection} *) + + val introspect : 'a t -> OBus_introspect.member +end + +(** D-Bus properties *) +module Property : sig + + (** D-Bus property description *) + + (** Type of access modes *) + type 'a access = + private + | Readable + | Writable + | Readable_writable + + val readable : [ `readable ] access + (** Access mode for readable properties *) + + val writable : [ `writable ] access + (** Access mode for writable properties *) + + val readable_writable : [ `readable | `writable ] access + (** Access mode for readable and writable properties *) + + (** Type of a property description *) + type ('a, 'access) t = { + interface : OBus_name.interface; + member : OBus_name.member; + typ : 'a OBus_value.C.single; + access : 'access access; + annotations : OBus_introspect.annotation list; + } + + (** {6 Creation} *) + + val make : + interface : OBus_name.interface -> + member : OBus_name.member -> + typ : 'a OBus_value.C.single -> + access : 'access access -> + annotations : OBus_introspect.annotation list -> ('a, 'access) t + + (** {6 Projections} *) + + val interface : ('a, 'access) t -> OBus_name.interface + val member : ('a, 'access) t -> OBus_name.member + val typ : ('a, 'access) t -> 'a OBus_value.C.single + val access : ('a, 'access) t -> 'access access + val annotations : ('a, 'access) t -> OBus_introspect.annotation list + + (** {6 Introspection} *) + + val introspect : ('a, 'access) t -> OBus_introspect.member +end diff --git a/src/protocol/oBus_message.ml b/src/protocol/oBus_message.ml new file mode 100644 index 0000000..9a33ba5 --- /dev/null +++ b/src/protocol/oBus_message.ml @@ -0,0 +1,136 @@ +(* + * oBus_message.ml + * --------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +type serial = int32 +type body = OBus_value.V.sequence + +type flags = { + no_reply_expected : bool; + no_auto_start : bool; +} + +let no_reply_expected flags = flags.no_reply_expected +let no_auto_start flags = flags.no_auto_start + +let default_flags = { + no_reply_expected = false; + no_auto_start = false; +} + +let make_flags ?(no_reply_expected=false) ?(no_auto_start=false) () = { + no_reply_expected = no_reply_expected; + no_auto_start = no_auto_start; +} + +type typ = + | Method_call of OBus_path.t * OBus_name.interface * OBus_name.member + | Method_return of serial + | Error of serial * OBus_name.error + | Signal of OBus_path.t * OBus_name.interface * OBus_name.member + +type t = { + flags : flags; + serial : serial; + typ : typ; + destination : OBus_name.bus; + sender : OBus_name.bus; + body : body; +} + +let flags m = m.flags +let serial m = m.serial +let typ m = m.typ +let destination m = m.destination +let sender m = m.sender +let body m = m.body + +let make ?(flags=default_flags) ?(serial=0l) ?(sender="") ?(destination="") ~typ body = + { flags = flags; + serial = serial; + typ = typ; + destination = destination; + sender = sender; + body = body } + +let method_call ?flags ?serial ?sender ?destination ~path ?(interface="") ~member body = + make ?flags ?serial ?sender ?destination ~typ:(Method_call(path, interface, member)) body + +let method_return ?flags ?serial ?sender ?destination ~reply_serial body = + make ?flags ?serial ?sender ?destination ~typ:(Method_return(reply_serial)) body + +let error ?flags ?serial ?sender ?destination ~reply_serial ~error_name body = + make ?flags ?serial ?sender ?destination ~typ:(Error(reply_serial, error_name)) body + +let signal ?flags ?serial ?sender ?destination ~path ~interface ~member body = + make ?flags ?serial ?sender ?destination ~typ:(Signal(path, interface, member)) body + +exception Invalid_reply of string + +let invalid_reply ~method_call ~expected_signature ~method_return = + match method_call, method_return with + | { typ = Method_call(path, interface, member) }, { typ = Method_return _; body } -> + Invalid_reply + (Printf.sprintf + "unexpected signature for the reply to the method %S on interface %S, expected: %S, got: %S" + member + interface + (OBus_value.string_of_signature expected_signature) + (OBus_value.string_of_signature (OBus_value.V.type_of_sequence body))) + | _ -> + invalid_arg "OBus_message.invalid_reply" + +open Format +open OBus_value + +let print pp message = + fprintf pp + "no_reply_expected = %B@\n\ + no_auto_start = %B@\n\ + serial = %ld@\n\ + message_type = %a@\n\ + sender = %S@\n\ + destination = %S@\n\ + signature = %S@\n\ + body_type = %a@\n\ + body = %a@\n" + message.flags.no_reply_expected + message.flags.no_auto_start + message.serial + (fun pp -> function + | Method_call(path, interface, member) -> + fprintf pp + "method_call@\n\ + path = %S@\n\ + interface = %S@\n\ + member = %S" + (OBus_path.to_string path) interface member + | Method_return reply_serial -> + fprintf pp + "method_return@\n\ + reply_serial = %ld" + reply_serial + | Error(reply_serial, error_name) -> + fprintf pp + "error@\n\ + reply_serial = %ld@\n\ + error_name = %S" + reply_serial error_name + | Signal(path, interface, member) -> + fprintf pp + "signal@\n\ + path = %S@\n\ + interface = %S@\n\ + member = %S" + (OBus_path.to_string path) interface member) + message.typ + message.sender + message.destination + (string_of_signature (V.type_of_sequence message.body)) + T.print_sequence (V.type_of_sequence message.body) + V.print_sequence message.body diff --git a/src/protocol/oBus_message.mli b/src/protocol/oBus_message.mli new file mode 100644 index 0000000..a56dae5 --- /dev/null +++ b/src/protocol/oBus_message.mli @@ -0,0 +1,131 @@ +(* + * oBus_message.mli + * ---------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Message description *) + +type serial = int32 + +(** {6 Message structure} *) + +type body = OBus_value.V.sequence + (** The body is a sequence of dynamically typed values *) + +type typ = + | Method_call of OBus_path.t * OBus_name.interface * OBus_name.member + | Method_return of serial + | Error of serial * OBus_name.error + | Signal of OBus_path.t * OBus_name.interface * OBus_name.member + +(** flags *) +type flags = { + no_reply_expected : bool; + no_auto_start : bool; +} + +val no_reply_expected : flags -> bool + (** [no_reply_expected] projection *) + +val no_auto_start : flags -> bool + (** [no_auto_start] projection *) + +val make_flags : ?no_reply_expected:bool -> ?no_auto_start:bool -> unit -> flags + (** Creates message flags. All optional arguments default to + [false] *) + +val default_flags : flags + (** All false *) + +type t = { + flags : flags; + serial : serial; + typ : typ; + destination : OBus_name.bus; + sender : OBus_name.bus; + body : body; +} + +(** {8 Projections} *) + +val flags : t -> flags +val serial : t -> serial +val typ : t -> typ +val destination : t -> OBus_name.bus +val sender : t -> OBus_name.bus +val body : t -> body + +(** {6 Helpers for creating messages} *) + +(** Note that when creating a message the serial field is not + relevant, it is overridden by {!OBus_connection} at + sending-time *) + +val make : + ?flags : flags -> + ?serial : serial -> + ?sender : OBus_name.bus -> + ?destination : OBus_name.bus -> + typ : typ -> + body -> t + +val method_call : + ?flags : flags -> + ?serial : serial -> + ?sender : OBus_name.bus -> + ?destination : OBus_name.bus -> + path : OBus_path.t -> + ?interface : OBus_name.interface -> + member : OBus_name.member -> + body -> t + +val method_return : + ?flags : flags -> + ?serial : serial -> + ?sender : OBus_name.bus -> + ?destination : OBus_name.bus -> + reply_serial : serial -> + body -> t + +val error : + ?flags : flags -> + ?serial : serial -> + ?sender : OBus_name.bus -> + ?destination : OBus_name.bus -> + reply_serial : serial -> + error_name : OBus_name.error -> + body -> t + +val signal : + ?flags : flags -> + ?serial : serial -> + ?sender : OBus_name.bus -> + ?destination : OBus_name.bus -> + path : OBus_path.t -> + interface : OBus_name.interface -> + member : OBus_name.member -> + body -> t + +(** {6 Errors} *) + +exception Invalid_reply of string + (** Exception raised when the signature of the reply to a method + call does not match the expected signature. The argument is an + error message. *) + +val invalid_reply : method_call : t -> expected_signature : OBus_value.signature -> method_return : t -> exn + (** [invalid_reply ~method_call ~expected_signature ~method_return] + @return an {!Invalid_reply} exception with a informative + description of the error. + @raise Invalid_argument if [method_call] is not a method + call message or [method_return] is not a method return + message *) + +(** {6 Pretty-printing} *) + +val print : Format.formatter -> t -> unit + (** Print a message on a formatter *) diff --git a/src/protocol/oBus_method.ml b/src/protocol/oBus_method.ml new file mode 100644 index 0000000..c2133cf --- /dev/null +++ b/src/protocol/oBus_method.ml @@ -0,0 +1,45 @@ +(* + * oBus_method.ml + * -------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(method)" + +let call info proxy args = + OBus_connection.method_call + ~connection:(OBus_proxy.connection proxy) + ~destination:(OBus_proxy.name proxy) + ~path:(OBus_proxy.path proxy) + ~interface:(OBus_member.Method.interface info) + ~member:(OBus_member.Method.member info) + ~i_args:(OBus_value.arg_types (OBus_member.Method.i_args info)) + ~o_args:(OBus_value.arg_types (OBus_member.Method.o_args info)) + args + +let call_with_context info proxy args = + let%lwt msg, result = + OBus_connection.method_call_with_message + ~connection:(OBus_proxy.connection proxy) + ~destination:(OBus_proxy.name proxy) + ~path:(OBus_proxy.path proxy) + ~interface:(OBus_member.Method.interface info) + ~member:(OBus_member.Method.member info) + ~i_args:(OBus_value.arg_types (OBus_member.Method.i_args info)) + ~o_args:(OBus_value.arg_types (OBus_member.Method.o_args info)) + args + in + Lwt.return (OBus_context.make (OBus_proxy.connection proxy) msg, result) + +let call_no_reply info proxy args = + OBus_connection.method_call_no_reply + ~connection:(OBus_proxy.connection proxy) + ~destination:(OBus_proxy.name proxy) + ~path:(OBus_proxy.path proxy) + ~interface:(OBus_member.Method.interface info) + ~member:(OBus_member.Method.member info) + ~i_args:(OBus_value.arg_types (OBus_member.Method.i_args info)) + args diff --git a/src/protocol/oBus_method.mli b/src/protocol/oBus_method.mli new file mode 100644 index 0000000..e568411 --- /dev/null +++ b/src/protocol/oBus_method.mli @@ -0,0 +1,22 @@ +(* + * oBus_method.mli + * --------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus methods *) + +val call : ('a, 'b) OBus_member.Method.t -> OBus_proxy.t -> 'a -> 'b Lwt.t + (** [call meth proxy args] calls the method [meth] on the object + pointed by [proxy], and wait for the reply. *) + +val call_with_context : ('a, 'b) OBus_member.Method.t -> OBus_proxy.t -> 'a -> (OBus_context.t * 'b) Lwt.t + (** [call_with_context meth proxy args] is like {!call} except that + it also returns the context of the method return *) + +val call_no_reply : ('a, 'b) OBus_member.Method.t -> OBus_proxy.t -> 'a -> unit Lwt.t + (** [call_no_reply meth proxy args] is the same as {!call} except + that it does not wait for a reply *) diff --git a/src/protocol/oBus_object.ml b/src/protocol/oBus_object.ml new file mode 100644 index 0000000..c0863a0 --- /dev/null +++ b/src/protocol/oBus_object.ml @@ -0,0 +1,1014 @@ +(* + * oBus_object.ml + * -------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Lwt_react + +let section = Lwt_log.Section.make "obus(object)" + +(* +-----------------------------------------------------------------+ + | Types | + +-----------------------------------------------------------------+ *) + +module Connection_set = Set.Make(OBus_connection) +module String_set = Set.Make(String) +module String_map = Map.Make(String) +module Path_map = Map.Make(OBus_path) + +module type Method_info = sig + type obj + type i_type + type o_type + val info : (i_type, o_type) OBus_member.Method.t + val handler : obj -> i_type -> o_type Lwt.t +end + +module type Signal_info = sig + type obj + type typ + val info : typ OBus_member.Signal.t +end + +module type Property_info = sig + type obj + type typ + type access + val info : (typ, access) OBus_member.Property.t + val set : (obj -> typ -> unit Lwt.t) option + val signal : (obj -> typ signal) option +end + +module type Property_instance = sig + type typ + type access + val info : (typ, access) OBus_member.Property.t + + val signal : typ signal + (* The signal holding the current value of the property *) + + val monitor : unit event + (* Event which send notifications when the contents of the + property changes *) +end + +type property_instance = (module Property_instance) + +(* An interface descriptor *) +type 'a interface = { + i_name : OBus_name.interface; + (* The name of the interface *) + + i_methods : 'a method_info array; + (* Array of methods, for dispatching method calls and introspection *) + + i_signals : 'a signal_info array; + (* Array of signals, for introspection *) + + i_properties : 'a property_info array; + (* Array of for properties, for reading/writing properties and introspection *) + + i_annotations : OBus_introspect.annotation list; + (* List of annotations of the interfaces. They are used for + introspection *) +} + +(* D-Bus object informations *) +and 'a t = { + path : OBus_path.t; + (* The path of the object *) + + mutable data : 'a option; + (* Data attached to the object *) + + exports : Connection_set.t signal; + set_exports : Connection_set.t -> unit; + (* Set of connection on which the object is exported *) + + owner : OBus_peer.t option; + (* The optionnal owner of the object *) + + mutable interfaces : 'a interface array; + (* Interfaces implemented by this object *) + + mutable properties : property_instance option array array; + (* All property instances of the object *) + + mutable changed : OBus_value.V.single option String_map.t array; + (* Properties that changed since the last upadte, organised by + interface *) + + properties_changed : (OBus_name.interface -> (OBus_name.member * OBus_value.V.single option) list -> unit Lwt.t) ref; + (* Function called when proeprties change. It may emit a + notification signal. The default one use + [org.freedesktop.DBus.Properties.PropertiesChanged] *) +} + +and 'a method_info = (module Method_info with type obj = 'a t) +and 'a signal_info = (module Signal_info with type obj = 'a t) +and 'a property_info = (module Property_info with type obj = 'a t) + +(* Signature for static objects *) +module type Static = sig + type data + (* Type of data attached to the obejct *) + + val obj : data t + (* The object itself *) +end + +type static = (module Static) + +(* Signature for dynamic object *) +module type Dynamic = sig + type data + (* Type of data attached to obejcts *) + + val get : OBus_context.t -> OBus_path.t -> data t Lwt.t +end + +type dynamic = (module Dynamic) + +(* Informations stored in connections *) +type info = { + mutable statics : static Path_map.t; + (* Static objects exported on the connection *) + + mutable dynamics : dynamic Path_map.t; + (* Dynamic objects exported on the connection *) + + mutable watcher : unit event; + (* Event which cleanup things when the connection goes down *) +} + +(* +-----------------------------------------------------------------+ + | Object parameters | + +-----------------------------------------------------------------+ *) + +let path obj = obj.path +let owner obj = obj.owner +let exports obj = obj.exports + +let introspect_args args = + List.map2 + (fun name_opt typ -> (name_opt, typ)) + (OBus_value.arg_names args) + (OBus_value.C.type_sequence (OBus_value.arg_types args)) + +let introspect_method (type d) info = + let module M = (val info : Method_info with type obj = d t) in + OBus_member.Method.introspect M.info + +let introspect_signal (type d) info = + let module S = (val info : Signal_info with type obj = d t) in + OBus_member.Signal.introspect S.info + +let introspect_property (type d) info = + let module P = (val info : Property_info with type obj = d t) in + OBus_member.Property.introspect P.info + +let introspect obj = + Array.fold_right + (fun interface acc -> + let members = [] in + let members = Array.fold_right (fun member acc -> introspect_property member :: acc) interface.i_properties members in + let members = Array.fold_right (fun member acc -> introspect_signal member :: acc) interface.i_signals members in + let members = Array.fold_right (fun member acc -> introspect_method member :: acc) interface.i_methods members in + (interface.i_name, members, interface.i_annotations) :: acc) + obj.interfaces [] + +let on_properties_changed obj = obj.properties_changed + +(* +-----------------------------------------------------------------+ + | Binary search | + +-----------------------------------------------------------------+ *) + +let binary_search compare key array = + let rec loop a b = + if a = b then + -1 + else begin + let middle = (a + b) / 2 in + let cmp = compare key (Array.unsafe_get array middle) in + if cmp = 0 then + middle + else if cmp < 0 then + loop a middle + else + loop (middle + 1) b + end + in + loop 0 (Array.length array) + +let compare_interface name interface = + String.compare name interface.i_name + +let compare_property (type d) name property = + let module P = (val property : Property_info with type obj = d t) in + String.compare name P.info.OBus_member.Property.member + +let compare_method (type d) name method_ = + let module M = (val method_ : Method_info with type obj = d t) in + String.compare name M.info.OBus_member.Method.member + +(* +-----------------------------------------------------------------+ + | Dispatching | + +-----------------------------------------------------------------+ *) + +let unknown_method interface member arguments = + Lwt.fail + (OBus_error.Unknown_method + (Printf.sprintf + "Method %S with signature %S on interface %S does not exist" + member + (OBus_value.string_of_signature (OBus_value.V.type_of_sequence arguments)) + interface)) + +(* Executes a method *) +let execute (type d) method_info context obj arguments = + let module M = (val method_info : Method_info with type obj = d t) in + let arguments = + try + OBus_value.C.cast_sequence + (OBus_value.arg_types (OBus_member.Method.i_args M.info)) + arguments + with OBus_value.C.Signature_mismatch -> + raise + (OBus_error.Failed + (Printf.sprintf + "invalid signature(%S) for method %S on interface %S, must be %S" + (OBus_value.string_of_signature + (OBus_value.V.type_of_sequence arguments)) + (OBus_member.Method.member M.info) + (OBus_member.Method.interface M.info) + (OBus_value.string_of_signature + (OBus_value.C.type_sequence + (OBus_value.arg_types + (OBus_member.Method.i_args M.info)))))) + in + Lwt.with_value OBus_context.key (Some context) + (fun () -> + let%lwt reply = M.handler obj arguments in + Lwt.return (OBus_value.C.make_sequence (OBus_value.arg_types (OBus_member.Method.o_args M.info)) reply)) + +(* Dispatch a method call to the implementation of the method *) +let dispatch context obj interface member arguments = + if interface = "" then + let rec loop i = + if i = Array.length obj.interfaces then + unknown_method interface member arguments + else + match binary_search compare_method member obj.interfaces.(i).i_methods with + | -1 -> + loop (i + 1) + | index -> + execute obj.interfaces.(i).i_methods.(index) context obj arguments + in + loop 0 + else + match binary_search compare_interface interface obj.interfaces with + | -1 -> + unknown_method interface member arguments + | index -> + let interface = obj.interfaces.(index) in + match binary_search compare_method member interface.i_methods with + | -1 -> + unknown_method interface.i_name member arguments + | index -> + execute interface.i_methods.(index) context obj arguments + +(* Search a dynamic node prefix of [path] in [map]: *) +let search_dynamic path map = + Path_map.fold + (fun prefix dynamic acc -> + match acc with + | Some _ -> + acc + | None -> + match OBus_path.after prefix path with + | Some path -> + Some(path, dynamic) + | None -> + None) + map None + +let send_reply context value = + try%lwt + let open OBus_message in + OBus_connection.send_message (OBus_context.connection context) { + flags = { no_reply_expected = true; no_auto_start = true }; + serial = 0l; + typ = Method_return(OBus_context.serial context); + destination = OBus_peer.name (OBus_context.sender context); + sender = ""; + body = value; + } + with exn -> + Lwt_log.warning ~section ~exn "failed to send reply to method call" + +let send_error context exn = + let name, message = OBus_error.cast exn in + try%lwt + let open OBus_message in + OBus_connection.send_message (OBus_context.connection context) { + flags = { no_reply_expected = true; no_auto_start = true }; + serial = 0l; + typ = Error(OBus_context.serial context, name); + destination = OBus_peer.name (OBus_context.sender context); + sender = ""; + body = [OBus_value.V.basic_string message]; + } + with exn -> + Lwt_log.warning ~section ~exn "failed to send error in reply to method call" + +(* Returns the list of children of a node *) +let children info prefix = + String_set.elements + (Path_map.fold + (fun path obj acc -> match OBus_path.after prefix path with + | Some(element :: _) -> String_set.add element acc + | _ -> acc) + info.statics + String_set.empty) + +exception No_such_object + +(* Handle method call messages *) +let handle_message connection info message = + match message with + | { OBus_message.typ = OBus_message.Method_call(path, interface, member) } -> + ignore begin + let context = OBus_context.make connection message in + try%lwt + let%lwt reply = + (* First, we search the object in static objects *) + match try Some(Path_map.find path info.statics) with Not_found -> None with + | Some static -> + let module M = (val static : Static) in + dispatch context M.obj interface member (OBus_message.body message) + | None -> + (* Then we search in dynamic objects *) + match search_dynamic path info.dynamics with + | None -> + Lwt.fail No_such_object + | Some(path, dynamic) -> + let module M = (val dynamic : Dynamic) in + let%lwt result = + try%lwt + let%lwt obj = M.get context path in + Lwt.return (`Success obj) + with exn -> + Lwt.return (`Failure exn) + in + match result with + | `Success obj -> + dispatch context obj interface member (OBus_message.body message) + | `Failure Not_found -> + Lwt.fail No_such_object + | `Failure exn -> + let%lwt () = Lwt_log.error ~section ~exn "dynamic object handler failed with" in + Lwt.fail No_such_object + in + send_reply context reply + with + | No_such_object -> begin + (* Handle introspection for missing intermediate object: + + for example if we have only one exported object + with path "/a/b/c", we need to add introspection + support for virtual objects with path "/", "/a", + "/a/b", "/a/b/c". *) + match interface, member, OBus_message.body message with + | ("" | "org.freedesktop.DBus.Introspectable"), "Introspect", [] -> + let buffer = Buffer.create 1024 in + OBus_introspect.output + (Xmlm.make_output ~nl:true ~indent:(Some 2) (`Buffer buffer)) + ([], children info path); + send_reply context [OBus_value.V.basic_string (Buffer.contents buffer)] + | _ -> + send_error context (OBus_error.Unknown_object (Printf.sprintf "Object %S does not exists" (OBus_path.to_string path))) + end + | exn -> + let%lwt () = + if OBus_error.name exn = OBus_error.ocaml then + (* It is a bad thing to raise an error that is not + mapped to a D-Bus error, so we alert the + user: *) + Lwt_log.error_f ~section ~exn + "method call handler for method %S on interface %S failed with" + member interface + else + Lwt.return () + in + send_error context exn + end; + Some message + + | _ -> + Some message + +(* +-----------------------------------------------------------------+ + | Exportation | + +-----------------------------------------------------------------+ *) + +let key = OBus_connection.new_key () + +let cleanup connection info = + E.stop info.watcher; + Path_map.iter + (fun path static -> + let module M = (val static : Static) in + M.obj.set_exports (Connection_set.remove connection (S.value M.obj.exports))) + info.statics + +let get_info connection = + match OBus_connection.get connection key with + | Some info -> + info + | None -> + let info = { + statics = Path_map.empty; + dynamics = Path_map.empty; + watcher = E.never; + } in + OBus_connection.set connection key (Some info); + let _ = Lwt_sequence.add_r (handle_message connection info) (OBus_connection.incoming_filters connection) in + info.watcher <- ( + E.map + (fun state -> cleanup connection info) + (E.once + (S.changes + (OBus_connection.active connection))) + ); + info + +let remove connection obj = + let exports = S.value obj.exports in + if Connection_set.mem connection exports then begin + if S.value (OBus_connection.active connection) then begin + match OBus_connection.get connection key with + | Some info -> + info.statics <- Path_map.remove obj.path info.statics + | None -> + () + end; + obj.set_exports (Connection_set.remove connection exports); + end + +let remove_by_path connection path = + if S.value (OBus_connection.active connection) then + match OBus_connection.get connection key with + | None -> + () + | Some info -> + info.dynamics <- Path_map.remove path info.dynamics; + match try Some(Path_map.find path info.statics) with Not_found -> None with + | Some static -> + let module M = (val static : Static) in + remove connection M.obj + | None -> + () + +let export (type d) connection obj = + if obj.data = None then + failwith "OBus_object.export: cannot export an object without data attached" + else + let exports = S.value obj.exports in + if not (Connection_set.mem connection exports) then begin + let info = get_info connection in + let () = + (* Remove any object registered under the same path: *) + match try Some(Path_map.find obj.path info.statics) with Not_found -> None with + | Some static -> + let module M = (val static : Static) in + remove connection M.obj + | None -> + () + in + let module M = struct + type data = d + let obj = obj + end in + info.statics <- Path_map.add obj.path (module M : Static) info.statics; + obj.set_exports (Connection_set.add connection exports) + end + +let destroy obj = + Connection_set.iter (fun connection -> remove connection obj) (S.value obj.exports) + +let dynamic (type d) ~connection ~prefix ~handler = + let info = get_info connection in + let module M = struct + type data = d + let get = handler + end in + info.dynamics <- Path_map.add prefix (module M : Dynamic) info.dynamics + +(* +-----------------------------------------------------------------+ + | Signals | + +-----------------------------------------------------------------+ *) + +let emit obj ~interface ~member ?peer typ x = + let module M = OBus_message in + let body = OBus_value.C.make_sequence typ x in + match peer, obj.owner with + | Some { OBus_peer.connection; OBus_peer.name }, _ + | _, Some { OBus_peer.connection; OBus_peer.name } -> + OBus_connection.send_message connection { + M.flags = { M.no_reply_expected = true; M.no_auto_start = true }; + M.serial = 0l; + M.typ = OBus_message.Signal(obj.path, interface, member); + M.destination = name; + M.sender = ""; + M.body = body; + } + | None, None -> + let signal = { + M.flags = { M.no_reply_expected = true; M.no_auto_start = true }; + M.serial = 0l; + M.typ = OBus_message.Signal(obj.path, interface, member); + M.destination = ""; + M.sender = ""; + M.body = body; + } in + Lwt.join (Connection_set.fold + (fun connection l -> OBus_connection.send_message connection signal :: l) + (S.value obj.exports) []) + +(* +-----------------------------------------------------------------+ + | Property change notifications | + +-----------------------------------------------------------------+ *) + +let notify_properties_change (type d) obj interface_name changed index = + (* Sleep a bit, so multiple changes are sent only one time. *) + let%lwt () = Lwt.pause () in + let members = changed.(index) in + changed.(index) <- String_map.empty; + try%lwt + !(obj.properties_changed) + interface_name + (String_map.fold (fun name value_opt acc -> (name, value_opt) :: acc) members []) + with exn -> + Lwt_log.error ~exn ~section "properties_changed callback failed with" + +let handle_property_change obj index info value_opt = + let empty = String_map.is_empty obj.changed.(index) in + obj.changed.(index) <- String_map.add (OBus_member.Property.member info) value_opt obj.changed.(index); + if empty then ignore (notify_properties_change obj (OBus_member.Property.interface info) obj.changed index) + +let handle_property_change_true (type d) (type v) obj interface_index prop value = + let module P = (val prop : Property_info with type obj = d t and type typ = v) in + let value = OBus_value.C.make_single (OBus_member.Property.typ P.info) value in + handle_property_change obj interface_index P.info (Some value) + +let handle_property_change_invalidates (type d) (type v) obj interface_index prop value = + let module P = (val prop : Property_info with type obj = d t and type typ = v) in + handle_property_change obj interface_index P.info None + +(* +-----------------------------------------------------------------+ + | Property maps genrations | + +-----------------------------------------------------------------+ *) + +(* Notification mode for a property *) +type emits_signal_changed = + | Esc_default + (* Use the default value, which may be defined in the + interface *) + | Esc_false + (* Do not notify property changes *) + | Esc_true + (* Notify property changes, and send the new contents in the + notification *) + | Esc_invalidates + (* Only send the property name in changes' notifications *) + +let get_emits_changed_signal annotations = + try + match List.assoc OBus_introspect.emits_changed_signal annotations with + | "true" -> Esc_true + | "false" -> Esc_false + | "invalidates" -> Esc_invalidates + | value -> + ignore (Lwt_log.warning_f "invalid value(%S) for annotation %S. Using default(\"true\")" value OBus_introspect.emits_changed_signal); + Esc_true + with Not_found -> + Esc_default + +(* Generate the [properties] field from the [interfaces] field: *) +let generate (type d) obj = + (* Stop monitoring of previous properties *) + Array.iter + (fun instances -> + Array.iter + (function + | Some instance -> + let module M = (val instance : Property_instance) in + S.stop M.signal; + E.stop M.monitor + | None -> ()) + instances) + obj.properties; + let count = Array.length obj.interfaces in + obj.properties <- Array.make count [||]; + obj.changed <- Array.make count String_map.empty; + for i = 0 to count - 1 do + let properties = obj.interfaces.(i).i_properties in + let count' = Array.length properties in + let instances = Array.make count' None in + obj.properties.(i) <- instances; + for j = 0 to count' - 1 do + let module P = (val properties.(j) : Property_info with type obj = d t) in + match P.signal with + | Some make -> + let module I = struct + type typ = P.typ + type access = P.access + let info = P.info + let signal = make obj + let monitor = + let esc_prop = get_emits_changed_signal (OBus_member.Property.annotations P.info) + and esc_intf = get_emits_changed_signal obj.interfaces.(i).i_annotations in + let info = (module P : Property_info with type obj = d t and type typ = P.typ) in + match esc_prop, esc_intf with + | Esc_false, _ | Esc_default, Esc_false -> + E.never + | Esc_true, _ | Esc_default, (Esc_default | Esc_true) -> + E.map (handle_property_change_true obj i info) (S.changes signal) + | Esc_invalidates, _ | Esc_default, Esc_invalidates -> + E.map (handle_property_change_invalidates obj i info) (S.changes signal) + end in + instances.(j) <- (Some(module I : Property_instance)) + | None -> + () + done + done + +(* +-----------------------------------------------------------------+ + | Member informations | + +-----------------------------------------------------------------+ *) + +let method_info (type d) (type i) (type o) info f = + let module M = struct + type obj = d t + type i_type = i + type o_type = o + let info = info + let handler = f + end in + (module M : Method_info with type obj = d t) + +let signal_info (type d) (type i) info = + let module M = struct + type obj = d t + type typ = i + let info = info + end in + (module M : Signal_info with type obj = d t) + +let property_r_info (type d) (type i) (type a) info signal = + let module M = struct + type obj = d t + type typ = i + type access = a + let info = info + let set = None + let signal = Some signal + end in + (module M : Property_info with type obj = d t) + +let property_w_info (type d) (type i) (type a) info set = + let module M = struct + type obj = d t + type typ = i + type access = a + let info = info + let set = Some set + let signal = None + end in + (module M : Property_info with type obj = d t) + +let property_rw_info (type d) (type i) (type a) info signal set = + let module M = struct + type obj = d t + type typ = i + type access = a + let info = info + let set = Some set + let signal = Some signal + end in + (module M : Property_info with type obj = d t) + +(* +-----------------------------------------------------------------+ + | Interfaces creation | + +-----------------------------------------------------------------+ *) + +let make_interface_unsafe name annotations methods signals properties = { + i_name = name; + i_methods = methods; + i_signals = signals; + i_properties = properties; + i_annotations = annotations; +} + +let compare_methods (type d) m1 m2 = + let module M1 = (val m1 : Method_info with type obj = d t) in + let module M2 = (val m2 : Method_info with type obj = d t) in + String.compare (OBus_member.Method.member M1.info) (OBus_member.Method.member M2.info) + +let compare_signals (type d) s1 s2 = + let module S1 = (val s1 : Signal_info with type obj = d t) in + let module S2 = (val s2 : Signal_info with type obj = d t) in + String.compare (OBus_member.Signal.member S1.info) (OBus_member.Signal.member S2.info) + +let compare_properties (type d) p1 p2 = + let module P1 = (val p1 : Property_info with type obj = d t) in + let module P2 = (val p2 : Property_info with type obj = d t) in + String.compare (OBus_member.Property.member P1.info) (OBus_member.Property.member P2.info) + +let make_interface ~name ?(annotations=[]) ?(methods=[]) ?(signals=[]) ?(properties=[]) () = + let methods = Array.of_list methods + and signals = Array.of_list signals + and properties = Array.of_list properties in + Array.sort compare_methods methods; + Array.sort compare_signals signals; + Array.sort compare_properties properties; + make_interface_unsafe name annotations methods signals properties + +let process_interfaces interfaces = + let rec uniq = function + | iface :: iface' :: rest when iface.i_name = iface'.i_name -> + uniq (iface :: rest) + | iface :: rest -> + iface :: uniq rest + | [] -> + [] + and compare i1 i2 = + String.compare i1.i_name i2.i_name + in + Array.of_list (uniq (List.stable_sort compare interfaces)) + +let add_interfaces obj interfaces = + obj.interfaces <- process_interfaces (interfaces @ Array.to_list obj.interfaces); + generate obj + +let remove_interfaces_by_names obj names = + obj.interfaces <- Array.of_list (List.filter (fun iface -> not (List.mem iface.i_name names)) (Array.to_list obj.interfaces)); + generate obj + +let remove_interfaces obj interfaces = + remove_interfaces_by_names obj (List.map (fun iface -> iface.i_name) interfaces) + +(* +-----------------------------------------------------------------+ + | Common interfaces | + +-----------------------------------------------------------------+ *) + +open OBus_member + +let introspectable (type d) () = + let interface = "org.freedesktop.DBus.Introspectable" in + make_interface_unsafe interface [] + [| + (let module M = struct + type obj = d t + type i_type = unit + type o_type = string + + let info = { + Method.interface = interface; + Method.member = "Introspect"; + Method.i_args = OBus_value.arg0; + Method.o_args = OBus_value.arg1 (Some "result", OBus_value.C.basic_string); + Method.annotations = []; + } + + let handler obj () = + let context = OBus_context.get () in + let info = get_info (OBus_context.connection context) in + let buf = Buffer.create 42 in + OBus_introspect.output + (Xmlm.make_output ~nl:true ~indent:(Some 2) (`Buffer buf)) + (introspect obj, children info obj.path); + Lwt.return (Buffer.contents buf) + end in + (module M : Method_info with type obj = d t)); + |] + [||] + [||] + +let properties (type d) () = + let interface = "org.freedesktop.DBus.Properties" in + make_interface_unsafe interface [] + [| + (let module M = struct + type obj = d t + type i_type = string * string + type o_type = OBus_value.V.single + + let info = { + Method.interface = interface; + Method.member = "Get"; + Method.i_args = + OBus_value.arg2 + (Some "interface", OBus_value.C.basic_string) + (Some "member", OBus_value.C.basic_string); + Method.o_args = + OBus_value.arg1 + (Some "value", OBus_value.C.variant); + Method.annotations = []; + } + + let handler obj (interface, member) = + match binary_search compare_interface interface obj.interfaces with + | -1 -> + Lwt.fail (OBus_error.Unknown_interface(Printf.sprintf "Interface %S does not exists" interface)) + | i -> + match binary_search compare_property member obj.interfaces.(i).i_properties with + | -1 -> + Lwt.fail (OBus_error.Unknown_property(Printf.sprintf "Property %S on interface %S does not exists" member interface)) + | j -> + match obj.properties.(i).(j) with + | Some instance -> + let module I = (val instance : Property_instance) in + Lwt.return (OBus_value.C.make_single (Property.typ I.info) (S.value I.signal)) + | None -> + Lwt.fail (OBus_error.Failed(Printf.sprintf "Property %S on interface %S is not readable" member interface)) + end in + (module M : Method_info with type obj = d t)); + + (let module M = struct + type obj = d t + type i_type = string + type o_type = (string * OBus_value.V.single) list + + let info = { + Method.interface = interface; + Method.member = "GetAll"; + Method.i_args = + OBus_value.arg1 + (Some "interface", OBus_value.C.basic_string); + Method.o_args = + OBus_value.arg1 + (Some "values", OBus_value.C.dict OBus_value.C.string OBus_value.C.variant); + Method.annotations = []; + } + + let handler obj interface = + match binary_search compare_interface interface obj.interfaces with + | -1 -> + Lwt.fail (OBus_error.Unknown_interface(Printf.sprintf "Interface %S does not exists" interface)) + | i -> + let count = Array.length obj.properties.(i) in + let rec loop j acc = + if j = count then + acc + else + match obj.properties.(i).(j) with + | Some instance -> + let module I = (val instance : Property_instance) in + loop (j + 1) + ((Property.member I.info, + OBus_value.C.make_single (Property.typ I.info) (S.value I.signal)) :: acc) + | None -> + loop (j + 1) acc + in + Lwt.return (loop 0 []) + end in + (module M : Method_info with type obj = d t)); + + (let module M = struct + type obj = d t + type i_type = string * string * OBus_value.V.single + type o_type = unit + + let info = { + Method.interface = interface; + Method.member = "Set"; + Method.i_args = + OBus_value.arg3 + (Some "interface", OBus_value.C.basic_string) + (Some "member", OBus_value.C.basic_string) + (Some "value", OBus_value.C.variant); + Method.o_args = + OBus_value.arg0; + Method.annotations = []; + } + + let handler obj (interface, member, value) = + match binary_search compare_interface interface obj.interfaces with + | -1 -> + Lwt.fail (OBus_error.Unknown_interface(Printf.sprintf "Interface %S does not exists" interface)) + | i -> + match binary_search compare_property member obj.interfaces.(i).i_properties with + | -1 -> + Lwt.fail (OBus_error.Unknown_property(Printf.sprintf "Property %S on interface %S does not exists" member interface)) + | j -> + let module P = (val obj.interfaces.(i).i_properties.(j) : Property_info with type obj = d t) in + match P.set with + | Some f -> begin + match try `Success(OBus_value.C.cast_single (Property.typ P.info) value) with exn -> `Failure exn with + | `Success value -> + f obj value + | `Failure OBus_value.C.Signature_mismatch -> + Lwt.fail + (OBus_error.Failed + (Printf.sprintf + "invalid type(%S) for property %S on interface %S, should be %S" + (OBus_value.string_of_signature + [OBus_value.V.type_of_single value]) + member + interface + (OBus_value.string_of_signature + [OBus_value.C.type_single + (Property.typ P.info)]))) + | `Failure exn -> + Lwt.fail exn + end + | None -> + Lwt.fail (OBus_error.Property_read_only(Printf.sprintf "property %S on interface %S is not writable" member interface)) + end in + (module M : Method_info with type obj = d t)); + |] + [| + (let module S = struct + type obj = d t + type typ = string * (string * OBus_value.V.single) list * string list + let info = { + Signal.interface = interface; + Signal.member = "PropertiesChanged"; + Signal.args = + OBus_value.arg3 + (Some "interface", OBus_value.C.basic_string) + (Some "updates", OBus_value.C.dict OBus_value.C.string OBus_value.C.variant) + (Some "invalidates", OBus_value.C.array OBus_value.C.basic_string); + Signal.annotations = []; + } + end in + (module S : Signal_info with type obj = d t)); + |] + [||] + +(* +-----------------------------------------------------------------+ + | Constructors | + +-----------------------------------------------------------------+ *) + +let properties_changed obj interface values = + emit obj + ~interface:"org.freedesktop.DBus.Properties" + ~member:"PropertiesChanged" + (OBus_value.C.seq3 + OBus_value.C.basic_string + (OBus_value.C.dict OBus_value.C.string OBus_value.C.variant) + (OBus_value.C.array OBus_value.C.basic_string)) + (interface, + OBus_util.filter_map + (function + | (name, Some value) -> Some(name, value) + | (name, None) -> None) + values, + OBus_util.filter_map + (function + | (name, Some value) -> None + | (name, None) -> Some name) + values) + +let make ?owner ?(common=true) ?(interfaces=[]) path = + let interfaces = if common then introspectable () :: properties () :: interfaces else interfaces in + let exports, set_exports = S.create ~eq:Connection_set.equal Connection_set.empty in + let obj = { + path = path; + exports = exports; + set_exports = set_exports; + owner = owner; + data = None; + properties = [||]; + interfaces = process_interfaces interfaces; + changed = [||]; + properties_changed = ref (fun name values -> assert false); + } in + obj.properties_changed := (fun name values -> properties_changed obj name values); + obj + +let attach obj data = + match obj.data with + | Some _ -> + failwith "OBus_object.attach: object already contains attached" + | None -> + obj.data <- Some data; + generate obj; + match obj.owner with + | None -> + () + | Some peer -> + export (OBus_peer.connection peer) obj; + ignore (let%lwt () = OBus_peer.wait_for_exit peer in + destroy obj; + Lwt.return ()) + +let get obj = + match obj.data with + | Some data -> data + | None -> failwith "OBus_object.get: no data attached" diff --git a/src/protocol/oBus_object.mli b/src/protocol/oBus_object.mli new file mode 100644 index 0000000..db55a70 --- /dev/null +++ b/src/protocol/oBus_object.mli @@ -0,0 +1,204 @@ +(* + * oBus_object.mli + * --------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Local D-Bus objects *) + +(** This module allows you to create D-Bus objects and export them on a + connection, allowing other programs to acccess them. *) + +(** {6 Types} *) + +type 'a t + (** Type of local D-Bus objects. It contains informations needed by + obus to export it on a connection and dispatch incoming method + calls. + + ['a] is the type of value that may be attached to this + object. *) + +type 'a interface + (** An interface description *) + +type 'a method_info + (** Informations about a method *) + +type 'a signal_info + (** Informations about a signal *) + +type 'a property_info + (** Informations about a property *) + +(** {6 Objects creation} *) + +val attach : 'a t -> 'a -> unit + (** [attach obus_object custom_obejct] attaches [custom_object] to + [obus_object]. [custom_object] will be the value received by + method call handlers. Note that you need to attach the object + before you can export it on a coneection and you can not attach + an object multiple times. *) + +val get : 'a t -> 'a + (** [get obj] returns the data attached to the given object *) + +val make : ?owner : OBus_peer.t -> ?common : bool -> ?interfaces : 'a interface list -> OBus_path.t -> 'a t + (** [make ?owner ?common ?interfaces path] creates a new D-Bus + object with path [path]. + + If [owner] is specified, then: + - all signals will be sent to it by default, + - the object will be removed from all its exports when the owner exits, + - it will automatically be exported on the connection of the owner when + [attach] is invoked. + + [interfaces] is the list of interfaces implemented by the + object. New interfaces can be added latter with + {!add_interfaces}. If [common] is [true] (the default) then + {!introspectable} and {!properties} are automatically added. *) + +(** {6 Properties} *) + +val path : 'a t -> OBus_path.t + (** [path obj] returns the path of the object *) + +val owner : 'a t -> OBus_peer.t option + (** [owner obj] returns the owner of the object, if any *) + +val exports : 'a t -> Set.Make(OBus_connection).t React.signal + (** [exports obj] is a signal holding the list of connnections on + which the object is exported. *) + +val introspect : 'a t -> OBus_introspect.interface list + (** [introspect obj] returns the introspection of all interfaces + implemented by [obj] *) + +val on_properties_changed : 'a t -> (OBus_name.interface -> (OBus_name.member * OBus_value.V.single option) list -> unit Lwt.t) ref + (** Function called when one or more properties of the given object + change. The new contents of the property is given along with the + property name according to the + [org.freedesktop.DBus.Property.EmitsChangedSignal]. + + The default function uses the standard + [org.freedesktop.DBus.Properties.PropertiesChanged] signal. *) + +(** {6 Exports} *) + +val export : OBus_connection.t -> 'a t -> unit + (** [export connection obj] exports [obj] on [connection]. It raises + {!OBus_connection.Connection_closed} if the connection is closed. *) + +val remove : OBus_connection.t -> 'a t -> unit + (** [remove connection obj] removes [obj] from [connection]. It does + nothing if the connection is closed. *) + +val remove_by_path : OBus_connection.t -> OBus_path.t -> unit + (** [remove_by_path connection path] removes the object with path + [path] on [connection]. It works for normal objects and dynamic + nodes. It does nothing if the connection is closed. *) + +val destroy : 'a t -> unit + (** [destroy obj] removes [obj] from all connection it is exported + on *) + +val dynamic : + connection : OBus_connection.t -> + prefix : OBus_path.t -> + handler : (OBus_context.t -> OBus_path.t -> 'a t Lwt.t) -> unit + (** [dynamic ~connection ~prefix ~handler] defines a dynamic node in + the tree of object. This means that objects with a path prefixed + by [prefix], will be created on the fly by [handler] when a + process try to access them. + + [handler] receive the context and rest of path after the + prefix. It may raises [Not_found] to indicates that there is no + object under the given path. + + Note: if you manually export an object with a path prefixed by + [prefix], it will have precedence over the one created by + [handler]. *) + +(** {6 Interfaces} *) + +val make_interface : name : OBus_name.interface -> + ?annotations : OBus_introspect.annotation list -> + ?methods : 'a method_info list -> + ?signals : 'a signal_info list -> + ?properties : 'a property_info list -> unit -> 'a interface + (** [make_interface ~name ?annotations ?methods ?signals ?properties ()] + creates a new interface *) + +(**/**) + +val make_interface_unsafe : OBus_name.interface -> + OBus_introspect.annotation list -> + 'a method_info array -> + 'a signal_info array -> + 'a property_info array -> 'a interface + +(**/**) + +val add_interfaces : 'a t -> 'a interface list -> unit + (** [add_interfaces obj ifaces] adds suport for the interfaces + described by [ifaces] to the given object. If an interface with + the same name is already attached to the object, then it is + replaced by the new one. *) + +val remove_interfaces : 'a t -> 'a interface list -> unit + (** [remove_interaces obj ifaces] removes informations about the + given interfaces from [obj]. If [obj] does not implement some of + the interfaces, it does nothing. *) + +val remove_interfaces_by_names : 'a t -> OBus_name.interface list -> unit + (** Same as {!remove_interfaces} but takes only the interface names + as argument. *) + +(** {8 Well-known interfaces} *) + +val introspectable : unit -> 'a interface + (** The [org.freedesktop.DBus.Introspectable] interface *) + +val properties : unit -> 'a interface + (** The [org.freedesktop.DBus.Properties] interface *) + +(** {6 Members} *) + +val method_info : ('a, 'b) OBus_member.Method.t -> ('c t -> 'a -> 'b Lwt.t) -> 'c method_info + (** [method_info desc handler] creates a method-call + member. [handler] receive the destination object of the method + call and the arguments of the method call. The context of the + call is also available to [handler] by using + {!OBus_context.get}. *) + +val signal_info : 'a OBus_member.Signal.t -> 'b signal_info + (** Defines a signal. It is only used for introspection *) + +val property_r_info : ('a, [ `readable ]) OBus_member.Property.t -> ('b t -> 'a React.signal) -> 'b property_info + (** [property_r_info desc get] defines a read-only property. [get] + is called once when data is attached to an object with + {!attach}. It must return a signal holding the current value of + the property. *) + +val property_w_info : ('a, [ `writable ]) OBus_member.Property.t -> ('b t -> 'a -> unit Lwt.t) -> 'b property_info + (** [property_w_info desc set] defines a write-only property. [set] + is used to set the propertry contents. *) + +val property_rw_info : ('a, [ `readable | `writable ]) OBus_member.Property.t -> ('b t -> 'a React.signal) -> ('b t -> 'a -> unit Lwt.t) -> 'b property_info + (** [property_rw_info desc get set] defines a readable and writable + property. [get] and [set] have the same semantic as for + {!property_r_info} and {!property_w_info}. *) + +(** {6 Signals} *) + +val emit : 'a t -> + interface : OBus_name.interface -> + member : OBus_name.member -> + ?peer : OBus_peer.t -> + 'b OBus_value.C.sequence -> 'b -> unit Lwt.t + (** [emit obj ~interface ~member ?peer typ args] emits a signal. it + uses the same rules as {!OBus_signal.emit} for choosing the + destinations of the signal. *) diff --git a/src/protocol/oBus_peer.ml b/src/protocol/oBus_peer.ml new file mode 100644 index 0000000..bdb1fc8 --- /dev/null +++ b/src/protocol/oBus_peer.ml @@ -0,0 +1,88 @@ +(* + * oBus_peer.ml + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Lwt_react + +type t = { + connection : OBus_connection.t; + name : OBus_name.bus; +} + +let compare = Pervasives.compare + +let connection p = p.connection +let name p = p.name + +let make ~connection ~name = { connection = connection; name = name } +let anonymous c = { connection = c; name = "" } + +let ping peer = + let%lwt reply, () = + OBus_connection.method_call_with_message + ~connection:peer.connection + ~destination:OBus_protocol.bus_name + ~path:[] + ~interface:"org.freedesktop.DBus.Peer" + ~member:"Peer" + ~i_args:OBus_value.C.seq0 + ~o_args:OBus_value.C.seq0 + () + in + Lwt.return { peer with name = OBus_message.sender reply } + +let get_machine_id peer = + let%lwt mid = + OBus_connection.method_call + ~connection:peer.connection + ~destination:OBus_protocol.bus_name + ~path:[] + ~interface:"org.freedesktop.DBus.Peer" + ~member:"GetMachineId" + ~i_args:OBus_value.C.seq0 + ~o_args:(OBus_value.C.seq1 OBus_value.C.basic_string) + () + in + try + Lwt.return (OBus_uuid.of_string mid) + with exn -> + Lwt.fail exn + +let wait_for_exit peer = + match peer.name with + | "" -> + Lwt.fail (Invalid_argument "OBus_peer.wait_for_exit: peer has no name") + | name -> + let switch = Lwt_switch.create () in + let%lwt owner = OBus_resolver.make ~switch peer.connection name in + if S.value owner = "" then + Lwt_switch.turn_off switch + else + (let%lwt _ = E.next (E.filter ((=) "") (S.changes owner)) in + Lwt.return ()) + [%lwt.finally + Lwt_switch.turn_off switch] + +(* +-----------------------------------------------------------------+ + | Private peers | + +-----------------------------------------------------------------+ *) + +type peer = t + +module type Private = sig + type t = private peer + external of_peer : peer -> t = "%identity" + external to_peer : t -> peer = "%identity" +end + +module Private = +struct + type t = peer + external of_peer : peer -> t = "%identity" + external to_peer : t -> peer = "%identity" +end diff --git a/src/protocol/oBus_peer.mli b/src/protocol/oBus_peer.mli new file mode 100644 index 0000000..03524ff --- /dev/null +++ b/src/protocol/oBus_peer.mli @@ -0,0 +1,107 @@ +(* + * oBus_peer.mli + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus peers *) + +(** A D-Bus peer represent an application which can be reach though a + D-Bus connection. It is the application at the end-point of the + connection or, if the end-point is a message bus, any application + connected to it. *) + +type t = { + connection : OBus_connection.t; + (** Connection used to reach the peer. *) + + name : OBus_name.bus; + (** Name of the peer. This only make sense if the connection is a + connection to a message bus. *) +} + +val compare : t -> t -> int + (** Same as [Pervasives.compare]. It allows this module to be used + as argument to the functors [Set.Make] and [Map.Make]. *) + +val connection : t -> OBus_connection.t + (** [connection] projection *) + +val name : t -> OBus_name.bus + (** [name] projection *) + +(** Note that it is possible to use either a unique connection name or + a bus name as peer name. + + Both possibility have advantages and drawbacks: + + - using bus names such as "org.freedesktop.DBus.Hal" avoid the + need to resolve the name. When doing the first method call the bus + will automatically start the service if available. Also if the + service restarts the peer will still be valid. + + One drawback is that the owner may change over the time, and + method calls may not be made on the same peer. + + - using a unique name, which can be retreived with bus functions + (see {!OBus_bus}), ensures that the peer won't change over time. + By the way if the service exits, or another application replaces it + and we want to always use the default one, we have to write the + code to handle owner change. + + So, one good strategy is to use bus names when calls do not involve + side-effect on the service such as object creation, and use unique + names for object created on our demand. Basically you can stick to + this rule: + + Always use bus name for a well-known objects, such as + "/org/freedesktop/Hal/Manager" on "org.freedesktop.Hal.Manager" + and use unique name for objects for which the path is retrieved + from a method call. +*) + +val make : connection : OBus_connection.t -> name : OBus_name.bus -> t + (** [make connection name] make a named peer *) + +val anonymous : OBus_connection.t -> t + (** [anonymous connection] make an anonymous peer *) + +val ping : t -> t Lwt.t + (** Ping a peer, and return the peer which really respond to the + ping. + + For example, the fastest way to get the the peer owning a bus + name, and start it if not running is: + + [ping (OBus_peer.make bus "well.known.name")] *) + +val get_machine_id : t -> OBus_uuid.t Lwt.t + (** @return the id of the machine the peer is running on *) + +val wait_for_exit : t -> unit Lwt.t + (** [wait_for_exit peer] wait until [peer] exit. If [peer] is not + running then it returns immediatly. Raises [Invalid_argument] if + the peer has no name. *) + +(** {6 Private peers} *) + +type peer = t + +(** Minimal interface of private peers *) +module type Private = sig + type t = private peer + + external of_peer : peer -> t = "%identity" + external to_peer : t -> peer = "%identity" +end + +(** Minimal implementation of private peers *) +module Private : sig + type t = peer + + external of_peer : peer -> t = "%identity" + external to_peer : t -> peer = "%identity" +end diff --git a/src/protocol/oBus_property.ml b/src/protocol/oBus_property.ml new file mode 100644 index 0000000..78baaf1 --- /dev/null +++ b/src/protocol/oBus_property.ml @@ -0,0 +1,364 @@ +(* + * oBus_property.ml + * ---------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(property)" + +open Lwt.Infix +open Lwt_react +open OBus_interfaces.Org_freedesktop_DBus_Properties + +(* +-----------------------------------------------------------------+ + | Types | + +-----------------------------------------------------------------+ *) + +module String_map = Map.Make(String) + +type map = (OBus_context.t * OBus_value.V.single) String_map.t + +type monitor = OBus_proxy.t -> OBus_name.interface -> Lwt_switch.t -> map signal Lwt.t + +type ('a, 'access) t = { + p_interface : OBus_name.interface; + (* The interface of the property. *) + + p_member : OBus_name.member; + (* The name of the property. *) + + p_proxy : OBus_proxy.t; + (* The object owning the property. *) + + p_monitor : monitor; + (* Monitor for this property. *) + + p_cast : OBus_context.t -> OBus_value.V.single -> 'a; + p_make : 'a -> OBus_value.V.single; +} + +type 'a r = ('a, [ `readable ]) t +type 'a w = ('a, [ `writable ]) t +type 'a rw = ('a, [ `readable | `writable ]) t + +type group = { + g_interface : OBus_name.interface; + (* The interface of the group *) + + g_proxy : OBus_proxy.t; + (* The object owning the group of properties *) + + g_monitor : monitor; + (* Monitor for this group. *) +} + +module Group_map = Map.Make + (struct + type t = OBus_name.bus * OBus_path.t * OBus_name.interface + (* Groups are indexed by: + - name of the owner of the property + - path of the object owning the property + - interfaec of the property *) + let compare = Pervasives.compare + end) + +(* Type of a cache for a group *) +type cache = { + mutable c_count : int; + (* Numbers of monitored properties using this group. *) + + c_map : map signal; + (* The signal holding the current state of properties. *) + + c_switch : Lwt_switch.t; + (* Switch for the signal used to monitor the group. *) +} + +type info = { + mutable cache : cache Lwt.t Group_map.t; + (* Cache of all monitored properties. *) +} + +(* +-----------------------------------------------------------------+ + | Default monitor | + +-----------------------------------------------------------------+ *) + +let update_map context dict map = + List.fold_left (fun map (name, value) -> String_map.add name (context, value) map) map dict + +let map_of_list context dict = + update_map context dict String_map.empty + +let get_all_no_cache proxy interface = + OBus_method.call_with_context m_GetAll proxy interface + +let default_monitor proxy interface switch = + let%lwt event = + OBus_signal.connect ~switch + (OBus_signal.with_filters + (OBus_match.make_arguments [(0, OBus_match.AF_string interface)]) + (OBus_signal.with_context + (OBus_signal.make s_PropertiesChanged proxy))) + and context, dict = get_all_no_cache proxy interface in + Lwt.return (S.map snd + (S.fold_s ~eq:(fun (_, a) (_, b) -> String_map.equal (=) a b) + (fun (_, map) (sig_context, (interface, updates, invalidates)) -> + if invalidates = [] then + Lwt.return (sig_context, update_map sig_context updates map) + else + let%lwt context, dict = get_all_no_cache proxy interface in + Lwt.return (sig_context, map_of_list context dict)) + (context, map_of_list context dict) + event)) + +(* +-----------------------------------------------------------------+ + | Property creation | + +-----------------------------------------------------------------+ *) + +let make ?(monitor=default_monitor) desc proxy = { + p_interface = OBus_member.Property.interface desc; + p_member = OBus_member.Property.member desc; + p_proxy = proxy; + p_monitor = monitor; + p_cast = (fun context value -> OBus_value.C.cast_single (OBus_member.Property.typ desc) value); + p_make = (OBus_value.C.make_single (OBus_member.Property.typ desc)); +} + +let group ?(monitor=default_monitor) proxy interface = { + g_proxy = proxy; + g_interface = interface; + g_monitor = monitor; +} + +(* +-----------------------------------------------------------------+ + | Transformations | + +-----------------------------------------------------------------+ *) + +let map_rw f g property = { + property with + p_cast = (fun context x -> f (property.p_cast context x)); + p_make = (fun x -> property.p_make (g x)); +} + +let map_rw_with_context f g property = { + property with + p_cast = (fun context x -> f context (property.p_cast context x)); + p_make = (fun x -> property.p_make (g x)); +} + +let map_r f property = { + property with + p_cast = (fun context x -> f (property.p_cast context x)); + p_make = (fun x -> assert false); +} + +let map_r_with_context f property = { + property with + p_cast = (fun context x -> f context (property.p_cast context x)); + p_make = (fun x -> assert false); +} + +let map_w g property = { + property with + p_cast = (fun context x -> assert false); + p_make = (fun x -> property.p_make (g x)); +} + +(* +-----------------------------------------------------------------+ + | Operations on maps | + +-----------------------------------------------------------------+ *) + +let find property map = + let context, value = String_map.find property.p_member map in + property.p_cast context value + +let find_with_context property map = + let context, value = String_map.find property.p_member map in + (context, property.p_cast context value) + +let find_value name map = + let context, value = String_map.find name map in + value + +let find_value_with_context name map = + String_map.find name map + +let print_map pp map = + let open Format in + pp_open_box pp 2; + pp_print_string pp "{"; + pp_print_cut pp (); + pp_open_hvbox pp 0; + String_map.iter + (fun name (context, value) -> + pp_open_box pp 0; + pp_print_string pp name; + pp_print_space pp (); + pp_print_string pp "="; + pp_print_space pp (); + OBus_value.V.print_single pp value; + pp_print_string pp ";"; + pp_close_box pp (); + pp_print_cut pp ()) + map; + pp_close_box pp (); + pp_print_cut pp (); + pp_print_string pp "}"; + pp_close_box pp () + +let string_of_map map = + let open Format in + let buf = Buffer.create 42 in + let pp = formatter_of_buffer buf in + pp_set_margin pp max_int; + print_map pp map; + pp_print_flush pp (); + Buffer.contents buf + +(* +-----------------------------------------------------------------+ + | Properties reading/writing | + +-----------------------------------------------------------------+ *) + +let key = OBus_connection.new_key () + +let get_with_context prop = + match OBus_connection.get (OBus_proxy.connection prop.p_proxy) key with + | Some info -> begin + match + try + Some(Group_map.find (OBus_proxy.name prop.p_proxy, + OBus_proxy.path prop.p_proxy, + prop.p_interface) info.cache) + with Not_found -> + None + with + | Some cache_thread -> + let%lwt cache = cache_thread in + Lwt.return (find_with_context prop (S.value cache.c_map)) + | None -> + let%lwt context, value = OBus_method.call_with_context m_Get prop.p_proxy (prop.p_interface, prop.p_member) in + Lwt.return (context, prop.p_cast context value) + end + | None -> + let%lwt context, value = OBus_method.call_with_context m_Get prop.p_proxy (prop.p_interface, prop.p_member) in + Lwt.return (context, prop.p_cast context value) + +let get prop = + get_with_context prop >|= snd + +let set prop value = + OBus_method.call m_Set prop.p_proxy (prop.p_interface, prop.p_member, prop.p_make value) + +let get_group group = + match OBus_connection.get (OBus_proxy.connection group.g_proxy) key with + | Some info -> begin + match + try + Some(Group_map.find (OBus_proxy.name group.g_proxy, + OBus_proxy.path group.g_proxy, + group.g_interface) info.cache) + with Not_found -> + None + with + | Some cache_thread -> + let%lwt cache = cache_thread in + Lwt.return (S.value cache.c_map) + | None -> + let%lwt context, dict = get_all_no_cache group.g_proxy group.g_interface in + Lwt.return (map_of_list context dict) + end + | None -> + let%lwt context, dict = get_all_no_cache group.g_proxy group.g_interface in + Lwt.return (map_of_list context dict) + +(* +-----------------------------------------------------------------+ + | Monitoring | + +-----------------------------------------------------------------+ *) + +let finalise disable _ = + ignore (Lazy.force disable) + +let monitor_group ?switch group = + Lwt_switch.check switch; + let cache_key = (OBus_proxy.name group.g_proxy, OBus_proxy.path group.g_proxy, group.g_interface) in + let info = + match OBus_connection.get (OBus_proxy.connection group.g_proxy) key with + | Some info -> + info + | None -> + let info = { cache = Group_map.empty } in + OBus_connection.set (OBus_proxy.connection group.g_proxy) key (Some info); + info + in + let%lwt cache = + match + try + Some(Group_map.find cache_key info.cache) + with Not_found -> + None + with + | Some cache_thread -> + cache_thread + | None -> + let waiter, wakener = Lwt.wait () in + info.cache <- Group_map.add cache_key waiter info.cache; + let switch = Lwt_switch.create () in + try%lwt + let%lwt signal = group.g_monitor group.g_proxy group.g_interface switch in + let cache = { + c_count = 0; + c_map = signal; + c_switch = switch; + } in + Lwt.wakeup wakener cache; + Lwt.return cache + with exn -> + info.cache <- Group_map.remove cache_key info.cache; + Lwt.wakeup_exn wakener exn; + let%lwt () = Lwt_switch.turn_off switch in + Lwt.fail exn + in + + cache.c_count <- cache.c_count + 1; + + let disable = lazy( + try%lwt + cache.c_count <- cache.c_count - 1; + if cache.c_count = 0 then begin + info.cache <- Group_map.remove cache_key info.cache; + Lwt_switch.turn_off cache.c_switch + end else + Lwt.return () + with exn -> + let%lwt () = + Lwt_log.warning_f + ~section + ~exn + "failed to disable monitoring of properties for interface %S on object %S from %S" + group.g_interface + (OBus_path.to_string (OBus_proxy.path group.g_proxy)) + (OBus_proxy.name group.g_proxy) + in + Lwt.fail exn + ) in + + let signal = S.with_finaliser (finalise disable) cache.c_map in + + let%lwt () = + Lwt_switch.add_hook_or_exec + switch + (fun () -> + S.stop signal; + Lazy.force disable) + in + + Lwt.return signal + +let monitor ?switch prop = + let%lwt signal = monitor_group ?switch { g_interface = prop.p_interface; + g_proxy = prop.p_proxy; + g_monitor = prop.p_monitor } in + Lwt.return (S.map (find prop) signal) diff --git a/src/protocol/oBus_property.mli b/src/protocol/oBus_property.mli new file mode 100644 index 0000000..b6b905a --- /dev/null +++ b/src/protocol/oBus_property.mli @@ -0,0 +1,145 @@ +(* + * oBus_property.mli + * ----------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus properties *) + +(** {6 Types} *) + +type ('a, 'access) t + (** Type of a property holding a value of type ['a]. ['access] is + the access mode of the property. *) + +type 'a r = ('a, [ `readable ]) t + (** Type of read-only properties *) + +type 'a w = ('a, [ `writable ]) t + (** Type of write-only properties *) + +type 'a rw = ('a, [ `readable | `writable ]) t + (** Type of read and write properties *) + +type map = (OBus_context.t * OBus_value.V.single) Map.Make(String).t + (** Type of all properties of an interface. *) + +type group + (** Type of a group of properties. Property groups are used to + read/monitor all the properties of an interface. *) + +type monitor = OBus_proxy.t -> OBus_name.interface -> Lwt_switch.t -> map React.signal Lwt.t + (** Type of a function creating a signal holding the contents of all + the properties of an interface. The default monitor uses the + [org.freedesktop.DBus.Properties.PropertiesChanged] signal. *) + +(** {6 Properties creation} *) + +val make : ?monitor : monitor -> ('a, 'access) OBus_member.Property.t -> OBus_proxy.t -> ('a, 'access) t + (** [make ?monitor property proxy] returns the property object for + this proxy. *) + +val group : ?monitor : monitor -> OBus_proxy.t -> OBus_name.interface -> group + (** [group ?monitor proxy interface] creates a group for all + readable properties of the given interface. Note that it is + faster to read a group of properties rather than reading each + property individually. *) + +(** {6 Properties transformation} *) + +val map_rw : ('a -> 'b) -> ('b -> 'a) -> 'a rw -> 'b rw + (** [map property f g] maps [property] with [f] and [g] *) + +val map_rw_with_context : (OBus_context.t -> 'a -> 'b) -> ('b -> 'a) -> 'a rw -> 'b rw + (** Same as {!map} except that the context is also passed to mapping + functions. *) + +val map_r : ('a -> 'b) -> ('a, [> `readable ]) t -> 'b r + (** Maps a read-only property. *) + +val map_r_with_context : (OBus_context.t -> 'a -> 'b) -> ('a, [> `readable ]) t -> 'b r + (** Maps a read-only property, passing the context to the mapping + function *) + +val map_w : ('b -> 'a) -> ('a, [> `writable ]) t -> 'b w + (** Maps a write-only property. *) + +(** {6 Operations on properties} *) + +val get : ('a, [> `readable ]) t -> 'a Lwt.t + (** Read the contents of a property. *) + +val get_with_context : ('a, [> `readable ]) t -> (OBus_context.t * 'a) Lwt.t + (** Same as {!get} but also returns the context *) + +val set : ('a, [> `writable ]) t -> 'a -> unit Lwt.t + (** Write the contents of a property *) + +val get_group : group -> map Lwt.t + (** Returns the set of all properties that belong to the given + group. *) + +(** {6 Operations on property maps} *) + +val find_value : OBus_name.member -> map -> OBus_value.V.single + (** [find_value name map] returns the value associated to [name] in + [set]. It raises [Not_found] if [name] is not in [map]. *) + +val find_value_with_context : OBus_name.member -> map -> OBus_context.t * OBus_value.V.single + (** Same as {!find_value} but also returns the context in which the + property was received. *) + +val find : ('a, [> `readable ]) t -> map -> 'a + (** [find property map] looks up for the given property in [set] and + maps it to a value of type ['a]. It raises [Not_found] if + [property] does not belong to [map]. *) + +val find_with_context : ('a, [> `readable ]) t -> map -> OBus_context.t * 'a + (** Same as {!find} but also returns the context in which the + property was received. *) + +val print_map : Format.formatter -> map -> unit + (** [print_set pp map] prints all the properties of [map]. *) + +val string_of_map : map -> string + (** [string_of_set set] prints [set] into a string and returns it. *) + +(** {6 Monitoring} *) + +(** Lots of D-Bus services notify other applications with a D-Bus + signal when one or more properties of an object change. In this + case it is possible to monitor the contents of a property. + + Note that when at least one property of an interface is monitored, + obus will keep a local state of all the properties of the + interface. +*) + +val monitor : ?switch : Lwt_switch.t -> ('a, [> `readable ]) t -> 'a React.signal Lwt.t + (** [monitor ?switch property] returns the signal holding the + current contents of [property]. Raises [Failure] if the property + is not monitorable. + + Resources allocated to monitor the property are automatically + freed when the signal is garbage collected *) + +val monitor_group : ?switch : Lwt_switch.t -> group -> map React.signal Lwt.t + (** [monitor_group ?switch group] monitors all properties of the + given group. *) + +(** {6 Helpers for custom monitors} *) + +val get_all_no_cache : OBus_proxy.t -> OBus_name.interface -> (OBus_context.t * (OBus_name.member * OBus_value.V.single) list) Lwt.t + (** [get_all_no_cache proxy interface] reads the value of all + properties without using the cache. *) + +val update_map : OBus_context.t -> (OBus_name.member * OBus_value.V.single) list -> map -> map + (** [update_map context values map] add all properties with their + context and value to [map]. *) + +val map_of_list : OBus_context.t -> (OBus_name.member * OBus_value.V.single) list -> map + (** [map_of_list context values] returns the map corresponding to + the given values and context. *) diff --git a/src/protocol/oBus_proxy.ml b/src/protocol/oBus_proxy.ml new file mode 100644 index 0000000..d4d186b --- /dev/null +++ b/src/protocol/oBus_proxy.ml @@ -0,0 +1,97 @@ +(* + * oBus_proxy.ml + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(proxy)" + +open OBus_peer +open OBus_message + +type t = { + peer : OBus_peer.t; + path : OBus_path.t; +} + +let compare = Pervasives.compare + +let make ~peer ~path = { peer = peer; path = path } + +let peer proxy = proxy.peer +let path proxy = proxy.path +let connection proxy = proxy.peer.connection +let name proxy = proxy.peer.name + +type proxy = t + +module type Private = sig + type t = private proxy + external of_proxy : proxy -> t = "%identity" + external to_proxy : t -> proxy = "%identity" +end + +module Private = +struct + type t = proxy + external of_proxy : proxy -> t = "%identity" + external to_proxy : t -> proxy = "%identity" +end + +(* +-----------------------------------------------------------------+ + | Method calls | + +-----------------------------------------------------------------+ *) + +let call proxy ~interface ~member ~i_args ~o_args args = + OBus_connection.method_call + ~connection:proxy.peer.connection + ~destination:proxy.peer.name + ~path:proxy.path + ~interface + ~member + ~i_args + ~o_args + args + +let call_with_context proxy ~interface ~member ~i_args ~o_args args = + let%lwt msg, result = + OBus_connection.method_call_with_message + ~connection:proxy.peer.connection + ~destination:proxy.peer.name + ~path:proxy.path + ~interface + ~member + ~i_args + ~o_args + args + in + Lwt.return (OBus_context.make proxy.peer.connection msg, result) + +let call_no_reply proxy ~interface ~member ~i_args args = + OBus_connection.method_call_no_reply + ~connection:proxy.peer.connection + ~destination:proxy.peer.name + ~path:proxy.path + ~interface + ~member + ~i_args + args + +(* +-----------------------------------------------------------------+ + | Introspection | + +-----------------------------------------------------------------+ *) + +let introspect proxy = + let%lwt str = + call proxy ~interface:"org.freedesktop.DBus.Introspectable" ~member:"Introspect" + ~i_args:OBus_value.C.seq0 + ~o_args:(OBus_value.C.seq1 OBus_value.C.basic_string) + () + in + try + Lwt.return (OBus_introspect.input (Xmlm.make_input ~strip:true (`String(0, str)))) + with Xmlm.Error((line, column), err) -> + Lwt.fail (Failure(Printf.sprintf "OBus_proxy.introspect: invalid document, at line %d: %s" line (Xmlm.error_message err))) diff --git a/src/protocol/oBus_proxy.mli b/src/protocol/oBus_proxy.mli new file mode 100644 index 0000000..e8aafdc --- /dev/null +++ b/src/protocol/oBus_proxy.mli @@ -0,0 +1,93 @@ +(* + * oBus_proxy.mli + * -------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Remote D-Bus objects *) + +(** A proxy is an object on which live on a different processus, but + behave as a native ocaml value. *) + +(** The default type for proxies *) +type t = { + peer : OBus_peer.t; + (** Peer owning the object *) + + path : OBus_path.t; + (** Path of the object on the peer *) +} + +val compare : t -> t -> int + (** Same as [Pervasives.compare]. It allows this module to be used + as argument to the functors [Set.Make] and [Map.Make]. *) + +val make : peer : OBus_peer.t -> path : OBus_path.t -> t + (** Creates a proxy from the given peer and path *) + +(** {6 Informations} *) + +val peer : t -> OBus_peer.t + (** Returns the peer pointed by a proxy *) + +val path : t -> OBus_path.t + (** Returns the path of a proxy *) + +val connection : t -> OBus_connection.t + (** [connection proxy = OBus_peer.connection (peer proxy)] *) + +val name : t -> OBus_name.bus + (** [connection proxy = OBus_peer.name (peer proxy)] *) + +val introspect : t -> OBus_introspect.document Lwt.t + (** [introspect proxy] introspects the given proxy *) + +(** {6 Method calls} *) + +val call : t -> + interface : OBus_name.interface -> + member : OBus_name.member -> + i_args : 'a OBus_value.C.sequence -> + o_args : 'b OBus_value.C.sequence -> 'a -> 'b Lwt.t + (** [call proxy ~interface ~member ~i_args ~o_args args] calls the + given method on the given proxy and wait for the reply. *) + +val call_with_context : t -> + interface : OBus_name.interface -> + member : OBus_name.member -> + i_args : 'a OBus_value.C.sequence -> + o_args : 'b OBus_value.C.sequence -> 'a -> (OBus_context.t * 'b) Lwt.t + (** [call_with_context] is like {!call} except that is also returns + the context of the method return *) + +val call_no_reply : t -> + interface : OBus_name.interface -> + member : OBus_name.member -> + i_args : 'a OBus_value.C.sequence -> 'a -> unit Lwt.t + (** [call_no_reply] is the same as {!call} except that it does not + wait for a reply *) + +(** {6 Private proxies} *) + +(** The two following module interface and implementations are helpers + for using private proxies. A private proxy is just a normal proxy + but defined as a private type, to avoid incorrect use. *) + +type proxy = t + +(** Minimal interface of private proxies *) +module type Private = sig + type t = private proxy + external of_proxy : proxy -> t = "%identity" + external to_proxy : t -> proxy = "%identity" +end + +(** Minimal implementation of private proxies *) +module Private : sig + type t = proxy + external of_proxy : proxy -> t = "%identity" + external to_proxy : t -> proxy = "%identity" +end diff --git a/src/protocol/oBus_resolver.ml b/src/protocol/oBus_resolver.ml new file mode 100644 index 0000000..f892d14 --- /dev/null +++ b/src/protocol/oBus_resolver.ml @@ -0,0 +1,194 @@ +(* + * oBus_resolver.ml + * ---------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(resolver)" + +open Lwt_react + +module String_map = Map.Make(String) + +(* We keep track on each connection of the last [cache_size] peers + that have already exited: *) +let cache_size = 100 + +type resolver = { + mutable count : int; + (* Number of instances of this resolver. The resolver is + automatically disabled when this number reach 0. *) + + owner : OBus_name.bus signal; + (* The owner of the name that is being monitored. *) + + set_owner : OBus_name.bus -> unit; + (* Sets the owner. *) +} + +(* Informations stored in connections *) +and info = { + mutable resolvers : (resolver * Lwt_switch.t) Lwt.t String_map.t; + (* Mapping from names to active resolvers. The maps hold thread + instead of resolver directly to avoid the following problem: + + 1 - a resolver for a certain name is being created, + 2 - the creation yields, + 3 - another resolver for the same name is requested before the + creation of the previous one terminates, + 4 - the second to register in this map wwill erase the first one. + *) + + mutable exited : OBus_name.bus array; + (* Array holding the last [cache_size] peers that have already + exited *) + + mutable exited_index : int; + (* Position where to store the next exited peers in [exited]. *) +} + +let finalise remove _ = + ignore (Lazy.force remove) + +let has_exited peer_name info = + let rec loop index = + if index = cache_size then + false + else if info.exited.(index) = peer_name then + true + else + loop (index + 1) + in + loop 0 + +let key = OBus_connection.new_key () + +let get_name_owner connection name = + try%lwt + OBus_connection.method_call + ~connection + ~destination:OBus_protocol.bus_name + ~path:OBus_protocol.bus_path + ~interface:OBus_protocol.bus_interface + ~member:"GetNameOwner" + ~i_args:(OBus_value.C.seq1 OBus_value.C.basic_string) + ~o_args:(OBus_value.C.seq1 OBus_value.C.basic_string) + name + with exn when OBus_error.name exn = "org.freedesktop.DBus.Error.NameHasNoOwner" -> + Lwt.return "" + +(* Handle NameOwnerChanged events *) +let update_mapping info message = + let open OBus_message in + let open OBus_value in + match message with + | { sender = "org.freedesktop.DBus"; + typ = Signal(["org"; "freedesktop"; "DBus"], "org.freedesktop.DBus", "NameOwnerChanged"); + body = [V.Basic(V.String name); V.Basic(V.String old_owner); V.Basic(V.String new_owner)] } -> + + if OBus_name.is_unique name && new_owner = "" && not (has_exited name info) then begin + (* Remember that the peer has exited: *) + info.exited.(info.exited_index) <- name; + info.exited_index <- (info.exited_index + 1) mod cache_size + end; + + begin + match try Lwt.state (String_map.find name info.resolvers) with Not_found -> Sleep with + | Return(resolver, switch) -> + resolver.set_owner new_owner + | Fail _ | Sleep -> + (* Discards events arriving before GetNameOwner has returned *) + () + end; + + Some message + | _ -> + Some message + +let make ?switch connection name = + Lwt_switch.check switch; + OBus_string.assert_validate OBus_name.validate_bus name; + let info = + match OBus_connection.get connection key with + | Some info -> + info + | None -> + let info = { + resolvers = String_map.empty; + exited = Array.make cache_size ""; + exited_index = 0; + } in + OBus_connection.set connection key (Some info); + let _ = Lwt_sequence.add_l (update_mapping info) (OBus_connection.incoming_filters connection) in + info + in + + (* If [name] is a unique name and the peer has already exited, then + there is nothing to do: *) + if OBus_name.is_unique name && has_exited name info then + Lwt.return (S.const "") + else begin + let%lwt resolver, export_switch = + match try Some(String_map.find name info.resolvers) with Not_found -> None with + | Some thread -> + thread + | None -> + let waiter, wakener = Lwt.wait () in + info.resolvers <- String_map.add name waiter info.resolvers; + let export_switch = Lwt_switch.create () in + try%lwt + let%lwt () = + OBus_match.export + ~switch:export_switch + connection + (OBus_match.rule + ~typ:`Signal + ~sender:OBus_protocol.bus_name + ~interface:OBus_protocol.bus_interface + ~member:"NameOwnerChanged" + ~path:OBus_protocol.bus_path + ~arguments:(OBus_match.make_arguments [(0, OBus_match.AF_string name)]) ()) + in + let%lwt current_owner = get_name_owner connection name in + let owner, set_owner = S.create current_owner in + let resolver = { count = 0; owner; set_owner } in + Lwt.wakeup wakener (resolver, export_switch); + Lwt.return (resolver, export_switch) + with exn -> + info.resolvers <- String_map.remove name info.resolvers; + Lwt.wakeup_exn wakener exn; + let%lwt () = Lwt_switch.turn_off export_switch in + Lwt.fail exn + in + + resolver.count <- resolver.count + 1; + + let remove = lazy( + try%lwt + resolver.count <- resolver.count - 1; + if resolver.count = 0 then begin + (* The resolver is no more used, so we disable it: *) + info.resolvers <- String_map.remove name info.resolvers; + Lwt_switch.turn_off export_switch + end else + Lwt.return () + with exn -> + let%lwt () = Lwt_log.warning_f ~section ~exn "failed to disable resolver for name %S" name in + Lwt.fail exn + ) in + + let owner = S.with_finaliser (finalise remove) resolver.owner in + + let%lwt () = + Lwt_switch.add_hook_or_exec + switch + (fun () -> + S.stop owner; + Lazy.force remove) + in + + Lwt.return owner + end diff --git a/src/protocol/oBus_resolver.mli b/src/protocol/oBus_resolver.mli new file mode 100644 index 0000000..16040ad --- /dev/null +++ b/src/protocol/oBus_resolver.mli @@ -0,0 +1,34 @@ +(* + * oBus_resolver.mli + * ----------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Bus name resolving *) + +(** This module implements bus name resolving and monitoring. + + - for a unique connection name, it means being notified when the + peer owning this name exits + + - for a well-known name such as "org.domain.Serivce" it means + knowing at each time who is the current owner and being notified + when the service owner changes (i.e. the process implementing the + service change). + + It is basically an abstraction for {!OBus_bus.get_owner} and + {!OBus_bus.name_owner_changed}. You should prefer using it instead + of implementing your own name monitoring because resolver are + shared and obus internally uses them, so this avoids extra messages. + + Note that with a peer-to-peer connection, resolver will always act + as if there is no owner. *) + +val make : ?switch : Lwt_switch.t -> OBus_connection.t -> OBus_name.bus -> OBus_name.bus React.signal Lwt.t + (** [make ?switch bus name] creates a resolver which will monitor + the name [name] on [bus]. It returns a signal holding the + current owner of the name. It holds [""] when there is no + owner. *) diff --git a/src/protocol/oBus_server.ml b/src/protocol/oBus_server.ml new file mode 100644 index 0000000..cd17ae7 --- /dev/null +++ b/src/protocol/oBus_server.ml @@ -0,0 +1,516 @@ +(* + * oBus_server.ml + * -------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(server)" + +open Unix +open Lwt.Infix + +(* +-----------------------------------------------------------------+ + | Types | + +-----------------------------------------------------------------+ *) + +(* Type of a listener. A server have one or more listeners. Each + listener listen for new clients on a givne address *) +type listener = { + lst_fd : Lwt_unix.file_descr; + lst_address : OBus_address.t; + lst_guid : OBus_address.guid; + lst_capabilities : OBus_auth.capability list; +} + +(* Type of events received by a listener *) +type event = + | Event_shutdown + (* Event fired when the user shutdown the server, or when a + listener fails. *) + | Event_connection of Lwt_unix.file_descr * Unix.sockaddr + (* A new client connects to the server *) + +(* Type of a server *) +type t = { + mutable srv_up : bool; + (* The server state *) + + srv_addresses : OBus_address.t list; + (* List of connecting addresses of the server *) + + srv_callback : (t -> OBus_transport.t -> unit); + (* The callback function *) + + srv_abort_waiter : event Lwt.t; + srv_abort_wakener : event Lwt.u; + (* Sleeping thread which is wakeup with the value [Event_shutdown] + when the server is shutdown *) + + srv_mechanisms : OBus_auth.Server.mechanism list option; + (* List of mechanisms supported by this server *) + + srv_allow_anonymous : bool; + (* Does the server allow anonymous clients ? *) + + srv_nonce : string; + (* The server nonce, for the "tcp-nonce" transport *) + + srv_nonce_file : string; + (* The file in which the nonce is stored *) + + mutable srv_loops : unit Lwt.t; + (* [srv_loops] is the join of all listener's loops *) +} + +(* +-----------------------------------------------------------------+ + | Accepting new connecctions | + +-----------------------------------------------------------------+ *) + +(* Reads the nonce sent by the client before authentication. The nonce + is composed of the first 16 bytes sent by the client. *) +let read_nonce fd = + let nonce = Bytes.create 16 in + let rec loop ofs len = + Lwt_unix.read fd nonce ofs len >>= function + | 0 -> + Lwt.fail End_of_file + | n -> + if n = len then + Lwt.return (Bytes.unsafe_to_string nonce) + else + loop (ofs + n) (len - n) + in + loop 0 16 + +(* Wait for a client to connects *) +let rec accept server listener = + begin + try%lwt + let%lwt result = Lwt_unix.accept listener.lst_fd in + Lwt.return (`Accept result) + with Unix_error(err, _, _) -> + let%lwt () = + if server.srv_up then + Lwt_log.error_f ~section "uncaught error: %s" (error_message err) + else + (* Ignore errors that happens after a shutdown *) + Lwt.return () + in + Lwt.return `Shutdown + end >>= function + | `Accept(fd, address) -> + if OBus_address.name listener.lst_address = "nonce-tcp" then begin + begin + try%lwt + let%lwt nonce = read_nonce fd in + if nonce <> server.srv_nonce then begin + let%lwt () = Lwt_log.notice_f ~section "client rejected because of invalid nonce" in + Lwt.return `Drop + end else + Lwt.return `OK + with + | End_of_file -> + let%lwt () = Lwt_log.warning ~section "cannot read nonce from socket" in + Lwt.return `Drop + | Unix.Unix_error(err, _, _) -> + let%lwt () = Lwt_log.warning_f ~section "cannot read nonce from socket: %s" (Unix.error_message err) in + Lwt.return `Drop + end >>= function + | `OK -> + Lwt.return (Event_connection(fd, address)) + | `Drop -> + let%lwt () = + try + Lwt_unix.shutdown fd SHUTDOWN_ALL; + Lwt_unix.close fd + with Unix.Unix_error(err, _, _) -> + Lwt_log.error_f ~section "cannot shutdown socket: %s" (Unix.error_message err) + in + accept server listener + end else + Lwt.return (Event_connection(fd, address)) + | `Shutdown -> + Lwt.return Event_shutdown + +(* +-----------------------------------------------------------------+ + | Listeners | + +-----------------------------------------------------------------+ *) + +(* Cleans up resources allocated for the given listenning address *) +let cleanup address = + match OBus_address.name address with + | "unix" -> begin + match OBus_address.arg "path" address with + | Some path -> begin + (* Sockets in the file system must be removed manually *) + try + Lwt_unix.unlink path + with Unix_error(err, _, _) -> + Lwt_log.error_f ~section "cannot unlink '%s': %s" path (Unix.error_message err) + end + | None -> + Lwt.return () + end + | _ -> + Lwt.return () + +let string_of_address = function + | ADDR_UNIX path -> + let len = String.length path in + if len > 0 && path.[0] = '\x00' then + Printf.sprintf "unix abstract path %S" (String.sub path 1 (len - 1)) + else + Printf.sprintf "unix path %S" path + | ADDR_INET(ia, port) -> + Printf.sprintf "internet address %s:%d" (string_of_inet_addr ia) port + +(* Handle new clients. This function never fails. *) +let handle_client server listener fd address = + let shutdown = lazy( + try%lwt + Lwt_unix.shutdown fd SHUTDOWN_ALL; + Lwt_unix.close fd + with Unix.Unix_error(err, _, _) -> + Lwt_log.error_f ~section "cannot shutdown socket: %s" (Unix.error_message err) + ) in + try%lwt + let buf = Bytes.create 1 in + Lwt_unix.read fd buf 0 1 >>= function + | 0 -> + Lwt.fail (OBus_auth.Auth_failure "did not receive the initial null byte") + | 1 -> + let user_id = + try + Some((Lwt_unix.get_credentials fd).Lwt_unix.cred_uid) + with Unix.Unix_error(error, _, _) -> + ignore (Lwt_log.info_f ~section "cannot read credential: %s" (Unix.error_message error)); + None + in + let%lwt user_id, capabilities = + OBus_auth.Server.authenticate + ~capabilities:listener.lst_capabilities + ?mechanisms:server.srv_mechanisms + ?user_id + ~guid:listener.lst_guid + ~stream:(OBus_auth.stream_of_fd fd) + () + in + if user_id = None && not server.srv_allow_anonymous then begin + let%lwt () = Lwt_log.notice_f ~section "client from %s rejected because anonymous connections are not allowed" (string_of_address address) in + Lazy.force shutdown + end else begin + try + server.srv_callback server (OBus_transport.socket ~capabilities fd); + Lwt.return () + with exn -> + let%lwt () = Lwt_log.error ~section ~exn "server callback failed failed with" in + Lazy.force shutdown + end + | _ -> + assert false + with exn -> + let%lwt () = + match exn with + | OBus_auth.Auth_failure msg -> + Lwt_log.notice_f ~section "authentication failure for client from %s: %s" (string_of_address address) msg + | exn -> + Lwt_log.error_f ~section ~exn "authentication for client from %s failed with" (string_of_address address) + in + Lazy.force shutdown + +(* Accept clients until the server is shutdown, or an accept fails: *) +let rec lst_loop server listener = + Lwt.pick [server.srv_abort_waiter; accept server listener] >>= function + | Event_shutdown -> + let%lwt () = + try + Lwt_unix.close listener.lst_fd + with Unix_error(err, _, _) -> + Lwt_log.error_f ~section "cannot close listenning socket: %s" (Unix.error_message err) + in + cleanup listener.lst_address + + | Event_connection(fd, address) -> + (* Launch authentication and dispatching in parallel: *) + ignore (handle_client server listener fd address); + lst_loop server listener + +(* +-----------------------------------------------------------------+ + | Address -> transport | + +-----------------------------------------------------------------+ *) + +(* Tries to create a socket using the given parameters *) +let make_socket domain typ address = + let fd = Lwt_unix.socket domain typ 0 in + (try Lwt_unix.set_close_on_exec fd with _ -> ()); + try + let%lwt () = Lwt_unix.bind fd address in + Lwt_unix.listen fd 10; + Lwt.return fd + with Unix_error(err, _, _) as exn -> + let%lwt () = Lwt_log.error_f ~section "failed to create listenning socket with %s: %s" (string_of_address address) (Unix.error_message err) in + let%lwt () = Lwt_unix.close fd in + Lwt.fail exn + +let make_path path = + make_socket PF_UNIX SOCK_STREAM (ADDR_UNIX(path)) + +let make_abstract path = + make_socket PF_UNIX SOCK_STREAM (ADDR_UNIX("\x00" ^ path)) + +(* Takes a D-Bus listenning address and returns the list of [(fd, + client-address)] it denotes *) +let fd_addr_list_of_address address = match OBus_address.name address with + | "unix" -> begin + match (OBus_address.arg "path" address, + OBus_address.arg "abstract" address, + OBus_address.arg "tmpdir" address) with + | Some path, None, None -> + let%lwt fd = make_path path in + Lwt.return [(fd, address)] + | None, Some abst, None -> + let%lwt fd = make_abstract abst in + Lwt.return [(fd, address)] + | None, None, Some tmpd -> begin + let path = Filename.concat tmpd ("obus-" ^ OBus_util.hex_encode (OBus_util.random_string 10)) in + (* Try with abstract name first *) + try%lwt + let%lwt fd = make_abstract path in + Lwt.return [(fd, OBus_address.make ~name:"unix" ~args:[("abstract", path)])] + with exn -> + (* And fallback to path in the filesystem *) + let%lwt fd = make_path path in + Lwt.return [(fd, OBus_address.make ~name:"unix" ~args:[("path", path)])] + end + | _ -> + Lwt.fail (Invalid_argument "OBus_transport.connect: invalid unix address, must supply exactly one of 'path', 'abstract', 'tmpdir'") + end + + | ("tcp" | "nonce-tcp") as name -> begin + let port = match OBus_address.arg "port" address with + | Some port -> port + | None -> "0" + and bind = match OBus_address.arg "bind" address with + | Some bind -> bind + | None -> match OBus_address.arg "host" address with + | Some host -> host + | None -> "*" + in + let opts = [AI_SOCKTYPE SOCK_STREAM; AI_PASSIVE] in + let opts = match OBus_address.arg "family" address with + | Some "ipv4" -> AI_FAMILY PF_INET :: opts + | Some "ipv6" -> AI_FAMILY PF_INET6 :: opts + | Some family -> Printf.ksprintf invalid_arg "OBus_server.make_server: unknown address family '%s'" family + | None -> opts + in + let ais = getaddrinfo bind port opts in + (* Remove duplicate address info: *) + let module AI_set = Set.Make(struct type t = addr_info let compare = compare end) in + let ais = AI_set.elements (List.fold_left (fun set ai -> AI_set.add ai set) AI_set.empty ais) in + match ais with + | [] -> + Printf.ksprintf + failwith + "OBus_transport.make_server: no address info for bind=%s port=%s%s" + bind port + (match OBus_address.arg "family" address with + | None -> "" + | Some f -> " family=" ^ f) + | ais -> + let%lwt results = Lwt_list.map_p + (fun ai -> + try%lwt + let%lwt fd = make_socket ai.ai_family ai.ai_socktype ai.ai_addr in + match getsockname (Lwt_unix.unix_file_descr fd) with + | ADDR_UNIX path -> + assert false + | ADDR_INET(host, port) -> + Lwt.return (`Success(fd, OBus_address.make ~name ~args:[("host", string_of_inet_addr host); + ("port", string_of_int port); + ("family", + match ai.ai_family with + | PF_UNIX -> assert false + | PF_INET -> "ipv4" + | PF_INET6 -> "ipv6")])) + with exn -> + Lwt.return (`Failure exn)) + ais + in + let fd_addr_list = + OBus_util.filter_map + (function + | `Success x -> Some x + | `Failure _ -> None) + results + in + if fd_addr_list = [] then + (* If no fds have been created, raises the first failure: *) + match OBus_util.find_map (function `Failure e -> Some e | `Success _ -> None) results with + | Some exn -> Lwt.fail exn + | None -> assert false + else + Lwt.return fd_addr_list + end + + | "autolaunch" -> + Lwt.fail (Failure "OBus_server.make_server: autolaunch can not be used as a listenning address") + + | name -> + Lwt.fail (Failure ("OBus_server.make_server: unknown transport type: " ^ name)) + +(* +-----------------------------------------------------------------+ + | Servers | + +-----------------------------------------------------------------+ *) + +let addresses server = server.srv_addresses + +let shutdown server = + if server.srv_up then begin + server.srv_up <- false; + Lwt.wakeup server.srv_abort_wakener Event_shutdown; + let%lwt () = + if server.srv_nonce_file <> "" then begin + try + Lwt_unix.unlink server.srv_nonce_file + with Unix_error(err, _, _) -> + Lwt_log.error_f ~section "cannot unlink '%s': %s" server.srv_nonce_file (Unix.error_message err) + end else + Lwt.return () + in + (* Wait for all listenners to exit: *) + server.srv_loops + end else + server.srv_loops + +let default_address = OBus_address.make ~name:"unix" ~args:[("tmpdir", Filename.get_temp_dir_name ())] + +let make_lowlevel ?switch ?(capabilities=OBus_auth.capabilities) ?mechanisms ?(addresses=[default_address]) ?(allow_anonymous=false) callback = + Lwt_switch.check switch; + match addresses with + | [] -> + Lwt.fail (Invalid_argument "OBus_server.make: no addresses given") + + | addresses -> + (* Construct the list of all listening fds for each + address: *) + let%lwt result_by_address = + Lwt_list.map_p + (fun address -> + try%lwt + let%lwt x = fd_addr_list_of_address address in + Lwt.return (`Success x) + with e -> + Lwt.return (`Failure e)) + addresses + in + + (* Close all listening file descriptors and fail: *) + let abort exn = + let%lwt () = + Lwt_list.iter_p + (function + | `Success fd_addr_list -> + Lwt_list.iter_p + (fun (fd, address) -> + try%lwt + let%lwt () = Lwt_unix.close fd in + cleanup address + with Unix_error(err, _, _) -> + Lwt_log.error_f ~section "failed to close listenning file descriptor: %s" (Unix.error_message err)) + fd_addr_list + | `Failure e -> + Lwt.return ()) + result_by_address + in + Lwt.fail exn + in + + match OBus_util.find_map (function `Success _ -> None | `Failure e -> Some e) result_by_address with + | Some exn -> + abort exn + + | None -> + let%lwt nonce, nonce_file = + if List.exists (fun addr -> OBus_address.name addr = "nonce-tcp") addresses then begin + let nonce = OBus_util.random_string 16 in + let file_name = Filename.concat (Filename.get_temp_dir_name ()) ("obus-" ^ OBus_util.hex_encode (OBus_util.random_string 10)) in + try%lwt + let%lwt () = Lwt_io.with_file ~mode:Lwt_io.output file_name (fun oc -> Lwt_io.write oc nonce) in + Lwt.return (nonce, file_name) + with Unix.Unix_error(err, _, _) -> + abort (Failure(Printf.sprintf "cannot create nonce file '%s': %s" file_name (Unix.error_message err))) + end else + Lwt.return ("", "") + in + + let successes = + List.map + (function + | `Failure _ -> assert false + | `Success x -> x) + result_by_address + in + + let guids = List.map (fun _ -> OBus_uuid.generate ()) successes in + + let successes = + List.map2 + (fun fd_addr_list guid -> + List.map + (fun (fd, addr) -> + let args = ("guid", OBus_uuid.to_string guid) :: OBus_address.args addr in + let args = + if OBus_address.name addr = "nonce-tcp" then + ("noncefile", nonce_file) :: args + else + args + in + (fd, { addr with OBus_address.args = args })) + fd_addr_list) + successes guids + in + + let listeners = List.flatten + (List.map2 + (fun fd_addr_list guid -> + List.map + (fun (fd, address) -> { + lst_fd = fd; + lst_address = address; + lst_capabilities = (List.filter + (fun `Unix_fd -> + match (OBus_address.arg "path" address, + OBus_address.arg "abstract" address) with + | None, None -> false + | _ -> true) + capabilities); + lst_guid = guid; + }) + fd_addr_list) + successes guids) + in + + let abort_waiter, abort_wakener = Lwt.wait () in + let server = { + srv_up = true; + srv_addresses = List.map snd (List.flatten successes); + srv_callback = callback; + srv_abort_waiter = abort_waiter; + srv_abort_wakener = abort_wakener; + srv_mechanisms = mechanisms; + srv_allow_anonymous = allow_anonymous; + srv_nonce = nonce; + srv_nonce_file = nonce_file; + srv_loops = Lwt.return (); + } in + server.srv_loops <- Lwt.join (List.map (fun listener -> lst_loop server listener) listeners); + + let%lwt () = Lwt_switch.add_hook_or_exec switch (fun () -> shutdown server) in + Lwt.return server + +let make ?switch ?capabilities ?mechanisms ?addresses ?allow_anonymous callback = + make_lowlevel ?switch ?capabilities ?mechanisms ?addresses ?allow_anonymous + (fun server transport -> callback server (OBus_connection.of_transport ~up:false transport)) diff --git a/src/protocol/oBus_server.mli b/src/protocol/oBus_server.mli new file mode 100644 index 0000000..14ae219 --- /dev/null +++ b/src/protocol/oBus_server.mli @@ -0,0 +1,72 @@ +(* + * oBus_server.mli + * --------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Servers for one-to-one communication *) + +type t + (** Type of a server *) + +val addresses : t -> OBus_address.t list + (** [addresses server] returns all the addresses the server is + listenning on. These addresses must be passed to clients so they + can connect to [server]. *) + +val shutdown : t -> unit Lwt.t + (** [shutdown server] shutdowns the given server. It terminates when + all listeners (a server may listen on several addresses) have + exited. If the server has already been shut down, it does + nothing. *) + +val make : + ?switch : Lwt_switch.t -> + ?capabilities : OBus_auth.capability list -> + ?mechanisms : OBus_auth.Server.mechanism list -> + ?addresses : OBus_address.t list -> + ?allow_anonymous : bool -> + (t -> OBus_connection.t -> unit) -> t Lwt.t + (** [make ?switch ?capabilities ?mechanisms ?addresses ?allow_anonymous f] + Creates a server which will listen on all of the given addresses. + + @param capabilites is the set of the server's capabilities, + @param mechanisms is the list of authentication mechanisms + supported by the server, + @param addresses default to + [{ name = "unix"; args = [("tmpdir", "/tmp")]], + @param allow_anonymous tell whether clients using anonymous + authentication will be accepted. It defaults to [false], + @param capabilities is the list of supported capabilities, it + defaults to {!OBus_auth.capabilities} + @param f is the callback which receive new clients. It takes + as arguments the server and the connection for the client. + + About errors: + - if no addresses are provided, it raises [Invalid_argument], + - if an address is invalid, it raises [Invalid_argument] + - if listening fails for one of the addresses, it fails with the + exception reported for that address + + It succeeds if it can listen on at least one address. + + When a new client connects, the server handles authentication of + this client, then it creates a transport and the connection on + top of this transport. + + Note that connections passed to [f] are initially down. It is up + to the user to set them up with {!OBus_connection.set_up}. *) + +val make_lowlevel : + ?switch : Lwt_switch.t -> + ?capabilities : OBus_auth.capability list -> + ?mechanisms : OBus_auth.Server.mechanism list -> + ?addresses : OBus_address.t list -> + ?allow_anonymous : bool -> + (t -> OBus_transport.t -> unit) -> t Lwt.t + (** [make_lowlevel] is the same as {!make} except that [f] receives + only the transport, and no connection is created for this + transport. *) diff --git a/src/protocol/oBus_signal.ml b/src/protocol/oBus_signal.ml new file mode 100644 index 0000000..b9a3542 --- /dev/null +++ b/src/protocol/oBus_signal.ml @@ -0,0 +1,292 @@ +(* + * oBus_signal.ml + * -------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(signal)" + +open Lwt_react + +(* +-----------------------------------------------------------------+ + | Signal descriptors | + +-----------------------------------------------------------------+ *) + +type 'a t = { + interface : OBus_name.interface; + (* The interface of the signal. *) + + member : OBus_name.member; + (* The name of the signal. *) + + peer : OBus_peer.t; + (* The peer emitting the signal. *) + + path : OBus_path.t option; + (* The path of the object emitting the signa or [None] if we want to + match signals comming from any objects. *) + + map : (OBus_context.t * OBus_path.t * OBus_value.V.sequence) event -> (OBus_context.t * 'a) event; + (* The function which maps the event into an event holding values of + type ['a]. *) + + filters : OBus_match.arguments; + (* Argument filters. *) + + match_rule : bool; + (* Whether the managed mode for the match rule is enabled *) +} + +let empty_filters = OBus_match.make_arguments [] + +(* Cast a message body into an ocaml value: *) +let cast signal (context, path, body) = + try + Some(context, + OBus_value.C.cast_sequence + (OBus_value.arg_types + (OBus_member.Signal.args signal)) + body) + with OBus_value.C.Signature_mismatch -> + ignore ( + Lwt_log.error_f ~section "failed to cast signal from %S, interface %S, member %S with signature %S to %S" + (OBus_peer.name (OBus_context.sender context)) + (OBus_member.Signal.interface signal) + (OBus_member.Signal.member signal) + (OBus_value.string_of_signature + (OBus_value.V.type_of_sequence body)) + (OBus_value.string_of_signature + (OBus_value.C.type_sequence + (OBus_value.arg_types + (OBus_member.Signal.args signal)))) + ); + None + +let cast_any signal (context, path, body) = + match cast signal (context, path, body) with + | Some(context, v) -> Some(context, (OBus_proxy.make (OBus_context.sender context) path, v)) + | None -> None + +let make signal proxy = { + interface = OBus_member.Signal.interface signal; + member = OBus_member.Signal.member signal; + peer = OBus_proxy.peer proxy; + path = Some(OBus_proxy.path proxy); + map = E.fmap (cast signal); + filters = empty_filters; + match_rule = OBus_connection.name (OBus_proxy.connection proxy) <> ""; +} + +let make_any signal peer = { + interface = OBus_member.Signal.interface signal; + member = OBus_member.Signal.member signal; + peer = peer; + path = None; + map = E.fmap (cast_any signal); + filters = empty_filters; + match_rule = OBus_connection.name (OBus_peer.connection peer) <> ""; +} + +(* +-----------------------------------------------------------------+ + | Signals transformations and parameters | + +-----------------------------------------------------------------+ *) + +let map_event f sd = + { sd with map = fun event -> f (sd.map event) } + +let map f sd = + { sd with map = fun event -> E.map (fun (context, value) -> (context, f value)) (sd.map event) } + +let map_with_context f sd = + { sd with map = fun event -> E.map (fun (context, value) -> (context, f context value)) (sd.map event) } + +let with_context sd = + { sd with map = fun event -> E.map (fun (context, value) -> (context, (context, value))) (sd.map event) } + +let with_filters filters sd = + { sd with filters } + +let with_match_rule match_rule sd = + { sd with match_rule } + +(* +-----------------------------------------------------------------+ + | Signals dispatching | + +-----------------------------------------------------------------+ *) + +module Signal_map = Map.Make + (struct + type t = OBus_path.t option * OBus_name.interface * OBus_name.member + let compare = Pervasives.compare + end) + +type info = { + mutable senders : (OBus_context.t * OBus_path.t * OBus_value.V.sequence -> unit) Lwt_sequence.t Signal_map.t; +} + +let dispatch connection info message = + match OBus_message.typ message with + | OBus_message.Signal(path, interface, member) -> + begin + match try Some(Signal_map.find (Some path, interface, member) info.senders) with Not_found -> None with + | Some senders -> + Lwt_sequence.iter_l + (fun send -> + try + send (OBus_context.make connection message, path, OBus_message.body message) + with exn -> + ignore (Lwt_log.error ~section ~exn "signal event failed with")) + senders + | None -> + () + end; + begin + match try Some(Signal_map.find (None, interface, member) info.senders) with Not_found -> None with + | Some senders -> + Lwt_sequence.iter_l + (fun send -> + try + send (OBus_context.make connection message, path, OBus_message.body message) + with exn -> + ignore (Lwt_log.error ~section ~exn "signal event failed with")) + senders + | None -> + () + end; + Some message + | _ -> + Some message + +(* +-----------------------------------------------------------------+ + | Signals connection | + +-----------------------------------------------------------------+ *) + +let finalise disconnect _ = + ignore (Lazy.force disconnect) + +let key = OBus_connection.new_key () + +let connect ?switch sd = + Lwt_switch.check switch; + let connection = OBus_peer.connection sd.peer and name = OBus_peer.name sd.peer in + + (* Switch freeing resources allocated for this signal: *) + let resources_switch = Lwt_switch.create () in + + try%lwt + (* Add the match rule if requested: *) + let%lwt () = + if sd.match_rule then + OBus_match.export + ~switch:resources_switch + connection + (OBus_match.rule + ~typ:`Signal + ~sender:name + ?path:sd.path + ~interface:sd.interface + ~member:sd.member + ()) + else + Lwt.return () + + (* Plus the resolver if needed: *) + and owner_option = + if OBus_connection.name connection <> "" && name <> "" then + if OBus_name.is_unique name then + Lwt.return (Some (S.const name)) + else + let%lwt owner = OBus_resolver.make ~switch:resources_switch connection name in + Lwt.return (Some owner) + else + Lwt.return None + in + + let info = + match OBus_connection.get connection key with + | Some info -> + info + | None -> + let info = { + senders = Signal_map.empty; + } in + OBus_connection.set connection key (Some info); + let _ = Lwt_sequence.add_l (dispatch connection info) (OBus_connection.incoming_filters connection) in + info + in + + let senders = + match try Some(Signal_map.find (sd.path, sd.interface, sd.member) info.senders) with Not_found -> None with + | Some senders -> + senders + | None -> + let senders = Lwt_sequence.create () in + info.senders <- Signal_map.add (sd.path, sd.interface, sd.member) senders info.senders; + senders + in + + let event, send = E.create () in + let send v = send v in + let node = Lwt_sequence.add_r send senders in + + let event = + E.filter + (fun (context, path, body) -> + match owner_option with + | Some owner when S.value owner <> OBus_peer.name (OBus_context.sender context) -> + false + | _ -> + OBus_match.match_values sd.filters body) + event + in + + let disconnect = lazy( + try%lwt + Lwt_sequence.remove node; + if Lwt_sequence.is_empty senders then + info.senders <- Signal_map.remove (sd.path, sd.interface, sd.member) info.senders; + Lwt_switch.turn_off resources_switch + with exn -> + let%lwt () = + Lwt_log.warning_f + ~section + ~exn + "failed to disconnect signal \"%s.%s\" of object \"%s\" from \"%s\"" + sd.interface + sd.member + (match sd.path with + | Some path -> OBus_path.to_string path + | None -> "<any>") + (OBus_peer.name sd.peer) + in + Lwt.fail exn + ) in + + let event = E.with_finaliser (finalise disconnect) (E.map snd (sd.map event)) in + + let%lwt () = + Lwt_switch.add_hook_or_exec + switch + (fun () -> + E.stop event; + Lazy.force disconnect) + in + + Lwt.return event + with exn -> + let%lwt () = Lwt_switch.turn_off resources_switch in + Lwt.fail exn + +(* +-----------------------------------------------------------------+ + | Emitting signals | + +-----------------------------------------------------------------+ *) + +let emit info obj ?peer args = + OBus_object.emit obj + ~interface:(OBus_member.Signal.interface info) + ~member:(OBus_member.Signal.member info) + ?peer + (OBus_value.arg_types (OBus_member.Signal.args info)) + args diff --git a/src/protocol/oBus_signal.mli b/src/protocol/oBus_signal.mli new file mode 100644 index 0000000..4107fb4 --- /dev/null +++ b/src/protocol/oBus_signal.mli @@ -0,0 +1,78 @@ +(* + * oBus_signal.mli + * --------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus signals *) + +(** {6 Emitting signals} *) + +val emit : 'a OBus_member.Signal.t -> 'b OBus_object.t -> ?peer : OBus_peer.t -> 'a -> unit Lwt.t + (** [emit signal obj ?peer args] emits [signal] from [obj]. The + destinations of the signal are selected as follow: + + - if [peer] is provided, then the message is sent only to it + - otherwise, if the the object has an owner, it is sent to the owner, + - otherwise, the message is broadcasted on all the connections [obj] + is exported on. + *) + +(** {6 Receving signals} *) + +type 'a t + (** Type of a signal descriptor. A signal descriptor represent the + source of a signal and describes how the value should be + transformed. *) + +val make : 'a OBus_member.Signal.t -> OBus_proxy.t -> 'a t + (** [make signal proxy] creates a signal descriptor. *) + +val make_any : 'a OBus_member.Signal.t -> OBus_peer.t -> (OBus_proxy.t * 'a) t + (** [make_any signal peer] creates a signal descriptor for receiving + signals from any object of [peer]. *) + +val connect : ?switch : Lwt_switch.t -> 'a t -> 'a React.event Lwt.t + (** [connect ?switch sd] connects the signal descriptor [sd] and + returns the event which occurs when the given D-Bus signal is + received. *) + +(** {6 Signals transformations and parameters} *) + +val map_event : ((OBus_context.t * 'a) React.event -> (OBus_context.t * 'b) React.event) -> 'a t -> 'b t + (** [map_event f sd] transforms with [f] the event that is created + when [sd] is connected. *) + +val map : ('a -> 'b) -> 'a t -> 'b t + (** Simplified version of {!map_event}. *) + +val map_with_context : (OBus_context.t -> 'a -> 'b) -> 'a t -> 'b t + (** Same as {!map} but the mapping function also receive the + context. *) + +val with_context : 'a t -> (OBus_context.t * 'a) t + (** @return a signal descriptor that returns contexts in which + signals are received. *) + +val with_filters : OBus_match.arguments -> 'a t -> 'a t + (** [with_filters filters sd] is the signal descriptor [sd] with the + given list of argument filters. When connected, obus will add + this filters to the matching rule send to the message bus, so + the bus can use them to drop messages that do not match these + filters. + + The goal of argument filters is to reduce the number of messages + received, and so to reduce the number of wakeup of the + program. + + Note that match rule management must be activated for filters to + take effect (see {!with_match_rule}). *) + +val with_match_rule : bool -> 'a t -> 'a t + (** [with_match_rule state sd] enables or disables the automatic + management of matching rules. If the endpoint of the underlying + connection is a message bus it defaults to [true], otherwise it + default to [false]. *) diff --git a/src/protocol/oBus_transport.ml b/src/protocol/oBus_transport.ml new file mode 100644 index 0000000..de6ca9a --- /dev/null +++ b/src/protocol/oBus_transport.ml @@ -0,0 +1,292 @@ +(* + * oBus_transport.ml + * ----------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(transport)" + +open Unix +open Printf +open OBus_address +open Lwt.Infix + +(* +-----------------------------------------------------------------+ + | Types and constructors | + +-----------------------------------------------------------------+ *) + +type t = { + recv : unit -> OBus_message.t Lwt.t; + send : OBus_message.t -> unit Lwt.t; + capabilities : OBus_auth.capability list; + shutdown : unit -> unit Lwt.t; +} + +let make ?switch ~recv ~send ?(capabilities=[]) ~shutdown () = + let transport = { + recv = recv; + send = send; + capabilities = capabilities; + shutdown = shutdown; + } in + Lwt_switch.add_hook switch transport.shutdown; + transport + +let recv t = t.recv () +let send t message = t.send message +let capabilities t = t.capabilities +let shutdown t = t.shutdown () + +(* +-----------------------------------------------------------------+ + | Socket transport | + +-----------------------------------------------------------------+ *) + +let socket ?switch ?(capabilities=[]) fd = + let transport = + if List.mem `Unix_fd capabilities then + let reader = OBus_wire.reader fd + and writer = OBus_wire.writer fd in + { recv = (fun _ -> OBus_wire.read_message_with_fds reader); + send = (fun msg -> OBus_wire.write_message_with_fds writer msg); + capabilities = capabilities; + shutdown = (fun _ -> + let%lwt () = OBus_wire.close_reader reader <&> OBus_wire.close_writer writer in + Lwt_unix.shutdown fd SHUTDOWN_ALL; + Lwt_unix.close fd) } + else + let ic = Lwt_io.of_fd ~mode:Lwt_io.input ~close:Lwt.return fd + and oc = Lwt_io.of_fd ~mode:Lwt_io.output ~close:Lwt.return fd in + { recv = (fun _ -> OBus_wire.read_message ic); + send = (fun msg -> OBus_wire.write_message oc msg); + capabilities = capabilities; + shutdown = (fun _ -> + let%lwt () = Lwt_io.close ic <&> Lwt_io.close oc in + Lwt_unix.shutdown fd SHUTDOWN_ALL; + Lwt_unix.close fd) } + in + Lwt_switch.add_hook switch transport.shutdown; + transport + +(* +-----------------------------------------------------------------+ + | Loopback transport | + +-----------------------------------------------------------------+ *) + +let loopback () = + let mvar = Lwt_mvar.create_empty () in + { recv = (fun _ -> Lwt_mvar.take mvar); + send = (fun m -> Lwt_mvar.put mvar { m with OBus_message.body = OBus_value.V.sequence_dup (OBus_message.body m) }); + capabilities = [`Unix_fd]; + shutdown = Lwt.return } + +(* +-----------------------------------------------------------------+ + | Addresses -> transport | + +-----------------------------------------------------------------+ *) + +let make_socket domain typ addr = + let fd = Lwt_unix.socket domain typ 0 in + (try Lwt_unix.set_close_on_exec fd with _ -> ()); + try%lwt + let%lwt () = Lwt_unix.connect fd addr in + Lwt.return (fd, domain) + with exn -> + let%lwt () = Lwt_unix.close fd in + Lwt.fail exn + +let rec write_nonce fd nonce pos len = + Lwt_unix.write_string fd nonce 0 16 >>= function + | 0 -> + Lwt.fail (Failure "OBus_transport.connect: failed to send the nonce to the server") + | n -> + if n = len then + Lwt.return () + else + write_nonce fd nonce (pos + n) (len - n) + +let make_socket_nonce nonce_file domain typ addr = + match nonce_file with + | None -> + Lwt.fail (Invalid_argument "OBus_transport.connect: missing 'noncefile' parameter") + | Some file_name -> + let%lwt nonce = + try%lwt + Lwt_io.with_file ~mode:Lwt_io.input file_name (Lwt_io.read ~count:16) + with + | Unix.Unix_error(err, _, _) -> + Lwt.fail (Failure(Printf.sprintf "failed to read the nonce file '%s': %s" file_name (Unix.error_message err))) + | End_of_file -> + Lwt.fail (Failure(Printf.sprintf "OBus_transport.connect: '%s' is an invalid nonce-file" file_name)) + in + if String.length nonce <> 16 then + Lwt.fail (Failure(Printf.sprintf "OBus_transport.connect: '%s' is an invalid nonce-file" file_name)) + else begin + let%lwt fd, domain = make_socket domain typ addr in + let%lwt () = write_nonce fd nonce 0 16 in + Lwt.return (fd, domain) + end + +let rec connect address = + match OBus_address.name address with + | "unix" -> begin + match (OBus_address.arg "path" address, + OBus_address.arg "abstract" address, + OBus_address.arg "tmpdir" address) with + | Some path, None, None -> + make_socket PF_UNIX SOCK_STREAM (ADDR_UNIX path) + | None, Some abst, None -> + make_socket PF_UNIX SOCK_STREAM (ADDR_UNIX("\x00" ^ abst)) + | None, None, Some tmpd -> + Lwt.fail (Invalid_argument "OBus_transport.connect: unix tmpdir can only be used as a listening address") + | _ -> + Lwt.fail (Invalid_argument "OBus_transport.connect: invalid unix address, must supply exactly one of 'path', 'abstract', 'tmpdir'") + end + | ("tcp" | "nonce-tcp") as name -> begin + let host = match OBus_address.arg "host" address with + | Some host -> host + | None -> "" + and port = match OBus_address.arg "port" address with + | Some port -> port + | None -> "0" + in + let opts = [AI_SOCKTYPE SOCK_STREAM] in + let opts = match OBus_address.arg "family" address with + | Some "ipv4" -> AI_FAMILY PF_INET :: opts + | Some "ipv6" -> AI_FAMILY PF_INET6 :: opts + | Some family -> Printf.ksprintf invalid_arg "OBus_transport.connect: unknown address family '%s'" family + | None -> opts + in + Lwt_unix.getaddrinfo host port opts >>= function + | [] -> + Lwt.fail + (Failure + (Printf.sprintf + "OBus_transport.connect: no address info for host=%s port=%s%s" + host port + (match OBus_address.arg "family" address with + | None -> "" + | Some f -> " family=" ^ f))) + | ai :: ais -> + let make_socket = + if name = "nonce-tcp" then + make_socket_nonce (OBus_address.arg "noncefile" address) + else + make_socket + in + try%lwt + make_socket ai.ai_family ai.ai_socktype ai.ai_addr + with exn -> + (* If the first connection failed, try with all the + other ones: *) + let rec find = function + | [] -> + (* If all connection failed, raise the error for + the first address: *) + Lwt.fail exn + | ai :: ais -> + try%lwt + make_socket ai.ai_family ai.ai_socktype ai.ai_addr + with exn -> + find ais + in + find ais + end + | "launchd" -> begin + match OBus_address.arg "env" address with + | Some env -> + let%lwt path = + try%lwt + Lwt_process.pread_line ("launchctl", [|"launchctl"; "getenv"; env|]) + with exn -> + let%lwt () = Lwt_log.error_f ~exn ~section "launchctl failed" in + Lwt.fail exn + in + make_socket PF_UNIX SOCK_STREAM (ADDR_UNIX path) + | None -> + Lwt.fail (Invalid_argument "OBus_transport.connect: missing 'env' in launchd address") + end + | "autolaunch" -> begin + let%lwt addresses = + let%lwt uuid = Lazy.force OBus_info.machine_uuid in + let%lwt line = + try%lwt + Lwt_process.pread_line ("dbus-launch", [|"dbus-launch"; "--autolaunch"; OBus_uuid.to_string uuid; "--binary-syntax"|]) + with exn -> + let%lwt () = Lwt_log.error_f ~exn ~section "autolaunch failed" in + Lwt.fail exn + in + let line = try String.sub line 0 (String.index line '\000') with _ -> line in + try%lwt + Lwt.return (OBus_address.of_string line) + with OBus_address.Parse_failure(addr, pos, reason) as exn -> + let%lwt () = Lwt_log.error_f ~section "autolaunch returned an invalid address %S, at position %d: %s" addr pos reason in + Lwt.fail exn + in + match addresses with + | [] -> + let%lwt () = Lwt_log.error_f ~section "'autolaunch' returned no addresses" in + Lwt.fail (Failure "'autolaunch' returned no addresses") + | address :: rest -> + try%lwt + connect address + with exn -> + let rec find = function + | [] -> + Lwt.fail exn + | address :: rest -> + try%lwt + connect address + with exn -> + find rest + in + find rest + end + + | name -> + Lwt.fail (Failure ("unknown transport type: " ^ name)) + +let of_addresses ?switch ?(capabilities=OBus_auth.capabilities) ?mechanisms addresses = + Lwt_switch.check switch; + match addresses with + | [] -> + Lwt.fail (Invalid_argument "OBus_transport.of_addresses: no address given") + | addr :: rest -> + (* Search an address for which connection succeed: *) + let%lwt fd, domain = + try%lwt + connect addr + with exn -> + (* If the first try fails, try with the others: *) + let rec find = function + | [] -> + (* If they all fail, raise the first exception: *) + Lwt.fail exn + | addr :: rest -> + try%lwt + connect addr + with exn -> + find rest + in + find rest + in + (* Do authentication only once: *) + try%lwt + Lwt_unix.write_string fd "\x00" 0 1 >>= function + | 0 -> + Lwt.fail (OBus_auth.Auth_failure "failed to send the initial null byte") + | 1 -> + let%lwt guid, capabilities = + OBus_auth.Client.authenticate + ~capabilities:(List.filter (function `Unix_fd -> domain = PF_UNIX) capabilities) + ?mechanisms + ~stream:(OBus_auth.stream_of_fd fd) + () + in + Lwt.return (guid, socket ?switch ~capabilities fd) + | n -> + assert false + with exn -> + Lwt_unix.shutdown fd SHUTDOWN_ALL; + let%lwt () = Lwt_unix.close fd in + Lwt.fail exn diff --git a/src/protocol/oBus_transport.mli b/src/protocol/oBus_transport.mli new file mode 100644 index 0000000..a360b2e --- /dev/null +++ b/src/protocol/oBus_transport.mli @@ -0,0 +1,79 @@ +(* + * oBus_transport.mli + * ------------------ + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Low-level transporting of messages *) + +type t + (** Type of message transport *) + +val recv : t -> OBus_message.t Lwt.t + (** [recv tr] receives one message from the given transport *) + +val send : t -> OBus_message.t -> unit Lwt.t + (** [send tr msg] sends [msg] over the transport [tr]. *) + +val capabilities : t -> OBus_auth.capability list + (** Returns the capabilities of the transport *) + +val shutdown : t -> unit Lwt.t + (** [shutdown tr] frees resources allocated by the given transport *) + +val make : + ?switch : Lwt_switch.t -> + recv : (unit -> OBus_message.t Lwt.t) -> + send : (OBus_message.t -> unit Lwt.t) -> + ?capabilities : OBus_auth.capability list -> + shutdown : (unit -> unit Lwt.t) -> unit -> t + (** [make ?switch ~recv ~send ~support_unxi_fd ~shutdown ()] creates + a new transport from the given functions. @param capabilities + defaults to [[]]. + + Notes: + - message reading/writing are serialized by obus, so there is no + need to handle concurrent access to transport + *) + +val loopback : unit -> t + (** Loopback transport, each message sent is received on the same + transport *) + +val socket : ?switch : Lwt_switch.t -> ?capabilities : OBus_auth.capability list -> Lwt_unix.file_descr -> t + (** [socket ?switch ?capabilities socket] creates a socket + transport. + + @param capabilities defaults to [[]]. For unix sockets, the + [`Unix_fd] capability is accepted. *) + +val of_addresses : + ?switch : Lwt_switch.t -> + ?capabilities : OBus_auth.capability list -> + ?mechanisms : OBus_auth.Client.mechanism list -> + OBus_address.t list -> + (OBus_address.guid * t) Lwt.t + (** [of_addresses ?switch ?capabilities ?mechanisms addresses] tries to: + + - connect to the server using one of the given given addresses, + - authenticate itself to the server using [mechanisms], which + defaults to {!OBus_auth.Client.default_mechanisms}, + - negotiates [capabilities], which defaults to + {!OBus_auth.capabilities} + + If all succeeded, it returns the server address guid and the + newly created transport, which is ready to send and receive + messages. + + Note about errors: + - if one of the addresses is not valid, or [addresses = []], + it raises [Invalid_argument], + - if all connections failed, it raises the exception raised + by the try on first address, which is either a [Failure] or + a [Unix.Unix_error] + - if the authentication failed, a {!OBus_auth.Auth_error} is + raised + *) diff --git a/src/protocol/oBus_uuid.ml b/src/protocol/oBus_uuid.ml new file mode 100644 index 0000000..c2ab26a --- /dev/null +++ b/src/protocol/oBus_uuid.ml @@ -0,0 +1,28 @@ +(* + * oBus_uuid.ml + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +type t = string + +let of_string str = + let fail _ = raise (Invalid_argument (Printf.sprintf "OBus_uuid.of_string(%S)" str)) in + if String.length str <> 32 then fail (); + try OBus_util.hex_decode str + with _ -> fail () + +let to_string = OBus_util.hex_encode + +let generate () = + let uuid = Bytes.create 16 in + OBus_util.fill_random uuid 0 12; + let v = Int32.of_float (Unix.time ()) in + Bytes.set uuid 12 (Char.unsafe_chr (Int32.to_int (Int32.shift_right v 24))); + Bytes.set uuid 13 (Char.unsafe_chr (Int32.to_int (Int32.shift_right v 16))); + Bytes.set uuid 14 (Char.unsafe_chr (Int32.to_int (Int32.shift_right v 8))); + Bytes.set uuid 15 (Char.unsafe_chr (Int32.to_int v)); + Bytes.unsafe_to_string uuid diff --git a/src/protocol/oBus_uuid.mli b/src/protocol/oBus_uuid.mli new file mode 100644 index 0000000..9888e88 --- /dev/null +++ b/src/protocol/oBus_uuid.mli @@ -0,0 +1,31 @@ +(* + * oBus_uuid.mli + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus universally-unique IDs *) + +(** D-Bus uuid are used to distinguish message buses, addresses, and + machines. + + Note that they are not compatible with RFC4122. *) + +type t + +val generate : unit -> t + (** Generate a new uuid *) + +val of_string : string -> t + (** Create a uuid from a string. The string must contain an + hex-encoded uuid, i.e. be of length 32 and only contain + hexadecimal characters. It raise a failure otherwise. + + @raise Invalid_argument if the string does not contain a valid + uuid. *) + +val to_string : t -> string + (** Return a hex-encoded string representation of an uuid. *) diff --git a/src/protocol/oBus_wire.ml b/src/protocol/oBus_wire.ml new file mode 100644 index 0000000..4a8cba5 --- /dev/null +++ b/src/protocol/oBus_wire.ml @@ -0,0 +1,1333 @@ +(* + * oBus_lowlevel.ml + * ---------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(wire)" + +open Printf +open OBus_value +open OBus_message +open OBus_protocol + +(* +-----------------------------------------------------------------+ + | Errors | + +-----------------------------------------------------------------+ *) + +exception Data_error of string +exception Protocol_error of string + +let () = + Printexc.register_printer + (function + | Data_error msg -> + Some(sprintf "failed to marshal D-Bus message: %s" msg) + | Protocol_error msg -> + Some(sprintf "D-Bus protocol error: %s" msg) + | _ -> + None) + +(* Common error message *) +let array_too_big len = sprintf "array size exceed the limit: %d" len +let message_too_big len = sprintf "message size exceed the limit: %d" len +let signature_too_long s len = sprintf "too long signature: '%s', with len %d" (string_of_signature s) len +let invalid_protocol_version ver = sprintf "invalid protocol version: %d (obus implement protocol version %d)" ver OBus_info.protocol_version +let invalid_byte_order ch = sprintf "invalid byte order(%C)" ch + +(* +-----------------------------------------------------------------+ + | Padding | + +-----------------------------------------------------------------+ *) + +let padding2 i = i land 1 +let padding4 i = (4 - i) land 3 +let padding8 i = (8 - i) land 7 + +let pad2 i = i + padding2 i +let pad4 i = i + padding4 i +let pad8 i = i + padding8 i + +let pad8_p = function + | T.Structure _ + | T.Basic T.Int64 + | T.Basic T.Uint64 + | T.Basic T.Double -> true + | _ -> false + +(* +-----------------------------------------------------------------+ + | Raw description of header fields | + +-----------------------------------------------------------------+ *) + +type raw_fields = { + mutable rf_path : OBus_path.t option; + mutable rf_member : OBus_name.member; + mutable rf_interface : OBus_name.interface; + mutable rf_error_name : OBus_name.error; + mutable rf_reply_serial : serial option; + mutable rf_destination : OBus_name.bus; + mutable rf_sender : OBus_name.bus; + mutable rf_signature : signature; + mutable rf_unix_fds : int; +} + +let missing_field message_type_name field_name = + raise (Protocol_error(sprintf "invalid header, field '%s' is required for '%s'" + field_name message_type_name)) + +let get_required_string message_type_name field_name = function + | "" -> + missing_field message_type_name field_name + | string -> + string + +let get_required_option message_type_name field_name = function + | None -> + missing_field message_type_name field_name + | Some value -> + value + +let method_call_of_raw fields = + Method_call(get_required_option "method-call" "path" fields.rf_path, + fields.rf_interface, + get_required_string "method-call" "member" fields.rf_member) + +let method_return_of_raw fields = + Method_return(get_required_option "method-return" "reply-serial" fields.rf_reply_serial) + +let error_of_raw fields = + Error(get_required_option "error" "reply-serial" fields.rf_reply_serial, + get_required_string "error" "error-name" fields.rf_error_name) + +let signal_of_raw fields = + Signal(get_required_option "signal" "path" fields.rf_path, + get_required_string "signal" "interface" fields.rf_interface, + get_required_string "signal" "member" fields.rf_member) + +(* +-----------------------------------------------------------------+ + | Error mapping | + +-----------------------------------------------------------------+ *) + +(* Maps error returned by [OBus_*.*] to [Data_error] or + [Protocol_error]: *) + +let map_exn f = function + | OBus_string.Invalid_string err -> + raise (f (OBus_string.error_message err)) + | OBus_value.Invalid_signature(str, msg) -> + raise (f (Printf.sprintf "invalid signature (%S): %s" str msg)) + | exn -> + raise exn + +let data_error msg = Data_error msg +let protocol_error msg = Protocol_error msg + +(* +-----------------------------------------------------------------+ + | Message size calculation | + +-----------------------------------------------------------------+ *) + +module FD_set = Set.Make(struct type t = Unix.file_descr let compare = compare end) + +module Count = +struct + (* The goal of this module is to compute the marshaled size of a + message, and the number of different file descriptors it + contains. *) + + type counter = { + mutable ofs : int; + (* Simulate an offset *) + mutable fds : FD_set.t; + (* Set used to collect all file descriptors *) + } + + let path_length = function + | [] -> 1 + | l -> List.fold_left (fun acc x -> 1 + String.length x + acc) 0 l + + let rec iter f c = function + | [] -> () + | x :: l -> f c x; iter f c l + + let rec tsingle c = function + | T.Basic _ -> + c.ofs <- c.ofs + 1 + | T.Array t -> + c.ofs <- c.ofs + 1; + tsingle c t + | T.Dict(tk, tv) -> + c.ofs <- c.ofs + 4; + tsingle c tv + | T.Structure l -> + c.ofs <- c.ofs + 2; + iter tsingle c l + | T.Variant -> + c.ofs <- c.ofs + 1 + + let tsequence c l = + iter tsingle c l + + let rec tsingle_of_single c = function + | V.Basic x -> + c.ofs <- c.ofs + 1 + | V.Array(t, x) -> + c.ofs <- c.ofs + 1; + tsingle c t + | V.Byte_array _ -> + c.ofs <- c.ofs + 2 + | V.Dict(tk, tv, x) -> + c.ofs <- c.ofs + 4; + tsingle c tv + | V.Structure l -> + c.ofs <- c.ofs + 2; + iter tsingle_of_single c l + | V.Variant x -> + c.ofs <- c.ofs + 1 + + let tsequence_of_sequence c l = + iter tsingle_of_single c l + + let rec basic c = function + | V.Byte _ -> + c.ofs <- c.ofs + 1 + | V.Int16 _ + | V.Uint16 _ -> + c.ofs <- pad2 c.ofs + 2 + | V.Boolean _ + | V.Int32 _ + | V.Uint32 _ -> + c.ofs <- pad4 c.ofs + 4 + | V.Int64 _ + | V.Uint64 _ + | V.Double _ -> + c.ofs <- pad8 c.ofs + 8 + | V.String s -> + c.ofs <- pad4 c.ofs + String.length s + 5 + | V.Signature s -> + c.ofs <- c.ofs + 2; + tsequence c s + | V.Object_path p -> + c.ofs <- pad4 c.ofs + path_length p + 5 + | V.Unix_fd fd -> + c.ofs <- pad4 c.ofs + 4; + c.fds <- FD_set.add fd c.fds + + let rec single c = function + | V.Basic x -> + basic c x + | V.Array(t, l) -> + c.ofs <- pad4 c.ofs + 4; + if pad8_p t then c.ofs <- pad8 c.ofs; + iter single c l + | V.Byte_array bytes -> + c.ofs <- pad4 c.ofs + 4 + String.length bytes + | V.Dict(tk, tv, l) -> + c.ofs <- pad8 (pad4 c.ofs + 4); + iter dict_entry c l + | V.Structure l -> + c.ofs <- pad8 c.ofs; + iter single c l + | V.Variant x -> + c.ofs <- c.ofs + 2; + tsingle_of_single c x; + single c x + + and dict_entry c (k, v) = + c.ofs <- pad8 c.ofs; + basic c k; + single c v + + let sequence c l = + iter single c l + + let message msg = + let c = { ofs = 16; fds = FD_set.empty } in + begin match msg.typ with + | Method_call(path, "", member) -> + (* +9 for: + - the code (1) + - the signature of one basic type code (3) + - the string length (4) + - the null byte (1) *) + c.ofs <- pad8 c.ofs + 9 + path_length path; + c.ofs <- pad8 c.ofs + 9 + String.length member + | Method_call(path, interface, member) + | Signal(path, interface, member) -> + c.ofs <- pad8 c.ofs + 9 + path_length path; + c.ofs <- pad8 c.ofs + 9 + String.length interface; + c.ofs <- pad8 c.ofs + 9 + String.length member + | Method_return serial -> + c.ofs <- pad8 c.ofs + 8 + | Error(serial, name) -> + c.ofs <- pad8 c.ofs + 9 + String.length name; + c.ofs <- pad8 c.ofs + 8 + end; + if msg.destination <> "" then + c.ofs <- pad8 c.ofs + 9 + String.length msg.destination; + if msg.sender <> "" then + c.ofs <- pad8 c.ofs + 9 + String.length msg.sender; + (* The signature *) + c.ofs <- pad8 c.ofs + 6; + tsequence_of_sequence c msg.body; + (* The number of fds: *) + c.ofs <- pad8 c.ofs + 8; + (* The message body: *) + sequence c msg.body; + c +end + +(* +-----------------------------------------------------------------+ + | Unsafe writing of integers | + +-----------------------------------------------------------------+ *) + +let put_char = Bytes.unsafe_set +let put_uint8 buf ofs x = put_char buf ofs (Char.unsafe_chr x) + +module type Integer_writers = sig + val put_int16 : bytes -> int -> int -> unit + val put_int32 : bytes -> int -> int32 -> unit + val put_int64 : bytes -> int -> int64 -> unit + val put_uint16 : bytes -> int -> int -> unit + val put_uint32 : bytes -> int -> int32 -> unit + val put_uint64 : bytes -> int -> int64 -> unit + + val put_uint : bytes -> int -> int -> unit +end + +module LE_integer_writers : Integer_writers = +struct + let put_int16 buf ofs v = + put_uint8 buf (ofs + 0) v; + put_uint8 buf (ofs + 1) (v lsr 8) + let put_uint16 = put_int16 + + let put_int32 buf ofs v = + put_uint8 buf (ofs + 0) (Int32.to_int v); + put_uint8 buf (ofs + 1) (Int32.to_int (Int32.shift_right v 8)); + put_uint8 buf (ofs + 2) (Int32.to_int (Int32.shift_right v 16)); + put_uint8 buf (ofs + 3) (Int32.to_int (Int32.shift_right v 24)) + let put_uint32 = put_int32 + + let put_int64 buf ofs v = + put_uint8 buf (ofs + 0) (Int64.to_int v); + put_uint8 buf (ofs + 1) (Int64.to_int (Int64.shift_right v 8)); + put_uint8 buf (ofs + 2) (Int64.to_int (Int64.shift_right v 16)); + put_uint8 buf (ofs + 3) (Int64.to_int (Int64.shift_right v 24)); + put_uint8 buf (ofs + 4) (Int64.to_int (Int64.shift_right v 32)); + put_uint8 buf (ofs + 5) (Int64.to_int (Int64.shift_right v 40)); + put_uint8 buf (ofs + 6) (Int64.to_int (Int64.shift_right v 48)); + put_uint8 buf (ofs + 7) (Int64.to_int (Int64.shift_right v 56)) + let put_uint64 = put_int64 + + let put_uint buf ofs v = + put_uint8 buf (ofs + 0) v; + put_uint8 buf (ofs + 1) (v lsr 8); + put_uint8 buf (ofs + 2) (v lsr 16); + put_uint8 buf (ofs + 3) (v asr 24) +end + +module BE_integer_writers : Integer_writers = +struct + let put_int16 buf ofs v = + put_uint8 buf (ofs + 0) (v lsr 8); + put_uint8 buf (ofs + 1) v + let put_uint16 = put_int16 + + let put_int32 buf ofs v = + put_uint8 buf (ofs + 0) (Int32.to_int (Int32.shift_right v 24)); + put_uint8 buf (ofs + 1) (Int32.to_int (Int32.shift_right v 16)); + put_uint8 buf (ofs + 2) (Int32.to_int (Int32.shift_right v 8)); + put_uint8 buf (ofs + 3) (Int32.to_int v) + let put_uint32 = put_int32 + + let put_int64 buf ofs v = + put_uint8 buf (ofs + 0) (Int64.to_int (Int64.shift_right v 56)); + put_uint8 buf (ofs + 1) (Int64.to_int (Int64.shift_right v 48)); + put_uint8 buf (ofs + 2) (Int64.to_int (Int64.shift_right v 40)); + put_uint8 buf (ofs + 3) (Int64.to_int (Int64.shift_right v 32)); + put_uint8 buf (ofs + 4) (Int64.to_int (Int64.shift_right v 24)); + put_uint8 buf (ofs + 5) (Int64.to_int (Int64.shift_right v 16)); + put_uint8 buf (ofs + 6) (Int64.to_int (Int64.shift_right v 8)); + put_uint8 buf (ofs + 7) (Int64.to_int v) + let put_uint64 = put_int64 + + let put_uint buf ofs v = + put_uint8 buf (ofs + 0) (v asr 24); + put_uint8 buf (ofs + 1) (v lsr 16); + put_uint8 buf (ofs + 2) (v lsr 8); + put_uint8 buf (ofs + 3) v +end + +(* +-----------------------------------------------------------------+ + | Unsafe reading of integers | + +-----------------------------------------------------------------+ *) + +let get_char = String.unsafe_get +let get_uint8 buf ofs = Char.code (get_char buf ofs) + +module type Integer_readers = sig + val get_int16 : string -> int -> int + val get_int32 : string -> int -> int32 + val get_int64 : string -> int -> int64 + val get_uint16 : string -> int -> int + val get_uint32 : string -> int -> int32 + val get_uint64 : string -> int -> int64 + + val get_uint : string -> int -> int +end + +module LE_integer_readers : Integer_readers = +struct + let get_int16 buf ofs = + let v0 = get_uint8 buf (ofs + 0) + and v1 = get_uint8 buf (ofs + 1) in + let v = v0 lor (v1 lsl 8) in + if v land (1 lsl 15) = 0 then + v + else + ((-1 land (lnot 0x7fff)) lor v) + + let get_uint16 buf ofs = + let v0 = get_uint8 buf (ofs + 0) + and v1 = get_uint8 buf (ofs + 1) in + (v0 lor (v1 lsl 8)) + + let get_int32 buf ofs = + let v0 = get_uint8 buf (ofs + 0) + and v1 = get_uint8 buf (ofs + 1) + and v2 = get_uint8 buf (ofs + 2) + and v3 = get_uint8 buf (ofs + 3) in + (Int32.logor + (Int32.logor + (Int32.of_int v0) + (Int32.shift_left (Int32.of_int v1) 8)) + (Int32.logor + (Int32.shift_left (Int32.of_int v2) 16) + (Int32.shift_left (Int32.of_int v3) 24))) + let get_uint32 = get_int32 + + let get_int64 buf ofs = + let v0 = get_uint8 buf (ofs + 0) + and v1 = get_uint8 buf (ofs + 1) + and v2 = get_uint8 buf (ofs + 2) + and v3 = get_uint8 buf (ofs + 3) + and v4 = get_uint8 buf (ofs + 4) + and v5 = get_uint8 buf (ofs + 5) + and v6 = get_uint8 buf (ofs + 6) + and v7 = get_uint8 buf (ofs + 7) in + (Int64.logor + (Int64.logor + (Int64.logor + (Int64.of_int v0) + (Int64.shift_left (Int64.of_int v1) 8)) + (Int64.logor + (Int64.shift_left (Int64.of_int v2) 16) + (Int64.shift_left (Int64.of_int v3) 24))) + (Int64.logor + (Int64.logor + (Int64.shift_left (Int64.of_int v4) 32) + (Int64.shift_left (Int64.of_int v5) 40)) + (Int64.logor + (Int64.shift_left (Int64.of_int v6) 48) + (Int64.shift_left (Int64.of_int v7) 56)))) + let get_uint64 = get_int64 + + let get_uint buf ofs = + let v0 = get_uint8 buf (ofs + 0) + and v1 = get_uint8 buf (ofs + 1) + and v2 = get_uint8 buf (ofs + 2) + and v3 = get_uint8 buf (ofs + 3) in + (v0 lor (v1 lsl 8) lor (v2 lsl 16) lor (v3 lsl 24)) +end + +module BE_integer_readers : Integer_readers = +struct + let get_int16 buf ofs = + let v1 = get_uint8 buf (ofs + 0) + and v0 = get_uint8 buf (ofs + 1) in + let v = v0 lor (v1 lsl 8) in + if v land (1 lsl 15) = 0 then + v + else + ((-1 land (lnot 0x7fff)) lor v) + + let get_uint16 buf ofs = + let v1 = get_uint8 buf (ofs + 0) + and v0 = get_uint8 buf (ofs + 1) in + (v0 lor (v1 lsl 8)) + + let get_int32 buf ofs = + let v3 = get_uint8 buf (ofs + 0) + and v2 = get_uint8 buf (ofs + 1) + and v1 = get_uint8 buf (ofs + 2) + and v0 = get_uint8 buf (ofs + 3) in + (Int32.logor + (Int32.logor + (Int32.of_int v0) + (Int32.shift_left (Int32.of_int v1) 8)) + (Int32.logor + (Int32.shift_left (Int32.of_int v2) 16) + (Int32.shift_left (Int32.of_int v3) 24))) + let get_uint32 = get_int32 + + let get_int64 buf ofs = + let v7 = get_uint8 buf (ofs + 0) + and v6 = get_uint8 buf (ofs + 1) + and v5 = get_uint8 buf (ofs + 2) + and v4 = get_uint8 buf (ofs + 3) + and v3 = get_uint8 buf (ofs + 4) + and v2 = get_uint8 buf (ofs + 5) + and v1 = get_uint8 buf (ofs + 6) + and v0 = get_uint8 buf (ofs + 7) in + (Int64.logor + (Int64.logor + (Int64.logor + (Int64.of_int v0) + (Int64.shift_left (Int64.of_int v1) 8)) + (Int64.logor + (Int64.shift_left (Int64.of_int v2) 16) + (Int64.shift_left (Int64.of_int v3) 24))) + (Int64.logor + (Int64.logor + (Int64.shift_left (Int64.of_int v4) 32) + (Int64.shift_left (Int64.of_int v5) 40)) + (Int64.logor + (Int64.shift_left (Int64.of_int v6) 48) + (Int64.shift_left (Int64.of_int v7) 56)))) + let get_uint64 = get_int64 + + let get_uint buf ofs = + let v3 = get_uint8 buf (ofs + 0) + and v2 = get_uint8 buf (ofs + 1) + and v1 = get_uint8 buf (ofs + 2) + and v0 = get_uint8 buf (ofs + 3) in + (v0 lor (v1 lsl 8) lor (v2 lsl 16) lor (v3 lsl 24)) +end + +(* +---------------------------------------------------------------+ + | Common writing functions | + +---------------------------------------------------------------+ *) + +module FD_map = Map.Make(struct type t = Unix.file_descr let compare = Pervasives.compare end) + +(* A pointer for serializing data *) +type wpointer = { + buf : bytes; + mutable ofs : int; + max : int; + fds : int FD_map.t; + (* Maps file descriptros to their index in the resulting fds + array *) +} + +let write_padding2 ptr = + if ptr.ofs land 1 = 1 then begin + put_uint8 ptr.buf ptr.ofs 0; + ptr.ofs <- ptr.ofs + 1 + end + +let write_padding4 ptr = + for k = 1 to padding4 ptr.ofs do + put_uint8 ptr.buf ptr.ofs 0; + ptr.ofs <- ptr.ofs + 1 + done + +let write_padding8 ptr = + for k = 1 to padding8 ptr.ofs do + put_uint8 ptr.buf ptr.ofs 0; + ptr.ofs <- ptr.ofs + 1 + done + +let write1 writer ptr value = + writer ptr.buf ptr.ofs value; + ptr.ofs <- ptr.ofs + 1 + +let write2 writer ptr value = + write_padding2 ptr; + writer ptr.buf ptr.ofs value; + ptr.ofs <- ptr.ofs + 2 + +let write4 writer ptr value = + write_padding4 ptr; + writer ptr.buf ptr.ofs value; + ptr.ofs <- ptr.ofs + 4 + +let write8 writer ptr value = + write_padding8 ptr; + writer ptr.buf ptr.ofs value; + ptr.ofs <- ptr.ofs + 8 + +let write_bytes ptr value = + let len = String.length value in + String.unsafe_blit value 0 ptr.buf ptr.ofs len; + ptr.ofs <- ptr.ofs + len + +(* +-----------------------------------------------------------------+ + | Message writing | + +-----------------------------------------------------------------+ *) + +module Make_writer(Integer_writers : Integer_writers) = +struct + open Integer_writers + + let write_uint8 ptr value = write1 put_uint8 ptr value + let write_uint ptr value = write4 put_uint ptr value + + (* Serialize one string, without verifying it *) + let write_string_no_check ptr string = + write_uint ptr (String.length string); + write_bytes ptr string; + write_uint8 ptr 0 + + (* Serialize a signature. *) + let write_signature ptr signature = + let string = OBus_value.string_of_signature signature in + write_uint8 ptr (String.length string); + write_bytes ptr string; + write_uint8 ptr 0 + + let write_object_path ptr path = + write_string_no_check ptr (OBus_path.to_string path) + + let write_basic ptr = function + | V.Byte x -> write1 put_char ptr x + | V.Boolean x -> write4 put_uint ptr (match x with true -> 1 | false -> 0) + | V.Int16 x -> write2 put_int16 ptr x + | V.Int32 x -> write4 put_int32 ptr x + | V.Int64 x -> write8 put_int64 ptr x + | V.Uint16 x -> write2 put_uint16 ptr x + | V.Uint32 x -> write4 put_uint32 ptr x + | V.Uint64 x -> write8 put_uint64 ptr x + | V.Double x -> write8 put_uint64 ptr (Int64.bits_of_float x) + | V.String x -> begin match OBus_string.validate x with + | Some error -> + raise (Data_error(OBus_string.error_message error)) + | None -> + write_string_no_check ptr x + end + | V.Signature x -> write_signature ptr x + | V.Object_path x -> write_object_path ptr x + | V.Unix_fd fd -> write4 put_uint ptr (FD_map.find fd ptr.fds) + + let rec write_array ptr padded_on_8 write_element values = + (* Array are serialized as follow: + + (1) padding to a 4-block alignement (for array size) + (2) array size + (3) alignement to array elements padding (even if the array is empty) + (4) serialized elements + + The array size (2) is the size of serialized elements (4) *) + + (* Write the padding *) + write_padding4 ptr; + (* Save the position where to write the length of the array: *) + let length_ofs = ptr.ofs in + (* Allocate 4 bytes for the length: *) + ptr.ofs <- ptr.ofs + 4; + (* After the size we are always padded on 4, so we only need to + add padding if elements padding is 8: *) + if padded_on_8 then write_padding8 ptr; + (* Save the position of the beginning of the elements of the + array: *) + let start_ofs = ptr.ofs in + List.iter (fun x -> write_element ptr x) values; + let length = ptr.ofs - start_ofs in + if length < 0 || length > max_array_size then raise (Data_error(array_too_big length)); + (* Write the array length: *) + put_uint ptr.buf length_ofs length + + let rec write_dict_entry ptr (k, v) = + (* Dict-entries are serialized as follow: + + (1) alignement on a 8-block + (2) serialized key + (3) serialized value *) + write_padding8 ptr; + write_basic ptr k; + write_single ptr v + + and write_single ptr = function + | V.Basic x -> + write_basic ptr x + | V.Array(t, x) -> + write_array ptr (pad8_p t) write_single x + | V.Byte_array s -> + write_uint ptr (String.length s); + write_bytes ptr s + | V.Dict(tk, tv, x) -> + write_array ptr true write_dict_entry x + | V.Structure x -> + (* Structure are serialized as follow: + + (1) alignement to an 8-block + (2) serialized contents *) + write_padding8 ptr; + write_sequence ptr x + | V.Variant x -> + (* Variant are serialized as follow: + + (1) marshaled variant signature + (2) serialized contents *) + write_signature ptr [OBus_value.V.type_of_single x]; + write_single ptr x + + and write_sequence ptr = function + | [] -> + () + | x :: l -> + write_single ptr x; + write_sequence ptr l + + (* Header field ptr *) + let write_field_real ptr code typ writer value = + (* Each header field is a structure, so we need to be aligned on 8 *) + write_padding8 ptr; + write_uint8 ptr code; + write_signature ptr [T.Basic typ]; + writer ptr value + + (* Write a field if defined *) + let write_field ptr code typ writer = function + | None -> + () + | Some value -> + write_field_real ptr code typ writer value + + (* Validate and write a field if defined *) + let write_name_field ptr code test = function + | "" -> + () + | string -> + match test string with + | Some error -> + raise (Data_error(OBus_string.error_message error)) + | None -> + write_field_real ptr code T.String write_string_no_check string + + (* Serialize one complete message *) + let write_message byte_order_char msg = + let { Count.ofs = size; Count.fds = fds } = Count.message msg in + if size > max_message_size then raise (Data_error(message_too_big size)); + + let buffer = Bytes.create size in + let ptr = { + buf = buffer; + ofs = 16; + max = size; + fds = snd (FD_set.fold (fun fd (n, map) -> (n + 1, FD_map.add fd n map)) fds (0, FD_map.empty)); + } in + + let fd_count = FD_set.cardinal fds in + (* Compute ``raw'' headers *) + let code, fields = match msg.typ with + | Method_call(path, interface, member) -> + if member = "" then raise (Data_error "invalid method-call message: field 'member' is empty"); + (1, + { rf_path = Some path; + rf_interface = interface; + rf_member = member; + rf_error_name = ""; + rf_reply_serial = None; + rf_destination = msg.destination; + rf_sender = msg.sender; + rf_signature = V.type_of_sequence msg.body; + rf_unix_fds = fd_count }) + | Method_return reply_serial -> + (2, + { rf_path = None; + rf_interface = ""; + rf_member = ""; + rf_error_name = ""; + rf_reply_serial = Some reply_serial; + rf_destination = msg.destination; + rf_sender = msg.sender; + rf_signature = V.type_of_sequence msg.body; + rf_unix_fds = fd_count }) + | Error(reply_serial, error_name) -> + if error_name = "" then raise (Data_error "invalid error message: field 'error-name' is empty"); + (3, + { rf_path = None; + rf_interface = ""; + rf_member = ""; + rf_error_name = error_name; + rf_reply_serial = Some reply_serial; + rf_destination = msg.destination; + rf_sender = msg.sender; + rf_signature = V.type_of_sequence msg.body; + rf_unix_fds = fd_count }) + | Signal(path, interface, member) -> + if interface = "" then raise (Data_error "invalid signal message, field 'interface' is empty"); + if member = "" then raise (Data_error "invalid signal message, field 'member' is empty"); + (4, + { rf_path = Some path; + rf_interface = interface; + rf_member = member; + rf_error_name = ""; + rf_reply_serial = None; + rf_destination = msg.destination; + rf_sender = msg.sender; + rf_signature = V.type_of_sequence msg.body; + rf_unix_fds = fd_count }) + in + + write_field ptr 1 T.Object_path write_object_path fields.rf_path; + write_name_field ptr 2 OBus_name.validate_interface fields.rf_interface; + write_name_field ptr 3 OBus_name.validate_member fields.rf_member; + write_name_field ptr 4 OBus_name.validate_error fields.rf_error_name; + write_field ptr 5 T.Uint32 (write4 put_uint32) fields.rf_reply_serial; + write_name_field ptr 6 OBus_name.validate_bus fields.rf_destination; + write_name_field ptr 7 OBus_name.validate_bus fields.rf_sender; + write_field_real ptr 8 T.Signature write_signature fields.rf_signature; + write_field_real ptr 9 T.Uint32 (write4 put_uint) fields.rf_unix_fds; + + let fields_length = ptr.ofs - 16 in + + if fields_length < 0 || fields_length > max_array_size then + raise (Data_error(array_too_big fields_length)); + + (* The message body start aligned on an 8-boundary after the + header: *) + write_padding8 ptr; + + let start_ofs = ptr.ofs in + + (* Write the message body *) + write_sequence ptr msg.body; + + let body_length = ptr.ofs - start_ofs in + + (* byte #0 : byte-order *) + put_char buffer 0 byte_order_char; + (* byte #1 : message type code *) + put_uint8 buffer 1 code; + (* byte #2 : message flags *) + put_uint8 buffer 2 + ((if msg.flags.no_reply_expected then 1 else 0) lor + (if msg.flags.no_auto_start then 2 else 0)); + (* byte #3 : protocol version *) + put_uint8 buffer 3 OBus_info.protocol_version; + (* byte #4-7 : body length *) + put_uint buffer 4 body_length; + (* byte #8-11 : serial *) + put_uint32 buffer 8 msg.serial; + (* byte #12-15 : fields length *) + put_uint buffer 12 fields_length; + + (* Create the array of file descriptors *) + let fds = Array.make fd_count Unix.stdin in + FD_map.iter (fun fd index -> Array.unsafe_set fds index fd) ptr.fds; + + (Bytes.unsafe_to_string ptr.buf, fds) +end + +module LE_writer = Make_writer(LE_integer_writers) +module BE_writer = Make_writer(BE_integer_writers) + +let string_of_message ?(byte_order=Lwt_io.system_byte_order) msg = + try + match byte_order with + | Lwt_io.Little_endian -> + LE_writer.write_message 'l' msg + | Lwt_io.Big_endian -> + BE_writer.write_message 'B' msg + with exn -> + raise (map_exn data_error exn) + +let write_message oc ?byte_order msg = + match string_of_message ?byte_order msg with + | str, [||] -> + Lwt_io.write oc str + | _ -> + Lwt.fail (Data_error "Cannot send a message with file descriptors on a channel") + +type writer = { + w_channel : Lwt_io.output_channel; + w_file_descr : Lwt_unix.file_descr; +} + +let close_writer writer = Lwt_io.close writer.w_channel + +let writer fd = { + w_channel = Lwt_io.of_fd ~mode:Lwt_io.output ~close:Lwt.return fd; + w_file_descr = fd; +} + +let write_message_with_fds writer ?byte_order msg = + match string_of_message ?byte_order msg with + | buf, [||] -> + (* No file descriptor to send, simply use the channel *) + Lwt_io.write writer.w_channel buf + | buf, fds -> + Lwt_io.atomic begin fun oc -> + (* Ensures there is nothing left to send: *) + let%lwt () = Lwt_io.flush oc in + let len = String.length buf in + let vec = Lwt_unix.IO_vectors.create () in + Lwt_unix.IO_vectors.append_bytes vec (Bytes.unsafe_of_string buf) 0 len; + (* Send the file descriptors and the message: *) + let%lwt n = Lwt_unix.Versioned.send_msg_2 writer.w_file_descr vec (Array.to_list fds) in + assert (n >= 0 && n <= len); + (* Write what is remaining: *) + Lwt_io.write_from_string_exactly oc buf n (len - n) + end writer.w_channel + +(* +-----------------------------------------------------------------+ + | Common reading operations | + +-----------------------------------------------------------------+ *) + +(* A pointer for unserializing data *) +type rpointer = { + buf : string; + mutable ofs : int; + max : int; + mutable fds : Unix.file_descr array; + (* The array of file descriptors received with the message *) +} + +let out_of_bounds () = raise (Protocol_error "out of bounds") +let unitialized_padding () = raise (Protocol_error "unitialized padding") + +let read_padding ptr count = + for i = 1 to count do + if get_uint8 ptr.buf ptr.ofs <> 0 then unitialized_padding (); + ptr.ofs <- ptr.ofs + 1 + done + +let read_padding2 ptr = + if padding2 ptr.ofs = 1 then begin + if ptr.ofs + 1 > ptr.max then out_of_bounds (); + if get_uint8 ptr.buf ptr.ofs <> 0 then unitialized_padding () + end + +let read_padding4 ptr = + let padding = padding4 ptr.ofs in + if ptr.ofs + padding > ptr.max then out_of_bounds (); + read_padding ptr padding + +let read_padding8 ptr = + let padding = padding8 ptr.ofs in + if ptr.ofs + padding > ptr.max then out_of_bounds (); + read_padding ptr padding + +let read1 reader ptr = + if ptr.ofs + 1 > ptr.max then out_of_bounds (); + let x = reader ptr.buf ptr.ofs in + ptr.ofs <- ptr.ofs + 1; + x + +let read2 reader ptr = + let padding = padding2 ptr.ofs in + if ptr.ofs + padding + 2 > ptr.max then out_of_bounds (); + read_padding ptr padding; + let x = reader ptr.buf ptr.ofs in + ptr.ofs <- ptr.ofs + 2; + x + +let read4 reader ptr = + let padding = padding4 ptr.ofs in + if ptr.ofs + padding + 4 > ptr.max then out_of_bounds (); + read_padding ptr padding; + let x = reader ptr.buf ptr.ofs in + ptr.ofs <- ptr.ofs + 4; + x + +let read8 reader ptr = + let padding = padding8 ptr.ofs in + if ptr.ofs + padding + 8 > ptr.max then out_of_bounds (); + read_padding ptr padding; + let x = reader ptr.buf ptr.ofs in + ptr.ofs <- ptr.ofs + 8; + x + +let read_bytes ptr len = + if len < 0 || ptr.ofs + len > ptr.max then out_of_bounds (); + let s = Bytes.create len in + String.unsafe_blit ptr.buf ptr.ofs s 0 len; + ptr.ofs <- ptr.ofs + len; + Bytes.unsafe_to_string s + +(* +-----------------------------------------------------------------+ + | Message reading | + +-----------------------------------------------------------------+ *) + +module Make_reader(Integer_readers : Integer_readers) = +struct + open Integer_readers + + let read_uint ptr = read4 get_uint ptr + let read_uint8 ptr = read1 get_uint8 ptr + + let read_string_no_check ptr = + let len = read_uint ptr in + let x = read_bytes ptr len in + if read_uint8 ptr <> 0 then raise (Protocol_error "missing string terminal null byte"); + x + + let read_signature ptr = + let len = read_uint8 ptr in + let x = read_bytes ptr len in + if read_uint8 ptr <> 0 then raise (Protocol_error "missing signature terminating null byte"); + OBus_value.signature_of_string x + + let read_object_path ptr = + let str = read_string_no_check ptr in + OBus_path.of_string str + + let read_vbyte ptr = V.Byte(read1 get_char ptr) + let read_vboolean ptr = match read_uint ptr with + | 0 -> V.Boolean false + | 1 -> V.Boolean true + | n -> raise (Protocol_error(sprintf "invalid boolean value: %d" n)) + let read_vint16 ptr = V.Int16(read2 get_int16 ptr) + let read_vint32 ptr = V.Int32(read4 get_int32 ptr) + let read_vint64 ptr = V.Int64(read8 get_int64 ptr) + let read_vuint16 ptr = V.Uint16(read2 get_uint16 ptr) + let read_vuint32 ptr = V.Uint32(read4 get_uint32 ptr) + let read_vuint64 ptr = V.Uint64(read8 get_uint64 ptr) + let read_vdouble ptr = V.Double(Int64.float_of_bits (read8 get_uint64 ptr)) + let read_vstring ptr = + let str = read_string_no_check ptr in + match OBus_string.validate str with + | None -> V.String str + | Some error -> raise (Protocol_error(OBus_string.error_message error)) + let read_vsignature ptr = V.Signature(read_signature ptr) + let read_vobject_path ptr = V.Object_path(read_object_path ptr) + let read_unix_fd ptr = + let index = read4 get_uint ptr in + if index < 0 || index >= Array.length ptr.fds then + raise (Protocol_error "fd index out of bounds") + else + V.Unix_fd(Array.unsafe_get ptr.fds index) + + let basic_reader = function + | T.Byte -> read_vbyte + | T.Boolean -> read_vboolean + | T.Int16 -> read_vint16 + | T.Int32 -> read_vint32 + | T.Int64 -> read_vint64 + | T.Uint16 -> read_vuint16 + | T.Uint32 -> read_vuint32 + | T.Uint64 -> read_vuint64 + | T.Double -> read_vdouble + | T.String -> read_vstring + | T.Signature -> read_vsignature + | T.Object_path -> read_vobject_path + | T.Unix_fd -> read_unix_fd + + let read_array padded_on_8 read_element ptr = + let len = read_uint ptr in + if len < 0 || len > max_array_size then raise (Protocol_error(array_too_big len)); + if padded_on_8 then read_padding8 ptr; + let limit = ptr.ofs + len in + let rec aux () = + if ptr.ofs >= limit then + [] + else + let x = read_element ptr in + let l = aux () in + x :: l + in + aux () + + let rec single_reader = function + | T.Basic t -> + let reader = basic_reader t in + (fun ptr -> V.basic(reader ptr)) + | T.Array(T.Basic T.Byte)-> + (fun ptr -> + let len = read_uint ptr in + if len < 0 || len > max_array_size then raise (Protocol_error(array_too_big len)); + V.byte_array (read_bytes ptr len)) + | T.Array t -> + let reader = single_reader t and padded_on_8 = pad8_p t in + (fun ptr -> V.unsafe_array t (read_array padded_on_8 reader ptr)) + | T.Dict(tk, tv) -> + let kreader = basic_reader tk and vreader = single_reader tv in + let reader ptr = + read_padding8 ptr; + let k = kreader ptr in + let v = vreader ptr in + (k, v) + in + (fun ptr -> V.unsafe_dict tk tv (read_array true reader ptr)) + | T.Structure tl -> + let reader = sequence_reader tl in + (fun ptr -> + read_padding8 ptr; + V.structure (reader ptr)) + | T.Variant -> + read_variant + + and read_variant ptr = + match read_signature ptr with + | [t] -> + V.variant (single_reader t ptr) + | s -> + raise (Protocol_error(Printf.sprintf "variant signature does not contain one single type: %S" (OBus_value.string_of_signature s))) + + and sequence_reader = function + | [] -> + (fun ptr -> []) + | t :: l -> + let head_reader = single_reader t and tail_reader = sequence_reader l in + (fun ptr -> + let x = head_reader ptr in + let l = tail_reader ptr in + x :: l) + + let read_field code typ reader ptr = + match read_signature ptr with + | [T.Basic t] when t = typ -> + reader ptr + | s -> + raise (Protocol_error(sprintf "invalid header field signature for code %d: %S, should be %S" + code (string_of_signature s) (string_of_signature [T.Basic typ]))) + + let read_name_field code test ptr = + let str = read_field code T.String read_string_no_check ptr in + match test str with + | None -> + str + | Some error -> + raise (Protocol_error(OBus_string.error_message error)) + + let read_message buffer get_message = + (* Check the protocol version first, since we can not do anything + if it is not the same as our *) + let protocol_version = get_uint8 buffer 3 in + if protocol_version <> OBus_info.protocol_version then + raise (Protocol_error(invalid_protocol_version protocol_version)); + + let message_maker = match get_uint8 buffer 1 with + | 1 -> method_call_of_raw + | 2 -> method_return_of_raw + | 3 -> error_of_raw + | 4 -> signal_of_raw + | n -> raise (Protocol_error(sprintf "unknown message type: %d" n)) in + + let n = get_uint8 buffer 2 in + let flags = { no_reply_expected = n land 1 = 1; no_auto_start = n land 2 = 2 } in + + let body_length = get_uint buffer 4 + and serial = get_uint32 buffer 8 + and fields_length = get_uint buffer 12 in + + (* Header fields array start on byte #16 and message start aligned + on a 8-boundary after it, so we have: *) + let total_length = 16 + pad8 fields_length + body_length in + + (* Safety checkings *) + + if fields_length < 0 || fields_length > max_array_size then + raise (Protocol_error(array_too_big fields_length)); + + if body_length < 0 || total_length > max_message_size then + raise (Protocol_error(message_too_big total_length)); + + get_message total_length begin fun ptr pending_fds cont -> + let fields = { + rf_path = None; + rf_member = ""; + rf_interface = ""; + rf_error_name = ""; + rf_reply_serial = None; + rf_destination = ""; + rf_sender = ""; + rf_signature = []; + rf_unix_fds = 0; + } in + let limit = ptr.ofs + fields_length in + (* Reading of fields *) + while ptr.ofs < limit do + read_padding8 ptr; + match read_uint8 ptr with + | 1 -> fields.rf_path <- Some(read_field 1 T.Object_path read_object_path ptr) + | 2 -> fields.rf_interface <- read_name_field 2 OBus_name.validate_interface ptr + | 3 -> fields.rf_member <- read_name_field 3 OBus_name.validate_member ptr + | 4 -> fields.rf_error_name <- read_name_field 4 OBus_name.validate_error ptr + | 5 -> fields.rf_reply_serial <- Some(read_field 5 T.Uint32 (read4 get_uint32) ptr) + | 6 -> fields.rf_destination <- read_name_field 6 OBus_name.validate_bus ptr + | 7 -> fields.rf_sender <- read_name_field 7 OBus_name.validate_bus ptr + | 8 -> fields.rf_signature <- read_field 8 T.Signature read_signature ptr + | 9 -> fields.rf_unix_fds <- read_field 9 T.Uint32 (read4 get_uint) ptr + | _ -> ignore (read_variant ptr) (* Unsupported header field *) + done; + + begin + match pending_fds with + | None -> + if fields.rf_unix_fds <> Array.length ptr.fds then + raise (Protocol_error(sprintf + "invalid number of file descriptor, %d expected, %d received" + fields.rf_unix_fds + (Array.length ptr.fds))); + | Some(consumed, queue) -> + ptr.fds <- Array.init fields.rf_unix_fds + (fun i -> + if Queue.is_empty queue then + raise (Protocol_error "file descriptor missing") + else begin + let fd = Queue.take queue in + consumed := fd :: !consumed; + fd + end) + end; + + read_padding8 ptr; + let body = sequence_reader fields.rf_signature ptr in + + if ptr.ofs < ptr.max then raise (Protocol_error "junk bytes after message"); + cont { flags = flags; + sender = fields.rf_sender; + destination = fields.rf_destination; + serial = serial; + typ = message_maker fields; + body = body } + end +end + +module LE_reader = Make_reader(LE_integer_readers) +module BE_reader = Make_reader(BE_integer_readers) + +let read_message ic = + try%lwt + Lwt_io.atomic begin fun ic -> + let buffer = Bytes.create 16 in + let%lwt () = Lwt_io.read_into_exactly ic buffer 0 16 in + let buffer = Bytes.unsafe_to_string buffer in + (match get_char buffer 0 with + | 'l' -> LE_reader.read_message + | 'B' -> BE_reader.read_message + | ch -> raise (Protocol_error(invalid_byte_order ch))) + buffer + (fun length f -> + let length = length - 16 in + let buffer = Bytes.create length in + let%lwt () = Lwt_io.read_into_exactly ic buffer 0 length in + let buffer = Bytes.unsafe_to_string buffer in + f { buf = buffer; ofs = 0; max = length; fds = [||] } None Lwt.return) + end ic + with exn -> + raise (map_exn protocol_error exn) + +let message_of_string buffer fds = + if String.length buffer < 16 then invalid_arg "OBus_wire.message_of_string: buffer too small"; + try + (match get_char buffer 0 with + | 'l' -> LE_reader.read_message + | 'B' -> BE_reader.read_message + | ch -> raise (Protocol_error(invalid_byte_order ch))) + buffer + (fun length f -> + if length <> String.length buffer then raise (Protocol_error "invalid message size"); + f { buf = buffer; ofs = 16; max = length; fds = fds } None (fun x -> x)) + with exn -> + raise (map_exn protocol_error exn) + +type reader = { + r_channel : Lwt_io.input_channel; + r_pending_fds : Unix.file_descr Queue.t; + (* File descriptors received and not yet taken *) +} + +let close_reader reader = + let fds = Queue.fold (fun fds fd -> fd :: fds) [] reader.r_pending_fds in + Queue.clear reader.r_pending_fds; + let%lwt () = + Lwt_list.iter_p + (fun fd -> + try + Lwt_unix.close (Lwt_unix.of_unix_file_descr ~set_flags:false fd) + with Unix.Unix_error(err, _, _) -> + Lwt_log.error_f ~section "cannot close file descriptor: %s" (Unix.error_message err)) + fds + in + Lwt_io.close reader.r_channel + +let reader fd = + let pending_fds = Queue.create () in + { + r_channel = Lwt_io.make ~mode:Lwt_io.input + (fun buf ofs len -> + let%lwt n, fds = Lwt_bytes.recv_msg fd [Lwt_bytes.io_vector buf ofs len] in + List.iter (fun fd -> + (try Unix.set_close_on_exec fd with _ -> ()); + Queue.push fd pending_fds) fds; + Lwt.return n); + r_pending_fds = pending_fds; + } + +let read_message_with_fds reader = + let consumed_fds = ref [] in + try%lwt + Lwt_io.atomic begin fun ic -> + let buffer = Bytes.create 16 in + let%lwt () = Lwt_io.read_into_exactly ic buffer 0 16 in + let buffer = Bytes.unsafe_to_string buffer in + (match get_char buffer 0 with + | 'l' -> LE_reader.read_message + | 'B' -> BE_reader.read_message + | ch -> raise (Protocol_error(invalid_byte_order ch))) + buffer + (fun length f -> + let length = length - 16 in + let buffer = Bytes.create length in + let%lwt () = Lwt_io.read_into_exactly ic buffer 0 length in + let buffer = Bytes.unsafe_to_string buffer in + f { buf = buffer; ofs = 0; max = length; fds = [||] } (Some(consumed_fds, reader.r_pending_fds)) Lwt.return) + end reader.r_channel + with exn -> + let%lwt () = + Lwt_list.iter_p + (fun fd -> + try + Lwt_unix.close (Lwt_unix.of_unix_file_descr ~set_flags:false fd) + with Unix.Unix_error(err, _, _) -> + Lwt_log.error_f ~section "cannot close file descriptor: %s" (Unix.error_message err)) + !consumed_fds + in + Lwt.fail (map_exn protocol_error exn) + +(* +-----------------------------------------------------------------+ + | Size computation | + +-----------------------------------------------------------------+ *) + +let get_message_size buf ofs = + + let unsafe_get_uint map_ofs i = + let v0 = String.unsafe_get buf (map_ofs (i + 0)) + and v1 = String.unsafe_get buf (map_ofs (i + 1)) + and v2 = String.unsafe_get buf (map_ofs (i + 2)) + and v3 = String.unsafe_get buf (map_ofs (i + 3)) in + Char.code v0 lor (Char.code v1 lsl 8) lor (Char.code v2 lsl 16) lor (Char.code v3 lsl 24) + in + + if ofs < 0 || ofs + 16 >= String.length buf then + raise (Invalid_argument "OBus_wire.get_message_size") + + else + (* Byte-order *) + let map_ofs = match String.unsafe_get buf ofs with + | 'l' -> (fun i -> i) + | 'B' -> (fun i -> 3 - i) + | ch -> raise (Protocol_error(invalid_byte_order ch)) + in + let ver = Char.code (String.unsafe_get buf (ofs + 3)) in + if ver <> OBus_info.protocol_version then + raise (Protocol_error(invalid_protocol_version ver)); + + let body_length = unsafe_get_uint map_ofs (ofs + 8) + and fields_length = unsafe_get_uint map_ofs (ofs + 12) in + + let total_length = 16 + fields_length + pad8 fields_length + body_length in + + if fields_length < 0 || fields_length > max_array_size then + raise (Protocol_error(array_too_big fields_length)); + + if body_length < 0 || total_length > max_message_size then + raise (Protocol_error(message_too_big total_length)); + + total_length diff --git a/src/protocol/oBus_wire.mli b/src/protocol/oBus_wire.mli new file mode 100644 index 0000000..f217a49 --- /dev/null +++ b/src/protocol/oBus_wire.mli @@ -0,0 +1,74 @@ +(* + * oBus_lowlevel.mli + * ----------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Message serialization/deserialization *) + +exception Data_error of string + (** Exception raised when a message can not be sent. The parameter is an + error message. + + Possible reasons are: the message is too big or contains arrays + that are too big. *) + +exception Protocol_error of string + (** Exception raised when a received message is not valid. + + Possible reasons are: + + - a size limit is exceeded + - a name/string/object-path is not valid + - a boolean value is other than 0 or 1 + - ... *) + +val read_message : Lwt_io.input_channel -> OBus_message.t Lwt.t + (** [read_message ic] deserializes a message from a channel. It + fails if the message contains file descriptors. *) + +val write_message : Lwt_io.output_channel -> ?byte_order : Lwt_io.byte_order -> OBus_message.t -> unit Lwt.t + (** [write_message oc ?byte_order message] serializes a message to a + channel. It fails if the message contains file descriptors. *) + +val message_of_string : string -> Unix.file_descr array -> OBus_message.t + (** [message_of_string buf fds] returns a message from a + string. [fds] is used to resolv file descriptors the message may + contains. *) + +val string_of_message : ?byte_order : Lwt_io.byte_order -> OBus_message.t -> string * Unix.file_descr array + (** Marshal a message into a string. Returns also the list of file + descriptors that must be sent with the message. *) + +type reader + (** A reader which support unix fd passing *) + +val reader : Lwt_unix.file_descr -> reader + (** [reader unix_socket] creates a reader from a unix socket *) + +val read_message_with_fds : reader -> OBus_message.t Lwt.t + (** Read a message with its file descriptors from the given + reader *) + +val close_reader : reader -> unit Lwt.t + (** [close_reader reader] closes the given reader. + + Note: this does not close the underlying file descriptor. *) + +type writer + (** A writer which support unix fd passing *) + +val writer : Lwt_unix.file_descr -> writer + (** [writer unix_socket] creates a writer from a unix socket *) + +val write_message_with_fds : writer -> ?byte_order : Lwt_io.byte_order -> OBus_message.t -> unit Lwt.t + (** Write a message with its file descriptors on the given writer *) + +val close_writer : writer -> unit Lwt.t + (** [close_writer writer] closes the given writer. + + Note: this does not close the underlying file descriptor. *) + |