diff options
Diffstat (limited to '')
| -rw-r--r-- | tests/SSLServer.pm | 236 |
1 files changed, 236 insertions, 0 deletions
diff --git a/tests/SSLServer.pm b/tests/SSLServer.pm new file mode 100644 index 0000000..37a8bfa --- /dev/null +++ b/tests/SSLServer.pm @@ -0,0 +1,236 @@ +package SSLServer; + +# This is only HTTPS server for now. +# But it is named SSLServer to easily distinguish from HTTPServer + +use strict; +use warnings; +use lib '.'; + +use HTTP::Daemon; +use HTTP::Status; +use HTTP::Headers; +use HTTP::Response; + +# Skip this test rather than fail it when the module isn't installed +if (!eval {require IO::Socket::SSL;1;}) { + print STDERR "This test needs the perl module \"IO::Socket::SSL\".\n"; + print STDERR "Install e.g. on Debian with 'apt-get install libio-socket-ssl-perl'\n"; + print STDERR " or if using cpanminus 'cpanm IO::Socket::SSL' could be used to install it.\n"; + exit 77; # skip +} + +#use IO::Socket::SSLX; # 'debug4'; +use HTTPServer; + +our @ISA = qw(IO::Socket::SSL HTTP::Daemon::ClientConn HTTP::Daemon HTTPServer); + +my $VERSION = 0.01; + +my $CRLF = "\015\012"; # "\r\n" is not portable + +# Config options for server +my $log = undef; +my $DEBUG = undef; + +my %ssl_params; + +my $sslsock; +my $plaincon; +my %args; + +#$HTTP::Daemon::DEBUG=5; +#*DEBUG = \$HTTP::Daemon::DEBUG; + +$args{SSL_error_trap} ||= \&ssl_error; + +my $class = 'SSLServer'; +my $self = {}; +$self = bless $self, $class; + +sub init +{ + my $self = shift; + my %sargs = @_; + + %ssl_params = %sargs; + unless (exists($ssl_params{'lhostname'}) && + exists($ssl_params{'sslport'}) && + exists($ssl_params{'ciphers'}) && + exists($ssl_params{'cafile'}) && + exists($ssl_params{'certfile'}) && + exists($ssl_params{'keyfile'})) { + die "Required parameters for SSL tests are missing"; + } +} + +sub ssl_setup_conn +{ + $sslsock = IO::Socket::SSL->new(LocalAddr => $ssl_params{'lhostname'}, + LocalPort => $ssl_params{'sslport'}, + Listen => 10, + Timeout => 30, + ReuseAddr => 1, + SSL_cipher_list => $ssl_params{'ciphers'}, + SSL_verify_mode => 0x00, + SSL_ca_file => $ssl_params{'cafile'}, + SSL_cert_file => $ssl_params{'certfile'}, + SSL_key_file => $ssl_params{'keyfile'}); + + $sslsock || warn $IO::Socket::SSL::ERROR; + return $sslsock; +} + +sub fileno +{ + my $self = shift; + my $fn = ${*$self}{'_SSL_fileno'}; + return defined($fn) ? $fn : $self->SUPER::fileno(); +} + +sub accept +{ + my $self = shift; + my $pkg = shift || "SSLServer"; + my ($sock, $peer) = $sslsock->accept($pkg); + if ($sock) { + ${*$sock}{'httpd_daemon'} = $self; + ${*$self}{'httpd_daemon'} = $sock; + my $fileno = ${*$self}{'_SSL_fileno'} = &fileno($self); + my $f = $sock->fileno; + return wantarray ? ($sock, $peer) : $sock; + } + else { + print STDERR "Failed to get socket from SSL\n" if $DEBUG; + return; + } + +} + +sub _default_port { 443; } +sub _default_scheme { "https"; } + +sub url +{ + my $self = shift; + my $url = $self->SUPER::url; + return $url if ($self->can("HTTP::Daemon::_default_port")); + + # Workaround for old versions of HTTP::Daemon + $url =~ s!^http:!https:!; + $url =~ s!/$!:80/! unless ($url =~ m!:(?:\d+)/$!); + $url =~ s!:443/$!/!; + return $url; +} + +sub _need_more +{ + my $self = shift; + if ($_[1]) { + my($timeout, $fdset) = @_[1,2]; + print STDERR "select(,,,$timeout)\n" if $DEBUG; + my $n = select($fdset,undef,undef,$timeout); + unless ($n) { + $self->reason(defined($n) ? "Timeout" : "select: $!"); + return; + } + } + my $total = 0; + while (1){ + print STDERR sprintf("sysread() already %d\n",$total) if $DEBUG; + my $n = sysread(${*$self}{'httpd_daemon'}, $_[0], 2048, length($_[0])); + print STDERR sprintf("sysread() just \$n=%s\n",(defined $n?$n:'undef')) if $DEBUG; + $total += $n if defined $n; + last if $! =~ 'Resource temporarily unavailable'; + #SSL_Error because of aggressive reading + + $self->reason(defined($n) ? "Client closed" : "sysread: $!") unless $n; + last unless $n; + last unless $n == 2048; + } + $total; +} + +sub daemon +{ + my $self = shift; + ${*$self}{'httpd_daemon'}; +} + +sub conn +{ + my $self = shift; + ${*$self}{'sslcon'}; +} + +sub run +{ + my ($self, $urls, $synch_callback) = @_; + my $initialized = 0; + my $sslsock; + + while (1) + { + if (!$initialized) + { + $sslsock = $self->ssl_setup_conn(); + $sslsock || warn "Failed to get ssl sock"; + + $initialized = 1; + open (LOGFILE, '>', "/tmp/wgetserver.log"); + LOGFILE->autoflush(1); + print LOGFILE "Starting logging"; + $synch_callback->() if $synch_callback; + } + + my $con = $self->accept(); + ${*$self}{'sslcon'} = $con; + + while (my $req = $self->get_request) + { + #my $url_path = $req->url->path; + my $url_path = $req->url->as_string; + if ($url_path =~ m{/$}) + { # append 'index.html' + $url_path .= 'index.html'; + } + + #if ($url_path =~ m{^/}) { # remove trailing '/' + # $url_path = substr ($url_path, 1); + #} + if ($log) + { + print LOGFILE "Method: ", $req->method, "\n"; + print LOGFILE "Path: ", $url_path, "\n"; + print LOGFILE "Available URLs: ", "\n"; + foreach my $key (keys %$urls) + { + print LOGFILE $key, "\n"; + } + } + if (exists($urls->{$url_path})) + { + print LOGFILE "Serving requested URL: ", $url_path, "\n" if $log; + next unless ($req->method eq "HEAD" || $req->method eq "GET"); + + my $url_rec = $urls->{$url_path}; + HTTPServer::send_response($self, $req, $url_rec, $con); + last; + } + else + { + print LOGFILE "Requested wrong URL: ", $url_path, "\n" if $log; + $con->send_error($HTTP::Status::RC_FORBIDDEN); + last; + } + last; + } + print LOGFILE "Closing connection\n" if $log; + close(LOGFILE); + $con->close(); + } +} + +1; + +# vim: et ts=4 sw=4 |