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