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($fdset->count
 360             && (!(TLSProxy::Message->end)
 361                 || (defined $self->sessionfile()
 362                     && (-s $self->sessionfile()) == 0))
 363             && $ctr < 10) {
 364         if (!(@ready = $fdset->can_read(1))) {
 365             $ctr++;
 366             next;
 367         }
 368         foreach my $hand (@ready) {
 369             if ($hand == $server_sock) {
 370                 if ($server_sock->sysread($indata, 16384)) {
 371                     if ($indata = $self->process_packet(1, $indata)) {
 372                         $client_sock->syswrite($indata) or goto END;
 373                     }
 374                     $ctr = 0;
 375                 } else {
 376                     $fdset->remove($server_sock);
 377                     $client_sock->shutdown(SHUT_WR);
 378                 }
 379             } elsif ($hand == $client_sock) {
 380                 if ($client_sock->sysread($indata, 16384)) {
 381                     if ($indata = $self->process_packet(0, $indata)) {
 382                         $server_sock->syswrite($indata) or goto END;
 383                     }
 384                     $ctr = 0;
 385                 } else {
 386                     $fdset->remove($client_sock);
 387                     $server_sock->shutdown(SHUT_WR);
 388                 }
 389             } else {
 390                 kill(3, $self->{real_serverpid});
 391                 die "Unexpected handle";
 392             }
 393         }
 394     }
 395
 396     if ($ctr >= 10) {
 397         kill(3, $self->{real_serverpid});
 398         die "No progress made";
 399     }
 400
 401     END:
 402     print "Connection closed\n";
 403     if($server_sock) {
 404         $server_sock->close();
 405         $self->{server_sock} = undef;
 406     }
 407     if($client_sock) {
 408         #Closing this also kills the child process
 409         $client_sock->close();
 410     }
 411
 412     my $pid;
 413     if (--$self->{serverconnects} == 0) {
 414         $pid = $self->{serverpid};
 415         die "serverpid is zero\n" if $pid == 0;
 416         print "Waiting for server process to close: $pid...\n";
 417         # recall that we wait on process that buffers server's output
 418         waitpid($pid, 0);
 419         die "exit code $? from server process\n" if $? != 0;
 420     } else {
 421         # It's a bit counter-intuitive spot to make next connection to
 422         # the s_server. Rationale is that established connection works
 423         # as syncronization point, in sense that this way we know that
 424         # s_server is actually done with current session...
 425         $self->connect_to_server();
 426     }
 427     $pid = $self->{clientpid};
 428     die "clientpid is zero\n" if $pid == 0;
 429     print "Waiting for client process to close: $pid...\n";
 430     waitpid($pid, 0);
 431
 432     return 1;
 433 }
 434
 435 sub process_packet
 436 {
 437     my ($self, $server, $packet) = @_;
 438     my $len_real;
 439     my $decrypt_len;
 440     my $data;
 441     my $recnum;
 442
 443     if ($server) {
 444         print "Received server packet\n";
 445     } else {
 446         print "Received client packet\n";
 447     }
 448
 449     if ($self->{direction} != $server) {
 450         $self->{flight} = $self->{flight} + 1;
 451         $self->{direction} = $server;
 452     }
 453
 454     print "Packet length = ".length($packet)."\n";
 455     print "Processing flight ".$self->flight."\n";
 456
 457     #Return contains the list of record found in the packet followed by the
 458     #list of messages in those records and any partial message
 459     my @ret = TLSProxy::Record->get_records($server, $self->flight,
 460                                             $self->{partial}[$server].$packet);
 461     $self->{partial}[$server] = $ret[2];
 462     push @{$self->{record_list}}, @{$ret[0]};
 463     push @{$self->{message_list}}, @{$ret[1]};
 464
 465     print "\n";
 466
 467     if (scalar(@{$ret[0]}) == 0) {
 468         return "";
 469     }
 470
 471     #Finished parsing. Call user provided filter here
 472     if (defined $self->filter) {
 473         $self->filter->($self);
 474     }
 475
 476     #Reconstruct the packet
 477     $packet = "";
 478     foreach my $record (@{$self->record_list}) {
 479         $packet .= $record->reconstruct_record($server);
 480     }
 481
 482     print "Forwarded packet length = ".length($packet)."\n\n";
 483
 484     return $packet;
 485 }
 486
 487 #Read accessors
 488 sub execute
 489 {
 490     my $self = shift;
 491     return $self->{execute};
 492 }
 493 sub cert
 494 {
 495     my $self = shift;
 496     return $self->{cert};
 497 }
 498 sub debug
 499 {
 500     my $self = shift;
 501     return $self->{debug};
 502 }
 503 sub flight
 504 {
 505     my $self = shift;
 506     return $self->{flight};
 507 }
 508 sub record_list
 509 {
 510     my $self = shift;
 511     return $self->{record_list};
 512 }
 513 sub success
 514 {
 515     my $self = shift;
 516     return $self->{success};
 517 }
 518 sub end
 519 {
 520     my $self = shift;
 521     return $self->{end};
 522 }
 523 sub supports_IPv6
 524 {
 525     my $self = shift;
 526     return $have_IPv6;
 527 }
 528 sub proxy_addr
 529 {
 530     my $self = shift;
 531     return $self->{proxy_addr};
 532 }
 533 sub proxy_port
 534 {
 535     my $self = shift;
 536     return $self->{proxy_port};
 537 }
 538 sub server_addr
 539 {
 540     my $self = shift;
 541     return $self->{server_addr};
 542 }
 543 sub server_port
 544 {
 545     my $self = shift;
 546     return $self->{server_port};
 547 }
 548 sub serverpid
 549 {
 550     my $self = shift;
 551     return $self->{serverpid};
 552 }
 553 sub clientpid
 554 {
 555     my $self = shift;
 556     return $self->{clientpid};
 557 }
 558
 559 #Read/write accessors
 560 sub filter
 561 {
 562     my $self = shift;
 563     if (@_) {
 564         $self->{filter} = shift;
 565     }
 566     return $self->{filter};
 567 }
 568 sub cipherc
 569 {
 570     my $self = shift;
 571     if (@_) {
 572         $self->{cipherc} = shift;
 573     }
 574     return $self->{cipherc};
 575 }
 576 sub ciphersuitesc
 577 {
 578     my $self = shift;
 579     if (@_) {
 580         $self->{ciphersuitesc} = shift;
 581     }
 582     return $self->{ciphersuitesc};
 583 }
 584 sub ciphers
 585 {
 586     my $self = shift;
 587     if (@_) {
 588         $self->{ciphers} = shift;
 589     }
 590     return $self->{ciphers};
 591 }
 592 sub ciphersuitess
 593 {
 594     my $self = shift;
 595     if (@_) {
 596         $self->{ciphersuitess} = shift;
 597     }
 598     return $self->{ciphersuitess};
 599 }
 600 sub serverflags
 601 {
 602     my $self = shift;
 603     if (@_) {
 604         $self->{serverflags} = shift;
 605     }
 606     return $self->{serverflags};
 607 }
 608 sub clientflags
 609 {
 610     my $self = shift;
 611     if (@_) {
 612         $self->{clientflags} = shift;
 613     }
 614     return $self->{clientflags};
 615 }
 616 sub serverconnects
 617 {
 618     my $self = shift;
 619     if (@_) {
 620         $self->{serverconnects} = shift;
 621     }
 622     return $self->{serverconnects};
 623 }
 624 # This is a bit ugly because the caller is responsible for keeping the records
 625 # in sync with the updated message list; simply updating the message list isn't
 626 # sufficient to get the proxy to forward the new message.
 627 # But it does the trick for the one test (test_sslsessiontick) that needs it.
 628 sub message_list
 629 {
 630     my $self = shift;
 631     if (@_) {
 632         $self->{message_list} = shift;
 633     }
 634     return $self->{message_list};
 635 }
 636
 637 sub fill_known_data
 638 {
 639     my $length = shift;
 640     my $ret = "";
 641     for (my $i = 0; $i < $length; $i++) {
 642         $ret .= chr($i);
 643     }
 644     return $ret;
 645 }
 646
 647 sub is_tls13
 648 {
 649     my $class = shift;
 650     if (@_) {
 651         $is_tls13 = shift;
 652     }
 653     return $is_tls13;
 654 }
 655
 656 sub reneg
 657 {
 658     my $self = shift;
 659     if (@_) {
 660         $self->{reneg} = shift;
 661     }
 662     return $self->{reneg};
 663 }
 664
 665 #Setting a sessionfile means that the client will not close until the given
 666 #file exists. This is useful in TLSv1.3 where otherwise s_client will close
 667 #immediately at the end of the handshake, but before the session has been
 668 #received from the server. A side effect of this is that s_client never sends
 669 #a close_notify, so instead we consider success to be when it sends application
 670 #data over the connection.
 671 sub sessionfile
 672 {
 673     my $self = shift;
 674     if (@_) {
 675         $self->{sessionfile} = shift;
 676         TLSProxy::Message->successondata(1);
 677     }
 678     return $self->{sessionfile};
 679 }
 680
 681 sub ciphersuite
 682 {
 683     my $class = shift;
 684     if (@_) {
 685         $ciphersuite = shift;
 686     }
 687     return $ciphersuite;
 688 }
 689
 690 1;