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