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 - "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 should work (jabberd14, jabberd2,
ejabberd, googletalk).

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

=over 4

=item B<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;
}

=item B<init>

(Re)initializes the writer.

=cut

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

=item B<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}), '');
}

=item B<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;
}

=item B<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;
}

=item B<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;
}

=item B<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;
}

=item B<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;
}

=item B<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;
}

=item B<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;
}

=item B<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;
}


=item B<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;
}

=back

=head1 AUTHOR

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