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