lib/DJabberd/VHost.pm

package DJabberd::VHost;
use strict;
use B ();       # improved debugging when hooks are called
use Carp qw(croak);
use DJabberd::Util qw(tsub as_bool);
use DJabberd::Log;
use DJabberd::JID;
use DJabberd::Roster;

our $logger = DJabberd::Log->get_logger();
our $hook_logger = DJabberd::Log->get_logger("DJabberd::Hook");

sub new {
    my ($class, %opts) = @_;

    my $self = {
        'server_name'   => lc(delete $opts{server_name} || ""),
        'require_ssl'   => delete $opts{require_ssl},
        's2s'           => delete $opts{s2s},
        'hooks'         => {},
        'server'        => undef,  # set when added to a server

        # local connections
        'jid2sock'      => {},  # bob@207.7.148.210/rez -> DJabberd::Connection
        'bare2fulls'    => {},  # barejids -> { fulljid -> 1 }

        'quirksmode'    => 1,

        'server_secret' => undef,  # server secret we use for dialback HMAC keys.  trumped
                                   # if a plugin implements a cluster-wide keyed shared secret

        features        => [],     # list of features

        subdomain       => {},  # subdomain => plugin mapping of subdomains we should accept

        inband_reg      => 0,   # bool: inband registration

        roster_cache    => {},  # $barejid_str -> DJabberd::Roster

        roster_wanters  => {},  # $barejid_str -> [ [$on_success, $on_fail]+ ]

        disco_kids      => {},  # $jid_str -> "Description" - children of this vhost for service discovery
        plugin_types    => {},  # ref($plugin instance) -> 1
    };

    croak("Missing/invalid vhost name") unless
        $self->{server_name} && $self->{server_name} =~ /^[-\w\.]+$/;

    my $plugins = delete $opts{plugins};
    croak("Unknown vhost parameters: " . join(", ", keys %opts)) if %opts;

    bless $self, $class;

    $logger->info("Addding plugins...");
    foreach my $pl (@{ $plugins || [] }) {
        $self->add_plugin($pl);
    }

    return $self;
}

sub register_subdomain {
    my ($self, $subdomain, $plugin) = @_;
    my $qualified_subdomain = $subdomain . "." . $self->{server_name};
    $logger->logdie("VHost '$self->{server_name}' already has '$subdomain' registered by plugin '$self->{subdomain}->{$qualified_subdomain}'")
        if $self->{subdomain}->{$qualified_subdomain};

    $self->{subdomain}->{$qualified_subdomain} = $plugin;
}

sub handles_domain {
    my ($self, $domain) = @_;
    if ($self->{server_name} eq $domain) {
        return 1;
    } elsif (exists $self->{subdomain}->{$domain}) {
        return 1;
    } else {
        return 0;
    }
}

sub server_name {
    my $self = shift;
    return $self->{server_name};
}

sub add_feature {
    my ($self, $feature) = @_;
    push @{$self->{features}}, $feature;
}

sub features {
    my ($self) = @_;
    return @{$self->{features}};
}

sub setup_default_plugins {
    my $self = shift;
    unless ($self->are_hooks("deliver")) {
        unless ($self->has_plugin_of_type("DJabberd::Delivery::Local")) {
            $logger->logwarn("Adding implicit plugin DJabberd::Delivery::Local");
            $self->add_plugin(DJabberd::Delivery::Local->new);
        }
        if ($self->s2s && ! $self->has_plugin_of_type("DJabberd::Delivery::S2S")) {
            $logger->logwarn("Adding implicit plugin DJabberd::Delivery::S2S");
            $self->add_plugin(DJabberd::Delivery::S2S->new);
        }
    }

    unless ($self->has_plugin_of_type("DJabberd::Delivery::Local")) {
        $logger->logwarn("No DJabberd::Delivery::Local delivery plugin configured");
    }

    if ($self->s2s && ! $self->has_plugin_of_type("DJabberd::Delivery::S2S")) {
        $logger->logdie("s2s enabled, but no implicit or explicit DJabberd::Delivery::S2S plugin.");
    }

    unless ($self->are_hooks("PresenceCheck")) {
        $self->add_plugin(DJabberd::PresenceChecker::Local->new);
    }
}

sub quirksmode { $_[0]{quirksmode} };

sub set_config_quirksmode {
    my ($self, $val) = @_;
    $self->{quirksmode} = as_bool($val);
}

sub set_config_s2s {
    my ($self, $val) = @_;
    $self->{s2s} = as_bool($val);
}

sub set_config_inbandreg {
    my ($self, $val) = @_;
    $self->{inband_reg} = as_bool($val);
}

sub set_config_childservice {
    my ($self, $val) = @_;

    my ($strjid, $desc) = split(/\s+/, $val, 2);

    my $jid = DJabberd::JID->new($strjid);
    $logger->logdie("Invalid JID ".$strjid) unless $jid;

    $desc ||= $jid->node;

    $logger->info("Registered $strjid as VHost child service: $desc");

    $self->{disco_kids}{$jid} = $desc;
}

sub allow_inband_registration {
    my $self = shift;
    return $self->{inband_reg};
}

sub set_config_requiressl {
    my ($self, $val) = @_;
    $self->{require_ssl} = as_bool($val);
}

# true if vhost has s2s enabled
sub s2s {
    my $self = shift;
    return $self->{s2s};
}

sub child_services {
    return $_[0]->{disco_kids};
}

sub server {
    my $self = shift;
    return $self->{server};
}

sub set_server {
    my ($self, $server) = @_;
    $self->{server} = $server;
    Scalar::Util::weaken($self->{server});
}

sub run_hook_chain {
    my $self = shift;
    my %opts = @_;

    my ($phase, $methods, $args, $fallback, $hook_inv)
        = @opts{qw(phase methods args fallback hook_invocant)};

    if (0) {
        delete @opts{qw(phase methods args fallback hook_invocant)};
        die if %opts;
    }

    hook_chain_fast($self,
                    $phase,
                    $args     || [],
                    $methods  || {},
                    $fallback || sub {},
                    $hook_inv);
}

my $dummy_sub = sub {};

sub hook_chain_fast {
    my ($self, $phase, $args, $methods, $fallback, $hook_inv) = @_;

    # fast path, no phases, only fallback:
    if ($self && ! ref $phase && ! @{ $self->{hooks}->{$phase} || []}) {
        $fallback->($self,
                    DJabberd::Callback->new({
                        _phase     => $phase,
                        decline    => $dummy_sub,
                        declined   => $dummy_sub,
                        stop_chain => $dummy_sub,
                        %$methods,
                    }),
                    @$args) if $fallback;
        return;
    }

    # make phase into an arrayref;
    $phase = [ $phase ] unless ref $phase;

    my @hooks;
    foreach my $ph (@$phase) {
        $logger->logcroak("Undocumented hook phase: '$ph'") unless
            $DJabberd::HookDocs::hook{$ph};

        # self can be undef if the connection object invokes us.
        # because sometimes there is no vhost, as in the case of
        # old serverin dialback without a to address.
        if ($self) {
            push @hooks, @{ $self->{hooks}->{$ph} || [] };
        }
    }
    push @hooks, $fallback if $fallback;

    # pre-declared here so they're captured by closures below
    my ($cb, $try_another, $depth);
    my $hook_count = scalar @hooks;

    my $stopper = sub {
        $try_another = undef;
    };
    $try_another = sub {
        my $hk = shift @hooks
            or return;

        # conditional debug statement -- computing this is costly, so only do this
        # when we are actually running in debug mode --kane
        if ($logger->is_debug) {
            $depth++;

            # most hooks are anonymous sub refs, and it's hard to determine where they
            # came from. Sub::Identify gives you only the name (which is __ANON__) and
            # the filename. This gives us both the filename and line number it's defined
            # on, giving the user a very clear pointer to which subref will be invoked --kane
            #
            # Since this is B pokery, protect us from doing anything wrong and exiting the
            # server accidentally.
            my $cv   = B::svref_2object($hk);
            my $line = eval {
                # $obj is either a B::LISTOP or a B::COP, keep walking up
                # till we reach the B::COP, so we can get the line number;
                my $obj     = $cv->ROOT->first;
                $obj = $obj->first while $obj->can('first');
                $obj->line;
            } || "Unknown ($@)";
            $logger->debug(
                "For phase [@$phase] invoking hook $depth of $hook_count defined at: ".
                $cv->FILE .':'. $line
            );
        }

        $cb->{_has_been_called} = 0;  # cheating version of: $cb->reset;
        $hk->($self || $hook_inv,
              $cb,
              @$args);

        # just in case the last person in the chain forgets
        # to call a callback, we destroy the circular reference ourselves.
        unless (@hooks) {
            $try_another = undef;
            $cb = undef;
        }
    };
    $cb = DJabberd::Callback->new({
        _phase     => $phase->[0],           # just for leak tracking, not needed
        decline    => $try_another,
        declined   => $try_another,
        stop_chain => $stopper,
        _post_fire => sub {
            # when somebody fires this callback, we know
            # we're done (unless it was decline/declined)
            # and we need to clean up circular references
            my $fired = shift;
            unless ($fired =~ /^decline/) {
                $try_another = undef;
                $cb = undef;
            }
        },
        %$methods,
    });

    $try_another->();
}

# return the version of the spec we implement
sub spec_version {
    my $self = shift;
    return $self->{_spec_version} ||= DJabberd::StreamVersion->new("1.0");
}

sub name {
    my $self = shift;
    return $self->{server_name};
}

# vhost method
sub add_plugin {
    my ($self, $plugin) = @_;
    $logger->info("Adding plugin: $plugin");
    $self->{plugin_types}{ref $plugin} = 1;
    $plugin->register($self);
}

*requires_ssl = \&require_ssl;  # english
sub require_ssl {
    my $self = shift;
    return $self->{require_ssl};
}

sub are_hooks {
    my ($self, $phase) = @_;
    return scalar @{ $self->{hooks}{$phase} || [] } ? 1 : 0;
}

sub has_plugin_of_type {
    my ($self, $class) = @_;
    return $self->{plugin_types}{$class};
}

sub register_hook {
    my ($self, $phase, $subref) = @_;
    Carp::croak("Can't register hook on a non-VHost") unless UNIVERSAL::isa($self, "DJabberd::VHost");

    $logger->logcroak("Undocumented hook phase: '$phase'") unless
        $DJabberd::HookDocs::hook{$phase};

    push @{ $self->{hooks}{$phase} ||= [] }, $subref;
}

# lookup a local user by fulljid
sub find_jid {
    my ($self, $jid) = @_;
    return $self->find_jid($jid->as_string) if ref $jid;
    my $sock = $self->{jid2sock}{$jid} or return undef;
    return undef if $sock->{closed};
    return $sock;
}

sub register_jid {
    my ($self, $jid, $resource, $conn, $cb) = @_;

    my $barestr = $jid->as_bare_string; ## $jid should be bare anyway
    my $fullstr = "$barestr/$resource";

    # $cb can ->registered, ->error
    $logger->info("Registering '$fullstr' to connection '$conn->{id}'");

    ## deprecated 0078 appears a bit conflicting with RFC 3920
    ## the recommended behaviour in the latter is to generate a resource for
    ## the dupe. Don't ask me if one resource uses RFC 3920 and the other
    ## XEP 0078 :D. If we detect a sasl connection, we go with the RFC way.
    if (my $econn = $self->{jid2sock}{$fullstr}) {
        if ($conn->sasl) {
            my $resource = DJabberd::JID->rand_resource;
            $fullstr = "$barestr/$resource";
        }
        else {
            $econn->stream_error("conflict");
        }
    }
    my $fulljid = DJabberd::JID->new($fullstr);

    $self->{jid2sock}{$fullstr} = $conn;
    ($self->{bare2fulls}{$barestr} ||= {})->{$fullstr} = 1;  # TODO: this should be the connection, not a 1, saves work in unregister JID?

    $cb->registered($fulljid);
}

sub unregister_jid {
    my ($self, $jid, $conn) = @_;

    my $barestr = $jid->as_bare_string;
    my $fullstr = $jid->as_string;

    my $deleted_fulljid;
    if (my $exist = $self->{jid2sock}{$fullstr}) {
        if ($exist == $conn) {
            delete $self->{jid2sock}{$fullstr};
            $deleted_fulljid = 1;
        }
    }

    if ($deleted_fulljid) {
        if ($self->{bare2fulls}{$barestr}) {
            delete $self->{bare2fulls}{$barestr}{$fullstr};
            unless (%{ $self->{bare2fulls}{$barestr} }) {
                delete $self->{bare2fulls}{$barestr};
            }
        }
    }

}

# given a bare jid, find all local connections
sub find_conns_of_bare {
    my ($self, $jid) = @_;
    my $barestr = $jid->as_bare_string;
    my @conns;
    foreach my $fullstr (keys %{ $self->{bare2fulls}{$barestr} || {} }) {
        my $conn = $self->find_jid($fullstr)
            or next;
        push @conns, $conn;
    }

    return @conns;
}

# returns true if given jid is recognized as "for the server"
sub uses_jid {
    my ($self, $jid) = @_;
    return 0 unless $jid;
    return lc($jid->as_string) eq $self->{server_name};
}

# returns true if given jid is controlled by this vhost
sub handles_jid {
    my ($self, $jid) = @_;
    return 0 unless $jid;
    return lc($jid->domain) eq $self->{server_name};
}

sub roster_push {
    my ($self, $jid, $ritem) = @_;
    croak("no ritem") unless $ritem;

    # kill cache if roster checked;
    my $barestr = $jid->as_bare_string;
    delete $self->{roster_cache}{$barestr};

    # XMPP-IM: howwever a server SHOULD NOT push or deliver roster items
    # in that state to the contact. (None + Pending In)
    return if $ritem->subscription->is_none_pending_in;

    # TODO: single-server roster push only.   need to use a hook
    # to go across the cluster

    my $xml = "<query xmlns='jabber:iq:roster'>";
    $xml .= $ritem->as_xml;
    $xml .= "</query>";

    my @conns = $self->find_conns_of_bare($jid);
    foreach my $c (@conns) {
        next unless $c->is_available && $c->requested_roster;
        my $id = $c->new_iq_id;
        my $iq = "<iq to='" . $c->bound_jid->as_string_exml . "' type='set' id='$id'>$xml</iq>";
        $c->xmllog->info($iq);
        $c->write(\$iq);
    }
}

sub get_secret_key {
    my ($self, $cb) = @_;
    $cb->("i", $self->{server_secret} ||= join('', map { rand() } (1..20)));
}

sub get_secret_key_by_handle {
    my ($self, $handle, $cb) = @_;
    if ($handle eq "i") {
        # internal
        $cb->($self->{server_secret});
    } else {
        # bogus handle.  currently only handle "i" is supported.
        $cb->(undef);
    }
}

sub get_roster {
    my ($self, $jid, %meth) = @_;
    my $good_cb = delete $meth{'on_success'};
    my $bad_cb  = delete $meth{'on_fail'};
    Carp::croak("unknown args") if %meth;

    my $barestr = $jid->as_bare_string;

    # see if it's cached.
    if (my $roster = $self->{roster_cache}{$barestr}) {
        if ($roster->inc_cache_gets >= 3) {
            delete $self->{roster_cache}{$barestr};
        }
        $good_cb->($roster);
        return;
    }

    # upon connect there are three immediate requests of a user's
    # roster, then pretty much never again, but those three can,
    # depending on the client's preference between sending initial
    # presence vs. roster get first, be 3 loads in parallel, or 1,
    # then 2 in parallel.  in any case, multiple async loads can be in
    # flight at once, so let's keep a list of roster-wanters and only
    # do one request, then send the answer to everybody.  the
    # $kick_off_load is to keep track of whether or not this is the
    # first request that actually has to start loading it, or we're a
    # 2nd/3rd caller.
    my $kick_off_load = 0;

    my $list = $self->{roster_wanters}{$barestr} ||= [];
    $kick_off_load = 1 unless @$list;
    push @$list, [$good_cb, $bad_cb];
    return unless $kick_off_load;

    $self->run_hook_chain(phase => "RosterGet",
                          args  => [ $jid ],
                          methods => {
                              set_roster => sub {
                                  my $roster = $_[1];
                                  $self->{roster_cache}{$barestr} = $roster;

                                  # upon connect there are three immediate requests of a user's
                                  # roster, then pretty much never again, so we keep it cached 5 seconds,
                                  # then discard it.
                                  Danga::Socket->AddTimer(5.0, sub {
                                      delete $self->{roster_cache}{$barestr};
                                  });

                                  # call all the on-success items, but deleting the current list
                                  # first, lest any of the callbacks load more roster items
                                  delete $self->{roster_wanters}{$barestr};
                                  my $done = 0;
                                  foreach my $li (@$list) {
                                      $li->[0]->($roster);
                                      $done = 1 if $roster->inc_cache_gets >= 3;
                                  }

                                  # if they've used it three times, they're done with
                                  # the initial roster, probes, and broadcast, so drop
                                  # it early, not waiting for 5 seconds.
                                  if ($done) {
                                      delete $self->{roster_cache}{$barestr};
                                  }
                              },
                          },
                          fallback => sub {
                              # call all the on-fail items, but deleting the current list
                              # first, lest any of the callbacks load more roster items
                              delete $self->{roster_wanters}{$barestr};
                              foreach my $li (@$list) {
                                  $li->[1]->() if $li->[1];
                              }
                          });
}

# $jidarg can be a $jid for now.  future:  arrayref of jid objs
# $cb is $cb->($map) where $map is hashref of fulljidstr -> $presence_stanza_obj
sub check_presence {
    my ($self, $jidarg, $cb) = @_;

    my %map;
    my $add_presence = sub {
        my ($jid, $stanza) = @_;
        $map{$jid->as_string} = $stanza;
    };

    # this hook chain is a little different, it's expected
    # to always fall through to the end.
    $self->run_hook_chain(phase => "PresenceCheck",
                           args  => [ $jidarg, $add_presence ],
                           fallback => sub {
                               $cb->(\%map);
                           });
}

sub debug {
    my $self = shift;
    return unless $self->{debug};
    printf STDERR @_;
}


# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

1;