1package DJabberd::VHost; 2use strict; 3use B (); # improved debugging when hooks are called 4use Carp qw(croak); 5use DJabberd::Util qw(tsub as_bool); 6use DJabberd::Log; 7use DJabberd::JID; 8use DJabberd::Roster; 9 10our $logger = DJabberd::Log->get_logger(); 11our $hook_logger = DJabberd::Log->get_logger("DJabberd::Hook"); 12 13sub new { 14 my ($class, %opts) = @_; 15 16 my $self = { 17 'server_name' => lc(delete $opts{server_name} || ""), 18 'require_ssl' => delete $opts{require_ssl}, 19 's2s' => delete $opts{s2s}, 20 'hooks' => {}, 21 'server' => undef, # set when added to a server 22 23 # local connections 24 'jid2sock' => {}, # bob@207.7.148.210/rez -> DJabberd::Connection 25 'bare2fulls' => {}, # barejids -> { fulljid -> 1 } 26 27 'quirksmode' => 1, 28 29 'server_secret' => undef, # server secret we use for dialback HMAC keys. trumped 30 # if a plugin implements a cluster-wide keyed shared secret 31 32 features => [], # list of features 33 34 subdomain => {}, # subdomain => plugin mapping of subdomains we should accept 35 36 inband_reg => 0, # bool: inband registration 37 38 roster_cache => {}, # $barejid_str -> DJabberd::Roster 39 40 roster_wanters => {}, # $barejid_str -> [ [$on_success, $on_fail]+ ] 41 42 disco_kids => {}, # $jid_str -> "Description" - children of this vhost for service discovery 43 plugin_types => {}, # ref($plugin instance) -> 1 44 }; 45 46 croak("Missing/invalid vhost name") unless 47 $self->{server_name} && $self->{server_name} =~ /^[-\w\.]+$/; 48 49 my $plugins = delete $opts{plugins}; 50 croak("Unknown vhost parameters: " . join(", ", keys %opts)) if %opts; 51 52 bless $self, $class; 53 54 $logger->info("Addding plugins..."); 55 foreach my $pl (@{ $plugins || [] }) { 56 $self->add_plugin($pl); 57 } 58 59 return $self; 60} 61 62sub register_subdomain { 63 my ($self, $subdomain, $plugin) = @_; 64 my $qualified_subdomain = $subdomain . "." . $self->{server_name}; 65 $logger->logdie("VHost '$self->{server_name}' already has '$subdomain' registered by plugin '$self->{subdomain}->{$qualified_subdomain}'") 66 if $self->{subdomain}->{$qualified_subdomain}; 67 68 $self->{subdomain}->{$qualified_subdomain} = $plugin; 69} 70 71sub handles_domain { 72 my ($self, $domain) = @_; 73 if ($self->{server_name} eq $domain) { 74 return 1; 75 } elsif (exists $self->{subdomain}->{$domain}) { 76 return 1; 77 } else { 78 return 0; 79 } 80} 81 82sub server_name { 83 my $self = shift; 84 return $self->{server_name}; 85} 86 87sub add_feature { 88 my ($self, $feature) = @_; 89 push @{$self->{features}}, $feature; 90} 91 92sub features { 93 my ($self) = @_; 94 return @{$self->{features}}; 95} 96 97sub setup_default_plugins { 98 my $self = shift; 99 unless ($self->are_hooks("deliver")) { 100 unless ($self->has_plugin_of_type("DJabberd::Delivery::Local")) { 101 $logger->logwarn("Adding implicit plugin DJabberd::Delivery::Local"); 102 $self->add_plugin(DJabberd::Delivery::Local->new); 103 } 104 if ($self->s2s && ! $self->has_plugin_of_type("DJabberd::Delivery::S2S")) { 105 $logger->logwarn("Adding implicit plugin DJabberd::Delivery::S2S"); 106 $self->add_plugin(DJabberd::Delivery::S2S->new); 107 } 108 } 109 110 unless ($self->has_plugin_of_type("DJabberd::Delivery::Local")) { 111 $logger->logwarn("No DJabberd::Delivery::Local delivery plugin configured"); 112 } 113 114 if ($self->s2s && ! $self->has_plugin_of_type("DJabberd::Delivery::S2S")) { 115 $logger->logdie("s2s enabled, but no implicit or explicit DJabberd::Delivery::S2S plugin."); 116 } 117 118 unless ($self->are_hooks("PresenceCheck")) { 119 $self->add_plugin(DJabberd::PresenceChecker::Local->new); 120 } 121} 122 123sub quirksmode { $_[0]{quirksmode} }; 124 125sub set_config_quirksmode { 126 my ($self, $val) = @_; 127 $self->{quirksmode} = as_bool($val); 128} 129 130sub set_config_s2s { 131 my ($self, $val) = @_; 132 $self->{s2s} = as_bool($val); 133} 134 135sub set_config_inbandreg { 136 my ($self, $val) = @_; 137 $self->{inband_reg} = as_bool($val); 138} 139 140sub set_config_childservice { 141 my ($self, $val) = @_; 142 143 my ($strjid, $desc) = split(/\s+/, $val, 2); 144 145 my $jid = DJabberd::JID->new($strjid); 146 $logger->logdie("Invalid JID ".$strjid) unless $jid; 147 148 $desc ||= $jid->node; 149 150 $logger->info("Registered $strjid as VHost child service: $desc"); 151 152 $self->{disco_kids}{$jid} = $desc; 153} 154 155sub allow_inband_registration { 156 my $self = shift; 157 return $self->{inband_reg}; 158} 159 160sub set_config_requiressl { 161 my ($self, $val) = @_; 162 $self->{require_ssl} = as_bool($val); 163} 164 165# true if vhost has s2s enabled 166sub s2s { 167 my $self = shift; 168 return $self->{s2s}; 169} 170 171sub child_services { 172 return $_[0]->{disco_kids}; 173} 174 175sub server { 176 my $self = shift; 177 return $self->{server}; 178} 179 180sub set_server { 181 my ($self, $server) = @_; 182 $self->{server} = $server; 183 Scalar::Util::weaken($self->{server}); 184} 185 186sub run_hook_chain { 187 my $self = shift; 188 my %opts = @_; 189 190 my ($phase, $methods, $args, $fallback, $hook_inv) 191 = @opts{qw(phase methods args fallback hook_invocant)}; 192 193 if (0) { 194 delete @opts{qw(phase methods args fallback hook_invocant)}; 195 die if %opts; 196 } 197 198 hook_chain_fast($self, 199 $phase, 200 $args || [], 201 $methods || {}, 202 $fallback || sub {}, 203 $hook_inv); 204} 205 206my $dummy_sub = sub {}; 207 208sub hook_chain_fast { 209 my ($self, $phase, $args, $methods, $fallback, $hook_inv) = @_; 210 211 # fast path, no phases, only fallback: 212 if ($self && ! ref $phase && ! @{ $self->{hooks}->{$phase} || []}) { 213 $fallback->($self, 214 DJabberd::Callback->new({ 215 _phase => $phase, 216 decline => $dummy_sub, 217 declined => $dummy_sub, 218 stop_chain => $dummy_sub, 219 %$methods, 220 }), 221 @$args) if $fallback; 222 return; 223 } 224 225 # make phase into an arrayref; 226 $phase = [ $phase ] unless ref $phase; 227 228 my @hooks; 229 foreach my $ph (@$phase) { 230 $logger->logcroak("Undocumented hook phase: '$ph'") unless 231 $DJabberd::HookDocs::hook{$ph}; 232 233 # self can be undef if the connection object invokes us. 234 # because sometimes there is no vhost, as in the case of 235 # old serverin dialback without a to address. 236 if ($self) { 237 push @hooks, @{ $self->{hooks}->{$ph} || [] }; 238 } 239 } 240 push @hooks, $fallback if $fallback; 241 242 # pre-declared here so they're captured by closures below 243 my ($cb, $try_another, $depth); 244 my $hook_count = scalar @hooks; 245 246 my $stopper = sub { 247 $try_another = undef; 248 }; 249 $try_another = sub { 250 my $hk = shift @hooks 251 or return; 252 253 # conditional debug statement -- computing this is costly, so only do this 254 # when we are actually running in debug mode --kane 255 if ($logger->is_debug) { 256 $depth++; 257 258 # most hooks are anonymous sub refs, and it's hard to determine where they 259 # came from. Sub::Identify gives you only the name (which is __ANON__) and 260 # the filename. This gives us both the filename and line number it's defined 261 # on, giving the user a very clear pointer to which subref will be invoked --kane 262 # 263 # Since this is B pokery, protect us from doing anything wrong and exiting the 264 # server accidentally. 265 my $cv = B::svref_2object($hk); 266 my $line = eval { 267 # $obj is either a B::LISTOP or a B::COP, keep walking up 268 # till we reach the B::COP, so we can get the line number; 269 my $obj = $cv->ROOT->first; 270 $obj = $obj->first while $obj->can('first'); 271 $obj->line; 272 } || "Unknown ($@)"; 273 $logger->debug( 274 "For phase [@$phase] invoking hook $depth of $hook_count defined at: ". 275 $cv->FILE .':'. $line 276 ); 277 } 278 279 $cb->{_has_been_called} = 0; # cheating version of: $cb->reset; 280 $hk->($self || $hook_inv, 281 $cb, 282 @$args); 283 284 # just in case the last person in the chain forgets 285 # to call a callback, we destroy the circular reference ourselves. 286 unless (@hooks) { 287 $try_another = undef; 288 $cb = undef; 289 } 290 }; 291 $cb = DJabberd::Callback->new({ 292 _phase => $phase->[0], # just for leak tracking, not needed 293 decline => $try_another, 294 declined => $try_another, 295 stop_chain => $stopper, 296 _post_fire => sub { 297 # when somebody fires this callback, we know 298 # we're done (unless it was decline/declined) 299 # and we need to clean up circular references 300 my $fired = shift; 301 unless ($fired =~ /^decline/) { 302 $try_another = undef; 303 $cb = undef; 304 } 305 }, 306 %$methods, 307 }); 308 309 $try_another->(); 310} 311 312# return the version of the spec we implement 313sub spec_version { 314 my $self = shift; 315 return $self->{_spec_version} ||= DJabberd::StreamVersion->new("1.0"); 316} 317 318sub name { 319 my $self = shift; 320 return $self->{server_name}; 321} 322 323# vhost method 324sub add_plugin { 325 my ($self, $plugin) = @_; 326 $logger->info("Adding plugin: $plugin"); 327 $self->{plugin_types}{ref $plugin} = 1; 328 $plugin->register($self); 329} 330 331*requires_ssl = \&require_ssl; # english 332sub require_ssl { 333 my $self = shift; 334 return $self->{require_ssl}; 335} 336 337sub are_hooks { 338 my ($self, $phase) = @_; 339 return scalar @{ $self->{hooks}{$phase} || [] } ? 1 : 0; 340} 341 342sub has_plugin_of_type { 343 my ($self, $class) = @_; 344 return $self->{plugin_types}{$class}; 345} 346 347sub register_hook { 348 my ($self, $phase, $subref) = @_; 349 Carp::croak("Can't register hook on a non-VHost") unless UNIVERSAL::isa($self, "DJabberd::VHost"); 350 351 $logger->logcroak("Undocumented hook phase: '$phase'") unless 352 $DJabberd::HookDocs::hook{$phase}; 353 354 push @{ $self->{hooks}{$phase} ||= [] }, $subref; 355} 356 357# lookup a local user by fulljid 358sub find_jid { 359 my ($self, $jid) = @_; 360 return $self->find_jid($jid->as_string) if ref $jid; 361 my $sock = $self->{jid2sock}{$jid} or return undef; 362 return undef if $sock->{closed}; 363 return $sock; 364} 365 366sub register_jid { 367 my ($self, $jid, $resource, $conn, $cb) = @_; 368 369 my $barestr = $jid->as_bare_string; ## $jid should be bare anyway 370 my $fullstr = "$barestr/$resource"; 371 372 # $cb can ->registered, ->error 373 $logger->info("Registering '$fullstr' to connection '$conn->{id}'"); 374 375 ## deprecated 0078 appears a bit conflicting with RFC 3920 376 ## the recommended behaviour in the latter is to generate a resource for 377 ## the dupe. Don't ask me if one resource uses RFC 3920 and the other 378 ## XEP 0078 :D. If we detect a sasl connection, we go with the RFC way. 379 if (my $econn = $self->{jid2sock}{$fullstr}) { 380 if ($conn->sasl) { 381 my $resource = DJabberd::JID->rand_resource; 382 $fullstr = "$barestr/$resource"; 383 } 384 else { 385 $econn->stream_error("conflict"); 386 } 387 } 388 my $fulljid = DJabberd::JID->new($fullstr); 389 390 $self->{jid2sock}{$fullstr} = $conn; 391 ($self->{bare2fulls}{$barestr} ||= {})->{$fullstr} = 1; # TODO: this should be the connection, not a 1, saves work in unregister JID? 392 393 $cb->registered($fulljid); 394} 395 396sub unregister_jid { 397 my ($self, $jid, $conn) = @_; 398 399 my $barestr = $jid->as_bare_string; 400 my $fullstr = $jid->as_string; 401 402 my $deleted_fulljid; 403 if (my $exist = $self->{jid2sock}{$fullstr}) { 404 if ($exist == $conn) { 405 delete $self->{jid2sock}{$fullstr}; 406 $deleted_fulljid = 1; 407 } 408 } 409 410 if ($deleted_fulljid) { 411 if ($self->{bare2fulls}{$barestr}) { 412 delete $self->{bare2fulls}{$barestr}{$fullstr}; 413 unless (%{ $self->{bare2fulls}{$barestr} }) { 414 delete $self->{bare2fulls}{$barestr}; 415 } 416 } 417 } 418 419} 420 421# given a bare jid, find all local connections 422sub find_conns_of_bare { 423 my ($self, $jid) = @_; 424 my $barestr = $jid->as_bare_string; 425 my @conns; 426 foreach my $fullstr (keys %{ $self->{bare2fulls}{$barestr} || {} }) { 427 my $conn = $self->find_jid($fullstr) 428 or next; 429 push @conns, $conn; 430 } 431 432 return @conns; 433} 434 435# returns true if given jid is recognized as "for the server" 436sub uses_jid { 437 my ($self, $jid) = @_; 438 return 0 unless $jid; 439 return lc($jid->as_string) eq $self->{server_name}; 440} 441 442# returns true if given jid is controlled by this vhost 443sub handles_jid { 444 my ($self, $jid) = @_; 445 return 0 unless $jid; 446 return lc($jid->domain) eq $self->{server_name}; 447} 448 449sub roster_push { 450 my ($self, $jid, $ritem) = @_; 451 croak("no ritem") unless $ritem; 452 453 # kill cache if roster checked; 454 my $barestr = $jid->as_bare_string; 455 delete $self->{roster_cache}{$barestr}; 456 457 # XMPP-IM: howwever a server SHOULD NOT push or deliver roster items 458 # in that state to the contact. (None + Pending In) 459 return if $ritem->subscription->is_none_pending_in; 460 461 # TODO: single-server roster push only. need to use a hook 462 # to go across the cluster 463 464 my $xml = "<query xmlns='jabber:iq:roster'>"; 465 $xml .= $ritem->as_xml; 466 $xml .= "</query>"; 467 468 my @conns = $self->find_conns_of_bare($jid); 469 foreach my $c (@conns) { 470 next unless $c->is_available && $c->requested_roster; 471 my $id = $c->new_iq_id; 472 my $iq = "<iq to='" . $c->bound_jid->as_string_exml . "' type='set' id='$id'>$xml</iq>"; 473 $c->xmllog->info($iq); 474 $c->write(\$iq); 475 } 476} 477 478sub get_secret_key { 479 my ($self, $cb) = @_; 480 $cb->("i", $self->{server_secret} ||= join('', map { rand() } (1..20))); 481} 482 483sub get_secret_key_by_handle { 484 my ($self, $handle, $cb) = @_; 485 if ($handle eq "i") { 486 # internal 487 $cb->($self->{server_secret}); 488 } else { 489 # bogus handle. currently only handle "i" is supported. 490 $cb->(undef); 491 } 492} 493 494sub get_roster { 495 my ($self, $jid, %meth) = @_; 496 my $good_cb = delete $meth{'on_success'}; 497 my $bad_cb = delete $meth{'on_fail'}; 498 Carp::croak("unknown args") if %meth; 499 500 my $barestr = $jid->as_bare_string; 501 502 # see if it's cached. 503 if (my $roster = $self->{roster_cache}{$barestr}) { 504 if ($roster->inc_cache_gets >= 3) { 505 delete $self->{roster_cache}{$barestr}; 506 } 507 $good_cb->($roster); 508 return; 509 } 510 511 # upon connect there are three immediate requests of a user's 512 # roster, then pretty much never again, but those three can, 513 # depending on the client's preference between sending initial 514 # presence vs. roster get first, be 3 loads in parallel, or 1, 515 # then 2 in parallel. in any case, multiple async loads can be in 516 # flight at once, so let's keep a list of roster-wanters and only 517 # do one request, then send the answer to everybody. the 518 # $kick_off_load is to keep track of whether or not this is the 519 # first request that actually has to start loading it, or we're a 520 # 2nd/3rd caller. 521 my $kick_off_load = 0; 522 523 my $list = $self->{roster_wanters}{$barestr} ||= []; 524 $kick_off_load = 1 unless @$list; 525 push @$list, [$good_cb, $bad_cb]; 526 return unless $kick_off_load; 527 528 $self->run_hook_chain(phase => "RosterGet", 529 args => [ $jid ], 530 methods => { 531 set_roster => sub { 532 my $roster = $_[1]; 533 $self->{roster_cache}{$barestr} = $roster; 534 535 # upon connect there are three immediate requests of a user's 536 # roster, then pretty much never again, so we keep it cached 5 seconds, 537 # then discard it. 538 Danga::Socket->AddTimer(5.0, sub { 539 delete $self->{roster_cache}{$barestr}; 540 }); 541 542 # call all the on-success items, but deleting the current list 543 # first, lest any of the callbacks load more roster items 544 delete $self->{roster_wanters}{$barestr}; 545 my $done = 0; 546 foreach my $li (@$list) { 547 $li->[0]->($roster); 548 $done = 1 if $roster->inc_cache_gets >= 3; 549 } 550 551 # if they've used it three times, they're done with 552 # the initial roster, probes, and broadcast, so drop 553 # it early, not waiting for 5 seconds. 554 if ($done) { 555 delete $self->{roster_cache}{$barestr}; 556 } 557 }, 558 }, 559 fallback => sub { 560 # call all the on-fail items, but deleting the current list 561 # first, lest any of the callbacks load more roster items 562 delete $self->{roster_wanters}{$barestr}; 563 foreach my $li (@$list) { 564 $li->[1]->() if $li->[1]; 565 } 566 }); 567} 568 569# $jidarg can be a $jid for now. future: arrayref of jid objs 570# $cb is $cb->($map) where $map is hashref of fulljidstr -> $presence_stanza_obj 571sub check_presence { 572 my ($self, $jidarg, $cb) = @_; 573 574 my %map; 575 my $add_presence = sub { 576 my ($jid, $stanza) = @_; 577 $map{$jid->as_string} = $stanza; 578 }; 579 580 # this hook chain is a little different, it's expected 581 # to always fall through to the end. 582 $self->run_hook_chain(phase => "PresenceCheck", 583 args => [ $jidarg, $add_presence ], 584 fallback => sub { 585 $cb->(\%map); 586 }); 587} 588 589sub debug { 590 my $self = shift; 591 return unless $self->{debug}; 592 printf STDERR @_; 593} 594 595 596# Local Variables: 597# mode: perl 598# c-basic-indent: 4 599# indent-tabs-mode: nil 600# End: 601 6021; 603