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