pax_global_header00006660000000000000000000000064145673775120014533gustar00rootroot0000000000000052 comment=66c5919e1e7498f10346997d7eb64e140517ea9b obus-1.2.5/000077500000000000000000000000001456737751200125105ustar00rootroot00000000000000obus-1.2.5/.github/000077500000000000000000000000001456737751200140505ustar00rootroot00000000000000obus-1.2.5/.github/CODEOWNERS000066400000000000000000000002361456737751200154440ustar00rootroot00000000000000# These are the default owners for everything in the repo. They will # be requested for review when someone opens a pull request. * @diml @pmetzger @Freyr666 obus-1.2.5/.gitignore000066400000000000000000000000171456737751200144760ustar00rootroot00000000000000_build/ .merlinobus-1.2.5/.travis.yml000066400000000000000000000005031456737751200146170ustar00rootroot00000000000000language: c sudo: required install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh script: bash -ex .travis-opam.sh sudo: required env: matrix: - OCAML_VERSION=4.04 - OCAML_VERSION=4.05 - OCAML_VERSION=4.06 - OCAML_VERSION=4.07 - OCAML_VERSION=4.08 os: - linux obus-1.2.5/CHANGES.md000066400000000000000000000031471456737751200141070ustar00rootroot000000000000001.2.5 (2024-02-27) ------------------ * Add OCaml >= 5.0 support * Upgrade to ppxlib >= 0.26.0 1.2.0 (2019-07-04) ------------------ * opam: add dependency on `menhir`, `ppxlib` * opam: remove dependency on `camlp4`, `lwt_camlp4` * switch to dune build system * replace Camlp4-based parser with the one generated by Menhir * remove all Camlp4 dependencies * replace Camlp4-based syntax module with obus.ppx 1.1.8 (2018-06-02) ------------------ * opam: add dependency on `oasis`, `lwt_react`, `lwt_camlp4`, `lwt_log` * opam: `ocamlfind` is now a build dependency * add support for OCaml 4.06 and `lwt` 3 * bump minimum OCaml version to 4.02.3 * enable travis tests * fix missing signature validation 1.1.7 (2016-07-18) ------------------ * fix compatibility with OCaml 4.03.0 1.1.6 (2014-04-21) ------------------ * support for React 1.0.0 1.1.5 (2012-10-02) ------------------ * compatibility fix for type-conv 1.1.4 (2012-07-30) ------------------ * update oasis files * minor fixes 1.1.3 (2011-07-29) ------------------ * depends on type-conv instead of type-conv.syntax * implements version 0.18 of the specification: * add the `eavesdrop` match keyword 1.1.2 (2011-04-12) ------------------ * implement property monitoring for upower, udisks and network-manager * implement new D-Bus errors (UnknownObject, UnknownInterface, ...) * update and implement new argument filters (argNpath and argNnamespace) 1.1.1 (2011-02-14) ------------------ * Fix a race condition in servers that may causes authentication to hang * Add support for launchd addresses 1.1 (2010-12-13) ---------------- * First stable release obus-1.2.5/LICENSE000066400000000000000000000027561456737751200135270ustar00rootroot00000000000000Copyright (c) 2009, Jeremie Dimino All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Jeremie Dimino nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. obus-1.2.5/README.md000066400000000000000000000050511456737751200137700ustar00rootroot00000000000000OBus ==== [![Build Status](https://travis-ci.com/ocaml-community/obus.svg?branch=master)](https://travis-ci.com/ocaml-community/obus) OBus is a pure OCaml implementation of the D-Bus protocol. It aims to provide a clean and easy way for ocaml programmers to access and provide D-Bus services. OBus is using the cooperative threading library Lwt, which make it very simple to fully exploit the asynchronous nature of D-Bus. Dependencies ------------ Make sure you have [dune](https://dune.build/) installed, and install all the missing dependencies listed in the output of this command: $ dune external-lib-deps @install --missing Installation ------------ The recommended way to install obus and its dependencies is via [opam](https://opam.ocaml.org/): `opam install obus`. Manual installation from sources -------------------------------- To build and install obus: $ dune build @install ### Tests _(optionnal)_ To build and execute tests: $ dune runtest Using the library ----------------- OBus install the following packages: * `obus`: the core library, implementing the D-Bus protocol, * `obus.ppx`: syntax extensions to aid registering OBus exceptions. * `obus.notification`: interface to the freedesktop Notification service, * `obus.hal`: interface to the freedesktop Hal service, * `obus.upower`: interface to the freedesktop UPower service, * `obus.udisks`: interface to the freedesktop UDisks service, * `obus.policykit`: interface to the freedesktop PolicyKit servie. Using the tools --------------- There are several tools provided in the obus distribution: * `obus-dump`, to execute a command and dump all messages that goes throug the session and/or system message bus, * `obus-introspect` which can recursively introspect a D-Bus service, * `obus-gen-interface`, to convert D-Bus introspection files into ocaml definition modules, * `obus-gen-client` and obus-gen-server which can generate template for using or implementing D-Bus servies, * `obus-xml2idl` and obus-idl2xml to convert xml introspection documents to the obus idl format, and vice versa. There are manual pages for all this tools. The caml files generated by obus-gen-client and obus-gen-server are meant to be edited and adapted. In practice introspections files contains only marshaling informations so it is often not sufficient for creating a usable binding. Here is a simple example of use of the tools: $ obus-introspect org.freedesktop.Notifications /org/freedesktop/Notifications > notif.xml $ obus-gen-interface notif.xml $ obus-gen-client notif.xml obus-1.2.5/bindings/000077500000000000000000000000001456737751200143055ustar00rootroot00000000000000obus-1.2.5/bindings/hal/000077500000000000000000000000001456737751200150515ustar00rootroot00000000000000obus-1.2.5/bindings/hal/dune000066400000000000000000000004421456737751200157270ustar00rootroot00000000000000(library (name obus_hal) (public_name obus.hal) (wrapped false) (libraries lwt obus) (preprocess (pps lwt_ppx ppx_obus))) (rule (targets hal_interfaces.ml hal_interfaces.mli) (deps hal_interfaces.obus) (action (run obus-gen-interface -keep-common -o hal_interfaces %{deps}))) obus-1.2.5/bindings/hal/hal_device.ml000066400000000000000000000252031456737751200174700ustar00rootroot00000000000000(* * hal_device.ml * ------------- * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt open OBus_value open Hal_interfaces include OBus_proxy.Private type udi = OBus_path.t let udi = OBus_proxy.path let computer () = let%lwt bus = OBus_bus.system () in return (OBus_proxy.make (OBus_peer.make bus "org.freedesktop.Hal") ["org"; "freedesktop"; "Hal"; "devices"; "computer"]) type property = | Pstring of string | Pstrlist of string list | Pint of int32 | Puint64 of int64 | Pbool of bool | Pdouble of float let property_of_variant = function | V.Basic(V.String s) -> Pstring s | V.Array(T.Basic T.String, _) as l -> Pstrlist(C.cast_single (C.array C.basic_string) l) | V.Basic(V.Int32 x) -> Pint x | V.Basic(V.Uint64 x) -> Puint64 x | V.Basic(V.Boolean x) -> Pbool x | V.Basic(V.Double x) -> Pdouble x | v -> Printf.ksprintf failwith "Hal_device.property_of_variant: invalid device property: %s" (V.string_of_single v) let variant_of_property = function | Pstring s -> V.basic_string s | Pstrlist l -> C.make_single (C.array C.basic_string) l | Pint x -> V.basic_int32 x | Puint64 x -> V.basic_uint64 x | Pbool x -> V.basic_boolean x | Pdouble x -> V.basic_double x open Org_freedesktop_Hal_Device let get_all_properties proxy = let%lwt l = OBus_method.call m_GetAllProperties proxy () in return (List.map (fun (name, value) -> (name, property_of_variant value)) l) let set_multiple_properties proxy properties = OBus_method.call m_SetMultipleProperties proxy (List.map (fun (name, property) -> (name, variant_of_property property)) properties) let get_property proxy key = OBus_method.call m_GetProperty proxy key >|= property_of_variant let get_property_string proxy key = OBus_method.call m_GetPropertyString proxy key let get_property_string_list proxy key = OBus_method.call m_GetPropertyStringList proxy key let get_property_integer proxy key = let%lwt value = OBus_method.call m_GetPropertyInteger proxy key in let value = Int32.to_int value in return value let get_property_boolean proxy key = OBus_method.call m_GetPropertyBoolean proxy key let get_property_double proxy key = OBus_method.call m_GetPropertyDouble proxy key let set_property proxy key value = OBus_method.call m_SetProperty proxy (key, variant_of_property value) let set_property_string proxy key value = OBus_method.call m_SetPropertyString proxy (key, value) let set_property_string_list proxy key value = OBus_method.call m_SetPropertyStringList proxy (key, value) let set_property_integer proxy key value = let value = Int32.of_int value in OBus_method.call m_SetPropertyInteger proxy (key, value) let set_property_boolean proxy key value = OBus_method.call m_SetPropertyBoolean proxy (key, value) let set_property_double proxy key value = OBus_method.call m_SetPropertyDouble proxy (key, value) let remove_property proxy key = OBus_method.call m_RemoveProperty proxy key let get_property_type proxy key = let%lwt typ = OBus_method.call m_GetPropertyType proxy key in let typ = Int32.to_int typ in return typ let property_exists proxy key = OBus_method.call m_PropertyExists proxy key let add_capability proxy capability = OBus_method.call m_AddCapability proxy capability let query_capability proxy capability = OBus_method.call m_QueryCapability proxy capability let lock proxy reason = OBus_method.call m_Lock proxy reason let unlock proxy = OBus_method.call m_Unlock proxy () let acquire_interface_lock proxy interface_name exclusive = OBus_method.call m_AcquireInterfaceLock proxy (interface_name, exclusive) let release_interface_lock proxy interface_name = OBus_method.call m_ReleaseInterfaceLock proxy interface_name let is_caller_locked_out proxy interface_name caller_sysbus_name = OBus_method.call m_IsCallerLockedOut proxy (interface_name, caller_sysbus_name) let is_caller_privileged proxy action caller_sysbus_name = OBus_method.call m_IsCallerPrivileged proxy (action, caller_sysbus_name) let is_locked_by_others proxy interface_name = OBus_method.call m_IsLockedByOthers proxy interface_name let string_list_append proxy key value = OBus_method.call m_StringListAppend proxy (key, value) let string_list_prepend proxy key value = OBus_method.call m_StringListPrepend proxy (key, value) let string_list_remove proxy key value = OBus_method.call m_StringListRemove proxy (key, value) let emit_condition proxy condition_name condition_details = OBus_method.call m_EmitCondition proxy (condition_name, condition_details) let rescan proxy = OBus_method.call m_Rescan proxy () let reprobe proxy = OBus_method.call m_Reprobe proxy () let claim_interface proxy interface_name introspection_xml = OBus_method.call m_ClaimInterface proxy (interface_name, introspection_xml) let addon_is_ready proxy = OBus_method.call m_AddonIsReady proxy () let property_modified proxy = OBus_signal.map (fun (num_updates, updates) -> let num_updates = Int32.to_int num_updates in (num_updates, updates)) (OBus_signal.make s_PropertyModified proxy) let condition proxy = OBus_signal.make s_Condition proxy let interface_lock_acquired proxy = OBus_signal.map (fun (interface_name, lock_holder, num_locks) -> let num_locks = Int32.to_int num_locks in (interface_name, lock_holder, num_locks)) (OBus_signal.make s_InterfaceLockAcquired proxy) let interface_lock_released proxy = OBus_signal.map (fun (interface_name, lock_holder, num_locks) -> let num_locks = Int32.to_int num_locks in (interface_name, lock_holder, num_locks)) (OBus_signal.make s_InterfaceLockReleased proxy) module Volume = struct open Org_freedesktop_Hal_Device_Volume let mount proxy mount_point fstype extra_options = let%lwt return_code = OBus_method.call m_Mount proxy (mount_point, fstype, extra_options) in let return_code = Int32.to_int return_code in return return_code let unmount proxy extra_options = let%lwt return_code = OBus_method.call m_Unmount proxy extra_options in let return_code = Int32.to_int return_code in return return_code let eject proxy extra_options = let%lwt return_code = OBus_method.call m_Eject proxy extra_options in let return_code = Int32.to_int return_code in return return_code end module Storage = struct open Org_freedesktop_Hal_Device_Storage let eject proxy extra_options = let%lwt return_code = OBus_method.call m_Eject proxy extra_options in let return_code = Int32.to_int return_code in return return_code let close_tray proxy extra_options = let%lwt return_code = OBus_method.call m_CloseTray proxy extra_options in let return_code = Int32.to_int return_code in return return_code end module Storage_removable = struct open Org_freedesktop_Hal_Device_Storage_Removable let check_for_media proxy = OBus_method.call m_CheckForMedia proxy () end module Wake_on_lan = struct open Org_freedesktop_Hal_Device_WakeOnLan let get_supported proxy = let%lwt return_code = OBus_method.call m_GetSupported proxy () in let return_code = Int32.to_int return_code in return return_code let get_enabled proxy = let%lwt return_code = OBus_method.call m_GetEnabled proxy () in let return_code = Int32.to_int return_code in return return_code let set_enabled proxy enable = let%lwt return_code = OBus_method.call m_SetEnabled proxy enable in let return_code = Int32.to_int return_code in return return_code end module System_power_management = struct open Org_freedesktop_Hal_Device_SystemPowerManagement let suspend proxy num_seconds_to_sleep = let num_seconds_to_sleep = Int32.of_int num_seconds_to_sleep in let%lwt return_code = OBus_method.call m_Suspend proxy num_seconds_to_sleep in let return_code = Int32.to_int return_code in return return_code let suspend_hybrid proxy num_seconds_to_sleep = let num_seconds_to_sleep = Int32.of_int num_seconds_to_sleep in let%lwt return_code = OBus_method.call m_SuspendHybrid proxy num_seconds_to_sleep in let return_code = Int32.to_int return_code in return return_code let hibernate proxy = let%lwt return_code = OBus_method.call m_Hibernate proxy () in let return_code = Int32.to_int return_code in return return_code let shutdown proxy = let%lwt return_code = OBus_method.call m_Shutdown proxy () in let return_code = Int32.to_int return_code in return return_code let reboot proxy = let%lwt return_code = OBus_method.call m_Reboot proxy () in let return_code = Int32.to_int return_code in return return_code let set_power_save proxy enable_power_save = let%lwt return_code = OBus_method.call m_SetPowerSave proxy enable_power_save in let return_code = Int32.to_int return_code in return return_code end module Cpufreq = struct open Org_freedesktop_Hal_Device_CPUFreq let set_cpufreq_governor proxy governor_string = OBus_method.call m_SetCPUFreqGovernor proxy governor_string let set_cpufreq_performance proxy value = let value = Int32.of_int value in OBus_method.call m_SetCPUFreqPerformance proxy value let set_cpufreq_consider_nice proxy value = OBus_method.call m_SetCPUFreqConsiderNice proxy value let get_cpufreq_governor proxy = OBus_method.call m_GetCPUFreqGovernor proxy () let get_cpufreq_performance proxy = let%lwt return_code = OBus_method.call m_GetCPUFreqPerformance proxy () in let return_code = Int32.to_int return_code in return return_code let get_cpufreq_consider_nice proxy = OBus_method.call m_GetCPUFreqConsiderNice proxy () let get_cpufreq_available_governors proxy = OBus_method.call m_GetCPUFreqAvailableGovernors proxy () end module Laptop_panel = struct open Org_freedesktop_Hal_Device_LaptopPanel let set_brightness proxy brightness_value = let brightness_value = Int32.of_int brightness_value in let%lwt return_code = OBus_method.call m_SetBrightness proxy brightness_value in let return_code = Int32.to_int return_code in return return_code let get_brightness proxy = let%lwt brightness_value = OBus_method.call m_GetBrightness proxy () in let brightness_value = Int32.to_int brightness_value in return brightness_value end module Kill_switch = struct open Org_freedesktop_Hal_Device_KillSwitch let set_power proxy value = let%lwt return_code = OBus_method.call m_SetPower proxy value in let return_code = Int32.to_int return_code in return return_code let get_power proxy = let%lwt value = OBus_method.call m_GetPower proxy () in let value = Int32.to_int value in return value end obus-1.2.5/bindings/hal/hal_device.mli000066400000000000000000000110011456737751200176300ustar00rootroot00000000000000(* * hal_device.mli * -------------- * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Hal devices *) include OBus_proxy.Private type udi = OBus_path.t (** Unique Device Identifier *) val udi : t -> udi (** Return the udi of a device *) val computer : unit -> t Lwt.t (** The computer device *) type property = (** A device property *) | Pstring of string (** An UTF8 string *) | Pstrlist of string list (** List of UTF8 strings *) | Pint of int32 (** 32-bit signed integer *) | Puint64 of int64 (** 64-bit unsigned integer *) | Pbool of bool | Pdouble of float (** IEEE754 double precision floating point number *) val property_of_variant : OBus_value.V.single -> property (** Tries to convert the given variant into a property *) val variant_of_property : property -> OBus_value.V.single (** Converts the gievn property into a D-Bus variant *) (** {6 Common device interface} *) val get_all_properties : t -> (string * property) list Lwt.t val set_multiple_properties : t -> (string * property) list -> unit Lwt.t val get_property : t -> string -> property Lwt.t val get_property_string : t -> string -> string Lwt.t val get_property_string_list : t -> string -> string list Lwt.t val get_property_integer : t -> string -> int Lwt.t val get_property_boolean : t -> string -> bool Lwt.t val get_property_double : t -> string -> float Lwt.t val set_property : t -> string -> property -> unit Lwt.t val set_property_string : t -> string -> string -> unit Lwt.t val set_property_string_list : t -> string -> string list -> unit Lwt.t val set_property_integer : t -> string -> int -> unit Lwt.t val set_property_boolean : t -> string -> bool -> unit Lwt.t val set_property_double : t -> string -> float -> unit Lwt.t val remove_property : t -> string -> unit Lwt.t val get_property_type : t -> string -> int Lwt.t val property_exists : t -> string -> bool Lwt.t val add_capability : t -> string -> unit Lwt.t val query_capability : t -> string -> bool Lwt.t val lock : t -> string -> bool Lwt.t val unlock : t -> bool Lwt.t val acquire_interface_lock : t -> string -> bool -> unit Lwt.t val release_interface_lock : t -> string -> unit Lwt.t val is_caller_locked_out : t -> string -> string -> bool Lwt.t val is_caller_privileged : t -> string -> string -> string Lwt.t val is_locked_by_others : t -> string -> bool Lwt.t val string_list_append : t -> string -> string -> unit Lwt.t val string_list_prepend : t -> string -> string -> unit Lwt.t val string_list_remove : t -> string -> string -> unit Lwt.t val emit_condition : t -> string -> string -> bool Lwt.t val rescan : t -> bool Lwt.t val reprobe : t -> bool Lwt.t val claim_interface : t -> string -> string -> bool Lwt.t val addon_is_ready : t -> bool Lwt.t val property_modified : t -> (int * (string * bool * bool) list) OBus_signal.t val condition : t -> (string * string) OBus_signal.t val interface_lock_acquired : t -> (string * string * int) OBus_signal.t val interface_lock_released : t -> (string * string * int) OBus_signal.t (** {6 Specifics interfaces} *) module Volume : sig val mount : t -> string -> string -> string list -> int Lwt.t val unmount : t -> string list -> int Lwt.t val eject : t -> string list -> int Lwt.t end module Storage : sig val eject : t -> string list -> int Lwt.t val close_tray : t -> string list -> int Lwt.t end module Storage_removable : sig val check_for_media : t -> bool Lwt.t end module Wake_on_lan : sig val get_supported : t -> int Lwt.t val get_enabled : t -> int Lwt.t val set_enabled : t -> bool -> int Lwt.t end module System_power_management : sig val suspend : t -> int -> int Lwt.t val suspend_hybrid : t -> int -> int Lwt.t val hibernate : t -> int Lwt.t val shutdown : t -> int Lwt.t val reboot : t -> int Lwt.t val set_power_save : t -> bool -> int Lwt.t end module Cpufreq : sig val set_cpufreq_governor : t -> string -> unit Lwt.t val set_cpufreq_performance : t -> int -> unit Lwt.t val set_cpufreq_consider_nice : t -> bool -> unit Lwt.t val get_cpufreq_governor : t -> string Lwt.t val get_cpufreq_performance : t -> int Lwt.t val get_cpufreq_consider_nice : t -> bool Lwt.t val get_cpufreq_available_governors : t -> string list Lwt.t end module Laptop_panel : sig val set_brightness : t -> int -> int Lwt.t val get_brightness : t -> int Lwt.t end module Kill_switch : sig val set_power : t -> bool -> int Lwt.t val get_power : t -> int Lwt.t end obus-1.2.5/bindings/hal/hal_interfaces.obus000066400000000000000000000147151456737751200207220ustar00rootroot00000000000000(* * hal_interfaces.obus * ------------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) interface org.freedesktop.Hal.Device { method GetAllProperties : () -> (properties : (string, variant) dict) method SetMultipleProperties : (properties : (string, variant) dict) -> () method GetProperty : (key : string) -> (value : variant) method GetPropertyString : (key : string) -> (value : string) method GetPropertyStringList : (key : string) -> (value : string array) method GetPropertyInteger : (key : string) -> (value : int32) method GetPropertyBoolean : (key : string) -> (value : boolean) method GetPropertyDouble : (key : string) -> (value : double) method SetProperty : (key : string, value : variant) -> () method SetPropertyString : (key : string, value : string) -> () method SetPropertyStringList : (key : string, value : string array) -> () method SetPropertyInteger : (key : string, value : int32) -> () method SetPropertyBoolean : (key : string, value : boolean) -> () method SetPropertyDouble : (key : string, value : double) -> () method RemoveProperty : (key : string) -> () method GetPropertyType : (key : string) -> (type : int32) method PropertyExists : (key : string) -> (does_it_exist : boolean) method AddCapability : (capability : string) -> () method QueryCapability : (capability : string) -> (does_it_have_capability : boolean) method Lock : (reason : string) -> (acquired_lock : boolean) method Unlock : () -> (released_lock : boolean) method AcquireInterfaceLock : (interface_name : string, exclusive : boolean) -> () method ReleaseInterfaceLock : (interface_name : string) -> () method IsCallerLockedOut : (interface_name : string, caller_sysbus_name : string) -> (whether_caller_is_locked_out : boolean) method IsCallerPrivileged : (action : string, caller_sysbus_name : string) -> (result : string) method IsLockedByOthers : (interface_name : string) -> (whether_it_is_locked_by_others : boolean) method StringListAppend : (key : string, value : string) -> () method StringListPrepend : (key : string, value : string) -> () method StringListRemove : (key : string, value : string) -> () method EmitCondition : (condition_name : string, condition_details : string) -> (rc : boolean) method Rescan : () -> (call_had_sideeffect : boolean) method Reprobe : () -> (call_had_sideeffect : boolean) method ClaimInterface : (interface_name : string, introspection_xml : string) -> (rc : boolean) method AddonIsReady : () -> (rc : boolean) signal PropertyModified : (num_updates : int32, updates : (string * boolean * boolean) array) signal Condition : (cond_name : string, cond_details : string) signal InterfaceLockAcquired : (interface_name : string, lock_holder : string, num_locks : int32) signal InterfaceLockReleased : (interface_name : string, lock_holder : string, num_locks : int32) } interface org.freedesktop.Hal.Device.CPUFreq { method SetCPUFreqGovernor : (governor_string : string) -> () method SetCPUFreqPerformance : (value : int32) -> () method SetCPUFreqConsiderNice : (value : boolean) -> () method GetCPUFreqGovernor : () -> (return_code : string) method GetCPUFreqPerformance : () -> (return_code : int32) method GetCPUFreqConsiderNice : () -> (return_code : boolean) method GetCPUFreqAvailableGovernors : () -> (return_code : string array) } interface org.freedesktop.Hal.Device.KillSwitch { method SetPower : (value : boolean) -> (return_code : int32) method GetPower : () -> (value : int32) } interface org.freedesktop.Hal.Device.LaptopPanel { method SetBrightness : (brightness_value : int32) -> (return_code : int32) method GetBrightness : () -> (brightness_value : int32) } interface org.freedesktop.Hal.Device.Leds { method SetBrightness : (brightness_value : int32) -> (return_code : int32) method GetBrightness : () -> (brightness_value : int32) } interface org.freedesktop.Hal.Device.Storage { method Eject : (options : string array) -> (result : int32) method CloseTray : (options : string array) -> (result : int32) } interface org.freedesktop.Hal.Device.Storage.Removable { method CheckForMedia : () -> (call_had_sideeffect : boolean) } interface org.freedesktop.Hal.Device.SystemPowerManagement { method Suspend : (num_seconds_to_sleep : int32) -> (return_code : int32) method SuspendHybrid : (num_seconds_to_sleep : int32) -> (return_code : int32) method Hibernate : () -> (return_code : int32) method Shutdown : () -> (return_code : int32) method Reboot : () -> (return_code : int32) method SetPowerSave : (enable_power_save : boolean) -> (return_code : int32) } interface org.freedesktop.Hal.Device.Volume { method Mount : (mount_point : string, fstype : string, options : string array) -> (result : int32) method Unmount : (options : string array) -> (result : int32) method Eject : (options : string array) -> (result : int32) } interface org.freedesktop.Hal.Device.Volume.Crypto { method Setup : (passphrase : string) -> (result : int32) method Teardown : () -> (result : int32) } interface org.freedesktop.Hal.Device.WakeOnLan { method GetSupported : () -> (return_code : int32) method GetEnabled : () -> (return_code : int32) method SetEnabled : (enable : boolean) -> (return_code : int32) } interface org.freedesktop.Hal.Manager { method GetAllDevices : () -> (devices : string array) method GetAllDevicesWithProperties : () -> (devices_with_props : (string * (string, variant) dict) array) method DeviceExists : (udi : string) -> (does_it_exist : boolean) method FindDeviceStringMatch : (key : string, value : string) -> (devices : string array) method FindDeviceByCapability : (capability : string) -> (devices : string array) method NewDevice : () -> (temporary_udi : string) method Remove : (udi : string) -> () method CommitToGdl : (temporary_udi : string, global_udi : string) -> () method AcquireGlobalInterfaceLock : (interface_name : string, exclusive : boolean) -> () method ReleaseGlobalInterfaceLock : (interface_name : string) -> () method SingletonAddonIsReady : (command_line : string) -> () signal DeviceAdded : (udi : string) signal DeviceRemoved : (udi : string) signal NewCapability : (udi : string, cap_name : string) signal GlobalInterfaceLockAcquired : (interface_name : string, lock_holder : string, num_locks : int32) signal GlobalInterfaceLockReleased : (interface_name : string, lock_holder : string, num_locks : int32) } obus-1.2.5/bindings/hal/hal_manager.ml000066400000000000000000000063641456737751200176520ustar00rootroot00000000000000(* * hal_manager.ml * -------------- * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt open OBus_value include OBus_proxy.Private let manager () = let%lwt bus = OBus_bus.system () in return (OBus_proxy.make (OBus_peer.make bus "org.freedesktop.Hal") [ "org"; "freedesktop"; "Hal"; "Manager" ]) open Hal_interfaces.Org_freedesktop_Hal_Manager let make_device context udi = Hal_device.of_proxy (OBus_proxy.make (OBus_context.sender context) (OBus_path.of_string udi)) let get_all_devices proxy = let%lwt context, l = OBus_method.call_with_context m_GetAllDevices proxy () in return (List.map (make_device context) l) let get_all_devices_with_properties proxy = let%lwt context, l = OBus_method.call_with_context m_GetAllDevicesWithProperties proxy () in return (List.map (fun (udi, properties) -> (make_device context udi, List.map (fun (name, value) -> (name, Hal_device.property_of_variant value)) properties)) l) let device_exists proxy udi = OBus_method.call m_DeviceExists proxy (OBus_path.to_string udi) let find_device_string_match proxy key value = let%lwt context, l = OBus_method.call_with_context m_FindDeviceStringMatch proxy (key, value) in return (List.map (make_device context) l) let find_device_by_capability proxy capability = let%lwt context, l = OBus_method.call_with_context m_FindDeviceByCapability proxy capability in return (List.map (make_device context) l) let new_device proxy = let%lwt context, udi = OBus_method.call_with_context m_NewDevice proxy () in return (make_device context udi) let remove proxy dev = OBus_method.call m_Remove proxy (OBus_path.to_string (Hal_device.udi dev)) let commit_to_gdl proxy temporary_udi global_udi = OBus_method.call m_CommitToGdl proxy (temporary_udi, global_udi) let acquire_global_interface_lock proxy interface_name exclusive = OBus_method.call m_AcquireGlobalInterfaceLock proxy (interface_name, exclusive) let release_global_interface_lock proxy interface_name = OBus_method.call m_ReleaseGlobalInterfaceLock proxy interface_name let singleton_addon_is_ready proxy command_line = OBus_method.call m_SingletonAddonIsReady proxy command_line let device_added proxy = OBus_signal.map_with_context make_device (OBus_signal.make s_DeviceAdded proxy) let device_removed proxy = OBus_signal.map_with_context make_device (OBus_signal.make s_DeviceRemoved proxy) let new_capability proxy = OBus_signal.map_with_context (fun context (udi, cap) -> (make_device context udi, cap)) (OBus_signal.make s_NewCapability proxy) let global_interface_lock_acquired proxy = OBus_signal.map (fun (interface_name, lock_holder, num_locks) -> let num_locks = Int32.to_int num_locks in (interface_name, lock_holder, num_locks)) (OBus_signal.make s_GlobalInterfaceLockAcquired proxy) let global_interface_lock_released proxy = OBus_signal.map (fun (interface_name, lock_holder, num_locks) -> let num_locks = Int32.to_int num_locks in (interface_name, lock_holder, num_locks)) (OBus_signal.make s_GlobalInterfaceLockReleased proxy) obus-1.2.5/bindings/hal/hal_manager.mli000066400000000000000000000024571456737751200200220ustar00rootroot00000000000000(* * hal_manager.mli * --------------- * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** The Hal manager *) include OBus_proxy.Private val manager : unit -> t Lwt.t (** The Hal manager *) val get_all_devices : t -> Hal_device.t list Lwt.t val get_all_devices_with_properties : t -> (Hal_device.t * (string * Hal_device.property) list) list Lwt.t val device_exists : t -> Hal_device.udi -> bool Lwt.t val find_device_string_match : t -> string -> string -> Hal_device.t list Lwt.t val find_device_by_capability : t -> string -> Hal_device.t list Lwt.t val new_device : t -> Hal_device.t Lwt.t val remove : t -> Hal_device.t -> unit Lwt.t val commit_to_gdl : t -> string -> string -> unit Lwt.t val acquire_global_interface_lock : t -> string -> bool -> unit Lwt.t val release_global_interface_lock : t -> string -> unit Lwt.t val singleton_addon_is_ready : t -> string -> unit Lwt.t val device_added : t -> Hal_device.t OBus_signal.t val device_removed : t -> Hal_device.t OBus_signal.t val new_capability : t -> (Hal_device.t * string) OBus_signal.t val global_interface_lock_acquired : t -> (string * string * int) OBus_signal.t val global_interface_lock_released : t -> (string * string * int) OBus_signal.t obus-1.2.5/bindings/network-manager/000077500000000000000000000000001456737751200174065ustar00rootroot00000000000000obus-1.2.5/bindings/network-manager/dune000066400000000000000000000004761456737751200202730ustar00rootroot00000000000000(library (name obus_network_manager) (public_name obus.network_manager) (wrapped false) (libraries lwt lwt_log obus) (preprocess (pps lwt_ppx ppx_obus))) (rule (targets nm_interfaces.ml nm_interfaces.mli) (deps nm_interfaces.obus) (action (run obus-gen-interface -keep-common -o nm_interfaces %{deps}))) obus-1.2.5/bindings/network-manager/nm_access_point.ml000066400000000000000000000045121456737751200231060ustar00rootroot00000000000000(* * nm_access_point.ml * ------------------ * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 *) open Lwt include OBus_proxy.Private open Nm_interfaces.Org_freedesktop_NetworkManager_AccessPoint type ap_flag = [ `Privacy ] let flags proxy = OBus_property.map_r (fun n -> if (Int32.to_int n) land 0x01 <> 0 then [`Privacy] else []) (OBus_property.make ~monitor:Nm_monitor.monitor p_Flags proxy) type ap_security_flag = [ `Pair_wep40 | `Pair_wep104 | `Pair_tkip | `Pair_ccmp | `Group_wep40 | `Group_wep104 | `Group_tkip | `Group_ccmp | `Key_mgmt_psk | `Key_mgmt_802_1x ] let ap_security_flags_of_int32 n = let n = Int32.to_int n in let add l bit_mask flag = if n land bit_mask <> 0 then flag :: l else l in let l = [] in let l = add l 0x001 `Pair_wep40 in let l = add l 0x002 `Pair_wep104 in let l = add l 0x004 `Pair_tkip in let l = add l 0x008 `Pair_ccmp in let l = add l 0x010 `Group_wep40 in let l = add l 0x020 `Group_wep104 in let l = add l 0x040 `Group_tkip in let l = add l 0x080 `Group_ccmp in let l = add l 0x100 `Key_mgmt_psk in let l = add l 0x200 `Key_mgmt_802_1x in l let wpa_flags proxy = OBus_property.map_r ap_security_flags_of_int32 (OBus_property.make ~monitor:Nm_monitor.monitor p_WpaFlags proxy) let rsn_flags proxy = OBus_property.map_r ap_security_flags_of_int32 (OBus_property.make ~monitor:Nm_monitor.monitor p_RsnFlags proxy) let ssid proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Ssid proxy let frequency proxy = OBus_property.map_r Int32.to_int (OBus_property.make ~monitor:Nm_monitor.monitor p_Frequency proxy) let hw_address proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_HwAddress proxy let mode proxy = OBus_property.map_r Int32.to_int (OBus_property.make ~monitor:Nm_monitor.monitor p_Mode proxy) let max_bitrate proxy = OBus_property.map_r Int32.to_int (OBus_property.make ~monitor:Nm_monitor.monitor p_MaxBitrate proxy) let strength proxy = OBus_property.map_r int_of_char (OBus_property.make ~monitor:Nm_monitor.monitor p_Strength proxy) let properties_changed proxy = OBus_signal.make s_PropertiesChanged proxy let properties proxy = OBus_property.group ~monitor:Nm_monitor.monitor proxy interface obus-1.2.5/bindings/network-manager/nm_access_point.mli000066400000000000000000000034301456737751200232550ustar00rootroot00000000000000(* * nm_access_point.mli * ------------------- * Copyright : (c) 2010, Pierre Chambart * 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Access point interface *) include OBus_proxy.Private (** {6 Signals} *) val properties_changed : t -> (string * OBus_value.V.single) list OBus_signal.t (** {6 Properties} *) type ap_flag = [ `Privacy (** Access point supports privacy measures. *) ] val flags : t -> ap_flag list OBus_property.r type ap_security_flag = [ `Pair_wep40 (** Access point supports pairwise 40-bit WEP encryption *) | `Pair_wep104 (** Access point supports pairwise 104-bit WEP encryption *) | `Pair_tkip (** Access point supports pairwise TKIP encryption *) | `Pair_ccmp (** Access point supports pairwise CCMP encryption *) | `Group_wep40 (** Access point supports a group 40-bit WEP cipher *) | `Group_wep104 (** Access point supports a group 104-bit WEP cipher *) | `Group_tkip (** Access point supports a group TKIP cipher *) | `Group_ccmp (** Access point supports a group CCMP cipher *) | `Key_mgmt_psk (** Access point supports PSK key management *) | `Key_mgmt_802_1x (** Access point supports 802.1x key management *) ] val wpa_flags : t -> ap_security_flag list OBus_property.r val rsn_flags : t -> ap_security_flag list OBus_property.r val ssid : t -> string OBus_property.r val frequency : t -> int OBus_property.r val hw_address : t -> string OBus_property.r val mode : t -> int OBus_property.r val max_bitrate : t -> int OBus_property.r val strength : t -> int OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/network-manager/nm_connection.ml000066400000000000000000000035401456737751200225730ustar00rootroot00000000000000(* * nm_connection.ml * ---------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 *) open Lwt let section = Lwt_log.Section.make "network-manager(connection)" include OBus_proxy.Private open Nm_interfaces.Org_freedesktop_NetworkManager_Connection_Active type state = [ `Unknown | `Activating | `Activated ] let service_name proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_ServiceName proxy let connection proxy = OBus_property.map_r_with_context (fun context x -> Nm_settings.Connection.of_proxy (OBus_proxy.make (OBus_context.sender context) x)) (OBus_property.make ~monitor:Nm_monitor.monitor p_Connection proxy) let specific_object proxy = OBus_property.map_r_with_context (fun context x -> OBus_proxy.make (OBus_context.sender context) x) (OBus_property.make ~monitor:Nm_monitor.monitor p_SpecificObject proxy) let devices proxy = OBus_property.map_r_with_context (fun context paths -> List.map (fun path -> Nm_device.of_proxy (OBus_proxy.make (OBus_context.sender context) path)) paths) (OBus_property.make ~monitor:Nm_monitor.monitor p_Devices proxy) let state proxy = OBus_property.map_r (function | 0l -> `Unknown | 1l -> `Activating | 2l -> `Activated | st -> ignore (Lwt_log.warning_f ~section "Nm_connection.state: unknown state: %ld" st); `Unknown) (OBus_property.make ~monitor:Nm_monitor.monitor p_State proxy) let default proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Default proxy let vpn proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Vpn proxy let properties_changed proxy = OBus_signal.make s_PropertiesChanged proxy let properties proxy = OBus_property.group ~monitor:Nm_monitor.monitor proxy interface obus-1.2.5/bindings/network-manager/nm_connection.mli000066400000000000000000000021761456737751200227500ustar00rootroot00000000000000(* * nm_connection.mli * ----------------- * Copyright : (c) 2010, Pierre Chambart * 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** NetworkManager active connections *) (** An active connection is a connection that is currently being used *) include OBus_proxy.Private (** The connection state *) type state = [ `Unknown (** The active connection is in an unknown state. *) | `Activating (** The connection is activating. *) | `Activated (** The connection is activated. *) ] (** {6 Signals} *) val properties_changed : t -> (string * OBus_value.V.single) list OBus_signal.t (** {6 Properties} *) val service_name : t -> string OBus_property.r val connection : t -> Nm_settings.Connection.t OBus_property.r val specific_object : t -> OBus_proxy.t OBus_property.r val devices : t -> Nm_device.t list OBus_property.r val state : t -> state OBus_property.r val default : t -> bool OBus_property.r val vpn : t -> bool OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/network-manager/nm_device.ml000066400000000000000000000245171456737751200217020ustar00rootroot00000000000000(* * nm_device.ml * ------------ * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 *) open Lwt let section = Lwt_log.Section.make "network-manager(device)" include OBus_proxy.Private type state = [ `Unknown | `Unmanaged | `Unavailable | `Disconnected | `Prepare | `Config | `Need_auth | `Ip_config | `Activated | `Failed ] type state_reason = [ `Unknown | `None | `Now_managed | `Now_unmanaged | `Config_failed | `Config_unavailable | `Config_expired | `No_secrets | `Supplicant_disconnect | `Supplicant_config_failed | `Supplicant_failed | `Supplicant_timeout | `Ppp_start_failed | `Ppp_disconnect | `Ppp_failed | `Dhcp_start_failed | `Dhcp_error | `Dhcp_failed | `Shared_start_failed | `Shared_failed | `Autoip_start_failed | `Autoip_error | `Autoip_failed | `Modem_busy | `Modem_no_dial_tone | `Modem_no_carrier | `Modem_dial_timeout | `Modem_dial_failed | `Modem_init_failed | `Gsm_apn_failed | `Gsm_registration_not_searching | `Gsm_registration_denied | `Gsm_registration_timeout | `Gsm_registration_failed | `Gsm_pin_check_failed | `Firmware_missing | `Removed | `Sleeping | `Connection_removed | `User_requested | `Carrier | `Connection_assumed | `Supplicant_available ] type typ = [ `Unknown | `Ethernet | `Wifi | `Gsm | `Cdma ] type capability = [ `Nm_supported | `Carrier_detect ] let state_of_int32 = function | 0l -> `Unknown | 1l -> `Unmanaged | 2l -> `Unavailable | 3l -> `Disconnected | 4l -> `Prepare | 5l -> `Config | 6l -> `Need_auth | 7l -> `Ip_config | 8l -> `Activated | 9l -> `Failed | st -> ignore (Lwt_log.warning_f ~section "Nm_device.state_of_int32: unknown device_state: %ld" st); `Unknown let state_reason_of_int32 = function | 0l -> `Unknown | 1l -> `None | 2l -> `Now_managed | 3l -> `Now_unmanaged | 4l -> `Config_failed | 5l -> `Config_unavailable | 6l -> `Config_expired | 7l -> `No_secrets | 8l -> `Supplicant_disconnect | 9l -> `Supplicant_config_failed | 10l -> `Supplicant_failed | 11l -> `Supplicant_timeout | 12l -> `Ppp_start_failed | 13l -> `Ppp_disconnect | 14l -> `Ppp_failed | 15l -> `Dhcp_start_failed | 16l -> `Dhcp_error | 17l -> `Dhcp_failed | 18l -> `Shared_start_failed | 19l -> `Shared_failed | 20l -> `Autoip_start_failed | 21l -> `Autoip_error | 22l -> `Autoip_failed | 23l -> `Modem_busy | 24l -> `Modem_no_dial_tone | 25l -> `Modem_no_carrier | 26l -> `Modem_dial_timeout | 27l -> `Modem_dial_failed | 28l -> `Modem_init_failed | 29l -> `Gsm_apn_failed | 30l -> `Gsm_registration_not_searching | 31l -> `Gsm_registration_denied | 32l -> `Gsm_registration_timeout | 33l -> `Gsm_registration_failed | 34l -> `Gsm_pin_check_failed | 35l -> `Firmware_missing | 36l -> `Removed | 37l -> `Sleeping | 38l -> `Connection_removed | 39l -> `User_requested | 40l -> `Carrier | 41l -> `Connection_assumed | 42l -> `Supplicant_available | n -> ignore (Lwt_log.warning_f ~section "Nm_device.state_reason_of_int32: unknown state_reason: %ld" n); `Unknown open Nm_interfaces.Org_freedesktop_NetworkManager_Device let udi proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Udi proxy let interface proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Interface proxy let driver proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Driver proxy let capabilities proxy = OBus_property.map_r (fun n -> let n = Int32.to_int n in let l = [] in let l = if n land 0x1 <> 0 then `Nm_supported :: l else l in let l = if n land 0x2 <> 0 then `Carrier_detect :: l else l in l) (OBus_property.make ~monitor:Nm_monitor.monitor p_Capabilities proxy) let ip4_address proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Ip4Address proxy let state proxy = OBus_property.map_r state_of_int32 (OBus_property.make ~monitor:Nm_monitor.monitor p_State proxy) let ip4_config proxy = OBus_property.map_r_with_context (fun context path -> Nm_ip4_config.of_proxy (OBus_proxy.make (OBus_context.sender context) path)) (OBus_property.make ~monitor:Nm_monitor.monitor p_Ip4Config proxy) let dhcp4_config proxy = OBus_property.map_r_with_context (fun context path -> Nm_dhcp4_config.of_proxy (OBus_proxy.make (OBus_context.sender context) path)) (OBus_property.make ~monitor:Nm_monitor.monitor p_Dhcp4Config proxy) let ip6_config proxy = OBus_property.map_r_with_context (fun context path -> Nm_ip6_config.of_proxy (OBus_proxy.make (OBus_context.sender context) path)) (OBus_property.make ~monitor:Nm_monitor.monitor p_Ip6Config proxy) let managed proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Managed proxy let device_type proxy = OBus_property.map_r (function | 0l -> `Unknown | 1l -> `Ethernet | 2l -> `Wifi | 3l -> `Gsm | 4l -> `Cdma | n -> ignore (Lwt_log.warning_f ~section "device_type_of_int: unknown type: %ld" n); `Unknown) (OBus_property.make ~monitor:Nm_monitor.monitor p_DeviceType proxy) let disconnect proxy = OBus_method.call m_Disconnect proxy () let state_changed proxy = OBus_signal.map (fun (new_state, old_state, reason) -> (state_of_int32 new_state, state_of_int32 old_state, state_reason_of_int32 reason)) (OBus_signal.make s_StateChanged proxy) let properties proxy = OBus_property.group ~monitor:Nm_monitor.monitor proxy Nm_interfaces.Org_freedesktop_NetworkManager_Device.interface module Bluetooth = struct open Nm_interfaces.Org_freedesktop_NetworkManager_Device_Bluetooth let hw_address proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_HwAddress proxy let name proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Name proxy let bt_capabilities proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:Nm_monitor.monitor p_BtCapabilities proxy) let properties_changed proxy = OBus_signal.make s_PropertiesChanged proxy let properties proxy = OBus_property.group ~monitor:Nm_monitor.monitor proxy interface end module Cdma = struct open Nm_interfaces.Org_freedesktop_NetworkManager_Device_Cdma let properties_changed proxy = OBus_signal.make s_PropertiesChanged proxy end module Gsm = struct open Nm_interfaces.Org_freedesktop_NetworkManager_Device_Gsm let properties_changed proxy = OBus_signal.make s_PropertiesChanged proxy end module Olpc_mesh = struct open Nm_interfaces.Org_freedesktop_NetworkManager_Device_OlpcMesh let hw_address proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_HwAddress proxy let companion proxy = OBus_property.map_r_with_context (fun context x -> OBus_proxy.make (OBus_context.sender context) x) (OBus_property.make ~monitor:Nm_monitor.monitor p_Companion proxy) let active_channel proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:Nm_monitor.monitor p_ActiveChannel proxy) let properties_changed proxy = OBus_signal.make s_PropertiesChanged proxy let properties proxy = OBus_property.group ~monitor:Nm_monitor.monitor proxy interface end module Serial = struct open Nm_interfaces.Org_freedesktop_NetworkManager_Device_Serial let ppp_stats proxy = OBus_signal.map (fun (in_bytes, out_bytes) -> let in_bytes = Int32.to_int in_bytes in let out_bytes = Int32.to_int out_bytes in (in_bytes, out_bytes)) (OBus_signal.make s_PppStats proxy) end module Wired = struct open Nm_interfaces.Org_freedesktop_NetworkManager_Device_Wired let hw_address proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_HwAddress proxy let speed proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:Nm_monitor.monitor p_Speed proxy) let carrier proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Carrier proxy let properties_changed proxy = OBus_signal.make s_PropertiesChanged proxy let properties proxy = OBus_property.group ~monitor:Nm_monitor.monitor proxy interface end module Wireless = struct open Nm_interfaces.Org_freedesktop_NetworkManager_Device_Wireless type wireless_capability = [ `Cipher_wep40 | `Cipher_wep104 | `Cipher_tkip | `Cipher_ccmp | `Wpa | `Rsn ] type wifi_mode = [ `Unknown | `Adhoc | `Infra ] let get_access_points proxy = let%lwt (context, access_points) = OBus_method.call_with_context m_GetAccessPoints proxy () in return ( List.map (fun path -> Nm_access_point.of_proxy (OBus_proxy.make (OBus_context.sender context) path)) access_points ) let hw_address proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_HwAddress proxy let mode proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:Nm_monitor.monitor p_Mode proxy) let bitrate proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:Nm_monitor.monitor p_Bitrate proxy) let active_access_point proxy = OBus_property.map_r_with_context (fun context x -> OBus_proxy.make (OBus_context.sender context) x) (OBus_property.make ~monitor:Nm_monitor.monitor p_ActiveAccessPoint proxy) let wireless_capabilities proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:Nm_monitor.monitor p_WirelessCapabilities proxy) let properties_changed proxy = OBus_signal.make s_PropertiesChanged proxy let access_point_added proxy = OBus_signal.map_with_context (fun context access_point -> Nm_access_point.of_proxy (OBus_proxy.make (OBus_context.sender context) access_point)) (OBus_signal.make s_AccessPointAdded proxy) let access_point_removed proxy = OBus_signal.map_with_context (fun context access_point -> Nm_access_point.of_proxy (OBus_proxy.make (OBus_context.sender context) access_point)) (OBus_signal.make s_AccessPointRemoved proxy) let properties proxy = OBus_property.group ~monitor:Nm_monitor.monitor proxy interface end obus-1.2.5/bindings/network-manager/nm_device.mli000066400000000000000000000177611456737751200220560ustar00rootroot00000000000000(* * nm_device.mli * ------------- * Copyright : (c) 2010, Pierre Chambart * 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** NetworkManager devices *) include OBus_proxy.Private (** {6 Common interface} *) (** {8 Types} *) type state = [ `Unknown (** The device is in an unknown state. *) | `Unmanaged (** The device is not managed by NetworkManager. *) | `Unavailable (** The device cannot be used (carrier off, rfkill, etc) *) | `Disconnected (** The device is not connected. *) | `Prepare (** The device is preparing to connect. *) | `Config (** The device is being configured. *) | `Need_auth (** The device is awaiting secrets necessary to continue connection. *) | `Ip_config (** The IP settings of the device are being requested and configured. *) | `Activated (** The device is active. *) | `Failed (** The device is in a failure state following an attempt to activate it. *) ] type state_reason = [ `Unknown (** The reason for the device state change is unknown. *) | `None (** The state change is normal. *) | `Now_managed (** The device is now managed. *) | `Now_unmanaged (** The device is no longer managed. *) | `Config_failed (** The device could not be readied for configuration. *) | `Config_unavailable (** IP configuration could not be reserved (no available address, timeout, etc). *) | `Config_expired (** The IP configuration is no longer valid. *) | `No_secrets (** Secrets were required, but not provided. *) | `Supplicant_disconnect (** The 802.1X supplicant disconnected from the access point or authentication server. *) | `Supplicant_config_failed (** Configuration of the 802.1X supplicant failed. *) | `Supplicant_failed (** The 802.1X supplicant quit or failed unexpectedly. *) | `Supplicant_timeout (** The 802.1X supplicant took too long to authenticate. *) | `Ppp_start_failed (** The PPP service failed to start within the allowed time. *) | `Ppp_disconnect (** The PPP service disconnected unexpectedly. *) | `Ppp_failed (** The PPP service quit or failed unexpectedly. *) | `Dhcp_start_failed (** The DHCP service failed to start within the allowed time. *) | `Dhcp_error (** The DHCP service reported an unexpected error. *) | `Dhcp_failed (** The DHCP service quit or failed unexpectedly. *) | `Shared_start_failed (** The shared connection service failed to start. *) | `Shared_failed (** The shared connection service quit or failed unexpectedly. *) | `Autoip_start_failed (** The AutoIP service failed to start. *) | `Autoip_error (** The AutoIP service reported an unexpected error. *) | `Autoip_failed (** The AutoIP service quit or failed unexpectedly. *) | `Modem_busy (** Dialing failed because the line was busy. *) | `Modem_no_dial_tone (** Dialing failed because there was no dial tone. *) | `Modem_no_carrier (** Dialing failed because there was carrier. *) | `Modem_dial_timeout (** Dialing timed out. *) | `Modem_dial_failed (** Dialing failed. *) | `Modem_init_failed (** Modem initialization failed. *) | `Gsm_apn_failed (** Failed to select the specified GSM APN. *) | `Gsm_registration_not_searching (** Not searching for networks. *) | `Gsm_registration_denied (** Network registration was denied. *) | `Gsm_registration_timeout (** Network registration timed out. *) | `Gsm_registration_failed (** Failed to register with the requested GSM network. *) | `Gsm_pin_check_failed (** PIN check failed. *) | `Firmware_missing (** Necessary firmware for the device may be missing. *) | `Removed (** The device was removed. *) | `Sleeping (** NetworkManager went to sleep. *) | `Connection_removed (** The device's active connection was removed or disappeared. *) | `User_requested (** A user or client requested the disconnection. *) | `Carrier (** The device's carrier/link changed. *) | `Connection_assumed (** The device's existing connection was assumed. *) | `Supplicant_available (** The 802.1x supplicant is now available. *) ] type typ = [ `Unknown (** The device type is unknown. *) | `Ethernet (** The device is wired Ethernet device. *) | `Wifi (** The device is an 802.11 WiFi device. *) | `Gsm (** The device is a GSM-based cellular WAN device. *) | `Cdma (** The device is a CDMA/IS-95-based cellular WAN device. *) ] type capability = [ `Nm_supported (** The device is supported by NetworkManager. *) | `Carrier_detect (** The device supports carrier detection. *) ] (** {8 Methods} *) val disconnect : t -> unit Lwt.t (** {8 Signals} *) val state_changed : t -> (state * state * state_reason) OBus_signal.t (** {8 Properties} *) val udi : t -> string OBus_property.r val interface : t -> string OBus_property.r val driver : t -> string OBus_property.r val capabilities : t -> capability list OBus_property.r val ip4_address : t -> int32 OBus_property.r val state : t -> state OBus_property.r val ip4_config : t -> Nm_ip4_config.t OBus_property.r val dhcp4_config : t -> Nm_dhcp4_config.t OBus_property.r val ip6_config : t -> Nm_ip6_config.t OBus_property.r val managed : t -> bool OBus_property.r val device_type : t -> typ OBus_property.r val properties : t -> OBus_property.group (** {6 Specific device interfaces} *) module Bluetooth : sig val properties_changed : t -> (string * OBus_value.V.single) list OBus_signal.t val hw_address : t -> string OBus_property.r val name : t -> string OBus_property.r val bt_capabilities : t -> int OBus_property.r val properties : t -> OBus_property.group end module Cdma : sig val properties_changed : t -> (string * OBus_value.V.single) list OBus_signal.t end module Gsm : sig val properties_changed : t -> (string * OBus_value.V.single) list OBus_signal.t end module Olpc_mesh : sig val properties_changed : t -> (string * OBus_value.V.single) list OBus_signal.t val hw_address : OBus_proxy.t -> (string, [ `readable ]) OBus_property.t val companion : OBus_proxy.t -> (OBus_proxy.t, [ `readable ]) OBus_property.t val active_channel : OBus_proxy.t -> (int, [ `readable ]) OBus_property.t val properties : t -> OBus_property.group end module Serial : sig val ppp_stats : t -> (int * int) OBus_signal.t end module Wired : sig val properties_changed : t -> (string * OBus_value.V.single) list OBus_signal.t val hw_address : t -> string OBus_property.r val speed : t -> int OBus_property.r val carrier : t -> bool OBus_property.r val properties : t -> OBus_property.group end module Wireless : sig type wireless_capability = [ `Cipher_wep40 (** The device supports the 40-bit WEP cipher. *) | `Cipher_wep104 (** The device supports the 104-bit WEP cipher. *) | `Cipher_tkip (** The device supports the TKIP cipher. *) | `Cipher_ccmp (** The device supports the CCMP cipher. *) | `Wpa (** The device supports the WPA encryption/authentication protocol. *) | `Rsn (** The device supports the RSN encryption/authentication protocol. *) ] type wifi_mode = [ `Unknown (** Mode is unknown. *) | `Adhoc (** Uncoordinated network without central infrastructure. *) | `Infra (** Coordinated network with one or more central controllers. *) ] val get_access_points : t -> Nm_access_point.t list Lwt.t val properties_changed : t -> (string * OBus_value.V.single) list OBus_signal.t val access_point_added : t -> Nm_access_point.t OBus_signal.t val access_point_removed : t -> Nm_access_point.t OBus_signal.t val hw_address : t -> string OBus_property.r val mode : t -> int OBus_property.r val bitrate : t -> int OBus_property.r val active_access_point : t -> OBus_proxy.t OBus_property.r val wireless_capabilities : t -> int OBus_property.r val properties : t -> OBus_property.group end obus-1.2.5/bindings/network-manager/nm_dhcp4_config.ml000066400000000000000000000006021456737751200227570ustar00rootroot00000000000000(* * nm_dhcp4_config.ml * ------------------ * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 *) include OBus_proxy.Private open Nm_interfaces.Org_freedesktop_NetworkManager_DHCP4Config let options proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Options proxy let properties_changed proxy = OBus_signal.make s_PropertiesChanged proxy obus-1.2.5/bindings/network-manager/nm_dhcp4_config.mli000066400000000000000000000006331456737751200231340ustar00rootroot00000000000000(* * nm_dhcp4_config.mli * ------------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** DHCP4 configuration *) include OBus_proxy.Private val options : t -> (string * OBus_value.V.single) list OBus_property.r val properties_changed : t -> (string * OBus_value.V.single) list OBus_signal.t obus-1.2.5/bindings/network-manager/nm_interfaces.obus000066400000000000000000000151511456737751200231200ustar00rootroot00000000000000(* * nm_interfaces.obus * ------------------ * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) interface org.freedesktop.NetworkManager { method GetDevices : () -> (devices : object_path array) method ActivateConnection : (service_name : string, connection : object_path, device : object_path, specific_object : object_path) -> (active_connection : object_path) method DeactivateConnection : (active_connection : object_path) -> () method Sleep : (sleep : boolean) -> () property_rw WirelessEnabled : boolean property_r WirelessHardwareEnabled : boolean property_rw WwanEnabled : boolean property_r WwanHardwareEnabled : boolean property_r ActiveConnections : object_path array property_r State : uint32 signal StateChanged : (state : uint32) signal PropertiesChanged : (properties : (string, variant) dict) signal DeviceAdded : (state : object_path) signal DeviceRemoved : (state : object_path) } interface org.freedesktop.NetworkManager.AccessPoint { property_r Flags : uint32 property_r WpaFlags : uint32 property_r RsnFlags : uint32 property_r Ssid : byte array property_r Frequency : uint32 property_r HwAddress : string property_r Mode : uint32 property_r MaxBitrate : uint32 property_r Strength : byte signal PropertiesChanged : (properties : (string, variant) dict) } interface org.freedesktop.NetworkManager.Connection.Active { property_r ServiceName : string property_r Connection : object_path property_r SpecificObject : object_path property_r Devices : object_path array property_r State : uint32 property_r Default : boolean property_r Vpn : boolean signal PropertiesChanged : (properties : (string, variant) dict) } interface org.freedesktop.NetworkManager.DHCP4Config { property_r Options : (string, variant) dict signal PropertiesChanged : (properties : (string, variant) dict) } interface org.freedesktop.NetworkManager.Device { property_r Udi : string property_r Interface : string property_r Driver : string property_r Capabilities : uint32 property_r Ip4Address : uint32 property_r State : uint32 property_r Ip4Config : object_path property_r Dhcp4Config : object_path property_r Ip6Config : object_path property_r Managed : boolean property_r DeviceType : uint32 method Disconnect : () -> () signal StateChanged : (new_state : uint32, old_state : uint32, reason : uint32) } interface org.freedesktop.NetworkManager.Device.Bluetooth { property_r HwAddress : string property_r Name : string property_r BtCapabilities : uint32 signal PropertiesChanged : (properties : (string, variant) dict) } interface org.freedesktop.NetworkManager.Device.Cdma { signal PropertiesChanged : (properties : (string, variant) dict) } interface org.freedesktop.NetworkManager.Device.Gsm { signal PropertiesChanged : (properties : (string, variant) dict) } interface org.freedesktop.NetworkManager.Device.OlpcMesh { property_r HwAddress : string property_r Companion : object_path property_r ActiveChannel : uint32 signal PropertiesChanged : (properties : (string, variant) dict) } interface org.freedesktop.NetworkManager.Device.Serial { signal PppStats : (in_bytes : uint32, out_bytes : uint32) } interface org.freedesktop.NetworkManager.Device.Wired { property_r HwAddress : string property_r Speed : uint32 property_r Carrier : boolean signal PropertiesChanged : (properties : (string, variant) dict) } interface org.freedesktop.NetworkManager.Device.Wireless { method GetAccessPoints : () -> (access_points : object_path array) property_r HwAddress : string property_r Mode : uint32 property_r Bitrate : uint32 property_r ActiveAccessPoint : object_path property_r WirelessCapabilities : uint32 signal PropertiesChanged : (properties : (string, variant) dict) signal AccessPointAdded : (access_point : object_path) signal AccessPointRemoved : (access_point : object_path) } interface org.freedesktop.NetworkManager.IP4Config { property_r Addresses : (uint32 array) array property_r Nameservers : uint32 array property_r WinsServers : uint32 array property_r Domains : string array property_r Routes : (uint32 array) array } interface org.freedesktop.NetworkManager.IP6Config { property_r Addresses : (byte array * uint32) array property_r Nameservers : (byte array) array property_r Domains : string array property_r Routes : (byte array * uint32 * byte array * uint32) array } interface org.freedesktop.NetworkManager.PPP { method NeedSecrets : () -> (username : string, password : string) method SetIp4Config : (config : (string, variant) dict) -> () method SetState : (state : uint32) -> () } interface org.freedesktop.NetworkManager.VPN.Connection { signal PropertiesChanged : (properties : (string, variant) dict) property_r VpnState : uint32 property_r Banner : string signal VpnStateChanged : (state : uint32, reason : uint32) } interface org.freedesktop.NetworkManager.VPN.Plugin { method Connect : (connection : (string, (string, variant) dict) dict) -> () method NeedSecrets : (settings : (string, (string, variant) dict) dict) -> (setting_name : string) method Disconnect : () -> () method SetIp4Config : (config : (string, variant) dict) -> () method SetFailure : (reason : string) -> () property_r State : uint32 signal StateChanged : (state : uint32) signal Ip4Config : (ip4config : (string, variant) dict) signal LoginBanner : (banner : string) signal Failure : (reason : uint32) } interface org.freedesktop.NetworkManagerSettings { method ListConnections : () -> (connections : object_path array) method AddConnection : (connection : (string, (string, variant) dict) dict) -> () signal NewConnection : (connection : object_path) } interface org.freedesktop.NetworkManagerSettings.Connection { method Update : (properties : (string, (string, variant) dict) dict) -> () method Delete : () -> () method GetSettings : () -> (settings : (string, (string, variant) dict) dict) signal Updated : (settings : (string, (string, variant) dict) dict) signal Removed : () } interface org.freedesktop.NetworkManagerSettings.Connection.Secrets { method GetSecrets : (setting_name : string, hints : string array, request_new : boolean) -> (secrets : (string, (string, variant) dict) dict) } interface org.freedesktop.NetworkManagerSettings.System { method SaveHostname : (hostname : string) -> () property_r Hostname : string property_r CanModify : boolean signal PropertiesChanged : (properties : (string, variant) dict) signal CheckPermissions : () method GetPermissions : () -> (permissions : uint32) } obus-1.2.5/bindings/network-manager/nm_ip4_config.ml000066400000000000000000000020161456737751200224520ustar00rootroot00000000000000(* * nm_ip4_config.ml * ---------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 *) include OBus_proxy.Private open Nm_interfaces.Org_freedesktop_NetworkManager_IP4Config let addresses proxy = OBus_property.map_r (fun x -> List.map (List.map Int32.to_int) x) (OBus_property.make ~monitor:Nm_monitor.monitor p_Addresses proxy) let nameservers proxy = OBus_property.map_r (fun x -> List.map Int32.to_int x) (OBus_property.make ~monitor:Nm_monitor.monitor p_Nameservers proxy) let wins_servers proxy = OBus_property.map_r (fun x -> List.map Int32.to_int x) (OBus_property.make ~monitor:Nm_monitor.monitor p_WinsServers proxy) let domains proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Domains proxy let routes proxy = OBus_property.map_r (fun x -> List.map (List.map Int32.to_int) x) (OBus_property.make ~monitor:Nm_monitor.monitor p_Routes proxy) let properties proxy = OBus_property.group ~monitor:Nm_monitor.monitor proxy interface obus-1.2.5/bindings/network-manager/nm_ip4_config.mli000066400000000000000000000010341456737751200226220ustar00rootroot00000000000000(* * nm_ip4_config.mli * ----------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Ip4 configuration *) include OBus_proxy.Private val addresses : t -> int list list OBus_property.r val nameservers : t -> int list OBus_property.r val wins_servers : t -> int list OBus_property.r val domains : t -> string list OBus_property.r val routes : t -> int list list OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/network-manager/nm_ip6_config.ml000066400000000000000000000015521456737751200224600ustar00rootroot00000000000000(* * nm_ip6_config.ml * ---------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 *) include OBus_proxy.Private open Nm_interfaces.Org_freedesktop_NetworkManager_IP6Config let addresses proxy = OBus_property.map_r (fun x -> List.map (fun (x1, x2) -> (x1, Int32.to_int x2)) x) (OBus_property.make ~monitor:Nm_monitor.monitor p_Addresses proxy) let nameservers proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Nameservers proxy let domains proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Domains proxy let routes proxy = OBus_property.map_r (fun x -> List.map (fun (x1, x2, x3, x4) -> (x1, Int32.to_int x2, x3, Int32.to_int x4)) x) (OBus_property.make ~monitor:Nm_monitor.monitor p_Routes proxy) let properties proxy = OBus_property.group ~monitor:Nm_monitor.monitor proxy interface obus-1.2.5/bindings/network-manager/nm_ip6_config.mli000066400000000000000000000010111456737751200226170ustar00rootroot00000000000000(* * nm_ip6_config.mli * ----------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Ip6 configuration *) include OBus_proxy.Private val addresses : t -> (string * int) list OBus_property.r val nameservers : t -> string list OBus_property.r val domains : t -> string list OBus_property.r val routes : t -> (string * int * string * int) list OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/network-manager/nm_manager.ml000066400000000000000000000101631456737751200220450ustar00rootroot00000000000000(* * nm_manager.ml * ------------- * Copyright : (c) 2010, Pierre Chambart * 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt let section = Lwt_log.Section.make "network-manager" include OBus_peer.Private let daemon () = let%lwt bus = OBus_bus.system () in Lwt.return (OBus_peer.make bus "org.freedesktop.NetworkManager") (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) type state = [ `Unknown | `Asleep | `Connecting | `Connected | `Disconnected ] let state_of_int32 = function | 0l -> `Unknown | 1l -> `Asleep | 2l -> `Connecting | 3l -> `Connected | 4l -> `Disconnected | i -> ignore (Lwt_log.warning_f ~section "Nm_manager.state_of_int32: unknown state: %ld" i); `Unknown (* +-----------------------------------------------------------------+ | D-Bus definitions | +-----------------------------------------------------------------+ *) let proxy daemon = OBus_proxy.make daemon ["org"; "freedesktop"; "NetworkManager"] open Nm_interfaces.Org_freedesktop_NetworkManager let get_devices daemon = let%lwt (context, devices) = OBus_method.call_with_context m_GetDevices (proxy daemon) () in return ( List.map (fun path -> Nm_device.of_proxy (OBus_proxy.make (OBus_context.sender context) path)) devices ) let activate_connection daemon ~service_name ~connection ~device ~specific_object = let connection = OBus_proxy.path (Nm_settings.Connection.to_proxy connection) in let device = OBus_proxy.path (Nm_device.to_proxy device) in let specific_object = OBus_proxy.path specific_object in let%lwt (context, active_connection) = OBus_method.call_with_context m_ActivateConnection (proxy daemon) (service_name, connection, device, specific_object) in return ( Nm_connection.of_proxy (OBus_proxy.make (OBus_context.sender context) active_connection) ) let deactivate_connection daemon ~active_connection = let active_connection = OBus_proxy.path (Nm_connection.to_proxy active_connection) in OBus_method.call m_DeactivateConnection (proxy daemon) active_connection let sleep daemon ~sleep = OBus_method.call m_Sleep (proxy daemon) sleep let wireless_enabled daemon = OBus_property.make ~monitor:Nm_monitor.monitor p_WirelessEnabled (proxy daemon) let wireless_hardware_enabled daemon = OBus_property.make ~monitor:Nm_monitor.monitor p_WirelessHardwareEnabled (proxy daemon) let wwan_enabled daemon = OBus_property.make ~monitor:Nm_monitor.monitor p_WwanEnabled (proxy daemon) let wwan_hardware_enabled daemon = OBus_property.make ~monitor:Nm_monitor.monitor p_WwanHardwareEnabled (proxy daemon) let active_connections daemon = OBus_property.map_r_with_context (fun context paths -> List.map (fun path -> Nm_connection.of_proxy (OBus_proxy.make (OBus_context.sender context) path)) paths) (OBus_property.make ~monitor:Nm_monitor.monitor p_ActiveConnections (proxy daemon)) let state daemon = OBus_property.map_r state_of_int32 (OBus_property.make ~monitor:Nm_monitor.monitor p_State (proxy daemon)) let state_changed daemon = OBus_signal.map state_of_int32 (OBus_signal.make s_StateChanged (proxy daemon)) let properties_changed daemon = OBus_signal.make s_PropertiesChanged (proxy daemon) let device_added daemon = OBus_signal.map_with_context (fun context state -> Nm_device.of_proxy (OBus_proxy.make (OBus_context.sender context) state)) (OBus_signal.make s_DeviceAdded (proxy daemon)) let device_removed daemon = OBus_signal.map_with_context (fun context state -> Nm_device.of_proxy (OBus_proxy.make (OBus_context.sender context) state)) (OBus_signal.make s_DeviceRemoved (proxy daemon)) let properties daemon = OBus_property.group ~monitor:Nm_monitor.monitor (proxy daemon) interface obus-1.2.5/bindings/network-manager/nm_manager.mli000066400000000000000000000035701456737751200222220ustar00rootroot00000000000000(* * nm_manager.mli * -------------- * Copyright : (c) 2010, Pierre Chambart * 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** NetworkManager main interface *) include OBus_peer.Private val daemon : unit -> t Lwt.t (** [daemon ()] returns the peer object for the network manager daemon *) (** {6 Types} *) (** State of the daemon *) type state = [ `Unknown (** The NetworkManager daemon is in an unknown state. *) | `Asleep (** The NetworkManager daemon is asleep and all interfaces managed by it are inactive. *) | `Connecting (** The NetworkManager daemon is connecting a device. *) | `Connected (** The NetworkManager daemon is connected. *) | `Disconnected (** The NetworkManager daemon is disconnected. *) ] (** {6 Methods} *) val get_devices : t -> Nm_device.t list Lwt.t val activate_connection : t -> service_name : OBus_name.bus -> connection : Nm_settings.Connection.t -> device : Nm_device.t -> specific_object : OBus_proxy.t -> Nm_connection.t Lwt.t val deactivate_connection : t -> active_connection : Nm_connection.t -> unit Lwt.t val sleep : t -> sleep : bool -> unit Lwt.t (** {6 Signals} *) val state_changed : t -> state OBus_signal.t val properties_changed : t -> (string * OBus_value.V.single) list OBus_signal.t val device_added : t -> Nm_device.t OBus_signal.t val device_removed : t -> Nm_device.t OBus_signal.t (** {6 Properties} *) val wireless_enabled : t -> bool OBus_property.rw val wireless_hardware_enabled : t -> bool OBus_property.r val wwan_enabled : t -> bool OBus_property.rw val wwan_hardware_enabled : t -> bool OBus_property.r val active_connections : t -> Nm_connection.t list OBus_property.r val state : t -> state OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/network-manager/nm_monitor.ml000066400000000000000000000016701456737751200221250ustar00rootroot00000000000000(* * nm_monitor.ml * ------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt_react open Lwt open OBus_value module String_map = Map.Make(String) let properties_changed interface = OBus_member.Signal.make ~interface ~member:"PropertiesChanged" ~args:(arg1 (Some "properties", C.dict C.string C.variant)) ~annotations:[] let monitor proxy interface switch = let%lwt event = OBus_signal.connect ~switch (OBus_signal.with_context (OBus_signal.make (properties_changed interface) proxy)) and context, dict = OBus_property.get_all_no_cache proxy interface in return (S.fold_s ~eq:(String_map.equal (=)) (fun map (context, updates) -> return (OBus_property.update_map context updates map)) (OBus_property.map_of_list context dict) event) obus-1.2.5/bindings/network-manager/nm_monitor.mli000066400000000000000000000005031456737751200222700ustar00rootroot00000000000000(* * nm_monitor.mli * -------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Properties monitoring *) val monitor : OBus_property.monitor (** Monitor for properties of Network Manager interfaces. *) obus-1.2.5/bindings/network-manager/nm_ppp.ml000066400000000000000000000007101456737751200212270ustar00rootroot00000000000000(* * nm_ppp.ml * --------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 *) include OBus_proxy.Private open Nm_interfaces.Org_freedesktop_NetworkManager_PPP let need_secrets proxy = OBus_method.call m_NeedSecrets proxy () let set_ip4_config proxy ~config = OBus_method.call m_SetIp4Config proxy config let set_state proxy ~state = let state = Int32.of_int state in OBus_method.call m_SetState proxy state obus-1.2.5/bindings/network-manager/nm_ppp.mli000066400000000000000000000006261456737751200214060ustar00rootroot00000000000000(* * nm_ppp.mli * ---------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** PPP *) include OBus_proxy.Private val need_secrets : t -> (string * string) Lwt.t val set_ip4_config : t -> config : (string * OBus_value.V.single) list -> unit Lwt.t val set_state : t -> state : int -> unit Lwt.t obus-1.2.5/bindings/network-manager/nm_settings.ml000066400000000000000000000052111456737751200222710ustar00rootroot00000000000000(* * nm_settings.ml * -------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 *) open Lwt include OBus_proxy.Private open Nm_interfaces.Org_freedesktop_NetworkManagerSettings let user () = let%lwt bus = OBus_bus.session () in return (OBus_proxy.make (OBus_peer.make bus "org.freedesktop.NetworkManagerUserSettings") [ "org"; "freedesktop"; "NetworkManagerSettings" ]) let system () = let%lwt bus = OBus_bus.system () in return (OBus_proxy.make (OBus_peer.make bus "org.freedesktop.NetworkManagerSystemSettings") [ "org"; "freedesktop"; "NetworkManagerSettings" ]) module Connection = struct include OBus_proxy.Private open Nm_interfaces.Org_freedesktop_NetworkManagerSettings_Connection let update proxy ~properties = OBus_method.call m_Update proxy properties let delete proxy = OBus_method.call m_Delete proxy () let get_settings proxy = OBus_method.call m_GetSettings proxy () let updated proxy = OBus_signal.make s_Updated proxy let removed proxy = OBus_signal.make s_Removed proxy module Secrets = struct open Nm_interfaces.Org_freedesktop_NetworkManagerSettings_Connection_Secrets let get_secrets proxy ~setting_name ~hints ~request_new = OBus_method.call m_GetSecrets proxy (setting_name, hints, request_new) end end module System = struct open Nm_interfaces.Org_freedesktop_NetworkManagerSettings_System let save_hostname proxy ~hostname = OBus_method.call m_SaveHostname proxy hostname let hostname proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Hostname proxy let can_modify proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_CanModify proxy let properties_changed proxy = OBus_signal.make s_PropertiesChanged proxy let check_permissions proxy = OBus_signal.make s_CheckPermissions proxy let get_permissions proxy = let%lwt permissions = OBus_method.call m_GetPermissions proxy () in let permissions = Int32.to_int permissions in return permissions end let list_connections proxy = let%lwt (context, connections) = OBus_method.call_with_context m_ListConnections proxy () in return ( List.map (fun path -> Connection.of_proxy (OBus_proxy.make (OBus_context.sender context) path)) connections ) let add_connection proxy ~connection = OBus_method.call m_AddConnection proxy connection let new_connection proxy = OBus_signal.map_with_context (fun context connection -> Connection.of_proxy (OBus_proxy.make (OBus_context.sender context) connection)) (OBus_signal.make s_NewConnection proxy) obus-1.2.5/bindings/network-manager/nm_settings.mli000066400000000000000000000035241456737751200224470ustar00rootroot00000000000000(* * nm_settings.mli * --------------- * Copyright : (c) 2010, Pierre Chambart * 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** NetworkManager settings *) include OBus_proxy.Private val user : unit -> t Lwt.t (** [user ()] returns the proxy object for user settings. The object is on the session message bus. *) val system : unit -> t Lwt.t (** [system ()] returns the proxy object for system settings. The object is on the system message bus *) (** Connection settings *) module Connection : sig include OBus_proxy.Private (** {6 Methods} *) val update : t -> properties : (string * (string * OBus_value.V.single) list) list -> unit Lwt.t val delete : t -> unit Lwt.t val get_settings : t -> (string * (string * OBus_value.V.single) list) list Lwt.t (** {6 Signals} *) val updated : t -> (string * (string * OBus_value.V.single) list) list OBus_signal.t val removed : t -> unit OBus_signal.t module Secrets : sig val get_secrets : t -> setting_name : string -> hints : string list -> request_new : bool -> (string * (string * OBus_value.V.single) list) list Lwt.t end end (** System settings *) module System : sig val save_hostname : t -> hostname : string -> unit Lwt.t val hostname : t -> string OBus_property.r val can_modify : t -> bool OBus_property.r val properties_changed : t -> (string * OBus_value.V.single) list OBus_signal.t val check_permissions : t -> unit OBus_signal.t val get_permissions : t -> int Lwt.t end (** {6 Methods} *) val list_connections : t -> Connection.t list Lwt.t (** {6 Signals} *) val add_connection : t -> connection : (string * (string * OBus_value.V.single) list) list -> unit Lwt.t val new_connection : t -> Connection.t OBus_signal.t obus-1.2.5/bindings/network-manager/nm_vpn_connection.ml000066400000000000000000000015321456737751200234550ustar00rootroot00000000000000(* * nm_vpn_connection.ml * -------------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 *) include OBus_proxy.Private open Nm_interfaces.Org_freedesktop_NetworkManager_VPN_Connection let properties_changed proxy = OBus_signal.make s_PropertiesChanged proxy let vpn_state proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:Nm_monitor.monitor p_VpnState proxy) let banner proxy = OBus_property.make ~monitor:Nm_monitor.monitor p_Banner proxy let vpn_state_changed proxy = OBus_signal.map (fun (state, reason) -> let state = Int32.to_int state in let reason = Int32.to_int reason in (state, reason)) (OBus_signal.make s_VpnStateChanged proxy) let properties proxy = OBus_property.group ~monitor:Nm_monitor.monitor proxy interface obus-1.2.5/bindings/network-manager/nm_vpn_connection.mli000066400000000000000000000010111456737751200236160ustar00rootroot00000000000000(* * nm_vpn_connection.mli * --------------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** VPN connections *) include OBus_proxy.Private val vpn_state_changed : t -> (int * int) OBus_signal.t val properties_changed : t -> (string * OBus_value.V.single) list OBus_signal.t val vpn_state : t -> int OBus_property.r val banner : t -> string OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/network-manager/nm_vpn_plugin.ml000066400000000000000000000022441456737751200226150ustar00rootroot00000000000000(* * nm_vpn_plugin.ml * ---------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 *) include OBus_proxy.Private open Nm_interfaces.Org_freedesktop_NetworkManager_VPN_Plugin let connect proxy ~connection = OBus_method.call m_Connect proxy connection let need_secrets proxy ~settings = OBus_method.call m_NeedSecrets proxy settings let disconnect proxy = OBus_method.call m_Disconnect proxy () let set_ip4_config proxy ~config = OBus_method.call m_SetIp4Config proxy config let set_failure proxy ~reason = OBus_method.call m_SetFailure proxy reason let state proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:Nm_monitor.monitor p_State proxy) let state_changed proxy = OBus_signal.map (fun state -> let state = Int32.to_int state in state) (OBus_signal.make s_StateChanged proxy) let ip4_config proxy = OBus_signal.make s_Ip4Config proxy let login_banner proxy = OBus_signal.make s_LoginBanner proxy let failure proxy = OBus_signal.map (fun reason -> let reason = Int32.to_int reason in reason) (OBus_signal.make s_Failure proxy) obus-1.2.5/bindings/network-manager/nm_vpn_plugin.mli000066400000000000000000000015411456737751200227650ustar00rootroot00000000000000(* * nm_vpn_plugin.mli * ----------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** VPN plugin interface *) include OBus_proxy.Private val connect : t -> connection : (string * (string * OBus_value.V.single) list) list -> unit Lwt.t val need_secrets : t -> settings : (string * (string * OBus_value.V.single) list) list -> string Lwt.t val disconnect : t -> unit Lwt.t val set_ip4_config : t -> config : (string * OBus_value.V.single) list -> unit Lwt.t val set_failure : t -> reason : string -> unit Lwt.t val state_changed : t -> int OBus_signal.t val ip4_config : t -> (string * OBus_value.V.single) list OBus_signal.t val login_banner : t -> string OBus_signal.t val failure : t -> int OBus_signal.t val state : t -> int OBus_property.r obus-1.2.5/bindings/notification/000077500000000000000000000000001456737751200167735ustar00rootroot00000000000000obus-1.2.5/bindings/notification/dune000066400000000000000000000005301456737751200176470ustar00rootroot00000000000000(library (name obus_notification) (public_name obus.notification) (wrapped false) (libraries lwt obus) (preprocess (pps lwt_ppx ppx_obus))) (rule (targets notification_interfaces.ml notification_interfaces.mli) (deps notification_interfaces.obus) (action (run obus-gen-interface -keep-common -o notification_interfaces %{deps}))) obus-1.2.5/bindings/notification/notification.ml000066400000000000000000000244211456737751200220160ustar00rootroot00000000000000(* * notification.ml * --------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt_react open Lwt open OBus_value let app_name = ref (Filename.basename Sys.argv.(0)) let desktop_entry = ref None (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) type server_info = { server_name : string; server_vendor : string; server_version : string; server_spec_version : string; } type image = { img_width : int; img_height : int; img_rowstride : int; img_has_alpha : bool; img_bits_per_sample : int; img_channels : int; img_data : string; } type urgency = [ `Low | `Normal | `Critical ] type id = int32 (* An notification id *) (* All informations about an opened notification *) type notification = { mutable notif_deleted : bool; (* Wether the notification as already been closed *) notif_action : string -> unit; (* Wakeup the waiting thread when an action is received *) notif_closed : unit -> unit; (* Wakeup the waiting thread with [`Closed] when a notification is closed *) } type 'a t = { result : 'a Lwt.t; notification : notification; peer : OBus_peer.t; id : id; } module Peer_map = Map.Make(OBus_peer) module Id_map = Map.Make(Int32) let notifications : notification Id_map.t ref Peer_map.t ref = ref Peer_map.empty (* All opened notifications, by peer then id *) let default_action = "default" (* Default action for notifications *) (* +-----------------------------------------------------------------+ | D-Bus methods and signals | +-----------------------------------------------------------------+ *) let server_name = "org.freedesktop.Notifications" let server_path = ["org"; "freedesktop"; "Notifications"] open Notification_interfaces.Org_freedesktop_Notifications let proxy = lazy( let%lwt bus = OBus_bus.session () in return (OBus_proxy.make (OBus_peer.make bus server_name) server_path) ) let get_server_information () = let%lwt proxy = Lazy.force proxy in let%lwt name, vendor, version, spec_version = OBus_method.call m_GetServerInformation proxy () in return { server_name = name; server_vendor = vendor; server_version = version; server_spec_version = spec_version; } let get_capabilities () = let%lwt proxy = Lazy.force proxy in OBus_method.call m_GetCapabilities proxy () let notify proxy ~app_name ~id ~icon ~summary ~body ~actions ~hints ~timeout = let%lwt context, return_id = OBus_method.call_with_context m_Notify proxy (app_name, id, icon, summary, body, actions, hints, Int32.of_int timeout) in return (OBus_context.sender context, return_id) let close_notification proxy id = OBus_method.call m_CloseNotification proxy id let s_NotificationClosed = OBus_member.Signal.make ~interface:"org.freedesktop.Notifications" ~member:"NotificationClosed" ~args:(arg2 (None, C.basic_uint32) (None, C.basic_uint32)) ~annotations:[] let notification_closed proxy = OBus_signal.make s_NotificationClosed proxy let s_ActionInvoked = OBus_member.Signal.make ~interface:"org.freedesktop.Notifications" ~member:"ActionInvoked" ~args:(arg2 (None, C.basic_uint32) (None, C.basic_string)) ~annotations:[] let action_invoked proxy = OBus_signal.make s_ActionInvoked proxy (* +-----------------------------------------------------------------+ | Notifications monitoring | +-----------------------------------------------------------------+ *) let monitor_peer peer = ignore begin let%lwt () = OBus_peer.wait_for_exit peer in let m = Peer_map.find peer !notifications in notifications := Peer_map.remove peer !notifications; (* Cancel all opened notification opened on this peer: *) Id_map.iter (fun id notif -> notif.notif_closed ()) !m; return () end let remove_notification peer id notif = notif.notif_deleted <- true; let r = Peer_map.find peer !notifications in r := Id_map.remove id !r let init_callbacks = lazy( let%lwt bus = OBus_bus.session () in (* Create an anymous proxy for connecting signals, so we will receive signals comming from any daemon *) let anonymous_proxy = { OBus_proxy.peer = OBus_peer.anonymous bus; OBus_proxy.path = server_path } in let%lwt event = OBus_signal.connect (OBus_signal.map_with_context (fun context (id, reason) -> (OBus_context.sender context, id, reason)) (notification_closed anonymous_proxy)) in (* Handle signals for closed notifications *) E.keep (E.map_p (fun (peer, id, reason) -> match try Some(Peer_map.find peer !notifications) with Not_found -> None with | None -> return () | Some m -> match try Some(Id_map.find id !m) with Not_found -> None with | None -> return () | Some notif -> remove_notification peer id notif; notif.notif_closed (); return ()) event); let%lwt event = OBus_signal.connect (OBus_signal.map_with_context (fun context (id, action) -> (OBus_context.sender context, id, action)) (action_invoked anonymous_proxy)) in (* Handle signals for actions *) E.keep (E.map_p (fun (peer, id, action) -> match try Some(Peer_map.find peer !notifications) with Not_found -> None with | None -> return () | Some m -> match try Some(Id_map.find id !m) with Not_found -> None with | None -> return () | Some notif -> remove_notification peer id notif; notif.notif_action action; return ()) event); return () ) (* +-----------------------------------------------------------------+ | Operations on notifications | +-----------------------------------------------------------------+ *) let result n = n.result let close n = let notif = n.notification in if not notif.notif_deleted then begin remove_notification n.peer n.id notif; notif.notif_closed (); (* Call the method on the peer which have opened the notification *) close_notification (OBus_proxy.make n.peer server_path) n.id end else return () (* +-----------------------------------------------------------------+ | Openning notifications | +-----------------------------------------------------------------+ *) let rec filter_opt = function | [] -> [] | Some x :: l -> x :: filter_opt l | None :: l -> filter_opt l let default_desktop_entry = desktop_entry let notify ?(app_name= !app_name) ?desktop_entry ?replace ?(icon="") ?image ~summary ?(body="") ?(actions=[]) ?urgency ?category ?sound_file ?suppress_sound ?pos ?(hints=[]) ?(timeout= -1) () = let desktop_entry = match desktop_entry with | None -> !default_desktop_entry | x -> x in (*** Creation of hints ***) let make_hint name x f = match x with | Some x -> Some(name, f x) | None -> None in let hints = filter_opt [make_hint "desktop-entry" desktop_entry V.basic_string; make_hint "image_data" image (fun image -> V.structure [V.basic_int32 (Int32.of_int image.img_width); V.basic_int32 (Int32.of_int image.img_height); V.basic_int32 (Int32.of_int image.img_rowstride); V.basic_boolean image.img_has_alpha; V.basic_int32 (Int32.of_int image.img_bits_per_sample); V.basic_int32 (Int32.of_int image.img_channels); V.byte_array image.img_data]); make_hint "urgency" urgency (fun urgency -> V.basic_int32 (match urgency with | `Low -> 0l | `Normal -> 1l | `Critical -> 2l)); make_hint "category" category V.basic_string; make_hint "sound-file" sound_file V.basic_string; make_hint "suppress-sound" suppress_sound V.basic_boolean; make_hint "x" pos (fun (x, y) -> V.basic_int32(Int32.of_int x)); make_hint "y" pos (fun (x, y) -> V.basic_int32(Int32.of_int y))] @ hints in (*** Handling of actions ***) let _, actions, actions_map = List.fold_right (fun (text, user_key) (acc, al, am) -> (* For each action, generate a key and associate it to the given function *) let key = Printf.sprintf "key%d" acc in (acc + 1, key :: text :: al, (key, user_key) :: am)) actions (0, [], []) in let actions_map = (default_action, `Default) :: actions_map in (* Setup callbacks *) let%lwt () = Lazy.force init_callbacks in (* Get the proxy *) let%lwt daemon = Lazy.force proxy in (* Create the notification *) let%lwt peer, id = notify daemon ~app_name ~id:(match replace with | Some n -> n.id | None -> 0l) ~icon ~summary ~body ~actions ~hints ~timeout in let waiter, wakener = wait () in let notif = { notif_deleted = false; notif_action = (fun action -> wakeup wakener (try List.assoc action actions_map with Not_found -> `Default)); notif_closed = (fun () -> wakeup wakener `Closed); } in begin try let r = Peer_map.find peer !notifications in r := Id_map.add id notif !r with Not_found -> notifications := Peer_map.add peer (ref (Id_map.add id notif Id_map.empty)) !notifications; (* Monitor the peer to be sure the notification is closed when the peer exits *) monitor_peer peer end; return { result = waiter; notification = notif; peer = peer; id = id; } obus-1.2.5/bindings/notification/notification.mli000066400000000000000000000072751456737751200221770ustar00rootroot00000000000000(* * notification.mli * ---------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Popup notifications *) (** For complete details about notifications, look at the {{:http://www.galago-project.org/specs/notification/} the official specifications} *) val app_name : string ref (** Application name used for notification. The default value is taken from [Sys.argv.(0)] *) val desktop_entry : string option ref (** If the application has a desktop entry, it can be specified here *) (** {6 Operations on notifications} *) (** Type of an opened notifications *) type 'a t val result : 'a t -> 'a Lwt.t (** Waits for a notification to be closed then returns: - [`Closed] if the user clicked on the cross, timeout was reached or the notification daemon exited - [`Default] if the default action was invoked, i.e. the user clicked on the notification, but not on a buttons - the corresponding action if the user clicked on a button other than the cross *) val close : 'a t -> unit Lwt.t (** Close the notification now *) (** {6 Opening notifications} *) type urgency = [ `Low | `Normal | `Critical ] (** Urgency level of popups *) (** An image description *) type image = { img_width : int; img_height : int; img_rowstride : int; img_has_alpha: bool; img_bits_per_sample : int; img_channels : int; img_data : string; } val notify : ?app_name : string -> ?desktop_entry : string -> ?replace : _ t -> ?icon : string -> ?image : image -> summary : string -> ?body : string -> ?actions : (string * ([> `Default | `Closed ] as 'a)) list -> ?urgency : urgency -> ?category : string -> ?sound_file : string -> ?suppress_sound : bool -> ?pos : int * int -> ?hints : (string * OBus_value.V.single) list -> ?timeout : int -> unit -> 'a t Lwt.t (** Open a notification. - [app_name] and [desktop_entry] can override default values taken from references - [replace] is a popup id this notification replace - [icon] is the notification icon. It is either as a URI (file://...) or a name in a freedesktop.org-compliant icon theme (not a GTK+ stock ID) - [image] is an image, it is used if [icon] is not present - [summary] is a single line overview of the notification - [body] is a multi-line body of text. Each line is a paragraph, server implementations are free to word wrap them as they see fit. The body may contain simple markup as specified in Markup. It must be encoded using UTF-8. If the body is omitted, just the summary is displayed. - [action] is a list of (text, key) pair, [text] is the text displayed to the user and [key] is the value which will be returned when the action is invoked - [category] is a string representing the category of the notification, for example: "device.added", "email.arrived" (more category can be found in the specifications) - [sound_file] is a sound file to play while displaying the notification - [suppress_sound] tell the daemon to suppress sounds - [pos] is a screen position - [hints] is a list of additionnal hints - [timeout] is a timeout in millisecond *) (** {6 Informations} *) (** Server informations *) type server_info = { server_name : string; server_vendor : string; server_version : string; server_spec_version : string; } val get_server_information : unit -> server_info Lwt.t (** Retreive server informations *) val get_capabilities : unit -> string list Lwt.t (** Retreive server capabilities, see specification for details *) obus-1.2.5/bindings/notification/notification_interfaces.obus000066400000000000000000000013111456737751200245520ustar00rootroot00000000000000(* * notification_interfaces.obus * ---------------------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) interface org.freedesktop.Notifications { method GetServerInformation : () -> (return_name : string, return_vendor : string, return_version : string, return_spec_version : string) method GetCapabilities : () -> (return_caps : string array) method CloseNotification : (id : uint32) -> () method Notify : (app_name : string, id : uint32, icon : string, summary : string, body : string, actions : string array, hints : (string, variant) dict, timeout : int32) -> (return_id : uint32) } obus-1.2.5/bindings/policykit/000077500000000000000000000000001456737751200163145ustar00rootroot00000000000000obus-1.2.5/bindings/policykit/dune000066400000000000000000000005131456737751200171710ustar00rootroot00000000000000(library (name obus_policy_kit) (public_name obus.policykit) (wrapped false) (libraries lwt obus) (preprocess (pps lwt_ppx ppx_obus))) (rule (targets policy_kit_interfaces.ml policy_kit_interfaces.mli) (deps policy_kit_interfaces.obus) (action (run obus-gen-interface -keep-common -o policy_kit_interfaces %{deps}))) obus-1.2.5/bindings/policykit/policy_kit.ml000066400000000000000000000012301456737751200210100ustar00rootroot00000000000000(* * policy_kit.ml * ------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) let not_authorized = "org.freedesktop.PolicyKit.Error.NotAuthorized" open Policy_kit_interfaces.Org_freedesktop_PolicyKit_AuthenticationAgent let obtain_authorization ~action_id ?(xid=0) ~pid () = let%lwt session_bus = OBus_bus.session () in let proxy = OBus_proxy.make (OBus_peer.make session_bus "org.freedesktop.PolicyKit.AuthenticationAgent") [] in OBus_method.call m_ObtainAuthorization proxy (action_id, Int32.of_int xid, Int32.of_int pid) obus-1.2.5/bindings/policykit/policy_kit.mli000066400000000000000000000015361456737751200211720ustar00rootroot00000000000000(* * policy_kit.mli * -------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** PolicyKit interface *) val not_authorized : OBus_error.name (** Exception raised by services when trying to perform an action for which we do not have authorization from PolicyKit *) val obtain_authorization : action_id : string -> ?xid : int -> pid : int -> unit -> bool Lwt.t (** [obtain_authorization ~action_id ~xid ~pid] tries to obtain authorization for [action_id]. It returns whether it succeed or not. @param action_id PolicyKit action identifier; see PolKitAction @param xid X11 window ID for the top-level X11 window the dialog will be transient for @param pid Process ID to grant authorization to *) obus-1.2.5/bindings/policykit/policy_kit_interfaces.obus000066400000000000000000000006121456737751200235560ustar00rootroot00000000000000(* * policy_kit_interfaces.obus * -------------------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) interface org.freedesktop.PolicyKit.AuthenticationAgent { method ObtainAuthorization : (action_id : string, xid : uint32, pid : uint32) -> (gained_authorization : boolean) } obus-1.2.5/bindings/udisks/000077500000000000000000000000001456737751200156075ustar00rootroot00000000000000obus-1.2.5/bindings/udisks/dune000066400000000000000000000004641456737751200164710ustar00rootroot00000000000000(library (name obus_udisks) (public_name obus.udisks) (wrapped false) (libraries lwt obus) (preprocess (pps lwt_ppx ppx_obus))) (rule (targets uDisks_interfaces.ml uDisks_interfaces.mli) (deps uDisks_interfaces.obus) (action (run obus-gen-interface -keep-common -o uDisks_interfaces %{deps}))) obus-1.2.5/bindings/udisks/uDisks.ml000066400000000000000000000253761456737751200174200ustar00rootroot00000000000000(* * uDisks.ml * --------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) type inhibit_cookie = string type all_spindown_timeouts_cookie = string type inhibit_all_polling_cookie = string type fs = { fs_id : string; fs_name : string; fs_supports_unix_owners : bool; fs_can_mount : bool; fs_can_create : bool; fs_max_label_len : int; fs_supports_label_rename : bool; fs_supports_online_label_rename : bool; fs_supports_fsck : bool; fs_supports_online_fsck : bool; fs_supports_resize_enlarge : bool; fs_supports_online_resize_enlarge : bool; fs_supports_resize_shrink : bool; fs_supports_online_resize_shrink : bool; } type job = { job_device : UDisks_device.t; job_in_progress : bool; job_is_cancellable : bool; job_id : string; job_num_tasks : int; job_cur_task : int; job_cur_task_id : string; job_cur_task_percentage : float; } (* +-----------------------------------------------------------------+ | Exceptions | +-----------------------------------------------------------------+ *) exception Busy exception Cancelled exception Failed exception Filesystem_driver_missing exception Filesystem_tools_missing exception Inhibited exception Invalid_option exception Not_found exception Not_supported exception Permission_denied let busy = "org.freedesktop.UDisks.Error.Busy" let cancelled = "org.freedesktop.UDisks.Error.Cancelled" let failed = "org.freedesktop.UDisks.Error.Failed" let filesystem_driver_missing = "org.freedesktop.UDisks.Error.FilesystemDriverMissing" let filesystem_tools_missing = "org.freedesktop.UDisks.Error.FilesystemToolsMissing" let inhibited = "org.freedesktop.UDisks.Error.Inhibited" let invalid_option = "org.freedesktop.UDisks.Error.InvalidOption" let not_found = "org.freedesktop.UDisks.Error.NotFound" let not_supported = "org.freedesktop.UDisks.Error.NotSupported" let permission_denied = "org.freedesktop.UDisks.Error.PermissionDenied" (* +-----------------------------------------------------------------+ | D-Bus definitions | +-----------------------------------------------------------------+ *) include OBus_peer.Private let daemon () = let%lwt bus = OBus_bus.system () in return (OBus_peer.make bus "org.freedesktop.UDisks") open UDisks_interfaces.Org_freedesktop_UDisks let proxy daemon = OBus_proxy.make daemon ["org"; "freedesktop"; "UDisks"] let make_device context path = UDisks_device.of_proxy (OBus_proxy.make (OBus_context.sender context) path) let make_adapter context path = UDisks_adapter.of_proxy (OBus_proxy.make (OBus_context.sender context) path) let make_expander context path = UDisks_expander.of_proxy (OBus_proxy.make (OBus_context.sender context) path) let make_port context path = UDisks_port.of_proxy (OBus_proxy.make (OBus_context.sender context) path) let enumerate_adapters daemon = let%lwt (context, devices) = OBus_method.call_with_context m_EnumerateAdapters (proxy daemon) () in return (List.map (make_adapter context) devices) let enumerate_expanders daemon = let%lwt (context, devices) = OBus_method.call_with_context m_EnumerateExpanders (proxy daemon) () in return (List.map (make_expander context) devices) let enumerate_ports daemon = let%lwt (context, devices) = OBus_method.call_with_context m_EnumeratePorts (proxy daemon) () in return (List.map (make_port context) devices) let enumerate_devices daemon = let%lwt (context, devices) = OBus_method.call_with_context m_EnumerateDevices (proxy daemon) () in return (List.map (make_device context) devices) let enumerate_device_files daemon = OBus_method.call m_EnumerateDeviceFiles (proxy daemon) () let find_device_by_device_file daemon ~device_file = let%lwt (context, device) = OBus_method.call_with_context m_FindDeviceByDeviceFile (proxy daemon) device_file in return (make_device context device) let find_device_by_major_minor daemon ~device_major ~device_minor = let%lwt (context, device) = OBus_method.call_with_context m_FindDeviceByMajorMinor (proxy daemon) (device_major, device_minor) in return (make_device context device) let drive_inhibit_all_polling daemon ~options = OBus_method.call m_DriveInhibitAllPolling (proxy daemon) options let drive_uninhibit_all_polling daemon ~cookie = OBus_method.call m_DriveUninhibitAllPolling (proxy daemon) cookie let drive_set_all_spindown_timeouts daemon ~timeout_seconds ~options = let timeout_seconds = Int32.of_int timeout_seconds in OBus_method.call m_DriveSetAllSpindownTimeouts (proxy daemon) (timeout_seconds, options) let drive_unset_all_spindown_timeouts daemon ~cookie = OBus_method.call m_DriveUnsetAllSpindownTimeouts (proxy daemon) cookie let linux_lvm2_vgstart daemon ~uuid ~options = OBus_method.call m_LinuxLvm2VGStart (proxy daemon) (uuid, options) let linux_lvm2_vgstop daemon ~uuid ~options = OBus_method.call m_LinuxLvm2VGStop (proxy daemon) (uuid, options) let linux_lvm2_vgset_name daemon ~uuid ~name = OBus_method.call m_LinuxLvm2VGSetName (proxy daemon) (uuid, name) let linux_lvm2_vgadd_pv daemon ~uuid ~physical_volume ~options = let physical_volume = OBus_proxy.path (UDisks_device.to_proxy physical_volume) in OBus_method.call m_LinuxLvm2VGAddPV (proxy daemon) (uuid, physical_volume, options) let linux_lvm2_vgremove_pv daemon ~vg_uuid ~pv_uuid ~options = OBus_method.call m_LinuxLvm2VGRemovePV (proxy daemon) (vg_uuid, pv_uuid, options) let linux_lvm2_lvset_name daemon ~group_uuid ~uuid ~name = OBus_method.call m_LinuxLvm2LVSetName (proxy daemon) (group_uuid, uuid, name) let linux_lvm2_lvstart daemon ~group_uuid ~uuid ~options = OBus_method.call m_LinuxLvm2LVStart (proxy daemon) (group_uuid, uuid, options) let linux_lvm2_lvremove daemon ~group_uuid ~uuid ~options = OBus_method.call m_LinuxLvm2LVRemove (proxy daemon) (group_uuid, uuid, options) let linux_lvm2_lvcreate daemon ~group_uuid ~name ~size ~num_stripes ~stripe_size ~num_mirrors ~options ~fstype ~fsoptions = let num_stripes = Int32.of_int num_stripes in let num_mirrors = Int32.of_int num_mirrors in let%lwt (context, created_device) = OBus_method.call_with_context m_LinuxLvm2LVCreate (proxy daemon) (group_uuid, name, size, num_stripes, stripe_size, num_mirrors, options, fstype, fsoptions) in return (make_device context created_device) let linux_md_start daemon ~components ~options = let components = List.map (fun c -> OBus_proxy.path (UDisks_device.to_proxy c)) components in let%lwt (context, device) = OBus_method.call_with_context m_LinuxMdStart (proxy daemon) (components, options) in return (make_device context device) let linux_md_create daemon ~components ~level ~stripe_size ~name ~options = let components = List.map (fun c -> OBus_proxy.path (UDisks_device.to_proxy c)) components in let%lwt (context, device) = OBus_method.call_with_context m_LinuxMdCreate (proxy daemon) (components, level, stripe_size, name, options) in return (make_device context device) let inhibit daemon = OBus_method.call m_Inhibit (proxy daemon) () let uninhibit daemon ~cookie = OBus_method.call m_Uninhibit (proxy daemon) cookie let device_added daemon = OBus_signal.map_with_context make_device (OBus_signal.make s_DeviceAdded (proxy daemon)) let device_removed daemon = OBus_signal.map_with_context make_device (OBus_signal.make s_DeviceRemoved (proxy daemon)) let device_changed daemon = OBus_signal.map_with_context make_device (OBus_signal.make s_DeviceChanged (proxy daemon)) let device_job_changed daemon = OBus_signal.map_with_context (fun context (device, job_in_progress, job_is_cancellable, job_id, job_num_tasks, job_cur_task, job_cur_task_id, job_cur_task_percentage) -> { job_device = make_device context device; job_in_progress = job_in_progress; job_is_cancellable = job_is_cancellable; job_id = job_id; job_num_tasks = Int32.to_int job_num_tasks; job_cur_task = Int32.to_int job_cur_task; job_cur_task_id = job_cur_task_id; job_cur_task_percentage = job_cur_task_percentage; }) (OBus_signal.make s_DeviceJobChanged (proxy daemon)) let adapter_added daemon = OBus_signal.map_with_context make_adapter (OBus_signal.make s_AdapterAdded (proxy daemon)) let adapter_removed daemon = OBus_signal.map_with_context make_adapter (OBus_signal.make s_AdapterRemoved (proxy daemon)) let adapter_changed daemon = OBus_signal.map_with_context make_adapter (OBus_signal.make s_AdapterChanged (proxy daemon)) let expander_added daemon = OBus_signal.map_with_context make_expander (OBus_signal.make s_ExpanderAdded (proxy daemon)) let expander_removed daemon = OBus_signal.map_with_context make_expander (OBus_signal.make s_ExpanderRemoved (proxy daemon)) let expander_changed daemon = OBus_signal.map_with_context make_expander (OBus_signal.make s_ExpanderChanged (proxy daemon)) let port_added daemon = OBus_signal.map_with_context make_port (OBus_signal.make s_PortAdded (proxy daemon)) let port_removed daemon = OBus_signal.map_with_context make_port (OBus_signal.make s_PortRemoved (proxy daemon)) let port_changed daemon = OBus_signal.map_with_context make_port (OBus_signal.make s_PortChanged (proxy daemon)) let daemon_version daemon = OBus_property.make p_DaemonVersion (proxy daemon) let daemon_is_inhibited daemon = OBus_property.make p_DaemonIsInhibited (proxy daemon) let supports_luks_devices daemon = OBus_property.make p_SupportsLuksDevices (proxy daemon) let known_filesystems daemon = OBus_property.map_r (fun l -> List.map (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14) -> { fs_id = x1; fs_name = x2; fs_supports_unix_owners = x3; fs_can_mount = x4; fs_can_create = x5; fs_max_label_len = Int32.to_int x6; fs_supports_label_rename = x7; fs_supports_online_label_rename = x8; fs_supports_fsck = x9; fs_supports_online_fsck = x10; fs_supports_resize_enlarge = x11; fs_supports_online_resize_enlarge = x12; fs_supports_resize_shrink = x13; fs_supports_online_resize_shrink = x14; }) l) (OBus_property.make p_KnownFilesystems (proxy daemon)) type properties = { known_filesystems : fs list; supports_luks_devices : bool; daemon_is_inhibited : bool; daemon_version : string; } let properties daemon = OBus_property.group (proxy daemon) interface obus-1.2.5/bindings/udisks/uDisks.mli000066400000000000000000000142351456737751200175610ustar00rootroot00000000000000(* * uDisks.mli * ---------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** UDisks main interface *) include OBus_peer.Private val daemon : unit -> t Lwt.t (** [daemon ()] returns the peer object for the udisks daemon *) (** {6 Exceptions} *) val busy : OBus_error.name val cancelled : OBus_error.name val failed : OBus_error.name val filesystem_driver_missing : OBus_error.name val filesystem_tools_missing : OBus_error.name val inhibited : OBus_error.name val invalid_option : OBus_error.name val not_found : OBus_error.name val not_supported : OBus_error.name val permission_denied : OBus_error.name (** {6 Methods} *) type inhibit_cookie val inhibit : t -> inhibit_cookie Lwt.t val uninhibit : t -> cookie : inhibit_cookie -> unit Lwt.t val linux_md_create : t -> components : UDisks_device.t list -> level : string -> stripe_size : int64 -> name : string -> options : string list -> UDisks_device.t Lwt.t val linux_md_start : t -> components : UDisks_device.t list -> options : string list -> UDisks_device.t Lwt.t val linux_lvm2_lvcreate : t -> group_uuid : string -> name : string -> size : int64 -> num_stripes : int -> stripe_size : int64 -> num_mirrors : int -> options : string list -> fstype : string -> fsoptions : string list -> UDisks_device.t Lwt.t val linux_lvm2_lvremove : t -> group_uuid : string -> uuid : string -> options : string list -> unit Lwt.t val linux_lvm2_lvstart : t -> group_uuid : string -> uuid : string -> options : string list -> unit Lwt.t val linux_lvm2_lvset_name : t -> group_uuid : string -> uuid : string -> name : string -> unit Lwt.t val linux_lvm2_vgremove_pv : t -> vg_uuid : string -> pv_uuid : string -> options : string list -> unit Lwt.t val linux_lvm2_vgadd_pv : t -> uuid : string -> physical_volume : UDisks_device.t -> options : string list -> unit Lwt.t val linux_lvm2_vgset_name : t -> uuid : string -> name : string -> unit Lwt.t val linux_lvm2_vgstop : t -> uuid : string -> options : string list -> unit Lwt.t val linux_lvm2_vgstart : t -> uuid : string -> options : string list -> unit Lwt.t type all_spindown_timeouts_cookie val drive_set_all_spindown_timeouts : t -> timeout_seconds : int -> options : string list -> all_spindown_timeouts_cookie Lwt.t val drive_unset_all_spindown_timeouts : t -> cookie : all_spindown_timeouts_cookie -> unit Lwt.t type inhibit_all_polling_cookie val drive_inhibit_all_polling : t -> options : string list -> inhibit_all_polling_cookie Lwt.t val drive_uninhibit_all_polling : t -> cookie : inhibit_all_polling_cookie -> unit Lwt.t val find_device_by_major_minor : t -> device_major : int64 -> device_minor : int64 -> UDisks_device.t Lwt.t val find_device_by_device_file : t -> device_file : string -> UDisks_device.t Lwt.t val enumerate_device_files : t -> string list Lwt.t val enumerate_devices : t -> UDisks_device.t list Lwt.t val enumerate_ports : t -> UDisks_port.t list Lwt.t val enumerate_expanders : t -> UDisks_expander.t list Lwt.t val enumerate_adapters : t -> UDisks_adapter.t list Lwt.t (** {6 Signals} *) val port_changed : t -> UDisks_port.t OBus_signal.t val port_removed : t -> UDisks_port.t OBus_signal.t val port_added : t -> UDisks_port.t OBus_signal.t val expander_changed : t -> UDisks_expander.t OBus_signal.t val expander_removed : t -> UDisks_expander.t OBus_signal.t val expander_added : t -> UDisks_expander.t OBus_signal.t val adapter_changed : t -> UDisks_adapter.t OBus_signal.t val adapter_removed : t -> UDisks_adapter.t OBus_signal.t val adapter_added : t -> UDisks_adapter.t OBus_signal.t val device_changed : t -> UDisks_device.t OBus_signal.t val device_removed : t -> UDisks_device.t OBus_signal.t val device_added : t -> UDisks_device.t OBus_signal.t type job = { job_device : UDisks_device.t; job_in_progress : bool; (** Whether a job is currently in progress. job OBus_signal.t (** {6 Properties} *) (** File-system informations *) type fs = { fs_id : string; (** The name / identifier of the file system (such as ext3 or vfat), similar to the contents of the Device:IdType property. *) fs_name : string; (** A human readable name for the file system such as "Linux Ext3". *) fs_supports_unix_owners : bool; (** Whether the file system supports the UNIX owners model (e.g. ext3 does, but vfat doesn't). *) fs_can_mount : bool; (** Whether the file system can be mounted. *) fs_can_create : bool; (** Whether the file system can be created on a device. *) fs_max_label_len : int; (** The maximum amount of bytes that the file system label can hold. Set to zero if the file system doesn't support labels. *) fs_supports_label_rename : bool; (** Whether the label of the file system can be changed. *) fs_supports_online_label_rename : bool; (** Whether the label can be changed while the file system is mounted. *) fs_supports_fsck : bool; (** Whether the file system can be checked. *) fs_supports_online_fsck : bool; (** Whether the file system can be checked while mounted. *) fs_supports_resize_enlarge : bool; (** Whether the file system can be enlarged. *) fs_supports_online_resize_enlarge : bool; (** Whether the file system can be enlarged while mounted. *) fs_supports_resize_shrink : bool; (** Whether the file system can be shrunk. *) fs_supports_online_resize_shrink : bool; (** Whether the file system can be shrunk while mounted. *) } val known_filesystems : t -> fs list OBus_property.r val supports_luks_devices : t -> bool OBus_property.r val daemon_is_inhibited : t -> bool OBus_property.r val daemon_version : t -> string OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/udisks/uDisks_adapter.ml000066400000000000000000000020041456737751200210770ustar00rootroot00000000000000(* * uDisks_adapter.ml * ----------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) include OBus_proxy.Private open UDisks_interfaces.Org_freedesktop_UDisks_Adapter let changed proxy = OBus_signal.make s_Changed proxy let native_path proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_NativePath proxy let vendor proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_Vendor proxy let model proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_Model proxy let driver proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_Driver proxy let num_ports proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_NumPorts proxy) let fabric proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_Fabric proxy let properties proxy = OBus_property.group ~monitor:UDisks_monitor.monitor proxy interface obus-1.2.5/bindings/udisks/uDisks_adapter.mli000066400000000000000000000011761456737751200212610ustar00rootroot00000000000000(* * uDisks_adapter.mli * ------------------ * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** UDisks adapter interface *) include OBus_proxy.Private (** {6 Signals} *) val changed : t -> unit OBus_signal.t (** {6 Properties} *) val fabric : t -> string OBus_property.r val num_ports : t -> int OBus_property.r val driver : t -> string OBus_property.r val model : t -> string OBus_property.r val vendor : t -> string OBus_property.r val native_path : t -> string OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/udisks/uDisks_device.ml000066400000000000000000000550521456737751200207310ustar00rootroot00000000000000(* * uDisks_device.ml * ---------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt include OBus_proxy.Private (* +-----------------------------------------------------------------+ | Types | +-----------------------------------------------------------------+ *) type benchmark_result = { bench_read_transfer_rate_results : (int64 * float) list; bench_write_transfer_rate_results : (int64 * float) list; bench_access_time_results : (int64 * float) list; } type spindown_timeout_cookie = string type inhibit_polling_cookie = string type process = { pr_pid : int; pr_uid : int; pr_comamnd_line : string; } type job = { job_in_progress : bool; job_id : string; job_initiated_by_uid : int; job_is_cancellable : bool; job_cur_task_percentage : float; } (* +-----------------------------------------------------------------+ | D-Bus members | +-----------------------------------------------------------------+ *) open UDisks_interfaces.Org_freedesktop_UDisks_Device let job_cancel proxy = OBus_method.call m_JobCancel proxy () let partition_table_create proxy ~scheme ~options = OBus_method.call m_PartitionTableCreate proxy (scheme, options) let partition_delete proxy ~options = OBus_method.call m_PartitionDelete proxy options let partition_create proxy ~offset ~size ~typ ~label ~flags ~options ~fstype ~fsoptions = let%lwt (context, created_device) = OBus_method.call_with_context m_PartitionCreate proxy (offset, size, typ, label, flags, options, fstype, fsoptions) in let created_device = OBus_proxy.make (OBus_context.sender context) created_device in return created_device let partition_modify proxy ~typ ~label ~flags = OBus_method.call m_PartitionModify proxy (typ, label, flags) let filesystem_create proxy ~fstype ~options = OBus_method.call m_FilesystemCreate proxy (fstype, options) let filesystem_set_label proxy ~new_label = OBus_method.call m_FilesystemSetLabel proxy new_label let filesystem_mount proxy ~filesystem_type ~options = OBus_method.call m_FilesystemMount proxy (filesystem_type, options) let filesystem_unmount proxy ~options = OBus_method.call m_FilesystemUnmount proxy options let filesystem_check proxy ~options = OBus_method.call m_FilesystemCheck proxy options let filesystem_list_open_files proxy = let%lwt processes = OBus_method.call m_FilesystemListOpenFiles proxy () in return (List.map (fun (x1, x2, x3) -> { pr_pid = Int32.to_int x1; pr_uid = Int32.to_int x2; pr_comamnd_line = x3; }) processes) let luks_unlock proxy ~passphrase ~options = let%lwt (context, cleartext_device) = OBus_method.call_with_context m_LuksUnlock proxy (passphrase, options) in let cleartext_device = OBus_proxy.make (OBus_context.sender context) cleartext_device in return cleartext_device let luks_lock proxy ~options = OBus_method.call m_LuksLock proxy options let luks_change_passphrase proxy ~current_passphrase ~new_passphrase = OBus_method.call m_LuksChangePassphrase proxy (current_passphrase, new_passphrase) let linux_md_add_spare proxy ~component ~options = let component = OBus_proxy.path component in OBus_method.call m_LinuxMdAddSpare proxy (component, options) let linux_md_expand proxy ~components ~options = let components = List.map OBus_proxy.path components in OBus_method.call m_LinuxMdExpand proxy (components, options) let linux_md_remove_component proxy ~component ~options = let component = OBus_proxy.path component in OBus_method.call m_LinuxMdRemoveComponent proxy (component, options) let linux_md_stop proxy ~options = OBus_method.call m_LinuxMdStop proxy options let linux_lvm2_lvstop proxy ~options = OBus_method.call m_LinuxLvm2LVStop proxy options let linux_md_check proxy ~options = OBus_method.call m_LinuxMdCheck proxy options let drive_inhibit_polling proxy ~options = OBus_method.call m_DriveInhibitPolling proxy options let drive_uninhibit_polling proxy ~cookie = OBus_method.call m_DriveUninhibitPolling proxy cookie let drive_poll_media proxy = OBus_method.call m_DrivePollMedia proxy () let drive_eject proxy ~options = OBus_method.call m_DriveEject proxy options let drive_detach proxy ~options = OBus_method.call m_DriveDetach proxy options let drive_set_spindown_timeout proxy ~timeout_seconds ~options = let timeout_seconds = Int32.of_int timeout_seconds in OBus_method.call m_DriveSetSpindownTimeout proxy (timeout_seconds, options) let drive_unset_spindown_timeout proxy ~cookie = OBus_method.call m_DriveUnsetSpindownTimeout proxy cookie let drive_ata_smart_refresh_data proxy ~options = OBus_method.call m_DriveAtaSmartRefreshData proxy options let drive_ata_smart_initiate_selftest proxy ~test ~options = OBus_method.call m_DriveAtaSmartInitiateSelftest proxy (test, options) let drive_benchmark proxy ~do_write_benchmark ~options = let%lwt (x1, x2, x3) = OBus_method.call m_DriveBenchmark proxy (do_write_benchmark, options) in return { bench_read_transfer_rate_results = x1; bench_write_transfer_rate_results = x2; bench_access_time_results = x3; } let changed proxy = OBus_signal.make s_Changed proxy let job_changed proxy = OBus_signal.map (fun (job_in_progress, job_is_cancellable, job_id, job_initiated_by_uid, job_percentage) -> { job_in_progress = job_in_progress; job_id = job_id; job_initiated_by_uid = Int32.to_int job_initiated_by_uid; job_is_cancellable = job_is_cancellable; job_cur_task_percentage = job_percentage; }) (OBus_signal.make s_JobChanged proxy) let native_path proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_NativePath proxy let device_detection_time proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceDetectionTime proxy let device_media_detection_time proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceMediaDetectionTime proxy let device_major proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceMajor proxy let device_minor proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceMinor proxy let device_file proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceFile proxy let device_file_presentation proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceFilePresentation proxy let device_file_by_id proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceFileById proxy let device_file_by_path proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceFileByPath proxy let device_is_system_internal proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsSystemInternal proxy let device_is_partition proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsPartition proxy let device_is_partition_table proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsPartitionTable proxy let device_is_removable proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsRemovable proxy let device_is_media_available proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsMediaAvailable proxy let device_is_media_change_detected proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsMediaChangeDetected proxy let device_is_media_change_detection_polling proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsMediaChangeDetectionPolling proxy let device_is_media_change_detection_inhibitable proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsMediaChangeDetectionInhibitable proxy let device_is_media_change_detection_inhibited proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsMediaChangeDetectionInhibited proxy let device_is_read_only proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsReadOnly proxy let device_is_drive proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsDrive proxy let device_is_optical_disc proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsOpticalDisc proxy let device_is_mounted proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsMounted proxy let device_mount_paths proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceMountPaths proxy let device_mounted_by_uid proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceMountedByUid proxy) let device_is_luks proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsLuks proxy let device_is_luks_cleartext proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsLuksCleartext proxy let device_is_linux_md_component proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsLinuxMdComponent proxy let device_is_linux_md proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsLinuxMd proxy let device_is_linux_lvm2_lv proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsLinuxLvm2LV proxy let device_is_linux_lvm2_pv proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsLinuxLvm2PV proxy let device_is_linux_dmmp_component proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsLinuxDmmpComponent proxy let device_is_linux_dmmp proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsLinuxDmmp proxy let device_is_linux_loop proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceIsLinuxLoop proxy let device_size proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceSize proxy let device_block_size proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DeviceBlockSize proxy let device_presentation_hide proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DevicePresentationHide proxy let device_presentation_nopolicy proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DevicePresentationNopolicy proxy let device_presentation_name proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DevicePresentationName proxy let device_presentation_icon_name proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DevicePresentationIconName proxy let job_in_progress proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_JobInProgress proxy let job_id proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_JobId proxy let job_initiated_by_uid proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_JobInitiatedByUid proxy) let job_is_cancellable proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_JobIsCancellable proxy let job_percentage proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_JobPercentage proxy let id_usage proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_IdUsage proxy let id_type proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_IdType proxy let id_version proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_IdVersion proxy let id_uuid proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_IdUuid proxy let id_label proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_IdLabel proxy let luks_holder proxy = OBus_property.map_r_with_context (fun context x -> OBus_proxy.make (OBus_context.sender context) x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_LuksHolder proxy) let luks_cleartext_slave proxy = OBus_property.map_r_with_context (fun context x -> OBus_proxy.make (OBus_context.sender context) x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_LuksCleartextSlave proxy) let luks_cleartext_unlocked_by_uid proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_LuksCleartextUnlockedByUid proxy) let partition_slave proxy = OBus_property.map_r_with_context (fun context x -> OBus_proxy.make (OBus_context.sender context) x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_PartitionSlave proxy) let partition_scheme proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_PartitionScheme proxy let partition_type proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_PartitionType proxy let partition_label proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_PartitionLabel proxy let partition_uuid proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_PartitionUuid proxy let partition_flags proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_PartitionFlags proxy let partition_number proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_PartitionNumber proxy) let partition_offset proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_PartitionOffset proxy let partition_size proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_PartitionSize proxy let partition_alignment_offset proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_PartitionAlignmentOffset proxy let partition_table_scheme proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_PartitionTableScheme proxy let partition_table_count proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_PartitionTableCount proxy) let drive_vendor proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveVendor proxy let drive_model proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveModel proxy let drive_revision proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveRevision proxy let drive_serial proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveSerial proxy let drive_wwn proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveWwn proxy let drive_rotation_rate proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveRotationRate proxy) let drive_write_cache proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveWriteCache proxy let drive_connection_interface proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveConnectionInterface proxy let drive_connection_speed proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveConnectionSpeed proxy let drive_media_compatibility proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveMediaCompatibility proxy let drive_media proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveMedia proxy let drive_is_media_ejectable proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveIsMediaEjectable proxy let drive_can_detach proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveCanDetach proxy let drive_can_spindown proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveCanSpindown proxy let drive_is_rotational proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveIsRotational proxy let drive_adapter proxy = OBus_property.map_r_with_context (fun context x -> UDisks_adapter.of_proxy (OBus_proxy.make (OBus_context.sender context) x)) (OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveAdapter proxy) let drive_ports proxy = OBus_property.map_r_with_context (fun context x -> List.map (fun path -> UDisks_port.of_proxy (OBus_proxy.make (OBus_context.sender context) path)) x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_DrivePorts proxy) let drive_similar_devices proxy = OBus_property.map_r_with_context (fun context x -> List.map (fun path -> OBus_proxy.make (OBus_context.sender context) path) x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveSimilarDevices proxy) let optical_disc_is_blank proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_OpticalDiscIsBlank proxy let optical_disc_is_appendable proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_OpticalDiscIsAppendable proxy let optical_disc_is_closed proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_OpticalDiscIsClosed proxy let optical_disc_num_tracks proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_OpticalDiscNumTracks proxy) let optical_disc_num_audio_tracks proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_OpticalDiscNumAudioTracks proxy) let optical_disc_num_sessions proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_OpticalDiscNumSessions proxy) let drive_ata_smart_is_available proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveAtaSmartIsAvailable proxy let drive_ata_smart_time_collected proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveAtaSmartTimeCollected proxy let drive_ata_smart_status proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveAtaSmartStatus proxy let drive_ata_smart_blob proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_DriveAtaSmartBlob proxy let linux_md_component_level proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdComponentLevel proxy let linux_md_component_position proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdComponentPosition proxy) let linux_md_component_num_raid_devices proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdComponentNumRaidDevices proxy) let linux_md_component_uuid proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdComponentUuid proxy let linux_md_component_name proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdComponentName proxy let linux_md_component_home_host proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdComponentHomeHost proxy let linux_md_component_version proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdComponentVersion proxy let linux_md_component_holder proxy = OBus_property.map_r_with_context (fun context x -> OBus_proxy.make (OBus_context.sender context) x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdComponentHolder proxy) let linux_md_component_state proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdComponentState proxy let linux_md_state proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdState proxy let linux_md_level proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdLevel proxy let linux_md_uuid proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdUuid proxy let linux_md_home_host proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdHomeHost proxy let linux_md_name proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdName proxy let linux_md_num_raid_devices proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdNumRaidDevices proxy) let linux_md_version proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdVersion proxy let linux_md_slaves proxy = OBus_property.map_r_with_context (fun context x -> List.map (fun path -> OBus_proxy.make (OBus_context.sender context) path) x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdSlaves proxy) let linux_md_is_degraded proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdIsDegraded proxy let linux_md_sync_action proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdSyncAction proxy let linux_md_sync_percentage proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdSyncPercentage proxy let linux_md_sync_speed proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxMdSyncSpeed proxy let linux_lvm2_pvuuid proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2PVUuid proxy let linux_lvm2_pvnum_metadata_areas proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2PVNumMetadataAreas proxy) let linux_lvm2_pvgroup_name proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2PVGroupName proxy let linux_lvm2_pvgroup_uuid proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2PVGroupUuid proxy let linux_lvm2_pvgroup_size proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2PVGroupSize proxy let linux_lvm2_pvgroup_unallocated_size proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2PVGroupUnallocatedSize proxy let linux_lvm2_pvgroup_sequence_number proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2PVGroupSequenceNumber proxy let linux_lvm2_pvgroup_extent_size proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2PVGroupExtentSize proxy let linux_lvm2_pvgroup_physical_volumes proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2PVGroupPhysicalVolumes proxy let linux_lvm2_pvgroup_logical_volumes proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2PVGroupLogicalVolumes proxy let linux_lvm2_lvname proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2LVName proxy let linux_lvm2_lvuuid proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2LVUuid proxy let linux_lvm2_lvgroup_name proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2LVGroupName proxy let linux_lvm2_lvgroup_uuid proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLvm2LVGroupUuid proxy let linux_dmmp_component_holder proxy = OBus_property.map_r_with_context (fun context x -> OBus_proxy.make (OBus_context.sender context) x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxDmmpComponentHolder proxy) let linux_dmmp_name proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxDmmpName proxy let linux_dmmp_slaves proxy = OBus_property.map_r_with_context (fun context x -> List.map (fun path -> OBus_proxy.make (OBus_context.sender context) path) x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxDmmpSlaves proxy) let linux_dmmp_parameters proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxDmmpParameters proxy let linux_loop_filename proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_LinuxLoopFilename proxy let properties proxy = OBus_property.group ~monitor:UDisks_monitor.monitor proxy interface obus-1.2.5/bindings/udisks/uDisks_device.mli000066400000000000000000000261511456737751200211000ustar00rootroot00000000000000(* * uDisks_device.mli * ----------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** UDisks device interface *) include OBus_proxy.Private (** {6 Methods} *) type benchmark_result = { bench_read_transfer_rate_results : (int64 * float) list; (** An array of pairs where the first element is the offset and the second element is the measured read transfer rate (in bytes/sec) at the given offset. *) bench_write_transfer_rate_results : (int64 * float) list; (** An array of pairs where the first element is the offset and the second element is the measured read transfer rate (in bytes/sec) at the given offset. This is an empty array unless write benchmarking has been requested. *) bench_access_time_results : (int64 * float) list; (** An array of pairs where the first element is the offset and the second element the amount of time (in seconds) it took to seek to the position. *) } val drive_benchmark : t -> do_write_benchmark : bool -> options : string list -> benchmark_result Lwt.t val drive_ata_smart_initiate_selftest : t -> test : string -> options : string list -> unit Lwt.t val drive_ata_smart_refresh_data : t -> options : string list -> unit Lwt.t type spindown_timeout_cookie val drive_set_spindown_timeout : t -> timeout_seconds : int -> options : string list -> spindown_timeout_cookie Lwt.t val drive_unset_spindown_timeout : t -> cookie : spindown_timeout_cookie -> unit Lwt.t val drive_detach : t -> options : string list -> unit Lwt.t val drive_eject : t -> options : string list -> unit Lwt.t val drive_poll_media : t -> unit Lwt.t type inhibit_polling_cookie val drive_inhibit_polling : t -> options : string list -> inhibit_polling_cookie Lwt.t val drive_uninhibit_polling : t -> cookie : inhibit_polling_cookie -> unit Lwt.t val linux_md_check : t -> options : string list -> int64 Lwt.t val linux_lvm2_lvstop : t -> options : string list -> unit Lwt.t val linux_md_stop : t -> options : string list -> unit Lwt.t val linux_md_remove_component : t -> component : t -> options : string list -> unit Lwt.t val linux_md_expand : t -> components : t list -> options : string list -> unit Lwt.t val linux_md_add_spare : t -> component : t -> options : string list -> unit Lwt.t val luks_change_passphrase : t -> current_passphrase : string -> new_passphrase : string -> unit Lwt.t val luks_lock : t -> options : string list -> unit Lwt.t val luks_unlock : t -> passphrase : string -> options : string list -> t Lwt.t type process = { pr_pid : int; pr_uid : int; pr_comamnd_line : string; } val filesystem_list_open_files : t -> process list Lwt.t val filesystem_check : t -> options : string list -> bool Lwt.t val filesystem_unmount : t -> options : string list -> unit Lwt.t val filesystem_mount : t -> filesystem_type : string -> options : string list -> string Lwt.t val filesystem_set_label : t -> new_label : string -> unit Lwt.t val filesystem_create : t -> fstype : string -> options : string list -> unit Lwt.t val partition_modify : t -> typ : string -> label : string -> flags : string list -> unit Lwt.t val partition_create : t -> offset : int64 -> size : int64 -> typ : string -> label : string -> flags : string list -> options : string list -> fstype : string -> fsoptions : string list -> t Lwt.t val partition_delete : t -> options : string list -> unit Lwt.t val partition_table_create : t -> scheme : string -> options : string list -> unit Lwt.t val job_cancel : t -> unit Lwt.t (** {6 Signals} *) (** A job description *) type job = { job_in_progress : bool; (** Whether a job is currently in progress *) job_id : string; (** The identifier of the job *) job_initiated_by_uid : int; (** he UNIX user id of the user who initiated the job *) job_is_cancellable : bool; (** Whether the job is cancellable *) job_cur_task_percentage : float; (** Percentage completed of current task (between 0 and 100, negative if unknown) *) } val job_changed : t -> job OBus_signal.t val changed : t -> unit OBus_signal.t (** {6 Properties} *) val linux_dmmp_parameters : t -> string OBus_property.r val linux_dmmp_slaves : t -> t list OBus_property.r val linux_dmmp_name : t -> string OBus_property.r val linux_dmmp_component_holder : t -> t OBus_property.r val linux_lvm2_lvgroup_uuid : t -> string OBus_property.r val linux_lvm2_lvgroup_name : t -> string OBus_property.r val linux_lvm2_lvuuid : t -> string OBus_property.r val linux_lvm2_lvname : t -> string OBus_property.r val linux_lvm2_pvgroup_logical_volumes : t -> string list OBus_property.r val linux_lvm2_pvgroup_physical_volumes : t -> string list OBus_property.r val linux_lvm2_pvgroup_extent_size : t -> int64 OBus_property.r val linux_lvm2_pvgroup_sequence_number : t -> int64 OBus_property.r val linux_lvm2_pvgroup_unallocated_size : t -> int64 OBus_property.r val linux_lvm2_pvgroup_size : t -> int64 OBus_property.r val linux_lvm2_pvgroup_uuid : t -> string OBus_property.r val linux_lvm2_pvgroup_name : t -> string OBus_property.r val linux_lvm2_pvnum_metadata_areas : t -> int OBus_property.r val linux_lvm2_pvuuid : t -> string OBus_property.r val linux_md_sync_speed : t -> int64 OBus_property.r val linux_md_sync_percentage : t -> float OBus_property.r val linux_md_sync_action : t -> string OBus_property.r val linux_md_is_degraded : t -> bool OBus_property.r val linux_md_slaves : t -> t list OBus_property.r val linux_md_version : t -> string OBus_property.r val linux_md_num_raid_devices : t -> int OBus_property.r val linux_md_name : t -> string OBus_property.r val linux_md_home_host : t -> string OBus_property.r val linux_md_uuid : t -> string OBus_property.r val linux_md_level : t -> string OBus_property.r val linux_md_state : t -> string OBus_property.r val linux_md_component_state : t -> string list OBus_property.r val linux_md_component_holder : t -> t OBus_property.r val linux_md_component_version : t -> string OBus_property.r val linux_md_component_home_host : t -> string OBus_property.r val linux_md_component_name : t -> string OBus_property.r val linux_md_component_uuid : t -> string OBus_property.r val linux_md_component_num_raid_devices : t -> int OBus_property.r val linux_md_component_position : t -> int OBus_property.r val linux_md_component_level : t -> string OBus_property.r val drive_ata_smart_blob : t -> string OBus_property.r val drive_ata_smart_status : t -> string OBus_property.r val drive_ata_smart_time_collected : t -> int64 OBus_property.r val drive_ata_smart_is_available : t -> bool OBus_property.r val optical_disc_num_sessions : t -> int OBus_property.r val optical_disc_num_audio_tracks : t -> int OBus_property.r val optical_disc_num_tracks : t -> int OBus_property.r val optical_disc_is_closed : t -> bool OBus_property.r val optical_disc_is_appendable : t -> bool OBus_property.r val optical_disc_is_blank : t -> bool OBus_property.r val drive_similar_devices : t -> t list OBus_property.r val drive_ports : t -> UDisks_port.t list OBus_property.r val drive_adapter : t -> UDisks_adapter.t OBus_property.r val drive_is_rotational : t -> bool OBus_property.r val drive_can_spindown : t -> bool OBus_property.r val drive_can_detach : t -> bool OBus_property.r val drive_is_media_ejectable : t -> bool OBus_property.r val drive_media : t -> string OBus_property.r val drive_media_compatibility : t -> string list OBus_property.r val drive_connection_speed : t -> int64 OBus_property.r val drive_connection_interface : t -> string OBus_property.r val drive_write_cache : t -> string OBus_property.r val drive_rotation_rate : t -> int OBus_property.r val drive_wwn : t -> string OBus_property.r val drive_serial : t -> string OBus_property.r val drive_revision : t -> string OBus_property.r val drive_model : t -> string OBus_property.r val drive_vendor : t -> string OBus_property.r val partition_table_count : t -> int OBus_property.r val partition_table_scheme : t -> string OBus_property.r val partition_alignment_offset : t -> int64 OBus_property.r val partition_size : t -> int64 OBus_property.r val partition_offset : t -> int64 OBus_property.r val partition_number : t -> int OBus_property.r val partition_flags : t -> string list OBus_property.r val partition_uuid : t -> string OBus_property.r val partition_label : t -> string OBus_property.r val partition_type : t -> string OBus_property.r val partition_scheme : t -> string OBus_property.r val partition_slave : t -> t OBus_property.r val luks_cleartext_unlocked_by_uid : t -> int OBus_property.r val luks_cleartext_slave : t -> t OBus_property.r val luks_holder : t -> t OBus_property.r val id_label : t -> string OBus_property.r val id_uuid : t -> string OBus_property.r val id_version : t -> string OBus_property.r val id_type : t -> string OBus_property.r val id_usage : t -> string OBus_property.r val job_percentage : t -> float OBus_property.r val job_is_cancellable : t -> bool OBus_property.r val job_initiated_by_uid : t -> int OBus_property.r val job_id : t -> string OBus_property.r val job_in_progress : t -> bool OBus_property.r val device_presentation_icon_name : t -> string OBus_property.r val device_presentation_name : t -> string OBus_property.r val device_presentation_nopolicy : t -> bool OBus_property.r val device_presentation_hide : t -> bool OBus_property.r val device_block_size : t -> int64 OBus_property.r val device_size : t -> int64 OBus_property.r val device_is_linux_dmmp : t -> bool OBus_property.r val device_is_linux_dmmp_component : t -> bool OBus_property.r val device_is_linux_lvm2_pv : t -> bool OBus_property.r val device_is_linux_lvm2_lv : t -> bool OBus_property.r val device_is_linux_md : t -> bool OBus_property.r val device_is_linux_md_component : t -> bool OBus_property.r val device_is_luks_cleartext : t -> bool OBus_property.r val device_is_luks : t -> bool OBus_property.r val device_mounted_by_uid : t -> int OBus_property.r val device_mount_paths : t -> string list OBus_property.r val device_is_mounted : t -> bool OBus_property.r val device_is_optical_disc : t -> bool OBus_property.r val device_is_drive : t -> bool OBus_property.r val device_is_read_only : t -> bool OBus_property.r val device_is_media_change_detection_inhibited : t -> bool OBus_property.r val device_is_media_change_detection_inhibitable : t -> bool OBus_property.r val device_is_media_change_detection_polling : t -> bool OBus_property.r val device_is_media_change_detected : t -> bool OBus_property.r val device_is_media_available : t -> bool OBus_property.r val device_is_removable : t -> bool OBus_property.r val device_is_partition_table : t -> bool OBus_property.r val device_is_partition : t -> bool OBus_property.r val device_is_system_internal : t -> bool OBus_property.r val device_file_by_path : t -> string list OBus_property.r val device_file_by_id : t -> string list OBus_property.r val device_file_presentation : t -> string OBus_property.r val device_file : t -> string OBus_property.r val device_minor : t -> int64 OBus_property.r val device_major : t -> int64 OBus_property.r val device_media_detection_time : t -> int64 OBus_property.r val device_detection_time : t -> int64 OBus_property.r val native_path : t -> string OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/udisks/uDisks_expander.ml000066400000000000000000000026361456737751200213000ustar00rootroot00000000000000(* * uDisks_expander.ml * ------------------ * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) include OBus_proxy.Private open UDisks_interfaces.Org_freedesktop_UDisks_Expander let changed proxy = OBus_signal.make s_Changed proxy let native_path proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_NativePath proxy let vendor proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_Vendor proxy let model proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_Model proxy let revision proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_Revision proxy let num_ports proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_NumPorts proxy) let upstream_ports proxy = OBus_property.map_r_with_context (fun context x -> List.map (fun path -> UDisks_port.of_proxy ( OBus_proxy.make (OBus_context.sender context) path)) x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_UpstreamPorts proxy) let adapter proxy = OBus_property.map_r_with_context (fun context x -> UDisks_adapter.of_proxy (OBus_proxy.make (OBus_context.sender context) x)) (OBus_property.make ~monitor:UDisks_monitor.monitor p_Adapter proxy) let properties proxy = OBus_property.group ~monitor:UDisks_monitor.monitor proxy interface obus-1.2.5/bindings/udisks/uDisks_expander.mli000066400000000000000000000013131456737751200214400ustar00rootroot00000000000000(* * uDisks_expander.mli * ------------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** UDisks expander interface *) include OBus_proxy.Private (** {6 Signals} *) val changed : t -> unit OBus_signal.t (** {6 Properties} *) val native_path : t -> string OBus_property.r val vendor : t -> string OBus_property.r val model : t -> string OBus_property.r val revision : t -> string OBus_property.r val num_ports : t -> int OBus_property.r val upstream_ports : t -> UDisks_port.t list OBus_property.r val adapter : t -> UDisks_adapter.t OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/udisks/uDisks_interfaces.obus000066400000000000000000000303431456737751200221510ustar00rootroot00000000000000(* * uDisks_interfaces.obus * ---------------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) interface org.freedesktop.UDisks { method EnumerateAdapters : () -> (devices : object_path array) method EnumerateExpanders : () -> (devices : object_path array) method EnumeratePorts : () -> (devices : object_path array) method EnumerateDevices : () -> (devices : object_path array) method EnumerateDeviceFiles : () -> (device_files : string array) method FindDeviceByDeviceFile : (device_file : string) -> (device : object_path) method FindDeviceByMajorMinor : (device_major : int64, device_minor : int64) -> (device : object_path) method DriveInhibitAllPolling : (options : string array) -> (cookie : string) method DriveUninhibitAllPolling : (cookie : string) -> () method DriveSetAllSpindownTimeouts : (timeout_seconds : int32, options : string array) -> (cookie : string) method DriveUnsetAllSpindownTimeouts : (cookie : string) -> () method LinuxLvm2VGStart : (uuid : string, options : string array) -> () method LinuxLvm2VGStop : (uuid : string, options : string array) -> () method LinuxLvm2VGSetName : (uuid : string, name : string) -> () method LinuxLvm2VGAddPV : (uuid : string, physical_volume : object_path, options : string array) -> () method LinuxLvm2VGRemovePV : (vg_uuid : string, pv_uuid : string, options : string array) -> () method LinuxLvm2LVSetName : (group_uuid : string, uuid : string, name : string) -> () method LinuxLvm2LVStart : (group_uuid : string, uuid : string, options : string array) -> () method LinuxLvm2LVRemove : (group_uuid : string, uuid : string, options : string array) -> () method LinuxLvm2LVCreate : (group_uuid : string, name : string, size : uint64, num_stripes : uint32, stripe_size : uint64, num_mirrors : uint32, options : string array, fstype : string, fsoptions : string array) -> (created_device : object_path) method LinuxMdStart : (components : object_path array, options : string array) -> (device : object_path) method LinuxMdCreate : (components : object_path array, level : string, stripe_size : uint64, name : string, options : string array) -> (device : object_path) method Inhibit : () -> (cookie : string) method Uninhibit : (cookie : string) -> () signal DeviceAdded : (device : object_path) signal DeviceRemoved : (device : object_path) signal DeviceChanged : (device : object_path) signal DeviceJobChanged : (device : object_path, job_in_progress : boolean, job_is_cancellable : boolean, job_id : string, job_num_tasks : int32, job_cur_task : int32, job_cur_task_id : string, job_cur_task_percentage : double) signal AdapterAdded : (adapter : object_path) signal AdapterRemoved : (adapter : object_path) signal AdapterChanged : (adapter : object_path) signal ExpanderAdded : (expander : object_path) signal ExpanderRemoved : (expander : object_path) signal ExpanderChanged : (expander : object_path) signal PortAdded : (port : object_path) signal PortRemoved : (port : object_path) signal PortChanged : (port : object_path) property_r DaemonVersion : string property_r DaemonIsInhibited : boolean property_r SupportsLuksDevices : boolean property_r KnownFilesystems : (string * string * boolean * boolean * boolean * uint32 * boolean * boolean * boolean * boolean * boolean * boolean * boolean * boolean) array } interface org.freedesktop.UDisks.Adapter { signal Changed : () property_r NativePath : string property_r Vendor : string property_r Model : string property_r Driver : string property_r NumPorts : uint32 property_r Fabric : string } interface org.freedesktop.UDisks.Device { method JobCancel : () -> () method PartitionTableCreate : (scheme : string, options : string array) -> () method PartitionDelete : (options : string array) -> () method PartitionCreate : (offset : uint64, size : uint64, type : string, label : string, flags : string array, options : string array, fstype : string, fsoptions : string array) -> (created_device : object_path) method PartitionModify : (type : string, label : string, flags : string array) -> () method FilesystemCreate : (fstype : string, options : string array) -> () method FilesystemSetLabel : (new_label : string) -> () method FilesystemMount : (filesystem_type : string, options : string array) -> (mount_path : string) method FilesystemUnmount : (options : string array) -> () method FilesystemCheck : (options : string array) -> (is_clean : boolean) method FilesystemListOpenFiles : () -> (processes : (uint32 * uint32 * string) array) method LuksUnlock : (passphrase : string, options : string array) -> (cleartext_device : object_path) method LuksLock : (options : string array) -> () method LuksChangePassphrase : (current_passphrase : string, new_passphrase : string) -> () method LinuxMdAddSpare : (component : object_path, options : string array) -> () method LinuxMdExpand : (components : object_path array, options : string array) -> () method LinuxMdRemoveComponent : (component : object_path, options : string array) -> () method LinuxMdStop : (options : string array) -> () method LinuxLvm2LVStop : (options : string array) -> () method LinuxMdCheck : (options : string array) -> (number_of_errors : uint64) method DriveInhibitPolling : (options : string array) -> (cookie : string) method DriveUninhibitPolling : (cookie : string) -> () method DrivePollMedia : () -> () method DriveEject : (options : string array) -> () method DriveDetach : (options : string array) -> () method DriveSetSpindownTimeout : (timeout_seconds : int32, options : string array) -> (cookie : string) method DriveUnsetSpindownTimeout : (cookie : string) -> () method DriveAtaSmartRefreshData : (options : string array) -> () method DriveAtaSmartInitiateSelftest : (test : string, options : string array) -> () method DriveBenchmark : (do_write_benchmark : boolean, options : string array) -> (read_transfer_rate_results : (uint64 * double) array, write_transfer_rate_results : (uint64 * double) array, access_time_results : (uint64 * double) array) signal Changed : () signal JobChanged : (job_in_progress : boolean, job_is_cancellable : boolean, job_id : string, job_initiated_by_uid : uint32, job_percentage : double) property_r NativePath : string property_r DeviceDetectionTime : uint64 property_r DeviceMediaDetectionTime : uint64 property_r DeviceMajor : int64 property_r DeviceMinor : int64 property_r DeviceFile : string property_r DeviceFilePresentation : string property_r DeviceFileById : string array property_r DeviceFileByPath : string array property_r DeviceIsSystemInternal : boolean property_r DeviceIsPartition : boolean property_r DeviceIsPartitionTable : boolean property_r DeviceIsRemovable : boolean property_r DeviceIsMediaAvailable : boolean property_r DeviceIsMediaChangeDetected : boolean property_r DeviceIsMediaChangeDetectionPolling : boolean property_r DeviceIsMediaChangeDetectionInhibitable : boolean property_r DeviceIsMediaChangeDetectionInhibited : boolean property_r DeviceIsReadOnly : boolean property_r DeviceIsDrive : boolean property_r DeviceIsOpticalDisc : boolean property_r DeviceIsMounted : boolean property_r DeviceMountPaths : string array property_r DeviceMountedByUid : uint32 property_r DeviceIsLuks : boolean property_r DeviceIsLuksCleartext : boolean property_r DeviceIsLinuxMdComponent : boolean property_r DeviceIsLinuxMd : boolean property_r DeviceIsLinuxLvm2LV : boolean property_r DeviceIsLinuxLvm2PV : boolean property_r DeviceIsLinuxDmmpComponent : boolean property_r DeviceIsLinuxDmmp : boolean property_r DeviceIsLinuxLoop : boolean property_r DeviceSize : uint64 property_r DeviceBlockSize : uint64 property_r DevicePresentationHide : boolean property_r DevicePresentationNopolicy : boolean property_r DevicePresentationName : string property_r DevicePresentationIconName : string property_r JobInProgress : boolean property_r JobId : string property_r JobInitiatedByUid : uint32 property_r JobIsCancellable : boolean property_r JobPercentage : double property_r IdUsage : string property_r IdType : string property_r IdVersion : string property_r IdUuid : string property_r IdLabel : string property_r LuksHolder : object_path property_r LuksCleartextSlave : object_path property_r LuksCleartextUnlockedByUid : uint32 property_r PartitionSlave : object_path property_r PartitionScheme : string property_r PartitionType : string property_r PartitionLabel : string property_r PartitionUuid : string property_r PartitionFlags : string array property_r PartitionNumber : int32 property_r PartitionOffset : uint64 property_r PartitionSize : uint64 property_r PartitionAlignmentOffset : uint64 property_r PartitionTableScheme : string property_r PartitionTableCount : int32 property_r DriveVendor : string property_r DriveModel : string property_r DriveRevision : string property_r DriveSerial : string property_r DriveWwn : string property_r DriveRotationRate : uint32 property_r DriveWriteCache : string property_r DriveConnectionInterface : string property_r DriveConnectionSpeed : uint64 property_r DriveMediaCompatibility : string array property_r DriveMedia : string property_r DriveIsMediaEjectable : boolean property_r DriveCanDetach : boolean property_r DriveCanSpindown : boolean property_r DriveIsRotational : boolean property_r DriveAdapter : object_path property_r DrivePorts : object_path array property_r DriveSimilarDevices : object_path array property_r OpticalDiscIsBlank : boolean property_r OpticalDiscIsAppendable : boolean property_r OpticalDiscIsClosed : boolean property_r OpticalDiscNumTracks : uint32 property_r OpticalDiscNumAudioTracks : uint32 property_r OpticalDiscNumSessions : uint32 property_r DriveAtaSmartIsAvailable : boolean property_r DriveAtaSmartTimeCollected : uint64 property_r DriveAtaSmartStatus : string property_r DriveAtaSmartBlob : byte array property_r LinuxMdComponentLevel : string property_r LinuxMdComponentPosition : int32 property_r LinuxMdComponentNumRaidDevices : int32 property_r LinuxMdComponentUuid : string property_r LinuxMdComponentName : string property_r LinuxMdComponentHomeHost : string property_r LinuxMdComponentVersion : string property_r LinuxMdComponentHolder : object_path property_r LinuxMdComponentState : string array property_r LinuxMdState : string property_r LinuxMdLevel : string property_r LinuxMdUuid : string property_r LinuxMdHomeHost : string property_r LinuxMdName : string property_r LinuxMdNumRaidDevices : int32 property_r LinuxMdVersion : string property_r LinuxMdSlaves : object_path array property_r LinuxMdIsDegraded : boolean property_r LinuxMdSyncAction : string property_r LinuxMdSyncPercentage : double property_r LinuxMdSyncSpeed : uint64 property_r LinuxLvm2PVUuid : string property_r LinuxLvm2PVNumMetadataAreas : uint32 property_r LinuxLvm2PVGroupName : string property_r LinuxLvm2PVGroupUuid : string property_r LinuxLvm2PVGroupSize : uint64 property_r LinuxLvm2PVGroupUnallocatedSize : uint64 property_r LinuxLvm2PVGroupSequenceNumber : uint64 property_r LinuxLvm2PVGroupExtentSize : uint64 property_r LinuxLvm2PVGroupPhysicalVolumes : string array property_r LinuxLvm2PVGroupLogicalVolumes : string array property_r LinuxLvm2LVName : string property_r LinuxLvm2LVUuid : string property_r LinuxLvm2LVGroupName : string property_r LinuxLvm2LVGroupUuid : string property_r LinuxDmmpComponentHolder : object_path property_r LinuxDmmpName : string property_r LinuxDmmpSlaves : object_path array property_r LinuxDmmpParameters : string property_r LinuxLoopFilename : string } interface org.freedesktop.UDisks.Expander { signal Changed : () property_r NativePath : string property_r Vendor : string property_r Model : string property_r Revision : string property_r NumPorts : uint32 property_r UpstreamPorts : object_path array property_r Adapter : object_path } interface org.freedesktop.UDisks.Port { signal Changed : () property_r NativePath : string property_r Adapter : object_path property_r Parent : object_path property_r Number : int32 property_r ConnectorType : string } obus-1.2.5/bindings/udisks/uDisks_monitor.ml000066400000000000000000000017401456737751200211540ustar00rootroot00000000000000(* * uDisks_monitor.ml * ----------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt_react open Lwt module String_map = Map.Make(String) let changed interface = OBus_member.Signal.make ~interface ~member:"Changed" ~args:OBus_value.arg0 ~annotations:[] let monitor proxy interface switch = let%lwt event = OBus_signal.connect ~switch (OBus_signal.with_context (OBus_signal.make (changed interface) proxy)) and context, dict = OBus_property.get_all_no_cache proxy interface in return (S.hold ~eq:(String_map.equal (=)) (OBus_property.map_of_list context dict) (E.map_s (fun (context, ()) -> let%lwt context, dict = OBus_property.get_all_no_cache proxy interface in return (OBus_property.map_of_list context dict)) event)) obus-1.2.5/bindings/udisks/uDisks_monitor.mli000066400000000000000000000005011456737751200213170ustar00rootroot00000000000000(* * uDisks_monitor.mli * ------------------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Properties monitoring *) val monitor : OBus_property.monitor (** Monitor for properties of udisk interfaces. *) obus-1.2.5/bindings/udisks/uDisks_port.ml000066400000000000000000000023011456737751200204430ustar00rootroot00000000000000(* * uDisks_port.ml * -------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) include OBus_proxy.Private open UDisks_interfaces.Org_freedesktop_UDisks_Port let changed proxy = OBus_signal.make s_Changed proxy let native_path proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_NativePath proxy let adapter proxy = OBus_property.map_r_with_context (fun context x -> UDisks_adapter.of_proxy (OBus_proxy.make (OBus_context.sender context) x)) (OBus_property.make ~monitor:UDisks_monitor.monitor p_Adapter proxy) let parent proxy = OBus_property.map_r_with_context (fun context x -> UDisks_adapter.of_proxy (OBus_proxy.make (OBus_context.sender context) x)) (OBus_property.make ~monitor:UDisks_monitor.monitor p_Parent proxy) let number proxy = OBus_property.map_r (fun x -> Int32.to_int x) (OBus_property.make ~monitor:UDisks_monitor.monitor p_Number proxy) let connector_type proxy = OBus_property.make ~monitor:UDisks_monitor.monitor p_ConnectorType proxy let properties proxy = OBus_property.group ~monitor:UDisks_monitor.monitor proxy interface obus-1.2.5/bindings/udisks/uDisks_port.mli000066400000000000000000000011471456737751200206230ustar00rootroot00000000000000(* * uDisks_port.mli * --------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** UDisks port interface *) include OBus_proxy.Private (** {6 Signals} *) val changed : t -> unit OBus_signal.t (** {6 Properties} *) val connector_type : t -> string OBus_property.r val number : t -> int OBus_property.r val parent : t -> UDisks_adapter.t OBus_property.r val adapter : t -> UDisks_adapter.t OBus_property.r val native_path : t -> string OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/upower/000077500000000000000000000000001456737751200156265ustar00rootroot00000000000000obus-1.2.5/bindings/upower/dune000066400000000000000000000004641456737751200165100ustar00rootroot00000000000000(library (name obus_upower) (public_name obus.upower) (wrapped false) (libraries lwt obus) (preprocess (pps lwt_ppx ppx_obus))) (rule (targets uPower_interfaces.ml uPower_interfaces.mli) (deps uPower_interfaces.obus) (action (run obus-gen-interface -keep-common -o uPower_interfaces %{deps}))) obus-1.2.5/bindings/upower/uPower.ml000066400000000000000000000057111456737751200174450ustar00rootroot00000000000000(* * uPower.ml * --------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt include OBus_peer.Private let general_error = "org.freedesktop.UPower.GeneralError" let daemon () = let%lwt bus = OBus_bus.system () in return (OBus_peer.make bus "org.freedesktop.UPower") open UPower_interfaces.Org_freedesktop_UPower let proxy daemon = OBus_proxy.make daemon ["org"; "freedesktop"; "UPower"] let enumerate_devices daemon = let%lwt (context, devices) = OBus_method.call_with_context m_EnumerateDevices (proxy daemon) () in return (List.map (fun path -> UPower_device.of_proxy (OBus_proxy.make (OBus_context.sender context) path)) devices) let device_added daemon = OBus_signal.map_with_context (fun context device -> UPower_device.of_proxy (OBus_proxy.make (OBus_context.sender context) (OBus_path.of_string device))) (OBus_signal.make s_DeviceAdded (proxy daemon)) let device_removed daemon = OBus_signal.map_with_context (fun context device -> UPower_device.of_proxy (OBus_proxy.make (OBus_context.sender context) (OBus_path.of_string device))) (OBus_signal.make s_DeviceRemoved (proxy daemon)) let device_changed daemon = OBus_signal.map_with_context (fun context device -> UPower_device.of_proxy (OBus_proxy.make (OBus_context.sender context) (OBus_path.of_string device))) (OBus_signal.make s_DeviceChanged (proxy daemon)) let changed daemon = OBus_signal.make s_Changed (proxy daemon) let sleeping daemon = OBus_signal.make s_Sleeping (proxy daemon) let resuming daemon = OBus_signal.make s_Resuming (proxy daemon) let about_to_sleep daemon = OBus_method.call m_AboutToSleep (proxy daemon) () let suspend daemon = OBus_method.call m_Suspend (proxy daemon) () let suspend_allowed daemon = OBus_method.call m_SuspendAllowed (proxy daemon) () let hibernate daemon = OBus_method.call m_Hibernate (proxy daemon) () let hibernate_allowed daemon = OBus_method.call m_HibernateAllowed (proxy daemon) () let daemon_version daemon = OBus_property.make ~monitor:UPower_monitor.monitor p_DaemonVersion (proxy daemon) let can_suspend daemon = OBus_property.make ~monitor:UPower_monitor.monitor p_CanSuspend (proxy daemon) let can_hibernate daemon = OBus_property.make ~monitor:UPower_monitor.monitor p_CanHibernate (proxy daemon) let on_battery daemon = OBus_property.make ~monitor:UPower_monitor.monitor p_OnBattery (proxy daemon) let on_low_battery daemon = OBus_property.make ~monitor:UPower_monitor.monitor p_OnLowBattery (proxy daemon) let lid_is_closed daemon = OBus_property.make ~monitor:UPower_monitor.monitor p_LidIsClosed (proxy daemon) let lid_is_present daemon = OBus_property.make ~monitor:UPower_monitor.monitor p_LidIsPresent (proxy daemon) let properties daemon = OBus_property.group ~monitor:UPower_monitor.monitor (proxy daemon) interface obus-1.2.5/bindings/upower/uPower.mli000066400000000000000000000024521456737751200176150ustar00rootroot00000000000000(* * uPower.mli * ---------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** UPower main interface *) include OBus_peer.Private val daemon : unit -> t Lwt.t (** [daemon ()] returns the peer object for the upower daemon *) val general_error : OBus_error.name (** {6 Methods} *) val hibernate_allowed : t -> bool Lwt.t val hibernate : t -> unit Lwt.t val suspend_allowed : t -> bool Lwt.t val suspend : t -> unit Lwt.t val about_to_sleep : t -> unit Lwt.t val enumerate_devices : t -> UPower_device.t list Lwt.t (** {6 Signals} *) val resuming : t -> unit OBus_signal.t val sleeping : t -> unit OBus_signal.t val changed : t -> unit OBus_signal.t val device_changed : t -> UPower_device.t OBus_signal.t val device_removed : t -> UPower_device.t OBus_signal.t val device_added : t -> UPower_device.t OBus_signal.t (** {6 Properties} *) val lid_is_present : t -> bool OBus_property.r val lid_is_closed : t -> bool OBus_property.r val on_low_battery : t -> bool OBus_property.r val on_battery : t -> bool OBus_property.r val can_hibernate : t -> bool OBus_property.r val can_suspend : t -> bool OBus_property.r val daemon_version : t -> string OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/upower/uPower_device.ml000066400000000000000000000115371456737751200207670ustar00rootroot00000000000000(* * uPower_device.ml * ---------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt include OBus_proxy.Private let general_error = "org.freedesktop.UPower.Device.GeneralError" type typ = [ `Unknown | `Line_power | `Battery | `Ups | `Monitor | `Mouse | `Keyboard | `Pda | `Phone ] type state = [ `Unknown | `Charging | `Discharging | `Empty | `Fully_charged | `Pending_charge | `Pending_discharge ] type technology = [ `Unknown | `Lithium_ion | `Lithium_polymer | `Lithium_iron_phosphate | `Lead_acid | `Nickel_cadmium | `Nickel_metal_hydride ] open UPower_interfaces.Org_freedesktop_UPower_Device let refresh proxy = OBus_method.call m_Refresh proxy () let changed proxy = OBus_signal.make s_Changed proxy let get_history proxy ~typ ~timespan ~resolution = let timespan = Int32.of_int timespan in let resolution = Int32.of_int resolution in let%lwt data = OBus_method.call m_GetHistory proxy (typ, timespan, resolution) in let data = List.map (fun (x1, x2, x3) -> (Int32.to_int x1, x2, Int32.to_int x3)) data in return data let get_statistics proxy ~typ = OBus_method.call m_GetStatistics proxy typ let native_path proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_NativePath proxy let vendor proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_Vendor proxy let model proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_Model proxy let serial proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_Serial proxy let update_time proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_UpdateTime proxy let typ proxy = OBus_property.map_r (function | 0l -> `Unknown | 1l -> `Line_power | 2l -> `Battery | 3l -> `Ups | 4l -> `Monitor | 5l -> `Mouse | 6l -> `Keyboard | 7l -> `Pda | 8l -> `Phone | n -> Printf.ksprintf failwith "invalid device type: %ld" n) (OBus_property.make ~monitor:UPower_monitor.monitor p_Type proxy) let power_supply proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_PowerSupply proxy let has_history proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_HasHistory proxy let has_statistics proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_HasStatistics proxy let online proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_Online proxy let energy proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_Energy proxy let energy_empty proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_EnergyEmpty proxy let energy_full proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_EnergyFull proxy let energy_full_design proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_EnergyFullDesign proxy let energy_rate proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_EnergyRate proxy let voltage proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_Voltage proxy let time_to_empty proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_TimeToEmpty proxy let time_to_full proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_TimeToFull proxy let percentage proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_Percentage proxy let is_present proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_IsPresent proxy let state proxy = OBus_property.map_r (function | 0l -> `Unknown | 1l -> `Charging | 2l -> `Discharging | 3l -> `Empty | 4l -> `Fully_charged | 5l -> `Pending_charge | 6l -> `Pending_discharge | n -> Printf.ksprintf failwith "invalid device state: %ld" n) (OBus_property.make ~monitor:UPower_monitor.monitor p_State proxy) let is_rechargeable proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_IsRechargeable proxy let capacity proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_Capacity proxy let technology proxy = OBus_property.map_r (function | 0l -> `Unknown | 1l -> `Lithium_ion | 2l -> `Lithium_polymer | 3l -> `Lithium_iron_phosphate | 4l -> `Lead_acid | 5l -> `Nickel_cadmium | 6l -> `Nickel_metal_hydride | n -> Printf.ksprintf failwith "invalid technolofy number: %ld" n) (OBus_property.make ~monitor:UPower_monitor.monitor p_Technology proxy) let recall_notice proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_RecallNotice proxy let recall_vendor proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_RecallVendor proxy let recall_url proxy = OBus_property.make ~monitor:UPower_monitor.monitor p_RecallUrl proxy let properties proxy = OBus_property.group ~monitor:UPower_monitor.monitor proxy interface obus-1.2.5/bindings/upower/uPower_device.mli000066400000000000000000000045611456737751200211370ustar00rootroot00000000000000(* * uPower_device.mli * ----------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** UPower device interface *) include OBus_proxy.Private (** {6 Types} *) (** Type of power source *) type typ = [ `Unknown | `Line_power | `Battery | `Ups | `Monitor | `Mouse | `Keyboard | `Pda | `Phone ] (** The battery power state *) type state = [ `Unknown | `Charging | `Discharging | `Empty | `Fully_charged | `Pending_charge | `Pending_discharge ] (** Technology used in the battery *) type technology = [ `Unknown | `Lithium_ion | `Lithium_polymer | `Lithium_iron_phosphate | `Lead_acid | `Nickel_cadmium | `Nickel_metal_hydride ] val general_error : OBus_error.name (** {6 Methods} *) val get_statistics : t -> typ : string -> (float * float) list Lwt.t val get_history : t -> typ : string -> timespan : int -> resolution : int -> (int * float * int) list Lwt.t val refresh : t -> unit Lwt.t (** {6 Signals} *) val changed : t -> unit OBus_signal.t (** {6 Properties} *) val recall_url : t -> string OBus_property.r val recall_vendor : t -> string OBus_property.r val recall_notice : t -> bool OBus_property.r val technology : t -> technology OBus_property.r val capacity : t -> float OBus_property.r val is_rechargeable : t -> bool OBus_property.r val state : t -> state OBus_property.r val is_present : t -> bool OBus_property.r val percentage : t -> float OBus_property.r val time_to_full : t -> int64 OBus_property.r val time_to_empty : t -> int64 OBus_property.r val voltage : t -> float OBus_property.r val energy_rate : t -> float OBus_property.r val energy_full_design : t -> float OBus_property.r val energy_full : t -> float OBus_property.r val energy_empty : t -> float OBus_property.r val energy : t -> float OBus_property.r val online : t -> bool OBus_property.r val has_statistics : t -> bool OBus_property.r val has_history : t -> bool OBus_property.r val power_supply : t -> bool OBus_property.r val typ : t -> typ OBus_property.r val update_time : t -> int64 OBus_property.r val serial : t -> string OBus_property.r val model : t -> string OBus_property.r val vendor : t -> string OBus_property.r val native_path : t -> string OBus_property.r val properties : t -> OBus_property.group obus-1.2.5/bindings/upower/uPower_interfaces.obus000066400000000000000000000061231456737751200222060ustar00rootroot00000000000000(* * uPower_interfaces.obus * ---------------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) interface org.freedesktop.UPower { method EnumerateDevices : () -> (devices : object_path array) (* Introspections files are wrong for this signals: signal DeviceAdded : (device : object_path) signal DeviceRemoved : (device : object_path) signal DeviceChanged : (device : object_path) *) signal DeviceAdded : (device : string) signal DeviceRemoved : (device : string) signal DeviceChanged : (device : string) signal Changed : () signal Sleeping : () signal Resuming : () method AboutToSleep : () -> () method Suspend : () -> () method SuspendAllowed : () -> (allowed : boolean) method Hibernate : () -> () method HibernateAllowed : () -> (allowed : boolean) property_r DaemonVersion : string property_r CanSuspend : boolean property_r CanHibernate : boolean property_r OnBattery : boolean property_r OnLowBattery : boolean property_r LidIsClosed : boolean property_r LidIsPresent : boolean } interface org.freedesktop.UPower.Device { method Refresh : () -> () signal Changed : () method GetHistory : (type : string, timespan : uint32, resolution : uint32) -> (data : (uint32 * double * uint32) array) method GetStatistics : (type : string) -> (data : (double * double) array) property_r NativePath : string property_r Vendor : string property_r Model : string property_r Serial : string property_r UpdateTime : uint64 property_r Type : uint32 property_r PowerSupply : boolean property_r HasHistory : boolean property_r HasStatistics : boolean property_r Online : boolean property_r Energy : double property_r EnergyEmpty : double property_r EnergyFull : double property_r EnergyFullDesign : double property_r EnergyRate : double property_r Voltage : double property_r TimeToEmpty : int64 property_r TimeToFull : int64 property_r Percentage : double property_r IsPresent : boolean property_r State : uint32 property_r IsRechargeable : boolean property_r Capacity : double property_r Technology : uint32 property_r RecallNotice : boolean property_r RecallVendor : string property_r RecallUrl : string } interface org.freedesktop.UPower.QoS { method SetMinimumLatency : (type : string, value : int32) -> () method RequestLatency : (type : string, value : int32, persistent : boolean) -> (cookie : uint32) method CancelRequest : (type : string, cookie : uint32) -> () method GetLatency : (type : string) -> (value : int32) signal LatencyChanged : (type : string, value : int32) method GetLatencyRequests : () -> (requests : (uint32 * uint32 * uint32 * string * int64 * boolean * string * string * int32) array) signal RequestsChanged : () } interface org.freedesktop.UPower.Wakeups { property_r HasCapability : boolean method GetTotal : () -> (value : uint32) signal TotalChanged : (value : uint32) method GetData : () -> (data : (boolean * uint32 * double * string * string) array) signal DataChanged : () } obus-1.2.5/bindings/upower/uPower_monitor.ml000066400000000000000000000017401456737751200212120ustar00rootroot00000000000000(* * uPower_monitor.ml * ----------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt_react open Lwt module String_map = Map.Make(String) let changed interface = OBus_member.Signal.make ~interface ~member:"Changed" ~args:OBus_value.arg0 ~annotations:[] let monitor proxy interface switch = let%lwt event = OBus_signal.connect ~switch (OBus_signal.with_context (OBus_signal.make (changed interface) proxy)) and context, dict = OBus_property.get_all_no_cache proxy interface in return (S.hold ~eq:(String_map.equal (=)) (OBus_property.map_of_list context dict) (E.map_s (fun (context, ()) -> let%lwt context, dict = OBus_property.get_all_no_cache proxy interface in return (OBus_property.map_of_list context dict)) event)) obus-1.2.5/bindings/upower/uPower_monitor.mli000066400000000000000000000005021456737751200213560ustar00rootroot00000000000000(* * uPower_monitor.mli * ------------------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Properties monitoring *) val monitor : OBus_property.monitor (** Monitor for properties of upower interfaces. *) obus-1.2.5/bindings/upower/uPower_policy.ml000066400000000000000000000047061456737751200210270ustar00rootroot00000000000000(* * uPower_policy.ml * ---------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt type cookie = int type latency = [ `Cpu_dma | `Network ] let string_of_latency = function | `Cpu_dma -> "cpu_dma" | `Network -> "network" let latency_of_string = function | "cpu_dma" -> `Cpu_dma | "network" -> `Network | latency -> Printf.ksprintf failwith "unknown latency type (%S)" latency type latency_request = { lr_cookie : cookie; lr_uid : int; lr_pid : int; lr_exec : string; lr_timespec : int64; lr_persistent : bool; lr_typ : latency; lr_reserved : string; lr_value : int; } open UPower_interfaces.Org_freedesktop_UPower_QoS let proxy daemon = OBus_proxy.make (UPower.to_peer daemon) ["org"; "freedesktop"; "UPower"; "Policy"] let set_minimum_latency daemon ~latency ~value = OBus_method.call m_SetMinimumLatency (proxy daemon) (string_of_latency latency, Int32.of_int value) let request_latency daemon ~latency ~value ~persistent = let value = Int32.of_int value in let%lwt cookie = OBus_method.call m_RequestLatency (proxy daemon) (string_of_latency latency, value, persistent) in let cookie = Int32.to_int cookie in return cookie let cancel_request daemon ~latency ~cookie = let cookie = Int32.of_int cookie in OBus_method.call m_CancelRequest (proxy daemon) (string_of_latency latency, cookie) let get_latency daemon ~latency = let%lwt value = OBus_method.call m_GetLatency (proxy daemon) (string_of_latency latency) in let value = Int32.to_int value in return value let latency_changed daemon = OBus_signal.map (fun (latency, value) -> (latency_of_string latency, Int32.to_int value)) (OBus_signal.make s_LatencyChanged (proxy daemon)) let get_latency_requests daemon = let%lwt requests = OBus_method.call m_GetLatencyRequests (proxy daemon) () in return (List.map (fun (cookie, uid, pid, exec, timespec, persistent, typ, reserved, value) -> { lr_cookie = Int32.to_int cookie; lr_uid = Int32.to_int uid; lr_pid = Int32.to_int pid; lr_exec = exec; lr_timespec = timespec; lr_persistent = persistent; lr_typ = latency_of_string typ; lr_reserved = reserved; lr_value = Int32.to_int value; }) requests) let requests_changed daemon = OBus_signal.make s_RequestsChanged (proxy daemon) obus-1.2.5/bindings/upower/uPower_policy.mli000066400000000000000000000030371456737751200211740ustar00rootroot00000000000000(* * uPower_policy.mli * ----------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Quality of service policy *) (** {6 Types} *) type cookie (** Type of request identifiers *) type latency = [ `Cpu_dma | `Network ] (** Type of latency request *) type latency_request = { lr_cookie : cookie; (** The random cookie that identifies the request. *) lr_uid : int; (** The user ID that issued the request. *) lr_pid : int; (** The process ID of the application. *) lr_exec : string; (** The executable that issued the request. *) lr_timespec : int64; (** The number of seconds since the epoch. *) lr_persistent : bool; (** If the request is persistent and outlives the connection lifetime. *) lr_typ : latency; (** The type of the request.*) lr_reserved : string; lr_value : int; (** The value, in microseconds or kilobits per second. *) } (** {6 Methods} *) val get_latency_requests : UPower.t -> latency_request list Lwt.t val get_latency : UPower.t -> latency : latency -> int Lwt.t val request_latency : UPower.t -> latency : latency -> value : int -> persistent : bool -> cookie Lwt.t val cancel_request : UPower.t -> latency : latency -> cookie : cookie -> unit Lwt.t val set_minimum_latency : UPower.t -> latency : latency -> value : int -> unit Lwt.t (** {6 Signals} *) val requests_changed : UPower.t -> unit OBus_signal.t val latency_changed : UPower.t -> (latency * int) OBus_signal.t obus-1.2.5/bindings/upower/uPower_wakeups.ml000066400000000000000000000025561456737751200212100ustar00rootroot00000000000000(* * uPower_wakeups.ml * ----------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt type data = { data_is_userspace : bool; data_id : int; data_value : float; data_cmdline : string option; data_details : string; } open UPower_interfaces.Org_freedesktop_UPower_Wakeups let proxy daemon = OBus_proxy.make (UPower.to_peer daemon) ["org"; "freedesktop"; "UPower"; "Wakeups"] let has_capability daemon = OBus_property.make p_HasCapability (proxy daemon) let get_total daemon = let%lwt value = OBus_method.call m_GetTotal (proxy daemon) () in let value = Int32.to_int value in return value let total_changed daemon = OBus_signal.map (fun value -> let value = Int32.to_int value in value) (OBus_signal.make s_TotalChanged (proxy daemon)) let get_data daemon = let%lwt data = OBus_method.call m_GetData (proxy daemon) () in return (List.map (fun (is_userspace, id, value, cmdline, details) -> { data_is_userspace = is_userspace; data_id = Int32.to_int id; data_value = value; data_cmdline = if cmdline = "" then None else Some cmdline; data_details = details; }) data) let data_changed daemon = OBus_signal.make s_DataChanged (proxy daemon) obus-1.2.5/bindings/upower/uPower_wakeups.mli000066400000000000000000000020771456737751200213570ustar00rootroot00000000000000(* * uPower_wakeups.mli * ------------------ * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** UPower wakeups interface *) (** {6 Types} *) (** The data of all the processes and drivers which contribute to the wakeups on the system. *) type data = { data_is_userspace : bool; (** If the wakeup is from userspace ? *) data_id : int; (** The process ID of the application, or the IRQ for kernel drivers. *) data_value : float; (** The number of wakeups per second. *) data_cmdline : string option; (** The command line for the application, or [None] for kernel drivers. *) data_details : string; (** The details about the wakeup. *) } (** {6 Methods} *) val get_data : UPower.t -> data list Lwt.t val get_total : UPower.t -> int Lwt.t (** {6 Signals} *) val data_changed : UPower.t -> unit OBus_signal.t val total_changed : UPower.t -> int OBus_signal.t (** {6 Properties} *) val has_capability : UPower.t -> bool OBus_property.r obus-1.2.5/docs/000077500000000000000000000000001456737751200134405ustar00rootroot00000000000000obus-1.2.5/docs/apiref-intro000066400000000000000000000030341456737751200157620ustar00rootroot00000000000000{1 OBus - API Reference} {2 OBus library} This section describe modules of the core OBus library. OBus is composed of a lot of modules, but you will usually need only a few of them. {3 Connections and message Buses} {!modules: OBus_bus OBus_connection OBus_server } {3 D-Bus objects} {!modules: OBus_proxy OBus_object OBus_method OBus_signal OBus_property OBus_member } {3 Introspection} {!modules: OBus_introspect OBus_introspect_ext } {3 Misc} {!modules: OBus_error OBus_value OBus_resolver OBus_peer OBus_info OBus_name OBus_path OBus_string OBus_uuid OBus_context } {3 OBus low-level API} {!modules: OBus_match OBus_message OBus_address OBus_auth OBus_transport OBus_wire } {2 Service bindings} This section list bindings to D-Bus services shipped with OBus. {3 Notifications} Bindings to the freedesktop popup notification service. {!modules: Notification } {3 PolicyKit} Bindings to the freedesktop popup PolicyKit service. {!modules: Policy_kit } {3 Hal} Bindings to the freedesktop Hal service. {!modules: Hal_manager Hal_device } {3 UPower} Bindings to the freedesktop UPower service. {!modules: UPower UPower_device UPower_policy UPower_wakeups } {3 UPower} Bindings to the freedesktop UDisks service. {!modules: UDisks UDisks_device UDisks_port UDisks_adapter UDisks_expander } {3 NetworkManager} Bindings to the NetworkManager service. {!modules: Nm_access_point Nm_connection Nm_device Nm_dhcp4_config Nm_ip4_config Nm_ip6_config Nm_manager Nm_ppp Nm_settings Nm_vpn_connection Nm_vpn_plugin } {3 Index} {!indexlist} obus-1.2.5/docs/man/000077500000000000000000000000001456737751200142135ustar00rootroot00000000000000obus-1.2.5/docs/man/dune000066400000000000000000000002641456737751200150730ustar00rootroot00000000000000(install (section man) (files obus-dump.1 obus-gen-client.1 obus-gen-interface.1 obus-gen-server.1 obus-idl2xml.1 obus-introspect.1 obus-xml2idl.1))obus-1.2.5/docs/man/obus-dump.1000066400000000000000000000013261456737751200162120ustar00rootroot00000000000000\" obus-dump.1 \" ----------- \" Copyright : (c) 2009, Jeremie Dimino \" Licence : BSD3 \" \" This file is a part of obus, an ocaml implementation of D-Bus. .TH OBUS-DUMP 1 "October 2009" .SH NAME obus-dump \- a D-Bus message dumper .SH SYNOPSIS .B obus-dump [ .I options ] .I command [ .I arguments ] .SH DESCRIPTION .B obus-dump allows you to run a command and dumps all messages it tries to send through the session or system bus. .SH OPTIONS .IP "-o output-file" Uses .I output-file as output file instead of stderr. .IP "-help or --help" Display a short usage summary and exit. .SH AUTHOR Jérémie Dimino .SH "SEE ALSO" .BR obus-introspect (1), .BR obus-binder (1). obus-1.2.5/docs/man/obus-gen-client.1000066400000000000000000000024221456737751200172700ustar00rootroot00000000000000\" obus-gen-client.1 \" ----------------- \" Copyright : (c) 2010, Jeremie Dimino \" Licence : BSD3 \" .TH OBUS-GEN-CLIENT 1 "April 2010" .SH NAME obus-gen-client \- generate client-side ocaml bindings from D-Bus introspection files .SH SYNOPSIS .B obus-gen-client [ .I options ] .I input-file .SH DESCRIPTION .B obus-gen-client generates an ocaml module from D-Bus introspection files. The generated module contains functions to send method calls, receive signals and read/write properties. It depends on the interface module generated with .B obus-gen-interface. The module generated by .B obus-gen-client it is meant to be edited. .SH OPTIONS .IP "-o output-prefix" Use this name as output prefix. It defaults to the input file name without its extension and extended with "_client". For example, if the input file name is "foo.xml" (or "foo.obus"), then "obus-gen-client" will generate "foo_client.ml" and "foo_client.mli". .IP "-keep-common" Keeps common interfaces, i.e. all interfaces starting with "org.freedesktop.DBus". By default they are dropped. .IP "-help or --help" Display a short usage summary and exit. .SH AUTHOR Jérémie Dimino .SH "SEE ALSO" .BR obus-introspect (1), .BR obus-gen-interface (1), .BR obus-gen-server (1). obus-1.2.5/docs/man/obus-gen-interface.1000066400000000000000000000031361456737751200177550ustar00rootroot00000000000000\" obus-gen-interface.1 \" -------------------- \" Copyright : (c) 2010, Jeremie Dimino \" Licence : BSD3 \" \" This file is a part of obus, an ocaml implementation of D-Bus. .TH OBUS-GEN-INTERFACE 1 "April 2010" .SH NAME obus-gen-interface \- convert D-Bus introspection files to ocaml code .SH SYNOPSIS .B obus-gen-interface [ .I options ] .I input-file .SH DESCRIPTION .B obus-gen-interface generates an OCaml module from a D-Bus introspection file. The generated module contains methods, signals and properties definitions. It is required for by both client-side and server-side code. Note that the files generated by .B obus-gen-interface are not meant to be edited. .SH OPTIONS .IP "-o output-prefix" Use this name as output prefix. It defaults to the input file name without its extension and extended with "_interfaces". For example, if the input file name is "foo.xml" (or "foo.obus"), then "obus-gen-interface" will generate "foo_interfaces.ml" and "foo_interfaces.mli". .IP "-keep-common" Keeps common interfaces, i.e. all interfaces starting with "org.freedesktop.DBus". By default they are dropped. .IP "-mode {both|client|server}" Set the code generation mode. It defaults to "both". In "client" mode, only code for client-side use is generated. In "server" mode, only code for server-side use is generated. In "both" mode, code for client-side and server-side use is generated. .IP "-help or --help" Display a short usage summary and exit. .SH AUTHOR Jérémie Dimino .SH "SEE ALSO" .BR obus-introspect (1), .BR obus-gen-client (1), .BR obus-gen-server (1). obus-1.2.5/docs/man/obus-gen-server.1000066400000000000000000000024521456737751200173230ustar00rootroot00000000000000\" obus-gen-server.1 \" ----------------- \" Copyright : (c) 2010, Jeremie Dimino \" Licence : BSD3 \" .TH OBUS-GEN-SERVER 1 "April 2010" .SH NAME obus-gen-server \- generate server-side ocaml bindings from D-Bus introspection files .SH SYNOPSIS .B obus-gen-server [ .I options ] .I input-files .SH DESCRIPTION .B obus-gen-server generates an ocaml module from D-Bus introspection files. The generated module contains code for defining a D-Bus service implementing the D-Bus interfaces listed in intropection files. It depends on the interface module generated with .B obus-gen-interface. The module generated by .B obus-gen-server it is meant to be edited. .SH OPTIONS .IP "-o output-prefix" Use this name as output prefix. It defaults to the input file name without its extension and extended with "_server". For example, if the input file name is "foo.xml" (or "foo.obus"), then "obus-gen-server" will generate "foo_server.ml" and "foo_server.mli". .IP "-keep-common" Keeps common interfaces, i.e. all interfaces starting with "org.freedesktop.DBus". By default they are dropped. .IP "-help or --help" Display a short usage summary and exit. .SH AUTHOR Jérémie Dimino .SH "SEE ALSO" .BR obus-introspect (1), .BR obus-gen-interface (1), .BR obus-gen-client (1). obus-1.2.5/docs/man/obus-idl2xml.1000066400000000000000000000012351456737751200166170ustar00rootroot00000000000000\" obus-idl2xml.1 \" -------------- \" Copyright : (c) 2010, Jeremie Dimino \" Licence : BSD3 \" .TH OBUS-IDL2XML 1 "April 2010" .SH NAME obus-idl2xml \- convert an obus IDL file into a D-Bus introspection one .SH SYNOPSIS .B obus-idl2xml [ .I options ] .I input-file .SH DESCRIPTION .B obus-xml2idl generates a D-Bus xml introspection file from an obus IDL one .SH OPTIONS .IP "-o file-name" Use this name as output. It defaults to the input file name with the extension replaced by "xml". .IP "-help or --help" Display a short usage summary and exit. .SH AUTHOR Jérémie Dimino .SH "SEE ALSO" .BR obus-xml2idl. obus-1.2.5/docs/man/obus-introspect.1000066400000000000000000000021011456737751200174270ustar00rootroot00000000000000\" obus-introspect.1 \" ----------------- \" Copyright : (c) 2009, Jeremie Dimino \" Licence : BSD3 \" \" This file is a part of obus, an ocaml implementation of D-Bus. .TH OBUS-INTROSPECT 1 "October 2009" .SH NAME obus-introspect \- a D-Bus introspecter .SH SYNOPSIS .B obus-intrpsoect [ .I options ] .I destination .I path .SH DESCRIPTION .B obus-introspect allow you to introspect a D-Bus service. Given a .B path it can introspect recursively all its children. By default it prints only all the interfaces it found, but it can also prints all object path with the interfaces they implements. .SH OPTIONS .IP -rec Introspects recursively all sub-nodes instead of just the one of .B path .I path .IP -session The service is on the session bus (the default). .IP -system The service is on the system bus. .IP -objects List objects with interfaces they implements instead of interfaces. .IP "-help or --help" Display a short usage summary and exit. .SH AUTHOR Jérémie Dimino .SH "SEE ALSO" .BR obus-dump (1), .BR obus-binder (1). obus-1.2.5/docs/man/obus-xml2idl.1000066400000000000000000000015741456737751200166250ustar00rootroot00000000000000\" obus-xml2idl.1 \" -------------- \" Copyright : (c) 2010, Jeremie Dimino \" Licence : BSD3 \" .TH OBUS-XML2IDL 1 "April 2010" .SH NAME obus-xml2idl \- convert a D-Bus introspection file into an obus IDL one .SH SYNOPSIS .B obus-xml2idl [ .I options ] .I input-file .SH DESCRIPTION .B obus-xml2idl generates an obus IDL file from a D-Bus xml introspection file. THe file can then be used with other obus tools such as .B obus-gen-interface , .B obus-gen-client , .B obus-gen-server . The goal of the obus IDL is to allow you to write D-Bus interface with a syntax lighter than XML. .SH OPTIONS .IP "-o file-name" Use this name as output. It defaults to the input file name with the extension replaced by "obus". .IP "-help or --help" Display a short usage summary and exit. .SH AUTHOR Jérémie Dimino .SH "SEE ALSO" .BR obus-idl2xml. obus-1.2.5/docs/manual/000077500000000000000000000000001456737751200147155ustar00rootroot00000000000000obus-1.2.5/docs/manual/Makefile000066400000000000000000000005321456737751200163550ustar00rootroot00000000000000# Makefile # -------- # Copyright : (c) 2010, Jeremie Dimino # Licence : BSD3 # # This file is a part of obus, an ocaml implementation of D-Bus. .PHONY: all clean clean-aux all: manual.pdf %.pdf: %.tex rubber --pdf $< clean: clean-aux rm -f *.pdf clean-aux: rm -f *.aux *.dvi *.log *.out *.toc *.html *.htoc *.haux obus-1.2.5/docs/manual/manual.rst000066400000000000000000000521221456737751200167260ustar00rootroot00000000000000******** Overview ******** **D-Bus** is an inter-processes communication protocol, or IPC for short, which has recently become a standard on desktop oriented computers. It is now possible to talk to a lot application using dbus. Moreover, it has many bindings/implementations for differents languages, which make it easily accessible. **OBus** is a pure OCaml implementation of this protocol. What makes it different from other bindings/implementations is that it is the only one using cooperative threads, which makes it very simple to fully exploit the asynchronous nature of dbus. The main package of the OBus distribution is the ``obus`` findlib package, which contains the core library and some utilities for generating OCaml client modules from arbitrary dbus services. OBus also comes with some packages containing high level bindings to a few well-known Freedesktop dbus services: - ``obus.hal`` - ``obus.notification`` - ``obus.network-manager`` - ``obus.policykit`` - ``obus.udisks`` - ``obus.upower`` The low-level API is described in the section `Low-level use of OBus`_ of this manual. Note that you must have a good knowledge of dbus to use it effectively. It is recommended to familiarize yourself with the Lwt_ library before using OBus. .. _Lwt: https://ocsigen.org/lwt/ ------------------------------------------ *********** Quick start *********** This section provides simple usage examples of OBus and the utilities it comes with. You can also look at the examples_ directory for more concrete examples. .. _examples: https://github.com/diml/obus/tree/master/docs/examples Using the predefined bindings ----------------------------- The usage of the predefined bindings is straightforward and doesn't require any knowledge of dbus nor OBus. This is a program that opens a popup notification:: let () = Lwt_main.run begin let%lwt id = Notification.notify ~summary:"Hello, world!" () in Lwt.return () end Generating a client OCaml module from a running service ------------------------------------------------------- To use a dbus service, you first have to obtain its interface through its published introspection XML. Some applications put these files into ``/usr/share/dbus-1/interfaces/``, but you can also just directly ask a running service:: $ obus-introspect -rec org.foo.bar / > foo.xml This will recursively introspect the ``org.foo.bar`` service, and dump its interface data into ``foo.xml`` The next step is to generate an OCaml module describing its interface:: $ obus-gen-interface foo.xml This will generate ``foo_interfaces.ml`` and ``foo_interfaces.mli``. The generated interfaces shouldn't be directly edited. Now we can generate the client module:: $ obus-gen-client foo.xml This will generate ``foo_client.ml`` and ``foo_client.mli``. These generated clients can be freely edited, and have to be compiled with the ``lwt_ppx`` syntax extension. Now we can use the ``Foo_client`` module to interact with the service. Methods are mapped to functions returning ``Lwt.t`` wrapped values, signals are mapped to values of type ``OBus_signal.t``, and properties to values of type ``OBus_property.t``. For example:: let () = Lwt_main.run begin (* Connect to the session bus *) let%lwt bus = OBus_bus.session () in (* Create a proxy for a remote object *) let proxy = OBus_proxy.make (OBus_peer.make bus "org.foo.bar") ["org"; "foo"; "bar"] in (* Call a method *) let%lwt result = Foo_client.Org_foo_bar.plop proxy ... in (* Connect to a signal *) let%lwt () = Lwt_react.E.notify (fun args -> ...) =|< OBus_signal.connect (Foo_client.Org_foo_bar.plip proxy) in (* Read the contents of a property *) let%lwt value = OBus_property.get (Foo_client.Org_foo_bar.plap proxy) in ... end ----------------------------------------------- ****** Basics ****** In this section we will describe the minimum you must know to use OBus and interfaces for dbus services written with OBus (like the ones provided in the OBus distribution: ``obus.notification``, ``obus.upower``, ...) Connections and message buses ----------------------------- A ``connection`` is a way of exchanging messages with another application speaking the dbus protocol. Most of the time applications use connection to a special application called a *message bus*. A message bus act as a router between several applications. On a desktop computer, there are two well-known instances: the *system* message bus, and the user *session* message bus. The first one is unique given a computer, and uses security policies. The second is unique given a user session. Its goal is to allow programs running in the same session to talk to each other. OBus offers two function for connecting to these message buses: ``OBus_bus.session`` and ``OBus_bus.system``. The session bus exists for the life-time of a user session. It exits when the session is closed, and any programs using it should exit to, that is why OBus will exit the program when the connection to the session bus is lost. However this behavior can be changed. On the other hand, the system bus can be restarted and programs using it may try to reopen the connection. System-wide application should handle the loss of the connection with the system bus. Here is a small example which connects the session bus and prints its id:: let () = Lwt_main.run begin (* Open a connection to the session message bus: *) let%lwt bus = OBus_bus.session () in (* Obtain its id: *) let%lwt id = OBus_bus.get_id bus in Lwt_io.printlf "The session bus id is %d." (OBus_uuid.to_string id) end Names ----- On a message bus, applications are referenced using names. There is a special category of names called *unique names*. Each time an application connects to a bus, the bus give it a unique name. Unique name are of the form ``:1.42`` and cannot be changed. You can think of a unique name as an *ip* (such as ``192.168.1.42``). Once connected, the unique name can be retrieved with the function ``OBus_bus.name``. Here is a program that prints its own unique name:: let () = Lwt_main.run begin (* Connects to the session bus: *) let%lwt bus = OBus_bus.session () in (* Read our unique name: *) let%lwt name = OBus_bus.name bus in Lwt_io.printlf "My unique connection name is %s." name end Unique names are useful to uniquely identify an application. However, when you want to use a specific service you may prefer using a well-known name such as ``org.freedesktop.Notifications``. D-Bus allows applications to own as many non-unique names as they want. You can think of a non-unique name as an *url* (such as ``obus.forge.ocamlcore.org``). Names can be requested or resolved using functions of the ``OBus_bus`` module. Here is an example:: let () = Lwt_main.run begin let%lwt bus = OBus_bus.session () in let%lwt () = try%lwt (* Try to resolve a name, this may fail if nobody owns it: *) let%lwt owner = OBus_bus.get_name_owner bus "org.freedesktop.Notifications" in Lwt_io.printlf "The owner is %d." with OBus_bus.Name_has_no_owner msg -> Lwt_io.printlf "Cannot resolve the name: %s." msg in (* Request a name: *) OBus_bus.request_name bus "org.foo.bar" >>= function | `Primary_owner -> Lwt_io.printl "I own the name org.foo.bar!" | `In_queue -> Lwt_io.printl "Somebody else owns the name, i am in the queue." | `Exists -> Lwt_io.printl "Somebody else owns the name\ and does not want to lose it :(." | `Already_owner (* Cannot happen *) Lwt_io.printl "I already owns this name." end Note that the ``OBus_resolver`` module offer a better way of resolving names and monitoring name owners. See section `Name Tracking`_ for details. Peers ----- A *peer* represents an application accessible through a dbus connection. To uniquely identify a peer one needs a connection and a name. The module ``OBus_peer`` defines the type type of peers. There are two requests that should be available on all peers: ``ping`` and ``get_machine_id``. The first one just pings the peer to see if it is alive, and the second returns the id of the machine the peer is currently running on. Objects and proxies ------------------- In order to export services, dbus uses the concept of *objects*. An application may holds as many objects as it wants. From the inside of the application, dbus objects are generally mapped to language-native objects. From the outside, objects are refered to though *object-paths*, which looks like ``/org/freedesktop/DBus``. You can think of an object path as a pointer. Objects may have members which are organized by interface (such as ``org.freedesktop.DBus``. There are three types of members: - Methods - Signals - Properties Methods act like functions which can be called by any client. Signals are spontaneous events that may occurs at any time, which clients may register to in order to be notified when they occur. Properties act as variables, which can be read and/or written, and sometimes monitored. In order to uniquely identify an object, we need its path and the peer that owns it. We call such a thing a *proxy*. Proxies are defined in the module ``OBus_proxy`` Here is a simple example of how to call a method on a proxy (we will explain the ``C.seq...`` things later):: open OBus_value let () = Lwt_main.run begin let%lwt bus = OBus_bus.session () in (* Create the peer: *) let%lwt peer = OBus_peer.make ~name:"org.freedesktop.DBus" ~connection:bus in (* Create the proxy: *) let%lwt proxy = OBus_proxy.make ~peer ~path:["org"; "freedesktop"; "DBus"] in (* Call a method: *) let%lwt id = OBus_proxy.call proxy ~interface:"org.freedesktop.DBus" ~member:"GetId" ~i_args:C.seq0 ~o_args:(C.seq1 C.basic_string) () in Lwt_io.printlf "The bus id is: %s" id end -------------------------------------------------- ******************************************************* Interaction between the OCaml world and the D-Bus world ******************************************************* Value mapping ------------- D-Bus defines its own type system, which is used to serialize and deserialize messages. These types are defined in the module ``OBus_value.T``, and dbus values are defined in the module ``OBus_value.V``. When a message is received, its contents are represented as a value of type ``OBus_value.V.sequence``. Similarly, when a message is sent, it is first converted into this format. Manipulating boxed dbus values is not very handy. To make the interaction more transparent, OBus defines a set of type combinators which allow to easily switch between the dbus representation and the OCaml representation. These converters are defined in the module ``OBus_value.C``. Here is an example (in the toplevel):: # open OBus_value;; (* Make a D-Bus value from an ocaml one: *) # C.make_sequence (C.seq2 C.basic_int32 (C.array C.basic_string)) (42l, ["foo"; "bar"]);; - : OBus_value.V.sequence = [OBus_value.V.Basic (OBus_value.V.Int32 42l); OBus_value.V.Array (OBus_value.T.Basic OBus_value.T.String, [OBus_value.V.Basic (OBus_value.V.String "foo"); OBus_value.V.Basic (OBus_value.V.String "bar")])] (* Cast a D-Bus value to an ocaml one: *) # C.cast_sequence (C.seq1 C.basic_string) [V.basic(V.string "foobar")];; - : string = "foobar" (* Try to cast a D-Bus value to an ocaml one with the wrong type: *) # C.cast_sequence (C.seq1 C.basic_string) [V.basic(V.int32 0l)];; Exception: OBus_value.C.Signature_mismatch. Error mapping ------------- A call to a method may fail. In this case the service sends an error to the caller. OCaml exceptions can be mapped to dbus errors with the the ``OBus_error`` module by registering them with the ``OBus_error.Register`` functor. OBus provides a PPX syntax extension to simplify this process:: exception My_exn of string [@@obus "org.foo.bar.MyError"] ----------------------------------------------------- ******************** Using D-Bus services ******************** In this section we describe the canonical way of using a dbus service with OBus. Defining and using members -------------------------- For all types of members (methods, signals and properties), dbus provides types to defines them and functions to use these definitions. A member definition contains all the information about a member. For example, here is the definition of a method call named ``foo`` on interface ``org.foo.bar`` which takes a string and returns an 32-bits signed integer:: open OBus_member let m_Foo = { Method.interface = "org.foo.bar"; Method.member = "Foo"; Method.i_args = C.seq1 C.basic_string; Method.o_args = C.seq1 C.basic_int32; Method.annotations = []; } Once a member is defined, it can be used by the corresponding modules:: open OBus_members (* Definition of a method *) let m_GetId = { Method.interface = "org.freedesktop.DBus"; Method.member = "GetId"; Method.i_args = C.seq0; Method.o_args = C.seq1 C.basic_string; Method.annotations = []; } (* Definition of a signal *) let s_NameAcquired = { Signal.interface = "org.freedesktop.DBus"; Signal.member = "NameAcquired"; Signal.args = C.seq1 (C.basic C.string); Signal.annotations = []; } let () = Lwt_main.run begin let%lwt bus = OBus_bus.session () in let proxy = OBus_proxy.make (OBus_peer.make bus "org.freedesktop.DBus") ["org"; "freedesktop"; "DBus"] in (* Call the method we just defined: *) let%lwt id = OBus_method.call m_GetId proxy () in (* Register to the signal we just defined: *) let%lwt event = OBus_signal.connect (OBus_signal.make s_NameAcquired proxy) in Lwt_react.E.notify_p (fun name -> Lwt_io.printlf "name acquired: %s" name) event; Lwt_io.printlf "The message bus id is %s" id end Of course, writing definitions by hand may be very boring and error-prone. To avoid that, OBus provides a few tools to automatically convert introspection data to OCaml definitions. Using tools to generate member definitions ------------------------------------------ There are two tools that are useful for client-side code: ``obus-gen-interface`` and ``obus-gen-client``. The first one converts an xml introspection document (or an IDL_ file) into an OCaml module containing all the caml-ized definitions. This generated file is in fact also needed for server-side code. Note that files produced by ``obus-gen-interface`` are not meant to be edited. The second tool maps members to their OCaml counterpart: methods are mapped to functions, signals to value of type ``OBus_signal.t`` and properties to values of type ``OBus_property.t``. This generated file is meant to be edited. For example, you can edit it in order to change the type of values taken/returned by methods. .. _IDL: The IDL language ---------------- Since editing XML is horrible, OBus provides a intermediate language to write dbus interfaces. This language also allows you to automatically converts integers to OCaml variants when needed. The syntax is pretty simple. Here is an example, taken from the OBus sources (file ``src/oBus_interfaces.obus``):: interface org.freedesktop.DBus { (** A method definition: *) method Hello : () -> (name : string) (** Bitwise flags definition: *) flag request_name_flags : uint32 { 0b001: allow_replacement 0b010: replace_existing 0b100: do_not_queue } (** Definition of an enumeration: *) enum request_name_result : uint32 { 1: primary_owner 2: in_queue 3: exists 4: already_owner } (** A method that use newly defined types: *) method RequestName : (name : string, flags : request_name_flags) -> (result : request_name_result) } All obus tools that accept XML files also accept IDL files. It is also possible to convert between IDL and XML with ``obus-idl2xml`` and ``obus-xml2idl``. Name tracking ------------- The owner of a non-unique name may change over time, so OBus provides the ``OBus_resolver``, which maps the name to a React signal that holds its current owner. ----------------------------------------------------- ********************** Writing D-Bus services ********************** In this document we describe the canonical way of writing dbus services with OBus. Local dbus objects are represented by values of type ``OBus_object.t``. The main operations on objects are: adding an interface and exporting it on a connection. Exporting an object means making it available to all peers reachable from the connection. In order to add callable methods to objects you have to create interfaces descriptions (of type ``'a OBus\_object.interface``) and add them to objects. The canonical way to create interfaces with OBus is to first write its signature in an XML introspection file or in an OBus IDL file, then convert it into an ocaml definition module with ``obus-gen-interface`` and in a template ocaml source file with ``obus-gen-server``. Here is a small example of an interface:: interface org.Foo.Bar { method GetApplicationName : () -> (name : string) (** Returns the name of the application *) } It is converted with:: $ obus-gen-interface foobar.obus -o foobar_interfaces file "foobar_interfaces.ml" written file "foobar_interfaces.mli" written $ obus-gen-server foobar.obus -o foobar file "foobar.ml" written Now all that you have to do is to edit the file generated by ``obus-gen-server`` and replace the "Not implemented" errors with your code. Once you are done, we're ready to actually create the object, add the interface and export it:: let () = Lwt_main.run begin let%lwt bus = OBus_bus.session () in (* Request a name: *) let%lwt _ = OBus_bus.request_name bus "org.Foo.Bar" in (* Create the object: *) let obj = OBus_object.make ~interfaces:[Foobar.Org_Foo_Bar.interface] ["plip"] in (* Attach it some data: *) OBus_object.attach obj (); (* Export the object on the connection *) OBus_object.export bus obj; (* Wait forever *) fst (Lwt.wait ()) end Note the you can attach custom data to the object with ``OBus_object.attach``. --------------------------------------------- ************************ One-to-one communication ************************ Instead of connection to a message bus, you may want to directly connects to another application. This can be done with ``OBus_connection.of_addresses``. If you want to allow other applications to connect to your application you have to start a server. Starting a server is very simple, all you have to do is to call ``OBus_server.make`` with a callback that will receive new connections. ----------------------------------------------------- ********************* Low-level use of OBus ********************* This document describes the low-level part of obus. Message filters --------------- Message filters are function that are applied to all incoming/outgoing messages. Filters are of type:: type filter = OBus_message.t -> OBus_message.t option Each filter may use and/or modify the message. If ``None`` is returned the message is dropped. Matching rules -------------- When using a message bus, an application do not receive messages that are not destined to it. In order to receive such messages, one needs to add rules on the message bus. All messages matching a rule are sent to the application which defined that rule. There are two ways of adding matching rules: by using the module ``OBus_bus``, or by using ``OBus_match``. The functions ``OBus_bus.add_match`` and ``OBus_bus.remove_match`` are directly mapped to the corresponding methods of the message bus. The function ``OBus_match.export`` is more clever: - it exports only one time duplicated rules, - it exports only the most general rules. We say that a rule ``r1`` is more general that a rule ``r2`` if all messages matched by ``r2`` are also matched by ``r1``. For example, a rule that accepts all messages with interface field equal to ``foo.bar`` is more general that a rule that accept all messages with interface field equal to ``foo.bar`` and with member field equal to ``plop``. Note that you must be careful if you use both modules that automatically manage rules (such as ``OBus_signal``, ``OBus_resolver`` or ``OBus_property``) and ``OBus_bus.add_match`` or ``OBus_bus.remove_match``. Defining new transports ----------------------- A transport is a way of receiving and sending messages. The ``OBus_transport`` module allows to define new transports. If you want to create a new transport using the same serialization format as default transport, then you can use the ``OBus_wire`` module. By defining new transports, you can for example write an application that forward messages over the network in very few lines of code. Defining new authentication mechanisms -------------------------------------- When openning a connection, before we can send and receive message over it, dbus requires a authentication procedure. OBus implements both client and server side authentication. The ``OBus_auth`` allow to write new client and server side authentication mechanisms. obus-1.2.5/docs/manual/manual.tex000066400000000000000000000645171456737751200167310ustar00rootroot00000000000000% manual.tex % ---------- % Copyright : (c) 2011, Jeremie Dimino % Licence : BSD3 % % This file is a part of obus, an ocaml implementation of D-Bus. \documentclass{article} \usepackage{fullpage} \usepackage[utf8]{inputenc} \usepackage{url} \usepackage{hyperref} \usepackage{listings} \usepackage{xcolor} \usepackage{xspace} %% +------------------------------------------------------------------+ %% | Configuration | %% +------------------------------------------------------------------+ \hypersetup{% a4paper=true, pdfstartview=FitH, colorlinks=false, pdfborder=0 0 0, pdftitle = {OBus user manual}, pdfauthor = {Jérémie Dimino}, pdfkeywords = {OCaml, D-Bus} } \lstset{ language=[Objective]Caml, extendedchars, showspaces=false, showstringspaces=false, showtabs=false, basicstyle=\ttfamily, frame=l, framerule=1.5mm, xleftmargin=6mm, framesep=4mm, rulecolor=\color{lightgray}, emph={lwt,for\_lwt,try\_lwt,raise\_lwt}, emphstyle=\color[rgb]{0.627451, 0.125490, 0.941176}, moredelim=*[s][\itshape]{(*}{*)}, moredelim=[is][\textcolor{darkgray}]{§}{§}, escapechar=°, keywordstyle=\color[rgb]{0.627451, 0.125490, 0.941176}, stringstyle=\color[rgb]{0.545098, 0.278431, 0.364706}, commentstyle=\color[rgb]{0.698039, 0.133333, 0.133333}, numberstyle=\color[rgb]{0.372549, 0.619608, 0.627451} } %% +-----------------------------------------------------------------+ %% | Aliases | %% +-----------------------------------------------------------------+ \newcommand{\obus}{\texttt{OBus}\xspace} \newcommand{\dbus}{\texttt{D-Bus}\xspace} %% +-----------------------------------------------------------------+ %% | Headers | %% +-----------------------------------------------------------------+ \title{OBus user manual} \author{Jérémie Dimino} \begin{document} \maketitle %% +-----------------------------------------------------------------+ %% | Abstract | %% +-----------------------------------------------------------------+ \begin{abstract} \dbus is an inter-processes communication protocol, or IPC for short, which has recently become a standard on desktop oriented computers. It is now possible to talk to a lot application using \dbus. Moreover, it has many bindings/implementations for differents languages, which make it easily accessible. \obus is a pure OCaml implementation of this protocol. What makes it different from other bindings/implementations is that it is the only one using cooperative threads, which make it very simple to fully exploit the asynchronous nature of D-Bus. \textbf{Note:} it is advised to have some knowledge about the \texttt{Lwt} library before reading this manual. \end{abstract} %% +-----------------------------------------------------------------+ %% | Table of contents | %% +-----------------------------------------------------------------+ \setcounter{tocdepth}{2} \tableofcontents %% +-----------------------------------------------------------------+ %% | Section | %% +-----------------------------------------------------------------+ \section{Introduction} \subsection{Overview of \obus} \subsubsection{Packages} The main packages of the \obus distribution is the \obus package, available via findlib. It contains the core library. Moveover, \obus although provides packages for using a bunch of services of the Freedesktop project: \begin{itemize} \item \texttt{obus.hal} \item \texttt{obus.notification} \item \texttt{obus.network-manager} \item \texttt{obus.policykit} \item \texttt{obus.udisks} \item \texttt{obus.upower} \end{itemize} The use of these packages is straightforward and you need to know almost nothing about \dbus or \obus. For example, here is a program which open a popup notification: \begin{lstlisting} open Notification lwt () = lwt id = Notification.notify ~summary:"Hello, world!" () in return () \end{lstlisting} Lastly \obus also provides a syntax extension (package \texttt{obus.syntax}) and a parser/printer for the IDL language (package \texttt{obus.idl}). \subsubsection{Modules} \obus contains about 30 public modules. But do not be scared, most of the time you will need a very small subset of them. These modules can be divided in two categories: \begin{itemize} \item{the high-level API} \item{the low-level API} \end{itemize} The low-level API is described in the section ~\ref{lowlevel-section} of this manual. Note that you must have a good knowledge of \dbus to use it. %% +-----------------------------------------------------------------+ %% | Section | %% +-----------------------------------------------------------------+ \section{Quick start} In this section we explain how to quickly uses a \dbus service using \obus. \begin{itemize} \item The first step is to obtain the introspection of the service. Some applications put theses file into \texttt{/usr/share/dbus-1/interfaces/}. Otherwise you can get it by introspecting a running service, for example: \lstset{language=bash} \begin{lstlisting} $ obus-introspect -rec org.foo.bar / > foo.xml \end{lstlisting} will recursivelly introspect the service named \texttt{org.foo.bar} and put all the interfaces it implements into \texttt{foo.xml}. \item The second step is to turn this file into an ocaml module which contains the description of the interface: \lstset{language=bash} \begin{lstlisting} $ obus-gen-interface foo.xml \end{lstlisting} This will create the two files \texttt{foo\_interfaces.ml} and \texttt{foo\_interfaces.ml}. \item The final step is to turn the introspection file into a module for client-side use: \lstset{language=bash} \begin{lstlisting} $ obus-gen-client foo.xml \end{lstlisting} This will produce the two files \texttt{foo\_client.mli} and \texttt{foo\_client.ml}. These two files can be edited, and must be compiled with the \texttt{lwt.syntax} syntax extension. \end{itemize} After that, you can use \texttt{Foo\_client} module to access the service. Methods are mapped to functions returning a \texttt{lwt} thread, signals are mapped to values of type \texttt{OBus\_signal.t}, and properties to values of type \texttt{OBus\_property.t}. For example: \lstset{language=[Objective]Caml} \begin{lstlisting} lwt () = (* Connect to the session bus *) lwt bus = OBus_bus.session () in (* Create a proxy for a remote object *) let proxy = OBus_proxy.make (OBus_peer.make bus "org.foo.bar") ["org"; "foo"; "bar"] in (* Call a method of the servivce *) lwt result = Foo_client.Org_foo_bar.plop proxy ... in (* Connect to a signal of the service *) lwt () = Lwt_react.E.notify (fun args -> ...) =|< OBus_signal.connect (Foo_client.Org_foo_bar.plip proxy) in (* Read the contents of a property *) lwt value = OBus_property.get (Foo_client.Org_foo_bar.plap proxy) in ... \end{lstlisting} %% +-----------------------------------------------------------------+ %% | Section | %% +-----------------------------------------------------------------+ \section{Basis} In this section we will describe the minimum you must know to use \obus and interfaces for \dbus services written with \obus (like the ones provided in the \obus distribution: \texttt{obus.notification}, \texttt{obus.upower}, \dots). \subsection{Connections and message buses} A \emph{connection} is a way of exchanging messages with another application speaking the \dbus protocol. Most of the time applications use connection to a special application called a \emph{message bus}. A message bus act as a router between several applications. On a desktop computer, there are two well-known instances: the \emph{system} message bus, and the user \emph{session} message bus. The first one is unique given a computer, and use security policies. The second is unique given a user session. Its goal is to allow programs running in the session to talk to each other. \obus offers two function for connecting to these message buses: \texttt{OBus\_bus.session} and \texttt{OBus\_bus.system}. The session bus exists for the life-time of a user session. It exits when the session is closed, and any programs using it should exit to, that is why \obus will exit the program when the connection to the session bus is lost. However this behavior can be changed. On the other hand the system bus can be restarted and program using it may try to reopen the connection. System-wide application should handle the lost of the connection with the system bus. Here is a small example which connects the session bus and prints its id: \lstset{language=[Objective]Caml} \begin{lstlisting} open Lwt lwt () = (* Open a connection to the session message bus: *) lwt bus = OBus_bus.session () in (* Obtain its id: *) lwt id = OBus_bus.get_id bus in Lwt_io.printlf "The session bus id is %d." (OBus_uuid.to_string id) \end{lstlisting} \subsection{Names} On a message bus, applications are referenced using names. There is a special category of names called \emph{unique names}. Each time an application connects to a bus, the bus give it a unique name. Unique name are of the form \texttt{:1.42} and cannot be changed. You can think of a unique name as an \emph{ip} (such as \texttt{192.168.1.42}). Once connected, the unique name can is returned by the function \texttt{OBus\_bus.name}. Here is an example of a program that prints its unique name: \lstset{language=[Objective]Caml} \begin{lstlisting} open Lwt lwt () = (* Connects to the session bus: *) lwt bus = OBus_bus.session () in (* Read our unique name: *) let name = OBus_bus.name bus in Lwt_io.printlf "My unique connection name is %s." name \end{lstlisting} Unique name are usefull to uniquelly identify an application. However when you want to use a specific service you may prefer using a well-known name such as \texttt{org.freedesktop.Notifications}. \dbus allows applications to own as many non-unique names as they want. You can think of a non-unique name as a \emph{dns} (such as ``obus.forge.ocamlcore.org''). Names can be requested or resolved using functions of the \texttt{OBus\_bus} module. Here is an example: \lstset{language=[Objective]Caml} \begin{lstlisting} open Lwt lwt () = lwt bus = OBus_bus.session () in lwt () = try_lwt (* Try to resolve a name, this may fail if nobody owns it: *) lwt owner = OBus_bus.get_name_owner bus "org.freedesktop.Notifications" in Lwt_io.printlf "The owner is %d." with OBus_bus.Name_has_no_owner msg -> Lwt_io.printlf "Cannot resolve the name: %s." msg in (* Request a name: *) OBus_bus.request_name bus "org.foo.bar" >>= function | `Primary_owner -> Lwt_io.printl "I own the name org.foo.bar!" | `In_queue -> Lwt_io.printl "Somebody else owns the name, i am in the queue." | `Exists -> Lwt_io.printl "Somebody else owns the name\ and does not want to loose it :(." | `Already_owner (* Cannot happen *) Lwt_io.printl "I already owns this name." \end{lstlisting} Note that the \texttt{OBus\_resolver} module offer a better way of resolving names and monitoring name owners. See section ~\ref{name-tracking} for details. \subsection{Peers} A \emph{peer} represent an application accessible through a \dbus connection. To uniquelly identify a peer one needs a connection and a name. The module \texttt{OBus\_peer} defines the type type of peers. There are two requests that should be available on all peers: \texttt{ping} and \texttt{get\_machine\_id}. The first one just ping the peer to see if it is alive, and the second returns the id of the machine the peer is currently running on. \subsection{Objects and proxies} In order to export services, \dbus uses the concept of \emph{objects}. An application may holds as many objects as it wants. From the inside of the application, \dbus objects are generally mapped to language native objects. From the outside, objects are refered by \emph{object-paths}, which looks like ``\texttt{/org/freedesktop/DBus}''. You can think of an object path as a pointer. Objects may have members which are organized by interfaces (such as ``\texttt{org.freedesktop.DBus}''). There are three types of members: \begin{itemize} \item Methods \item Signals \item Properties \end{itemize} Methods act like functions. Clients can call methods of objects. Signals are spontaneous events that may occurs at any time. Clients may register to these signals and then be notified when a signal arrive. Properties act as variable, that can be read and/or written and sometimes monitored. In order to uniquelly identify an object, we need its path and the peer that owns it. We call such a thing a \emph{proxy}. Proxies are defined in the module \texttt{OBus\_proxy}. Here is a simple example on how to call a method on a proxy (we will explain latter what means the \texttt{C.seq...} things): \lstset{language=[Objective]Caml} \begin{lstlisting} open Lwt open OBus_value lwt () = lwt bus = OBus_bus.session () in (* Create the peer: *) let peer = OBus_peer.make ~name:"org.freedesktop.DBus" ~connection:bus in (* Create the proxy: *) let proxy = OBus_proxy.make ~peer ~path:["org"; "freedesktop"; "DBus"] in (* Call a method: *) lwt id = OBus_proxy.call proxy ~interface:"org.freedesktop.DBus" ~member:"GetId" ~i_args:C.seq0 ~o_args:(C.seq1 C.basic_string) () in Lwt_io.printlf "The bus id is: %s" id \end{lstlisting} %% +-----------------------------------------------------------------+ %% | Section | %% +-----------------------------------------------------------------+ \section{Interaction between the OCaml world and the D-Bus world} \subsection{Value mapping} \dbus defines its own type system, which is used to serialize and deserialize messages. These types are defined in the module \texttt{OBus\_value.T} and \dbus values that are defined in the module \texttt{OBus\_value.V}. When a message is received, its contents is represented as a value of type \texttt{OBus\_value.V.sequence}. Simillary, when a message is sent, it is first converted into this format. Manipulating boxed \dbus values is not very handy. To make the interaction more transparent, \obus defines a set of type combinators which allow to easilly switch between the \dbus representation and the ocaml representation. These convertors are defined in the module \texttt{OBus\_value.C}. Here is an example of convertion (in the toplevel): \lstset{language=[Objective]Caml} \begin{lstlisting} # open OBus_value;; (* Make a D-Bus value from an ocaml one: *) # C.make_sequence (C.seq2 C.basic_int32 (C.array C.basic_string)) (42l, ["foo"; "bar"]);; - : OBus_value.V.sequence = [OBus_value.V.Basic (OBus_value.V.Int32 42l); OBus_value.V.Array (OBus_value.T.Basic OBus_value.T.String, [OBus_value.V.Basic (OBus_value.V.String "foo"); OBus_value.V.Basic (OBus_value.V.String "bar")])] (* Cast a D-Bus value to an ocaml one: *) # C.cast_sequence (C.seq1 C.basic_string) [V.basic(V.string "foobar")];; - : string = "foobar" (* Try to cast a D-Bus value to an ocaml one with the wrong type: *) # C.cast_sequence (C.seq1 C.basic_string) [V.basic(V.int32 0l)];; Exception: OBus_value.C.Signature_mismatch. \end{lstlisting} \subsection{Errors mapping} A call to a method may fails. In this case the service sends an error to the caller. \dbus errors are mapped to ocaml exceptions by the \texttt{OBus\_error} module. Basically, to defines a mapping between an exception and a \dbus error, here is what you have to do: \lstset{language=[Objective]Caml} \begin{lstlisting} exception My_exn of string let module M = OBus_error.Register(struct exception E = My_exn let name = "org.foo.bar.MyError" end) in () \end{lstlisting} Or, if you use the syntax extension: \lstset{language=[Objective]Caml} \begin{lstlisting} exception My_exn of string with obus("org.foo.bar.MyError") \end{lstlisting} %% +-----------------------------------------------------------------+ %% | Section | %% +-----------------------------------------------------------------+ \section{Using D-Bus services} In this section we describe the canonical way of using a \dbus service with \obus. \subsection{Defining and using members} For all types of members (methods, signals and properties), \dbus provides types to defines them and functions to use these definitions. A member definition contains all the information about a member. For example, here is the definition of a method call named ``foo'' on interface ``org.foo.bar'' which takes a string and returns an 32-bits signed integer: \lstset{language=[Objective]Caml} \begin{lstlisting} open OBus_member let m_Foo = { Method.interface = "org.foo.bar"; Method.member = "Foo"; Method.i_args = C.seq1 C.basic_string; Method.o_args = C.seq1 C.basic_int32; Method.annotations = []; } \end{lstlisting} Once a member is defined, it can be used by the corresponding modules: \lstset{language=[Objective]Caml} \begin{lstlisting} open Lwt open OBus_members (* Definition of a method *) let m_GetId = { Method.interface = "org.freedesktop.DBus"; Method.member = "GetId"; Method.i_args = C.seq0; Method.o_args = C.seq1 C.basic_string; Method.annotations = []; } (* Definition of a signal *) let s_NameAcquired = { Signal.interface = "org.freedesktop.DBus"; Signal.member = "NameAcquired"; Signal.args = C.seq1 (C.basic C.string); Signal.annotations = []; } lwt () = lwt bus = OBus_bus.session () in let proxy = OBus_proxy.make (OBus_peer.make bus "org.freedesktop.DBus") ["org"; "freedesktop"; "DBus"] in (* Call the method we just defined: *) lwt id = OBus_method.call m_GetId proxy () in (* Register to the signal we just defined: *) lwt event = OBus_signal.connect (OBus_signal.make s_NameAcquired proxy) in Lwt_react.E.notify_p (fun name -> Lwt_io.printlf "name acquired: %s" name) event; Lwt_io.printlf "The message bus id is %s" id \end{lstlisting} Of course, writting definitions by hand may be very boring and error-prone. To avoid that \obus can automatically convert introspection data into ocaml definitions. \subsection{Using tools to generate member definitions} There are two tools that are usefull for client-side code: \texttt{obus-gen-interface} and \texttt{obus-gen-client}. The first one converts an xml introspection document (or an idl file) into an ocaml module containing all the camlized definitions. This generated file is in fact also needed for server-side code. Note that fiels produced by \texttt{obus-gen-interface} are not meant to be edited. The second tool maps members into their ocaml counterpart: methods are mapped to functions, signals to value of type \texttt{OBus\_signal.t} and properties to values of type \texttt{OBus\_property.t}. This generated file is meant to be edited. For example, you can edit it in order to change the type of values taken/returned by methods. \subsection{The \obus IDL language} Since editing XML is horrible, \obus provides a intermediate language to write \dbus interfaces. Moreover this language allow you to automatically converts integers to ocaml variants when needed. The syntax is pretty simple. Here is an example, taken from \obus sources (file \texttt{src/oBus\_interfaces.obus}): \lstset{language=[Objective]Caml} \begin{lstlisting} interface org.freedesktop.DBus { (** A method definition: *) method Hello : () -> (name : string) (** Bitwise flags definition: *) flag request_name_flags : uint32 { 0b001: allow_replacement 0b010: replace_existing 0b100: do_not_queue } (** Definition of an enumeration: *) enum request_name_result : uint32 { 1: primary_owner 2: in_queue 3: exists 4: already_owner } (** A method that use newly defined types: *) method RequestName : (name : string, flags : request_name_flags) -> (result : request_name_result) } \end{lstlisting} All \obus tools that accept XML files also accept IDL files. Moreover it is possible to convert them by using \texttt{obus-idl2xml} and \texttt{obus-xml2idl}. \subsection{Name tracking} \label{name-tracking} The owner of a on-unique name may change over the time. \obus provides the \texttt{OBus\_resolver} module to deals with it. The owner is mapped into a React's signal holding the current owner of a name. %% +-----------------------------------------------------------------+ %% | Section | %% +-----------------------------------------------------------------+ \section{Writing D-Bus services} In this section we describe the canonical way of writing \dbus services with \obus. Local \dbus objects are represented by values of type \texttt{OBus\_object.t}. The main operations on objects are: adding an interface and exporting it on a connection. Exporting an object means making it available to all peers reachable from the connection. In order to add callable methods to objects you have to create interfaces descriptions (of type \texttt{'a OBus\_object.interface}) and add them to objects. The canonical way to create interfaces with \obus is to first write its signature in an XML introspection file or in an \obus idl file, then convert it into an ocaml definition module with \texttt{obus-gen-interface} and in a template ocaml source file with \texttt{obus-gen-server}. Here is a small example of interface: \lstset{language=[Objective]Caml} \begin{lstlisting} interface org.Foo.Bar { method GetApplicationName : () -> (name : string) (** Returns the name of the application *) } \end{lstlisting} It is converted with: \lstset{language=bash} \begin{lstlisting} $ obus-gen-interface foobar.obus -o foobar_interfaces file "foobar_interfaces.ml" written file "foobar_interfaces.mli" written $ obus-gen-server foobar.obus -o foobar file "foobar.ml" written \end{lstlisting} Now all that you have to do is to edit the file generated by \texttt{obus-gen-server} and replace the ``Not implemented'' errors by your code. Once it is done, here is how to actually create the object, add the interface and export it: \lstset{language=[Objective]Caml} \begin{lstlisting} lwt () = lwt bus = OBus_bus.session () in (* Request a name: *) lwt _ = OBus_bus.request_name bus "org.Foo.Bar" in (* Create the object: *) let obj = OBus_object.make ~interfaces:[Foobar.Org_Foo_Bar.interface] ["plip"] in (* Attach it some data: *) OBus_object.attach obj (); (* Export the object on the connection *) OBus_object.export bus obj; (* Wait forever *) fst (wait ()) \end{lstlisting} Note the you can attach custom data to the object with \texttt{OBus\_object.attach}. %% +-----------------------------------------------------------------+ %% | Section | %% +-----------------------------------------------------------------+ \section{One-to-one communication} Instead of connection to a message bus, you may want to directly connects to another application. This can be done with \texttt{OBus\_connection.of\_addresses}. If you want to allow other applications to connect to your application then you have to start a server. Starting a server is very simple, all you have to do is to call \texttt{OBus\_server.make} with a callback that will receive new connections. %% +-----------------------------------------------------------------+ %% | Section | %% +-----------------------------------------------------------------+ \section{Low-level use of D-Bus} \label{lowlevel-section} This section describes the low-level part of \obus. \subsection{Message filters} Message filters are function that are applied to all incomming/outgoing messages. Filters are of type: \lstset{language=[Objective]Caml} \begin{lstlisting} type filter = OBus_message.t -> OBus_message.t option \end{lstlisting} Each filter may use and/or modify the message. If \texttt{None} is returned the message is dropped. \subsection{Matching rules} When using a message bus, an application do not receive messages that are not destined to it. In order to receive such messages, one need to add rules on the message bus. All messages matching a rule are sent to the application which defined that rule. There are two ways of adding matching rules: by using the module \texttt{OBus\_bus}, or by using \texttt{OBus\_match}. The functions \texttt{OBus\_bus.add\_match} and \texttt{OBus\_bus.remove\_match} are directly mapped to the corresponding methods of the message bus. The function \texttt{OBus\_match.export} is more clever: \begin{itemize} \item it exports only one time duplicated rules, \item it exports only the most general rules. \end{itemize} We say that a rule \texttt{r1} is more general that a rule \texttt{r2} if all messages matched by \texttt{r2} are also matched by \texttt{r1}. For example a rule that accept all messages with interface field equal to \texttt{foo.bar} is more general that a rule that accept all messages with interface field equal to \texttt{foo.bar} and with member field equal to \texttt{plop}. Note that you must be carefull if you use both modules that automatically manage rules (such as \texttt{OBus\_signal}, \texttt{OBus\_resolver} or \texttt{OBus\_property}) and \texttt{OBus\_bus.add\_match} or \texttt{OBus\_bus.remove\_match}. \subsection{Defining new transports} A transport is a way of receiving and sending messages. The \texttt{OBus\_transport} allow to defines new transports. If you want to create a new transport that use the same serialization format as default transport, then you can use the \texttt{OBus\_wire} module. By definning new transports, you can for example write an application that forward messages over the network in a very few lines of code. \subsection{Defining new authentication mechanisms} When openning a connection, before we can send and receive message over it, \dbus requires a authentication procedure. \obus implements both client and server side authentication. The \texttt{OBus\_auth} allow to write new client and server side authentication mechanisms. \end{document} obus-1.2.5/dune000066400000000000000000000002151456737751200133640ustar00rootroot00000000000000(env (release (flags (:standard -w -3-6-7-9-27-32-33-34-35-37-38-39))) (dev (flags (:standard -w -3-6-7-9-27-32-33-34-35-37-38-39))))obus-1.2.5/dune-project000066400000000000000000000000771456737751200150360ustar00rootroot00000000000000(lang dune 1.4) (using menhir 2.0) (name obus) (version 1.2.5) obus-1.2.5/examples/000077500000000000000000000000001456737751200143265ustar00rootroot00000000000000obus-1.2.5/examples/battery_monitoring.ml000066400000000000000000000040621456737751200206010ustar00rootroot00000000000000(* * battery_monitoring.ml * --------------------- * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt_react open Lwt open Lwt_io (* List of monitored batteries. *) let batteries = ref [] let print_state device state = printlf "state of %s: %s" (OBus_path.to_string (OBus_proxy.path (UPower_device.to_proxy device))) (match state with | `Unknown -> "unknown" | `Charging -> "charging" | `Discharging -> "discharging" | `Empty -> "empty" | `Fully_charged -> "fully charged" | `Pending_charge -> "pending charge" | `Pending_discharge -> "pending discharge") (* Handle device addition. *) let monitor_device device = if List.exists (fun (device', _, _) -> device = device') !batteries then return () else begin let switch = Lwt_switch.create () in let%lwt signal = OBus_property.monitor (UPower_device.state device) in let%lwt s = S.map_s (print_state device) signal in batteries := (device, switch, s) :: !batteries; return () end (* Handle device removal. *) let unmonitor_device device = let%lwt () = Lwt_list.iter_p (fun (device', switch, s) -> if device = device' then begin S.stop s; Lwt_switch.turn_off switch end else return ()) !batteries in batteries := List.filter (fun (device', _, _) -> device <> device') !batteries; return () let () = Lwt_main.run begin (* Get the manager proxy. *) let%lwt manager = UPower.daemon () in (* Handle device addition/removal. *) let%lwt () = OBus_signal.connect (UPower.device_added manager) >|= E.map_p monitor_device >|= E.keep and () = OBus_signal.connect (UPower.device_removed manager) >|= E.map_p unmonitor_device >|= E.keep in (* Monitor all the batteries initially present on the system. *) let%lwt devices = UPower.enumerate_devices manager in let%lwt () = Lwt_list.iter_p monitor_device devices in fst (wait ()) end obus-1.2.5/examples/bus_functions.ml000066400000000000000000000032531456737751200175440ustar00rootroot00000000000000(* * bus_functions.ml * ---------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* This sample illustrate use if some of the functions offered by the message bus *) open Lwt open Lwt_react open Lwt_io let service = "org.freedesktop.Notifications" let name = "org.ocamlcore.forge.obus" module String_set = Set.Make(String) let () = Lwt_main.run begin let%lwt bus = OBus_bus.session () in let%lwt id = OBus_bus.get_id bus in let%lwt () = printlf "the message bus id is: %S" (OBus_uuid.to_string id) in let%lwt names = OBus_bus.list_names bus in let%lwt () = printlf "names on the session bus:" in let%lwt () = Lwt_list.iter_p (printlf " %s") names in let%lwt names = OBus_bus.list_activatable_names bus in let%lwt () = printlf "these names are activatable:" in let%lwt () = Lwt_list.iter_p (printlf " %s") names in let%lwt () = printf "trying to start service %S: " service in let%lwt result = OBus_bus.start_service_by_name bus service in let%lwt () = printl (match result with | `Success -> "success" | `Already_running -> "already running") in let%lwt () = printf "trying to acquire the name %S: " name in let%lwt result = OBus_bus.request_name bus ~replace_existing:true ~do_not_queue:true name in let%lwt () = printl (match result with | `Primary_owner -> "success" | `In_queue -> "in queue" | `Exists -> "the name already exists" | `Already_owner -> "i already own the name") in printlf "my names are: %s" (String.concat ", " (String_set.elements (S.value (OBus_bus.names bus)))) end obus-1.2.5/examples/dune000066400000000000000000000022351456737751200152060ustar00rootroot00000000000000(alias (name examples) (deps bus_functions.exe hello.exe list_services.exe monitor.exe eject.exe signals.exe battery_monitoring.exe network_manager.exe notify.exe ping.exe pong.exe)) (executables (names bus_functions hello list_services monitor) (modules bus_functions hello list_services monitor) (libraries lwt obus) (preprocess (pps lwt_ppx))) (executables (names eject signals) (modules eject signals) (libraries lwt obus obus_hal) (preprocess (pps lwt_ppx))) (executable (name battery_monitoring) (modules battery_monitoring) (libraries lwt obus obus_upower) (preprocess (pps lwt_ppx))) (executable (name network_manager) (modules network_manager) (libraries lwt obus obus_network_manager) (preprocess (pps lwt_ppx))) (executable (name notify) (modules notify) (libraries lwt obus obus_notification) (preprocess (pps lwt_ppx))) (executables (names ping pong) (modules ping pong ping_pong) (libraries lwt obus) (preprocess (pps lwt_ppx))) (rule (targets ping_pong.ml ping_pong.mli) (deps ping_pong.xml) (action (run obus-gen-interface -keep-common -o ping_pong %{deps}))) obus-1.2.5/examples/eject.ml000066400000000000000000000013271456737751200157550ustar00rootroot00000000000000(* * eject.ml * -------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* Simple sample which eject all cdroms using Hal *) open Lwt open Lwt_io let () = Lwt_main.run begin let%lwt manager = Hal_manager.manager () in let%lwt cdroms = Hal_manager.find_device_by_capability manager "storage.cdrom" in let%lwt () = printlf "cdrom(s) found: %d" (List.length cdroms) in Lwt_list.iter_p begin function cdrom -> let%lwt () = printlf "eject on device %s" (OBus_path.to_string (OBus_proxy.path (Hal_device.to_proxy cdrom))) in let%lwt _ = Hal_device.Storage.eject cdrom [] in return () end cdroms end obus-1.2.5/examples/hello.ml000066400000000000000000000006451456737751200157700ustar00rootroot00000000000000(* * hello.ml * -------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* Just open a connection with the message bus and print the assigned unique name *) let () = Lwt_main.run begin let%lwt bus = OBus_bus.session () in Lwt_io.printlf "My unique connection name is: %s" (OBus_connection.name bus) end obus-1.2.5/examples/list_services.ml000066400000000000000000000015101456737751200175330ustar00rootroot00000000000000(* * list_services.ml * ---------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* List services with their owner *) open Lwt open Lwt_io let list name get_bus = let%lwt () = printlf "service name mapping on %s bus:" name in let%lwt bus = get_bus () in (* Get the list of all names on the session bus *) let%lwt names = OBus_bus.list_names bus in Lwt_list.iter_p (fun name -> let%lwt owner = OBus_bus.get_name_owner bus name in printlf " %s -> %s" owner name) (* Select only names which are not connection unique names *) (List.filter (fun s -> s.[0] <> ':') names) let () = Lwt_main.run begin let%lwt () = list "session" OBus_bus.session in list "system" OBus_bus.system end obus-1.2.5/examples/monitor.ml000066400000000000000000000020361456737751200163500ustar00rootroot00000000000000(* * monitor.ml * ---------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* This sample illustrate the use of threads in D-Bus + use of filters. Filters are part of the lowlevel api. *) open Lwt open OBus_bus open OBus_message open OBus_value let filter what_bus message = Format.printf "@[message intercepted on %s bus:@\n%a@]@." what_bus OBus_message.print message; (* Drop the message so we do not respond to method call *) None let add_filter what_bus get_bus = let%lwt bus = get_bus () in let _ = Lwt_sequence.add_r (filter what_bus) (OBus_connection.incoming_filters bus) in Lwt_list.iter_p (fun typ -> OBus_bus.add_match bus (OBus_match.rule ~typ ())) [ `Method_call; `Method_return; `Error; `Signal ] let () = Lwt_main.run begin let%lwt () = add_filter "session" OBus_bus.session <&> add_filter "system" OBus_bus.system in let%lwt () = Lwt_io.printlf "type Ctrl+C to stop" in fst (wait ()) end obus-1.2.5/examples/network_manager.ml000066400000000000000000000026331456737751200200470ustar00rootroot00000000000000(* * network_manager.ml * ------------------ * Copyright : (c) 2011, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* This example illustrate the use of OBus to detect network-manager connections. *) open Lwt_react open Lwt open Lwt_io open OBus_value let () = Lwt_main.run begin (* Get the manager. *) let%lwt manager = Nm_manager.daemon () in (* Create a signal descriptor for listenning on signals comming from any DHCP4 object. *) let sig_desc = OBus_signal.make_any Nm_interfaces.Org_freedesktop_NetworkManager_DHCP4Config.s_PropertiesChanged (Nm_manager.to_peer manager) in (* Connects to this signal. *) let%lwt event = OBus_signal.connect sig_desc in (* Prints all DHCP4 options when one configuration changes. *) E.keep (E.map_s (fun (proxy, properties) -> match try Some(List.assoc "Options" properties) with Not_found -> None with | Some options -> let%lwt () = printlf "DHCP options for %S:" (OBus_path.to_string (OBus_proxy.path proxy)) in Lwt_list.iter_s (fun (key, value) -> printlf " %s = %s" key (V.string_of_single value)) (C.cast_single (C.dict C.string C.variant) options) | None -> return ()) event); fst (wait ()) end obus-1.2.5/examples/notify.ml000066400000000000000000000016121456737751200161700ustar00rootroot00000000000000(* * notify.ml * --------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt open Lwt_io let () = Lwt_main.run begin (* Open a first notification: *) let%lwt _ = Notification.notify ~summary:"Hello, world!" ~body:"ocaml is fun!" ~icon:"info" () in let%lwt () = Lwt_unix.sleep 0.5 in (* Open another one, with buttons on it: *) let%lwt handle = Notification.notify ~summary:"Actions test" ~body:"click on something!" ~category:"network" ~actions:[("coucou", `Coucou); ("plop", `Plop)] () in (* Then wait for the result: *) Notification.result handle >>= function | `Coucou -> eprintl "You pressed coucou!" | `Plop -> eprintl "You pressed plop!" | `Default -> eprintl "default action invoked" | `Closed -> eprintl "notification closed" end obus-1.2.5/examples/ping.ml000066400000000000000000000015101456737751200156120ustar00rootroot00000000000000(* * ping.ml * ------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* Ping the pong service *) open Lwt open Lwt_io open Ping_pong.Org_foo_bar let ping proxy msg = OBus_method.call m_Ping proxy msg let _ = Lwt_main.run begin let%lwt bus = OBus_bus.session () in (* Create a proxy for the remote object *) let proxy = OBus_proxy.make (OBus_peer.make bus "org.plop") ["plip"] in (* Send a ping *) let%lwt () = printl "trying to ping the pong service..." in try%lwt let%lwt msg = ping proxy "coucou" in printlf "received: %s" msg with | OBus_bus.Name_has_no_owner msg -> let%lwt () = printl "You must run pong to try this sample!" in exit 1 | exn -> Lwt.fail exn end obus-1.2.5/examples/ping_pong.xml000066400000000000000000000002611456737751200170270ustar00rootroot00000000000000 obus-1.2.5/examples/pong.ml000066400000000000000000000015351456737751200156270ustar00rootroot00000000000000(* * pong.ml * ------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* Very simple service with one object have a ping method *) open Lwt open Lwt_io let ping obj msg = let%lwt () = printlf "received: %s" msg in return msg let interface = Ping_pong.Org_foo_bar.make { Ping_pong.Org_foo_bar.m_Ping = (fun obj msg -> ping (OBus_object.get obj) msg); } let () = Lwt_main.run begin let%lwt bus = OBus_bus.session () in (* Request a name *) let%lwt _ = OBus_bus.request_name bus "org.plop" in (* Create the object *) let obj = OBus_object.make ~interfaces:[interface] ["plip"] in OBus_object.attach obj (); (* Export the object on the connection *) OBus_object.export bus obj; (* Wait forever *) fst (wait ()) end obus-1.2.5/examples/signals.ml000066400000000000000000000054021456737751200163210ustar00rootroot00000000000000(* * signals.ml * ---------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* This sample illustrate the use of signals *) open Lwt_react open Lwt open Lwt_io (* Add an handler on keyboard event which print the multimedia key pressed *) let handle_multimedia_keys device = OBus_signal.connect (Hal_device.condition device) >|= (E.map_p (fun (action, key) -> let%lwt () = printlf "from Hal: action %S on key %S!" action key in let%lwt () = printlf " the signal come from the device %S" (OBus_path.to_string (Hal_device.udi device)) in return ())) >|= E.keep let () = Lwt_main.run begin let%lwt session = OBus_bus.session () in (* +---------------------------------------------------------------+ | Signals from message bus | +---------------------------------------------------------------+ *) let%lwt () = OBus_signal.connect (OBus_bus.name_owner_changed session) >|= (E.map_p (fun (name, old_owner, new_owner) -> printlf "from D-Bus: the owner of the name %S changed: %S -> %S" name old_owner new_owner)) >|= E.keep in let%lwt () = OBus_signal.connect (OBus_bus.name_lost session) >|= E.map_p (printlf "from D-Bus: i lost the name %S!") >|= E.keep in let%lwt () = OBus_signal.connect (OBus_bus.name_acquired session) >|= E.map_p (printf "from D-Bus: i got the name '%S!") >|= E.keep in (* +---------------------------------------------------------------+ | Some Hal signals | +---------------------------------------------------------------+ *) let%lwt manager = Hal_manager.manager () in let%lwt () = OBus_signal.connect (Hal_manager.device_added manager) >|= (E.map_p (fun device -> let%lwt () = printlf "from Hal: device added: %S" (OBus_path.to_string (Hal_device.udi device)) in (* Handle the adding of keyboards *) Hal_device.query_capability device "input.keyboard" >>= function | true -> handle_multimedia_keys device | false -> return ())) >|= E.keep in (* Find all keyboards and handle events on them *) let%lwt keyboards = Hal_manager.find_device_by_capability manager "input.keyboard" in let%lwt () = printlf "keyboard founds: %d" (List.length keyboards) in let%lwt () = Lwt_list.iter_p (fun dev -> printlf " %s" (OBus_path.to_string (Hal_device.udi dev))) keyboards in let%lwt () = Lwt_list.iter_p handle_multimedia_keys keyboards in let%lwt () = printf "type Ctrl+C to stop\n%!" in fst (wait ()) end obus-1.2.5/obus.opam000066400000000000000000000011131456737751200143320ustar00rootroot00000000000000opam-version: "2.0" version: "1.2.5" synopsis: "Pure Ocaml implementation of the D-Bus protocol" maintainer: "freyrnjordrson@gmail.com" authors: [ "Jérémie Dimino" ] homepage: "https://github.com/ocaml-community/obus" bug-reports: "https://github.com/ocaml-community/obus/issues" dev-repo: "git+https://github.com/ocaml-community/obus.git" license: "BSD-3-Clause" build: [ [ "dune" "build" "-p" name "-j" jobs ] ] depends: [ "ocaml" {>= "4.07"} "dune" {>= "1.1"} "menhir" {build} "xmlm" "lwt" {>= "4.3.0"} "lwt_ppx" "lwt_log" "lwt_react" "ppxlib" {>= "0.26.0"} ] obus-1.2.5/src/000077500000000000000000000000001456737751200132775ustar00rootroot00000000000000obus-1.2.5/src/idl/000077500000000000000000000000001456737751200140475ustar00rootroot00000000000000obus-1.2.5/src/idl/dune000066400000000000000000000002451456737751200147260ustar00rootroot00000000000000(library (name OBus_idl) (synopsis "DSL for defining D-Bus interfaces") (libraries obus_internals)) (ocamllex (modules lexer)) (menhir (modules parser)) obus-1.2.5/src/idl/lexer.mll000066400000000000000000000036011456737751200156740ustar00rootroot00000000000000{ open Lexing open Parser exception SyntaxError of string } let lident = ['a'-'z']['a'-'z''0'-'9''_']* let uident = ['A'-'Z']['a'-'z''A'-'Z''0'-'9''_']* let integer = ('0'['b''o''x''u'])?['0'-'9']+ rule read = parse | [' ' '\t' '\n']+ { read lexbuf } | "interface" { INTERFACE } | "method" { METHOD } | "signal" { SIGNAL } | "property_r" { PROPERTY_R } | "property_w" { PROPERTY_W } | "property_rw" { PROPERTY_RW } | "annotation" { ANNOTATION } | "enum" { ENUM } | "flag" { FLAG } | "with" { WITH } | '"' { read_string (Buffer.create 20) lexbuf } | "(*" { skip_comment lexbuf } | "," { COMMA } | "." { PERIOD } | "=" { EQMARK } | ":" { COLON } | "+" { PLUS } | "-" { MINUS } | "*" { STAR } | "->" { ARROW } | "_" { UNDERSCORE } | "{" { LBRACE } | "}" { RBRACE } | "(" { LPAREN } | ")" { RPAREN } | integer as i { INT i } | lident as s { LIDENT s } | uident as s { UIDENT s } | _ { raise (SyntaxError ("Unexpected char: " ^ Lexing.lexeme lexbuf)) } | eof { EOF } and skip_comment = parse | "*)" { read lexbuf } | _ { skip_comment lexbuf } and read_string buf = parse | '"' { STRING (Buffer.contents buf) } | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } | [^ '"' '\\']+ { Buffer.add_string buf (Lexing.lexeme lexbuf); read_string buf lexbuf } | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } | eof { raise (SyntaxError ("String is not terminated")) } obus-1.2.5/src/idl/oBus_idl.ml000066400000000000000000000123431456737751200161440ustar00rootroot00000000000000open Lexer open Lexing exception Parse_failure of string let parse s = let lexbuf = Lexing.from_string s in try Parser.interfaces Lexer.read lexbuf with e -> let curr = lexbuf.Lexing.lex_curr_p in let cnum = curr.Lexing.pos_cnum - curr.Lexing.pos_bol in let tok = Lexing.lexeme lexbuf in raise (Parse_failure (Printf.sprintf "%s: pos [%d] token %s" (Printexc.to_string e) cnum tok)) let parse_file file_name = let ic = open_in file_name in let lexbuf = Lexing.from_channel ic in try let ifaces = Parser.interfaces Lexer.read lexbuf in close_in ic; ifaces with e -> close_in ic; let curr = lexbuf.Lexing.lex_curr_p in let cnum = curr.Lexing.pos_cnum - curr.Lexing.pos_bol in let tok = Lexing.lexeme lexbuf in raise (Parse_failure (Printf.sprintf "%s: pos [%d] token %s" (Printexc.to_string e) cnum tok)) (* +-----------------------------------------------------------------+ | Printing | +-----------------------------------------------------------------+ *) open OBus_introspect_ext open OBus_value open Format let rec print_term top pp = function | Term(id, []) -> pp_print_string pp id | Term(id, [t]) -> fprintf pp "%a %s" (print_term false) t id | Term(id, tl) -> fprintf pp "(%a) %s" (print_seq true ", ") tl id | Tuple tl -> if top then print_seq false " * " pp tl else fprintf pp "(%a)" (print_seq false " * ") tl and print_seq top sep pp = function | [] -> () | [t] -> print_term top pp t | t :: tl -> fprintf pp "%a%s%a" (print_term top) t sep (print_seq top sep) tl let print_args pp args = let rec aux = function | [] -> () | [(None, typ)] -> fprintf pp "_ : %a" (print_term true) typ | [(Some name, typ)] -> fprintf pp "%s : %a" name (print_term true) typ | (None, typ) :: l -> fprintf pp "_ : %a, " (print_term true) typ; aux l | (Some name, typ) :: l -> fprintf pp "%s : %a, " name (print_term true) typ; aux l in pp_print_char pp '('; aux args; pp_print_char pp ')' let print_annotations pp = function | [] -> () | l -> pp_print_string pp " with {\n"; List.iter (fun (name, value) -> fprintf pp " %s = %S\n" name value) l; pp_print_string pp " }\n" let string_of_key = function | T.Byte -> "byte" | T.Int16 -> "int16" | T.Int32 -> "int32" | T.Int64 -> "int64" | T.Uint16 -> "uint16" | T.Uint32 -> "uint32" | T.Uint64 -> "uint64" | _ -> assert false let print pp interfaces = List.iter (function (name, members, symbols, annotations) -> fprintf pp "\ninterface %s {\n" name; List.iter (fun (name, sym) -> let keyword, typ, values = match sym with | Sym_enum(typ, values) -> "enum", typ, values | Sym_flag(typ, values) -> "flag", typ, values in fprintf pp " %s %s : %s {\n" keyword name (string_of_key typ); let values = List.map (fun (key, name) -> ((match key with | V.Byte x -> sprintf "%x" (Char.code x) | V.Int16 x | V.Uint16 x -> sprintf "%x" x | V.Int32 x | V.Uint32 x -> sprintf "%lx" x | V.Int64 x | V.Uint64 x -> sprintf "%Lx" x | _ -> assert false), name)) values in let max_len = List.fold_left (fun m (key, name) -> max m (String.length key)) 0 values in List.iter (fun (key, name) -> fprintf pp " 0x%s%s: %s\n" (String.make (max_len - String.length key) '0') key name) values; fprintf pp " }\n") symbols; List.iter (fun (name, value) -> fprintf pp " annotation %s = %S\n" name value) annotations; List.iter (function | Method(name, i_args, o_args, annotations) -> fprintf pp " method %s : %a -> %a\n" name print_args i_args print_args o_args; print_annotations pp annotations | Signal(name, args, annotations) -> fprintf pp " signal %s : %a\n" name print_args args; print_annotations pp annotations | Property(name, typ, access, annotations) -> fprintf pp " property.%s %s : %a\n" (match access with | Read -> "r" | Write -> "w" | Read_write -> "rw") name (print_term true) typ; print_annotations pp annotations) members; pp_print_string pp "}\n") interfaces let print_file name interfaces = let oc = open_out name in let pp = formatter_of_out_channel oc in try print pp interfaces; pp_print_flush pp (); close_out oc with exn -> (* Should never happen *) close_out oc; raise exn obus-1.2.5/src/idl/oBus_idl.mli000066400000000000000000000016041456737751200163130ustar00rootroot00000000000000(* * oBus_idl.mli * ------------ * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Intermediate language for writing D-Bus interfaces *) exception Parse_failure of string (** Exception raised when parsing fails for some reason. The argument is an error message. *) val parse : string -> OBus_introspect_ext.interface list (** [parse string] parses the given string. *) val parse_file : string -> OBus_introspect_ext.interface list (** [parse_file path] Helper to parse the contents of a file. *) val print : Format.formatter -> OBus_introspect_ext.interface list -> unit (** [print pp interfaces] prints the given interfaces on [pp] in the obus idl format *) val print_file : string -> OBus_introspect_ext.interface list -> unit (** Helper to print to a file *) obus-1.2.5/src/idl/parser.mly000066400000000000000000000112101456737751200160610ustar00rootroot00000000000000%{ open OBus_value open OBus_introspect_ext let rec get_members = function | [] -> [] | `Member m :: rest -> m :: get_members rest | `Annotation _ :: rest -> get_members rest | `Symbol _ :: rest -> get_members rest let rec get_annotations = function | [] -> [] | `Member _ :: rest -> get_annotations rest | `Annotation a :: rest -> a :: get_annotations rest | `Symbol _ :: rest -> get_annotations rest let rec get_symbols = function | [] -> [] | `Member _ :: rest -> get_symbols rest | `Annotation _ :: rest -> get_symbols rest | `Symbol s :: rest -> s :: get_symbols rest let parse_int typ str = match typ with | T.Byte -> V.Byte(char_of_int (int_of_string str)) | T.Int16 -> V.Int16(int_of_string str) | T.Int32 -> V.Int32(Int32.of_string str) | T.Int64 -> V.Int64(Int64.of_string str) | T.Uint16 -> V.Uint16(int_of_string str) | T.Uint32 -> V.Uint32(Int32.of_string str) | T.Uint64 -> V.Uint64(Int64.of_string str) | _ -> assert false let rev = List.rev %} %token INTERFACE METHOD SIGNAL PROPERTY_R PROPERTY_W PROPERTY_RW %token ANNOTATION ENUM FLAG WITH %token COMMA PERIOD LBRACE RBRACE LPAREN RPAREN %token EQMARK COLON PLUS MINUS ARROW UNDERSCORE STAR %token LIDENT UIDENT %token STRING %token INT %token EOF %start interfaces %% interfaces: | EOF { [] } | iface = interface; ifaces = interfaces { iface :: ifaces } ; interface: | INTERFACE; name = name; LBRACE; members = members; RBRACE { (name, get_members members, get_symbols members, get_annotations members) } ; ident: | n = LIDENT { n } | n = UIDENT { n } ; name: | n = ident { n } | n = ident; PERIOD; rest = name { n ^ "." ^ rest } ; members: | { [] } | members = members; member = member { member :: members } ; member: | METHOD; name = ident; COLON; LPAREN; i_args = arguments; RPAREN; ARROW; LPAREN; o_args = arguments; RPAREN; annot = annotations { `Member (Method (name, i_args, o_args, annot)) } | SIGNAL; name = ident; COLON; LPAREN; args = arguments; RPAREN; annot = annotations { `Member (Signal (name, args, annot)) } | PROPERTY_R; name = ident; COLON; typ = type_term; annot = annotations { `Member (Property (name, typ, Read, annot)) } | PROPERTY_W; name = ident; COLON; typ = type_term; annot = annotations { `Member (Property (name, typ, Write, annot)) } | PROPERTY_RW; name = ident; COLON; typ = type_term; annot = annotations { `Member (Property (name, typ, Read_write, annot)) } | ANNOTATION; name = STRING; EQMARK; value = STRING { `Annotation (name, value) } | ENUM; name = ident; COLON; typ = key_type; LBRACE; values = values; RBRACE { `Symbol (name, sym_enum typ (List.map (fun (key, value) -> (parse_int typ key, value)) values)) } | FLAG; name = ident; COLON; typ = key_type; LBRACE; values = values; RBRACE { `Symbol (name, sym_flag typ (List.map (fun (key, value) -> (parse_int typ key, value)) values)) } ; values: | { [] } | vals = values; v = value { v :: vals } ; value: | key = INT; COLON; value = ident { (key, value) } | MINUS; key = INT; COLON; value = ident { ("-" ^ key, value) } | PLUS; key = INT; COLON; value = ident { (key, value) } ; annotations: | { [] } | WITH; LBRACE; annots = annotations; last = annotation; RBRACE { last :: annots } ; annotation: | name = name; EQMARK; value = STRING { (name, value) } ; arguments: | { [] } | arg = argument { [ arg ] } | arg = argument; COMMA; rest = arguments { arg :: rest } ; argument: | name = ident; COLON; typ = type_term { (Some name, typ) } | UNDERSCORE; COLON; typ = type_term { (None, typ) } ; type_term: | id = ident { term id [] } | LPAREN; t = type_term; RPAREN { t } | LPAREN; tup = type_tuple; RPAREN { tuple tup } | t = type_term; id = ident { term id [t] } | LPAREN; args = type_args; RPAREN; id = ident { term id args } ; type_tuple: | t = type_term; STAR; tl = type_tuple { t :: tl } | t = type_term { [ t ] } ; type_args: | t = type_term; COMMA; tl = type_args { t :: tl } | t = type_term { [ t ] } ; key_type: | id = LIDENT { match id with | "byte" -> T.Byte | "int16" -> T.Int16 | "int32" -> T.Int32 | "int64" -> T.Int64 | "uint16" -> T.Uint16 | "uint32" -> T.Uint32 | "uint64" -> T.Uint64 | _ -> raise (Failure(Printf.sprintf "invalid key type: %s" id)) } ; obus-1.2.5/src/internals/000077500000000000000000000000001456737751200152765ustar00rootroot00000000000000obus-1.2.5/src/internals/dune000066400000000000000000000002571456737751200161600ustar00rootroot00000000000000(library (name obus_internals) (public_name obus.internals) (libraries lwt.unix lwt_log xmlm) (wrapped false) (preprocess (pps lwt_ppx))) (ocamllex oBus_type_ext_lexer) obus-1.2.5/src/internals/oBus_introspect.ml000066400000000000000000000156171456737751200210240ustar00rootroot00000000000000(* * oBus_introspect.ml * ------------------ * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open OBus_xml_parser type name = string type annotation = name * string type argument = name option * OBus_value.T.single type access = Read | Write | Read_write type member = | Method of name * argument list * argument list * annotation list | Signal of name * argument list * annotation list | Property of name * OBus_value.T.single * access * annotation list type interface = name * member list * annotation list type node = OBus_path.element type document = interface list * node list exception Parse_failure = OBus_xml_parser.Parse_failure let () = Printexc.register_printer (function | Parse_failure((line, column), msg) -> Some(Printf.sprintf "failed to parse D-Bus introspection document, at line %d, column %d: %s" line column msg) | _ -> None) let annotations p = any p (elt "annotation" (fun p -> let name = ar p "name" in let value = ar p "value" in (name, value))) type direction = In | Out let atype p = let signature = ar p "type" in match OBus_value.signature_of_string signature with | [] -> failwith p "empty signature" | [t] -> t | _ -> Printf.ksprintf (failwith p) "this signature contains more than one single type: %S" signature let arguments p = any p (elt "arg" (fun p -> let name = ao p "name" in let dir = afd p "direction" In [("in", In); ("out", Out)] in let typ = atype p in (dir, (name, typ)))) let mk_aname test p = let name = ar p "name" in match test name with | Some error -> failwith p (OBus_string.error_message error) | None -> name let amember = mk_aname OBus_name.validate_member let anode = mk_aname OBus_path.validate_element let ainterface = mk_aname OBus_name.validate_interface let method_decl = elt "method" (fun p -> let name = amember p in let args = arguments p in let ins, outs = OBus_util.split (function | (In, x) -> OBus_util.InL x | (Out, x) -> OBus_util.InR x) args in let annots = annotations p in (Method(name, ins, outs, annots))) let signal_decl = elt "signal" (fun p -> let name = amember p in let args = arguments p in let annots = annotations p in (Signal(name, List.map snd args, annots))) let property_decl = elt "property" (fun p -> let name = amember p in let access = afr p "access" [("read", Read); ("write", Write); ("readwrite", Read_write)] in let typ = atype p in let annots = annotations p in (Property(name, typ, access, annots))) let node = elt "node" (fun p -> let name = anode p in match OBus_path.validate_element name with | None -> name | Some error -> failwith p (OBus_string.error_message { error with OBus_string.typ = "node name" })) let interface = elt "interface" (fun p -> let name = ainterface p in let decls = any p (union [method_decl; signal_decl; property_decl]) in let annots = annotations p in (name, decls, annots)) let document = elt "node" (fun p -> let interfs = any p interface in let subs = any p node in (interfs, subs)) let input xi = OBus_xml_parser.input xi document type xml = Element of string * (string * string) list * xml list let to_xml (ifaces, nodes) = let pannots = List.map (fun (n, v) -> Element("annotation", [("name", n); ("value", v)], [])) in let pargs dir = List.map (fun (n, t) -> let attrs = [("type", OBus_value.string_of_signature [t])] in let attrs = match dir with | Some In -> ("direction", "in") :: attrs | Some Out -> ("direction", "out") :: attrs | None -> attrs in let attrs = match n with | Some n -> ("name", n) :: attrs | None -> attrs in Element("arg", attrs, [])) in Element("node", [], List.map (fun (name, content, annots) -> Element("interface", [("name", name)], pannots annots @ List.map (function | Method(name, ins, outs, annots) -> Element("method", [("name", name)], pargs (Some In) ins @ pargs (Some Out) outs @ pannots annots) | Signal(name, args, annots) -> Element("signal", [("name", name)], pargs None args @ pannots annots) | Property(name, typ, access, annots) -> Element("property", [("name", name); ("type", OBus_value.string_of_signature [typ]); ("access", match access with | Read -> "read" | Write -> "write" | Read_write -> "readwrite")], pannots annots)) content)) ifaces @ List.map (fun n -> Element("node", [("name", n)], [])) nodes) let output xo doc = let rec aux (Element(name, attrs, children)) = Xmlm.output xo (`El_start(("", name), List.map (fun (name, value) -> (("", name), value)) attrs)); List.iter aux children; Xmlm.output xo `El_end in Xmlm.output xo (`Dtd(Some "")); aux (to_xml doc) (* +-----------------------------------------------------------------+ | Annotations | +-----------------------------------------------------------------+ *) let deprecated = "org.freedesktop.DBus.Deprecated" let csymbol = "org.freedesktop.DBus.GLib.CSymbol" let no_reply = "org.freedesktop.DBus.Method.NoReply" let emits_changed_signal = "org.freedesktop.DBus.Property.EmitsChangedSignal" obus-1.2.5/src/internals/oBus_introspect.mli000066400000000000000000000026731456737751200211730ustar00rootroot00000000000000(* * oBus_introspect.mli * ------------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** D-Bus obejct introspection *) type name = string type annotation = name * string type argument = name option * OBus_value.T.single type access = Read | Write | Read_write (** Access mode of properties *) type member = | Method of name * argument list * argument list * annotation list | Signal of name * argument list * annotation list | Property of name * OBus_value.T.single * access * annotation list type interface = name * member list * annotation list type node = OBus_path.element type document = interface list * node list (** {6 Xml conversion} *) exception Parse_failure of Xmlm.pos * string val input : Xmlm.input -> document (** Try to read an xml document as an introspection document. @raise Parse_failure if the parsing fail. *) val output : Xmlm.output -> document -> unit (** Create an xml from an introspection document *) (** {6 Well-known annotations} *) val deprecated : name (** The [org.freedesktop.DBus.Deprecated] annotation *) val csymbol : name (** The [org.freedesktop.DBus.GLib.CSymbol] annotation *) val no_reply : name (** The [org.freedesktop.DBus.Method.NoReply] annotation *) val emits_changed_signal : name (** The [org.freedesktop.DBus.Property.EmitsChangedSignal] annotation *) obus-1.2.5/src/internals/oBus_introspect_ext.ml000066400000000000000000000346161456737751200217040ustar00rootroot00000000000000(* * oBus_introspect_ext.ml * ---------------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Printf open OBus_value (* +-----------------------------------------------------------------+ | Annotations | +-----------------------------------------------------------------+ *) let obus_enum = "org.ocamlcore.forge.obus.Enum" let obus_flag = "org.ocamlcore.forge.obus.Flag" let obus_type = "org.ocamlcore.forge.obus.Type" let obus_itype = "org.ocamlcore.forge.obus.IType" let obus_otype = "org.ocamlcore.forge.obus.OType" (* +-----------------------------------------------------------------+ | Extended types | +-----------------------------------------------------------------+ *) type basic = | Byte | Boolean | Int16 | Int32 | Int64 | Uint16 | Uint32 | Uint64 | Double | String | Signature | Object_path | Unix_fd | Enum of T.basic * (V.basic * string) list | Flag of T.basic * (V.basic * string) list type single = | Basic of basic | Structure of single list | Array of single | Dict of basic * single | Variant type sequence = single list let byte = Byte let boolean = Boolean let int16 = Int16 let int32 = Int32 let int64 = Int64 let uint16 = Uint16 let uint32 = Uint32 let uint64 = Uint64 let double = Double let string = String let signature = Signature let object_path = Object_path let unix_fd = Unix_fd let check_values func typ values = match typ with | T.Byte | T.Int16 | T.Int32 | T.Int64 | T.Uint16 | T.Uint32 | T.Uint64 -> List.iter (fun (value, name) -> if V.type_of_basic value <> typ then ksprintf invalid_arg "OBus_introspect_ext.%s: unexpected type" func) values | _ -> ksprintf invalid_arg "OBus_introspect_ext.%s: type '%s' is not supported for enumerations" func (T.string_of_basic typ) let enum typ values = check_values "enum" typ values; Enum(typ, values) let flag typ values = check_values "flag" typ values; Flag(typ, values) let basic t = Basic t let structure t = Structure t let array t = Array t let dict tk tv = Dict(tk, tv) let variant = Variant (* +-----------------------------------------------------------------+ | Stripping | +-----------------------------------------------------------------+ *) let strip_basic = function | Byte -> T.Byte | Boolean -> T.Boolean | Int16 -> T.Int16 | Int32 -> T.Int32 | Int64 -> T.Int64 | Uint16 -> T.Uint16 | Uint32 -> T.Uint32 | Uint64 -> T.Uint64 | Double -> T.Double | String -> T.String | Signature -> T.Signature | Object_path -> T.Object_path | Unix_fd -> T.Unix_fd | Enum(t, _) -> t | Flag(t, _) -> t let rec strip_single = function | Basic t -> T.Basic(strip_basic t) | Structure tl -> T.structure(List.map strip_single tl) | Array t -> T.Array(strip_single t) | Dict(tk, tv) -> T.Dict(strip_basic tk, strip_single tv) | Variant -> T.Variant let strip_sequence l = List.map strip_single l (* +-----------------------------------------------------------------+ | Projections | +-----------------------------------------------------------------+ *) let project_basic = function | T.Byte -> Byte | T.Boolean -> Boolean | T.Int16 -> Int16 | T.Int32 -> Int32 | T.Int64 -> Int64 | T.Uint16 -> Uint16 | T.Uint32 -> Uint32 | T.Uint64 -> Uint64 | T.Double -> Double | T.String -> String | T.Signature -> Signature | T.Object_path -> Object_path | T.Unix_fd -> Unix_fd let rec project_single = function | T.Basic t -> Basic(project_basic t) | T.Structure tl -> structure(List.map project_single tl) | T.Array t -> Array(project_single t) | T.Dict(tk, tv) -> Dict(project_basic tk, project_single tv) | T.Variant -> Variant let project_sequence l = List.map project_single l (* +-----------------------------------------------------------------+ | Symbols and environments | +-----------------------------------------------------------------+ *) type term = OBus_type_ext_lexer.term = | Term of string * term list | Tuple of term list let term name args = Term(name, args) let tuple = function | [t] -> t | l -> Tuple l type symbol = | Sym_enum of OBus_value.T.basic * (OBus_value.V.basic * string) list | Sym_flag of OBus_value.T.basic * (OBus_value.V.basic * string) list let sym_enum typ values = check_values "sym_enum" typ values; Sym_enum(typ, values) let sym_flag typ values = check_values "sym_flag" typ values; Sym_flag(typ, values) type env = (string * symbol) list exception Resolve_error of string let rec resolve env = function | Term(name, args) -> begin let args = List.map (resolve env) args in match try Some(List.assoc name env) with Not_found -> None with | Some(Sym_enum(typ, values)) -> Basic(Enum(typ, values)) | Some(Sym_flag(typ, values)) -> Basic(Flag(typ, values)) | None -> match name, args with | "byte", [] -> Basic Byte | "boolean", [] -> Basic Boolean | "int16", [] -> Basic Int16 | "int32", [] -> Basic Int32 | "int64", [] -> Basic Int64 | "uint16", [] -> Basic Uint16 | "uint32", [] -> Basic Uint32 | "uint64", [] -> Basic Uint64 | "double", [] -> Basic Double | "string", [] -> Basic String | "signature", [] -> Basic Signature | "object_path", [] -> Basic Object_path | "unix_fd", [] -> Basic Unix_fd | "array", [t] -> Array t | "dict", [Basic tk; tv] -> Dict(tk, tv) | "dict", [tk; tv] -> raise (Resolve_error "type of a dictionary key must be a basic type") | "variant", [] -> Variant | _ -> raise (Resolve_error(sprintf "unbounded symbol: %S with arity %d" name (List.length args))) end | Tuple l -> Structure(List.map (resolve env) l) (* +-----------------------------------------------------------------+ | Projection D-Bus types -> terms | +-----------------------------------------------------------------+ *) let term_of_basic = function | T.Byte -> term "byte" [] | T.Boolean -> term "boolean" [] | T.Int16 -> term "int16" [] | T.Int32 -> term "int32" [] | T.Int64 -> term "int64" [] | T.Uint16 -> term "uint16" [] | T.Uint32 -> term "uint32" [] | T.Uint64 -> term "uint64" [] | T.Double -> term "double" [] | T.String -> term "string" [] | T.Signature -> term "signature" [] | T.Object_path -> term "object_path" [] | T.Unix_fd -> term "unix_fd" [] let rec term_of_single = function | T.Basic t -> term_of_basic t | T.Array t -> term "array" [term_of_single t] | T.Dict(tk, tv) -> term "dict" [term_of_basic tk; term_of_single tv] | T.Structure tl -> tuple (List.map term_of_single tl) | T.Variant -> term "variant" [] let term_of_sequence l = tuple (List.map term_of_single l) (* +-----------------------------------------------------------------+ | Exended ast | +-----------------------------------------------------------------+ *) type name = string type annotation = name * string type argument = name option * term type access = OBus_introspect.access = Read | Write | Read_write type member = | Method of name * argument list * argument list * annotation list | Signal of name * argument list * annotation list | Property of name * term * access * annotation list type interface = name * member list * (string * symbol) list * annotation list (* +-----------------------------------------------------------------+ | Printing/parsing | +-----------------------------------------------------------------+ *) open Printf let rec string_of_term = function | Term(name, []) -> name | Term(name, args) -> "(" ^ String.concat " " (name :: List.map string_of_term args) ^ ")" | Tuple typs -> "<" ^ String.concat "," (List.map string_of_term typs) ^ ">" let string_of_enum name typ values = sprintf "%s:%s=%s" name (match typ with | T.Byte -> "byte" | T.Int16 -> "int16" | T.Int32 -> "int32" | T.Int64 -> "int64" | T.Uint16 -> "uint16" | T.Uint32 -> "uint32" | T.Uint64 -> "uint64" | _ -> assert false) (String.concat "," (List.map (fun (key, value) -> sprintf "%s:%s" (match key with | V.Byte x -> string_of_int (Char.code x) | V.Int16 x | V.Uint16 x -> string_of_int x | V.Int32 x | V.Uint32 x -> Int32.to_string x | V.Int64 x | V.Uint64 x -> Int64.to_string x | _ -> assert false) value) values)) let string_of_flag = string_of_enum let term_of_string str = try OBus_type_ext_lexer.single (Lexing.from_string str) with OBus_type_ext_lexer.Fail(pos, msg) -> ksprintf failwith "failed to parse extended type %S, at position %d: %s" str pos msg let enum_of_string str = try OBus_type_ext_lexer.enum_and_flag (Lexing.from_string str) with OBus_type_ext_lexer.Fail(pos, msg) -> ksprintf failwith "failed to parse extended symbol %S, at position %d: %s" str pos msg let flag_of_string = enum_of_string (* +-----------------------------------------------------------------+ | Encoding | +-----------------------------------------------------------------+ *) let set_annotation name value annotations = let rec loop acc = function | [] -> (name, value) :: acc | (name', _) :: rest when name = name' -> (name, value) :: List.rev_append acc rest | a :: rest -> loop (a :: acc) rest in loop [] annotations let encode_arguments env args annotation_name annotations = let rec loop acc use_ext = function | [] -> (List.rev acc, use_ext) | (name, typ) :: rest -> let ext_typ = resolve env typ in let std_typ = strip_single ext_typ in (* Check whether the type contains extended types: *) if project_single std_typ = ext_typ then loop ((name, std_typ) :: acc) use_ext rest else loop ((name, std_typ) :: acc) true rest in let args', use_ext = loop [] false args in if use_ext then (args', set_annotation annotation_name (string_of_term (tuple (List.map snd args))) annotations) else (args', annotations) let encode (name, members, symbols, annotations) = let env = symbols in let members = List.map (function | Method(name, i_args, o_args, annotations) -> let i_args, annotations = encode_arguments env i_args obus_itype annotations in let o_args, annotations = encode_arguments env o_args obus_otype annotations in OBus_introspect.Method(name, i_args, o_args, annotations) | Signal(name, args, annotations) -> let args, annotations = encode_arguments env args obus_type annotations in OBus_introspect.Signal(name, args, annotations) | Property(name, typ, access, annotations) -> begin match encode_arguments env [(None, typ)] obus_type annotations with | [(None, typ)], annotations -> OBus_introspect.Property(name, typ, access, annotations) | _ -> assert false end) members in let annotations = List.map (function | (name, Sym_enum(typ, values)) -> (obus_enum, string_of_enum name typ values) | (name, Sym_flag(typ, values)) -> (obus_flag, string_of_flag name typ values)) symbols @ annotations in (name, members, annotations) let get_annotation name annotations = let rec loop acc = function | [] -> (acc, None) | (name', value) :: rest -> if name = name' then (List.rev_append acc rest, Some value) else loop ((name', value) :: acc) rest in loop [] annotations let decode_arguments args annotation_name annotations = match get_annotation annotation_name annotations with | (annotations, None) -> (List.map (fun (name, typ) -> (name, term_of_single typ)) args, annotations) | (annotations, Some value) -> (List.map2 (fun (name, _) term -> (name, term)) args (match term_of_string value with | Tuple l -> l | t -> [t]), annotations) let decode (name, members, annotations) = let members = List.map (function | OBus_introspect.Method(name, i_args, o_args, annotations) -> let i_args, annotations = decode_arguments i_args obus_itype annotations in let o_args, annotations = decode_arguments o_args obus_otype annotations in Method(name, i_args, o_args, annotations) | OBus_introspect.Signal(name, args, annotations) -> let args, annotations = decode_arguments args obus_type annotations in Signal(name, args, annotations) | OBus_introspect.Property(name, typ, access, annotations) -> begin match decode_arguments [(None, typ)] obus_type annotations with | [(None, typ)], annotations -> Property(name, typ, access, annotations) | _ -> assert false end) members in let symbols, annotations = List.partition (fun (name, value) -> name = obus_enum || name = obus_flag) annotations in let symbols = List.map (fun (name, value) -> if name = obus_enum then let name, typ, values = enum_of_string value in (name, sym_enum typ values) else if name = obus_flag then let name, typ, values = flag_of_string value in (name, sym_flag typ values) else assert false) symbols in (name, members, symbols, annotations) obus-1.2.5/src/internals/oBus_introspect_ext.mli000066400000000000000000000143711456737751200220510ustar00rootroot00000000000000(* * oBus_introspect_ext.mli * ----------------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** OBus extended introspection *) (** By default, introspection documents do not convey semantical information, such as enumerations or flags. However it is possible to attach information to interfaces and members. This module implements an extended introspection format, which can be encoded into standard introspection documents by using annotations. *) (** {6 Annotations} *) (** The following annotations are used to encode additional informations into D-Bus introspection documents *) val obus_enum : string (** The [org.ocamlcore.forge.obus.Enum] annotation *) val obus_flag : string (** The [org.ocamlcore.forge.obus.Flag] annotation *) val obus_type : string (** The [org.ocamlcore.forge.obus.Type] annotation *) val obus_itype : string (** The [org.ocamlcore.forge.obus.IType] annotation *) val obus_otype : string (** The [org.ocamlcore.forge.obus.OType] annotation *) (** {6 Extended types} *) type basic = private | Byte | Boolean | Int16 | Int32 | Int64 | Uint16 | Uint32 | Uint64 | Double | String | Signature | Object_path | Unix_fd | Enum of OBus_value.T.basic * (OBus_value.V.basic * string) list (** An enumeration. The first argument is the real D-Bus type and the second is a list of [(constant, keyword)]. For example: {[ Enum(OBus_value.T.Uint32, [(OBus_value.V.Uint32 1l, "ok"); (OBus_value.V.Uint32 2l, "fail")]) ]} Note that the real D-Bus type must be {!OBus_value.T.Byte} or an integer type. *) | Flag of OBus_value.T.basic * (OBus_value.V.basic * string) list (** A flag. The first argument is the real type and the second is a list of [(bits, keyword)]. For example: {[ Flag(OBus_value.T.Uint32, [(OBus_value.V.Uint32 0x01l, "flag1"); (OBus_value.V.Uint32 0x02l, "flag2"); (OBus_value.V.Uint32 0x04l, "flag3")]) ]} Note that the real D-Bus type must be {!OBus_value.T.Byte} or an integer type. *) type single = | Basic of basic | Structure of single list | Array of single | Dict of basic * single | Variant type sequence = single list (** {8 Constructors} *) val byte : basic val boolean : basic val int16 : basic val int32 : basic val int64 : basic val uint16 : basic val uint32 : basic val uint64 : basic val double : basic val string : basic val signature : basic val object_path : basic val unix_fd : basic val enum : OBus_value.T.basic -> (OBus_value.V.basic * string) list -> basic val flag : OBus_value.T.basic -> (OBus_value.V.basic * string) list -> basic val basic : basic -> single val structure : single list -> single val array : single -> single val dict : basic -> single -> single val variant : single (** {6 Terms} *) (** A term represent a type, where symbols have not been resolved. *) type term = private | Term of string * term list (** A term. Arguments are - the symbol name, which is either the name of a D-Bus type or a user defined type - the arguments taken by the function associated to the symbol *) | Tuple of term list (** A list of terms, packed into a tuple. Tuples are always mapped to D-Bus structures. Moreover it is ensured that there is never a type of the form [Tuple[t]]. *) val term : string -> term list -> term (** Construct a term *) val tuple : term list -> term (** Construct a tuple. If the list is of length 1, the type itself is returned. *) (** {6 Symbols} *) (** Type of user-definable symbols *) type symbol = private | Sym_enum of OBus_value.T.basic * (OBus_value.V.basic * string) list | Sym_flag of OBus_value.T.basic * (OBus_value.V.basic * string) list val sym_enum : OBus_value.T.basic -> (OBus_value.V.basic * string) list -> symbol (** Create an enumeration *) val sym_flag : OBus_value.T.basic -> (OBus_value.V.basic * string) list -> symbol (** Create a flag type *) (** {6 Conversions} *) (** {8 Stripping} *) (** The following functions remove extension from types. *) val strip_basic : basic -> OBus_value.T.basic val strip_single : single -> OBus_value.T.single val strip_sequence : sequence -> OBus_value.T.sequence (** {8 Projections} *) (** The following functions project standard D-Bus types into extended D-Bus types *) val project_basic : OBus_value.T.basic -> basic val project_single : OBus_value.T.single -> single val project_sequence : OBus_value.T.sequence -> sequence (** {8 Types to terms conversions} *) (** The following functions returns the term associated to a standard D-Bus type *) val term_of_basic : OBus_value.T.basic -> term val term_of_single : OBus_value.T.single -> term val term_of_sequence : OBus_value.T.sequence -> term (** {8 Symbols resolution} *) type env = (string * symbol) list (** An environment, mapping names to symbol *) exception Resolve_error of string (** Exception raised when the resolution of symbols of a type fails. *) val resolve : env -> term -> single (** [resolve env term] resolves symbols of [term] using [env], and returns the extended type it denotes. It raises {!Resolve_error} if a symbol of [term] is not found in [env]. *) (** {6 Extended introspection ast} *) type name = string type annotation = name * string type argument = name option * term type access = OBus_introspect.access = Read | Write | Read_write type member = | Method of name * argument list * argument list * annotation list | Signal of name * argument list * annotation list | Property of name * term * access * annotation list type interface = name * member list * (string * symbol) list * annotation list (** {6 Encoding/decoding} *) val encode : interface -> OBus_introspect.interface (** Encode the given interface into a standard one by using annotations *) val decode : OBus_introspect.interface -> interface (** Decode the given standard interface into an extended one by decoding annotations *) obus-1.2.5/src/internals/oBus_name.ml000066400000000000000000000175001456737751200175430ustar00rootroot00000000000000(* * oBus_name.ml * ------------ * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open String open OBus_string type bus = string type interface = string type member = string type error = string (* +-----------------------------------------------------------------+ | Bus names | +-----------------------------------------------------------------+ *) let is_unique name = length name > 0 && unsafe_get name 0 = ':' let validate_unique_connection str = let fail i msg = Some{ typ = "unique connection name"; str = str; ofs = i; msg = msg } and len = length str in let rec element_start i = if i = len then fail i "empty element" else match unsafe_get str i with | 'A' .. 'Z' | 'a' .. 'z' | '_' | '-' | '0' .. '9'-> element (i + 1) | '.' -> fail i "empty element" | _ -> fail i "invalid character" and element i = if i = len then None else match unsafe_get str i with | '.' -> element_start (i + 1) | 'A' .. 'Z' | 'a' .. 'z' | '_' | '-' | '0' .. '9'-> element (i + 1) | _ -> fail i "invalid character" and first_element i = if i = len then fail (-1) "must contains at least two elements" else match unsafe_get str i with | '.' -> element_start (i + 1) | 'A' .. 'Z' | 'a' .. 'z' | '_' | '-' | '0' .. '9'-> first_element (i + 1) | _ -> fail i "invalid character" in if len > OBus_protocol.max_name_length then fail (-1) "name too long" else if len = 1 then fail 1 "premature end of name" else match unsafe_get str 1 with | 'A' .. 'Z' | 'a' .. 'z' | '_' | '-' | '0' .. '9'-> first_element 2 | '.' -> fail 1 "empty element" | _ -> fail 1 "invalid character" let validate_bus_other str = let fail i msg = Some{ typ = "unique connection name"; str = str; ofs = i; msg = msg } and len = length str in let rec element_start i = if i = len then fail i "empty element" else match unsafe_get str i with | 'A' .. 'Z' | 'a' .. 'z' | '_' | '-' -> element (i + 1) | '.' -> fail i "empty element" | _ -> fail i "invalid character" and element i = if i = len then None else match unsafe_get str i with | '.' -> element_start (i + 1) | 'A' .. 'Z' | 'a' .. 'z' | '_' | '-' | '0' .. '9'-> element (i + 1) | _ -> fail i "invalid character" and first_element i = if i = len then fail (-1) "must contains at least two elements" else match unsafe_get str i with | '.' -> element_start (i + 1) | 'A' .. 'Z' | 'a' .. 'z' | '_' | '-' | '0' .. '9'-> first_element (i + 1) | _ -> fail i "invalid character" in if len > OBus_protocol.max_name_length then fail (-1) "name too long" else match unsafe_get str 1 with | 'A' .. 'Z' | 'a' .. 'z' | '_' | '-' | '0' .. '9'-> first_element 2 | '.' -> element_start 2 | _ -> fail 1 "invalid character" let validate_bus = function | "" -> Some{ typ = "bus name"; str = ""; ofs = -1; msg = "empty name" } | str -> match unsafe_get str 0 with | ':' -> validate_unique_connection str | 'A' .. 'Z' | 'a' .. 'z' | '_' | '-' -> validate_bus_other str | '.' -> Some{ typ = "bus name"; str = str; ofs = 0; msg = "empty element" } | _ -> Some{ typ = "bus name"; str = str; ofs = 0; msg = "invalid character" } (* +-----------------------------------------------------------------+ | Interface names | +-----------------------------------------------------------------+ *) let validate_interface str = let fail i msg = Some{ typ = "interface name"; str = str; ofs = i; msg = msg } and len = length str in let rec element_start i = if i = len then fail i "empty element" else match unsafe_get str i with | 'A' .. 'Z' | 'a' .. 'z' | '_' -> element (i + 1) | '.' -> fail i "empty element" | _ -> fail i "invalid character" and element i = if i = len then None else match unsafe_get str i with | '.' -> element_start (i + 1) | 'A' .. 'Z' | 'a' .. 'z' | '_' | '0' .. '9' -> element (i + 1) | _ -> fail i "invalid character" and first_element i = if i = len then fail (-1) "must contains at least two elements" else match unsafe_get str i with | '.' -> element_start (i + 1) | 'A' .. 'Z' | 'a' .. 'z' | '_' | '0' .. '9' -> first_element (i + 1) | _ -> fail i "invalid character" in if len > OBus_protocol.max_name_length then fail (-1) "name too long" else if len = 0 then fail (-1) "empty name" else match unsafe_get str 0 with | 'A' .. 'Z' | 'a' .. 'z' | '_' -> first_element 1 | '.' -> fail 0 "empty element" | _ -> fail 0 "invalid character" (* +-----------------------------------------------------------------+ | Member names | +-----------------------------------------------------------------+ *) let validate_member str = let fail i msg = Some{ typ = "member name"; str = str; ofs = i; msg = msg } and len = length str in let rec aux i = if i = len then None else match unsafe_get str i with | 'A' .. 'Z' | 'a' .. 'z' | '_' | '0' .. '9' -> aux (i + 1) | _ -> fail i "invalid character" in if len > OBus_protocol.max_name_length then fail (-1) "name too long" else if len = 0 then fail (-1) "empty name" else match unsafe_get str 0 with | 'A' .. 'Z' | 'a' .. 'z' | '_' -> aux 1 | _ -> fail 0 "invalid character" (* +-----------------------------------------------------------------+ | Error names | +-----------------------------------------------------------------+ *) let validate_error str = (* Error names have the same restriction as interface names *) match validate_interface str with | None -> None | Some error -> Some{ error with typ = "error name" } (* +-----------------------------------------------------------------+ | Name translation | +-----------------------------------------------------------------+ *) (* Split a name into blocks. Blocks are the longest sub-strings matched by the regulare expression: "[A-Z]*[^A-Z.]*" *) let split name = (* Recognize the first part of a block: "[A-Z]*" *) let rec part1 i = if i = String.length name then i else match name.[i] with | 'A' .. 'Z' -> part1 (i + 1) | _ -> part2 i (* Recognize the second part of a block: "[^A-Z.]*" *) and part2 i = if i = String.length name then i else match name.[i] with | 'A' .. 'Z' | '.' -> i | _ -> part2 (i + 1) in let rec split i = if i = String.length name then [] else let j = part1 i in if j = i then (* Skip empty blocks *) split (i + 1) else String.sub name i (j - i) :: split j in split 0 let ocaml_lid name = String.uncapitalize_ascii (String.concat "_" (List.map String.lowercase_ascii (split name))) let ocaml_uid name = String.capitalize_ascii (String.concat "_" (List.map String.lowercase_ascii (split name))) let haskell_lid name = String.uncapitalize_ascii (String.concat "" (split name)) let haskell_uid name = String.capitalize_ascii (String.concat "" (split name)) obus-1.2.5/src/internals/oBus_name.mli000066400000000000000000000042151456737751200177130ustar00rootroot00000000000000(* * oBus_name.mli * ------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** D-Bus names *) (** For specific restrictions on D-Bus names, see @see the specification General restrictions include: - names must not be empty - names must contains only ascii characters *) type bus = OBus_string.t (** Bus names example: "org.freedesktop.DBus", ":1.1" *) val validate_bus : OBus_string.validator val is_unique : bus -> bool (** Tell wether a bus name is a unique connection name or not. *) type interface = OBus_string.t (** Interface names example: "org.freedesktop.DBus.Introspectable" *) val validate_interface : OBus_string.validator type member = OBus_string.t (** Methods/signals/properties names example: "StartServiceByName" *) val validate_member : OBus_string.validator type error = OBus_string.t (** Error names example: "org.freedesktop.Error.UnknownMethod" *) val validate_error : OBus_string.validator (** {6 D-Bus name translation} *) val split : string -> string list (** Split a name into longest blocks matched by the regular expression "[A-Z]*[^A-Z.]*": [split "SetCPUFreqGovernor" = ["Set"; "CPUFreq"; "Governor"]], [split "org.freedesktop.DBus" = ["org"; "freedesktop"; "DBus"]] *) val ocaml_lid : string -> string (** Translate a D-Bus name into an ocaml-style lower-identifier: [caml_lid "SetCPUFreqGovernor" = "set_cpufreq_governor"] *) val ocaml_uid : string -> string (** Translate a D-Bus name into an ocaml-style upper-identifier: [caml_uid "org.freedesktop.DBus" = "Org_freedesktop_dbus"] *) val haskell_lid : string -> string (** Translate a D-Bus name into an haskell-style lower-identifier: [haskell_lid "SetCPUFreqGovernor" = "setCPUFreqGovernor"] *) val haskell_uid : string -> string (** Translate a D-Bus name into an haskell-style upper-identifier: [haskell_uid "org.freedesktop.DBus" = "OrgFreedesktopDBus"] *) obus-1.2.5/src/internals/oBus_path.ml000066400000000000000000000073631456737751200175650ustar00rootroot00000000000000(* * oBus_path.ml * ------------ * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Printf open String open OBus_string type element = string type t = element list let compare = Stdlib.compare let is_valid_char ch = (ch >= 'A' && ch <= 'Z') || (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') || ch = '_' let validate str = let fail i msg = Some{ typ = "path"; str = str; ofs = i; msg = msg } and len = length str in let rec aux_element_start i = if i = len then fail (i - 1) "trailing '/'" else if is_valid_char (unsafe_get str i) then aux_element (i + 1) else if unsafe_get str i = '/' then fail i "empty element" else fail i "invalid char" and aux_element i = if i = len then None else let ch = unsafe_get str i in if ch = '/' then aux_element_start (i + 1) else if is_valid_char ch then aux_element (i + 1) else fail i "invalid char" in if len = 0 then fail (-1) "empty path" else if unsafe_get str 0 = '/' then if len = 1 then None else aux_element_start 1 else fail 0 "must start with '/'" let validate_element = function | "" -> Some{ typ = "path element"; str = ""; ofs = -1; msg = "empty element" } | str -> let len = length str in let rec aux i = if i = len then None else if is_valid_char (unsafe_get str i) then aux (i + 1) else Some{ typ = "path element"; str = ""; ofs = i; msg = "invalid character" } in aux 0 let empty = [] let to_string = function | [] -> "/" | path -> let str = Bytes.create (List.fold_left (fun len elt -> len + length elt + 1) 0 path) in ignore (List.fold_left (fun pos elt -> match validate_element elt with | None -> Bytes.unsafe_set str pos '/'; let len = length elt in unsafe_blit elt 0 str (pos + 1) len; pos + 1 + len | Some error -> raise (Invalid_string error)) 0 path); Bytes.unsafe_to_string str let of_string str = match validate str with | Some error -> raise (OBus_string.Invalid_string error) | None -> let rec aux acc j = if j <= 0 then acc else let i = rindex_from str j '/' in let len = j - i in let elt = Bytes.create len in unsafe_blit str (i + 1) elt 0 len; let elt = Bytes.unsafe_to_string elt in aux (elt :: acc) (i - 1) in aux [] (length str - 1) let escape s = let len = length s in let r = Bytes.create (len * 2) in for i = 0 to len - 1 do let j = i * 2 and n = int_of_char s.[i] in Bytes.set r j (char_of_int (n land 15 + int_of_char 'a')); Bytes.set r (j + 1) (char_of_int (n lsr 4 + int_of_char 'a')) done; Bytes.unsafe_to_string r let unescape s = let len = length s / 2 in let r = Bytes.create len in for i = 0 to len - 1 do let j = i * 2 in Bytes.set r i (char_of_int ((int_of_char s.[j] - int_of_char 'a') lor ((int_of_char s.[j + 1] - int_of_char 'a') lsl 4))) done; Bytes.unsafe_to_string r let rec after prefix path = match prefix, path with | [], p -> Some p | e1 :: p1, e2 :: p2 when e1 = e2 -> after p1 p2 | _ -> None let unique_id = ref (0, 0) let generate () = let id1 , id2 = !unique_id in let id2 = id2 + 1 in if id2 < 0 then unique_id := (id1 + 1, 0) else unique_id := (id1, id2); ["org"; "ocamlcore"; "forge"; "obus"; sprintf "%d_%d" id1 id2] obus-1.2.5/src/internals/oBus_path.mli000066400000000000000000000024711456737751200177310ustar00rootroot00000000000000(* * oBus_path.mli * ------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Manipulation of dbus object paths *) type element = string (** A path component *) type t = element list (** A complete path *) val compare : t -> t -> int (** Same as [Stdlib.compare]. It allows this module to be used as argument to the functors [Set.Make] and [Map.Make]. *) (** {6 Construction} *) val empty : t (** Empty path *) val after : t -> t -> t option (** [after prefix path] if [path = prefix @ p] return [Some p], and [None] if not *) val of_string : string -> t (** Create an object path from a string. @raise OBus_string.Invalid_string if the given string does not represent a valid object path *) val to_string : t -> string (** Return a string representation of an object path *) (** {6 Helpers} *) val escape : string -> element (** Escape an arbitrary string into a valid element *) val unescape : element -> string (** Interpret escape sequence to get back the original string *) val generate : unit -> t (** [generate ()] generate a new unique path *) (** {6 Validation} *) val validate : OBus_string.validator val validate_element : OBus_string.validator obus-1.2.5/src/internals/oBus_protocol.ml000066400000000000000000000007331456737751200204640ustar00rootroot00000000000000(* * oBus_protocol.ml * ---------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* Protocol parameters *) let max_type_recursion_depth = 32 let max_name_length = 255 let max_array_size = 1 lsl 26 let max_message_size = 1 lsl 27 let bus_name = "org.freedesktop.DBus" let bus_path = ["org"; "freedesktop"; "DBus"] let bus_interface = "org.freedesktop.DBus" obus-1.2.5/src/internals/oBus_string.ml000066400000000000000000000071471456737751200201370ustar00rootroot00000000000000(* * oBus_string.ml * -------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) type t = string type error = { typ : string; str : string; ofs : int; msg : string; } let typ e = e.typ let str e = e.str let ofs e = e.ofs let msg e = e.msg type validator = string -> error option exception Invalid_string of error let error_message error = if error.ofs < 0 then Printf.sprintf "invalid D-Bus %s (%S): %s" error.typ error.str error.msg else Printf.sprintf "invalid D-Bus %s (%S), at position %d: %s" error.typ error.str error.ofs error.msg let () = Printexc.register_printer (function | Invalid_string error -> Some(error_message error) | _ -> None) let () = Printexc.register_printer (function | Invalid_string error -> Some(error_message error) | _ -> None) let validate s = let fail i msg = Some{ typ = "string"; str = s; ofs = i; msg = msg } in let len = String.length s in let rec main i = if i = len then None else let ch = String.unsafe_get s i in match ch with | '\x00' -> fail i "null byte" | '\x01' .. '\x7f' -> main (i + 1) | '\xc0' .. '\xdf' -> if i + 1 >= len then fail len "premature end of UTF8 sequence" else begin let byte1 = Char.code (String.unsafe_get s (i + 1)) in if byte1 land 0xc0 != 0x80 then fail (i + 1) "malformed UTF8 sequence" else if ((Char.code ch land 0x1f) lsl 6) lor (byte1 land 0x3f) < 0x80 then fail i "overlong UTF8 sequence" else main (i + 2) end | '\xe0' .. '\xef' -> if i + 2 >= len then fail len "premature end of UTF8 sequence" else begin let byte1 = Char.code (String.unsafe_get s (i + 1)) and byte2 = Char.code (String.unsafe_get s (i + 2)) in if byte1 land 0xc0 != 0x80 then fail (i + 1) "malformed UTF8 sequence" else if byte2 land 0xc0 != 0x80 then fail (i + 2) "malformed UTF8 sequence" else if ((Char.code ch land 0x0f) lsl 12) lor ((byte1 land 0x3f) lsl 6) lor (byte2 land 0x3f) < 0x800 then fail i "overlong UTF8 sequence" else main (i + 3) end | '\xf0' .. '\xf7' -> if i + 3 >= len then fail len "premature end of UTF8 sequence" else begin let byte1 = Char.code (String.unsafe_get s (i + 1)) and byte2 = Char.code (String.unsafe_get s (i + 2)) and byte3 = Char.code (String.unsafe_get s (i + 3)) in if byte1 land 0xc0 != 0x80 then fail (i + 1) "malformed UTF8 sequence" else if byte2 land 0xc0 != 0x80 then fail (i + 2) "malformed UTF8 sequence" else if byte3 land 0xc0 != 0x80 then fail (i + 3) "malformed UTF8 sequence" else if ((Char.code ch land 0x0f) lsl 18) lor ((byte1 land 0x3f) lsl 12) lor ((byte2 land 0x3f) lsl 6) lor (byte3 land 0x3f) < 0x10000 then fail i "overlong UTF8 sequence" else main (i + 4) end | _ -> fail i "invalid start of UTF8 sequence" in main 0 let assert_validate validator str = match validator str with | Some error -> raise (Invalid_string error) | None -> () obus-1.2.5/src/internals/oBus_string.mli000066400000000000000000000031041456737751200202750ustar00rootroot00000000000000(* * oBus_string.mli * --------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Restriction on strings used with D-Bus *) (** There are a lot of restrictions for strings used in D-Bus. OBus only verifies strings when a message is sent or received *) type error = { (** Contains informations about invalid strings *) typ : string; (** Type of string ("string", "bus name", "error name", "path", ...) *) str : string; (** The string which fail to validate *) ofs : int; (** is the position in bytes where the validation failed *) msg : string; (** explains why the string failed to validate *) } val error_message : error -> string (** [error_message error] returns a human-readable error message *) (** {8 Error projections} *) val typ : error -> string val str : error -> string val ofs : error -> int val msg : error -> string (** {6 Validators} *) type validator = string -> error option (** Tests if a string is correct. - if it is, returns [None] - if not, returns [Some(ofs, msg)] *) exception Invalid_string of error val assert_validate : validator -> string -> unit (** Raises {!Invalid_string} if the given string failed to validate *) (** {6 Common strings} *) type t = string (** Type for common strings, restrictions are: - a string must be encoded in valid UTF-8 - a string must not contains the null byte *) val validate : validator (** Validation function for common strings *) obus-1.2.5/src/internals/oBus_type_ext_lexer.mll000066400000000000000000000052501456737751200220360ustar00rootroot00000000000000(* * oBus_type_ext_lexer.mll * ----------------------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) { open OBus_value 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 type term = | Term of string * term list | Tuple of term list let term name args = Term(name, args) let tuple = function | [t] -> t | l -> Tuple l } let int = ['-' '+']? ['0'-'9']+ let space = [' ' '\t' '\n'] let ident = ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* rule enum_and_flag = parse | space* (ident as name) space* ":" (ident as typ) "=" { let typ = match typ with | "byte" -> T.Byte | "int16" -> T.Int16 | "int32" -> T.Int32 | "int64" -> T.Int64 | "uint16" -> T.Uint16 | "uint32" -> T.Uint32 | "uint64" -> T.Uint64 | _ -> fail lexbuf "invalid key type: %S" typ in let values = values typ lexbuf in eoi lexbuf; (name, typ, values) } | "" { fail lexbuf "syntax error" } and eoi = parse | space* eof { () } | "" { fail lexbuf "syntax error" } and values typ = parse | space* (int as key) space* ":" space* (ident as name) { let key = match typ with | T.Byte -> V.Byte(char_of_int (int_of_string key)) | T.Int16 -> V.Int16(int_of_string key) | T.Int32 -> V.Int32(Int32.of_string key) | T.Int64 -> V.Int64(Int64.of_string key) | T.Uint16 -> V.Uint16(int_of_string key) | T.Uint32 -> V.Uint32(Int32.of_string key) | T.Uint64 -> V.Uint64(Int64.of_string key) | _ -> assert false in if comma lexbuf then (key, name) :: values typ lexbuf else [(key, name)] } | "" { fail lexbuf "syntax error" } and comma = parse | space* "," { true } | "" { false } and single = parse | space* (ident as name) { term name [] } | space* "(" (ident as name) { term name (type_args lexbuf) } | space* "<" { tuple (tuple_args lexbuf) } | "" { fail lexbuf "syntax error" } and type_args = parse | space* ")" { [] } | "" { let typ = single lexbuf in typ :: type_args lexbuf } and tuple_args = parse | space* ">" { [] } | "" { let typ = single lexbuf in typ :: tuple_args2 lexbuf } and tuple_args2 = parse | space* ">" { [] } | space* "," { let typ = single lexbuf in typ :: tuple_args2 lexbuf } | "" { fail lexbuf "syntax error" } obus-1.2.5/src/internals/oBus_util.ml000066400000000000000000000161751456737751200176070ustar00rootroot00000000000000(* * oBus_util.ml * ------------ * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) let section = Lwt_log.Section.make "obus(util)" let rec assoc x = function | [] -> None | (k, v) :: _ when k = x -> Some(v) | _ :: l -> assoc x l let rec assq x = function | [] -> None | (k, v) :: _ when k == x -> Some(v) | _ :: l -> assq x l let rec find_map f = function | [] -> None | x :: l -> match f x with | None -> find_map f l | y -> y let filter_map f l = List.fold_right (fun x acc -> match f x with | None -> acc | Some(v) -> v :: acc) l [] let part_map f l = List.fold_right (fun x (success, failure) -> match f x with | None -> (success, x :: failure) | Some(v) -> (v :: success, failure)) l ([], []) type ('a, 'b) either = | InL of 'a | InR of 'b let split f l = List.fold_right (fun x (a, b) -> match f x with | InL x -> (x :: a, b) | InR x -> (a, x :: b)) l ([], []) let map_option x f = match x with | Some x -> Some(f x) | None -> None let encode_char n = if n < 10 then char_of_int (n + Char.code '0') else if n < 16 then char_of_int (n + Char.code 'a' - 10) else assert false let hex_encode str = let len = String.length str in let hex = Bytes.create (len * 2) in for i = 0 to len - 1 do let n = Char.code (String.unsafe_get str i) in Bytes.unsafe_set hex (i * 2) (encode_char (n lsr 4)); Bytes.unsafe_set hex (i * 2 + 1) (encode_char (n land 15)) done; Bytes.unsafe_to_string hex let decode_char ch = match ch with | '0'..'9' -> Char.code ch - Char.code '0' | 'a'..'f' -> Char.code ch - Char.code 'a' + 10 | 'A'..'F' -> Char.code ch - Char.code 'A' + 10 | _ -> raise (Invalid_argument "OBus_util.decode_char") let hex_decode hex = if String.length hex mod 2 <> 0 then raise (Invalid_argument "OBus_util.hex_decode"); let len = String.length hex / 2 in let str = Bytes.create len in for i = 0 to len - 1 do Bytes.unsafe_set str i (char_of_int ((decode_char (String.unsafe_get hex (i * 2)) lsl 4) lor (decode_char (String.unsafe_get hex (i * 2 + 1))))) done; Bytes.unsafe_to_string str let homedir = lazy( try Lwt.return (Sys.getenv "HOME") with Not_found -> let%lwt pwd = Lwt_unix.getpwuid (Unix.getuid ()) in Lwt.return pwd.Unix.pw_dir ) let init_pseudo = Lazy.from_fun Random.self_init let fill_pseudo buffer pos len = ignore (Lwt_log.warning ~section "using pseudo-random generator"); Lazy.force init_pseudo; for i = pos to pos + len - 1 do Bytes.unsafe_set buffer i (char_of_int (Random.int 256)) done let fill_random buffer pos len = try let ic = open_in "/dev/urandom" in let n = input ic buffer pos len in if n < len then fill_pseudo buffer (pos + n) (len - n); close_in ic with exn -> ignore (Lwt_log.warning_f ~exn ~section "failed to get random data from /dev/urandom"); fill_pseudo buffer pos len let random_string n = let str = Bytes.create n in fill_random str 0 n; Bytes.unsafe_to_string str let random_int32 () = let r = random_string 4 in Int32.logor (Int32.logor (Int32.of_int (Char.code r.[0])) (Int32.shift_left (Int32.of_int (Char.code r.[1])) 8)) (Int32.logor (Int32.shift_left (Int32.of_int (Char.code r.[2])) 16) (Int32.shift_left (Int32.of_int (Char.code r.[3])) 24)) let random_int () = Int32.to_int (random_int32 ()) let random_int64 () = Int64.logor (Int64.of_int32 (random_int32 ())) (Int64.shift_left (Int64.of_int32 (random_int32 ())) 32) (* Compute the sha1 of a string. Copied from uuidm by Daniel C. Bünzli, which can be found here: http://erratique.ch/software/uuidm *) let sha_1 s = let sha_1_pad s = let len = String.length s in let blen = 8 * len in let rem = len mod 64 in let mlen = if rem > 55 then len + 128 - rem else len + 64 - rem in let m = Bytes.create mlen in Bytes.blit_string s 0 m 0 len; Bytes.fill m len (mlen - len) '\x00'; Bytes.set m len '\x80'; if Sys.word_size > 32 then begin Bytes.set m (mlen - 8) (Char.unsafe_chr (blen lsr 56 land 0xFF)); Bytes.set m (mlen - 7) (Char.unsafe_chr (blen lsr 48 land 0xFF)); Bytes.set m (mlen - 6) (Char.unsafe_chr (blen lsr 40 land 0xFF)); Bytes.set m (mlen - 5) (Char.unsafe_chr (blen lsr 32 land 0xFF)); end; Bytes.set m (mlen - 4) (Char.unsafe_chr (blen lsr 24 land 0xFF)); Bytes.set m (mlen - 3) (Char.unsafe_chr (blen lsr 16 land 0xFF)); Bytes.set m (mlen - 2) (Char.unsafe_chr (blen lsr 8 land 0xFF)); Bytes.set m (mlen - 1) (Char.unsafe_chr (blen land 0xFF)); Bytes.unsafe_to_string m in (* Operations on int32 *) let ( &&& ) = ( land ) in let ( lor ) = Int32.logor in let ( lxor ) = Int32.logxor in let ( land ) = Int32.logand in let ( ++ ) = Int32.add in let lnot = Int32.lognot in let sr = Int32.shift_right in let sl = Int32.shift_left in let cls n x = (sl x n) lor (Int32.shift_right_logical x (32 - n)) in (* Start *) let m = sha_1_pad s in let w = Array.make 16 0l in let h0 = ref 0x67452301l in let h1 = ref 0xEFCDAB89l in let h2 = ref 0x98BADCFEl in let h3 = ref 0x10325476l in let h4 = ref 0xC3D2E1F0l in let a = ref 0l in let b = ref 0l in let c = ref 0l in let d = ref 0l in let e = ref 0l in for i = 0 to ((String.length m) / 64) - 1 do (* For each block *) (* Fill w *) let base = i * 64 in for j = 0 to 15 do let k = base + (j * 4) in w.(j) <- sl (Int32.of_int (Char.code m.[k])) 24 lor sl (Int32.of_int (Char.code m.[k + 1])) 16 lor sl (Int32.of_int (Char.code m.[k + 2])) 8 lor (Int32.of_int (Char.code m.[k + 3])) done; (* Loop *) a := !h0; b := !h1; c := !h2; d := !h3; e := !h4; for t = 0 to 79 do let f, k = if t <= 19 then (!b land !c) lor ((lnot !b) land !d), 0x5A827999l else if t <= 39 then !b lxor !c lxor !d, 0x6ED9EBA1l else if t <= 59 then (!b land !c) lor (!b land !d) lor (!c land !d), 0x8F1BBCDCl else !b lxor !c lxor !d, 0xCA62C1D6l in let s = t &&& 0xF in if (t >= 16) then begin w.(s) <- cls 1 begin w.((s + 13) &&& 0xF) lxor w.((s + 8) &&& 0xF) lxor w.((s + 2) &&& 0xF) lxor w.(s) end end; let temp = (cls 5 !a) ++ f ++ !e ++ w.(s) ++ k in e := !d; d := !c; c := cls 30 !b; b := !a; a := temp; done; (* Update *) h0 := !h0 ++ !a; h1 := !h1 ++ !b; h2 := !h2 ++ !c; h3 := !h3 ++ !d; h4 := !h4 ++ !e done; let h = Bytes.create 20 in let i2s h k i = Bytes.set h (k ) (Char.unsafe_chr ((Int32.to_int (sr i 24)) &&& 0xFF)); Bytes.set h (k + 1) (Char.unsafe_chr ((Int32.to_int (sr i 16)) &&& 0xFF)); Bytes.set h (k + 2) (Char.unsafe_chr ((Int32.to_int (sr i 8)) &&& 0xFF)); Bytes.set h (k + 3) (Char.unsafe_chr ((Int32.to_int i) &&& 0xFF)); in i2s h 0 !h0; i2s h 4 !h1; i2s h 8 !h2; i2s h 12 !h3; i2s h 16 !h4; Bytes.unsafe_to_string h obus-1.2.5/src/internals/oBus_util.mli000066400000000000000000000037721456737751200177570ustar00rootroot00000000000000(* * oBus_util.mli * ------------- * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** This module contain various functions used by both the library and the tools *) val assoc : 'a -> ('a * 'b) list -> 'b option (** Same as List.assoc but return an option *) val assq : 'a -> ('a * 'b) list -> 'b option (** Same as List.assq but return an option *) val find_map : ('a -> 'b option) -> 'a list -> 'b option (** [find_map f l] Apply [f] on each element of [l] until it return [Some x] and return that result or return [None] *) val filter_map : ('a -> 'b option) -> 'a list -> 'b list (** [filter_map f l] apply [f] on each element of [l] and return the list ef element for which [f] succeed (i.e. return [Some x]) *) val part_map : ('a -> 'b option) -> 'a list -> 'b list * 'a list (** [part_map f l] apply [f] on each element of [l] and return the list of success and the list of failure *) type ('a, 'b) either = | InL of 'a | InR of 'b val split : ('a -> ('b, 'c) either) -> 'a list -> 'b list * 'c list (** Split a list *) val map_option : 'a option -> ('a -> 'b) -> 'b option val sha_1 : string -> string (** Compute the sha1 of a string *) val hex_encode : string -> string val hex_decode : string -> string (** A hex-encoded string is a string where each character is replaced by two hexadecimal characters which represent his ascii code *) val homedir : string Lwt.t Lazy.t (** The home directory *) (** {6 Random number generation} *) (** All the following functions try to generate random numbers using /dev/urandom and can fallback to pseudo-random generator *) val fill_random : bytes -> int -> int -> unit (** [fill_random str ofs len] Fill the given string from [ofs] to [ofs+len-1] with random bytes. *) val random_string : int -> string val random_int : unit -> int val random_int32 : unit -> int32 val random_int64 : unit -> int64 obus-1.2.5/src/internals/oBus_value.ml000066400000000000000000001262251456737751200177440ustar00rootroot00000000000000(* * oBus_value.mlp * -------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) let section = Lwt_log.Section.make "obus(value)" open Format let print_seq left right sep f pp l = pp_print_string pp left; begin match l with | [] -> () | x :: l -> pp_open_box pp 0; f pp x; List.iter (fprintf pp "%s@ %a" sep f) l; pp_close_box pp () end; pp_print_string pp right let print_list f = print_seq "[" "]" ";" f let print_tuple f = print_seq "(" ")" "," f let string_of printer x = let buf = Buffer.create 42 in let pp = formatter_of_buffer buf in pp_set_margin pp max_int; printer pp x; pp_print_flush pp (); Buffer.contents buf module T = struct (* +---------------------------------------------------------------+ | D-Bus type definitions | +---------------------------------------------------------------+ *) type basic = | Byte | Boolean | Int16 | Int32 | Int64 | Uint16 | Uint32 | Uint64 | Double | String | Signature | Object_path | Unix_fd type single = | Basic of basic | Structure of single list | Array of single | Dict of basic * single | Variant type sequence = single list let byte = Byte let boolean = Boolean let int16 = Int16 let int32 = Int32 let int64 = Int64 let uint16 = Uint16 let uint32 = Uint32 let uint64 = Uint64 let double = Double let string = String let signature = Signature let object_path = Object_path let unix_fd = Unix_fd let basic_byte = Basic Byte let basic_boolean = Basic Boolean let basic_int16 = Basic Int16 let basic_int32 = Basic Int32 let basic_int64 = Basic Int64 let basic_uint16 = Basic Uint16 let basic_uint32 = Basic Uint32 let basic_uint64 = Basic Uint64 let basic_double = Basic Double let basic_string = Basic String let basic_signature = Basic Signature let basic_object_path = Basic Object_path let basic_unix_fd = Basic Unix_fd let basic t = Basic t let structure t = Structure t let array t = Array t let dict tk tv = Dict(tk, tv) let variant = Variant (* +---------------------------------------------------------------+ | D-Bus types pretty-printing | +---------------------------------------------------------------+ *) let string_of_basic = function | Byte -> "T.Byte" | Boolean -> "T.Boolean" | Int16 -> "T.Int16" | Int32 -> "T.Int32" | Int64 -> "T.Int64" | Uint16 -> "T.Uint16" | Uint32 -> "T.Uint32" | Uint64 -> "T.Uint64" | Double -> "T.Double" | String -> "T.String" | Signature -> "T.Signature" | Object_path -> "T.Object_path" | Unix_fd -> "T.Unix_fd" let print_basic pp t = pp_print_string pp (string_of_basic t) let rec print_single pp = function | Basic t -> fprintf pp "@[<2>T.Basic@ %a@]" print_basic t | Array t -> fprintf pp "@[<2>T.Array@,(%a)@]" print_single t | Dict(tk, tv) -> fprintf pp "@[<2>T.Dict@,(@[%a,@ %a@])@]" print_basic tk print_single tv | Structure tl -> fprintf pp "@[<2>T.Structure@ %a@]" print_sequence tl | Variant -> fprintf pp "T.Variant" and print_sequence pp = print_list print_single pp let string_of_single = string_of print_single let string_of_sequence = string_of print_sequence end type signature = T.sequence (* +-----------------------------------------------------------------+ | Signature validation | +-----------------------------------------------------------------+ *) exception Invalid_signature of string * string let () = Printexc.register_printer (function | Invalid_signature(str, msg) -> Some(Printf.sprintf "invalid signature %S: %s" str msg) | _ -> None) let invalid_signature str msg = raise (Invalid_signature(str, msg)) let length_validate_signature l = let rec aux_single length depth_struct depth_array depth_dict_entry = function | T.Basic _ | T.Variant -> length + 1 | T.Array t -> if depth_array > OBus_protocol.max_type_recursion_depth then failwith "too many nested arrays" else aux_single (length + 1) depth_struct (depth_array + 1) depth_dict_entry t | T.Dict(tk, tv) -> if depth_array > OBus_protocol.max_type_recursion_depth then failwith "too many nested arrays" else if depth_dict_entry > OBus_protocol.max_type_recursion_depth then failwith "too many nested dict-entries" else aux_single (length + 4) depth_struct (depth_array + 1) (depth_dict_entry + 1) tv | T.Structure [] -> failwith "empty struct" | T.Structure tl -> if depth_struct > OBus_protocol.max_type_recursion_depth then failwith "too many nested structs" else aux_sequence (length + 2) (depth_struct + 1) depth_array depth_dict_entry tl and aux_sequence length depth_struct depth_array depth_dict_entry = function | [] -> if length > 255 then failwith "signature too long" else length | t :: tl -> aux_sequence (aux_single length depth_struct depth_array depth_dict_entry t) depth_struct depth_array depth_dict_entry tl in let _ : int = aux_sequence 0 0 0 0 l in () let signature_length l = let rec aux_single length = function | T.Basic _ | T.Variant -> length + 1 | T.Array t -> aux_single (length + 1) t | T.Dict(tk, tv) -> aux_single (length + 4) tv | T.Structure tl -> aux_sequence (length + 2) tl and aux_sequence length = function | [] -> length | t :: tl -> aux_sequence (aux_single length t) tl in aux_sequence 0 l let validate_signature l = try length_validate_signature l; None with Failure msg -> Some msg (* +-----------------------------------------------------------------+ | Signature reading | +-----------------------------------------------------------------+ *) let signature_of_string str = let len = String.length str and i = ref 0 in let fail fmt = Printf.ksprintf (invalid_signature str) fmt in let get_char () = let j = !i in if j = len then fail "premature end of signature" else begin i := j + 1; String.unsafe_get str j end in let parse_basic msg = function | 'y' -> T.Byte | 'b' -> T.Boolean | 'n' -> T.Int16 | 'q' -> T.Uint16 | 'i' -> T.Int32 | 'u' -> T.Uint32 | 'x' -> T.Int64 | 't' -> T.Uint64 | 'd' -> T.Double | 's' -> T.String | 'o' -> T.Object_path | 'g' -> T.Signature | 'h' -> T.Unix_fd | chr -> fail msg chr in let rec parse_single = function | 'a' -> begin match get_char () with | '{' -> let tk = parse_basic "invalid basic type code: %c" (get_char ()) in let tv = parse_single (get_char ()) in begin match get_char () with | '}' -> T.Dict(tk, tv) | _ -> fail "'}' missing" end | ch -> T.Array(parse_single ch) end | '(' -> T.Structure (parse_struct (get_char ())) | ')' -> fail "')' without '('" | 'v' -> T.Variant | ch -> T.Basic(parse_basic "invalid type code: %c" ch); and parse_struct = function | ')' -> [] | ch -> let t = parse_single ch in let l = parse_struct (get_char ()) in t :: l in let rec read_sequence () = if !i = len then [] else let t = parse_single (get_char ()) in let l = read_sequence () in t :: l in let s = read_sequence () in match validate_signature s with | Some msg -> invalid_signature str msg | None -> s (* +-----------------------------------------------------------------+ | Signature writing | +-----------------------------------------------------------------+ *) let string_of_signature signature = let len = signature_length signature in let str = Bytes.create len and i = ref 0 in let put_char ch = let j = !i in Bytes.unsafe_set str j ch; i := j + 1 in let write_basic t = put_char (match t with | T.Byte -> 'y' | T.Boolean -> 'b' | T.Int16 -> 'n' | T.Uint16 -> 'q' | T.Int32 -> 'i' | T.Uint32 -> 'u' | T.Int64 -> 'x' | T.Uint64 -> 't' | T.Double -> 'd' | T.String -> 's' | T.Object_path -> 'o' | T.Signature -> 'g' | T.Unix_fd -> 'h') in let rec write_single = function | T.Basic t -> write_basic t | T.Array t -> put_char 'a'; write_single t | T.Dict(tk, tv) -> put_char 'a'; put_char '{'; write_basic tk; write_single tv; put_char '}' | T.Structure tl -> put_char '('; List.iter write_single tl; put_char ')' | T.Variant -> put_char 'v' in List.iter write_single signature; let str = Bytes.unsafe_to_string str in try length_validate_signature signature; str with Failure msg -> raise (Invalid_signature(str, msg)) module V = struct (* +---------------------------------------------------------------+ | D-Bus value definitions | +---------------------------------------------------------------+ *) type basic = | Byte of char | Boolean of bool | Int16 of int | Int32 of int32 | Int64 of int64 | Uint16 of int | Uint32 of int32 | Uint64 of int64 | Double of float | String of string | Signature of signature | Object_path of OBus_path.t | Unix_fd of Unix.file_descr type single = | Basic of basic | Array of T.single * single list | Byte_array of string | Dict of T.basic * T.single * (basic * single) list | Structure of single list | Variant of single type sequence = single list let byte x = Byte x let boolean x = Boolean x let int16 x = Int16 x let int32 x = Int32 x let int64 x = Int64 x let uint16 x = Uint16 x let uint32 x = Uint32 x let uint64 x = Uint64 x let double x = Double x let string x = String x let signature x = Signature x let object_path x = Object_path x let unix_fd x = Unix_fd x let basic_byte x = Basic(Byte x) let basic_boolean x = Basic(Boolean x) let basic_int16 x = Basic(Int16 x) let basic_int32 x = Basic(Int32 x) let basic_int64 x = Basic(Int64 x) let basic_uint16 x = Basic(Uint16 x) let basic_uint32 x = Basic(Uint32 x) let basic_uint64 x = Basic(Uint64 x) let basic_double x = Basic(Double x) let basic_string x = Basic(String x) let basic_signature x = Basic(Signature x) let basic_object_path x = Basic(Object_path x) let basic_unix_fd x = Basic(Unix_fd x) let basic x = Basic x let byte_array x = Byte_array x let structure x = Structure x let variant x = Variant x (* +---------------------------------------------------------------+ | Value typing | +---------------------------------------------------------------+ *) let type_of_basic = function | Byte _ -> T.Byte | Boolean _ -> T.Boolean | Int16 _ -> T.Int16 | Int32 _ -> T.Int32 | Int64 _ -> T.Int64 | Uint16 _ -> T.Uint16 | Uint32 _ -> T.Uint32 | Uint64 _ -> T.Uint64 | Double _ -> T.Double | String _ -> T.String | Signature _ -> T.Signature | Object_path _ -> T.Object_path | Unix_fd _ -> T.Unix_fd let rec type_of_single = function | Basic x -> T.Basic(type_of_basic x) | Array(t, x) -> T.Array t | Byte_array x -> T.Array(T.Basic T.Byte) | Dict(tk, tv, x) -> T.Dict(tk, tv) | Structure x -> T.Structure(List.map type_of_single x) | Variant _ -> T.Variant let type_of_sequence = List.map type_of_single let array t l = if t = T.Basic T.Byte then begin let s = Bytes.create (List.length l) and i = ref 0 in List.iter (function | Basic(Byte x) -> Bytes.unsafe_set s !i x; incr i | _ -> invalid_arg "OBus_value.array: unexpected type") l; Byte_array (Bytes.unsafe_to_string s) end else begin List.iter (fun x -> if type_of_single x <> t then invalid_arg "OBus_value.array: unexpected type") l; Array(t, l) end let dict tk tv l = List.iter (fun (k, v) -> if type_of_basic k <> tk || type_of_single v <> tv then invalid_arg "OBus_value.dict: unexpected type") l; Dict(tk, tv, l) let unsafe_array t l = if t = T.Basic T.Byte then array t l else Array(t, l) let unsafe_dict tk tv l = Dict(tk, tv, l) (* +---------------------------------------------------------------+ | Value pretty-printing | +---------------------------------------------------------------+ *) let print_basic pp = function | Byte x -> fprintf pp "%C" x | Boolean x -> fprintf pp "%B" x | Int16 x -> fprintf pp "%d" x | Int32 x -> fprintf pp "%ldl" x | Int64 x -> fprintf pp "%LdL" x | Uint16 x -> fprintf pp "%d" x | Uint32 x -> fprintf pp "%ldl" x | Uint64 x -> fprintf pp "%LdL" x | Double x -> fprintf pp "%f" x | String x -> fprintf pp "%S" x | Signature x -> T.print_sequence pp x | Object_path x -> print_list (fun pp elt -> fprintf pp "%S" elt) pp x | Unix_fd x -> pp_print_string pp "" let explode str = let rec aux acc = function | -1 -> acc | i -> aux (Basic(Byte(String.unsafe_get str i)) :: acc) (i - 1) in aux [] (String.length str - 1) let rec print_single pp = function | Basic v -> print_basic pp v | Array(t, l) -> print_list print_single pp l | Byte_array s -> print_single pp (Array(T.Basic T.Byte, explode s)) | Dict(tk, tv, l) -> print_list (fun pp (k, v) -> fprintf pp "(@[%a,@ %a@])" print_basic k print_single v) pp l | Structure l -> print_sequence pp l | Variant x -> fprintf pp "@[<2>Variant@,(@[%a,@ %a@])@]" T.print_single (type_of_single x) print_single x and print_sequence pp l = print_tuple print_single pp l let string_of_basic = string_of print_basic let string_of_single = string_of print_single let string_of_sequence = string_of print_sequence (* +---------------------------------------------------------------+ | FDs closing | +---------------------------------------------------------------+ *) module FD_set = Set.Make(struct type t = Unix.file_descr let compare = compare end) let basic_contains_fds = function | T.Unix_fd -> true | _ -> false let rec single_contains_fds = function | T.Basic t -> basic_contains_fds t | T.Array t -> single_contains_fds t | T.Dict(tk, tv) -> basic_contains_fds tk || single_contains_fds tv | T.Structure t -> sequence_contains_fds t | T.Variant -> true and sequence_contains_fds t = List.exists single_contains_fds t let basic_collect_fds acc = function | Unix_fd fd -> FD_set .add fd acc | _ -> acc let rec single_collect_fds acc = function | Basic v -> basic_collect_fds acc v | Array(t, l) -> if single_contains_fds t then List.fold_left single_collect_fds acc l else acc | Dict(tk, tv, l) -> if basic_contains_fds tk || single_contains_fds tv then List.fold_left (fun acc (k, v) -> basic_collect_fds (single_collect_fds acc v) k) acc l else acc | Structure l -> sequence_collect_fds acc l | Variant v -> single_collect_fds acc v | Byte_array _ -> acc and sequence_collect_fds acc l = List.fold_left single_collect_fds acc l let close_fds collect_fds value = 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 "failed to close file descriptor: %s" (Unix.error_message err)) (FD_set.elements (collect_fds FD_set.empty value)) let basic_close = close_fds basic_collect_fds let single_close = close_fds single_collect_fds let sequence_close = close_fds sequence_collect_fds (* +---------------------------------------------------------------+ | FDs duplicating | +---------------------------------------------------------------+ *) module FD_map = Map.Make(struct type t = Unix.file_descr let compare = compare end) let basic_dup map = function | Unix_fd fd -> begin try Unix_fd(FD_map.find fd !map) with Not_found -> let fd' = Unix.dup fd in map := FD_map.add fd fd' !map; Unix_fd fd end | value -> value let rec single_dup map = function | Basic x -> basic (basic_dup map x) | Array(t, l) as v -> if single_contains_fds t then array t (List.map (single_dup map) l) else v | Dict(tk, tv, l) as v -> if basic_contains_fds tk || single_contains_fds tv then dict tk tv (List.map (fun (k, v) -> (basic_dup map k, single_dup map v)) l) else v | Structure l -> structure (sequence_dup map l) | Byte_array _ as v -> v | Variant x -> variant (single_dup map x) and sequence_dup map l = List.map (single_dup map) l let basic_dup value = basic_dup (ref FD_map.empty) value let single_dup value = single_dup (ref FD_map.empty) value let sequence_dup value = sequence_dup (ref FD_map.empty) value end module C = struct (* +---------------------------------------------------------------+ | Type combinators | +---------------------------------------------------------------+ *) exception Signature_mismatch type 'a basic = { basic_type : T.basic; basic_make : 'a -> V.basic; basic_cast : V.basic -> 'a; } type 'a single = { single_type : T.single; single_make : 'a -> V.single; single_cast : V.single -> 'a; } type 'a sequence = { sequence_type : T.sequence; sequence_make : 'a -> V.sequence; sequence_cast : V.sequence -> 'a; } let type_basic t = t.basic_type let type_single t = t.single_type let type_sequence t = t.sequence_type let make_basic t x = t.basic_make x let make_single t x = t.single_make x let make_sequence t x = t.sequence_make x let cast_basic t x = t.basic_cast x let cast_single t x = t.single_cast x let cast_sequence t x = t.sequence_cast x let dyn_basic t = { basic_type = t; basic_make = (fun x -> if V.type_of_basic x <> t then failwith "OBus_value.dyn_basic: types mismatach" else x); basic_cast = (fun x -> if V.type_of_basic x <> t then raise Signature_mismatch else x); } let dyn_single t = { single_type = t; single_make = (fun x -> if V.type_of_single x <> t then failwith "OBus_value.dyn_single: types mismatach" else x); single_cast = (fun x -> if V.type_of_single x <> t then raise Signature_mismatch else x); } let dyn_sequence t = { sequence_type = t; sequence_make = (fun x -> if V.type_of_sequence x <> t then failwith "OBus_value.dyn_sequence: types mismatach" else x); sequence_cast = (fun x -> if V.type_of_sequence x <> t then raise Signature_mismatch else x); } let byte = { basic_type = T.Byte; basic_make = V.byte; basic_cast = (function | V.Byte x -> x | _ -> raise Signature_mismatch); } let basic_byte = { single_type = T.basic_byte; single_make = V.basic_byte; single_cast = (function | V.Basic(V.Byte x) -> x | _ -> raise Signature_mismatch); } let boolean = { basic_type = T.Boolean; basic_make = V.boolean; basic_cast = (function | V.Boolean x -> x | _ -> raise Signature_mismatch); } let basic_boolean = { single_type = T.basic_boolean; single_make = V.basic_boolean; single_cast = (function | V.Basic(V.Boolean x) -> x | _ -> raise Signature_mismatch); } let int16 = { basic_type = T.Int16; basic_make = V.int16; basic_cast = (function | V.Int16 x -> x | _ -> raise Signature_mismatch); } let basic_int16 = { single_type = T.basic_int16; single_make = V.basic_int16; single_cast = (function | V.Basic(V.Int16 x) -> x | _ -> raise Signature_mismatch); } let int32 = { basic_type = T.Int32; basic_make = V.int32; basic_cast = (function | V.Int32 x -> x | _ -> raise Signature_mismatch); } let basic_int32 = { single_type = T.basic_int32; single_make = V.basic_int32; single_cast = (function | V.Basic(V.Int32 x) -> x | _ -> raise Signature_mismatch); } let int64 = { basic_type = T.Int64; basic_make = V.int64; basic_cast = (function | V.Int64 x -> x | _ -> raise Signature_mismatch); } let basic_int64 = { single_type = T.basic_int64; single_make = V.basic_int64; single_cast = (function | V.Basic(V.Int64 x) -> x | _ -> raise Signature_mismatch); } let uint16 = { basic_type = T.Uint16; basic_make = V.uint16; basic_cast = (function | V.Uint16 x -> x | _ -> raise Signature_mismatch); } let basic_uint16 = { single_type = T.basic_uint16; single_make = V.basic_uint16; single_cast = (function | V.Basic(V.Uint16 x) -> x | _ -> raise Signature_mismatch); } let uint32 = { basic_type = T.Uint32; basic_make = V.uint32; basic_cast = (function | V.Uint32 x -> x | _ -> raise Signature_mismatch); } let basic_uint32 = { single_type = T.basic_uint32; single_make = V.basic_uint32; single_cast = (function | V.Basic(V.Uint32 x) -> x | _ -> raise Signature_mismatch); } let uint64 = { basic_type = T.Uint64; basic_make = V.uint64; basic_cast = (function | V.Uint64 x -> x | _ -> raise Signature_mismatch); } let basic_uint64 = { single_type = T.basic_uint64; single_make = V.basic_uint64; single_cast = (function | V.Basic(V.Uint64 x) -> x | _ -> raise Signature_mismatch); } let double = { basic_type = T.Double; basic_make = V.double; basic_cast = (function | V.Double x -> x | _ -> raise Signature_mismatch); } let basic_double = { single_type = T.basic_double; single_make = V.basic_double; single_cast = (function | V.Basic(V.Double x) -> x | _ -> raise Signature_mismatch); } let string = { basic_type = T.String; basic_make = V.string; basic_cast = (function | V.String x -> x | _ -> raise Signature_mismatch); } let basic_string = { single_type = T.basic_string; single_make = V.basic_string; single_cast = (function | V.Basic(V.String x) -> x | _ -> raise Signature_mismatch); } let signature = { basic_type = T.Signature; basic_make = V.signature; basic_cast = (function | V.Signature x -> x | _ -> raise Signature_mismatch); } let basic_signature = { single_type = T.basic_signature; single_make = V.basic_signature; single_cast = (function | V.Basic(V.Signature x) -> x | _ -> raise Signature_mismatch); } let object_path = { basic_type = T.Object_path; basic_make = V.object_path; basic_cast = (function | V.Object_path x -> x | _ -> raise Signature_mismatch); } let basic_object_path = { single_type = T.basic_object_path; single_make = V.basic_object_path; single_cast = (function | V.Basic(V.Object_path x) -> x | _ -> raise Signature_mismatch); } let unix_fd = { basic_type = T.Unix_fd; basic_make = V.unix_fd; basic_cast = (function | V.Unix_fd x -> x | _ -> raise Signature_mismatch); } let basic_unix_fd = { single_type = T.basic_unix_fd; single_make = V.basic_unix_fd; single_cast = (function | V.Basic(V.Unix_fd x) -> x | _ -> raise Signature_mismatch); } let basic t = { single_type = T.Basic t.basic_type; single_make = (fun x -> V.Basic(t.basic_make x)); single_cast = (function | V.Basic x -> t.basic_cast x | _ -> raise Signature_mismatch); } let structure t = { single_type = T.Structure t.sequence_type; single_make = (fun x -> V.Structure(t.sequence_make x)); single_cast = (function | V.Structure x -> t.sequence_cast x | _ -> raise Signature_mismatch); } let byte_array = { single_type = T.Array T.basic_byte; single_make = V.byte_array; single_cast = (function | V.Byte_array x -> x | _ -> raise Signature_mismatch); } let array t = { single_type = T.Array t.single_type; single_make = (fun x -> V.Array(t.single_type, List.map t.single_make x)); single_cast = (function | V.Array(t', x) when t.single_type = t' -> List.map t.single_cast x | V.Byte_array s when t.single_type = T.basic_byte -> let rec aux acc = function | -1 -> acc | i -> aux (t.single_cast (V.basic_byte (String.unsafe_get s i)) :: acc) (i - 1) in aux [] (String.length s - 1) | _ -> raise Signature_mismatch); } let dict tk tv = { single_type = T.Dict(tk.basic_type, tv.single_type); single_make = (fun x -> V.Dict(tk.basic_type, tv.single_type, List.map (fun (k, v) -> (tk.basic_make k, tv.single_make v)) x)); single_cast = (function | V.Dict(tk', tv', x) when tk.basic_type = tk' && tv.single_type = tv' -> List.map (fun (k, v) -> (tk.basic_cast k, tv.single_cast v)) x | _ -> raise Signature_mismatch); } let variant = { single_type = T.Variant; single_make = (fun x -> V.Variant x); single_cast = (function | V.Variant x -> x | _ -> raise Signature_mismatch); } let seq_cons t tl = { sequence_type = t.single_type :: tl.sequence_type; sequence_make = (fun (x, l) -> t.single_make x :: tl.sequence_make l); sequence_cast = (function | x :: l -> (t.single_cast x, tl.sequence_cast l) | [] -> raise Signature_mismatch); } let seq0 = { sequence_type = []; sequence_make = (fun () -> []); sequence_cast = (function | [] -> () | _ -> raise Signature_mismatch); } let seq1 t1 = { sequence_type = [t1.single_type]; sequence_make = (fun x1 -> [t1.single_make x1]); sequence_cast = (function | [x1] -> t1.single_cast x1 | _ -> raise Signature_mismatch); } let seq2 t1 t2 = { sequence_type = [t1.single_type; t2.single_type]; sequence_make = (fun (x1, x2) -> [t1.single_make x1; t2.single_make x2]); sequence_cast = (function | [x1; x2] -> (t1.single_cast x1, t2.single_cast x2) | _ -> raise Signature_mismatch); } let seq3 t1 t2 t3 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type]; sequence_make = (fun (x1, x2, x3) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3]); sequence_cast = (function | [x1; x2; x3] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3) | _ -> raise Signature_mismatch); } let seq4 t1 t2 t3 t4 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type]; sequence_make = (fun (x1, x2, x3, x4) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4]); sequence_cast = (function | [x1; x2; x3; x4] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4) | _ -> raise Signature_mismatch); } let seq5 t1 t2 t3 t4 t5 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type; t5.single_type]; sequence_make = (fun (x1, x2, x3, x4, x5) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4; t5.single_make x5]); sequence_cast = (function | [x1; x2; x3; x4; x5] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4, t5.single_cast x5) | _ -> raise Signature_mismatch); } let seq6 t1 t2 t3 t4 t5 t6 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type; t5.single_type; t6.single_type]; sequence_make = (fun (x1, x2, x3, x4, x5, x6) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4; t5.single_make x5; t6.single_make x6]); sequence_cast = (function | [x1; x2; x3; x4; x5; x6] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4, t5.single_cast x5, t6.single_cast x6) | _ -> raise Signature_mismatch); } let seq7 t1 t2 t3 t4 t5 t6 t7 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type; t5.single_type; t6.single_type; t7.single_type]; sequence_make = (fun (x1, x2, x3, x4, x5, x6, x7) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4; t5.single_make x5; t6.single_make x6; t7.single_make x7]); sequence_cast = (function | [x1; x2; x3; x4; x5; x6; x7] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4, t5.single_cast x5, t6.single_cast x6, t7.single_cast x7) | _ -> raise Signature_mismatch); } let seq8 t1 t2 t3 t4 t5 t6 t7 t8 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type; t5.single_type; t6.single_type; t7.single_type; t8.single_type]; sequence_make = (fun (x1, x2, x3, x4, x5, x6, x7, x8) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4; t5.single_make x5; t6.single_make x6; t7.single_make x7; t8.single_make x8]); sequence_cast = (function | [x1; x2; x3; x4; x5; x6; x7; x8] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4, t5.single_cast x5, t6.single_cast x6, t7.single_cast x7, t8.single_cast x8) | _ -> raise Signature_mismatch); } let seq9 t1 t2 t3 t4 t5 t6 t7 t8 t9 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type; t5.single_type; t6.single_type; t7.single_type; t8.single_type; t9.single_type]; sequence_make = (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4; t5.single_make x5; t6.single_make x6; t7.single_make x7; t8.single_make x8; t9.single_make x9]); sequence_cast = (function | [x1; x2; x3; x4; x5; x6; x7; x8; x9] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4, t5.single_cast x5, t6.single_cast x6, t7.single_cast x7, t8.single_cast x8, t9.single_cast x9) | _ -> raise Signature_mismatch); } let seq10 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type; t5.single_type; t6.single_type; t7.single_type; t8.single_type; t9.single_type; t10.single_type]; sequence_make = (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4; t5.single_make x5; t6.single_make x6; t7.single_make x7; t8.single_make x8; t9.single_make x9; t10.single_make x10]); sequence_cast = (function | [x1; x2; x3; x4; x5; x6; x7; x8; x9; x10] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4, t5.single_cast x5, t6.single_cast x6, t7.single_cast x7, t8.single_cast x8, t9.single_cast x9, t10.single_cast x10) | _ -> raise Signature_mismatch); } let seq11 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type; t5.single_type; t6.single_type; t7.single_type; t8.single_type; t9.single_type; t10.single_type; t11.single_type]; sequence_make = (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4; t5.single_make x5; t6.single_make x6; t7.single_make x7; t8.single_make x8; t9.single_make x9; t10.single_make x10; t11.single_make x11]); sequence_cast = (function | [x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4, t5.single_cast x5, t6.single_cast x6, t7.single_cast x7, t8.single_cast x8, t9.single_cast x9, t10.single_cast x10, t11.single_cast x11) | _ -> raise Signature_mismatch); } let seq12 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type; t5.single_type; t6.single_type; t7.single_type; t8.single_type; t9.single_type; t10.single_type; t11.single_type; t12.single_type]; sequence_make = (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4; t5.single_make x5; t6.single_make x6; t7.single_make x7; t8.single_make x8; t9.single_make x9; t10.single_make x10; t11.single_make x11; t12.single_make x12]); sequence_cast = (function | [x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11; x12] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4, t5.single_cast x5, t6.single_cast x6, t7.single_cast x7, t8.single_cast x8, t9.single_cast x9, t10.single_cast x10, t11.single_cast x11, t12.single_cast x12) | _ -> raise Signature_mismatch); } let seq13 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type; t5.single_type; t6.single_type; t7.single_type; t8.single_type; t9.single_type; t10.single_type; t11.single_type; t12.single_type; t13.single_type]; sequence_make = (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4; t5.single_make x5; t6.single_make x6; t7.single_make x7; t8.single_make x8; t9.single_make x9; t10.single_make x10; t11.single_make x11; t12.single_make x12; t13.single_make x13]); sequence_cast = (function | [x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11; x12; x13] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4, t5.single_cast x5, t6.single_cast x6, t7.single_cast x7, t8.single_cast x8, t9.single_cast x9, t10.single_cast x10, t11.single_cast x11, t12.single_cast x12, t13.single_cast x13) | _ -> raise Signature_mismatch); } let seq14 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type; t5.single_type; t6.single_type; t7.single_type; t8.single_type; t9.single_type; t10.single_type; t11.single_type; t12.single_type; t13.single_type; t14.single_type]; sequence_make = (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4; t5.single_make x5; t6.single_make x6; t7.single_make x7; t8.single_make x8; t9.single_make x9; t10.single_make x10; t11.single_make x11; t12.single_make x12; t13.single_make x13; t14.single_make x14]); sequence_cast = (function | [x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4, t5.single_cast x5, t6.single_cast x6, t7.single_cast x7, t8.single_cast x8, t9.single_cast x9, t10.single_cast x10, t11.single_cast x11, t12.single_cast x12, t13.single_cast x13, t14.single_cast x14) | _ -> raise Signature_mismatch); } let seq15 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type; t5.single_type; t6.single_type; t7.single_type; t8.single_type; t9.single_type; t10.single_type; t11.single_type; t12.single_type; t13.single_type; t14.single_type; t15.single_type]; sequence_make = (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4; t5.single_make x5; t6.single_make x6; t7.single_make x7; t8.single_make x8; t9.single_make x9; t10.single_make x10; t11.single_make x11; t12.single_make x12; t13.single_make x13; t14.single_make x14; t15.single_make x15]); sequence_cast = (function | [x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4, t5.single_cast x5, t6.single_cast x6, t7.single_cast x7, t8.single_cast x8, t9.single_cast x9, t10.single_cast x10, t11.single_cast x11, t12.single_cast x12, t13.single_cast x13, t14.single_cast x14, t15.single_cast x15) | _ -> raise Signature_mismatch); } let seq16 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15 t16 = { sequence_type = [t1.single_type; t2.single_type; t3.single_type; t4.single_type; t5.single_type; t6.single_type; t7.single_type; t8.single_type; t9.single_type; t10.single_type; t11.single_type; t12.single_type; t13.single_type; t14.single_type; t15.single_type; t16.single_type]; sequence_make = (fun (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16) -> [t1.single_make x1; t2.single_make x2; t3.single_make x3; t4.single_make x4; t5.single_make x5; t6.single_make x6; t7.single_make x7; t8.single_make x8; t9.single_make x9; t10.single_make x10; t11.single_make x11; t12.single_make x12; t13.single_make x13; t14.single_make x14; t15.single_make x15; t16.single_make x16]); sequence_cast = (function | [x1; x2; x3; x4; x5; x6; x7; x8; x9; x10; x11; x12; x13; x14; x15; x16] -> (t1.single_cast x1, t2.single_cast x2, t3.single_cast x3, t4.single_cast x4, t5.single_cast x5, t6.single_cast x6, t7.single_cast x7, t8.single_cast x8, t9.single_cast x9, t10.single_cast x10, t11.single_cast x11, t12.single_cast x12, t13.single_cast x13, t14.single_cast x14, t15.single_cast x15, t16.single_cast x16) | _ -> raise Signature_mismatch); } end (* +-----------------------------------------------------------------+ | Arguments | +-----------------------------------------------------------------+ *) open C type 'a arguments = { arg_types : 'a C.sequence; arg_names : string option list; } let arguments ~arg_types ~arg_names = if List.length arg_types.C.sequence_type = List.length arg_names then { arg_types = arg_types; arg_names = arg_names; } else invalid_arg "OBus_value.arguments" let arg_types t = t.arg_types let arg_names t = t.arg_names let arg_cons (name, t) args = { arg_types = seq_cons t args.arg_types; arg_names = name :: args.arg_names; } let arg0 = { arg_types = seq0; arg_names = []; } let arg1 (n1, t1) = { arg_types = seq1 t1; arg_names = [n1]; } let arg2 (n1, t1) (n2, t2) = { arg_types = seq2 t1 t2; arg_names = [n1; n2]; } let arg3 (n1, t1) (n2, t2) (n3, t3) = { arg_types = seq3 t1 t2 t3; arg_names = [n1; n2; n3]; } let arg4 (n1, t1) (n2, t2) (n3, t3) (n4, t4) = { arg_types = seq4 t1 t2 t3 t4; arg_names = [n1; n2; n3; n4]; } let arg5 (n1, t1) (n2, t2) (n3, t3) (n4, t4) (n5, t5) = { arg_types = seq5 t1 t2 t3 t4 t5; arg_names = [n1; n2; n3; n4; n5]; } let arg6 (n1, t1) (n2, t2) (n3, t3) (n4, t4) (n5, t5) (n6, t6) = { arg_types = seq6 t1 t2 t3 t4 t5 t6; arg_names = [n1; n2; n3; n4; n5; n6]; } let arg7 (n1, t1) (n2, t2) (n3, t3) (n4, t4) (n5, t5) (n6, t6) (n7, t7) = { arg_types = seq7 t1 t2 t3 t4 t5 t6 t7; arg_names = [n1; n2; n3; n4; n5; n6; n7]; } let arg8 (n1, t1) (n2, t2) (n3, t3) (n4, t4) (n5, t5) (n6, t6) (n7, t7) (n8, t8) = { arg_types = seq8 t1 t2 t3 t4 t5 t6 t7 t8; arg_names = [n1; n2; n3; n4; n5; n6; n7; n8]; } let arg9 (n1, t1) (n2, t2) (n3, t3) (n4, t4) (n5, t5) (n6, t6) (n7, t7) (n8, t8) (n9, t9) = { arg_types = seq9 t1 t2 t3 t4 t5 t6 t7 t8 t9; arg_names = [n1; n2; n3; n4; n5; n6; n7; n8; n9]; } let arg10 (n1, t1) (n2, t2) (n3, t3) (n4, t4) (n5, t5) (n6, t6) (n7, t7) (n8, t8) (n9, t9) (n10, t10) = { arg_types = seq10 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10; arg_names = [n1; n2; n3; n4; n5; n6; n7; n8; n9; n10]; } let arg11 (n1, t1) (n2, t2) (n3, t3) (n4, t4) (n5, t5) (n6, t6) (n7, t7) (n8, t8) (n9, t9) (n10, t10) (n11, t11) = { arg_types = seq11 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11; arg_names = [n1; n2; n3; n4; n5; n6; n7; n8; n9; n10; n11]; } let arg12 (n1, t1) (n2, t2) (n3, t3) (n4, t4) (n5, t5) (n6, t6) (n7, t7) (n8, t8) (n9, t9) (n10, t10) (n11, t11) (n12, t12) = { arg_types = seq12 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12; arg_names = [n1; n2; n3; n4; n5; n6; n7; n8; n9; n10; n11; n12]; } let arg13 (n1, t1) (n2, t2) (n3, t3) (n4, t4) (n5, t5) (n6, t6) (n7, t7) (n8, t8) (n9, t9) (n10, t10) (n11, t11) (n12, t12) (n13, t13) = { arg_types = seq13 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13; arg_names = [n1; n2; n3; n4; n5; n6; n7; n8; n9; n10; n11; n12; n13]; } let arg14 (n1, t1) (n2, t2) (n3, t3) (n4, t4) (n5, t5) (n6, t6) (n7, t7) (n8, t8) (n9, t9) (n10, t10) (n11, t11) (n12, t12) (n13, t13) (n14, t14) = { arg_types = seq14 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 t14; arg_names = [n1; n2; n3; n4; n5; n6; n7; n8; n9; n10; n11; n12; n13; n14]; } let arg15 (n1, t1) (n2, t2) (n3, t3) (n4, t4) (n5, t5) (n6, t6) (n7, t7) (n8, t8) (n9, t9) (n10, t10) (n11, t11) (n12, t12) (n13, t13) (n14, t14) (n15, t15) = { arg_types = seq15 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15; arg_names = [n1; n2; n3; n4; n5; n6; n7; n8; n9; n10; n11; n12; n13; n14; n15]; } let arg16 (n1, t1) (n2, t2) (n3, t3) (n4, t4) (n5, t5) (n6, t6) (n7, t7) (n8, t8) (n9, t9) (n10, t10) (n11, t11) (n12, t12) (n13, t13) (n14, t14) (n15, t15) (n16, t16) = { arg_types = seq16 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 t12 t13 t14 t15 t16; arg_names = [n1; n2; n3; n4; n5; n6; n7; n8; n9; n10; n11; n12; n13; n14; n15; n16]; } obus-1.2.5/src/internals/oBus_value.mli000066400000000000000000000431101456737751200201040ustar00rootroot00000000000000(* * oBus_value.mli * -------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** D-Bus types, values and converters *) (** {6 Types} *) (** D-Bus types *) module T : sig type basic = | Byte | Boolean | Int16 | Int32 | Int64 | Uint16 | Uint32 | Uint64 | Double | String | Signature | Object_path | Unix_fd type single = | Basic of basic | Structure of single list | Array of single | Dict of basic * single | Variant type sequence = single list (** {6 Constructors} *) val byte : basic val boolean : basic val int16 : basic val int32 : basic val int64 : basic val uint16 : basic val uint32 : basic val uint64 : basic val double : basic val string : basic val signature : basic val object_path : basic val unix_fd : basic val basic : basic -> single val structure : single list -> single val array : single -> single val dict : basic -> single -> single val variant : single val basic_byte : single val basic_boolean : single val basic_int16 : single val basic_int32 : single val basic_int64 : single val basic_uint16 : single val basic_uint32 : single val basic_uint64 : single val basic_double : single val basic_string : single val basic_signature : single val basic_object_path : single val basic_unix_fd : single (** {6 Pretty printing} *) val print_basic : Format.formatter -> basic -> unit val print_single : Format.formatter -> single -> unit val print_sequence : Format.formatter -> sequence -> unit val string_of_basic : basic -> string val string_of_single : single -> string val string_of_sequence : sequence -> string end (** {6 Signatures} *) type signature = T.sequence exception Invalid_signature of string * string (** [Invalid_signature(signature, message)] is raised when a signature is invalid. [signature] is a string representation of the signature (using D-Bus type codes) and [message] is an error message. *) val string_of_signature : signature -> string (** Returns a string representation of a signature using D-Bus type codes. If the signature is not valid (for example it is too long), it raises {!Invalid_signature}. *) val signature_of_string : string -> signature (** Parses a signature. Raises {!Invalid_signature} if the signature is not correct *) val validate_signature : signature -> string option (** Not all signatures are valid. [validate] returns [None] if the given signature is a valid one, or [Some reason] if it is not. *) (** {6 Values} *) (** D-Bus values *) module V : sig type basic = | Byte of char | Boolean of bool | Int16 of int | Int32 of int32 | Int64 of int64 | Uint16 of int | Uint32 of int32 | Uint64 of int64 | Double of float | String of string | Signature of signature | Object_path of OBus_path.t | Unix_fd of Unix.file_descr type single = private | Basic of basic | Array of T.single * single list | Byte_array of string | Dict of T.basic * T.single * (basic * single) list | Structure of single list | Variant of single type sequence = single list (** {6 Constructors} *) val byte : char -> basic val boolean : bool -> basic val int16 : int -> basic val int32 : int32 -> basic val int64 : int64 -> basic val uint16 : int -> basic val uint32 : int32 -> basic val uint64 : int64 -> basic val double : float -> basic val string : string -> basic val signature : signature -> basic val object_path : OBus_path.t -> basic val unix_fd : Unix.file_descr -> basic val basic : basic -> single val array : T.single -> single list -> single val byte_array : string -> single val dict : T.basic -> T.single -> (basic * single) list -> single val structure : single list -> single val variant : single -> single (**/**) val unsafe_array : T.single -> single list -> single val unsafe_dict : T.basic -> T.single -> (basic * single) list -> single (**/**) val basic_byte : char -> single val basic_boolean : bool -> single val basic_int16 : int -> single val basic_int32 : int32 -> single val basic_int64 : int64 -> single val basic_uint16 : int -> single val basic_uint32 : int32 -> single val basic_uint64 : int64 -> single val basic_double : float -> single val basic_string : string -> single val basic_signature : signature -> single val basic_object_path : OBus_path.t -> single val basic_unix_fd : Unix.file_descr -> single (** {6 Typing} *) val type_of_basic : basic -> T.basic val type_of_single : single -> T.single val type_of_sequence : sequence -> T.sequence (** {6 Pretty printing} *) val print_basic : Format.formatter -> basic -> unit val print_single : Format.formatter -> single -> unit val print_sequence : Format.formatter -> sequence -> unit val string_of_basic : basic -> string val string_of_single : single -> string val string_of_sequence : sequence -> string (** {6 File descriptors utils} *) val basic_dup : basic -> basic val single_dup : single -> single val sequence_dup : sequence -> sequence (** Duplicates all file descriptors of the given value *) val basic_close : basic -> unit Lwt.t val single_close : single -> unit Lwt.t val sequence_close : sequence -> unit Lwt.t (** Closes all file descriptors of the given value *) end (** {6 Type converters} *) (** Type converters *) module C : sig (** This module offers a convenient way of constructing a boxed D-Bus value from a OCaml value, and of casting a boxed D-Bus value into a OCaml value. *) type 'a basic (** Type of converters dealing with basic D-Bus types *) type 'a single (** Type of converters dealing with single D-Bus types *) type 'a sequence (** Type of converters dealing with sequence D-Bus types *) (** {6 Constructors} *) val byte : char basic val boolean : bool basic val int16 : int basic val int32 : int32 basic val int64 : int64 basic val uint16 : int basic val uint32 : int32 basic val uint64 : int64 basic val double : float basic val string : string basic val signature : signature basic val object_path : OBus_path.t basic val unix_fd : Unix.file_descr basic val basic : 'a basic -> 'a single val structure : 'a sequence -> 'a single val byte_array : string single val array : 'a single -> 'a list single val dict : 'a basic -> 'b single -> ('a * 'b) list single val variant : V.single single val basic_byte : char single val basic_boolean : bool single val basic_int16 : int single val basic_int32 : int32 single val basic_int64 : int64 single val basic_uint16 : int single val basic_uint32 : int32 single val basic_uint64 : int64 single val basic_double : float single val basic_string : string single val basic_signature : signature single val basic_object_path : OBus_path.t single val basic_unix_fd : Unix.file_descr single (** {6 Types extraction} *) val type_basic : 'a basic -> T.basic val type_single : 'a single -> T.single val type_sequence : 'a sequence -> T.sequence (** {6 Boxing} *) val make_basic : 'a basic -> 'a -> V.basic val make_single : 'a single -> 'a -> V.single val make_sequence : 'a sequence -> 'a -> V.sequence (** {6 Unboxing} *) exception Signature_mismatch (** Exception raised when a boxed value do not have the same signature as the combinator *) val cast_basic : 'a basic -> V.basic -> 'a val cast_single : 'a single -> V.single -> 'a val cast_sequence : 'a sequence -> V.sequence -> 'a (** {6 Dynamic values} *) (** The follwing functions allows you to create converters that do not convert values. *) val dyn_basic : T.basic -> V.basic basic val dyn_single : T.single -> V.single single val dyn_sequence : T.sequence -> V.sequence sequence (** {6 Sequence constructors} *) val seq0 : unit sequence val seq1 : 'a1 single -> 'a1 sequence val seq2 : 'a1 single -> 'a2 single -> ('a1 * 'a2) sequence val seq3 : 'a1 single -> 'a2 single -> 'a3 single -> ('a1 * 'a2 * 'a3) sequence val seq4 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> ('a1 * 'a2 * 'a3 * 'a4) sequence val seq5 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> 'a5 single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5) sequence val seq6 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> 'a5 single -> 'a6 single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) sequence val seq7 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> 'a5 single -> 'a6 single -> 'a7 single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) sequence val seq8 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> 'a5 single -> 'a6 single -> 'a7 single -> 'a8 single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) sequence val seq9 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> 'a5 single -> 'a6 single -> 'a7 single -> 'a8 single -> 'a9 single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) sequence val seq10 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> 'a5 single -> 'a6 single -> 'a7 single -> 'a8 single -> 'a9 single -> 'a10 single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) sequence val seq11 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> 'a5 single -> 'a6 single -> 'a7 single -> 'a8 single -> 'a9 single -> 'a10 single -> 'a11 single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11) sequence val seq12 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> 'a5 single -> 'a6 single -> 'a7 single -> 'a8 single -> 'a9 single -> 'a10 single -> 'a11 single -> 'a12 single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12) sequence val seq13 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> 'a5 single -> 'a6 single -> 'a7 single -> 'a8 single -> 'a9 single -> 'a10 single -> 'a11 single -> 'a12 single -> 'a13 single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12 * 'a13) sequence val seq14 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> 'a5 single -> 'a6 single -> 'a7 single -> 'a8 single -> 'a9 single -> 'a10 single -> 'a11 single -> 'a12 single -> 'a13 single -> 'a14 single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12 * 'a13 * 'a14) sequence val seq15 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> 'a5 single -> 'a6 single -> 'a7 single -> 'a8 single -> 'a9 single -> 'a10 single -> 'a11 single -> 'a12 single -> 'a13 single -> 'a14 single -> 'a15 single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12 * 'a13 * 'a14 * 'a15) sequence val seq16 : 'a1 single -> 'a2 single -> 'a3 single -> 'a4 single -> 'a5 single -> 'a6 single -> 'a7 single -> 'a8 single -> 'a9 single -> 'a10 single -> 'a11 single -> 'a12 single -> 'a13 single -> 'a14 single -> 'a15 single -> 'a16 single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12 * 'a13 * 'a14 * 'a15 * 'a16) sequence end (** {6 Methods/signals arguments} *) (** Type of a list of arguments used by methods and signals. It is ensured that the number of single types contained in [arg_types] is equal to the number of names. *) type 'a arguments = private { arg_types : 'a C.sequence; (** Types of the arguments *) arg_names : string option list; (** Names of the arguments *) } val arguments : arg_types : 'a C.sequence -> arg_names : string option list -> 'a arguments (** [arguments ~arg_types ~arg_names] creates a list of arguments. It raises [Invalid_arg] if the number of single types contained in [arg_types] is not equal to the number of names. *) val arg_types : 'a arguments -> 'a C.sequence (** Returns the underlying sequence converter of a list of arguments. *) val arg_names : 'a arguments -> string option list (** Returns the names of a list of arguments *) (** {8 Constructors} *) val arg_cons : string option * 'a C.single -> 'b arguments -> ('a * 'b) arguments (** [arg_cons (name, typ) arguments] adds the argument [(name, type)] to the beginning of [arguments] *) val arg0 : unit arguments val arg1 : string option * 'a1 C.single -> 'a1 arguments val arg2 : string option * 'a1 C.single -> string option * 'a2 C.single -> ('a1 * 'a2) arguments val arg3 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> ('a1 * 'a2 * 'a3) arguments val arg4 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> ('a1 * 'a2 * 'a3 * 'a4) arguments val arg5 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> string option * 'a5 C.single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5) arguments val arg6 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> string option * 'a5 C.single -> string option * 'a6 C.single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) arguments val arg7 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> string option * 'a5 C.single -> string option * 'a6 C.single -> string option * 'a7 C.single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) arguments val arg8 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> string option * 'a5 C.single -> string option * 'a6 C.single -> string option * 'a7 C.single -> string option * 'a8 C.single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) arguments val arg9 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> string option * 'a5 C.single -> string option * 'a6 C.single -> string option * 'a7 C.single -> string option * 'a8 C.single -> string option * 'a9 C.single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) arguments val arg10 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> string option * 'a5 C.single -> string option * 'a6 C.single -> string option * 'a7 C.single -> string option * 'a8 C.single -> string option * 'a9 C.single -> string option * 'a10 C.single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) arguments val arg11 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> string option * 'a5 C.single -> string option * 'a6 C.single -> string option * 'a7 C.single -> string option * 'a8 C.single -> string option * 'a9 C.single -> string option * 'a10 C.single -> string option * 'a11 C.single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11) arguments val arg12 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> string option * 'a5 C.single -> string option * 'a6 C.single -> string option * 'a7 C.single -> string option * 'a8 C.single -> string option * 'a9 C.single -> string option * 'a10 C.single -> string option * 'a11 C.single -> string option * 'a12 C.single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12) arguments val arg13 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> string option * 'a5 C.single -> string option * 'a6 C.single -> string option * 'a7 C.single -> string option * 'a8 C.single -> string option * 'a9 C.single -> string option * 'a10 C.single -> string option * 'a11 C.single -> string option * 'a12 C.single -> string option * 'a13 C.single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12 * 'a13) arguments val arg14 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> string option * 'a5 C.single -> string option * 'a6 C.single -> string option * 'a7 C.single -> string option * 'a8 C.single -> string option * 'a9 C.single -> string option * 'a10 C.single -> string option * 'a11 C.single -> string option * 'a12 C.single -> string option * 'a13 C.single -> string option * 'a14 C.single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12 * 'a13 * 'a14) arguments val arg15 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> string option * 'a5 C.single -> string option * 'a6 C.single -> string option * 'a7 C.single -> string option * 'a8 C.single -> string option * 'a9 C.single -> string option * 'a10 C.single -> string option * 'a11 C.single -> string option * 'a12 C.single -> string option * 'a13 C.single -> string option * 'a14 C.single -> string option * 'a15 C.single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12 * 'a13 * 'a14 * 'a15) arguments val arg16 : string option * 'a1 C.single -> string option * 'a2 C.single -> string option * 'a3 C.single -> string option * 'a4 C.single -> string option * 'a5 C.single -> string option * 'a6 C.single -> string option * 'a7 C.single -> string option * 'a8 C.single -> string option * 'a9 C.single -> string option * 'a10 C.single -> string option * 'a11 C.single -> string option * 'a12 C.single -> string option * 'a13 C.single -> string option * 'a14 C.single -> string option * 'a15 C.single -> string option * 'a16 C.single -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12 * 'a13 * 'a14 * 'a15 * 'a16) arguments obus-1.2.5/src/internals/oBus_xml_parser.ml000066400000000000000000000116751456737751200210060ustar00rootroot00000000000000(* * oBus_xml_parser.ml * ------------------ * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Printf exception Parse_failure of Xmlm.pos * string type xml = | Element of Xmlm.pos * string * (string * string) list * xml list | PCData of Xmlm.pos * string type node_type = | NT_element of string | NT_pcdata | NT_any | NT_union of node_type list type 'a node = node_type * (xml -> 'a option) type xml_parser = { position : Xmlm.pos; attributes : (string * string) list; mutable children : xml list; } let failwith p msg = raise (Parse_failure(p.position, msg)) let ao p name = OBus_util.assoc name p.attributes let ar p name = match ao p name with | Some v -> v | None -> ksprintf (failwith p) "attribute '%s' missing" name let ad p name default = match ao p name with | Some v -> v | None -> default let afo p name field = match OBus_util.assoc name p.attributes with | None -> None | Some v -> match OBus_util.assoc v field with | Some v -> Some v | None -> ksprintf (failwith p) "unexpected value for '%s' (%s), must be one of %s" name v (String.concat ", " (List.map (fun (name, v) -> "'" ^ name ^ "'") field)) let afr p name field = match afo p name field with | Some v -> v | None -> ksprintf (failwith p) "attribute '%s' missing" name let afd p name default field = match afo p name field with | Some v -> v | None -> default let execute xml_parser p = try let result = xml_parser p in match p.children with | [] -> result | Element(pos, name, _, _) :: _ -> ksprintf (failwith p) "unknown element '%s'" name | PCData(pos, _) :: _ -> failwith p "trailing pc-data" with | Parse_failure _ as exn -> raise exn | exn -> failwith p (Printexc.to_string exn) let elt name elt_parser = (NT_element name, function | Element(pos, name', attrs, children) when name = name' -> Some(execute elt_parser { position = pos; children = children; attributes = attrs}) | _ -> None) let pcdata = (NT_pcdata, function | Element _ -> None | PCData(_, x) -> Some x) let union nodes = let types, fl = List.split nodes in (NT_union types, fun node -> OBus_util.find_map (fun f -> f node) fl) let map (typ, f) g = (typ, fun node -> OBus_util.map_option (f node) g) let string_of_type typ = let rec flat acc = function | NT_union l -> List.fold_left flat acc l | NT_pcdata -> "" :: acc | NT_any -> "" :: acc | NT_element name -> name :: acc in match flat [] typ with | [] -> "" | [x] -> x | l -> String.concat " or " l let opt p (typ, f) = match OBus_util.part_map f p.children with | [], rest -> None | [x], rest -> p.children <- rest; Some x | _, rest -> ksprintf (failwith p) "too many nodes of type %S" (string_of_type typ) let one p (typ, f) = match opt p (typ, f) with | Some x -> x | None -> ksprintf (failwith p) "element missing: %S" (string_of_type typ) let any p (typ, f) = let success, rest = OBus_util.part_map f p.children in p.children <- rest; success let pos_of_xml = function | Element(pos, _, _, _) -> pos | PCData(pos, _) -> pos let parse node xml = execute (fun p -> one p node) { position = pos_of_xml xml; attributes = []; children = [xml] } let input input node = let rec make () = let pos = Xmlm.pos input in match Xmlm.input input with | `El_start(("", name), attrs) -> Element(pos, name, List.map (fun ((uri, name), value) -> (name, value)) attrs, make_list ()) | `El_start((_, name), attrs) -> (* Drops elements that are not part of the specification *) drop 0; make () | `El_end -> raise (Parse_failure(pos, "unexpected end of element")) | `Data str -> PCData(pos, str) | `Dtd _ -> make () and make_list () = let pos = Xmlm.pos input in match Xmlm.input input with | `El_start(("", name), attrs) -> let xml = Element(pos, name, List.map (fun ((uri, name), value) -> (name, value)) attrs, make_list ()) in xml :: make_list () | `El_start((_, name), attrs) -> drop 0; make_list () | `El_end -> [] | `Data str -> let xml = PCData(pos, str) in xml :: make_list () | `Dtd _ -> make_list () and drop deep = match Xmlm.input input with | `El_start _ -> drop (deep + 1) | `El_end -> if deep <> 0 then drop (deep - 1) | `Data str -> drop deep | `Dtd _ -> drop deep in try parse node (make ()) with Xmlm.Error(pos, error) -> raise (Parse_failure(pos, Xmlm.error_message error)) obus-1.2.5/src/internals/oBus_xml_parser.mli000066400000000000000000000053321456737751200211500ustar00rootroot00000000000000(* * oBus_xml_parser.mli * ------------------- * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Monadic xml parsing *) (** This module implements a simple monadic xml parser. It is intended to make it easy to write XML document parsers. In OBus it is used to parse introspection document. *) exception Parse_failure of Xmlm.pos * string type xml_parser (** Type of an xml parser. It is used to parse a sequence of arguments and children of an element. *) type 'a node (** Type of a single xml node parser, returning a value of type ['a] *) val failwith : xml_parser -> string -> 'a (** Fail at current position with the given error message *) val input : Xmlm.input -> 'a node -> 'a (** Run a parser on a xml input. If it fails it raises a [Parse_failure] *) (** {6 Parsing of attributes} *) (** For the following functions, the first argument is the attribute name and each letter mean: - [o] : the attribute is optionnal - [r] : the attribute is required - [d] : a default value is given - [f] : a associative list for the attribute value is specified. *) val ar : xml_parser -> string -> string val ao : xml_parser -> string -> string option val ad : xml_parser -> string -> string -> string val afr : xml_parser -> string -> (string * 'a) list -> 'a val afo : xml_parser -> string -> (string * 'a) list -> 'a option val afd : xml_parser -> string -> 'a -> (string * 'a) list -> 'a (** {6 Parsing of elements} *) val elt : string -> (xml_parser -> 'a) -> 'a node (** [elt typ parser] creates a node parser. It will parse element of type [typ]. [parser] is used to parse the attributes and children of the element. Note that [parser] must consume all children, if some are left unparsed the parsing will fail. *) val pcdata : string node (** [pcdata f] parse one PCData *) val map : 'a node -> ('a -> 'b) -> 'b node (** [map node f] wraps the result of a node parser with [f] *) val union : 'a node list -> 'a node (** [union nodes] Node parser which parses any node matched by one of the given node parsers *) (** {6 Modifiers} *) val one : xml_parser -> 'a node -> 'a (** [one node] parse exactly one node with the given node parser. It will fail if there is 0 or more than one node matched by [node]. *) val opt : xml_parser -> 'a node -> 'a option (** same as [one] but do not fail if there is no node matched by [node]. *) val any : xml_parser -> 'a node -> 'a list (** [any node] Parse all element matched by [node]. The resulting list is in the same order as the order in which nodes appears in the xml. *) obus-1.2.5/src/ppx/000077500000000000000000000000001456737751200141065ustar00rootroot00000000000000obus-1.2.5/src/ppx/dune000066400000000000000000000002671456737751200147710ustar00rootroot00000000000000(library (name ppx_obus) (public_name obus.ppx) (kind ppx_rewriter) (synopsis "Utility syntax for defining D-Bus errors") (libraries ppxlib) (preprocess (pps ppxlib.metaquot))) obus-1.2.5/src/ppx/ppx_obus.ml000066400000000000000000000036221456737751200163020ustar00rootroot00000000000000open Ppxlib let rewriter_name = "ppx_obus" let find_attr_expr s attrs = let expr_of_payload = function | PStr [{ pstr_desc = Pstr_eval (e, _); _ }] -> Some e | _ -> None in try expr_of_payload ( let payload = List.find (fun attr -> attr.attr_name.txt = s) attrs in payload.attr_payload) with Not_found -> None let register_obus_exception = function | { pstr_desc = Pstr_exception exn; pstr_loc } -> (match find_attr_expr "obus" exn.ptyexn_attributes with | Some expr -> let registerer typ = let loc = pstr_loc in if Filename.basename pstr_loc.loc_start.pos_fname = "oBus_error.ml" then [%stri let () = let module M = Register(struct let name = [%e expr] exception E of [%t typ] end) in () ] else [%stri let () = let module M = OBus_error.Register(struct let name = [%e expr] exception E of [%t typ] end) in () ] in (match exn.ptyexn_constructor.pext_kind with | Pext_decl (_, Pcstr_tuple [typ], None) -> Some (registerer typ) | _ -> Location.raise_errorf ~loc:pstr_loc "%s: OBus exceptions take a single string argument" rewriter_name) | _ -> None) | _ -> None let obus_mapper = object(self) inherit Ast_traverse.map method! structure items = List.fold_right (fun item acc -> let item' = self#structure_item item in match register_obus_exception item with | Some reg -> item' :: reg :: acc | None -> item' :: acc) items [] end let () = Driver.register_transformation ~impl:(fun structure -> obus_mapper#structure structure) rewriter_name obus-1.2.5/src/protocol/000077500000000000000000000000001456737751200151405ustar00rootroot00000000000000obus-1.2.5/src/protocol/dune000066400000000000000000000006671456737751200160270ustar00rootroot00000000000000(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}))) obus-1.2.5/src/protocol/oBus_address.ml000066400000000000000000000111321456737751200201050ustar00rootroot00000000000000(* * oBus_address.ml * --------------- * Copyright : (c) 2008, Jeremie Dimino * 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 ) obus-1.2.5/src/protocol/oBus_address.mli000066400000000000000000000034001456737751200202550ustar00rootroot00000000000000(* * oBus_address.mli * ---------------- * Copyright : (c) 2008, Jeremie Dimino * 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 *) obus-1.2.5/src/protocol/oBus_address_lexer.mll000066400000000000000000000046701456737751200214710ustar00rootroot00000000000000(* * oBus_address_lexer.mll * ---------------------- * Copyright : (c) 2009, Jeremie Dimino * 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 '%'" } obus-1.2.5/src/protocol/oBus_auth.ml000066400000000000000000000735041456737751200174340ustar00rootroot00000000000000(* * oBus_auth.ml * ------------ * Copyright : (c) 2008, Jeremie Dimino * 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 obus-1.2.5/src/protocol/oBus_auth.mli000066400000000000000000000133761456737751200176060ustar00rootroot00000000000000(* * oBus_auth.mli * ------------- * Copyright : (c) 2008, Jeremie Dimino * 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 obus-1.2.5/src/protocol/oBus_bus.ml000066400000000000000000000212051456737751200172530ustar00rootroot00000000000000(* * oBus_bus.ml * ----------- * Copyright : (c) 2008, Jeremie Dimino * 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) obus-1.2.5/src/protocol/oBus_bus.mli000066400000000000000000000161401456737751200174260ustar00rootroot00000000000000(* * oBus_bus.mli * ------------ * Copyright : (c) 2008, Jeremie Dimino * 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 obus-1.2.5/src/protocol/oBus_config.ml000066400000000000000000000005321456737751200177270ustar00rootroot00000000000000(* -*- tuareg -*- * OBus_config.ml * -------------- * Copyright : (c) 2009, Jeremie Dimino * 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" obus-1.2.5/src/protocol/oBus_connection.ml000066400000000000000000000565161456737751200206360ustar00rootroot00000000000000(* * oBus_connection.ml * ------------------ * Copyright : (c) 2008, Jeremie Dimino * 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 = Stdlib.compare (* +-----------------------------------------------------------------+ | Guids | +-----------------------------------------------------------------+ *) (* Mapping from server guid to connection. *) module Guid_map = Map.Make(struct type t = OBus_address.guid let compare = Stdlib.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 obus-1.2.5/src/protocol/oBus_connection.mli000066400000000000000000000174211456737751200207770ustar00rootroot00000000000000(* * oBus_connection.mli * ------------------- * Copyright : (c) 2008, Jeremie Dimino * 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 [Stdlib.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 *) obus-1.2.5/src/protocol/oBus_context.ml000066400000000000000000000017021456737751200201460ustar00rootroot00000000000000(* * oBus_context.ml * --------------- * Copyright : (c) 2010, Jeremie Dimino * 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 obus-1.2.5/src/protocol/oBus_context.mli000066400000000000000000000023341456737751200203210ustar00rootroot00000000000000(* * oBus_context.mli * ---------------- * Copyright : (c) 2010, Jeremie Dimino * 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 *) obus-1.2.5/src/protocol/oBus_error.ml000066400000000000000000000062511456737751200176170ustar00rootroot00000000000000(* * oBus_error.ml * ------------- * Copyright : (c) 2008, Jeremie Dimino * 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"] obus-1.2.5/src/protocol/oBus_error.mli000066400000000000000000000067511456737751200177750ustar00rootroot00000000000000(* * oBus_error.mli * -------------- * Copyright : (c) 2008, Jeremie Dimino * 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 *) obus-1.2.5/src/protocol/oBus_info.ml000066400000000000000000000015621456737751200174210ustar00rootroot00000000000000(* * oBus_info.ml * ------------ * Copyright : (c) 2008, Jeremie Dimino * 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 ) obus-1.2.5/src/protocol/oBus_info.mli000066400000000000000000000013171456737751200175700ustar00rootroot00000000000000(* * oBus_info.mli * ------------- * Copyright : (c) 2008, Jeremie Dimino * 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). *) obus-1.2.5/src/protocol/oBus_interfaces.obus000066400000000000000000000047531456737751200211560ustar00rootroot00000000000000(* * oBus_interfaces.obus * -------------------- * Copyright : (c) 2010, Jeremie Dimino * 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) } obus-1.2.5/src/protocol/oBus_match.ml000066400000000000000000000415731456737751200175700ustar00rootroot00000000000000(* * oBus_match.ml * ------------- * Copyright : (c) 2009, Jeremie Dimino * 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 () obus-1.2.5/src/protocol/oBus_match.mli000066400000000000000000000113301456737751200177250ustar00rootroot00000000000000(* * oBus_match.mli * -------------- * Copyright : (c) 2009, Jeremie Dimino * 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. *) obus-1.2.5/src/protocol/oBus_match_rule_lexer.mll000066400000000000000000000027671456737751200221740ustar00rootroot00000000000000(* * oBus_match_rule_lexer.mll * ------------------------- * Copyright : (c) 2009, Jeremie Dimino * 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 } obus-1.2.5/src/protocol/oBus_member.ml000066400000000000000000000051321456737751200177320ustar00rootroot00000000000000(* * oBus_member.ml * -------------- * Copyright : (c) 2010, Jeremie Dimino * 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 obus-1.2.5/src/protocol/oBus_member.mli000066400000000000000000000065751456737751200201170ustar00rootroot00000000000000(* * oBus_member.mli * --------------- * Copyright : (c) 2010, Jeremie Dimino * 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 obus-1.2.5/src/protocol/oBus_message.ml000066400000000000000000000100211456737751200201000ustar00rootroot00000000000000(* * oBus_message.ml * --------------- * Copyright : (c) 2008, Jeremie Dimino * 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 obus-1.2.5/src/protocol/oBus_message.mli000066400000000000000000000062261456737751200202650ustar00rootroot00000000000000(* * oBus_message.mli * ---------------- * Copyright : (c) 2008, Jeremie Dimino * 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 *) obus-1.2.5/src/protocol/oBus_method.ml000066400000000000000000000031021456737751200177360ustar00rootroot00000000000000(* * oBus_method.ml * -------------- * Copyright : (c) 2010, Jeremie Dimino * 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 obus-1.2.5/src/protocol/oBus_method.mli000066400000000000000000000015171456737751200201170ustar00rootroot00000000000000(* * oBus_method.mli * --------------- * Copyright : (c) 2010, Jeremie Dimino * 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 *) obus-1.2.5/src/protocol/oBus_object.ml000066400000000000000000001116471456737751200177420ustar00rootroot00000000000000(* * oBus_object.ml * -------------- * Copyright : (c) 2008, Jeremie Dimino * 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" obus-1.2.5/src/protocol/oBus_object.mli000066400000000000000000000171571456737751200201140ustar00rootroot00000000000000(* * oBus_object.mli * --------------- * Copyright : (c) 2008, Jeremie Dimino * 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. *) obus-1.2.5/src/protocol/oBus_peer.ml000066400000000000000000000044131456737751200174170ustar00rootroot00000000000000(* * oBus_peer.ml * ------------ * Copyright : (c) 2008, Jeremie Dimino * 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 = Stdlib.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 obus-1.2.5/src/protocol/oBus_peer.mli000066400000000000000000000066061456737751200175760ustar00rootroot00000000000000(* * oBus_peer.mli * ------------- * Copyright : (c) 2008, Jeremie Dimino * 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 [Stdlib.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 obus-1.2.5/src/protocol/oBus_property.ml000066400000000000000000000267711456737751200203630ustar00rootroot00000000000000(* * oBus_property.ml * ---------------- * Copyright : (c) 2010, Jeremie Dimino * 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 = Stdlib.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) obus-1.2.5/src/protocol/oBus_property.mli000066400000000000000000000126341456737751200205250ustar00rootroot00000000000000(* * oBus_property.mli * ----------------- * Copyright : (c) 2010, Jeremie Dimino * 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. *) obus-1.2.5/src/protocol/oBus_proxy.ml000066400000000000000000000051221456737751200176430ustar00rootroot00000000000000(* * oBus_proxy.ml * ------------- * Copyright : (c) 2008, Jeremie Dimino * 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 = Stdlib.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))) obus-1.2.5/src/protocol/oBus_proxy.mli000066400000000000000000000053211456737751200200150ustar00rootroot00000000000000(* * oBus_proxy.mli * -------------- * Copyright : (c) 2008, Jeremie Dimino * 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 [Stdlib.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 obus-1.2.5/src/protocol/oBus_resolver.ml000066400000000000000000000143221456737751200203250ustar00rootroot00000000000000(* * oBus_resolver.ml * ---------------- * Copyright : (c) 2008, Jeremie Dimino * 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 obus-1.2.5/src/protocol/oBus_resolver.mli000066400000000000000000000024471456737751200205030ustar00rootroot00000000000000(* * oBus_resolver.mli * ----------------- * Copyright : (c) 2008, Jeremie Dimino * 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. *) obus-1.2.5/src/protocol/oBus_server.ml000066400000000000000000000501501456737751200177710ustar00rootroot00000000000000(* * oBus_server.ml * -------------- * Copyright : (c) 2008, Jeremie Dimino * 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)) obus-1.2.5/src/protocol/oBus_server.mli000066400000000000000000000054411456737751200201450ustar00rootroot00000000000000(* * oBus_server.mli * --------------- * Copyright : (c) 2008, Jeremie Dimino * 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. *) obus-1.2.5/src/protocol/oBus_signal.ml000066400000000000000000000224561456737751200177500ustar00rootroot00000000000000(* * oBus_signal.ml * -------------- * Copyright : (c) 2010, Jeremie Dimino * 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 = Stdlib.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 -> "") (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 obus-1.2.5/src/protocol/oBus_signal.mli000066400000000000000000000056461456737751200201230ustar00rootroot00000000000000(* * oBus_signal.mli * --------------- * Copyright : (c) 2010, Jeremie Dimino * 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]. *) obus-1.2.5/src/protocol/oBus_transport.ml000066400000000000000000000261761456737751200205320ustar00rootroot00000000000000(* * oBus_transport.ml * ----------------- * Copyright : (c) 2009, Jeremie Dimino * 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 obus-1.2.5/src/protocol/oBus_transport.mli000066400000000000000000000053241456737751200206730ustar00rootroot00000000000000(* * oBus_transport.mli * ------------------ * Copyright : (c) 2009, Jeremie Dimino * 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 *) obus-1.2.5/src/protocol/oBus_uuid.ml000066400000000000000000000016041456737751200174310ustar00rootroot00000000000000(* * oBus_uuid.ml * ------------ * Copyright : (c) 2008, Jeremie Dimino * 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 obus-1.2.5/src/protocol/oBus_uuid.mli000066400000000000000000000014661456737751200176100ustar00rootroot00000000000000(* * oBus_uuid.mli * ------------- * Copyright : (c) 2008, Jeremie Dimino * 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. *) obus-1.2.5/src/protocol/oBus_wire.ml000066400000000000000000001307751456737751200174450ustar00rootroot00000000000000(* * oBus_lowlevel.ml * ---------------- * Copyright : (c) 2008, Jeremie Dimino * 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 = Stdlib.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 obus-1.2.5/src/protocol/oBus_wire.mli000066400000000000000000000050671456737751200176110ustar00rootroot00000000000000(* * oBus_lowlevel.mli * ----------------- * Copyright : (c) 2008, Jeremie Dimino * 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. *) obus-1.2.5/tests/000077500000000000000000000000001456737751200136525ustar00rootroot00000000000000obus-1.2.5/tests/dune000066400000000000000000000003631456737751200145320ustar00rootroot00000000000000(executable (name main) (modules main gen_random progress test_serialization test_validation test_auth test_communication test_gc) (libraries lwt obus) (preprocess (pps lwt_ppx))) (alias (name runtest) (action (run ./main.exe))) obus-1.2.5/tests/gen_random.ml000066400000000000000000000121031456737751200163120ustar00rootroot00000000000000(* * gen_random.ml * ------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open OBus_value open OBus_message let _ = Random.self_init () let option f = if Random.bool () then Some(f ()) else None (* Generate a random non-empty string *) let string max_len = let len = 1 + Random.int max_len in let str = Bytes.create len in for i = 0 to len - 1 do Bytes.set str i (char_of_int (Char.code 'a' + Random.int 26)) done; Bytes.unsafe_to_string str (* Generate an object path *) let path () = let rec aux acc = function | 0 -> acc | n -> aux (string 30 :: acc) (n - 1) in aux [] (Random.int 10) (* Generate a valid (interface/bus/error) name *) let name () = let rec aux acc = function | 0 -> acc | n -> aux (string 15 :: acc) (n - 1) in String.concat "." (aux [] (2 + Random.int 8)) let unique_name () = ":" ^ name () (* Generate a valid member name *) let member () = string 20 let serial () = Random.int32 Int32.max_int let message_type () = match Random.int 4 with | 0 -> Method_call(path (), name (), member ()) | 1 -> Method_return(serial ()) | 2 -> Error(serial (), name ()) | _ -> Signal(path (), name (), member ()) let uint16 () = Random.int (1 lsl 16) let uint32 () = Int32.logor (Int32.shift_left (Random.int32 Int32.max_int) 1) (Random.int32 2l) let uint64 () = Int64.logor (Int64.shift_left (Random.int64 Int64.max_int) 1) (Random.int64 2L) let int16 () = uint16 () - (1 lsl 15) let int32 () = uint32 () let int64 () = uint64 () let double () = Int64.to_float (int64 ()) (* In the following functions, [count] is the number of terminals (basic types/values) and [deep] is the current number of containers nesting *) let tbasic count deep = match Random.int 12 with | 0 -> count + 1, T.Byte | 1 -> count + 1, T.Boolean | 2 -> count + 1, T.Int16 | 3 -> count + 1, T.Int32 | 4 -> count + 1, T.Int64 | 5 -> count + 1, T.Uint16 | 6 -> count + 1, T.Uint32 | 7 -> count + 1, T.Uint64 | 8 -> count + 1, T.Double | 9 -> count + 1, T.String | 10 -> count + 1, T.Signature | _ -> count + 1, T.Object_path let rec tsingle count deep = if deep > 3 then let count, t = tbasic count deep in (count, T.basic t) else match Random.int 5 with | 0 -> let count, t = tbasic count deep in (count, T.Basic t) | 1 -> let count, t = tsequence count (deep + 1) in (count, T.Structure t) | 2 -> let count, t = tsingle count (deep + 1) in (count, T.Array t) | 3 -> let count, tk = tbasic count (deep + 1) in let count, tv = tsingle count (deep + 1) in (count, T.Dict(tk, tv)) | _ -> (count + 1, T.Variant) and tsequence count deep = let rec aux count acc = function | 0 -> (count, acc) | n -> let count, t = tsingle count (deep + 1) in aux count (t :: acc) (n - 1) in if count > 30 then let count, t = tbasic count deep in (count, [T.Basic t]) else aux count [] (1 + Random.int 10) let basic count deep = function | T.Byte -> count + 1, V.Byte(char_of_int (Random.int 256)) | T.Boolean -> count + 1, V.Boolean(Random.bool ()) | T.Int16 -> count + 1, V.Int16(int16 ()) | T.Int32 -> count + 1, V.Int32(int32 ()) | T.Int64 -> count + 1, V.Int64(int64 ()) | T.Uint16 -> count + 1, V.Uint16(uint16 ()) | T.Uint32 -> count + 1, V.Uint32(uint32 ()) | T.Uint64 -> count + 1, V.Uint64(uint64 ()) | T.Double -> count + 1, V.Double(double ()) | T.String -> count + 1, V.String(string 100) | T.Signature -> count + 1, V.Signature(snd (tsequence 0 0)) | T.Object_path -> count + 1, V.Object_path(path ()) | T.Unix_fd -> count + 1, V.Unix_fd Unix.stdin let rec single count deep = function | T.Basic t -> let count, x = basic count deep t in (count, V.basic x) | T.Structure tl -> let count, x = sequence count (deep + 1) tl in (count, V.structure x) | T.Array t -> let rec aux count acc = function | 0 -> (count, V.array t acc) | n -> let count, x = single count (deep + 1) t in aux count (x :: acc) (n - 1) in aux count [] (Random.int (max 1 (min 200 (1000 - count)))) | T.Dict(tk, tv) -> let rec aux count acc = function | 0 -> (count, V.dict tk tv acc) | n -> let count, k = basic count (deep + 1) tk in let count, v = single count (deep + 1) tv in aux count ((k, v) :: acc) (n - 1) in aux count [] (Random.int (max 1 (min 200 (1000 - count)))) | T.Variant -> let _, t = tsingle 15 (deep + 1) in let count, x = single count (deep + 1) t in (count, V.variant x) and sequence count deep tl = List.fold_right (fun t (count, l) -> let count, x = single count (deep + 1) t in (count, x :: l)) tl (count, []) let message () = { flags = { no_reply_expected = Random.bool (); no_auto_start = Random.bool () }; serial = serial (); typ = message_type (); destination = name (); sender = unique_name (); body = snd (sequence 0 0 (snd (tsequence 0 0))); } obus-1.2.5/tests/gen_random.mli000066400000000000000000000004611456737751200164670ustar00rootroot00000000000000(* * gen_random.mli * -------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Generation of random test data *) val message : unit -> OBus_message.t (** Generate a random message *) obus-1.2.5/tests/main.ml000066400000000000000000000036601456737751200151350ustar00rootroot00000000000000(* * main.ml * ------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt let tty = Unix.isatty Unix.stdout let title msg = if tty then Lwt_io.printf "\027[34;1m%s\r=[ \027[37;1m%s\027[34;1m ]=\n\027[0m" (String.make 80 '=') msg else Lwt_io.printlf "=[ %s ]=" msg let rec run_tests failures total = function | [] -> if tty then if failures = 0 then Lwt_io.printl "\027[32;1mAll tests succeeded!\027[0m" else Lwt_io.printlf "\027[31;1m%d of %d tests failed.\027[0m" failures total else if failures = 0 then Lwt_io.printl "All tests succeeded!" else Lwt_io.printlf "%d of %d tests failed." failures total | (name, test) :: rest -> let%lwt () = title name in begin try%lwt test () with exn -> let%lwt () = Lwt_io.printlf "test failed with: %s" (Printexc.to_string exn) in let%lwt () = Lwt_io.printl (Printexc.get_backtrace ()) in return false end >>= function | true -> let%lwt () = if tty then Lwt_io.print "\n\027[32;1mTest passed.\n\027[0m\n" else Lwt_io.print "\nTest passed.\n\n" in run_tests failures (total + 1) rest | false -> let%lwt () = if tty then Lwt_io.print "\n\027[31;1mTest failed.\n\027[0m\n" else Lwt_io.print "\nTest failed.\n\n" in run_tests (failures + 1) (total + 1) rest let () = Lwt_main.run begin run_tests 0 0 [ "serialization", Test_serialization.test; "string validation", Test_validation.test; "authentication", Test_auth.test; (*"communication", Test_communication.test;*) "garbage collection", Test_gc.test; ] end obus-1.2.5/tests/progress.ml000066400000000000000000000014771456737751200160610ustar00rootroot00000000000000(* * progress.ml * ----------- * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt type t = { mutable current_percent : int; mutable current : int; prefix : string; max : int; } let make prefix max = let%lwt () = Lwt_io.printf "%s: 0%%%!" prefix in return { prefix = prefix; max = max; current = 0; current_percent = 0; } let incr p = p.current <- p.current + 1; let x = p.current * 100 / p.max in if x <> p.current_percent then begin p.current_percent <- x; let%lwt () = Lwt_io.printf "\r%s: %d%%" p.prefix x in Lwt_io.flush Lwt_io.stdout end else return () let close p = let%lwt () = Lwt_io.printf "\r%s: 100%%\n" p.prefix in Lwt_io.flush Lwt_io.stdout obus-1.2.5/tests/progress.mli000066400000000000000000000006341456737751200162240ustar00rootroot00000000000000(* * progress.mli * ------------ * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (** Print progression on stdout/stderr *) type t val make : string -> int -> t Lwt.t (** [make prefix max] *) val incr : t -> unit Lwt.t (** [incr progress] *) val close : t -> unit Lwt.t (** [close progress] *) obus-1.2.5/tests/syntax_extension.ml000066400000000000000000000061411456737751200176300ustar00rootroot00000000000000(* * syntax_extension.ml * ------------------- * Copyright : (c) 2009-2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* +-----------------------------------------------------------------+ | Type tests | +-----------------------------------------------------------------+ *) (* Functionnal type *) let typ = <:obus_func< string -> uint -> string -> string -> string -> string list -> (string, variant) assoc -> int -> uint >> (* Alias *) type t = int with obus (* Alias with type parameters *) type ('a, 'b, 'c) t = (int * 'a list) structure * ('c, 'b) balbla with obus module type M = sig (* Alias with type paramters in an interface *) type ('a, 'b, 'c) t = (int * 'a list) structure * ('c, 'b) balbla with obus(single -> basic -> basic -> container) end (* Automatic generation of a record combinator*) type foo = { a : A.B.string; b : int list; c : (int, string, char) machin; d : (int * byte_array * (int, string) dict_entry set) structure * int; } with obus (* Tuple *) let big_tuple = <:obus_type< int * string * uint * int32 * byte * char * int list * int * int * string * variant * signature >> (* Very big tuple *) let super_big_tuple = <:obus_type< x0 * x1 * x2 * x3 * x4 * x5 * x6 * x7 * x8 * x9 * x10 * x11 * x12 * x13 * x14 * x15 * x16 * x17 * x18 * x19 * x20 * x21 * x22 * x23 * x24 * x25 * x26 * x27 * x28 * x29 * x30 * x31 * x32 * x33 * x34 * x35 * x36 * x37 * x38 * x39 * x40 * x41 * x42 >> (* +-----------------------------------------------------------------+ | Exceptions | +-----------------------------------------------------------------+ *) exception Fatal_error of string with obus("org.foo.Error.FatalError") exception Simple_error of string with obus(prefix ^ ".SimpleError") (* +-----------------------------------------------------------------+ | Proxy code | +-----------------------------------------------------------------+ *) OP_method Plop : int OP_method Plop : int -> string OP_signal HaHaHa : string OP_property_r Foo : int list (* +-----------------------------------------------------------------+ | Proxy code with a custom proxy | +-----------------------------------------------------------------+ *) module Proxy = OBus_proxy.Make (struct type proxy = t let cast x = x.proxy let make x = failwith "not implemented" end) OP_method SetCPUFreqGovernor : string OP_method MethodWithLabels : x : int -> y : int -> str : string -> unit (* +-----------------------------------------------------------------+ | Object code | +-----------------------------------------------------------------+ *) OL_method Test : int -> int OL_method TestWithDefinition : int -> int = fun x -> x + 1 OL_signal Foo : string * string OL_property_rw Prop : int = (fun obj -> return obj.x) (fun obj x -> obj.x <- x; return ()) obus-1.2.5/tests/test_auth.ml000066400000000000000000000024411456737751200162050ustar00rootroot00000000000000(* * test_auth.ml * ------------ * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt let server_ic, client_oc = Lwt_io.pipe () let client_ic, server_oc = Lwt_io.pipe () let guid = OBus_uuid.generate () let user_id = Unix.getuid () let test_mech mech = try%lwt let%lwt () = Lwt.join [(let%lwt _ = OBus_auth.Client.authenticate ~stream:(OBus_auth.stream_of_channels (client_ic, client_oc)) () in return ()); let%lwt _ = OBus_auth.Server.authenticate ~user_id ~mechanisms:[mech] ~guid ~stream:(OBus_auth.stream_of_channels (server_ic, server_oc)) () in return ()] in let%lwt () = Lwt_io.printlf "authentication %s works!" (OBus_auth.Server.mech_name mech) in return true with exn -> let%lwt () = Lwt_io.printlf "authentication %s do not works: %s" (OBus_auth.Server.mech_name mech) (Printexc.to_string exn) in return false let test () = let%lwt a = test_mech OBus_auth.Server.mech_external in let%lwt b = test_mech OBus_auth.Server.mech_dbus_cookie_sha1 in let%lwt c = test_mech OBus_auth.Server.mech_anonymous in return (a && b && c) obus-1.2.5/tests/test_communication.ml000066400000000000000000000041211456737751200201060ustar00rootroot00000000000000(* * test_communication.ml * --------------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* Test the communication with a message bus *) open Lwt open Lwt_io open OBus_message (* number of message to generate *) let test_count = 100 let name = "obus.test.communication" let rec run_tests con = function | 0 -> return () | n -> let message = Gen_random.message () in let%lwt () = OBus_connection.send_message con { message with destination = name; typ = Signal(["obus"; "test"], "obus.test", "test"); } in run_tests con (n - 1) let rec wait_for_name con = OBus_bus.name_has_owner con name >>= function | true -> return () | false -> let%lwt () = Lwt_unix.sleep 0.1 in wait_for_name con let test () = let%lwt () = Lwt_io.flush Lwt_io.stdout in match Unix.fork () with | 0 -> let%lwt con = OBus_bus.session () in let%lwt () = wait_for_name con in let%lwt () = run_tests con test_count in exit 0 | pid -> let%lwt () = printlf "sending and receiving %d messages through the message bus." test_count in let%lwt bus = OBus_bus.session () in let%lwt _ = OBus_bus.request_name bus name in let%lwt progress = Progress.make "received" test_count in let waiter, wakener = wait () in let count = ref 0 in ignore (Lwt_sequence.add_r (function | { typ = Signal(["obus"; "test"], "obus.test", "test") } -> ignore (Progress.incr progress); incr count; if !count = test_count then wakeup wakener true; None | msg -> Some msg) (OBus_connection.incoming_filters bus)); let%lwt result = waiter in let%lwt () = Progress.close progress in let%lwt _ = Lwt_unix.waitpid [] pid in return result obus-1.2.5/tests/test_gc.ml000066400000000000000000000025371456737751200156430ustar00rootroot00000000000000(* * test_gc.ml * ---------- * Copyright : (c) 2010, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt open Lwt_io let ok = ref false let finalise _ = ok := true let test () = let success = true in let%lwt bus = OBus_bus.session () in let%lwt () = print "safety check: " in let event = ref 0 in ok := false; Gc.finalise finalise event; let event = 1 in ignore event; Gc.full_major (); let%lwt () = printl (if !ok then "success" else "failure") in let success = success && !ok in let%lwt () = print "testing garbage collection of a signal without a switch: " in let%lwt event = OBus_signal.connect (OBus_bus.name_owner_changed bus) in ok := false; Gc.finalise finalise event; let event = 1 in ignore event; Gc.full_major (); let%lwt () = printl (if !ok then "success" else "failure") in let success = success && !ok in let%lwt () = print "testing garbage collection of a signal with a switch: " in let switch = Lwt_switch.create () in let%lwt event = OBus_signal.connect ~switch (OBus_bus.name_owner_changed bus) in ok := false; Gc.finalise finalise event; let event = 1 in ignore event; Gc.full_major (); let%lwt () = printl (if !ok then "success" else "failure") in let success = success && !ok in return success obus-1.2.5/tests/test_serialization.ml000066400000000000000000000054701456737751200201260ustar00rootroot00000000000000(* * test_serialization.ml * --------------------- * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) (* Testing of serialization/deserialization *) open Lwt open Lwt_io (* number of message to generate *) let test_count = 100 type result = { success : int; (* Writing/reading succeed and original and resulting messages are equal *) failure : int; (* Writing/reading succeed but original and resulting messages are not equal *) reading_error : int; (* Failed to deserialize the message *) writing_error : int; (* Falied to serialize the message *) } let run_one_test byte_order msg acc = try let str, fds = OBus_wire.string_of_message ~byte_order msg in let msg' = OBus_wire.message_of_string str fds in if msg' = msg then { acc with success = acc.success + 1 } else begin { acc with failure = acc.failure + 1 } end with | OBus_wire.Data_error msg -> { acc with writing_error = acc.writing_error + 1 } | OBus_wire.Protocol_error msg -> { acc with reading_error = acc.reading_error + 1 } let run_tests prefix byte_order l = let%lwt progress = Progress.make prefix test_count in let rec aux acc n = function | [] -> let%lwt () = Progress.close progress in return acc | msg :: l -> let%lwt () = Progress.incr progress in aux (run_one_test byte_order msg acc) (n + 1) l in aux { success = 0; failure = 0; reading_error = 0; writing_error = 0 } 0 l let print_result result = let%lwt () = printf " success: %d\n" result.success in let%lwt () = printf " failure: %d\n" result.failure in let%lwt () = printf " writing error: %d\n" result.writing_error in let%lwt () = printf " reading error: %d\n" result.reading_error in return () let rec gen_messages progress acc = function | 0 -> let%lwt () = Progress.close progress in return acc | n -> let%lwt () = Progress.incr progress in gen_messages progress (Gen_random.message () :: acc) (n - 1) let test () = let%lwt progress = Progress.make (Printf.sprintf "generating %d messages" test_count) test_count in let%lwt msgs = gen_messages progress [] test_count in let%lwt () = printl "try to serialize/deserialize all messages and compare the result to the original message." in let%lwt result_le = run_tests " - in little endian" Lwt_io.Little_endian msgs in let%lwt () = print_result result_le in let%lwt result_be = run_tests " - in big endian" Lwt_io.Big_endian msgs in let%lwt () = print_result result_be in return (result_le.failure = 0 && result_le.reading_error = 0 && result_le.writing_error = 0 && result_be.failure = 0 && result_be.reading_error = 0 && result_be.writing_error = 0) obus-1.2.5/tests/test_validation.ml000066400000000000000000000024561456737751200174040ustar00rootroot00000000000000(* * test_validation.ml * ------------------ * Copyright : (c) 2009, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt open Lwt_io let good = [ OBus_string.validate "azerty"; OBus_string.validate "Jérémie"; OBus_path.validate "/"; OBus_path.validate "/a"; OBus_path.validate "/a/b"; OBus_name.validate_bus ":1.1"; OBus_name.validate_bus ":a.2"; OBus_name.validate_bus "foo.bar"; OBus_name.validate_bus "a.b.c.d"; ] let bad = [ OBus_string.validate "\xe9"; OBus_path.validate "/dd//dd"; OBus_path.validate "/dd//"; OBus_path.validate "/dd/"; OBus_path.validate ""; OBus_name.validate_bus ":1..2"; OBus_name.validate_bus "a..b"; ] let test () = let%lwt () = printl "Validation of all types of D-Bus strings" in let%lwt () = Lwt_list.iter_s (function | Some err -> printlf "valid string recognized as bad: %s" (OBus_string.error_message err) | None -> return ()) good in let%lwt () = Lwt_list.iter_s (function | None -> printlf "invalid string recognized as good" | Some _ -> return ()) bad in return (List.for_all ((=) None) good && List.for_all ((<>) None) bad) obus-1.2.5/tools/000077500000000000000000000000001456737751200136505ustar00rootroot00000000000000obus-1.2.5/tools/introspection/000077500000000000000000000000001456737751200165505ustar00rootroot00000000000000obus-1.2.5/tools/introspection/dune000066400000000000000000000003421456737751200174250ustar00rootroot00000000000000(executables (names obus_dump obus_introspect) (public_names obus-dump obus-introspect) (modules obus_dump obus_introspect) (libraries tools_util lwt obus.internals obus) (preprocess (pps lwt_ppx))) obus-1.2.5/tools/introspection/obus_dump.ml000066400000000000000000000041201456737751200210740ustar00rootroot00000000000000(* * obus_dump.ml * ------------ * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) open Lwt.Infix let usage_msg = Printf.sprintf "Usage: %s cmd args Execute 'cmd' and dump all messages it sent to session and system bus options are:" (Filename.basename (Sys.argv.(0))) let rec loop pp action what_bus a b = let%lwt message = OBus_transport.recv a in Format.fprintf pp "-----@\n@[%s on %s bus:@\n%a@]@." action what_bus OBus_message.print message; let%lwt () = OBus_transport.send b message in loop pp action what_bus a b let launch pp what_bus laddresses = let%lwt addresses = Lazy.force laddresses in let%lwt server = OBus_server.make_lowlevel ~capabilities:[`Unix_fd] (fun server transport -> ignore begin let%lwt (_, bus) = OBus_transport.of_addresses ~capabilities:[`Unix_fd] addresses in Lwt.choose [loop pp "message received" what_bus bus transport; loop pp "sending message" what_bus transport bus] end) in Unix.putenv (Printf.sprintf "DBUS_%s_BUS_ADDRESS" (String.uppercase_ascii what_bus)) (OBus_address.to_string (OBus_server.addresses server)); Lwt.return () let () = let out = ref "/dev/stderr" and cmd_args = ref [] in let anon_fun s = cmd_args := s :: !cmd_args in let args = [ "-o", Arg.Set_string out, " output messages to this file instead of stderr"; "--", Arg.Rest anon_fun, "command separator"; ] in Arg.parse args anon_fun usage_msg; let cmd_args = List.rev !cmd_args in let cmd = match cmd_args with | [] -> Arg.usage args usage_msg; exit 2 | x :: _ -> x in let oc = open_out !out in let pp = Format.formatter_of_out_channel oc in Lwt_main.run begin let%lwt () = launch pp "session" OBus_address.session <&> launch pp "system" OBus_address.system in let%lwt _ = Lwt_unix.waitpid [] (Unix.create_process cmd (Array.of_list cmd_args) Unix.stdin Unix.stdout Unix.stderr) in close_out oc; Lwt.return () end obus-1.2.5/tools/introspection/obus_introspect.ml000066400000000000000000000065601456737751200223330ustar00rootroot00000000000000(* * obus_introspect.ml * ------------------ * Copyright : (c) 2008, Jeremie Dimino * Licence : BSD3 * * This file is a part of obus, an ocaml implementation of D-Bus. *) let recursive = ref false let anons = ref [] let session = ref false let system = ref false let address = ref None let obj_mode = ref false let args = [ "-rec", Arg.Set recursive, "introspect recursively all sub-nodes"; "-session", Arg.Set session, "the service is on the session bus (the default)"; "-system", Arg.Set system, "the service is on the system bus"; "-address", Arg.String (fun addr -> address := Some addr), "the service is on the given message bus"; "-objects", Arg.Set obj_mode, "list objects with interfaces they implements instead of interfaces"; ] let usage_msg = Printf.sprintf "Usage: %s