view release on metacpan or  search on metacpan

lib/Net/Server.pm  view on Meta::CPAN

    if (length($prop->{'log_file'})
        && !$prop->{'log_function'}) {
        open STDERR, '>&_SERVER_LOG' || die "Cannot open STDERR to _SERVER_LOG [$!]";
    } elsif ($prop->{'setsid'}) { # completely daemonize by closing STDERR (should be done after fork)
        open STDERR, '>&STDOUT' || die "Cannot open STDERR to STDOUT [$!]";
    }

    # allow for a pid file (must be done after backgrounding and chrooting)
    # Remove of this pid may fail after a chroot to another location... however it doesn't interfere either.
    if ($prop->{'pid_file'}) {
        if (eval { create_pid_file($prop->{'pid_file'}) }) {
            $prop->{'pid_file_unlink'} = 1;
        } else {
            $self->fatal(my $e = $@);
        }
    }

    # make sure that allow and deny look like array refs
    $prop->{$_} = [] for grep {! ref $prop->{$_}} qw(allow deny cidr_allow cidr_deny);

    $prop->{'reverse_lookups'} ||= 1 if $prop->{'double_reverse_lookups'};
    $prop->{'double_reverse_lookups'} = $1 || $prop->{'double_reverse_lookups'} || 1
        if $prop->{'reverse_lookups'} && $prop->{'reverse_lookups'} =~ /^(?:double|2)(.*)$/i;
}

sub initialize_logging {
    my $self = shift;
    my $prop = $self->{'server'};
    if (! defined($prop->{'log_file'})) {
        $prop->{'log_file'} = ''; # log to STDERR
        return;
    }

    # pluggable logging
    if (my $code = $prop->{'log_function'}) {
        if (ref $code ne 'CODE') {
            require Scalar::Util;
            croak "Passed log_function $code was not a valid method of server, or was not a code object" if ! $self->can($code);
            my $copy = $self;
            $prop->{'log_function'} = sub { $copy->$code(@_) };
            Scalar::Util::weaken($copy);
        }
    } elsif ($prop->{'log_file'} =~ /^([a-zA-Z]\w*(?:::[a-zA-Z]\w*)*)$/) {
        my $pkg  = "Net::Server::Log::$prop->{'log_file'}";
        (my $file = "$pkg.pm") =~ s|::|/|g;
        if (eval { require $file }) {
            $prop->{'log_function'} = $pkg->initialize($self);
            $prop->{'log_class'}    = $pkg;
            return;
        } elsif ($file =~ /::/ || grep {-e "$_/$file"} @INC) {
            $self->fatal("Unable to load log module $pkg from file $file: $@");
        }
    }

    # regular file based logging
    croak "Unsecure filename \"$prop->{'log_file'}\"" if $prop->{'log_file'} !~ m|^([\:\w\.\-/\\]+)$|;
    $prop->{'log_file'} = $1; # open a logging file
    open(_SERVER_LOG, ">>", $prop->{'log_file'})
        || croak "Couldn't open log file \"$prop->{'log_file'}\" [$!]";
    _SERVER_LOG->autoflush(1);
    push @{ $prop->{'chown_files'} }, $prop->{'log_file'};
}

sub post_configure_hook {}

sub _server_type { ref($_[0]) }

sub pre_bind { # make sure we have good port parameters
    my $self = shift;
    my $prop = $self->{'server'};

    my $super = $self->net_server_type;
    my $type  = $self->_server_type;
    if ($self->isa('Net::Server::MultiType')) {
        my $base = delete($prop->{'_recursive_multitype'}) || Net::Server::MultiType->net_server_type;
        $super = "$super -> MultiType -> $base";
    }
    $type .= " (type $super)" if $type ne $super;
    $self->log(2, $self->log_time ." $type starting! pid($$)");

    $prop->{'sock'} = [grep {$_} map { $self->proto_object($_) } @{ $self->prepared_ports }];
    $self->fatal("No valid socket parameters found") if ! @{ $prop->{'sock'} };
}

sub prepared_ports {
    my $self = shift;
    my $prop = $self->{'server'};

    my ($ports, $hosts, $protos, $ipvs) = @$prop{qw(port host proto ipv)};
    $ports ||= $prop->{'ports'};
    if (!defined($ports) || (ref($ports) && !@$ports)) {
        $ports = $self->default_port;
        if (!defined($ports) || (ref($ports) && !@$ports)) {
            $ports = default_port();
            $self->log(2, "Port Not Defined.  Defaulting to '$ports'");
        }
    }

    my %bound;
    my $bind = $prop->{'_bind'} = [];
    for my $_port (ref($ports) ? @$ports : $ports) {
        my $_host  = ref($hosts)  ? $hosts->[ @$bind >= @$hosts  ? -1 : $#$bind + 1] : $hosts; # if ports are greater than hosts - augment with the last host
        my $_proto = ref($protos) ? $protos->[@$bind >= @$protos ? -1 : $#$bind + 1] : $protos;
        my $_ipv   = ref($ipvs)  ? $ipvs->[ @$bind >= @$ipvs  ? -1 : $#$bind + 1] : $ipvs;
        foreach my $info ($self->port_info($_port, $_host, $_proto, $_ipv)) {
            my ($port, $host, $proto, $ipv) = @$info{qw(port host proto ipv)}; # use cleaned values
            if ($port ne "0" && $bound{"$host\e$port\e$proto\e$ipv"}++) {
                $self->log(2, "Duplicate configuration (\U$proto\E) on [$host]:$port with IPv$ipv) - skipping");
                next;
            }
            push @$bind, $info;
        }
    }

    return $bind;
}

sub port_info {
    my ($self, $port, $host, $proto, $ipv) = @_;
    return parse_info($port, $host, $proto, $ipv, $self);
}

lib/Net/Server.pm  view on Meta::CPAN

                delete $ref->{$fd};
                delete $map{$sock->hup_string} if ! keys %$ref;
            } else {
                $self->log(2, "Added new port configuration");
                $sock->connect($self);
            }
        }
        foreach my $str (keys %map) {
            foreach my $fd (keys %{ $map{$str} }) {
                $self->log(2, "Closing un-mapped port ($str) on fd $fd");
                POSIX::close($fd);
            }
        }
        delete $ENV{'BOUND_SOCKETS'};
        $self->{'hup_waitpid'} = 1;

    } else { # connect to fresh ports
        foreach my $sock (@{ $prop->{'sock'} }) {
            $sock->log_connect($self);
            $sock->connect($self);
        }
    }

    if (@{ $prop->{'sock'} } > 1 || $prop->{'multi_port'}) {
        $prop->{'multi_port'} = 1;
        $prop->{'select'} = IO::Select->new; # if more than one socket we'll need to select on it
        $prop->{'select'}->add($_) for @{ $prop->{'sock'} };
    } else {
        $prop->{'multi_port'} = undef;
        $prop->{'select'}     = undef;
    }
}

sub post_bind_hook {}


sub post_bind { # secure the process and background it
    my $self = shift;
    my $prop = $self->{'server'};

    if (! defined $prop->{'group'}) {
        $self->log(1, "Group Not Defined.  Defaulting to EGID '$)'");
        $prop->{'group'} = $);
    } elsif ($prop->{'group'} =~ /^([\w.-]+(?:[ ,][\w.-]+)*)$/) {
            $prop->{'group'} = eval { get_gid($1) };
        $self->fatal(my $e = $@) if $@;
    } else {
        $self->fatal("Invalid group \"$prop->{'group'}\"");
    }

    if (! defined $prop->{'user'}) {
        $self->log(1, "User Not Defined.  Defaulting to EUID '$>'");
        $prop->{'user'} = $>;
    } elsif ($prop->{'user'} =~ /^([\w.-]+)$/) {
        $prop->{'user'} = eval { get_uid($1) };
        $self->fatal(my $e = $@) if $@;
    } else {
        $self->fatal("Invalid user \"$prop->{'user'}\"");
    }

    # chown any files or sockets that we need to
    if ($prop->{'group'} ne $) || $prop->{'user'} ne $>) {
        my @chown_files;
        push @chown_files, map {$_->NS_port} grep {$_->NS_proto =~ /^UNIX/} @{ $prop->{'sock'} };
        push @chown_files, $prop->{'pid_file'}  if $prop->{'pid_file_unlink'};
        push @chown_files, $prop->{'lock_file'} if $prop->{'lock_file_unlink'};
        push @chown_files, @{ $prop->{'chown_files'} || [] };
        my $uid = $prop->{'user'};
        my $gid = (split /\ /, $prop->{'group'})[0];
        foreach my $file (@chown_files){
            chown($uid, $gid, $file) || $self->fatal("Couldn't chown \"$file\" [$!]");
        }
    }

    if ($prop->{'chroot'}) {
        $self->fatal("Specified chroot \"$prop->{'chroot'}\" doesn't exist.") if ! -d $prop->{'chroot'};
        $self->log(2, "Chrooting to $prop->{'chroot'}");
        chroot($prop->{'chroot'}) || $self->fatal("Couldn't chroot to \"$prop->{'chroot'}\": $!");
    }

    # drop privileges
    eval {
        if ($prop->{'group'} ne $)) {
            $self->log(2, "Setting gid to \"$prop->{'group'}\"");
            set_gid($prop->{'group'} );
        }
        if ($prop->{'user'} ne $>) {
            $self->log(2, "Setting uid to \"$prop->{'user'}\"");
            set_uid($prop->{'user'});
        }
    };
    if ($@) {
        if ($> == 0) {
            $self->fatal(my $e = $@);
        } elsif ($< == 0) {
            $self->log(2, "NOTICE: Effective UID changed, but Real UID is 0: $@");
        } else {
            $self->log(2, my $e = $@);
        }
    }

    $prop->{'requests'} = 0; # record number of request

    $SIG{'INT'}  = $SIG{'TERM'} = $SIG{'QUIT'} = sub { $self->server_close; };
    $SIG{'PIPE'} = 'IGNORE'; # most cases, a closed pipe will take care of itself
    $SIG{'CHLD'} = \&sig_chld; # catch children (mainly for Fork and PreFork but works for any chld)
    $SIG{'HUP'}  = sub { $self->sig_hup };
}

sub sig_chld {
    1 while waitpid(-1, POSIX::WNOHANG()) > 0;
    $SIG{'CHLD'} = \&sig_chld;
}

sub pre_loop_hook {}

sub loop {
    my $self = shift;
    while ($self->accept) {
        $self->run_client_connection;
        last if $self->done;
    }
}

sub accept {
    my $self = shift;
    my $prop = $self->{'server'};

    my $sock = undef;
    my $retries = 30;
    while ($retries--) {