f3e76bf35c457ef6cbc3691c3b69220cb7ef6cdc
[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::HelloRetryRequest;
20 use TLSProxy::ServerHello;
21 use TLSProxy::EncryptedExtensions;
22 use TLSProxy::Certificate;
23 use TLSProxy::CertificateVerify;
24 use TLSProxy::ServerKeyExchange;
25 use TLSProxy::NewSessionTicket;
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     }
347     die "clientpid is zero\n" if $self->clientpid == 0;
348     print "Waiting for client process to close: ".$self->clientpid."\n";
349     waitpid($self->clientpid, 0);
350
351     return 1;
352 }
353
354 sub process_packet
355 {
356     my ($self, $server, $packet) = @_;
357     my $len_real;
358     my $decrypt_len;
359     my $data;
360     my $recnum;
361
362     if ($server) {
363         print "Received server packet\n";
364     } else {
365         print "Received client packet\n";
366     }
367
368     print "Packet length = ".length($packet)."\n";
369     print "Processing flight ".$self->flight."\n";
370
371     #Return contains the list of record found in the packet followed by the
372     #list of messages in those records
373     my @ret = TLSProxy::Record->get_records($server, $self->flight, $packet);
374     push @{$self->record_list}, @{$ret[0]};
375     push @{$self->{message_list}}, @{$ret[1]};
376
377     print "\n";
378
379     #Finished parsing. Call user provided filter here
380     if(defined $self->filter) {
381         $self->filter->($self);
382     }
383
384     #Reconstruct the packet
385     $packet = "";
386     foreach my $record (@{$self->record_list}) {
387         #We only replay the records for the current flight
388         if ($record->flight != $self->flight) {
389             next;
390         }
391         $packet .= $record->reconstruct_record($server);
392     }
393
394     $self->{flight} = $self->{flight} + 1;
395
396     print "Forwarded packet length = ".length($packet)."\n\n";
397
398     return $packet;
399 }
400
401 #Read accessors
402 sub execute
403 {
404     my $self = shift;
405     return $self->{execute};
406 }
407 sub cert
408 {
409     my $self = shift;
410     return $self->{cert};
411 }
412 sub debug
413 {
414     my $self = shift;
415     return $self->{debug};
416 }
417 sub flight
418 {
419     my $self = shift;
420     return $self->{flight};
421 }
422 sub record_list
423 {
424     my $self = shift;
425     return $self->{record_list};
426 }
427 sub success
428 {
429     my $self = shift;
430     return $self->{success};
431 }
432 sub end
433 {
434     my $self = shift;
435     return $self->{end};
436 }
437 sub supports_IPv6
438 {
439     my $self = shift;
440     return $have_IPv6;
441 }
442
443 #Read/write accessors
444 sub proxy_addr
445 {
446     my $self = shift;
447     if (@_) {
448         $self->{proxy_addr} = shift;
449     }
450     return $self->{proxy_addr};
451 }
452 sub proxy_port
453 {
454     my $self = shift;
455     if (@_) {
456         $self->{proxy_port} = shift;
457     }
458     return $self->{proxy_port};
459 }
460 sub server_addr
461 {
462     my $self = shift;
463     if (@_) {
464         $self->{server_addr} = shift;
465     }
466     return $self->{server_addr};
467 }
468 sub server_port
469 {
470     my $self = shift;
471     if (@_) {
472         $self->{server_port} = shift;
473     }
474     return $self->{server_port};
475 }
476 sub filter
477 {
478     my $self = shift;
479     if (@_) {
480         $self->{filter} = shift;
481     }
482     return $self->{filter};
483 }
484 sub cipherc
485 {
486     my $self = shift;
487     if (@_) {
488         $self->{cipherc} = shift;
489     }
490     return $self->{cipherc};
491 }
492 sub ciphers
493 {
494     my $self = shift;
495     if (@_) {
496         $self->{ciphers} = shift;
497     }
498     return $self->{ciphers};
499 }
500 sub serverflags
501 {
502     my $self = shift;
503     if (@_) {
504         $self->{serverflags} = shift;
505     }
506     return $self->{serverflags};
507 }
508 sub clientflags
509 {
510     my $self = shift;
511     if (@_) {
512         $self->{clientflags} = shift;
513     }
514     return $self->{clientflags};
515 }
516 sub serverconnects
517 {
518     my $self = shift;
519     if (@_) {
520         $self->{serverconnects} = shift;
521     }
522     return $self->{serverconnects};
523 }
524 # This is a bit ugly because the caller is responsible for keeping the records
525 # in sync with the updated message list; simply updating the message list isn't
526 # sufficient to get the proxy to forward the new message.
527 # But it does the trick for the one test (test_sslsessiontick) that needs it.
528 sub message_list
529 {
530     my $self = shift;
531     if (@_) {
532         $self->{message_list} = shift;
533     }
534     return $self->{message_list};
535 }
536 sub serverpid
537 {
538     my $self = shift;
539     if (@_) {
540         $self->{serverpid} = shift;
541     }
542     return $self->{serverpid};
543 }
544 sub clientpid
545 {
546     my $self = shift;
547     if (@_) {
548         $self->{clientpid} = shift;
549     }
550     return $self->{clientpid};
551 }
552
553 sub fill_known_data
554 {
555     my $length = shift;
556     my $ret = "";
557     for (my $i = 0; $i < $length; $i++) {
558         $ret .= chr($i);
559     }
560     return $ret;
561 }
562
563 sub is_tls13
564 {
565     my $class = shift;
566     if (@_) {
567         $is_tls13 = shift;
568     }
569     return $is_tls13;
570 }
571
572 sub reneg
573 {
574     my $self = shift;
575     if (@_) {
576         $self->{reneg} = shift;
577     }
578     return $self->{reneg};
579 }
580
581 #Setting a sessionfile means that the client will not close until the given
582 #file exists. This is useful in TLSv1.3 where otherwise s_client will close
583 #immediately at the end of the handshake, but before the session has been
584 #received from the server. A side effect of this is that s_client never sends
585 #a close_notify, so instead we consider success to be when it sends application
586 #data over the connection.
587 sub sessionfile
588 {
589     my $self = shift;
590     if (@_) {
591         $self->{sessionfile} = shift;
592         TLSProxy::Message->successondata(1);
593     }
594     return $self->{sessionfile};
595 }
596
597 sub ciphersuite
598 {
599     my $class = shift;
600     if (@_) {
601         $ciphersuite = shift;
602     }
603     return $ciphersuite;
604 }
605
606 1;