[Bps-public-commit] r9925 - in Net-Server-Coro: . lib/Net/Server
alexmv at bestpractical.com
alexmv at bestpractical.com
Wed Dec 12 17:58:42 EST 2007
Author: alexmv
Date: Wed Dec 12 17:58:41 2007
New Revision: 9925
Added:
Net-Server-Coro/lib/Net/Server/Proto/
Net-Server-Coro/lib/Net/Server/Proto/SSL.pm
Net-Server-Coro/lib/Net/Server/Proto/TCP.pm
Modified:
Net-Server-Coro/ (props changed)
Net-Server-Coro/lib/Net/Server/Coro.pm
Log:
r25676 at zoq-fot-pik: chmrr | 2007-12-12 17:57:04 -0500
* Working SSL and multi-listen
Modified: Net-Server-Coro/lib/Net/Server/Coro.pm
==============================================================================
--- Net-Server-Coro/lib/Net/Server/Coro.pm (original)
+++ Net-Server-Coro/lib/Net/Server/Coro.pm Wed Dec 12 17:58:41 2007
@@ -1,117 +1,95 @@
package Net::Server::Coro;
use strict;
-use vars qw($VERSION @ISA $LOCK_EX $LOCK_UN);
-use POSIX qw(WNOHANG);
-use Fcntl ();
-use Net::Server ();
-use Net::Server::SIG qw(register_sig check_sigs);
+use warnings;
+use vars qw($VERSION);
use Coro;
use Coro::Semaphore;
-use Coro::Event;
+use Coro::Handle;
use Coro::Socket;
- at ISA = qw(Net::Server);
+use base qw(Net::Server);
-### override-able options for this package
-sub options {
- my $self = shift;
- my $prop = $self->{server};
- my $ref = shift;
-
- $self->SUPER::options($ref);
-
- foreach ( qw(max_servers max_requests request_timeout response_timeout) ){
- $prop->{$_} = undef unless exists $prop->{$_};
- $ref->{$_} = \$prop->{$_};
- }
+my $connections = new Coro::Semaphore 500; # $MAX_CONNECTS;
+use vars qw/$SELF @FH @POOL/;
-}
+no warnings 'redefine';
-sub Coro::Socket::AUTOLOAD {
- warn $Coro::Socket::AUTOLOAD;
-}
-sub pre_bind {
- warn "pre_bind"
+sub Coro::Handle::accept {
+ my ( $peername, $fh );
+ while () {
+ ( $fh, $peername ) = tied( ${ $_[0] } )->[0]->accept;
+ if ($peername) {
+ my $socket
+ = $_[0]->new_from_fh( $fh,
+ forward_class => tied( ${ $_[0] } )->[7] );
+ return wantarray ? ( $socket, $peername ) : $socket;
+ }
+
+ return unless $!{EAGAIN};
+
+ $_[0]->readable or return;
+ }
}
-my $SOCK;
-sub bind {
- warn "bind";
+
+sub post_bind_hook {
my $self = shift;
my $prop = $self->{server};
- foreach my $port ( @{ $prop->{port} } ){
- my $obj = $self->proto_object($prop->{host},
- $port,
- $prop->{proto},
- ) || next;
- $SOCK = $obj;
- #push @{ $prop->{sock} }, $obj;
- }
+ $prop->{sock}
+ = [ map { make_coro_socket($_) } @{ $prop->{sock} } ];
}
-sub proto_object {
- my $self = shift;
- my ($host,$port,$proto) = @_;
- $host = '0.0.0.0' if $host eq '*';
- return Coro::Socket->new(
- LocalAddr => $host,
- LocalPort => $port,
- ReuseAddr => 1,
- Listen => 1,
- );
+sub make_coro_socket {
+ my $socket = shift;
+ my $proto = $socket->NS_proto;
+ $socket = Coro::Socket->new_from_fh( $socket, forward_class => ref $socket );
+ $socket->NS_proto($proto);
+ return $socket;
}
+sub get_client_info { }
-sub post_bind { warn "post_bind: $SOCK" }
-my @fh;
-my @pool;
-my $connections = new Coro::Semaphore 500; # $MAX_CONNECTS;
-
-use vars '$SELF';
sub handler {
- while () {
- my $prop = $SELF->{server};
- my $fh = pop @fh;
- if ($fh) {
- $prop->{connected} = 1;
- my $from = $fh->peername;
- warn "CONNECTED! ($fh - $from)";
- $prop->{client} = $fh;
- $SELF->run_client_connection;
- last if $SELF->done;
- $prop->{connected} = 0;
- close $fh;
- $connections->up;
- } else {
- last if @pool >= 20; #$MAX_POOL;
- push @pool, $Coro::current;
- schedule;
- }
- }
+ while (1) {
+ my $prop = $SELF->{server};
+ my $fh = pop @FH;
+ if ($fh) {
+ $prop->{connected} = 1;
+ my $from = $fh->peername;
+ $prop->{client} = $fh;
+ $SELF->run_client_connection;
+ last if $SELF->done;
+ $prop->{connected} = 0;
+ close $fh;
+ $connections->up;
+ } else {
+ last if @POOL >= 20; #$MAX_POOL;
+ push @POOL, $Coro::current;
+ schedule;
+ }
+ }
}
### prepare for connections
sub loop {
my $self = $SELF = shift;
my $prop = $self->{server};
+ for my $socket ( @{ $prop->{sock} } ) {
+ async {
+ while (1) {
+ $connections->down;
+ my $accepted = scalar $socket->accept;
+ next unless $accepted;
+ push @FH, $accepted;
+ if (@POOL) {
+ ( pop @POOL )->ready;
+ } else {
+ async \&handler;
+ }
- async {
- while (1) {
- $connections->down;
- warn "CC";
- push @fh, scalar $SOCK->accept;
- warn "GOT: @fh\n";
- if (@pool) {
- (pop @pool)->ready;
- } else {
- async \&handler;
}
-
- }
- };
+ };
+ }
schedule;
- loop;
}
-*FileHandle::peername = *Coro::Socket::peername;
-
1;
Added: Net-Server-Coro/lib/Net/Server/Proto/SSL.pm
==============================================================================
--- (empty file)
+++ Net-Server-Coro/lib/Net/Server/Proto/SSL.pm Wed Dec 12 17:58:41 2007
@@ -0,0 +1,254 @@
+# -*- perl -*-
+#
+# Net::Server::Proto::SSL - Net::Server Protocol module
+#
+# $Id: SSL.pm,v 1.11 2007/02/03 05:56:34 rhandom Exp $
+#
+# Copyright (C) 2001-2007
+#
+# Paul Seamons
+# paul at seamons.com
+# http://seamons.com/
+#
+# This package may be distributed under the terms of either the
+# GNU General Public License
+# or the
+# Perl Artistic License
+#
+# All rights reserved.
+#
+################################################################
+
+package Net::Server::Proto::SSL;
+
+use strict;
+use vars qw($VERSION $AUTOLOAD @ISA);
+use Net::Server::Proto::TCP ();
+eval { require IO::Socket::SSL; };
+$@ && warn "Module IO::Socket::SSL is required for SSL.";
+
+$VERSION = $Net::Server::VERSION; # done until separated
+ at ISA = qw(IO::Socket::SSL);
+
+
+sub object {
+ my $type = shift;
+ my $class = ref($type) || $type || __PACKAGE__;
+
+ my ($default_host,$port,$server) = @_;
+ my $prop = $server->{server};
+ my $host;
+
+ ### allow for things like "domain.com:80"
+ if( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){
+ ($host,$port) = ($1,$2);
+
+ ### allow for things like "80"
+ }elsif( $port =~ /^(\w+)$/ ){
+ ($host,$port) = ($default_host,$1);
+
+ ### don't know that style of port
+ }else{
+ $server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__);
+ }
+
+ ### read any additional protocol specific arguments
+ $server->configure({
+ SSL_server => \$prop->{SSL_server},
+ SSL_use_cert => \$prop->{SSL_use_cert},
+ SSL_verify_mode => \$prop->{SSL_verify_mode},
+ SSL_key_file => \$prop->{SSL_key_file},
+ SSL_cert_file => \$prop->{SSL_cert_file},
+ SSL_ca_path => \$prop->{SSL_ca_path},
+ SSL_ca_file => \$prop->{SSL_ca_file},
+ SSL_cipher_list => \$prop->{SSL_cipher_list},
+ SSL_passwd_cb => \$prop->{SSL_passwd_cb},
+ });
+
+ ### create the handle under this package
+ my $sock = $class->SUPER::new();
+
+ ### store some properties
+ $sock->NS_host($host);
+ $sock->NS_port($port);
+ $sock->NS_proto('SSL');
+
+ return $sock;
+}
+
+sub log_connect {
+ my $sock = shift;
+ my $server = shift;
+ my $host = $sock->NS_host;
+ my $port = $sock->NS_port;
+ my $proto = $sock->NS_proto;
+ $server->log(2,"Binding to $proto port $port on host $host\n");
+}
+
+### connect the first time
+sub connect {
+ my $sock = shift;
+ my $server = shift;
+ my $prop = $server->{server};
+
+ my $host = $sock->NS_host;
+ my $port = $sock->NS_port;
+
+ my %args = ();
+ $args{LocalPort} = $port; # what port to bind on
+ $args{Proto} = 'tcp'; # what procol to use
+ $args{LocalAddr} = $host if $host !~ /\*/; # what local address (* is all)
+ $args{Listen} = $prop->{listen}; # how many connections for kernel to queue
+ $args{Reuse} = 1; # allow us to rebind the port on a restart
+
+ ### add in any ssl specific properties
+ foreach ( keys %$prop ){
+ next unless /^SSL_/;
+ $args{$_} = $prop->{$_} if defined $prop->{$_};
+ }
+
+ ### connect to the sock
+ $sock->SUPER::configure(\%args)
+ or $server->fatal("Can't connect to SSL port $port on $host [$!]");
+
+ $server->fatal("Back sock [$!]!".caller())
+ unless $sock;
+
+}
+
+### connect on a sig -HUP
+sub reconnect {
+ my $sock = shift;
+ my $fd = shift;
+ my $server = shift;
+
+ $sock->fdopen( $fd, 'w' )
+ or $server->fatal("Error opening to file descriptor ($fd) [$!]");
+
+}
+
+### allow for endowing the child
+sub accept {
+ my $sock = shift;
+ my($client, $peername) = $sock->SUPER::accept();
+
+ ### pass items on
+ if( $peername ){
+ bless $client, ref($sock);
+ $client->NS_proto( $sock->NS_proto );
+ }
+
+ return wantarray ? ($client, $peername) : $client;
+}
+
+### a string containing any information necessary for restarting the server
+### via a -HUP signal
+### a newline is not allowed
+### the hup_string must be a unique identifier based on configuration info
+sub hup_string {
+ my $sock = shift;
+ return join("|",
+ $sock->NS_host,
+ $sock->NS_port,
+ $sock->NS_proto,
+ );
+}
+
+### short routine to show what we think we are
+sub show {
+ my $sock = shift;
+ my $t = "Ref = \"" .ref($sock) . "\"\n";
+ foreach my $prop ( qw(NS_proto NS_port NS_host) ){
+ $t .= " $prop = \"" .$sock->$prop()."\"\n";
+ }
+ return $t;
+}
+
+### self installer
+sub AUTOLOAD {
+ my $sock = shift;
+
+ my ($prop) = $AUTOLOAD =~ /::([^:]+)$/ ? $1 : '';
+ if( ! $prop ){
+ die "No property called.";
+ }
+
+ if( $prop =~ /^(NS_proto|NS_port|NS_host)$/ ){
+ no strict 'refs';
+ * { __PACKAGE__ ."::". $prop } = sub {
+ my $sock = shift;
+ if( @_ ){
+ ${*$sock}{$prop} = shift;
+ return delete ${*$sock}{$prop} unless defined ${*$sock}{$prop};
+ }else{
+ return ${*$sock}{$prop};
+ }
+ };
+ use strict 'refs';
+
+ $sock->$prop(@_);
+
+ }else{
+ die "What method is that? [$prop]";
+ }
+}
+
+1;
+
+=head1 NAME
+
+ Net::Server::Proto::SSL - Net::Server SSL protocol.
+
+=head1 SYNOPSIS
+
+See L<Net::Server::Proto>.
+
+=head1 DESCRIPTION
+
+Experimental. If anybody has any successes or ideas for
+improvment under SSL, please email <paul at seamons.com>.
+
+Protocol module for Net::Server. This module implements a
+secure socket layer over tcp (also known as SSL).
+See L<Net::Server::Proto>.
+
+There is a limit inherent from using IO::Socket::SSL,
+namely that only one SSL connection can be maintained by
+Net::Server. However, Net::Server should also be able to
+maintain any number of TCP, UDP, or UNIX connections in
+addition to the one SSL connection.
+
+Additionally, getline support is very limited and writing
+directly to STDOUT will not work. This is entirely dependent
+upon the implementation of IO::Socket::SSL. getline may work
+but the client is not copied to STDOUT under SSL. It is suggested
+that clients sysread and syswrite to the client handle
+(located in $self->{server}->{client} or passed to the process_request
+subroutine as the first argument).
+
+=head1 PARAMETERS
+
+In addition to the normal Net::Server parameters, any of the
+SSL parameters from IO::Socket::SSL may also be specified.
+See L<IO::Socket::SSL> for information on setting this up.
+
+=head1 BUGS
+
+Christopher A Bongaarts pointed out that if the SSL negotiation is slow then
+the server won't be accepting for that period of time (because the locking
+of accept is around both the socket accept and the SSL negotiation). This
+means that as it stands now the SSL implementation is susceptible to DOS attacks.
+To fix this will require deviding up the accept call a little bit more finely
+which may not yet be possible with IO::Socket::SSL. Any ideas or patches on this
+bug are welcome.
+
+=head1 LICENCE
+
+Distributed under the same terms as Net::Server
+
+=head1 THANKS
+
+Thanks to Vadim for pointing out the IO::Socket::SSL accept
+was returning objects blessed into the wrong class.
+
+=cut
Added: Net-Server-Coro/lib/Net/Server/Proto/TCP.pm
==============================================================================
--- (empty file)
+++ Net-Server-Coro/lib/Net/Server/Proto/TCP.pm Wed Dec 12 17:58:41 2007
@@ -0,0 +1,200 @@
+# -*- perl -*-
+#
+# Net::Server::Proto::TCP - Net::Server Protocol module
+#
+# $Id: TCP.pm,v 1.12 2007/02/03 05:55:56 rhandom Exp $
+#
+# Copyright (C) 2001-2007
+#
+# Paul Seamons
+# paul at seamons.com
+# http://seamons.com/
+#
+# This package may be distributed under the terms of either the
+# GNU General Public License
+# or the
+# Perl Artistic License
+#
+# All rights reserved.
+#
+################################################################
+
+package Net::Server::Proto::TCP;
+
+use strict;
+use vars qw($VERSION $AUTOLOAD @ISA);
+use IO::Socket ();
+
+$VERSION = $Net::Server::VERSION; # done until separated
+ at ISA = qw(IO::Socket::INET);
+
+sub object {
+ my $type = shift;
+ my $class = ref($type) || $type || __PACKAGE__;
+
+ my ($default_host,$port,$server) = @_;
+ my $host;
+
+ ### allow for things like "domain.com:80"
+ if( $port =~ m/^([\w\.\-\*\/]+):(\w+)$/ ){
+ ($host,$port) = ($1,$2);
+
+ ### allow for things like "80"
+ }elsif( $port =~ /^(\w+)$/ ){
+ ($host,$port) = ($default_host,$1);
+
+ ### don't know that style of port
+ }else{
+ $server->fatal("Undeterminate port \"$port\" under ".__PACKAGE__);
+ }
+
+ ### create the handle under this package
+ my $sock = $class->SUPER::new();
+
+ ### store some properties
+ $sock->NS_host($host);
+ $sock->NS_port($port);
+ $sock->NS_proto('TCP');
+
+ return $sock;
+}
+
+sub log_connect {
+ my $sock = shift;
+ my $server = shift;
+ my $host = $sock->NS_host;
+ my $port = $sock->NS_port;
+ my $proto = $sock->NS_proto;
+ $server->log(2,"Binding to $proto port $port on host $host\n");
+}
+
+### connect the first time
+sub connect {
+ my $sock = shift;
+ my $server = shift;
+ my $prop = $server->{server};
+
+ my $host = $sock->NS_host;
+ my $port = $sock->NS_port;
+
+ my %args = ();
+ $args{LocalPort} = $port; # what port to bind on
+ $args{Proto} = 'tcp'; # what procol to use
+ $args{LocalAddr} = $host if $host !~ /\*/; # what local address (* is all)
+ $args{Listen} = $prop->{listen}; # how many connections for kernel to queue
+ $args{Reuse} = 1; # allow us to rebind the port on a restart
+
+ ### connect to the sock
+ $sock->SUPER::configure(\%args)
+ or $server->fatal("Can't connect to TCP port $port on $host [$!]");
+
+ $server->fatal("Back sock [$!]!".caller())
+ unless $sock;
+
+}
+
+### connect on a sig -HUP
+sub reconnect {
+ my $sock = shift;
+ my $fd = shift;
+ my $server = shift;
+
+ $sock->fdopen( $fd, 'w' )
+ or $server->fatal("Error opening to file descriptor ($fd) [$!]");
+
+}
+
+### allow for endowing the child
+sub accept {
+ my $sock = shift;
+ my($client, $peername) = $sock->SUPER::accept();
+
+ ### pass items on
+ if( $peername ){
+ $client->NS_proto( $sock->NS_proto );
+ }
+
+ return wantarray ? ($client, $peername) : $client;
+}
+
+### a string containing any information necessary for restarting the server
+### via a -HUP signal
+### a newline is not allowed
+### the hup_string must be a unique identifier based on configuration info
+sub hup_string {
+ my $sock = shift;
+ return join("|",
+ $sock->NS_host,
+ $sock->NS_port,
+ $sock->NS_proto,
+ );
+}
+
+### short routine to show what we think we are
+sub show {
+ my $sock = shift;
+ my $t = "Ref = \"" .ref($sock) . "\"\n";
+ foreach my $prop ( qw(NS_proto NS_port NS_host) ){
+ $t .= " $prop = \"" .$sock->$prop()."\"\n";
+ }
+ return $t;
+}
+
+### self installer
+sub AUTOLOAD {
+ my $sock = shift;
+
+ my ($prop) = $AUTOLOAD =~ /::([^:]+)$/ ? $1 : '';
+ if( ! $prop ){
+ die "No property called.";
+ }
+
+ if( $prop =~ /^(NS_proto|NS_port|NS_host|NS_recv_len|NS_recv_flags)$/ ){
+ no strict 'refs';
+ * { __PACKAGE__ ."::". $prop } = sub {
+ my $sock = shift;
+ if( @_ ){
+ ${*$sock}{$prop} = shift;
+ return delete ${*$sock}{$prop} unless defined ${*$sock}{$prop};
+ }else{
+ return ${*$sock}{$prop};
+ }
+ };
+ use strict 'refs';
+
+ $sock->$prop(@_);
+
+ }else{
+ die "What method is that? [$prop]";
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ Net::Server::Proto::TCP - Net::Server TCP protocol.
+
+=head1 SYNOPSIS
+
+See L<Net::Server::Proto>.
+
+=head1 DESCRIPTION
+
+Protocol module for Net::Server. This module implements the
+SOCK_STREAM socket type under INET (also known as TCP).
+See L<Net::Server::Proto>.
+
+=head1 PARAMETERS
+
+There are no additional parameters that can be specified.
+See L<Net::Server> for more information on reading arguments.
+
+=head1 LICENCE
+
+Distributed under the same terms as Net::Server
+
+=cut
+
More information about the Bps-public-commit
mailing list