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