Net/XMPP2/Writer.pm

package Net::XMPP2::Writer;
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 DESCRIPTION

This module contains some helper functions for writing XMPP "XML",
which is not real XML at all ;-( I use L<XML::Writer> and tune it
until it creates "XML" that is accepted by most servers propably
(all of the XMPP servers i tested yet work (jabberd14, jabberd2, ejabberd).

I hope the semantics of L<XML::Writer> don't change much over the future,
but if they do and you run into problems, please report them!

The whole "XML" concept of XMPP is fundamentally broken anyway. It's supposed
to be an subset of XML. But a subset of XML productions is not XML. Strictly
speaking you need a special XMPP "XML" parser and writer to be 100% conformant.

On top of that XMPP B<requires> you to parse these partial "XML" documents.
But a partial XML document is not well-formed, heck, it's not even a XML document!.
And a parser should bail out with an error. But XMPP doesn't care, it just relies on
implementation dependend behaviour of chunked parsing modes for SAX parsing.
This functionality isn't even specified by the XML recommendation in any way.
The recommendation even says that it's undefined what happens if you process
not-well-formed XML documents.

But I try to be as "XML" XMPP conformant as possible (it should be around 99-100%).
But it's hard to say what XML is conformant, as the specifications of XMPP "XML" and XML
are contradicting. For example XMPP also says you only have to generated and accept
utf-8 encodings of XML, but the XML recommendation says that each parser has
to accept utf-8 B<and> utf-16. So, what do you do? Do you use a XML conformant parser
or do you write your own?

I'm using XML::Parser::Expat because expat knows how to parse broken (aka 'partial')
"XML" documents, as XMPP requires. Another argument is that if you capture a XMPP
conversation to the end, and even if a '</stream:stream>' tag was captured, you
wont have a valid XML document. The problem is that you have to resent a <stream> tag
after TLS and SASL authentication each! Awww... I'm repeating myself.

But well... Net::XMPP2 does it's best with expat to cope with the fundamental brokeness
of "XML" in XMPP.

Back to the issue with "XML" generation: I've discoverd that many XMPP servers (eg.
jabberd14 and ejabberd) have problems with XML namespaces. Thats the reason why
I'm assigning the namespace prefixes manually: The servers just don't accept validly
namespaced XML. The draft 3921bis does even state that a client SHOULD generate a 'stream'
prefix for the <stream> tag.

I advice you to explictly set the namespaces too if you generate "XML" for XMPP yourself,
at least until all or most of the XMPP servers have been fixed. Which might take some
years :-) And maybe will happen never.

And another note: As XMPP requires all predefined entity characters to be escaped
in character data you need a "XML" writer that will escape everything:

   RFC 3920 - 11.1.  Restrictions:

     character data or attribute values containing unescaped characters
     that map to the predefined entities (Section 4.6 therein);
     such characters MUST be escaped

This means:
You have to escape '>' in the character data. I don't know whether XML::Writer
does that. And I honestly don't care much about this. XMPP is broken by design and
I have barely time to writer my own XML parsers and writers to suit their sick taste
of "XML". (Do I repeat myself?)

I would be happy if they finally say (in RFC3920): "XMPP is NOT XML. It's just
XML-like, and some XML utilities allow you to process this kind of XML.".

=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.

=back

And calls C<init>.

=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 (xmpp_ns ('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 => {
 # XXX: removed authname, because it ensures maximum connectivitiy
 #      along multiple server implementations - XMPP is such a crap
 #        authname => $user . '@' . $domain,
         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> (to be compliant
only use: 'get', 'set', 'result' and 'error'). 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.
If C<$create_cb> is undefined an empty tag will be generated.

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 and is mandatory in this API.

=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})
   }
   push @from, (id => $id) if defined $id;
   if (defined $create_cb) {
      $w->startTag ('iq', type => $type, @from, %attrs);
      $create_cb->($w);
      $w->endTag;
   } else {
      $w->emptyTag ('iq', type => $type, @from, %attrs);
   }
   $self->flush;
}

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

Sends a presence stanza.

C<$create_cb> has the same meaning as for C<send_iq>.
C<%attrs> will let you pass further optional arguments like 'to'.

C<$type> is the type of the presence, which may be one of:

   unavailable, subscribe, subscribed, unsubscribe, unsubscribed, probe, error

Or something completly different if you don't like the RFC 3921 :-)

C<%attrs> contains further attributes for the presence tag or may contain one of the
following exceptional keys:

If C<%attrs> contains a 'show' key: a child xml tag with that name will be geenerated
with the value as the content, which should be one of 'away', 'chat', 'dnd' and 'xa'.

If C<%attrs> contains a 'status' key: a child xml tag with that name will be generated
with the value as content. If the value of the 'status' key is an hash reference
the keys will be interpreted as language identifiers for the xml:lang attribute
of each status element. If one of these keys is the empty string '' no xml:lang attribute
will be generated for it. The values will be the character content of the status tags.

If C<%attrs> contains a 'priority' key: a child xml tag with that name will be generated
with the value as content, which must be a number between -128 and +127.

Note: If C<$create_cb> is undefined and one of the above attributes (show,
status or priority) were given, the generates presence tag won't be empty.

=cut

sub _generate_key_xml {
   my ($w, $key, $value) = @_;
   $w->startTag ($key);
   $w->characters ($value);
   $w->endTag;
}

sub _generate_key_xmls {
   my ($w, $key, $value) = @_;
   if (ref ($value) eq 'HASH') {
      for (keys %$value) {
         $w->startTag ($key, ($_ ne '' ? ([xmpp_ns ('xml'), 'lang'] => $_) : ()));
         $w->characters ($value->{$_});
         $w->endTag;
      }
   } else {
      $w->startTag ($key);
      $w->characters ($value);
      $w->endTag;
   }
}

sub send_presence {
   my ($self, $id, $type, $create_cb, %attrs) = @_;

   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('client'), '');

   my @add;
   push @add, (type => $type) if defined $type;
   push @add, (id => $id) if defined $id;

   my %fattrs =
      map { $_ => $attrs{$_} }
         grep { my $k = $_; not grep { $k eq $_ } qw/show priority status/ }
            keys %attrs;

   if (defined $create_cb) {
      $w->startTag ('presence', @add, %fattrs);
      _generate_key_xml ($w, show => $attrs{show})         if defined $attrs{show};
      _generate_key_xml ($w, priority => $attrs{priority}) if defined $attrs{priority};
      _generate_key_xmls ($w, status => $attrs{status})    if defined $attrs{status};
      $create_cb->($w);
      $w->endTag;
   } else {
      if (exists $attrs{show} or $attrs{priority} or $attrs{status}) {
         $w->startTag ('presence', @add, %fattrs);
         _generate_key_xml ($w, show => $attrs{show})         if defined $attrs{show};
         _generate_key_xml ($w, priority => $attrs{priority}) if defined $attrs{priority};
         _generate_key_xmls ($w, status => $attrs{status})    if defined $attrs{status};
         $w->endTag;
      } else {
         $w->emptyTag ('presence', @add, %fattrs);
      }
   }

   $self->flush;
}

=head2 send_message ($id, $to, $type, $create_cb, %attrs)

Sends a message stanza.

C<$to> is the destination JID of the message. C<$type> is
the type of the message, and if C<$type> is undefined it will default to 'chat'.
C<$type> must be one of the following: 'chat', 'error', 'groupchat', 'headline'
or 'normal'.

C<$create_cb> has the same meaning as in C<send_iq>.

C<%attrs> contains further attributes for the message tag or may contain one of the
following exceptional keys:

If C<%attrs> contains a 'body' key: a child xml tag with that name will be generated
with the value as content. If the value of the 'body' key is an hash reference
the keys will be interpreted as language identifiers for the xml:lang attribute
of each body element. If one of these keys is the empty string '' no xml:lang attribute
will be generated for it. The values will be the character content of the body tags.

If C<%attrs> contains a 'subject' key: a child xml tag with that name will be generated
with the value as content. If the value of the 'subject' key is an hash reference
the keys will be interpreted as language identifiers for the xml:lang attribute
of each subject element. If one of these keys is the empty string '' no xml:lang attribute
will be generated for it. The values will be the character content of the subject tags.

If C<%attrs> contains a 'thread' key: a child xml tag with that name will be generated
and the value will be the character content.

=cut

sub send_message {
   my ($self, $id, $to, $type, $create_cb, %attrs) = @_;

   my $w = $self->{writer};
   $w->addPrefix (xmpp_ns ('client'), '');

   my @add;
   push @add, (id => $id) if defined $id;

   $type ||= 'chat';

   my %fattrs =
      map { $_ => $attrs{$_} }
         grep { my $k = $_; not grep { $k eq $_ } qw/subject body thread/ }
            keys %attrs;

   if (defined $create_cb) {
      $w->startTag ('message', @add, to => $to, type => $type, %fattrs);
      _generate_key_xmls ($w, subject => $attrs{subject})    if defined $attrs{subject};
      _generate_key_xmls ($w, body => $attrs{body})          if defined $attrs{body};
      _generate_key_xml ($w, thread => $attrs{thread})       if defined $attrs{thread};
      $create_cb->($w);
      $w->endTag;
   } else {
      if (exists $attrs{subject} or $attrs{body} or $attrs{thread}) {
         $w->startTag ('message', @add, to => $to, type => $type, %fattrs);
         _generate_key_xmls ($w, subject => $attrs{subject})    if defined $attrs{subject};
         _generate_key_xmls ($w, body => $attrs{body})          if defined $attrs{body};
         _generate_key_xml ($w, thread => $attrs{thread})       if defined $attrs{thread};
         $w->endTag;
      } else {
         $w->emptyTag ('message', @add, to => $to, type => $type, %fattrs);
      }
   }

   $self->flush;
}


=head2 write_error_tag ($error_stanza_node, $error_type, $error)

C<$error_type> is one of 'cancel', 'continue', 'modify', 'auth' and 'wait'.
C<$error> is the name of the error tag child element. If C<$error> is one of
the following:

   'bad-request', 'conflict', 'feature-not-implemented', 'forbidden', 'gone',
   'internal-server-error', 'item-not-found', 'jid-malformed', 'not-acceptable',
   'not-allowed', 'not-authorized', 'payment-required', 'recipient-unavailable',
   'redirect', 'registration-required', 'remote-server-not-found',
   'remote-server-timeout', 'resource-constraint', 'service-unavailable',
   'subscription-required', 'undefined-condition', 'unexpected-request'

then a default can be select for C<$error_type>, and the argument can be undefined.

Note: This method is currently a bit limited in the generation of the xml
for the errors, if you need more please contact me.

=cut

our %STANZA_ERRORS = (
   'bad-request'             => ['modify', 400],
   'conflict'                => ['cancel', 409],
   'feature-not-implemented' => ['cancel', 501],
   'forbidden'               => ['auth',   403],
   'gone'                    => ['modify', 302],
   'internal-server-error'   => ['wait',   500],
   'item-not-found'          => ['cancel', 404],
   'jid-malformed'           => ['modify', 400],
   'not-acceptable'          => ['modify', 406],
   'not-allowed'             => ['cancel', 405],
   'not-authorized'          => ['auth',   401],
   'payment-required'        => ['auth',   402],
   'recipient-unavailable'   => ['wait',   404],
   'redirect'                => ['modify', 302],
   'registration-required'   => ['auth',   407],
   'remote-server-not-found' => ['cancel', 404],
   'remote-server-timeout'   => ['wait',   504],
   'resource-constraint'     => ['wait',   500],
   'service-unavailable'     => ['cancel', 503],
   'subscription-required'   => ['auth',   407],
   'undefined-condition'     => ['cancel', 500],
   'unexpected-request'      => ['wait',   400],
);

sub write_error_tag {
   my ($self, $errstanza, $type, $error) = @_;

   my $w = $self->{writer};

   $_->write_on ($w) for $errstanza->nodes;

   my @add;

   unless (defined $type and defined $STANZA_ERRORS{$error}) {
      $type = $STANZA_ERRORS{$error}->[0];
   }

   push @add, (code => $STANZA_ERRORS{$error}->[1]);

   $w->addPrefix (xmpp_ns ('client'), '');
   $w->startTag ([xmpp_ns ('client') => 'error'], type => $type, @add);
      $w->addPrefix (xmpp_ns ('stanzas'), '');
      $w->emptyTag ([xmpp_ns ('stanzas') => $error]);
   $w->endTag;
}

=head1 AUTHOR

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

=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.15
Committed:	Mon Jun 25 07:56:52 2007 UTC (19 years, 3 months ago) by elmex
Branch:	MAIN
Changes since 1.14:	+3 -1 lines
Log Message:	sime fixes and changes
#	User	Rev	Content
1	elmex	1.1	package Net::XMPP2::Writer;
2			use strict;
3			use XML::Writer;
4			use Authen::SASL;
5			use MIME::Base64;
6			use Net::XMPP2::Namespaces qw/xmpp_ns/;
7
8			=head1 NAME
9
10	elmex	1.5	Net::XMPP2::Writer - A "XML" writer for XMPP
11	elmex	1.1
12			=head1 SYNOPSIS
13
14			use Net::XMPP2::Writer;
15			...
16
17	elmex	1.3	=head1 DESCRIPTION
18
19	elmex	1.5	This module contains some helper functions for writing XMPP "XML",
20	elmex	1.3	which is not real XML at all ;-( I use L<XML::Writer> and tune it
21	elmex	1.5	until it creates "XML" that is accepted by most servers propably
22	elmex	1.3	(all of the XMPP servers i tested yet work (jabberd14, jabberd2, ejabberd).
23
24			I hope the semantics of L<XML::Writer> don't change much over the future,
25			but if they do and you run into problems, please report them!
26
27	elmex	1.5	The whole "XML" concept of XMPP is fundamentally broken anyway. It's supposed
28	elmex	1.3	to be an subset of XML. But a subset of XML productions is not XML. Strictly
29	elmex	1.5	speaking you need a special XMPP "XML" parser and writer to be 100% conformant.
30	elmex	1.3
31	elmex	1.14	On top of that XMPP B<requires> you to parse these partial "XML" documents.
32	elmex	1.10	But a partial XML document is not well-formed, heck, it's not even a XML document!.
33			And a parser should bail out with an error. But XMPP doesn't care, it just relies on
34			implementation dependend behaviour of chunked parsing modes for SAX parsing.
35			This functionality isn't even specified by the XML recommendation in any way.
36			The recommendation even says that it's undefined what happens if you process
37			not-well-formed XML documents.
38
39	elmex	1.9	But I try to be as "XML" XMPP conformant as possible (it should be around 99-100%).
40	elmex	1.5	But it's hard to say what XML is conformant, as the specifications of XMPP "XML" and XML
41	elmex	1.3	are contradicting. For example XMPP also says you only have to generated and accept
42			utf-8 encodings of XML, but the XML recommendation says that each parser has
43	elmex	1.14	to accept utf-8 B<and> utf-16. So, what do you do? Do you use a XML conformant parser
44	elmex	1.3	or do you write your own?
45
46	elmex	1.5	I'm using XML::Parser::Expat because expat knows how to parse broken (aka 'partial')
47			"XML" documents, as XMPP requires. Another argument is that if you capture a XMPP
48	elmex	1.3	conversation to the end, and even if a '</stream:stream>' tag was captured, you
49			wont have a valid XML document. The problem is that you have to resent a <stream> tag
50	elmex	1.10	after TLS and SASL authentication each! Awww... I'm repeating myself.
51	elmex	1.3
52			But well... Net::XMPP2 does it's best with expat to cope with the fundamental brokeness
53	elmex	1.5	of "XML" in XMPP.
54	elmex	1.3
55	elmex	1.5	Back to the issue with "XML" generation: I've discoverd that many XMPP servers (eg.
56	elmex	1.3	jabberd14 and ejabberd) have problems with XML namespaces. Thats the reason why
57	elmex	1.9	I'm assigning the namespace prefixes manually: The servers just don't accept validly
58	elmex	1.3	namespaced XML. The draft 3921bis does even state that a client SHOULD generate a 'stream'
59			prefix for the <stream> tag.
60
61	elmex	1.5	I advice you to explictly set the namespaces too if you generate "XML" for XMPP yourself,
62	elmex	1.3	at least until all or most of the XMPP servers have been fixed. Which might take some
63			years :-) And maybe will happen never.
64
65	elmex	1.5	And another note: As XMPP requires all predefined entity characters to be escaped
66			in character data you need a "XML" writer that will escape everything:
67
68			RFC 3920 - 11.1. Restrictions:
69
70			character data or attribute values containing unescaped characters
71			that map to the predefined entities (Section 4.6 therein);
72			such characters MUST be escaped
73
74			This means:
75			You have to escape '>' in the character data. I don't know whether XML::Writer
76	elmex	1.9	does that. And I honestly don't care much about this. XMPP is broken by design and
77			I have barely time to writer my own XML parsers and writers to suit their sick taste
78			of "XML". (Do I repeat myself?)
79	elmex	1.5
80	elmex	1.10	I would be happy if they finally say (in RFC3920): "XMPP is NOT XML. It's just
81			XML-like, and some XML utilities allow you to process this kind of XML.".
82
83	elmex	1.1	=head1 METHODS
84
85			=head2 new (%args)
86
87			This methods takes following arguments:
88
89			=over 4
90
91			=item write_cb
92
93			The callback that is called when a XML stanza was completly written
94			and is ready for transfer. The first argument of the callback
95			will be the character data to send to the socket.
96
97	elmex	1.9	=back
98
99	elmex	1.1	And calls C<init>.
100
101			=cut
102
103			sub new {
104			my $this = shift;
105			my $class = ref($this) \|\| $this;
106			my $self = { write_cb => sub {}, @_ };
107			bless $self, $class;
108			$self->init;
109			return $self;
110			}
111
112			=head2 init
113
114			(Re)initializes the writer.
115
116			=cut
117
118			sub init {
119			my ($self) = @_;
120			$self->{write_buf} = "";
121			$self->{writer} = XML::Writer->new (OUTPUT => \$self->{write_buf}, NAMESPACES => 1);
122			}
123
124			=head2 flush ()
125
126			This method flushes the internal write buffer and will invoke the C<write_cb>
127			callback. (see also C<new ()> above)
128
129			=cut
130
131			sub flush {
132			my ($self) = @_;
133			$self->{write_cb}->(substr $self->{write_buf}, 0, (length $self->{write_buf}), '');
134			}
135
136			=head2 send_init_stream ($domain)
137
138			This method will generate a XMPP stream header. C<$domain> has to be the
139			domain of the server (or endpoint) we want to connect to.
140
141			=cut
142
143			sub send_init_stream {
144			my ($self, $language, $domain) = @_;
145
146			my $w = $self->{writer};
147			$w->xmlDecl ('UTF-8');
148			$w->addPrefix (xmpp_ns ('stream'), 'stream');
149			$w->addPrefix (xmpp_ns ('client'), '');
150	elmex	1.9	$w->forceNSDecl (xmpp_ns ('client'));
151	elmex	1.1	$w->startTag (
152			[xmpp_ns ('stream'), 'stream'],
153			to => $domain,
154			version => '1.0',
155			[xmpp_ns ('xml'), 'lang'] => $language
156			);
157			$self->flush;
158			}
159
160			=head2 send_end_of_stream
161
162			Sends end of the stream.
163
164			=cut
165
166			sub send_end_of_stream {
167			my ($self) = @_;
168			my $w = $self->{writer};
169			$w->endTag ([xmpp_ns ('stream'), 'stream']);
170			$self->flush;
171			}
172
173			=head2 send_sasl_auth ($mechanisms)
174
175			This methods sends the start of a SASL authentication. C<$mechanisms> is
176			a string with space seperated mechanisms that are supported by the other
177			end.
178
179			=cut
180
181			sub send_sasl_auth {
182			my ($self, $mechanisms, $user, $domain, $pass) = @_;
183
184			my $sasl = Authen::SASL->new (
185			mechanism => $mechanisms,
186			callback => {
187	elmex	1.15	# XXX: removed authname, because it ensures maximum connectivitiy
188			# along multiple server implementations - XMPP is such a crap
189			# authname => $user . '@' . $domain,
190	elmex	1.1	user => $user,
191			pass => $pass,
192			}
193			);
194
195			$self->{sasl} = $sasl->client_new ('xmpp', $domain);
196
197			my $w = $self->{writer};
198			$w->addPrefix (xmpp_ns ('sasl'), '');
199			$w->startTag ([xmpp_ns ('sasl'), 'auth'], mechanism => $self->{sasl}->mechanism);
200			$w->characters (MIME::Base64::encode_base64 ($self->{sasl}->client_start, ''));
201			$w->endTag;
202			$self->flush;
203			}
204
205			=head2 send_sasl_response ($challenge)
206
207			This method generated the SASL authentication response to a C<$challenge>.
208			You must not call this method without calling C<send_sasl_auth ()> before.
209
210			=cut
211
212			sub send_sasl_response {
213			my ($self, $challenge) = @_;
214			$challenge = MIME::Base64::decode_base64 ($challenge);
215			my $ret = '';
216			unless ($challenge =~ /rspauth=/) { # rspauth basically means: we are done
217			$ret = $self->{sasl}->client_step ($challenge);
218			unless ($ret) {
219			die "Error in SASL authentication in client step with challenge: '$challenge'\n";
220			}
221			}
222			my $w = $self->{writer};
223			$w->addPrefix (xmpp_ns ('sasl'), '');
224			$w->startTag ([xmpp_ns ('sasl'), 'response']);
225			$w->characters (MIME::Base64::encode_base64 ($ret, ''));
226			$w->endTag;
227			$self->flush;
228			}
229
230	elmex	1.2	=head2 send_starttls
231
232			Sends the starttls command to the server.
233
234			=cut
235
236			sub send_starttls {
237			my ($self) = @_;
238			my $w = $self->{writer};
239			$w->addPrefix (xmpp_ns ('tls'), '');
240			$w->emptyTag ([xmpp_ns ('tls'), 'starttls']);
241			$self->flush;
242			}
243
244	elmex	1.1	=head2 send_iq ($id, $type, $create_cb, %attrs)
245
246	elmex	1.3	This method sends an IQ stanza of type C<$type> (to be compliant
247			only use: 'get', 'set', 'result' and 'error'). C<$create_cb>
248	elmex	1.1	will be called with an XML::Writer instance as first argument.
249			C<$create_cb> should be used to fill the IQ xml stanza.
250	elmex	1.3	If C<$create_cb> is undefined an empty tag will be generated.
251	elmex	1.1
252			C<%attrs> should have further attributes for the IQ stanza tag.
253			For example 'to' or 'from'. If the C<%attrs> contain a 'lang' attribute
254			it will be put into the 'xml' namespace.
255
256	elmex	1.3	C<$id> is the id to give this IQ stanza and is mandatory in this API.
257	elmex	1.1
258			=cut
259
260			sub send_iq {
261			my ($self, $id, $type, $create_cb, %attrs) = @_;
262			my $w = $self->{writer};
263			$w->addPrefix (xmpp_ns ('bind'), '');
264			my (@from) = ($self->{jid} ? (from => $self->{jid}) : ());
265			if ($attrs{lang}) {
266			push @from, ([ xmpp_ns ('xml'), 'lang' ] => delete $attrs{leng})
267			}
268	elmex	1.6	push @from, (id => $id) if defined $id;
269	elmex	1.3	if (defined $create_cb) {
270	elmex	1.6	$w->startTag ('iq', type => $type, @from, %attrs);
271	elmex	1.3	$create_cb->($w);
272			$w->endTag;
273			} else {
274	elmex	1.6	$w->emptyTag ('iq', type => $type, @from, %attrs);
275	elmex	1.3	}
276			$self->flush;
277			}
278
279			=head2 send_presence ($id, $type, $create_cb, %attrs)
280
281			Sends a presence stanza.
282
283			C<$create_cb> has the same meaning as for C<send_iq>.
284			C<%attrs> will let you pass further optional arguments like 'to'.
285
286			C<$type> is the type of the presence, which may be one of:
287
288			unavailable, subscribe, subscribed, unsubscribe, unsubscribed, probe, error
289
290			Or something completly different if you don't like the RFC 3921 :-)
291
292			C<%attrs> contains further attributes for the presence tag or may contain one of the
293			following exceptional keys:
294
295			If C<%attrs> contains a 'show' key: a child xml tag with that name will be geenerated
296			with the value as the content, which should be one of 'away', 'chat', 'dnd' and 'xa'.
297
298			If C<%attrs> contains a 'status' key: a child xml tag with that name will be generated
299			with the value as content. If the value of the 'status' key is an hash reference
300			the keys will be interpreted as language identifiers for the xml:lang attribute
301			of each status element. If one of these keys is the empty string '' no xml:lang attribute
302			will be generated for it. The values will be the character content of the status tags.
303
304			If C<%attrs> contains a 'priority' key: a child xml tag with that name will be generated
305			with the value as content, which must be a number between -128 and +127.
306
307			Note: If C<$create_cb> is undefined and one of the above attributes (show,
308			status or priority) were given, the generates presence tag won't be empty.
309
310			=cut
311
312			sub _generate_key_xml {
313			my ($w, $key, $value) = @_;
314			$w->startTag ($key);
315			$w->characters ($value);
316	elmex	1.1	$w->endTag;
317			}
318
319	elmex	1.3	sub _generate_key_xmls {
320			my ($w, $key, $value) = @_;
321			if (ref ($value) eq 'HASH') {
322			for (keys %$value) {
323	elmex	1.11	$w->startTag ($key, ($_ ne '' ? ([xmpp_ns ('xml'), 'lang'] => $_) : ()));
324	elmex	1.3	$w->characters ($value->{$_});
325			$w->endTag;
326			}
327			} else {
328			$w->startTag ($key);
329			$w->characters ($value);
330			$w->endTag;
331			}
332	elmex	1.1	}
333
334			sub send_presence {
335	elmex	1.4	my ($self, $id, $type, $create_cb, %attrs) = @_;
336	elmex	1.3
337	elmex	1.1	my $w = $self->{writer};
338			$w->addPrefix (xmpp_ns ('client'), '');
339	elmex	1.3
340			my @add;
341	elmex	1.4	push @add, (type => $type) if defined $type;
342			push @add, (id => $id) if defined $id;
343	elmex	1.3
344	elmex	1.7	my %fattrs =
345			map { $_ => $attrs{$_} }
346	elmex	1.12	grep { my $k = $_; not grep { $k eq $_ } qw/show priority status/ }
347	elmex	1.7	keys %attrs;
348
349	elmex	1.3	if (defined $create_cb) {
350	elmex	1.7	$w->startTag ('presence', @add, %fattrs);
351			_generate_key_xml ($w, show => $attrs{show}) if defined $attrs{show};
352			_generate_key_xml ($w, priority => $attrs{priority}) if defined $attrs{priority};
353			_generate_key_xmls ($w, status => $attrs{status}) if defined $attrs{status};
354	elmex	1.3	$create_cb->($w);
355			$w->endTag;
356			} else {
357			if (exists $attrs{show} or $attrs{priority} or $attrs{status}) {
358	elmex	1.7	$w->startTag ('presence', @add, %fattrs);
359			_generate_key_xml ($w, show => $attrs{show}) if defined $attrs{show};
360			_generate_key_xml ($w, priority => $attrs{priority}) if defined $attrs{priority};
361			_generate_key_xmls ($w, status => $attrs{status}) if defined $attrs{status};
362	elmex	1.3	$w->endTag;
363			} else {
364	elmex	1.7	$w->emptyTag ('presence', @add, %fattrs);
365	elmex	1.3	}
366			}
367
368	elmex	1.1	$self->flush;
369			}
370
371	elmex	1.3	=head2 send_message ($id, $to, $type, $create_cb, %attrs)
372
373			Sends a message stanza.
374
375			C<$to> is the destination JID of the message. C<$type> is
376	elmex	1.6	the type of the message, and if C<$type> is undefined it will default to 'chat'.
377	elmex	1.3	C<$type> must be one of the following: 'chat', 'error', 'groupchat', 'headline'
378			or 'normal'.
379
380			C<$create_cb> has the same meaning as in C<send_iq>.
381
382			C<%attrs> contains further attributes for the message tag or may contain one of the
383			following exceptional keys:
384
385			If C<%attrs> contains a 'body' key: a child xml tag with that name will be generated
386			with the value as content. If the value of the 'body' key is an hash reference
387			the keys will be interpreted as language identifiers for the xml:lang attribute
388			of each body element. If one of these keys is the empty string '' no xml:lang attribute
389			will be generated for it. The values will be the character content of the body tags.
390
391			If C<%attrs> contains a 'subject' key: a child xml tag with that name will be generated
392			with the value as content. If the value of the 'subject' key is an hash reference
393			the keys will be interpreted as language identifiers for the xml:lang attribute
394			of each subject element. If one of these keys is the empty string '' no xml:lang attribute
395			will be generated for it. The values will be the character content of the subject tags.
396
397			If C<%attrs> contains a 'thread' key: a child xml tag with that name will be generated
398			and the value will be the character content.
399
400			=cut
401
402	elmex	1.1	sub send_message {
403	elmex	1.4	my ($self, $id, $to, $type, $create_cb, %attrs) = @_;
404	elmex	1.3
405	elmex	1.1	my $w = $self->{writer};
406			$w->addPrefix (xmpp_ns ('client'), '');
407	elmex	1.3
408	elmex	1.4	my @add;
409			push @add, (id => $id) if defined $id;
410
411	elmex	1.3	$type \|\|= 'chat';
412
413	elmex	1.7	my %fattrs =
414			map { $_ => $attrs{$_} }
415	elmex	1.12	grep { my $k = $_; not grep { $k eq $_ } qw/subject body thread/ }
416	elmex	1.7	keys %attrs;
417
418	elmex	1.3	if (defined $create_cb) {
419	elmex	1.7	$w->startTag ('message', @add, to => $to, type => $type, %fattrs);
420			_generate_key_xmls ($w, subject => $attrs{subject}) if defined $attrs{subject};
421			_generate_key_xmls ($w, body => $attrs{body}) if defined $attrs{body};
422			_generate_key_xml ($w, thread => $attrs{thread}) if defined $attrs{thread};
423	elmex	1.3	$create_cb->($w);
424			$w->endTag;
425			} else {
426			if (exists $attrs{subject} or $attrs{body} or $attrs{thread}) {
427	elmex	1.7	$w->startTag ('message', @add, to => $to, type => $type, %fattrs);
428			_generate_key_xmls ($w, subject => $attrs{subject}) if defined $attrs{subject};
429			_generate_key_xmls ($w, body => $attrs{body}) if defined $attrs{body};
430			_generate_key_xml ($w, thread => $attrs{thread}) if defined $attrs{thread};
431	elmex	1.3	$w->endTag;
432			} else {
433	elmex	1.7	$w->emptyTag ('message', @add, to => $to, type => $type, %fattrs);
434	elmex	1.3	}
435			}
436
437	elmex	1.1	$self->flush;
438			}
439
440	elmex	1.4
441			=head2 write_error_tag ($error_stanza_node, $error_type, $error)
442
443			C<$error_type> is one of 'cancel', 'continue', 'modify', 'auth' and 'wait'.
444			C<$error> is the name of the error tag child element. If C<$error> is one of
445			the following:
446
447			'bad-request', 'conflict', 'feature-not-implemented', 'forbidden', 'gone',
448			'internal-server-error', 'item-not-found', 'jid-malformed', 'not-acceptable',
449			'not-allowed', 'not-authorized', 'payment-required', 'recipient-unavailable',
450			'redirect', 'registration-required', 'remote-server-not-found',
451			'remote-server-timeout', 'resource-constraint', 'service-unavailable',
452			'subscription-required', 'undefined-condition', 'unexpected-request'
453
454			then a default can be select for C<$error_type>, and the argument can be undefined.
455
456			Note: This method is currently a bit limited in the generation of the xml
457			for the errors, if you need more please contact me.
458
459			=cut
460
461			our %STANZA_ERRORS = (
462			'bad-request' => ['modify', 400],
463			'conflict' => ['cancel', 409],
464			'feature-not-implemented' => ['cancel', 501],
465			'forbidden' => ['auth', 403],
466			'gone' => ['modify', 302],
467			'internal-server-error' => ['wait', 500],
468			'item-not-found' => ['cancel', 404],
469			'jid-malformed' => ['modify', 400],
470			'not-acceptable' => ['modify', 406],
471			'not-allowed' => ['cancel', 405],
472			'not-authorized' => ['auth', 401],
473			'payment-required' => ['auth', 402],
474			'recipient-unavailable' => ['wait', 404],
475			'redirect' => ['modify', 302],
476			'registration-required' => ['auth', 407],
477			'remote-server-not-found' => ['cancel', 404],
478			'remote-server-timeout' => ['wait', 504],
479			'resource-constraint' => ['wait', 500],
480			'service-unavailable' => ['cancel', 503],
481			'subscription-required' => ['auth', 407],
482			'undefined-condition' => ['cancel', 500],
483			'unexpected-request' => ['wait', 400],
484			);
485
486			sub write_error_tag {
487			my ($self, $errstanza, $type, $error) = @_;
488
489			my $w = $self->{writer};
490
491			$_->write_on ($w) for $errstanza->nodes;
492
493			my @add;
494
495			unless (defined $type and defined $STANZA_ERRORS{$error}) {
496			$type = $STANZA_ERRORS{$error}->[0];
497			}
498
499	elmex	1.13	push @add, (code => $STANZA_ERRORS{$error}->[1]);
500	elmex	1.4
501			$w->addPrefix (xmpp_ns ('client'), '');
502			$w->startTag ([xmpp_ns ('client') => 'error'], type => $type, @add);
503			$w->addPrefix (xmpp_ns ('stanzas'), '');
504			$w->emptyTag ([xmpp_ns ('stanzas') => $error]);
505			$w->endTag;
506			}
507
508	elmex	1.1	=head1 AUTHOR
509
510			Robin Redeker, C<< <elmex at ta-sa.org> >>
511
512			=head1 COPYRIGHT & LICENSE
513
514			Copyright 2007 Robin Redeker, all rights reserved.
515
516			This program is free software; you can redistribute it and/or modify it
517			under the same terms as Perl itself.
518
519			=cut
520
521			1; # End of Net::XMPP2