File Coverage

blib/lib/Net/Server/Proto/SSLEAY.pm

Criterion	Covered	Total	%
statement	261	346	75.4
branch	92	168	54.7
condition	30	72	41.6
subroutine	37	45	82.2
pod	7	34	20.5
total	427	665	64.2

# -*- perl -*-
#
#  Net::Server::Proto::SSLEAY - Net::Server Protocol module
#
#  Copyright (C) 2010-2022
#
#    Paul Seamons
#
#  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::SSLEAY;

use strict;
use warnings;
use Fcntl ();
use Errno ();
use Carp qw(croak);
use base qw(Net::Server::IP); # Can safely handle IPv4 or IPv6 on the fly
use Net::Server::Proto qw(SOMAXCONN AF_INET AF_INET6 AF_UNSPEC);

BEGIN {
    eval { require Net::SSLeay; 1 }
        or warn "Module Net::SSLeay is required for SSLeay.";
    for my $sub (qw(load_error_strings SSLeay_add_ssl_algorithms ENGINE_load_builtin_engines ENGINE_register_all_complete randomize)) {
        my $subref = Net::SSLeay->can($sub);
        $subref->() if $subref;
    }
    eval { [Fcntl::F_GETFL(), Fcntl::F_SETFL(), Fcntl::O_NONBLOCK()] } || die "Could not access Fcntl constant while loading ".__PACKAGE__.": $@";
}

our $AUTOLOAD;

my @ssl_args = qw(
    SSL_use_cert
    SSL_verify_mode
    SSL_key_file
    SSL_cert_file
    SSL_ca_path
    SSL_ca_file
    SSL_cipher_list
    SSL_passwd_cb
    SSL_max_getline_length
    SSL_error_callback
);

sub NS_proto { 'SSLEAY' }
sub NS_port   { my $sock = shift; ${*$sock}{'NS_port'}   = shift if @_; return ${*$sock}{'NS_port'}   }
sub NS_host   { my $sock = shift; ${*$sock}{'NS_host'}   = shift if @_; return ${*$sock}{'NS_host'}   }
sub NS_ipv    { my $sock = shift; ${*$sock}{'NS_ipv'}    = shift if @_; return ${*$sock}{'NS_ipv'}    }
sub NS_listen { my $sock = shift; ${*$sock}{'NS_listen'} = shift if @_; return ${*$sock}{'NS_listen'} }

sub object {
    my ($class, $info, $server) = @_;

    my $ssl = $server->{'server'}->{'ssl_args'} ||= do {
        my %temp = map {$_ => undef} @ssl_args;
        $server->configure({map {$_ => \$temp{$_}} @ssl_args});
        \%temp;
    };

    my $sock = $class->new;
    $sock->NS_host($info->{'host'});
    $sock->NS_port($info->{'port'});
    $sock->NS_ipv( $info->{'ipv'} );
    $sock->NS_listen(defined($info->{'listen'}) ? $info->{'listen'}
                    : defined($server->{'server'}->{'listen'}) ? $server->{'server'}->{'listen'}
                    : SOMAXCONN);
    ${*$sock}{'NS_orig_port'} = $info->{'orig_port'} if defined $info->{'orig_port'};

    for my $key (@ssl_args) {
        my $val = defined($info->{$key}) ? $info->{$key}
                : defined($ssl->{$key})  ? $ssl->{$key}
                : $server->can($key) ? $server->$key($info->{'host'}, $info->{'port'}, 'SSLEAY')
                : undef;
        next if ! defined $val;
        $sock->$key($val) if defined $val;
    }
    return $sock;
}

sub log_connect {
    my ($sock, $server) = @_;
    $server->log(2, "Binding to ".$sock->NS_proto." port ".$sock->NS_port." on host ".$sock->NS_host." with IPv".$sock->NS_ipv);
}

sub connect { # connect the first time
    my ($sock, $server) = @_;
    my $host = $sock->NS_host;
    my $port = $sock->NS_port;
    my $ipv  = $sock->NS_ipv;
    my $lstn = $sock->NS_listen;

    $sock->SUPER::configure({
        LocalPort => $port,
        Proto     => 'tcp',
        Listen    => $lstn,
        ReuseAddr => 1,
        Reuse     => 1,
        Family    => ($ipv eq '6' ? AF_INET6 : $ipv eq '4' ? AF_INET : AF_UNSPEC),
        (($host ne '*') ? (LocalAddr => $host) : ()), # * is all
    }) || $server->fatal("Can't connect to SSLEAY port $port on $host [$!]");

    if ($port eq '0' and $port = $sock->sockport) {
        $server->log(2, "  Bound to auto-assigned port $port");
        ${*$sock}{'NS_orig_port'} = $sock->NS_port;
        $sock->NS_port($port);
    } elsif ($port =~ /\D/ and $port = $sock->sockport) {
        $server->log(2, "  Bound to service port ".$sock->NS_port()."($port)");
        ${*$sock}{'NS_orig_port'} = $sock->NS_port;
        $sock->NS_port($port);
    }

    $sock->bind_SSL($server);
}

sub reconnect { # connect on a sig -HUP
    my ($sock, $fd, $server, $port) = @_;
    $server->log(3,"Reassociating file descriptor $fd with ".$sock->NS_proto." on [".$sock->NS_host."]:".$sock->NS_port.", using IPv".$sock->NS_ipv);
    my $resp = $sock->fdopen( $fd, 'w' ) or $server->fatal("Error opening to file descriptor ($fd) [$!]");

    my $ipv = $sock->NS_ipv;
    ${*$sock}{'io_socket_domain'} = $ipv eq '6' ? AF_INET6 : $ipv eq '4' ? AF_INET : AF_UNSPEC;

    $sock->bind_SSL($server);

    if ($port ne $sock->NS_port) {
        $server->log(2, "  Re-bound to previously assigned port $port");
        ${*$sock}{'NS_orig_port'} = $sock->NS_port;
        $sock->NS_port($port);
    }

    return $resp;
}

sub bind_SSL {
    my ($sock, $server) = @_;
    my $ctx = Net::SSLeay::CTX_new();  $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_new");

    Net::SSLeay::CTX_set_options($ctx, Net::SSLeay::OP_ALL());  $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_options");

    # 0x01: SSL_MODE_ENABLE_PARTIAL_WRITE
    # 0x10: SSL_MODE_RELEASE_BUFFERS (ignored before OpenSSL v1.0.0)
    Net::SSLeay::CTX_set_mode($ctx, 0x11);  $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_set_mode");

    # Load certificate. This will prompt for a password if necessary.
    my $file_key  = $sock->SSL_key_file  || die "SSLeay missing SSL_key_file on ".$sock->hup_string.".\n";
    my $file_cert = $sock->SSL_cert_file || die "SSLeay missing SSL_cert_file on ".$sock->hup_string>".\n";
    Net::SSLeay::CTX_use_RSAPrivateKey_file($ctx, $file_key,  Net::SSLeay::FILETYPE_PEM());  $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_RSAPrivateKey_file");
    Net::SSLeay::CTX_use_certificate_file(  $ctx, $file_cert, Net::SSLeay::FILETYPE_PEM());  $sock->SSLeay_check_fatal("SSLeay bind_SSL CTX_use_certificate_file");
    $sock->SSLeay_context($ctx);
}

sub close {
    my $sock = shift;
    if ($sock->SSLeay_is_client) {
        if (my $ssl = ${*$sock}{'SSLeay'}) { # Avoid trying to build a new ctx just to throw it away
            my $should_shutdown = 1; # Net::SSLeay <= 1.85 does not have is_init_finished(), so just attempt shutdown in this case:
            eval { $should_shutdown = 0 if !Net::SSLeay::is_init_finished($ssl) };
            Net::SSLeay::shutdown($ssl) if $should_shutdown;
            Net::SSLeay::free($ssl);
        }
    } else {
        Net::SSLeay::CTX_free($sock->SSLeay_context);
    }
    $sock->SSLeay_check_fatal("SSLeay close free");
    return $sock->SUPER::close(@_);
}

sub accept {
    my ($sock, $class) = (@_);
    my ($client, $peername);
    if (wantarray) {
        ($client, $peername) = $sock->SUPER::accept($class);
    } else {
        $client = $sock->SUPER::accept($class);
    }
    if (defined $client) {
        $client->NS_proto($sock->NS_proto);
        $client->NS_ipv(  $sock->NS_ipv);
        $client->NS_host( $sock->NS_host);
        $client->NS_port( $sock->NS_port);
        $client->SSLeay_context($sock->SSLeay_context);
        $client->SSLeay_is_client(1);
    }

    return wantarray ? ($client, $peername) : $client;
}

sub post_accept {
    my $client = shift;
    $client->SSLeay;
}

sub SSLeay {
    my $client = shift;

    if (! exists ${*$client}{'SSLeay'}) {
        die "SSLeay refusing to accept on non-client socket" if !$client->SSLeay_is_client;

        $client->autoflush(1);

        my $f = fcntl($client, Fcntl::F_GETFL(), 0)                || die "SSLeay - fcntl get: $!\n";
        fcntl($client, Fcntl::F_SETFL(), $f | Fcntl::O_NONBLOCK()) || die "SSLeay - fcntl set: $!\n";

        my $ssl = Net::SSLeay::new($client->SSLeay_context);  $client->SSLeay_check_fatal("SSLeay new");
        Net::SSLeay::set_fd($ssl, $client->fileno);           $client->SSLeay_check_fatal("SSLeay set_fd");
        Net::SSLeay::accept($ssl);                            $client->SSLeay_check_fatal("SSLeay accept");
        ${*$client}{'SSLeay'} = $ssl;
    }

    return if ! defined wantarray;
    return ${*$client}{'SSLeay'};
}

sub SSLeay_check_fatal {
    my ($client, $msg) = @_;
    if (my $err = $client->SSLeay_check_error($msg, 1)) {
        my ($pkg, $file, $line) = caller;
        die "$msg at $file line $line\n  ".join('  ', @$err);
    }
}

sub SSLeay_check_error {
    my ($client, $msg, $fatal) = @_;
    my @err;
    while (my $n = Net::SSLeay::ERR_get_error()) {
        push @err, "$n. ". Net::SSLeay::ERR_error_string($n) ."\n";
    }
    if (@err) {
        my $cb = $client->SSL_error_callback;
        $cb->($client, $msg, \@err, ($fatal ? 'is_fatal' : ())) if $cb;
        return \@err;
    }
    return;
}

# my $err = $sock->SSLeay_check_perm($msg)
# Returns permanent error string for $sock, or undef if no permanent error.
# Do not call this method unless you receive an unknown error response
# from one of the Net::SSLeay::* routines. If a temporary error is detected,
# then it will run select() using the corresponding READ or WRITE bits
# before returning undef.
sub SSLeay_check_perm {
    my ($client, $msg) = @_;
    my $perm;
    if (my $ssl = ${*$client}{'SSLeay'} and my $fn = $client->fileno()) {
        my $err = Net::SSLeay::get_error($ssl, -1);
        return if !$err;
        vec(my $vec = '', $fn, 1) = 1;
        if ($err == Net::SSLeay::ERROR_WANT_READ()) {
            select($vec, undef, undef, undef); # This is not a real error. SSLeay just wants to read, so block until something is ready.
            return;
        }
        if ($err == Net::SSLeay::ERROR_WANT_WRITE()) {
            select(undef, $vec, undef, undef); # This is not a real error. SSLeay just wants to write, so block until socket has room.
            return;
        }
        return if $!{'EAGAIN'} || $!{'EINTR'} || $!{'ENOBUFS'}; # Retryable safe errno
        ($perm = "FD$fn-sslerr[$err] - ".Net::SSLeay::ERR_error_string($err)." [$!] $@")=~s/\s+$//;
    }
    return if !$perm;

    $msg ||= "SSL ERROR";
    my $errs = [ ${*$client}{'_error'} = $perm = "$msg: ($perm)" ];
    if (my $cb = $client->SSL_error_callback) {
        $cb->($client, $msg, $errs);
    }
    return $errs->[0];
}

# my $bytes = $sock->pending();
# Returns number of bytes in the buffer.
sub pending {
    my $sock = shift;
    my $ssl = $sock && ${*$sock}{'SSLeay'} or return 0;
    return length ${*$sock}{'SSLeay_buffer'} if defined ${*$sock}{'SSLeay_buffer'};
    return Net::SSLeay::pending($ssl);
}


###----------------------------------------------------------------###

sub read_until {
    my ($client, $bytes, $end_qr) = @_;

    croak "read_until: bytes must be positive, or else undef" if defined $bytes and !$bytes || $bytes !~ /^\d+$/;

    my $ssl = $client->SSLeay;

    my $content = '';
    my $ok = 0;
    my $n = undef;
    while (!$ok) {
        $client->sysread($content, 16384, length $content) or last;
        if (defined($end_qr) && $content =~ m/$end_qr/g) {
            $n = pos($content);
            $ok = 1;
        }
        if ($bytes and length $content >= $bytes and !$ok || $n > $bytes) { # Keep qr match only if found earlier than $bytes
            $n = $bytes;
            $ok = 2;
        }
    }
    my $got = length $content;
    if ($ok and $n and $got > $n) { # Whoops, got a little too much, so prepend the extra onto the front of the buffer for later
        defined ${*$client}{'SSLeay_buffer'} or ${*$client}{'SSLeay_buffer'} = '';
        ${*$client}{'SSLeay_buffer'} = substr($content,$n,$got-$n,'') . ${*$client}{'SSLeay_buffer'};
    }
    return wantarray ? ($ok, $content) : $content;
}

sub read {
    my ($client, $buf, $size, $offset) = @_;
    my ($ok, $read) = $client->read_until($size);
    defined($_[1]) or $_[1] = '';
    substr($_[1], $offset || 0, length($_[1]), $read);
    return length $read;
}

sub sysread {
    my ($client, $buf, $max, $offset) = @_;
    delete ${*$client}{'_error'};
    $max = 1 if !$max || $max<0;
    $offset ||= 0;
    ref $buf or $buf = \$_[1];
    my $ssl = $client->SSLeay or return;
    my $max_bytes = 16384; # Read as many bytes as possible
    my ($retries, $data, $rv) = 5;
    if (my $ready = $client->pending) {
        my $buffer_size = defined ${*$client}{'SSLeay_buffer'} && length ${*$client}{'SSLeay_buffer'};
        if (!$buffer_size) {
            ($data, $rv) = Net::SSLeay::read($ssl, $max_bytes); # Hopefully $rv >= $ready
            $buffer_size = length (${*$client}{'SSLeay_buffer'} = $data) if defined $data; # Successfully consumed Net::SSLeay buffer
        }
        !$buffer_size and ${*$client}{'_error'} = "SSLEAY failed reading buffer" and return;
        $data = delete ${*$client}{'SSLeay_buffer'};
    }

    while ($retries-->0 and !defined $data) {
        $! = 0;
        ($data, $rv) = Net::SSLeay::read($ssl, $max_bytes);
        last if defined $data;
        return if $client->SSLeay_check_perm("SSLEAY sysread");
    }

    defined $data or return;
    my $length = length $data;
    $length>$max and ${*$client}{'SSLeay_buffer'} = substr $data,$max,$length-$max,''; # If too long, leave the extraneous bytes in the buffer

    defined $$buf or $$buf = '';
    if ($offset > length($$buf)) {
        $$buf .= "\0" x ($offset - length($$buf));
    }

    substr $$buf, $offset, length($$buf)-$offset, $data;
    return $length;
}

sub error { my $client = shift; return ${*$client}{'_error'} }

sub syswrite {
    my ($client, $buf, $length, $offset) = @_;
    delete ${*$client}{'_error'};

    $length = length $buf unless defined $length;
    $offset ||= 0;
    my $ssl = $client->SSLeay;
    my $content = substr $buf, $offset, $length;
    my $tries = 5;
    while ($tries-->0) {
        $! = 0;
        my $wrote = Net::SSLeay::write($ssl, $buf);
        return $wrote if $wrote >= 0;
        return if $client->SSLeay_check_perm("SSLEAY syswrite");
    }

    return;
}

sub getline {
    my $client = shift;
    my ($ok, $line) = $client->read_until($client->SSL_max_getline_length, $/);
    return $line;
}

sub getlines {
    my $client = shift;
    my @lines;
    while (1) {
        my ($ok, $line) = $client->read_until($client->SSL_max_getline_length, $/);
        push @lines, $line;
        last if $ok != 1;
    }
    return @lines;
}

sub print {
    my $client = shift;
    delete ${*$client}{'_error'};
    my $OFS = defined $, ? $, : '';
    my $buf = join $OFS, @_;
    return $client->write($buf);
}

sub printf {
    my $client = shift;
    $client->print(sprintf(shift, @_));
}

sub say {
    my $client = shift;
    $client->print(@_, "\n");
}

# my $bytes = $sock->write($data, $length, $offset)
# Returns the number of bytes from $data sent to the $sock
# beginning at $offset and sending up to $length bytes.
# If length is omitted, the entire $data string is sent.
# If $offset is omitted, then starts from the beginning (0).
# If only partial data is sent, then it will keep retrying
# until all the data has been encrypted and sent.
sub write {
    my $client = shift;
    my $buf    = shift;
    $buf = substr($buf, $_[1] || 0, $_[0]) if @_;
    my $total = 0;
    while (my $sent = $client->syswrite($buf, length($buf)-$total, $total)) {
        $total += $sent;
        return $total if $total >= length $buf;
    }
    return;
}

sub seek {
    my $client = shift;
    my ($pos, $whence) = @_;
    if ($whence) {
        $! = "Seek from $whence of non-zero is not supported.";
        return 0;
    }
    my $n = $client->read(my $buf, $pos);
    if ($n != $pos) {
        $| = "Couldn't seek to $pos ($n)\n";
        return 0;
    }
    return 1;
}

sub poll_cb { # implemented for psgi compatibility - TODO - should poll appropriately for Multipex
    my ($self, $cb) = @_;
    return $cb->($self);
}

###----------------------------------------------------------------###

sub hup_string {
    my $sock = shift;
    return join "|", $sock->NS_host, $sock->NS_port, $sock->NS_proto, "ipv".$sock->NS_ipv, (defined(${*$sock}{'NS_orig_port'}) ? ${*$sock}{'NS_orig_port'} : ());
}

sub show {
    my $sock = shift;
    my $t = "Ref = \"".ref($sock). "\" (".$sock->hup_string.")\n";
    foreach my $prop (qw(SSLeay_context SSLeay_is_client)) {
        $t .= "  $prop = \"" .$sock->$prop()."\"\n";
    }
    return $t;
}

sub AUTOLOAD {
    my $sock = shift;
    my $prop = $AUTOLOAD =~ /::([^:]+)$/ ? $1 : die "Missing property in AUTOLOAD.";
    die "Unknown method or property [$prop]"
        if $prop !~ /^(SSLeay_context|SSLeay_is_client|SSL_\w+)$/;

    no strict 'refs';
    *{__PACKAGE__."::${prop}"} = sub {
        my $sock = shift;
        if (@_) {
            ${*$sock}{$prop} = shift;
            return delete ${*$sock}{$prop} if ! defined ${*$sock}{$prop};
        } else {
            return ${*$sock}{$prop};
        }
    };
    return $sock->$prop(@_);
}

sub tie_stdout { 1 }

1;

__END__