Proxy.pm 15.0 KB
Newer Older
1
# Copyright 2016-2018 The OpenSSL Project Authors. All Rights Reserved.
M
Matt Caswell 已提交
2
#
3 4 5 6
# 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
M
Matt Caswell 已提交
7 8

use strict;
M
Matt Caswell 已提交
9
use POSIX ":sys_wait_h";
M
Matt Caswell 已提交
10 11 12 13 14 15 16 17 18

package TLSProxy::Proxy;

use File::Spec;
use IO::Socket;
use IO::Select;
use TLSProxy::Record;
use TLSProxy::Message;
use TLSProxy::ClientHello;
M
Matt Caswell 已提交
19
use TLSProxy::ServerHello;
M
Matt Caswell 已提交
20
use TLSProxy::EncryptedExtensions;
21
use TLSProxy::Certificate;
22
use TLSProxy::CertificateVerify;
M
Matt Caswell 已提交
23
use TLSProxy::ServerKeyExchange;
E
Emilia Kasper 已提交
24
use TLSProxy::NewSessionTicket;
M
Matt Caswell 已提交
25
use Time::HiRes qw/usleep/;
M
Matt Caswell 已提交
26

27 28 29
my $have_IPv6 = 0;
my $IP_factory;

M
Matt Caswell 已提交
30
my $is_tls13 = 0;
31
my $ciphersuite = undef;
M
Matt Caswell 已提交
32

M
Matt Caswell 已提交
33 34 35 36 37 38 39 40 41 42 43 44 45 46 47
sub new
{
    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,
M
Matt Caswell 已提交
48 49 50
        serverflags => "",
        clientflags => "",
        serverconnects => 1,
M
Matt Caswell 已提交
51
        serverpid => 0,
M
Matt Caswell 已提交
52
        clientpid => 0,
M
Matt Caswell 已提交
53
        reneg => 0,
54
        sessionfile => undef,
M
Matt Caswell 已提交
55 56 57 58 59

        #Public read
        execute => $execute,
        cert => $cert,
        debug => $debug,
M
Matt Caswell 已提交
60
        cipherc => "",
61 62 63
        ciphersuitesc => "",
        ciphers => "AES128-SHA",
        ciphersuitess => "TLS_AES_128_GCM_SHA256",
64 65 66
        flight => -1,
        direction => -1,
        partial => ["", ""],
M
Matt Caswell 已提交
67 68 69 70
        record_list => [],
        message_list => [],
    };

71 72 73 74 75
    # 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.
76
    eval {
77 78
        require IO::Socket::INET6;
        my $s = IO::Socket::INET6->new(
79 80 81 82 83 84 85 86
            LocalAddr => "::1",
            LocalPort => 0,
            Listen=>1,
            );
        $s or die "\n";
        $s->close();
    };
    if ($@ eq "") {
87
        $IP_factory = sub { IO::Socket::INET6->new(@_); };
88 89 90
        $have_IPv6 = 1;
    } else {
        eval {
91 92
            require IO::Socket::IP;
            my $s = IO::Socket::IP->new(
93 94 95 96 97 98 99 100
                LocalAddr => "::1",
                LocalPort => 0,
                Listen=>1,
                );
            $s or die "\n";
            $s->close();
        };
        if ($@ eq "") {
101
            $IP_factory = sub { IO::Socket::IP->new(@_); };
102 103 104 105 106 107
            $have_IPv6 = 1;
        } else {
            $IP_factory = sub { IO::Socket::INET->new(@_); };
        }
    }

108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
    # Create the Proxy socket
    my $proxaddr = $self->{proxy_addr};
    $proxaddr =~ s/[\[\]]//g; # Remove [ and ]
    my @proxyargs = (
        LocalHost   => $proxaddr,
        LocalPort   => $self->{proxy_port},
        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";
    } else {
        warn "Failed creating proxy socket (".$proxaddr.",".$self->{proxy_port}."): $!\n";
    }

M
Matt Caswell 已提交
127 128 129
    return bless $self, $class;
}

130 131 132 133 134 135 136
sub DESTROY
{
    my $self = shift;

    $self->{proxy_sock}->close() if $self->{proxy_sock};
}

M
Matt Caswell 已提交
137
sub clearClient
M
Matt Caswell 已提交
138 139 140
{
    my $self = shift;

M
Matt Caswell 已提交
141
    $self->{cipherc} = "";
142
    $self->{ciphersuitec} = "";
143 144 145
    $self->{flight} = -1;
    $self->{direction} = -1;
    $self->{partial} = ["", ""];
M
Matt Caswell 已提交
146 147
    $self->{record_list} = [];
    $self->{message_list} = [];
M
Matt Caswell 已提交
148
    $self->{clientflags} = "";
149
    $self->{sessionfile} = undef;
M
Matt Caswell 已提交
150
    $self->{clientpid} = 0;
M
Matt Caswell 已提交
151
    $is_tls13 = 0;
152
    $ciphersuite = undef;
M
Matt Caswell 已提交
153 154 155 156 157

    TLSProxy::Message->clear();
    TLSProxy::Record->clear();
}

M
Matt Caswell 已提交
158 159 160 161 162
sub clear
{
    my $self = shift;

    $self->clearClient;
163 164
    $self->{ciphers} = "AES128-SHA";
    $self->{ciphersuitess} = "TLS_AES_128_GCM_SHA256";
M
Matt Caswell 已提交
165 166 167
    $self->{serverflags} = "";
    $self->{serverconnects} = 1;
    $self->{serverpid} = 0;
M
Matt Caswell 已提交
168
    $self->{reneg} = 0;
M
Matt Caswell 已提交
169 170
}

M
Matt Caswell 已提交
171 172 173 174 175 176 177 178
sub restart
{
    my $self = shift;

    $self->clear;
    $self->start;
}

M
Matt Caswell 已提交
179 180 181 182 183 184 185 186
sub clientrestart
{
    my $self = shift;

    $self->clear;
    $self->clientstart;
}

M
Matt Caswell 已提交
187 188 189 190 191
sub start
{
    my ($self) = shift;
    my $pid;

192 193 194 195
    if ($self->{proxy_sock} == 0) {
        return 0;
    }

M
Matt Caswell 已提交
196 197
    $pid = fork();
    if ($pid == 0) {
198
        my $execcmd = $self->execute
199
            ." s_server -max_protocol TLSv1.3 -no_comp -rev -engine ossltest -accept "
M
Matt Caswell 已提交
200
            .($self->server_port)
M
Matt Caswell 已提交
201 202
            ." -cert ".$self->cert." -cert2 ".$self->cert
            ." -naccept ".$self->serverconnects;
203 204 205
        unless ($self->supports_IPv6) {
            $execcmd .= " -4";
        }
M
Matt Caswell 已提交
206 207 208
        if ($self->ciphers ne "") {
            $execcmd .= " -cipher ".$self->ciphers;
        }
209 210 211
        if ($self->ciphersuitess ne "") {
            $execcmd .= " -ciphersuites ".$self->ciphersuitess;
        }
M
Matt Caswell 已提交
212 213 214
        if ($self->serverflags ne "") {
            $execcmd .= " ".$self->serverflags;
        }
215 216 217
        if ($self->debug) {
            print STDERR "Server command: $execcmd\n";
        }
M
Matt Caswell 已提交
218
        exec($execcmd);
M
Matt Caswell 已提交
219
    }
M
Matt Caswell 已提交
220
    $self->serverpid($pid);
M
Matt Caswell 已提交
221

222
    return $self->clientstart;
M
Matt Caswell 已提交
223 224 225 226 227
}

sub clientstart
{
    my ($self) = shift;
M
Matt Caswell 已提交
228 229 230 231 232
    my $oldstdout;

    if ($self->execute) {
        my $pid = fork();
        if ($pid == 0) {
M
Matt Caswell 已提交
233 234 235 236 237 238 239
            my $echostr;
            if ($self->reneg()) {
                $echostr = "R";
            } else {
                $echostr = "test";
            }
            my $execcmd = "echo ".$echostr." | ".$self->execute
240
                 ." s_client -max_protocol TLSv1.3 -engine ossltest -connect "
M
Matt Caswell 已提交
241
                 .($self->proxy_addr).":".($self->proxy_port);
242 243 244
            unless ($self->supports_IPv6) {
                $execcmd .= " -4";
            }
M
Matt Caswell 已提交
245 246 247
            if ($self->cipherc ne "") {
                $execcmd .= " -cipher ".$self->cipherc;
            }
248 249 250
            if ($self->ciphersuitesc ne "") {
                $execcmd .= " -ciphersuites ".$self->ciphersuitesc;
            }
M
Matt Caswell 已提交
251 252 253
            if ($self->clientflags ne "") {
                $execcmd .= " ".$self->clientflags;
            }
254 255 256
            if (defined $self->sessionfile) {
                $execcmd .= " -ign_eof";
            }
257 258 259
            if ($self->debug) {
                print STDERR "Client command: $execcmd\n";
            }
M
Matt Caswell 已提交
260
            exec($execcmd);
M
Matt Caswell 已提交
261
        }
M
Matt Caswell 已提交
262
        $self->clientpid($pid);
M
Matt Caswell 已提交
263 264 265
    }

    # Wait for incoming connection from client
266
    my $client_sock;
267
    if(!($client_sock = $self->{proxy_sock}->accept())) {
268 269 270
        warn "Failed accepting incoming connection: $!\n";
        return 0;
    }
M
Matt Caswell 已提交
271 272 273 274

    print "Connection opened\n";

    # Now connect to the server
M
Matt Caswell 已提交
275
    my $retry = 50;
M
Matt Caswell 已提交
276 277 278 279
    my $server_sock;
    #We loop over this a few times because sometimes s_server can take a while
    #to start up
    do {
280 281
        my $servaddr = $self->server_addr;
        $servaddr =~ s/[\[\]]//g; # Remove [ and ]
282 283 284 285 286 287 288 289
        eval {
            $server_sock = $IP_factory->(
                PeerAddr => $servaddr,
                PeerPort => $self->server_port,
                MultiHomed => 1,
                Proto => 'tcp'
            );
        };
M
Matt Caswell 已提交
290 291

        $retry--;
M
Matt Caswell 已提交
292 293 294
        #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)) {
295 296
            $server_sock->close() if defined($server_sock);
            undef $server_sock;
M
Matt Caswell 已提交
297 298 299 300
            if ($retry) {
                #Sleep for a short while
                select(undef, undef, undef, 0.1);
            } else {
301 302
                warn "Failed to start up server (".$servaddr.",".$self->server_port."): $!\n";
                return 0;
M
Matt Caswell 已提交
303 304 305 306 307 308 309 310 311 312
            }
        }
    } while (!$server_sock);

    my $sel = IO::Select->new($server_sock, $client_sock);
    my $indata;
    my @handles = ($server_sock, $client_sock);

    #Wait for either the server socket or the client socket to become readable
    my @ready;
313
    my $ctr = 0;
314
    local $SIG{PIPE} = "IGNORE";
315 316 317
    while(     (!(TLSProxy::Message->end)
                || (defined $self->sessionfile()
                    && (-s $self->sessionfile()) == 0))
318 319 320 321 322
            && $ctr < 10) {
        if (!(@ready = $sel->can_read(1))) {
            $ctr++;
            next;
        }
M
Matt Caswell 已提交
323 324 325 326 327
        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);
328
                $ctr = 0;
M
Matt Caswell 已提交
329 330 331 332
            } elsif ($hand == $client_sock) {
                $client_sock->sysread($indata, 16384) or goto END;
                $indata = $self->process_packet(0, $indata);
                $server_sock->syswrite($indata);
333
                $ctr = 0;
M
Matt Caswell 已提交
334
            } else {
335
                die "Unexpected handle";
M
Matt Caswell 已提交
336 337 338 339
            }
        }
    }

340
    die "No progress made" if $ctr >= 10;
341

M
Matt Caswell 已提交
342 343 344 345 346 347 348 349 350 351 352 353
    END:
    print "Connection closed\n";
    if($server_sock) {
        $server_sock->close();
    }
    if($client_sock) {
        #Closing this also kills the child process
        $client_sock->close();
    }
    if(!$self->debug) {
        select($oldstdout);
    }
M
Matt Caswell 已提交
354 355 356 357 358 359
    $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);
360
        die "exit code $? from server process\n" if $? != 0;
M
Matt Caswell 已提交
361 362 363
    } else {
        # Give s_server sufficient time to finish what it was doing
        usleep(250000);
M
Matt Caswell 已提交
364
    }
M
Matt Caswell 已提交
365 366 367 368
    die "clientpid is zero\n" if $self->clientpid == 0;
    print "Waiting for client process to close: ".$self->clientpid."\n";
    waitpid($self->clientpid, 0);

369
    return 1;
M
Matt Caswell 已提交
370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385
}

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";
    }

386 387 388 389 390
    if ($self->{direction} != $server) {
        $self->{flight} = $self->{flight} + 1;
        $self->{direction} = $server;
    }

M
Matt Caswell 已提交
391 392 393 394
    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
395 396 397
    #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];
M
Matt Caswell 已提交
398 399 400 401 402
    push @{$self->record_list}, @{$ret[0]};
    push @{$self->{message_list}}, @{$ret[1]};

    print "\n";

403 404 405 406
    if (scalar(@{$ret[0]}) == 0 or length($ret[2]) != 0) {
        return "";
    }

M
Matt Caswell 已提交
407
    #Finished parsing. Call user provided filter here
408
    if (defined $self->filter) {
M
Matt Caswell 已提交
409 410
        $self->filter->($self);
    }
M
Matt Caswell 已提交
411 412 413 414

    #Reconstruct the packet
    $packet = "";
    foreach my $record (@{$self->record_list}) {
415
        $packet .= $record->reconstruct_record($server);
M
Matt Caswell 已提交
416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458
    }

    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};
}
459 460 461 462 463
sub supports_IPv6
{
    my $self = shift;
    return $have_IPv6;
}
M
Matt Caswell 已提交
464 465 466 467 468 469 470 471 472 473
sub proxy_addr
{
    my $self = shift;
    return $self->{proxy_addr};
}
sub proxy_port
{
    my $self = shift;
    return $self->{proxy_port};
}
474 475

#Read/write accessors
M
Matt Caswell 已提交
476 477 478 479
sub server_addr
{
    my $self = shift;
    if (@_) {
M
Matt Caswell 已提交
480
        $self->{server_addr} = shift;
M
Matt Caswell 已提交
481 482 483 484 485 486 487
    }
    return $self->{server_addr};
}
sub server_port
{
    my $self = shift;
    if (@_) {
M
Matt Caswell 已提交
488
        $self->{server_port} = shift;
M
Matt Caswell 已提交
489 490 491 492 493 494 495
    }
    return $self->{server_port};
}
sub filter
{
    my $self = shift;
    if (@_) {
M
Matt Caswell 已提交
496
        $self->{filter} = shift;
M
Matt Caswell 已提交
497 498 499
    }
    return $self->{filter};
}
M
Matt Caswell 已提交
500 501 502 503
sub cipherc
{
    my $self = shift;
    if (@_) {
M
Matt Caswell 已提交
504
        $self->{cipherc} = shift;
M
Matt Caswell 已提交
505 506 507
    }
    return $self->{cipherc};
}
508 509 510 511 512 513 514 515
sub ciphersuitesc
{
    my $self = shift;
    if (@_) {
        $self->{ciphersuitesc} = shift;
    }
    return $self->{ciphersuitesc};
}
M
Matt Caswell 已提交
516 517 518 519
sub ciphers
{
    my $self = shift;
    if (@_) {
M
Matt Caswell 已提交
520
        $self->{ciphers} = shift;
M
Matt Caswell 已提交
521 522 523
    }
    return $self->{ciphers};
}
524 525 526 527 528 529 530 531
sub ciphersuitess
{
    my $self = shift;
    if (@_) {
        $self->{ciphersuitess} = shift;
    }
    return $self->{ciphersuitess};
}
M
Matt Caswell 已提交
532 533 534 535
sub serverflags
{
    my $self = shift;
    if (@_) {
M
Matt Caswell 已提交
536
        $self->{serverflags} = shift;
M
Matt Caswell 已提交
537 538 539 540 541 542 543
    }
    return $self->{serverflags};
}
sub clientflags
{
    my $self = shift;
    if (@_) {
M
Matt Caswell 已提交
544
        $self->{clientflags} = shift;
M
Matt Caswell 已提交
545 546 547 548 549 550 551
    }
    return $self->{clientflags};
}
sub serverconnects
{
    my $self = shift;
    if (@_) {
M
Matt Caswell 已提交
552
        $self->{serverconnects} = shift;
M
Matt Caswell 已提交
553 554 555
    }
    return $self->{serverconnects};
}
556 557 558 559 560 561 562 563 564 565 566 567
# 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};
}
M
Matt Caswell 已提交
568 569 570 571
sub serverpid
{
    my $self = shift;
    if (@_) {
M
Matt Caswell 已提交
572
        $self->{serverpid} = shift;
M
Matt Caswell 已提交
573 574 575
    }
    return $self->{serverpid};
}
M
Matt Caswell 已提交
576 577 578 579 580 581 582 583
sub clientpid
{
    my $self = shift;
    if (@_) {
        $self->{clientpid} = shift;
    }
    return $self->{clientpid};
}
D
David Benjamin 已提交
584 585 586 587 588 589 590 591 592 593

sub fill_known_data
{
    my $length = shift;
    my $ret = "";
    for (my $i = 0; $i < $length; $i++) {
        $ret .= chr($i);
    }
    return $ret;
}
M
Matt Caswell 已提交
594

M
Matt Caswell 已提交
595 596 597 598
sub is_tls13
{
    my $class = shift;
    if (@_) {
M
Matt Caswell 已提交
599
        $is_tls13 = shift;
M
Matt Caswell 已提交
600 601 602
    }
    return $is_tls13;
}
M
Matt Caswell 已提交
603 604 605 606 607

sub reneg
{
    my $self = shift;
    if (@_) {
M
Matt Caswell 已提交
608
        $self->{reneg} = shift;
M
Matt Caswell 已提交
609 610 611 612
    }
    return $self->{reneg};
}

613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628
#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};
}

629 630 631 632 633 634 635 636 637
sub ciphersuite
{
    my $class = shift;
    if (@_) {
        $ciphersuite = shift;
    }
    return $ciphersuite;
}

M
Matt Caswell 已提交
638
1;