Update - OpenSSL 1.1.1-pre7-dev
This commit is contained in:
@@ -21,7 +21,8 @@ $VERSION = "0.8";
|
||||
@EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file
|
||||
srctop_dir srctop_file
|
||||
data_file
|
||||
pipe with cmdstr quotify));
|
||||
pipe with cmdstr quotify
|
||||
openssl_versions));
|
||||
|
||||
=head1 NAME
|
||||
|
||||
@@ -606,6 +607,23 @@ sub srctop_file {
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<data_dir LIST>
|
||||
|
||||
LIST is a list of directories that make up a path from the data directory
|
||||
associated with the test (see L</DESCRIPTION> above).
|
||||
C<data_dir> returns the resulting directory as a string, adapted to the local
|
||||
operating system.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub data_dir {
|
||||
return __data_dir(@_);
|
||||
}
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<data_file LIST, FILENAME>
|
||||
|
||||
LIST is a list of directories that make up a path from the data directory
|
||||
@@ -788,6 +806,32 @@ sub quotify {
|
||||
return map { $arg_formatter->($_) } @_;
|
||||
}
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<openssl_versions>
|
||||
|
||||
Returns a list of two numbers, the first representing the build version,
|
||||
the second representing the library version. See opensslv.h for more
|
||||
information on those numbers.
|
||||
|
||||
= back
|
||||
|
||||
=cut
|
||||
|
||||
my @versions = ();
|
||||
sub openssl_versions {
|
||||
unless (@versions) {
|
||||
my %lines =
|
||||
map { s/\R$//;
|
||||
/^(.*): (0x[[:xdigit:]]{8})$/;
|
||||
die "Weird line: $_" unless defined $1;
|
||||
$1 => hex($2) }
|
||||
run(test(['versions']), capture => 1);
|
||||
@versions = ( $lines{'Build version'}, $lines{'Library version'} );
|
||||
}
|
||||
return @versions;
|
||||
}
|
||||
|
||||
######################################################################
|
||||
# private functions. These are never exported.
|
||||
|
||||
@@ -940,6 +984,12 @@ sub __data_file {
|
||||
return catfile($directories{SRCDATA},@_,$f);
|
||||
}
|
||||
|
||||
sub __data_dir {
|
||||
BAIL_OUT("Must run setup() first") if (! $test_name);
|
||||
|
||||
return catdir($directories{SRCDATA},@_);
|
||||
}
|
||||
|
||||
sub __results_file {
|
||||
BAIL_OUT("Must run setup() first") if (! $test_name);
|
||||
|
||||
|
||||
@@ -267,14 +267,17 @@ sub get_messages
|
||||
}
|
||||
} elsif ($record->content_type == TLSProxy::Record::RT_ALERT) {
|
||||
my ($alertlev, $alertdesc) = unpack('CC', $record->decrypt_data);
|
||||
print " [$alertlev, $alertdesc]\n";
|
||||
#A CloseNotify from the client indicates we have finished successfully
|
||||
#(we assume)
|
||||
if (!$end && !$server && $alertlev == AL_LEVEL_WARN
|
||||
&& $alertdesc == AL_DESC_CLOSE_NOTIFY) {
|
||||
$success = 1;
|
||||
}
|
||||
#All alerts end the test
|
||||
$end = 1;
|
||||
#Fatal or close notify alerts end the test
|
||||
if ($alertlev == AL_LEVEL_FATAL || $alertdesc == AL_DESC_CLOSE_NOTIFY) {
|
||||
$end = 1;
|
||||
}
|
||||
}
|
||||
|
||||
return @messages;
|
||||
|
||||
+320
-196
@@ -22,52 +22,16 @@ use TLSProxy::Certificate;
|
||||
use TLSProxy::CertificateVerify;
|
||||
use TLSProxy::ServerKeyExchange;
|
||||
use TLSProxy::NewSessionTicket;
|
||||
use Time::HiRes qw/usleep/;
|
||||
|
||||
my $have_IPv6 = 0;
|
||||
my $have_IPv6;
|
||||
my $IP_factory;
|
||||
|
||||
my $is_tls13 = 0;
|
||||
my $ciphersuite = undef;
|
||||
|
||||
sub new
|
||||
BEGIN
|
||||
{
|
||||
my $class = shift;
|
||||
my ($filter,
|
||||
$execute,
|
||||
$cert,
|
||||
$debug) = @_;
|
||||
|
||||
my $self = {
|
||||
#Public read/write
|
||||
proxy_addr => "localhost",
|
||||
proxy_port => 4453,
|
||||
server_addr => "localhost",
|
||||
server_port => 4443,
|
||||
filter => $filter,
|
||||
serverflags => "",
|
||||
clientflags => "",
|
||||
serverconnects => 1,
|
||||
serverpid => 0,
|
||||
clientpid => 0,
|
||||
reneg => 0,
|
||||
sessionfile => undef,
|
||||
|
||||
#Public read
|
||||
execute => $execute,
|
||||
cert => $cert,
|
||||
debug => $debug,
|
||||
cipherc => "",
|
||||
ciphers => "AES128-SHA:TLS13-AES-128-GCM-SHA256",
|
||||
flight => 0,
|
||||
record_list => [],
|
||||
message_list => [],
|
||||
};
|
||||
|
||||
# IO::Socket::IP is on the core module list, IO::Socket::INET6 isn't.
|
||||
# However, IO::Socket::INET6 is older and is said to be more widely
|
||||
# deployed for the moment, and may have less bugs, so we try the latter
|
||||
# first, then fall back on the code modules. Worst case scenario, we
|
||||
# first, then fall back on the core modules. Worst case scenario, we
|
||||
# fall back to IO::Socket::INET, only supports IPv4.
|
||||
eval {
|
||||
require IO::Socket::INET6;
|
||||
@@ -98,26 +62,72 @@ sub new
|
||||
$have_IPv6 = 1;
|
||||
} else {
|
||||
$IP_factory = sub { IO::Socket::INET->new(@_); };
|
||||
$have_IPv6 = 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $is_tls13 = 0;
|
||||
my $ciphersuite = undef;
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my ($filter,
|
||||
$execute,
|
||||
$cert,
|
||||
$debug) = @_;
|
||||
|
||||
my $self = {
|
||||
#Public read/write
|
||||
proxy_addr => $have_IPv6 ? "[::1]" : "127.0.0.1",
|
||||
filter => $filter,
|
||||
serverflags => "",
|
||||
clientflags => "",
|
||||
serverconnects => 1,
|
||||
reneg => 0,
|
||||
sessionfile => undef,
|
||||
|
||||
#Public read
|
||||
proxy_port => 0,
|
||||
server_port => 0,
|
||||
serverpid => 0,
|
||||
clientpid => 0,
|
||||
execute => $execute,
|
||||
cert => $cert,
|
||||
debug => $debug,
|
||||
cipherc => "",
|
||||
ciphersuitesc => "",
|
||||
ciphers => "AES128-SHA",
|
||||
ciphersuitess => "TLS_AES_128_GCM_SHA256",
|
||||
flight => -1,
|
||||
direction => -1,
|
||||
partial => ["", ""],
|
||||
record_list => [],
|
||||
message_list => [],
|
||||
};
|
||||
|
||||
# Create the Proxy socket
|
||||
my $proxaddr = $self->{proxy_addr};
|
||||
$proxaddr =~ s/[\[\]]//g; # Remove [ and ]
|
||||
my @proxyargs = (
|
||||
LocalHost => $proxaddr,
|
||||
LocalPort => $self->{proxy_port},
|
||||
LocalPort => 0,
|
||||
Proto => "tcp",
|
||||
Listen => SOMAXCONN,
|
||||
);
|
||||
push @proxyargs, ReuseAddr => 1
|
||||
unless $^O eq "MSWin32";
|
||||
$self->{proxy_sock} = $IP_factory->(@proxyargs);
|
||||
|
||||
if ($self->{proxy_sock}) {
|
||||
print "Proxy started on port ".$self->{proxy_port}."\n";
|
||||
if (my $sock = $IP_factory->(@proxyargs)) {
|
||||
$self->{proxy_sock} = $sock;
|
||||
$self->{proxy_port} = $sock->sockport();
|
||||
$self->{proxy_addr} = $sock->sockhost();
|
||||
$self->{proxy_addr} =~ s/(.*:.*)/[$1]/;
|
||||
print "Proxy started on port ",
|
||||
"$self->{proxy_addr}:$self->{proxy_port}\n";
|
||||
# use same address for s_server
|
||||
$self->{server_addr} = $self->{proxy_addr};
|
||||
} else {
|
||||
warn "Failed creating proxy socket (".$proxaddr.",".$self->{proxy_port}."): $!\n";
|
||||
warn "Failed creating proxy socket (".$proxaddr.",0): $!\n";
|
||||
}
|
||||
|
||||
return bless $self, $class;
|
||||
@@ -135,7 +145,10 @@ sub clearClient
|
||||
my $self = shift;
|
||||
|
||||
$self->{cipherc} = "";
|
||||
$self->{flight} = 0;
|
||||
$self->{ciphersuitec} = "";
|
||||
$self->{flight} = -1;
|
||||
$self->{direction} = -1;
|
||||
$self->{partial} = ["", ""];
|
||||
$self->{record_list} = [];
|
||||
$self->{message_list} = [];
|
||||
$self->{clientflags} = "";
|
||||
@@ -153,7 +166,8 @@ sub clear
|
||||
my $self = shift;
|
||||
|
||||
$self->clearClient;
|
||||
$self->{ciphers} = "AES128-SHA:TLS13-AES-128-GCM-SHA256";
|
||||
$self->{ciphers} = "AES128-SHA";
|
||||
$self->{ciphersuitess} = "TLS_AES_128_GCM_SHA256";
|
||||
$self->{serverflags} = "";
|
||||
$self->{serverconnects} = 1;
|
||||
$self->{serverpid} = 0;
|
||||
@@ -176,6 +190,25 @@ sub clientrestart
|
||||
$self->clientstart;
|
||||
}
|
||||
|
||||
sub connect_to_server
|
||||
{
|
||||
my $self = shift;
|
||||
my $servaddr = $self->{server_addr};
|
||||
|
||||
$servaddr =~ s/[\[\]]//g; # Remove [ and ]
|
||||
|
||||
my $sock = $IP_factory->(PeerAddr => $servaddr,
|
||||
PeerPort => $self->{server_port},
|
||||
Proto => 'tcp');
|
||||
if (!defined($sock)) {
|
||||
my $err = $!;
|
||||
kill(3, $self->{real_serverpid});
|
||||
die "unable to connect: $err\n";
|
||||
}
|
||||
|
||||
$self->{server_sock} = $sock;
|
||||
}
|
||||
|
||||
sub start
|
||||
{
|
||||
my ($self) = shift;
|
||||
@@ -185,28 +218,90 @@ sub start
|
||||
return 0;
|
||||
}
|
||||
|
||||
$pid = fork();
|
||||
if ($pid == 0) {
|
||||
my $execcmd = $self->execute
|
||||
." s_server -no_comp -rev -engine ossltest -accept "
|
||||
.($self->server_port)
|
||||
." -cert ".$self->cert." -cert2 ".$self->cert
|
||||
." -naccept ".$self->serverconnects;
|
||||
unless ($self->supports_IPv6) {
|
||||
$execcmd .= " -4";
|
||||
}
|
||||
if ($self->ciphers ne "") {
|
||||
$execcmd .= " -cipher ".$self->ciphers;
|
||||
}
|
||||
if ($self->serverflags ne "") {
|
||||
$execcmd .= " ".$self->serverflags;
|
||||
}
|
||||
if ($self->debug) {
|
||||
print STDERR "Server command: $execcmd\n";
|
||||
}
|
||||
exec($execcmd);
|
||||
my $execcmd = $self->execute
|
||||
." s_server -max_protocol TLSv1.3 -no_comp -rev -engine ossltest"
|
||||
#In TLSv1.3 we issue two session tickets. The default session id
|
||||
#callback gets confused because the ossltest engine causes the same
|
||||
#session id to be created twice due to the changed random number
|
||||
#generation. Using "-ext_cache" replaces the default callback with a
|
||||
#different one that doesn't get confused.
|
||||
." -ext_cache"
|
||||
." -accept $self->{server_addr}:0"
|
||||
." -cert ".$self->cert." -cert2 ".$self->cert
|
||||
." -naccept ".$self->serverconnects;
|
||||
if ($self->ciphers ne "") {
|
||||
$execcmd .= " -cipher ".$self->ciphers;
|
||||
}
|
||||
$self->serverpid($pid);
|
||||
if ($self->ciphersuitess ne "") {
|
||||
$execcmd .= " -ciphersuites ".$self->ciphersuitess;
|
||||
}
|
||||
if ($self->serverflags ne "") {
|
||||
$execcmd .= " ".$self->serverflags;
|
||||
}
|
||||
if ($self->debug) {
|
||||
print STDERR "Server command: $execcmd\n";
|
||||
}
|
||||
|
||||
open(my $savedin, "<&STDIN");
|
||||
|
||||
# Temporarily replace STDIN so that sink process can inherit it...
|
||||
$pid = open(STDIN, "$execcmd 2>&1 |") or die "Failed to $execcmd: $!\n";
|
||||
$self->{real_serverpid} = $pid;
|
||||
|
||||
# Process the output from s_server until we find the ACCEPT line, which
|
||||
# tells us what the accepting address and port are.
|
||||
while (<>) {
|
||||
print;
|
||||
s/\R$//; # Better chomp
|
||||
next unless (/^ACCEPT\s.*:(\d+)$/);
|
||||
$self->{server_port} = $1;
|
||||
last;
|
||||
}
|
||||
|
||||
if ($self->{server_port} == 0) {
|
||||
# This actually means that s_server exited, because otherwise
|
||||
# we would still searching for ACCEPT...
|
||||
waitpid($pid, 0);
|
||||
die "no ACCEPT detected in '$execcmd' output: $?\n";
|
||||
}
|
||||
|
||||
# Just make sure everything else is simply printed [as separate lines].
|
||||
# The sub process simply inherits our STD* and will keep consuming
|
||||
# server's output and printing it as long as there is anything there,
|
||||
# out of our way.
|
||||
my $error;
|
||||
$pid = undef;
|
||||
if (eval { require Win32::Process; 1; }) {
|
||||
if (Win32::Process::Create(my $h, $^X, "perl -ne print", 0, 0, ".")) {
|
||||
$pid = $h->GetProcessID();
|
||||
$self->{proc_handle} = $h; # hold handle till next round [or exit]
|
||||
} else {
|
||||
$error = Win32::FormatMessage(Win32::GetLastError());
|
||||
}
|
||||
} else {
|
||||
if (defined($pid = fork)) {
|
||||
$pid or exec("$^X -ne print") or exit($!);
|
||||
} else {
|
||||
$error = $!;
|
||||
}
|
||||
}
|
||||
|
||||
# Change back to original stdin
|
||||
open(STDIN, "<&", $savedin);
|
||||
close($savedin);
|
||||
|
||||
if (!defined($pid)) {
|
||||
kill(3, $self->{real_serverpid});
|
||||
die "Failed to capture s_server's output: $error\n";
|
||||
}
|
||||
|
||||
$self->{serverpid} = $pid;
|
||||
|
||||
print STDERR "Server responds on ",
|
||||
"$self->{server_addr}:$self->{server_port}\n";
|
||||
|
||||
# Connect right away...
|
||||
$self->connect_to_server();
|
||||
|
||||
return $self->clientstart;
|
||||
}
|
||||
@@ -214,41 +309,57 @@ sub start
|
||||
sub clientstart
|
||||
{
|
||||
my ($self) = shift;
|
||||
my $oldstdout;
|
||||
|
||||
if ($self->execute) {
|
||||
my $pid = fork();
|
||||
if ($pid == 0) {
|
||||
my $echostr;
|
||||
if ($self->reneg()) {
|
||||
$echostr = "R";
|
||||
} else {
|
||||
$echostr = "test";
|
||||
}
|
||||
my $execcmd = "echo ".$echostr." | ".$self->execute
|
||||
." s_client -engine ossltest -connect "
|
||||
.($self->proxy_addr).":".($self->proxy_port);
|
||||
unless ($self->supports_IPv6) {
|
||||
$execcmd .= " -4";
|
||||
}
|
||||
if ($self->cipherc ne "") {
|
||||
$execcmd .= " -cipher ".$self->cipherc;
|
||||
}
|
||||
if ($self->clientflags ne "") {
|
||||
$execcmd .= " ".$self->clientflags;
|
||||
}
|
||||
if (defined $self->sessionfile) {
|
||||
$execcmd .= " -ign_eof";
|
||||
}
|
||||
if ($self->debug) {
|
||||
print STDERR "Client command: $execcmd\n";
|
||||
}
|
||||
exec($execcmd);
|
||||
my $pid;
|
||||
my $execcmd = $self->execute
|
||||
." s_client -max_protocol TLSv1.3 -engine ossltest"
|
||||
." -connect $self->{proxy_addr}:$self->{proxy_port}";
|
||||
if ($self->cipherc ne "") {
|
||||
$execcmd .= " -cipher ".$self->cipherc;
|
||||
}
|
||||
$self->clientpid($pid);
|
||||
if ($self->ciphersuitesc ne "") {
|
||||
$execcmd .= " -ciphersuites ".$self->ciphersuitesc;
|
||||
}
|
||||
if ($self->clientflags ne "") {
|
||||
$execcmd .= " ".$self->clientflags;
|
||||
}
|
||||
if ($self->clientflags !~ m/-(no)?servername/) {
|
||||
$execcmd .= " -servername localhost";
|
||||
}
|
||||
if (defined $self->sessionfile) {
|
||||
$execcmd .= " -ign_eof";
|
||||
}
|
||||
if ($self->debug) {
|
||||
print STDERR "Client command: $execcmd\n";
|
||||
}
|
||||
|
||||
open(my $savedout, ">&STDOUT");
|
||||
# If we open pipe with new descriptor, attempt to close it,
|
||||
# explicitly or implicitly, would incur waitpid and effectively
|
||||
# dead-lock...
|
||||
if (!($pid = open(STDOUT, "| $execcmd"))) {
|
||||
my $err = $!;
|
||||
kill(3, $self->{real_serverpid});
|
||||
die "Failed to $execcmd: $err\n";
|
||||
}
|
||||
$self->{clientpid} = $pid;
|
||||
|
||||
# queue [magic] input
|
||||
print $self->reneg ? "R" : "test";
|
||||
|
||||
# this closes client's stdin without waiting for its pid
|
||||
open(STDOUT, ">&", $savedout);
|
||||
close($savedout);
|
||||
}
|
||||
|
||||
# Wait for incoming connection from client
|
||||
my $fdset = IO::Select->new($self->{proxy_sock});
|
||||
if (!$fdset->can_read(60)) {
|
||||
kill(3, $self->{real_serverpid});
|
||||
die "s_client didn't try to connect\n";
|
||||
}
|
||||
|
||||
my $client_sock;
|
||||
if(!($client_sock = $self->{proxy_sock}->accept())) {
|
||||
warn "Failed accepting incoming connection: $!\n";
|
||||
@@ -257,100 +368,96 @@ sub clientstart
|
||||
|
||||
print "Connection opened\n";
|
||||
|
||||
# Now connect to the server
|
||||
my $retry = 50;
|
||||
my $server_sock;
|
||||
#We loop over this a few times because sometimes s_server can take a while
|
||||
#to start up
|
||||
do {
|
||||
my $servaddr = $self->server_addr;
|
||||
$servaddr =~ s/[\[\]]//g; # Remove [ and ]
|
||||
eval {
|
||||
$server_sock = $IP_factory->(
|
||||
PeerAddr => $servaddr,
|
||||
PeerPort => $self->server_port,
|
||||
MultiHomed => 1,
|
||||
Proto => 'tcp'
|
||||
);
|
||||
};
|
||||
|
||||
$retry--;
|
||||
#Some buggy IP factories can return a defined server_sock that hasn't
|
||||
#actually connected, so we check peerport too
|
||||
if ($@ || !defined($server_sock) || !defined($server_sock->peerport)) {
|
||||
$server_sock->close() if defined($server_sock);
|
||||
undef $server_sock;
|
||||
if ($retry) {
|
||||
#Sleep for a short while
|
||||
select(undef, undef, undef, 0.1);
|
||||
} else {
|
||||
warn "Failed to start up server (".$servaddr.",".$self->server_port."): $!\n";
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
} while (!$server_sock);
|
||||
|
||||
my $sel = IO::Select->new($server_sock, $client_sock);
|
||||
my $server_sock = $self->{server_sock};
|
||||
my $indata;
|
||||
my @handles = ($server_sock, $client_sock);
|
||||
|
||||
#Wait for either the server socket or the client socket to become readable
|
||||
$fdset = IO::Select->new($server_sock, $client_sock);
|
||||
my @ready;
|
||||
my $ctr = 0;
|
||||
local $SIG{PIPE} = "IGNORE";
|
||||
while( (!(TLSProxy::Message->end)
|
||||
|| (defined $self->sessionfile()
|
||||
&& (-s $self->sessionfile()) == 0))
|
||||
&& $ctr < 10) {
|
||||
if (!(@ready = $sel->can_read(1))) {
|
||||
$self->{saw_session_ticket} = undef;
|
||||
while($fdset->count && $ctr < 10) {
|
||||
if (defined($self->{sessionfile})) {
|
||||
# s_client got -ign_eof and won't be exiting voluntarily, so we
|
||||
# look for data *and* session ticket...
|
||||
last if TLSProxy::Message->success()
|
||||
&& $self->{saw_session_ticket};
|
||||
}
|
||||
if (!(@ready = $fdset->can_read(1))) {
|
||||
$ctr++;
|
||||
next;
|
||||
}
|
||||
foreach my $hand (@ready) {
|
||||
if ($hand == $server_sock) {
|
||||
$server_sock->sysread($indata, 16384) or goto END;
|
||||
$indata = $self->process_packet(1, $indata);
|
||||
$client_sock->syswrite($indata);
|
||||
$ctr = 0;
|
||||
if ($server_sock->sysread($indata, 16384)) {
|
||||
if ($indata = $self->process_packet(1, $indata)) {
|
||||
$client_sock->syswrite($indata) or goto END;
|
||||
}
|
||||
$ctr = 0;
|
||||
} else {
|
||||
$fdset->remove($server_sock);
|
||||
$client_sock->shutdown(SHUT_WR);
|
||||
}
|
||||
} elsif ($hand == $client_sock) {
|
||||
$client_sock->sysread($indata, 16384) or goto END;
|
||||
$indata = $self->process_packet(0, $indata);
|
||||
$server_sock->syswrite($indata);
|
||||
$ctr = 0;
|
||||
if ($client_sock->sysread($indata, 16384)) {
|
||||
if ($indata = $self->process_packet(0, $indata)) {
|
||||
$server_sock->syswrite($indata) or goto END;
|
||||
}
|
||||
$ctr = 0;
|
||||
} else {
|
||||
$fdset->remove($client_sock);
|
||||
$server_sock->shutdown(SHUT_WR);
|
||||
}
|
||||
} else {
|
||||
kill(3, $self->{real_serverpid});
|
||||
die "Unexpected handle";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
die "No progress made" if $ctr >= 10;
|
||||
if ($ctr >= 10) {
|
||||
kill(3, $self->{real_serverpid});
|
||||
die "No progress made";
|
||||
}
|
||||
|
||||
END:
|
||||
print "Connection closed\n";
|
||||
if($server_sock) {
|
||||
$server_sock->close();
|
||||
$self->{server_sock} = undef;
|
||||
}
|
||||
if($client_sock) {
|
||||
#Closing this also kills the child process
|
||||
$client_sock->close();
|
||||
}
|
||||
if(!$self->debug) {
|
||||
select($oldstdout);
|
||||
}
|
||||
$self->serverconnects($self->serverconnects - 1);
|
||||
if ($self->serverconnects == 0) {
|
||||
die "serverpid is zero\n" if $self->serverpid == 0;
|
||||
print "Waiting for server process to close: "
|
||||
.$self->serverpid."\n";
|
||||
waitpid( $self->serverpid, 0);
|
||||
die "exit code $? from server process\n" if $? != 0;
|
||||
|
||||
my $pid;
|
||||
if (--$self->{serverconnects} == 0) {
|
||||
$pid = $self->{serverpid};
|
||||
print "Waiting for 'perl -ne print' process to close: $pid...\n";
|
||||
$pid = waitpid($pid, 0);
|
||||
if ($pid > 0) {
|
||||
die "exit code $? from 'perl -ne print' process\n" if $? != 0;
|
||||
} elsif ($pid == 0) {
|
||||
kill(3, $self->{real_serverpid});
|
||||
die "lost control over $self->{serverpid}?";
|
||||
}
|
||||
$pid = $self->{real_serverpid};
|
||||
print "Waiting for s_server process to close: $pid...\n";
|
||||
# it's done already, just collect the exit code [and reap]...
|
||||
waitpid($pid, 0);
|
||||
die "exit code $? from s_server process\n" if $? != 0;
|
||||
} else {
|
||||
# Give s_server sufficient time to finish what it was doing
|
||||
usleep(250000);
|
||||
# It's a bit counter-intuitive spot to make next connection to
|
||||
# the s_server. Rationale is that established connection works
|
||||
# as syncronization point, in sense that this way we know that
|
||||
# s_server is actually done with current session...
|
||||
$self->connect_to_server();
|
||||
}
|
||||
die "clientpid is zero\n" if $self->clientpid == 0;
|
||||
print "Waiting for client process to close: ".$self->clientpid."\n";
|
||||
waitpid($self->clientpid, 0);
|
||||
$pid = $self->{clientpid};
|
||||
print "Waiting for s_client process to close: $pid...\n";
|
||||
waitpid($pid, 0);
|
||||
|
||||
return 1;
|
||||
}
|
||||
@@ -369,34 +476,47 @@ sub process_packet
|
||||
print "Received client packet\n";
|
||||
}
|
||||
|
||||
if ($self->{direction} != $server) {
|
||||
$self->{flight} = $self->{flight} + 1;
|
||||
$self->{direction} = $server;
|
||||
}
|
||||
|
||||
print "Packet length = ".length($packet)."\n";
|
||||
print "Processing flight ".$self->flight."\n";
|
||||
|
||||
#Return contains the list of record found in the packet followed by the
|
||||
#list of messages in those records
|
||||
my @ret = TLSProxy::Record->get_records($server, $self->flight, $packet);
|
||||
push @{$self->record_list}, @{$ret[0]};
|
||||
#list of messages in those records and any partial message
|
||||
my @ret = TLSProxy::Record->get_records($server, $self->flight,
|
||||
$self->{partial}[$server].$packet);
|
||||
$self->{partial}[$server] = $ret[2];
|
||||
push @{$self->{record_list}}, @{$ret[0]};
|
||||
push @{$self->{message_list}}, @{$ret[1]};
|
||||
|
||||
print "\n";
|
||||
|
||||
if (scalar(@{$ret[0]}) == 0 or length($ret[2]) != 0) {
|
||||
return "";
|
||||
}
|
||||
|
||||
#Finished parsing. Call user provided filter here
|
||||
if(defined $self->filter) {
|
||||
if (defined $self->filter) {
|
||||
$self->filter->($self);
|
||||
}
|
||||
|
||||
#Take a note on NewSessionTicket
|
||||
foreach my $message (reverse @{$self->{message_list}}) {
|
||||
if ($message->{mt} == TLSProxy::Message::MT_NEW_SESSION_TICKET) {
|
||||
$self->{saw_session_ticket} = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
#Reconstruct the packet
|
||||
$packet = "";
|
||||
foreach my $record (@{$self->record_list}) {
|
||||
#We only replay the records for the current flight
|
||||
if ($record->flight != $self->flight) {
|
||||
next;
|
||||
}
|
||||
$packet .= $record->reconstruct_record($server);
|
||||
}
|
||||
|
||||
$self->{flight} = $self->{flight} + 1;
|
||||
|
||||
print "Forwarded packet length = ".length($packet)."\n\n";
|
||||
|
||||
return $packet;
|
||||
@@ -453,24 +573,28 @@ sub proxy_port
|
||||
my $self = shift;
|
||||
return $self->{proxy_port};
|
||||
}
|
||||
|
||||
#Read/write accessors
|
||||
sub server_addr
|
||||
{
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{server_addr} = shift;
|
||||
}
|
||||
return $self->{server_addr};
|
||||
}
|
||||
sub server_port
|
||||
{
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{server_port} = shift;
|
||||
}
|
||||
return $self->{server_port};
|
||||
}
|
||||
sub serverpid
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{serverpid};
|
||||
}
|
||||
sub clientpid
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{clientpid};
|
||||
}
|
||||
|
||||
#Read/write accessors
|
||||
sub filter
|
||||
{
|
||||
my $self = shift;
|
||||
@@ -487,6 +611,14 @@ sub cipherc
|
||||
}
|
||||
return $self->{cipherc};
|
||||
}
|
||||
sub ciphersuitesc
|
||||
{
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{ciphersuitesc} = shift;
|
||||
}
|
||||
return $self->{ciphersuitesc};
|
||||
}
|
||||
sub ciphers
|
||||
{
|
||||
my $self = shift;
|
||||
@@ -495,6 +627,14 @@ sub ciphers
|
||||
}
|
||||
return $self->{ciphers};
|
||||
}
|
||||
sub ciphersuitess
|
||||
{
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{ciphersuitess} = shift;
|
||||
}
|
||||
return $self->{ciphersuitess};
|
||||
}
|
||||
sub serverflags
|
||||
{
|
||||
my $self = shift;
|
||||
@@ -531,22 +671,6 @@ sub message_list
|
||||
}
|
||||
return $self->{message_list};
|
||||
}
|
||||
sub serverpid
|
||||
{
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{serverpid} = shift;
|
||||
}
|
||||
return $self->{serverpid};
|
||||
}
|
||||
sub clientpid
|
||||
{
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{clientpid} = shift;
|
||||
}
|
||||
return $self->{clientpid};
|
||||
}
|
||||
|
||||
sub fill_known_data
|
||||
{
|
||||
|
||||
@@ -36,7 +36,7 @@ my %record_type = (
|
||||
|
||||
use constant {
|
||||
VERS_TLS_1_4 => 0x0305,
|
||||
VERS_TLS_1_3_DRAFT => 0x7f17,
|
||||
VERS_TLS_1_3_DRAFT => 0x7f1c,
|
||||
VERS_TLS_1_3 => 0x0304,
|
||||
VERS_TLS_1_2 => 0x0303,
|
||||
VERS_TLS_1_1 => 0x0302,
|
||||
@@ -61,83 +61,70 @@ sub get_records
|
||||
my $server = shift;
|
||||
my $flight = shift;
|
||||
my $packet = shift;
|
||||
my $partial = "";
|
||||
my @record_list = ();
|
||||
my @message_list = ();
|
||||
my $data;
|
||||
my $content_type;
|
||||
my $version;
|
||||
my $len;
|
||||
my $len_real;
|
||||
my $decrypt_len;
|
||||
|
||||
my $recnum = 1;
|
||||
while (length ($packet) > 0) {
|
||||
print " Record $recnum";
|
||||
if ($server) {
|
||||
print " (server -> client)\n";
|
||||
} else {
|
||||
print " (client -> server)\n";
|
||||
}
|
||||
#Get the record header
|
||||
if (length($packet) < TLS_RECORD_HEADER_LENGTH) {
|
||||
print " Record $recnum ", $server ? "(server -> client)\n"
|
||||
: "(client -> server)\n";
|
||||
|
||||
#Get the record header (unpack can't fail if $packet is too short)
|
||||
my ($content_type, $version, $len) = unpack('Cnn', $packet);
|
||||
|
||||
if (length($packet) < TLS_RECORD_HEADER_LENGTH + ($len // 0)) {
|
||||
print "Partial data : ".length($packet)." bytes\n";
|
||||
$packet = "";
|
||||
} else {
|
||||
($content_type, $version, $len) = unpack('CnnC*', $packet);
|
||||
$data = substr($packet, 5, $len);
|
||||
$partial = $packet;
|
||||
last;
|
||||
}
|
||||
|
||||
print " Content type: ".$record_type{$content_type}."\n";
|
||||
print " Version: $tls_version{$version}\n";
|
||||
print " Length: $len";
|
||||
if ($len == length($data)) {
|
||||
print "\n";
|
||||
$decrypt_len = $len_real = $len;
|
||||
} else {
|
||||
print " (expected), ".length($data)." (actual)\n";
|
||||
$decrypt_len = $len_real = length($data);
|
||||
}
|
||||
my $data = substr($packet, TLS_RECORD_HEADER_LENGTH, $len);
|
||||
|
||||
my $record = TLSProxy::Record->new(
|
||||
$flight,
|
||||
$content_type,
|
||||
$version,
|
||||
$len,
|
||||
0,
|
||||
$len_real,
|
||||
$decrypt_len,
|
||||
substr($packet, TLS_RECORD_HEADER_LENGTH, $len_real),
|
||||
substr($packet, TLS_RECORD_HEADER_LENGTH, $len_real)
|
||||
);
|
||||
print " Content type: ".$record_type{$content_type}."\n";
|
||||
print " Version: $tls_version{$version}\n";
|
||||
print " Length: $len\n";
|
||||
|
||||
if ($content_type != RT_CCS) {
|
||||
if (($server && $server_encrypting)
|
||||
|| (!$server && $client_encrypting)) {
|
||||
if (!TLSProxy::Proxy->is_tls13() && $etm) {
|
||||
$record->decryptETM();
|
||||
} else {
|
||||
$record->decrypt();
|
||||
}
|
||||
$record->encrypted(1);
|
||||
my $record = TLSProxy::Record->new(
|
||||
$flight,
|
||||
$content_type,
|
||||
$version,
|
||||
$len,
|
||||
0,
|
||||
$len, # len_real
|
||||
$len, # decrypt_len
|
||||
$data, # data
|
||||
$data # decrypt_data
|
||||
);
|
||||
|
||||
if (TLSProxy::Proxy->is_tls13()) {
|
||||
print " Inner content type: "
|
||||
.$record_type{$record->content_type()}."\n";
|
||||
}
|
||||
if ($content_type != RT_CCS) {
|
||||
if (($server && $server_encrypting)
|
||||
|| (!$server && $client_encrypting)) {
|
||||
if (!TLSProxy::Proxy->is_tls13() && $etm) {
|
||||
$record->decryptETM();
|
||||
} else {
|
||||
$record->decrypt();
|
||||
}
|
||||
$record->encrypted(1);
|
||||
|
||||
if (TLSProxy::Proxy->is_tls13()) {
|
||||
print " Inner content type: "
|
||||
.$record_type{$record->content_type()}."\n";
|
||||
}
|
||||
}
|
||||
|
||||
push @record_list, $record;
|
||||
|
||||
#Now figure out what messages are contained within this record
|
||||
my @messages = TLSProxy::Message->get_messages($server, $record);
|
||||
push @message_list, @messages;
|
||||
|
||||
$packet = substr($packet, TLS_RECORD_HEADER_LENGTH + $len_real);
|
||||
$recnum++;
|
||||
}
|
||||
|
||||
push @record_list, $record;
|
||||
|
||||
#Now figure out what messages are contained within this record
|
||||
my @messages = TLSProxy::Message->get_messages($server, $record);
|
||||
push @message_list, @messages;
|
||||
|
||||
$packet = substr($packet, TLS_RECORD_HEADER_LENGTH + $len);
|
||||
$recnum++;
|
||||
}
|
||||
|
||||
return (\@record_list, \@message_list);
|
||||
return (\@record_list, \@message_list, $partial);
|
||||
}
|
||||
|
||||
sub clear
|
||||
@@ -197,6 +184,7 @@ sub new
|
||||
data => $data,
|
||||
decrypt_data => $decrypt_data,
|
||||
orig_decrypt_data => $decrypt_data,
|
||||
sent => 0,
|
||||
encrypted => 0,
|
||||
outer_content_type => RT_APPLICATION_DATA
|
||||
};
|
||||
@@ -287,6 +275,12 @@ sub reconstruct_record
|
||||
my $server = shift;
|
||||
my $data;
|
||||
|
||||
#We only replay the records in the same direction
|
||||
if ($self->{sent} || ($self->flight & 1) != $server) {
|
||||
return "";
|
||||
}
|
||||
$self->{sent} = 1;
|
||||
|
||||
if ($self->sslv2) {
|
||||
$data = pack('n', $self->len | 0x8000);
|
||||
} else {
|
||||
@@ -391,4 +385,16 @@ sub outer_content_type
|
||||
}
|
||||
return $self->{outer_content_type};
|
||||
}
|
||||
sub is_fatal_alert
|
||||
{
|
||||
my $self = shift;
|
||||
my $server = shift;
|
||||
|
||||
if (($self->{flight} & 1) == $server
|
||||
&& $self->{content_type} == TLSProxy::Record::RT_ALERT) {
|
||||
my ($level, $alert) = unpack('CC', $self->decrypt_data);
|
||||
return $alert if ($level == 2);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
1;
|
||||
Reference in New Issue
Block a user