[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