1# ======================================================================
2#
3# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
4# SOAP::Lite is free software; you can redistribute it
5# and/or modify it under the same terms as Perl itself.
6#
7# $Id: JABBER.pm 51 2004-11-14 19:30:50Z byrnereese $
8#
9# ======================================================================
10
11package SOAP::Transport::JABBER;
12
13use strict;
14use vars qw($VERSION);
15#$VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name$ =~ /-(\d+)_([\d_]+)/);
16$VERSION = $SOAP::Lite::VERSION;
17
18use Net::Jabber 1.0021 qw(Client);
19use URI::Escape;
20use URI;
21use SOAP::Lite;
22
23my $NAMESPACE = "http://namespaces.soaplite.com/transport/jabber";
24
25{ local $^W;
26  # fix problem with printData in 1.0021
27  *Net::Jabber::printData = sub {'nothing'} if Net::Jabber->VERSION == 1.0021;
28
29  # fix problem with Unicode encoding in EscapeXML. Jabber ALWAYS convert latin to utf8
30  *Net::Jabber::EscapeXML = *Net::Jabber::EscapeXML = # that's Jabber 1.0021
31  *XML::Stream::EscapeXML = *XML::Stream::EscapeXML = # that's Jabber 1.0022
32    \&SOAP::Utils::encode_data;
33
34  # There is also an error in XML::Stream::UnescapeXML 1.12, but
35  # we can't do anything there, except hack it also :(
36}
37
38# ======================================================================
39
40package URI::jabber; # ok, lets do 'jabber://' scheme
41require URI::_server; require URI::_userpass;
42@URI::jabber::ISA=qw(URI::_server URI::_userpass);
43
44  # jabber://soaplite_client:soapliteclient@jabber.org:5222/soaplite_server@jabber.org/Home
45  # ^^^^^^   ^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^ ^^^^^^^^^^ ^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^
46
47# ======================================================================
48
49package SOAP::Transport::JABBER::Query;
50
51sub new {
52  my $proto = shift;
53  bless {} => ref($proto) || $proto;
54}
55
56sub SetPayload {
57  shift; Net::Jabber::SetXMLData("single",shift->{QUERY},"payload",shift,{});
58}
59
60sub GetPayload {
61  shift; Net::Jabber::GetXMLData("value",shift->{QUERY},"payload","");
62}
63
64# ======================================================================
65
66package SOAP::Transport::JABBER::Client;
67
68use vars qw(@ISA);
69@ISA = qw(SOAP::Client Net::Jabber::Client);
70
71sub DESTROY { SOAP::Trace::objects('()') }
72
73sub new {
74  my $self = shift;
75
76  unless (ref $self) {
77    my $class = ref($self) || $self;
78    my(@params, @methods);
79    while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
80    $self = $class->SUPER::new(@params);
81    while (@methods) { my($method, $params) = splice(@methods,0,2);
82      $self->$method(ref $params eq 'ARRAY' ? @$params : $params)
83    }
84    SOAP::Trace::objects('()');
85  }
86  return $self;
87}
88
89sub endpoint {
90  my $self = shift;
91
92  return $self->SUPER::endpoint unless @_;
93
94  my $endpoint = shift;
95
96  # nothing to do if new endpoint is the same as current one
97  return $self if $self->SUPER::endpoint && $self->SUPER::endpoint eq $endpoint;
98
99  my $uri = URI->new($endpoint);
100  my($undef, $to, $resource) = split m!/!, $uri->path, 3;
101  $self->Connect(
102    hostname => $uri->host,
103    port => $uri->port,
104  ) or Carp::croak "Can't connect to @{[$uri->host_port]}: $!";
105
106  my @result = $self->AuthSend(
107    username => $uri->user,
108    password => $uri->password,
109    resource => 'soapliteClient',
110  );
111  $result[0] eq "ok" or Carp::croak "Can't authenticate to @{[$uri->host_port]}: @result";
112
113  $self->AddDelegate(
114    namespace  => $NAMESPACE,
115    parent     => 'Net::Jabber::Query',
116    parenttype => 'query',
117    delegate   => 'SOAP::Transport::JABBER::Query',
118  );
119
120  # Get roster and announce presence
121  $self->RosterGet();
122  $self->PresenceSend();
123
124  $self->SUPER::endpoint($endpoint);
125}
126
127sub send_receive {
128  my($self, %parameters) = @_;
129  my($envelope, $endpoint, $encoding) =
130    @parameters{qw(envelope endpoint encoding)};
131
132  $self->endpoint($endpoint ||= $self->endpoint);
133
134  my($undef, $to, $resource) = split m!/!, URI->new($endpoint)->path, 3;
135
136  # Create a Jabber info/query message
137  my $iq = new Net::Jabber::IQ();
138  $iq->SetIQ(
139    type => 'set',
140    to   => join '/', $to => $resource || 'soapliteServer',
141  );
142  my $query = $iq->NewQuery($NAMESPACE);
143  $query->SetPayload($envelope);
144
145  SOAP::Trace::debug($envelope);
146
147  my $iq_rcvd = $self->SendAndReceiveWithID($iq);
148  my($query_rcvd) = $iq_rcvd->GetQuery($NAMESPACE) if $iq_rcvd; # expect only one
149  my $msg = $query_rcvd->GetPayload() if $query_rcvd;
150
151  SOAP::Trace::debug($msg);
152
153  my $code = $self->GetErrorCode();
154
155  $self->code($code);
156  $self->message($code);
157  $self->is_success(!defined $code || $code eq '');
158  $self->status($code);
159
160  return $msg;
161}
162
163# ======================================================================
164
165package SOAP::Transport::JABBER::Server;
166
167use Carp ();
168use vars qw(@ISA $AUTOLOAD);
169@ISA = qw(SOAP::Server);
170
171sub new {
172  my $self = shift;
173
174  unless (ref $self) {
175    my $class = ref($self) || $self;
176    my $uri = URI->new(shift);
177    $self = $class->SUPER::new(@_);
178
179    $self->{_jabberserver} = Net::Jabber::Client->new;
180    $self->{_jabberserver}->Connect(
181      hostname      => $uri->host,
182      port          => $uri->port,
183    ) or Carp::croak "Can't connect to @{[$uri->host_port]}: $!";
184
185    my($undef, $resource) = split m!/!, $uri->path, 2;
186    my @result = $self->AuthSend(
187      username => $uri->user,
188      password => $uri->password,
189      resource => $resource || 'soapliteServer',
190    );
191    $result[0] eq "ok" or Carp::croak "Can't authenticate to @{[$uri->host_port]}: @result";
192
193    $self->{_jabberserver}->SetCallBacks(
194      iq => sub {
195        shift;
196        my $iq = new Net::Jabber::IQ(@_);
197
198        my($query) = $iq->GetQuery($NAMESPACE); # expect only one
199        my $request = $query->GetPayload();
200
201        SOAP::Trace::debug($request);
202
203        # Set up response
204        my $reply = $iq->Reply;
205        my $x = $reply->NewQuery($NAMESPACE);
206
207        my $response = $self->SUPER::handle($request);
208        $x->SetPayload($response);
209
210        # Send response
211        $self->{_jabberserver}->Send($reply);
212      }
213    );
214
215    $self->AddDelegate(
216      namespace  => $NAMESPACE,
217      parent     => 'Net::Jabber::Query',
218      parenttype => 'query',
219      delegate   => 'SOAP::Transport::JABBER::Query',
220    );
221
222    $self->RosterGet();
223    $self->PresenceSend();
224  }
225  return $self;
226}
227
228sub AUTOLOAD {
229  my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
230  return if $method eq 'DESTROY';
231
232  no strict 'refs';
233  *$AUTOLOAD = sub { shift->{_jabberserver}->$method(@_) };
234  goto &$AUTOLOAD;
235}
236
237sub handle {
238  shift->Process();
239}
240
241# ======================================================================
242
2431;
244
245__END__
246