util/perl/TLSProxy/Proxy.pm

   1 # Copyright 2016-2018 The OpenSSL Project Authors. All Rights Reserved.
   2 #
   3 # Licensed under the OpenSSL license (the "License").  You may not use
   4 # this file except in compliance with the License.  You can obtain a copy
   5 # in the file LICENSE in the source distribution or at
   6 # https://www.openssl.org/source/license.html
   7
   8 use strict;
   9 use POSIX ":sys_wait_h";
  10
  11 package TLSProxy::Proxy;
  12
  13 use File::Spec;
  14 use IO::Socket;
  15 use IO::Select;
  16 use TLSProxy::Record;
  17 use TLSProxy::Message;
  18 use TLSProxy::ClientHello;
  19 use TLSProxy::ServerHello;
  20 use TLSProxy::EncryptedExtensions;
  21 use TLSProxy::Certificate;
  22 use TLSProxy::CertificateVerify;
  23 use TLSProxy::ServerKeyExchange;
  24 use TLSProxy::NewSessionTicket;
  25
  26 my $have_IPv6;
  27 my $IP_factory;
  28
  29 BEGIN
  30 {
  31     # IO::Socket::IP is on the core module list, IO::Socket::INET6 isn't.
  32     # However, IO::Socket::INET6 is older and is said to be more widely
  33     # deployed for the moment, and may have less bugs, so we try the latter
  34     # first, then fall back on the core modules.  Worst case scenario, we
  35     # fall back to IO::Socket::INET, only supports IPv4.
  36     eval {
  37         require IO::Socket::INET6;
  38         my $s = IO::Socket::INET6->new(
  39             LocalAddr => "::1",
  40             LocalPort => 0,
  41             Listen=>1,
  42             );
  43         $s or die "\n";
  44         $s->close();
  45     };
  46     if ($@ eq "") {
  47         $IP_factory = sub { IO::Socket::INET6->new(@_); };
  48         $have_IPv6 = 1;
  49     } else {
  50         eval {
  51             require IO::Socket::IP;
  52             my $s = IO::Socket::IP->new(
  53                 LocalAddr => "::1",
  54                 LocalPort => 0,
  55                 Listen=>1,
  56                 );
  57             $s or die "\n";
  58             $s->close();
  59         };
  60         if ($@ eq "") {
  61             $IP_factory = sub { IO::Socket::IP->new(@_); };
  62             $have_IPv6 = 1;
  63         } else {
  64             $IP_factory = sub { IO::Socket::INET->new(@_); };
  65             $have_IPv6 = 0;
  66         }
  67     }
  68 }
  69
  70 my $is_tls13 = 0;
  71 my $ciphersuite = undef;
  72
  73 sub new
  74 {
  75     my $class = shift;
  76     my ($filter,
  77         $execute,
  78         $cert,
  79         $debug) = @_;
  80
  81     my $self = {
  82         #Public read/write
  83         proxy_addr => $have_IPv6 ? "[::1]" : "127.0.0.1",
  84         filter => $filter,
  85         serverflags => "",
  86         clientflags => "",
  87         serverconnects => 1,
  88         reneg => 0,
  89         sessionfile => undef,
  90
  91         #Public read
  92         proxy_port => 0,
  93         server_port => 0,
  94         serverpid => 0,
  95         clientpid => 0,
  96         execute => $execute,
  97         cert => $cert,
  98         debug => $debug,
  99         cipherc => "",
 100         ciphersuitesc => "",
 101         ciphers => "AES128-SHA",
 102         ciphersuitess => "TLS_AES_128_GCM_SHA256",
 103         flight => -1,
 104         direction => -1,
 105         partial => ["", ""],
 106         record_list => [],
 107         message_list => [],
 108     };
 109
 110     # Create the Proxy socket
 111     my $proxaddr = $self->{proxy_addr};
 112     $proxaddr =~ s/[\[\]]//g; # Remove [ and ]
 113     my @proxyargs = (
 114         LocalHost   => $proxaddr,
 115         LocalPort   => 0,
 116         Proto       => "tcp",
 117         Listen      => SOMAXCONN,
 118        );
 119
 120     if (my $sock = $IP_factory->(@proxyargs)) {
 121         $self->{proxy_sock} = $sock;
 122         $self->{proxy_port} = $sock->sockport();
 123         $self->{proxy_addr} = $sock->sockhost();
 124         $self->{proxy_addr} =~ s/(.*:.*)/[$1]/;
 125         print "Proxy started on port ",
 126               "$self->{proxy_addr}:$self->{proxy_port}\n";
 127         # use same address for s_server
 128         $self->{server_addr} = $self->{proxy_addr};
 129     } else {
 130         warn "Failed creating proxy socket (".$proxaddr.",0): $!\n";
 131     }
 132
 133     return bless $self, $class;
 134 }
 135
 136 sub DESTROY
 137 {
 138     my $self = shift;
 139
 140     $self->{proxy_sock}->close() if $self->{proxy_sock};
 141 }
 142
 143 sub clearClient
 144 {
 145     my $self = shift;
 146
 147     $self->{cipherc} = "";
 148     $self->{ciphersuitec} = "";
 149     $self->{flight} = -1;
 150     $self->{direction} = -1;
 151     $self->{partial} = ["", ""];
 152     $self->{record_list} = [];
 153     $self->{message_list} = [];
 154     $self->{clientflags} = "";
 155     $self->{sessionfile} = undef;
 156     $self->{clientpid} = 0;
 157     $is_tls13 = 0;
 158     $ciphersuite = undef;
 159
 160     TLSProxy::Message->clear();
 161     TLSProxy::Record->clear();
 162 }
 163
 164 sub clear
 165 {
 166     my $self = shift;
 167
 168     $self->clearClient;
 169     $self->{ciphers} = "AES128-SHA";
 170     $self->{ciphersuitess} = "TLS_AES_128_GCM_SHA256";
 171     $self->{serverflags} = "";
 172     $self->{serverconnects} = 1;
 173     $self->{serverpid} = 0;
 174     $self->{reneg} = 0;
 175 }
 176
 177 sub restart
 178 {
 179     my $self = shift;
 180
 181     $self->clear;
 182     $self->start;
 183 }
 184
 185 sub clientrestart
 186 {
 187     my $self = shift;
 188
 189     $self->clear;
 190     $self->clientstart;
 191 }
 192
 193 sub connect_to_server
 194 {
 195     my $self = shift;
 196     my $servaddr = $self->{server_addr};
 197
 198     $servaddr =~ s/[\[\]]//g; # Remove [ and ]
 199
 200     my $sock = $IP_factory->(PeerAddr => $servaddr,
 201                              PeerPort => $self->{server_port},
 202                              Proto => 'tcp');
 203     if (!defined($sock)) {
 204         my $err = $!;
 205         kill(3, $self->{real_serverpid});
 206         die "unable to connect: $err\n";
 207     }
 208
 209     $self->{server_sock} = $sock;
 210 }
 211
 212 sub start
 213 {
 214     my ($self) = shift;
 215     my $pid;
 216
 217     if ($self->{proxy_sock} == 0) {
 218         return 0;
 219     }
 220
 221     my $execcmd = $self->execute
 222         ." s_server -max_protocol TLSv1.3 -no_comp -rev -engine ossltest"
 223         ." -accept $self->{server_addr}:0"
 224         ." -cert ".$self->cert." -cert2 ".$self->cert
 225         ." -naccept ".$self->serverconnects;
 226     if ($self->ciphers ne "") {
 227         $execcmd .= " -cipher ".$self->ciphers;
 228     }
 229     if ($self->ciphersuitess ne "") {
 230         $execcmd .= " -ciphersuites ".$self->ciphersuitess;
 231     }
 232     if ($self->serverflags ne "") {
 233         $execcmd .= " ".$self->serverflags;
 234     }
 235     if ($self->debug) {
 236         print STDERR "Server command: $execcmd\n";
 237     }
 238
 239     open(my $savedin, "<&STDIN");
 240
 241     # Temporarily replace STDIN so that sink process can inherit it...
 242     $pid = open(STDIN, "$execcmd 2>&1 |") or die "Failed to $execcmd: $!\n";
 243     $self->{real_serverpid} = $pid;
 244
 245     # Process the output from s_server until we find the ACCEPT line, which
 246     # tells us what the accepting address and port are.
 247     while (<>) {
 248         print;
 249         s/\R$//;                # Better chomp
 250         next unless (/^ACCEPT\s.*:(\d+)$/);
 251         $self->{server_port} = $1;
 252         last;
 253     }
 254
 255     if ($self->{server_port} == 0) {
 256         # This actually means that s_server exited, because otherwise
 257         # we would still searching for ACCEPT...
 258         waitpid($pid, 0);
 259         die "no ACCEPT detected in '$execcmd' output: $?\n";
 260     }
 261
 262     # Just make sure everything else is simply printed [as separate lines].
 263     # The sub process simply inherits our STD* and will keep consuming
 264     # server's output and printing it as long as there is anything there,
 265     # out of our way.
 266     my $error;
 267     $pid = undef;
 268     if (eval { require Win32::Process; 1; }) {
 269         if (Win32::Process::Create(my $h, $^X, "perl -ne print", 0, 0, ".")) {
 270             $pid = $h->GetProcessID();
 271             $self->{proc_handle} = $h;  # hold handle till next round [or exit]
 272         } else {
 273             $error = Win32::FormatMessage(Win32::GetLastError());
 274         }
 275     } else {
 276         if (defined($pid = fork)) {
 277             $pid or exec("$^X -ne print") or exit($!);
 278         } else {
 279             $error = $!;
 280         }
 281     }
 282
 283     # Change back to original stdin
 284     open(STDIN, "<&", $savedin);
 285     close($savedin);
 286
 287     if (!defined($pid)) {
 288         kill(3, $self->{real_serverpid});
 289         die "Failed to capture s_server's output: $error\n";
 290     }
 291
 292     $self->{serverpid} = $pid;
 293
 294     print STDERR "Server responds on ",
 295                  "$self->{server_addr}:$self->{server_port}\n";
 296
 297     # Connect right away...
 298     $self->connect_to_server();
 299
 300     return $self->clientstart;
 301 }
 302
 303 sub clientstart
 304 {
 305     my ($self) = shift;
 306
 307     if ($self->execute) {
 308         my $pid;
 309         my $execcmd = $self->execute
 310              ." s_client -max_protocol TLSv1.3 -engine ossltest"
 311              ." -connect $self->{proxy_addr}:$self->{proxy_port}";
 312         if ($self->cipherc ne "") {
 313             $execcmd .= " -cipher ".$self->cipherc;
 314         }
 315         if ($self->ciphersuitesc ne "") {
 316             $execcmd .= " -ciphersuites ".$self->ciphersuitesc;
 317         }
 318         if ($self->clientflags ne "") {
 319             $execcmd .= " ".$self->clientflags;
 320         }
 321         if ($self->clientflags !~ m/-(no)?servername/) {
 322             $execcmd .= " -servername localhost";
 323         }
 324         if (defined $self->sessionfile) {
 325             $execcmd .= " -ign_eof";
 326         }
 327         if ($self->debug) {
 328             print STDERR "Client command: $execcmd\n";
 329         }
 330
 331         open(my $savedout, ">&STDOUT");
 332         # If we open pipe with new descriptor, attempt to close it,
 333         # explicitly or implicitly, would incur waitpid and effectively
 334         # dead-lock...
 335         if (!($pid = open(STDOUT, "| $execcmd"))) {
 336             my $err = $!;
 337             kill(3, $self->{real_serverpid});
 338             die "Failed to $execcmd: $err\n";
 339         }
 340         $self->{clientpid} = $pid;
 341
 342         # queue [magic] input
 343         print $self->reneg ? "R" : "test";
 344
 345         # this closes client's stdin without waiting for its pid
 346         open(STDOUT, ">&", $savedout);
 347         close($savedout);
 348     }
 349
 350     # Wait for incoming connection from client
 351     my $fdset = IO::Select->new($self->{proxy_sock});
 352     if (!$fdset->can_read(60)) {
 353         kill(3, $self->{real_serverpid});
 354         die "s_client didn't try to connect\n";
 355     }
 356
 357     my $client_sock;
 358     if(!($client_sock = $self->{proxy_sock}->accept())) {
 359         warn "Failed accepting incoming connection: $!\n";
 360         return 0;
 361     }
 362
 363     print "Connection opened\n";
 364
 365     my $server_sock = $self->{server_sock};
 366     my $indata;
 367
 368     #Wait for either the server socket or the client socket to become readable
 369     $fdset = IO::Select->new($server_sock, $client_sock);
 370     my @ready;
 371     my $ctr = 0;
 372     local $SIG{PIPE} = "IGNORE";
 373     $self->{saw_session_ticket} = undef;
 374     while($fdset->count && $ctr < 10) {
 375         if (defined($self->{sessionfile})) {
 376             # s_client got -ign_eof and won't be exiting voluntarily, so we
 377             # look for data *and* session ticket...
 378             last if TLSProxy::Message->success()
 379                     && $self->{saw_session_ticket};
 380         }
 381         if (!(@ready = $fdset->can_read(1))) {
 382             $ctr++;
 383             next;
 384         }
 385         foreach my $hand (@ready) {
 386             if ($hand == $server_sock) {
 387                 if ($server_sock->sysread($indata, 16384)) {
 388                     if ($indata = $self->process_packet(1, $indata)) {
 389                         $client_sock->syswrite($indata) or goto END;
 390                     }
 391                     $ctr = 0;
 392                 } else {
 393                     $fdset->remove($server_sock);
 394                     $client_sock->shutdown(SHUT_WR);
 395                 }
 396             } elsif ($hand == $client_sock) {
 397                 if ($client_sock->sysread($indata, 16384)) {
 398                     if ($indata = $self->process_packet(0, $indata)) {
 399                         $server_sock->syswrite($indata) or goto END;
 400                     }
 401                     $ctr = 0;
 402                 } else {
 403                     $fdset->remove($client_sock);
 404                     $server_sock->shutdown(SHUT_WR);
 405                 }
 406             } else {
 407                 kill(3, $self->{real_serverpid});
 408                 die "Unexpected handle";
 409             }
 410         }
 411     }
 412
 413     if ($ctr >= 10) {
 414         kill(3, $self->{real_serverpid});
 415         die "No progress made";
 416     }
 417
 418     END:
 419     print "Connection closed\n";
 420     if($server_sock) {
 421         $server_sock->close();
 422         $self->{server_sock} = undef;
 423     }
 424     if($client_sock) {
 425         #Closing this also kills the child process
 426         $client_sock->close();
 427     }
 428
 429     my $pid;
 430     if (--$self->{serverconnects} == 0) {
 431         $pid = $self->{serverpid};
 432         print "Waiting for 'perl -ne print' process to close: $pid...\n";
 433         $pid = waitpid($pid, 0);
 434         if ($pid > 0) {
 435             die "exit code $? from 'perl -ne print' process\n" if $? != 0;
 436         } elsif ($pid == 0) {
 437             kill(3, $self->{real_serverpid});
 438             die "lost control over $self->{serverpid}?";
 439         }
 440         $pid = $self->{real_serverpid};
 441         print "Waiting for s_server process to close: $pid...\n";
 442         # it's done already, just collect the exit code [and reap]...
 443         waitpid($pid, 0);
 444         die "exit code $? from s_server process\n" if $? != 0;
 445     } else {
 446         # It's a bit counter-intuitive spot to make next connection to
 447         # the s_server. Rationale is that established connection works
 448         # as syncronization point, in sense that this way we know that
 449         # s_server is actually done with current session...
 450         $self->connect_to_server();
 451     }
 452     $pid = $self->{clientpid};
 453     print "Waiting for s_client process to close: $pid...\n";
 454     waitpid($pid, 0);
 455
 456     return 1;
 457 }
 458
 459 sub process_packet
 460 {
 461     my ($self, $server, $packet) = @_;
 462     my $len_real;
 463     my $decrypt_len;
 464     my $data;
 465     my $recnum;
 466
 467     if ($server) {
 468         print "Received server packet\n";
 469     } else {
 470         print "Received client packet\n";
 471     }
 472
 473     if ($self->{direction} != $server) {
 474         $self->{flight} = $self->{flight} + 1;
 475         $self->{direction} = $server;
 476     }
 477
 478     print "Packet length = ".length($packet)."\n";
 479     print "Processing flight ".$self->flight."\n";
 480
 481     #Return contains the list of record found in the packet followed by the
 482     #list of messages in those records and any partial message
 483     my @ret = TLSProxy::Record->get_records($server, $self->flight,
 484                                             $self->{partial}[$server].$packet);
 485     $self->{partial}[$server] = $ret[2];
 486     push @{$self->{record_list}}, @{$ret[0]};
 487     push @{$self->{message_list}}, @{$ret[1]};
 488
 489     print "\n";
 490
 491     if (scalar(@{$ret[0]}) == 0 or length($ret[2]) != 0) {
 492         return "";
 493     }
 494
 495     #Finished parsing. Call user provided filter here
 496     if (defined $self->filter) {
 497         $self->filter->($self);
 498     }
 499
 500     #Take a note on NewSessionTicket
 501     foreach my $message (reverse @{$self->{message_list}}) {
 502         if ($message->{mt} == TLSProxy::Message::MT_NEW_SESSION_TICKET) {
 503             $self->{saw_session_ticket} = 1;
 504             last;
 505         }
 506     }
 507
 508     #Reconstruct the packet
 509     $packet = "";
 510     foreach my $record (@{$self->record_list}) {
 511         $packet .= $record->reconstruct_record($server);
 512     }
 513
 514     print "Forwarded packet length = ".length($packet)."\n\n";
 515
 516     return $packet;
 517 }
 518
 519 #Read accessors
 520 sub execute
 521 {
 522     my $self = shift;
 523     return $self->{execute};
 524 }
 525 sub cert
 526 {
 527     my $self = shift;
 528     return $self->{cert};
 529 }
 530 sub debug
 531 {
 532     my $self = shift;
 533     return $self->{debug};
 534 }
 535 sub flight
 536 {
 537     my $self = shift;
 538     return $self->{flight};
 539 }
 540 sub record_list
 541 {
 542     my $self = shift;
 543     return $self->{record_list};
 544 }
 545 sub success
 546 {
 547     my $self = shift;
 548     return $self->{success};
 549 }
 550 sub end
 551 {
 552     my $self = shift;
 553     return $self->{end};
 554 }
 555 sub supports_IPv6
 556 {
 557     my $self = shift;
 558     return $have_IPv6;
 559 }
 560 sub proxy_addr
 561 {
 562     my $self = shift;
 563     return $self->{proxy_addr};
 564 }
 565 sub proxy_port
 566 {
 567     my $self = shift;
 568     return $self->{proxy_port};
 569 }
 570 sub server_addr
 571 {
 572     my $self = shift;
 573     return $self->{server_addr};
 574 }
 575 sub server_port
 576 {
 577     my $self = shift;
 578     return $self->{server_port};
 579 }
 580 sub serverpid
 581 {
 582     my $self = shift;
 583     return $self->{serverpid};
 584 }
 585 sub clientpid
 586 {
 587     my $self = shift;
 588     return $self->{clientpid};
 589 }
 590
 591 #Read/write accessors
 592 sub filter
 593 {
 594     my $self = shift;
 595     if (@_) {
 596         $self->{filter} = shift;
 597     }
 598     return $self->{filter};
 599 }
 600 sub cipherc
 601 {
 602     my $self = shift;
 603     if (@_) {
 604         $self->{cipherc} = shift;
 605     }
 606     return $self->{cipherc};
 607 }
 608 sub ciphersuitesc
 609 {
 610     my $self = shift;
 611     if (@_) {
 612         $self->{ciphersuitesc} = shift;
 613     }
 614     return $self->{ciphersuitesc};
 615 }
 616 sub ciphers
 617 {
 618     my $self = shift;
 619     if (@_) {
 620         $self->{ciphers} = shift;
 621     }
 622     return $self->{ciphers};
 623 }
 624 sub ciphersuitess
 625 {
 626     my $self = shift;
 627     if (@_) {
 628         $self->{ciphersuitess} = shift;
 629     }
 630     return $self->{ciphersuitess};
 631 }
 632 sub serverflags
 633 {
 634     my $self = shift;
 635     if (@_) {
 636         $self->{serverflags} = shift;
 637     }
 638     return $self->{serverflags};
 639 }
 640 sub clientflags
 641 {
 642     my $self = shift;
 643     if (@_) {
 644         $self->{clientflags} = shift;
 645     }
 646     return $self->{clientflags};
 647 }
 648 sub serverconnects
 649 {
 650     my $self = shift;
 651     if (@_) {
 652         $self->{serverconnects} = shift;
 653     }
 654     return $self->{serverconnects};
 655 }
 656 # This is a bit ugly because the caller is responsible for keeping the records
 657 # in sync with the updated message list; simply updating the message list isn't
 658 # sufficient to get the proxy to forward the new message.
 659 # But it does the trick for the one test (test_sslsessiontick) that needs it.
 660 sub message_list
 661 {
 662     my $self = shift;
 663     if (@_) {
 664         $self->{message_list} = shift;
 665     }
 666     return $self->{message_list};
 667 }
 668
 669 sub fill_known_data
 670 {
 671     my $length = shift;
 672     my $ret = "";
 673     for (my $i = 0; $i < $length; $i++) {
 674         $ret .= chr($i);
 675     }
 676     return $ret;
 677 }
 678
 679 sub is_tls13
 680 {
 681     my $class = shift;
 682     if (@_) {
 683         $is_tls13 = shift;
 684     }
 685     return $is_tls13;
 686 }
 687
 688 sub reneg
 689 {
 690     my $self = shift;
 691     if (@_) {
 692         $self->{reneg} = shift;
 693     }
 694     return $self->{reneg};
 695 }
 696
 697 #Setting a sessionfile means that the client will not close until the given
 698 #file exists. This is useful in TLSv1.3 where otherwise s_client will close
 699 #immediately at the end of the handshake, but before the session has been
 700 #received from the server. A side effect of this is that s_client never sends
 701 #a close_notify, so instead we consider success to be when it sends application
 702 #data over the connection.
 703 sub sessionfile
 704 {
 705     my $self = shift;
 706     if (@_) {
 707         $self->{sessionfile} = shift;
 708         TLSProxy::Message->successondata(1);
 709     }
 710     return $self->{sessionfile};
 711 }
 712
 713 sub ciphersuite
 714 {
 715     my $class = shift;
 716     if (@_) {
 717         $ciphersuite = shift;
 718     }
 719     return $ciphersuite;
 720 }
 721
 722 1;