Net/XMPP2/Writer.pm

package Net::XMPP2::Writer;
use warnings;
use strict;
use XML::Writer;
use Authen::SASL;
use MIME::Base64;
use Net::XMPP2::Namespaces qw/xmpp_ns/;

=head1 NAME

Net::XMPP2::Writer - A XML writer for XMPP

=head1 SYNOPSIS

   use Net::XMPP2::Writer;
   ...

=head1 METHODS

=head2 new (%args)

This methods takes following arguments:

=over 4

=item write_cb

The callback that is called when a XML stanza was completly written
and is ready for transfer. The first argument of the callback
will be the character data to send to the socket.

And calls C<init>.

=back

=cut

sub new {
   my $this = shift;
   my $class = ref($this) || $this;
   my $self = { write_cb => sub {}, @_ };
   bless $self, $class;
   $self->init;
   return $self;
}

=head2 init

(Re)initializes the writer.

=cut

sub init {
   my ($self) = @_;
   $self->{write_buf} = "";
   $self->{writer} = XML::Writer->new (OUTPUT => \$self->{write_buf}, NAMESPACES => 1);
}

=head2 flush ()

This method flushes the internal write buffer and will invoke the C<write_cb>
callback. (see also C<new ()> above)

=cut

sub flush {
   my ($self) = @_;
   $self->{write_cb}->(substr $self->{write_buf}, 0, (length $self->{write_buf}), '');
}

=head2 send_init_stream ($domain)

This method will generate a XMPP stream header. C<$domain> has to be the
domain of the server (or endpoint) we want to connect to.

=cut

sub send_init_stream {
   my ($self, $language, $domain) = @_;

   my $w = $self->{writer};
   $w->xmlDecl ('UTF-8');
   $w->addPrefix (xmpp_ns ('stream'), 'stream');
   $w->addPrefix (xmpp_ns ('client'), '');
   $w->forceNSDecl ('jabber:client');
   $w->startTag (
      [xmpp_ns ('stream'), 'stream'],
      to => $domain,
      version => '1.0',
      [xmpp_ns ('xml'), 'lang'] => $language
   );
   $self->flush;
}

=head2 send_end_of_stream

Sends end of the stream.

=cut

sub send_end_of_stream {
   my ($self) = @_;
   my $w = $self->{writer};
   $w->endTag ([xmpp_ns ('stream'), 'stream']);
   $self->flush;
}

=head2 send_sasl_auth ($mechanisms)

This methods sends the start of a SASL authentication. C<$mechanisms> is
a string with space seperated mechanisms that are supported by the other
end.

=cut

sub send_sasl_auth {
   my ($self, $mechanisms, $user, $domain, $pass) = @_;

   my $sasl = Authen::SASL->new (
      mechanism => $mechanisms,
      callback => {
         authname => $user,
         user => $user,
         pass => $pass,
      }
   );

   $self->{sasl} = $sasl->client_new ('xmpp', $domain);

   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('sasl'),   '');
   $w->startTag ([xmpp_ns ('sasl'), 'auth'], mechanism => $self->{sasl}->mechanism);
   $w->characters (MIME::Base64::encode_base64 ($self->{sasl}->client_start, ''));
   $w->endTag;
   $self->flush;
}

=head2 send_sasl_response ($challenge)

This method generated the SASL authentication response to a C<$challenge>.
You must not call this method without calling C<send_sasl_auth ()> before.

=cut

sub send_sasl_response {
   my ($self, $challenge) = @_;
   $challenge = MIME::Base64::decode_base64 ($challenge);
   my $ret = '';
   unless ($challenge =~ /rspauth=/) { # rspauth basically means: we are done
      $ret = $self->{sasl}->client_step ($challenge);
      unless ($ret) {
         die "Error in SASL authentication in client step with challenge: '$challenge'\n";
      }
   }
   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('sasl'),   '');
   $w->startTag ([xmpp_ns ('sasl'), 'response']);
   $w->characters (MIME::Base64::encode_base64 ($ret, ''));
   $w->endTag;
   $self->flush;
}

=head2 send_starttls

Sends the starttls command to the server.

=cut

sub send_starttls {
   my ($self) = @_;
   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('tls'),   '');
   $w->emptyTag ([xmpp_ns ('tls'), 'starttls']);
   $self->flush;
}

=head2 send_iq ($id, $type, $create_cb, %attrs)

This method sends an IQ stanza of type C<$type>. C<$create_cb>
will be called with an XML::Writer instance as first argument.
C<$create_cb> should be used to fill the IQ xml stanza.

C<%attrs> should have further attributes for the IQ stanza tag.
For example 'to' or 'from'. If the C<%attrs> contain a 'lang' attribute
it will be put into the 'xml' namespace.

C<$id> is the id to give this IQ stanza.

=cut

sub send_iq {
   my ($self, $id, $type, $create_cb, %attrs) = @_;
   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('bind'), '');
   my (@from) = ($self->{jid} ? (from => $self->{jid}) : ());
   if ($attrs{lang}) {
      push @from, ([ xmpp_ns ('xml'), 'lang' ] => delete $attrs{leng})
   }
   $w->startTag ('iq', id => $id, type => $type, @from, %attrs);
   $create_cb->($w);
   $w->endTag;
   $self->flush;
}

sub send_initial_presence {
   my ($self) = @_;
   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('client'), '');
   $w->emptyTag ('presence', from => $self->{jid});
   $self->flush;
}

# XXX
sub send_presence {
   my ($self, $to) = @_;
   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('client'), '');
   $w->emptyTag ('presence', from => $self->{jid}, to => $to);
   $self->flush;
}

# XXX
sub send_message {
   my ($self, $to, $type, $cb) = @_;
   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('client'), '');
   $w->startTag ('message', to => $to, from => $self->{jid}, type => $type);
   $cb->($w);
   $w->endTag;
   $self->flush;
}

=head1 AUTHOR

Robin Redeker, C<< <elmex at ta-sa.org> >>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-net-xmpp2 at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-XMPP2>.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Net::XMPP2

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Net-XMPP2>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Net-XMPP2>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-XMPP2>

=item * Search CPAN

L<http://search.cpan.org/dist/Net-XMPP2>

=back

=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2007 Robin Redeker, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of Net::XMPP2
Revision:	1.2
Committed:	Tue Jan 23 22:36:11 2007 UTC (19 years, 8 months ago) by elmex
Branch:	MAIN
Changes since 1.1:	+14 -0 lines
Log Message:	implemented TLS!
#	User	Rev	Content
1	elmex	1.1	package Net::XMPP2::Writer;
2			use warnings;
3			use strict;
4			use XML::Writer;
5			use Authen::SASL;
6			use MIME::Base64;
7			use Net::XMPP2::Namespaces qw/xmpp_ns/;
8
9			=head1 NAME
10
11			Net::XMPP2::Writer - A XML writer for XMPP
12
13			=head1 SYNOPSIS
14
15			use Net::XMPP2::Writer;
16			...
17
18			=head1 METHODS
19
20			=head2 new (%args)
21
22			This methods takes following arguments:
23
24			=over 4
25
26			=item write_cb
27
28			The callback that is called when a XML stanza was completly written
29			and is ready for transfer. The first argument of the callback
30			will be the character data to send to the socket.
31
32			And calls C<init>.
33
34			=back
35
36			=cut
37
38			sub new {
39			my $this = shift;
40			my $class = ref($this) \|\| $this;
41			my $self = { write_cb => sub {}, @_ };
42			bless $self, $class;
43			$self->init;
44			return $self;
45			}
46
47			=head2 init
48
49			(Re)initializes the writer.
50
51			=cut
52
53			sub init {
54			my ($self) = @_;
55			$self->{write_buf} = "";
56			$self->{writer} = XML::Writer->new (OUTPUT => \$self->{write_buf}, NAMESPACES => 1);
57			}
58
59			=head2 flush ()
60
61			This method flushes the internal write buffer and will invoke the C<write_cb>
62			callback. (see also C<new ()> above)
63
64			=cut
65
66			sub flush {
67			my ($self) = @_;
68			$self->{write_cb}->(substr $self->{write_buf}, 0, (length $self->{write_buf}), '');
69			}
70
71			=head2 send_init_stream ($domain)
72
73			This method will generate a XMPP stream header. C<$domain> has to be the
74			domain of the server (or endpoint) we want to connect to.
75
76			=cut
77
78			sub send_init_stream {
79			my ($self, $language, $domain) = @_;
80
81			my $w = $self->{writer};
82			$w->xmlDecl ('UTF-8');
83			$w->addPrefix (xmpp_ns ('stream'), 'stream');
84			$w->addPrefix (xmpp_ns ('client'), '');
85			$w->forceNSDecl ('jabber:client');
86			$w->startTag (
87			[xmpp_ns ('stream'), 'stream'],
88			to => $domain,
89			version => '1.0',
90			[xmpp_ns ('xml'), 'lang'] => $language
91			);
92			$self->flush;
93			}
94
95			=head2 send_end_of_stream
96
97			Sends end of the stream.
98
99			=cut
100
101			sub send_end_of_stream {
102			my ($self) = @_;
103			my $w = $self->{writer};
104			$w->endTag ([xmpp_ns ('stream'), 'stream']);
105			$self->flush;
106			}
107
108			=head2 send_sasl_auth ($mechanisms)
109
110			This methods sends the start of a SASL authentication. C<$mechanisms> is
111			a string with space seperated mechanisms that are supported by the other
112			end.
113
114			=cut
115
116			sub send_sasl_auth {
117			my ($self, $mechanisms, $user, $domain, $pass) = @_;
118
119			my $sasl = Authen::SASL->new (
120			mechanism => $mechanisms,
121			callback => {
122			authname => $user,
123			user => $user,
124			pass => $pass,
125			}
126			);
127
128			$self->{sasl} = $sasl->client_new ('xmpp', $domain);
129
130			my $w = $self->{writer};
131			$w->addPrefix (xmpp_ns ('sasl'), '');
132			$w->startTag ([xmpp_ns ('sasl'), 'auth'], mechanism => $self->{sasl}->mechanism);
133			$w->characters (MIME::Base64::encode_base64 ($self->{sasl}->client_start, ''));
134			$w->endTag;
135			$self->flush;
136			}
137
138			=head2 send_sasl_response ($challenge)
139
140			This method generated the SASL authentication response to a C<$challenge>.
141			You must not call this method without calling C<send_sasl_auth ()> before.
142
143			=cut
144
145			sub send_sasl_response {
146			my ($self, $challenge) = @_;
147			$challenge = MIME::Base64::decode_base64 ($challenge);
148			my $ret = '';
149			unless ($challenge =~ /rspauth=/) { # rspauth basically means: we are done
150			$ret = $self->{sasl}->client_step ($challenge);
151			unless ($ret) {
152			die "Error in SASL authentication in client step with challenge: '$challenge'\n";
153			}
154			}
155			my $w = $self->{writer};
156			$w->addPrefix (xmpp_ns ('sasl'), '');
157			$w->startTag ([xmpp_ns ('sasl'), 'response']);
158			$w->characters (MIME::Base64::encode_base64 ($ret, ''));
159			$w->endTag;
160			$self->flush;
161			}
162
163	elmex	1.2	=head2 send_starttls
164
165			Sends the starttls command to the server.
166
167			=cut
168
169			sub send_starttls {
170			my ($self) = @_;
171			my $w = $self->{writer};
172			$w->addPrefix (xmpp_ns ('tls'), '');
173			$w->emptyTag ([xmpp_ns ('tls'), 'starttls']);
174			$self->flush;
175			}
176
177	elmex	1.1	=head2 send_iq ($id, $type, $create_cb, %attrs)
178
179			This method sends an IQ stanza of type C<$type>. C<$create_cb>
180			will be called with an XML::Writer instance as first argument.
181			C<$create_cb> should be used to fill the IQ xml stanza.
182
183			C<%attrs> should have further attributes for the IQ stanza tag.
184			For example 'to' or 'from'. If the C<%attrs> contain a 'lang' attribute
185			it will be put into the 'xml' namespace.
186
187			C<$id> is the id to give this IQ stanza.
188
189			=cut
190
191			sub send_iq {
192			my ($self, $id, $type, $create_cb, %attrs) = @_;
193			my $w = $self->{writer};
194			$w->addPrefix (xmpp_ns ('bind'), '');
195			my (@from) = ($self->{jid} ? (from => $self->{jid}) : ());
196			if ($attrs{lang}) {
197			push @from, ([ xmpp_ns ('xml'), 'lang' ] => delete $attrs{leng})
198			}
199			$w->startTag ('iq', id => $id, type => $type, @from, %attrs);
200			$create_cb->($w);
201			$w->endTag;
202			$self->flush;
203			}
204
205			sub send_initial_presence {
206			my ($self) = @_;
207			my $w = $self->{writer};
208			$w->addPrefix (xmpp_ns ('client'), '');
209			$w->emptyTag ('presence', from => $self->{jid});
210			$self->flush;
211			}
212
213			# XXX
214			sub send_presence {
215			my ($self, $to) = @_;
216			my $w = $self->{writer};
217			$w->addPrefix (xmpp_ns ('client'), '');
218			$w->emptyTag ('presence', from => $self->{jid}, to => $to);
219			$self->flush;
220			}
221
222			# XXX
223			sub send_message {
224			my ($self, $to, $type, $cb) = @_;
225			my $w = $self->{writer};
226			$w->addPrefix (xmpp_ns ('client'), '');
227			$w->startTag ('message', to => $to, from => $self->{jid}, type => $type);
228			$cb->($w);
229			$w->endTag;
230			$self->flush;
231			}
232
233			=head1 AUTHOR
234
235			Robin Redeker, C<< <elmex at ta-sa.org> >>
236
237			=head1 BUGS
238
239			Please report any bugs or feature requests to
240			C<bug-net-xmpp2 at rt.cpan.org>, or through the web interface at
241			L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-XMPP2>.
242			I will be notified, and then you'll automatically be notified of progress on
243			your bug as I make changes.
244
245			=head1 SUPPORT
246
247			You can find documentation for this module with the perldoc command.
248
249			perldoc Net::XMPP2
250
251			You can also look for information at:
252
253			=over 4
254
255			=item * AnnoCPAN: Annotated CPAN documentation
256
257			L<http://annocpan.org/dist/Net-XMPP2>
258
259			=item * CPAN Ratings
260
261			L<http://cpanratings.perl.org/d/Net-XMPP2>
262
263			=item * RT: CPAN's request tracker
264
265			L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-XMPP2>
266
267			=item * Search CPAN
268
269			L<http://search.cpan.org/dist/Net-XMPP2>
270
271			=back
272
273			=head1 ACKNOWLEDGEMENTS
274
275			=head1 COPYRIGHT & LICENSE
276
277			Copyright 2007 Robin Redeker, all rights reserved.
278
279			This program is free software; you can redistribute it and/or modify it
280			under the same terms as Perl itself.
281
282			=cut
283
284			1; # End of Net::XMPP2