util/perl/TLSProxy/Proxy.pm

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