Skip Menu |
 

This queue is for tickets about the Net-Server CPAN distribution.

Report information
The Basics
Id: 74084
Status: resolved
Priority: 0/
Queue: Net-Server

People
Owner: Nobody in particular
Requestors: UNDEF [...] cpan.org
Cc:
AdminCc:

Bug Information
Severity: (no value)
Broken in: (no value)
Fixed in: (no value)

Attachments


Subject: Net::Server::Proto::SSLEAY syswrite and sysread support
Download (untitled) / with headers
text/plain 333b
Good day. I've added sysread and syswrite support to Net::Server::Proto::SSLEAY. Patch including tests attached. Hope you will find this patch useful and will merge it. We need sysread and syswrite in Net::Server::Proto::SSLEAY to add correct support of SSL to Starman (that is based on Net::Server). Best regards, Sergey Zasenko
Subject: ssleay-sysread-syswrite.patch
diff --git a/lib/Net/Server/Proto/SSLEAY.pm b/lib/Net/Server/Proto/SSLEAY.pm index 2d8d2f7..149c8df 100644 --- a/lib/Net/Server/Proto/SSLEAY.pm +++ b/lib/Net/Server/Proto/SSLEAY.pm @@ -330,8 +330,44 @@ sub write { $client->print($buf); } -sub sysread { die "sysread is not supported by Net::Server::Proto::SSLEAY" } -sub syswrite { die "syswrite is not supported by Net::Server::Proto::SSLEAY" } +sub sysread { + my ($client, $buf, $length, $offset) = @_; + + $length = length $buf unless defined $length; + $offset = 0 unless defined $offset; + my $ssl = $client->SSLeay; + + my $data = Net::SSLeay::read($ssl, $length); + + return if $!{EAGAIN} || $!{EINTR}; + + die "SSLeay print: $!\n" unless defined $data; + + $length = length($data); + $$buf = '' if !defined $buf; + + if ($offset > length($$buf)) { + $$buf .= "\0" x ($offset - length($buf)); + } + + substr($$buf, $offset, length($$buf), $data); + return $length; +} + +sub syswrite { + my ($client, $buf, $length, $offset) = @_; + + $length = length $buf unless defined $length; + $offset = 0 unless defined $offset; + my $ssl = $client->SSLeay; + + my $write = Net::SSLeay::write_partial($ssl, $offset, $length, $buf); + + return if $!{EAGAIN} || $!{EINTR}; + die "SSLeay print: $!\n" if $write < 0; + + return $write; +} ###----------------------------------------------------------------### diff --git a/t/SSLEAY_test.t b/t/SSLEAY_test.t new file mode 100644 index 0000000..28c7b4a --- /dev/null +++ b/t/SSLEAY_test.t @@ -0,0 +1,156 @@ +use strict; +use warnings; + +use Net::SSLeay; +use Test::More; +use Net::Server; +use File::Temp; + +use_ok 'Net::Server::Proto::SSLEAY'; + +# Find free port +my $sock = IO::Socket::INET->new( + LocalHost => '127.0.0.1', + Proto => 'tcp', + Listen => 1 +); +my $port = $sock->sockport; +$sock->close; + +my $pem = do { + local $/; + <DATA>; +}; + +my ($pem_fh, $pem_filename) = + File::Temp::tempfile(SUFFIX => '.pem', UNLINK => 1); + +print $pem_fh $pem; +$pem_fh->close; + +local @ARGV = ( + '--SSL_cert_file' => $pem_filename, + '--SSL_key_file' => $pem_filename +); + +my $res; + +subtest 'Test Syswrite' => + sub { test_server('Net::Server::Test::Syswrite', $port) }; + +done_testing; + +sub test_server { + my ($server, $port) = @_; + my $read; + + no strict 'refs'; + pipe($read, ${"${server}::pipe"}); + use strict 'refs'; + + my $pid = fork; + die unless defined $pid; + + if ($pid) { + <$read>; + my $remote = IO::Socket::INET->new( + PeerAddr => 'localhost', + PeerPort => $port, + Proto => 'tcp' + ); + + my $ctx = Net::SSLeay::CTX_new() + or die_now("Failed to create SSL_CTX $!"); + Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL) + and die_if_ssl_error("ssl ctx set options"); + my $ssl = Net::SSLeay::new($ctx) + or die_now("Failed to create SSL $!"); + + Net::SSLeay::set_fd($ssl, $remote->fileno); + Net::SSLeay::connect($ssl); + + Net::SSLeay::write($ssl, "foo bar"); + my $res = Net::SSLeay::read($ssl); + is $res, "foo bar", "received correct data from server"; + } + else { + close STDERR; + $server->run( + port => "$port", + proto => 'ssleay', + ); + exit; + } +} + +package Net::Server::Test::Syswrite; +use base qw(Net::Server); +use IO::Socket; + +our $pipe; + +sub accept { + my $self = shift; + + warn $pipe; + $pipe->write("go!\n"); + $pipe->flush; + + return $self->SUPER::accept(); +} + +sub process_request { + my $self = shift; + + my $string = "foo bar\n"; + my $offset = 0; + + my $total = 0; + my $buf; + + # Wait data + my $vec = ''; + vec($vec, $self->{server}->{client}->fileno, 1) = 1; + + until ($buf) { + select($vec, undef, undef, undef); + $self->{server}->{client}->sysread(\$buf, 100, $total); + } + + select(undef, $vec, undef, undef); + + $self->{server}->{client}->syswrite($buf); + + $self->server_close; +} + +__END__ +-----BEGIN CERTIFICATE----- +MIICKTCCAZICCQDFxHnOjdmTTjANBgkqhkiG9w0BAQUFADBZMQswCQYDVQQGEwJB +VTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0 +cyBQdHkgTHRkMRIwEAYDVQQDDAlsb2NhbGhvc3QwHhcNMTIwMTE0MTgzMjMwWhcN +NzUxMTE0MTIwNDE0WjBZMQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0 +ZTEhMB8GA1UECgwYSW50ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMRIwEAYDVQQDDAls +b2NhbGhvc3QwgZ8wDQYJKoZIhvcNAQEBBQADgY0AMIGJAoGBAKLGfQantHdi/0cd +eoOHRbWKChpI/g84hU8SnwmrSMZR0x76vDLKMDYohISoKxRPx6j2M2x3P4K+kEJm +C5H9iGdD9p9ljGnRdkGp5yYeuwWfePRb4AOwP5qgQtEb0OctFIMjcAIIAw/lsnUs +hGnom0+uA9W2H63PgO0o4qiVAn7NAgMBAAEwDQYJKoZIhvcNAQEFBQADgYEATDGA +dYRl5wpsYcpLgNzu0M4SENV0DAE2wNTZ4LIR1wxHbcxdgzMhjp0wwfVQBTJFNqWu +DbeIFt4ghPMsUQKmMc4+og2Zyll8qev8oNgWQneKjDAEKKpzdvUoRZyGx1ZocGzi +S4LDiMd4qhD+GGePcHwmR8x/okoq58xZO/+Qygc= +-----END CERTIFICATE----- +-----BEGIN RSA PRIVATE KEY----- +MIICXAIBAAKBgQCixn0Gp7R3Yv9HHXqDh0W1igoaSP4POIVPEp8Jq0jGUdMe+rwy +yjA2KISEqCsUT8eo9jNsdz+CvpBCZguR/YhnQ/afZYxp0XZBqecmHrsFn3j0W+AD +sD+aoELRG9DnLRSDI3ACCAMP5bJ1LIRp6JtPrgPVth+tz4DtKOKolQJ+zQIDAQAB +AoGASXDmvhbyfJ8k8HAjc66XzBWxAzUFs9Zbh1aufM1UM259o8+bFAtXf0f+ql+5 +uBtaySf0Aa8374SNT/f8pmzOmpiXMvYRz8Z5Gc6JYpYd/PrCoSCGtP+NdCvk7Y5c +eUmmpiEto4+fgCAKrtqc5jm8eBWn/yNhQNDBVJ9qX+kXQOECQQDVBLvBZaECSMTm +djKuPlZ93cmyI7g+TURTl2N08fz4xQVVbo5+AV0GsEZupBpTgrHpLTk8gKP/nfdR +9KWZldbZAkEAw55+SqrVTv4cI0fMvC0t8Wl46zTkY9tK65TGnbO1DbTQh9qs+NwH ++v3uu47ef5w/73xLtDjQouz//0z5rgF3FQJAfrmOKQOYwY8g9CmlBNu5ALAM6Zku +ZoH4//G0DUJYyHYNMkHPK08MVIpRnEisELpTtPBeeIvfBJapJ2xvh+sIIQJASeY4 +I5EB4EOS8akQKQ6QSqDjs0dZ+HdBiFm95pmbDkB+frQXoDPPN/xyEZzZZS/r31b/ +amgEOWh7FUFJGXkoOQJBALfOgsiss0lASlOXAg1rwO4m2OaDiaEde01PLcSjIaKl +Qfbzc7ZYF+fGDsHHlD5Kgj1CGaWCVVHqCv4UHSrA/gM= +-----END RSA PRIVATE KEY-----
Download (untitled) / with headers
text/plain 502b
Thankyou for the patches. They have been applied and are in the just released version 2.000. Paul On Tue Jan 17 07:13:58 2012, UNDEF wrote: Show quoted text
> Good day. > > I've added sysread and syswrite support to Net::Server::Proto::SSLEAY. > Patch including tests attached. > > Hope you will find this patch useful and will merge it. > > We need sysread and syswrite in Net::Server::Proto::SSLEAY to add > correct support of SSL to Starman (that is based on Net::Server). > > Best regards, > Sergey Zasenko


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.