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