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