c53c2fec82
Original logic was "if no records found *or* last one is truncated, then leave complete records in queue." Trouble is that if we don't pass on complete records and get complete packet in opposite direction, then queued records will go back to sender. In other words complete records should always be passed on. [Possible alternative would be to match direction in reconstruct_record.] Reviewed-by: Richard Levitte <levitte@openssl.org> (Merged from https://github.com/openssl/openssl/pull/5887)
690 lines
17 KiB
Perl
690 lines
17 KiB
Perl
# Copyright 2016-2018 The OpenSSL Project Authors. All Rights Reserved.
|
|
#
|
|
# Licensed under the OpenSSL license (the "License"). You may not use
|
|
# this file except in compliance with the License. You can obtain a copy
|
|
# in the file LICENSE in the source distribution or at
|
|
# https://www.openssl.org/source/license.html
|
|
|
|
use strict;
|
|
use POSIX ":sys_wait_h";
|
|
|
|
package TLSProxy::Proxy;
|
|
|
|
use File::Spec;
|
|
use IO::Socket;
|
|
use IO::Select;
|
|
use TLSProxy::Record;
|
|
use TLSProxy::Message;
|
|
use TLSProxy::ClientHello;
|
|
use TLSProxy::ServerHello;
|
|
use TLSProxy::EncryptedExtensions;
|
|
use TLSProxy::Certificate;
|
|
use TLSProxy::CertificateVerify;
|
|
use TLSProxy::ServerKeyExchange;
|
|
use TLSProxy::NewSessionTicket;
|
|
|
|
my $have_IPv6 = 0;
|
|
my $IP_factory;
|
|
|
|
my $is_tls13 = 0;
|
|
my $ciphersuite = undef;
|
|
|
|
sub new
|
|
{
|
|
my $class = shift;
|
|
my ($filter,
|
|
$execute,
|
|
$cert,
|
|
$debug) = @_;
|
|
|
|
my $self = {
|
|
#Public read/write
|
|
proxy_addr => "localhost",
|
|
server_addr => "localhost",
|
|
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 => [],
|
|
};
|
|
|
|
# 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
|
|
# fall back to IO::Socket::INET, only supports IPv4.
|
|
eval {
|
|
require IO::Socket::INET6;
|
|
my $s = IO::Socket::INET6->new(
|
|
LocalAddr => "::1",
|
|
LocalPort => 0,
|
|
Listen=>1,
|
|
);
|
|
$s or die "\n";
|
|
$s->close();
|
|
};
|
|
if ($@ eq "") {
|
|
$IP_factory = sub { IO::Socket::INET6->new(@_); };
|
|
$have_IPv6 = 1;
|
|
} else {
|
|
eval {
|
|
require IO::Socket::IP;
|
|
my $s = IO::Socket::IP->new(
|
|
LocalAddr => "::1",
|
|
LocalPort => 0,
|
|
Listen=>1,
|
|
);
|
|
$s or die "\n";
|
|
$s->close();
|
|
};
|
|
if ($@ eq "") {
|
|
$IP_factory = sub { IO::Socket::IP->new(@_); };
|
|
$have_IPv6 = 1;
|
|
} else {
|
|
$IP_factory = sub { IO::Socket::INET->new(@_); };
|
|
}
|
|
}
|
|
|
|
# Create the Proxy socket
|
|
my $proxaddr = $self->{proxy_addr};
|
|
$proxaddr =~ s/[\[\]]//g; # Remove [ and ]
|
|
my @proxyargs = (
|
|
LocalHost => $proxaddr,
|
|
LocalPort => 0,
|
|
Proto => "tcp",
|
|
Listen => SOMAXCONN,
|
|
);
|
|
$self->{proxy_sock} = $IP_factory->(@proxyargs);
|
|
|
|
if ($self->{proxy_sock}) {
|
|
$self->{proxy_port} = $self->{proxy_sock}->sockport();
|
|
print "Proxy started on port ".$self->{proxy_port}."\n";
|
|
} else {
|
|
warn "Failed creating proxy socket (".$proxaddr.",0): $!\n";
|
|
}
|
|
|
|
return bless $self, $class;
|
|
}
|
|
|
|
sub DESTROY
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->{proxy_sock}->close() if $self->{proxy_sock};
|
|
}
|
|
|
|
sub clearClient
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->{cipherc} = "";
|
|
$self->{ciphersuitec} = "";
|
|
$self->{flight} = -1;
|
|
$self->{direction} = -1;
|
|
$self->{partial} = ["", ""];
|
|
$self->{record_list} = [];
|
|
$self->{message_list} = [];
|
|
$self->{clientflags} = "";
|
|
$self->{sessionfile} = undef;
|
|
$self->{clientpid} = 0;
|
|
$is_tls13 = 0;
|
|
$ciphersuite = undef;
|
|
|
|
TLSProxy::Message->clear();
|
|
TLSProxy::Record->clear();
|
|
}
|
|
|
|
sub clear
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->clearClient;
|
|
$self->{ciphers} = "AES128-SHA";
|
|
$self->{ciphersuitess} = "TLS_AES_128_GCM_SHA256";
|
|
$self->{serverflags} = "";
|
|
$self->{serverconnects} = 1;
|
|
$self->{serverpid} = 0;
|
|
$self->{reneg} = 0;
|
|
}
|
|
|
|
sub restart
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->clear;
|
|
$self->start;
|
|
}
|
|
|
|
sub clientrestart
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->clear;
|
|
$self->clientstart;
|
|
}
|
|
|
|
sub connect_to_server
|
|
{
|
|
my $self = shift;
|
|
my $servaddr = $self->{server_addr};
|
|
|
|
$servaddr =~ s/[\[\]]//g; # Remove [ and ]
|
|
|
|
$self->{server_sock} = $IP_factory->(PeerAddr => $servaddr,
|
|
PeerPort => $self->{server_port},
|
|
Proto => 'tcp')
|
|
or die "unable to connect: $!\n";
|
|
}
|
|
|
|
sub start
|
|
{
|
|
my ($self) = shift;
|
|
my $pid;
|
|
|
|
if ($self->{proxy_sock} == 0) {
|
|
return 0;
|
|
}
|
|
|
|
my $execcmd = $self->execute
|
|
." s_server -max_protocol TLSv1.3 -no_comp -rev -engine ossltest"
|
|
." -accept 0 -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->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 |") 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...
|
|
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();
|
|
} 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;
|
|
}
|
|
|
|
sub clientstart
|
|
{
|
|
my ($self) = shift;
|
|
|
|
if ($self->execute) {
|
|
my $pid;
|
|
my $execcmd = $self->execute
|
|
." s_client -max_protocol TLSv1.3 -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->ciphersuitesc ne "") {
|
|
$execcmd .= " -ciphersuites ".$self->ciphersuitesc;
|
|
}
|
|
if ($self->clientflags ne "") {
|
|
$execcmd .= " ".$self->clientflags;
|
|
}
|
|
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(1)) {
|
|
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";
|
|
return 0;
|
|
}
|
|
|
|
print "Connection opened\n";
|
|
|
|
my $server_sock = $self->{server_sock};
|
|
my $indata;
|
|
|
|
#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($fdset->count
|
|
&& (!(TLSProxy::Message->end)
|
|
|| (defined $self->sessionfile()
|
|
&& (-s $self->sessionfile()) == 0))
|
|
&& $ctr < 10) {
|
|
if (!(@ready = $fdset->can_read(1))) {
|
|
$ctr++;
|
|
next;
|
|
}
|
|
foreach my $hand (@ready) {
|
|
if ($hand == $server_sock) {
|
|
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) {
|
|
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";
|
|
}
|
|
}
|
|
}
|
|
|
|
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();
|
|
}
|
|
|
|
my $pid;
|
|
if (--$self->{serverconnects} == 0) {
|
|
$pid = $self->{serverpid};
|
|
die "serverpid is zero\n" if $pid == 0;
|
|
print "Waiting for server process to close: $pid...\n";
|
|
# recall that we wait on process that buffers server's output
|
|
waitpid($pid, 0);
|
|
die "exit code $? from server process\n" if $? != 0;
|
|
} else {
|
|
# 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();
|
|
}
|
|
$pid = $self->{clientpid};
|
|
die "clientpid is zero\n" if $pid == 0;
|
|
print "Waiting for client process to close: $pid...\n";
|
|
waitpid($pid, 0);
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub process_packet
|
|
{
|
|
my ($self, $server, $packet) = @_;
|
|
my $len_real;
|
|
my $decrypt_len;
|
|
my $data;
|
|
my $recnum;
|
|
|
|
if ($server) {
|
|
print "Received server packet\n";
|
|
} else {
|
|
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 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) {
|
|
return "";
|
|
}
|
|
|
|
#Finished parsing. Call user provided filter here
|
|
if (defined $self->filter) {
|
|
$self->filter->($self);
|
|
}
|
|
|
|
#Reconstruct the packet
|
|
$packet = "";
|
|
foreach my $record (@{$self->record_list}) {
|
|
$packet .= $record->reconstruct_record($server);
|
|
}
|
|
|
|
print "Forwarded packet length = ".length($packet)."\n\n";
|
|
|
|
return $packet;
|
|
}
|
|
|
|
#Read accessors
|
|
sub execute
|
|
{
|
|
my $self = shift;
|
|
return $self->{execute};
|
|
}
|
|
sub cert
|
|
{
|
|
my $self = shift;
|
|
return $self->{cert};
|
|
}
|
|
sub debug
|
|
{
|
|
my $self = shift;
|
|
return $self->{debug};
|
|
}
|
|
sub flight
|
|
{
|
|
my $self = shift;
|
|
return $self->{flight};
|
|
}
|
|
sub record_list
|
|
{
|
|
my $self = shift;
|
|
return $self->{record_list};
|
|
}
|
|
sub success
|
|
{
|
|
my $self = shift;
|
|
return $self->{success};
|
|
}
|
|
sub end
|
|
{
|
|
my $self = shift;
|
|
return $self->{end};
|
|
}
|
|
sub supports_IPv6
|
|
{
|
|
my $self = shift;
|
|
return $have_IPv6;
|
|
}
|
|
sub proxy_addr
|
|
{
|
|
my $self = shift;
|
|
return $self->{proxy_addr};
|
|
}
|
|
sub proxy_port
|
|
{
|
|
my $self = shift;
|
|
return $self->{proxy_port};
|
|
}
|
|
sub server_addr
|
|
{
|
|
my $self = shift;
|
|
return $self->{server_addr};
|
|
}
|
|
sub server_port
|
|
{
|
|
my $self = 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;
|
|
if (@_) {
|
|
$self->{filter} = shift;
|
|
}
|
|
return $self->{filter};
|
|
}
|
|
sub cipherc
|
|
{
|
|
my $self = shift;
|
|
if (@_) {
|
|
$self->{cipherc} = shift;
|
|
}
|
|
return $self->{cipherc};
|
|
}
|
|
sub ciphersuitesc
|
|
{
|
|
my $self = shift;
|
|
if (@_) {
|
|
$self->{ciphersuitesc} = shift;
|
|
}
|
|
return $self->{ciphersuitesc};
|
|
}
|
|
sub ciphers
|
|
{
|
|
my $self = shift;
|
|
if (@_) {
|
|
$self->{ciphers} = shift;
|
|
}
|
|
return $self->{ciphers};
|
|
}
|
|
sub ciphersuitess
|
|
{
|
|
my $self = shift;
|
|
if (@_) {
|
|
$self->{ciphersuitess} = shift;
|
|
}
|
|
return $self->{ciphersuitess};
|
|
}
|
|
sub serverflags
|
|
{
|
|
my $self = shift;
|
|
if (@_) {
|
|
$self->{serverflags} = shift;
|
|
}
|
|
return $self->{serverflags};
|
|
}
|
|
sub clientflags
|
|
{
|
|
my $self = shift;
|
|
if (@_) {
|
|
$self->{clientflags} = shift;
|
|
}
|
|
return $self->{clientflags};
|
|
}
|
|
sub serverconnects
|
|
{
|
|
my $self = shift;
|
|
if (@_) {
|
|
$self->{serverconnects} = shift;
|
|
}
|
|
return $self->{serverconnects};
|
|
}
|
|
# This is a bit ugly because the caller is responsible for keeping the records
|
|
# in sync with the updated message list; simply updating the message list isn't
|
|
# sufficient to get the proxy to forward the new message.
|
|
# But it does the trick for the one test (test_sslsessiontick) that needs it.
|
|
sub message_list
|
|
{
|
|
my $self = shift;
|
|
if (@_) {
|
|
$self->{message_list} = shift;
|
|
}
|
|
return $self->{message_list};
|
|
}
|
|
|
|
sub fill_known_data
|
|
{
|
|
my $length = shift;
|
|
my $ret = "";
|
|
for (my $i = 0; $i < $length; $i++) {
|
|
$ret .= chr($i);
|
|
}
|
|
return $ret;
|
|
}
|
|
|
|
sub is_tls13
|
|
{
|
|
my $class = shift;
|
|
if (@_) {
|
|
$is_tls13 = shift;
|
|
}
|
|
return $is_tls13;
|
|
}
|
|
|
|
sub reneg
|
|
{
|
|
my $self = shift;
|
|
if (@_) {
|
|
$self->{reneg} = shift;
|
|
}
|
|
return $self->{reneg};
|
|
}
|
|
|
|
#Setting a sessionfile means that the client will not close until the given
|
|
#file exists. This is useful in TLSv1.3 where otherwise s_client will close
|
|
#immediately at the end of the handshake, but before the session has been
|
|
#received from the server. A side effect of this is that s_client never sends
|
|
#a close_notify, so instead we consider success to be when it sends application
|
|
#data over the connection.
|
|
sub sessionfile
|
|
{
|
|
my $self = shift;
|
|
if (@_) {
|
|
$self->{sessionfile} = shift;
|
|
TLSProxy::Message->successondata(1);
|
|
}
|
|
return $self->{sessionfile};
|
|
}
|
|
|
|
sub ciphersuite
|
|
{
|
|
my $class = shift;
|
|
if (@_) {
|
|
$ciphersuite = shift;
|
|
}
|
|
return $ciphersuite;
|
|
}
|
|
|
|
1;
|