/usr/local/CPAN/DJabberd/DJabberd/Presence.pm
package DJabberd::Presence;
use strict;
use base qw(DJabberd::Stanza);
use Carp qw(croak confess);
use fields (
'dont_load_rosteritem', # bool: if set, don't load roster item for this probe. it's a trusted probe. (internally generated)
);
sub clone {
my $self = shift;
my $clone = $self->SUPER::clone;
$clone->{dont_load_rosteritem} = $self->{dont_load_rosteritem};
return $clone;
}
# TODO: _process_outbound_invisible -- seen in wild. not in spec, but how to handle?
# Wildfire crew says:
# Presences of type invisible are not XMPP compliant. That was the
# old way invisibility was implemented before. The correct way to #
# implement invisibility is to use JEP-0126: Invisibility that is #
# based on privacy lists. The server will ignore presences of type
# # invisible and instead assume that an available presence was
# sent. In # other words, the server will ignore the invisibility
# request.
# used by DJabberd::PresenceChecker::Local.
my %last_bcast; # barejidstring -> { full_jid_string -> $cloned_pres_stanza }
sub forget_last_presence {
my ($class, $jid) = @_;
my $barestr = $jid->as_bare_string;
my $map = $last_bcast{$barestr} or return;
delete $map->{$jid->as_string};
delete $last_bcast{$barestr} unless %$map;
}
sub set_local_presence {
my ($class, $jid, $prepkt) = @_;
return 0 unless $jid;
$last_bcast{$jid->as_bare_string}{$jid->as_string} = $prepkt;
}
# is this directed presence? must be to a JID, and must be available/unavailable, not probe/subscribe/etc.
sub is_directed {
my $self = shift;
return 0 unless $self->to_jid;
my $type = $self->type;
return 0 if $type && $type ne "unavailable";
return 1;
}
sub on_recv_from_server {
my ($self, $conn) = @_;
$DJabberd::Stats::counter{"s2si-Presence"}++;
$self->process_inbound($conn->vhost);
}
sub on_recv_from_client {
my ($self, $conn) = @_;
$DJabberd::Stats::counter{"c2s-Presence"}++;
$self->process_outbound($conn);
}
sub local_presence_info {
my ($class, $jid) = @_;
my $barestr = $jid->as_bare_string;
return $last_bcast{$barestr} || {};
}
# constructor
sub available {
my ($class, %opts) = @_;
my ($from) = map { delete $opts{$_} } qw(from);
croak "Invalid options" if %opts;
my $xml = DJabberd::XMLElement->new("", "presence", {
'{}from' => $from->as_string,
}, []);
return $class->downbless($xml);
}
# constructor
sub probe {
my ($class, %opts) = @_;
my ($from, $to) = map { delete $opts{$_} } qw(from to);
croak "Invalid options" if %opts;
my $xml = DJabberd::XMLElement->new("", "presence", { '{}type' => 'probe',
'{}from' => $from->as_string,
'{}to' => $to->as_bare_string }, []);
return $class->downbless($xml);
}
# constructor
sub make_subscribed {
my ($class, %opts) = @_;
my ($from, $to) = map { delete $opts{$_} } qw(from to);
croak "Invalid options" if %opts;
my $xml = DJabberd::XMLElement->new("", "presence", { '{}type' => 'subscribed',
'{}from' => $from->as_bare_string,
'{}to' => $to->as_bare_string }, []);
return $class->downbless($xml);
}
# constructor
sub make_subscribe {
my ($class, %opts) = @_;
my ($from, $to) = map { delete $opts{$_} } qw(from to);
croak "Invalid options" if %opts;
my $xml = DJabberd::XMLElement->new("", "presence", { '{}type' => 'subscribe',
'{}from' => $from->as_bare_string,
'{}to' => $to->as_bare_string }, []);
return $class->downbless($xml);
}
# constructor
sub available_stanza {
my ($class) = @_;
my $xml = DJabberd::XMLElement->new("", "presence", {}, []);
return $class->downbless($xml);
}
# constructor
sub unavailable_stanza {
my ($class) = @_;
my $xml = DJabberd::XMLElement->new("", "presence", { '{}type' => "unavailable" }, []);
return $class->downbless($xml);
}
sub is_unavailable {
my $self = shift;
no warnings 'uninitialized'; # type can be uninitialized and that is ok
return $self->type eq 'unavailable';
}
sub type {
my $self = shift;
return $self->attr("{}type");
}
sub fail {
my ($self, $vhost, $reason) = @_;
# TODO: figure this out (presence type='error' stuff, when?)
warn "PRESENCE FAILURE: $reason\n";
return;
}
# like delivery, but handles inbound processing if the target
# is somebody on our domain. TODO: IQs are going to need
# this same out-vs-in processing. it should be generic.
sub procdeliver {
my ($self, $vhost) = @_;
if ($vhost->isa("DJabberd::Connection")) {
warn "Deprecated arg of connection to procdeliver at " . join(", ", caller);
$vhost = $vhost->vhost;
}
# TODO: this needs some re-thinking for the cluster case, as
# "handles_jid" means one of two things in general: 1) I'm the
# sole handler of this JID (the below interpretation), vs 2) I can
# handle at least some of this vhost's domain, at least I don't
# handle none of it.
# The fear is that in the cluster case you'd have to always deliver,
# which we want to avoid.
# We should have another API that's like ->handles_jid_and_shes_online_here($jid)
my $contact_jid = $self->to_jid or die;
if ($vhost->handles_jid($contact_jid)) {
my $clone = $self->clone;
$clone->process_inbound($vhost);
} else {
$self->deliver($vhost);
}
}
sub process {
confess "No generic 'process' method for $_[0]";
}
our %outbound_need_ritem = (
unsubscribe => 1,
unsubscribed => 1,
);
sub process_outbound {
my ($self, $conn) = @_;
my $type = $self->type || "available";
return 0 unless $conn->bound_jid;
return $self->fail($conn->vhost, "bogus type") unless $type =~ /^\w+$/;
my $call_method = sub {
my $ritem = shift;
my $meth = "_process_outbound_$type";
eval { $self->$meth($conn,$ritem) };
if ($@) {
warn " ... ERROR: [$@]\n";
}
return;
};
if ($outbound_need_ritem{$type}) {
my $to_jid = $self->to_jid
or return $self->fail($conn->vhost, "no/invalid 'to' attribute");
my $from_jid = $self->from_jid
or return $self->fail($conn->vhost, "no/invalid 'from' attribute");
$self->_roster_load_item($conn->vhost, $from_jid, $to_jid, $call_method);
} else {
$call_method->();
}
}
sub process_inbound {
my ($self, $vhost) = @_;
Carp::confess("Not a vhost") unless $vhost->isa("DJabberd::VHost");
my $type = $self->type || "available";
return $self->fail($vhost, "bogus type") unless $type =~ /^\w+$/;
my $to_jid = $self->to_jid
or return $self->fail($vhost, "no/invalid 'to' attribute");
my $from_jid = $self->from_jid
or return $self->fail($vhost, "no/invalid 'from' attribute");
my $call_method = sub {
my $ritem = shift;
my $meth = "_process_inbound_$type";
eval { $self->$meth($vhost, $ritem, $from_jid) };
if ($@) {
warn " ... ERROR: [$@].\n";
}
};
# the presence packet is flagged as internally-generated and not
# wanting us to load the roster item (because it's probably a
# trusted probe). also, for available/unavailable directed
# presence don't load ritem because those handlers don't need it:
# they just deliver.
if ($self->{dont_load_rosteritem} ||
$type eq "available" || $type eq "unavailable")
{
$call_method->(undef);
return;
}
# find the RosterItem corresponding to this sender, and only once
# we have it, invoke the next handler
$self->_roster_load_item($vhost, $to_jid, $from_jid, $call_method);
}
sub _roster_load_item {
my ($self, $vhost, $my_jid, $contact_jid, $call_method) = @_;
$vhost->run_hook_chain(phase => "RosterLoadItem",
args => [ $my_jid, $contact_jid ],
methods => {
error => sub {
my ($cb, $reason) = @_;
return $self->fail($vhost, "RosterLoadItem hook failed: $reason");
},
set => sub {
my ($cb, $ritem) = @_;
$call_method->($ritem);
},
});
return 0;
}
sub _process_inbound_available {
my ($self, $vhost) = @_;
$self->deliver($vhost);
}
sub _process_inbound_unavailable {
my ($self, $vhost) = @_;
$self->deliver($vhost);
}
sub _process_inbound_subscribe {
my ($self, $vhost, $ritem, $from_jid) = @_;
my $to_jid = $self->to_jid;
# XMPP: server SHOULD auto-reply if contact already subscribed from
if ($ritem && $ritem->subscription->sub_from) {
my $subd = DJabberd::Presence->make_subscribed(to => $from_jid,
from => $to_jid);
$subd->procdeliver($vhost);
# let's act like they probed us too, so we send them our presence.
my $probe = DJabberd::Presence->probe(from => $from_jid,
to => $to_jid);
$probe->procdeliver($vhost);
return;
}
#warn " ... not already subscribed from, didn't shortcut.\n";
$ritem ||= DJabberd::RosterItem->new($from_jid);
# ignore duplicate pending-in subscriptions
if ($ritem->subscription->pending_in) {
warn "ignoring dup inbound subscribe, already pending-in.\n";
return;
}
# TODO: HOOK FOR auto-subscribed sending. violates spec, but LiveJournal
# could use it. i think spec isn't thoughtful enough there.
# mark the roster item as pending-in, and save it:
$ritem->subscription->set_pending_in;
$vhost->run_hook_chain(phase => "RosterSetItem",
args => [ $to_jid, $ritem ],
methods => {
done => sub {
$self->deliver($vhost);
},
error => sub { my $reason = $_[1]; },
},
);
}
sub _process_inbound_subscribed {
my ($self, $vhost, $ritem) = @_;
Carp::confess("Not a vhost") unless $vhost->isa("DJabberd::VHost");
# MUST ignore inbound subscribed if we weren't awaiting
# its arrival
return unless $ritem && $ritem->subscription->pending_out;
my $to_jid = $self->to_jid;
#warn "processing inbound subscribed...\n";
$ritem->subscription->got_inbound_subscribed;
$vhost->run_hook_chain(phase => "RosterSetItem",
args => [ $to_jid, $ritem ],
methods => {
done => sub {
$vhost->roster_push($to_jid, $ritem);
my $probe = DJabberd::Presence->probe(from => $to_jid,
to => $ritem->jid);
$probe->procdeliver($vhost);
$self->deliver($vhost);
},
error => sub { my $reason = $_[1]; },
},
);
}
sub _process_inbound_probe {
my ($self, $vhost, $ritem, $from_jid) = @_;
unless ($self->{dont_load_rosteritem}) {
return unless $ritem && $ritem->subscription->sub_from;
}
my $jid = $self->to_jid;
$vhost->check_presence($jid, sub {
my $map = shift;
foreach my $fullstr (keys %$map) {
my $stanza = $map->{$fullstr};
my $to_send = $stanza->clone;
$to_send->set_to($from_jid);
$to_send->deliver($vhost);
}
});
}
sub _process_inbound_unsubscribe {
my ($self, $vhost, $ritem) = @_;
# if we don't know the user, just drop it
return unless $ritem;
my $to_jid = $self->to_jid;
$ritem->subscription->got_inbound_unsubscribe;
$vhost->run_hook_chain(phase => "RosterSetItem",
args => [ $to_jid, $ritem ],
methods => {
done => sub {
$vhost->roster_push($to_jid, $ritem);
$self->deliver($vhost);
},
error => sub { my $reason = $_[1]; },
},
);
}
sub _process_inbound_unsubscribed {
my ($self, $vhost, $ritem) = @_;
# TODO:
# 1) MUST roster push
# 2) MUST deliver to all available resources
# to -> none
# keep it in the roster as 'none', don't remove. client does that with type='remove'
}
sub broadcast_from {
my ($self, $conn) = @_;
my $from_jid = $conn->bound_jid;
my $vhost = $conn->vhost;
my $broadcast = sub {
my $roster = shift;
foreach my $it ($roster->from_items) {
my $dpres = $self->clone;
$dpres->set_to($it->jid);
$dpres->set_from($from_jid);
$dpres->procdeliver($vhost);
}
# For the purpose of presence broadcasting
# we act as if all of the other resources
# for this bare JID are on the roster.
# This means that resources of the same
# JID are aware of each other and can send
# messages to each other, etc.
foreach my $otherconn ($vhost->find_conns_of_bare($from_jid)) {
my $to_jid = $otherconn->bound_jid;
next if $from_jid->eq($to_jid);
my $dpres = $self->clone;
$dpres->set_to($to_jid);
$dpres->set_from($from_jid);
$dpres->procdeliver($vhost);
}
};
$vhost->get_roster($from_jid, on_success => $broadcast);
}
sub _process_outbound_available {
my ($self, $conn, $skip_alter) = @_;
my $vhost = $conn->vhost;
if (!$skip_alter && $vhost->are_hooks("AlterPresenceAvailable")) {
$vhost->run_hook_chain(phase => "AlterPresenceAvailable",
args => [ $conn, $self ],
methods => {
done => sub {
return if $conn->{closed};
$self->_process_outbound_available($conn, 1);
},
},
);
return;
}
if ($self->is_directed) {
$conn->add_directed_presence($self->to_jid);
$self->deliver;
return;
}
my $jid = $conn->bound_jid;
DJabberd::Presence->set_local_presence($jid, $self->clone);
$conn->set_available(1);
if ($conn->is_initial_presence) {
$conn->on_initial_presence;
}
$self->broadcast_from($conn);
}
sub _process_outbound_unavailable {
my ($self, $conn, $skip_alter) = @_;
my $vhost = $conn->vhost;
if (!$skip_alter && $vhost->are_hooks("AlterPresenceUnavailable")) {
warn "runnig hook chain unavailable";
$vhost->run_hook_chain(phase => "AlterPresenceUnavailable",
args => [ $conn, $self ],
methods => {
done => sub {
return if $conn->{closed};
$self->_process_outbound_unavailable($conn, 1);
},
},
);
return;
}
if ($self->is_directed) {
delete($conn->{directed_presence}->{$self->to_jid});
$self->deliver;
return;
}
# if we are becoming unavailable then we need to tell all our directed presences customers this
# per RFC 3921 5.1.4.2
my $from_jid = $conn->bound_jid;
foreach my $to_jid ($conn->directed_presence) {
my $dpres = $self->clone;
$dpres->set_to($to_jid);
$dpres->set_from($from_jid);
# I think we only need to deliver and not procdeliver here
# because we don't actually want to process it anymore -- sky
# TODO: not sure of that. --brad
$dpres->deliver($conn->vhost);
}
$conn->clear_directed_presence;
my $jid = $conn->bound_jid;
DJabberd::Presence->set_local_presence($jid, $self->clone);
$conn->set_available(0);
$self->broadcast_from($conn);
}
sub _process_outbound_unsubscribe {
my ($self, $conn, $ritem) = @_;
my $from_jid = $self->from_jid;
my $to_jid = $self->to_jid or die "Can't subscribe to bogus jid";
# we didn't have this user;
return unless $ritem;
$ritem->subscription->got_outbound_unsubscribe;
$conn->vhost->run_hook_chain(phase => "RosterSetItem",
args => [ $from_jid, $ritem ],
methods => {
done => sub {
# xmpp-ip 8.4.[12]
# roster push, (to => none, both => from)
# deliver.
$conn->vhost->roster_push($from_jid, $ritem);
# let's bare-ifiy our from address, as per the SHOULD in XMPP-IM 8.2.5
# {=remove-resource-on-presence-out}
$self->set_from($self->from_jid->as_bare_string);
$self->procdeliver($conn->vhost);
},
error => sub { my $reason = $_[1]; },
}
);
}
sub _process_outbound_unsubscribed {
my ($self, $conn, $ritem) = @_;
my $deliver = sub {
$self->set_from($self->from_jid->as_bare_string);
$self->procdeliver($conn->vhost);
};
# no relation, but deliver anyway....
unless ($ritem) {
# TODO: we should deliver these, I assume, as that's consistent
# with other parts of spec wrt inter-server sync issues? --brad
$deliver->();
return;
}
my $from_jid = $conn->bound_jid;
my $contact_jid = $self->to_jid or die "Can't subscribe to bogus jid";
# xmpp-ip 8.5.[12]
# roster push (from => none, both => to), clearing pendin as well...
$ritem->subscription->got_outbound_unsubscribed;
$conn->vhost->run_hook_chain(phase => "RosterSetItem",
args => [ $from_jid, $ritem ],
methods => {
done => sub {
$conn->vhost->roster_push($from_jid, $ritem);
# continue this packet along to contact
$self->set_from($self->from_jid->as_bare_string);
$self->procdeliver($conn->vhost);
# send unavailable presence to contact:
my $unavail = DJabberd::Presence->unavailable_stanza;
$unavail->set_to($contact_jid);
$unavail->set_from($from_jid);
$unavail->deliver($conn->vhost); # procdeliver's useless: proc just delivers
},
error => sub { my $reason = $_[1]; },
},
);
}
sub _process_outbound_subscribe {
my ($self, $conn) = @_;
my $from_jid = $conn->bound_jid;
my $contact_jid = $self->to_jid or die "Can't subscribe to bogus jid";
# XMPPIP-9.2-p2: MUST without exception
# route these, to combat sync issues
# between parties
my $deliver = sub {
# let's bare-ifiy our from address, as per the SHOULD in XMPP-IM 8.2.5
# {=remove-resource-on-presence-out}
$self->set_from($self->from_jid->as_bare_string);
$self->procdeliver($conn->vhost);
};
my $save = sub {
my $ritem = shift;
$conn->vhost->run_hook_chain(phase => "RosterSetItem",
args => [ $from_jid, $ritem ],
methods => {
done => sub {
$conn->vhost->roster_push($from_jid, $ritem);
$deliver->();
},
error => sub { my $reason = $_[1]; },
},
);
};
my $on_load = sub {
my (undef, $ritem) = @_;
# not in roster, skip.
$ritem ||= DJabberd::RosterItem->new($contact_jid);
if ($ritem->subscription->got_outbound_subscribe) {
# subscription modified, must save, which will then
# deliver when done.
$save->($ritem);
} else {
$deliver->();
}
};
$conn->vhost->run_hook_chain(phase => "RosterLoadItem",
args => [ $from_jid, $contact_jid ],
methods => {
error => sub {
my (undef, $reason) = @_;
return $self->fail($conn, "RosterLoadItem hook failed: $reason");
},
set => $on_load,
});
}
sub _process_outbound_subscribed {
my ($self, $conn) = @_;
# user wanting to subscribe or approve subscription request to contact
my $contact_jid = $self->to_jid
or return $self->fail($conn, "no/invalid 'to' attribute");
$conn->vhost->run_hook_chain(phase => "RosterLoadItem",
args => [ $conn->bound_jid, $contact_jid ],
methods => {
error => sub {
my (undef, $reason) = @_;
return $self->fail($conn, "RosterLoadItem hook failed: $reason");
},
set => sub {
my (undef, $ritem) = @_;
# not in roster, skip.
return unless $ritem;
my $subs = $ritem->subscription;
# skip unless we were in pending in state
return unless $subs->pending_in;
$self->_process_outbound_subscribed_with_ritem($conn, $ritem);
},
});
}
# second stage of outbound 'subscribed' processing, once we load the item and
# decide to skip processing or not. see above.
sub _process_outbound_subscribed_with_ritem {
my ($self, $conn, $ritem) = @_;
my $vhost = $conn->vhost;
$ritem->subscription->got_outbound_subscribed;
my $from_jid = $conn->bound_jid || die("lacking from_jid");
my $to_jid = $self->to_jid;
$conn->vhost->run_hook_chain(phase => "RosterSetItem",
args => [ $conn->bound_jid, $ritem ],
methods => {
done => sub {
$conn->vhost->roster_push($conn->bound_jid, $ritem);
$self->procdeliver($conn->vhost);
# the spec's a little unclear as to whether, on successful subscribe,
# host A sends probes vs. host B sends the presence out. we do both,
# as does ejabberd and other servers.
$vhost->check_presence($conn->bound_jid, sub {
my $map = shift;
foreach my $fullstr (keys %$map) {
my $stanza = $map->{$fullstr};
my $to_send = $stanza->clone;
$to_send->set_to($to_jid);
$to_send->deliver($vhost);
}
});
},
error => sub { my $reason = $_[1]; },
},
);
}
1;