1package DJabberd::Presence; 2use strict; 3use base qw(DJabberd::Stanza); 4use Carp qw(croak confess); 5use fields ( 6 'dont_load_rosteritem', # bool: if set, don't load roster item for this probe. it's a trusted probe. (internally generated) 7 ); 8 9 10sub clone { 11 my $self = shift; 12 my $clone = $self->SUPER::clone; 13 $clone->{dont_load_rosteritem} = $self->{dont_load_rosteritem}; 14 return $clone; 15} 16 17# TODO: _process_outbound_invisible -- seen in wild. not in spec, but how to handle? 18# Wildfire crew says: 19# Presences of type invisible are not XMPP compliant. That was the 20# old way invisibility was implemented before. The correct way to # 21# implement invisibility is to use JEP-0126: Invisibility that is # 22# based on privacy lists. The server will ignore presences of type 23# # invisible and instead assume that an available presence was 24# sent. In # other words, the server will ignore the invisibility 25# request. 26 27# used by DJabberd::PresenceChecker::Local. 28my %last_bcast; # barejidstring -> { full_jid_string -> $cloned_pres_stanza } 29 30sub forget_last_presence { 31 my ($class, $jid) = @_; 32 33 my $barestr = $jid->as_bare_string; 34 my $map = $last_bcast{$barestr} or return; 35 delete $map->{$jid->as_string}; 36 delete $last_bcast{$barestr} unless %$map; 37} 38 39sub set_local_presence { 40 my ($class, $jid, $prepkt) = @_; 41 return 0 unless $jid; 42 $last_bcast{$jid->as_bare_string}{$jid->as_string} = $prepkt; 43} 44 45# is this directed presence? must be to a JID, and must be available/unavailable, not probe/subscribe/etc. 46sub is_directed { 47 my $self = shift; 48 return 0 unless $self->to_jid; 49 my $type = $self->type; 50 return 0 if $type && $type ne "unavailable"; 51 return 1; 52} 53 54sub on_recv_from_server { 55 my ($self, $conn) = @_; 56 $DJabberd::Stats::counter{"s2si-Presence"}++; 57 $self->process_inbound($conn->vhost); 58} 59 60sub on_recv_from_client { 61 my ($self, $conn) = @_; 62 $DJabberd::Stats::counter{"c2s-Presence"}++; 63 $self->process_outbound($conn); 64} 65 66sub local_presence_info { 67 my ($class, $jid) = @_; 68 my $barestr = $jid->as_bare_string; 69 return $last_bcast{$barestr} || {}; 70} 71 72# constructor 73sub available { 74 my ($class, %opts) = @_; 75 my ($from) = map { delete $opts{$_} } qw(from); 76 croak "Invalid options" if %opts; 77 78 my $xml = DJabberd::XMLElement->new("", "presence", { 79 '{}from' => $from->as_string, 80 }, []); 81 return $class->downbless($xml); 82} 83 84# constructor 85sub probe { 86 my ($class, %opts) = @_; 87 my ($from, $to) = map { delete $opts{$_} } qw(from to); 88 croak "Invalid options" if %opts; 89 90 my $xml = DJabberd::XMLElement->new("", "presence", { '{}type' => 'probe', 91 '{}from' => $from->as_string, 92 '{}to' => $to->as_bare_string }, []); 93 return $class->downbless($xml); 94} 95 96# constructor 97sub make_subscribed { 98 my ($class, %opts) = @_; 99 my ($from, $to) = map { delete $opts{$_} } qw(from to); 100 croak "Invalid options" if %opts; 101 102 my $xml = DJabberd::XMLElement->new("", "presence", { '{}type' => 'subscribed', 103 '{}from' => $from->as_bare_string, 104 '{}to' => $to->as_bare_string }, []); 105 return $class->downbless($xml); 106} 107 108# constructor 109sub make_subscribe { 110 my ($class, %opts) = @_; 111 my ($from, $to) = map { delete $opts{$_} } qw(from to); 112 croak "Invalid options" if %opts; 113 114 my $xml = DJabberd::XMLElement->new("", "presence", { '{}type' => 'subscribe', 115 '{}from' => $from->as_bare_string, 116 '{}to' => $to->as_bare_string }, []); 117 return $class->downbless($xml); 118} 119 120# constructor 121sub available_stanza { 122 my ($class) = @_; 123 my $xml = DJabberd::XMLElement->new("", "presence", {}, []); 124 return $class->downbless($xml); 125} 126 127# constructor 128sub unavailable_stanza { 129 my ($class) = @_; 130 my $xml = DJabberd::XMLElement->new("", "presence", { '{}type' => "unavailable" }, []); 131 return $class->downbless($xml); 132} 133 134sub is_unavailable { 135 my $self = shift; 136 no warnings 'uninitialized'; # type can be uninitialized and that is ok 137 return $self->type eq 'unavailable'; 138} 139 140sub type { 141 my $self = shift; 142 return $self->attr("{}type"); 143} 144 145sub fail { 146 my ($self, $vhost, $reason) = @_; 147 # TODO: figure this out (presence type='error' stuff, when?) 148 warn "PRESENCE FAILURE: $reason\n"; 149 return; 150} 151 152# like delivery, but handles inbound processing if the target 153# is somebody on our domain. TODO: IQs are going to need 154# this same out-vs-in processing. it should be generic. 155sub procdeliver { 156 my ($self, $vhost) = @_; 157 158 if ($vhost->isa("DJabberd::Connection")) { 159 warn "Deprecated arg of connection to procdeliver at " . join(", ", caller); 160 $vhost = $vhost->vhost; 161 } 162 163 # TODO: this needs some re-thinking for the cluster case, as 164 # "handles_jid" means one of two things in general: 1) I'm the 165 # sole handler of this JID (the below interpretation), vs 2) I can 166 # handle at least some of this vhost's domain, at least I don't 167 # handle none of it. 168 # The fear is that in the cluster case you'd have to always deliver, 169 # which we want to avoid. 170 # We should have another API that's like ->handles_jid_and_shes_online_here($jid) 171 my $contact_jid = $self->to_jid or die; 172 if ($vhost->handles_jid($contact_jid)) { 173 my $clone = $self->clone; 174 $clone->process_inbound($vhost); 175 } else { 176 $self->deliver($vhost); 177 } 178} 179 180sub process { 181 confess "No generic 'process' method for $_[0]"; 182} 183 184our %outbound_need_ritem = ( 185 unsubscribe => 1, 186 unsubscribed => 1, 187 ); 188 189sub process_outbound { 190 my ($self, $conn) = @_; 191 my $type = $self->type || "available"; 192 193 194 return 0 unless $conn->bound_jid; 195 return $self->fail($conn->vhost, "bogus type") unless $type =~ /^\w+$/; 196 197 my $call_method = sub { 198 my $ritem = shift; 199 my $meth = "_process_outbound_$type"; 200 eval { $self->$meth($conn,$ritem) }; 201 if ($@) { 202 warn " ... ERROR: [$@]\n"; 203 } 204 return; 205 }; 206 207 if ($outbound_need_ritem{$type}) { 208 my $to_jid = $self->to_jid 209 or return $self->fail($conn->vhost, "no/invalid 'to' attribute"); 210 my $from_jid = $self->from_jid 211 or return $self->fail($conn->vhost, "no/invalid 'from' attribute"); 212 $self->_roster_load_item($conn->vhost, $from_jid, $to_jid, $call_method); 213 } else { 214 $call_method->(); 215 } 216 217} 218 219sub process_inbound { 220 my ($self, $vhost) = @_; 221 Carp::confess("Not a vhost") unless $vhost->isa("DJabberd::VHost"); 222 223 my $type = $self->type || "available"; 224 225 return $self->fail($vhost, "bogus type") unless $type =~ /^\w+$/; 226 227 my $to_jid = $self->to_jid 228 or return $self->fail($vhost, "no/invalid 'to' attribute"); 229 my $from_jid = $self->from_jid 230 or return $self->fail($vhost, "no/invalid 'from' attribute"); 231 232 my $call_method = sub { 233 my $ritem = shift; 234 my $meth = "_process_inbound_$type"; 235 eval { $self->$meth($vhost, $ritem, $from_jid) }; 236 if ($@) { 237 warn " ... ERROR: [$@].\n"; 238 } 239 }; 240 241 # the presence packet is flagged as internally-generated and not 242 # wanting us to load the roster item (because it's probably a 243 # trusted probe). also, for available/unavailable directed 244 # presence don't load ritem because those handlers don't need it: 245 # they just deliver. 246 if ($self->{dont_load_rosteritem} || 247 $type eq "available" || $type eq "unavailable") 248 { 249 $call_method->(undef); 250 return; 251 } 252 253 # find the RosterItem corresponding to this sender, and only once 254 # we have it, invoke the next handler 255 $self->_roster_load_item($vhost, $to_jid, $from_jid, $call_method); 256} 257 258sub _roster_load_item { 259 my ($self, $vhost, $my_jid, $contact_jid, $call_method) = @_; 260 261 $vhost->run_hook_chain(phase => "RosterLoadItem", 262 args => [ $my_jid, $contact_jid ], 263 methods => { 264 error => sub { 265 my ($cb, $reason) = @_; 266 return $self->fail($vhost, "RosterLoadItem hook failed: $reason"); 267 }, 268 set => sub { 269 my ($cb, $ritem) = @_; 270 $call_method->($ritem); 271 }, 272 }); 273 return 0; 274} 275 276sub _process_inbound_available { 277 my ($self, $vhost) = @_; 278 $self->deliver($vhost); 279} 280 281sub _process_inbound_unavailable { 282 my ($self, $vhost) = @_; 283 $self->deliver($vhost); 284} 285 286sub _process_inbound_subscribe { 287 my ($self, $vhost, $ritem, $from_jid) = @_; 288 289 my $to_jid = $self->to_jid; 290 291 # XMPP: server SHOULD auto-reply if contact already subscribed from 292 if ($ritem && $ritem->subscription->sub_from) { 293 my $subd = DJabberd::Presence->make_subscribed(to => $from_jid, 294 from => $to_jid); 295 $subd->procdeliver($vhost); 296 297 # let's act like they probed us too, so we send them our presence. 298 my $probe = DJabberd::Presence->probe(from => $from_jid, 299 to => $to_jid); 300 $probe->procdeliver($vhost); 301 return; 302 } 303 304 #warn " ... not already subscribed from, didn't shortcut.\n"; 305 306 $ritem ||= DJabberd::RosterItem->new($from_jid); 307 308 # ignore duplicate pending-in subscriptions 309 if ($ritem->subscription->pending_in) { 310 warn "ignoring dup inbound subscribe, already pending-in.\n"; 311 return; 312 } 313 314 # TODO: HOOK FOR auto-subscribed sending. violates spec, but LiveJournal 315 # could use it. i think spec isn't thoughtful enough there. 316 317 # mark the roster item as pending-in, and save it: 318 $ritem->subscription->set_pending_in; 319 320 $vhost->run_hook_chain(phase => "RosterSetItem", 321 args => [ $to_jid, $ritem ], 322 methods => { 323 done => sub { 324 $self->deliver($vhost); 325 }, 326 error => sub { my $reason = $_[1]; }, 327 }, 328 ); 329} 330 331sub _process_inbound_subscribed { 332 my ($self, $vhost, $ritem) = @_; 333 Carp::confess("Not a vhost") unless $vhost->isa("DJabberd::VHost"); 334 335 # MUST ignore inbound subscribed if we weren't awaiting 336 # its arrival 337 return unless $ritem && $ritem->subscription->pending_out; 338 339 my $to_jid = $self->to_jid; 340 341 #warn "processing inbound subscribed...\n"; 342 $ritem->subscription->got_inbound_subscribed; 343 344 $vhost->run_hook_chain(phase => "RosterSetItem", 345 args => [ $to_jid, $ritem ], 346 methods => { 347 done => sub { 348 $vhost->roster_push($to_jid, $ritem); 349 350 my $probe = DJabberd::Presence->probe(from => $to_jid, 351 to => $ritem->jid); 352 $probe->procdeliver($vhost); 353 $self->deliver($vhost); 354 }, 355 error => sub { my $reason = $_[1]; }, 356 }, 357 ); 358 359} 360 361sub _process_inbound_probe { 362 my ($self, $vhost, $ritem, $from_jid) = @_; 363 unless ($self->{dont_load_rosteritem}) { 364 return unless $ritem && $ritem->subscription->sub_from; 365 } 366 367 my $jid = $self->to_jid; 368 369 $vhost->check_presence($jid, sub { 370 my $map = shift; 371 foreach my $fullstr (keys %$map) { 372 my $stanza = $map->{$fullstr}; 373 my $to_send = $stanza->clone; 374 $to_send->set_to($from_jid); 375 $to_send->deliver($vhost); 376 } 377 }); 378} 379 380sub _process_inbound_unsubscribe { 381 my ($self, $vhost, $ritem) = @_; 382 383 # if we don't know the user, just drop it 384 return unless $ritem; 385 386 my $to_jid = $self->to_jid; 387 388 $ritem->subscription->got_inbound_unsubscribe; 389 390 $vhost->run_hook_chain(phase => "RosterSetItem", 391 args => [ $to_jid, $ritem ], 392 methods => { 393 done => sub { 394 $vhost->roster_push($to_jid, $ritem); 395 $self->deliver($vhost); 396 }, 397 error => sub { my $reason = $_[1]; }, 398 }, 399 ); 400} 401 402sub _process_inbound_unsubscribed { 403 my ($self, $vhost, $ritem) = @_; 404 405 # TODO: 406 # 1) MUST roster push 407 # 2) MUST deliver to all available resources 408 409 # to -> none 410 # keep it in the roster as 'none', don't remove. client does that with type='remove' 411} 412 413sub broadcast_from { 414 my ($self, $conn) = @_; 415 416 my $from_jid = $conn->bound_jid; 417 my $vhost = $conn->vhost; 418 419 my $broadcast = sub { 420 my $roster = shift; 421 foreach my $it ($roster->from_items) { 422 my $dpres = $self->clone; 423 $dpres->set_to($it->jid); 424 $dpres->set_from($from_jid); 425 $dpres->procdeliver($vhost); 426 } 427 428 # For the purpose of presence broadcasting 429 # we act as if all of the other resources 430 # for this bare JID are on the roster. 431 # This means that resources of the same 432 # JID are aware of each other and can send 433 # messages to each other, etc. 434 foreach my $otherconn ($vhost->find_conns_of_bare($from_jid)) { 435 my $to_jid = $otherconn->bound_jid; 436 next if $from_jid->eq($to_jid); 437 my $dpres = $self->clone; 438 $dpres->set_to($to_jid); 439 $dpres->set_from($from_jid); 440 $dpres->procdeliver($vhost); 441 } 442 }; 443 444 $vhost->get_roster($from_jid, on_success => $broadcast); 445} 446 447sub _process_outbound_available { 448 my ($self, $conn, $skip_alter) = @_; 449 450 my $vhost = $conn->vhost; 451 if (!$skip_alter && $vhost->are_hooks("AlterPresenceAvailable")) { 452 $vhost->run_hook_chain(phase => "AlterPresenceAvailable", 453 args => [ $conn, $self ], 454 methods => { 455 done => sub { 456 return if $conn->{closed}; 457 $self->_process_outbound_available($conn, 1); 458 }, 459 }, 460 ); 461 return; 462 } 463 464 if ($self->is_directed) { 465 $conn->add_directed_presence($self->to_jid); 466 $self->deliver; 467 return; 468 } 469 470 my $jid = $conn->bound_jid; 471 DJabberd::Presence->set_local_presence($jid, $self->clone); 472 473 $conn->set_available(1); 474 475 if ($conn->is_initial_presence) { 476 $conn->on_initial_presence; 477 } 478 479 $self->broadcast_from($conn); 480} 481 482sub _process_outbound_unavailable { 483 my ($self, $conn, $skip_alter) = @_; 484 485 my $vhost = $conn->vhost; 486 if (!$skip_alter && $vhost->are_hooks("AlterPresenceUnavailable")) { 487 warn "runnig hook chain unavailable"; 488 $vhost->run_hook_chain(phase => "AlterPresenceUnavailable", 489 args => [ $conn, $self ], 490 methods => { 491 done => sub { 492 return if $conn->{closed}; 493 $self->_process_outbound_unavailable($conn, 1); 494 }, 495 }, 496 ); 497 return; 498 } 499 500 501 if ($self->is_directed) { 502 delete($conn->{directed_presence}->{$self->to_jid}); 503 $self->deliver; 504 return; 505 } 506 507 # if we are becoming unavailable then we need to tell all our directed presences customers this 508 # per RFC 3921 5.1.4.2 509 510 my $from_jid = $conn->bound_jid; 511 foreach my $to_jid ($conn->directed_presence) { 512 my $dpres = $self->clone; 513 $dpres->set_to($to_jid); 514 $dpres->set_from($from_jid); 515 # I think we only need to deliver and not procdeliver here 516 # because we don't actually want to process it anymore -- sky 517 # TODO: not sure of that. --brad 518 $dpres->deliver($conn->vhost); 519 } 520 $conn->clear_directed_presence; 521 522 my $jid = $conn->bound_jid; 523 DJabberd::Presence->set_local_presence($jid, $self->clone); 524 525 $conn->set_available(0); 526 $self->broadcast_from($conn); 527} 528 529 530sub _process_outbound_unsubscribe { 531 my ($self, $conn, $ritem) = @_; 532 533 my $from_jid = $self->from_jid; 534 my $to_jid = $self->to_jid or die "Can't subscribe to bogus jid"; 535 536 # we didn't have this user; 537 return unless $ritem; 538 539 $ritem->subscription->got_outbound_unsubscribe; 540 541 $conn->vhost->run_hook_chain(phase => "RosterSetItem", 542 args => [ $from_jid, $ritem ], 543 methods => { 544 done => sub { 545 # xmpp-ip 8.4.[12] 546 # roster push, (to => none, both => from) 547 # deliver. 548 $conn->vhost->roster_push($from_jid, $ritem); 549 550 # let's bare-ifiy our from address, as per the SHOULD in XMPP-IM 8.2.5 551 # {=remove-resource-on-presence-out} 552 $self->set_from($self->from_jid->as_bare_string); 553 $self->procdeliver($conn->vhost); 554 }, 555 error => sub { my $reason = $_[1]; }, 556 } 557 ); 558 559} 560 561sub _process_outbound_unsubscribed { 562 my ($self, $conn, $ritem) = @_; 563 564 my $deliver = sub { 565 $self->set_from($self->from_jid->as_bare_string); 566 $self->procdeliver($conn->vhost); 567 }; 568 569 # no relation, but deliver anyway.... 570 unless ($ritem) { 571 # TODO: we should deliver these, I assume, as that's consistent 572 # with other parts of spec wrt inter-server sync issues? --brad 573 $deliver->(); 574 return; 575 } 576 577 my $from_jid = $conn->bound_jid; 578 my $contact_jid = $self->to_jid or die "Can't subscribe to bogus jid"; 579 580 # xmpp-ip 8.5.[12] 581 # roster push (from => none, both => to), clearing pendin as well... 582 $ritem->subscription->got_outbound_unsubscribed; 583 584 $conn->vhost->run_hook_chain(phase => "RosterSetItem", 585 args => [ $from_jid, $ritem ], 586 methods => { 587 done => sub { 588 $conn->vhost->roster_push($from_jid, $ritem); 589 590 # continue this packet along to contact 591 $self->set_from($self->from_jid->as_bare_string); 592 $self->procdeliver($conn->vhost); 593 594 # send unavailable presence to contact: 595 my $unavail = DJabberd::Presence->unavailable_stanza; 596 $unavail->set_to($contact_jid); 597 $unavail->set_from($from_jid); 598 $unavail->deliver($conn->vhost); # procdeliver's useless: proc just delivers 599 }, 600 error => sub { my $reason = $_[1]; }, 601 }, 602 ); 603} 604 605 606sub _process_outbound_subscribe { 607 my ($self, $conn) = @_; 608 609 my $from_jid = $conn->bound_jid; 610 my $contact_jid = $self->to_jid or die "Can't subscribe to bogus jid"; 611 612 # XMPPIP-9.2-p2: MUST without exception 613 # route these, to combat sync issues 614 # between parties 615 616 my $deliver = sub { 617 # let's bare-ifiy our from address, as per the SHOULD in XMPP-IM 8.2.5 618 # {=remove-resource-on-presence-out} 619 $self->set_from($self->from_jid->as_bare_string); 620 621 $self->procdeliver($conn->vhost); 622 }; 623 624 my $save = sub { 625 my $ritem = shift; 626 $conn->vhost->run_hook_chain(phase => "RosterSetItem", 627 args => [ $from_jid, $ritem ], 628 methods => { 629 done => sub { 630 $conn->vhost->roster_push($from_jid, $ritem); 631 $deliver->(); 632 }, 633 error => sub { my $reason = $_[1]; }, 634 }, 635 ); 636 }; 637 638 my $on_load = sub { 639 my (undef, $ritem) = @_; 640 641 # not in roster, skip. 642 $ritem ||= DJabberd::RosterItem->new($contact_jid); 643 644 if ($ritem->subscription->got_outbound_subscribe) { 645 # subscription modified, must save, which will then 646 # deliver when done. 647 $save->($ritem); 648 } else { 649 $deliver->(); 650 } 651 }; 652 653 $conn->vhost->run_hook_chain(phase => "RosterLoadItem", 654 args => [ $from_jid, $contact_jid ], 655 methods => { 656 error => sub { 657 my (undef, $reason) = @_; 658 return $self->fail($conn, "RosterLoadItem hook failed: $reason"); 659 }, 660 set => $on_load, 661 }); 662} 663 664 665 666sub _process_outbound_subscribed { 667 my ($self, $conn) = @_; 668 669 # user wanting to subscribe or approve subscription request to contact 670 my $contact_jid = $self->to_jid 671 or return $self->fail($conn, "no/invalid 'to' attribute"); 672 673 $conn->vhost->run_hook_chain(phase => "RosterLoadItem", 674 args => [ $conn->bound_jid, $contact_jid ], 675 methods => { 676 error => sub { 677 my (undef, $reason) = @_; 678 return $self->fail($conn, "RosterLoadItem hook failed: $reason"); 679 }, 680 set => sub { 681 my (undef, $ritem) = @_; 682 683 # not in roster, skip. 684 return unless $ritem; 685 686 my $subs = $ritem->subscription; 687 688 # skip unless we were in pending in state 689 return unless $subs->pending_in; 690 691 $self->_process_outbound_subscribed_with_ritem($conn, $ritem); 692 }, 693 }); 694} 695 696# second stage of outbound 'subscribed' processing, once we load the item and 697# decide to skip processing or not. see above. 698sub _process_outbound_subscribed_with_ritem { 699 my ($self, $conn, $ritem) = @_; 700 my $vhost = $conn->vhost; 701 $ritem->subscription->got_outbound_subscribed; 702 703 my $from_jid = $conn->bound_jid || die("lacking from_jid"); 704 my $to_jid = $self->to_jid; 705 706 $conn->vhost->run_hook_chain(phase => "RosterSetItem", 707 args => [ $conn->bound_jid, $ritem ], 708 methods => { 709 done => sub { 710 $conn->vhost->roster_push($conn->bound_jid, $ritem); 711 $self->procdeliver($conn->vhost); 712 713 # the spec's a little unclear as to whether, on successful subscribe, 714 # host A sends probes vs. host B sends the presence out. we do both, 715 # as does ejabberd and other servers. 716 $vhost->check_presence($conn->bound_jid, sub { 717 my $map = shift; 718 foreach my $fullstr (keys %$map) { 719 my $stanza = $map->{$fullstr}; 720 my $to_send = $stanza->clone; 721 $to_send->set_to($to_jid); 722 $to_send->deliver($vhost); 723 } 724 }); 725 }, 726 error => sub { my $reason = $_[1]; }, 727 }, 728 ); 729} 730 731 7321; 733