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; 28 29my $have_IPv6; 30my $IP_factory; 31 32BEGIN 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 73my $is_tls13 = 0; 74my $ciphersuite = undef; 75 76sub 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 85sub 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 94sub 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 138sub DESTROY 139{ 140 my $self = shift; 141 142 $self->{proxy_sock}->close() if $self->{proxy_sock}; 143} 144 145sub 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 166sub 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 179sub restart 180{ 181 my $self = shift; 182 183 $self->clear; 184 $self->start; 185} 186 187sub clientrestart 188{ 189 my $self = shift; 190 191 $self->clear; 192 $self->clientstart; 193} 194 195sub 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 214sub 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 322sub clientstart 323{ 324 my ($self) = shift; 325 326 my $success = 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 $success = 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 $success; 486} 487 488sub 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 551sub execute 552{ 553 my $self = shift; 554 return $self->{execute}; 555} 556sub cert 557{ 558 my $self = shift; 559 return $self->{cert}; 560} 561sub debug 562{ 563 my $self = shift; 564 return $self->{debug}; 565} 566sub flight 567{ 568 my $self = shift; 569 return $self->{flight}; 570} 571sub record_list 572{ 573 my $self = shift; 574 return $self->{record_list}; 575} 576sub success 577{ 578 my $self = shift; 579 return $self->{success}; 580} 581sub end 582{ 583 my $self = shift; 584 return $self->{end}; 585} 586sub supports_IPv6 587{ 588 my $self = shift; 589 return $have_IPv6; 590} 591sub proxy_addr 592{ 593 my $self = shift; 594 return $self->{proxy_addr}; 595} 596sub proxy_port 597{ 598 my $self = shift; 599 return $self->{proxy_port}; 600} 601sub server_addr 602{ 603 my $self = shift; 604 return $self->{server_addr}; 605} 606sub server_port 607{ 608 my $self = shift; 609 return $self->{server_port}; 610} 611sub serverpid 612{ 613 my $self = shift; 614 return $self->{serverpid}; 615} 616sub clientpid 617{ 618 my $self = shift; 619 return $self->{clientpid}; 620} 621 622#Read/write accessors 623sub filter 624{ 625 my $self = shift; 626 if (@_) { 627 $self->{filter} = shift; 628 } 629 return $self->{filter}; 630} 631sub cipherc 632{ 633 my $self = shift; 634 if (@_) { 635 $self->{cipherc} = shift; 636 } 637 return $self->{cipherc}; 638} 639sub ciphersuitesc 640{ 641 my $self = shift; 642 if (@_) { 643 $self->{ciphersuitesc} = shift; 644 } 645 return $self->{ciphersuitesc}; 646} 647sub ciphers 648{ 649 my $self = shift; 650 if (@_) { 651 $self->{ciphers} = shift; 652 } 653 return $self->{ciphers}; 654} 655sub ciphersuitess 656{ 657 my $self = shift; 658 if (@_) { 659 $self->{ciphersuitess} = shift; 660 } 661 return $self->{ciphersuitess}; 662} 663sub serverflags 664{ 665 my $self = shift; 666 if (@_) { 667 $self->{serverflags} = shift; 668 } 669 return $self->{serverflags}; 670} 671sub clientflags 672{ 673 my $self = shift; 674 if (@_) { 675 $self->{clientflags} = shift; 676 } 677 return $self->{clientflags}; 678} 679sub 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. 691sub message_list 692{ 693 my $self = shift; 694 if (@_) { 695 $self->{message_list} = shift; 696 } 697 return $self->{message_list}; 698} 699 700sub 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 710sub is_tls13 711{ 712 my $class = shift; 713 if (@_) { 714 $is_tls13 = shift; 715 } 716 return $is_tls13; 717} 718 719sub 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. 734sub sessionfile 735{ 736 my $self = shift; 737 if (@_) { 738 $self->{sessionfile} = shift; 739 TLSProxy::Message->successondata(1); 740 } 741 return $self->{sessionfile}; 742} 743 744sub ciphersuite 745{ 746 my $class = shift; 747 if (@_) { 748 $ciphersuite = shift; 749 } 750 return $ciphersuite; 751} 752 753sub isdtls 754{ 755 my $self = shift; 756 return $self->{isdtls}; #read-only 757} 758 7591; 760