/usr/local/CPAN/DJabberd/DJabberd/IQ.pm
package DJabberd::IQ;
use strict;
use base qw(DJabberd::Stanza);
use DJabberd::Util qw(exml);
use DJabberd::Roster;
use Digest::SHA1;
use DJabberd::Log;
our $logger = DJabberd::Log->get_logger();
sub on_recv_from_client {
my ($self, $conn) = @_;
my $to = $self->to_jid;
if (! $to || $conn->vhost->uses_jid($to)) {
$self->process($conn);
return;
}
$self->deliver;
}
my $iq_handler = {
'get-{jabber:iq:roster}query' => \&process_iq_getroster,
'set-{jabber:iq:roster}query' => \&process_iq_setroster,
'get-{jabber:iq:auth}query' => \&process_iq_getauth,
'set-{jabber:iq:auth}query' => \&process_iq_setauth,
'set-{urn:ietf:params:xml:ns:xmpp-session}session' => \&process_iq_session,
'set-{urn:ietf:params:xml:ns:xmpp-bind}bind' => \&process_iq_bind,
'get-{http://jabber.org/protocol/disco#info}query' => \&process_iq_disco_info_query,
'get-{http://jabber.org/protocol/disco#items}query' => \&process_iq_disco_items_query,
'get-{jabber:iq:register}query' => \&process_iq_getregister,
'set-{jabber:iq:register}query' => \&process_iq_setregister,
'set-{djabberd:test}query' => \&process_iq_set_djabberd_test,
};
# DO NOT OVERRIDE THIS
sub process {
my DJabberd::IQ $self = shift;
my $conn = shift;
# FIXME: handle 'result'/'error' IQs from when we send IQs
# out, like in roster pushes
# Trillian Jabber 3.1 is stupid and sends a lot of IQs (but non-important ones)
# without ids. If we respond to them (also without ids, or with id='', rather),
# then Trillian crashes. So let's just ignore them.
return unless defined($self->id) && length($self->id);
$conn->vhost->run_hook_chain(phase => "c2s-iq",
args => [ $self ],
fallback => sub {
my $sig = $self->signature;
my $meth = $iq_handler->{$sig};
unless ($meth) {
$self->send_error(
qq{<error type='cancel'>}.
qq{<feature-not-implemented xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>}.
qq{<text xmlns='urn:ietf:params:xml:ns:xmpp-stanzas' xml:lang='en'>}.
qq{This feature is not implemented yet in DJabberd.}.
qq{</text>}.
qq{</error>}
);
$logger->warn("Unknown IQ packet: $sig");
return;
}
$DJabberd::Stats::counter{"InIQ:$sig"}++;
$meth->($conn, $self);
});
}
sub signature {
my $iq = shift;
my $fc = $iq->first_element;
# FIXME: should signature ever get called on a bogus IQ packet?
return $iq->type . "-" . ($fc ? $fc->element : "(BOGUS)");
}
sub send_result {
my DJabberd::IQ $self = shift;
$self->send_reply("result");
}
sub send_error {
my DJabberd::IQ $self = shift;
my $raw = shift || '';
$self->send_reply("error", $self->innards_as_xml . "\n" . $raw);
}
# caller must send well-formed XML (but we do the wrapping element)
sub send_result_raw {
my DJabberd::IQ $self = shift;
my $raw = shift;
return $self->send_reply("result", $raw);
}
sub send_reply {
my DJabberd::IQ $self = shift;
my ($type, $raw) = @_;
my $conn = $self->{connection}
or return;
$raw ||= "";
my $id = $self->id;
my $bj = $conn->bound_jid;
my $from_jid = $self->to;
my $to = $bj ? (" to='" . $bj->as_string_exml . "'") : "";
my $from = $from_jid ? (" from='" . $from_jid . "'") : "";
my $xml = qq{<iq$to$from type='$type' id='$id'>$raw</iq>};
$conn->xmllog->info($xml);
$conn->write(\$xml);
}
sub process_iq_disco_info_query {
my ($conn, $iq) = @_;
# Trillian, again, is fucking stupid and crashes on just
# about anything its homemade XML parser doesn't like.
# so ignore it when it asks for this, just never giving
# it a reply.
if ($conn->vhost->quirksmode && $iq->id =~ /^trill_/) {
return;
}
# TODO: these can be sent back to another server I believe -- sky
# TODO: Here we need to figure out what identities we have and
# capabilities we have
my $xml;
$xml = qq{<query xmlns='http://jabber.org/protocol/disco#info'>};
$xml .= qq{<identity category='server' type='im' name='djabberd'/>};
foreach my $cap ('http://jabber.org/protocol/disco#info',
$conn->vhost->features)
{
$xml .= "<feature var='$cap'/>";
}
$xml .= qq{</query>};
$iq->send_reply('result', $xml);
}
sub process_iq_disco_items_query {
my ($conn, $iq) = @_;
my $vhost = $conn->vhost;
my $items = $vhost ? $vhost->child_services : {};
my $xml = qq{<query xmlns='http://jabber.org/protocol/disco#items'>}.
join('', map({ "<item jid='".exml($_)."' name='".exml($items->{$_})."' />" } keys %$items)).
qq{</query>};
$iq->send_reply('result', $xml);
}
sub process_iq_getroster {
my ($conn, $iq) = @_;
my $send_roster = sub {
my $roster = shift;
$logger->info("Sending roster to conn $conn->{id}");
$iq->send_result_raw($roster->as_xml);
# JIDs who want to subscribe to us, since we were offline
foreach my $jid (map { $_->jid }
grep { $_->subscription->pending_in }
$roster->items) {
my $subpkt = DJabberd::Presence->make_subscribe(to => $conn->bound_jid,
from => $jid);
# already in roster as pendin, we've already processed it,
# so just deliver it (or queue it) so user can reply with
# subscribed/unsubscribed:
$conn->note_pend_in_subscription($subpkt);
}
};
# need to be authenticated to request a roster.
my $bj = $conn->bound_jid;
unless ($bj) {
$iq->send_error(
qq{<error type='auth'>}.
qq{<not-authorized xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>}.
qq{<text xmlns='urn:ietf:params:xml:ns:xmpp-stanzas' xml:lang='en'>}.
qq{You need to be authenticated before requesting a roster.}.
qq{</text>}.
qq{</error>}
);
return;
}
# {=getting-roster-on-login}
$conn->set_requested_roster(1);
$conn->vhost->get_roster($bj,
on_success => $send_roster,
on_fail => sub {
$send_roster->(DJabberd::Roster->new);
});
return 1;
}
sub process_iq_setroster {
my ($conn, $iq) = @_;
my $item = $iq->query->first_element;
unless ($item && $item->element eq "{jabber:iq:roster}item") {
$iq->send_error( # TODO make this error proper
qq{<error type='error-type'>}.
qq{<not-authorized xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>}.
qq{<text xmlns='urn:ietf:params:xml:ns:xmpp-stanzas' xml:lang='langcode'>}.
qq{You need to be authenticated before requesting a roster.}.
qq{</text>}.
qq{</error>}
);
return;
}
# {=xmpp-ip-7.6-must-ignore-subscription-values}
my $subattr = $item->attr('{}subscription') || "";
my $removing = $subattr eq "remove" ? 1 : 0;
my $jid = $item->attr("{}jid")
or return $iq->send_error( # TODO Yeah, this one too
qq{<error type='error-type'>}.
qq{<not-authorized xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>}.
qq{<text xmlns='urn:ietf:params:xml:ns:xmpp-stanzas' xml:lang='langcode'>}.
qq{You need to be authenticated before requesting a roster.}.
qq{</text>}.
qq{</error>}
);
my $name = $item->attr("{}name");
# find list of group names to add/update. can ignore
# if we're just removing.
my @groups; # scalars of names
unless ($removing) {
foreach my $ele ($item->children_elements) {
next unless $ele->element eq "{jabber:iq:roster}group";
push @groups, $ele->first_child;
}
}
my $ritem = DJabberd::RosterItem->new(jid => $jid,
name => $name,
remove => $removing,
groups => \@groups,
);
# TODO if ($removing), send unsubscribe/unsubscribed presence
# stanzas. See RFC3921 8.6
# {=add-item-to-roster}
my $phase = $removing ? "RosterRemoveItem" : "RosterAddUpdateItem";
$conn->vhost->run_hook_chain(phase => $phase,
args => [ $conn->bound_jid, $ritem ],
methods => {
done => sub {
my ($self, $ritem_final) = @_;
# the RosterRemoveItem isn't required to return the final item
$ritem_final = $ritem if $removing;
$iq->send_result;
$conn->vhost->roster_push($conn->bound_jid, $ritem_final);
# TODO: section 8.6: must send a
# bunch of presence
# unsubscribe/unsubscribed messages
},
error => sub { # TODO What sort of error stat is being hit here?
$iq->send_error;
},
},
fallback => sub {
if ($removing) {
# NOTE: we used to send an error here, but clients get
# out of sync and we need to let them think a delete
# happened even if it didn't.
$iq->send_result;
} else { # TODO ACK, This one as well
$iq->send_error;
}
});
return 1;
}
sub process_iq_getregister {
my ($conn, $iq) = @_;
# If the entity is not already registered and the host supports
# In-Band Registration, the host MUST inform the entity of the
# required registration fields. If the host does not support
# In-Band Registration, it MUST return a <service-unavailable/>
# error. If the host is redirecting registration requests to some
# other medium (e.g., a website), it MAY return an <instructions/>
# element only, as shown in the Redirection section of this
# document.
my $vhost = $conn->vhost;
unless ($vhost->allow_inband_registration) {
# MUST return a <service-unavailable/>
$iq->send_error(
qq{<error type='cancel' code='503'>}.
qq{<service-unavailable xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>}.
qq{<text xmlns='urn:ietf:params:xml:ns:xmpp-stanzas' xml:lang='en'>}.
qq{In-Band registration is not supported by this server's configuration.}.
qq{</text>}.
qq{</error>}
);
return;
}
# if authenticated, give them existing login info:
if (my $jid = $conn->bound_jid) {
my $password = 0 ? "<password></password>" : ""; # TODO
my $username = $jid->node;
$iq->send_result_raw(qq{<query xmlns='jabber:iq:register'>
<registered/>
<username>$username</username>
$password
</query>});
return;
}
# not authenticated, ask for their required fields
# NOTE: we send_result_raw here, which just writes, so they don't
# need to be an available resource (since they're not even authed
# yet) for this to work. that's like most things in IQ anyway.
$iq->send_result_raw(qq{<query xmlns='jabber:iq:register'>
<instructions>
Choose a username and password for use with this service.
</instructions>
<username/>
<password/>
</query>});
}
sub process_iq_setregister {
my ($conn, $iq) = @_;
my $vhost = $conn->vhost;
unless ($vhost->allow_inband_registration) {
# MUST return a <service-unavailable/>
$iq->send_error(
qq{<error type='cancel'>}.
qq{<service-unavailable xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>}.
qq{<text xmlns='urn:ietf:params:xml:ns:xmpp-stanzas' xml:lang='en'>}.
qq{In-Band registration is not supported by this server\'s configuration.}.
qq{</text>}.
qq{</error>}
);
return;
}
my $bjid = $conn->bound_jid;
# remove (cancel) support
my $item = $iq->query->first_element;
if ($item && $item->element eq "{jabber:iq:register}remove") {
if ($bjid) {
my $rosterwipe = sub {
$vhost->run_hook_chain(phase => "RosterWipe",
args => [ $bjid ],
methods => {
done => sub {
$iq->send_result;
$conn->stream_error("not-authorized");
},
});
};
$vhost->run_hook_chain(phase => "UnregisterJID",
args => [ username => $bjid->node, conn => $conn ],
methods => {
deleted => sub {
$rosterwipe->();
},
notfound => sub {
warn "notfound.\n";
return $iq->send_error;
},
error => sub {
return $iq->send_error;
},
});
$iq->send_result;
} else {
$iq->send_error; # TODO: <forbidden/>
}
return;
}
my $query = $iq->query
or die;
my @children = $query->children;
my $get = sub {
my $lname = shift;
foreach my $c (@children) {
next unless ref $c && $c->element eq "{jabber:iq:register}$lname";
my $text = $c->first_child;
return undef if ref $text;
return $text;
}
return undef;
};
my $username = $get->("username");
my $password = $get->("password");
return $iq->send_error unless $username =~ /^\w+$/;
return $iq->send_error if $bjid && $bjid->node ne $username;
# create the account
$vhost->run_hook_chain(phase => "RegisterJID",
args => [ username => $username, conn => $conn, password => $password ],
methods => {
saved => sub {
return $iq->send_result;
},
conflict => sub {
my $epass = exml($password);
return $iq->send_error(qq{
<query xmlns='jabber:iq:register'>
<username>$username</username>
<password>$epass</password>
</query>
<error code='409' type='cancel'>
<conflict xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
</error>
});
},
error => sub {
return $iq->send_error;
},
});
}
sub process_iq_getauth {
my ($conn, $iq) = @_;
# <iq type='get' id='gaimf46fbc1e'><query xmlns='jabber:iq:auth'><username>brad</username></query></iq>
# force SSL by not letting them login
if ($conn->vhost->requires_ssl && ! $conn->ssl) {
$conn->stream_error("policy-violation", "Local policy requires use of SSL before authentication.");
return;
}
my $username = "";
my $child = $iq->query->first_element;
if ($child && $child->element eq "{jabber:iq:auth}username") {
$username = $child->first_child;
die "Element in username field?" if ref $username;
}
# FIXME: use nodeprep or whatever, not \w+
$username = '' unless $username =~ /^\w+$/;
my $type = ($conn->vhost->are_hooks("GetPassword") ||
$conn->vhost->are_hooks("CheckDigest")) ? "<digest/>" : "<password/>";
$iq->send_result_raw("<query xmlns='jabber:iq:auth'><username>$username</username>$type<resource/></query>");
return 1;
}
sub process_iq_setauth {
my ($conn, $iq) = @_;
# <iq type='set' id='gaimbb822399'><query xmlns='jabber:iq:auth'><username>brad</username><resource>work</resource><digest>ab2459dc7506d56247e2dc684f6e3b0a5951a808</digest></query></iq>
my $id = $iq->id;
my $query = $iq->query
or die;
my @children = $query->children;
my $get = sub {
my $lname = shift;
foreach my $c (@children) {
next unless ref $c && $c->element eq "{jabber:iq:auth}$lname";
my $text = $c->first_child;
return undef if ref $text;
return $text;
}
return undef;
};
my $username = $get->("username");
my $resource = $get->("resource");
my $password = $get->("password");
my $digest = $get->("digest");
# "Both the username and the resource are REQUIRED for client
# authentication" Section 3.1 of XEP 0078
return unless $username && $username =~ /^\w+$/;
return unless $resource;
my $vhost = $conn->vhost;
my $reject = sub {
$DJabberd::Stats::counter{'auth_failure'}++;
$iq->send_reply("error", qq{<error code='401' type='auth'><not-authorized xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/></error>});
return 1;
};
my $accept = sub {
my $cb = shift;
my $authjid = shift;
# create default JID
unless (defined $authjid) {
my $sname = $vhost->name;
$authjid = "$username\@$sname";
}
# register
my $jid = DJabberd::JID->new("$authjid");
unless ($jid) {
$reject->();
return;
}
my $regcb = DJabberd::Callback->new({
registered => sub {
(undef, my $fulljid) = @_;
$conn->set_bound_jid($fulljid);
$DJabberd::Stats::counter{'auth_success'}++;
$iq->send_result;
},
error => sub {
$iq->send_error;
},
_post_fire => sub {
$conn = undef;
$iq = undef;
},
});
$vhost->register_jid($jid, $resource, $conn, $regcb);
};
# XXX FIXME
# If the client ignores your wishes get a digest or password
# We should throw an error indicating so
# Currently we will just return authentication denied -- artur
if ($vhost->are_hooks("GetPassword")) {
$vhost->run_hook_chain(phase => "GetPassword",
args => [ username => $username, conn => $conn ],
methods => {
set => sub {
my (undef, $good_password) = @_;
if ($password && $password eq $good_password) {
$accept->();
} elsif ($digest) {
my $good_dig = lc(Digest::SHA1::sha1_hex($conn->{stream_id} . $good_password));
if ($good_dig eq $digest) {
$accept->();
} else {
$reject->();
}
} else {
$reject->();
}
},
},
fallback => $reject);
} elsif ($vhost->are_hooks("CheckDigest")) {
$vhost->run_hook_chain(phase => "CheckDigest",
args => [ username => $username, conn => $conn, digest => $digest, resource => $resource ],
methods => {
accept => $accept,
reject => $reject,
});
} else {
$vhost->run_hook_chain(phase => "CheckCleartext",
args => [ username => $username, conn => $conn, password => $password ],
methods => {
accept => $accept,
reject => $reject,
});
}
return 1; # signal that we've handled it
}
## sessions have been deprecated, see appendix E of:
## http://xmpp.org/internet-drafts/draft-saintandre-rfc3921bis-07.html
## BUT, we have to advertise session support since, libpurple REQUIRES it
## (sigh)
sub process_iq_session {
my ($conn, $iq) = @_;
my $from = $iq->from;
my $id = $iq->id;
my $xml = qq{<iq from='$from' type='result' id='$id'/>};
$conn->xmllog->info($xml);
$conn->write(\$xml);
}
sub process_iq_bind {
my ($conn, $iq) = @_;
# <iq type='set' id='purple88621b5d'><bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'><resource>yann</resource></bind></iq>
my $id = $iq->id;
my $query = $iq->bind
or die;
my $bindns = 'urn:ietf:params:xml:ns:xmpp-bind';
my @children = $query->children;
my $get = sub {
my $lname = shift;
foreach my $c (@children) {
next unless ref $c && $c->element eq "{$bindns}$lname";
my $text = $c->first_child;
return undef if ref $text;
return $text;
}
return undef;
};
my $resource = $get->("resource") || DJabberd::JID->rand_resource;
my $vhost = $conn->vhost;
my $reject = sub {
my $xml = <<EOX;
<iq id='$id' type='error'>
<error type='modify'>
<bad-request xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
</error>
</iq>
EOX
$conn->xmllog->info($xml);
$conn->write(\$xml);
return 1;
};
## rfc3920 §8.4.2.2
my $cancel = sub {
my $reason = shift || "no reason";
my $xml = <<EOX;
<iq id='$id' type='error'>
<error type='cancel'>
<not-allowed
xmlns='urn:ietf:params:xml:ns:xmpp-stanzas'/>
</error>
</iq>
EOX
$conn->log->error("Reject bind request: $reason");
$conn->xmllog->info($xml);
$conn->write(\$xml);
return 1;
};
my $sasl = $conn->sasl
or return $cancel->("no sasl");
my $authjid = $conn->sasl->authenticated_jid
or return $cancel->("no authenticated_jid");
# register
my $jid = DJabberd::JID->new($authjid);
unless ($jid) {
$reject->();
return;
}
my $regcb = DJabberd::Callback->new({
registered => sub {
(undef, my $fulljid) = @_;
$conn->set_bound_jid($fulljid);
$DJabberd::Stats::counter{'auth_success'}++;
my $xml = <<EOX;
<iq id='$id' type='result'>
<bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'>
<jid>$fulljid</jid>
</bind>
</iq>
EOX
$conn->xmllog->info($xml);
$conn->write(\$xml);
},
error => sub {
$reject->();
},
_post_fire => sub {
$conn = undef;
$iq = undef;
},
});
$vhost->register_jid($jid, $resource, $conn, $regcb);
return 1;
}
sub process_iq_set_djabberd_test {
my ($conn, $iq) = @_;
# <iq type='set' id='foo'><query xmlns='djabberd:test'>some command</query></iq>
my $id = $iq->id;
unless ($ENV{DJABBERD_TEST_COMMANDS}) {
$iq->send_error;
return;
}
my $query = $iq->query
or die;
my $command = $query->first_child;
if ($command eq "write error") {
$conn->set_writer_func(sub {
my ($bref, $to_write, $offset) = @_;
$conn->close;
return 0;
});
$iq->send_result_raw("<wont_get_to_you_anyway/>");
return;
}
$iq->send_result_raw("<unknown-command/>");
}
sub id {
return $_[0]->attr("{}id");
}
sub type {
return $_[0]->attr("{}type");
}
sub from {
return $_[0]->attr("{}from");
}
sub query {
my $self = shift;
my $child = $self->first_element
or return;
my $ele = $child->element
or return;
return undef unless $child->element =~ /\}query$/;
return $child;
}
sub bind {
my $self = shift;
my $child = $self->first_element
or return;
my $ele = $child->element
or return;
return unless $child->element =~ /\}bind$/;
return $child;
}
sub deliver_when_unavailable {
my $self = shift;
return $self->type eq "result" ||
$self->type eq "error";
}
sub make_response {
my ($self) = @_;
my $response = $self->SUPER::make_response();
$response->attrs->{"{}type"} = "result";
return $response;
}
1;