1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
(* Browse the local network for ssh services using Avahi and D-Bus.
* There is *zero* documentation for this. I examined a lot of code
* to do this, and the following page was also very helpful:
* http://www.amk.ca/diary/2007/04/rough_notes_python_and_dbus.html
* See also the DBus API reference:
* http://dbus.freedesktop.org/doc/dbus/api/html/index.html
* See also Dan Berrange's Perl bindings:
* http://search.cpan.org/src/DANBERR/Net-DBus-0.33.5/lib/Net/
*
* By Richard W.M. Jones <rich@annexia.org> or <rjones@redhat.com>.
* PUBLIC DOMAIN example code.
*)
open Printf
open DBus
let debug = true
let service = "_ssh._tcp"
let rec print_msg msg =
(match Message.get_type msg with
| Message.Invalid ->
printf "Invalid";
| Message.Method_call ->
printf "Method_call";
| Message.Method_return ->
printf "Method_return";
| Message.Error ->
printf "Error";
| Message.Signal ->
printf "Signal");
let print_opt f name =
match f msg with
| None -> ()
| Some value -> printf " %s=%S" name value
in
print_opt Message.get_member "member";
print_opt Message.get_path "path";
print_opt Message.get_interface "interface";
print_opt Message.get_sender "sender";
let fields = Message.get msg in
printf "(";
print_fields fields;
printf ")\n%!";
and print_fields fields =
printf "%s" (String.concat ", " (List.map string_of_ty fields))
(* Perform a synchronous call to an object method. *)
let call_method ~bus ~name ~path ~interface ~methd args =
(* Create the method_call message. *)
let msg = Message.new_method_call name path interface methd in
Message.append msg args;
(* Send the message, get reply. *)
let r = Connection.send_with_reply_and_block bus msg (-1) in
Message.get r
(* A service has appeared on the network. Resolve its IP address, etc. *)
let resolve_service bus sb_path msg =
let fields = Message.get msg in
match fields with
(* match fields in the ItemNew message from ServiceBrowser. *)
| [(Int32 _) as interface;
(Int32 _) as protocol;
(String _) as name;
(String _) as service;
(String _) as domain;
_ (* flags *)] ->
(* Create a new ServiceResolver object which is used to resolve
* the actual locations of network services found by the ServiceBrowser.
*)
let sr =
call_method ~bus
~name:"org.freedesktop.Avahi"
~path:"/"
~interface:"org.freedesktop.Avahi.Server"
~methd:"ServiceResolverNew"
[
interface;
protocol;
name;
service;
domain;
Int32 (-1_l); (* AVAHI_PROTO_UNSPEC *)
UInt32 0_l; (* flags *)
] in
let sr_path =
match sr with
| [ ObjectPath path ] -> path
| _ -> assert false in
if debug then eprintf "ServiceResolver path = %S\n%!" sr_path;
(* Add a match rule so we see these all signals of interest. *)
Bus.add_match bus
(String.concat "," [
"type='signal'";
"sender='org.freedesktop.Avahi.ServiceResolver'";
"path='" ^ sr_path ^ "'";
]) true;
()
| _ ->
prerr_endline "warning: unexpected message contents of ItemNew signal";
()
(* This is called when we get a message/signal. Could be from the
* (global) ServiceBrowser or any of the ServiceResolver objects.
*)
let got_message bus sb_path msg =
if debug then print_msg msg;
let typ = Message.get_type msg in
let member = match Message.get_member msg with None -> "" | Some m -> m in
let interface =
match Message.get_interface msg with None -> "" | Some m -> m in
if typ = Message.Signal then (
match interface, member with
| "org.freedesktop.Avahi.ServiceBrowser", "CacheExhausted" -> ()
| "org.freedesktop.Avahi.ServiceBrowser", "ItemNew" ->
(* New service has appeared, start to resolve it. *)
resolve_service bus sb_path msg
| "org.freedesktop.Avahi.ServiceBrowser", "ItemRemove" ->
(* XXX Service has disappeared. *)
()
| "org.freedesktop.Avahi.ServiceBrowser", "AllForNow" -> ()
| "org.freedesktop.Avahi.ServiceResolver", "Found" ->
(* Resolver has resolved the name of a previously appearing service. *)
(* XXX *)
()
| "org.freedesktop.DBus", _ -> ()
| interface, member ->
eprintf "warning: ignored unknown message %s from %s\n%!"
member interface
);
true
(* Store the connection bus. However don't bother
* connecting to D-Bus at all until the user opens the connection
* dialog for the first time.
*)
let connection = ref None
(* Create system bus object, and create the service
* browser. XXX Probably not robust if the daemon restarts.
*)
let connect () =
match !connection with
| Some bus -> (bus, false)
| None ->
let bus = Bus.get Bus.System in
(* Create a new ServiceBrowser object which emits a signal whenever
* a new network service of the type specified is found on the network.
*)
let sb =
call_method ~bus
~name:"org.freedesktop.Avahi"
~path:"/"
~interface:"org.freedesktop.Avahi.Server"
~methd:"ServiceBrowserNew"
[
Int32 (-1_l); (* interface, -1=AVAHI_IF_UNSPEC *)
Int32 0_l; (* 0=IPv4, 1=IPv6 *)
String service; (* service type *)
String ""; (* XXX call GetDomainName() *)
UInt32 0_l; (* flags *)
] in
let sb_path =
match sb with
| [ ObjectPath path ] -> path
| _ -> assert false in
if debug then eprintf "ServiceBrowser path = %S\n%!" sb_path;
(* Register a callback to accept the signals. *)
(* XXX This leaks memory because it is never freed. *)
Connection.add_filter bus (
fun bus msg -> got_message bus sb_path msg
);
(* Add a match rule so we see these all signals of interest. *)
Bus.add_match bus
(String.concat "," [
"type='signal'";
"sender='org.freedesktop.Avahi.ServiceBrowser'";
"path='" ^ sb_path ^ "'";
]) true;
connection := Some (bus);
(bus, true)
let () =
let bus, just_connected = connect () in
(* Wait for incoming signals. *)
while Connection.read_write_dispatch bus (-1) do ()
done
|
