view release on metacpan or  search on metacpan

lib/DJabberd/Connection.pm  view on Meta::CPAN

            'ssl',            # undef when not in ssl mode, else the $ssl object from Net::SSLeay
            'stream_id',      # undef until set first time
            'to_host',        # undef until stream start
            'version',        # the DJabberd::StreamVersion we negotiated
            'rcvd_features',  # the features stanza we've received from the other party
            'log',            # Log::Log4perl object for this connection
            'xmllog',         # Log::Log4perl object that controls raw xml logging
            'id',             # connection id, used for logging purposes
            'write_when_readable',  # arrayref/bool, for SSL:  as boolean, we're only readable so we can write again.
                                    # but bool true is actually an arrayref of previous watch_read state
            'iqctr',          # iq counter.  incremented whenever we SEND an iq to the party (roster pushes, etc)
            'in_stream',      # bool:  true if we're in a stream tag
            'counted_close',  # bool:  temporary here to track down the overcounting of disconnects
            'disconnect_handlers',  # array of coderefs to call when this connection is closed for any reason
            'sasl',           # the sasl connection object, when sasl has been or is being negotiated
            );

our $connection_id = 1;

use XML::SAX ();
use DJabberd::XMLParser;
use Digest::SHA1 qw(sha1_hex);

use DJabberd::SAXHandler;
use DJabberd::JID;
use DJabberd::IQ;
use DJabberd::Message;
use DJabberd::Util qw(exml tsub);

use Data::Dumper;
use Carp qw(croak);

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

use constant POLLIN        => 1;
use constant POLLOUT       => 4;

BEGIN {
    my $xmldebug = $ENV{XMLDEBUG};

    if ($xmldebug) {
        eval 'use constant XMLDEBUG => "' . quotemeta($xmldebug) . '"';
        die "XMLDEBUG path '$xmldebug' needs to be a directory writable by the user you are running $0 as\n" unless -w $xmldebug;
    } else {
        eval "use constant XMLDEBUG => ''";
    }
}

our %LOGMAP;

sub new {
    my ($class, $sock, $server) = @_;
    my $self = $class->SUPER::new($sock);

    croak("Server param not a DJabberd (server) object, '" . ref($server) . "'")
        unless $server->isa("DJabberd");

    $self->{vhost}   = undef;  # set once we get a stream start header from them.
    $self->{server}  = $server;
    Scalar::Util::weaken($self->{server});

    $self->{log}     = DJabberd::Log->get_logger($class);

    # hack to inject XML after Connection:: in the logger category
    my $xml_category = $class;
    $xml_category =~ s/Connection::/Connection::XML::/;

    $self->{xmllog}  = DJabberd::Log->get_logger($xml_category);

    my $fromip = $self->peer_ip_string || "<undef>";

    # a health check monitor doesn't get an id assigned/wasted on it, and doesn't log
    # so it's less annoying to look at:
    unless ($server->is_monitor_host($fromip)) {
        $self->{id}      = $connection_id++;
        $self->log->debug("New connection '$self->{id}' from $fromip");
    }

    if (XMLDEBUG) {
        system("mkdir -p " . XMLDEBUG ."/$$/");
        my $handle = IO::Handle->new;
        no warnings;
        my $from = $fromip || "outbound";
        my $filename = "+>" . XMLDEBUG . "/$$/$from-$self->{id}";
        open ($handle, $filename) || die "Cannot open $filename: $!";
        $handle->autoflush(1);
        $LOGMAP{$self} = $handle;
    }
    return $self;
}

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

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

sub handler {
    return $_[0]->{saxhandler};
}

sub vhost {
    my DJabberd::Connection $self = $_[0];
    return $self->{vhost};
}

sub server {
    my DJabberd::Connection $self = $_[0];
    return $self->{server};
}

sub bound_jid {
    my DJabberd::Connection $self = $_[0];
    return $self->{bound_jid};
}

sub new_iq_id {
    my DJabberd::Connection $self = shift;

lib/DJabberd/Connection.pm  view on Meta::CPAN

    $self->{rcvd_features} = $feat_stanza;
}

sub set_bound_jid {
    my ($self, $jid) = @_;
    die unless $jid && $jid->isa('DJabberd::JID');
    $self->{bound_jid} = $jid;
}

sub set_to_host {
    my ($self, $host) = @_;
    $self->{to_host} = $host;
}

sub to_host {
    my $self = shift;
    return $self->{to_host} or
        die "To host accessed before it was set";
}

sub set_version {
    my ($self, $verob) = @_;
    $self->{version} = $verob;
}

sub version {
    my $self = shift;
    return $self->{version} or
        die "Version accessed before it was set";
}

sub stream_id {
    my $self = shift;
    return $self->{stream_id} ||= Digest::SHA1::sha1_hex(rand() . rand() . rand());
}

# only use this run_hook_chain when
sub run_hook_chain {
    my $self = shift;
    my %opts = @_;
    $opts{hook_invocant} = $self;

    my $known_deprecated = delete $opts{deprecated};
    my ($pkg, $filename, $line) = caller;
    my $vhost = $self->vhost;

    unless ($known_deprecated) {
        warn("DEPRECATED caller ($pkg/$filename/$line) of run_hook_chain on a connection\n");
    }
    return DJabberd::VHost::run_hook_chain($vhost, %opts);
}

# this can fail to signal that this connection can't work on this
# vhost for instance, this vhost doesn't support s2s, so a serverin or
# dialback subclass can override this to return 0 when s2s isn't
# enabled for the vhost
sub set_vhost {
    my ($self, $vhost) = @_;
    Carp::croak("Not a DJabberd::VHost: $vhost") unless UNIVERSAL::isa($vhost, "DJabberd::VHost");
    $self->{vhost} = $vhost;
    Scalar::Util::weaken($self->{vhost});
    return 1;
}

# called by DJabberd::SAXHandler
sub on_stanza_received {
    my ($self, $node) = @_;
    die "SUBCLASSES MUST OVERRIDE 'on_stanza_received' for $self\n";
}

# subclasses should override returning 0 or 1
sub is_server {
    die "Undefined 'is_server' for $_[0]";
}

sub process_incoming_stanza_from_s2s_out {
    my ($self, $node) = @_;

    my %stanzas = (
                   "{urn:ietf:params:xml:ns:xmpp-tls}starttls"  => 'DJabberd::Stanza::StartTLS',
                   "{http://etherx.jabber.org/streams}features" => 'DJabberd::Stanza::StreamFeatures',
                   );

    my $class = $stanzas{$node->element};
    unless ($class) {
        warn "Unknown/handled stanza: " . $node->element . " on connection ($self->{id}), " . ref($self) .  "\n";
        return;
    }

    my $obj = $class->downbless($node, $self);
    $obj->on_recv_from_server($self);
}

sub send_stanza {
    my ($self, $stanza) = @_;

    # getter subref for pre_stanza_write hooks to
    # get at their own private copy of the stanza
    my $cloned;
    my $getter = sub {
        return $cloned if $cloned;
        if ($self != $stanza->connection) {
            $cloned = $stanza->clone;
            $cloned->set_connection($self);
        } else {
            $cloned = $stanza;
        }
        return $cloned;
    };

    $self->vhost->hook_chain_fast("pre_stanza_write",
                                  [ $getter ],
                                  {
                                     # TODO: implement.
                                  },
                                  sub {
                                      # if any hooks called the $getter, instantiating
                                      # the $cloned copy, then that's what we write.
                                      # as an optimization (the fast path), we just
                                      # write the untouched, uncloned original.
                                      $self->write_stanza($cloned || $stanza);