xref: /freebsd/crypto/openssl/util/perl/TLSProxy/Proxy.pm (revision e7be843b4a162e68651d3911f0357ed464915629) 
1# Copyright 2016-2025 The OpenSSL Project Authors. All Rights Reserved.
2#
3# Licensed under the Apache License 2.0 (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
8use strict;
9use POSIX ":sys_wait_h";
10
11package TLSProxy::Proxy;
12
13use File::Spec;
14use IO::Socket;
15use IO::Select;
16use TLSProxy::Record;
17use TLSProxy::Message;
18use TLSProxy::ClientHello;
19use TLSProxy::ServerHello;
20use TLSProxy::HelloVerifyRequest;
21use TLSProxy::EncryptedExtensions;
22use TLSProxy::Certificate;
23use TLSProxy::CertificateRequest;
24use TLSProxy::CertificateVerify;
25use TLSProxy::ServerKeyExchange;
26use TLSProxy::NewSessionTicket;
27use TLSProxy::NextProto;
28
29my $have_IPv6;
30my $useINET6;
31my $IP_factory;
32
33BEGIN
34{
35    # IO::Socket::IP is on the core module list, IO::Socket::INET6 isn't.
36    # However, IO::Socket::INET6 is older and is said to be more widely
37    # deployed for the moment, and may have less bugs, so we try the latter
38    # first, then fall back on the core modules.  Worst case scenario, we
39    # fall back to IO::Socket::INET, only supports IPv4.
40    eval {
41        require IO::Socket::INET6;
42        my $s = IO::Socket::INET6->new(
43            LocalAddr => "::1",
44            LocalPort => 0,
45            Listen=>1,
46            );
47        $s or die "\n";
48        $s->close();
49    };
50    if ($@ eq "") {
51        $IP_factory = sub { IO::Socket::INET6->new(Domain => AF_INET6, @_); };
52        $have_IPv6 = 1;
53        $useINET6 = 1;
54    } else {
55        eval {
56            require IO::Socket::IP;
57            my $s = IO::Socket::IP->new(
58                LocalAddr => "::1",
59                LocalPort => 0,
60                Listen=>1,
61                );
62            $s or die "\n";
63            $s->close();
64        };
65        if ($@ eq "") {
66            $IP_factory = sub { IO::Socket::IP->new(@_); };
67            $have_IPv6 = 1;
68            $useINET6 = 0;
69        } else {
70            $IP_factory = sub { IO::Socket::INET->new(@_); };
71            $have_IPv6 = 0;
72            $useINET6 = 0;
73        }
74    }
75}
76
77my $is_tls13 = 0;
78my $ciphersuite = undef;
79
80sub new {
81    my $class = shift;
82    my ($filter,
83        $execute,
84        $cert,
85        $debug) = @_;
86    return init($class, $filter, $execute, $cert, $debug, 0);
87}
88
89sub new_dtls {
90    my $class = shift;
91    my ($filter,
92        $execute,
93        $cert,
94        $debug) = @_;
95    return init($class, $filter, $execute, $cert, $debug, 1);
96}
97
98sub init
99{
100    require IO::Socket::IP;
101    my $class = shift;
102    my ($filter,
103        $execute,
104        $cert,
105        $debug,
106        $isdtls) = @_;
107
108    my $test_client_port;
109
110    # Sometimes, our random selection of client ports gets unlucky
111    # And we randomly select a port thats already in use.  This causes
112    # this test to fail, so lets harden ourselves against that by doing
113    # a test bind to the randomly selected port, and only continue once we
114    # find a port thats available.
115    my $test_client_addr = $have_IPv6 ? "[::1]" : "127.0.0.1";
116    my $found_port = 0;
117    for (my $i = 0; $i <= 10; $i++) {
118        $test_client_port = 49152 + int(rand(65535 - 49152));
119        my $test_sock;
120        if ($useINET6 == 0) {
121            $test_sock = IO::Socket::IP->new(LocalPort => $test_client_port,
122                                             LocalAddr => $test_client_addr);
123        } else {
124            $test_sock = IO::Socket::INET6->new(LocalAddr => $test_client_addr,
125                                                LocalPort => $test_client_port,
126                                                Domain => AF_INET6);
127        }
128        if ($test_sock) {
129            $found_port = 1;
130            $test_sock->close();
131            print "Found available client port ${test_client_port}\n";
132            last;
133        }
134        print "Port ${test_client_port} in use - $@\n";
135    }
136
137    if ($found_port == 0) {
138        die "Unable to find usable port for TLSProxy";
139    }
140
141    my $self = {
142        #Public read/write
143        proxy_addr => $test_client_addr,
144        client_addr => $test_client_addr,
145        filter => $filter,
146        serverflags => "",
147        clientflags => "",
148        serverconnects => 1,
149        reneg => 0,
150        sessionfile => undef,
151
152        #Public read
153        isdtls => $isdtls,
154        proxy_port => 0,
155        client_port => $test_client_port,
156        server_port => 0,
157        serverpid => 0,
158        clientpid => 0,
159        execute => $execute,
160        cert => $cert,
161        debug => $debug,
162        cipherc => "",
163        ciphersuitesc => "",
164        ciphers => "AES128-SHA",
165        ciphersuitess => "TLS_AES_128_GCM_SHA256",
166        flight => -1,
167        direction => -1,
168        partial => ["", ""],
169        record_list => [],
170        message_list => [],
171    };
172
173    return bless $self, $class;
174}
175
176sub DESTROY
177{
178    my $self = shift;
179
180    $self->{proxy_sock}->close() if $self->{proxy_sock};
181}
182
183sub clearClient
184{
185    my $self = shift;
186
187    $self->{cipherc} = "";
188    $self->{ciphersuitec} = "";
189    $self->{flight} = -1;
190    $self->{direction} = -1;
191    $self->{partial} = ["", ""];
192    $self->{record_list} = [];
193    $self->{message_list} = [];
194    $self->{clientflags} = "";
195    $self->{sessionfile} = undef;
196    $self->{clientpid} = 0;
197    $is_tls13 = 0;
198    $ciphersuite = undef;
199
200    TLSProxy::Message->clear();
201    TLSProxy::Record->clear();
202}
203
204sub clear
205{
206    my $self = shift;
207
208    $self->clearClient;
209    $self->{ciphers} = "AES128-SHA";
210    $self->{ciphersuitess} = "TLS_AES_128_GCM_SHA256";
211    $self->{serverflags} = "";
212    $self->{serverconnects} = 1;
213    $self->{serverpid} = 0;
214    $self->{reneg} = 0;
215}
216
217sub restart
218{
219    my $self = shift;
220
221    $self->clear;
222    $self->start;
223}
224
225sub clientrestart
226{
227    my $self = shift;
228
229    $self->clear;
230    $self->clientstart;
231}
232
233sub connect_to_server
234{
235    my $self = shift;
236    my $servaddr = $self->{server_addr};
237
238    $servaddr =~ s/[\[\]]//g; # Remove [ and ]
239
240    my $sock = $IP_factory->(PeerAddr => $servaddr,
241                             PeerPort => $self->{server_port},
242                             Proto => $self->{isdtls} ? 'udp' : 'tcp');
243    if (!defined($sock)) {
244        my $err = $!;
245        kill(3, $self->{real_serverpid});
246        die "unable to connect: $err\n";
247    }
248
249    $self->{server_sock} = $sock;
250}
251
252sub start
253{
254    my ($self) = shift;
255    my $pid;
256
257    # Create the Proxy socket
258    my $proxaddr = $self->{proxy_addr};
259    $proxaddr =~ s/[\[\]]//g; # Remove [ and ]
260    my $clientaddr = $self->{client_addr};
261    $clientaddr =~ s/[\[\]]//g; # Remove [ and ]
262
263    my @proxyargs;
264
265    if ($self->{isdtls}) {
266        @proxyargs = (
267            LocalHost   => $proxaddr,
268            LocalPort   => 0,
269            PeerHost   => $clientaddr,
270            PeerPort   => $self->{client_port},
271            Proto       => "udp",
272        );
273    } else {
274        @proxyargs = (
275            LocalHost   => $proxaddr,
276            LocalPort   => 0,
277            Proto       => "tcp",
278            Listen      => SOMAXCONN,
279        );
280    }
281
282    if (my $sock = $IP_factory->(@proxyargs)) {
283        $self->{proxy_sock} = $sock;
284        $self->{proxy_port} = $sock->sockport();
285        $self->{proxy_addr} = $sock->sockhost();
286        $self->{proxy_addr} =~ s/(.*:.*)/[$1]/;
287        print "Proxy started on port ",
288            "$self->{proxy_addr}:$self->{proxy_port}\n";
289        # use same address for s_server
290        $self->{server_addr} = $self->{proxy_addr};
291    } else {
292        warn "Failed creating proxy socket (".$proxaddr.",0): $!\n";
293    }
294
295    if ($self->{proxy_sock} == 0) {
296        return 0;
297    }
298
299    my $execcmd = $self->execute
300        ." s_server -no_comp -engine ossltest -state"
301        #In TLSv1.3 we issue two session tickets. The default session id
302        #callback gets confused because the ossltest engine causes the same
303        #session id to be created twice due to the changed random number
304        #generation. Using "-ext_cache" replaces the default callback with a
305        #different one that doesn't get confused.
306        ." -ext_cache"
307        ." -accept $self->{server_addr}:0"
308        ." -cert ".$self->cert." -cert2 ".$self->cert
309        ." -naccept ".$self->serverconnects;
310    if ($self->{isdtls}) {
311        $execcmd .= " -dtls -max_protocol DTLSv1.2"
312                    # TLSProxy does not support message fragmentation. So
313                    # set a high mtu and fingers crossed.
314                    ." -mtu 1500";
315    } else {
316        $execcmd .= " -rev -max_protocol TLSv1.3";
317    }
318    if ($self->ciphers ne "") {
319        $execcmd .= " -cipher ".$self->ciphers;
320    }
321    if ($self->ciphersuitess ne "") {
322        $execcmd .= " -ciphersuites ".$self->ciphersuitess;
323    }
324    if ($self->serverflags ne "") {
325        $execcmd .= " ".$self->serverflags;
326    }
327    if ($self->debug) {
328        print STDERR "Server command: $execcmd\n";
329    }
330
331    open(my $savedin, "<&STDIN");
332
333    # Temporarily replace STDIN so that sink process can inherit it...
334    open(STDIN, "$^X -e 'sleep(10)' |") if $self->{isdtls};
335    $pid = open(STDIN, "$execcmd 2>&1 |") or die "Failed to $execcmd: $!\n";
336    $self->{real_serverpid} = $pid;
337
338    # Process the output from s_server until we find the ACCEPT line, which
339    # tells us what the accepting address and port are.
340    while (<>) {
341        print;
342        s/\R$//;                # Better chomp
343        next unless (/^ACCEPT\s.*:(\d+)$/);
344        $self->{server_port} = $1;
345        last;
346    }
347
348    if ($self->{server_port} == 0) {
349        # This actually means that s_server exited, because otherwise
350        # we would still searching for ACCEPT...
351        waitpid($pid, 0);
352        die "no ACCEPT detected in '$execcmd' output: $?\n";
353    }
354
355    # Just make sure everything else is simply printed [as separate lines].
356    # The sub process simply inherits our STD* and will keep consuming
357    # server's output and printing it as long as there is anything there,
358    # out of our way.
359    my $error;
360    $pid = undef;
361    if (eval { require Win32::Process; 1; }) {
362        if (Win32::Process::Create(my $h, $^X, "perl -ne print", 0, 0, ".")) {
363            $pid = $h->GetProcessID();
364            $self->{proc_handle} = $h;  # hold handle till next round [or exit]
365        } else {
366            $error = Win32::FormatMessage(Win32::GetLastError());
367        }
368    } else {
369        if (defined($pid = fork)) {
370            $pid or exec("$^X -ne print") or exit($!);
371        } else {
372            $error = $!;
373        }
374    }
375
376    # Change back to original stdin
377    open(STDIN, "<&", $savedin);
378    close($savedin);
379
380    if (!defined($pid)) {
381        kill(3, $self->{real_serverpid});
382        die "Failed to capture s_server's output: $error\n";
383    }
384
385    $self->{serverpid} = $pid;
386
387    print STDERR "Server responds on ",
388                 "$self->{server_addr}:$self->{server_port}\n";
389
390    # Connect right away...
391    $self->connect_to_server();
392
393    return $self->clientstart;
394}
395
396sub clientstart
397{
398    my ($self) = shift;
399
400    my $success = 1;
401
402    if ($self->execute) {
403        my $pid;
404        my $execcmd = $self->execute
405             ." s_client -engine ossltest"
406             ." -connect $self->{proxy_addr}:$self->{proxy_port}";
407        if ($self->{isdtls}) {
408            $execcmd .= " -dtls -max_protocol DTLSv1.2"
409                        # TLSProxy does not support message fragmentation. So
410                        # set a high mtu and fingers crossed.
411                        ." -mtu 1500"
412                        # UDP has no "accept" for sockets which means we need to
413                        # know were to send data back to.
414                        ." -bind $self->{client_addr}:$self->{client_port}";
415        } else {
416            $execcmd .= " -max_protocol TLSv1.3";
417        }
418        if ($self->cipherc ne "") {
419            $execcmd .= " -cipher ".$self->cipherc;
420        }
421        if ($self->ciphersuitesc ne "") {
422            $execcmd .= " -ciphersuites ".$self->ciphersuitesc;
423        }
424        if ($self->clientflags ne "") {
425            $execcmd .= " ".$self->clientflags;
426        }
427        if ($self->clientflags !~ m/-(no)?servername/) {
428            $execcmd .= " -servername localhost";
429        }
430        if (defined $self->sessionfile) {
431            $execcmd .= " -ign_eof";
432        }
433        if ($self->debug) {
434            print STDERR "Client command: $execcmd\n";
435        }
436
437        open(my $savedout, ">&STDOUT");
438        # If we open pipe with new descriptor, attempt to close it,
439        # explicitly or implicitly, would incur waitpid and effectively
440        # dead-lock...
441        if (!($pid = open(STDOUT, "| $execcmd"))) {
442            my $err = $!;
443            kill(3, $self->{real_serverpid});
444            die "Failed to $execcmd: $err\n";
445        }
446        $self->{clientpid} = $pid;
447
448        # queue [magic] input
449        print $self->reneg ? "R" : "test";
450
451        # this closes client's stdin without waiting for its pid
452        open(STDOUT, ">&", $savedout);
453        close($savedout);
454    }
455
456    # Wait for incoming connection from client
457    my $fdset = IO::Select->new($self->{proxy_sock});
458    if (!$fdset->can_read(60)) {
459        kill(3, $self->{real_serverpid});
460        die "s_client didn't try to connect\n";
461    }
462
463    my $client_sock;
464    if($self->{isdtls}) {
465        $client_sock = $self->{proxy_sock}
466    } elsif (!($client_sock = $self->{proxy_sock}->accept())) {
467        warn "Failed accepting incoming connection: $!\n";
468        return 0;
469    }
470
471    print "Connection opened\n";
472
473    my $server_sock = $self->{server_sock};
474    my $indata;
475
476    #Wait for either the server socket or the client socket to become readable
477    $fdset = IO::Select->new($server_sock, $client_sock);
478    my @ready;
479    my $ctr = 0;
480    local $SIG{PIPE} = "IGNORE";
481    $self->{saw_session_ticket} = undef;
482    while($fdset->count && $ctr < 10) {
483        if (defined($self->{sessionfile})) {
484            # s_client got -ign_eof and won't be exiting voluntarily, so we
485            # look for data *and* session ticket...
486            last if TLSProxy::Message->success()
487                    && $self->{saw_session_ticket};
488        }
489        if (!(@ready = $fdset->can_read(1))) {
490            last if TLSProxy::Message->success()
491                && $self->{saw_session_ticket};
492
493            $ctr++;
494            next;
495        }
496        foreach my $hand (@ready) {
497            if ($hand == $server_sock) {
498                if ($server_sock->sysread($indata, 16384)) {
499                    if ($indata = $self->process_packet(1, $indata)) {
500                        $client_sock->syswrite($indata) or goto END;
501                    }
502                    $ctr = 0;
503                } else {
504                    $fdset->remove($server_sock);
505                    $client_sock->shutdown(SHUT_WR);
506                }
507            } elsif ($hand == $client_sock) {
508                if ($client_sock->sysread($indata, 16384)) {
509                    if ($indata = $self->process_packet(0, $indata)) {
510                        $server_sock->syswrite($indata) or goto END;
511                    }
512                    $ctr = 0;
513                } else {
514                    $fdset->remove($client_sock);
515                    $server_sock->shutdown(SHUT_WR);
516                }
517            } else {
518                kill(3, $self->{real_serverpid});
519                die "Unexpected handle";
520            }
521        }
522    }
523
524    if ($ctr >= 10) {
525        kill(3, $self->{real_serverpid});
526        print "No progress made\n";
527        $success = 0;
528    }
529
530    END:
531    print "Connection closed\n";
532    if($server_sock) {
533        $server_sock->close();
534        $self->{server_sock} = undef;
535    }
536    if($client_sock) {
537        #Closing this also kills the child process
538        $client_sock->close();
539    }
540
541    my $pid;
542    if (--$self->{serverconnects} == 0) {
543        $pid = $self->{serverpid};
544        print "Waiting for 'perl -ne print' process to close: $pid...\n";
545        $pid = waitpid($pid, 0);
546        if ($pid > 0) {
547            die "exit code $? from 'perl -ne print' process\n" if $? != 0;
548        } elsif ($pid == 0) {
549            kill(3, $self->{real_serverpid});
550            die "lost control over $self->{serverpid}?";
551        }
552        $pid = $self->{real_serverpid};
553        print "Waiting for s_server process to close: $pid...\n";
554        # it's done already, just collect the exit code [and reap]...
555        waitpid($pid, 0);
556        die "exit code $? from s_server process\n" if $? != 0;
557    } else {
558        # It's a bit counter-intuitive spot to make next connection to
559        # the s_server. Rationale is that established connection works
560        # as synchronization point, in sense that this way we know that
561        # s_server is actually done with current session...
562        $self->connect_to_server();
563    }
564    $pid = $self->{clientpid};
565    print "Waiting for s_client process to close: $pid...\n";
566    waitpid($pid, 0);
567
568    return $success;
569}
570
571sub process_packet
572{
573    my ($self, $server, $packet) = @_;
574    my $len_real;
575    my $decrypt_len;
576    my $data;
577    my $recnum;
578
579    if ($server) {
580        print "Received server packet\n";
581    } else {
582        print "Received client packet\n";
583    }
584
585    if ($self->{direction} != $server) {
586        $self->{flight} = $self->{flight} + 1;
587        $self->{direction} = $server;
588    }
589
590    print "Packet length = ".length($packet)."\n";
591    print "Processing flight ".$self->flight."\n";
592
593    #Return contains the list of record found in the packet followed by the
594    #list of messages in those records and any partial message
595    my @ret = TLSProxy::Record->get_records($server, $self->flight,
596                                            $self->{partial}[$server].$packet,
597                                            $self->{isdtls});
598
599    $self->{partial}[$server] = $ret[2];
600    push @{$self->{record_list}}, @{$ret[0]};
601    push @{$self->{message_list}}, @{$ret[1]};
602
603    print "\n";
604
605    if (scalar(@{$ret[0]}) == 0 or length($ret[2]) != 0) {
606        return "";
607    }
608
609    #Finished parsing. Call user provided filter here
610    if (defined $self->filter) {
611        $self->filter->($self);
612    }
613
614    #Take a note on NewSessionTicket
615    foreach my $message (reverse @{$self->{message_list}}) {
616        if ($message->{mt} == TLSProxy::Message::MT_NEW_SESSION_TICKET) {
617            $self->{saw_session_ticket} = 1;
618            last;
619        }
620    }
621
622    #Reconstruct the packet
623    $packet = "";
624    foreach my $record (@{$self->record_list}) {
625        $packet .= $record->reconstruct_record($server);
626    }
627
628    print "Forwarded packet length = ".length($packet)."\n\n";
629
630    return $packet;
631}
632
633#Read accessors
634sub execute
635{
636    my $self = shift;
637    return $self->{execute};
638}
639sub cert
640{
641    my $self = shift;
642    return $self->{cert};
643}
644sub debug
645{
646    my $self = shift;
647    return $self->{debug};
648}
649sub flight
650{
651    my $self = shift;
652    return $self->{flight};
653}
654sub record_list
655{
656    my $self = shift;
657    return $self->{record_list};
658}
659sub success
660{
661    my $self = shift;
662    return $self->{success};
663}
664sub end
665{
666    my $self = shift;
667    return $self->{end};
668}
669sub supports_IPv6
670{
671    my $self = shift;
672    return $have_IPv6;
673}
674sub proxy_addr
675{
676    my $self = shift;
677    return $self->{proxy_addr};
678}
679sub proxy_port
680{
681    my $self = shift;
682    return $self->{proxy_port};
683}
684sub server_addr
685{
686    my $self = shift;
687    return $self->{server_addr};
688}
689sub server_port
690{
691    my $self = shift;
692    return $self->{server_port};
693}
694sub serverpid
695{
696    my $self = shift;
697    return $self->{serverpid};
698}
699sub clientpid
700{
701    my $self = shift;
702    return $self->{clientpid};
703}
704
705#Read/write accessors
706sub filter
707{
708    my $self = shift;
709    if (@_) {
710        $self->{filter} = shift;
711    }
712    return $self->{filter};
713}
714sub cipherc
715{
716    my $self = shift;
717    if (@_) {
718        $self->{cipherc} = shift;
719    }
720    return $self->{cipherc};
721}
722sub ciphersuitesc
723{
724    my $self = shift;
725    if (@_) {
726        $self->{ciphersuitesc} = shift;
727    }
728    return $self->{ciphersuitesc};
729}
730sub ciphers
731{
732    my $self = shift;
733    if (@_) {
734        $self->{ciphers} = shift;
735    }
736    return $self->{ciphers};
737}
738sub ciphersuitess
739{
740    my $self = shift;
741    if (@_) {
742        $self->{ciphersuitess} = shift;
743    }
744    return $self->{ciphersuitess};
745}
746sub serverflags
747{
748    my $self = shift;
749    if (@_) {
750        $self->{serverflags} = shift;
751    }
752    return $self->{serverflags};
753}
754sub clientflags
755{
756    my $self = shift;
757    if (@_) {
758        $self->{clientflags} = shift;
759    }
760    return $self->{clientflags};
761}
762sub serverconnects
763{
764    my $self = shift;
765    if (@_) {
766        $self->{serverconnects} = shift;
767    }
768    return $self->{serverconnects};
769}
770# This is a bit ugly because the caller is responsible for keeping the records
771# in sync with the updated message list; simply updating the message list isn't
772# sufficient to get the proxy to forward the new message.
773# But it does the trick for the one test (test_sslsessiontick) that needs it.
774sub message_list
775{
776    my $self = shift;
777    if (@_) {
778        $self->{message_list} = shift;
779    }
780    return $self->{message_list};
781}
782
783sub fill_known_data
784{
785    my $length = shift;
786    my $ret = "";
787    for (my $i = 0; $i < $length; $i++) {
788        $ret .= chr($i);
789    }
790    return $ret;
791}
792
793sub is_tls13
794{
795    my $class = shift;
796    if (@_) {
797        $is_tls13 = shift;
798    }
799    return $is_tls13;
800}
801
802sub reneg
803{
804    my $self = shift;
805    if (@_) {
806        $self->{reneg} = shift;
807    }
808    return $self->{reneg};
809}
810
811#Setting a sessionfile means that the client will not close until the given
812#file exists. This is useful in TLSv1.3 where otherwise s_client will close
813#immediately at the end of the handshake, but before the session has been
814#received from the server. A side effect of this is that s_client never sends
815#a close_notify, so instead we consider success to be when it sends application
816#data over the connection.
817sub sessionfile
818{
819    my $self = shift;
820    if (@_) {
821        $self->{sessionfile} = shift;
822        TLSProxy::Message->successondata(1);
823    }
824    return $self->{sessionfile};
825}
826
827sub ciphersuite
828{
829    my $class = shift;
830    if (@_) {
831        $ciphersuite = shift;
832    }
833    return $ciphersuite;
834}
835
836sub isdtls
837{
838    my $self = shift;
839    return $self->{isdtls}; #read-only
840}
841
8421;
843