util/perl/TLSProxy/Proxy.pm

   1 # Copyright 2016 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 use Time::HiRes qw/usleep/;
  26
  27 my $have_IPv6 = 0;
  28 my $IP_factory;
  29
  30 my $is_tls13 = 0;
  31 my $ciphersuite = undef;
  32
  33 sub new
  34 {
  35     my $class = shift;
  36     my ($filter,
  37         $execute,
  38         $cert,
  39         $debug) = @_;
  40
  41     my $self = {
  42         #Public read/write
  43         proxy_addr => "localhost",
  44         proxy_port => 4453,
  45         server_addr => "localhost",
  46         server_port => 4443,
  47         filter => $filter,
  48         serverflags => "",
  49         clientflags => "",
  50         serverconnects => 1,
  51         serverpid => 0,
  52         clientpid => 0,
  53         reneg => 0,
  54         sessionfile => undef,
  55
  56         #Public read
  57         execute => $execute,
  58         cert => $cert,
  59         debug => $debug,
  60         cipherc => "",
  61         ciphers => "AES128-SHA:TLS13-AES-128-GCM-SHA256",
  62         flight => 0,
  63         record_list => [],
  64         message_list => [],
  65     };
  66
  67     # IO::Socket::IP is on the core module list, IO::Socket::INET6 isn't.
  68     # However, IO::Socket::INET6 is older and is said to be more widely
  69     # deployed for the moment, and may have less bugs, so we try the latter
  70     # first, then fall back on the code modules.  Worst case scenario, we
  71     # fall back to IO::Socket::INET, only supports IPv4.
  72     eval {
  73         require IO::Socket::INET6;
  74         my $s = IO::Socket::INET6->new(
  75             LocalAddr => "::1",
  76             LocalPort => 0,
  77             Listen=>1,
  78             );
  79         $s or die "\n";
  80         $s->close();
  81     };
  82     if ($@ eq "") {
  83         $IP_factory = sub { IO::Socket::INET6->new(@_); };
  84         $have_IPv6 = 1;
  85     } else {
  86         eval {
  87             require IO::Socket::IP;
  88             my $s = IO::Socket::IP->new(
  89                 LocalAddr => "::1",
  90                 LocalPort => 0,
  91                 Listen=>1,
  92                 );
  93             $s or die "\n";
  94             $s->close();
  95         };
  96         if ($@ eq "") {
  97             $IP_factory = sub { IO::Socket::IP->new(@_); };
  98             $have_IPv6 = 1;
  99         } else {
 100             $IP_factory = sub { IO::Socket::INET->new(@_); };
 101         }
 102     }
 103
 104     # Create the Proxy socket
 105     my $proxaddr = $self->{proxy_addr};
 106     $proxaddr =~ s/[\[\]]//g; # Remove [ and ]
 107     my @proxyargs = (
 108         LocalHost   => $proxaddr,
 109         LocalPort   => $self->{proxy_port},
 110         Proto       => "tcp",
 111         Listen      => SOMAXCONN,
 112        );
 113     push @proxyargs, ReuseAddr => 1
 114         unless $^O eq "MSWin32";
 115     $self->{proxy_sock} = $IP_factory->(@proxyargs);
 116
 117     if ($self->{proxy_sock}) {
 118         print "Proxy started on port ".$self->{proxy_port}."\n";
 119     } else {
 120         warn "Failed creating proxy socket (".$proxaddr.",".$self->{proxy_port}."): $!\n";
 121     }
 122
 123     return bless $self, $class;
 124 }
 125
 126 sub DESTROY
 127 {
 128     my $self = shift;
 129
 130     $self->{proxy_sock}->close() if $self->{proxy_sock};
 131 }
 132
 133 sub clearClient
 134 {
 135     my $self = shift;
 136
 137     $self->{cipherc} = "";
 138     $self->{flight} = 0;
 139     $self->{record_list} = [];
 140     $self->{message_list} = [];
 141     $self->{clientflags} = "";
 142     $self->{sessionfile} = undef;
 143     $self->{clientpid} = 0;
 144     $is_tls13 = 0;
 145     $ciphersuite = undef;
 146
 147     TLSProxy::Message->clear();
 148     TLSProxy::Record->clear();
 149 }
 150
 151 sub clear
 152 {
 153     my $self = shift;
 154
 155     $self->clearClient;
 156     $self->{ciphers} = "AES128-SHA:TLS13-AES-128-GCM-SHA256";
 157     $self->{serverflags} = "";
 158     $self->{serverconnects} = 1;
 159     $self->{serverpid} = 0;
 160     $self->{reneg} = 0;
 161 }
 162
 163 sub restart
 164 {
 165     my $self = shift;
 166
 167     $self->clear;
 168     $self->start;
 169 }
 170
 171 sub clientrestart
 172 {
 173     my $self = shift;
 174
 175     $self->clear;
 176     $self->clientstart;
 177 }
 178
 179 sub start
 180 {
 181     my ($self) = shift;
 182     my $pid;
 183
 184     if ($self->{proxy_sock} == 0) {
 185         return 0;
 186     }
 187
 188     $pid = fork();
 189     if ($pid == 0) {
 190         my $execcmd = $self->execute
 191             ." s_server -no_comp -rev -engine ossltest -accept "
 192             .($self->server_port)
 193             ." -cert ".$self->cert." -cert2 ".$self->cert
 194             ." -naccept ".$self->serverconnects;
 195         unless ($self->supports_IPv6) {
 196             $execcmd .= " -4";
 197         }
 198         if ($self->ciphers ne "") {
 199             $execcmd .= " -cipher ".$self->ciphers;
 200         }
 201         if ($self->serverflags ne "") {
 202             $execcmd .= " ".$self->serverflags;
 203         }
 204         if ($self->debug) {
 205             print STDERR "Server command: $execcmd\n";
 206         }
 207         exec($execcmd);
 208     }
 209     $self->serverpid($pid);
 210
 211     return $self->clientstart;
 212 }
 213
 214 sub clientstart
 215 {
 216     my ($self) = shift;
 217     my $oldstdout;
 218
 219     if ($self->execute) {
 220         my $pid = fork();
 221         if ($pid == 0) {
 222             my $echostr;
 223             if ($self->reneg()) {
 224                 $echostr = "R";
 225             } else {
 226                 $echostr = "test";
 227             }
 228             my $execcmd = "echo ".$echostr." | ".$self->execute
 229                  ." s_client -engine ossltest -connect "
 230                  .($self->proxy_addr).":".($self->proxy_port);
 231             unless ($self->supports_IPv6) {
 232                 $execcmd .= " -4";
 233             }
 234             if ($self->cipherc ne "") {
 235                 $execcmd .= " -cipher ".$self->cipherc;
 236             }
 237             if ($self->clientflags ne "") {
 238                 $execcmd .= " ".$self->clientflags;
 239             }
 240             if (defined $self->sessionfile) {
 241                 $execcmd .= " -ign_eof";
 242             }
 243             if ($self->debug) {
 244                 print STDERR "Client command: $execcmd\n";
 245             }
 246             exec($execcmd);
 247         }
 248         $self->clientpid($pid);
 249     }
 250
 251     # Wait for incoming connection from client
 252     my $client_sock;
 253     if(!($client_sock = $self->{proxy_sock}->accept())) {
 254         warn "Failed accepting incoming connection: $!\n";
 255         return 0;
 256     }
 257
 258     print "Connection opened\n";
 259
 260     # Now connect to the server
 261     my $retry = 50;
 262     my $server_sock;
 263     #We loop over this a few times because sometimes s_server can take a while
 264     #to start up
 265     do {
 266         my $servaddr = $self->server_addr;
 267         $servaddr =~ s/[\[\]]//g; # Remove [ and ]
 268         eval {
 269             $server_sock = $IP_factory->(
 270                 PeerAddr => $servaddr,
 271                 PeerPort => $self->server_port,
 272                 MultiHomed => 1,
 273                 Proto => 'tcp'
 274             );
 275         };
 276
 277         $retry--;
 278         #Some buggy IP factories can return a defined server_sock that hasn't
 279         #actually connected, so we check peerport too
 280         if ($@ || !defined($server_sock) || !defined($server_sock->peerport)) {
 281             $server_sock->close() if defined($server_sock);
 282             undef $server_sock;
 283             if ($retry) {
 284                 #Sleep for a short while
 285                 select(undef, undef, undef, 0.1);
 286             } else {
 287                 warn "Failed to start up server (".$servaddr.",".$self->server_port."): $!\n";
 288                 return 0;
 289             }
 290         }
 291     } while (!$server_sock);
 292
 293     my $sel = IO::Select->new($server_sock, $client_sock);
 294     my $indata;
 295     my @handles = ($server_sock, $client_sock);
 296
 297     #Wait for either the server socket or the client socket to become readable
 298     my @ready;
 299     my $ctr = 0;
 300     local $SIG{PIPE} = "IGNORE";
 301     while(     (!(TLSProxy::Message->end)
 302                 || (defined $self->sessionfile()
 303                     && (-s $self->sessionfile()) == 0))
 304             && $ctr < 10) {
 305         if (!(@ready = $sel->can_read(1))) {
 306             $ctr++;
 307             next;
 308         }
 309         foreach my $hand (@ready) {
 310             if ($hand == $server_sock) {
 311                 $server_sock->sysread($indata, 16384) or goto END;
 312                 $indata = $self->process_packet(1, $indata);
 313                 $client_sock->syswrite($indata);
 314                 $ctr = 0;
 315             } elsif ($hand == $client_sock) {
 316                 $client_sock->sysread($indata, 16384) or goto END;
 317                 $indata = $self->process_packet(0, $indata);
 318                 $server_sock->syswrite($indata);
 319                 $ctr = 0;
 320             } else {
 321                 die "Unexpected handle";
 322             }
 323         }
 324     }
 325
 326     die "No progress made" if $ctr >= 10;
 327
 328     END:
 329     print "Connection closed\n";
 330     if($server_sock) {
 331         $server_sock->close();
 332     }
 333     if($client_sock) {
 334         #Closing this also kills the child process
 335         $client_sock->close();
 336     }
 337     if(!$self->debug) {
 338         select($oldstdout);
 339     }
 340     $self->serverconnects($self->serverconnects - 1);
 341     if ($self->serverconnects == 0) {
 342         die "serverpid is zero\n" if $self->serverpid == 0;
 343         print "Waiting for server process to close: "
 344               .$self->serverpid."\n";
 345         waitpid( $self->serverpid, 0);
 346         die "exit code $? from server process\n" if $? != 0;
 347     } else {
 348         # Give s_server sufficient time to finish what it was doing
 349         usleep(250000);
 350     }
 351     die "clientpid is zero\n" if $self->clientpid == 0;
 352     print "Waiting for client process to close: ".$self->clientpid."\n";
 353     waitpid($self->clientpid, 0);
 354
 355     return 1;
 356 }
 357
 358 sub process_packet
 359 {
 360     my ($self, $server, $packet) = @_;
 361     my $len_real;
 362     my $decrypt_len;
 363     my $data;
 364     my $recnum;
 365
 366     if ($server) {
 367         print "Received server packet\n";
 368     } else {
 369         print "Received client packet\n";
 370     }
 371
 372     print "Packet length = ".length($packet)."\n";
 373     print "Processing flight ".$self->flight."\n";
 374
 375     #Return contains the list of record found in the packet followed by the
 376     #list of messages in those records
 377     my @ret = TLSProxy::Record->get_records($server, $self->flight, $packet);
 378     push @{$self->record_list}, @{$ret[0]};
 379     push @{$self->{message_list}}, @{$ret[1]};
 380
 381     print "\n";
 382
 383     #Finished parsing. Call user provided filter here
 384     if(defined $self->filter) {
 385         $self->filter->($self);
 386     }
 387
 388     #Reconstruct the packet
 389     $packet = "";
 390     foreach my $record (@{$self->record_list}) {
 391         #We only replay the records for the current flight
 392         if ($record->flight != $self->flight) {
 393             next;
 394         }
 395         $packet .= $record->reconstruct_record($server);
 396     }
 397
 398     $self->{flight} = $self->{flight} + 1;
 399
 400     print "Forwarded packet length = ".length($packet)."\n\n";
 401
 402     return $packet;
 403 }
 404
 405 #Read accessors
 406 sub execute
 407 {
 408     my $self = shift;
 409     return $self->{execute};
 410 }
 411 sub cert
 412 {
 413     my $self = shift;
 414     return $self->{cert};
 415 }
 416 sub debug
 417 {
 418     my $self = shift;
 419     return $self->{debug};
 420 }
 421 sub flight
 422 {
 423     my $self = shift;
 424     return $self->{flight};
 425 }
 426 sub record_list
 427 {
 428     my $self = shift;
 429     return $self->{record_list};
 430 }
 431 sub success
 432 {
 433     my $self = shift;
 434     return $self->{success};
 435 }
 436 sub end
 437 {
 438     my $self = shift;
 439     return $self->{end};
 440 }
 441 sub supports_IPv6
 442 {
 443     my $self = shift;
 444     return $have_IPv6;
 445 }
 446 sub proxy_addr
 447 {
 448     my $self = shift;
 449     return $self->{proxy_addr};
 450 }
 451 sub proxy_port
 452 {
 453     my $self = shift;
 454     return $self->{proxy_port};
 455 }
 456
 457 #Read/write accessors
 458 sub server_addr
 459 {
 460     my $self = shift;
 461     if (@_) {
 462         $self->{server_addr} = shift;
 463     }
 464     return $self->{server_addr};
 465 }
 466 sub server_port
 467 {
 468     my $self = shift;
 469     if (@_) {
 470         $self->{server_port} = shift;
 471     }
 472     return $self->{server_port};
 473 }
 474 sub filter
 475 {
 476     my $self = shift;
 477     if (@_) {
 478         $self->{filter} = shift;
 479     }
 480     return $self->{filter};
 481 }
 482 sub cipherc
 483 {
 484     my $self = shift;
 485     if (@_) {
 486         $self->{cipherc} = shift;
 487     }
 488     return $self->{cipherc};
 489 }
 490 sub ciphers
 491 {
 492     my $self = shift;
 493     if (@_) {
 494         $self->{ciphers} = shift;
 495     }
 496     return $self->{ciphers};
 497 }
 498 sub serverflags
 499 {
 500     my $self = shift;
 501     if (@_) {
 502         $self->{serverflags} = shift;
 503     }
 504     return $self->{serverflags};
 505 }
 506 sub clientflags
 507 {
 508     my $self = shift;
 509     if (@_) {
 510         $self->{clientflags} = shift;
 511     }
 512     return $self->{clientflags};
 513 }
 514 sub serverconnects
 515 {
 516     my $self = shift;
 517     if (@_) {
 518         $self->{serverconnects} = shift;
 519     }
 520     return $self->{serverconnects};
 521 }
 522 # This is a bit ugly because the caller is responsible for keeping the records
 523 # in sync with the updated message list; simply updating the message list isn't
 524 # sufficient to get the proxy to forward the new message.
 525 # But it does the trick for the one test (test_sslsessiontick) that needs it.
 526 sub message_list
 527 {
 528     my $self = shift;
 529     if (@_) {
 530         $self->{message_list} = shift;
 531     }
 532     return $self->{message_list};
 533 }
 534 sub serverpid
 535 {
 536     my $self = shift;
 537     if (@_) {
 538         $self->{serverpid} = shift;
 539     }
 540     return $self->{serverpid};
 541 }
 542 sub clientpid
 543 {
 544     my $self = shift;
 545     if (@_) {
 546         $self->{clientpid} = shift;
 547     }
 548     return $self->{clientpid};
 549 }
 550
 551 sub fill_known_data
 552 {
 553     my $length = shift;
 554     my $ret = "";
 555     for (my $i = 0; $i < $length; $i++) {
 556         $ret .= chr($i);
 557     }
 558     return $ret;
 559 }
 560
 561 sub is_tls13
 562 {
 563     my $class = shift;
 564     if (@_) {
 565         $is_tls13 = shift;
 566     }
 567     return $is_tls13;
 568 }
 569
 570 sub reneg
 571 {
 572     my $self = shift;
 573     if (@_) {
 574         $self->{reneg} = shift;
 575     }
 576     return $self->{reneg};
 577 }
 578
 579 #Setting a sessionfile means that the client will not close until the given
 580 #file exists. This is useful in TLSv1.3 where otherwise s_client will close
 581 #immediately at the end of the handshake, but before the session has been
 582 #received from the server. A side effect of this is that s_client never sends
 583 #a close_notify, so instead we consider success to be when it sends application
 584 #data over the connection.
 585 sub sessionfile
 586 {
 587     my $self = shift;
 588     if (@_) {
 589         $self->{sessionfile} = shift;
 590         TLSProxy::Message->successondata(1);
 591     }
 592     return $self->{sessionfile};
 593 }
 594
 595 sub ciphersuite
 596 {
 597     my $class = shift;
 598     if (@_) {
 599         $ciphersuite = shift;
 600     }
 601     return $ciphersuite;
 602 }
 603
 604 1;