ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/Net-XMPP2/lib/Net/XMPP2/Connection.pm
Revision: 1.10
Committed: Fri Apr 20 14:56:45 2007 UTC (19 years, 5 months ago) by elmex
Branch: MAIN
Changes since 1.9: +45 -118 lines
Log Message:
implemented Client.pm. Implemented error objects which simplyfied
the error reporting.

File Contents

# Content
1 package Net::XMPP2::Connection;
2 use strict;
3 use AnyEvent;
4 use IO::Socket::INET;
5 use Net::XMPP2::Parser;
6 use Net::XMPP2::Writer;
7 use Net::XMPP2::Util qw/split_jid/;
8 use Net::XMPP2::Event;
9 use Net::XMPP2::SimpleConnection;
10 use Net::XMPP2::Namespaces qw/xmpp_ns/;
11 use Net::XMPP2::Error;
12 use Net::DNS;
13
14 our @ISA = qw/Net::XMPP2::SimpleConnection Net::XMPP2::Event/;
15
16 =head1 NAME
17
18 Net::XMPP2::Connection - A XML stream that implements the XMPP RFC 3920.
19
20 =head1 SYNOPSIS
21
22 use Net::XMPP2::Connection;
23
24 my $con =
25 Net::XMPP2::Connection->new (
26 username => "abc",
27 domain => "jabber.org",
28 resource => "Net::XMPP2"
29 );
30
31 $con->connect or die "Couldn't connect to jabber.org: $!";
32 $con->init;
33 $con->reg_cb (stream_ready => sub { print "XMPP stream ready!\n" });
34
35 =head1 DESCRIPTION
36
37 This module represents a XMPP stream as described in RFC 3920. You can issue the basic
38 XMPP XML stanzas with methods like C<send_iq>, C<send_message> and C<send_presence>.
39
40 And receive events with the C<reg_cb> event framework from the connection.
41
42 If you need instant messaging stuff please take a look at C<Net::XMPP2::IM::Connection>.
43
44 =head1 METHODS
45
46 =head2 new (%args)
47
48 Following arguments can be passed in C<%args>:
49
50 =over 4
51
52 =item language => $tag
53
54 This should be the language of the human readable contents that
55 will be transmitted over the stream. The default will be 'en'.
56
57 Please look in RFC 3066 how C<$tag> should look like.
58
59 =item jid => $jid
60
61 This can be used to set the settings C<username>, C<domain>
62 (and optionally C<resource>) from a C<$jid>.
63
64 =item resource => $resource
65
66 If this argument is given C<$resource> will be passed as desired
67 resource on resource binding.
68
69 Note: You have to take care that the stringprep profile for
70 resources can be applied at: C<$resource>. Otherwise the server
71 might signal an error. See L<Net::XMPP2::Util> for utility functions
72 to check this.
73
74 =item domain => $domain
75
76 This is the destination host we are going to connect to.
77 As the connection won't be automatically connected use C<connect>
78 to initiate the connect.
79
80 Note: A SRV RR lookup will be performed to discover the real hostname
81 and port to connect to. See also C<connect>.
82
83 =item override_host => $host
84 =item override_port => $port
85
86 This will be used as override to connect to.
87
88 =item port => $port
89
90 This is optional, the default port is 5222.
91
92 Note: A SRV RR lookup will be performed to discover the real hostname
93 and port to connect to. See also C<connect>.
94
95 =item username => $username
96
97 This is your C<$username> (the userpart in the JID);
98
99 Note: You have to take care that the stringprep profile for
100 nodes can be applied at: C<$username>. Otherwise the server
101 might signal an error. See L<Net::XMPP2::Util> for utility functions
102 to check this.
103
104 =item password => $password
105
106 This is the password for the C<username> above.
107
108 =item disable_ssl => $bool
109
110 If C<$bool> is true no SSL will be used.
111
112 =back
113
114 =cut
115
116 sub new {
117 my $this = shift;
118 my $class = ref($this) || $this;
119 my $self = { language => 'en', @_ };
120 bless $self, $class;
121
122 $self->{parser} = new Net::XMPP2::Parser;
123 $self->{writer} = Net::XMPP2::Writer->new (
124 write_cb => sub { $self->write_data ($_[0]) }
125 );
126
127 $self->{parser}->set_stanza_cb (sub {
128 $self->handle_stanza (@_);
129 });
130
131 $self->{iq_id} = 1;
132
133 $self->{disconnect_cb} = sub {
134 my ($host, $port, $message) = @_;
135 delete $self->{authenticated};
136 delete $self->{ssl_enabled};
137 $self->event (disconnect => $host, $port, $message);
138 };
139
140 if ($self->{jid}) {
141 my ($user, $host, $res) = split_jid ($self->{jid});
142 $self->{username} = $user;
143 $self->{domain} = $host;
144 $self->{resource} = $res if defined $res;
145 }
146
147 for (qw/username password domain/) {
148 die "No '$_' argument given to new, but '$_' is required\n"
149 unless $self->{$_};
150 }
151
152 return $self;
153 }
154
155 =head2 connect ($no_srv_rr)
156
157 Try to connect to the domain and port passed in C<new>.
158
159 A SRV RR lookup will be performed on the domain to discover
160 the host and port to use. If you don't want this set C<$no_srv_rr>
161 to a true value. C<$no_srv_rr> is false by default.
162
163 As the SRV RR lookup might return multiple host and you fail to
164 connect to one you might just call this function again to try a
165 different host.
166
167 If C<connect> was successful and we connected a true value is returned.
168 If the connect was unsuccessful undef is returned and C<$!> will be set
169 to the error that occured while connecting.
170
171 If you want to know whether further connection attempts might be more
172 successful (as SRV RR lookup may return multiple hosts) call C<may_try_connect>
173 (see also C<may_try_connect>).
174
175 Note that an internal list will be kept of tried hosts. Use
176 C<reset_connect_tries> to reset the internal list of tried hosts.
177
178 =cut
179
180 sub connect {
181 my ($self, $no_srv_rr) = @_;
182
183 my ($host, $port) = ($self->{domain}, $self->{port} || 5222);
184 if ($self->{override_host}) {
185 ($host, $port) = ($self->{override_host}, $self->{override_port} || 5222);
186
187 } else {
188 unless ($no_srv_rr) {
189 my $res = Net::DNS::Resolver->new;
190 my $p = $res->query ('_xmpp-client._tcp.'.$host, 'SRV');
191 if ($p) {
192 my @srvs = grep { $_->type eq 'SRV' } $p->answer;
193 if (@srvs) {
194 @srvs = sort { $a->priority <=> $b->priority } @srvs;
195 @srvs = sort { $b->weight <=> $a->weight } @srvs; # TODO
196 $port = $srvs[0]->port;
197 $host = $srvs[0]->target;
198 }
199 }
200 }
201 }
202
203 if ($self->SUPER::connect ($host, $port)) {
204 $self->event (connect => $host, $port);
205 return 1;
206 } else {
207 return undef;
208 }
209 }
210
211 =head2 may_try_connect
212
213 Returns the number of left alternatives of hosts to connect to for the
214 domain passed to C<new>.
215
216 An internal list of tried hosts will be managed by C<connect> and those
217 hosts will be ignored by a SRV RR lookup (which will be done if you
218 call this function).
219
220 Use C<reset_connect_tries> to reset the internal list of tried hosts.
221
222 =cut
223
224 sub may_try_connect {
225 # TODO
226 }
227
228 =head2 reset_connect_tries
229
230 This function resets the internal list of tried hosts for C<connect>.
231 See also C<connect>.
232
233 =cut
234
235 sub reset_connect_tries {
236 # TODO
237 }
238
239 sub handle_data {
240 my ($self, $buf) = @_;
241 $self->event (debug_recv => $$buf);
242 $self->{parser}->feed (substr $$buf, 0, (length $$buf), '');
243 }
244
245 sub debug_wrote_data {
246 my ($self, $data) = @_;
247 $self->event (debug_send => $data);
248 }
249
250 sub write_data {
251 my ($self, $data) = @_;
252 $self->SUPER::write_data ($data);
253 }
254
255 sub handle_stanza {
256 my ($self, $p, $node) = @_;
257
258 if ($node->eq (stream => 'features')) {
259 $self->event (stream_features => $node);
260 $self->handle_stream_features ($node);
261 $self->{features} = $node;
262
263 } elsif ($node->eq (tls => 'proceed')) {
264 $self->enable_ssl;
265 $self->{parser}->init;
266 $self->{writer}->init;
267 $self->{writer}->send_init_stream ($self->{language}, $self->{domain});
268
269 } elsif ($node->eq (sasl => 'challenge')) {
270 $self->handle_sasl_challenge ($node);
271 } elsif ($node->eq (sasl => 'success')) {
272 $self->handle_sasl_success ($node);
273 } elsif ($node->eq (client => 'iq')) {
274 $self->handle_iq ($node);
275 } elsif ($node->eq (client => 'message')) {
276 $self->event (message_xml => $node);
277 } elsif ($node->eq (client => 'presence')) {
278 $self->event (presence_xml => $node);
279 } elsif ($node->eq (stream => 'error')) {
280 $self->handle_error ($node);
281 } else {
282 warn "Didn't understood stanza: '" . $node->name . "'";
283 }
284 }
285
286 =head2 init ()
287
288 Initiate the XML stream.
289
290 =cut
291
292 sub init {
293 my ($self) = @_;
294 $self->{writer}->send_init_stream ($self->{language}, $self->{domain});
295 }
296
297 =head2 is_connected ()
298
299 Returns true if the connection is still connected and stanzas can be
300 sent.
301
302 =cut
303
304 sub is_connected {
305 my ($self) = @_;
306 $self->{authenticated}
307 }
308
309 =head2 send_iq ($type, $create_cb, $result_cb, %attrs)
310
311 This method sends an IQ XMPP request.
312
313 Please take a look at the documentation for C<send_iq> in Net::XMPP2::Writer
314 about the meaning of C<$type>, C<$create_cb> and C<%attrs>.
315
316 C<$result_cb> will be called when a result was received. The first argument to
317 C<$result_cb> will be a Net::XMPP2::Node instance containing the IQ result
318 stanza contents.
319
320 If the IQ resulted in a stanza error the second argument to C<$result_cb> will
321 be C<undef> (if the error type was not 'continue') and the third argument will
322 be a L<Net::XMPP2::Error::IQ> object.
323
324 This method returns the newly generated id for this iq request.
325
326 =cut
327
328 sub send_iq {
329 my ($self, $type, $create_cb, $result_cb, %attrs) = @_;
330 my $id = $self->{iq_id}++;
331 $self->{iqs}->{$id} = $result_cb;
332 $self->{writer}->send_iq ($id, $type, $create_cb, %attrs);
333 $id
334 }
335
336 =head2 reply_iq_result ($req_iq_node, $create_cb, %attrs)
337
338 This method will generate a result reply to the iq request C<Net::XMPP2::Node>
339 in C<$req_iq_node>.
340
341 Please take a look at the documentation for C<send_iq> in Net::XMPP2::Writer
342 about the meaning C<$create_cb> and C<%attrs>.
343
344 Use C<$create_cb> to create the XML for the result.
345
346 The type for this iq reply is 'result'.
347
348 =cut
349
350 sub reply_iq_result {
351 my ($self, $iqnode, $create_cb, %attrs) = @_;
352 $self->{writer}->send_iq ($iqnode->attr ('id'), 'result', $create_cb, %attrs);
353 }
354
355 =head2 reply_iq_error ($req_iq_node, $error_type, $error, %attrs)
356
357 This method will generate an error reply to the iq request C<Net::XMPP2::Node>
358 in C<$req_iq_node>.
359
360 C<$error_type> is one of 'cancel', 'continue', 'modify', 'auth' and 'wait'.
361 C<$error> is one of the defined error conditions described in
362 L<Net::XMPP2::Writer::write_error_tag>.
363
364 Please take a look at the documentation for C<send_iq> in Net::XMPP2::Writer
365 about the meaning of C<%attrs>.
366
367 The type for this iq reply is 'error'.
368
369 =cut
370
371 sub reply_iq_error {
372 my ($self, $iqnode, $errtype, $error, %attrs) = @_;
373
374 $self->{writer}->send_iq (
375 $iqnode->attr ('id'), 'error',
376 sub { $self->{writer}->write_error_tag ($iqnode, $errtype, $error) },
377 %attrs
378 );
379 }
380
381 sub handle_iq {
382 my ($self, $node) = @_;
383
384 my $type = $node->attr ('type');
385
386 if ($type eq 'result') {
387 if (my $cb = delete $self->{iqs}->{$node->attr ('id')}) {
388 $cb->($node);
389 }
390
391 } elsif ($type eq 'error') {
392 if (my $cb = delete $self->{iqs}->{$node->attr ('id')}) {
393
394 my $error = Net::XMPP2::Error::IQ->new (node => $node);
395 $cb->(($error->type eq 'continue' ? $node : undef), $error);
396 }
397
398 } else {
399 my $handled = 0;
400 $self->event ("iq_${type}_request_xml" => $node, \$handled);
401
402 my @from;
403 push @from, (to => $node->attr ('from')) if $node->attr ('from');
404
405 unless ($handled) {
406 $self->reply_iq_error ($node, undef, 'feature-not-implemented', @from);
407 }
408 }
409 }
410
411 sub handle_stream_features {
412 my ($self, $node) = @_;
413 my @mechs = $node->find_all ([qw/sasl mechanisms/], [qw/sasl mechanism/]);
414 my @bind = $node->find_all ([qw/bind bind/]);
415 my @tls = $node->find_all ([qw/tls starttls/]);
416
417 if (not ($self->{disable_ssl}) && not ($self->{ssl_enabled}) && @tls) {
418 $self->{writer}->send_starttls;
419
420 } elsif (not ($self->{authenticated}) and @mechs) {
421 $self->{writer}->send_sasl_auth (
422 (join ' ', map { $_->text } @mechs),
423 $self->{username}, $self->{domain}, $self->{password}
424 );
425
426 } elsif (@bind) {
427 $self->do_rebind ($self->{resource});
428 }
429 }
430
431 sub handle_sasl_challenge {
432 my ($self, $node) = @_;
433 $self->{writer}->send_sasl_response ($node->text);
434 }
435
436 sub handle_sasl_success {
437 my ($self, $node) = @_;
438 $self->{authenticated} = 1;
439 $self->{parser}->init;
440 $self->{writer}->init;
441 $self->{writer}->send_init_stream ($self->{language}, $self->{domain});
442 }
443
444 sub handle_error {
445 my ($self, $node) = @_;
446 my $error = Net::XMPP2::Error::Stream->new (node => $node);
447
448 $self->event (stream_error => $error);
449 $self->{writer}->send_end_of_stream;
450 }
451
452 =head2 send_presence ($type, $create_cb, %attrs)
453
454 This method sends a presence stanza, for the meanings
455 of C<$type>, C<$create_cb> and C<%attrs> please take a look
456 at the documentation for L<Net::XMPP2::Writer::send_presence>.
457
458 This methods does attach an id attribute to the message stanza and
459 will return the id that was used (so you can react on possible replies).
460
461 =cut
462
463 sub send_presence {
464 my ($self, $type, $create_cb, %attrs) = @_;
465 my $id = $self->{iq_id}++;
466 $self->{writer}->send_presence ($id, $type, $create_cb, %attrs);
467 $id
468 }
469
470 =head2 send_message ($to, $type, $create_cb, %attrs)
471
472 This method sends a presence stanza, for the meanings
473 of C<$to>, C<$type>, C<$create_cb> and C<%attrs> please take a look
474 at the documentation for L<Net::XMPP2::Writer::send_message>.
475
476 This methods does attach an id attribute to the message stanza and
477 will return the id that was used (so you can react on possible replies).
478
479 =cut
480
481 sub send_message {
482 my ($self, $to, $type, $create_cb, %attrs) = @_;
483 my $id = $self->{iq_id}++;
484 $self->{writer}->send_message ($id, $to, $type, $create_cb, %attrs);
485 $id
486 }
487
488 =head2 do_rebind ($resource)
489
490 In case you got a C<bind_error> event and want to retry
491 binding you can call this function to set a new C<$resource>
492 and retry binding.
493
494 If it fails again you can call this again. Becareful not to
495 end up in a loop!
496
497 If binding was successful the C<stream_ready> event will be generated.
498
499 =cut
500
501 sub do_rebind {
502 my ($self, $resource) = @_;
503 $self->{resource} = $resource;
504 $self->send_iq (
505 set =>
506 sub {
507 my ($w) = @_;
508 if ($self->{resource}) {
509 $w->startTag ([xmpp_ns ('bind'), 'bind']);
510 $w->startTag ([xmpp_ns ('bind'), 'resource']);
511 $w->characters ($self->{resource});
512 $w->endTag;
513 $w->endTag;
514 } else {
515 $w->emptyTag ([xmpp_ns ('bind'), 'bind'])
516 }
517 },
518 sub {
519 my ($ret_iq, $error, $err) = @_;
520
521 if ($err) {
522 my ($res) = $error->xml_node ()->find_all ([qw/bind bind/], [qw/bind resource/]);
523 $self->event (bind_error => $error, ($res ? $res : $self->{resource}));
524
525 } else {
526 my @jid = $ret_iq->find_all ([qw/bind bind/], [qw/bind jid/]);
527 my $jid = $jid[0]->text;
528 unless ($jid) { die "Got empty JID tag from server!\n" }
529 $self->{jid} = $jid;
530
531 $self->event (stream_ready => $jid);
532 }
533 }
534 );
535 }
536
537 =head2 jid
538
539 After the stream has been bound to a resource the JID can be retrieved via this
540 method.
541
542 =cut
543
544 sub jid { $_[0]->{jid} }
545
546 =head2 features
547
548 Returns the last received <features> tag in form of an L<Net::XMPP2::Node> object.
549
550 =cut
551
552 sub features { $_[0]->{features} }
553
554 #sub enable_extension {
555 # my ($self, @exts) = @_;
556 # for (@exts) {
557 # if (/^xep-(\d+)$/i) {
558 # $self->{ext}->{''.(1*$1)} = 1;
559 # }
560 # }
561 #}
562 #
563 #sub check_extension {
564 # my ($self, $extnum) = @_;
565 # return $self->{ext}->{"$extnum"} || $Net::XMPP2::EXTENSION_ENABLED{"$extnum"};
566 #}
567
568 =head1 EVENTS
569
570 These events can be registered on with C<reg_cb>:
571
572 =over 4
573
574 =item stream_features_xml => $node
575
576 This event is sent when a stream feature (<features>) tag is received. C<$node> is the
577 L<Net::XMPP2::Node> object that represents the <features> tag.
578
579 =item stream_ready => $jid
580
581 This event is sent if the XML stream has been established (and
582 resources have been bound) and is ready for transmitting regular stanzas.
583
584 C<$jid> is the bound jabber id.
585
586 =item stream_error => $error
587
588 This event is sent if a XML stream error occured. C<$error>
589 is a L<Net::XMPP2::Error::Stream> object.
590
591 =item bind_error => $error, $resource
592
593 This event is generated when the stream was unable to bind to
594 any or the in C<new> specified resource. C<$error> is a L<Net::XMPP2::Error::IQ>
595 object. C<$resource> is the errornous resource string or undef if none
596 was received.
597
598 The C<condition> of the C<$error> might be one of: 'bad-request',
599 'not-allowed' or 'conflict'.
600
601 Node: this is untested, i couldn't get the server to send a bind error
602 to test this.
603
604 =item connect => $host, $port
605
606 This event is generated when a successful connect was performed to
607 the domain passed to C<new>.
608
609 Note: C<$host> and C<$port> might be different from the domain you passed to
610 C<new> if C<connect> performed a SRV RR lookup.
611
612 If this connection is lost a C<disconnect> will be generated with the same
613 C<$host> and C<$port>.
614
615 =item disconnect => $host, $port, $message
616
617 This event is generated when the connection was lost or another error
618 occured while writing or reading from it.
619
620 C<$message> is a humand readable error message for the failure.
621 C<$host> and C<$port> were the host and port we were connected to.
622
623 Note: C<$host> and C<$port> might be different from the domain you passed to
624 C<new> if C<connect> performed a SRV RR lookup.
625
626 =item presence_xml => $node
627
628 This event is sent when a presence stanza is received. C<$node> is the
629 L<Net::XMPP2::Node> object that represents the <presence> tag.
630
631 =item message_xml => $node
632
633 This event is sent when a message stanza is received. C<$node> is the
634 L<Net::XMPP2::Node> object that represents the <message> tag.
635
636 =item iq_set_request_xml => $node, $handled_ref
637
638 =item iq_get_request_xml => $node, $handled_ref
639
640 These events are sent when an iq request stanza of type 'get' or 'set' is received.
641 C<$type> will either be 'get' or 'set' and C<$node> will be the L<Net::XMPP2::Node>
642 object of the iq tag.
643
644 If C<$$handled_ref> is true an event handler should not handle this message anymore.
645
646 If one of the event handlers handled this message the scalar pointed at by
647 the reference in C<$handled_ref> should be set to 1 true value. If C<$$handled_ref>
648 is still false after all event handlers were executed an error iq will be generated.
649
650 =back
651
652 =head1 AUTHOR
653
654 Robin Redeker, C<< <elmex at ta-sa.org> >>
655
656 =head1 COPYRIGHT & LICENSE
657
658 Copyright 2007 Robin Redeker, all rights reserved.
659
660 This program is free software; you can redistribute it and/or modify it
661 under the same terms as Perl itself.
662
663 =cut
664
665 1; # End of Net::XMPP2