diff options
| author | Stéphane Glondu <glondu@debian.org> | 2013-07-27 09:18:19 +0200 |
|---|---|---|
| committer | Stéphane Glondu <glondu@debian.org> | 2013-07-27 09:18:19 +0200 |
| commit | b779dbc796f2c44e8ccce5180ebb346062183fbf (patch) | |
| tree | 33686ed3c357dfff6f9b3b4616566edfa4688ece | |
Import obus_1.1.5.orig.tar.gz
[dgit import orig obus_1.1.5.orig.tar.gz]
208 files changed, 35746 insertions, 0 deletions
diff --git a/.project b/.project new file mode 100644 index 0000000..9ad0e7c --- /dev/null +++ b/.project @@ -0,0 +1 @@ +obus, an ocaml implementation of D-Bus @@ -0,0 +1,29 @@ +===== 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 diff --git a/CHANGES.darcs b/CHANGES.darcs new file mode 100644 index 0000000..46c480b --- /dev/null +++ b/CHANGES.darcs @@ -0,0 +1,2403 @@ +Tue Oct 2 11:56:47 CEST 2012 Jeremie Dimino <jeremie@dimino.org> + tagged 1.1.5 + +Tue Oct 2 11:56:33 CEST 2012 Jeremie Dimino <jeremie@dimino.org> + * bump version number + +Tue Oct 2 11:56:21 CEST 2012 Jeremie Dimino <jeremie@dimino.org> + * update CHANGES + +Tue Oct 2 11:48:24 CEST 2012 Jeremie Dimino <jeremie@dimino.org> + * remove OBus_top + +Tue Oct 2 11:38:06 CEST 2012 Jeremie Dimino <jeremie@dimino.org> + * follow type-conv incompatible changes + +Mon Jul 30 20:25:32 CEST 2012 Jeremie Dimino <jeremie@dimino.org> + tagged 1.1.4 + +Mon Jul 30 20:25:25 CEST 2012 Jeremie Dimino <jeremie@dimino.org> + * bump version number + +Mon Jul 30 20:25:14 CEST 2012 Jeremie Dimino <jeremie@dimino.org> + * update CHANGES + +Fri May 11 19:16:54 CEST 2012 Jeremie Dimino <jeremie@dimino.org> + * upgrade versions in _oasis to oasis 0.3 + +Wed Apr 25 08:10:52 CEST 2012 Jeremie Dimino <jeremie@dimino.org> + * update setup.ml for oasis 0.3.0 + +Thu Mar 15 02:28:40 CET 2012 Jeremie Dimino <jeremie@dimino.org> + * add OBus_connection.send_message_keep_serial for implementing a D-Bus daemon + +Thu Mar 15 02:13:03 CET 2012 Jeremie Dimino <jeremie@dimino.org> + * do not share OBus_connection.active + +Wed Mar 14 21:07:36 CET 2012 Jeremie Dimino <jeremie@dimino.org> + * fix a double-close of file-descriptor + +Wed Mar 14 11:16:50 CET 2012 Jeremie Dimino <jeremie@dimino.org> + * typos: replace UDisks_monitor by UPower_monitor in upower bindings + +Wed Mar 14 11:13:38 CET 2012 Jeremie Dimino <jeremie@dimino.org> + * compatibility with latest oasis + +Wed Jan 4 15:15:05 CET 2012 Jeremie Dimino <jeremie@dimino.org> + * depend on camlp4 instead of camlp4.lib for the syntax extension + +Fri Jul 29 21:50:43 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + tagged 1.1.3 + +Fri Jul 29 21:50:38 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + * version 1.1.3 + +Fri Jul 29 21:48:14 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + * implement the new eavesdrop match rule key + +Thu Jul 28 21:36:33 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + * add a minimal setup.ml file + +Sat Jun 18 18:24:16 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + * remove oasis files from the repository + +Thu Jun 16 20:33:28 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + * type-conv.syntax -> type-conv + +Sun May 1 21:44:33 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + * read /etc/machine-id if the machine uuid file cannot be read + +Mon May 30 20:17:06 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + * use oasis 0.2.1 + +Thu Apr 14 13:00:05 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + * typo + +Tue Apr 12 19:20:44 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + tagged 1.1.2 + +Tue Apr 12 19:20:38 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + * version 1.1.2 + +Tue Apr 12 19:20:05 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + * update CHANGES + +Mon Apr 11 22:27:31 CEST 2011 Jeremie Dimino <jeremie@dimino.org> + * update argNpath matching and handle argNnamespace + +Tue Mar 15 17:37:18 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * change the network-manager example + +Mon Mar 14 23:41:49 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * allow to monitor signals comming from any objects of a peer + +Tue Mar 15 17:25:20 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * replace Lwt_react.{E,S}.notify* by Lwt_react.{E,S}.keep + +Thu Mar 10 22:14:40 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * use new D-Bus errors + +Thu Mar 10 16:41:24 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * use Lwt_react instead of Lwt_event,Lwt_signal + +Thu Mar 10 10:20:25 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * implements upower and udisks properties monitoring + +Mon Feb 14 23:30:26 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * version 1.1.1 + +Thu Mar 10 02:09:12 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * add an example for network-manager + +Wed Mar 9 23:58:30 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * implement property monitoring for network-manager + +Mon Feb 14 23:10:54 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * add a CHANGES file + +Mon Feb 14 19:40:42 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * try to get the session bus address from launchd when the environment variable is not set + +Mon Feb 14 16:50:03 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * do not call oasis in predist.sh + +Mon Feb 14 16:47:50 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * use listings in the manual + +Mon Feb 14 13:25:47 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * add launchd support + +Mon Feb 14 11:53:15 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * add a boring file + +Sun Jan 9 12:48:59 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * only use read and write during authentication + +Sun Jan 9 10:32:56 CET 2011 Jeremie Dimino <jeremie@dimino.org> + * fix a race condition in servers that may cause end-of-authentication to hang + +Thu Dec 16 17:31:15 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add a constraint for the ocaml version in _oasis + +Mon Dec 13 14:48:59 CET 2010 Jeremie Dimino <jeremie@dimino.org> + tagged 1.1 + +Mon Dec 13 14:48:55 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * version 1.1 + +Sat Nov 27 01:40:39 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * replace Lwt.set by Lwt.with_value + +Wed Nov 24 20:57:51 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * update to match last version of lwt + +Thu Nov 18 09:06:55 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * use Lwt_unix.getaddrinfo instead of Unix.getaddrinfo + +Thu Nov 18 04:29:20 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * use new lwt async unix calls + +Wed Nov 17 13:02:11 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * Lwt_unix.close now returns a thread + +Wed Nov 17 12:59:26 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * pass the context via local storage to method call handlers + +Mon Nov 8 17:27:47 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * put code examples into boxes in the manual + +Tue Nov 2 19:31:03 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add files generated by 'oasis setup' + +Sat Oct 23 02:08:57 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add darcs info to _oasis + +Sat Oct 23 01:58:17 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add oasis files to the repository + +Sat Oct 23 01:43:58 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * udpate oasis stuff to oasis 0.2 + +Tue Oct 12 18:34:26 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add the inputenc package for the manual + +Wed Oct 6 21:07:11 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix behavior in OBus_resolver when the service is initially not present + +Tue Oct 5 00:41:40 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * remove colors in the manual + +Tue Oct 5 00:39:50 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * rename Makefile to make-dist.sh + +Tue Sep 7 16:20:13 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * more doc + +Tue Sep 7 11:06:48 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * remove code files for the manual + +Tue Sep 7 11:02:05 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * open the interface module in generated files + +Tue Sep 7 11:01:54 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add obus-introspect to _oasis + +Tue Sep 7 10:51:01 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * changes in the manual + +Mon Sep 6 19:17:27 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * use meldor for syntax highlighting + +Mon Sep 6 08:43:38 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * make the manual to depends on code examples + +Sun Sep 5 18:36:09 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * remove the VERSION file + + The version is now defined in the _oasis file. + +Sun Sep 5 18:12:08 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * build the manual when in dev mode + +Sun Sep 5 18:06:08 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add tests and examples to _oasis + +Sun Sep 5 16:20:36 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * make Pa_obus an internal module + +Sun Sep 5 10:05:37 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * remove manual/_tags + +Sun Sep 5 09:54:57 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * update the README + +Sun Sep 5 09:35:19 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * switch to oasis + +Sat Sep 4 16:19:56 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * install user manual with oasis + +Sat Sep 4 16:15:45 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * change installation directory for man-pages + +Sat Sep 4 19:12:22 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * more doc + +Sat Sep 4 13:15:00 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * use raise_lwt instead of fail + +Fri Sep 3 21:39:39 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * more doc + +Fri Sep 3 17:19:54 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add an _oasis file + +Fri Sep 3 11:56:34 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * more doc + +Fri Sep 3 08:37:16 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * better way of colorizing code + +Thu Sep 2 16:25:21 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * colorize code examples in the manual + +Thu Sep 2 13:12:29 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * adds sections to the manual + +Tue Aug 31 18:56:41 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * uncomment code commented by mistake + +Tue Aug 31 18:50:37 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * update the README + +Sun Aug 29 19:53:48 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix garbage collection of signals, resolves, ... + +Sun Aug 29 18:26:50 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * typo + +Sun Aug 29 11:54:41 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add switches to connections and transports + +Sun Aug 29 10:57:03 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * update switch uses + +Sun Aug 29 10:42:19 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * replace OBus_connection.support_unix_fd by OBus_connection.can_send_*_type + +Sun Aug 29 10:33:06 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add switches to servers + +Sat Aug 28 16:36:30 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * better naming of tools output files + +Sat Aug 28 16:18:41 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * refactoring and better API + +Sun Aug 15 18:29:36 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * replace string option by string for the type of names + +Sun Aug 15 13:27:44 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * refactoring in _tags + +Thu Aug 12 08:33:39 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * put use-ocamlfind in myocamlbuild.ml + +Wed Aug 11 11:23:33 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * update the compilation process with new ocaml 3.12 features + +Sun Aug 1 19:59:24 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * replace "running_of_connection connection" by "connection#get" + +Sun Aug 1 19:51:43 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add a Makefile for the manual + +Sat Jun 26 17:06:18 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix compiplation with ocaml 3.12 + +Tue Jun 22 21:40:20 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * doc + +Sun Jun 20 13:13:19 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * typo + +Sun Jun 20 00:15:54 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * rename records with shorter field names + +Thu Jun 17 13:13:01 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * Fix D-Bus error mapping + +Thu Jun 17 09:48:34 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * uses a private type only for argument filters in OBus_match + +Thu Jun 17 09:36:23 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * only invalidates the property cache when the owner is present + +Thu Jun 17 09:34:38 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * make server code a bit more readable + +Thu Jun 17 09:25:08 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * invalidates the property cache when the owner changes + +Wed Jun 16 14:39:25 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * remove pa_monad from _tags + +Wed Jun 16 14:37:17 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * remove pa_monad + + Not used anymore. + +Sat Jun 12 15:23:48 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add syntax/pa_obus.ml + +Fri Jun 11 11:30:04 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * typo + +Fri Jun 11 11:23:30 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * rewrite error handling + +Thu Jun 3 08:59:30 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * simplify D-Bus errors + +Wed Jun 2 22:30:28 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * small enhancement in OBus_idl + +Fri May 28 15:37:54 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add obus_idl.mllib + +Fri May 28 13:29:52 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * obus.idl depends on camlp4.lib and not camlp4 + +Fri May 28 13:19:52 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * make the idl available as a sub-library + +Fri May 28 03:29:33 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * send interfaces annotations in introspection + +Fri May 28 03:24:09 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix annotaions printing in obus-gen-interface + +Wed May 26 14:59:00 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * typo + +Wed May 26 08:38:07 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * handle sign in annotations + +Wed May 26 02:27:13 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * extend D-Bus interface by using annotations + +Mon May 24 16:32:00 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * typo + +Sat May 22 13:22:49 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix an inversion in an error message + +Sat May 22 10:26:05 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add an emacs mode for editing idl files + +Thu May 20 15:24:16 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * use less quotes in idl files + +Thu May 20 13:25:40 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * print annotations when converting an xml file to an idl file + +Thu May 20 13:21:20 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * remove ocaml keywords in the parser of idl files + +Thu May 20 11:57:31 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add support for annotations in idl files + +Thu May 20 09:46:05 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * do not call generate in OBus_object.make + +Thu May 20 09:34:43 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix arguments of obus-gen-interface + +Thu May 20 08:31:45 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * do not allow methods with the same name and different types + +Thu May 20 08:22:59 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix property notification modes + +Thu May 20 01:16:09 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * use auto-generated code for common interfaces + +Wed May 19 23:53:58 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * handle annotations for local objects + +Wed May 19 13:23:36 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * handle members annotations + +Wed May 19 12:55:26 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * allow to use another notification system for objects' properties + +Wed May 19 11:45:40 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add OBus_property.monitor_custom + +Wed May 19 11:24:21 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * implement OBus_property.monitor_wiht_stopper + +Wed May 19 11:20:50 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * better handling of cached properties + +Tue May 18 15:59:27 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix tests + +Tue May 18 15:55:45 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * change the type of OBus_method.reply + + This prevent from not repsonding to a message by mistake + +Tue May 18 10:41:39 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * use the new standard PropertiesChanged signal + +Sat May 8 13:49:24 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * typo in network-manager: int32 instead of uint32 + +Fri May 7 19:43:29 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * split the network manager bindings into several modules + +Fri May 7 18:48:44 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * handle interfaces without method and without property + +Wed May 5 13:54:12 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * enhancement in rule set computation + + Now, we compute the minimal set of incomparable most general rules. + +Tue May 4 10:06:52 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * make the notify_mode argument recquired + +Tue May 4 09:41:08 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * allow to add/remove several interfaces at the same time + +Tue May 4 08:36:43 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * do not keep message bodies in contexts + +Mon May 3 11:17:28 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * change the way of returnig the reply to a method call + +Mon May 3 09:00:31 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * replace oBus_interfaces.ml* by oBus_interfaces.obus + +Sun May 2 22:36:10 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * rewrite contexts stuff + +Thu Apr 29 16:06:09 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * typo + +Wed Apr 28 14:54:50 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * use more property groups + +Tue Apr 27 21:16:50 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add property groups + +Sat Apr 24 13:26:51 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * sort members in obus-gen-interface + +Sat Apr 24 13:06:47 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix order of methods of the properties interface + +Sat Apr 24 11:59:36 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * call OBus_object.generate after data has been attached + +Fri Apr 23 17:28:59 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add OBus_property.updates + +Fri Apr 23 09:28:02 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * use records instead of labelled arguments for service code + + This imporve error messages. + +Fri Apr 23 02:30:34 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix code generated by obus-gen-server + +Thu Apr 22 13:39:21 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * optimization in OBus_auth + +Thu Apr 22 13:12:43 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * typo + +Sun Apr 18 19:34:24 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * switch to melt for the user manual + +Sun Apr 18 17:12:20 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * adds dynamic value converters + +Sat Apr 17 22:30:55 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * typo... + +Sat Apr 17 22:03:52 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * typo + +Sat Apr 17 18:05:00 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * typo + +Wed Apr 14 20:58:56 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix server code printing + +Wed Apr 14 16:14:37 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix IDL parsing + +Tue Apr 13 11:32:22 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * do not requires full camlp4 for the idl + +Tue Apr 13 11:25:24 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix installation new tools + +Tue Apr 13 09:26:23 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add an IDL language + +Mon Apr 12 14:23:49 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * simplifications + +Tue Apr 6 16:18:26 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * better errors on cast failures + +Mon Apr 5 19:29:11 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * allow to create custom notification modes for local objects + +Mon Apr 5 19:17:52 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * always close duplicated file descriptors after sending a message + +Mon Apr 5 19:14:19 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * duplicate file descriptors before sending them + +Mon Apr 5 18:39:42 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix a fd leak in OBus_wire + + When a message failed to be read, file descriptor removed from the + queue were not closed. + +Mon Apr 5 18:10:54 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * allow to cache properties, even if we are not using property monitoring + +Mon Apr 5 13:58:43 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * remove OBusPropertiesChanged + +Mon Apr 5 00:31:35 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * allow to choose the notification mode + +Sun Apr 4 23:23:56 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * more efficient local objects + + Methods and properties are not stored in sorted arrays. + +Sun Apr 4 15:13:22 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * refactoring + +Sun Apr 4 09:30:23 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix automatic introspection + +Sun Apr 4 09:06:50 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add property change notifications for local objects + +Sat Apr 3 15:31:17 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * better control of property change notifications + +Fri Apr 2 14:36:18 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * allow to unmonitor a proeprty + +Fri Apr 2 14:23:05 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add more helpers in OBus_proxy for properties + +Fri Apr 2 10:06:40 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * smarter update of properties + + When the notification signal contains update informations, use them + instead of calling GetAll. + +Thu Apr 1 18:17:30 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * filter incomming signals with argument filters + +Thu Apr 1 17:56:09 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * Refactoring + + - move helpers of OBus_connection to OBus_{method,signal,property} + - keep only basic functions in OBus_connection + - OBus_connection do not depdends anymore on OBus_type, + so we can define the context type directly in OBus_type and + remove the ugly hack with exceptions... + +Wed Mar 31 15:48:50 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * drops non-standard extensions of introspection documents + +Wed Mar 31 15:10:11 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix a type in tools/print.ml + +Wed Mar 31 14:41:49 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix UDisks bindings + +Wed Mar 31 14:23:57 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add UDisks.Permission_denied + +Wed Mar 31 14:18:24 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add bindings for udisks + +Wed Mar 31 10:47:44 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add the exception Policy_kit.Not_authorized + +Wed Mar 31 10:41:36 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add bindings for policykit + +Wed Mar 31 08:26:20 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * use labelled arguments in generated bindings + +Wed Mar 31 08:09:42 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add exceptions for UPower + +Wed Mar 31 00:24:30 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * enhancements in the UPower binding + +Tue Mar 30 22:17:07 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * enhancement in OBus_property + +Tue Mar 30 21:17:41 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * Better handling of properties + + Automatic use of Changed+GetAll + +Tue Mar 30 14:22:45 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add OBus_signal + +Tue Mar 30 10:49:04 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * start of a binding to upower + +Tue Mar 30 09:42:47 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add helpers for private proxies + +Tue Mar 30 02:41:23 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add "broken" type combinators + +Tue Mar 30 01:35:29 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix arguments for obus-dump + +Mon Mar 29 20:25:39 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * add copyright to network-manager files + +Mon Mar 29 20:23:08 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * do not install pa_obus.cma twice + +Mon Mar 29 19:58:44 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * fix bindings printing + +Mon Mar 29 19:40:10 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * do not depends on lwt.text + +Mon Mar 29 19:30:40 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * install bindings .a files + +Mon Mar 29 19:06:58 CEST 2010 chambart@crans.org + * NetworkManager binding + +Mon Mar 29 11:33:28 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * allow to enable/disable automatic match rules management + +Sun Mar 28 12:58:22 CEST 2010 Jeremie Dimino <jeremie@dimino.org> + * better tests + +Sun Mar 28 01:15:04 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * start better unit tests + +Sun Mar 28 00:41:19 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * rename SELinux... -> Selinux... + +Sat Mar 27 10:21:20 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * fix validation of bus names + +Thu Mar 25 21:08:01 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * change OBus_bus.session and OBus_bus.system + +Thu Mar 25 18:30:38 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add bindings to doc + +Thu Mar 25 16:41:22 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * fix css copying + +Thu Mar 25 16:16:21 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * typo + +Thu Mar 25 16:09:41 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * fix the doc rule of the Makefile + +Thu Mar 25 16:02:13 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * better compilation rules + + It is now possible to compile/install only libraries + +Thu Mar 25 11:28:03 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * Lwt_log.exn -> Lwt_log.error + +Thu Mar 25 08:01:36 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * css: fix color of keyword symbols + +Thu Mar 25 00:34:50 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * css: highlight definitions + +Wed Mar 24 21:05:53 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * minor css changes + +Wed Mar 24 11:01:03 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * copy the css to the doc directory + +Wed Mar 24 09:43:19 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * make documentation more beautiful + +Tue Mar 23 22:58:23 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * do not use camlp4 on .mli, cleanup _tags and fix doc + +Tue Mar 23 18:57:49 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add categories to documentation + +Tue Mar 23 16:32:05 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * update signal connection + +Sun Mar 21 18:21:51 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * uses new lwt logs + +Sat Mar 20 15:03:34 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * Lwt.select --> Lwt.pick + +Fri Mar 19 02:20:55 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * resolvers enhancements + +Fri Mar 19 02:09:27 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * server enhancement + +Wed Mar 17 18:51:50 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * signal handling enhancement + +Tue Mar 16 20:23:20 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * repalce Lwt_main.fast_yield by Lwt.pause + +Tue Mar 16 18:50:34 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add finalisers for events and signals + +Mon Mar 15 21:41:08 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * Lwt_stream.push_stream --> Lwt_stream.create + +Mon Mar 15 17:15:25 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * remove the O{P,L}_interface keywords + + Not needed + +Mon Mar 15 13:32:39 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add the error "org.freedesktop.Error.InvalidArgs" mapped to Invalid_argument + +Fri Mar 12 18:10:37 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add a depency to lwt.react + +Fri Mar 12 00:27:47 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * fix a fd leak when passing fds + +Fri Mar 5 11:28:28 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * make name validation faster (~4 times faster) + +Thu Mar 4 16:30:16 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * log message bus openning problems + +Tue Mar 2 16:46:52 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * srting validation a bit more efficient + +Tue Mar 2 15:25:05 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * fix random float generation in tests + +Tue Mar 2 10:36:52 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * allow to not replace the on_disconnect function in OBus_bus.register_connection + +Mon Mar 1 23:12:57 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * fix a serialization bug + +Mon Mar 1 13:54:28 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add sections in oBus_server.ml + +Mon Mar 1 11:57:56 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * rename OBus_error.unmake to OBus_error.cast + +Mon Mar 1 11:23:09 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * server-side nonce-tcp transport + +Mon Mar 1 10:26:00 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * client-side nonce-tcp transport + +Mon Mar 1 09:55:25 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * better support of server-side tcp transport + +Mon Mar 1 08:32:40 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * change the semantic of server listenning failure + + If we cannot listen on one of the addresses, we fail. + +Sun Feb 28 17:24:48 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * rename test to tests + +Sun Feb 28 17:18:41 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * fix camlp4 code generation + +Sun Feb 28 17:09:26 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * rewrite syntax tests + +Sun Feb 28 16:51:39 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * fix code generation + +Sun Feb 28 12:12:26 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add support for custom bus address in obus-dump + +Sun Feb 28 11:01:45 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add OX_interface keywords + +Sun Feb 28 01:09:09 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * new way of defining interfaces + +Fri Feb 26 10:49:10 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * ensures that argument filter indexes are between 0 and 63 + +Thu Feb 25 19:11:55 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * OBus_signal.t -> OBus_proxy.signal in obus-binder + +Thu Feb 25 18:47:16 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * OBus_object enhancement + +Thu Feb 25 18:17:05 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * typo + +Thu Feb 25 18:10:39 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * allow to sets argument filters + +Thu Feb 25 16:43:05 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add path-style matching on message arguments + +Thu Feb 25 15:27:57 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add OBus_object.S + +Thu Feb 25 15:02:19 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * functorize the OBus_proxy module, and remove uneeded modules + +Thu Feb 25 10:54:08 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add more exception printers + +Sat Feb 20 18:39:37 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * use fast_yield instead of yield in OBus_server + +Sat Feb 20 12:20:28 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * bugfix in address parsing + +Sat Feb 20 12:01:51 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * better handling of transport/server creation errors + +Fri Feb 19 18:14:23 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * Better handling of lexer errors + +Fri Feb 19 14:19:37 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * make OBus_bus.acquired_names a signal + +Fri Feb 19 14:10:18 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * use React.signal for varaibles that may change over the time + +Fri Feb 19 13:25:20 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * renaming of polymorphic variants + +Fri Feb 19 11:26:15 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * update logging instructions + +Thu Feb 18 20:05:25 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * udpate logging instructions + +Wed Feb 17 21:35:00 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * handle Out_of_memory in the dispatcher + +Wed Feb 17 11:31:38 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * bugfix: double wakeup of resolver initialisation thread + +Wed Feb 17 11:07:13 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * do not fail when the sending of a message is canceled + +Wed Feb 17 10:10:36 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * allow to cancel the sending of a message + +Wed Feb 10 10:04:57 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * remove macros from OBus_connection.ml + + Code with macros is less readable. + +Mon Feb 8 20:13:36 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * allow labelled arguments in obus-types + +Sun Jan 31 09:34:55 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * allow interface with a custom proxy type + +Thu Jan 28 18:23:26 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * do not closes everything on exit + +Thu Jan 28 11:26:52 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * fix a dead-lock when sending several messages in parallel + +Wed Jan 27 23:18:31 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add OBus_bus.Access_denied + +Wed Jan 27 16:25:28 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add labels for OBus_{peer,proxy}.make + +Tue Jan 26 22:09:20 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * correspondance table for types + +Tue Jan 26 22:06:47 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add predist.sh + +Tue Jan 26 18:31:26 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * start of documentation + +Tue Jan 19 16:33:54 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add support for dynamic objects + +Tue Jan 19 15:42:43 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * fix OBus_path.escape + +Sun Jan 17 18:42:22 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * doc + +Sat Jan 16 17:36:14 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * duplicate file descriptors in the loopback transport + +Sat Jan 16 17:16:03 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * do not creates the loopback connection by default + +Sat Jan 16 17:09:45 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * add arguments to OBus_type.Cast_failure + +Sat Jan 16 16:31:58 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * better handling of exceptions + +Sat Jan 16 14:59:31 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * enhancement for reading/writing messages with fds + +Sat Jan 16 14:01:57 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * do not use buffering for authentication + +Sat Jan 16 11:58:08 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * handle unix fd passing in obus-dump + +Sat Jan 16 11:52:22 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * implementation of external and anonymous authentication mechanisms for server-side + +Sat Jan 16 00:36:15 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * implementation of fd passing over unix socket + +Fri Jan 15 01:46:34 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * style + +Fri Jan 15 01:35:06 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * change build order + + Build documentation after the lib. + +Thu Jan 14 21:21:35 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * move OBus_type.Pervasives to OBus_pervasives + +Tue Jan 12 13:22:23 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * Lwt_util --> Lwt_list + +Sun Jan 10 12:26:15 CET 2010 Jeremie Dimino <jeremie@dimino.org> + * fix method calls of OBus_bus + +Tue Dec 22 10:19:30 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * remove logs with level notice + +Sat Dec 19 13:43:29 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * yield before dispatching in OBus_server + +Sat Dec 12 19:47:41 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * add the obus_array combinator + +Fri Dec 11 22:47:11 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * rename tests + +Fri Dec 11 22:44:43 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * rename OBus_type.Perv to OBus_type.Pervasives + +Tue Nov 10 08:46:48 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * replace the logging system by the one of Lwt + +Mon Nov 2 06:37:52 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * close file descriptors on exec + +Tue Oct 20 15:43:45 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * more features for objects + +Sat Oct 17 16:11:49 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * fix hal bindings + +Fri Oct 16 16:44:14 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * s/DBus/D-BUS + +Fri Oct 16 12:40:46 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * use '$(wildcard ...)' in the Makefile + + so we do not fail on bytecode only architecture since .cmx* are not + present. + +Wed Oct 14 01:38:43 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * add the date to manpages + +Wed Oct 14 01:38:23 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * s/authentification/authentication/ + +Tue Oct 13 20:26:17 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * typo + +Tue Oct 13 19:16:22 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * fix scripts + +Tue Oct 13 14:46:36 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * make obus depends on lwt.unix instead of lwt + +Tue Oct 13 08:15:22 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * add manual pages + +Tue Oct 13 07:24:18 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * fix printing of property signatures + +Tue Oct 13 01:59:46 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * fix signatures printing + +Sun Oct 11 21:56:23 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + tagged 1.0rc1 + +Sun Oct 11 21:56:13 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * version 1.0rc1 + +Sun Oct 11 21:45:13 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * switch to xmlm + +Sun Oct 11 19:42:21 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * added OBus_proxy.children + +Sun Oct 11 16:44:00 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * remove OBus_config from documentation + +Sat Oct 10 19:57:26 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * update README + +Sat Oct 10 19:45:37 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * license fixes + +Sat Oct 10 19:44:40 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * enhancement in the build process + +Sat Oct 10 19:10:56 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * style + +Sat Oct 10 17:51:40 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * remove benchmark + + not very use-full and i do not want to maintain it... + +Sat Oct 10 11:06:00 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * change binder for service code generation + +Wed Oct 7 16:10:56 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * allow to define methods and property readers/writers directly + +Wed Oct 7 14:30:49 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * fix tests + +Wed Oct 7 13:41:16 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * reimplementation of service offering code + +Sun Oct 4 09:32:46 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * use [Lwt_event.always_notify*] + +Sat Oct 3 17:11:25 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * rename OBUS_INTERFACE to OBUS_interface + +Thu Oct 1 19:40:15 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * fix DBUS_COOKIE_SHA1 authentication + +Thu Oct 1 19:25:34 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * modification of the behaviour of signal creation + +Thu Oct 1 17:59:55 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * fix UTF-8 checking + +Wed Sep 30 21:14:25 CEST 2009 Jeremie Dimino <dimino@crans.org> + * rewrite examples + +Wed Sep 30 19:20:14 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * more rewriting + +Tue Sep 29 21:10:18 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * adapt for new lwt + other changes + +Mon Sep 21 07:42:31 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * make Match_rule public and add rule parsing + +Sun Sep 20 10:20:00 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * put transport stuff into a separate module + +Sun Sep 20 08:22:41 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * end of rewrite of serialization code + +Sat Sep 19 22:12:21 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * start of a more robust serialization code + +Sat Sep 19 22:09:44 CEST 2009 Jeremie Dimino <jeremie@dimino.org> + * changes in OBus_value + + - rename Structure and Tstructure to Struct and Tstruct + - add Byte_array for compact representation of array of bytes + - remove functors for signature serialization + +Thu Feb 19 00:19:32 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * fix a race condition in the benchmark + +Wed Feb 18 23:47:53 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * embed pa_monad + + It is only a build-time dependency. + +Wed Feb 18 23:38:37 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * remove pa_trace + +Wed Feb 18 23:31:45 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * add a benchmark + +Wed Feb 18 22:59:01 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * flush the connection on normal exit + +Wed Feb 18 22:23:54 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * better printing in tests + +Wed Feb 18 22:21:34 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * correctly cleanup everything at exit + +Tue Feb 17 17:59:42 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * rewrite io using custom channels + + - use a bigger buffer (less system calls) + - more control on how to serialize things + - enhancement of delayed flushing + +Tue Feb 17 00:58:02 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * minimise syscalls + + Add a machinery to do as few flush as possible. + +Sat Feb 14 22:18:45 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * use -linkpkg only when linking binaries + +Fri Feb 6 00:44:10 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * renaming + +Thu Jan 29 22:20:06 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * upgrade tests + +Fri Jan 16 14:00:39 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * added syntax pa_constructor + +Fri Jan 16 13:12:12 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * move the code of Types_rw to OBus_value + +Fri Jan 16 08:23:02 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * rewrite of pa_obus + modification of type combinators + + - pa_obus now fully use type-conv + - combinators are renamed from "t..." to "obus_..." + +Thu Jan 15 14:13:00 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * added the pa_projection syntax extension + +Thu Jan 15 14:02:06 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * use the _tags file for finding packages instead of "ocamlfind list" + + This way, the -package option is added even for missing packages and + ocamlfind report the error. + +Thu Jan 15 12:27:27 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * use a variant for message type instead of polymorphics variants + +Thu Jan 15 02:33:49 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * just pack the connection into a object + +Tue Jan 13 21:13:29 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * fix argument order for obus_emit_signal + +Tue Jan 13 21:07:19 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * let ocamlbuild generate the META file + +Tue Jan 13 17:38:02 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * change the semantic of OBus_connection.send_message_with_reply + + Return an error (OBus_message.error) instead of raising an exception. + +Tue Jan 13 16:57:15 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * building of shared libraries + +Mon Jan 12 16:45:17 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * rename progress samples + +Mon Jan 12 16:29:38 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * cleanup the build process + +Mon Jan 12 16:25:57 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * add usefull scripts + +Mon Jan 12 14:54:12 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * remove avahi bindings + + To much work to implement because of the lack of a good documentation. + +Mon Jan 12 14:47:30 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * stop support for ocaml < 3.11 + +Mon Jan 12 14:35:57 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * use a private type for hal device udi + + This is to be sure we do not use accidently arbitrary object path. + +Mon Jan 12 14:23:05 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * allow to use custom proxy types + +Mon Jan 12 12:03:32 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * construct a list of acquired names + +Mon Jan 12 11:48:15 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * fixes in notification + + - call CloseNotification on the right peer + - monitor only peers we have opened notification on + +Mon Jan 12 01:26:00 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * rename notify -> notification + +Mon Jan 12 01:17:45 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * put internal modules in obus/internals + + This way bindings and samples do not have access to them. + +Mon Jan 12 00:50:26 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * put pervasive definitions in OBus_type.Pervasives and automatically open it + +Mon Jan 12 00:20:11 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * enhancement of the notification binding + + Handle all possible errors (daemon exit, ...) + +Mon Jan 12 00:19:30 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * use objects for connections instead of records + + This makes connections comparable. + +Fri Jan 9 16:17:40 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * integration of name resolving/monitoring + + used internally to corretly route signals and detect when a peer has + exited. + +Fri Jan 9 15:56:04 CET 2009 Jeremie Dimino <jeremie@dimino.org> + * module for bus methods used internally + +Mon Dec 1 03:37:53 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [test/communication] new test + + Test the communication with another application not using obus. + +Mon Dec 1 03:29:26 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/name] typo + +Mon Dec 1 02:51:30 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [test] rewrite several tests + +Mon Dec 1 02:50:05 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/value] signature validation + +Mon Dec 1 01:03:45 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/name,obus/string] refactoring + +Mon Dec 1 00:00:15 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/value] better pretty-printing + +Sun Nov 30 17:28:28 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/lowlevel] more abstraction for serializer/deserializer + +Sun Nov 30 14:55:28 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * use Filename.temp_dir_name to locate the temporary directory + +Sat Nov 29 16:44:41 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/name] check that names have at least two elements + +Sat Nov 29 16:28:36 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * make ocaml 3.11 happy about file names + + replace '-' by '_' in file names + +Sat Nov 29 16:19:22 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [install] change the behaviour of make uninstall/install + +Sat Nov 29 16:19:02 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [tags] use only pkg_* tags + +Sat Nov 29 16:06:26 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/lowlevel] functorize serialization/deserialization + +Sat Nov 29 16:04:49 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/monad] module for monad signature + +Sat Nov 29 16:00:24 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/string] new module for all strings validation + +Thu Nov 13 02:49:49 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/signal] fix enable/disable + +Fri Oct 31 23:27:44 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [build] modifications due to change in modules + +Fri Oct 31 23:26:49 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [syntax] adapt pa_obus for the new api + +Fri Oct 31 23:26:04 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [tags] use the same syntax extensions for all files + +Fri Oct 31 23:25:42 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [test] rewrite tests with the new api + +Fri Oct 31 23:25:21 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [tools] rewrite tools with the new api + +Fri Oct 31 23:25:02 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [samples] rewrite samples with the new api + +Fri Oct 31 23:24:38 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [bindings] rewrite bindings for the new api + +Fri Oct 31 23:24:19 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus] code cleanup + +Fri Oct 31 23:22:36 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/error] new errors + better failwith + +Fri Oct 31 23:21:54 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/message] change fields type according to change in names + +Fri Oct 31 23:19:23 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/context] remove OBus_context + + OBus_peer.tt and OBus_connection.tt are enough, there is no need for + an additional module . + +Fri Oct 31 23:17:56 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/mset] allow to deal with nodes, and separate nodes from their sets + +Fri Oct 31 23:17:17 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/mqueue] simplify message queues + +Fri Oct 31 23:16:06 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/introspect] verify names in introspection document at parsing time + +Fri Oct 31 23:14:24 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/connection] remove signal receiver at connection level + + This is a lowlevel operation which can be done with filter if the user + really want to do such a thing. + +Fri Oct 31 23:09:26 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus] unification of diferrent proxy types + + - there is only one type to represent proxy: OBus_proxy.t which is now + a pair of a peer and a path. + + - facility for creating interfaces dealing with path or connection + directly are removed because this brought several problems (like name + owner change) and without it the api cleaner. + + - also it is now possible to register to any signal emited by a peer. + +Fri Oct 31 23:07:02 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/peer] new module OBus_peer to deal with DBus peer + + DBus peers are represented by a connection + a name. + OBus_peer also implement the "org.freedesktop.DBus.peer" interface. + +Fri Oct 31 23:05:46 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/name] code cleanup + rename Connection_unique to Unique + +Fri Oct 31 23:04:01 CET 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/introspect] move OBus_interface in OBus_introspect + +Sun Oct 26 01:06:29 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [tools/obus-dump] fix argument order for launching sub-command + +Thu Oct 23 23:47:56 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [tools/obus-dump] tools to dump messages sent by an application + +Thu Oct 23 23:46:29 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/transport] rewrite transport code + + launch authentication at creation time + +Wed Oct 22 06:09:52 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/lowlevel] fix: calculate padding for structure and dict_entry + +Wed Oct 22 04:28:49 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/connection] enhance error handling + +Wed Oct 22 03:28:39 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus] use lwt for all io operations + +Wed Oct 22 03:02:33 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/value] print value without boxing + use formatters + +Tue Oct 21 20:53:58 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/mset] rewrite MSet + +Tue Oct 21 19:50:01 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [log] print backtrace if ocaml >= 3.11 + +Sun Oct 19 15:38:42 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [name_translator] module with translations dbus names -> caml names + +Sun Oct 19 06:10:30 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [syntax/pa_obus] add syntax extension for method, signal and properties in client mode + +Sun Oct 19 00:30:27 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [syntax/pa_obus] change the syntax of dbus interfaces + + OBUS_class id iface = object ... end + become: + class virtual id = OBUS_interface iface ... end + +Sat Oct 18 21:33:58 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/server] let the user set the connection up itself + +Sat Oct 18 08:22:22 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [samples/progress] new service sample + +Sat Oct 18 01:36:20 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/object] type combinator for object + +Sat Oct 18 01:09:20 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/object] class for object created for a specific client + +Sat Oct 18 00:07:15 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/object] allow signal to be emited to a specific destination + +Fri Oct 17 23:37:38 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/connection] fix error handling + + connections to message buses were not closed correctly when a fatal + error happened + +Fri Oct 17 01:56:06 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + tagged 0.3 + +Fri Oct 17 01:43:12 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [doc] update README + +Fri Oct 17 01:15:40 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/auth] remove server mechanisms which require credentials + +Fri Oct 17 01:00:16 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/connection] handle introspection on intermediate undefined objects + +Fri Oct 17 00:42:47 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [syntax/pa_obus] define the type "_list" for OBUS_bitwise + + So we can use it in place where we need both the caml type and the + dbus type. + +Fri Oct 17 00:09:16 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/objects] set only one path by object + + instead of having a path by connection, use the same path for all + connections an object is exported on. It is easier to handle and + more natural. + +Thu Oct 16 20:16:40 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/context] let retreive the context of method calls + +Thu Oct 16 19:16:17 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [bindings/notify] make the use of actions in notify simplier + +Thu Oct 16 18:51:01 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/proxy] add functions for direct access of properties + +Thu Oct 16 11:51:03 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/proxy] change argument order + + the proxy argument is now in first position + +Thu Oct 16 11:41:45 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [signals] use sequence types instead of functionnal types for signals + + this is more natural since signals do not have a reply, this avoid + extra anoying "-> unit". + +Thu Oct 16 10:58:16 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/connection] remove the message queue from the connection + +Thu Oct 16 10:30:39 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [objects] abstract interface definition + syntax extension + code generation + +Wed Oct 15 20:37:32 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/connection] use message queue + + - reading and dispatching is done in separate thread + - allow to set a connection up or down + +Wed Oct 15 20:37:08 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/mqueue] implementation of message queue + +Wed Oct 15 19:18:44 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/server] implementation of dbus server for peer-to-peer communication + +Wed Oct 15 05:30:51 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [syntax/pa_log] remove pa_log and use a caml module Log instead + +Wed Oct 15 05:05:18 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [syntax/pa_seq] remove old ununsed syntax extension + +Tue Oct 14 19:05:45 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/address] implement address -> string + +Tue Oct 14 13:10:52 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/auth] use lwt for mechanism handlers + +Tue Oct 14 13:07:58 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [syntax/log] enhancement of logging + + allow use of pa_log in [Util] + uses colors for errors if possible + +Tue Oct 14 09:37:20 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/auth] implementation of dbus_cookie_sha1, client + server + +Tue Oct 14 08:44:21 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/lowlevel] fix serialization of double + +Tue Oct 14 05:12:11 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * [obus/auth] rewrite parsing + better handling of errors + +Mon Oct 13 04:05:10 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * implementation of server-side authentification + +Sun Oct 12 21:39:26 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * remove the dependency OBus_type -> OBus_internals + + OBus_type can then be put higher in the depency list and so we can put + combinators in various modules + +Sun Oct 12 20:42:29 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * begin implementation of object exporting + +Sun Oct 12 20:25:36 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * rewrite transport/serialization stuff + + - asbtract transport to make it easy to write new custom transport: + a transport is now only a pair of functions able to send/receive message + - remove by hand bufferization handling and use lwt channels instead, + performance cost is too small (=0 ?) compared to advantages: + * better error handling + * it is simplier to write serializers (in the future: x11 transport) + * less memory consumption + +Tue Sep 16 19:23:14 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fix installation of syntax extension + +Tue Sep 16 05:56:46 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fixes with new path representation + +Tue Sep 16 03:48:58 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * object path : string -> string list + + implement object as list of elements instead of just string: + - this avoid confusion with normal string + - this is usefull for service mode (object tree) + +Tue Sep 16 01:36:22 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * renaming of name types + +Tue Sep 9 14:29:29 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fix hal device computer path + +Mon Sep 1 17:58:15 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * handle signal with us as destination + +Tue Aug 26 16:54:18 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * make notify handle replacement of the notifications daemon + +Tue Aug 26 16:04:53 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * validation of all type of strings + +Thu Aug 21 06:44:57 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Always unmarshal the message immediatly + + Instead of delaying the unmarshaling of messages until we find a specific reader, we + directly unmarshal it as a dynamically typed value and then the value is casted. Same thing + for writing. + + - This make the code simplier + - This allow more features (like matching on message arguments) + - This dooes not any difference it term of cost + +Mon Aug 18 07:27:07 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + tagged 0.2 + +Mon Aug 18 07:20:25 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * doc + +Mon Aug 18 06:30:57 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * start of a avahi binding + +Mon Aug 18 05:05:01 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * enhance the notification binding + +Mon Aug 18 03:38:06 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * implementation of properties + +Mon Aug 18 02:17:49 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * handling of signals + +Sat Aug 16 02:50:58 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * add dependency checking in the build process + +Fri Aug 15 05:04:11 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * allow to disable sugars in generated by obus-binder + +Fri Aug 15 04:23:52 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * add support for custom array types + +Fri Aug 15 03:06:24 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * change parameters order for method call + +Fri Aug 15 02:02:24 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fix installation issues + +Fri Aug 15 01:21:13 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * more syntactic sugars + +Thu Aug 14 03:20:06 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * use quotations for pa_obus + +Thu Aug 14 02:03:15 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * allow using of proxy type when casting dynamic values + +Thu Aug 14 01:46:32 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * use dict_entry instead of dict + + this simplify the code and it allow to wrap dict_entry combinator + +Thu Aug 14 00:01:28 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * put all type informations together + +Fri Aug 8 17:40:57 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * simplify annotations + +Thu Aug 7 03:36:18 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * implementation of autolaunch + +Wed Aug 6 05:31:11 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * extend OBus_client + change the type of OBus_bus.{session,system} + + - Add a functor with every parameters fixed because this happen often + - Replace unit -> bus by lazy bus, because this avoid errors when used + with [Make_fixed*] + +Wed Aug 6 05:00:14 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * notifications binding + +Wed Aug 6 02:53:30 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * handle anonymous mechanism + +Wed Aug 6 02:53:17 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * handle tcp transport + +Wed Aug 6 00:15:03 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * various enhancement + +Wed Aug 6 00:08:29 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * clean up the build process + +Wed Aug 6 00:07:47 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * rewrite samples + +Wed Aug 6 00:07:26 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * starting of a hal binding + +Wed Aug 6 00:06:47 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * finish tools + +Wed Aug 6 00:03:15 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * simplification of annotations + + with too many convertion it is becoming confising and generating + annotations is not very usefull. + +Tue Aug 5 23:43:44 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * remove xml interfaces + + now everything is done directly in caml + +Tue Aug 5 23:43:08 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * remove all binder modules (not used any more) + +Tue Jul 29 10:56:21 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * various fixes + recode some samples with lwt + +Tue Jul 29 10:55:37 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * implementation of the binding library + record the bus module with it + +Tue Jul 29 05:43:10 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * syntax extension + +Mon Jul 28 20:02:06 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * various changes + +Mon Jul 28 19:56:57 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * lwtisation + +Sun Jul 27 18:12:57 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * finalizing combinators + +Sun Jul 27 03:56:16 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * implementation of OBus_wire + test + +Sat Jul 26 16:17:56 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * allow to wrap types maker/caster for dynamic values + +Sat Jul 26 10:51:36 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * monadic xml parser + +Fri Jul 25 10:55:07 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * add more information to annotations + + encode some caml specifics information in annotations so they can be + exported in introspections + +Thu Jul 24 14:07:12 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * implementation of annotations + pervasives combinators + +Thu Jul 24 12:03:59 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Monadic reading/writing + start of type combinators + +Tue Jul 22 23:25:45 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * encode DBus type classes in classes instead of hack with polymorphic + variant + + This avoid some assert false. + +Tue Jul 22 11:11:46 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * rewrite of the module for dynamically typed values + +Sun Jul 20 01:15:50 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * add default case to the matching class + make a matching class in the Maker functor + +Sat Jul 19 23:46:13 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * new way to deal with dynamic values + +Fri Jun 20 05:10:37 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * merge wireTypes with commonTypes + +Tue Jun 17 22:15:31 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * enhancement of Types and Values modules + +Thu Jun 12 23:19:09 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * module Path for manipulation of object path + +Thu Jun 12 21:29:22 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * remove signature field from user messages + + As this is just a function of the body it is not needed. Moreover it + avoid the creation of invalid message without have to make the type of + message private. + +Thu Jun 12 07:53:39 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * use Values.dtypes for signature in user version of messages + +Thu Jun 12 05:27:39 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * new sample, using avahi + +Thu Jun 12 03:55:27 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fixe a serialization bug + + make a arithmetic shift instead of a logical one for the last octet of integer, so we get 255 + instead of 127... + +Thu Jun 12 03:19:20 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fixe a small bug with generation of tuple pattern + + A Ast.PaTup was missing and the generated code were wrong for methods returning multiple + values. + + +Thu Jun 12 01:19:05 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * new module for message + + Message are now created as only one value of type Message.t. + +Wed Jun 11 03:12:50 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * do not add exception makers when no exception is defined + +Wed Jun 11 02:53:19 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * add _no_reply version to generated functions + +Wed Jun 11 02:05:01 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * allow on_error in generated code + async sample + + - add the optionnal on_error argument to *_async functions in generated code + - add a sample async.ml to illustrate the use of async calls + +Wed Jun 11 01:33:24 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * suppress method calls filtering in the monitor sample + + The bus always disconnect us when we try to do it and this + make the sample to crash... + +Tue Jun 10 23:12:11 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + tagged 0.1 + +Tue Jun 10 23:06:46 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * install script and README + +Tue Jun 10 20:41:17 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * comment samples and add a better examples with threads + +Tue Jun 10 20:38:56 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * correct a bug with threads + + There was a bug which let another thread than the dispatcher to + dispatch at the openning of the connection. + +Tue Jun 10 18:02:38 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * change the form of generated code + + Do not generate all readers/writers in one big module. This + generate more code but it is less confusing. + +Tue Jun 10 16:20:17 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Lot of work on the api + + - handle almost all error cases + - better Connection interface + - simplify annotations in xmls + - better thread suppport: + it is now possible to send a synchrounous message in an handler or filter + in the threaded versions. + Also unify the two version, (remove any test of the form if use_threads...) + + +Fri Jun 6 04:10:01 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * allow simplified construction of values and types + +Fri Jun 6 03:47:57 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * adapt header reading to match the specification + + we must not fail if we encounter an unknown header fields or message type. + +Fri Jun 6 01:39:06 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * remove a redundant information for reading array + +Thu Jun 5 22:53:08 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * generate safer code + +Thu Jun 5 13:33:45 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fixe order of instruction in generated code + +Wed Jun 4 21:12:44 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * cleaner rewrite of code generation + +Wed Jun 4 21:11:28 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * rewrite of the solver with dynamic rules + +Wed Jun 4 03:16:15 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * simplify some part and make the library more safe + + rewrite of the code for marshaling and unmarshaling in a more safe way. + + better handling of errors + +Sat May 31 12:46:02 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * use define_context to get things working corretly + +Sat May 31 10:19:17 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fixe a problem with thread when openning connection + +Sat May 31 08:22:33 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * implement support for signals + samples + +Sat May 31 06:10:15 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * more extensions + allow documentation in xmls + + - add extension "convert" to allow conevtion between arbitrary types + (see DBus.add_match for an example) + - allow defined type to be "external" which means that only serialization functions + will be generated + - allow documentation in the xml file and write it in the mli file + - also define a variant type for signals + +Sat May 31 00:25:49 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * remove old code + +Fri May 30 17:34:38 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * rewrite attributes parsing of xml element + errors handling + +Thu May 29 21:12:11 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * generate documentations + +Thu May 29 18:04:50 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * remove a typo in the function for writing 64bits integers + +Thu May 29 17:50:19 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * make the compilation with C stubs to work + a small benchmark + +Thu May 29 16:45:08 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * new sample : bus-functions + + a small sample to test the org.freedesktop.DBus interface + +Thu May 29 16:44:08 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * add proxy and flag annotations support + +Thu May 29 05:27:33 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * factorize generated code + +Wed May 28 18:02:27 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * remove old code + +Wed May 28 17:58:05 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * new binder tool + + - parsing of xml introspection files + - generation of readers/writers + - generation of caml modules + +Wed May 28 05:28:13 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * be sure to use the new buffer after writing message body + +Wed May 28 05:16:04 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * make every parts work together + + - adapt code generation to generate valid code, without any warnings + - correct some serializations errors + - let choose at compile if we want to use C stubs or not + (the caml version of intergers serializations is a bit slower but at least + it always work) + - remove any hand-written serialization stuff and replace with inclusion of + auto-generated files + +Sun May 25 01:51:37 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * auto-generation of functions for reading/writing general dbus values + +Sat May 24 17:07:18 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * better code for reading/writing dbus signatures + +Sat May 24 14:12:42 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * automatic generation of module for reading/writing header + +Sat May 24 12:54:33 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * add a test for the binder + +Sat May 24 12:53:54 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * various fixes/additions + +Sat May 24 12:50:34 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fixes in rules for record + + make the dependencies more general to let more complicated readers/writers to be generated. + +Sat May 24 12:47:06 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * rewrite code generation for array + + instead of unrolling the first loop, just substract a gap size before starting the loop. + +Sat May 24 12:46:19 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * do not make a difference between original Advance and ones generated by optimization when not needed + +Sat May 24 12:35:44 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * dynamic rules for inlining tuples + + before each resolution generate several rules to let all tuples to be inlined. + This let the programmer to put parentheses wherever he want in the caml type. + +Sat May 24 12:30:54 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * choose exceptions that generated code can raise + +Sat May 24 12:28:57 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * define test tag for library test + clean the _tags file + +Fri May 23 13:42:15 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * automatically add what needed when using camlp4 quotations + +Fri May 23 13:41:39 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * use an optionnal argument for the shared flag + +Fri May 23 13:39:12 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * complete generation of message writing + +Fri May 23 13:16:57 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * add a rule for writing constant + +Fri May 23 12:00:15 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * correction of types printing + +Fri May 23 11:12:54 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * essentially estheticism + +Fri May 23 11:10:45 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * helpers for caml expressions creation + +Fri May 23 11:09:52 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * constants in generated code + + Put in the same place expressions which may change in the future. + +Fri May 23 10:30:51 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * simplify types and fixes one-length tuples represententation + + - remove polymorphism for type ids because it is not used here + and it ligthen code + - hacks for tuples are removed in Generate so internal variables + are no longer used + - ensures the right invariant on types + - remove representation of dbus types as [Types.typ] because + it is only used internally by [GenSerializer] + +Fri May 23 10:29:48 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * remove tuples handling in Generate + add tracing support + +Thu May 22 14:56:04 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * various fixes + +Wed May 21 12:37:42 CEST 2008 jeremie@dimino.org + * rewrite code generation with optimization + + try do do a maximum of precalculation of padding/checking on generated code + + +Wed May 21 03:28:12 CEST 2008 jeremie@dimino.org + * choose faster byte order for sending messages + +Wed May 21 03:21:43 CEST 2008 jeremie@dimino.org + * use C stubs for marshaling integers + +Thu May 8 18:52:04 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * some fixes with cookies and threads + +Thu May 1 00:52:22 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * use weak hash tables for mapping guids to connections + +Wed Apr 30 23:17:37 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * make typ private to prevent malformed types + +Wed Apr 30 11:36:12 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * adapt caml code generation + +Wed Apr 30 11:35:21 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * share code for reading dbus signatures + +Wed Apr 30 11:32:49 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * split specifics utils functions between binder and obus + + - Common_util_* contain common utils functions + - binder and obus include it plus add some specifics utils functions + +Wed Apr 30 11:32:14 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * functions for generating a list of names + +Wed Apr 30 11:29:28 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * partial rewrite of Generate + + Make it behave correctly when generating expression for reqding/writing tuples + +Mon Apr 28 20:58:31 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * new module for correctly handle tuples + +Sat Apr 26 20:28:47 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * compile only what is working + +Sat Apr 26 20:23:17 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * move samples to subdirectories + +Sat Apr 26 20:19:39 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * make obus compiling with or without thread support + +Sat Apr 26 20:19:09 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * module for easy creation of messages + +Sat Apr 26 20:17:13 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * common code for writing signatures + +Sat Apr 26 19:42:09 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * basic samples + +Sat Apr 26 19:42:00 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * finer control of verbosity + +Sat Apr 26 19:37:57 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * syntax for writing dbus types and values + +Sat Apr 26 19:04:46 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * print dbus error messages on stderr + +Sat Apr 26 17:53:27 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * renaming of types and values + +Sat Apr 26 16:12:23 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * add also length information in received message + +Sat Apr 26 15:29:53 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * make distinction between sended message and received message + + No more problems with serials! + +Sat Apr 26 14:40:13 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * put syntax extension and filters in the same directory + +Sat Apr 26 14:35:02 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * add filter for tracing code + +Sat Apr 26 13:09:20 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * serial must not be zero + +Sat Apr 26 13:08:30 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * module Message for easy creation of messages + +Sat Apr 26 03:44:25 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * padding and other marshaling errors fixes + +Sat Apr 26 02:13:04 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fixes in reading signature + +Sat Apr 26 00:56:32 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * padding functions were wrong ! + +Fri Apr 25 23:57:52 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * a transport dumper + + Very usefull for debugging! + +Fri Apr 25 23:20:49 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * handling of guids in addresses + +Fri Apr 25 22:30:20 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fixes for compiling samples + +Fri Apr 25 19:55:47 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * add facilities for logging + +Fri Apr 25 17:06:13 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * simplify transport + +Fri Apr 25 14:40:54 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fixes in compilation + +Fri Apr 25 14:18:26 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * remove unix depency from Address + +Fri Apr 25 11:54:03 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * no more used + +Fri Apr 25 05:23:32 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * typo, types errors, ... + +Fri Apr 25 02:40:44 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * major rewriting + + Write/rewrite of most of the library and reorganization of module hierarchy + +Fri Apr 25 00:53:38 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * rewrite of type/value construction + +Thu Apr 24 18:45:38 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * module Interface for run-time handling of interfaces + +Thu Apr 24 18:44:58 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * module Cookie for async reception of messages + +Thu Apr 24 18:26:19 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * total rewrite of the connection module + +Wed Apr 23 23:08:42 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * lexers for authentification and addresses + +Wed Apr 23 16:17:33 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * final library interface + +Mon Apr 21 06:24:58 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * common interface for reading/writing signatures + +Mon Apr 21 06:22:05 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * constants + +Mon Apr 21 06:20:50 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * initial import + + module for handling receiving/sending/dispatching messages + +Mon Apr 21 04:17:56 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * transparent handling of lock + +Mon Apr 21 03:49:31 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * rewrite of marshaling module + +Mon Apr 21 03:49:01 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * cleaner interface + +Mon Apr 21 03:48:20 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * shared code for reading/writing signature + +Sun Apr 20 20:58:38 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * script for compilation + +Sun Apr 20 20:56:38 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * sample added + +Sun Apr 20 20:39:00 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * move _tags, myocamlbuild, .. to top directory + +Sun Apr 20 19:12:49 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * module for representation of an interface signature + +Sun Apr 20 19:12:17 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * interface for code generation for a language + +Sun Apr 20 19:09:20 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * first working implementation of dbus lowlevel library + +Sun Apr 20 19:06:11 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * generate working code... + +Sun Apr 20 17:29:38 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * give a name to unamed argument + +Sun Apr 20 17:29:07 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * correct handling of default value for params in xml + +Sun Apr 20 03:20:49 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * initial import + +Sun Apr 20 03:11:17 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * import initial + +Sat Apr 19 15:56:00 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * make rules definition easyier + +Sat Apr 19 13:49:41 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * factorisation + +Sat Apr 19 11:51:19 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * xml parser enhancement + +Sat Apr 19 10:29:56 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fixes in code generated + +Sat Apr 19 04:49:40 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * generation of caml code + +Sat Apr 19 03:06:50 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * fixes in caml types parsing + +Sat Apr 19 01:15:52 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * camlp4 extension for writing value of type Seq.t + +Sat Apr 19 01:14:06 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * use of module Seq + +Sat Apr 19 01:12:33 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * module for calling safely a function of arity n on a list of length n + +Fri Apr 18 22:36:23 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * typo + +Fri Apr 18 20:04:29 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Construction of herarchy of modules when loading mappings + mutiple mappings support + +Fri Apr 18 19:17:33 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * bugfixes + +Fri Apr 18 10:52:09 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * renaming Xml_parser to Xparser due to conflict with xml-light + +Fri Apr 18 09:13:02 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Update of binder for use with Lmap + +Fri Apr 18 09:10:52 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Tree deleted (no more used) + +Fri Apr 18 08:18:08 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * moving language module signature to Language + +Fri Apr 18 08:15:12 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * moving dbus interfaces to DBus and using new parsers + +Fri Apr 18 06:59:53 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * module for dealing with the mapping + +Fri Apr 18 06:59:36 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * typo + +Fri Apr 18 06:41:23 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * helpers for constructing list of arguments + +Fri Apr 18 06:40:56 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * parser for structure added + +Fri Apr 18 05:08:18 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * module for parsing xml + +Fri Apr 18 00:59:12 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * move filter_map in Util + +Fri Apr 18 00:58:24 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * generate only intermadiate xml file on the first pass + +Fri Apr 18 00:41:32 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * adding destination type to intermediate xml + +Thu Apr 17 22:23:13 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * using xml for intermediate description files + +Thu Apr 17 22:22:45 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * using existing concat + +Thu Apr 17 19:42:40 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * make interfaces tree manipulation more general + + Make it in binder instead of in caml only so it can be used for all languages + +Thu Apr 17 19:41:52 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * join/split functions for strings + +Thu Apr 17 07:04:11 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * modules for writing main programs + +Thu Apr 17 07:03:29 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * xml parsing + interface trees handling + +Thu Apr 17 07:02:59 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * utils + +Thu Apr 17 07:00:42 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Module signature generation + updating of rule definition methods + +Thu Apr 17 06:59:44 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Reusing left/right term with polymorphic variant + +Thu Apr 17 06:56:59 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Added ocamlbuild files + +Sat Apr 12 03:10:58 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Simplification + + Use of polymorphic variant for all type of term. + +Sat Apr 12 01:10:53 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Generation of caml code for writing dbus marshaled values + +Sun Apr 6 04:37:21 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * License added + +Sun Apr 6 04:33:07 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Generation of caml code for loading dbus marshaled values + +Sun Apr 6 04:32:54 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * DBus types + +Sun Apr 6 04:30:49 CEST 2008 Jeremie Dimino <jeremie@dimino.org> + * Abstract module for building convertor between two types of term @@ -0,0 +1,24 @@ +Copyright (c) 2009, Jeremie Dimino <jeremie@dimino.org> +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. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..68f2e0e --- /dev/null +++ b/Makefile @@ -0,0 +1,38 @@ +# OASIS_START +# DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb) + +SETUP = ocaml setup.ml + +build: setup.data + $(SETUP) -build $(BUILDFLAGS) + +doc: setup.data build + $(SETUP) -doc $(DOCFLAGS) + +test: setup.data build + $(SETUP) -test $(TESTFLAGS) + +all: + $(SETUP) -all $(ALLFLAGS) + +install: setup.data + $(SETUP) -install $(INSTALLFLAGS) + +uninstall: setup.data + $(SETUP) -uninstall $(UNINSTALLFLAGS) + +reinstall: setup.data + $(SETUP) -reinstall $(REINSTALLFLAGS) + +clean: + $(SETUP) -clean $(CLEANFLAGS) + +distclean: + $(SETUP) -distclean $(DISTCLEANFLAGS) + +setup.data: + $(SETUP) -configure $(CONFIGUREFLAGS) + +.PHONY: build doc test all install uninstall reinstall clean distclean configure + +# OASIS_STOP @@ -0,0 +1,88 @@ +OBus is a pure ocaml implementation of D-Bus. + +url: https://forge.ocamlcore.org/projects/obus/ + +* Requirements: + + obus depends on the following packages: + + lwt: http://www.ocsigen.org/install/lwt + type-conv: http://www.ocaml.info/home/ocaml_sources.html#type-conv + xmlm: http://erratique.ch/software/xmlm + + It also requires at least ocaml version 3.12. + +* Installation: + + To compile and install OBus just type: + + $ ocaml setup.ml -configure + $ ocaml setup.ml -build + $ ocaml setup.ml -install + + Optionally you can also build the documentation with: + + $ ocaml setup.ml -doc + + If you get the development version of obus you must obtain oasis + (http://oasis.forge.ocamlcore.org/). + +* Using the library + + OBus install the following packages: + + - obus: + the core library, implementing the D-Bus protocol, + + - 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 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 + +* Development: + + The last development version of obus can always be found in the + darcs repository hosted at darcs.ocamlcore.org: + + $ darcs get http://darcs.ocamlcore.org/repos/obus @@ -0,0 +1,446 @@ +# +-------------------------------------------------------------------+ +# | Package parameters | +# +-------------------------------------------------------------------+ + +OASISFormat: 0.3 +OCamlVersion: >= 3.12 +Name: obus +Version: 1.1.5 +LicenseFile: LICENSE +License: BSD3 +Authors: Jérémie Dimino +Homepage: http://obus.forge.ocamlcore.org/ +BuildTools:ocamlbuild +Plugins: DevFiles (0.3), META (0.3) +FilesAB: src/oBus_config.ml.ab +Synopsis: obus +Description: Pure OCaml implementation of the D-Bus protocol + +# +-------------------------------------------------------------------+ +# | The core library | +# +-------------------------------------------------------------------+ + +Library obus + Path: src + Install: true + Modules: + OBus_address, + OBus_auth, + OBus_bus, + OBus_connection, + OBus_context, + OBus_error, + OBus_info, + OBus_introspect_ext, + OBus_introspect, + OBus_match, + OBus_member, + OBus_message, + OBus_method, + OBus_name, + OBus_object, + OBus_path, + OBus_peer, + OBus_property, + OBus_proxy, + OBus_resolver, + OBus_server, + OBus_signal, + OBus_string, + OBus_transport, + OBus_uuid, + OBus_value, + OBus_wire, + OBus_interfaces + InternalModules: + OBus_address_lexer, + OBus_match_rule_lexer, + OBus_protocol, + OBus_type_ext_lexer, + OBus_util, + OBus_xml_parser, + OBus_config + BuildDepends: lwt.unix, lwt.react, lwt.syntax, lwt.syntax.log, type_conv, xmlm + XMETARequires: lwt.unix, lwt.react, xmlm + XMETADescription: Pure OCaml implementation of D-Bus + +# +-------------------------------------------------------------------+ +# | Other libraries | +# +-------------------------------------------------------------------+ + +Library "obus-idl" + Path: src + Install: true + Modules: OBus_idl + BuildDepends: obus, camlp4.lib, camlp4.quotations.o, camlp4.extend + FindlibName: idl + FindlibParent: obus + XMETADescription: Intermediate language for writing D-Bus interfaces + XMETARequires: obus, camlp4.lib + +Library "obus-syntax" + Path: syntax + Install: true + InternalModules: Pa_obus + FindlibName: syntax + FindlibParent: obus + BuildDepends: type_conv, camlp4, camlp4.quotations.o + CompiledObject: byte + XMETAType: syntax + XMETARequires: camlp4, type_conv + XMETADescription: Syntactic sugars for defining D-Bus errors + +# +-------------------------------------------------------------------+ +# | Interfaces to D-Bus services | +# +-------------------------------------------------------------------+ + +Library "obus-hal" + Path: bindings/hal + Install: true + Modules: Hal_device, Hal_manager, Hal_interfaces + BuildDepends: obus + FindlibName: hal + FindlibParent: obus + XMETADescription: Freedesktop Hal service binding + +Library "obus-notification" + Path: bindings/notification + Install: true + Modules: Notification, Notification_interfaces + BuildDepends: obus + FindlibName: notification + FindlibParent: obus + XMETADescription: Freedesktop Notification service binding + +Library "obus-network-manager" + Path: bindings/network-manager + Install: true + 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, + Nm_interfaces, + Nm_monitor + BuildDepends: obus + FindlibName: network-manager + FindlibParent: obus + XMETADescription: Freedesktop NetworkManager service binding + +Library "obus-upower" + Path: bindings/upower + Install: true + Modules: + UPower, + UPower_device, + UPower_policy, + UPower_wakeups, + UPower_interfaces, + UPower_monitor + BuildDepends: obus + FindlibName: upower + FindlibParent: obus + XMETADescription: Freedesktop UPower service binding + +Library "obus-udisks" + Path: bindings/udisks + Install: true + Modules: + UDisks, + UDisks_device, + UDisks_port, + UDisks_adapter, + UDisks_expander, + UDisks_interfaces, + UDisks_monitor + BuildDepends: obus + FindlibName: udisks + FindlibParent: obus + XMETADescription: Freedesktop UDisks service binding + +Library "obus-policykit" + Path: bindings/policykit + Install: true + Modules: Policy_kit, Policy_kit_interfaces + BuildDepends: obus + FindlibName: policykit + FindlibParent: obus + XMETADescription: Freedesktop PolicyKit service binding + +# +-------------------------------------------------------------------+ +# | Tools | +# +-------------------------------------------------------------------+ + +Executable "obus-gen-interface" + Path: tools + Install: true + CompiledObject: best + MainIs: obus_gen_interface.ml + BuildDepends: lwt.unix, lwt.react, lwt.syntax, lwt.syntax.log, type_conv, xmlm, camlp4.quotations.o, camlp4.extend, camlp4.lib + +Executable "obus-dump" + Path: tools + Install: true + CompiledObject: best + MainIs: obus_dump.ml + BuildDepends: obus + +Executable "obus-gen-client" + Path: tools + Install: true + CompiledObject: best + MainIs: obus_gen_client.ml + BuildDepends: obus, obus.idl, camlp4.lib + +Executable "obus-gen-server" + Path: tools + Install: true + CompiledObject: best + MainIs: obus_gen_server.ml + BuildDepends: obus, obus.idl, camlp4.lib + +Executable "obus-xml2idl" + Path: tools + Install: true + CompiledObject: best + MainIs: obus_xml2idl.ml + BuildDepends: obus, obus.idl, camlp4.lib + +Executable "obus-idl2xml" + Path: tools + Install: true + CompiledObject: best + MainIs: obus_idl2xml.ml + BuildDepends: obus, obus.idl, camlp4.lib + +Executable "obus-introspect" + Path: tools + Install: true + CompiledObject: best + MainIs: obus_introspect.ml + BuildDepends: obus + +# +-------------------------------------------------------------------+ +# | Man pages | +# +-------------------------------------------------------------------+ + +Document "obus-dump-man" + Type: custom (0.3) + Title: Man page for obus-dump + Install: true + BuildTools: gzip + XCustom: $gzip -c man/obus-dump.1 > man/obus-dump.1.gz + XCustomClean: $rm man/obus-dump.1.gz + DataFiles: man/obus-dump.1.gz + InstallDir: $mandir/man1 + +Document "obus-gen-interface-man" + Type: custom (0.3) + Title: Man page for obus-gen-interface + Install: true + BuildTools: gzip + XCustom: $gzip -c man/obus-gen-interface.1 > man/obus-gen-interface.1.gz + XCustomClean: $rm man/obus-gen-interface.1.gz + DataFiles: man/obus-gen-interface.1.gz + InstallDir: $mandir/man1 + +Document "obus-gen-client-man" + Type: custom (0.3) + Title: Man page for obus-gen-client + Install: true + BuildTools: gzip + XCustom: $gzip -c man/obus-gen-client.1 > man/obus-gen-client.1.gz + XCustomClean: $rm man/obus-gen-client.1.gz + DataFiles: man/obus-gen-client.1.gz + InstallDir: $mandir/man1 + +Document "obus-gen-server-man" + Type: custom (0.3) + Title: Man page for obus-gen-server + Install: true + BuildTools: gzip + XCustom: $gzip -c man/obus-gen-server.1 > man/obus-gen-server.1.gz + XCustomClean: $rm man/obus-gen-server.1.gz + DataFiles: man/obus-gen-server.1.gz + InstallDir: $mandir/man1 + +Document "obus-idl2xml-man" + Type: custom (0.3) + Title: Man page for obus-idl2xml + Install: true + BuildTools: gzip + XCustom: $gzip -c man/obus-idl2xml.1 > man/obus-idl2xml.1.gz + XCustomClean: $rm man/obus-idl2xml.1.gz + DataFiles: man/obus-idl2xml.1.gz + InstallDir: $mandir/man1 + +Document "obus-xml2idl-man" + Type: custom (0.3) + Title: Man page for obus-xml2idl + Install: true + BuildTools: gzip, rm + XCustom: $gzip -c man/obus-xml2idl.1 > man/obus-xml2idl.1.gz + XCustomClean: $rm man/obus-xml2idl.1.gz + DataFiles: man/obus-xml2idl.1.gz + InstallDir: $mandir/man1 + +Document "obus-introspect-man" + Type: custom (0.3) + Title: Man page for obus-introspect + Install: true + BuildTools: gzip, rm + XCustom: $gzip -c man/obus-introspect.1 > man/obus-introspect.1.gz + XCustomClean: $rm man/obus-introspect.1.gz + DataFiles: man/obus-introspect.1.gz + InstallDir: $mandir/man1 + +# +-------------------------------------------------------------------+ +# | Doc | +# +-------------------------------------------------------------------+ + +Document "obus-manual" + Title: OBus user manual + Type: custom (0.3) + Install: true + XCustom: make -C manual manual.pdf + DataFiles: manual/manual.pdf + InstallDir: $pdfdir + +Document "obus-api" + Title: API reference for OBus + Type: ocamlbuild (0.3) + Install: true + InstallDir: $htmldir/api + DataFiles: utils/doc/style.css + BuildTools: ocamldoc + XOCamlbuildPath: ./ + XOCamlbuildLibraries: + obus, + obus.hal, + obus.idl, + obus.network-manager, + obus.notification, + obus.policykit, + obus.udisks, + obus.upower + +# +-------------------------------------------------------------------+ +# | Tests | +# +-------------------------------------------------------------------+ + +Executable tests_exec + Path: tests + Install: false + Build$: flag(tests) + CompiledObject: best + MainIs: main.ml + BuildDepends: obus + +Test main + Command: $tests_exec + TestTools: tests_exec + +# +-------------------------------------------------------------------+ +# | Examples | +# +-------------------------------------------------------------------+ + +Document examples + Title: Examples + Type: custom (0.3) + Install: true + XCustom: true + DataFiles: examples/*.ml, examples/*.xml + InstallDir: $docdir/examples + +Executable "bus-functions" + Path: examples + Install: false + CompiledObject: best + MainIs: bus_functions.ml + BuildDepends: obus, lwt.syntax + +Executable eject + Path: examples + Install: false + CompiledObject: best + MainIs: eject.ml + BuildDepends: obus, lwt.syntax, obus.hal + +Executable hello + Path: examples + Install: false + CompiledObject: best + MainIs: hello.ml + BuildDepends: obus, lwt.syntax + +Executable "list-services" + Path: examples + Install: false + CompiledObject: best + MainIs: list_services.ml + BuildDepends: obus, lwt.syntax + +Executable monitor + Path: examples + Install: false + CompiledObject: best + MainIs: monitor.ml + BuildDepends: obus, lwt.syntax + +Executable notify + Path: examples + Install: false + CompiledObject: best + MainIs: notify.ml + BuildDepends: obus, lwt.syntax, obus.notification + +Executable ping + Path: examples + Install: false + CompiledObject: best + MainIs: ping.ml + BuildDepends: obus, lwt.syntax + +Executable pong + Path: examples + Install: false + CompiledObject: best + MainIs: pong.ml + BuildDepends: obus, lwt.syntax + +Executable signals + Path: examples + Install: false + CompiledObject: best + MainIs: signals.ml + BuildDepends: obus, lwt.syntax, obus.hal + +Executable "network-manager" + Path: examples + Install: false + CompiledObject: best + MainIs: network_manager.ml + BuildDepends: obus, lwt.syntax, obus.network-manager + +Executable "battery-monitoring" + Path: examples + Install: false + CompiledObject: best + MainIs: battery_monitoring.ml + BuildDepends: obus, lwt.syntax, obus.upower + +# +-------------------------------------------------------------------+ +# | Misc | +# +-------------------------------------------------------------------+ + +SourceRepository head + Type: darcs + Location: http://darcs.ocamlcore.org/repos/obus + Browser: http://darcs.ocamlcore.org/cgi-bin/darcsweb.cgi?r=obus;a=summary @@ -0,0 +1,299 @@ +# -*- conf -*- + +<**/*.ml>: syntax_camlp4o +<**/*.ml>: pa_obus +<syntax/*.ml>: -pa_obus + +# OASIS_START +# DO NOT EDIT (digest: 76acfb0d7012714187c715526071076d) +# Ignore VCS directories, you can use the same kind of rule outside +# OASIS_START/STOP if you want to exclude directories that contains +# useless stuff for the build process +<**/.svn>: -traverse +<**/.svn>: not_hygienic +".bzr": -traverse +".bzr": not_hygienic +".hg": -traverse +".hg": not_hygienic +".git": -traverse +".git": not_hygienic +"_darcs": -traverse +"_darcs": not_hygienic +# Library obus +"src/obus.cmxs": use_obus +# Library obus-idl +"src/obus-idl.cmxs": use_obus-idl +<src/*.ml{,i}>: use_obus +<src/*.ml{,i}>: pkg_lwt.syntax +<src/*.ml{,i}>: pkg_camlp4.lib +<src/*.ml{,i}>: pkg_lwt.unix +<src/*.ml{,i}>: pkg_lwt.react +<src/*.ml{,i}>: pkg_lwt.syntax.log +<src/*.ml{,i}>: pkg_type_conv +<src/*.ml{,i}>: pkg_xmlm +<src/*.ml{,i}>: pkg_camlp4.quotations.o +<src/*.ml{,i}>: pkg_camlp4.extend +# Library obus-syntax +"syntax/obus-syntax.cmxs": use_obus-syntax +<syntax/*.ml{,i}>: pkg_type_conv +<syntax/*.ml{,i}>: pkg_camlp4.quotations.o +<syntax/*.ml{,i}>: pkg_camlp4 +# Library obus-hal +"bindings/hal/obus-hal.cmxs": use_obus-hal +<bindings/hal/*.ml{,i}>: use_obus +<bindings/hal/*.ml{,i}>: pkg_lwt.syntax +<bindings/hal/*.ml{,i}>: pkg_lwt.unix +<bindings/hal/*.ml{,i}>: pkg_lwt.react +<bindings/hal/*.ml{,i}>: pkg_lwt.syntax.log +<bindings/hal/*.ml{,i}>: pkg_type_conv +<bindings/hal/*.ml{,i}>: pkg_xmlm +# Library obus-notification +"bindings/notification/obus-notification.cmxs": use_obus-notification +<bindings/notification/*.ml{,i}>: use_obus +<bindings/notification/*.ml{,i}>: pkg_lwt.syntax +<bindings/notification/*.ml{,i}>: pkg_lwt.unix +<bindings/notification/*.ml{,i}>: pkg_lwt.react +<bindings/notification/*.ml{,i}>: pkg_lwt.syntax.log +<bindings/notification/*.ml{,i}>: pkg_type_conv +<bindings/notification/*.ml{,i}>: pkg_xmlm +# Library obus-network-manager +"bindings/network-manager/obus-network-manager.cmxs": use_obus-network-manager +<bindings/network-manager/*.ml{,i}>: use_obus +<bindings/network-manager/*.ml{,i}>: pkg_lwt.syntax +<bindings/network-manager/*.ml{,i}>: pkg_lwt.unix +<bindings/network-manager/*.ml{,i}>: pkg_lwt.react +<bindings/network-manager/*.ml{,i}>: pkg_lwt.syntax.log +<bindings/network-manager/*.ml{,i}>: pkg_type_conv +<bindings/network-manager/*.ml{,i}>: pkg_xmlm +# Library obus-upower +"bindings/upower/obus-upower.cmxs": use_obus-upower +<bindings/upower/*.ml{,i}>: use_obus +<bindings/upower/*.ml{,i}>: pkg_lwt.syntax +<bindings/upower/*.ml{,i}>: pkg_lwt.unix +<bindings/upower/*.ml{,i}>: pkg_lwt.react +<bindings/upower/*.ml{,i}>: pkg_lwt.syntax.log +<bindings/upower/*.ml{,i}>: pkg_type_conv +<bindings/upower/*.ml{,i}>: pkg_xmlm +# Library obus-udisks +"bindings/udisks/obus-udisks.cmxs": use_obus-udisks +<bindings/udisks/*.ml{,i}>: use_obus +<bindings/udisks/*.ml{,i}>: pkg_lwt.syntax +<bindings/udisks/*.ml{,i}>: pkg_lwt.unix +<bindings/udisks/*.ml{,i}>: pkg_lwt.react +<bindings/udisks/*.ml{,i}>: pkg_lwt.syntax.log +<bindings/udisks/*.ml{,i}>: pkg_type_conv +<bindings/udisks/*.ml{,i}>: pkg_xmlm +# Library obus-policykit +"bindings/policykit/obus-policykit.cmxs": use_obus-policykit +<bindings/policykit/*.ml{,i}>: use_obus +<bindings/policykit/*.ml{,i}>: pkg_lwt.syntax +<bindings/policykit/*.ml{,i}>: pkg_lwt.unix +<bindings/policykit/*.ml{,i}>: pkg_lwt.react +<bindings/policykit/*.ml{,i}>: pkg_lwt.syntax.log +<bindings/policykit/*.ml{,i}>: pkg_type_conv +<bindings/policykit/*.ml{,i}>: pkg_xmlm +# Executable obus-gen-interface +<tools/obus_gen_interface.{native,byte}>: pkg_lwt.syntax +<tools/obus_gen_interface.{native,byte}>: pkg_camlp4.lib +<tools/obus_gen_interface.{native,byte}>: pkg_lwt.unix +<tools/obus_gen_interface.{native,byte}>: pkg_lwt.react +<tools/obus_gen_interface.{native,byte}>: pkg_lwt.syntax.log +<tools/obus_gen_interface.{native,byte}>: pkg_type_conv +<tools/obus_gen_interface.{native,byte}>: pkg_xmlm +<tools/obus_gen_interface.{native,byte}>: pkg_camlp4.quotations.o +<tools/obus_gen_interface.{native,byte}>: pkg_camlp4.extend +# Executable obus-dump +<tools/obus_dump.{native,byte}>: use_obus +<tools/obus_dump.{native,byte}>: pkg_lwt.syntax +<tools/obus_dump.{native,byte}>: pkg_lwt.unix +<tools/obus_dump.{native,byte}>: pkg_lwt.react +<tools/obus_dump.{native,byte}>: pkg_lwt.syntax.log +<tools/obus_dump.{native,byte}>: pkg_type_conv +<tools/obus_dump.{native,byte}>: pkg_xmlm +# Executable obus-gen-client +<tools/obus_gen_client.{native,byte}>: use_obus-idl +<tools/obus_gen_client.{native,byte}>: use_obus +<tools/obus_gen_client.{native,byte}>: pkg_lwt.syntax +<tools/obus_gen_client.{native,byte}>: pkg_camlp4.lib +<tools/obus_gen_client.{native,byte}>: pkg_lwt.unix +<tools/obus_gen_client.{native,byte}>: pkg_lwt.react +<tools/obus_gen_client.{native,byte}>: pkg_lwt.syntax.log +<tools/obus_gen_client.{native,byte}>: pkg_type_conv +<tools/obus_gen_client.{native,byte}>: pkg_xmlm +<tools/obus_gen_client.{native,byte}>: pkg_camlp4.quotations.o +<tools/obus_gen_client.{native,byte}>: pkg_camlp4.extend +# Executable obus-gen-server +<tools/obus_gen_server.{native,byte}>: use_obus-idl +<tools/obus_gen_server.{native,byte}>: use_obus +<tools/obus_gen_server.{native,byte}>: pkg_lwt.syntax +<tools/obus_gen_server.{native,byte}>: pkg_camlp4.lib +<tools/obus_gen_server.{native,byte}>: pkg_lwt.unix +<tools/obus_gen_server.{native,byte}>: pkg_lwt.react +<tools/obus_gen_server.{native,byte}>: pkg_lwt.syntax.log +<tools/obus_gen_server.{native,byte}>: pkg_type_conv +<tools/obus_gen_server.{native,byte}>: pkg_xmlm +<tools/obus_gen_server.{native,byte}>: pkg_camlp4.quotations.o +<tools/obus_gen_server.{native,byte}>: pkg_camlp4.extend +# Executable obus-xml2idl +<tools/obus_xml2idl.{native,byte}>: use_obus-idl +<tools/obus_xml2idl.{native,byte}>: use_obus +<tools/obus_xml2idl.{native,byte}>: pkg_lwt.syntax +<tools/obus_xml2idl.{native,byte}>: pkg_camlp4.lib +<tools/obus_xml2idl.{native,byte}>: pkg_lwt.unix +<tools/obus_xml2idl.{native,byte}>: pkg_lwt.react +<tools/obus_xml2idl.{native,byte}>: pkg_lwt.syntax.log +<tools/obus_xml2idl.{native,byte}>: pkg_type_conv +<tools/obus_xml2idl.{native,byte}>: pkg_xmlm +<tools/obus_xml2idl.{native,byte}>: pkg_camlp4.quotations.o +<tools/obus_xml2idl.{native,byte}>: pkg_camlp4.extend +# Executable obus-idl2xml +<tools/obus_idl2xml.{native,byte}>: use_obus-idl +<tools/obus_idl2xml.{native,byte}>: use_obus +<tools/obus_idl2xml.{native,byte}>: pkg_lwt.syntax +<tools/obus_idl2xml.{native,byte}>: pkg_camlp4.lib +<tools/obus_idl2xml.{native,byte}>: pkg_lwt.unix +<tools/obus_idl2xml.{native,byte}>: pkg_lwt.react +<tools/obus_idl2xml.{native,byte}>: pkg_lwt.syntax.log +<tools/obus_idl2xml.{native,byte}>: pkg_type_conv +<tools/obus_idl2xml.{native,byte}>: pkg_xmlm +<tools/obus_idl2xml.{native,byte}>: pkg_camlp4.quotations.o +<tools/obus_idl2xml.{native,byte}>: pkg_camlp4.extend +<tools/*.ml{,i}>: use_obus-idl +<tools/*.ml{,i}>: pkg_camlp4.lib +<tools/*.ml{,i}>: pkg_camlp4.quotations.o +<tools/*.ml{,i}>: pkg_camlp4.extend +# Executable obus-introspect +<tools/obus_introspect.{native,byte}>: use_obus +<tools/obus_introspect.{native,byte}>: pkg_lwt.syntax +<tools/obus_introspect.{native,byte}>: pkg_lwt.unix +<tools/obus_introspect.{native,byte}>: pkg_lwt.react +<tools/obus_introspect.{native,byte}>: pkg_lwt.syntax.log +<tools/obus_introspect.{native,byte}>: pkg_type_conv +<tools/obus_introspect.{native,byte}>: pkg_xmlm +<tools/*.ml{,i}>: use_obus +<tools/*.ml{,i}>: pkg_lwt.syntax +<tools/*.ml{,i}>: pkg_lwt.unix +<tools/*.ml{,i}>: pkg_lwt.react +<tools/*.ml{,i}>: pkg_lwt.syntax.log +<tools/*.ml{,i}>: pkg_type_conv +<tools/*.ml{,i}>: pkg_xmlm +# Executable tests_exec +<tests/main.{native,byte}>: use_obus +<tests/main.{native,byte}>: pkg_lwt.syntax +<tests/main.{native,byte}>: pkg_lwt.unix +<tests/main.{native,byte}>: pkg_lwt.react +<tests/main.{native,byte}>: pkg_lwt.syntax.log +<tests/main.{native,byte}>: pkg_type_conv +<tests/main.{native,byte}>: pkg_xmlm +<tests/*.ml{,i}>: use_obus +<tests/*.ml{,i}>: pkg_lwt.syntax +<tests/*.ml{,i}>: pkg_lwt.unix +<tests/*.ml{,i}>: pkg_lwt.react +<tests/*.ml{,i}>: pkg_lwt.syntax.log +<tests/*.ml{,i}>: pkg_type_conv +<tests/*.ml{,i}>: pkg_xmlm +# Executable bus-functions +<examples/bus_functions.{native,byte}>: use_obus +<examples/bus_functions.{native,byte}>: pkg_lwt.syntax +<examples/bus_functions.{native,byte}>: pkg_lwt.unix +<examples/bus_functions.{native,byte}>: pkg_lwt.react +<examples/bus_functions.{native,byte}>: pkg_lwt.syntax.log +<examples/bus_functions.{native,byte}>: pkg_type_conv +<examples/bus_functions.{native,byte}>: pkg_xmlm +# Executable eject +<examples/eject.{native,byte}>: use_obus-hal +<examples/eject.{native,byte}>: use_obus +<examples/eject.{native,byte}>: pkg_lwt.syntax +<examples/eject.{native,byte}>: pkg_lwt.unix +<examples/eject.{native,byte}>: pkg_lwt.react +<examples/eject.{native,byte}>: pkg_lwt.syntax.log +<examples/eject.{native,byte}>: pkg_type_conv +<examples/eject.{native,byte}>: pkg_xmlm +# Executable hello +<examples/hello.{native,byte}>: use_obus +<examples/hello.{native,byte}>: pkg_lwt.syntax +<examples/hello.{native,byte}>: pkg_lwt.unix +<examples/hello.{native,byte}>: pkg_lwt.react +<examples/hello.{native,byte}>: pkg_lwt.syntax.log +<examples/hello.{native,byte}>: pkg_type_conv +<examples/hello.{native,byte}>: pkg_xmlm +# Executable list-services +<examples/list_services.{native,byte}>: use_obus +<examples/list_services.{native,byte}>: pkg_lwt.syntax +<examples/list_services.{native,byte}>: pkg_lwt.unix +<examples/list_services.{native,byte}>: pkg_lwt.react +<examples/list_services.{native,byte}>: pkg_lwt.syntax.log +<examples/list_services.{native,byte}>: pkg_type_conv +<examples/list_services.{native,byte}>: pkg_xmlm +# Executable monitor +<examples/monitor.{native,byte}>: use_obus +<examples/monitor.{native,byte}>: pkg_lwt.syntax +<examples/monitor.{native,byte}>: pkg_lwt.unix +<examples/monitor.{native,byte}>: pkg_lwt.react +<examples/monitor.{native,byte}>: pkg_lwt.syntax.log +<examples/monitor.{native,byte}>: pkg_type_conv +<examples/monitor.{native,byte}>: pkg_xmlm +# Executable notify +<examples/notify.{native,byte}>: use_obus-notification +<examples/notify.{native,byte}>: use_obus +<examples/notify.{native,byte}>: pkg_lwt.syntax +<examples/notify.{native,byte}>: pkg_lwt.unix +<examples/notify.{native,byte}>: pkg_lwt.react +<examples/notify.{native,byte}>: pkg_lwt.syntax.log +<examples/notify.{native,byte}>: pkg_type_conv +<examples/notify.{native,byte}>: pkg_xmlm +<examples/*.ml{,i}>: use_obus-notification +# Executable ping +<examples/ping.{native,byte}>: use_obus +<examples/ping.{native,byte}>: pkg_lwt.syntax +<examples/ping.{native,byte}>: pkg_lwt.unix +<examples/ping.{native,byte}>: pkg_lwt.react +<examples/ping.{native,byte}>: pkg_lwt.syntax.log +<examples/ping.{native,byte}>: pkg_type_conv +<examples/ping.{native,byte}>: pkg_xmlm +# Executable pong +<examples/pong.{native,byte}>: use_obus +<examples/pong.{native,byte}>: pkg_lwt.syntax +<examples/pong.{native,byte}>: pkg_lwt.unix +<examples/pong.{native,byte}>: pkg_lwt.react +<examples/pong.{native,byte}>: pkg_lwt.syntax.log +<examples/pong.{native,byte}>: pkg_type_conv +<examples/pong.{native,byte}>: pkg_xmlm +# Executable signals +<examples/signals.{native,byte}>: use_obus-hal +<examples/signals.{native,byte}>: use_obus +<examples/signals.{native,byte}>: pkg_lwt.syntax +<examples/signals.{native,byte}>: pkg_lwt.unix +<examples/signals.{native,byte}>: pkg_lwt.react +<examples/signals.{native,byte}>: pkg_lwt.syntax.log +<examples/signals.{native,byte}>: pkg_type_conv +<examples/signals.{native,byte}>: pkg_xmlm +<examples/*.ml{,i}>: use_obus-hal +# Executable network-manager +<examples/network_manager.{native,byte}>: use_obus-network-manager +<examples/network_manager.{native,byte}>: use_obus +<examples/network_manager.{native,byte}>: pkg_lwt.syntax +<examples/network_manager.{native,byte}>: pkg_lwt.unix +<examples/network_manager.{native,byte}>: pkg_lwt.react +<examples/network_manager.{native,byte}>: pkg_lwt.syntax.log +<examples/network_manager.{native,byte}>: pkg_type_conv +<examples/network_manager.{native,byte}>: pkg_xmlm +<examples/*.ml{,i}>: use_obus-network-manager +# Executable battery-monitoring +<examples/battery_monitoring.{native,byte}>: use_obus-upower +<examples/battery_monitoring.{native,byte}>: use_obus +<examples/battery_monitoring.{native,byte}>: pkg_lwt.syntax +<examples/battery_monitoring.{native,byte}>: pkg_lwt.unix +<examples/battery_monitoring.{native,byte}>: pkg_lwt.react +<examples/battery_monitoring.{native,byte}>: pkg_lwt.syntax.log +<examples/battery_monitoring.{native,byte}>: pkg_type_conv +<examples/battery_monitoring.{native,byte}>: pkg_xmlm +<examples/*.ml{,i}>: use_obus-upower +<examples/*.ml{,i}>: use_obus +<examples/*.ml{,i}>: pkg_lwt.syntax +<examples/*.ml{,i}>: pkg_lwt.unix +<examples/*.ml{,i}>: pkg_lwt.react +<examples/*.ml{,i}>: pkg_lwt.syntax.log +<examples/*.ml{,i}>: pkg_type_conv +<examples/*.ml{,i}>: pkg_xmlm +# OASIS_STOP diff --git a/apiref-intro b/apiref-intro new file mode 100644 index 0000000..9bde14d --- /dev/null +++ b/apiref-intro @@ -0,0 +1,133 @@ +{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} diff --git a/bindings/hal/hal.mllib b/bindings/hal/hal.mllib new file mode 100644 index 0000000..b3b09ab --- /dev/null +++ b/bindings/hal/hal.mllib @@ -0,0 +1,3 @@ +Hal_device +Hal_manager +Hal_interfaces diff --git a/bindings/hal/hal_device.ml b/bindings/hal/hal_device.ml new file mode 100644 index 0000000..e755efa --- /dev/null +++ b/bindings/hal/hal_device.ml @@ -0,0 +1,337 @@ +(* + * hal_device.ml + * ------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * 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 () = + 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 = + 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 = + 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 = + 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 = + 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 = + 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 = + 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 = + 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 = + 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 = + 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 = + 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 = + 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 + 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 + 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 = + 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 = + 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 = + 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 = + 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 = + 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 + 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 = + 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 = + 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 = + lwt value = OBus_method.call m_GetPower proxy () in + let value = Int32.to_int value in + return value +end diff --git a/bindings/hal/hal_device.mli b/bindings/hal/hal_device.mli new file mode 100644 index 0000000..b02a382 --- /dev/null +++ b/bindings/hal/hal_device.mli @@ -0,0 +1,135 @@ +(* + * hal_device.mli + * -------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/hal/hal_interfaces.obus b/bindings/hal/hal_interfaces.obus new file mode 100644 index 0000000..7a8198c --- /dev/null +++ b/bindings/hal/hal_interfaces.obus @@ -0,0 +1,128 @@ +(* + * hal_interfaces.obus + * ------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +interface org.freedesktop.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) +} diff --git a/bindings/hal/hal_manager.ml b/bindings/hal/hal_manager.ml new file mode 100644 index 0000000..6e540d1 --- /dev/null +++ b/bindings/hal/hal_manager.ml @@ -0,0 +1,98 @@ +(* + * hal_manager.ml + * -------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * 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 () = + 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 = + 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 = + 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 = + 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 = + lwt context, l = OBus_method.call_with_context m_FindDeviceByCapability proxy capability in + return (List.map (make_device context) l) + +let new_device proxy = + 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) diff --git a/bindings/hal/hal_manager.mli b/bindings/hal/hal_manager.mli new file mode 100644 index 0000000..b49d04d --- /dev/null +++ b/bindings/hal/hal_manager.mli @@ -0,0 +1,33 @@ +(* + * hal_manager.mli + * --------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/hal/obus-hal.mllib b/bindings/hal/obus-hal.mllib new file mode 100644 index 0000000..a8d6d9a --- /dev/null +++ b/bindings/hal/obus-hal.mllib @@ -0,0 +1,6 @@ +# OASIS_START +# DO NOT EDIT (digest: 2940737783a89f577688fc8363e8f8d0) +Hal_device +Hal_manager +Hal_interfaces +# OASIS_STOP diff --git a/bindings/network-manager/network-manager.mllib b/bindings/network-manager/network-manager.mllib new file mode 100644 index 0000000..e3a48d4 --- /dev/null +++ b/bindings/network-manager/network-manager.mllib @@ -0,0 +1,12 @@ +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 +Nm_interfaces diff --git a/bindings/network-manager/nm_access_point.ml b/bindings/network-manager/nm_access_point.ml new file mode 100644 index 0000000..85ca05d --- /dev/null +++ b/bindings/network-manager/nm_access_point.ml @@ -0,0 +1,95 @@ +(* + * nm_access_point.ml + * ------------------ + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_access_point.mli b/bindings/network-manager/nm_access_point.mli new file mode 100644 index 0000000..320c9cf --- /dev/null +++ b/bindings/network-manager/nm_access_point.mli @@ -0,0 +1,59 @@ +(* + * nm_access_point.mli + * ------------------- + * Copyright : (c) 2010, Pierre Chambart <chambart@crans.org> + * 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_connection.ml b/bindings/network-manager/nm_connection.ml new file mode 100644 index 0000000..dc23ea1 --- /dev/null +++ b/bindings/network-manager/nm_connection.ml @@ -0,0 +1,67 @@ +(* + * nm_connection.ml + * ---------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_connection.mli b/bindings/network-manager/nm_connection.mli new file mode 100644 index 0000000..fd3bce8 --- /dev/null +++ b/bindings/network-manager/nm_connection.mli @@ -0,0 +1,40 @@ +(* + * nm_connection.mli + * ----------------- + * Copyright : (c) 2010, Pierre Chambart <chambart@crans.org> + * 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_device.ml b/bindings/network-manager/nm_device.ml new file mode 100644 index 0000000..f5f4caf --- /dev/null +++ b/bindings/network-manager/nm_device.ml @@ -0,0 +1,389 @@ +(* + * nm_device.ml + * ------------ + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 = + 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 diff --git a/bindings/network-manager/nm_device.mli b/bindings/network-manager/nm_device.mli new file mode 100644 index 0000000..dd78035 --- /dev/null +++ b/bindings/network-manager/nm_device.mli @@ -0,0 +1,251 @@ +(* + * nm_device.mli + * ------------- + * Copyright : (c) 2010, Pierre Chambart <chambart@crans.org> + * 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_dhcp4_config.ml b/bindings/network-manager/nm_dhcp4_config.ml new file mode 100644 index 0000000..757fc4a --- /dev/null +++ b/bindings/network-manager/nm_dhcp4_config.ml @@ -0,0 +1,16 @@ +(* + * nm_dhcp4_config.ml + * ------------------ + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_dhcp4_config.mli b/bindings/network-manager/nm_dhcp4_config.mli new file mode 100644 index 0000000..6919383 --- /dev/null +++ b/bindings/network-manager/nm_dhcp4_config.mli @@ -0,0 +1,15 @@ +(* + * nm_dhcp4_config.mli + * ------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_interfaces.obus b/bindings/network-manager/nm_interfaces.obus new file mode 100644 index 0000000..ccbd6ec --- /dev/null +++ b/bindings/network-manager/nm_interfaces.obus @@ -0,0 +1,183 @@ +(* + * nm_interfaces.obus + * ------------------ + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +interface org.freedesktop.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) +} diff --git a/bindings/network-manager/nm_ip4_config.ml b/bindings/network-manager/nm_ip4_config.ml new file mode 100644 index 0000000..d6dd30d --- /dev/null +++ b/bindings/network-manager/nm_ip4_config.ml @@ -0,0 +1,36 @@ +(* + * nm_ip4_config.ml + * ---------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_ip4_config.mli b/bindings/network-manager/nm_ip4_config.mli new file mode 100644 index 0000000..26bbd6d --- /dev/null +++ b/bindings/network-manager/nm_ip4_config.mli @@ -0,0 +1,20 @@ +(* + * nm_ip4_config.mli + * ----------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_ip6_config.ml b/bindings/network-manager/nm_ip6_config.ml new file mode 100644 index 0000000..d2ccf11 --- /dev/null +++ b/bindings/network-manager/nm_ip6_config.ml @@ -0,0 +1,29 @@ +(* + * nm_ip6_config.ml + * ---------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_ip6_config.mli b/bindings/network-manager/nm_ip6_config.mli new file mode 100644 index 0000000..2238880 --- /dev/null +++ b/bindings/network-manager/nm_ip6_config.mli @@ -0,0 +1,19 @@ +(* + * nm_ip6_config.mli + * ----------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_manager.ml b/bindings/network-manager/nm_manager.ml new file mode 100644 index 0000000..447c2c7 --- /dev/null +++ b/bindings/network-manager/nm_manager.ml @@ -0,0 +1,128 @@ +(* + * nm_manager.ml + * ------------- + * Copyright : (c) 2010, Pierre Chambart <chambart@crans.org> + * 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 () = + 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 = + 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 + 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 diff --git a/bindings/network-manager/nm_manager.mli b/bindings/network-manager/nm_manager.mli new file mode 100644 index 0000000..1c72201 --- /dev/null +++ b/bindings/network-manager/nm_manager.mli @@ -0,0 +1,62 @@ +(* + * nm_manager.mli + * -------------- + * Copyright : (c) 2010, Pierre Chambart <chambart@crans.org> + * 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_monitor.ml b/bindings/network-manager/nm_monitor.ml new file mode 100644 index 0000000..40912f0 --- /dev/null +++ b/bindings/network-manager/nm_monitor.ml @@ -0,0 +1,33 @@ +(* + * nm_monitor.ml + * ------------- + * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org> + * 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 = + 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) diff --git a/bindings/network-manager/nm_monitor.mli b/bindings/network-manager/nm_monitor.mli new file mode 100644 index 0000000..4fef481 --- /dev/null +++ b/bindings/network-manager/nm_monitor.mli @@ -0,0 +1,13 @@ +(* + * nm_monitor.mli + * -------------- + * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org> + * 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. *) diff --git a/bindings/network-manager/nm_ppp.ml b/bindings/network-manager/nm_ppp.ml new file mode 100644 index 0000000..45b3c8a --- /dev/null +++ b/bindings/network-manager/nm_ppp.ml @@ -0,0 +1,20 @@ +(* + * nm_ppp.ml + * --------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_ppp.mli b/bindings/network-manager/nm_ppp.mli new file mode 100644 index 0000000..90ada8c --- /dev/null +++ b/bindings/network-manager/nm_ppp.mli @@ -0,0 +1,16 @@ +(* + * nm_ppp.mli + * ---------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_settings.ml b/bindings/network-manager/nm_settings.ml new file mode 100644 index 0000000..6edd9f2 --- /dev/null +++ b/bindings/network-manager/nm_settings.ml @@ -0,0 +1,98 @@ +(* + * nm_settings.ml + * -------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + *) + +open Lwt + +include OBus_proxy.Private + +open Nm_interfaces.Org_freedesktop_NetworkManagerSettings + +let user () = + lwt bus = OBus_bus.session () in + return (OBus_proxy.make + (OBus_peer.make bus "org.freedesktop.NetworkManagerUserSettings") + [ "org"; "freedesktop"; "NetworkManagerSettings" ]) + +let system () = + 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 = + lwt permissions = OBus_method.call m_GetPermissions proxy () in + let permissions = Int32.to_int permissions in + return permissions +end + +let list_connections proxy = + 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) diff --git a/bindings/network-manager/nm_settings.mli b/bindings/network-manager/nm_settings.mli new file mode 100644 index 0000000..acd3409 --- /dev/null +++ b/bindings/network-manager/nm_settings.mli @@ -0,0 +1,60 @@ +(* + * nm_settings.mli + * --------------- + * Copyright : (c) 2010, Pierre Chambart <chambart@crans.org> + * 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_vpn_connection.ml b/bindings/network-manager/nm_vpn_connection.ml new file mode 100644 index 0000000..aa41cd7 --- /dev/null +++ b/bindings/network-manager/nm_vpn_connection.ml @@ -0,0 +1,32 @@ +(* + * nm_vpn_connection.ml + * -------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_vpn_connection.mli b/bindings/network-manager/nm_vpn_connection.mli new file mode 100644 index 0000000..0104606 --- /dev/null +++ b/bindings/network-manager/nm_vpn_connection.mli @@ -0,0 +1,20 @@ +(* + * nm_vpn_connection.mli + * --------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/nm_vpn_plugin.ml b/bindings/network-manager/nm_vpn_plugin.ml new file mode 100644 index 0000000..8738593 --- /dev/null +++ b/bindings/network-manager/nm_vpn_plugin.ml @@ -0,0 +1,50 @@ +(* + * nm_vpn_plugin.ml + * ---------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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) diff --git a/bindings/network-manager/nm_vpn_plugin.mli b/bindings/network-manager/nm_vpn_plugin.mli new file mode 100644 index 0000000..8dee401 --- /dev/null +++ b/bindings/network-manager/nm_vpn_plugin.mli @@ -0,0 +1,25 @@ +(* + * nm_vpn_plugin.mli + * ----------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/network-manager/obus-network-manager.mllib b/bindings/network-manager/obus-network-manager.mllib new file mode 100644 index 0000000..f5e96be --- /dev/null +++ b/bindings/network-manager/obus-network-manager.mllib @@ -0,0 +1,16 @@ +# OASIS_START +# DO NOT EDIT (digest: 123fc1eb65ccd078e1fd365494511235) +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 +Nm_interfaces +Nm_monitor +# OASIS_STOP diff --git a/bindings/notification/notification.ml b/bindings/notification/notification.ml new file mode 100644 index 0000000..30f22b4 --- /dev/null +++ b/bindings/notification/notification.ml @@ -0,0 +1,345 @@ +(* + * notification.ml + * --------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Lwt_react +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( + lwt bus = OBus_bus.session () in + return (OBus_proxy.make (OBus_peer.make bus server_name) server_path) +) + +let get_server_information () = + lwt proxy = Lazy.force proxy in + 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 () = + lwt proxy = Lazy.force proxy in + OBus_method.call m_GetCapabilities proxy () + +let notify proxy ~app_name ~id ~icon ~summary ~body ~actions ~hints ~timeout = + 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 + 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( + 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 + + 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); + + 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 *) + lwt () = Lazy.force init_callbacks in + + (* Get the proxy *) + lwt daemon = Lazy.force proxy in + + (* Create the notification *) + 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; + } diff --git a/bindings/notification/notification.mli b/bindings/notification/notification.mli new file mode 100644 index 0000000..0d59a35 --- /dev/null +++ b/bindings/notification/notification.mli @@ -0,0 +1,117 @@ +(* + * notification.mli + * ---------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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 *) diff --git a/bindings/notification/notification.mllib b/bindings/notification/notification.mllib new file mode 100644 index 0000000..6b8be58 --- /dev/null +++ b/bindings/notification/notification.mllib @@ -0,0 +1,2 @@ +Notification +Notification_interfaces diff --git a/bindings/notification/notification_interfaces.obus b/bindings/notification/notification_interfaces.obus new file mode 100644 index 0000000..523ac0c --- /dev/null +++ b/bindings/notification/notification_interfaces.obus @@ -0,0 +1,15 @@ +(* + * notification_interfaces.obus + * ---------------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +interface org.freedesktop.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) +} diff --git a/bindings/notification/obus-notification.mllib b/bindings/notification/obus-notification.mllib new file mode 100644 index 0000000..9552e75 --- /dev/null +++ b/bindings/notification/obus-notification.mllib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: 3217eb32d568f53015d6b5dfc673048f) +Notification +Notification_interfaces +# OASIS_STOP diff --git a/bindings/policykit/obus-policykit.mllib b/bindings/policykit/obus-policykit.mllib new file mode 100644 index 0000000..ceffa31 --- /dev/null +++ b/bindings/policykit/obus-policykit.mllib @@ -0,0 +1,5 @@ +# OASIS_START +# DO NOT EDIT (digest: c3ea2fb27b50a6ab7fe9affce002dfcb) +Policy_kit +Policy_kit_interfaces +# OASIS_STOP diff --git a/bindings/policykit/policy_kit.ml b/bindings/policykit/policy_kit.ml new file mode 100644 index 0000000..8f4cc1b --- /dev/null +++ b/bindings/policykit/policy_kit.ml @@ -0,0 +1,21 @@ +(* + * policy_kit.ml + * ------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let not_authorized = "org.freedesktop.PolicyKit.Error.NotAuthorized" + +open Policy_kit_interfaces.Org_freedesktop_PolicyKit_AuthenticationAgent + +let obtain_authorization ~action_id ?(xid=0) ~pid () = + 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) diff --git a/bindings/policykit/policy_kit.mli b/bindings/policykit/policy_kit.mli new file mode 100644 index 0000000..8317fb1 --- /dev/null +++ b/bindings/policykit/policy_kit.mli @@ -0,0 +1,24 @@ +(* + * policy_kit.mli + * -------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 + *) diff --git a/bindings/policykit/policy_kit_interfaces.obus b/bindings/policykit/policy_kit_interfaces.obus new file mode 100644 index 0000000..ce3b12b --- /dev/null +++ b/bindings/policykit/policy_kit_interfaces.obus @@ -0,0 +1,12 @@ +(* + * policy_kit_interfaces.obus + * -------------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +interface org.freedesktop.PolicyKit.AuthenticationAgent { + method ObtainAuthorization : (action_id : string, xid : uint32, pid : uint32) -> (gained_authorization : boolean) +} diff --git a/bindings/policykit/policykit.mllib b/bindings/policykit/policykit.mllib new file mode 100644 index 0000000..f0c727e --- /dev/null +++ b/bindings/policykit/policykit.mllib @@ -0,0 +1,2 @@ +Policy_kit +Policy_kit_interfaces diff --git a/bindings/udisks/obus-udisks.mllib b/bindings/udisks/obus-udisks.mllib new file mode 100644 index 0000000..9284e9b --- /dev/null +++ b/bindings/udisks/obus-udisks.mllib @@ -0,0 +1,10 @@ +# OASIS_START +# DO NOT EDIT (digest: 0ca1266d1c23bbfeae249af95fd44cab) +UDisks +UDisks_device +UDisks_port +UDisks_adapter +UDisks_expander +UDisks_interfaces +UDisks_monitor +# OASIS_STOP diff --git a/bindings/udisks/uDisks.ml b/bindings/udisks/uDisks.ml new file mode 100644 index 0000000..c0679c3 --- /dev/null +++ b/bindings/udisks/uDisks.ml @@ -0,0 +1,298 @@ +(* + * uDisks.ml + * --------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open 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 () = + 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 = + lwt (context, devices) = OBus_method.call_with_context m_EnumerateAdapters (proxy daemon) () in + return (List.map (make_adapter context) devices) + +let enumerate_expanders daemon = + lwt (context, devices) = OBus_method.call_with_context m_EnumerateExpanders (proxy daemon) () in + return (List.map (make_expander context) devices) + +let enumerate_ports daemon = + lwt (context, devices) = OBus_method.call_with_context m_EnumeratePorts (proxy daemon) () in + return (List.map (make_port context) devices) + +let enumerate_devices daemon = + 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 = + 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 = + 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 + 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 + 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 + 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 diff --git a/bindings/udisks/uDisks.mli b/bindings/udisks/uDisks.mli new file mode 100644 index 0000000..a08b1fd --- /dev/null +++ b/bindings/udisks/uDisks.mli @@ -0,0 +1,170 @@ +(* + * uDisks.mli + * ---------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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.</doc:summary *) + job_is_cancellable : bool; + (** Whether the job is cancellable *) + job_id : string; + (** The identifier of the job *) + job_num_tasks : int; + (** Number of tasks in the job *) + job_cur_task : int; + (** Current task number (zero-based offset) *) + job_cur_task_id : string; + (** Task identifier for current task *) + job_cur_task_percentage : float; + (** Percentage completed of current task (between 0 and 100, negative if unknown) *) +} + +val device_job_changed : t -> 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 diff --git a/bindings/udisks/uDisks_adapter.ml b/bindings/udisks/uDisks_adapter.ml new file mode 100644 index 0000000..9edfe00 --- /dev/null +++ b/bindings/udisks/uDisks_adapter.ml @@ -0,0 +1,38 @@ +(* + * uDisks_adapter.ml + * ----------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/udisks/uDisks_adapter.mli b/bindings/udisks/uDisks_adapter.mli new file mode 100644 index 0000000..9c24d82 --- /dev/null +++ b/bindings/udisks/uDisks_adapter.mli @@ -0,0 +1,27 @@ +(* + * uDisks_adapter.mli + * ------------------ + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/udisks/uDisks_device.ml b/bindings/udisks/uDisks_device.ml new file mode 100644 index 0000000..24839ba --- /dev/null +++ b/bindings/udisks/uDisks_device.ml @@ -0,0 +1,620 @@ +(* + * uDisks_device.ml + * ---------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open 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 = + 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 = + 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 = + 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 = + 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 + diff --git a/bindings/udisks/uDisks_device.mli b/bindings/udisks/uDisks_device.mli new file mode 100644 index 0000000..3516475 --- /dev/null +++ b/bindings/udisks/uDisks_device.mli @@ -0,0 +1,240 @@ +(* + * uDisks_device.mli + * ----------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/udisks/uDisks_expander.ml b/bindings/udisks/uDisks_expander.ml new file mode 100644 index 0000000..25e3cd8 --- /dev/null +++ b/bindings/udisks/uDisks_expander.ml @@ -0,0 +1,45 @@ +(* + * uDisks_expander.ml + * ------------------ + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/udisks/uDisks_expander.mli b/bindings/udisks/uDisks_expander.mli new file mode 100644 index 0000000..ccdbbab --- /dev/null +++ b/bindings/udisks/uDisks_expander.mli @@ -0,0 +1,28 @@ +(* + * uDisks_expander.mli + * ------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/udisks/uDisks_interfaces.obus b/bindings/udisks/uDisks_interfaces.obus new file mode 100644 index 0000000..02f73d4 --- /dev/null +++ b/bindings/udisks/uDisks_interfaces.obus @@ -0,0 +1,249 @@ +(* + * uDisks_interfaces.obus + * ---------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +interface org.freedesktop.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 +} diff --git a/bindings/udisks/uDisks_monitor.ml b/bindings/udisks/uDisks_monitor.ml new file mode 100644 index 0000000..93849ac --- /dev/null +++ b/bindings/udisks/uDisks_monitor.ml @@ -0,0 +1,35 @@ +(* + * uDisks_monitor.ml + * ----------------- + * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org> + * 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 = + 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, ()) -> + lwt context, dict = OBus_property.get_all_no_cache proxy interface in + return (OBus_property.map_of_list context dict)) + event)) diff --git a/bindings/udisks/uDisks_monitor.mli b/bindings/udisks/uDisks_monitor.mli new file mode 100644 index 0000000..bc31320 --- /dev/null +++ b/bindings/udisks/uDisks_monitor.mli @@ -0,0 +1,13 @@ +(* + * uDisks_monitor.mli + * ------------------ + * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org> + * 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. *) diff --git a/bindings/udisks/uDisks_port.ml b/bindings/udisks/uDisks_port.ml new file mode 100644 index 0000000..7aa2e31 --- /dev/null +++ b/bindings/udisks/uDisks_port.ml @@ -0,0 +1,39 @@ +(* + * uDisks_port.ml + * -------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/udisks/uDisks_port.mli b/bindings/udisks/uDisks_port.mli new file mode 100644 index 0000000..28aa67e --- /dev/null +++ b/bindings/udisks/uDisks_port.mli @@ -0,0 +1,26 @@ +(* + * uDisks_port.mli + * --------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/udisks/udisks.mllib b/bindings/udisks/udisks.mllib new file mode 100644 index 0000000..b21dd98 --- /dev/null +++ b/bindings/udisks/udisks.mllib @@ -0,0 +1,6 @@ +UDisks +UDisks_device +UDisks_port +UDisks_adapter +UDisks_expander +UDisks_interfaces diff --git a/bindings/upower/obus-upower.mllib b/bindings/upower/obus-upower.mllib new file mode 100644 index 0000000..eb2adb5 --- /dev/null +++ b/bindings/upower/obus-upower.mllib @@ -0,0 +1,9 @@ +# OASIS_START +# DO NOT EDIT (digest: 3b1f9c7cde3c597e58064966ac626192) +UPower +UPower_device +UPower_policy +UPower_wakeups +UPower_interfaces +UPower_monitor +# OASIS_STOP diff --git a/bindings/upower/uPower.ml b/bindings/upower/uPower.ml new file mode 100644 index 0000000..3c6a59d --- /dev/null +++ b/bindings/upower/uPower.ml @@ -0,0 +1,97 @@ +(* + * uPower.ml + * --------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Lwt + +include OBus_peer.Private + +let general_error = "org.freedesktop.UPower.GeneralError" + +let daemon () = + 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 = + 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 diff --git a/bindings/upower/uPower.mli b/bindings/upower/uPower.mli new file mode 100644 index 0000000..46c2fcb --- /dev/null +++ b/bindings/upower/uPower.mli @@ -0,0 +1,47 @@ +(* + * uPower.mli + * ---------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/upower/uPower_device.ml b/bindings/upower/uPower_device.ml new file mode 100644 index 0000000..4b66f93 --- /dev/null +++ b/bindings/upower/uPower_device.ml @@ -0,0 +1,177 @@ +(* + * uPower_device.ml + * ---------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open 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 + 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 diff --git a/bindings/upower/uPower_device.mli b/bindings/upower/uPower_device.mli new file mode 100644 index 0000000..ccfbead --- /dev/null +++ b/bindings/upower/uPower_device.mli @@ -0,0 +1,90 @@ +(* + * uPower_device.mli + * ----------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/upower/uPower_interfaces.obus b/bindings/upower/uPower_interfaces.obus new file mode 100644 index 0000000..224ade9 --- /dev/null +++ b/bindings/upower/uPower_interfaces.obus @@ -0,0 +1,90 @@ +(* + * uPower_interfaces.obus + * ---------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +interface org.freedesktop.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 : () +} diff --git a/bindings/upower/uPower_monitor.ml b/bindings/upower/uPower_monitor.ml new file mode 100644 index 0000000..cfc6a55 --- /dev/null +++ b/bindings/upower/uPower_monitor.ml @@ -0,0 +1,35 @@ +(* + * uPower_monitor.ml + * ----------------- + * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org> + * 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 = + 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, ()) -> + lwt context, dict = OBus_property.get_all_no_cache proxy interface in + return (OBus_property.map_of_list context dict)) + event)) diff --git a/bindings/upower/uPower_monitor.mli b/bindings/upower/uPower_monitor.mli new file mode 100644 index 0000000..a8a7376 --- /dev/null +++ b/bindings/upower/uPower_monitor.mli @@ -0,0 +1,13 @@ +(* + * uPower_monitor.mli + * ------------------ + * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org> + * 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. *) diff --git a/bindings/upower/uPower_policy.ml b/bindings/upower/uPower_policy.ml new file mode 100644 index 0000000..31e3219 --- /dev/null +++ b/bindings/upower/uPower_policy.ml @@ -0,0 +1,83 @@ +(* + * uPower_policy.ml + * ---------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open 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 + 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 = + 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 = + 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) diff --git a/bindings/upower/uPower_policy.mli b/bindings/upower/uPower_policy.mli new file mode 100644 index 0000000..a993c00 --- /dev/null +++ b/bindings/upower/uPower_policy.mli @@ -0,0 +1,61 @@ +(* + * uPower_policy.mli + * ----------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/upower/uPower_wakeups.ml b/bindings/upower/uPower_wakeups.ml new file mode 100644 index 0000000..f057262 --- /dev/null +++ b/bindings/upower/uPower_wakeups.ml @@ -0,0 +1,53 @@ +(* + * uPower_wakeups.ml + * ----------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open 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 = + 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 = + 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) diff --git a/bindings/upower/uPower_wakeups.mli b/bindings/upower/uPower_wakeups.mli new file mode 100644 index 0000000..16db989 --- /dev/null +++ b/bindings/upower/uPower_wakeups.mli @@ -0,0 +1,47 @@ +(* + * uPower_wakeups.mli + * ------------------ + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 diff --git a/bindings/upower/upower.mllib b/bindings/upower/upower.mllib new file mode 100644 index 0000000..bcc2698 --- /dev/null +++ b/bindings/upower/upower.mllib @@ -0,0 +1,5 @@ +UPower +UPower_device +UPower_policy +UPower_wakeups +UPower_interfaces diff --git a/configure b/configure new file mode 100755 index 0000000..97ed012 --- /dev/null +++ b/configure @@ -0,0 +1,27 @@ +#!/bin/sh + +# OASIS_START +# DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7) +set -e + +FST=true +for i in "$@"; do + if $FST; then + set -- + FST=false + fi + + case $i in + --*=*) + ARG=${i%%=*} + VAL=${i##*=} + set -- "$@" "$ARG" "$VAL" + ;; + *) + set -- "$@" "$i" + ;; + esac +done + +ocaml setup.ml -configure "$@" +# OASIS_STOP diff --git a/examples/battery_monitoring.ml b/examples/battery_monitoring.ml new file mode 100644 index 0000000..61ff94b --- /dev/null +++ b/examples/battery_monitoring.ml @@ -0,0 +1,75 @@ +(* + * battery_monitoring.ml + * --------------------- + * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org> + * 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 + lwt signal = OBus_property.monitor (UPower_device.state device) in + lwt s = S.map_s (print_state device) signal in + batteries := (device, switch, s) :: !batteries; + return () + end + +(* Handle device removal. *) +let unmonitor_device device = + 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 () + +lwt () = + (* Get the manager proxy. *) + lwt manager = UPower.daemon () in + + (* Handle device addition/removal. *) + 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. *) + lwt devices = UPower.enumerate_devices manager in + lwt () = Lwt_list.iter_p monitor_device devices in + + fst (wait ()) diff --git a/examples/bus_functions.ml b/examples/bus_functions.ml new file mode 100644 index 0000000..3f94430 --- /dev/null +++ b/examples/bus_functions.ml @@ -0,0 +1,54 @@ +(* + * bus_functions.ml + * ---------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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_react +open Lwt +open Lwt_io + +let service = "org.freedesktop.Notifications" +let name = "org.ocamlcore.forge.obus" + +module String_set = Set.Make(String) + +lwt () = + lwt bus = OBus_bus.session () in + + lwt id = OBus_bus.get_id bus in + lwt () = printlf "the message bus id is: %S" (OBus_uuid.to_string id) in + + lwt names = OBus_bus.list_names bus in + lwt () = printlf "names on the session bus:" in + lwt () = Lwt_list.iter_p (printlf " %s") names in + + lwt names = OBus_bus.list_activatable_names bus in + lwt () = printlf "these names are activatable:" in + lwt () = Lwt_list.iter_p (printlf " %s") names in + + lwt () = printf "trying to start service %S: " service in + lwt result = OBus_bus.start_service_by_name bus service in + lwt () = printl + (match result with + | `Success -> "success" + | `Already_running -> "already running") + in + + lwt () = printf "trying to acquire the name %S: " name in + lwt result = OBus_bus.request_name bus ~replace_existing:true ~do_not_queue:true name in + 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)))) diff --git a/examples/eject.ml b/examples/eject.ml new file mode 100644 index 0000000..16fc559 --- /dev/null +++ b/examples/eject.ml @@ -0,0 +1,23 @@ +(* + * eject.ml + * -------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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 + +lwt () = + lwt manager = Hal_manager.manager () in + lwt cdroms = Hal_manager.find_device_by_capability manager "storage.cdrom" in + lwt () = printlf "cdrom(s) found: %d" (List.length cdroms) in + Lwt_list.iter_p begin function cdrom -> + lwt () = printlf "eject on device %s" (OBus_path.to_string (OBus_proxy.path (Hal_device.to_proxy cdrom))) in + lwt _ = Hal_device.Storage.eject cdrom [] in + return () + end cdroms diff --git a/examples/hello.ml b/examples/hello.ml new file mode 100644 index 0000000..d553eca --- /dev/null +++ b/examples/hello.ml @@ -0,0 +1,17 @@ +(* + * hello.ml + * -------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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 *) + +open Lwt + +lwt () = + lwt bus = OBus_bus.session () in + Lwt_io.printlf "My unique connection name is: %s" (OBus_connection.name bus) diff --git a/examples/list_services.ml b/examples/list_services.ml new file mode 100644 index 0000000..b698922 --- /dev/null +++ b/examples/list_services.ml @@ -0,0 +1,32 @@ +(* + * list_services.ml + * ---------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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 = + lwt () = printlf "service name mapping on %s bus:" name in + lwt bus = get_bus () in + + (* Get the list of all names on the session bus *) + lwt names = OBus_bus.list_names bus in + + Lwt_list.iter_p + (fun name -> + 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) + +lwt () = + lwt () = list "session" OBus_bus.session in + list "system" OBus_bus.system diff --git a/examples/monitor.ml b/examples/monitor.ml new file mode 100644 index 0000000..41e0c03 --- /dev/null +++ b/examples/monitor.ml @@ -0,0 +1,33 @@ +(* + * monitor.ml + * ---------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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 "@[<hv 2>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 = + 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 ] + +lwt () = + lwt () = add_filter "session" OBus_bus.session <&> add_filter "system" OBus_bus.system in + lwt () = Lwt_io.printlf "type Ctrl+C to stop" in + fst (wait ()) diff --git a/examples/network_manager.ml b/examples/network_manager.ml new file mode 100644 index 0000000..87ad315 --- /dev/null +++ b/examples/network_manager.ml @@ -0,0 +1,48 @@ +(* + * network_manager.ml + * ------------------ + * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org> + * 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 + +lwt () = + (* Get the manager. *) + 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. *) + 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 -> + 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 ()) diff --git a/examples/notify.ml b/examples/notify.ml new file mode 100644 index 0000000..0a9598b --- /dev/null +++ b/examples/notify.ml @@ -0,0 +1,31 @@ +(* + * notify.ml + * --------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Lwt +open Lwt_io + +lwt () = + (* Open a first notification: *) + lwt _ = Notification.notify ~summary:"Hello, world!" ~body:"ocaml is fun!" ~icon:"info" () in + + lwt () = Lwt_unix.sleep 0.5 in + + (* Open another one, with buttons on it: *) + 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" diff --git a/examples/ping.ml b/examples/ping.ml new file mode 100644 index 0000000..1f039ae --- /dev/null +++ b/examples/ping.ml @@ -0,0 +1,37 @@ +(* + * ping.ml + * ------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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 + +lwt _ = + 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 *) + lwt () = printl "trying to ping the pong service..." in + + try_lwt + lwt msg = ping proxy "coucou" in + printlf "received: %s" msg + with + | OBus_bus.Name_has_no_owner msg -> + lwt () = printl "You must run pong to try this sample!" in + exit 1 + | exn -> + raise_lwt exn diff --git a/examples/ping_pong.xml b/examples/ping_pong.xml new file mode 100644 index 0000000..eb69bdd --- /dev/null +++ b/examples/ping_pong.xml @@ -0,0 +1,8 @@ +<node> + <interface name="org.foo.bar"> + <method name="Ping"> + <arg direction="in" type="s"/> + <arg direction="out" type="s"/> + </method> + </interface> +</node> diff --git a/examples/pong.ml b/examples/pong.ml new file mode 100644 index 0000000..addf650 --- /dev/null +++ b/examples/pong.ml @@ -0,0 +1,38 @@ +(* + * pong.ml + * ------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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 = + 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); + } + +lwt () = + lwt bus = OBus_bus.session () in + + (* Request a name *) + 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 ()) diff --git a/examples/signals.ml b/examples/signals.ml new file mode 100644 index 0000000..b4a94f7 --- /dev/null +++ b/examples/signals.ml @@ -0,0 +1,82 @@ +(* + * signals.ml + * ---------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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) -> + lwt () = printlf "from Hal: action %S on key %S!" action key in + lwt () = printlf " the signal come from the device %S" (OBus_path.to_string (Hal_device.udi device)) in + return ())) + >|= E.keep + +lwt () = + lwt session = OBus_bus.session () in + + (* +---------------------------------------------------------------+ + | Signals from message bus | + +---------------------------------------------------------------+ *) + + 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 + + lwt () = + OBus_signal.connect (OBus_bus.name_lost session) + >|= E.map_p (printlf "from D-Bus: i lost the name %S!") + >|= E.keep + in + + 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 | + +---------------------------------------------------------------+ *) + + lwt manager = Hal_manager.manager () in + + lwt () = + OBus_signal.connect (Hal_manager.device_added manager) + >|= (E.map_p + (fun device -> + 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 *) + lwt keyboards = Hal_manager.find_device_by_capability manager "input.keyboard" in + lwt () = printlf "keyboard founds: %d" (List.length keyboards) in + lwt () = Lwt_list.iter_p (fun dev -> printlf " %s" (OBus_path.to_string (Hal_device.udi dev))) keyboards in + + lwt () = Lwt_list.iter_p handle_multimedia_keys keyboards in + + lwt () = printf "type Ctrl+C to stop\n%!" in + fst (wait ()) diff --git a/man/obus-dump.1 b/man/obus-dump.1 new file mode 100644 index 0000000..cb7b5d4 --- /dev/null +++ b/man/obus-dump.1 @@ -0,0 +1,44 @@ +\" obus-dump.1 +\" ----------- +\" Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> +\" 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 <jeremie@dimino.org> + +.SH "SEE ALSO" +.BR obus-introspect (1), +.BR obus-binder (1). diff --git a/man/obus-gen-client.1 b/man/obus-gen-client.1 new file mode 100644 index 0000000..fee5a80 --- /dev/null +++ b/man/obus-gen-client.1 @@ -0,0 +1,53 @@ +\" obus-gen-client.1 +\" ----------------- +\" Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> +\" 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 <jeremie@dimino.org> + +.SH "SEE ALSO" +.BR obus-introspect (1), +.BR obus-gen-interface (1), +.BR obus-gen-server (1). diff --git a/man/obus-gen-interface.1 b/man/obus-gen-interface.1 new file mode 100644 index 0000000..1ca272d --- /dev/null +++ b/man/obus-gen-interface.1 @@ -0,0 +1,60 @@ +\" obus-gen-interface.1 +\" -------------------- +\" Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> +\" 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 <jeremie@dimino.org> + +.SH "SEE ALSO" +.BR obus-introspect (1), +.BR obus-gen-client (1), +.BR obus-gen-server (1). diff --git a/man/obus-gen-server.1 b/man/obus-gen-server.1 new file mode 100644 index 0000000..9991be9 --- /dev/null +++ b/man/obus-gen-server.1 @@ -0,0 +1,53 @@ +\" obus-gen-server.1 +\" ----------------- +\" Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> +\" 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 <jeremie@dimino.org> + +.SH "SEE ALSO" +.BR obus-introspect (1), +.BR obus-gen-interface (1), +.BR obus-gen-client (1). diff --git a/man/obus-idl2xml.1 b/man/obus-idl2xml.1 new file mode 100644 index 0000000..7d910b7 --- /dev/null +++ b/man/obus-idl2xml.1 @@ -0,0 +1,37 @@ +\" obus-idl2xml.1 +\" -------------- +\" Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> +\" 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 <jeremie@dimino.org> + +.SH "SEE ALSO" +.BR obus-xml2idl. diff --git a/man/obus-introspect.1 b/man/obus-introspect.1 new file mode 100644 index 0000000..814214f --- /dev/null +++ b/man/obus-introspect.1 @@ -0,0 +1,54 @@ +\" obus-introspect.1 +\" ----------------- +\" Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> +\" 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 <jeremie@dimino.org> + +.SH "SEE ALSO" +.BR obus-dump (1), +.BR obus-binder (1). diff --git a/man/obus-xml2idl.1 b/man/obus-xml2idl.1 new file mode 100644 index 0000000..eadd064 --- /dev/null +++ b/man/obus-xml2idl.1 @@ -0,0 +1,47 @@ +\" obus-xml2idl.1 +\" -------------- +\" Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> +\" 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 <jeremie@dimino.org> + +.SH "SEE ALSO" +.BR obus-idl2xml. diff --git a/manual/Makefile b/manual/Makefile new file mode 100644 index 0000000..2583c69 --- /dev/null +++ b/manual/Makefile @@ -0,0 +1,19 @@ +# Makefile +# -------- +# Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> +# 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 diff --git a/manual/manual.pdf b/manual/manual.pdf Binary files differnew file mode 100644 index 0000000..be2b0a5 --- /dev/null +++ b/manual/manual.pdf diff --git a/manual/manual.tex b/manual/manual.tex new file mode 100644 index 0000000..55f53d3 --- /dev/null +++ b/manual/manual.tex @@ -0,0 +1,801 @@ +% manual.tex +% ---------- +% Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org> +% 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} diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 0000000..7125daa --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,569 @@ +(* + * myocamlbuild.ml + * --------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(* OASIS_START *) +(* DO NOT EDIT (digest: ce24d7b6566c3cd588139351285f0819) *) +module OASISGettext = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISGettext.ml" + + let ns_ str = + str + + let s_ str = + str + + let f_ (str : ('a, 'b, 'c, 'd) format4) = + str + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + let init = + [] + +end + +module OASISExpr = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISExpr.ml" + + + + open OASISGettext + + type test = string + + type flag = string + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + type 'a choices = (t * 'a) list + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "<empty>" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "<no printer>") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + +end + + +# 117 "myocamlbuild.ml" +module BaseEnvLight = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseEnvLight.ml" + + module MapString = Map.Make(String) + + type t = string MapString.t + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + let var_get name env = + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + in + var_expand (MapString.find name env) + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 215 "myocamlbuild.ml" +module MyOCamlbuildFindlib = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" + + (** OCamlbuild extension, copied from + * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild + * by N. Pouillard and others + * + * Updated on 2009/02/28 + * + * Modified by Sylvain Le Gall + *) + open Ocamlbuild_plugin + + (* these functions are not really officially exported *) + let run_and_read = + Ocamlbuild_pack.My_unix.run_and_read + + let blank_sep_strings = + Ocamlbuild_pack.Lexers.blank_sep_strings + + let split s ch = + let x = + ref [] + in + let rec go s = + let pos = + String.index s ch + in + x := (String.before s pos)::!x; + go (String.after s (pos + 1)) + in + try + go s + with Not_found -> !x + + let split_nl s = split s '\n' + + let before_space s = + try + String.before s (String.index s ' ') + with Not_found -> s + + (* this lists all supported packages *) + let find_packages () = + List.map before_space (split_nl & run_and_read "ocamlfind list") + + (* this is supposed to list available syntaxes, but I don't know how to do it. *) + let find_syntaxes () = ["camlp4o"; "camlp4r"] + + (* ocamlfind command *) + let ocamlfind x = S[A"ocamlfind"; x] + + let dispatch = + function + | Before_options -> + (* by using Before_options one let command line options have an higher priority *) + (* on the contrary using After_options will guarantee to have the higher priority *) + (* override default commands by ocamlfind ones *) + Options.ocamlc := ocamlfind & A"ocamlc"; + Options.ocamlopt := ocamlfind & A"ocamlopt"; + Options.ocamldep := ocamlfind & A"ocamldep"; + Options.ocamldoc := ocamlfind & A"ocamldoc"; + Options.ocamlmktop := ocamlfind & A"ocamlmktop" + + | After_rules -> + + (* When one link an OCaml library/binary/package, one should use -linkpkg *) + flag ["ocaml"; "link"; "program"] & A"-linkpkg"; + + (* For each ocamlfind package one inject the -package option when + * compiling, computing dependencies, generating documentation and + * linking. *) + List.iter + begin fun pkg -> + flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; + end + (find_packages ()); + + (* Like -package but for extensions syntax. Morover -syntax is useless + * when linking. *) + List.iter begin fun syntax -> + flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + end (find_syntaxes ()); + + (* The default "thread" tag is not compatible with ocamlfind. + * Indeed, the default rules add the "threads.cma" or "threads.cmxa" + * options when using this tag. When using the "-linkpkg" option with + * ocamlfind, this module will then be added twice on the command line. + * + * To solve this, one approach is to add the "-thread" option when using + * the "threads" package using the previous plugin. + *) + flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) + + | _ -> + () + +end + +module MyOCamlbuildBase = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" + + (** Base functions for writing myocamlbuild.ml + @author Sylvain Le Gall + *) + + + + open Ocamlbuild_plugin + module OC = Ocamlbuild_pack.Ocaml_compiler + + type dir = string + type file = string + type name = string + type tag = string + +# 56 "/home/dim/sources/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" + + type t = + { + lib_ocaml: (name * dir list) list; + lib_c: (name * dir * file list) list; + flags: (tag list * (spec OASISExpr.choices)) list; + (* Replace the 'dir: include' from _tags by a precise interdepends in + * directory. + *) + includes: (dir * dir list) list; + } + + let env_filename = + Pathname.basename + BaseEnvLight.default_filename + + let dispatch_combine lst = + fun e -> + List.iter + (fun dispatch -> dispatch e) + lst + + let tag_libstubs nm = + "use_lib"^nm^"_stubs" + + let nm_libstubs nm = + nm^"_stubs" + + let dispatch t e = + let env = + BaseEnvLight.load + ~filename:env_filename + ~allow_empty:true + () + in + match e with + | Before_options -> + let no_trailing_dot s = + if String.length s >= 1 && s.[0] = '.' then + String.sub s 1 ((String.length s) - 1) + else + s + in + List.iter + (fun (opt, var) -> + try + opt := no_trailing_dot (BaseEnvLight.var_get var env) + with Not_found -> + Printf.eprintf "W: Cannot get variable %s" var) + [ + Options.ext_obj, "ext_obj"; + Options.ext_lib, "ext_lib"; + Options.ext_dll, "ext_dll"; + ] + + | After_rules -> + (* Declare OCaml libraries *) + List.iter + (function + | nm, [] -> + ocaml_lib nm + | nm, dir :: tl -> + ocaml_lib ~dir:dir (dir^"/"^nm); + List.iter + (fun dir -> + List.iter + (fun str -> + flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) + ["compile"; "infer_interface"; "doc"]) + tl) + t.lib_ocaml; + + (* Declare directories dependencies, replace "include" in _tags. *) + List.iter + (fun (dir, include_dirs) -> + Pathname.define_context dir include_dirs) + t.includes; + + (* Declare C libraries *) + List.iter + (fun (lib, dir, headers) -> + (* Handle C part of library *) + flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; + A("-l"^(nm_libstubs lib))]); + + flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] + (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); + + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); + + (* When ocaml link something that use the C library, then one + need that file to be up to date. + *) + dep ["link"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + dep ["compile"; "ocaml"; "program"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + + (* TODO: be more specific about what depends on headers *) + (* Depends on .h files *) + dep ["compile"; "c"] + headers; + + (* Setup search path for lib *) + flag ["link"; "ocaml"; "use_"^lib] + (S[A"-I"; P(dir)]); + ) + t.lib_c; + + (* Add flags *) + List.iter + (fun (tags, cond_specs) -> + let spec = + BaseEnvLight.var_choose cond_specs env + in + flag tags & spec) + t.flags + | _ -> + () + + let dispatch_default t = + dispatch_combine + [ + dispatch t; + MyOCamlbuildFindlib.dispatch; + ] + +end + + +# 476 "myocamlbuild.ml" +open Ocamlbuild_plugin;; +let package_default = + { + MyOCamlbuildBase.lib_ocaml = + [ + ("obus", ["src"]); + ("obus-idl", ["src"]); + ("obus-syntax", ["syntax"]); + ("obus-hal", ["bindings/hal"]); + ("obus-notification", ["bindings/notification"]); + ("obus-network-manager", ["bindings/network-manager"]); + ("obus-upower", ["bindings/upower"]); + ("obus-udisks", ["bindings/udisks"]); + ("obus-policykit", ["bindings/policykit"]) + ]; + lib_c = []; + flags = []; + includes = + [ + ("tools", ["src"]); + ("tests", ["src"]); + ("examples", + [ + "bindings/hal"; + "bindings/network-manager"; + "bindings/notification"; + "bindings/upower"; + "src" + ]); + ("bindings/upower", ["src"]); + ("bindings/udisks", ["src"]); + ("bindings/policykit", ["src"]); + ("bindings/notification", ["src"]); + ("bindings/network-manager", ["src"]); + ("bindings/hal", ["src"]) + ]; + } + ;; + +let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; + +# 519 "myocamlbuild.ml" +(* OASIS_STOP *) + +open Ocamlbuild_plugin + +let () = + dispatch + (fun hook -> + dispatch_default hook; + match hook with + | Before_options -> + Options.make_links := false + + | After_rules -> + (* Internal syntax extension *) + flag ["ocaml"; "compile"; "pa_obus"] & S[A"-ppopt"; A"syntax/pa_obus.cmo"]; + flag ["ocaml"; "ocamldep"; "pa_obus"] & S[A"-ppopt"; A"syntax/pa_obus.cmo"]; + flag ["ocaml"; "doc"; "pa_obus"] & S[A"-ppopt"; A"syntax/pa_obus.cmo"]; + dep ["ocaml"; "ocamldep"; "pa_obus"] ["syntax/pa_obus.cmo"]; + + (* Generation of ocaml modules from .obus files *) + rule "IDL to OCaml" + ~prods:["%.ml"; "%.mli"] + ~deps:["%.obus"; "tools/obus_gen_interface.byte"] + (fun env _ -> Cmd(S[P"tools/obus_gen_interface.byte"; + A"-keep-common"; + A"-o"; A(env "%"); + A(env "%.obus")])); + + (* Generation of ocaml modules from xml introspection files *) + rule "XML to OCaml" + ~prods:["%.ml"; "%.mli"] + ~deps:["%.xml"; "tools/obus_gen_interface.byte"] + (fun env _ -> Cmd(S[P"tools/obus_gen_interface.byte"; A"-o"; A(env "%"); A(env "%.xml")])); + + (* Use an introduction page with categories *) + tag_file "obus-api.docdir/index.html" ["apiref"]; + dep ["apiref"] ["apiref-intro"]; + flag ["apiref"] & S[A "-intro"; P "apiref-intro"; A"-colorize-code"] + + | _ -> + ()) + diff --git a/obus-api.odocl b/obus-api.odocl new file mode 100644 index 0000000..5b6efbc --- /dev/null +++ b/obus-api.odocl @@ -0,0 +1,65 @@ +# OASIS_START +# DO NOT EDIT (digest: f5ebd35d6b64c25e5abd5e83d528e130) +src/OBus_address +src/OBus_auth +src/OBus_bus +src/OBus_connection +src/OBus_context +src/OBus_error +src/OBus_info +src/OBus_introspect_ext +src/OBus_introspect +src/OBus_match +src/OBus_member +src/OBus_message +src/OBus_method +src/OBus_name +src/OBus_object +src/OBus_path +src/OBus_peer +src/OBus_property +src/OBus_proxy +src/OBus_resolver +src/OBus_server +src/OBus_signal +src/OBus_string +src/OBus_transport +src/OBus_uuid +src/OBus_value +src/OBus_wire +src/OBus_interfaces +bindings/hal/Hal_device +bindings/hal/Hal_manager +bindings/hal/Hal_interfaces +src/OBus_idl +bindings/network-manager/Nm_access_point +bindings/network-manager/Nm_connection +bindings/network-manager/Nm_device +bindings/network-manager/Nm_dhcp4_config +bindings/network-manager/Nm_ip4_config +bindings/network-manager/Nm_ip6_config +bindings/network-manager/Nm_manager +bindings/network-manager/Nm_ppp +bindings/network-manager/Nm_settings +bindings/network-manager/Nm_vpn_connection +bindings/network-manager/Nm_vpn_plugin +bindings/network-manager/Nm_interfaces +bindings/network-manager/Nm_monitor +bindings/notification/Notification +bindings/notification/Notification_interfaces +bindings/policykit/Policy_kit +bindings/policykit/Policy_kit_interfaces +bindings/udisks/UDisks +bindings/udisks/UDisks_device +bindings/udisks/UDisks_port +bindings/udisks/UDisks_adapter +bindings/udisks/UDisks_expander +bindings/udisks/UDisks_interfaces +bindings/udisks/UDisks_monitor +bindings/upower/UPower +bindings/upower/UPower_device +bindings/upower/UPower_policy +bindings/upower/UPower_wakeups +bindings/upower/UPower_interfaces +bindings/upower/UPower_monitor +# OASIS_STOP diff --git a/setup.ml b/setup.ml new file mode 100644 index 0000000..ff045ec --- /dev/null +++ b/setup.ml @@ -0,0 +1,7548 @@ +(* + * setup.ml + * -------- + * Copyright : (c) 2011, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(* OASIS_START *) +(* DO NOT EDIT (digest: fe2dbb9c8cc093d49d3738532cb96cc5) *) +(* + Regenerated by OASIS v0.3.0 + Visit http://oasis.forge.ocamlcore.org for more information and + documentation about functions used in this file. +*) +module OASISGettext = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISGettext.ml" + + let ns_ str = + str + + let s_ str = + str + + let f_ (str : ('a, 'b, 'c, 'd) format4) = + str + + let fn_ fmt1 fmt2 n = + if n = 1 then + fmt1^^"" + else + fmt2^^"" + + let init = + [] + +end + +module OASISContext = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISContext.ml" + + open OASISGettext + + type level = + [ `Debug + | `Info + | `Warning + | `Error] + + type t = + { + quiet: bool; + info: bool; + debug: bool; + ignore_plugins: bool; + ignore_unknown_fields: bool; + printf: level -> string -> unit; + } + + let printf lvl str = + let beg = + match lvl with + | `Error -> s_ "E: " + | `Warning -> s_ "W: " + | `Info -> s_ "I: " + | `Debug -> s_ "D: " + in + prerr_endline (beg^str) + + let default = + ref + { + quiet = false; + info = false; + debug = false; + ignore_plugins = false; + ignore_unknown_fields = false; + printf = printf; + } + + let quiet = + {!default with quiet = true} + + + let args () = + ["-quiet", + Arg.Unit (fun () -> default := {!default with quiet = true}), + (s_ " Run quietly"); + + "-info", + Arg.Unit (fun () -> default := {!default with info = true}), + (s_ " Display information message"); + + + "-debug", + Arg.Unit (fun () -> default := {!default with debug = true}), + (s_ " Output debug message")] +end + +module OASISString = struct +# 1 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISString.ml" + + + + (** Various string utilities. + + Mostly inspired by extlib and batteries ExtString and BatString libraries. + + @author Sylvain Le Gall + *) + + let nsplitf str f = + if str = "" then + [] + else + let buf = Buffer.create 13 in + let lst = ref [] in + let push () = + lst := Buffer.contents buf :: !lst; + Buffer.clear buf + in + let str_len = String.length str in + for i = 0 to str_len - 1 do + if f str.[i] then + push () + else + Buffer.add_char buf str.[i] + done; + push (); + List.rev !lst + + (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the + separator. + *) + let nsplit str c = + nsplitf str ((=) c) + + let find ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + while !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + what_idx := 0; + incr str_idx + done; + if !what_idx <> String.length what then + raise Not_found + else + !str_idx - !what_idx + + let sub_start str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str len (str_len - len) + + let sub_end ?(offset=0) str len = + let str_len = String.length str in + if len >= str_len then + "" + else + String.sub str 0 (str_len - len) + + let starts_with ~what ?(offset=0) str = + let what_idx = ref 0 in + let str_idx = ref offset in + let ok = ref true in + while !ok && + !str_idx < String.length str && + !what_idx < String.length what do + if str.[!str_idx] = what.[!what_idx] then + incr what_idx + else + ok := false; + incr str_idx + done; + if !what_idx = String.length what then + true + else + false + + let strip_starts_with ~what str = + if starts_with ~what str then + sub_start str (String.length what) + else + raise Not_found + + let ends_with ~what ?(offset=0) str = + let what_idx = ref ((String.length what) - 1) in + let str_idx = ref ((String.length str) - 1) in + let ok = ref true in + while !ok && + offset <= !str_idx && + 0 <= !what_idx do + if str.[!str_idx] = what.[!what_idx] then + decr what_idx + else + ok := false; + decr str_idx + done; + if !what_idx = -1 then + true + else + false + + let strip_ends_with ~what str = + if ends_with ~what str then + sub_end str (String.length what) + else + raise Not_found + + let replace_chars f s = + let buf = String.make (String.length s) 'X' in + for i = 0 to String.length s - 1 do + buf.[i] <- f s.[i] + done; + buf + +end + +module OASISUtils = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISUtils.ml" + + open OASISGettext + + module MapString = Map.Make(String) + + let map_string_of_assoc assoc = + List.fold_left + (fun acc (k, v) -> MapString.add k v acc) + MapString.empty + assoc + + module SetString = Set.Make(String) + + let set_string_add_list st lst = + List.fold_left + (fun acc e -> SetString.add e acc) + st + lst + + let set_string_of_list = + set_string_add_list + SetString.empty + + + let compare_csl s1 s2 = + String.compare (String.lowercase s1) (String.lowercase s2) + + module HashStringCsl = + Hashtbl.Make + (struct + type t = string + + let equal s1 s2 = + (String.lowercase s1) = (String.lowercase s2) + + let hash s = + Hashtbl.hash (String.lowercase s) + end) + + let varname_of_string ?(hyphen='_') s = + if String.length s = 0 then + begin + invalid_arg "varname_of_string" + end + else + begin + let buf = + OASISString.replace_chars + (fun c -> + if ('a' <= c && c <= 'z') + || + ('A' <= c && c <= 'Z') + || + ('0' <= c && c <= '9') then + c + else + hyphen) + s; + in + let buf = + (* Start with a _ if digit *) + if '0' <= s.[0] && s.[0] <= '9' then + "_"^buf + else + buf + in + String.lowercase buf + end + + let varname_concat ?(hyphen='_') p s = + let what = String.make 1 hyphen in + let p = + try + OASISString.strip_ends_with ~what p + with Not_found -> + p + in + let s = + try + OASISString.strip_starts_with ~what s + with Not_found -> + s + in + p^what^s + + + let is_varname str = + str = varname_of_string str + + let failwithf fmt = Printf.ksprintf failwith fmt + +end + +module PropList = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/PropList.ml" + + open OASISGettext + + type name = string + + exception Not_set of name * string option + exception No_printer of name + exception Unknown_field of name * name + + let () = + Printexc.register_printer + (function + | Not_set (nm, Some rsn) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) + | Not_set (nm, None) -> + Some + (Printf.sprintf (f_ "Field '%s' is not set") nm) + | No_printer nm -> + Some + (Printf.sprintf (f_ "No default printer for value %s") nm) + | Unknown_field (nm, schm) -> + Some + (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) + | _ -> + None) + + module Data = + struct + + type t = + (name, unit -> unit) Hashtbl.t + + let create () = + Hashtbl.create 13 + + let clear t = + Hashtbl.clear t + +# 71 "/home/dim/sources/oasis-0.3.0/src/oasis/PropList.ml" + end + + module Schema = + struct + + type ('ctxt, 'extra) value = + { + get: Data.t -> string; + set: Data.t -> ?context:'ctxt -> string -> unit; + help: (unit -> string) option; + extra: 'extra; + } + + type ('ctxt, 'extra) t = + { + name: name; + fields: (name, ('ctxt, 'extra) value) Hashtbl.t; + order: name Queue.t; + name_norm: string -> string; + } + + let create ?(case_insensitive=false) nm = + { + name = nm; + fields = Hashtbl.create 13; + order = Queue.create (); + name_norm = + (if case_insensitive then + String.lowercase + else + fun s -> s); + } + + let add t nm set get extra help = + let key = + t.name_norm nm + in + + if Hashtbl.mem t.fields key then + failwith + (Printf.sprintf + (f_ "Field '%s' is already defined in schema '%s'") + nm t.name); + Hashtbl.add + t.fields + key + { + set = set; + get = get; + help = help; + extra = extra; + }; + Queue.add nm t.order + + let mem t nm = + Hashtbl.mem t.fields nm + + let find t nm = + try + Hashtbl.find t.fields (t.name_norm nm) + with Not_found -> + raise (Unknown_field (nm, t.name)) + + let get t data nm = + (find t nm).get data + + let set t data nm ?context x = + (find t nm).set + data + ?context + x + + let fold f acc t = + Queue.fold + (fun acc k -> + let v = + find t k + in + f acc k v.extra v.help) + acc + t.order + + let iter f t = + fold + (fun () -> f) + () + t + + let name t = + t.name + end + + module Field = + struct + + type ('ctxt, 'value, 'extra) t = + { + set: Data.t -> ?context:'ctxt -> 'value -> unit; + get: Data.t -> 'value; + sets: Data.t -> ?context:'ctxt -> string -> unit; + gets: Data.t -> string; + help: (unit -> string) option; + extra: 'extra; + } + + let new_id = + let last_id = + ref 0 + in + fun () -> incr last_id; !last_id + + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + (* Default value container *) + let v = + ref None + in + + (* If name is not given, create unique one *) + let nm = + match name with + | Some s -> s + | None -> Printf.sprintf "_anon_%d" (new_id ()) + in + + (* Last chance to get a value: the default *) + let default () = + match default with + | Some d -> d + | None -> raise (Not_set (nm, Some (s_ "no default value"))) + in + + (* Get data *) + let get data = + (* Get value *) + try + (Hashtbl.find data nm) (); + match !v with + | Some x -> x + | None -> default () + with Not_found -> + default () + in + + (* Set data *) + let set data ?context x = + let x = + match update with + | Some f -> + begin + try + f ?context (get data) x + with Not_set _ -> + x + end + | None -> + x + in + Hashtbl.replace + data + nm + (fun () -> v := Some x) + in + + (* Parse string value, if possible *) + let parse = + match parse with + | Some f -> + f + | None -> + fun ?context s -> + failwith + (Printf.sprintf + (f_ "Cannot parse field '%s' when setting value %S") + nm + s) + in + + (* Set data, from string *) + let sets data ?context s = + set ?context data (parse ?context s) + in + + (* Output value as string, if possible *) + let print = + match print with + | Some f -> + f + | None -> + fun _ -> raise (No_printer nm) + in + + (* Get data, as a string *) + let gets data = + print (get data) + in + + begin + match schema with + | Some t -> + Schema.add t nm sets gets extra help + | None -> + () + end; + + { + set = set; + get = get; + sets = sets; + gets = gets; + help = help; + extra = extra; + } + + let fset data t ?context x = + t.set data ?context x + + let fget data t = + t.get data + + let fsets data t ?context s = + t.sets data ?context s + + let fgets data t = + t.gets data + + end + + module FieldRO = + struct + + let create ?schema ?name ?parse ?print ?default ?update ?help extra = + let fld = + Field.create ?schema ?name ?parse ?print ?default ?update ?help extra + in + fun data -> Field.fget data fld + + end +end + +module OASISMessage = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISMessage.ml" + + + open OASISGettext + open OASISContext + + let generic_message ~ctxt lvl fmt = + let cond = + if ctxt.quiet then + false + else + match lvl with + | `Debug -> ctxt.debug + | `Info -> ctxt.info + | _ -> true + in + Printf.ksprintf + (fun str -> + if cond then + begin + ctxt.printf lvl str + end) + fmt + + let debug ~ctxt fmt = + generic_message ~ctxt `Debug fmt + + let info ~ctxt fmt = + generic_message ~ctxt `Info fmt + + let warning ~ctxt fmt = + generic_message ~ctxt `Warning fmt + + let error ~ctxt fmt = + generic_message ~ctxt `Error fmt + +end + +module OASISVersion = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISVersion.ml" + + open OASISGettext + + + + type s = string + + type t = string + + type comparator = + | VGreater of t + | VGreaterEqual of t + | VEqual of t + | VLesser of t + | VLesserEqual of t + | VOr of comparator * comparator + | VAnd of comparator * comparator + + + (* Range of allowed characters *) + let is_digit c = + '0' <= c && c <= '9' + + let is_alpha c = + ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') + + let is_special = + function + | '.' | '+' | '-' | '~' -> true + | _ -> false + + let rec version_compare v1 v2 = + if v1 <> "" || v2 <> "" then + begin + (* Compare ascii string, using special meaning for version + * related char + *) + let val_ascii c = + if c = '~' then -1 + else if is_digit c then 0 + else if c = '\000' then 0 + else if is_alpha c then Char.code c + else (Char.code c) + 256 + in + + let len1 = String.length v1 in + let len2 = String.length v2 in + + let p = ref 0 in + + (** Compare ascii part *) + let compare_vascii () = + let cmp = ref 0 in + while !cmp = 0 && + !p < len1 && !p < len2 && + not (is_digit v1.[!p] && is_digit v2.[!p]) do + cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); + incr p + done; + if !cmp = 0 && !p < len1 && !p = len2 then + val_ascii v1.[!p] + else if !cmp = 0 && !p = len1 && !p < len2 then + - (val_ascii v2.[!p]) + else + !cmp + in + + (** Compare digit part *) + let compare_digit () = + let extract_int v p = + let start_p = !p in + while !p < String.length v && is_digit v.[!p] do + incr p + done; + let substr = + String.sub v !p ((String.length v) - !p) + in + let res = + match String.sub v start_p (!p - start_p) with + | "" -> 0 + | s -> int_of_string s + in + res, substr + in + let i1, tl1 = extract_int v1 (ref !p) in + let i2, tl2 = extract_int v2 (ref !p) in + i1 - i2, tl1, tl2 + in + + match compare_vascii () with + | 0 -> + begin + match compare_digit () with + | 0, tl1, tl2 -> + if tl1 <> "" && is_digit tl1.[0] then + 1 + else if tl2 <> "" && is_digit tl2.[0] then + -1 + else + version_compare tl1 tl2 + | n, _, _ -> + n + end + | n -> + n + end + else + begin + 0 + end + + + let version_of_string str = str + + let string_of_version t = t + + let chop t = + try + let pos = + String.rindex t '.' + in + String.sub t 0 pos + with Not_found -> + t + + let rec comparator_apply v op = + match op with + | VGreater cv -> + (version_compare v cv) > 0 + | VGreaterEqual cv -> + (version_compare v cv) >= 0 + | VLesser cv -> + (version_compare v cv) < 0 + | VLesserEqual cv -> + (version_compare v cv) <= 0 + | VEqual cv -> + (version_compare v cv) = 0 + | VOr (op1, op2) -> + (comparator_apply v op1) || (comparator_apply v op2) + | VAnd (op1, op2) -> + (comparator_apply v op1) && (comparator_apply v op2) + + let rec string_of_comparator = + function + | VGreater v -> "> "^(string_of_version v) + | VEqual v -> "= "^(string_of_version v) + | VLesser v -> "< "^(string_of_version v) + | VGreaterEqual v -> ">= "^(string_of_version v) + | VLesserEqual v -> "<= "^(string_of_version v) + | VOr (c1, c2) -> + (string_of_comparator c1)^" || "^(string_of_comparator c2) + | VAnd (c1, c2) -> + (string_of_comparator c1)^" && "^(string_of_comparator c2) + + let rec varname_of_comparator = + let concat p v = + OASISUtils.varname_concat + p + (OASISUtils.varname_of_string + (string_of_version v)) + in + function + | VGreater v -> concat "gt" v + | VLesser v -> concat "lt" v + | VEqual v -> concat "eq" v + | VGreaterEqual v -> concat "ge" v + | VLesserEqual v -> concat "le" v + | VOr (c1, c2) -> + (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) + | VAnd (c1, c2) -> + (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) + + let version_0_3_or_after t = + comparator_apply t (VGreaterEqual (string_of_version "0.3")) + +end + +module OASISLicense = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISLicense.ml" + + (** License for _oasis fields + @author Sylvain Le Gall + *) + + + + type license = string + + type license_exception = string + + type license_version = + | Version of OASISVersion.t + | VersionOrLater of OASISVersion.t + | NoVersion + + + type license_dep_5_unit = + { + license: license; + excption: license_exception option; + version: license_version; + } + + + type license_dep_5 = + | DEP5Unit of license_dep_5_unit + | DEP5Or of license_dep_5 list + | DEP5And of license_dep_5 list + + + type t = + | DEP5License of license_dep_5 + | OtherLicense of string (* URL *) + + +end + +module OASISExpr = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISExpr.ml" + + + + open OASISGettext + + type test = string + + type flag = string + + type t = + | EBool of bool + | ENot of t + | EAnd of t * t + | EOr of t * t + | EFlag of flag + | ETest of test * string + + + type 'a choices = (t * 'a) list + + let eval var_get t = + let rec eval' = + function + | EBool b -> + b + + | ENot e -> + not (eval' e) + + | EAnd (e1, e2) -> + (eval' e1) && (eval' e2) + + | EOr (e1, e2) -> + (eval' e1) || (eval' e2) + + | EFlag nm -> + let v = + var_get nm + in + assert(v = "true" || v = "false"); + (v = "true") + + | ETest (nm, vl) -> + let v = + var_get nm + in + (v = vl) + in + eval' t + + let choose ?printer ?name var_get lst = + let rec choose_aux = + function + | (cond, vl) :: tl -> + if eval var_get cond then + vl + else + choose_aux tl + | [] -> + let str_lst = + if lst = [] then + s_ "<empty>" + else + String.concat + (s_ ", ") + (List.map + (fun (cond, vl) -> + match printer with + | Some p -> p vl + | None -> s_ "<no printer>") + lst) + in + match name with + | Some nm -> + failwith + (Printf.sprintf + (f_ "No result for the choice list '%s': %s") + nm str_lst) + | None -> + failwith + (Printf.sprintf + (f_ "No result for a choice list: %s") + str_lst) + in + choose_aux (List.rev lst) + +end + +module OASISTypes = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISTypes.ml" + + + + + type name = string + type package_name = string + type url = string + type unix_dirname = string + type unix_filename = string + type host_dirname = string + type host_filename = string + type prog = string + type arg = string + type args = string list + type command_line = (prog * arg list) + + type findlib_name = string + type findlib_full = string + + type compiled_object = + | Byte + | Native + | Best + + + type dependency = + | FindlibPackage of findlib_full * OASISVersion.comparator option + | InternalLibrary of name + + + type tool = + | ExternalTool of name + | InternalExecutable of name + + + type vcs = + | Darcs + | Git + | Svn + | Cvs + | Hg + | Bzr + | Arch + | Monotone + | OtherVCS of url + + + type plugin_kind = + [ `Configure + | `Build + | `Doc + | `Test + | `Install + | `Extra + ] + + type plugin_data_purpose = + [ `Configure + | `Build + | `Install + | `Clean + | `Distclean + | `Install + | `Uninstall + | `Test + | `Doc + | `Extra + | `Other of string + ] + + type 'a plugin = 'a * name * OASISVersion.t option + + type all_plugin = plugin_kind plugin + + type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list + +# 102 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISTypes.ml" + + type 'a conditional = 'a OASISExpr.choices + + type custom = + { + pre_command: (command_line option) conditional; + post_command: (command_line option) conditional; + } + + + type common_section = + { + cs_name: name; + cs_data: PropList.Data.t; + cs_plugin_data: plugin_data; + } + + + type build_section = + { + bs_build: bool conditional; + bs_install: bool conditional; + bs_path: unix_dirname; + bs_compiled_object: compiled_object; + bs_build_depends: dependency list; + bs_build_tools: tool list; + bs_c_sources: unix_filename list; + bs_data_files: (unix_filename * unix_filename option) list; + bs_ccopt: args conditional; + bs_cclib: args conditional; + bs_dlllib: args conditional; + bs_dllpath: args conditional; + bs_byteopt: args conditional; + bs_nativeopt: args conditional; + } + + + type library = + { + lib_modules: string list; + lib_pack: bool; + lib_internal_modules: string list; + lib_findlib_parent: findlib_name option; + lib_findlib_name: findlib_name option; + lib_findlib_containers: findlib_name list; + } + + type executable = + { + exec_custom: bool; + exec_main_is: unix_filename; + } + + type flag = + { + flag_description: string option; + flag_default: bool conditional; + } + + type source_repository = + { + src_repo_type: vcs; + src_repo_location: url; + src_repo_browser: url option; + src_repo_module: string option; + src_repo_branch: string option; + src_repo_tag: string option; + src_repo_subdir: unix_filename option; + } + + type test = + { + test_type: [`Test] plugin; + test_command: command_line conditional; + test_custom: custom; + test_working_directory: unix_filename option; + test_run: bool conditional; + test_tools: tool list; + } + + type doc_format = + | HTML of unix_filename + | DocText + | PDF + | PostScript + | Info of unix_filename + | DVI + | OtherDoc + + + type doc = + { + doc_type: [`Doc] plugin; + doc_custom: custom; + doc_build: bool conditional; + doc_install: bool conditional; + doc_install_dir: unix_filename; + doc_title: string; + doc_authors: string list; + doc_abstract: string option; + doc_format: doc_format; + doc_data_files: (unix_filename * unix_filename option) list; + doc_build_tools: tool list; + } + + type section = + | Library of common_section * build_section * library + | Executable of common_section * build_section * executable + | Flag of common_section * flag + | SrcRepo of common_section * source_repository + | Test of common_section * test + | Doc of common_section * doc + + + type section_kind = + [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + + type package = + { + oasis_version: OASISVersion.t; + ocaml_version: OASISVersion.comparator option; + findlib_version: OASISVersion.comparator option; + name: package_name; + version: OASISVersion.t; + license: OASISLicense.t; + license_file: unix_filename option; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: string option; + categories: url list; + + conf_type: [`Configure] plugin; + conf_custom: custom; + + build_type: [`Build] plugin; + build_custom: custom; + + install_type: [`Install] plugin; + install_custom: custom; + uninstall_custom: custom; + + clean_custom: custom; + distclean_custom: custom; + + files_ab: unix_filename list; + sections: section list; + plugins: [`Extra] plugin list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } + +end + +module OASISUnixPath = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISUnixPath.ml" + + type unix_filename = string + type unix_dirname = string + + type host_filename = string + type host_dirname = string + + let current_dir_name = "." + + let parent_dir_name = ".." + + let is_current_dir fn = + fn = current_dir_name || fn = "" + + let concat f1 f2 = + if is_current_dir f1 then + f2 + else + let f1' = + try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 + in + f1'^"/"^f2 + + let make = + function + | hd :: tl -> + List.fold_left + (fun f p -> concat f p) + hd + tl + | [] -> + invalid_arg "OASISUnixPath.make" + + let dirname f = + try + String.sub f 0 (String.rindex f '/') + with Not_found -> + current_dir_name + + let basename f = + try + let pos_start = + (String.rindex f '/') + 1 + in + String.sub f pos_start ((String.length f) - pos_start) + with Not_found -> + f + + let chop_extension f = + try + let last_dot = + String.rindex f '.' + in + let sub = + String.sub f 0 last_dot + in + try + let last_slash = + String.rindex f '/' + in + if last_slash < last_dot then + sub + else + f + with Not_found -> + sub + + with Not_found -> + f + + let capitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.capitalize base) + + let uncapitalize_file f = + let dir = dirname f in + let base = basename f in + concat dir (String.uncapitalize base) + +end + +module OASISHostPath = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISHostPath.ml" + + + open Filename + + module Unix = OASISUnixPath + + let make = + function + | [] -> + invalid_arg "OASISHostPath.make" + | hd :: tl -> + List.fold_left Filename.concat hd tl + + let of_unix ufn = + if Sys.os_type = "Unix" then + ufn + else + make + (List.map + (fun p -> + if p = Unix.current_dir_name then + current_dir_name + else if p = Unix.parent_dir_name then + parent_dir_name + else + p) + (OASISString.nsplit ufn '/')) + + +end + +module OASISSection = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISSection.ml" + + open OASISTypes + + let section_kind_common = + function + | Library (cs, _, _) -> + `Library, cs + | Executable (cs, _, _) -> + `Executable, cs + | Flag (cs, _) -> + `Flag, cs + | SrcRepo (cs, _) -> + `SrcRepo, cs + | Test (cs, _) -> + `Test, cs + | Doc (cs, _) -> + `Doc, cs + + let section_common sct = + snd (section_kind_common sct) + + let section_common_set cs = + function + | Library (_, bs, lib) -> Library (cs, bs, lib) + | Executable (_, bs, exec) -> Executable (cs, bs, exec) + | Flag (_, flg) -> Flag (cs, flg) + | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) + | Test (_, tst) -> Test (cs, tst) + | Doc (_, doc) -> Doc (cs, doc) + + (** Key used to identify section + *) + let section_id sct = + let k, cs = + section_kind_common sct + in + k, cs.cs_name + + let string_of_section sct = + let k, nm = + section_id sct + in + (match k with + | `Library -> "library" + | `Executable -> "executable" + | `Flag -> "flag" + | `SrcRepo -> "src repository" + | `Test -> "test" + | `Doc -> "doc") + ^" "^nm + + let section_find id scts = + List.find + (fun sct -> id = section_id sct) + scts + + module CSection = + struct + type t = section + + let id = section_id + + let compare t1 t2 = + compare (id t1) (id t2) + + let equal t1 t2 = + (id t1) = (id t2) + + let hash t = + Hashtbl.hash (id t) + end + + module MapSection = Map.Make(CSection) + module SetSection = Set.Make(CSection) + +end + +module OASISBuildSection = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISBuildSection.ml" + +end + +module OASISExecutable = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISExecutable.ml" + + open OASISTypes + + let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = + let dir = + OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.dirname exec.exec_main_is) + in + let is_native_exec = + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native () + | Byte -> false + in + + OASISUnixPath.concat + dir + (cs.cs_name^(suffix_program ())), + + if not is_native_exec && + not exec.exec_custom && + bs.bs_c_sources <> [] then + Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) + else + None + +end + +module OASISLibrary = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISLibrary.ml" + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + type library_name = name + type findlib_part_name = name + type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t + + exception InternalLibraryNotFound of library_name + exception FindlibPackageNotFound of findlib_name + + type group_t = + | Container of findlib_name * group_t list + | Package of (findlib_name * + common_section * + build_section * + library * + group_t list) + + (* Look for a module file, considering capitalization or not. *) + let find_module source_file_exists (cs, bs, lib) modul = + let possible_base_fn = + List.map + (OASISUnixPath.concat bs.bs_path) + [modul; + OASISUnixPath.uncapitalize_file modul; + OASISUnixPath.capitalize_file modul] + in + (* TODO: we should be able to be able to determine the source for every + * files. Hence we should introduce a Module(source: fn) for the fields + * Modules and InternalModules + *) + List.fold_left + (fun acc base_fn -> + match acc with + | `No_sources _ -> + begin + let file_found = + List.fold_left + (fun acc ext -> + if source_file_exists (base_fn^ext) then + (base_fn^ext) :: acc + else + acc) + [] + [".ml"; ".mli"; ".mll"; ".mly"] + in + match file_found with + | [] -> + acc + | lst -> + `Sources (base_fn, lst) + end + | `Sources _ -> + acc) + (`No_sources possible_base_fn) + possible_base_fn + + let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = + List.fold_left + (fun acc modul -> + match find_module source_file_exists (cs, bs, lib) modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + acc) + [] + (lib.lib_modules @ lib.lib_internal_modules) + + let generated_unix_files + ~ctxt + ~is_native + ~has_native_dynlink + ~ext_lib + ~ext_dll + ~source_file_exists + (cs, bs, lib) = + + let find_modules lst ext = + let find_module modul = + match find_module source_file_exists (cs, bs, lib) modul with + | `Sources (base_fn, _) -> + [base_fn] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + lst + in + List.map + (fun nm -> + List.map + (fun base_fn -> base_fn ^"."^ext) + (find_module nm)) + lst + in + + (* The headers that should be compiled along *) + let headers = + if lib.lib_pack then + [] + else + find_modules + lib.lib_modules + "cmi" + in + + (* The .cmx that be compiled along *) + let cmxs = + let should_be_built = + (not lib.lib_pack) && (* Do not install .cmx packed submodules *) + match bs.bs_compiled_object with + | Native -> true + | Best -> is_native + | Byte -> false + in + if should_be_built then + find_modules + (lib.lib_modules @ lib.lib_internal_modules) + "cmx" + else + [] + in + + let acc_nopath = + [] + in + + (* Compute what libraries should be built *) + let acc_nopath = + (* Add the packed header file if required *) + let add_pack_header acc = + if lib.lib_pack then + [cs.cs_name^".cmi"] :: acc + else + acc + in + let byte acc = + add_pack_header ([cs.cs_name^".cma"] :: acc) + in + let native acc = + let acc = + add_pack_header + (if has_native_dynlink then + [cs.cs_name^".cmxs"] :: acc + else acc) + in + [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc + in + match bs.bs_compiled_object with + | Native -> + byte (native acc_nopath) + | Best when is_native -> + byte (native acc_nopath) + | Byte | Best -> + byte acc_nopath + in + + (* Add C library to be built *) + let acc_nopath = + if bs.bs_c_sources <> [] then + begin + ["lib"^cs.cs_name^"_stubs"^ext_lib] + :: + ["dll"^cs.cs_name^"_stubs"^ext_dll] + :: + acc_nopath + end + else + acc_nopath + in + + (* All the files generated *) + List.rev_append + (List.rev_map + (List.rev_map + (OASISUnixPath.concat bs.bs_path)) + acc_nopath) + (headers @ cmxs) + + type data = common_section * build_section * library + type tree = + | Node of (data option) * (tree MapString.t) + | Leaf of data + + let findlib_mapping pkg = + (* Map from library name to either full findlib name or parts + parent. *) + let fndlb_parts_of_lib_name = + let fndlb_parts cs lib = + let name = + match lib.lib_findlib_name with + | Some nm -> nm + | None -> cs.cs_name + in + let name = + String.concat "." (lib.lib_findlib_containers @ [name]) + in + name + in + List.fold_left + (fun mp -> + function + | Library (cs, _, lib) -> + begin + let lib_name = cs.cs_name in + let fndlb_parts = fndlb_parts cs lib in + if MapString.mem lib_name mp then + failwithf + (f_ "The library name '%s' is used more than once.") + lib_name; + match lib.lib_findlib_parent with + | Some lib_name_parent -> + MapString.add + lib_name + (`Unsolved (lib_name_parent, fndlb_parts)) + mp + | None -> + MapString.add + lib_name + (`Solved fndlb_parts) + mp + end + + | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> + mp) + MapString.empty + pkg.sections + in + + (* Solve the above graph to be only library name to full findlib name. *) + let fndlb_name_of_lib_name = + let rec solve visited mp lib_name lib_name_child = + if SetString.mem lib_name visited then + failwithf + (f_ "Library '%s' is involved in a cycle \ + with regard to findlib naming.") + lib_name; + let visited = SetString.add lib_name visited in + try + match MapString.find lib_name mp with + | `Solved fndlb_nm -> + fndlb_nm, mp + | `Unsolved (lib_nm_parent, post_fndlb_nm) -> + let pre_fndlb_nm, mp = + solve visited mp lib_nm_parent lib_name + in + let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in + fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp + with Not_found -> + failwithf + (f_ "Library '%s', which is defined as the findlib parent of \ + library '%s', doesn't exist.") + lib_name lib_name_child + in + let mp = + MapString.fold + (fun lib_name status mp -> + match status with + | `Solved _ -> + (* Solved initialy, no need to go further *) + mp + | `Unsolved _ -> + let _, mp = solve SetString.empty mp lib_name "<none>" in + mp) + fndlb_parts_of_lib_name + fndlb_parts_of_lib_name + in + MapString.map + (function + | `Solved fndlb_nm -> fndlb_nm + | `Unsolved _ -> assert false) + mp + in + + (* Convert an internal library name to a findlib name. *) + let findlib_name_of_library_name lib_nm = + try + MapString.find lib_nm fndlb_name_of_lib_name + with Not_found -> + raise (InternalLibraryNotFound lib_nm) + in + + (* Add a library to the tree. + *) + let add sct mp = + let fndlb_fullname = + let cs, _, _ = sct in + let lib_name = cs.cs_name in + findlib_name_of_library_name lib_name + in + let rec add_children nm_lst (children : tree MapString.t) = + match nm_lst with + | (hd :: tl) -> + begin + let node = + try + add_node tl (MapString.find hd children) + with Not_found -> + (* New node *) + new_node tl + in + MapString.add hd node children + end + | [] -> + (* Should not have a nameless library. *) + assert false + and add_node tl node = + if tl = [] then + begin + match node with + | Node (None, children) -> + Node (Some sct, children) + | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> + (* TODO: allow to merge Package, i.e. + * archive(byte) = "foo.cma foo_init.cmo" + *) + let cs, _, _ = sct in + failwithf + (f_ "Library '%s' and '%s' have the same findlib name '%s'") + cs.cs_name cs'.cs_name fndlb_fullname + end + else + begin + match node with + | Leaf data -> + Node (Some data, add_children tl MapString.empty) + | Node (data_opt, children) -> + Node (data_opt, add_children tl children) + end + and new_node = + function + | [] -> + Leaf sct + | hd :: tl -> + Node (None, MapString.add hd (new_node tl) MapString.empty) + in + add_children (OASISString.nsplit fndlb_fullname '.') mp + in + + let rec group_of_tree mp = + MapString.fold + (fun nm node acc -> + let cur = + match node with + | Node (Some (cs, bs, lib), children) -> + Package (nm, cs, bs, lib, group_of_tree children) + | Node (None, children) -> + Container (nm, group_of_tree children) + | Leaf (cs, bs, lib) -> + Package (nm, cs, bs, lib, []) + in + cur :: acc) + mp [] + in + + let group_mp = + List.fold_left + (fun mp -> + function + | Library (cs, bs, lib) -> + add (cs, bs, lib) mp + | _ -> + mp) + MapString.empty + pkg.sections + in + + let groups = + group_of_tree group_mp + in + + let library_name_of_findlib_name = + Lazy.lazy_from_fun + (fun () -> + (* Revert findlib_name_of_library_name. *) + MapString.fold + (fun k v mp -> MapString.add v k mp) + fndlb_name_of_lib_name + MapString.empty) + in + let library_name_of_findlib_name fndlb_nm = + try + MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) + with Not_found -> + raise (FindlibPackageNotFound fndlb_nm) + in + + groups, + findlib_name_of_library_name, + library_name_of_findlib_name + + let findlib_of_group = + function + | Container (fndlb_nm, _) + | Package (fndlb_nm, _, _, _, _) -> fndlb_nm + + let root_of_group grp = + let rec root_lib_aux = + (* We do a DFS in the group. *) + function + | Container (_, children) -> + List.fold_left + (fun res grp -> + if res = None then + root_lib_aux grp + else + res) + None + children + | Package (_, cs, bs, lib, _) -> + Some (cs, bs, lib) + in + match root_lib_aux grp with + | Some res -> + res + | None -> + failwithf + (f_ "Unable to determine root library of findlib library '%s'") + (findlib_of_group grp) + +end + +module OASISFlag = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISFlag.ml" + +end + +module OASISPackage = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISPackage.ml" + +end + +module OASISSourceRepository = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISSourceRepository.ml" + +end + +module OASISTest = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISTest.ml" + +end + +module OASISDocument = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISDocument.ml" + +end + +module OASISExec = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISExec.ml" + + open OASISGettext + open OASISUtils + open OASISMessage + + (* TODO: I don't like this quote, it is there because $(rm) foo expands to + * 'rm -f' foo... + *) + let run ~ctxt ?f_exit_code ?(quote=true) cmd args = + let cmd = + if quote then + if Sys.os_type = "Win32" then + if String.contains cmd ' ' then + (* Double the 1st double quote... win32... sigh *) + "\""^(Filename.quote cmd) + else + cmd + else + Filename.quote cmd + else + cmd + in + let cmdline = + String.concat " " (cmd :: args) + in + info ~ctxt (f_ "Running command '%s'") cmdline; + match f_exit_code, Sys.command cmdline with + | None, 0 -> () + | None, i -> + failwithf + (f_ "Command '%s' terminated with error code %d") + cmdline i + | Some f, i -> + f i + + let run_read_output ~ctxt ?f_exit_code cmd args = + let fn = + Filename.temp_file "oasis-" ".txt" + in + try + begin + let () = + run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) + in + let chn = + open_in fn + in + let routput = + ref [] + in + begin + try + while true do + routput := (input_line chn) :: !routput + done + with End_of_file -> + () + end; + close_in chn; + Sys.remove fn; + List.rev !routput + end + with e -> + (try Sys.remove fn with _ -> ()); + raise e + + let run_read_one_line ~ctxt ?f_exit_code cmd args = + match run_read_output ~ctxt ?f_exit_code cmd args with + | [fst] -> + fst + | lst -> + failwithf + (f_ "Command return unexpected output %S") + (String.concat "\n" lst) +end + +module OASISFileUtil = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/oasis/OASISFileUtil.ml" + + open OASISGettext + + let file_exists_case fn = + let dirname = Filename.dirname fn in + let basename = Filename.basename fn in + if Sys.file_exists dirname then + if basename = Filename.current_dir_name then + true + else + List.mem + basename + (Array.to_list (Sys.readdir dirname)) + else + false + + let find_file ?(case_sensitive=true) paths exts = + + (* Cardinal product of two list *) + let ( * ) lst1 lst2 = + List.flatten + (List.map + (fun a -> + List.map + (fun b -> a,b) + lst2) + lst1) + in + + let rec combined_paths lst = + match lst with + | p1 :: p2 :: tl -> + let acc = + (List.map + (fun (a,b) -> Filename.concat a b) + (p1 * p2)) + in + combined_paths (acc :: tl) + | [e] -> + e + | [] -> + [] + in + + let alternatives = + List.map + (fun (p,e) -> + if String.length e > 0 && e.[0] <> '.' then + p ^ "." ^ e + else + p ^ e) + ((combined_paths paths) * exts) + in + List.find + (if case_sensitive then + file_exists_case + else + Sys.file_exists) + alternatives + + let which ~ctxt prg = + let path_sep = + match Sys.os_type with + | "Win32" -> + ';' + | _ -> + ':' + in + let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in + let exec_ext = + match Sys.os_type with + | "Win32" -> + "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) + | _ -> + [""] + in + find_file ~case_sensitive:false [path_lst; [prg]] exec_ext + + (**/**) + let rec fix_dir dn = + (* Windows hack because Sys.file_exists "src\\" = false when + * Sys.file_exists "src" = true + *) + let ln = + String.length dn + in + if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then + fix_dir (String.sub dn 0 (ln - 1)) + else + dn + + let q = Filename.quote + (**/**) + + let cp ~ctxt ?(recurse=false) src tgt = + if recurse then + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt + "xcopy" [q src; q tgt; "/E"] + | _ -> + OASISExec.run ~ctxt + "cp" ["-r"; q src; q tgt] + else + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "copy" + | _ -> "cp") + [q src; q tgt] + + let mkdir ~ctxt tgt = + OASISExec.run ~ctxt + (match Sys.os_type with + | "Win32" -> "md" + | _ -> "mkdir") + [q tgt] + + let rec mkdir_parent ~ctxt f tgt = + let tgt = + fix_dir tgt + in + if Sys.file_exists tgt then + begin + if not (Sys.is_directory tgt) then + OASISUtils.failwithf + (f_ "Cannot create directory '%s', a file of the same name already \ + exists") + tgt + end + else + begin + mkdir_parent ~ctxt f (Filename.dirname tgt); + if not (Sys.file_exists tgt) then + begin + f tgt; + mkdir ~ctxt tgt + end + end + + let rmdir ~ctxt tgt = + if Sys.readdir tgt = [||] then + begin + match Sys.os_type with + | "Win32" -> + OASISExec.run ~ctxt "rd" [q tgt] + | _ -> + OASISExec.run ~ctxt "rm" ["-r"; q tgt] + end + + let glob ~ctxt fn = + let basename = + Filename.basename fn + in + if String.length basename >= 2 && + basename.[0] = '*' && + basename.[1] = '.' then + begin + let ext_len = + (String.length basename) - 2 + in + let ext = + String.sub basename 2 ext_len + in + let dirname = + Filename.dirname fn + in + Array.fold_left + (fun acc fn -> + try + let fn_ext = + String.sub + fn + ((String.length fn) - ext_len) + ext_len + in + if fn_ext = ext then + (Filename.concat dirname fn) :: acc + else + acc + with Invalid_argument _ -> + acc) + [] + (Sys.readdir dirname) + end + else + begin + if file_exists_case fn then + [fn] + else + [] + end +end + + +# 2142 "setup.ml" +module BaseEnvLight = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseEnvLight.ml" + + module MapString = Map.Make(String) + + type t = string MapString.t + + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" + + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin + MapString.empty + end + else + begin + failwith + (Printf.sprintf + "Unable to load environment, the file '%s' doesn't exist." + filename) + end + + let var_get name env = + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + in + var_expand (MapString.find name env) + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst +end + + +# 2240 "setup.ml" +module BaseContext = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseContext.ml" + + open OASISContext + + let args = args + + let default = default + +end + +module BaseMessage = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseMessage.ml" + + (** Message to user, overrid for Base + @author Sylvain Le Gall + *) + open OASISMessage + open BaseContext + + let debug fmt = debug ~ctxt:!default fmt + + let info fmt = info ~ctxt:!default fmt + + let warning fmt = warning ~ctxt:!default fmt + + let error fmt = error ~ctxt:!default fmt + +end + +module BaseEnv = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseEnv.ml" + + open OASISGettext + open OASISUtils + open PropList + + module MapString = BaseEnvLight.MapString + + type origin_t = + | ODefault + | OGetEnv + | OFileLoad + | OCommandLine + + type cli_handle_t = + | CLINone + | CLIAuto + | CLIWith + | CLIEnable + | CLIUser of (Arg.key * Arg.spec * Arg.doc) list + + type definition_t = + { + hide: bool; + dump: bool; + cli: cli_handle_t; + arg_help: string option; + group: string option; + } + + let schema = + Schema.create "environment" + + (* Environment data *) + let env = + Data.create () + + (* Environment data from file *) + let env_from_file = + ref MapString.empty + + (* Lexer for var *) + let var_lxr = + Genlex.make_lexer [] + + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + (* TODO: this is a quick hack to allow calling Test.Command + * without defining executable name really. I.e. if there is + * an exec Executable toto, then $(toto) should be replace + * by its real name. It is however useful to have this function + * for other variable that depend on the host and should be + * written better than that. + *) + let st = + var_lxr (Stream.of_string var) + in + match Stream.npeek 3 st with + | [Genlex.Ident "utoh"; Genlex.Ident nm] -> + OASISHostPath.of_unix (var_get nm) + | [Genlex.Ident "utoh"; Genlex.String s] -> + OASISHostPath.of_unix s + | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> + String.escaped (var_get nm) + | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> + String.escaped s + | [Genlex.Ident nm] -> + var_get nm + | _ -> + failwithf + (f_ "Unknown expression '%s' in variable expansion of %s.") + var + str + with + | Unknown_field (_, _) -> + failwithf + (f_ "No variable %s defined when trying to expand %S.") + var + str + | Stream.Error e -> + failwithf + (f_ "Syntax error when parsing '%s' when trying to \ + expand %S: %s") + var + str + e) + str; + Buffer.contents buff + + and var_get name = + let vl = + try + Schema.get schema env name + with Unknown_field _ as e -> + begin + try + MapString.find name !env_from_file + with Not_found -> + raise e + end + in + var_expand vl + + let var_choose ?printer ?name lst = + OASISExpr.choose + ?printer + ?name + var_get + lst + + let var_protect vl = + let buff = + Buffer.create (String.length vl) + in + String.iter + (function + | '$' -> Buffer.add_string buff "\\$" + | c -> Buffer.add_char buff c) + vl; + Buffer.contents buff + + let var_define + ?(hide=false) + ?(dump=true) + ?short_desc + ?(cli=CLINone) + ?arg_help + ?group + name (* TODO: type constraint on the fact that name must be a valid OCaml + id *) + dflt = + + let default = + [ + OFileLoad, (fun () -> MapString.find name !env_from_file); + ODefault, dflt; + OGetEnv, (fun () -> Sys.getenv name); + ] + in + + let extra = + { + hide = hide; + dump = dump; + cli = cli; + arg_help = arg_help; + group = group; + } + in + + (* Try to find a value that can be defined + *) + let var_get_low lst = + let errors, res = + List.fold_left + (fun (errors, res) (o, v) -> + if res = None then + begin + try + errors, Some (v ()) + with + | Not_found -> + errors, res + | Failure rsn -> + (rsn :: errors), res + | e -> + (Printexc.to_string e) :: errors, res + end + else + errors, res) + ([], None) + (List.sort + (fun (o1, _) (o2, _) -> + Pervasives.compare o2 o1) + lst) + in + match res, errors with + | Some v, _ -> + v + | None, [] -> + raise (Not_set (name, None)) + | None, lst -> + raise (Not_set (name, Some (String.concat (s_ ", ") lst))) + in + + let help = + match short_desc with + | Some fs -> Some fs + | None -> None + in + + let var_get_lst = + FieldRO.create + ~schema + ~name + ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) + ~print:var_get_low + ~default + ~update:(fun ?context x old_x -> x @ old_x) + ?help + extra + in + + fun () -> + var_expand (var_get_low (var_get_lst env)) + + let var_redefine + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt = + if Schema.mem schema name then + begin + (* TODO: look suspsicious, we want to memorize dflt not dflt () *) + Schema.set schema env ~context:ODefault name (dflt ()); + fun () -> var_get name + end + else + begin + var_define + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt + end + + let var_ignore (e : unit -> string) = + () + + let print_hidden = + var_define + ~hide:true + ~dump:false + ~cli:CLIAuto + ~arg_help:"Print even non-printable variable. (debug)" + "print_hidden" + (fun () -> "false") + + let var_all () = + List.rev + (Schema.fold + (fun acc nm def _ -> + if not def.hide || bool_of_string (print_hidden ()) then + nm :: acc + else + acc) + [] + schema) + + let default_filename = + BaseEnvLight.default_filename + + let load ?allow_empty ?filename () = + env_from_file := BaseEnvLight.load ?allow_empty ?filename () + + let unload () = + env_from_file := MapString.empty; + Data.clear env + + let dump ?(filename=default_filename) () = + let chn = + open_out_bin filename + in + let output nm value = + Printf.fprintf chn "%s=%S\n" nm value + in + let mp_todo = + (* Dump data from schema *) + Schema.fold + (fun mp_todo nm def _ -> + if def.dump then + begin + try + let value = + Schema.get + schema + env + nm + in + output nm value + with Not_set _ -> + () + end; + MapString.remove nm mp_todo) + !env_from_file + schema + in + (* Dump data defined outside of schema *) + MapString.iter output mp_todo; + + (* End of the dump *) + close_out chn + + let print () = + let printable_vars = + Schema.fold + (fun acc nm def short_descr_opt -> + if not def.hide || bool_of_string (print_hidden ()) then + begin + try + let value = + Schema.get + schema + env + nm + in + let txt = + match short_descr_opt with + | Some s -> s () + | None -> nm + in + (txt, value) :: acc + with Not_set _ -> + acc + end + else + acc) + [] + schema + in + let max_length = + List.fold_left max 0 + (List.rev_map String.length + (List.rev_map fst printable_vars)) + in + let dot_pad str = + String.make ((max_length - (String.length str)) + 3) '.' + in + + Printf.printf "\nConfiguration: \n"; + List.iter + (fun (name,value) -> + Printf.printf "%s: %s %s\n" name (dot_pad name) value) + (List.rev printable_vars); + Printf.printf "\n%!" + + let args () = + let arg_concat = + OASISUtils.varname_concat ~hyphen:'-' + in + [ + "--override", + Arg.Tuple + ( + let rvr = ref "" + in + let rvl = ref "" + in + [ + Arg.Set_string rvr; + Arg.Set_string rvl; + Arg.Unit + (fun () -> + Schema.set + schema + env + ~context:OCommandLine + !rvr + !rvl) + ] + ), + "var+val Override any configuration variable."; + + ] + @ + List.flatten + (Schema.fold + (fun acc name def short_descr_opt -> + let var_set s = + Schema.set + schema + env + ~context:OCommandLine + name + s + in + + let arg_name = + OASISUtils.varname_of_string ~hyphen:'-' name + in + + let hlp = + match short_descr_opt with + | Some txt -> txt () + | None -> "" + in + + let arg_hlp = + match def.arg_help with + | Some s -> s + | None -> "str" + in + + let default_value = + try + Printf.sprintf + (f_ " [%s]") + (Schema.get + schema + env + name) + with Not_set _ -> + "" + in + + let args = + match def.cli with + | CLINone -> + [] + | CLIAuto -> + [ + arg_concat "--" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIWith -> + [ + arg_concat "--with-" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIEnable -> + let dflt = + if default_value = " [true]" then + s_ " [default: enabled]" + else + s_ " [default: disabled]" + in + [ + arg_concat "--enable-" arg_name, + Arg.Unit (fun () -> var_set "true"), + Printf.sprintf (f_ " %s%s") hlp dflt; + + arg_concat "--disable-" arg_name, + Arg.Unit (fun () -> var_set "false"), + Printf.sprintf (f_ " %s%s") hlp dflt + ] + | CLIUser lst -> + lst + in + args :: acc) + [] + schema) +end + +module BaseArgExt = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseArgExt.ml" + + open OASISUtils + open OASISGettext + + let parse argv args = + (* Simulate command line for Arg *) + let current = + ref 0 + in + + try + Arg.parse_argv + ~current:current + (Array.concat [[|"none"|]; argv]) + (Arg.align args) + (failwithf (f_ "Don't know what to do with arguments: '%s'")) + (s_ "configure options:") + with + | Arg.Help txt -> + print_endline txt; + exit 0 + | Arg.Bad txt -> + prerr_endline txt; + exit 1 +end + +module BaseCheck = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseCheck.ml" + + open BaseEnv + open BaseMessage + open OASISUtils + open OASISGettext + + let prog_best prg prg_lst = + var_redefine + prg + (fun () -> + let alternate = + List.fold_left + (fun res e -> + match res with + | Some _ -> + res + | None -> + try + Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) + with Not_found -> + None) + None + prg_lst + in + match alternate with + | Some prg -> prg + | None -> raise Not_found) + + let prog prg = + prog_best prg [prg] + + let prog_opt prg = + prog_best prg [prg^".opt"; prg] + + let ocamlfind = + prog "ocamlfind" + + let version + var_prefix + cmp + fversion + () = + (* Really compare version provided *) + let var = + var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) + in + var_redefine + ~hide:true + var + (fun () -> + let version_str = + match fversion () with + | "[Distributed with OCaml]" -> + begin + try + (var_get "ocaml_version") + with Not_found -> + warning + (f_ "Variable ocaml_version not defined, fallback \ + to default"); + Sys.ocaml_version + end + | res -> + res + in + let version = + OASISVersion.version_of_string version_str + in + if OASISVersion.comparator_apply version cmp then + version_str + else + failwithf + (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") + var_prefix + (OASISVersion.string_of_comparator cmp) + version_str) + () + + let package_version pkg = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%v"; pkg] + + let package ?version_comparator pkg () = + let var = + OASISUtils.varname_concat + "pkg_" + (OASISUtils.varname_of_string pkg) + in + let findlib_dir pkg = + let dir = + OASISExec.run_read_one_line ~ctxt:!BaseContext.default + (ocamlfind ()) + ["query"; "-format"; "%d"; pkg] + in + if Sys.file_exists dir && Sys.is_directory dir then + dir + else + failwithf + (f_ "When looking for findlib package %s, \ + directory %s return doesn't exist") + pkg dir + in + let vl = + var_redefine + var + (fun () -> findlib_dir pkg) + () + in + ( + match version_comparator with + | Some ver_cmp -> + ignore + (version + var + ver_cmp + (fun _ -> package_version pkg) + ()) + | None -> + () + ); + vl +end + +module BaseOCamlcConfig = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseOCamlcConfig.ml" + + + open BaseEnv + open OASISUtils + open OASISGettext + + module SMap = Map.Make(String) + + let ocamlc = + BaseCheck.prog_opt "ocamlc" + + let ocamlc_config_map = + (* Map name to value for ocamlc -config output + (name ^": "^value) + *) + let rec split_field mp lst = + match lst with + | line :: tl -> + let mp = + try + let pos_semicolon = + String.index line ':' + in + if pos_semicolon > 1 then + ( + let name = + String.sub line 0 pos_semicolon + in + let linelen = + String.length line + in + let value = + if linelen > pos_semicolon + 2 then + String.sub + line + (pos_semicolon + 2) + (linelen - pos_semicolon - 2) + else + "" + in + SMap.add name value mp + ) + else + ( + mp + ) + with Not_found -> + ( + mp + ) + in + split_field mp tl + | [] -> + mp + in + + let cache = + lazy + (var_protect + (Marshal.to_string + (split_field + SMap.empty + (OASISExec.run_read_output + ~ctxt:!BaseContext.default + (ocamlc ()) ["-config"])) + [])) + in + var_redefine + "ocamlc_config_map" + ~hide:true + ~dump:false + (fun () -> + (* TODO: update if ocamlc change !!! *) + Lazy.force cache) + + let var_define nm = + (* Extract data from ocamlc -config *) + let avlbl_config_get () = + Marshal.from_string + (ocamlc_config_map ()) + 0 + in + let chop_version_suffix s = + try + String.sub s 0 (String.index s '+') + with _ -> + s + in + + let nm_config, value_config = + match nm with + | "ocaml_version" -> + "version", chop_version_suffix + | _ -> nm, (fun x -> x) + in + var_redefine + nm + (fun () -> + try + let map = + avlbl_config_get () + in + let value = + SMap.find nm_config map + in + value_config value + with Not_found -> + failwithf + (f_ "Cannot find field '%s' in '%s -config' output") + nm + (ocamlc ())) + +end + +module BaseStandardVar = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseStandardVar.ml" + + + open OASISGettext + open OASISTypes + open OASISExpr + open BaseCheck + open BaseEnv + + let ocamlfind = BaseCheck.ocamlfind + let ocamlc = BaseOCamlcConfig.ocamlc + let ocamlopt = prog_opt "ocamlopt" + let ocamlbuild = prog "ocamlbuild" + + + (**/**) + let rpkg = + ref None + + let pkg_get () = + match !rpkg with + | Some pkg -> pkg + | None -> failwith (s_ "OASIS Package is not set") + + let var_cond = ref [] + + let var_define_cond ~since_version f dflt = + let holder = ref (fun () -> dflt) in + let since_version = + OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) + in + var_cond := + (fun ver -> + if OASISVersion.comparator_apply ver since_version then + holder := f ()) :: !var_cond; + fun () -> !holder () + + (**/**) + + let pkg_name = + var_define + ~short_desc:(fun () -> s_ "Package name") + "pkg_name" + (fun () -> (pkg_get ()).name) + + let pkg_version = + var_define + ~short_desc:(fun () -> s_ "Package version") + "pkg_version" + (fun () -> + (OASISVersion.string_of_version (pkg_get ()).version)) + + let c = BaseOCamlcConfig.var_define + + let os_type = c "os_type" + let system = c "system" + let architecture = c "architecture" + let ccomp_type = c "ccomp_type" + let ocaml_version = c "ocaml_version" + + (* TODO: Check standard variable presence at runtime *) + + let standard_library_default = c "standard_library_default" + let standard_library = c "standard_library" + let standard_runtime = c "standard_runtime" + let bytecomp_c_compiler = c "bytecomp_c_compiler" + let native_c_compiler = c "native_c_compiler" + let model = c "model" + let ext_obj = c "ext_obj" + let ext_asm = c "ext_asm" + let ext_lib = c "ext_lib" + let ext_dll = c "ext_dll" + let default_executable_name = c "default_executable_name" + let systhread_supported = c "systhread_supported" + + let flexlink = + BaseCheck.prog "flexlink" + + let flexdll_version = + var_define + ~short_desc:(fun () -> "FlexDLL version (Win32)") + "flexdll_version" + (fun () -> + let lst = + OASISExec.run_read_output ~ctxt:!BaseContext.default + (flexlink ()) ["-help"] + in + match lst with + | line :: _ -> + Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) + | [] -> + raise Not_found) + + (**/**) + let p name hlp dflt = + var_define + ~short_desc:hlp + ~cli:CLIAuto + ~arg_help:"dir" + name + dflt + + let (/) a b = + if os_type () = Sys.os_type then + Filename.concat a b + else if os_type () = "Unix" then + OASISUnixPath.concat a b + else + OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") + (os_type ()) + (**/**) + + let prefix = + p "prefix" + (fun () -> s_ "Install architecture-independent files dir") + (fun () -> + match os_type () with + | "Win32" -> + let program_files = + Sys.getenv "PROGRAMFILES" + in + program_files/(pkg_name ()) + | _ -> + "/usr/local") + + let exec_prefix = + p "exec_prefix" + (fun () -> s_ "Install architecture-dependent files in dir") + (fun () -> "$prefix") + + let bindir = + p "bindir" + (fun () -> s_ "User executables") + (fun () -> "$exec_prefix"/"bin") + + let sbindir = + p "sbindir" + (fun () -> s_ "System admin executables") + (fun () -> "$exec_prefix"/"sbin") + + let libexecdir = + p "libexecdir" + (fun () -> s_ "Program executables") + (fun () -> "$exec_prefix"/"libexec") + + let sysconfdir = + p "sysconfdir" + (fun () -> s_ "Read-only single-machine data") + (fun () -> "$prefix"/"etc") + + let sharedstatedir = + p "sharedstatedir" + (fun () -> s_ "Modifiable architecture-independent data") + (fun () -> "$prefix"/"com") + + let localstatedir = + p "localstatedir" + (fun () -> s_ "Modifiable single-machine data") + (fun () -> "$prefix"/"var") + + let libdir = + p "libdir" + (fun () -> s_ "Object code libraries") + (fun () -> "$exec_prefix"/"lib") + + let datarootdir = + p "datarootdir" + (fun () -> s_ "Read-only arch-independent data root") + (fun () -> "$prefix"/"share") + + let datadir = + p "datadir" + (fun () -> s_ "Read-only architecture-independent data") + (fun () -> "$datarootdir") + + let infodir = + p "infodir" + (fun () -> s_ "Info documentation") + (fun () -> "$datarootdir"/"info") + + let localedir = + p "localedir" + (fun () -> s_ "Locale-dependent data") + (fun () -> "$datarootdir"/"locale") + + let mandir = + p "mandir" + (fun () -> s_ "Man documentation") + (fun () -> "$datarootdir"/"man") + + let docdir = + p "docdir" + (fun () -> s_ "Documentation root") + (fun () -> "$datarootdir"/"doc"/"$pkg_name") + + let htmldir = + p "htmldir" + (fun () -> s_ "HTML documentation") + (fun () -> "$docdir") + + let dvidir = + p "dvidir" + (fun () -> s_ "DVI documentation") + (fun () -> "$docdir") + + let pdfdir = + p "pdfdir" + (fun () -> s_ "PDF documentation") + (fun () -> "$docdir") + + let psdir = + p "psdir" + (fun () -> s_ "PS documentation") + (fun () -> "$docdir") + + let destdir = + p "destdir" + (fun () -> s_ "Prepend a path when installing package") + (fun () -> + raise + (PropList.Not_set + ("destdir", + Some (s_ "undefined by construct")))) + + let findlib_version = + var_define + "findlib_version" + (fun () -> + BaseCheck.package_version "findlib") + + let is_native = + var_define + "is_native" + (fun () -> + try + let _s : string = + ocamlopt () + in + "true" + with PropList.Not_set _ -> + let _s : string = + ocamlc () + in + "false") + + let ext_program = + var_define + "suffix_program" + (fun () -> + match os_type () with + | "Win32" -> ".exe" + | _ -> "") + + let rm = + var_define + ~short_desc:(fun () -> s_ "Remove a file.") + "rm" + (fun () -> + match os_type () with + | "Win32" -> "del" + | _ -> "rm -f") + + let rmdir = + var_define + ~short_desc:(fun () -> s_ "Remove a directory.") + "rmdir" + (fun () -> + match os_type () with + | "Win32" -> "rd" + | _ -> "rm -rf") + + let debug = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") + ~cli:CLIEnable + "debug" + (fun () -> "true") + + let profile = + var_define + ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") + ~cli:CLIEnable + "profile" + (fun () -> "false") + + let tests = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> + s_ "Compile tests executable and library and run them") + ~cli:CLIEnable + "tests" + (fun () -> "false")) + "true" + + let docs = + var_define_cond ~since_version:"0.3" + (fun () -> + var_define + ~short_desc:(fun () -> s_ "Create documentations") + ~cli:CLIEnable + "docs" + (fun () -> "true")) + "true" + + let native_dynlink = + var_define + ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") + ~cli:CLINone + "native_dynlink" + (fun () -> + let res = + let ocaml_lt_312 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (ocaml_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "3.12.0")) + in + let flexdll_lt_030 () = + OASISVersion.comparator_apply + (OASISVersion.version_of_string (flexdll_version ())) + (OASISVersion.VLesser + (OASISVersion.version_of_string "0.30")) + in + let has_native_dynlink = + let ocamlfind = ocamlfind () in + try + let fn = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ocamlfind + ["query"; "-predicates"; "native"; "dynlink"; + "-format"; "%d/%a"] + in + Sys.file_exists fn + with _ -> + false + in + if not has_native_dynlink then + false + else if ocaml_lt_312 () then + false + else if (os_type () = "Win32" || os_type () = "Cygwin") + && flexdll_lt_030 () then + begin + BaseMessage.warning + (f_ ".cmxs generation disabled because FlexDLL needs to be \ + at least 0.30. Please upgrade FlexDLL from %s to 0.30.") + (flexdll_version ()); + false + end + else + true + in + string_of_bool res) + + let init pkg = + rpkg := Some pkg; + List.iter (fun f -> f pkg.oasis_version) !var_cond + +end + +module BaseFileAB = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseFileAB.ml" + + open BaseEnv + open OASISGettext + open BaseMessage + + let to_filename fn = + let fn = + OASISHostPath.of_unix fn + in + if not (Filename.check_suffix fn ".ab") then + warning + (f_ "File '%s' doesn't have '.ab' extension") + fn; + Filename.chop_extension fn + + let replace fn_lst = + let buff = + Buffer.create 13 + in + List.iter + (fun fn -> + let fn = + OASISHostPath.of_unix fn + in + let chn_in = + open_in fn + in + let chn_out = + open_out (to_filename fn) + in + ( + try + while true do + Buffer.add_string buff (var_expand (input_line chn_in)); + Buffer.add_char buff '\n' + done + with End_of_file -> + () + ); + Buffer.output_buffer chn_out buff; + Buffer.clear buff; + close_in chn_in; + close_out chn_out) + fn_lst +end + +module BaseLog = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseLog.ml" + + open OASISUtils + + let default_filename = + Filename.concat + (Filename.dirname BaseEnv.default_filename) + "setup.log" + + module SetTupleString = + Set.Make + (struct + type t = string * string + let compare (s11, s12) (s21, s22) = + match String.compare s11 s21 with + | 0 -> String.compare s12 s22 + | n -> n + end) + + let load () = + if Sys.file_exists default_filename then + begin + let chn = + open_in default_filename + in + let scbuf = + Scanf.Scanning.from_file default_filename + in + let rec read_aux (st, lst) = + if not (Scanf.Scanning.end_of_input scbuf) then + begin + let acc = + try + Scanf.bscanf scbuf "%S %S\n" + (fun e d -> + let t = + e, d + in + if SetTupleString.mem t st then + st, lst + else + SetTupleString.add t st, + t :: lst) + with Scanf.Scan_failure _ -> + failwith + (Scanf.bscanf scbuf + "%l" + (fun line -> + Printf.sprintf + "Malformed log file '%s' at line %d" + default_filename + line)) + in + read_aux acc + end + else + begin + close_in chn; + List.rev lst + end + in + read_aux (SetTupleString.empty, []) + end + else + begin + [] + end + + let register event data = + let chn_out = + open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename + in + Printf.fprintf chn_out "%S %S\n" event data; + close_out chn_out + + let unregister event data = + if Sys.file_exists default_filename then + begin + let lst = + load () + in + let chn_out = + open_out default_filename + in + let write_something = + ref false + in + List.iter + (fun (e, d) -> + if e <> event || d <> data then + begin + write_something := true; + Printf.fprintf chn_out "%S %S\n" e d + end) + lst; + close_out chn_out; + if not !write_something then + Sys.remove default_filename + end + + let filter events = + let st_events = + List.fold_left + (fun st e -> + SetString.add e st) + SetString.empty + events + in + List.filter + (fun (e, _) -> SetString.mem e st_events) + (load ()) + + let exists event data = + List.exists + (fun v -> (event, data) = v) + (load ()) +end + +module BaseBuilt = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseBuilt.ml" + + open OASISTypes + open OASISGettext + open BaseStandardVar + open BaseMessage + + type t = + | BExec (* Executable *) + | BExecLib (* Library coming with executable *) + | BLib (* Library *) + | BDoc (* Document *) + + let to_log_event_file t nm = + "built_"^ + (match t with + | BExec -> "exec" + | BExecLib -> "exec_lib" + | BLib -> "lib" + | BDoc -> "doc")^ + "_"^nm + + let to_log_event_done t nm = + "is_"^(to_log_event_file t nm) + + let register t nm lst = + BaseLog.register + (to_log_event_done t nm) + "true"; + List.iter + (fun alt -> + let registered = + List.fold_left + (fun registered fn -> + if OASISFileUtil.file_exists_case fn then + begin + BaseLog.register + (to_log_event_file t nm) + (if Filename.is_relative fn then + Filename.concat (Sys.getcwd ()) fn + else + fn); + true + end + else + registered) + false + alt + in + if not registered then + warning + (f_ "Cannot find an existing alternative files among: %s") + (String.concat (s_ ", ") alt)) + lst + + let unregister t nm = + List.iter + (fun (e, d) -> + BaseLog.unregister e d) + (BaseLog.filter + [to_log_event_file t nm; + to_log_event_done t nm]) + + let fold t nm f acc = + List.fold_left + (fun acc (_, fn) -> + if OASISFileUtil.file_exists_case fn then + begin + f acc fn + end + else + begin + warning + (f_ "File '%s' has been marked as built \ + for %s but doesn't exist") + fn + (Printf.sprintf + (match t with + | BExec | BExecLib -> + (f_ "executable %s") + | BLib -> + (f_ "library %s") + | BDoc -> + (f_ "documentation %s")) + nm); + acc + end) + acc + (BaseLog.filter + [to_log_event_file t nm]) + + let is_built t nm = + List.fold_left + (fun is_built (_, d) -> + (try + bool_of_string d + with _ -> + false)) + false + (BaseLog.filter + [to_log_event_done t nm]) + + let of_executable ffn (cs, bs, exec) = + let unix_exec_is, unix_dll_opt = + OASISExecutable.unix_exec_is + (cs, bs, exec) + (fun () -> + bool_of_string + (is_native ())) + ext_dll + ext_program + in + let evs = + (BExec, cs.cs_name, [[ffn unix_exec_is]]) + :: + (match unix_dll_opt with + | Some fn -> + [BExecLib, cs.cs_name, [[ffn fn]]] + | None -> + []) + in + evs, + unix_exec_is, + unix_dll_opt + + let of_library ffn (cs, bs, lib) = + let unix_lst = + OASISLibrary.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + ~has_native_dynlink:(bool_of_string (native_dynlink ())) + ~ext_lib:(ext_lib ()) + ~ext_dll:(ext_dll ()) + (cs, bs, lib) + in + let evs = + [BLib, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + +end + +module BaseCustom = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseCustom.ml" + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + let run cmd args extra_args = + OASISExec.run ~ctxt:!BaseContext.default ~quote:false + (var_expand cmd) + (List.map + var_expand + (args @ (Array.to_list extra_args))) + + let hook ?(failsafe=false) cstm f e = + let optional_command lst = + let printer = + function + | Some (cmd, args) -> String.concat " " (cmd :: args) + | None -> s_ "No command" + in + match + var_choose + ~name:(s_ "Pre/Post Command") + ~printer + lst with + | Some (cmd, args) -> + begin + try + run cmd args [||] + with e when failsafe -> + warning + (f_ "Command '%s' fail with error: %s") + (String.concat " " (cmd :: args)) + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + end + | None -> + () + in + let res = + optional_command cstm.pre_command; + f e + in + optional_command cstm.post_command; + res +end + +module BaseDynVar = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseDynVar.ml" + + + open OASISTypes + open OASISGettext + open BaseEnv + open BaseBuilt + + let init pkg = + (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) + (* TODO: provide compile option for library libary_byte_args_VARNAME... *) + List.iter + (function + | Executable (cs, bs, exec) -> + if var_choose bs.bs_build then + var_ignore + (var_redefine + (* We don't save this variable *) + ~dump:false + ~short_desc:(fun () -> + Printf.sprintf + (f_ "Filename of executable '%s'") + cs.cs_name) + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + let fn_opt = + fold + BExec cs.cs_name + (fun _ fn -> Some fn) + None + in + match fn_opt with + | Some fn -> fn + | None -> + raise + (PropList.Not_set + (cs.cs_name, + Some (Printf.sprintf + (f_ "Executable '%s' not yet built.") + cs.cs_name))))) + + | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + ()) + pkg.sections +end + +module BaseTest = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseTest.ml" + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISExpr + open OASISGettext + + let test lst pkg extra_args = + + let one_test (failure, n) (test_plugin, cs, test) = + if var_choose + ~name:(Printf.sprintf + (f_ "test %s run") + cs.cs_name) + ~printer:string_of_bool + test.test_run then + begin + let () = + info (f_ "Running test '%s'") cs.cs_name + in + let back_cwd = + match test.test_working_directory with + | Some dir -> + let cwd = + Sys.getcwd () + in + let chdir d = + info (f_ "Changing directory to '%s'") d; + Sys.chdir d + in + chdir dir; + fun () -> chdir cwd + + | None -> + fun () -> () + in + try + let failure_percent = + BaseCustom.hook + test.test_custom + (test_plugin pkg (cs, test)) + extra_args + in + back_cwd (); + (failure_percent +. failure, n + 1) + with e -> + begin + back_cwd (); + raise e + end + end + else + begin + info (f_ "Skipping test '%s'") cs.cs_name; + (failure, n) + end + in + let (failed, n) = + List.fold_left + one_test + (0.0, 0) + lst + in + let failure_percent = + if n = 0 then + 0.0 + else + failed /. (float_of_int n) + in + let msg = + Printf.sprintf + (f_ "Tests had a %.2f%% failure rate") + (100. *. failure_percent) + in + if failure_percent > 0.0 then + failwith msg + else + info "%s" msg; + + (* Possible explanation why the tests where not run. *) + if OASISVersion.version_0_3_or_after pkg.oasis_version && + not (bool_of_string (BaseStandardVar.tests ())) && + lst <> [] then + BaseMessage.warning + "Tests are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-tests'" +end + +module BaseDoc = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseDoc.ml" + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISGettext + + let doc lst pkg extra_args = + + let one_doc (doc_plugin, cs, doc) = + if var_choose + ~name:(Printf.sprintf + (f_ "documentation %s build") + cs.cs_name) + ~printer:string_of_bool + doc.doc_build then + begin + info (f_ "Building documentation '%s'") cs.cs_name; + BaseCustom.hook + doc.doc_custom + (doc_plugin pkg (cs, doc)) + extra_args + end + in + List.iter one_doc lst; + + if OASISVersion.version_0_3_or_after pkg.oasis_version && + not (bool_of_string (BaseStandardVar.docs ())) && + lst <> [] then + BaseMessage.warning + "Docs are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-docs'" +end + +module BaseSetup = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/base/BaseSetup.ml" + + open BaseEnv + open BaseMessage + open OASISTypes + open OASISSection + open OASISGettext + open OASISUtils + + type std_args_fun = + package -> string array -> unit + + type ('a, 'b) section_args_fun = + name * (package -> (common_section * 'a) -> string array -> 'b) + + type t = + { + configure: std_args_fun; + build: std_args_fun; + doc: ((doc, unit) section_args_fun) list; + test: ((test, float) section_args_fun) list; + install: std_args_fun; + uninstall: std_args_fun; + clean: std_args_fun list; + clean_doc: (doc, unit) section_args_fun list; + clean_test: (test, unit) section_args_fun list; + distclean: std_args_fun list; + distclean_doc: (doc, unit) section_args_fun list; + distclean_test: (test, unit) section_args_fun list; + package: package; + oasis_fn: string option; + oasis_version: string; + oasis_digest: Digest.t option; + oasis_exec: string option; + oasis_setup_args: string list; + setup_update: bool; + } + + (* Associate a plugin function with data from package *) + let join_plugin_sections filter_map lst = + List.rev + (List.fold_left + (fun acc sct -> + match filter_map sct with + | Some e -> + e :: acc + | None -> + acc) + [] + lst) + + (* Search for plugin data associated with a section name *) + let lookup_plugin_section plugin action nm lst = + try + List.assoc nm lst + with Not_found -> + failwithf + (f_ "Cannot find plugin %s matching section %s for %s action") + plugin + nm + action + + let configure t args = + (* Run configure *) + BaseCustom.hook + t.package.conf_custom + (fun () -> + (* Reload if preconf has changed it *) + begin + try + unload (); + load (); + with _ -> + () + end; + + (* Run plugin's configure *) + t.configure t.package args; + + (* Dump to allow postconf to change it *) + dump ()) + (); + + (* Reload environment *) + unload (); + load (); + + (* Save environment *) + print (); + + (* Replace data in file *) + BaseFileAB.replace t.package.files_ab + + let build t args = + BaseCustom.hook + t.package.build_custom + (t.build t.package) + args + + let doc t args = + BaseDoc.doc + (join_plugin_sections + (function + | Doc (cs, e) -> + Some + (lookup_plugin_section + "documentation" + (s_ "build") + cs.cs_name + t.doc, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + let test t args = + BaseTest.test + (join_plugin_sections + (function + | Test (cs, e) -> + Some + (lookup_plugin_section + "test" + (s_ "run") + cs.cs_name + t.test, + cs, + e) + | _ -> + None) + t.package.sections) + t.package + args + + let all t args = + let rno_doc = + ref false + in + let rno_test = + ref false + in + Arg.parse_argv + ~current:(ref 0) + (Array.of_list + ((Sys.executable_name^" all") :: + (Array.to_list args))) + [ + "-no-doc", + Arg.Set rno_doc, + s_ "Don't run doc target"; + + "-no-test", + Arg.Set rno_test, + s_ "Don't run test target"; + ] + (failwithf (f_ "Don't know what to do with '%s'")) + ""; + + info "Running configure step"; + configure t [||]; + + info "Running build step"; + build t [||]; + + (* Load setup.log dynamic variables *) + BaseDynVar.init t.package; + + if not !rno_doc then + begin + info "Running doc step"; + doc t [||]; + end + else + begin + info "Skipping doc step" + end; + + if not !rno_test then + begin + info "Running test step"; + test t [||] + end + else + begin + info "Skipping test step" + end + + let install t args = + BaseCustom.hook + t.package.install_custom + (t.install t.package) + args + + let uninstall t args = + BaseCustom.hook + t.package.uninstall_custom + (t.uninstall t.package) + args + + let reinstall t args = + uninstall t args; + install t args + + let clean, distclean = + let failsafe f a = + try + f a + with e -> + warning + (f_ "Action fail with error: %s") + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + in + + let generic_clean t cstm mains docs tests args = + BaseCustom.hook + ~failsafe:true + cstm + (fun () -> + (* Clean section *) + List.iter + (function + | Test (cs, test) -> + let f = + try + List.assoc cs.cs_name tests + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, test)) + args + | Doc (cs, doc) -> + let f = + try + List.assoc cs.cs_name docs + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, doc)) + args + | Library _ + | Executable _ + | Flag _ + | SrcRepo _ -> + ()) + t.package.sections; + (* Clean whole package *) + List.iter + (fun f -> + failsafe + (f t.package) + args) + mains) + () + in + + let clean t args = + generic_clean + t + t.package.clean_custom + t.clean + t.clean_doc + t.clean_test + args + in + + let distclean t args = + (* Call clean *) + clean t args; + + (* Call distclean code *) + generic_clean + t + t.package.distclean_custom + t.distclean + t.distclean_doc + t.distclean_test + args; + + (* Remove generated file *) + List.iter + (fun fn -> + if Sys.file_exists fn then + begin + info (f_ "Remove '%s'") fn; + Sys.remove fn + end) + (BaseEnv.default_filename + :: + BaseLog.default_filename + :: + (List.rev_map BaseFileAB.to_filename t.package.files_ab)) + in + + clean, distclean + + let version t _ = + print_endline t.oasis_version + + let update_setup_ml, no_update_setup_ml_cli = + let b = ref true in + b, + ("-no-update-setup-ml", + Arg.Clear b, + s_ " Don't try to update setup.ml, even if _oasis has changed.") + + let update_setup_ml t = + let oasis_fn = + match t.oasis_fn with + | Some fn -> fn + | None -> "_oasis" + in + let oasis_exec = + match t.oasis_exec with + | Some fn -> fn + | None -> "oasis" + in + let ocaml = + Sys.executable_name + in + let setup_ml, args = + match Array.to_list Sys.argv with + | setup_ml :: args -> + setup_ml, args + | [] -> + failwith + (s_ "Expecting non-empty command line arguments.") + in + let ocaml, setup_ml = + if Sys.executable_name = Sys.argv.(0) then + (* We are not running in standard mode, probably the script + * is precompiled. + *) + "ocaml", "setup.ml" + else + ocaml, setup_ml + in + let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in + let do_update () = + let oasis_exec_version = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | 1 -> + failwithf + (f_ "Executable '%s' is probably an old version \ + of oasis (< 0.3.0), please update to version \ + v%s.") + oasis_exec t.oasis_version + | 127 -> + failwithf + (f_ "Cannot find executable '%s', please install \ + oasis v%s.") + oasis_exec t.oasis_version + | n -> + failwithf + (f_ "Command '%s version' exited with code %d.") + oasis_exec n) + oasis_exec ["version"] + in + if OASISVersion.comparator_apply + (OASISVersion.version_of_string oasis_exec_version) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string t.oasis_version)) then + begin + (* We have a version >= for the executable oasis, proceed with + * update. + *) + (* TODO: delegate this check to 'oasis setup'. *) + if Sys.os_type = "Win32" then + failwithf + (f_ "It is not possible to update the running script \ + setup.ml on Windows. Please update setup.ml by \ + running '%s'.") + (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) + else + begin + OASISExec.run + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | n -> + failwithf + (f_ "Unable to update setup.ml using '%s', \ + please fix the problem and retry.") + oasis_exec) + oasis_exec ("setup" :: t.oasis_setup_args); + OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) + end + end + else + failwithf + (f_ "The version of '%s' (v%s) doesn't match the version of \ + oasis used to generate the %s file. Please install at \ + least oasis v%s.") + oasis_exec oasis_exec_version setup_ml t.oasis_version + in + + if !update_setup_ml then + begin + try + match t.oasis_digest with + | Some dgst -> + if Sys.file_exists oasis_fn && dgst <> Digest.file "_oasis" then + begin + do_update (); + true + end + else + false + | None -> + false + with e -> + error + (f_ "Error when updating setup.ml. If you want to avoid this error, \ + you can bypass the update of %s by running '%s %s %s %s'") + setup_ml ocaml setup_ml no_update_setup_ml_cli + (String.concat " " args); + raise e + end + else + false + + let setup t = + let catch_exn = + ref true + in + try + let act_ref = + ref (fun _ -> + failwithf + (f_ "No action defined, run '%s %s -help'") + Sys.executable_name + Sys.argv.(0)) + + in + let extra_args_ref = + ref [] + in + let allow_empty_env_ref = + ref false + in + let arg_handle ?(allow_empty_env=false) act = + Arg.Tuple + [ + Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); + + Arg.Unit + (fun () -> + allow_empty_env_ref := allow_empty_env; + act_ref := act); + ] + in + + Arg.parse + (Arg.align + ([ + "-configure", + arg_handle ~allow_empty_env:true configure, + s_ "[options*] Configure the whole build process."; + + "-build", + arg_handle build, + s_ "[options*] Build executables and libraries."; + + "-doc", + arg_handle doc, + s_ "[options*] Build documents."; + + "-test", + arg_handle test, + s_ "[options*] Run tests."; + + "-all", + arg_handle ~allow_empty_env:true all, + s_ "[options*] Run configure, build, doc and test targets."; + + "-install", + arg_handle install, + s_ "[options*] Install libraries, data, executables \ + and documents."; + + "-uninstall", + arg_handle uninstall, + s_ "[options*] Uninstall libraries, data, executables \ + and documents."; + + "-reinstall", + arg_handle reinstall, + s_ "[options*] Uninstall and install libraries, data, \ + executables and documents."; + + "-clean", + arg_handle ~allow_empty_env:true clean, + s_ "[options*] Clean files generated by a build."; + + "-distclean", + arg_handle ~allow_empty_env:true distclean, + s_ "[options*] Clean files generated by a build and configure."; + + "-version", + arg_handle ~allow_empty_env:true version, + s_ " Display version of OASIS used to generate this setup.ml."; + + "-no-catch-exn", + Arg.Clear catch_exn, + s_ " Don't catch exception, useful for debugging."; + ] + @ + (if t.setup_update then + [no_update_setup_ml_cli] + else + []) + @ (BaseContext.args ()))) + (failwithf (f_ "Don't know what to do with '%s'")) + (s_ "Setup and run build process current package\n"); + + (* Build initial environment *) + load ~allow_empty:!allow_empty_env_ref (); + + (** Initialize flags *) + List.iter + (function + | Flag (cs, {flag_description = hlp; + flag_default = choices}) -> + begin + let apply ?short_desc () = + var_ignore + (var_define + ~cli:CLIEnable + ?short_desc + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + string_of_bool + (var_choose + ~name:(Printf.sprintf + (f_ "default value of flag %s") + cs.cs_name) + ~printer:string_of_bool + choices))) + in + match hlp with + | Some hlp -> + apply ~short_desc:(fun () -> hlp) () + | None -> + apply () + end + | _ -> + ()) + t.package.sections; + + BaseStandardVar.init t.package; + + BaseDynVar.init t.package; + + if t.setup_update && update_setup_ml t then + () + else + !act_ref t (Array.of_list (List.rev !extra_args_ref)) + + with e when !catch_exn -> + error "%s" (Printexc.to_string e); + exit 1 + +end + + +# 4480 "setup.ml" +module InternalConfigurePlugin = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/plugins/internal/InternalConfigurePlugin.ml" + + (** Configure using internal scheme + @author Sylvain Le Gall + *) + + open BaseEnv + open OASISTypes + open OASISUtils + open OASISGettext + open BaseMessage + + (** Configure build using provided series of check to be done + * and then output corresponding file. + *) + let configure pkg argv = + let var_ignore_eval var = + let _s : string = + var () + in + () + in + + let errors = + ref SetString.empty + in + + let buff = + Buffer.create 13 + in + + let add_errors fmt = + Printf.kbprintf + (fun b -> + errors := SetString.add (Buffer.contents b) !errors; + Buffer.clear b) + buff + fmt + in + + let warn_exception e = + warning "%s" (Printexc.to_string e) + in + + (* Check tools *) + let check_tools lst = + List.iter + (function + | ExternalTool tool -> + begin + try + var_ignore_eval (BaseCheck.prog tool) + with e -> + warn_exception e; + add_errors (f_ "Cannot find external tool '%s'") tool + end + | InternalExecutable nm1 -> + (* Check that matching tool is built *) + List.iter + (function + | Executable ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal executable \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + lst + in + + let build_checks sct bs = + if var_choose bs.bs_build then + begin + if bs.bs_compiled_object = Native then + begin + try + var_ignore_eval BaseStandardVar.ocamlopt + with e -> + warn_exception e; + add_errors + (f_ "Section %s requires native compilation") + (OASISSection.string_of_section sct) + end; + + (* Check tools *) + check_tools bs.bs_build_tools; + + (* Check depends *) + List.iter + (function + | FindlibPackage (findlib_pkg, version_comparator) -> + begin + try + var_ignore_eval + (BaseCheck.package ?version_comparator findlib_pkg) + with e -> + warn_exception e; + match version_comparator with + | None -> + add_errors + (f_ "Cannot find findlib package %s") + findlib_pkg + | Some ver_cmp -> + add_errors + (f_ "Cannot find findlib package %s (%s)") + findlib_pkg + (OASISVersion.string_of_comparator ver_cmp) + end + | InternalLibrary nm1 -> + (* Check that matching library is built *) + List.iter + (function + | Library ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal library \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) + bs.bs_build_depends + end + in + + (* Parse command line *) + BaseArgExt.parse argv (BaseEnv.args ()); + + (* OCaml version *) + begin + match pkg.ocaml_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "ocaml" + ver_cmp + BaseStandardVar.ocaml_version) + with e -> + warn_exception e; + add_errors + (f_ "OCaml version %s doesn't match version constraint %s") + (BaseStandardVar.ocaml_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + + (* Findlib version *) + begin + match pkg.findlib_version with + | Some ver_cmp -> + begin + try + var_ignore_eval + (BaseCheck.version + "findlib" + ver_cmp + BaseStandardVar.findlib_version) + with e -> + warn_exception e; + add_errors + (f_ "Findlib version %s doesn't match version constraint %s") + (BaseStandardVar.findlib_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end + | None -> + () + end; + + (* FlexDLL *) + if BaseStandardVar.os_type () = "Win32" || + BaseStandardVar.os_type () = "Cygwin" then + begin + try + var_ignore_eval BaseStandardVar.flexlink + with e -> + warn_exception e; + add_errors (f_ "Cannot find 'flexlink'") + end; + + (* Check build depends *) + List.iter + (function + | Executable (_, bs, _) + | Library (_, bs, _) as sct -> + build_checks sct bs + | Doc (_, doc) -> + if var_choose doc.doc_build then + check_tools doc.doc_build_tools + | Test (_, test) -> + if var_choose test.test_run then + check_tools test.test_tools + | _ -> + ()) + pkg.sections; + + (* Check if we need native dynlink (presence of libraries that compile to + * native) + *) + begin + let has_cmxa = + List.exists + (function + | Library (_, bs, _) -> + var_choose bs.bs_build && + (bs.bs_compiled_object = Native || + (bs.bs_compiled_object = Best && + bool_of_string (BaseStandardVar.is_native ()))) + | _ -> + false) + pkg.sections + in + if has_cmxa then + var_ignore_eval BaseStandardVar.native_dynlink + end; + + (* Check errors *) + if SetString.empty != !errors then + begin + List.iter + (fun e -> error "%s" e) + (SetString.elements !errors); + failwithf + (fn_ + "%d configuration error" + "%d configuration errors" + (SetString.cardinal !errors)) + (SetString.cardinal !errors) + end + +end + +module InternalInstallPlugin = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/plugins/internal/InternalInstallPlugin.ml" + + (** Install using internal scheme + @author Sylvain Le Gall + *) + + open BaseEnv + open BaseStandardVar + open BaseMessage + open OASISTypes + open OASISLibrary + open OASISGettext + open OASISUtils + + let exec_hook = + ref (fun (cs, bs, exec) -> cs, bs, exec) + + let lib_hook = + ref (fun (cs, bs, lib) -> cs, bs, lib, []) + + let doc_hook = + ref (fun (cs, doc) -> cs, doc) + + let install_file_ev = + "install-file" + + let install_dir_ev = + "install-dir" + + let install_findlib_ev = + "install-findlib" + + let win32_max_command_line_length = 8000 + + let split_install_command ocamlfind findlib_name meta files = + if Sys.os_type = "Win32" then + (* Arguments for the first command: *) + let first_args = ["install"; findlib_name; meta] in + (* Arguments for remaining commands: *) + let other_args = ["install"; findlib_name; "-add"] in + (* Extract as much files as possible from [files], [len] is + the current command line length: *) + let rec get_files len acc files = + match files with + | [] -> + (List.rev acc, []) + | file :: rest -> + let len = len + 1 + String.length file in + if len > win32_max_command_line_length then + (List.rev acc, files) + else + get_files len (file :: acc) rest + in + (* Split the command into several commands. *) + let rec split args files = + match files with + | [] -> + [] + | _ -> + (* Length of "ocamlfind install <lib> [META|-add]" *) + let len = + List.fold_left + (fun len arg -> + len + 1 (* for the space *) + String.length arg) + (String.length ocamlfind) + args + in + match get_files len [] files with + | ([], _) -> + failwith (s_ "Command line too long.") + | (firsts, others) -> + let cmd = args @ firsts in + (* Use -add for remaining commands: *) + let () = + let findlib_ge_132 = + OASISVersion.comparator_apply + (OASISVersion.version_of_string + (BaseStandardVar.findlib_version ())) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string "1.3.2")) + in + if not findlib_ge_132 then + failwithf + (f_ "Installing the library %s require to use the flag \ + '-add' of ocamlfind because the command line is too \ + long. This flag is only available for findlib 1.3.2. \ + Please upgrade findlib from %s to 1.3.2") + findlib_name (BaseStandardVar.findlib_version ()) + in + let cmds = split other_args others in + cmd :: cmds + in + (* The first command does not use -add: *) + split first_args files + else + ["install" :: findlib_name :: meta :: files] + + let install pkg argv = + + let in_destdir = + try + let destdir = + destdir () + in + (* Practically speaking destdir is prepended + * at the beginning of the target filename + *) + fun fn -> destdir^fn + with PropList.Not_set _ -> + fun fn -> fn + in + + let install_file ?tgt_fn src_file envdir = + let tgt_dir = + in_destdir (envdir ()) + in + let tgt_file = + Filename.concat + tgt_dir + (match tgt_fn with + | Some fn -> + fn + | None -> + Filename.basename src_file) + in + (* Create target directory if needed *) + OASISFileUtil.mkdir_parent + ~ctxt:!BaseContext.default + (fun dn -> + info (f_ "Creating directory '%s'") dn; + BaseLog.register install_dir_ev dn) + tgt_dir; + + (* Really install files *) + info (f_ "Copying file '%s' to '%s'") src_file tgt_file; + OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; + BaseLog.register install_file_ev tgt_file + in + + (* Install data into defined directory *) + let install_data srcdir lst tgtdir = + let tgtdir = + OASISHostPath.of_unix (var_expand tgtdir) + in + List.iter + (fun (src, tgt_opt) -> + let real_srcs = + OASISFileUtil.glob + ~ctxt:!BaseContext.default + (Filename.concat srcdir src) + in + if real_srcs = [] then + failwithf + (f_ "Wildcard '%s' doesn't match any files") + src; + List.iter + (fun fn -> + install_file + fn + (fun () -> + match tgt_opt with + | Some s -> + OASISHostPath.of_unix (var_expand s) + | None -> + tgtdir)) + real_srcs) + lst + in + + (** Install all libraries *) + let install_libs pkg = + + let files_of_library (f_data, acc) data_lib = + let cs, bs, lib, lib_extra = + !lib_hook data_lib + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then + begin + let acc = + (* Start with acc + lib_extra *) + List.rev_append lib_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + String.uncapitalize modul^".mli"; + String.capitalize modul^".mli"; + String.uncapitalize modul^".ml"; + String.capitalize modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in library %s") + modul cs.cs_name; + acc + end) + acc + lib.lib_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BLib + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the library *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + in + + (* Install one group of library *) + let install_group_lib grp = + (* Iterate through all group nodes *) + let rec install_group_lib_aux data_and_files grp = + let data_and_files, children = + match grp with + | Container (_, children) -> + data_and_files, children + | Package (_, cs, bs, lib, children) -> + files_of_library data_and_files (cs, bs, lib), children + in + List.fold_left + install_group_lib_aux + data_and_files + children + in + + (* Findlib name of the root library *) + let findlib_name = + findlib_of_group grp + in + + (* Determine root library *) + let root_lib = + root_of_group grp + in + + (* All files to install for this library *) + let f_data, files = + install_group_lib_aux (ignore, []) grp + in + + (* Really install, if there is something to install *) + if files = [] then + begin + warning + (f_ "Nothing to install for findlib library '%s'") + findlib_name + end + else + begin + let meta = + (* Search META file *) + let (_, bs, _) = + root_lib + in + let res = + Filename.concat bs.bs_path "META" + in + if not (OASISFileUtil.file_exists_case res) then + failwithf + (f_ "Cannot find file '%s' for findlib library %s") + res + findlib_name; + res + in + let files = + (* Make filename shorter to avoid hitting command max line length + * too early, esp. on Windows. + *) + let remove_prefix p n = + let plen = String.length p in + let nlen = String.length n in + if plen <= nlen && String.sub n 0 plen = p then + begin + let fn_sep = + if Sys.os_type = "Win32" then + '\\' + else + '/' + in + let cutpoint = plen + + (if plen < nlen && n.[plen] = fn_sep then + 1 + else + 0) + in + String.sub n cutpoint (nlen - cutpoint) + end + else + n + in + List.map (remove_prefix (Sys.getcwd ())) files + in + info + (f_ "Installing findlib library '%s'") + findlib_name; + let ocamlfind = ocamlfind () in + let commands = + split_install_command + ocamlfind + findlib_name + meta + files + in + List.iter + (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) + commands; + BaseLog.register install_findlib_ev findlib_name + end; + + (* Install data files *) + f_data (); + + in + + let group_libs, _, _ = + findlib_mapping pkg + in + + (* We install libraries in groups *) + List.iter install_group_lib group_libs + in + + let install_execs pkg = + let install_exec data_exec = + let (cs, bs, exec) = + !exec_hook data_exec + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then + begin + let exec_libdir () = + Filename.concat + (libdir ()) + pkg.name + in + BaseBuilt.fold + BaseBuilt.BExec + cs.cs_name + (fun () fn -> + install_file + ~tgt_fn:(cs.cs_name ^ ext_program ()) + fn + bindir) + (); + BaseBuilt.fold + BaseBuilt.BExecLib + cs.cs_name + (fun () fn -> + install_file + fn + exec_libdir) + (); + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name) + end + in + List.iter + (function + | Executable (cs, bs, exec)-> + install_exec (cs, bs, exec) + | _ -> + ()) + pkg.sections + in + + let install_docs pkg = + let install_doc data = + let (cs, doc) = + !doc_hook data + in + if var_choose doc.doc_install && + BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then + begin + let tgt_dir = + OASISHostPath.of_unix (var_expand doc.doc_install_dir) + in + BaseBuilt.fold + BaseBuilt.BDoc + cs.cs_name + (fun () fn -> + install_file + fn + (fun () -> tgt_dir)) + (); + install_data + Filename.current_dir_name + doc.doc_data_files + doc.doc_install_dir + end + in + List.iter + (function + | Doc (cs, doc) -> + install_doc (cs, doc) + | _ -> + ()) + pkg.sections + in + + install_libs pkg; + install_execs pkg; + install_docs pkg + + (* Uninstall already installed data *) + let uninstall _ argv = + List.iter + (fun (ev, data) -> + if ev = install_file_ev then + begin + if OASISFileUtil.file_exists_case data then + begin + info + (f_ "Removing file '%s'") + data; + Sys.remove data + end + else + begin + warning + (f_ "File '%s' doesn't exist anymore") + data + end + end + else if ev = install_dir_ev then + begin + if Sys.file_exists data && Sys.is_directory data then + begin + if Sys.readdir data = [||] then + begin + info + (f_ "Removing directory '%s'") + data; + OASISFileUtil.rmdir ~ctxt:!BaseContext.default data + end + else + begin + warning + (f_ "Directory '%s' is not empty (%s)") + data + (String.concat + ", " + (Array.to_list + (Sys.readdir data))) + end + end + else + begin + warning + (f_ "Directory '%s' doesn't exist anymore") + data + end + end + else if ev = install_findlib_ev then + begin + info (f_ "Removing findlib library '%s'") data; + OASISExec.run ~ctxt:!BaseContext.default + (ocamlfind ()) ["remove"; data] + end + else + failwithf (f_ "Unknown log event '%s'") ev; + BaseLog.unregister ev data) + (* We process event in reverse order *) + (List.rev + (BaseLog.filter + [install_file_ev; + install_dir_ev; + install_findlib_ev;])) + +end + + +# 5233 "setup.ml" +module OCamlbuildCommon = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildCommon.ml" + + (** Functions common to OCamlbuild build and doc plugin + *) + + open OASISGettext + open BaseEnv + open BaseStandardVar + + let ocamlbuild_clean_ev = + "ocamlbuild-clean" + + let ocamlbuildflags = + var_define + ~short_desc:(fun () -> "OCamlbuild additional flags") + "ocamlbuildflags" + (fun () -> "") + + (** Fix special arguments depending on environment *) + let fix_args args extra_argv = + List.flatten + [ + if (os_type ()) = "Win32" then + [ + "-classic-display"; + "-no-log"; + "-no-links"; + "-install-lib-dir"; + (Filename.concat (standard_library ()) "ocamlbuild") + ] + else + []; + + if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then + [ + "-byte-plugin" + ] + else + []; + args; + + if bool_of_string (debug ()) then + ["-tag"; "debug"] + else + []; + + if bool_of_string (profile ()) then + ["-tag"; "profile"] + else + []; + + OASISString.nsplit (ocamlbuildflags ()) ' '; + + Array.to_list extra_argv; + ] + + (** Run 'ocamlbuild -clean' if not already done *) + let run_clean extra_argv = + let extra_cli = + String.concat " " (Array.to_list extra_argv) + in + (* Run if never called with these args *) + if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then + begin + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args ["-clean"] extra_argv); + BaseLog.register ocamlbuild_clean_ev extra_cli; + at_exit + (fun () -> + try + BaseLog.unregister ocamlbuild_clean_ev extra_cli + with _ -> + ()) + end + + (** Run ocamlbuild, unregister all clean events *) + let run_ocamlbuild args extra_argv = + (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html + *) + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args args extra_argv); + (* Remove any clean event, we must run it again *) + List.iter + (fun (e, d) -> BaseLog.unregister e d) + (BaseLog.filter [ocamlbuild_clean_ev]) + + (** Determine real build directory *) + let build_dir extra_argv = + let rec search_args dir = + function + | "-build-dir" :: dir :: tl -> + search_args dir tl + | _ :: tl -> + search_args dir tl + | [] -> + dir + in + search_args "_build" (fix_args [] extra_argv) + +end + +module OCamlbuildPlugin = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildPlugin.ml" + + (** Build using ocamlbuild + @author Sylvain Le Gall + *) + + open OASISTypes + open OASISGettext + open OASISUtils + open BaseEnv + open OCamlbuildCommon + open BaseStandardVar + open BaseMessage + + let cond_targets_hook = + ref (fun lst -> lst) + + let build pkg argv = + + (* Return the filename in build directory *) + let in_build_dir fn = + Filename.concat + (build_dir argv) + fn + in + + (* Return the unix filename in host build directory *) + let in_build_dir_of_unix fn = + in_build_dir (OASISHostPath.of_unix fn) + in + + let cond_targets = + List.fold_left + (fun acc -> + function + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_library + in_build_dir_of_unix + (cs, bs, lib) + in + + let ends_with nd fn = + let nd_len = + String.length nd + in + (String.length fn >= nd_len) + && + (String.sub + fn + (String.length fn - nd_len) + nd_len) = nd + in + + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ".cma" fn + || ends_with ".cmxs" fn + || ends_with ".cmxa" fn + || ends_with (ext_lib ()) fn + || ends_with (ext_dll ()) fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for library %s") + cs.cs_name + end + + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, unix_exec_is, unix_dll_opt = + BaseBuilt.of_executable + in_build_dir_of_unix + (cs, bs, exec) + in + + let target ext = + let unix_tgt = + (OASISUnixPath.concat + bs.bs_path + (OASISUnixPath.chop_extension + exec.exec_main_is))^ext + in + let evs = + (* Fix evs, we want to use the unix_tgt, without copying *) + List.map + (function + | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> + BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] + | ev -> + ev) + evs + in + evs, [unix_tgt] + in + + (* Add executable *) + let acc = + match bs.bs_compiled_object with + | Native -> + (target ".native") :: acc + | Best when bool_of_string (is_native ()) -> + (target ".native") :: acc + | Byte + | Best -> + (target ".byte") :: acc + in + acc + end + + | Library _ | Executable _ | Test _ + | SrcRepo _ | Flag _ | Doc _ -> + acc) + [] + (* Keep the pkg.sections ordered *) + (List.rev pkg.sections); + in + + (* Check and register built files *) + let check_and_register (bt, bnm, lst) = + List.iter + (fun fns -> + if not (List.exists OASISFileUtil.file_exists_case fns) then + failwithf + (f_ "No one of expected built files %s exists") + (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) + lst; + (BaseBuilt.register bt bnm lst) + in + + let cond_targets = + (* Run the hook *) + !cond_targets_hook cond_targets + in + + (* Run a list of target... *) + run_ocamlbuild + (List.flatten + (List.map snd cond_targets)) + argv; + (* ... and register events *) + List.iter + check_and_register + (List.flatten (List.map fst cond_targets)) + + + let clean pkg extra_args = + run_clean extra_args; + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + +end + +module OCamlbuildDocPlugin = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" + + (* Create documentation using ocamlbuild .odocl files + @author Sylvain Le Gall + *) + + open OASISTypes + open OASISGettext + open OASISMessage + open OCamlbuildCommon + open BaseStandardVar + + + + let doc_build path pkg (cs, doc) argv = + let index_html = + OASISUnixPath.make + [ + path; + cs.cs_name^".docdir"; + "index.html"; + ] + in + let tgt_dir = + OASISHostPath.make + [ + build_dir argv; + OASISHostPath.of_unix path; + cs.cs_name^".docdir"; + ] + in + run_ocamlbuild [index_html] argv; + List.iter + (fun glb -> + BaseBuilt.register + BaseBuilt.BDoc + cs.cs_name + [OASISFileUtil.glob ~ctxt:!BaseContext.default + (Filename.concat tgt_dir glb)]) + ["*.html"; "*.css"] + + let doc_clean t pkg (cs, doc) argv = + run_clean argv; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + +end + + +# 5558 "setup.ml" +module CustomPlugin = struct +# 21 "/home/dim/sources/oasis-0.3.0/src/plugins/custom/CustomPlugin.ml" + + (** Generate custom configure/build/doc/test/install system + @author + *) + + open BaseEnv + open OASISGettext + open OASISTypes + + + + type t = + { + cmd_main: command_line conditional; + cmd_clean: (command_line option) conditional; + cmd_distclean: (command_line option) conditional; + } + + let run = BaseCustom.run + + let main t _ extra_args = + let cmd, args = + var_choose + ~name:(s_ "main command") + t.cmd_main + in + run cmd args extra_args + + let clean t pkg extra_args = + match var_choose t.cmd_clean with + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () + + let distclean t pkg extra_args = + match var_choose t.cmd_distclean with + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () + + module Build = + struct + let main t pkg extra_args = + main t pkg extra_args; + List.iter + (fun sct -> + let evs = + match sct with + | Library (cs, bs, lib) when var_choose bs.bs_build -> + begin + let evs, _ = + BaseBuilt.of_library + OASISHostPath.of_unix + (cs, bs, lib) + in + evs + end + | Executable (cs, bs, exec) when var_choose bs.bs_build -> + begin + let evs, _, _ = + BaseBuilt.of_executable + OASISHostPath.of_unix + (cs, bs, exec) + in + evs + end + | _ -> + [] + in + List.iter + (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) + evs) + pkg.sections + + let clean t pkg extra_args = + clean t pkg extra_args; + (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild + * considering moving this to BaseSetup? + *) + List.iter + (function + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) + pkg.sections + + let distclean t pkg extra_args = + distclean t pkg extra_args + end + + module Test = + struct + let main t pkg (cs, test) extra_args = + try + main t pkg extra_args; + 0.0 + with Failure s -> + BaseMessage.warning + (f_ "Test '%s' fails: %s") + cs.cs_name + s; + 1.0 + + let clean t pkg (cs, test) extra_args = + clean t pkg extra_args + + let distclean t pkg (cs, test) extra_args = + distclean t pkg extra_args + end + + module Doc = + struct + let main t pkg (cs, _) extra_args = + main t pkg extra_args; + BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] + + let clean t pkg (cs, _) extra_args = + clean t pkg extra_args; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + + let distclean t pkg (cs, _) extra_args = + distclean t pkg extra_args + end + +end + + +# 5694 "setup.ml" +open OASISTypes;; + +let setup_t = + { + BaseSetup.configure = InternalConfigurePlugin.configure; + build = OCamlbuildPlugin.build; + test = + [ + ("main", + CustomPlugin.Test.main + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$tests_exec", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) + ]; + doc = + [ + ("obus-dump-man", + CustomPlugin.Doc.main + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + ["-c"; "man/obus-dump.1"; ">"; "man/obus-dump.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-dump.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-gen-interface-man", + CustomPlugin.Doc.main + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-gen-interface.1"; + ">"; + "man/obus-gen-interface.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-gen-interface.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-gen-client-man", + CustomPlugin.Doc.main + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-gen-client.1"; + ">"; + "man/obus-gen-client.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-gen-client.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-gen-server-man", + CustomPlugin.Doc.main + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-gen-server.1"; + ">"; + "man/obus-gen-server.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-gen-server.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-idl2xml-man", + CustomPlugin.Doc.main + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-idl2xml.1"; + ">"; + "man/obus-idl2xml.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-idl2xml.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-xml2idl-man", + CustomPlugin.Doc.main + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-xml2idl.1"; + ">"; + "man/obus-xml2idl.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-xml2idl.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-introspect-man", + CustomPlugin.Doc.main + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-introspect.1"; + ">"; + "man/obus-introspect.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-introspect.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-manual", + CustomPlugin.Doc.main + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("make", ["-C"; "manual"; "manual.pdf"])) + ]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-api", OCamlbuildDocPlugin.doc_build "./"); + ("examples", + CustomPlugin.Doc.main + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("true", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) + ]; + install = InternalInstallPlugin.install; + uninstall = InternalInstallPlugin.uninstall; + clean = [OCamlbuildPlugin.clean]; + clean_test = + [ + ("main", + CustomPlugin.Test.clean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$tests_exec", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) + ]; + clean_doc = + [ + ("obus-dump-man", + CustomPlugin.Doc.clean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + ["-c"; "man/obus-dump.1"; ">"; "man/obus-dump.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-dump.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-gen-interface-man", + CustomPlugin.Doc.clean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-gen-interface.1"; + ">"; + "man/obus-gen-interface.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-gen-interface.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-gen-client-man", + CustomPlugin.Doc.clean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-gen-client.1"; + ">"; + "man/obus-gen-client.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-gen-client.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-gen-server-man", + CustomPlugin.Doc.clean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-gen-server.1"; + ">"; + "man/obus-gen-server.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-gen-server.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-idl2xml-man", + CustomPlugin.Doc.clean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-idl2xml.1"; + ">"; + "man/obus-idl2xml.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-idl2xml.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-xml2idl-man", + CustomPlugin.Doc.clean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-xml2idl.1"; + ">"; + "man/obus-xml2idl.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-xml2idl.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-introspect-man", + CustomPlugin.Doc.clean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-introspect.1"; + ">"; + "man/obus-introspect.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-introspect.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-manual", + CustomPlugin.Doc.clean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("make", ["-C"; "manual"; "manual.pdf"])) + ]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-api", OCamlbuildDocPlugin.doc_clean "./"); + ("examples", + CustomPlugin.Doc.clean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("true", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) + ]; + distclean = []; + distclean_test = + [ + ("main", + CustomPlugin.Test.distclean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("$tests_exec", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) + ]; + distclean_doc = + [ + ("obus-dump-man", + CustomPlugin.Doc.distclean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + ["-c"; "man/obus-dump.1"; ">"; "man/obus-dump.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-dump.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-gen-interface-man", + CustomPlugin.Doc.distclean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-gen-interface.1"; + ">"; + "man/obus-gen-interface.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-gen-interface.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-gen-client-man", + CustomPlugin.Doc.distclean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-gen-client.1"; + ">"; + "man/obus-gen-client.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-gen-client.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-gen-server-man", + CustomPlugin.Doc.distclean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-gen-server.1"; + ">"; + "man/obus-gen-server.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-gen-server.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-idl2xml-man", + CustomPlugin.Doc.distclean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-idl2xml.1"; + ">"; + "man/obus-idl2xml.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-idl2xml.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-xml2idl-man", + CustomPlugin.Doc.distclean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-xml2idl.1"; + ">"; + "man/obus-xml2idl.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-xml2idl.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-introspect-man", + CustomPlugin.Doc.distclean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("$gzip", + [ + "-c"; + "man/obus-introspect.1"; + ">"; + "man/obus-introspect.1.gz" + ])) + ]; + cmd_clean = + [ + (OASISExpr.EBool true, + Some (("$rm", ["man/obus-introspect.1.gz"]))) + ]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("obus-manual", + CustomPlugin.Doc.distclean + { + CustomPlugin.cmd_main = + [ + (OASISExpr.EBool true, + ("make", ["-C"; "manual"; "manual.pdf"])) + ]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }); + ("examples", + CustomPlugin.Doc.distclean + { + CustomPlugin.cmd_main = + [(OASISExpr.EBool true, ("true", []))]; + cmd_clean = [(OASISExpr.EBool true, None)]; + cmd_distclean = [(OASISExpr.EBool true, None)]; + }) + ]; + package = + { + oasis_version = "0.3"; + ocaml_version = Some (OASISVersion.VGreaterEqual "3.12"); + findlib_version = None; + name = "obus"; + version = "1.1.5"; + license = + OASISLicense.DEP5License + (OASISLicense.DEP5Unit + { + OASISLicense.license = "BSD3"; + excption = None; + version = OASISLicense.NoVersion; + }); + license_file = Some "LICENSE"; + copyrights = []; + maintainers = []; + authors = ["J\195\169r\195\169mie Dimino"]; + homepage = Some "http://obus.forge.ocamlcore.org/"; + synopsis = "obus"; + description = + Some "Pure OCaml implementation of the D-Bus protocol"; + categories = []; + conf_type = (`Configure, "internal", Some "0.3"); + conf_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + build_type = (`Build, "ocamlbuild", Some "0.3"); + build_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + install_type = (`Install, "internal", Some "0.3"); + install_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + uninstall_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + clean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + distclean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + files_ab = ["src/oBus_config.ml.ab"]; + sections = + [ + Library + ({ + cs_name = "obus"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "src"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("lwt.unix", None); + FindlibPackage ("lwt.react", None); + FindlibPackage ("lwt.syntax", None); + FindlibPackage ("lwt.syntax.log", None); + FindlibPackage ("type_conv", None); + FindlibPackage ("xmlm", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = + [ + "OBus_address"; + "OBus_auth"; + "OBus_bus"; + "OBus_connection"; + "OBus_context"; + "OBus_error"; + "OBus_info"; + "OBus_introspect_ext"; + "OBus_introspect"; + "OBus_match"; + "OBus_member"; + "OBus_message"; + "OBus_method"; + "OBus_name"; + "OBus_object"; + "OBus_path"; + "OBus_peer"; + "OBus_property"; + "OBus_proxy"; + "OBus_resolver"; + "OBus_server"; + "OBus_signal"; + "OBus_string"; + "OBus_transport"; + "OBus_uuid"; + "OBus_value"; + "OBus_wire"; + "OBus_interfaces" + ]; + lib_pack = false; + lib_internal_modules = + [ + "OBus_address_lexer"; + "OBus_match_rule_lexer"; + "OBus_protocol"; + "OBus_type_ext_lexer"; + "OBus_util"; + "OBus_xml_parser"; + "OBus_config" + ]; + lib_findlib_parent = None; + lib_findlib_name = None; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "obus-idl"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "src"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + FindlibPackage ("camlp4.lib", None); + FindlibPackage ("camlp4.quotations.o", None); + FindlibPackage ("camlp4.extend", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["OBus_idl"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "obus"; + lib_findlib_name = Some "idl"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "obus-syntax"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "syntax"; + bs_compiled_object = Byte; + bs_build_depends = + [ + FindlibPackage ("type_conv", None); + FindlibPackage ("camlp4", None); + FindlibPackage ("camlp4.quotations.o", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = []; + lib_pack = false; + lib_internal_modules = ["Pa_obus"]; + lib_findlib_parent = Some "obus"; + lib_findlib_name = Some "syntax"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "obus-hal"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "bindings/hal"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "obus"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = + ["Hal_device"; "Hal_manager"; "Hal_interfaces"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "obus"; + lib_findlib_name = Some "hal"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "obus-notification"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "bindings/notification"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "obus"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = + ["Notification"; "Notification_interfaces"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "obus"; + lib_findlib_name = Some "notification"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "obus-network-manager"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "bindings/network-manager"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "obus"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_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"; + "Nm_interfaces"; + "Nm_monitor" + ]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "obus"; + lib_findlib_name = Some "network-manager"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "obus-upower"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "bindings/upower"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "obus"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = + [ + "UPower"; + "UPower_device"; + "UPower_policy"; + "UPower_wakeups"; + "UPower_interfaces"; + "UPower_monitor" + ]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "obus"; + lib_findlib_name = Some "upower"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "obus-udisks"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "bindings/udisks"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "obus"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = + [ + "UDisks"; + "UDisks_device"; + "UDisks_port"; + "UDisks_adapter"; + "UDisks_expander"; + "UDisks_interfaces"; + "UDisks_monitor" + ]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "obus"; + lib_findlib_name = Some "udisks"; + lib_findlib_containers = []; + }); + Library + ({ + cs_name = "obus-policykit"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "bindings/policykit"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "obus"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + lib_modules = ["Policy_kit"; "Policy_kit_interfaces"]; + lib_pack = false; + lib_internal_modules = []; + lib_findlib_parent = Some "obus"; + lib_findlib_name = Some "policykit"; + lib_findlib_containers = []; + }); + Executable + ({ + cs_name = "obus-gen-interface"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "tools"; + bs_compiled_object = Best; + bs_build_depends = + [ + FindlibPackage ("lwt.unix", None); + FindlibPackage ("lwt.react", None); + FindlibPackage ("lwt.syntax", None); + FindlibPackage ("lwt.syntax.log", None); + FindlibPackage ("type_conv", None); + FindlibPackage ("xmlm", None); + FindlibPackage ("camlp4.quotations.o", None); + FindlibPackage ("camlp4.extend", None); + FindlibPackage ("camlp4.lib", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + exec_custom = false; + exec_main_is = "obus_gen_interface.ml"; + }); + Executable + ({ + cs_name = "obus-dump"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "tools"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "obus"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "obus_dump.ml"; }); + Executable + ({ + cs_name = "obus-gen-client"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "tools"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + InternalLibrary "obus-idl"; + FindlibPackage ("camlp4.lib", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "obus_gen_client.ml"; + }); + Executable + ({ + cs_name = "obus-gen-server"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "tools"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + InternalLibrary "obus-idl"; + FindlibPackage ("camlp4.lib", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "obus_gen_server.ml"; + }); + Executable + ({ + cs_name = "obus-xml2idl"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "tools"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + InternalLibrary "obus-idl"; + FindlibPackage ("camlp4.lib", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "obus_xml2idl.ml"; }); + Executable + ({ + cs_name = "obus-idl2xml"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "tools"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + InternalLibrary "obus-idl"; + FindlibPackage ("camlp4.lib", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "obus_idl2xml.ml"; }); + Executable + ({ + cs_name = "obus-introspect"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "tools"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "obus"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "obus_introspect.ml"; + }); + Doc + ({ + cs_name = "obus-dump-man"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + doc_type = (`Doc, "custom", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$mandir/man1"; + doc_title = "Man page for obus-dump"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = [("man/obus-dump.1.gz", None)]; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "gzip"]; + }); + Doc + ({ + cs_name = "obus-gen-interface-man"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + doc_type = (`Doc, "custom", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$mandir/man1"; + doc_title = "Man page for obus-gen-interface"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = + [("man/obus-gen-interface.1.gz", None)]; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "gzip"]; + }); + Doc + ({ + cs_name = "obus-gen-client-man"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + doc_type = (`Doc, "custom", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$mandir/man1"; + doc_title = "Man page for obus-gen-client"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = [("man/obus-gen-client.1.gz", None)]; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "gzip"]; + }); + Doc + ({ + cs_name = "obus-gen-server-man"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + doc_type = (`Doc, "custom", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$mandir/man1"; + doc_title = "Man page for obus-gen-server"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = [("man/obus-gen-server.1.gz", None)]; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "gzip"]; + }); + Doc + ({ + cs_name = "obus-idl2xml-man"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + doc_type = (`Doc, "custom", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$mandir/man1"; + doc_title = "Man page for obus-idl2xml"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = [("man/obus-idl2xml.1.gz", None)]; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "gzip"]; + }); + Doc + ({ + cs_name = "obus-xml2idl-man"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + doc_type = (`Doc, "custom", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$mandir/man1"; + doc_title = "Man page for obus-xml2idl"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = [("man/obus-xml2idl.1.gz", None)]; + doc_build_tools = + [ + ExternalTool "ocamlbuild"; + ExternalTool "gzip"; + ExternalTool "rm" + ]; + }); + Doc + ({ + cs_name = "obus-introspect-man"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + doc_type = (`Doc, "custom", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$mandir/man1"; + doc_title = "Man page for obus-introspect"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = [("man/obus-introspect.1.gz", None)]; + doc_build_tools = + [ + ExternalTool "ocamlbuild"; + ExternalTool "gzip"; + ExternalTool "rm" + ]; + }); + Doc + ({ + cs_name = "obus-manual"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + doc_type = (`Doc, "custom", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$pdfdir"; + doc_title = "OBus user manual"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = [("manual/manual.pdf", None)]; + doc_build_tools = [ExternalTool "ocamlbuild"]; + }); + Doc + ({ + cs_name = "obus-api"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + doc_type = (`Doc, "ocamlbuild", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$htmldir/api"; + doc_title = "API reference for OBus"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = [("utils/doc/style.css", None)]; + doc_build_tools = + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; + }); + Executable + ({ + cs_name = "tests_exec"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EFlag "tests", true) + ]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "tests"; + bs_compiled_object = Best; + bs_build_depends = [InternalLibrary "obus"]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "main.ml"; }); + Test + ({ + cs_name = "main"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + test_type = (`Test, "custom", Some "0.3"); + test_command = + [(OASISExpr.EBool true, ("$tests_exec", []))]; + test_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + test_working_directory = None; + test_run = + [ + (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); + (OASISExpr.EFlag "tests", true) + ]; + test_tools = + [ + ExternalTool "ocamlbuild"; + InternalExecutable "tests_exec" + ]; + }); + Doc + ({ + cs_name = "examples"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + doc_type = (`Doc, "custom", Some "0.3"); + doc_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)]; + }; + doc_build = + [ + (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); + (OASISExpr.EFlag "docs", true) + ]; + doc_install = [(OASISExpr.EBool true, true)]; + doc_install_dir = "$docdir/examples"; + doc_title = "Examples"; + doc_authors = []; + doc_abstract = None; + doc_format = OtherDoc; + doc_data_files = + [("examples/*.ml", None); ("examples/*.xml", None)]; + doc_build_tools = [ExternalTool "ocamlbuild"]; + }); + Executable + ({ + cs_name = "bus-functions"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + FindlibPackage ("lwt.syntax", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "bus_functions.ml"; }); + Executable + ({ + cs_name = "eject"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + FindlibPackage ("lwt.syntax", None); + InternalLibrary "obus-hal" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "eject.ml"; }); + Executable + ({ + cs_name = "hello"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + FindlibPackage ("lwt.syntax", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "hello.ml"; }); + Executable + ({ + cs_name = "list-services"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + FindlibPackage ("lwt.syntax", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "list_services.ml"; }); + Executable + ({ + cs_name = "monitor"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + FindlibPackage ("lwt.syntax", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "monitor.ml"; }); + Executable + ({ + cs_name = "notify"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + FindlibPackage ("lwt.syntax", None); + InternalLibrary "obus-notification" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "notify.ml"; }); + Executable + ({ + cs_name = "ping"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + FindlibPackage ("lwt.syntax", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "ping.ml"; }); + Executable + ({ + cs_name = "pong"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + FindlibPackage ("lwt.syntax", None) + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "pong.ml"; }); + Executable + ({ + cs_name = "signals"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + FindlibPackage ("lwt.syntax", None); + InternalLibrary "obus-hal" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "signals.ml"; }); + Executable + ({ + cs_name = "network-manager"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + FindlibPackage ("lwt.syntax", None); + InternalLibrary "obus-network-manager" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + {exec_custom = false; exec_main_is = "network_manager.ml"; + }); + Executable + ({ + cs_name = "battery-monitoring"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + bs_build = [(OASISExpr.EBool true, true)]; + bs_install = [(OASISExpr.EBool true, false)]; + bs_path = "examples"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "obus"; + FindlibPackage ("lwt.syntax", None); + InternalLibrary "obus-upower" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])]; + }, + { + exec_custom = false; + exec_main_is = "battery_monitoring.ml"; + }); + SrcRepo + ({ + cs_name = "head"; + cs_data = PropList.Data.create (); + cs_plugin_data = []; + }, + { + src_repo_type = Darcs; + src_repo_location = + "http://darcs.ocamlcore.org/repos/obus"; + src_repo_browser = + Some + "http://darcs.ocamlcore.org/cgi-bin/darcsweb.cgi?r=obus;a=summary"; + src_repo_module = None; + src_repo_branch = None; + src_repo_tag = None; + src_repo_subdir = None; + }) + ]; + plugins = + [(`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3")]; + schema_data = PropList.Data.create (); + plugin_data = []; + }; + oasis_fn = Some "_oasis"; + oasis_version = "0.3.0"; + oasis_digest = + Some "\028\177\017]\030\162\149\219\202k\003f\025\012\012\028"; + oasis_exec = None; + oasis_setup_args = []; + setup_update = false; + };; + +let setup () = BaseSetup.setup setup_t;; + +# 7539 "setup.ml" +(* OASIS_STOP *) + +let () = setup ();; diff --git a/src/META b/src/META new file mode 100644 index 0000000..1b5e4ea --- /dev/null +++ b/src/META @@ -0,0 +1,97 @@ +# OASIS_START +# DO NOT EDIT (digest: fac5ab0cbbc71226c9943d4a4aaf5441) +version = "1.1.5" +description = "Pure OCaml implementation of D-Bus" +requires = "lwt.unix lwt.react xmlm" +archive(byte) = "obus.cma" +archive(byte, plugin) = "obus.cma" +archive(native) = "obus.cmxa" +archive(native, plugin) = "obus.cmxs" +exists_if = "obus.cma" +package "upower" ( + version = "1.1.5" + description = "Freedesktop UPower service binding" + requires = "obus" + archive(byte) = "obus-upower.cma" + archive(byte, plugin) = "obus-upower.cma" + archive(native) = "obus-upower.cmxa" + archive(native, plugin) = "obus-upower.cmxs" + exists_if = "obus-upower.cma" +) + +package "udisks" ( + version = "1.1.5" + description = "Freedesktop UDisks service binding" + requires = "obus" + archive(byte) = "obus-udisks.cma" + archive(byte, plugin) = "obus-udisks.cma" + archive(native) = "obus-udisks.cmxa" + archive(native, plugin) = "obus-udisks.cmxs" + exists_if = "obus-udisks.cma" +) + +package "syntax" ( + version = "1.1.5" + description = "Syntactic sugars for defining D-Bus errors" + requires = "camlp4 type_conv" + archive(syntax, preprocessor) = "obus-syntax.cma" + archive(syntax, toploop) = "obus-syntax.cma" + exists_if = "obus-syntax.cma" +) + +package "policykit" ( + version = "1.1.5" + description = "Freedesktop PolicyKit service binding" + requires = "obus" + archive(byte) = "obus-policykit.cma" + archive(byte, plugin) = "obus-policykit.cma" + archive(native) = "obus-policykit.cmxa" + archive(native, plugin) = "obus-policykit.cmxs" + exists_if = "obus-policykit.cma" +) + +package "notification" ( + version = "1.1.5" + description = "Freedesktop Notification service binding" + requires = "obus" + archive(byte) = "obus-notification.cma" + archive(byte, plugin) = "obus-notification.cma" + archive(native) = "obus-notification.cmxa" + archive(native, plugin) = "obus-notification.cmxs" + exists_if = "obus-notification.cma" +) + +package "network-manager" ( + version = "1.1.5" + description = "Freedesktop NetworkManager service binding" + requires = "obus" + archive(byte) = "obus-network-manager.cma" + archive(byte, plugin) = "obus-network-manager.cma" + archive(native) = "obus-network-manager.cmxa" + archive(native, plugin) = "obus-network-manager.cmxs" + exists_if = "obus-network-manager.cma" +) + +package "idl" ( + version = "1.1.5" + description = "Intermediate language for writing D-Bus interfaces" + requires = "obus camlp4.lib" + archive(byte) = "obus-idl.cma" + archive(byte, plugin) = "obus-idl.cma" + archive(native) = "obus-idl.cmxa" + archive(native, plugin) = "obus-idl.cmxs" + exists_if = "obus-idl.cma" +) + +package "hal" ( + version = "1.1.5" + description = "Freedesktop Hal service binding" + requires = "obus" + archive(byte) = "obus-hal.cma" + archive(byte, plugin) = "obus-hal.cma" + archive(native) = "obus-hal.cmxa" + archive(native, plugin) = "obus-hal.cmxs" + exists_if = "obus-hal.cma" +) +# OASIS_STOP + diff --git a/src/oBus_address.ml b/src/oBus_address.ml new file mode 100644 index 0000000..3065a70 --- /dev/null +++ b/src/oBus_address.ml @@ -0,0 +1,116 @@ +(* + * oBus_address.ml + * --------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(address)" + +(* +-----------------------------------------------------------------+ + | Types | + +-----------------------------------------------------------------+ *) + +type guid = OBus_uuid.t + +type t = { + name : string; + args : (string * string) list; +} + +let name a = a.name +let args a = a.args + +let make ~name ~args = { name = name; args = args } + +let arg arg address = + OBus_util.assoc arg address.args + +let guid address = + match OBus_util.assoc "guid" address.args with + | Some guid -> Some(OBus_uuid.of_string guid) + | None -> None + +(* +-----------------------------------------------------------------+ + | Parsing/marshaling | + +-----------------------------------------------------------------+ *) + +exception Parse_failure of string * int * string + +let () = + Printexc.register_printer + (function + | Parse_failure(str, pos, msg) -> + Some(Printf.sprintf "failed to parse D-Bus addresses %S, at position %d: %s" str pos msg) + | _ -> + None) + +let of_string str = + try + List.map + (fun (name, args) -> { name = name; args = args }) + (OBus_address_lexer.addresses (Lexing.from_string str)) + with OBus_address_lexer.Fail(pos, msg) -> + raise (Parse_failure(str, pos, msg)) + +let to_string l = + let buf = Buffer.create 42 in + let escape = String.iter begin fun ch -> match ch with + | '0'..'9' | 'A'..'Z' | 'a'..'z' + | '_' | '-' | '/' | '.' | '\\' -> + Buffer.add_char buf ch + | _ -> + Printf.bprintf buf "%%%02x" (Char.code ch) + end in + let concat ch f = function + | [] -> () + | x :: l -> f x; List.iter (fun x -> Buffer.add_char buf ch; f x) l + in + concat ';' begin fun { name = name; args = args } -> + Buffer.add_string buf name; + Buffer.add_char buf ':'; + concat ',' + (fun (k, v) -> + Buffer.add_string buf k; + Buffer.add_char buf '='; + escape v) + args + end l; + Buffer.contents buf + +(* +-----------------------------------------------------------------+ + | Well known addresses | + +-----------------------------------------------------------------+ *) + +let system_bus_variable = "DBUS_SYSTEM_BUS_ADDRESS" +let session_bus_variable = "DBUS_SESSION_BUS_ADDRESS" + +let default_system = [{ name = "unix"; args = [("path", "/var/run/dbus/system_bus_socket")] }] +let default_session = [{ name = "autolaunch"; args = [] }] + +open Lwt + +let system = lazy( + match try Some (Sys.getenv system_bus_variable) with Not_found -> None with + | Some str -> + return (of_string str) + | None -> + lwt () = Lwt_log.info_f ~section "environment variable %s not found, using internal default" system_bus_variable in + return default_system +) + +let session = lazy( + match try Some(Sys.getenv session_bus_variable) with Not_found -> None with + | Some line -> + return (of_string line) + | None -> + lwt () = Lwt_log.info_f ~section "environment variable %s not found, trying to get session bus address from launchd" session_bus_variable in + try_lwt + lwt path = Lwt_process.pread_line ("launchctl", [|"launchctl"; "getenv"; "DBUS_LAUNCHD_SESSION_BUS_SOCKET"|]) in + return [{ name = "unix"; args = [("path", path)] }] + with exn -> + lwt () = Lwt_log.info_f ~exn ~section "failed to get session bus address from launchd, using internal default" in + return default_session +) diff --git a/src/oBus_address.mli b/src/oBus_address.mli new file mode 100644 index 0000000..3b7c10d --- /dev/null +++ b/src/oBus_address.mli @@ -0,0 +1,71 @@ +(* + * oBus_address.mli + * ---------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Manipulation of D-Bus addresses *) + +(** {6 Types} *) + +type guid = OBus_uuid.t + (** A unique address identifier. Each server listenning address' + has a unique one. *) + +(** Type of an address *) +type t = { + name : string; + (** The transport name *) + + args : (string * string) list; + (** Arguments of the address *) +} + +val name : t -> string + (** [name] projection *) + +val args : t -> (string * string) list + (** [args] Projection *) + +val make : name : string -> args : (string * string) list -> t + (** Creates an address *) + +val arg : string -> t -> string option + (** [arg key address] returns the value of argument [key], if any *) + +val guid : t -> guid option + (** Returns the address guid, if any *) + +(** {6 To/from string conversion} *) + +exception Parse_failure of string * int * string + (** [Parse_failure(string, position, reason)] exception raised when + parsing a string failed. *) + +val of_string : string -> t list + (** [of_string str] parse [str] and return the list of addresses + defined in it. + + @raise Parse_failure if the string contains an invalid address + *) + +val to_string : t list -> string + (** [to_string addresses] return a string representation of a list + of addresses *) + +(** {6 Well-known addresses} *) + +val system : t list Lwt.t Lazy.t + (** The list of addresses for system bus *) + +val session : t list Lwt.t Lazy.t + (** The list of addresses for session bus *) + +val default_system : t list + (** The default addresses for the system bus *) + +val default_session : t list + (** The default addresses for the session bus *) diff --git a/src/oBus_address_lexer.mll b/src/oBus_address_lexer.mll new file mode 100644 index 0000000..db0a666 --- /dev/null +++ b/src/oBus_address_lexer.mll @@ -0,0 +1,106 @@ +(* + * oBus_address_lexer.mll + * ---------------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +{ + exception Fail of int * string + + let pos lexbuf = lexbuf.Lexing.lex_start_p.Lexing.pos_cnum + + let fail lexbuf fmt = + Printf.ksprintf + (fun msg -> raise (Fail(pos lexbuf, msg))) + fmt +} + +let name = [^ ':' ',' ';' '=']+ + +rule addresses = parse + | eof { [] } + | "" { address_plus lexbuf } + +and address_plus = parse + | name as name { + check_colon lexbuf; + let parameters = parameters lexbuf in + if semi_colon lexbuf then + (name, parameters) :: address_plus lexbuf + else begin + check_eof lexbuf; + [(name, parameters)] + end + } + | ":" { + fail lexbuf "empty transport name" + } + | eof { + fail lexbuf "address expected" + } + +and semi_colon = parse + | ";" { true } + | "" { false } + +and check_eof = parse + | eof { () } + | _ as ch { fail lexbuf "invalid character %C" ch } + +and check_colon = parse + | ":" { () } + | "" { fail lexbuf "colon expected after transport name" } + +and parameters = parse + | name as key { + check_equal lexbuf; + let value = value (Buffer.create 42) lexbuf in + if coma lexbuf then + (key, value) :: parameters_plus lexbuf + else + [(key, value)] + } + | "=" { fail lexbuf "empty key" } + | "" { [] } + +and parameters_plus = parse + | name as key { + check_equal lexbuf; + let value = value (Buffer.create 42) lexbuf in + if coma lexbuf then + (key, value) :: parameters_plus lexbuf + else + [(key, value)] + } + | "=" { fail lexbuf "empty key" } + | "" { fail lexbuf "parameter expected" } + +and coma = parse + | "," { true } + | "" { false } + +and check_equal = parse + | "=" { () } + | "" { fail lexbuf "equal expected after key" } + +and value buf = parse + | [ '0'-'9' 'A'-'Z' 'a'-'z' '_' '-' '/' '.' '\\' ] as ch { + Buffer.add_char buf ch; + value buf lexbuf + } + | "%" { + Buffer.add_string buf (unescape lexbuf); + value buf lexbuf + } + | "" { + Buffer.contents buf + } + +and unescape = parse + | [ '0'-'9' 'a'-'f' 'A'-'F' ] [ '0'-'9' 'a'-'f' 'A'-'F' ] as str + { OBus_util.hex_decode str } + | "" + { failwith "two hexdigits expected after '%'" } diff --git a/src/oBus_auth.ml b/src/oBus_auth.ml new file mode 100644 index 0000000..f49af5f --- /dev/null +++ b/src/oBus_auth.ml @@ -0,0 +1,856 @@ +(* + * oBus_auth.ml + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(auth)" + +open Printf +open Lwt + +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 -> raise_lwt (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( + lwt homedir = Lazy.force OBus_util.homedir in + return (Filename.concat homedir ".dbus-keyrings") + ) + + let keyring_file_name context = + lwt dir = Lazy.force keyring_directory in + 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 = + 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 -> + lwt fname = keyring_file_name context in + lwt () = Lwt_log.error_f ~exn ~section "failed to load cookie file %s" fname in + raise_lwt exn + else + 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 -> + lwt () = + try_lwt + lwt () = Lwt_unix.unlink fname in + Lwt_log.info_f ~section "stale lock file %s removed" fname + with Unix.Unix_error(error, _, _) as exn -> + lwt () = Lwt_log.error_f ~section "failed to remove stale lock file %s: %s" fname (Unix.error_message error) in + raise_lwt exn + in + (try_lwt + really_lock () + with Unix.Unix_error(error, _, _) as exn -> + lwt () = Lwt_log.error_f ~section "failed to lock file %s after removing it: %s" fname (Unix.error_message error) in + raise_lwt exn) + | n -> + try_lwt + really_lock () + with exn -> + lwt () = Lwt_log.info_f ~section "waiting for lock file (%d) %s" n fname in + 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 -> + lwt () = Lwt_log.error_f ~section "failed to unlink file %s: %s" fname (Unix.error_message error) in + raise_lwt exn + + let save context cookies = + 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 + lwt dir = Lazy.force keyring_directory in + 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 -> + lwt () = Lwt_log.error_f ~section "failed to create directory %s with permissions 0600: %s" dir (Unix.error_message error) in + raise_lwt exn + end else + return () + in + lwt () = lock_file lock_fname in + try_lwt + lwt () = + try_lwt + Lwt_io.lines_to_file tmp_fname (Lwt_stream.map print_line (Lwt_stream.of_list cookies)) + with exn -> + lwt () = Lwt_log.error_f ~exn ~section "unable to write temporary keyring file %s" tmp_fname in + raise_lwt exn + in + try + Lwt_unix.rename tmp_fname fname + with Unix.Unix_error(error, _, _) as exn -> + lwt () = Lwt_log.error_f ~section "unable to rename file %s to %s: %s" tmp_fname fname (Unix.error_message error) in + raise_lwt exn + 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 -> + raise_lwt exn + | End_of_file -> + raise_lwt (Auth_failure("input: premature end of input")) + | exn -> + raise_lwt (Auth_failure("input: " ^ Printexc.to_string exn))); + send = (fun line -> + try_lwt + send line + with + | Auth_failure _ as exn -> + raise_lwt exn + | exn -> + raise_lwt (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 + raise_lwt (Auth_failure "input: line too long") + else + Lwt_io.read_char_opt ic >>= function + | None -> + raise_lwt (Auth_failure "input: premature end of input") + | Some ch -> + Buffer.add_char buf ch; + if last = '\r' && ch = '\n' then + return (Buffer.contents buf) + else + loop ch + in + loop '\x00') + ~send:(fun line -> + 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 = String.create 1 in + let rec loop last = + if Buffer.length buf > max_line_length then + raise_lwt (Auth_failure "input: line too long") + else + Lwt_unix.read fd tmp 0 1 >>= function + | 0 -> + raise_lwt (Auth_failure "input: premature end of input") + | 1 -> + let ch = tmp.[0] in + Buffer.add_char buf ch; + if last = '\r' && ch = '\n' then + 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 + return () + else + Lwt_unix.write fd line ofs len >>= function + | 0 -> + raise_lwt (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 = + lwt line = stream.recv () in + let len = String.length line in + if len < 2 || not (line.[len - 2] = '\r' && line.[len - 1] = '\n') then + raise_lwt (Auth_failure("input: invalid line received")) + else + 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 = + lwt line = recv_line stream in + 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 -> return x + | `Failure(Failure msg) -> + lwt () = send_line mode stream ("ERROR \"" ^ msg ^ "\"") in + recv mode command_parser stream + | `Failure exn -> raise_lwt 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) = 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 = return (Mech_ok(string_of_int (Unix.getuid ()))) + end + + class mech_anonymous_handler = object + inherit mechanism_handler + method init = return (Mech_ok("obus " ^ OBus_info.version)) + end + + class mech_dbus_cookie_sha1_handler = object + method init = return (Mech_continue(string_of_int (Unix.getuid ()))) + method data chal = + 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 + 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 + lwt () = Lwt_log.debug_f ~section "client: dbus_cookie_sha1: resp: %s" resp in + 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 + | [] -> + 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 -> + return (Transition(Client_auth(Some (name, Some resp)), + Waiting_for_data mech, + mechs)) + | Mech_ok resp -> + 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 -> + return (Transition(Client_data resp, + Waiting_for_data mech, + mechs)) + | Mech_ok resp -> + return (Transition(Client_data resp, + Waiting_for_ok, + mechs)) + | Mech_error msg -> + return (Transition(Client_error msg, + Waiting_for_data mech, + mechs)) + with exn -> + 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; + return (Transition(Client_cancel, + Waiting_for_reject, + mechs)) + | Server_ok guid -> + mech#abort; + return (Success guid) + | Server_agree_unix_fd -> + mech#abort; + return (Transition(Client_error "command not expected here", + Waiting_for_data mech, + mechs)) + end + + | Waiting_for_ok -> begin match cmd with + | Server_ok guid -> + return (Success guid) + | Server_rejected am -> + next mechs am + | Server_data _ + | Server_error _ -> + return (Transition(Client_cancel, + Waiting_for_reject, + mechs)) + | Server_agree_unix_fd -> + 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 + | _ -> return Failure + end + + let authenticate ?(capabilities=[]) ?(mechanisms=default_mechanisms) ~stream () = + let rec loop = function + | Transition(cmd, state, mechs) -> + lwt () = client_send stream cmd in + lwt cmd = client_recv stream in + transition mechs state cmd >>= loop + | Success guid -> + lwt caps = + if List.mem `Unix_fd capabilities then + lwt () = client_send stream Client_negotiate_unix_fd in + client_recv stream >>= function + | Server_agree_unix_fd -> + return [`Unix_fd] + | Server_error _ -> + return [] + | _ -> + (* This case is not covered by the + specification *) + return [] + else + return [] + in + lwt () = client_send stream Client_begin in + 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 = 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' -> + return (Mech_ok(Some user_id)) + | _ -> + return Mech_reject + end + + class mech_anonymous_handler = object + inherit mechanism_handler + method data _ = 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 + 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); + 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 *) + lwt id, cookie = match keyring with + | { Cookie.id = id; Cookie.cookie = cookie } :: _ -> + (* There is still valid cookies, just choose one *) + 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 + lwt () = Keyring.save context [{ Cookie.id = id; Cookie.time = cur_time; Cookie.cookie = cookie }] in + return (id, cookie) + in + let rand = hex_encode (OBus_util.random_string 16) in + let chal = sprintf "%s %ld %s" context id rand in + lwt () = Lwt_log.debug_f ~section "server: dbus_cookie_sha1: chal: %s" chal in + state <- `State2(cookie, rand); + 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 + return (Mech_ok user_id) + else + return Mech_reject) + + with _ -> + 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 = + return (Transition(Server_rejected (List.map mech_name mechs), + Waiting_for_auth)) + + let error msg = + 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 + lwt init = mech#init in + match init, resp with + | None, None -> + return (Transition(Server_data "", + Waiting_for_data mech)) + | Some chal, None -> + 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 -> + return (Transition(Server_data chal, + Waiting_for_data mech)) + | Mech_ok uid -> + return (Transition(Server_ok guid, + Waiting_for_begin(uid, []))) + | Mech_reject -> + reject mechs + with exn -> + reject mechs + end + | Client_begin -> return Failure + | Client_error msg -> reject mechs + | _ -> error "AUTH command expected" + end + + | Waiting_for_data mech -> begin match cmd with + | Client_data "" -> + return (Transition(Server_data "", + Waiting_for_data mech)) + | Client_data resp -> begin + try_lwt + mech#data resp >>= function + | Mech_continue chal -> + return (Transition(Server_data chal, + Waiting_for_data mech)) + | Mech_ok uid -> + return (Transition(Server_ok guid, + Waiting_for_begin(uid, []))) + | Mech_reject -> + reject mechs + with exn -> + reject mechs + end + | Client_begin -> mech#abort; 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 -> + return (Accept(uid, caps)) + | Client_cancel -> + reject mechs + | Client_error _ -> + reject mechs + | Client_negotiate_unix_fd -> + if List.mem `Unix_fd capabilities then + return(Transition(Server_agree_unix_fd, + Waiting_for_begin(uid, + if List.mem `Unix_fd caps then + caps + else + `Unix_fd :: caps))) + else + 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 = + 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 + lwt () = server_send stream cmd in + loop state count + | Accept(uid, caps) -> + return (uid, caps) + | Failure -> + auth_failure "authentication failure" + in + loop Waiting_for_auth 0 +end diff --git a/src/oBus_auth.mli b/src/oBus_auth.mli new file mode 100644 index 0000000..10f101a --- /dev/null +++ b/src/oBus_auth.mli @@ -0,0 +1,186 @@ +(* + * oBus_auth.mli + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Handle authentication mechanisms *) + +type data = string + (** Data for an authentication mechanism *) + +exception Auth_failure of string + (** Exception raise when authentication fail *) + +(** List of capatilities clients/servers may support *) +type capability = + [ `Unix_fd + (** The transport support 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 reads a complete line, ending with ["\r\n"], + @param send must sends 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 lenght 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 authentified. 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-size 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 clinet used anonymous authentication, and may + be disconnected according to server policy. + + Note: [authenticate] does not read the first zero byte. You + must read it by hand, and maybe use it to receive credentials. + + @param user_id is the user id determined by external method + @param capabilities defaults to [[]] + @param mechanisms default to {!default_mechanisms} + *) +end diff --git a/src/oBus_bus.ml b/src/oBus_bus.ml new file mode 100644 index 0000000..33c59c5 --- /dev/null +++ b/src/oBus_bus.ml @@ -0,0 +1,250 @@ +(* + * oBus_bus.ml + * ----------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(bus)" + +open Lwt_react +open Lwt +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 + lwt name = OBus_method.call m_Hello (proxy connection) () in + OBus_connection.set_name connection name; + return () + | Some _ -> + return () + +let of_addresses ?switch addresses = + lwt bus = OBus_connection.of_addresses ?switch addresses ~shared:true in + lwt () = register_connection bus in + return bus + +let session_bus = lazy( + try_lwt + lwt bus = Lazy.force OBus_address.session >>= of_addresses in + OBus_connection.set_on_disconnect bus exit_on_disconnect; + return bus + with exn -> + lwt () = Lwt_log.warning ~exn ~section "Failed to open a connection to the session bus" in + raise_lwt exn +) + +let session ?switch () = + Lwt_switch.check switch; + lwt bus = Lazy.force session_bus in + lwt () = Lwt_switch.add_hook_or_exec switch (fun () -> OBus_connection.close bus) in + return bus + +let system_bus_state = ref None +let system_bus_mutex = Lwt_mutex.create () + +let system ?switch () = + Lwt_switch.check switch; + lwt bus = + Lwt_mutex.with_lock system_bus_mutex + (fun () -> + match !system_bus_state with + | Some bus when S.value (OBus_connection.active bus) -> + return bus + | _ -> + try_lwt + lwt bus = Lazy.force OBus_address.system >>= of_addresses in + system_bus_state := Some bus; + return bus + with exn -> + lwt () = Lwt_log.warning ~exn ~section "Failed to open a connection to the system bus" in + raise_lwt exn) + in + lwt () = Lwt_switch.add_hook_or_exec switch (fun () -> OBus_connection.close bus) in + return bus + +(* +-----------------------------------------------------------------+ + | Bindings to functions of the message bus | + +-----------------------------------------------------------------+ *) + +exception Access_denied of string + with obus("org.freedesktop.DBus.Error.AccessDenied") + +exception Service_unknown of string + with obus("org.freedesktop.DBus.Error.ServiceUnknown") + +exception Match_rule_not_found of string + with obus("org.freedesktop.DBus.Error.MatchRuleNotFound") + +exception Match_rule_invalid of string + with obus("org.freedesktop.DBus.Error.MatchRuleInvalid") + +exception Service_unknown of string + with obus("org.freedesktop.DBus.Error.ServiceUnknown") + +exception Name_has_no_owner of string + with obus("org.freedesktop.DBus.Error.NameHasNoOwner") + +exception Adt_audit_data_unknown of string + with obus("org.freedesktop.DBus.Error.AdtAuditDataUnknown") + +exception Selinux_security_context_unknown of string + with 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 + lwt unique_name = get_name_owner bus name in + return (OBus_peer.make bus unique_name) + with Name_has_no_owner msg -> + lwt _ = start_service_by_name bus name in + lwt unique_name = get_name_owner bus name in + return (OBus_peer.make bus unique_name) + +let get_proxy bus name path = + lwt peer = get_peer bus name in + return (OBus_proxy.make peer path) diff --git a/src/oBus_bus.mli b/src/oBus_bus.mli new file mode 100644 index 0000000..142731b --- /dev/null +++ b/src/oBus_bus.mli @@ -0,0 +1,206 @@ +(* + * oBus_bus.mli + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Message buses management *) + +type t = OBus_connection.t + +(** {6 Well-known instances} *) + +val session : ?switch : Lwt_switch.t -> unit -> t Lwt.t + (** [session ?switch ()] returns a connection to the user session + message bus. Subsequent calls to {!session} will return the same + bus. OBus will automatically exits the program when an error + happen 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 it + 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 + 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] return 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] resolve [name] with {!get_peer} and + return 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 specify + 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 optionnal parameters default to [false], their meaning are: + + - [allow_replacement]: allow other application to steal you the name + - [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 + (** Return [true] if the service is currently running, i.e. some + application offer 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 applications waiting for a + name *) + +exception Service_unknown of string + (** Raised when we try to contact a service which is not available + and the bus do not known how to start it *) + +(** {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 try 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 emited each time the owner of a name (unique + connection name or service name) change. *) + +val name_lost : t -> OBus_name.bus OBus_signal.t +val name_acquired : t -> OBus_name.bus OBus_signal.t diff --git a/src/oBus_config.ml.ab b/src/oBus_config.ml.ab new file mode 100644 index 0000000..e16223d --- /dev/null +++ b/src/oBus_config.ml.ab @@ -0,0 +1,14 @@ +(* -*- tuareg -*- + * OBus_config.ml + * -------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(* Localtion of the machine id file: *) +let machine_uuid_file = "/var/lib/dbus/machine-id" + +(* Version of obus: *) +let version = "$(pkg_version)" diff --git a/src/oBus_connection.ml b/src/oBus_connection.ml new file mode 100644 index 0000000..9cc68f0 --- /dev/null +++ b/src/oBus_connection.ml @@ -0,0 +1,667 @@ +(* + * oBus_connection.ml + * ------------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(connection)" + +open Lwt_react +open Lwt + +(* +-----------------------------------------------------------------+ + | Exceptions | + +-----------------------------------------------------------------+ *) + +exception Connection_closed +exception Connection_lost +exception Transport_error of exn + +let () = + Printexc.register_printer + (function + | Connection_closed -> + Some "D-Bus connection closed" + | Connection_lost -> + Some "D-Bus connection lost" + | Transport_error exn -> + Some(Printf.sprintf "D-Bus transport failure: %s" (Printexc.to_string exn)) + | _ -> + None) + +(* +-----------------------------------------------------------------+ + | Types | + +-----------------------------------------------------------------+ *) + +module Serial_map = Map.Make + (struct + type t = OBus_message.serial + let compare : int32 -> int32 -> int = compare + end) + +module Int_map = Map.Make + (struct + type t = int + let compare : int -> int -> int = compare + end) + +type filter = OBus_message.t -> OBus_message.t option + (* Type of message filters *) + +(* Connection are wrapped into object in order to make them + comparable. In the code, wrapped connection are simply referred has + "connection" and internal connection details are referred as + "active". *) + +(* Type of active connections *) +type active_connection = { + mutable name : OBus_name.bus; + (* The name of the connection in case the endpoint is a message bus, + or [""] if not. *) + + transport : OBus_transport.t; + (* The transport used for messages *) + + mutable on_disconnect : exn -> unit Lwt.t; + (* [on_disconnect] is called the connection is closed + prematurely. This happen on transport errors. *) + + guid : OBus_address.guid option; + (* Guid of the connection. It may is [Some guid] if this is the + client-side part of a peer-to-peer connection and the connection + is shared. *) + + down : (unit Lwt.t * unit Lwt.u) option signal; + set_down : (unit Lwt.t * unit Lwt.u) option -> unit; + (* Waiting thread used to make the connection to stop dispatching + messages. *) + + state : [ `Up | `Down ] signal; + + abort_recv_wakener : OBus_message.t Lwt.u; + abort_send_wakener : unit Lwt.u; + abort_recv_waiter : OBus_message.t Lwt.t; + abort_send_waiter : unit Lwt.t; + (* Waiting threads wakeup when the connection is closed or + aborted. It is used to make the dispatcher/writer to exit. *) + + mutable next_serial : OBus_message.serial; + (* The first available serial, incremented for each message *) + + mutable outgoing_mutex : Lwt_mutex.t; + (* Mutex used to serialise message sending *) + + incoming_filters : filter Lwt_sequence.t; + outgoing_filters : filter Lwt_sequence.t; + + mutable reply_waiters : OBus_message.t Lwt.u Serial_map.t; + (* Mapping serial -> thread waiting for a reply *) + + mutable data : exn Int_map.t; + (* Set of locally stored values *) + + wrapper : t; + (* The wrapper containing the connection *) +} + +(* State of a connection *) +and connection_state = + | Active of active_connection + (* The connection is currently active *) + | Closed + (* The connection has been closed gracefully *) + | Killed + (* The connection has been killed after an error happened *) + +(* Connections are packed into objects to make them comparable *) +and t = < + state : connection_state; + (* Get the connection state *) + + set_state : connection_state -> unit; + (* Sets the state of the connection *) + + get : active_connection; + (* Returns the connection if it is active, and fail otherwise *) + + active : bool signal; + (* Signal holding the current connection state. *) +> + +let compare : t -> t -> int = Pervasives.compare + +(* +-----------------------------------------------------------------+ + | Guids | + +-----------------------------------------------------------------+ *) + +(* Mapping from server guid to connection. *) +module Guid_map = Map.Make(struct + type t = OBus_address.guid + let compare = Pervasives.compare + end) + +let guid_connection_map = ref Guid_map.empty + +(* +-----------------------------------------------------------------+ + | Filters | + +-----------------------------------------------------------------+ *) + +(* Apply a list of filter on a message, logging failure *) +let apply_filters typ message filters = + try + Lwt_sequence.fold_l + (fun filter message -> match message with + | Some message -> filter message + | None -> None) + filters (Some message) + with exn -> + ignore (Lwt_log.error_f ~section ~exn "an %s filter failed with" typ); + None + +(* +-----------------------------------------------------------------+ + | Connection closing | + +-----------------------------------------------------------------+ *) + +let cleanup active ~is_crash = + begin + match active.guid with + | Some guid -> + guid_connection_map := Guid_map.remove guid !guid_connection_map + | None -> + () + end; + + (* This make the dispatcher to exit if it is waiting on + [get_message] *) + wakeup_exn active.abort_recv_wakener Connection_closed; + begin + match S.value active.down with + | Some(waiter, wakener) -> + wakeup_exn wakener Connection_closed + | None -> + () + end; + + (* Wakeup all reply handlers so they will not wait forever *) + Serial_map.iter (fun _ wakener -> wakeup_exn wakener Connection_closed) active.reply_waiters; + + (* If the connection is closed normally, flush it *) + lwt () = + if not is_crash then + Lwt_mutex.with_lock active.outgoing_mutex return + else begin + wakeup_exn active.abort_send_wakener Connection_closed; + 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 -> + return () + | Active active -> + connection#set_state Closed; + cleanup active ~is_crash:false + +let kill connection exn = + match connection#state with + | Killed | Closed -> + return () + | Active active -> + connection#set_state Killed; + 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 -> + lwt () = Lwt_log.debug ~section "outgoing message dropped by filters" in + raise_lwt (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; + 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 + lwt () = choose [active.abort_send_waiter; + (* Do not cancel a thread while it is marshaling message: *) + 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; + return () + with + | OBus_wire.Data_error _ as exn -> + (* The message can not be marshaled for some + reason. This is not a fatal error. *) + raise_lwt exn + + | Canceled -> + (* Message sending have been canceled by the + user. This is not a fatal error either. *) + raise_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 *) + lwt () = kill connection exn in + raise_lwt exn + end else + match connection#state with + | Killed | Closed -> + raise_lwt Connection_closed + | Active _ -> + 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 = task () in + 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 = task () in + 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 + 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 + return (o_msg, OBus_value.C.cast_sequence o_args body) + with OBus_value.C.Signature_mismatch -> + raise_lwt (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) :: _ } -> + raise_lwt (OBus_error.make error_name message) + | { OBus_message.typ = OBus_message.Error(_, error_name) } -> + raise_lwt (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; + wakeup w message; + 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 + lwt body = + match member, body with + | "Ping", [] -> + return [] + | "GetMachineId", [] -> begin + try_lwt + lwt uuid = Lazy.force OBus_info.machine_uuid in + return [OBus_value.V.basic_string (OBus_uuid.to_string uuid)] + with exn -> + if OBus_error.name exn = OBus_error.ocaml then + raise_lwt + (OBus_error.Failed + (Printf.sprintf + "Cannot read the machine uuid file (%s)" + OBus_config.machine_uuid_file)) + else + raise_lwt exn + end + | _ -> + raise_lwt + (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 *) + return () + +let rec dispatch_forever active = + lwt () = + (* Wait for the connection to become up *) + match S.value active.down with + | Some(waiter, wakener) -> + waiter + | None -> + return () + in + lwt message = + try_lwt + choose [OBus_transport.recv active.transport; active.abort_recv_waiter] + with exn -> + lwt () = kill active.wrapper (Transport_error exn) in + raise_lwt exn + in + match apply_filters "incoming" message active.incoming_filters with + | None -> + 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" + 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(wait ())) in + let state = S.map (function None -> `Up | Some _ -> `Down) down in + let active = { + name = ""; + transport; + on_disconnect = (fun exn -> 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 -> + lwt guid, transport = OBus_transport.of_addresses ~capabilities addresses in + 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); + 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. *) + lwt guid, transport = OBus_transport.of_addresses ~capabilities addresses in + 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; + wakeup wakener () + +let set_down connection = + let active = connection#get in + match S.value active.down with + | Some _ -> + () + | None -> + active.set_down (Some(wait ())) + +let incoming_filters connection = connection#get.incoming_filters +let outgoing_filters connection = connection#get.outgoing_filters diff --git a/src/oBus_connection.mli b/src/oBus_connection.mli new file mode 100644 index 0000000..1d8a30d --- /dev/null +++ b/src/oBus_connection.mli @@ -0,0 +1,239 @@ +(* + * oBus_connection.mli + * ------------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus connections *) + +(** This module implement manipulation of a D-Bus connection. A D-Bus + connection is a channel opened with another application which also + implement the D-Bus protocol. It is used to exchange D-Bus + messages. *) + +type t + (** Type of D-Bus connections *) + +val compare : t -> t -> int + (** Same as [Pervasives.compare]. It allows this module to be used + as argument to the functors [Set.Make] and [Map.Make]. *) + +(** {6 Creation} *) + +(** The following functions will return a connection which is ready to + send and receive messages. You should use them only for direct + connection to another application without passing through a + message bus. + + Otherwise you should use [OBus_bus] or immediatly 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 + (** Creates 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 + (** Raise 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 happen 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 + meaning-full 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 wait 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 do 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 do 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 do not expect a reply *) + +(** {6 General purpose filters} *) + +(** Filters are functions whose 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 incomming messages *) + +val outgoing_filters : t -> filter Lwt_sequence.t + (** Filters appllied on outgoing messages *) + +(** {6 Connection's local Storage} *) + +(** Connection's local storage allow 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, expect for connection created with + [of_transport], newly created connection are always up. + + When a connection is down, messages will not be dispatched *) + +val state : t -> [ `Up | `Down ] React.signal + (** Signal holding the current state of the connection *) + +val set_up : t -> unit + (** Sets up the connection if it is not already up *) + +val set_down : t -> unit + (** Sets down the connection if it is not already down *) diff --git a/src/oBus_context.ml b/src/oBus_context.ml new file mode 100644 index 0000000..f7f9de6 --- /dev/null +++ b/src/oBus_context.ml @@ -0,0 +1,37 @@ +(* + * oBus_context.ml + * --------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +type t = { + connection : OBus_connection.t; + flags : OBus_message.flags; + sender : OBus_peer.t; + destination : OBus_peer.t; + serial : OBus_message.serial; +} + +let key = Lwt.new_key () + +let get () = + match Lwt.get key with + | Some ctx -> ctx + | None -> failwith "OBus_context.get: not in a method call handler" + +let make ~connection ~message = { + connection = connection; + flags = OBus_message.flags message; + sender = OBus_peer.make connection (OBus_message.sender message); + destination = OBus_peer.make connection (OBus_message.destination message); + serial = OBus_message.serial message; +} + +let connection ctx = ctx.connection +let flags ctx = ctx.flags +let serial ctx = ctx.serial +let sender ctx = ctx.sender +let destination ctx = ctx.destination diff --git a/src/oBus_context.mli b/src/oBus_context.mli new file mode 100644 index 0000000..b96727c --- /dev/null +++ b/src/oBus_context.mli @@ -0,0 +1,51 @@ +(* + * oBus_context.mli + * ---------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Message contexts *) + +(** {6 Types} *) + +(** A context contains information about the reception of a + message. *) + +type t + (** Type of a context. *) + +(** {6 Creation} *) + +val make : connection : OBus_connection.t -> message : OBus_message.t -> t + (** Creates a context from the given connection and message *) + +(** {6 Retreival} *) + +val get : unit -> t + (** In a method call handler, this returns the context of the method + call. *) + +val key : t Lwt.key + (** The key used for storing the context. *) + +(** {6 Projections} *) + +val connection : t -> OBus_connection.t + (** Returns the connection part of a context *) + +val sender : t -> OBus_peer.t + (** [sender context] returns the peer who sends the message *) + +val destination : t -> OBus_peer.t + (** [destinatino context] returns the peer to which the message were + sent *) + +val flags : t -> OBus_message.flags + (** [flags context] returns the flags of the message that was + received *) + +val serial : t -> OBus_message.serial + (** Returns the serial of the message *) diff --git a/src/oBus_error.ml b/src/oBus_error.ml new file mode 100644 index 0000000..a0fee17 --- /dev/null +++ b/src/oBus_error.ml @@ -0,0 +1,124 @@ +(* + * oBus_error.ml + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +type name = string +type message = string + +type error = { + name : name; + make : message -> exn; + cast : exn -> message option; +} + +exception DBus of name * message + +let ocaml = "org.ocamlcore.forge.obus.OCamlException" + +let () = + Printexc.register_printer + (function + | DBus(name, message) -> Some(Printf.sprintf "%s: %s" name message) + | _ -> None) + +(* List of all registered D-Bus errors *) +let errors = ref [] + +(* +-----------------------------------------------------------------+ + | Creation/casting | + +-----------------------------------------------------------------+ *) + +let make name message = + let rec loop = function + | [] -> + DBus(name, message) + | error :: errors -> + if error.name = name then + error.make message + else + loop errors + in + loop !errors + +let cast exn = + let rec loop = function + | [] -> + (ocaml, Printexc.to_string exn) + | error :: errors -> + match error.cast exn with + | Some message -> (error.name, message) + | None -> loop errors + in + match exn with + | DBus(name, message) -> (name, message) + | _ -> loop !errors + +let name exn = + let rec loop = function + | [] -> + ocaml + | error :: errors -> + match error.cast exn with + | Some message -> error.name + | None -> loop errors + in + match exn with + | DBus(name, message) -> name + | _ -> loop !errors + +(* +-----------------------------------------------------------------+ + | Registration | + +-----------------------------------------------------------------+ *) + +module type Error = sig + exception E of string + val name : name +end + +module Register(Error : Error) = +struct + let () = + errors := { + name = Error.name; + make = (fun message -> Error.E message); + cast = (function + | Error.E message -> Some message + | _ -> None); + } :: !errors +end + +(* +-----------------------------------------------------------------+ + | Well-known exceptions | + +-----------------------------------------------------------------+ *) + +exception Failed of message + with obus("org.freedesktop.DBus.Error.Failed") + +exception Invalid_args of message + with obus("org.freedesktop.DBus.Error.InvalidArgs") + +exception Unknown_method of message + with obus("org.freedesktop.DBus.Error.UnknownMethod") + +exception Unknown_object of message + with obus("org.freedesktop.DBus.Error.UnknownObject") + +exception Unknown_interface of message + with obus("org.freedesktop.DBus.Error.UnknownInterface") + +exception Unknown_property of message + with obus("org.freedesktop.DBus.Error.UnknownProperty") + +exception Property_read_only of message + with obus("org.freedesktop.DBus.Error.PropertyReadOnly") + +exception No_memory of message + with obus("org.freedesktop.DBus.Error.NoMemory") + +exception No_reply of message + with obus("org.freedesktop.DBus.Error.NoReply") diff --git a/src/oBus_error.mli b/src/oBus_error.mli new file mode 100644 index 0000000..5dd14b1 --- /dev/null +++ b/src/oBus_error.mli @@ -0,0 +1,120 @@ +(* + * oBus_error.mli + * -------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus errors management *) + +(** This module integrates D-Bus errors into OCaml exceptions, and + OCaml exceptions into D-Bus errors. + + To do this, an OCaml exception that maps a D-Bus error should be + registered with {!Register}. *) + +type name = OBus_name.error + (** An error name. For example: ["org.foo.bar.Error.Failed"] *) + +type message = string + (** An error message *) + +exception DBus of name * message + (** General exception for D-Bus errors. When the reply to a method + call is a D-Bus error that have not been registered, this + exception is raised. + + Arguments are: + - the D-Bus error name + - the error message + *) + +val ocaml : name + (** The name of the D-Bus error which is generated for uncaught + ocaml exceptions that have not been registered *) + +(** {6 D-Bus errors creating/casting} *) + +val name : exn -> name + (** [name exn] returns the D-Bus error name under which this + exception is registered. If the exception is not registered, + then [ocaml] is returned. *) + +val make : name -> message -> exn + (** [make exn message] creates an exception from an error name and + an error message. If the name is not registered, then + [DBus(name, message)] is returned. *) + +val cast : exn -> name * message + (** [cast exn] returns the D-Bus name and message of the given + exception. If the exception is not registered, [(ocaml, + Printexc.to_string exn)] is returned. *) + +(** {6 Errors registration} *) + +(** Signature for D-Bus error *) +module type Error = sig + exception E of string + (** The OCaml exception for this error *) + + val name : name + (** The D-Bus name if this error *) +end + +module Register(Error : Error) : sig end + (** Register an error. The typical use of the functor is: + + {[ + exception My_exception of string + let module M = + OBus_error.Register(struct + exception E = My_exception + let name = "my.exception.name" + end) + in () + ]} + + But you can althoug write this with the syntax extension: + + {[ + exception My_exception of string + with 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 + (** "org.freedesktop.DBus.Error.NoReply" *) diff --git a/src/oBus_idl.ml b/src/oBus_idl.ml new file mode 100644 index 0000000..d271db3 --- /dev/null +++ b/src/oBus_idl.ml @@ -0,0 +1,278 @@ +(* + * oBus_idl.ml + * ----------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Camlp4.PreCast +open Syntax +open OBus_introspect_ext +open OBus_value + +(* +-----------------------------------------------------------------+ + | Parsing | + +-----------------------------------------------------------------+ *) + +let interfaces = Gram.Entry.mk "interfaces" + +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 + +EXTEND Gram + GLOBAL: interfaces; + + ident: + [ [ n = LIDENT -> n + | n = UIDENT -> n + ] ]; + + interfaces: + [ [ l = LIST0 interface -> l ] ]; + + name: + [ [ n = ident; "."; rest = SELF -> + n ^ "." ^ rest + | n = ident -> + n ] ]; + + interface: + [ [ "interface"; name = name; "{"; members = LIST0 member; "}" -> + let rec get_members = function + | [] -> [] + | `Member m :: rest -> m :: get_members rest + | `Annotation _ :: rest -> get_members rest + | `Symbol _ :: rest -> get_members rest + in + let rec get_annotations = function + | [] -> [] + | `Member _ :: rest -> get_annotations rest + | `Annotation a :: rest -> a :: get_annotations rest + | `Symbol _ :: rest -> get_annotations rest + in + let rec get_symbols = function + | [] -> [] + | `Member _ :: rest -> get_symbols rest + | `Annotation _ :: rest -> get_symbols rest + | `Symbol s :: rest -> s :: get_symbols rest + in + (name, get_members members, get_symbols members, get_annotations members) ] ]; + + member: + [ [ "method"; name = ident; ":"; i_args = arguments; "->"; o_args = arguments; annotations = annotations -> + `Member(Method(name, i_args, o_args, annotations)) + | "signal"; name = ident; ":"; args = arguments; annotations = annotations -> + `Member(Signal(name, args, annotations)) + | "property_r"; name = ident; ":"; typ = type_term; annotations = annotations -> + `Member(Property(name, typ, Read, annotations)) + | "property_w"; name = ident; ":"; typ = type_term; annotations = annotations -> + `Member(Property(name, typ, Write, annotations)) + | "property_rw"; name = ident; ":"; typ = type_term; annotations = annotations -> + `Member(Property(name, typ, Read_write, annotations)) + | "annotation"; name = STRING; "="; value = STRING -> + `Annotation(name, value) + | "enum"; name = ident; ":"; typ = key_type; "{"; values = LIST1 value; "}" -> + `Symbol(name, sym_enum typ (List.map (fun (key, value) -> (parse_int typ key, value)) values)) + | "flag"; name = ident; ":"; typ = key_type; "{"; values = LIST1 value; "}" -> + `Symbol(name, sym_flag typ (List.map (fun (key, value) -> (parse_int typ key, value)) values)) + ] ]; + + value: + [ [ key = INT; ":"; value = ident -> (key, value) + | "-"; key = INT; ":"; value = ident -> ("-" ^ key, value) + | "+"; key = INT; ":"; value = ident -> (key, value) + ] ]; + + annotations: + [ [ "with"; "{"; l = LIST1 annotation; "}" -> l + | -> [] ] ]; + + annotation: + [ [ name = name; "="; value = STRING -> (name, value) ] ]; + + arguments: + [ [ "("; l = LIST0 argument SEP ","; ")" -> l ] ]; + + argument: + [ [ name = ident; ":"; typ = type_term -> (Some name, typ) + | "_"; ":"; typ = type_term -> (None, typ) ] ]; + + type_term: + [ "star" + [ t = SELF; "*"; tl = type_tuple -> tuple (t :: tl) ] + | "type_term1" + [ t = SELF; id = ident -> term id [t] ] + | "simple" + [ id = ident -> term id [] + | "("; t = SELF; ","; tl = type_args; ")"; id = ident -> term id (t :: tl) + | "("; t = SELF; ")" -> t ] + ]; + + type_tuple: + [ [ t = type_term LEVEL "type_term1"; "*"; tl = SELF -> t :: tl + | t = type_term LEVEL "type_term1" -> [t] ] ]; + + type_args: + [ [ t = type_term; ","; tl = SELF -> 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 + | _ -> Loc.raise _loc (Failure(Printf.sprintf "invalid key type: %s" id)) ] ]; +END + +exception Parse_failure of string + +let parse ?(file_name="<stream>") stream = + Gram.parse interfaces (Loc.mk file_name) stream + +let parse_file file_name = + let ic = open_in file_name in + try + let ifaces = parse ~file_name (Stream.of_channel ic) in + close_in ic; + ifaces + with exn -> + close_in ic; + raise (Parse_failure(Camlp4.ErrorHandler.to_string exn)) + +(* +-----------------------------------------------------------------+ + | Printing | + +-----------------------------------------------------------------+ *) + +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 diff --git a/src/oBus_idl.mli b/src/oBus_idl.mli new file mode 100644 index 0000000..127b8ad --- /dev/null +++ b/src/oBus_idl.mli @@ -0,0 +1,28 @@ +(* + * oBus_idl.mli + * ------------ + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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 : ?file_name : string -> char Stream.t -> OBus_introspect_ext.interface list + (** [parse stream] parses the given stream. [file_name] is used for + error messages. *) + +val parse_file : string -> OBus_introspect_ext.interface list + (** 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 *) diff --git a/src/oBus_info.ml b/src/oBus_info.ml new file mode 100644 index 0000000..3096d4d --- /dev/null +++ b/src/oBus_info.ml @@ -0,0 +1,36 @@ +(* + * oBus_info.ml + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(info)" + +open Lwt + +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 + lwt line = Lwt_io.with_file ~mode:Lwt_io.input file Lwt_io.read_line in + 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); + raise_lwt 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 _ -> + raise_lwt exn +) diff --git a/src/oBus_info.mli b/src/oBus_info.mli new file mode 100644 index 0000000..1456696 --- /dev/null +++ b/src/oBus_info.mli @@ -0,0 +1,27 @@ +(* + * oBus_info.mli + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Various informations *) + +val version : string + (** version of obus *) + +val machine_uuid : OBus_uuid.t Lwt.t Lazy.t + (** UUID of the machine we are running on *) + +val protocol_version : int + (** The version of the D-Bus protocol implemented by the library *) + +val max_name_length : int + (** Maximum length of a name (=255). This limit applies to bus + names, interfaces, and members *) + +val max_message_size : int + (** Maximum size of a message. In this version of the protocol this + is 2^27 bytes (128MB). *) diff --git a/src/oBus_interfaces.obus b/src/oBus_interfaces.obus new file mode 100644 index 0000000..da5f8bb --- /dev/null +++ b/src/oBus_interfaces.obus @@ -0,0 +1,76 @@ +(* + * oBus_interfaces.obus + * -------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +interface org.freedesktop.DBus.Peer { + method Ping : () -> () + method GetMachineId : () -> (machine_id : string) +} + +interface org.freedesktop.DBus.Introspectable { + method Introspect : () -> (result : string) +} + +interface org.freedesktop.DBus.Properties { + method Get : (interface_name : string, member : string) -> (value : variant) + method Set : (interface_name : string, member : string, value : variant) -> () + method GetAll : (interface_name : string) -> (values : (string, variant) dict) + signal PropertiesChanged : (interface_name : string, updates : (string, variant) dict, invalidates : string array) +} + +interface org.freedesktop.DBus { + method Hello : () -> (name : string) + + flag request_name_flags : uint32 { + 0b001: allow_replacement + 0b010: replace_existing + 0b100: do_not_queue + } + + enum request_name_result : uint32 { + 1: primary_owner + 2: in_queue + 3: exists + 4: already_owner + } + + method RequestName : (name : string, flags : request_name_flags) -> (result : request_name_result) + + enum release_name_result : uint32 { + 1: released + 2: non_existent + 3: not_owner + } + + method ReleaseName : (name : string) -> (result : release_name_result) + + enum start_service_by_name_result : uint32 { + 1: success + 2: already_running + } + + method StartServiceByName : (name : string, flags : uint32) -> (result : start_service_by_name_result) + + method UpdateActivationEnvironment : (x1 : (string, string) dict) -> () + method NameHasOwner : (x1 : string) -> (x1 : boolean) + method ListNames : () -> (x1 : string array) + method ListActivatableNames : () -> (x1 : string array) + method AddMatch : (x1 : string) -> () + method RemoveMatch : (x1 : string) -> () + method GetNameOwner : (x1 : string) -> (x1 : string) + method ListQueuedOwners : (x1 : string) -> (x1 : string array) + method GetConnectionUnixUser : (x1 : string) -> (x1 : uint32) + method GetConnectionUnixProcessID : (x1 : string) -> (x1 : uint32) + method GetAdtAuditSessionData : (x1 : string) -> (x1 : byte array) + method GetConnectionSELinuxSecurityContext : (x1 : string) -> (x1 : byte array) + method ReloadConfig : () -> () + method GetId : () -> (x1 : string) + signal NameOwnerChanged : (x1 : string, x2 : string, x3 : string) + signal NameLost : (x1 : string) + signal NameAcquired : (x1 : string) +} diff --git a/src/oBus_introspect.ml b/src/oBus_introspect.ml new file mode 100644 index 0000000..35a7bfa --- /dev/null +++ b/src/oBus_introspect.ml @@ -0,0 +1,188 @@ +(* + * oBus_introspect.ml + * ------------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open 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 "<!DOCTYPE node PUBLIC \"-//freedesktop//DTD D-BUS Object Introspection 1.0//EN\"\n\ + \"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd\">")); + 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" diff --git a/src/oBus_introspect.mli b/src/oBus_introspect.mli new file mode 100644 index 0000000..983d6ae --- /dev/null +++ b/src/oBus_introspect.mli @@ -0,0 +1,54 @@ +(* + * oBus_introspect.mli + * ------------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus 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 *) diff --git a/src/oBus_introspect_ext.ml b/src/oBus_introspect_ext.ml new file mode 100644 index 0000000..810fc34 --- /dev/null +++ b/src/oBus_introspect_ext.ml @@ -0,0 +1,460 @@ +(* + * oBus_introspect_ext.ml + * ---------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open 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) diff --git a/src/oBus_introspect_ext.mli b/src/oBus_introspect_ext.mli new file mode 100644 index 0000000..4ba2913 --- /dev/null +++ b/src/oBus_introspect_ext.mli @@ -0,0 +1,226 @@ +(* + * oBus_introspect_ext.mli + * ----------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** OBus extended introspection *) + +(** By default, introspection document do not convey semantical + informations, such as enumeration or flags. However it is possible + to attach information to interfaces and members. + + This module implement an extended introspection format, which can + be encoded into standard introspection documents by using + annotations. +*) + +(** {6 Annotations} *) + +(** The following annotations are used to encode additionnal + 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. Tuple are always + mapped to D-Bus structure. Moreover it is ensured that there + is never 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 *) diff --git a/src/oBus_match.ml b/src/oBus_match.ml new file mode 100644 index 0000000..80dd91f --- /dev/null +++ b/src/oBus_match.ml @@ -0,0 +1,523 @@ +(* + * oBus_match.ml + * ------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(match)" + +(* +-----------------------------------------------------------------+ + | Types | + +-----------------------------------------------------------------+ *) + +type argument_filter = + | AF_string of string + | AF_string_path of string + | AF_namespace of string + +type arguments = (int * argument_filter) list + +type rule = { + typ : [ `Signal | `Error | `Method_call | `Method_return ] option; + sender : OBus_name.bus; + interface : OBus_name.interface; + member : OBus_name.member; + path : OBus_path.t option; + destination : OBus_name.bus; + arguments : arguments; + eavesdrop : bool option; +} + +let typ e = e.typ +let sender e = e.sender +let interface e = e.interface +let member e = e.member +let path e = e.path +let destination e = e.destination +let arguments e = e.arguments +let eavesdrop e = e.eavesdrop + +let rule ?typ ?(sender="") ?(interface="") ?(member="") ?path ?(destination="") ?(arguments=[]) ?eavesdrop () = { + typ = typ; + sender = sender; + interface = interface; + member = member; + path = path; + destination = destination; + arguments = arguments; + eavesdrop = eavesdrop; +} + +(* +-----------------------------------------------------------------+ + | Arguments lists | + +-----------------------------------------------------------------+ *) + +let rec insert_sorted num filter = function + | [] -> [(num, filter)] + | (num', _) as pair :: rest when num' < num -> + pair :: insert_sorted num filter rest + | (num', _) :: rest when num' = num -> + (num, filter) :: rest + | ((num', _) :: rest) as l -> + (num, filter) :: l + +let make_arguments list = + List.fold_left + (fun l (num, filter) -> + if num < 0 || num > 63 then + Printf.ksprintf invalid_arg "OBus_match.arguments_of_list: invalid argument number '%d': it must be in the rane [1..63]" num + else + insert_sorted num filter l) + [] list + +external cast_arguments : arguments -> (int * argument_filter) list = "%identity" + +(* +-----------------------------------------------------------------+ + | string <-> rule | + +-----------------------------------------------------------------+ *) + +let string_of_rule mr = + let buf = Buffer.create 42 in + let rec coma = ref (fun _ -> coma := fun _ -> Buffer.add_char buf ',') in + let add key value = + !coma (); + Buffer.add_string buf key; + Buffer.add_string buf "='"; + Buffer.add_string buf value; + Buffer.add_char buf '\'' + in + let add_string key test = function + | "" -> () + | str -> + match test str with + | Some error -> raise (OBus_string.Invalid_string error) + | None -> add key str + in + begin + match mr.typ with + | None -> () + | Some t -> + add "type" + (match t with + | `Method_call -> "method_call" + | `Method_return -> "method_return" + | `Error -> "error" + | `Signal -> "signal") + end; + add_string "sender" OBus_name.validate_bus mr.sender; + add_string "interface" OBus_name.validate_interface mr.interface; + add_string "member" OBus_name.validate_member mr.member; + begin match mr.path with + | None -> () + | Some [] -> + !coma (); + Buffer.add_string buf "path='/'" + | Some p -> + !coma (); + Buffer.add_string buf "path='"; + List.iter + (fun elt -> + match OBus_path.validate_element elt with + | Some error -> + raise (OBus_string.Invalid_string error) + | None -> + Buffer.add_char buf '/'; + Buffer.add_string buf elt) + p; + Buffer.add_char buf '\'' + end; + add_string "destination" OBus_name.validate_bus mr.destination; + List.iter (fun (n, filter) -> + !coma (); + match filter with + | AF_string str -> + Printf.bprintf buf "arg%d='%s'" n str + | AF_string_path str -> + Printf.bprintf buf "arg%dpath='%s'" n str + | AF_namespace str -> + Printf.bprintf buf "arg%dnamespace='%s'" n str) mr.arguments; + begin match mr.eavesdrop with + | None -> () + | Some true -> add "eavesdrop" "true" + | Some false -> add "eavesdrop" "false" + end; + Buffer.contents buf + +exception Parse_failure of string * int * string + +let () = + Printexc.register_printer + (function + | Parse_failure(str, pos, reason) -> + Some(Printf.sprintf "failed to parse D-Bus matching rule %S, at position %d: %s" str pos reason) + | _ -> + None) + +exception Fail = OBus_match_rule_lexer.Fail + +let rule_of_string str = + try + let l = match str with + | "" -> [] + | _ -> OBus_match_rule_lexer.match_rules (Lexing.from_string str) + in + let check pos validate value = + match validate value with + | None -> + () + | Some err -> + raise (Fail(pos, OBus_string.error_message err)) + in + let mr = { + typ = None; + sender = ""; + interface = ""; + member = ""; + path = None; + destination = ""; + arguments = []; + eavesdrop = None; + } in + List.fold_left begin fun mr (pos, key, value) -> + match key with + | "type" -> + { mr with typ = Some(match value with + | "method_call" -> `Method_call + | "method_return" -> `Method_return + | "signal" -> `Signal + | "error" -> `Error + | _ -> raise (Fail(pos, Printf.sprintf "invalid message type (%s)" value))) } + | "sender" -> + check pos OBus_name.validate_bus value; + { mr with sender = value } + | "destination" -> + check pos OBus_name.validate_bus value; + { mr with destination = value } + | "interface" -> + check pos OBus_name.validate_interface value; + { mr with interface = value } + | "member" -> + check pos OBus_name.validate_member value; + { mr with member = value } + | "path" -> begin + try + { mr with path = Some(OBus_path.of_string value) } + with OBus_string.Invalid_string err -> + raise (Fail(pos, OBus_string.error_message err)) + end + | "eavesdrop" -> begin + match value with + | "true" -> { mr with eavesdrop = Some true } + | "false" -> { mr with eavesdrop = Some false } + | _ -> raise (Fail(pos, Printf.sprintf "invalid value for eavesdrop (%s)" value)) + end + | _ -> + match OBus_match_rule_lexer.arg (Lexing.from_string key) with + | Some(n, kind) -> + { mr with arguments = + insert_sorted n + (match kind with + | `String -> AF_string value + | `Path -> AF_string_path value + | `Namespace -> AF_namespace value) + mr.arguments } + | None -> + raise (Fail(pos, Printf.sprintf "invalid key (%s)" key)) + end mr l + with Fail(pos, msg) -> + raise (Parse_failure(str, pos, msg)) + +(* +-----------------------------------------------------------------+ + | Matching | + +-----------------------------------------------------------------+ *) + +let match_key matcher value = match matcher with + | None -> true + | Some value' -> value = value' + +let match_string matcher value = match matcher with + | "" -> true + | value' -> value = value' + +let starts_with str prefix = + let str_len = String.length str and prefix_len = String.length prefix in + let rec loop i = + (i = prefix_len) || (i < str_len && str.[i] = prefix.[i] && loop (i + 1)) + in + loop 0 + +let ends_with_slash str = str <> "" && str.[String.length str - 1] = '/' + +let rec match_arguments num matcher arguments = match matcher with + | [] -> + true + | (num', filter) :: rest -> + match_arguments_aux num num' filter rest arguments + +and match_arguments_aux num num' filter matcher arguments = match arguments with + | [] -> + false + | value :: rest when num < num' -> + match_arguments_aux (num + 1) num' filter matcher rest + | OBus_value.V.Basic(OBus_value.V.String value) :: rest -> + (match filter with + | AF_string str -> + str = value + | AF_string_path str -> + (str = value) + || (ends_with_slash str && starts_with value str) + || (ends_with_slash value && starts_with str value) + | AF_namespace str -> + starts_with value str && + (String.length value = String.length str || + value.[String.length str] = '.')) + && match_arguments (num + 1) matcher rest + | OBus_value.V.Basic(OBus_value.V.Object_path value) :: rest -> + (match filter with + | AF_string str -> + false + | AF_string_path str -> + let value = OBus_path.to_string value in + (str = value) + || (ends_with_slash str && starts_with value str) + || (ends_with_slash value && starts_with str value) + | AF_namespace _ -> + false) + && match_arguments (num + 1) matcher rest + | _ -> + false + +let match_values filters values = + match_arguments 0 filters values + +let match_message mr msg = + (match OBus_message.typ msg, mr.typ with + | OBus_message.Method_call(path, interface, member), (Some `Method_call | None) -> + (match_key mr.path path) && + (match_string mr.interface interface) && + (match_string mr.member member) + | OBus_message.Method_return serial, (Some `Method_return | None)-> + true + | OBus_message.Signal(path, interface, member), (Some `Signal | None) -> + (match_key mr.path path) && + (match_string mr.interface interface) && + (match_string mr.member member) + | OBus_message.Error(serial, name), (Some `Error | None) -> + true + | _ -> + false) && + (match_string mr.sender (OBus_message.sender msg)) && + (match_string mr.destination (OBus_message.destination msg)) && + (match_arguments 0 mr.arguments (OBus_message.body msg)) + +(* +-----------------------------------------------------------------+ + | Comparison | + +-----------------------------------------------------------------+ *) + +type comparison_result = + | More_general + | Less_general + | Equal + | Incomparable + +let rec compare_arguments acc l1 l2 = + match acc, l1, l2 with + | acc, [], [] -> + acc + | (Less_general | Equal), _ :: _, [] -> + Less_general + | (More_general | Equal), [], _ :: _ -> + More_general + | acc, (pos1, filter1) :: rest1, (pos2, filter2) :: rest2 -> + if pos1 = pos2 && filter1 = filter2 then + compare_arguments acc rest1 rest2 + else if pos1 < pos2 && (acc = Less_general || acc = Equal) then + compare_arguments Less_general rest1 l2 + else if pos1 > pos2 && (acc = More_general || acc = Equal) then + compare_arguments More_general l1 rest2 + else + raise Exit + | _ -> + raise Exit + +let compare_option acc x1 x2 = + if x1 = x2 then + acc + else + match acc, x1, x2 with + | (Less_general | Equal), Some _, None -> + Less_general + | (More_general | Equal), None, Some _ -> + More_general + | _ -> + raise Exit + +let compare_string acc x1 x2 = + if x1 = x2 then + acc + else + match acc, x1, x2 with + | (Less_general | Equal), x, "" when x <> "" -> + Less_general + | (More_general | Equal), "", x when x <> "" -> + More_general + | _ -> + raise Exit + +let compare_rules r1 r2 = + try + if r1.typ = r2.typ then begin + let acc = Equal in + let acc = compare_string acc r1.sender r2.sender in + let acc = compare_string acc r1.destination r2.destination in + let acc = compare_option acc r1.path r2.path in + let acc = compare_string acc r1.interface r2.interface in + let acc = compare_string acc r1.member r2.member in + let acc = compare_arguments acc r1.arguments r2.arguments in + if r1.eavesdrop = r2.eavesdrop then + acc + else + match acc, r1.eavesdrop, r2.eavesdrop with + | _, None, Some false -> + acc + | _, Some false, None -> + acc + | (Less_general | Equal), (None | Some false), Some true -> + Less_general + | (More_general | Equal), Some true, (None | Some false) -> + More_general + | _ -> + Incomparable + end else + Incomparable + with Exit -> + Incomparable + +(* +-----------------------------------------------------------------+ + | Exporting rules on message buses | + +-----------------------------------------------------------------+ *) + +open Lwt + +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 = + 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; + 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 + | _ -> + raise_lwt 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 + + 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; + lwt () = commit info in + lwt () = + Lwt_switch.add_hook_or_exec switch + (fun () -> + info.rules <- remove_first rule info.rules; + commit info) + in + return () diff --git a/src/oBus_match.mli b/src/oBus_match.mli new file mode 100644 index 0000000..648ef0b --- /dev/null +++ b/src/oBus_match.mli @@ -0,0 +1,141 @@ +(* + * oBus_match.mli + * -------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Matching rules *) + +(** {6 Rules} *) + +(** Type of an argument filter. Argument filters are used in match + rules to match message arguments. *) +type argument_filter = + | AF_string of string + (** [AF_string str] matches any string argument which is equal + to [str] *) + | AF_string_path of string + (** [AF_string_path path] matches any string or object-path + argument [arg] such that one of the following conditions + hold: + + - [arg] is equal to [path] + - [path] ends with ['/'] and is a prefix of [arg] + - [arg] ends with ['/'] and is a prefix of [path] *) + | AF_namespace of string + (** [AF_namespace namespace] matches any string argument [arg] + such that [arg] is 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, does 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 + (** Return a string representation of a matching rule. *) + +val rule_of_string : string -> rule + (** Parse a string representation of a matching rule. + + @raise Failure if the given string does not contain a valid + matching rule. *) + +(** {6 Rules and message buses} *) + +val export : ?switch : Lwt_switch.t -> OBus_connection.t -> rule -> unit Lwt.t + (** [export ?switch connection rule] registers [rule] on the message + bus. If another rule more general than [rule] is already + exported, then it does nothihng. + + You can provide a switch to manually disable the export. *) diff --git a/src/oBus_match_rule_lexer.mll b/src/oBus_match_rule_lexer.mll new file mode 100644 index 0000000..8f5ae2b --- /dev/null +++ b/src/oBus_match_rule_lexer.mll @@ -0,0 +1,60 @@ +(* + * oBus_match_rule_lexer.mll + * ------------------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +{ + exception Fail of int * string + + let pos lexbuf = lexbuf.Lexing.lex_start_p.Lexing.pos_cnum + + let fail lexbuf fmt = + Printf.ksprintf + (fun msg -> raise (Fail(pos lexbuf, msg))) + fmt +} + +rule match_rules = parse + | (['a'-'z' '_' '0'-'9']+ as key) "='" ([^ '\'']* as value) '\'' + { if comma lexbuf then + (pos lexbuf, key, value) :: match_rules lexbuf + else begin + check_eof lexbuf; + [(pos lexbuf, key, value)] + end } + | "=" { + fail lexbuf "empty key" + } + | eof { + fail lexbuf "match rule expected" + } + | _ as ch { + fail lexbuf "invalid character %C" ch + } + +and comma = parse + | ',' { true } + | "" { false } + +and check_eof = parse + | eof { () } + | _ as ch { fail lexbuf "invalid character %C" ch } + +and arg = parse + | "arg" (['0'-'9']+ as n) (("" | "path" | "namespace") as kind) eof { + let n = int_of_string n in + if n >= 0 && n <= 63 then + Some(n, + match kind with + | "" -> `String + | "path" -> `Path + | "namespace" -> `Namespace + | _ -> assert false) + else + fail lexbuf "invalid argument number '%d': it must be between 0 and 63" n + } + | "" { None } diff --git a/src/oBus_member.ml b/src/oBus_member.ml new file mode 100644 index 0000000..e4c7e9c --- /dev/null +++ b/src/oBus_member.ml @@ -0,0 +1,111 @@ +(* + * oBus_member.ml + * -------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open OBus_introspect + +let introspect_arguments args = + List.map2 + (fun name typ -> (name, typ)) + (OBus_value.arg_names args) + (OBus_value.C.type_sequence (OBus_value.arg_types args)) + +module Method = +struct + type ('a, 'b) t = { + interface : OBus_name.interface; + member : OBus_name.member; + i_args : 'a OBus_value.arguments; + o_args : 'b OBus_value.arguments; + annotations : OBus_introspect.annotation list; + } + + let make ~interface ~member ~i_args ~o_args ~annotations = { + interface = interface; + member = member; + i_args = i_args; + o_args = o_args; + annotations = annotations; + } + + let interface m = m.interface + let member m = m.member + let i_args m = m.i_args + let o_args m = m.o_args + let annotations m = m.annotations + + let introspect m = + Method(m.member, introspect_arguments m.i_args, introspect_arguments m.o_args, m.annotations) +end + +module Signal = +struct + type 'a t = { + interface : OBus_name.interface; + member : OBus_name.member; + args : 'a OBus_value.arguments; + annotations : OBus_introspect.annotation list; + } + + let make ~interface ~member ~args ~annotations = { + interface = interface; + member = member; + args = args; + annotations = annotations; + } + + let interface s = s.interface + let member s = s.member + let args s = s.args + let annotations s = s.annotations + + let introspect s = + Signal(s.member, introspect_arguments s.args, s.annotations) +end + +module Property = +struct + type 'a access = + | Readable + | Writable + | Readable_writable + + let readable = Readable + let writable = Writable + let readable_writable = Readable_writable + + type ('a, 'access) t = { + interface : OBus_name.interface; + member : OBus_name.member; + typ : 'a OBus_value.C.single; + access : 'access access; + annotations : OBus_introspect.annotation list; + } + + let make ~interface ~member ~typ ~access ~annotations = { + interface = interface; + member = member; + typ = typ; + access = access; + annotations = annotations; + } + + let interface p = p.interface + let member p = p.member + let typ p = p.typ + let access p = p.access + let annotations p = p.annotations + + let introspect p = + Property(p.member, OBus_value.C.type_single p.typ, + (match p.access with + | Readable -> Read + | Writable -> Write + | Readable_writable -> Read_write), + p.annotations) +end diff --git a/src/oBus_member.mli b/src/oBus_member.mli new file mode 100644 index 0000000..f901d1f --- /dev/null +++ b/src/oBus_member.mli @@ -0,0 +1,133 @@ +(* + * oBus_member.mli + * --------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus members description *) + +(** D-Bus Methods *) +module Method : sig + + (** D-Bus method description *) + + (** Type of a method description *) + type ('a, 'b) t = { + interface : OBus_name.interface; + member : OBus_name.member; + i_args : 'a OBus_value.arguments; + (** Input arguments *) + o_args : 'b OBus_value.arguments; + (** Output arguments *) + annotations : OBus_introspect.annotation list; + } + + (** {6 Creation} *) + + val make : + interface : OBus_name.interface -> + member : OBus_name.member -> + i_args : 'a OBus_value.arguments -> + o_args : 'b OBus_value.arguments -> + annotations : OBus_introspect.annotation list -> ('a, 'b) t + + (** {6 Projections} *) + + val interface : ('a, 'b) t -> OBus_name.interface + val member : ('a, 'b) t -> OBus_name.member + val i_args : ('a, 'b) t -> 'a OBus_value.arguments + val o_args : ('a, 'b) t -> 'b OBus_value.arguments + val annotations : ('a, 'b) t -> OBus_introspect.annotation list + + (** {6 Introspection} *) + + val introspect : ('a, 'b) t -> OBus_introspect.member +end + +(** D-Bus signals *) +module Signal : sig + + (** D-Bus signal description *) + + (** Type of a signal description *) + type 'a t = { + interface : OBus_name.interface; + member : OBus_name.member; + args : 'a OBus_value.arguments; + annotations : OBus_introspect.annotation list; + } + + (** {6 Creation} *) + + val make : + interface : OBus_name.interface -> + member : OBus_name.member -> + args : 'a OBus_value.arguments -> + annotations : OBus_introspect.annotation list -> 'a t + + (** {6 Projections} *) + + val interface : 'a t -> OBus_name.interface + val member : 'a t -> OBus_name.member + val args : 'a t -> 'a OBus_value.arguments + val annotations : 'a t -> OBus_introspect.annotation list + + (** {6 Introspection} *) + + val introspect : 'a t -> OBus_introspect.member +end + +(** D-Bus properties *) +module Property : sig + + (** D-Bus property description *) + + (** Type of access modes *) + type 'a access = + private + | Readable + | Writable + | Readable_writable + + val readable : [ `readable ] access + (** Access mode for readable properties *) + + val writable : [ `writable ] access + (** Access mode for writable properties *) + + val readable_writable : [ `readable | `writable ] access + (** Access mode for readable and writable properties *) + + (** Type of a property description *) + type ('a, 'access) t = { + interface : OBus_name.interface; + member : OBus_name.member; + typ : 'a OBus_value.C.single; + access : 'access access; + annotations : OBus_introspect.annotation list; + } + + (** {6 Creation} *) + + val make : + interface : OBus_name.interface -> + member : OBus_name.member -> + typ : 'a OBus_value.C.single -> + access : 'access access -> + annotations : OBus_introspect.annotation list -> ('a, 'access) t + + (** {6 Projections} *) + + val interface : ('a, 'access) t -> OBus_name.interface + val member : ('a, 'access) t -> OBus_name.member + val typ : ('a, 'access) t -> 'a OBus_value.C.single + val access : ('a, 'access) t -> 'access access + val annotations : ('a, 'access) t -> OBus_introspect.annotation list + + (** {6 Introspection} *) + + val introspect : ('a, 'access) t -> OBus_introspect.member +end diff --git a/src/oBus_message.ml b/src/oBus_message.ml new file mode 100644 index 0000000..9a33ba5 --- /dev/null +++ b/src/oBus_message.ml @@ -0,0 +1,136 @@ +(* + * oBus_message.ml + * --------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +type serial = int32 +type body = OBus_value.V.sequence + +type flags = { + no_reply_expected : bool; + no_auto_start : bool; +} + +let no_reply_expected flags = flags.no_reply_expected +let no_auto_start flags = flags.no_auto_start + +let default_flags = { + no_reply_expected = false; + no_auto_start = false; +} + +let make_flags ?(no_reply_expected=false) ?(no_auto_start=false) () = { + no_reply_expected = no_reply_expected; + no_auto_start = no_auto_start; +} + +type typ = + | Method_call of OBus_path.t * OBus_name.interface * OBus_name.member + | Method_return of serial + | Error of serial * OBus_name.error + | Signal of OBus_path.t * OBus_name.interface * OBus_name.member + +type t = { + flags : flags; + serial : serial; + typ : typ; + destination : OBus_name.bus; + sender : OBus_name.bus; + body : body; +} + +let flags m = m.flags +let serial m = m.serial +let typ m = m.typ +let destination m = m.destination +let sender m = m.sender +let body m = m.body + +let make ?(flags=default_flags) ?(serial=0l) ?(sender="") ?(destination="") ~typ body = + { flags = flags; + serial = serial; + typ = typ; + destination = destination; + sender = sender; + body = body } + +let method_call ?flags ?serial ?sender ?destination ~path ?(interface="") ~member body = + make ?flags ?serial ?sender ?destination ~typ:(Method_call(path, interface, member)) body + +let method_return ?flags ?serial ?sender ?destination ~reply_serial body = + make ?flags ?serial ?sender ?destination ~typ:(Method_return(reply_serial)) body + +let error ?flags ?serial ?sender ?destination ~reply_serial ~error_name body = + make ?flags ?serial ?sender ?destination ~typ:(Error(reply_serial, error_name)) body + +let signal ?flags ?serial ?sender ?destination ~path ~interface ~member body = + make ?flags ?serial ?sender ?destination ~typ:(Signal(path, interface, member)) body + +exception Invalid_reply of string + +let invalid_reply ~method_call ~expected_signature ~method_return = + match method_call, method_return with + | { typ = Method_call(path, interface, member) }, { typ = Method_return _; body } -> + Invalid_reply + (Printf.sprintf + "unexpected signature for the reply to the method %S on interface %S, expected: %S, got: %S" + member + interface + (OBus_value.string_of_signature expected_signature) + (OBus_value.string_of_signature (OBus_value.V.type_of_sequence body))) + | _ -> + invalid_arg "OBus_message.invalid_reply" + +open Format +open OBus_value + +let print pp message = + fprintf pp + "no_reply_expected = %B@\n\ + no_auto_start = %B@\n\ + serial = %ld@\n\ + message_type = %a@\n\ + sender = %S@\n\ + destination = %S@\n\ + signature = %S@\n\ + body_type = %a@\n\ + body = %a@\n" + message.flags.no_reply_expected + message.flags.no_auto_start + message.serial + (fun pp -> function + | Method_call(path, interface, member) -> + fprintf pp + "method_call@\n\ + path = %S@\n\ + interface = %S@\n\ + member = %S" + (OBus_path.to_string path) interface member + | Method_return reply_serial -> + fprintf pp + "method_return@\n\ + reply_serial = %ld" + reply_serial + | Error(reply_serial, error_name) -> + fprintf pp + "error@\n\ + reply_serial = %ld@\n\ + error_name = %S" + reply_serial error_name + | Signal(path, interface, member) -> + fprintf pp + "signal@\n\ + path = %S@\n\ + interface = %S@\n\ + member = %S" + (OBus_path.to_string path) interface member) + message.typ + message.sender + message.destination + (string_of_signature (V.type_of_sequence message.body)) + T.print_sequence (V.type_of_sequence message.body) + V.print_sequence message.body diff --git a/src/oBus_message.mli b/src/oBus_message.mli new file mode 100644 index 0000000..789ee4a --- /dev/null +++ b/src/oBus_message.mli @@ -0,0 +1,132 @@ +(* + * oBus_message.mli + * ---------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Message description *) + +type serial = int32 + +(** {6 Message structure} *) + +type body = OBus_value.V.sequence + (** The body is a sequence of dynamically typed values *) + +type typ = + | Method_call of OBus_path.t * OBus_name.interface * OBus_name.member + | Method_return of serial + | Error of serial * OBus_name.error + | Signal of OBus_path.t * OBus_name.interface * OBus_name.member + +(** flags *) +type flags = { + no_reply_expected : bool; + no_auto_start : bool; +} + +val no_reply_expected : flags -> bool + (** [no_reply_expected] projection *) + +val no_auto_start : flags -> bool + (** [no_auto_start] projection *) + +val make_flags : ?no_reply_expected:bool -> ?no_auto_start:bool -> unit -> flags + (** Creates message flags. All optionnal 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 an 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] + returns an {!Invalid_reply} exception with a informative + description of the error. + + It raises [Invalid_argument] if [method_call] is not a method + call message or [method_return] is not a method return + message *) + +(** {6 Pretty-printing} *) + +val print : Format.formatter -> t -> unit + (** Print a message on a formatter *) diff --git a/src/oBus_method.ml b/src/oBus_method.ml new file mode 100644 index 0000000..67f73d7 --- /dev/null +++ b/src/oBus_method.ml @@ -0,0 +1,45 @@ +(* + * oBus_method.ml + * -------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(method)" + +let call info proxy args = + OBus_connection.method_call + ~connection:(OBus_proxy.connection proxy) + ~destination:(OBus_proxy.name proxy) + ~path:(OBus_proxy.path proxy) + ~interface:(OBus_member.Method.interface info) + ~member:(OBus_member.Method.member info) + ~i_args:(OBus_value.arg_types (OBus_member.Method.i_args info)) + ~o_args:(OBus_value.arg_types (OBus_member.Method.o_args info)) + args + +let call_with_context info proxy args = + lwt msg, result = + OBus_connection.method_call_with_message + ~connection:(OBus_proxy.connection proxy) + ~destination:(OBus_proxy.name proxy) + ~path:(OBus_proxy.path proxy) + ~interface:(OBus_member.Method.interface info) + ~member:(OBus_member.Method.member info) + ~i_args:(OBus_value.arg_types (OBus_member.Method.i_args info)) + ~o_args:(OBus_value.arg_types (OBus_member.Method.o_args info)) + args + in + Lwt.return (OBus_context.make (OBus_proxy.connection proxy) msg, result) + +let call_no_reply info proxy args = + OBus_connection.method_call_no_reply + ~connection:(OBus_proxy.connection proxy) + ~destination:(OBus_proxy.name proxy) + ~path:(OBus_proxy.path proxy) + ~interface:(OBus_member.Method.interface info) + ~member:(OBus_member.Method.member info) + ~i_args:(OBus_value.arg_types (OBus_member.Method.i_args info)) + args diff --git a/src/oBus_method.mli b/src/oBus_method.mli new file mode 100644 index 0000000..8bc9ff5 --- /dev/null +++ b/src/oBus_method.mli @@ -0,0 +1,22 @@ +(* + * oBus_method.mli + * --------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus methods *) + +val call : ('a, 'b) OBus_member.Method.t -> OBus_proxy.t -> 'a -> 'b Lwt.t + (** [call meth proxy args] calls the method [meth] on the object + pointed by [proxy], and wait for the reply. *) + +val call_with_context : ('a, 'b) OBus_member.Method.t -> OBus_proxy.t -> 'a -> (OBus_context.t * 'b) Lwt.t + (** [call_with_context meth proxy args] is like {!call} except that + is also returns the context of the method return *) + +val call_no_reply : ('a, 'b) OBus_member.Method.t -> OBus_proxy.t -> 'a -> unit Lwt.t + (** [call_no_reply meth proxy args] is the same as {!call} except + that it does not wait for a reply *) diff --git a/src/oBus_name.ml b/src/oBus_name.ml new file mode 100644 index 0000000..5cdef4b --- /dev/null +++ b/src/oBus_name.ml @@ -0,0 +1,276 @@ +(* + * oBus_name.ml + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open 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 (String.concat "_" (List.map String.lowercase (split name))) +let ocaml_uid name = String.capitalize (String.concat "_" (List.map String.lowercase (split name))) + +let haskell_lid name = String.uncapitalize (String.concat "" (split name)) +let haskell_uid name = String.capitalize (String.concat "" (split name)) diff --git a/src/oBus_name.mli b/src/oBus_name.mli new file mode 100644 index 0000000..271ec7a --- /dev/null +++ b/src/oBus_name.mli @@ -0,0 +1,78 @@ +(* + * oBus_name.mli + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus names *) + +(** For specific restrictions on D-Bus names, see + @see <http://dbus.freedesktop.org/doc/dbus-specification.html#message-protocol-names> the specification + + General restrisction 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"] *) diff --git a/src/oBus_object.ml b/src/oBus_object.ml new file mode 100644 index 0000000..3fc9254 --- /dev/null +++ b/src/oBus_object.ml @@ -0,0 +1,1015 @@ +(* + * oBus_object.ml + * -------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Lwt_react +open Lwt + +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 = + raise_lwt + (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 + with_value OBus_context.key (Some context) + (fun () -> + lwt reply = M.handler obj arguments in + 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 + 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 -> + raise_lwt No_such_object + | Some(path, dynamic) -> + let module M = (val dynamic : Dynamic) in + lwt result = + try_lwt + lwt obj = M.get context path in + return (`Success obj) + with exn -> + return (`Failure exn) + in + match result with + | `Success obj -> + dispatch context obj interface member (OBus_message.body message) + | `Failure Not_found -> + raise_lwt No_such_object + | `Failure exn -> + lwt () = Lwt_log.error ~section ~exn "dynamic object handler failed with" in + raise_lwt 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 -> + 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 + 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 + 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. *) + 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); + 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 -> + raise_lwt (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 -> + raise_lwt (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 + return (OBus_value.C.make_single (Property.typ I.info) (S.value I.signal)) + | None -> + raise_lwt (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 -> + raise_lwt (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 + 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 -> + raise_lwt (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 -> + raise_lwt (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 -> + raise_lwt + (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 -> + raise_lwt exn + end + | None -> + raise_lwt (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 (lwt () = OBus_peer.wait_for_exit peer in + destroy obj; + return ()) + +let get obj = + match obj.data with + | Some data -> data + | None -> failwith "OBus_object.get: no data attached" diff --git a/src/oBus_object.mli b/src/oBus_object.mli new file mode 100644 index 0000000..f1bb0c8 --- /dev/null +++ b/src/oBus_object.mli @@ -0,0 +1,204 @@ +(* + * oBus_object.mli + * --------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Local D-Bus objects *) + +(** This module allow 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 incomming 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 exproted. *) + +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] do 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} by 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 returns a signal holding the current value of + the property. *) + +val property_w_info : ('a, [ `writable ]) OBus_member.Property.t -> ('b t -> 'a -> unit Lwt.t) -> 'b property_info + (** [property_w_info desc set] defines a write-only property. [set] + is used to set the propertry contents. *) + +val property_rw_info : ('a, [ `readable | `writable ]) OBus_member.Property.t -> ('b t -> 'a React.signal) -> ('b t -> 'a -> unit Lwt.t) -> 'b property_info + (** [property_rw_info desc get set] defines a readable and writable + property. [get] and [set] have the same semantic as for + {!property_r_info} and {!property_w_info}. *) + +(** {6 Signals} *) + +val emit : 'a t -> + interface : OBus_name.interface -> + member : OBus_name.member -> + ?peer : OBus_peer.t -> + 'b OBus_value.C.sequence -> 'b -> unit Lwt.t + (** [emit obj ~interface ~member ?peer typ args] emits a signal. it + uses the same rules as {!OBus_signal.emit} for choosing the + destinations of the signal. *) diff --git a/src/oBus_path.ml b/src/oBus_path.ml new file mode 100644 index 0000000..0ec400c --- /dev/null +++ b/src/oBus_path.ml @@ -0,0 +1,145 @@ +(* + * oBus_path.ml + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Printf +open String +open OBus_string + +type element = string +type t = element list + +let compare = Pervasives.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 = 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 -> + 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); + 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 = create len in + unsafe_blit str (i + 1) elt 0 len; + aux (elt :: acc) (i - 1) + in + aux [] (length str - 1) + +let escape s = + let len = length s in + let r = create (len * 2) in + for i = 0 to len - 1 do + let j = i * 2 and n = int_of_char s.[i] in + r.[j] <- char_of_int (n land 15 + int_of_char 'a'); + r.[j + 1] <- char_of_int (n lsr 4 + int_of_char 'a') + done; + r + +let unescape s = + let len = length s / 2 in + let r = create len in + for i = 0 to len - 1 do + let j = i * 2 in + 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; + 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] diff --git a/src/oBus_path.mli b/src/oBus_path.mli new file mode 100644 index 0000000..33f8744 --- /dev/null +++ b/src/oBus_path.mli @@ -0,0 +1,54 @@ +(* + * oBus_path.mli + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Manipulation of dbus object paths *) + +type element = string + (** A path component *) + +type t = element list + (** A complete path *) + +val compare : t -> t -> int + (** Same as [Pervasives.compare]. It allows this module to be used + as argument to the functors [Set.Make] and [Map.Make]. *) + +(** {6 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 diff --git a/src/oBus_peer.ml b/src/oBus_peer.ml new file mode 100644 index 0000000..069076c --- /dev/null +++ b/src/oBus_peer.ml @@ -0,0 +1,90 @@ +(* + * oBus_peer.ml + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Lwt_react +open Lwt + +type t = { + connection : OBus_connection.t; + name : OBus_name.bus; +} + +let compare = Pervasives.compare + +let connection p = p.connection +let name p = p.name + +let make ~connection ~name = { connection = connection; name = name } +let anonymous c = { connection = c; name = "" } + +let ping peer = + 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 + return { peer with name = OBus_message.sender reply } + +let get_machine_id peer = + 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 + return (OBus_uuid.of_string mid) + with exn -> + raise_lwt exn + +let wait_for_exit peer = + match peer.name with + | "" -> + raise_lwt (Invalid_argument "OBus_peer.wait_for_exit: peer has no name") + | name -> + let switch = Lwt_switch.create () in + lwt owner = OBus_resolver.make ~switch peer.connection name in + if S.value owner = "" then + Lwt_switch.turn_off switch + else + try_lwt + lwt _ = E.next (E.filter ((=) "") (S.changes owner)) in + return () + finally + Lwt_switch.turn_off switch + +(* +-----------------------------------------------------------------+ + | Private peers | + +-----------------------------------------------------------------+ *) + +type peer = t + +module type Private = sig + type t = private peer + external of_peer : peer -> t = "%identity" + external to_peer : t -> peer = "%identity" +end + +module Private = +struct + type t = peer + external of_peer : peer -> t = "%identity" + external to_peer : t -> peer = "%identity" +end diff --git a/src/oBus_peer.mli b/src/oBus_peer.mli new file mode 100644 index 0000000..e799c50 --- /dev/null +++ b/src/oBus_peer.mli @@ -0,0 +1,107 @@ +(* + * oBus_peer.mli + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus peers *) + +(** A D-Bus peer represent an application which can be reach though a + D-Bus connection. It is the application at the end-point of the + connection or, if the end-point is a message bus, any application + connected to it. *) + +type t = { + connection : OBus_connection.t; + (** Connection used to reach the peer. *) + + name : OBus_name.bus; + (** Name of the peer. This only make sense if the connection is a + connection to a message bus. *) +} + +val compare : t -> t -> int + (** Same as [Pervasives.compare]. It allows this module to be used + as argument to the functors [Set.Make] and [Map.Make]. *) + +val connection : t -> OBus_connection.t + (** [connection] projection *) + +val name : t -> OBus_name.bus + (** [name] projection *) + +(** Note that it is possible to use either a unique connection name or + a bus name as peer name. + + Both possibility have advantages and drawbacks: + + - using bus names such as "org.freedesktop.DBus.Hal" avoid the + need to resolve the name. When doing the first method call the bus + will automatically start the service if available. Also if the + service restart 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 unique name, which can be retreived with bus functions + (see {!OBus_bus}), ensure that the peer won't change over time. + By the way if the service exit, or another application replace 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 name when calls do not involve + side-effect on the service such as object creation, and use unique + name for object create 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 retreived + from a method call. +*) + +val make : connection : OBus_connection.t -> name : OBus_name.bus -> t + (** [make connection name] make a named peer *) + +val anonymous : OBus_connection.t -> t + (** [anonymous connection] make an anonymous peer *) + +val ping : t -> t Lwt.t + (** Ping a peer, and return the peer which really respond to the + ping. + + For example, the fastest way to get the the peer owning a bus + name, and start it if not running is: + + [ping (OBus_peer.make bus "well.known.name")] *) + +val get_machine_id : t -> OBus_uuid.t Lwt.t + (** Return the id of the machine the peer is running on *) + +val wait_for_exit : t -> unit Lwt.t + (** [wait_for_exit peer] wait until [peer] exit. If [peer] is not + running then it returns immediatly. Raises [Invalid_argument] if + the peer has no name. *) + +(** {6 Private peers} *) + +type peer = t + +(** Minimal interface of private peers *) +module type Private = sig + type t = private peer + + external of_peer : peer -> t = "%identity" + external to_peer : t -> peer = "%identity" +end + +(** Minimal implementation of private peers *) +module Private : sig + type t = peer + + external of_peer : peer -> t = "%identity" + external to_peer : t -> peer = "%identity" +end diff --git a/src/oBus_property.ml b/src/oBus_property.ml new file mode 100644 index 0000000..82a9cb3 --- /dev/null +++ b/src/oBus_property.ml @@ -0,0 +1,364 @@ +(* + * oBus_property.ml + * ---------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(property)" + +open Lwt_react +open Lwt +open OBus_interfaces.Org_freedesktop_DBus_Properties + +(* +-----------------------------------------------------------------+ + | Types | + +-----------------------------------------------------------------+ *) + +module String_map = Map.Make(String) + +type map = (OBus_context.t * OBus_value.V.single) String_map.t + +type monitor = OBus_proxy.t -> OBus_name.interface -> Lwt_switch.t -> map signal Lwt.t + +type ('a, 'access) t = { + p_interface : OBus_name.interface; + (* The interface of the property. *) + + p_member : OBus_name.member; + (* The name of the property. *) + + p_proxy : OBus_proxy.t; + (* The object owning the property. *) + + p_monitor : monitor; + (* Monitor for this property. *) + + p_cast : OBus_context.t -> OBus_value.V.single -> 'a; + p_make : 'a -> OBus_value.V.single; +} + +type 'a r = ('a, [ `readable ]) t +type 'a w = ('a, [ `writable ]) t +type 'a rw = ('a, [ `readable | `writable ]) t + +type group = { + g_interface : OBus_name.interface; + (* The interface of the group *) + + g_proxy : OBus_proxy.t; + (* The object owning the group of properties *) + + g_monitor : monitor; + (* Monitor for this group. *) +} + +module Group_map = Map.Make + (struct + type t = OBus_name.bus * OBus_path.t * OBus_name.interface + (* Groups are indexed by: + - name of the owner of the property + - path of the object owning the property + - interfaec of the property *) + let compare = Pervasives.compare + end) + +(* Type of a cache for a group *) +type cache = { + mutable c_count : int; + (* Numbers of monitored properties using this group. *) + + c_map : map signal; + (* The signal holding the current state of properties. *) + + c_switch : Lwt_switch.t; + (* Switch for the signal used to monitor the group. *) +} + +type info = { + mutable cache : cache Lwt.t Group_map.t; + (* Cache of all monitored properties. *) +} + +(* +-----------------------------------------------------------------+ + | Default monitor | + +-----------------------------------------------------------------+ *) + +let update_map context dict map = + List.fold_left (fun map (name, value) -> String_map.add name (context, value) map) map dict + +let map_of_list context dict = + update_map context dict String_map.empty + +let get_all_no_cache proxy interface = + OBus_method.call_with_context m_GetAll proxy interface + +let default_monitor proxy interface switch = + 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 + 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 + return (sig_context, update_map sig_context updates map) + else + lwt context, dict = get_all_no_cache proxy interface in + 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 -> + lwt cache = cache_thread in + return (find_with_context prop (S.value cache.c_map)) + | None -> + lwt context, value = OBus_method.call_with_context m_Get prop.p_proxy (prop.p_interface, prop.p_member) in + return (context, prop.p_cast context value) + end + | None -> + lwt context, value = OBus_method.call_with_context m_Get prop.p_proxy (prop.p_interface, prop.p_member) in + 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 -> + lwt cache = cache_thread in + return (S.value cache.c_map) + | None -> + lwt context, dict = get_all_no_cache group.g_proxy group.g_interface in + return (map_of_list context dict) + end + | None -> + lwt context, dict = get_all_no_cache group.g_proxy group.g_interface in + 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 + 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 = wait () in + info.cache <- Group_map.add cache_key waiter info.cache; + let switch = Lwt_switch.create () in + try_lwt + 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 + wakeup wakener cache; + return cache + with exn -> + info.cache <- Group_map.remove cache_key info.cache; + wakeup_exn wakener exn; + lwt () = Lwt_switch.turn_off switch in + raise_lwt 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 + return () + with exn -> + 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 + raise_lwt exn + ) in + + let signal = S.with_finaliser (finalise disable) cache.c_map in + + lwt () = + Lwt_switch.add_hook_or_exec + switch + (fun () -> + S.stop signal; + Lazy.force disable) + in + + return signal + +let monitor ?switch prop = + lwt signal = monitor_group ?switch { g_interface = prop.p_interface; + g_proxy = prop.p_proxy; + g_monitor = prop.p_monitor } in + return (S.map (find prop) signal) diff --git a/src/oBus_property.mli b/src/oBus_property.mli new file mode 100644 index 0000000..07855af --- /dev/null +++ b/src/oBus_property.mli @@ -0,0 +1,145 @@ +(* + * oBus_property.mli + * ----------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus properties *) + +(** {6 Types} *) + +type ('a, 'access) t + (** Type of a property holding a value of type ['a]. ['access] is + the access mode of the property. *) + +type 'a r = ('a, [ `readable ]) t + (** Type of read-only properties *) + +type 'a w = ('a, [ `writable ]) t + (** Type of write-only properties *) + +type 'a rw = ('a, [ `readable | `writable ]) t + (** Type of read and write properties *) + +type map = (OBus_context.t * OBus_value.V.single) Map.Make(String).t + (** Type of all properties of an interface. *) + +type group + (** Type of a group of property. Property groups are used to + read/monitor all the property 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 property rather than reading each + properties 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 conntext to the mapping + function *) + +val map_w : ('b -> 'a) -> ('a, [> `writable ]) t -> 'b w + (** Maps a write-only property. *) + +(** {6 Operations on properties} *) + +val get : ('a, [> `readable ]) t -> 'a Lwt.t + (** Read the contents of a property. *) + +val get_with_context : ('a, [> `readable ]) t -> (OBus_context.t * 'a) Lwt.t + (** Same as {!get} but also returns the context *) + +val set : ('a, [> `writable ]) t -> 'a -> unit Lwt.t + (** Write the contents of a property *) + +val get_group : group -> map Lwt.t + (** Returns the set of all properties that belong to the given + group. *) + +(** {6 Operations on property maps} *) + +val find_value : OBus_name.member -> map -> OBus_value.V.single + (** [find_value name map] returns the value associated to [name] in + [set]. It raises [Not_found] if [name] is not in [map]. *) + +val find_value_with_context : OBus_name.member -> map -> OBus_context.t * OBus_value.V.single + (** Same as {!find_value} but also returns the context in which the + property was received. *) + +val find : ('a, [> `readable ]) t -> map -> 'a + (** [find property map] looks up for the given property in [set] and + maps it to a value of type ['a]. It raises [Not_found] if + [property] does not belong to [map]. *) + +val find_with_context : ('a, [> `readable ]) t -> map -> OBus_context.t * 'a + (** Same as {!find} but also returns the context in which the + property was received. *) + +val print_map : Format.formatter -> map -> unit + (** [print_set pp map] prints all the properties of [map]. *) + +val string_of_map : map -> string + (** [string_of_set set] prints [set] into a string and returns it. *) + +(** {6 Monitoring} *) + +(** Lots of D-Bus services notify other applications with a D-Bus + signal when one or more properties of an object change. In this + case it is possible to monitor the contents of a property. + + Note that when at least one property of an interface is monitored, + obus will keep a local state of all the properties of the + interface. +*) + +val monitor : ?switch : Lwt_switch.t -> ('a, [> `readable ]) t -> 'a React.signal Lwt.t + (** [monitor ?switch property] returns the signal holding the + current contents of [property]. Raises [Failure] if the property + is not monitorable. + + Resources allocated to monitor the property are automatically + freed when the signal is garbage collected *) + +val monitor_group : ?switch : Lwt_switch.t -> group -> map React.signal Lwt.t + (** [monitor_group ?switch group] monitors all properties of the + given group. *) + +(** {6 Helpers for custom monitors} *) + +val get_all_no_cache : OBus_proxy.t -> OBus_name.interface -> (OBus_context.t * (OBus_name.member * OBus_value.V.single) list) Lwt.t + (** [get_all_no_cache proxy interface] reads the value of all + properties without using the cache. *) + +val update_map : OBus_context.t -> (OBus_name.member * OBus_value.V.single) list -> map -> map + (** [update_map context values map] add all properties with their + context and value to [map]. *) + +val map_of_list : OBus_context.t -> (OBus_name.member * OBus_value.V.single) list -> map + (** [map_of_list context values] returns the map corresponding to + the given values and context. *) diff --git a/src/oBus_protocol.ml b/src/oBus_protocol.ml new file mode 100644 index 0000000..ffbe951 --- /dev/null +++ b/src/oBus_protocol.ml @@ -0,0 +1,19 @@ +(* + * oBus_protocol.ml + * ---------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * 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" diff --git a/src/oBus_proxy.ml b/src/oBus_proxy.ml new file mode 100644 index 0000000..34450c5 --- /dev/null +++ b/src/oBus_proxy.ml @@ -0,0 +1,98 @@ +(* + * oBus_proxy.ml + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(proxy)" + +open Lwt +open OBus_peer +open OBus_message + +type t = { + peer : OBus_peer.t; + path : OBus_path.t; +} + +let compare = Pervasives.compare + +let make ~peer ~path = { peer = peer; path = path } + +let peer proxy = proxy.peer +let path proxy = proxy.path +let connection proxy = proxy.peer.connection +let name proxy = proxy.peer.name + +type proxy = t + +module type Private = sig + type t = private proxy + external of_proxy : proxy -> t = "%identity" + external to_proxy : t -> proxy = "%identity" +end + +module Private = +struct + type t = proxy + external of_proxy : proxy -> t = "%identity" + external to_proxy : t -> proxy = "%identity" +end + +(* +-----------------------------------------------------------------+ + | Method calls | + +-----------------------------------------------------------------+ *) + +let call proxy ~interface ~member ~i_args ~o_args args = + OBus_connection.method_call + ~connection:proxy.peer.connection + ~destination:proxy.peer.name + ~path:proxy.path + ~interface + ~member + ~i_args + ~o_args + args + +let call_with_context proxy ~interface ~member ~i_args ~o_args args = + 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 + 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 = + 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 + return (OBus_introspect.input (Xmlm.make_input ~strip:true (`String(0, str)))) + with Xmlm.Error((line, column), err) -> + raise_lwt (Failure(Printf.sprintf "OBus_proxy.introspect: invalid document, at line %d: %s" line (Xmlm.error_message err))) diff --git a/src/oBus_proxy.mli b/src/oBus_proxy.mli new file mode 100644 index 0000000..5961214 --- /dev/null +++ b/src/oBus_proxy.mli @@ -0,0 +1,93 @@ +(* + * oBus_proxy.mli + * -------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Remote D-Bus objects *) + +(** A proxy is an object on which live on a different processus, but + behave as a native ocaml value. *) + +(** The default type for proxies *) +type t = { + peer : OBus_peer.t; + (** Peer owning the object *) + + path : OBus_path.t; + (** Path of the object on the peer *) +} + +val compare : t -> t -> int + (** Same as [Pervasives.compare]. It allows this module to be used + as argument to the functors [Set.Make] and [Map.Make]. *) + +val make : peer : OBus_peer.t -> path : OBus_path.t -> t + (** Creates a proxy from the given peer and path *) + +(** {6 Informations} *) + +val peer : t -> OBus_peer.t + (** Returns the peer pointed by a proxy *) + +val path : t -> OBus_path.t + (** Returns the path of a proxy *) + +val connection : t -> OBus_connection.t + (** [connection proxy = OBus_peer.connection (peer proxy)] *) + +val name : t -> OBus_name.bus + (** [connection proxy = OBus_peer.name (peer proxy)] *) + +val introspect : t -> OBus_introspect.document Lwt.t + (** [introspect proxy] introspects the given proxy *) + +(** {6 Method calls} *) + +val call : t -> + interface : OBus_name.interface -> + member : OBus_name.member -> + i_args : 'a OBus_value.C.sequence -> + o_args : 'b OBus_value.C.sequence -> 'a -> 'b Lwt.t + (** [call proxy ~interface ~member ~i_args ~o_args args] calls the + given method on the given proxy and wait for the reply. *) + +val call_with_context : t -> + interface : OBus_name.interface -> + member : OBus_name.member -> + i_args : 'a OBus_value.C.sequence -> + o_args : 'b OBus_value.C.sequence -> 'a -> (OBus_context.t * 'b) Lwt.t + (** [call_with_context] is like {!call} except that is also returns + the context of the method return *) + +val call_no_reply : t -> + interface : OBus_name.interface -> + member : OBus_name.member -> + i_args : 'a OBus_value.C.sequence -> 'a -> unit Lwt.t + (** [call_no_reply] is the same as {!call} except that it does not + wait for a reply *) + +(** {6 Private proxies} *) + +(** The two following module interface and implementation are helpers + for using private proxies. A private proxy is just a bormal proxy + but defined as a private type, to avoid incorrect use. *) + +type proxy = t + +(** Minimal interface of private proxies *) +module type Private = sig + type t = private proxy + external of_proxy : proxy -> t = "%identity" + external to_proxy : t -> proxy = "%identity" +end + +(** Minimal implementation of private proxies *) +module Private : sig + type t = proxy + external of_proxy : proxy -> t = "%identity" + external to_proxy : t -> proxy = "%identity" +end diff --git a/src/oBus_resolver.ml b/src/oBus_resolver.ml new file mode 100644 index 0000000..c69997f --- /dev/null +++ b/src/oBus_resolver.ml @@ -0,0 +1,195 @@ +(* + * oBus_resolver.ml + * ---------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(resolver)" + +open Lwt_react +open Lwt + +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" -> + 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 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 + return (S.const "") + else begin + 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 = wait () in + info.resolvers <- String_map.add name waiter info.resolvers; + let export_switch = Lwt_switch.create () in + try_lwt + 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 + 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 + wakeup wakener (resolver, export_switch); + return (resolver, export_switch) + with exn -> + info.resolvers <- String_map.remove name info.resolvers; + wakeup_exn wakener exn; + lwt () = Lwt_switch.turn_off export_switch in + raise_lwt 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 + return () + with exn -> + lwt () = Lwt_log.warning_f ~section ~exn "failed to disable resolver for name %S" name in + raise_lwt exn + ) in + + let owner = S.with_finaliser (finalise remove) resolver.owner in + + lwt () = + Lwt_switch.add_hook_or_exec + switch + (fun () -> + S.stop owner; + Lazy.force remove) + in + + return owner + end diff --git a/src/oBus_resolver.mli b/src/oBus_resolver.mli new file mode 100644 index 0000000..d1c2618 --- /dev/null +++ b/src/oBus_resolver.mli @@ -0,0 +1,34 @@ +(* + * oBus_resolver.mli + * ----------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Bus name resolving *) + +(** This module implement bus names resolving and monitoring. + + - for a unique connection name, it means being notified when the + peer owning this name exit + + - 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 change (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 use them, so this avoid extra messages. + + Note that with a peer-to-peer connection, resolver will always act + as if they is no owner. *) + +val make : ?switch : Lwt_switch.t -> OBus_connection.t -> OBus_name.bus -> OBus_name.bus React.signal Lwt.t + (** [make ?switch bus name] creates a resolver which will monitor + the name [name] on [bus]. It returns a signal holding the + current owner of the name. It holds [""] when there is no + owner. *) diff --git a/src/oBus_server.ml b/src/oBus_server.ml new file mode 100644 index 0000000..dca31ab --- /dev/null +++ b/src/oBus_server.ml @@ -0,0 +1,516 @@ +(* + * oBus_server.ml + * -------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(server)" + +open Unix +open Lwt + +(* +-----------------------------------------------------------------+ + | 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 = String.create 16 in + let rec loop ofs len = + Lwt_unix.read fd nonce ofs len >>= function + | 0 -> + raise_lwt End_of_file + | n -> + if n = len then + return 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 + lwt result = Lwt_unix.accept listener.lst_fd in + return (`Accept result) + with Unix_error(err, _, _) -> + 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 *) + return () + in + return `Shutdown + end >>= function + | `Accept(fd, address) -> + if OBus_address.name listener.lst_address = "nonce-tcp" then begin + begin + try_lwt + lwt nonce = read_nonce fd in + if nonce <> server.srv_nonce then begin + lwt () = Lwt_log.notice_f ~section "client rejected because of invalid nonce" in + return `Drop + end else + return `OK + with + | End_of_file -> + lwt () = Lwt_log.warning ~section "cannot read nonce from socket" in + return `Drop + | Unix.Unix_error(err, _, _) -> + lwt () = Lwt_log.warning_f ~section "cannot read nonce from socket: %s" (Unix.error_message err) in + return `Drop + end >>= function + | `OK -> + return (Event_connection(fd, address)) + | `Drop -> + 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 + return (Event_connection(fd, address)) + | `Shutdown -> + 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 -> + return () + end + | _ -> + 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 = String.create 1 in + Lwt_unix.read fd buf 0 1 >>= function + | 0 -> + raise_lwt (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 + 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 + 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); + return () + with exn -> + lwt () = Lwt_log.error ~section ~exn "server callback failed failed with" in + Lazy.force shutdown + end + | _ -> + assert false + with exn -> + 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 = + pick [server.srv_abort_waiter; accept server listener] >>= function + | Event_shutdown -> + 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 + Lwt_unix.bind fd address; + Lwt_unix.listen fd 10; + return fd + with Unix_error(err, _, _) as exn -> + lwt () = Lwt_log.error_f ~section "failed to create listenning socket with %s: %s" (string_of_address address) (Unix.error_message err) in + lwt () = Lwt_unix.close fd in + raise_lwt 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 -> + lwt fd = make_path path in + return [(fd, address)] + | None, Some abst, None -> + lwt fd = make_abstract abst in + 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 + lwt fd = make_abstract path in + return [(fd, OBus_address.make ~name:"unix" ~args:[("abstract", path)])] + with exn -> + (* And fallback to path in the filesystem *) + lwt fd = make_path path in + return [(fd, OBus_address.make ~name:"unix" ~args:[("path", path)])] + end + | _ -> + raise_lwt (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 -> + lwt results = Lwt_list.map_p + (fun ai -> + try_lwt + 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) -> + 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 -> + 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 -> raise_lwt exn + | None -> assert false + else + return fd_addr_list + end + + | "autolaunch" -> + raise_lwt (Failure "OBus_server.make_server: autolaunch can not be used as a listenning address") + + | name -> + raise_lwt (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; + wakeup server.srv_abort_wakener Event_shutdown; + 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 + 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.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 + | [] -> + raise_lwt (Invalid_argument "OBus_server.make: no addresses given") + + | addresses -> + (* Construct the list of all listening fds for each + address: *) + lwt result_by_address = + Lwt_list.map_p + (fun address -> + try_lwt + lwt x = fd_addr_list_of_address address in + return (`Success x) + with e -> + return (`Failure e)) + addresses + in + + (* Close all listening file descriptors and fail: *) + let abort exn = + lwt () = + Lwt_list.iter_p + (function + | `Success fd_addr_list -> + Lwt_list.iter_p + (fun (fd, address) -> + try_lwt + 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 -> + return ()) + result_by_address + in + raise_lwt exn + in + + match OBus_util.find_map (function `Success _ -> None | `Failure e -> Some e) result_by_address with + | Some exn -> + abort exn + + | None -> + 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.temp_dir_name ("obus-" ^ OBus_util.hex_encode (OBus_util.random_string 10)) in + try_lwt + lwt () = Lwt_io.with_file ~mode:Lwt_io.output file_name (fun oc -> Lwt_io.write oc nonce) in + 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 + 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 = return (); + } in + server.srv_loops <- join (List.map (fun listener -> lst_loop server listener) listeners); + + lwt () = Lwt_switch.add_hook_or_exec switch (fun () -> shutdown server) in + return server + +let make ?switch ?capabilities ?mechanisms ?addresses ?allow_anonymous callback = + make_lowlevel ?switch ?capabilities ?mechanisms ?addresses ?allow_anonymous + (fun server transport -> callback server (OBus_connection.of_transport ~up:false transport)) diff --git a/src/oBus_server.mli b/src/oBus_server.mli new file mode 100644 index 0000000..68563a5 --- /dev/null +++ b/src/oBus_server.mli @@ -0,0 +1,72 @@ +(* + * oBus_server.mli + * --------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Servers for one-to-one communication *) + +type t + (** Type of a server *) + +val addresses : t -> OBus_address.t list + (** [addresses server] returns all the addresses the server is + listenning on. These addresses must be passed to clients so they + can connect to [server]. *) + +val shutdown : t -> unit Lwt.t + (** [shutdown server] shutdowns the given server. It terminates when + all listeners (a server may listen on several addresses) have + exited. If the server has already been shutdown, 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 address are provided, it raises [Invalid_argument], + - if an address is invalid, it raises [Invalid_argument] + - if listenning fails for one of the addresses, it fails with the + exception reported for this address + + It succeed if it can listen on at least one address. + + When a new client connects, the server handle authentication of + this client, then it creates a transport and the connection on + top of this transport. + + Note that connections passed to [f] are initially down. It is up + to the user to set them up with {!OBus_connection.set_up}. *) + +val make_lowlevel : + ?switch : Lwt_switch.t -> + ?capabilities : OBus_auth.capability list -> + ?mechanisms : OBus_auth.Server.mechanism list -> + ?addresses : OBus_address.t list -> + ?allow_anonymous : bool -> + (t -> OBus_transport.t -> unit) -> t Lwt.t + (** [make_lowlevel] is the same as {!make} except that [f] receives + only the transport, and no connection is created for this + transport. *) diff --git a/src/oBus_signal.ml b/src/oBus_signal.ml new file mode 100644 index 0000000..06162a3 --- /dev/null +++ b/src/oBus_signal.ml @@ -0,0 +1,292 @@ +(* + * oBus_signal.ml + * -------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(signal)" + +open Lwt_react +open Lwt + +(* +-----------------------------------------------------------------+ + | Signal descriptors | + +-----------------------------------------------------------------+ *) + +type 'a t = { + interface : OBus_name.interface; + (* The interface of the signal. *) + + member : OBus_name.member; + (* The name of the signal. *) + + peer : OBus_peer.t; + (* The peer emitting the signal. *) + + path : OBus_path.t option; + (* The path of the object emitting the signa or [None] if we want to + match signals comming from any objects. *) + + map : (OBus_context.t * OBus_path.t * OBus_value.V.sequence) event -> (OBus_context.t * 'a) event; + (* The function which maps the event into an event holding values of + type ['a]. *) + + filters : OBus_match.arguments; + (* Argument filters. *) + + match_rule : bool; + (* Whether the managed mode for the match rule is enabled *) +} + +let empty_filters = OBus_match.make_arguments [] + +(* Cast a message body into an ocaml value: *) +let cast signal (context, path, body) = + try + Some(context, + OBus_value.C.cast_sequence + (OBus_value.arg_types + (OBus_member.Signal.args signal)) + body) + with OBus_value.C.Signature_mismatch -> + ignore ( + Lwt_log.error_f ~section "failed to cast signal from %S, interface %S, member %S with signature %S to %S" + (OBus_peer.name (OBus_context.sender context)) + (OBus_member.Signal.interface signal) + (OBus_member.Signal.member signal) + (OBus_value.string_of_signature + (OBus_value.V.type_of_sequence body)) + (OBus_value.string_of_signature + (OBus_value.C.type_sequence + (OBus_value.arg_types + (OBus_member.Signal.args signal)))) + ); + None + +let cast_any signal (context, path, body) = + match cast signal (context, path, body) with + | Some(context, v) -> Some(context, (OBus_proxy.make (OBus_context.sender context) path, v)) + | None -> None + +let make signal proxy = { + interface = OBus_member.Signal.interface signal; + member = OBus_member.Signal.member signal; + peer = OBus_proxy.peer proxy; + path = Some(OBus_proxy.path proxy); + map = E.fmap (cast signal); + filters = empty_filters; + match_rule = OBus_connection.name (OBus_proxy.connection proxy) <> ""; +} + +let make_any signal peer = { + interface = OBus_member.Signal.interface signal; + member = OBus_member.Signal.member signal; + peer = peer; + path = None; + map = E.fmap (cast_any signal); + filters = empty_filters; + match_rule = OBus_connection.name (OBus_peer.connection peer) <> ""; +} + +(* +-----------------------------------------------------------------+ + | Signals transformations and parameters | + +-----------------------------------------------------------------+ *) + +let map_event f sd = + { sd with map = fun event -> f (sd.map event) } + +let map f sd = + { sd with map = fun event -> E.map (fun (context, value) -> (context, f value)) (sd.map event) } + +let map_with_context f sd = + { sd with map = fun event -> E.map (fun (context, value) -> (context, f context value)) (sd.map event) } + +let with_context sd = + { sd with map = fun event -> E.map (fun (context, value) -> (context, (context, value))) (sd.map event) } + +let with_filters filters sd = + { sd with filters } + +let with_match_rule match_rule sd = + { sd with match_rule } + +(* +-----------------------------------------------------------------+ + | Signals dispatching | + +-----------------------------------------------------------------+ *) + +module Signal_map = Map.Make + (struct + type t = OBus_path.t option * OBus_name.interface * OBus_name.member + let compare = Pervasives.compare + end) + +type info = { + mutable senders : (OBus_context.t * OBus_path.t * OBus_value.V.sequence -> unit) Lwt_sequence.t Signal_map.t; +} + +let dispatch connection info message = + match OBus_message.typ message with + | OBus_message.Signal(path, interface, member) -> + begin + match try Some(Signal_map.find (Some path, interface, member) info.senders) with Not_found -> None with + | Some senders -> + Lwt_sequence.iter_l + (fun send -> + try + send (OBus_context.make connection message, path, OBus_message.body message) + with exn -> + ignore (Lwt_log.error ~section ~exn "signal event failed with")) + senders + | None -> + () + end; + begin + match try Some(Signal_map.find (None, interface, member) info.senders) with Not_found -> None with + | Some senders -> + Lwt_sequence.iter_l + (fun send -> + try + send (OBus_context.make connection message, path, OBus_message.body message) + with exn -> + ignore (Lwt_log.error ~section ~exn "signal event failed with")) + senders + | None -> + () + end; + Some message + | _ -> + Some message + +(* +-----------------------------------------------------------------+ + | Signals connection | + +-----------------------------------------------------------------+ *) + +let finalise disconnect _ = + ignore (Lazy.force disconnect) + +let key = OBus_connection.new_key () + +let connect ?switch sd = + Lwt_switch.check switch; + let connection = OBus_peer.connection sd.peer and name = OBus_peer.name sd.peer in + + (* Switch freeing resources allocated for this signal: *) + let resources_switch = Lwt_switch.create () in + + try_lwt + (* Add the match rule if requested: *) + 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 + return () + + (* Plus the resolver if needed: *) + and owner_option = + if OBus_connection.name connection <> "" && name <> "" then + if OBus_name.is_unique name then + return (Some (S.const name)) + else + lwt owner = OBus_resolver.make ~switch:resources_switch connection name in + return (Some owner) + else + 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 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 -> + lwt () = + Lwt_log.warning_f + ~section + ~exn + "failed to disconnect signal \"%s.%s\" of object \"%s\" from \"%s\"" + sd.interface + sd.member + (match sd.path with + | Some path -> OBus_path.to_string path + | None -> "<any>") + (OBus_peer.name sd.peer) + in + raise_lwt exn + ) in + + let event = E.with_finaliser (finalise disconnect) (E.map snd (sd.map event)) in + + lwt () = + Lwt_switch.add_hook_or_exec + switch + (fun () -> + E.stop event; + Lazy.force disconnect) + in + + return event + with exn -> + lwt () = Lwt_switch.turn_off resources_switch in + raise_lwt exn + +(* +-----------------------------------------------------------------+ + | Emitting signals | + +-----------------------------------------------------------------+ *) + +let emit info obj ?peer args = + OBus_object.emit obj + ~interface:(OBus_member.Signal.interface info) + ~member:(OBus_member.Signal.member info) + ?peer + (OBus_value.arg_types (OBus_member.Signal.args info)) + args diff --git a/src/oBus_signal.mli b/src/oBus_signal.mli new file mode 100644 index 0000000..c02b07e --- /dev/null +++ b/src/oBus_signal.mli @@ -0,0 +1,77 @@ +(* + * oBus_signal.mli + * --------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus signals *) + +(** {6 Emitting signals} *) + +val emit : 'a OBus_member.Signal.t -> 'b OBus_object.t -> ?peer : OBus_peer.t -> 'a -> unit Lwt.t + (** [emit signal obj ?peer args] emit [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 connection [obj] is exported. + *) + +(** {6 Receving signals} *) + +type 'a t + (** Type of a signal descriptor. A signal descriptor represent the + source of a signal and describe 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 + (** Returns a signal descriptor that returns contexts in which + signals are received. *) + +val with_filters : OBus_match.arguments -> 'a t -> 'a t + (** [with_filters filters sd] is the signal descriptor [sd] with the + given list of argument filters. When connected, obus will add + this filters to the matching rule send to the message bus, so + the bus can use them to drop messages that do not match these + filters. + + The goal of argument filters is to reduce the number of messages + received, and so to reduce the number of wakeup of the + program. + + Note that match rule management must be activated for filters to + take effect (see {!with_match_rule}). *) + +val with_match_rule : bool -> 'a t -> 'a t + (** [with_match_rule state sd] enables or disables the automatic + management of matching rules. If the endpoint of the underlying + connection is a message bus it defaults to [true], otherwise it + default to [false]. *) diff --git a/src/oBus_string.ml b/src/oBus_string.ml new file mode 100644 index 0000000..8d6221a --- /dev/null +++ b/src/oBus_string.ml @@ -0,0 +1,115 @@ +(* + * oBus_string.ml + * -------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +type t = string + +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 -> () diff --git a/src/oBus_string.mli b/src/oBus_string.mli new file mode 100644 index 0000000..b724d77 --- /dev/null +++ b/src/oBus_string.mli @@ -0,0 +1,65 @@ +(* + * oBus_string.mli + * --------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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 a various restrictions for strings used in D-Bus. + Obus only verify 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 byte where the validation failed *) + + msg : string; + (** explain why the string failed to validate *) +} + +val error_message : error -> string + (** [error_message error] returns a human-readabe 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 + (** Function which test 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 + (** Validatition function for commong strings *) diff --git a/src/oBus_transport.ml b/src/oBus_transport.ml new file mode 100644 index 0000000..91967a4 --- /dev/null +++ b/src/oBus_transport.ml @@ -0,0 +1,292 @@ +(* + * oBus_transport.ml + * ----------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(transport)" + +open Unix +open Printf +open Lwt +open OBus_address + +(* +-----------------------------------------------------------------+ + | 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 _ -> + 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:return fd + and oc = Lwt_io.of_fd ~mode:Lwt_io.output ~close:return fd in + { recv = (fun _ -> OBus_wire.read_message ic); + send = (fun msg -> OBus_wire.write_message oc msg); + capabilities = capabilities; + shutdown = (fun _ -> + 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 = 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 + lwt () = Lwt_unix.connect fd addr in + return (fd, domain) + with exn -> + lwt () = Lwt_unix.close fd in + raise_lwt exn + +let rec write_nonce fd nonce pos len = + Lwt_unix.write fd nonce 0 16 >>= function + | 0 -> + raise_lwt (Failure "OBus_transport.connect: failed to send the nonce to the server") + | n -> + if n = len then + return () + else + write_nonce fd nonce (pos + n) (len - n) + +let make_socket_nonce nonce_file domain typ addr = + match nonce_file with + | None -> + raise_lwt (Invalid_argument "OBus_transport.connect: missing 'noncefile' parameter") + | Some file_name -> + lwt nonce = + try_lwt + Lwt_io.with_file ~mode:Lwt_io.input file_name (Lwt_io.read ~count:16) + with + | Unix.Unix_error(err, _, _) -> + raise_lwt (Failure(Printf.sprintf "failed to read the nonce file '%s': %s" file_name (Unix.error_message err))) + | End_of_file -> + raise_lwt (Failure(Printf.sprintf "OBus_transport.connect: '%s' is an invalid nonce-file" file_name)) + in + if String.length nonce <> 16 then + raise_lwt (Failure(Printf.sprintf "OBus_transport.connect: '%s' is an invalid nonce-file" file_name)) + else begin + lwt fd, domain = make_socket domain typ addr in + lwt () = write_nonce fd nonce 0 16 in + 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 -> + raise_lwt (Invalid_argument "OBus_transport.connect: unix tmpdir can only be used as a listening address") + | _ -> + raise_lwt (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 + | [] -> + 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: *) + raise_lwt 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 -> + lwt path = + try_lwt + Lwt_process.pread_line ("launchctl", [|"launchctl"; "getenv"; env|]) + with exn -> + lwt () = Lwt_log.error_f ~exn ~section "launchctl failed" in + raise_lwt exn + in + make_socket PF_UNIX SOCK_STREAM (ADDR_UNIX path) + | None -> + raise_lwt (Invalid_argument "OBus_transport.connect: missing 'env' in launchd address") + end + | "autolaunch" -> begin + lwt addresses = + lwt uuid = Lazy.force OBus_info.machine_uuid in + lwt line = + try_lwt + Lwt_process.pread_line ("dbus-launch", [|"dbus-launch"; "--autolaunch"; OBus_uuid.to_string uuid; "--binary-syntax"|]) + with exn -> + lwt () = Lwt_log.error_f ~exn ~section "autolaunch failed" in + raise_lwt exn + in + let line = try String.sub line 0 (String.index line '\000') with _ -> line in + try_lwt + return (OBus_address.of_string line) + with OBus_address.Parse_failure(addr, pos, reason) as exn -> + lwt () = Lwt_log.error_f ~section "autolaunch returned an invalid address %S, at position %d: %s" addr pos reason in + raise_lwt exn + in + match addresses with + | [] -> + lwt () = Lwt_log.error_f ~section "'autolaunch' returned no addresses" in + raise_lwt (Failure "'autolaunch' returned no addresses") + | address :: rest -> + try_lwt + connect address + with exn -> + let rec find = function + | [] -> + raise_lwt exn + | address :: rest -> + try_lwt + connect address + with exn -> + find rest + in + find rest + end + + | name -> + raise_lwt (Failure ("unknown transport type: " ^ name)) + +let of_addresses ?switch ?(capabilities=OBus_auth.capabilities) ?mechanisms addresses = + Lwt_switch.check switch; + match addresses with + | [] -> + raise_lwt (Invalid_argument "OBus_transport.of_addresses: no address given") + | addr :: rest -> + (* Search an address for which connection succeed: *) + 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: *) + raise_lwt exn + | addr :: rest -> + try_lwt + connect addr + with exn -> + find rest + in + find rest + in + (* Do authentication only once: *) + try_lwt + Lwt_unix.write fd "\x00" 0 1 >>= function + | 0 -> + raise_lwt (OBus_auth.Auth_failure "failed to send the initial null byte") + | 1 -> + 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 + return (guid, socket ?switch ~capabilities fd) + | n -> + assert false + with exn -> + Lwt_unix.shutdown fd SHUTDOWN_ALL; + lwt () = Lwt_unix.close fd in + raise_lwt exn diff --git a/src/oBus_transport.mli b/src/oBus_transport.mli new file mode 100644 index 0000000..610431e --- /dev/null +++ b/src/oBus_transport.mli @@ -0,0 +1,79 @@ +(* + * oBus_transport.mli + * ------------------ + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Low-level transporting of messages *) + +type t + (** Type of message transport *) + +val recv : t -> OBus_message.t Lwt.t + (** [recv tr] receives one message from the given transport *) + +val send : t -> OBus_message.t -> unit Lwt.t + (** [send tr msg] sends [msg] over the transport [tr]. *) + +val capabilities : t -> OBus_auth.capability list + (** Returns the capabilities of the transport *) + +val shutdown : t -> unit Lwt.t + (** [shutdown tr] free 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 socket, 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: + + - connects to the server using one of the given given addresses, + - authenticates ourself to the server using [mechanisms], which + defaults to {!OBus_auth.Client.default_mechanisms}, + - negociates [capabilities], which defaults to + {!OBus_auth.capabilities} + + If all succeed, it returns the server address guid and the + newly created transport, which is ready to send and receive + messages. + + Note about errors: + - if one of the addresses is not valid, or [addresses = []], + it raises [Invalid_argument], + - if all connections failed, it raises the exception raised + by the try on first address, which is either a [Failure] or + a [Unix.Unix_error] + - if the authentication failed, a {!OBus_auth.Auth_error} is + raised + *) diff --git a/src/oBus_type_ext_lexer.mll b/src/oBus_type_ext_lexer.mll new file mode 100644 index 0000000..de72963 --- /dev/null +++ b/src/oBus_type_ext_lexer.mll @@ -0,0 +1,105 @@ +(* + * oBus_type_ext_lexer.mll + * ----------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +{ + open OBus_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" } diff --git a/src/oBus_util.ml b/src/oBus_util.ml new file mode 100644 index 0000000..9579010 --- /dev/null +++ b/src/oBus_util.ml @@ -0,0 +1,244 @@ +(* + * oBus_util.ml + * ------------ + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(util)" + +open Lwt +open Printf + +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 rec 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 = String.create (len * 2) in + for i = 0 to len - 1 do + let n = Char.code (String.unsafe_get str i) in + String.unsafe_set hex (i * 2) (encode_char (n lsr 4)); + String.unsafe_set hex (i * 2 + 1) (encode_char (n land 15)) + done; + 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 = String.create len in + for i = 0 to len - 1 do + String.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; + str + +let homedir = lazy( + try + return (Sys.getenv "HOME") + with Not_found -> + lwt pwd = Lwt_unix.getpwuid (Unix.getuid ()) in + return pwd.Unix.pw_dir +) + +let init_pseudo = Lazy.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 + String.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 = String.create n in + fill_random str 0 n; + 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 = String.create mlen in + String.blit s 0 m 0 len; + String.fill m len (mlen - len) '\x00'; + m.[len] <- '\x80'; + if Sys.word_size > 32 then begin + m.[mlen - 8] <- Char.unsafe_chr (blen lsr 56 land 0xFF); + m.[mlen - 7] <- Char.unsafe_chr (blen lsr 48 land 0xFF); + m.[mlen - 6] <- Char.unsafe_chr (blen lsr 40 land 0xFF); + m.[mlen - 5] <- Char.unsafe_chr (blen lsr 32 land 0xFF); + end; + m.[mlen - 4] <- Char.unsafe_chr (blen lsr 24 land 0xFF); + m.[mlen - 3] <- Char.unsafe_chr (blen lsr 16 land 0xFF); + m.[mlen - 2] <- Char.unsafe_chr (blen lsr 8 land 0xFF); + m.[mlen - 1] <- Char.unsafe_chr (blen land 0xFF); + 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 = String.create 20 in + let i2s h k i = + h.[k] <- Char.unsafe_chr ((Int32.to_int (sr i 24)) &&& 0xFF); + h.[k + 1] <- Char.unsafe_chr ((Int32.to_int (sr i 16)) &&& 0xFF); + h.[k + 2] <- Char.unsafe_chr ((Int32.to_int (sr i 8)) &&& 0xFF); + 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; + h diff --git a/src/oBus_util.mli b/src/oBus_util.mli new file mode 100644 index 0000000..d693f64 --- /dev/null +++ b/src/oBus_util.mli @@ -0,0 +1,64 @@ +(* + * oBus_util.mli + * ------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * 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 : string -> 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 diff --git a/src/oBus_uuid.ml b/src/oBus_uuid.ml new file mode 100644 index 0000000..92c1926 --- /dev/null +++ b/src/oBus_uuid.ml @@ -0,0 +1,28 @@ +(* + * oBus_uuid.ml + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +type t = string + +let of_string str = + let fail _ = raise (Invalid_argument (Printf.sprintf "OBus_uuid.of_string(%S)" str)) in + if String.length str <> 32 then fail (); + try OBus_util.hex_decode str + with _ -> fail () + +let to_string = OBus_util.hex_encode + +let generate () = + let uuid = String.create 16 in + OBus_util.fill_random uuid 0 12; + let v = Int32.of_float (Unix.time ()) in + uuid.[12] <- (Char.unsafe_chr (Int32.to_int (Int32.shift_right v 24))); + uuid.[13] <- (Char.unsafe_chr (Int32.to_int (Int32.shift_right v 16))); + uuid.[14] <- (Char.unsafe_chr (Int32.to_int (Int32.shift_right v 8))); + uuid.[15] <- (Char.unsafe_chr (Int32.to_int v)); + uuid diff --git a/src/oBus_uuid.mli b/src/oBus_uuid.mli new file mode 100644 index 0000000..9888e88 --- /dev/null +++ b/src/oBus_uuid.mli @@ -0,0 +1,31 @@ +(* + * oBus_uuid.mli + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus universally-unique IDs *) + +(** D-Bus uuid are used to distinguish message buses, addresses, and + machines. + + Note that they are not compatible with RFC4122. *) + +type t + +val generate : unit -> t + (** Generate a new uuid *) + +val of_string : string -> t + (** Create a uuid from a string. The string must contain an + hex-encoded uuid, i.e. be of length 32 and only contain + hexadecimal characters. It raise a failure otherwise. + + @raise Invalid_argument if the string does not contain a valid + uuid. *) + +val to_string : t -> string + (** Return a hex-encoded string representation of an uuid. *) diff --git a/src/oBus_value.ml b/src/oBus_value.ml new file mode 100644 index 0000000..b98aa19 --- /dev/null +++ b/src/oBus_value.ml @@ -0,0 +1,1196 @@ +(* + * oBus_value.mlp + * -------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(value)" + +open Format + +let rec 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@,(@[<hv>%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 + aux_sequence 0 0 0 0 l + +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 + let _ = length_validate_signature l in + 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 = String.create len and i = ref 0 in + let put_char ch = + let j = !i in + String.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; + try + let _ = length_validate_signature in + 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 = String.create (List.length l) and i = ref 0 in + List.iter (function + | Basic(Byte x) -> + String.unsafe_set s !i x; + incr i + | _ -> + invalid_arg "OBus_value.array: unexpected type") l; + Byte_array 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 "<fd>" + + 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@,(@[<hv>%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]; +} + diff --git a/src/oBus_value.mli b/src/oBus_value.mli new file mode 100644 index 0000000..14277e0 --- /dev/null +++ b/src/oBus_value.mli @@ -0,0 +1,368 @@ +(* + * oBus_value.mli + * -------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** D-Bus 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 offer 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 diff --git a/src/oBus_wire.ml b/src/oBus_wire.ml new file mode 100644 index 0000000..6efea11 --- /dev/null +++ b/src/oBus_wire.ml @@ -0,0 +1,1328 @@ +(* + * oBus_lowlevel.ml + * ---------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let section = Lwt_log.Section.make "obus(wire)" + +open Printf +open Lwt +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 = String.unsafe_set +let put_uint8 buf ofs x = put_char buf ofs (Char.unsafe_chr x) + +module type Integer_writers = sig + val put_int16 : string -> int -> int -> unit + val put_int32 : string -> int -> int32 -> unit + val put_int64 : string -> int -> int64 -> unit + val put_uint16 : string -> int -> int -> unit + val put_uint32 : string -> int -> int32 -> unit + val put_uint64 : string -> int -> int64 -> unit + + val put_uint : string -> int -> int -> unit +end + +module LE_integer_writers : Integer_writers = +struct + let put_int16 buf ofs v = + put_uint8 buf (ofs + 0) v; + put_uint8 buf (ofs + 1) (v lsr 8) + let put_uint16 = put_int16 + + let put_int32 buf ofs v = + put_uint8 buf (ofs + 0) (Int32.to_int v); + put_uint8 buf (ofs + 1) (Int32.to_int (Int32.shift_right v 8)); + put_uint8 buf (ofs + 2) (Int32.to_int (Int32.shift_right v 16)); + put_uint8 buf (ofs + 3) (Int32.to_int (Int32.shift_right v 24)) + let put_uint32 = put_int32 + + let put_int64 buf ofs v = + put_uint8 buf (ofs + 0) (Int64.to_int v); + put_uint8 buf (ofs + 1) (Int64.to_int (Int64.shift_right v 8)); + put_uint8 buf (ofs + 2) (Int64.to_int (Int64.shift_right v 16)); + put_uint8 buf (ofs + 3) (Int64.to_int (Int64.shift_right v 24)); + put_uint8 buf (ofs + 4) (Int64.to_int (Int64.shift_right v 32)); + put_uint8 buf (ofs + 5) (Int64.to_int (Int64.shift_right v 40)); + put_uint8 buf (ofs + 6) (Int64.to_int (Int64.shift_right v 48)); + put_uint8 buf (ofs + 7) (Int64.to_int (Int64.shift_right v 56)) + let put_uint64 = put_int64 + + let put_uint buf ofs v = + put_uint8 buf (ofs + 0) v; + put_uint8 buf (ofs + 1) (v lsr 8); + put_uint8 buf (ofs + 2) (v lsr 16); + put_uint8 buf (ofs + 3) (v asr 24) +end + +module BE_integer_writers : Integer_writers = +struct + let put_int16 buf ofs v = + put_uint8 buf (ofs + 0) (v lsr 8); + put_uint8 buf (ofs + 1) v + let put_uint16 = put_int16 + + let put_int32 buf ofs v = + put_uint8 buf (ofs + 0) (Int32.to_int (Int32.shift_right v 24)); + put_uint8 buf (ofs + 1) (Int32.to_int (Int32.shift_right v 16)); + put_uint8 buf (ofs + 2) (Int32.to_int (Int32.shift_right v 8)); + put_uint8 buf (ofs + 3) (Int32.to_int v) + let put_uint32 = put_int32 + + let put_int64 buf ofs v = + put_uint8 buf (ofs + 0) (Int64.to_int (Int64.shift_right v 56)); + put_uint8 buf (ofs + 1) (Int64.to_int (Int64.shift_right v 48)); + put_uint8 buf (ofs + 2) (Int64.to_int (Int64.shift_right v 40)); + put_uint8 buf (ofs + 3) (Int64.to_int (Int64.shift_right v 32)); + put_uint8 buf (ofs + 4) (Int64.to_int (Int64.shift_right v 24)); + put_uint8 buf (ofs + 5) (Int64.to_int (Int64.shift_right v 16)); + put_uint8 buf (ofs + 6) (Int64.to_int (Int64.shift_right v 8)); + put_uint8 buf (ofs + 7) (Int64.to_int v) + let put_uint64 = put_int64 + + let put_uint buf ofs v = + put_uint8 buf (ofs + 0) (v asr 24); + put_uint8 buf (ofs + 1) (v lsr 16); + put_uint8 buf (ofs + 2) (v lsr 8); + put_uint8 buf (ofs + 3) v +end + +(* +-----------------------------------------------------------------+ + | Unsafe reading of integers | + +-----------------------------------------------------------------+ *) + +let get_char = String.unsafe_get +let get_uint8 buf ofs = Char.code (get_char buf ofs) + +module type Integer_readers = sig + val get_int16 : string -> int -> int + val get_int32 : string -> int -> int32 + val get_int64 : string -> int -> int64 + val get_uint16 : string -> int -> int + val get_uint32 : string -> int -> int32 + val get_uint64 : string -> int -> int64 + + val get_uint : string -> int -> int +end + +module LE_integer_readers : Integer_readers = +struct + let get_int16 buf ofs = + let v0 = get_uint8 buf (ofs + 0) + and v1 = get_uint8 buf (ofs + 1) in + let v = v0 lor (v1 lsl 8) in + if v land (1 lsl 15) = 0 then + v + else + ((-1 land (lnot 0x7fff)) lor v) + + let get_uint16 buf ofs = + let v0 = get_uint8 buf (ofs + 0) + and v1 = get_uint8 buf (ofs + 1) in + (v0 lor (v1 lsl 8)) + + let get_int32 buf ofs = + let v0 = get_uint8 buf (ofs + 0) + and v1 = get_uint8 buf (ofs + 1) + and v2 = get_uint8 buf (ofs + 2) + and v3 = get_uint8 buf (ofs + 3) in + (Int32.logor + (Int32.logor + (Int32.of_int v0) + (Int32.shift_left (Int32.of_int v1) 8)) + (Int32.logor + (Int32.shift_left (Int32.of_int v2) 16) + (Int32.shift_left (Int32.of_int v3) 24))) + let get_uint32 = get_int32 + + let get_int64 buf ofs = + let v0 = get_uint8 buf (ofs + 0) + and v1 = get_uint8 buf (ofs + 1) + and v2 = get_uint8 buf (ofs + 2) + and v3 = get_uint8 buf (ofs + 3) + and v4 = get_uint8 buf (ofs + 4) + and v5 = get_uint8 buf (ofs + 5) + and v6 = get_uint8 buf (ofs + 6) + and v7 = get_uint8 buf (ofs + 7) in + (Int64.logor + (Int64.logor + (Int64.logor + (Int64.of_int v0) + (Int64.shift_left (Int64.of_int v1) 8)) + (Int64.logor + (Int64.shift_left (Int64.of_int v2) 16) + (Int64.shift_left (Int64.of_int v3) 24))) + (Int64.logor + (Int64.logor + (Int64.shift_left (Int64.of_int v4) 32) + (Int64.shift_left (Int64.of_int v5) 40)) + (Int64.logor + (Int64.shift_left (Int64.of_int v6) 48) + (Int64.shift_left (Int64.of_int v7) 56)))) + let get_uint64 = get_int64 + + let get_uint buf ofs = + let v0 = get_uint8 buf (ofs + 0) + and v1 = get_uint8 buf (ofs + 1) + and v2 = get_uint8 buf (ofs + 2) + and v3 = get_uint8 buf (ofs + 3) in + (v0 lor (v1 lsl 8) lor (v2 lsl 16) lor (v3 lsl 24)) +end + +module BE_integer_readers : Integer_readers = +struct + let get_int16 buf ofs = + let v1 = get_uint8 buf (ofs + 0) + and v0 = get_uint8 buf (ofs + 1) in + let v = v0 lor (v1 lsl 8) in + if v land (1 lsl 15) = 0 then + v + else + ((-1 land (lnot 0x7fff)) lor v) + + let get_uint16 buf ofs = + let v1 = get_uint8 buf (ofs + 0) + and v0 = get_uint8 buf (ofs + 1) in + (v0 lor (v1 lsl 8)) + + let get_int32 buf ofs = + let v3 = get_uint8 buf (ofs + 0) + and v2 = get_uint8 buf (ofs + 1) + and v1 = get_uint8 buf (ofs + 2) + and v0 = get_uint8 buf (ofs + 3) in + (Int32.logor + (Int32.logor + (Int32.of_int v0) + (Int32.shift_left (Int32.of_int v1) 8)) + (Int32.logor + (Int32.shift_left (Int32.of_int v2) 16) + (Int32.shift_left (Int32.of_int v3) 24))) + let get_uint32 = get_int32 + + let get_int64 buf ofs = + let v7 = get_uint8 buf (ofs + 0) + and v6 = get_uint8 buf (ofs + 1) + and v5 = get_uint8 buf (ofs + 2) + and v4 = get_uint8 buf (ofs + 3) + and v3 = get_uint8 buf (ofs + 4) + and v2 = get_uint8 buf (ofs + 5) + and v1 = get_uint8 buf (ofs + 6) + and v0 = get_uint8 buf (ofs + 7) in + (Int64.logor + (Int64.logor + (Int64.logor + (Int64.of_int v0) + (Int64.shift_left (Int64.of_int v1) 8)) + (Int64.logor + (Int64.shift_left (Int64.of_int v2) 16) + (Int64.shift_left (Int64.of_int v3) 24))) + (Int64.logor + (Int64.logor + (Int64.shift_left (Int64.of_int v4) 32) + (Int64.shift_left (Int64.of_int v5) 40)) + (Int64.logor + (Int64.shift_left (Int64.of_int v6) 48) + (Int64.shift_left (Int64.of_int v7) 56)))) + let get_uint64 = get_int64 + + let get_uint buf ofs = + let v3 = get_uint8 buf (ofs + 0) + and v2 = get_uint8 buf (ofs + 1) + and v1 = get_uint8 buf (ofs + 2) + and v0 = get_uint8 buf (ofs + 3) in + (v0 lor (v1 lsl 8) lor (v2 lsl 16) lor (v3 lsl 24)) +end + +(* +---------------------------------------------------------------+ + | Common writing functions | + +---------------------------------------------------------------+ *) + +module FD_map = Map.Make(struct type t = Unix.file_descr let compare = Pervasives.compare end) + +(* A pointer for serializing data *) +type wpointer = { + buf : string; + 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 = String.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.create fd_count Unix.stdin in + FD_map.iter (fun fd index -> Array.unsafe_set fds index fd) ptr.fds; + + (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 + | _ -> + raise_lwt (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: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: *) + lwt () = Lwt_io.flush oc in + let len = String.length buf in + (* Send the file descriptors and the message: *) + lwt n = Lwt_unix.send_msg writer.w_file_descr [Lwt_unix.io_vector buf 0 len] (Array.to_list fds) in + assert (n >= 0 && n <= len); + (* Write what is remaining: *) + Lwt_io.write_from_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 = String.create len in + String.unsafe_blit ptr.buf ptr.ofs s 0 len; + ptr.ofs <- ptr.ofs + len; + 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 = String.create 16 in + lwt () = Lwt_io.read_into_exactly ic buffer 0 16 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 = String.create length in + lwt () = Lwt_io.read_into_exactly ic buffer 0 length in + f { buf = buffer; ofs = 0; max = length; fds = [||] } None 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; + 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 -> + 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; + 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 = String.create 16 in + lwt () = Lwt_io.read_into_exactly ic buffer 0 16 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 = String.create length in + lwt () = Lwt_io.read_into_exactly ic buffer 0 length in + f { buf = buffer; ofs = 0; max = length; fds = [||] } (Some(consumed_fds, reader.r_pending_fds)) return) + end reader.r_channel + with exn -> + 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 + raise_lwt (map_exn protocol_error exn) + +(* +-----------------------------------------------------------------+ + | Size computation | + +-----------------------------------------------------------------+ *) + +let get_message_size buf ofs = + + let unsafe_get_uint map_ofs i = + let v0 = String.unsafe_get buf (map_ofs (i + 0)) + and v1 = String.unsafe_get buf (map_ofs (i + 1)) + and v2 = String.unsafe_get buf (map_ofs (i + 2)) + and v3 = String.unsafe_get buf (map_ofs (i + 3)) in + Char.code v0 lor (Char.code v1 lsl 8) lor (Char.code v2 lsl 16) lor (Char.code v3 lsl 24) + in + + if ofs < 0 || ofs + 16 >= String.length buf then + raise (Invalid_argument "OBus_wire.get_message_size") + + else + (* Byte-order *) + let map_ofs = match String.unsafe_get buf ofs with + | 'l' -> (fun i -> i) + | 'B' -> (fun i -> 3 - i) + | ch -> raise (Protocol_error(invalid_byte_order ch)) + in + let ver = Char.code (String.unsafe_get buf (ofs + 3)) in + if ver <> OBus_info.protocol_version then + raise (Protocol_error(invalid_protocol_version ver)); + + let body_length = unsafe_get_uint map_ofs (ofs + 8) + and fields_length = unsafe_get_uint map_ofs (ofs + 12) in + + let total_length = 16 + fields_length + pad8 fields_length + body_length in + + if fields_length < 0 || fields_length > max_array_size then + raise (Protocol_error(array_too_big fields_length)); + + if body_length < 0 || total_length > max_message_size then + raise (Protocol_error(message_too_big total_length)); + + total_length diff --git a/src/oBus_wire.mli b/src/oBus_wire.mli new file mode 100644 index 0000000..8bf35ef --- /dev/null +++ b/src/oBus_wire.mli @@ -0,0 +1,74 @@ +(* + * oBus_lowlevel.mli + * ----------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Message serialization/deserialization *) + +exception Data_error of string + (** Exception raised a message can not be sent. The parameter is an + error message. + + Possible reasons are: the message is too big or contains too big + arrays. *) + +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. *) + diff --git a/src/oBus_xml_parser.ml b/src/oBus_xml_parser.ml new file mode 100644 index 0000000..bff10d4 --- /dev/null +++ b/src/oBus_xml_parser.ml @@ -0,0 +1,191 @@ +(* + * oBus_xml_parser.ml + * ------------------ + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * 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 -> "<pcdata>" :: acc + | NT_any -> "<any>" :: acc + | NT_element name -> name :: acc + in + match flat [] typ with + | [] -> "<nothing>" + | [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 rec 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)) diff --git a/src/oBus_xml_parser.mli b/src/oBus_xml_parser.mli new file mode 100644 index 0000000..ba2559c --- /dev/null +++ b/src/oBus_xml_parser.mli @@ -0,0 +1,85 @@ +(* + * oBus_xml_parser.mli + * ------------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Monadic xml parsing *) + +(** This module implement 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] Create 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] wrap the result of a node parser with [f] *) + +val union : 'a node list -> 'a node + (** [union nodes] Node parser which parse 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. *) diff --git a/src/obus-idl.mllib b/src/obus-idl.mllib new file mode 100644 index 0000000..5c81355 --- /dev/null +++ b/src/obus-idl.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 7a15122818e64a42f70d0b1d2be5a1f7) +OBus_idl +# OASIS_STOP diff --git a/src/obus.mllib b/src/obus.mllib new file mode 100644 index 0000000..407a9ea --- /dev/null +++ b/src/obus.mllib @@ -0,0 +1,38 @@ +# OASIS_START +# DO NOT EDIT (digest: 0955bcdfea9dbffe77a0dbee21dc12a4) +OBus_address +OBus_auth +OBus_bus +OBus_connection +OBus_context +OBus_error +OBus_info +OBus_introspect_ext +OBus_introspect +OBus_match +OBus_member +OBus_message +OBus_method +OBus_name +OBus_object +OBus_path +OBus_peer +OBus_property +OBus_proxy +OBus_resolver +OBus_server +OBus_signal +OBus_string +OBus_transport +OBus_uuid +OBus_value +OBus_wire +OBus_interfaces +OBus_address_lexer +OBus_match_rule_lexer +OBus_protocol +OBus_type_ext_lexer +OBus_util +OBus_xml_parser +OBus_config +# OASIS_STOP diff --git a/syntax/obus-syntax.mllib b/syntax/obus-syntax.mllib new file mode 100644 index 0000000..e4ad197 --- /dev/null +++ b/syntax/obus-syntax.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 4493e441e11bfc27f55fefc758f3f8d1) +Pa_obus +# OASIS_STOP diff --git a/syntax/pa_obus.ml b/syntax/pa_obus.ml new file mode 100644 index 0000000..fa05398 --- /dev/null +++ b/syntax/pa_obus.ml @@ -0,0 +1,39 @@ +(* + * pa_obus.ml + * ---------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(* Syntactic sugars for defining D-Bus exceptions *) + +open Camlp4.PreCast + +let () = + Pa_type_conv.add_generator_with_arg ~is_exn:true "obus" Syntax.expr_eoi + (fun arg is_exn typ -> match typ, arg with + | _, None -> + Loc.raise (Ast.loc_of_ctyp typ) (Stream.Error "pa_obus: argument recquired for the 'obus' generator") + | Ast.TyOf(_loc, (Ast.TyId(_, (Ast.IdUid(_, caml_name)))), _), Some dbus_name -> + if Filename.basename (Loc.file_name _loc) = "oBus_error.ml" then + <:str_item< + let module M = + Register(struct + let name = $dbus_name$ + exception E = $uid:caml_name$ + end) + in () + >> + else + <:str_item< + let module M = + OBus_error.Register(struct + let name = $dbus_name$ + exception E = $uid:caml_name$ + end) + in () + >> + | _ -> + Loc.raise (Ast.loc_of_ctyp typ) (Stream.Error "pa_obus: ``Caml_name of string'' expected")) diff --git a/tests/gen_random.ml b/tests/gen_random.ml new file mode 100644 index 0000000..8cd4bcc --- /dev/null +++ b/tests/gen_random.ml @@ -0,0 +1,166 @@ +(* + * gen_random.ml + * ------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open 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 = String.create len in + for i = 0 to len - 1 do + str.[i] <- char_of_int (Char.code 'a' + Random.int 26) + done; + 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))); +} diff --git a/tests/gen_random.mli b/tests/gen_random.mli new file mode 100644 index 0000000..9dcfa86 --- /dev/null +++ b/tests/gen_random.mli @@ -0,0 +1,13 @@ +(* + * gen_random.mli + * -------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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 *) diff --git a/tests/main.ml b/tests/main.ml new file mode 100644 index 0000000..8f34e8c --- /dev/null +++ b/tests/main.ml @@ -0,0 +1,67 @@ +(* + * main.ml + * ------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open 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 -> + lwt () = title name in + begin + try_lwt + test () + with exn -> + lwt () = Lwt_io.printlf "test failed with: %s" (Printexc.to_string exn) in + lwt () = Lwt_io.printl (Printexc.get_backtrace ()) in + return false + end >>= function + | true -> + 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 -> + 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 + +lwt () = + 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; + ] + diff --git a/tests/progress.ml b/tests/progress.ml new file mode 100644 index 0000000..fa9b873 --- /dev/null +++ b/tests/progress.ml @@ -0,0 +1,40 @@ +(* + * progress.ml + * ----------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * 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 = + 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; + lwt () = Lwt_io.printf "\r%s: %d%%" p.prefix x in + Lwt_io.flush Lwt_io.stdout + end else + return () + +let close p = + lwt () = Lwt_io.printf "\r%s: 100%%\n" p.prefix in + Lwt_io.flush Lwt_io.stdout diff --git a/tests/progress.mli b/tests/progress.mli new file mode 100644 index 0000000..3630121 --- /dev/null +++ b/tests/progress.mli @@ -0,0 +1,21 @@ +(* + * progress.mli + * ------------ + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * 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] *) diff --git a/tests/syntax_extension.ml b/tests/syntax_extension.ml new file mode 100644 index 0000000..b17f9af --- /dev/null +++ b/tests/syntax_extension.ml @@ -0,0 +1,85 @@ +(* + * syntax_extension.ml + * ------------------- + * Copyright : (c) 2009-2010, Jeremie Dimino <jeremie@dimino.org> + * 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 ()) diff --git a/tests/test_auth.ml b/tests/test_auth.ml new file mode 100644 index 0000000..9fd920e --- /dev/null +++ b/tests/test_auth.ml @@ -0,0 +1,39 @@ +(* + * test_auth.ml + * ------------ + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * 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 + lwt () = Lwt.join [OBus_auth.Client.authenticate + ~stream:(OBus_auth.stream_of_channels (client_ic, client_oc)) () + >> return (); + OBus_auth.Server.authenticate + ~user_id + ~mechanisms:[mech] + ~guid + ~stream:(OBus_auth.stream_of_channels (server_ic, server_oc)) () + >> return ()] in + lwt () = Lwt_io.printlf "authentication %s works!" (OBus_auth.Server.mech_name mech) in + return true + with exn -> + 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 () = + lwt a = test_mech OBus_auth.Server.mech_external in + lwt b = test_mech OBus_auth.Server.mech_dbus_cookie_sha1 in + lwt c = test_mech OBus_auth.Server.mech_anonymous in + return (a && b && c) diff --git a/tests/test_communication.ml b/tests/test_communication.ml new file mode 100644 index 0000000..e47a61b --- /dev/null +++ b/tests/test_communication.ml @@ -0,0 +1,66 @@ +(* + * test_communication.ml + * --------------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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 -> + lwt () = OBus_connection.send_message con { + Gen_random.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 -> lwt () = Lwt_unix.sleep 0.1 in wait_for_name con + +let test () = + lwt () = Lwt_io.flush Lwt_io.stdout in + match Unix.fork () with + | 0 -> + lwt con = OBus_bus.session () in + lwt () = wait_for_name con in + lwt () = run_tests con test_count in + exit 0 + | pid -> + lwt () = printlf "sending and receiving %d messages through the message bus." test_count in + lwt bus = OBus_bus.session () in + lwt _ = OBus_bus.request_name bus name in + 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)); + lwt result = waiter in + lwt () = Progress.close progress in + lwt _ = Lwt_unix.waitpid [] pid in + return result diff --git a/tests/test_gc.ml b/tests/test_gc.ml new file mode 100644 index 0000000..8369d90 --- /dev/null +++ b/tests/test_gc.ml @@ -0,0 +1,51 @@ +(* + * test_gc.ml + * ---------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Lwt +open Lwt_io + +let ok = ref false +let finalise _ = ok := true + +let test () = + let success = true in + lwt bus = OBus_bus.session () in + + 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 (); + lwt () = printl (if !ok then "success" else "failure") in + let success = success && !ok in + + lwt () = print "testing garbage collection of a signal without a switch: " in + 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 (); + lwt () = printl (if !ok then "success" else "failure") in + let success = success && !ok in + + lwt () = print "testing garbage collection of a signal with a switch: " in + let switch = Lwt_switch.create () in + 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 (); + lwt () = printl (if !ok then "success" else "failure") in + let success = success && !ok in + + return success diff --git a/tests/test_serialization.ml b/tests/test_serialization.ml new file mode 100644 index 0000000..58fdd10 --- /dev/null +++ b/tests/test_serialization.ml @@ -0,0 +1,84 @@ +(* + * test_serialization.ml + * --------------------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * 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 = + lwt progress = Progress.make prefix test_count in + let rec aux acc n = function + | [] -> + lwt () = Progress.close progress in + return acc + | msg :: l -> + 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 = + lwt () = printf " success: %d\n" result.success in + lwt () = printf " failure: %d\n" result.failure in + lwt () = printf " writing error: %d\n" result.writing_error in + lwt () = printf " reading error: %d\n" result.reading_error in + return () + +let rec gen_messages progress acc = function + | 0 -> + lwt () = Progress.close progress in + return acc + | n -> + lwt () = Progress.incr progress in + gen_messages progress (Gen_random.message () :: acc) (n - 1) + +let test () = + lwt progress = Progress.make (Printf.sprintf "generating %d messages" test_count) test_count in + lwt msgs = gen_messages progress [] test_count in + lwt () = printl "try to serialize/deserialize all messages and compare the result to the original message." in + lwt result_le = run_tests " - in little endian" Lwt_io.Little_endian msgs in + lwt () = print_result result_le in + lwt result_be = run_tests " - in big endian" Lwt_io.Big_endian msgs in + 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) diff --git a/tests/test_validation.ml b/tests/test_validation.ml new file mode 100644 index 0000000..bb6126b --- /dev/null +++ b/tests/test_validation.ml @@ -0,0 +1,59 @@ +(* + * test_validation.ml + * ------------------ + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * 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 () = + lwt () = printl "Validation of all types of D-Bus strings" in + lwt () = + Lwt_list.iter_s + (function + | Some err -> + printlf "valid string recognized as bad: %s" (OBus_string.error_message err) + | None -> + return ()) + good + in + 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) diff --git a/tools/obus_dump.ml b/tools/obus_dump.ml new file mode 100644 index 0000000..9f0df64 --- /dev/null +++ b/tools/obus_dump.ml @@ -0,0 +1,63 @@ +(* + * obus_dump.ml + * ------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Lwt + +let usage_msg = Printf.sprintf "Usage: %s <options> 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 = + lwt message = OBus_transport.recv a in + Format.fprintf pp "-----@\n@[<hv 2>%s on %s bus:@\n%a@]@." action what_bus + OBus_message.print message; + lwt () = OBus_transport.send b message in + loop pp action what_bus a b + +let launch pp what_bus laddresses = + lwt addresses = Lazy.force laddresses in + lwt server = + OBus_server.make_lowlevel ~capabilities:[`Unix_fd] + (fun server transport -> + ignore begin + lwt (_, bus) = OBus_transport.of_addresses ~capabilities:[`Unix_fd] addresses in + 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 what_bus)) (OBus_address.to_string (OBus_server.addresses server)); + 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, "<file> 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 + lwt () = launch pp "session" OBus_address.session <&> launch pp "system" OBus_address.system in + lwt _ = Lwt_unix.waitpid [] (Unix.create_process cmd (Array.of_list cmd_args) Unix.stdin Unix.stdout Unix.stderr) in + close_out oc; + return () + end diff --git a/tools/obus_gen_client.ml b/tools/obus_gen_client.ml new file mode 100644 index 0000000..5283a9c --- /dev/null +++ b/tools/obus_gen_client.ml @@ -0,0 +1,311 @@ +(* + * obus_gen_client.ml + * ------------------ + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Printf +open OBus_introspect_ext +open OBus_value + +let prog_name = Filename.basename Sys.argv.(0) + +let make_names args = + let _, l = + List.fold_left + (fun (n, l) (name, typ) -> + match name with + | None -> (n + 1, (false, "x" ^ string_of_int n) :: l) + | Some "type" -> (n, (true, "typ") :: l) + | Some name -> (n, (true, name) :: l)) + (1, []) + args + in + List.rev l + +(* Remove deprecated members *) +let remove_deprecated members = + List.filter + (function + | Method(_, _, _, annotations) + | Signal(_, _, annotations) + | Property(_, _, _, annotations) -> + try + List.assoc OBus_introspect.deprecated annotations <> "true" + with Not_found -> + true) + members + +(* +-----------------------------------------------------------------+ + | Implementation generation | + +-----------------------------------------------------------------+ *) + +let print_names oc = function + | [] -> + output_string oc "()"; + | [(_, name)] -> + output_string oc name + | (_, name) :: names -> + output_char oc '('; + output_string oc name; + List.iter (fun (_, name) -> fprintf oc ", %s" name) names; + output_char oc ')' + +let rec contains_path = function + | Term("object_path", []) -> true + | Term(_, l) -> List.exists contains_path l + | Tuple l -> List.exists contains_path l + +let make_convertors make_convertor names args = + List.map2 + (fun (_, name) (_, typ) -> match make_convertor true typ with + | Some f -> Some(sprintf "let %s = %s %s in\n" name f name) + | None -> None) + names args + +let print_impl oc name members symbols annotations = + let module_name = String.capitalize (Utils.file_name_of_interface_name name) in + fprintf oc "\n\ + module %s =\n\ + struct\n\ + \ open %s\n\n" + module_name module_name; + List.iter (fun (name, sym) -> fprintf oc " type %s = type_%s\n" name name) symbols; + List.iter + (function + | Method(name, i_args, o_args, annotations) -> + let i_names = make_names i_args and o_names = make_names o_args in + let i_convertors = make_convertors Utils.convertor_send i_names i_args + and o_convertors = make_convertors Utils.convertor_recv o_names o_args in + fprintf oc "\n let %s proxy" (OBus_name.ocaml_lid name); + List.iter + (function + | (false, name) -> fprintf oc " %s" name + | (true, name) -> fprintf oc " ~%s" name) + i_names; + output_string oc " =\n"; + List.iter + (function + | Some line -> fprintf oc " %s" line + | None -> ()) + i_convertors; + let need_context = List.exists (fun (_, typ) -> contains_path typ) o_args in + if List.for_all (fun conv -> conv = None) o_convertors then begin + if try List.assoc OBus_introspect.no_reply annotations = "true" with Not_found -> false then + fprintf oc " OBus_method.call_no_reply m_%s proxy " name + else + fprintf oc " OBus_method.call m_%s proxy " name; + print_names oc i_names; + output_char oc '\n' + end else begin + output_string oc " lwt "; + if need_context then output_string oc "(context, "; + print_names oc o_names; + if need_context then + fprintf oc ") = OBus_method.call_with_context m_%s proxy " name + else + fprintf oc " = OBus_method.call m_%s proxy " name; + print_names oc i_names; + output_string oc " in\n"; + List.iter + (function + | Some line -> fprintf oc " %s" line + | None -> ()) + o_convertors; + output_string oc " return "; + print_names oc o_names; + output_char oc '\n' + end + | Signal(name, args, annotations) -> + let names = make_names args in + let convertors = make_convertors Utils.convertor_recv names args in + fprintf oc "\n let %s proxy =\n" (OBus_name.ocaml_lid name); + if List.for_all (fun x -> x = None) convertors then + fprintf oc " OBus_signal.make s_%s proxy\n" name + else begin + if List.exists (fun (_, typ) -> contains_path typ) args then + output_string oc " OBus_signal.map_with_context\n\ + \ (fun context " + else + output_string oc " OBus_signal.map\n\ + \ (fun "; + print_names oc names; + output_string oc " ->\n"; + List.iter + (function + | Some line -> fprintf oc " %s" line + | None -> ()) + convertors; + output_string oc " "; + print_names oc names; + output_string oc ")\n"; + fprintf oc " (OBus_signal.connect s_%s proxy)\n" name + end + | Property(name, typ, access, annotations) -> + fprintf oc "\n let %s proxy =\n" (OBus_name.ocaml_lid name); + match Utils.convertor_recv true typ, Utils.convertor_send true typ with + | Some f_recv, Some f_send -> begin + let need_context = contains_path typ in + fprintf oc " OBus_property.map_%s%s\n" + (match access with + | Read -> "r" + | Write -> "w" + | Read_write -> "rw") + (if need_context then "_with_context" else ""); + let ctx = if need_context then " context" else "" in + if access = Read || access = Read_write then + fprintf oc " (fun%s x -> %s x)\n" ctx f_recv; + if access = Write || access = Read_write then + fprintf oc " (fun x -> %s x)\n" f_send; + fprintf oc " (OBus_property.make p_%s proxy)\n" name + end + | None, None -> + fprintf oc " OBus_property.make p_%s proxy\n" name + | _ -> + assert false) + members; + output_string oc "end\n" + +(* +-----------------------------------------------------------------+ + | Interface generation | + +-----------------------------------------------------------------+ *) + +let rec term_intf = function + | Term("byte", []) -> term "char" [] + | Term("boolean", []) -> term "bool" [] + | Term("int16", []) -> term "int" [] + | Term("int32", []) -> term "int" [] + | Term("int64", []) -> term "int64" [] + | Term("uint16", []) -> term "int" [] + | Term("uint32", []) -> term "int" [] + | Term("uint64", []) -> term "int64" [] + | Term("double", []) -> term "float" [] + | Term("string", []) -> term "string" [] + | Term("signature", []) -> term "OBus_value.signature" [] + | Term("object_path", []) -> term "OBus_proxy.t" [] + | Term("unix_fd", []) -> term "Unix.file_descr" [] + | Term("array", [Term("byte", [])]) -> term "string" [] + | Term("array", [t]) -> term "list" [term_intf t] + | Term("dict", [tk; tv]) -> term "list" [tuple[term_intf tk; term_intf tv]] + | Term("variant", []) -> term "OBus_value.V.single" [] + | Term(name, tl) -> term name (List.map term_intf tl) + | Tuple tl -> tuple (List.map term_intf tl) + +let print_symbol oc name sym = + let typ, values = + match sym with + | Sym_enum(typ, values) -> typ, values + | Sym_flag(typ, values) -> typ, values + in + fprintf oc " type %s =\n" name; + match values with + | [] -> + () + | (key, name) :: rest -> + fprintf oc " [ `%s" (String.capitalize name); + List.iter (fun (key, name) -> fprintf oc "\n | `%s" (String.capitalize name)) rest; + fprintf oc " ]\n" + +let print_intf oc name members symbols annotations = + fprintf oc "\nmodule %s : sig\n" (String.capitalize (Utils.file_name_of_interface_name name)); + List.iter (fun (name, sym) -> print_symbol oc name sym) symbols; + List.iter + (function + | Method(name, i_args, o_args, annotations) -> + fprintf oc " val %s : OBus_proxy.t -> " (OBus_name.ocaml_lid name); + List.iter + (function + | (None, typ) -> + fprintf oc "%a -> " (Term.print_intf true) (term_intf typ) + | (Some name, typ) -> + fprintf oc "%s : %a -> " name (Term.print_intf true) (term_intf typ)) + i_args; + Term.print_intf true oc + (term "Lwt.t" + [tuple + (List.map (fun (_, typ) -> term_intf typ) o_args)]); + output_char oc '\n' + | Signal(name, args, annotations) -> + fprintf oc " val %s : OBus_proxy.t -> %a\n" + (OBus_name.ocaml_lid name) + (Term.print_intf true) + (term "OBus_signal.t" + [tuple (List.map (fun (_, typ) -> term_intf typ) args)]) + | Property(name, typ, access, annotations) -> + fprintf oc " val %s : OBus_proxy.t -> %a\n" + (OBus_name.ocaml_lid name) + (Term.print_intf true) + (term "OBus_property.t" + [term_intf typ; + term + (match access with + | Read -> "[ `readable ]" + | Write -> "[ `writable ]" + | Read_write -> "[ `readable | `writable ]") + []])) + members; + output_string oc "end\n" + +(* +-----------------------------------------------------------------+ + | Entry-point | + +-----------------------------------------------------------------+ *) + +let usage_message = + Printf.sprintf "Usage: %s <options> <file>\n\ + Generate OCaml proxy code for D-Bus interfaces.\n\ + options are:" + prog_name + +let keep_common = ref false +let prefix = ref None + +let args = [ + "-keep-common", Arg.Set keep_common, "do not ignore common interfaces"; + "-o", Arg.String(fun str -> prefix := Some str), "<prefix> output file prefix"; +] + +let () = + let sources = ref [] in + Arg.parse args (fun s -> sources := s :: !sources) usage_message; + + let source = + match !sources with + | [s] -> s + | _ -> Arg.usage args usage_message; exit 1 + in + + let prefix, intf_module = + match !prefix with + | Some str -> + (str, String.capitalize (Filename.basename str) ^ "_interfaces") + | None -> + let name = try Filename.chop_extension source with Invalid_argument _ -> source in + (name ^ "_client", String.capitalize name ^ "_interfaces") + in + + let interfaces = Utils.parse_file source in + + let oc_impl = open_out (prefix ^ ".ml") and oc_intf = open_out (prefix ^ ".mli") in + + output_string oc_impl "open Lwt\n"; + Printf.fprintf oc_impl "open %s\n" intf_module; + + Utils.IFSet.iter + (fun (name, members, symbols, annotations) -> + if !keep_common || + (match OBus_name.split name with + | "org" :: "freedesktop" :: "DBus" :: _ -> false + | _ -> true) then begin + print_impl oc_impl name (remove_deprecated members) symbols annotations; + print_intf oc_intf name (remove_deprecated members) symbols annotations + end) + interfaces; + + close_out oc_impl; + close_out oc_intf; + + printf "file \"%s.ml\" written\n" prefix; + printf "file \"%s.mli\" written\n" prefix diff --git a/tools/obus_gen_interface.ml b/tools/obus_gen_interface.ml new file mode 100644 index 0000000..137f486 --- /dev/null +++ b/tools/obus_gen_interface.ml @@ -0,0 +1,484 @@ +(* + * obus_gen_interface.ml + * --------------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Printf +open OBus_value +open OBus_introspect_ext +open OBus_introspect + +let mode : [ `Both | `Client | `Server ] ref = ref `Both +let prog_name = Filename.basename Sys.argv.(0) + +(* +-----------------------------------------------------------------+ + | Common printers | + +-----------------------------------------------------------------+ *) + +let term_intf typ = + Term.intf (OBus_introspect_ext.term_of_single typ) + +let term_impl typ = + Term.impl (OBus_introspect_ext.term_of_single typ) + +let tuple_intf types = + Term.intf (OBus_introspect_ext.term_of_sequence types) + +let tuple_impl types = + Term.impl (OBus_introspect_ext.term_of_sequence types) + +let print_record oc members = + output_string oc " type 'a members = {\n"; + List.iter + (function + | Method(name, i_args, o_args, annotations) -> + fprintf oc " m_%s : 'a OBus_object.t -> %a -> %a;\n" + name + (Term.print_intf true) + (tuple (List.map (fun (name, typ) -> term_intf typ) i_args)) + (Term.print_intf true) + (term "Lwt.t" [(tuple (List.map (fun (name, typ) -> term_intf typ) o_args))]) + | Signal(name, args, annotations) -> + () + | Property(name, typ, Read, annotations) -> + fprintf oc " p_%s : 'a OBus_object.t -> %a;\n" + name + (Term.print_intf true) + (term "React.signal" [term_intf typ]) + | Property(name, typ, Write, annotations) -> + fprintf oc " p_%s : 'a OBus_object.t -> %a -> unit Lwt.t;\n" + name + (Term.print_intf true) + (term_intf typ) + | Property(name, typ, Read_write, annotations) -> + fprintf oc " p_%s : ('a OBus_object.t -> %a) * ('a OBus_object.t -> %a -> unit Lwt.t);\n" + name + (Term.print_intf true) + (term "React.signal" [term_intf typ]) + (Term.print_intf true) + (term_intf typ)) + members; + output_string oc " }\n" + +let print_symbol oc name sym = + let typ, values = + match sym with + | Sym_enum(typ, values) -> typ, values + | Sym_flag(typ, values) -> typ, values + in + fprintf oc " type type_%s =\n" name; + match values with + | [] -> + () + | (key, name) :: rest -> + fprintf oc " [ `%s" (String.capitalize name); + List.iter (fun (key, name) -> fprintf oc "\n | `%s" (String.capitalize name)) rest; + fprintf oc " ]\n" + +(* +-----------------------------------------------------------------+ + | Implementation generation | + +-----------------------------------------------------------------+ *) + +let string_of_integer_enum = function + | V.Byte x -> + sprintf "%C" x + | V.Int16 x | V.Uint16 x -> + sprintf "%d" x + | V.Int32 x | V.Uint32 x -> + sprintf "%ldl" x + | V.Int64 x | V.Uint64 x -> + sprintf "%LdL" x + | _ -> + assert false + +let string_of_integer_flag = function + | V.Byte x -> + sprintf "%d" (Char.code x) + | V.Int16 x | V.Uint16 x -> + sprintf "%d" x + | V.Int32 x | V.Uint32 x -> + sprintf "%ldl" x + | V.Int64 x | V.Uint64 x -> + sprintf "%LdL" x + | _ -> + assert false + +let print_args oc args = + fprintf oc "(arg%d" (List.length args); + List.iter + (function + | (None, typ) -> + fprintf oc "\n (None, %a)" + (Term.print_impl true) (term_impl typ) + | (Some name, typ) -> + fprintf oc "\n (Some %S, %a)" + name (Term.print_impl true) (term_impl typ)) + args; + output_char oc ')' + +let print_impl oc name members symbols annotations = + fprintf oc "module %s =\n\ + struct\n\ + \ let interface = %S\n" + (String.capitalize (Utils.file_name_of_interface_name name)) + name; + + (***** Symbols *****) + + List.iter + (fun (name, sym) -> + print_symbol oc name sym; + match sym with + | Sym_enum(typ, values) -> + fprintf oc " let cast_%s = function\n" name; + List.iter + (fun (key, name) -> + fprintf oc " | `%s -> %s\n" + (String.capitalize name) + (string_of_integer_enum key)) + values; + fprintf oc " let make_%s = function\n" name; + List.iter + (fun (key, name) -> + fprintf oc " | %s -> `%s\n" + (string_of_integer_enum key) + (String.capitalize name)) + values; + fprintf oc " | n -> Printf.ksprintf failwith \"invalid value for \\\"%s\\\": %s\" n\n" + name + (match typ with + | T.Byte -> "%c" + | T.Int16 | T.Uint16 -> "%d" + | T.Int32 | T.Uint32 -> "%ld" + | T.Int64 | T.Uint64 -> "%Ld" + | _ -> assert false) + | Sym_flag(typ, values) -> + fprintf oc " let cast_%s l =\n\ + \ let rec loop acc = function\n\ + \ | [] -> %sacc\n" + name + (if typ = T.Byte then "char_of_int " else ""); + List.iter + (fun (key, name) -> + fprintf oc " | `%s :: rest -> loop (%s) rest\n" + (String.capitalize name) + (match key with + | V.Byte x -> + sprintf "acc lor %d" (Char.code x) + | V.Int16 x | V.Uint16 x -> + sprintf "acc lor %d" x + | V.Int32 x | V.Uint32 x -> + sprintf "Int32.logor acc %ldl" x + | V.Int64 x | V.Uint64 x -> + sprintf "Int64.logor acc %LdL" x + | _ -> + assert false)) + values; + fprintf oc " in\n\ + \ loop %s l\n" + (match typ with + | T.Byte | T.Int16 | T.Uint16 -> "0" + | T.Int32 | T.Uint32 -> "0l" + | T.Int64 | T.Uint64 -> "0L" + | _ -> assert false); + fprintf oc " let make_%s n =\n\ + \ let l = [] in\n" + name; + if typ = T.Byte then + fprintf oc " let n = int_of_char n in\n"; + List.iter + (fun (key, name) -> + fprintf oc " let l = if %s then `%s :: l else l in\n" + (match key with + | V.Byte x -> + sprintf "n land %d <> 0" (Char.code x) + | V.Int16 x | V.Uint16 x -> + sprintf "n land %d <> 0" x + | V.Int32 x | V.Uint32 x -> + sprintf "Int32.logand n %ldl <> 0l" x + | V.Int64 x | V.Uint64 x -> + sprintf "Int64.logand n %LdL <> 0L" x + | _ -> assert false) + (String.capitalize name)) + values; + fprintf oc " l\n") + symbols; + + (***** Member description *****) + + List.iter + (function + | Method(name, i_args, o_args, annotations) -> + fprintf oc " let m_%s = {\n\ + \ Method.interface = interface;\n\ + \ Method.member = %S;\n\ + \ Method.i_args = %a;\n\ + \ Method.o_args = %a;\n\ + \ Method.annotations = [%s];\n\ + \ }\n" + name name print_args i_args print_args o_args + (String.concat ";\n " + (List.map + (fun (name, value) -> sprintf "(%s, %S)" (Utils.make_annotation name) value) + annotations)) + | Signal(name, args, annotations) -> + fprintf oc " let s_%s = {\n\ + \ Signal.interface = interface;\n\ + \ Signal.member = %S;\n\ + \ Signal.args = %a;\n\ + \ Signal.annotations = [%s];\n\ + \ }\n" + name name print_args args + (String.concat ";\n " + (List.map + (fun (name, value) -> sprintf "(%s, %S)" (Utils.make_annotation name) value) + annotations)) + | Property(name, typ, access, annotations) -> + fprintf oc " let p_%s = {\n\ + \ Property.interface = interface;\n\ + \ Property.member = %S;\n\ + \ Property.typ = %a;\n\ + \ Property.access = Property.%s;\n\ + \ Property.annotations = [%s];\n\ + \ }\n" + name name (Term.print_impl true) (term_impl typ) + (match access with + | Read -> "readable" + | Write -> "writable" + | Read_write -> "readable_writable") + (String.concat ";\n " + (List.map + (fun (name, value) -> sprintf "(%s, %S)" (Utils.make_annotation name) value) + annotations))) + members; + + (***** Interface description *****) + + if !mode <> `Client then begin + if List.exists (function Method _ | Property _ -> true | _ -> false) members then + print_record oc members; + output_string oc " let make members =\n"; + fprintf oc " OBus_object.make_interface_unsafe interface\n\ + \ [\n"; + List.iter + (fun (name, value) -> + fprintf oc " (%s, %S);\n" (Utils.make_annotation name) value) + annotations; + fprintf oc " ]\n\ + \ [|\n"; + List.iter + (function + | Method(name, i_args, o_args, annotations) -> + fprintf oc " method_info m_%s members.m_%s;\n" name name + | _ -> + ()) + members; + output_string oc " |]\n [|\n"; + List.iter + (function + | Signal(name, args, annotations) -> + fprintf oc " signal_info s_%s;\n" name + | _ -> + ()) + members; + output_string oc " |]\n [|\n"; + List.iter + (function + | Property(name, typ, Read, annotations) -> + fprintf oc " property_r_info p_%s members.p_%s;\n" name name + | Property(name, typ, Write, annotations) -> + fprintf oc " property_w_info p_%s members.p_%s;\n" name name + | Property(name, typ, Read_write, annotations) -> + fprintf oc " property_rw_info p_%s (fst members.p_%s) (snd members.p_%s);\n" name name name + | _ -> + ()) + members; + output_string oc " |]\n"; + end; + output_string oc "end\n" + +(* +-----------------------------------------------------------------+ + | Interface generation | + +-----------------------------------------------------------------+ *) + +let string_of_key_type = function + | T.Byte -> "char" + | T.Int16 | T.Uint16 -> "int" + | T.Int32 | T.Uint32 -> "int32" + | T.Int64 | T.Uint64 -> "int64" + | _ -> assert false + +let print_intf oc name members symbols annotations = + fprintf oc "module %s : sig\n" (String.capitalize (Utils.file_name_of_interface_name name)); + fprintf oc " val interface : OBus_name.interface\n"; + + (***** Symbols *****) + + List.iter + (fun (name, sym) -> + print_symbol oc name sym; + match sym with + | Sym_enum(typ, values) -> + fprintf oc " val make_%s : %s -> type_%s\n" + name + (string_of_key_type typ) + name; + fprintf oc " val cast_%s : type_%s -> %s\n" + name + name + (string_of_key_type typ) + | Sym_flag(typ, values) -> + fprintf oc " val make_%s : %s -> type_%s list\n" + name + (string_of_key_type typ) + name; + fprintf oc " val cast_%s : type_%s list -> %s\n" + name + name + (string_of_key_type typ)) + symbols; + + (***** Member description *****) + + List.iter + (function + | Method(name, i_args, o_args, annotations) -> + fprintf oc " val m_%s : %a\n" + name + (Term.print_intf true) + (term "Method.t" + [tuple_intf (List.map snd i_args); + tuple_intf (List.map snd o_args)]) + | Signal(name, args, annotations) -> + fprintf oc " val s_%s : %a\n" + name + (Term.print_intf true) + (term "Signal.t" + [tuple_intf (List.map snd args)]) + | Property(name, typ, access, annotations) -> + fprintf oc " val p_%s : %a\n" + name + (Term.print_intf true) + (term "Property.t" + [term_intf typ; + term + (match access with + | Read -> "[ `readable ]" + | Write -> "[ `writable ]" + | Read_write -> "[ `readable | `writable ]") + []])) + members; + + (***** Interface description *****) + + if !mode <> `Client then begin + if List.exists (function Method _ | Property _ -> true | _ -> false) members then begin + print_record oc members; + output_string oc " val make : 'a members -> 'a OBus_object.interface\n" + end else + output_string oc " val make : unit -> 'a OBus_object.interface\n"; + end; + output_string oc "end\n" + +(* +-----------------------------------------------------------------+ + | Sorting | + +-----------------------------------------------------------------+ *) + +let compare_members ma mb = + match ma, mb with + | Method(name_a, i_args_a, _, _), Method(name_b, i_args_b, _, _) -> + String.compare name_a name_b + | Signal(name_a, _, _), Signal(name_b, _, _) -> + String.compare name_a name_b + | Property(name_a, _, _, _), Property(name_b, _, _, _) -> + String.compare name_a name_b + | Method _, _ -> -1 + | _, Method _ -> 1 + | Signal _, _ -> -1 + | _, Signal _ -> 1 + +let sort_members members = List.sort compare_members members + +(* +-----------------------------------------------------------------+ + | Entry-point | + +-----------------------------------------------------------------+ *) + +let usage_message = + Printf.sprintf "Usage: %s <options> <file>\n\ + Generate OCaml modules for D-Bus interfaces.\n\ + options are:" prog_name + +let keep_common = ref false +let prefix = ref None + +let args = [ + "-keep-common", Arg.Set keep_common, "do not ignore common interfaces"; + "-o", Arg.String(fun str -> prefix := Some str), "<prefix> output file prefix"; + "-mode", + Arg.Symbol(["both"; "client"; "server"], + (function + | "both" -> mode := `Both + | "client" -> mode := `Client + | "server" -> mode := `Server + | _ -> assert false)), + " code generation mode, defaults to \"both\"" +] + +let () = + let sources = ref [] in + Arg.parse args (fun s -> sources := s :: !sources) usage_message; + + let source = + match !sources with + | [s] -> s + | _ -> Arg.usage args usage_message; exit 1 + in + + let interfaces = Utils.parse_file source in + + let prefix = + match !prefix with + | Some str -> str + | None -> (try Filename.chop_extension source with Invalid_argument _ -> source) ^ "_interfaces" + in + + let oc_impl = open_out (prefix ^ ".ml") and oc_intf = open_out (prefix ^ ".mli") in + + fprintf oc_impl + "(* File auto-generated by %s, DO NOT EDIT. *)\n\ + open OBus_value\n\ + open OBus_value.C\n\ + open OBus_member\n" + prog_name; + + if !mode <> `Client then + output_string oc_impl "open OBus_object\n"; + + fprintf oc_intf + "(* File auto-generated by %s, DO NOT EDIT. *)\n\ + open OBus_member\n" + prog_name; + + Utils.IFSet.iter + (fun ((name, members, symbols, annotations) as interface) -> + if !keep_common || + (match OBus_name.split name with + | "org" :: "freedesktop" :: "DBus" :: _ -> false + | _ -> true) then begin + (* We keeps only symbols from the extended interface *) + let name, members, annotations = OBus_introspect_ext.encode interface in + let members = sort_members members and annotations = List.sort compare annotations in + print_impl oc_impl name members symbols annotations; + print_intf oc_intf name members symbols annotations + end) + interfaces; + + close_out oc_impl; + close_out oc_intf; + + printf "file \"%s.ml\" written\n" prefix; + printf "file \"%s.mli\" written\n" prefix diff --git a/tools/obus_gen_server.ml b/tools/obus_gen_server.ml new file mode 100644 index 0000000..b6fbc5a --- /dev/null +++ b/tools/obus_gen_server.ml @@ -0,0 +1,204 @@ +(* + * obus_gen_server.ml + * ------------------ + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Printf +open OBus_introspect_ext +open OBus_value + +let prog_name = Filename.basename Sys.argv.(0) + +let make_names args = + let _, l = + List.fold_left + (fun (n, l) (name, typ) -> + match name with + | None -> (n + 1, (false, "x" ^ string_of_int n) :: l) + | Some "type" -> (n, (true, "typ") :: l) + | Some name -> (n, (true, name) :: l)) + (1, []) + args + in + List.rev l + +(* +-----------------------------------------------------------------+ + | Implementation generation | + +-----------------------------------------------------------------+ *) + +let print_names oc = function + | [] -> + output_string oc "()"; + | [(_, name)] -> + output_string oc name + | (_, name) :: names -> + output_char oc '('; + output_string oc name; + List.iter (fun (_, name) -> fprintf oc ", %s" name) names; + output_char oc ')' + +let rec contains_path = function + | Term("object_path", []) -> true + | Term(_, l) -> List.exists contains_path l + | Tuple l -> List.exists contains_path l + +let make_convertors make_convertor names args = + List.map2 + (fun (_, name) (_, typ) -> match make_convertor true typ with + | Some f -> Some(name, f) + | None -> None) + names args + +let print_impl oc name members symbols annotations = + let module_name = String.capitalize (Utils.file_name_of_interface_name name) in + fprintf oc "\n\ + module %s =\n\ + struct\n\ + \ open %s\n\n" + module_name module_name; + List.iter (fun (name, sym) -> fprintf oc " type %s = type_%s\n" name name) symbols; + List.iter + (function + | Signal(name, args, annotations) -> + let names = make_names args in + let convertors = make_convertors Utils.convertor_send names args in + fprintf oc "\n let %s obj" (OBus_name.ocaml_lid name); + List.iter + (function + | (false, name) -> fprintf oc " %s" name + | (true, name) -> fprintf oc " ~%s" name) + names; + output_string oc " =\n"; + List.iter + (function + | Some(name, f) -> fprintf oc " let %s = %s %s in\n" name f name + | None -> ()) + convertors; + fprintf oc " OBus_signal.emit s_%s obj" name; + List.iter + (fun (_, name) -> fprintf oc " %s" name) + names; + output_char oc '\n' + | _ -> + ()) + members; + List.iter + (function + | Method(name, i_args, o_args, annotations) -> + fprintf oc "\n let %s obj" (OBus_name.ocaml_lid name); + List.iter + (function + | (false, name) -> fprintf oc " %s" name + | (true, name) -> fprintf oc " ~%s" name) + (make_names i_args); + output_string oc " =\n raise_lwt (Failure \"not implemented\")\n" + | _ -> + ()) + members; + fprintf oc "\n let interface =\n\ + \ %s.make {\n" module_name; + List.iter + (function + | Method(name, i_args, o_args, annotations) -> + let i_names = make_names i_args and o_names = make_names o_args in + let i_convertors = make_convertors Utils.convertor_recv i_names i_args + and o_convertors = make_convertors Utils.convertor_send o_names o_args in + fprintf oc " m_%s = (\n\ + \ fun obj %a ->\n" name print_names i_names; + List.iter + (function + | Some(name, f) -> fprintf oc " let %s = %s %s in\n" name f name + | None -> ()) + i_convertors; + fprintf oc " lwt %a = %s (OBus_object.get obj)" print_names o_names (OBus_name.ocaml_lid name); + List.iter (fun (_, name) -> fprintf oc " %s" name) i_names; + output_string oc " in\n"; + List.iter + (function + | Some(name, f) -> fprintf oc " let %s = %s %s in\n" name f name + | None -> ()) + o_convertors; + fprintf oc " return %a\n\ + \ );\n" + print_names o_names + | Property(name, typ, access, annotations) -> + fprintf oc " p_%s = " name; + if access = Read_write then output_char oc '('; + if access = Read || access = Read_write then + output_string oc "(fun obj -> failwith \"not implemented\")"; + if access = Read_write then begin + output_string oc ",\n"; + output_string oc (String.make (11 + String.length name) ' ') + end; + if access = Write || access = Read_write then + output_string oc "(fun obj x -> failwith \"not implemented\")"; + if access = Read_write then + output_char oc ')'; + output_string oc ";\n" + | _ -> + ()) + members; + output_string oc " }\n"; + output_string oc "end\n" + +(* +-----------------------------------------------------------------+ + | Entry-point | + +-----------------------------------------------------------------+ *) + +let usage_message = + Printf.sprintf "Usage: %s <options> <file>\n\ + Generate OCaml server code for D-Bus interfaces.\n\ + options are:" + prog_name + +let keep_common = ref false +let prefix = ref None + +let args = [ + "-keep-common", Arg.Set keep_common, "do not ignore common interfaces"; + "-o", Arg.String(fun str -> prefix := Some str), "<prefix> output file prefix"; +] + +let () = + let sources = ref [] in + Arg.parse args (fun s -> sources := s :: !sources) usage_message; + + let source = + match !sources with + | [s] -> s + | _ -> Arg.usage args usage_message; exit 1 + in + + let prefix, intf_module = + match !prefix with + | Some str -> + (str, String.capitalize (Filename.basename str) ^ "_interfaces") + | None -> + let name = try Filename.chop_extension source with Invalid_argument _ -> source in + (name ^ "_server", String.capitalize name ^ "_interfaces") + in + + let interfaces = Utils.parse_file source in + + let oc = open_out (prefix ^ ".ml") in + + output_string oc "open Lwt\n"; + Printf.fprintf oc "open %s\n" intf_module; + + Utils.IFSet.iter + (fun (name, members, symbols, annotations) -> + if !keep_common || + (match OBus_name.split name with + | "org" :: "freedesktop" :: "DBus" :: _ -> false + | _ -> true) then begin + print_impl oc name members symbols annotations + end) + interfaces; + + close_out oc; + + printf "file \"%s.ml\" written\n" prefix diff --git a/tools/obus_idl2xml.ml b/tools/obus_idl2xml.ml new file mode 100644 index 0000000..4383eb5 --- /dev/null +++ b/tools/obus_idl2xml.ml @@ -0,0 +1,47 @@ +(* + * obus_idl2xml.ml + * --------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let usage_message = + Printf.sprintf "Usage: %s <options> <file>\n\ + Generate a D-Bus introspection file from an obus IDL file.\n\ + options are:" + (Filename.basename Sys.argv.(0)) + +let output = ref None + +let args = [ + "-o", Arg.String(fun str -> output := Some str), "<file-name> output file name"; +] + +let () = + let sources = ref [] in + Arg.parse args (fun s -> sources := s :: !sources) usage_message; + + let source = + match !sources with + | [s] -> s + | _ -> Arg.usage args usage_message; exit 1 + in + let destination = + match !output with + | None -> + (try + Filename.chop_extension source + with Invalid_argument _ -> + source) ^ ".xml" + | Some name -> + name + in + + let oc = open_out destination in + OBus_introspect.output + (Xmlm.make_output ~nl:true ~indent:(Some 2) (`Channel oc)) + ((List.map OBus_introspect_ext.encode (Utils.IFSet.elements (Utils.parse_idl source)), [])); + close_out oc; + Printf.printf "file \"%s\" written\n" destination diff --git a/tools/obus_introspect.ml b/tools/obus_introspect.ml new file mode 100644 index 0000000..4526e68 --- /dev/null +++ b/tools/obus_introspect.ml @@ -0,0 +1,95 @@ +(* + * obus_introspect.ml + * ------------------ + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let 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 <option> <destination> <path> +Introspect a D-Bus service (print only interfaces). +options are:" (Filename.basename (Sys.argv.(0))) + +open Lwt + +module Interface_map = Map.Make(struct type t = string let compare = compare end) + +let rec get proxy = + lwt interfaces, children = OBus_proxy.introspect proxy in + let map = List.fold_left (fun map (name, content, annots) -> + Interface_map.add name (content, annots) map) + Interface_map.empty interfaces in + let nodes = [(proxy, List.map (fun (name, _, _) -> name) interfaces)] in + match !recursive with + | true -> + List.fold_left + (fun t1 t2 -> + lwt nodes1, map1 = t1 and nodes2, map2 = t2 in + return (nodes1 @ nodes2, Interface_map.fold Interface_map.add map1 map2)) + (return (nodes, map)) + (List.map + (fun child -> + get { proxy with OBus_proxy.path = OBus_proxy.path proxy @ [child] }) + children) + | false -> + return (nodes, map) + +let main service path = + lwt bus = match !session, !system, !address with + | true, true, _ + | true, _, Some _ + | _, true, Some _ -> + prerr_endline "must specify at most one of -session, -system\n\n"; + Arg.usage args usage_msg; + exit 1 + | false, false, None + | true, false, None -> OBus_bus.session () + | false, true, None -> OBus_bus.system () + | false, false, Some addr -> OBus_bus.of_addresses (OBus_address.of_string addr) + in + lwt nodes, map = get (OBus_proxy.make (OBus_peer.make bus service) path) in + begin + match !obj_mode with + | false -> + OBus_introspect.output (Xmlm.make_output ~nl:true ~indent:(Some 2) (`Channel Pervasives.stdout)) + (Interface_map.fold (fun name (content, annots) acc -> (name, content, annots) :: acc) map [], []) + | true -> + List.iter begin fun (proxy, interfaces) -> + print_endline (OBus_path.to_string (OBus_proxy.path proxy)); + List.iter (Printf.printf " + %s\n") interfaces; + print_newline (); + end nodes + end; + return () + +let () = + Arg.parse args + (fun arg -> anons := arg :: !anons) + usage_msg; + + let service, path = match !anons with + | [path; service] -> (service, OBus_path.of_string path) + | _ -> Arg.usage args usage_msg; exit 1 + in + try + Lwt_main.run (main service path) + with + | OBus_introspect.Parse_failure((line, column), msg) -> + ignore_result (Lwt_io.eprintlf "invalid introspection document returned by the service!:%d:%d: %s" line column msg); + exit 1 diff --git a/tools/obus_xml2idl.ml b/tools/obus_xml2idl.ml new file mode 100644 index 0000000..989198b --- /dev/null +++ b/tools/obus_xml2idl.ml @@ -0,0 +1,43 @@ +(* + * obus_xml2idl.ml + * --------------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +let usage_message = + Printf.sprintf "Usage: %s <options> <file>\n\ + Generate an obus IDL file from a D-Bus introspection file.\n\ + options are:" + (Filename.basename Sys.argv.(0)) + +let output = ref None + +let args = [ + "-o", Arg.String(fun str -> output := Some str), "<file-name> output file name"; +] + +let () = + let sources = ref [] in + Arg.parse args (fun s -> sources := s :: !sources) usage_message; + + let source = + match !sources with + | [s] -> s + | _ -> Arg.usage args usage_message; exit 1 + in + let destination = + match !output with + | None -> + (try + Filename.chop_extension source + with Invalid_argument _ -> + source) ^ ".obus" + | Some name -> + name + in + + OBus_idl.print_file destination (Utils.IFSet.elements (Utils.parse_xml source)); + Printf.printf "file \"%s\" written\n" destination diff --git a/tools/term.ml b/tools/term.ml new file mode 100644 index 0000000..2f1d79f --- /dev/null +++ b/tools/term.ml @@ -0,0 +1,108 @@ +(* + * term.ml + * ------- + * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(* Terms manipulation *) + +open Printf +open OBus_introspect_ext + +(* +-----------------------------------------------------------------+ + | D-Bus types --> term (implementation) | + +-----------------------------------------------------------------+ *) + +let rec impl = function + | Term("byte", []) -> term "basic_byte" [] + | Term("boolean", []) -> term "basic_boolean" [] + | Term("int16", []) -> term "basic_int16" [] + | Term("int32", []) -> term "basic_int32" [] + | Term("int64", []) -> term "basic_int64" [] + | Term("uint16", []) -> term "basic_uint16" [] + | Term("uint32", []) -> term "basic_uint32" [] + | Term("uint64", []) -> term "basic_uint64" [] + | Term("double", []) -> term "basic_double" [] + | Term("string", []) -> term "basic_string" [] + | Term("signature", []) -> term "basic_signature" [] + | Term("object_path", []) -> term "basic_object_path" [] + | Term("unix_fd", []) -> term "basic_unix_fd" [] + | Term("array", [Term("byte", [])]) -> term "byte_array" [] + | Term("dict", [tk; tv]) -> term "dict" [tk; impl tv] + | Term(name, tl) -> term name (List.map impl tl) + | Tuple tl -> tuple (List.map impl tl) + +(* +-----------------------------------------------------------------+ + | D-Bus types --> term (interface) | + +-----------------------------------------------------------------+ *) + +let rec intf = function + | Term("byte", []) -> term "char" [] + | Term("boolean", []) -> term "bool" [] + | Term("int16", []) -> term "int" [] + | Term("int32", []) -> term "int32" [] + | Term("int64", []) -> term "int64" [] + | Term("uint16", []) -> term "int" [] + | Term("uint32", []) -> term "int32" [] + | Term("uint64", []) -> term "int64" [] + | Term("double", []) -> term "float" [] + | Term("string", []) -> term "string" [] + | Term("signature", []) -> term "OBus_value.signature" [] + | Term("object_path", []) -> term "OBus_path.t" [] + | Term("unix_fd", []) -> term "Unix.file_descr" [] + | Term("array", [Term("byte", [])]) -> term "string" [] + | Term("array", [t]) -> term "list" [intf t] + | Term("dict", [tk; tv]) -> term "list" [tuple [intf tk; intf tv]] + | Term("variant", []) -> term "OBus_value.V.single" [] + | Term(name, tl) -> term name (List.map intf tl) + | Tuple tl -> tuple (List.map intf tl) + +(* +-----------------------------------------------------------------+ + | Term printing (implementation) | + +-----------------------------------------------------------------+ *) + +let rec print_impl top oc = function + | Term(id, []) -> + output_string oc id + | Term(id, tl) -> + if not top then output_char oc '('; + output_string oc id; + List.iter + (fun t -> + output_char oc ' '; + print_impl false oc t) + tl; + if not top then output_char oc ')' + | Tuple [] -> + if not top then output_char oc '('; + output_string oc "structure seq0"; + if not top then output_char oc ')' + | Tuple tl -> + if not top then output_char oc '('; + fprintf oc "structure (seq%d" (List.length tl); + List.iter + (fun t -> + output_char oc ' '; + print_impl false oc t) + tl; + output_char oc ')'; + if not top then output_char oc ')' + +(* +-----------------------------------------------------------------+ + | Term printing (interface) | + +-----------------------------------------------------------------+ *) + +let rec print_intf top oc = function + | Term(id, []) -> output_string oc id + | Term(id, [t]) -> fprintf oc "%a %s" (print_intf false) t id + | Term(id, tl) -> fprintf oc "(%a) %s" (print_seq true ", ") tl id + | Tuple [] -> output_string oc "unit" + | Tuple tl -> if top then print_seq false " * " oc tl else fprintf oc "(%a)" (print_seq false " * ") tl + +and print_seq top sep oc = function + | [] -> () + | [t] -> print_intf top oc t + | t :: tl -> fprintf oc "%a%s%a" (print_intf top) t sep (print_seq top sep) tl diff --git a/tools/utils.ml b/tools/utils.ml new file mode 100644 index 0000000..44458a5 --- /dev/null +++ b/tools/utils.ml @@ -0,0 +1,148 @@ +(* + * utils.ml + * -------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +open Printf +open OBus_value +open OBus_introspect_ext + +module IFSet = Set.Make(struct + type t = OBus_introspect_ext.interface + let compare (n1, _, _, _) (n2, _, _, _) = String.compare n1 n2 + end) + +let parse_xml fname = + let ic = open_in fname in + try + let interfaces, _ = OBus_introspect.input (Xmlm.make_input ~entity:(fun _ -> Some "") ~strip:true (`Channel ic)) in + close_in ic; + let interfaces = List.map OBus_introspect_ext.decode interfaces in + List.fold_left (fun acc iface -> IFSet.add iface acc) IFSet.empty interfaces + with + | OBus_introspect.Parse_failure((line, column), msg) -> + Printf.eprintf "%s:%d:%d: %s.\n%!" fname line column msg; + exit 1 + +let parse_idl fname = + try + List.fold_left (fun acc iface -> IFSet.add iface acc) IFSet.empty (OBus_idl.parse_file fname) + with exn -> + Format.eprintf "@[<v0>%a@]@." Camlp4.ErrorHandler.print exn; + exit 1 + +let parse_file fname = + if Filename.check_suffix fname ".obus" then + parse_idl fname + else + parse_xml fname + +let file_name_of_interface_name name = + let result = String.create (String.length name) in + for i = 0 to String.length name - 1 do + if name.[i] = '.' then + result.[i] <- '_' + else + result.[i] <- name.[i] + done; + result + +let paren top s = if top then s else sprintf "(%s)" s + +let make_names l = + let rec aux n = function + | [] -> [] + | _ :: l -> sprintf "x%d" n :: aux (n + 1) l + in + aux 1 l + +let rec convertor conv top = function + | Term(name, []) -> + conv top name + | Term("array", [t]) -> begin + match convertor conv false t with + | Some f -> Some(paren top (sprintf "List.map %s" f)) + | None -> None + end + | Term("dict", [tk; tv]) -> begin + match convertor conv true tk, convertor conv true tv with + | None, None -> + None + | Some fk, None -> + Some(paren top (sprintf "List.map (fun (k, v) -> (%s k, v))" fk)) + | None, Some fv -> + Some(paren top (sprintf "List.map (fun (k, v) -> (k, %s v))" fv)) + | Some fk, Some fv -> + Some(paren top (sprintf "List.map (fun (k, v) -> (%s k, %s v))" fk fv)) + end + | Term(name, args) -> + None + | Tuple tl -> + let l = List.map (convertor conv true) tl in + if List.exists (fun f -> f <> None) l then begin + let names = make_names tl in + Some(sprintf "(fun (%s) -> (%s))" + (String.concat ", " names) + (String.concat ", " (List.map2 + (fun name conv -> + match conv with + | Some f -> sprintf "%s %s" f name + | None -> name) + names l))) + end else + None + +let dbus_symbols = [ + "byte"; + "boolean"; + "int16"; + "int32"; + "int64"; + "uint16"; + "uint32"; + "uint64"; + "double"; + "string"; + "signature"; + "object_path"; + "unix_fd"; + "array"; + "dict"; + "variant"; +] + +let convertor_send top typ = + convertor + (fun top t -> + match t with + | "int32" | "uint32" -> Some "Int32.of_int" + | "object_path" -> Some "OBus_proxy.path" + | name when List.mem name dbus_symbols -> None + | name -> Some("cast_" ^ name)) + top typ + +let convertor_recv top typ = + convertor + (fun top t -> + match t with + | "int32" | "uint32" -> Some "Int32.to_int" + | "object_path" -> Some(paren top ("OBus_proxy.make (OBus_context.sender context)")) + | name when List.mem name dbus_symbols -> None + | name -> Some("make_" ^ name)) + top typ + +let make_annotation = function + | "org.freedesktop.DBus.Deprecated" -> "OBus_introspect.deprecated" + | "org.freedesktop.DBus.GLib.CSymbol" -> "OBus_introspect.csymbol" + | "org.freedesktop.DBus.Method.NoReply" -> "OBus_introspect.no_reply" + | "org.freedesktop.DBus.Property.EmitsChangedSignal" -> "OBus_introspect.emits_changed_signal" + | "org.ocamlcore.forge.obus.Enum" -> "OBus_introspect_ext.obus_enum" + | "org.ocamlcore.forge.obus.Flag" -> "OBus_introspect_ext.obus_flag" + | "org.ocamlcore.forge.obus.Type" -> "OBus_introspect_ext.obus_type" + | "org.ocamlcore.forge.obus.IType" -> "OBus_introspect_ext.obus_itype" + | "org.ocamlcore.forge.obus.OType" -> "OBus_introspect_ext.obus_otype" + | name -> Printf.sprintf "%S" name diff --git a/tools/utils.mli b/tools/utils.mli new file mode 100644 index 0000000..4f12a5d --- /dev/null +++ b/tools/utils.mli @@ -0,0 +1,43 @@ +(* + * utils.mli + * --------- + * Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +(** Utilities for tools *) + +module IFSet : Set.S with type elt = OBus_introspect_ext.interface + (** Set of interfaces *) + +val parse_xml : string -> IFSet.t + (** [parse_xml file_name] parses [file_name] as an XML introspection + file *) + +val parse_idl : string -> IFSet.t + (** [parse_xml file_name] parses [file_name] as an obus IDL file *) + +val parse_file : string -> IFSet.t + (** [parse_file file_name] parses [file_name] as an XML + introspection file or as an IDL file (according to the file name + extension), and returns the set of interfaces it contains. *) + +val file_name_of_interface_name : OBus_name.interface -> string + (** Convert an interface name into a valid module file name *) + +val convertor_send : bool -> OBus_introspect_ext.term -> string option + (** [convertor_send paren typ] returns an expression which convert + caml values before they are sent. It returns [None] if no + conversion is needed. If [paren] is [true] then no parenthesis + will be used, otherwise the expression may be surrounded by + parenthesis if needed *) + +val convertor_recv : bool -> OBus_introspect_ext.term -> string option + (** [convertor_recv paren typ] returns an expression which convert + caml values after they are received. It returns [None] if no + conversion is needed. *) + +val make_annotation : OBus_introspect.name -> string + (** [make_annotation name] returns the code for the given annotation *) diff --git a/utils/doc/style.css b/utils/doc/style.css new file mode 100644 index 0000000..fb02716 --- /dev/null +++ b/utils/doc/style.css @@ -0,0 +1,171 @@ +/* A style for ocamldoc. Daniel C. Buenzli, Jérémie Dimino */ + +body { + padding: 0em; + border: 0em; + margin: 2em 10% 2em 10%; + font-weight: normal; + line-height: 130%; + text-align: justify; + background: white; + color : black; + min-width: 40ex; +} + +pre, p, div, span, img, table, td, ol, ul, li { + padding: 0em; + border: 0em; + margin: 0em +} + +h1, h2, h3, h4, h5, h6, div.h7, div.h8, div.h9 { + fontsize: 100%; + margin-bottom: 1em + padding: 1ex 0em 0em 0em; + border: 0em; + margin: 1em 0em 0em 0em; + font-weight : bold; + text-align: center; +} + +h1 { + font-size : 140% +} + +h2, h3, h4, h5, h6, div.h7, div.h8, div.h9 { + font-size : 100%; + border-top-style : none; + margin: 1ex 0em 0em 0em; + border: 1px solid #000000; + margin-top: 5px; + margin-bottom: 2px; + text-align: center; + padding: 2px; +} + +h2 { + font-size : 120%; + background-color: #90BDFF ; +} +h3 { + background-color: #90DDFF; +} +h4 { + background-color: #90EDFF; +} +h5 { + background-color: #90FDFF; +} +h6 { + background-color: #C0FFFF; +} +div.h7 { + background-color: #E0FFFF; +} +div.h8 { + background-color: #F0FFFF; +} +div.h9 { + background-color: #FFFFFF; +} + +.navbar { + padding-bottom : 1em; + margin-bottom: 1em; + border-bottom: 1px solid #000000; + border-bottom-style: dotted; +} + +p { + padding: 1em 0ex 0em 0em +} + +a, a:link, a:visited, a:active, a:hover { + color : #009; + text-decoration: none +} +a:hover { + color : #009; + text-decoration : none; + background-color: #5FFF88 +} + +hr { + border-style: none; +} +table { + font-size : 100% /* Why ? */ +} +ul li { + padding: 1em 0em 0em 0em; + margin:0em 0em 0em 2.5ex +} +ol li { + padding: 1em 0em 0em 0em; + margin:0em 0em 0em 2em +} + +pre { + margin: 3ex 0em 1ex 0em; + background-color: #edf0f9; +} +.keyword { + font-weight: bold; + color: #a020f0; +} +.keywordsign { + font-weight: bold; + color: #a020f0; +} +.typefieldcomment { + color : #b22222; +} +.keywordsign { + color: #a020f0; + +} +.code { + font-size: 120%; + color: #5f5f5f; +} +.info { + margin: 0em 0em 0em 2em +} +.comment { + color : #b22222; +} +.constructor { + color : #072 +} +.type { + color : #228b22; +} +.string { + color : #bc8f8f; +} +.warning { + color : Red; + font-weight : bold +} + +div.sig_block { + margin-left: 2em +} +.typetable { + color : #b8860b; + border-style : hidden +} +.indextable { + border-style : hidden +} +.paramstable { + border-style : hidden; + padding: 5pt 5pt +} + +.superscript { + font-size : 80% +} +.subscript { + font-size : 80% +} diff --git a/utils/obus-mode.el b/utils/obus-mode.el new file mode 100644 index 0000000..729d2e7 --- /dev/null +++ b/utils/obus-mode.el @@ -0,0 +1,69 @@ +;; obus-mode.el +;; ------------ +;; Copyright : (c) 2010, Jeremie Dimino <jeremie@dimino.org> +;; Licence : BSD3 + +(require 'tuareg) + +(defconst obus-keywords '("interface" "method" "signal" + "property_r" "property_w" "property_rw" + "annotation" "with" "enum" "flag") + "List of keywords for the obus-mode") + +(defconst obus-member-keywords '("method" "signal" + "property_r" "property_w" "property_rw") + "List of keywords used for defining D-Bus members") + +(defvar obus-file nil + "Whether the current buffer is an obus idl file") + +(defun obus-tuareg-mode-hook () + "Setup the tuareg mode for obus idl files" + (if obus-file + (progn + (setq obus-file nil) + (make-local-variable 'tuareg-governing-phrase-regexp) + (make-local-variable 'tuareg-keyword-alist) + (make-local-variable 'tuareg-font-lock-keywords) + + (setq tuareg-governing-phrase-regexp + (regexp-opt + '("interface" "method" "signal" + "property_r" "property_w" "property_rw" + "annotation" "enum" "flag") + `words)) + (setq tuareg-keyword-alist (mapcar (lambda (x) (cons x 2)) obus-keywords)) + + (setq tuareg-font-lock-keywords + (list + (list "[(){}:*=,]\\|->" + 0 'font-lock-keyword-face nil nil) + (list (regexp-opt obus-keywords `words) + 0 'font-lock-keyword-face nil nil) + (list (concat (regexp-opt obus-member-keywords `words) "[ \t\n]+\\([A-Za-z_][A-Za-z0-9_]*\\)\\>") + 2 'font-lock-function-name-face 'keep nil) + (list "\\<interface\\>[ \t\n]+\\([A-Za-z_][A-Za-z0-9_]*\\([.][A-Za-z0-9_]+\\)+\\)\\>" + 1 'font-lock-constant-face 'keep nil) + (list "\\<\\(enum\\|flag\\)\\>[ \t\n]+\\([A-Za-z_][A-Za-z0-9_]*\\)\\>" + 2 'font-lock-type-face 'keep nil) + (list "\\<\\([A-Za-z_][A-Za-z0-9_.]+\\)[ \t\n]*\\(=\\|:\\)" + 1 'font-lock-variable-name-face 'keep nil) + (list "\\([0-9][0-9a-zA-Z+-.]*\\|'.'\\|\"[^\"]*\"\\)[ \t\n]*:[ \t\n]*\\([A-Za-z_][A-Za-z0-9_]*\\)\\>" + 2 'font-lock-variable-name-face 'keep nil) + (list ":[ \t\n]*\\(\\([_--->.* \t]\\|\\w\\|(['~?]*\\([_--->.,* \t]\\|\\w\\)*)\\)*\\)" + 1 'font-lock-type-face 'keep nil) + (list (regexp-opt obus-keywords `words))))))) + +(add-hook 'tuareg-mode-hook 'obus-tuareg-mode-hook) + +;;;###autoload (add-to-list 'auto-mode-alist '("\\.obus\\'" . obus-mode)) + +;;;###autoload +(defun obus-mode () + "Major mode for editing obus idl files" + (interactive) + (print "toto") + (setq obus-file t) + (tuareg-mode)) + +(provide 'obus-mode) diff --git a/utils/scripts/cpufreq-performance b/utils/scripts/cpufreq-performance new file mode 100644 index 0000000..8195240 --- /dev/null +++ b/utils/scripts/cpufreq-performance @@ -0,0 +1,19 @@ +#!/usr/bin/env ocamlscript +(* + * cpufreq-performance + * ------------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +Ocaml.packs := ["obus.hal"; "lwt.syntax"] +-- + +(* Set the cpufreq governor to performance on all cpus *) + +let () = Lwt_unix.run begin + lwt computer = Lazy.force Hal_device.computer in + Hal_device.Cpufreq.set_cpufreq_governor computer "performance" +end diff --git a/utils/scripts/cpufreq-powersave b/utils/scripts/cpufreq-powersave new file mode 100644 index 0000000..7f4af8a --- /dev/null +++ b/utils/scripts/cpufreq-powersave @@ -0,0 +1,19 @@ +#!/usr/bin/env ocamlscript +(* + * cpufreq-powersave + * ----------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +Ocaml.packs := ["obus.hal"; "lwt.syntax"] +-- + +(* Set the cpufreq governor to powersave on all cpus *) + +let () = Lwt_unix.run begin + lwt computer = Lazy.force Hal_device.computer in + Hal_device.Cpufreq.set_cpufreq_governor computer "powersave" +end diff --git a/utils/scripts/multimedia-keys b/utils/scripts/multimedia-keys new file mode 100644 index 0000000..2771f33 --- /dev/null +++ b/utils/scripts/multimedia-keys @@ -0,0 +1,56 @@ +#!/usr/bin/env ocamlscript +(* + * multimedia-keys + * --------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +Ocaml.packs := ["lwt.syntax"; "obus.syntax"; "obus"] +-- + +(* Simple script which listen keyboard events emited by hal and run + commands *) + +open Lwt + +(* Configuration *) +let commands = [ + ("volume-up", "amixer -q set Master 5%+"); + ("volume-down", "amixer -q set Master 5%-"); +] + +lwt () = + lwt bus = Lazy.force OBus_bus.system in + + (* Tell the message bus we want to receive ButtonPressed events from + hal. *) + lwt () = OBus_bus.add_match bus (OBus_match.rule + ~sender:"org.freedesktop.Hal" + ~interface:"org.freedesktop.Hal.Device" + ~member:"Condition" + ~arguments:[(0, "ButtonPressed")] ()) in + + (* Add a message filter. We use that instead of adding a signal + receiver because we do not care about which object send the + event. *) + ignore (Lwt_sequence.add_l + (function + | { OBus_message.typ = OBus_message.Signal(_, "org.freedesktop.Hal.Device", "Condition"); + OBus_message.body = OBus_value.V.([Basic(String "ButtonPressed"); Basic(String button)]) } -> + begin match try Some(List.assoc button commands) with Not_found -> None with + | Some command -> + ignore_result (Lwt_unix.system command) + | None -> + () + end; + Some msg + | msg -> + Some msg) + (OBus_connection.incoming_filters bus)); + + (* Wait forever, the program will exit when the connection is + closed *) + fst (wait ()) diff --git a/utils/scripts/power-hibernate b/utils/scripts/power-hibernate new file mode 100644 index 0000000..ec46763 --- /dev/null +++ b/utils/scripts/power-hibernate @@ -0,0 +1,19 @@ +#!/usr/bin/env ocamlscript +(* + * power-hibernate + * --------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +Ocaml.packs := ["obus.hal"; "lwt.syntax"] +-- + +(* Make the computer to hibernate *) + +let _ = Lwt_main.run begin + lwt computer = Lazy.force Hal_device.computer in + Hal_device.System_power_management.hibernate computer +end diff --git a/utils/scripts/power-reboot b/utils/scripts/power-reboot new file mode 100644 index 0000000..e94bacf --- /dev/null +++ b/utils/scripts/power-reboot @@ -0,0 +1,19 @@ +#!/usr/bin/env ocamlscript +(* + * power-reboot + * ------------ + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +Ocaml.packs := ["obus.hal"; "lwt.syntax"] +-- + +(* Make the computer to reboot *) + +let _ = Lwt_unix.run begin + lwt computer = Lazy.force Hal_device.computer in + Hal_device.System_power_management.reboot computer +end diff --git a/utils/scripts/power-shutdown b/utils/scripts/power-shutdown new file mode 100644 index 0000000..c2ef262 --- /dev/null +++ b/utils/scripts/power-shutdown @@ -0,0 +1,19 @@ +#!/usr/bin/env ocamlscript +(* + * power-shutdown + * -------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +Ocaml.packs := ["obus.hal"; "lwt.syntax"] +-- + +(* Make the computer to shutdown *) + +let _ = Lwt_main.run begin + lwt computer = Lazy.force Hal_device.computer in + Hal_device.System_power_management.shutdown computer +end diff --git a/utils/scripts/power-suspend b/utils/scripts/power-suspend new file mode 100644 index 0000000..9cdb7bf --- /dev/null +++ b/utils/scripts/power-suspend @@ -0,0 +1,19 @@ +#!/usr/bin/env ocamlscript +(* + * power-suspend + * ------------- + * Copyright : (c) 2009, Jeremie Dimino <jeremie@dimino.org> + * Licence : BSD3 + * + * This file is a part of obus, an ocaml implementation of D-Bus. + *) + +Ocaml.packs := ["obus.hal"; "lwt.syntax"] +-- + +(* Make the computer to suspend to ram *) + +let _ = Lwt_main.run begin + lwt computer = Lazy.force Hal_device.computer in + Hal_device.System_power_management.suspend computer 0 +end |