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     $self->{server_sock} = $IP_factory->(PeerAddr => $servaddr,
 193                                          PeerPort => $self->{server_port},
 194                                          Proto => 'tcp')
 195                            or die "unable to connect: $!\n";
 196 }
 197
 198 sub start
 199 {
 200     my ($self) = shift;
 201     my $pid;
 202
 203     if ($self->{proxy_sock} == 0) {
 204         return 0;
 205     }
 206
 207     my $execcmd = $self->execute
 208         ." s_server -max_protocol TLSv1.3 -no_comp -rev -engine ossltest"
 209         ." -accept 0 -cert ".$self->cert." -cert2 ".$self->cert
 210         ." -naccept ".$self->serverconnects;
 211     unless ($self->supports_IPv6) {
 212         $execcmd .= " -4";
 213     }
 214     if ($self->ciphers ne "") {
 215         $execcmd .= " -cipher ".$self->ciphers;
 216     }
 217     if ($self->ciphersuitess ne "") {
 218         $execcmd .= " -ciphersuites ".$self->ciphersuitess;
 219     }
 220     if ($self->serverflags ne "") {
 221         $execcmd .= " ".$self->serverflags;
 222     }
 223     if ($self->debug) {
 224         print STDERR "Server command: $execcmd\n";
 225     }
 226
 227     open(my $savedin, "<&STDIN");
 228
 229     # Temporarily replace STDIN so that sink process can inherit it...
 230     $pid = open(STDIN, "$execcmd |") or die "Failed to $execcmd: $!\n";
 231     $self->{real_serverpid} = $pid;
 232
 233     # Process the output from s_server until we find the ACCEPT line, which
 234     # tells us what the accepting address and port are.
 235     while (<>) {
 236         print;
 237         s/\R$//;                # Better chomp
 238         next unless (/^ACCEPT\s.*:(\d+)$/);
 239         $self->{server_port} = $1;
 240         last;
 241     }
 242
 243     if ($self->{server_port} == 0) {
 244         # This actually means that s_server exited, because otherwise
 245         # we would still searching for ACCEPT...
 246         die "no ACCEPT detected in '$execcmd' output\n";
 247     }
 248
 249     # Just make sure everything else is simply printed [as separate lines].
 250     # The sub process simply inherits our STD* and will keep consuming
 251     # server's output and printing it as long as there is anything there,
 252     # out of our way.
 253     my $error;
 254     $pid = undef;
 255     if (eval { require Win32::Process; 1; }) {
 256         if (Win32::Process::Create(my $h, $^X, "perl -ne print", 0, 0, ".")) {
 257             $pid = $h->GetProcessID();
 258         } else {
 259             $error = Win32::FormatMessage(Win32::GetLastError());
 260         }
 261     } else {
 262         if (defined($pid = fork)) {
 263             $pid or exec("$^X -ne print") or exit($!);
 264         } else {
 265             $error = $!;
 266         }
 267     }
 268
 269     # Change back to original stdin
 270     open(STDIN, "<&", $savedin);
 271     close($savedin);
 272
 273     if (!defined($pid)) {
 274         kill(3, $self->{real_serverpid});
 275         die "Failed to capture s_server's output: $error\n";
 276     }
 277
 278     $self->{serverpid} = $pid;
 279
 280     print STDERR "Server responds on ",
 281         $self->{server_addr}, ":", $self->{server_port}, "\n";
 282
 283     # Connect right away...
 284     $self->connect_to_server();
 285
 286     return $self->clientstart;
 287 }
 288
 289 sub clientstart
 290 {
 291     my ($self) = shift;
 292
 293     if ($self->execute) {
 294         my $pid;
 295         my $execcmd = $self->execute
 296              ." s_client -max_protocol TLSv1.3 -engine ossltest -connect "
 297              .($self->proxy_addr).":".($self->proxy_port);
 298         unless ($self->supports_IPv6) {
 299             $execcmd .= " -4";
 300         }
 301         if ($self->cipherc ne "") {
 302             $execcmd .= " -cipher ".$self->cipherc;
 303         }
 304         if ($self->ciphersuitesc ne "") {
 305             $execcmd .= " -ciphersuites ".$self->ciphersuitesc;
 306         }
 307         if ($self->clientflags ne "") {
 308             $execcmd .= " ".$self->clientflags;
 309         }
 310         if (defined $self->sessionfile) {
 311             $execcmd .= " -ign_eof";
 312         }
 313         if ($self->debug) {
 314             print STDERR "Client command: $execcmd\n";
 315         }
 316
 317         open(my $savedout, ">&STDOUT");
 318         # If we open pipe with new descriptor, attempt to close it,
 319         # explicitly or implicitly, would incur waitpid and effectively
 320         # dead-lock...
 321         if (!($pid = open(STDOUT, "| $execcmd"))) {
 322             my $err = $!;
 323             kill(3, $self->{real_serverpid});
 324             die "Failed to $execcmd: $err\n";
 325         }
 326         $self->{clientpid} = $pid;
 327
 328         # queue [magic] input
 329         print $self->reneg ? "R" : "test";
 330
 331         # this closes client's stdin without waiting for its pid
 332         open(STDOUT, ">&", $savedout);
 333         close($savedout);
 334     }
 335
 336     # Wait for incoming connection from client
 337     my $fdset = IO::Select->new($self->{proxy_sock});
 338     if (!$fdset->can_read(1)) {
 339         kill(3, $self->{real_serverpid});
 340         die "s_client didn't try to connect\n";
 341     }
 342
 343     my $client_sock;
 344     if(!($client_sock = $self->{proxy_sock}->accept())) {
 345         warn "Failed accepting incoming connection: $!\n";
 346         return 0;
 347     }
 348
 349     print "Connection opened\n";
 350
 351     my $server_sock = $self->{server_sock};
 352     my $indata;
 353
 354     #Wait for either the server socket or the client socket to become readable
 355     $fdset = IO::Select->new($server_sock, $client_sock);
 356     my @ready;
 357     my $ctr = 0;
 358     local $SIG{PIPE} = "IGNORE";
 359     while(     (!(TLSProxy::Message->end)
 360                 || (defined $self->sessionfile()
 361                     && (-s $self->sessionfile()) == 0))
 362             && $ctr < 10) {
 363         if (!(@ready = $fdset->can_read(1))) {
 364             $ctr++;
 365             next;
 366         }
 367         foreach my $hand (@ready) {
 368             if ($hand == $server_sock) {
 369                 $server_sock->sysread($indata, 16384) or goto END;
 370                 $indata = $self->process_packet(1, $indata);
 371                 $client_sock->syswrite($indata);
 372                 $ctr = 0;
 373             } elsif ($hand == $client_sock) {
 374                 $client_sock->sysread($indata, 16384) or goto END;
 375                 $indata = $self->process_packet(0, $indata);
 376                 $server_sock->syswrite($indata);
 377                 $ctr = 0;
 378             } else {
 379                 kill(3, $self->{real_serverpid});
 380                 die "Unexpected handle";
 381             }
 382         }
 383     }
 384
 385     if ($ctr >= 10) {
 386         kill(3, $self->{real_serverpid});
 387         die "No progress made";
 388     }
 389
 390     END:
 391     print "Connection closed\n";
 392     if($server_sock) {
 393         $server_sock->close();
 394         $self->{server_sock} = undef;
 395     }
 396     if($client_sock) {
 397         #Closing this also kills the child process
 398         $client_sock->close();
 399     }
 400
 401     my $pid;
 402     if (--$self->{serverconnects} == 0) {
 403         $pid = $self->{serverpid};
 404         die "serverpid is zero\n" if $pid == 0;
 405         print "Waiting for server process to close: $pid...\n";
 406         # recall that we wait on process that buffers server's output
 407         waitpid($pid, 0);
 408         die "exit code $? from server process\n" if $? != 0;
 409     } else {
 410         # It's a bit counter-intuitive spot to make next connection to
 411         # the s_server. Rationale is that established connection works
 412         # as syncronization point, in sense that this way we know that
 413         # s_server is actually done with current session...
 414         $self->connect_to_server();
 415     }
 416     $pid = $self->{clientpid};
 417     die "clientpid is zero\n" if $pid == 0;
 418     print "Waiting for client process to close: $pid...\n";
 419     waitpid($pid, 0);
 420
 421     return 1;
 422 }
 423
 424 sub process_packet
 425 {
 426     my ($self, $server, $packet) = @_;
 427     my $len_real;
 428     my $decrypt_len;
 429     my $data;
 430     my $recnum;
 431
 432     if ($server) {
 433         print "Received server packet\n";
 434     } else {
 435         print "Received client packet\n";
 436     }
 437
 438     if ($self->{direction} != $server) {
 439         $self->{flight} = $self->{flight} + 1;
 440         $self->{direction} = $server;
 441     }
 442
 443     print "Packet length = ".length($packet)."\n";
 444     print "Processing flight ".$self->flight."\n";
 445
 446     #Return contains the list of record found in the packet followed by the
 447     #list of messages in those records and any partial message
 448     my @ret = TLSProxy::Record->get_records($server, $self->flight, $self->{partial}[$server].$packet);
 449     $self->{partial}[$server] = $ret[2];
 450     push @{$self->{record_list}}, @{$ret[0]};
 451     push @{$self->{message_list}}, @{$ret[1]};
 452
 453     print "\n";
 454
 455     if (scalar(@{$ret[0]}) == 0 or length($ret[2]) != 0) {
 456         return "";
 457     }
 458
 459     #Finished parsing. Call user provided filter here
 460     if (defined $self->filter) {
 461         $self->filter->($self);
 462     }
 463
 464     #Reconstruct the packet
 465     $packet = "";
 466     foreach my $record (@{$self->record_list}) {
 467         $packet .= $record->reconstruct_record($server);
 468     }
 469
 470     print "Forwarded packet length = ".length($packet)."\n\n";
 471
 472     return $packet;
 473 }
 474
 475 #Read accessors
 476 sub execute
 477 {
 478     my $self = shift;
 479     return $self->{execute};
 480 }
 481 sub cert
 482 {
 483     my $self = shift;
 484     return $self->{cert};
 485 }
 486 sub debug
 487 {
 488     my $self = shift;
 489     return $self->{debug};
 490 }
 491 sub flight
 492 {
 493     my $self = shift;
 494     return $self->{flight};
 495 }
 496 sub record_list
 497 {
 498     my $self = shift;
 499     return $self->{record_list};
 500 }
 501 sub success
 502 {
 503     my $self = shift;
 504     return $self->{success};
 505 }
 506 sub end
 507 {
 508     my $self = shift;
 509     return $self->{end};
 510 }
 511 sub supports_IPv6
 512 {
 513     my $self = shift;
 514     return $have_IPv6;
 515 }
 516 sub proxy_addr
 517 {
 518     my $self = shift;
 519     return $self->{proxy_addr};
 520 }
 521 sub proxy_port
 522 {
 523     my $self = shift;
 524     return $self->{proxy_port};
 525 }
 526 sub server_addr
 527 {
 528     my $self = shift;
 529     return $self->{server_addr};
 530 }
 531 sub server_port
 532 {
 533     my $self = shift;
 534     return $self->{server_port};
 535 }
 536 sub serverpid
 537 {
 538     my $self = shift;
 539     return $self->{serverpid};
 540 }
 541 sub clientpid
 542 {
 543     my $self = shift;
 544     return $self->{clientpid};
 545 }
 546
 547 #Read/write accessors
 548 sub filter
 549 {
 550     my $self = shift;
 551     if (@_) {
 552         $self->{filter} = shift;
 553     }
 554     return $self->{filter};
 555 }
 556 sub cipherc
 557 {
 558     my $self = shift;
 559     if (@_) {
 560         $self->{cipherc} = shift;
 561     }
 562     return $self->{cipherc};
 563 }
 564 sub ciphersuitesc
 565 {
 566     my $self = shift;
 567     if (@_) {
 568         $self->{ciphersuitesc} = shift;
 569     }
 570     return $self->{ciphersuitesc};
 571 }
 572 sub ciphers
 573 {
 574     my $self = shift;
 575     if (@_) {
 576         $self->{ciphers} = shift;
 577     }
 578     return $self->{ciphers};
 579 }
 580 sub ciphersuitess
 581 {
 582     my $self = shift;
 583     if (@_) {
 584         $self->{ciphersuitess} = shift;
 585     }
 586     return $self->{ciphersuitess};
 587 }
 588 sub serverflags
 589 {
 590     my $self = shift;
 591     if (@_) {
 592         $self->{serverflags} = shift;
 593     }
 594     return $self->{serverflags};
 595 }
 596 sub clientflags
 597 {
 598     my $self = shift;
 599     if (@_) {
 600         $self->{clientflags} = shift;
 601     }
 602     return $self->{clientflags};
 603 }
 604 sub serverconnects
 605 {
 606     my $self = shift;
 607     if (@_) {
 608         $self->{serverconnects} = shift;
 609     }
 610     return $self->{serverconnects};
 611 }
 612 # This is a bit ugly because the caller is responsible for keeping the records
 613 # in sync with the updated message list; simply updating the message list isn't
 614 # sufficient to get the proxy to forward the new message.
 615 # But it does the trick for the one test (test_sslsessiontick) that needs it.
 616 sub message_list
 617 {
 618     my $self = shift;
 619     if (@_) {
 620         $self->{message_list} = shift;
 621     }
 622     return $self->{message_list};
 623 }
 624
 625 sub fill_known_data
 626 {
 627     my $length = shift;
 628     my $ret = "";
 629     for (my $i = 0; $i < $length; $i++) {
 630         $ret .= chr($i);
 631     }
 632     return $ret;
 633 }
 634
 635 sub is_tls13
 636 {
 637     my $class = shift;
 638     if (@_) {
 639         $is_tls13 = shift;
 640     }
 641     return $is_tls13;
 642 }
 643
 644 sub reneg
 645 {
 646     my $self = shift;
 647     if (@_) {
 648         $self->{reneg} = shift;
 649     }
 650     return $self->{reneg};
 651 }
 652
 653 #Setting a sessionfile means that the client will not close until the given
 654 #file exists. This is useful in TLSv1.3 where otherwise s_client will close
 655 #immediately at the end of the handshake, but before the session has been
 656 #received from the server. A side effect of this is that s_client never sends
 657 #a close_notify, so instead we consider success to be when it sends application
 658 #data over the connection.
 659 sub sessionfile
 660 {
 661     my $self = shift;
 662     if (@_) {
 663         $self->{sessionfile} = shift;
 664         TLSProxy::Message->successondata(1);
 665     }
 666     return $self->{sessionfile};
 667 }
 668
 669 sub ciphersuite
 670 {
 671     my $class = shift;
 672     if (@_) {
 673         $ciphersuite = shift;
 674     }
 675     return $ciphersuite;
 676 }
 677
 678 1;