From aa4d426b4d3527d7e166df1a05058c9a4a0f6683 Mon Sep 17 00:00:00 2001 From: Wojtek Kosior Date: Fri, 30 Apr 2021 00:33:56 +0200 Subject: initial/final commit --- openssl-1.1.0h/util/perl/OpenSSL/Glob.pm | 21 + openssl-1.1.0h/util/perl/OpenSSL/Test.pm | 1051 ++++++++++++++++++++ openssl-1.1.0h/util/perl/OpenSSL/Test/Simple.pm | 91 ++ openssl-1.1.0h/util/perl/OpenSSL/Test/Utils.pm | 240 +++++ openssl-1.1.0h/util/perl/OpenSSL/Util/Pod.pm | 158 +++ openssl-1.1.0h/util/perl/TLSProxy/ClientHello.pm | 242 +++++ openssl-1.1.0h/util/perl/TLSProxy/Message.pm | 456 +++++++++ .../util/perl/TLSProxy/NewSessionTicket.pm | 81 ++ openssl-1.1.0h/util/perl/TLSProxy/Proxy.pm | 553 ++++++++++ openssl-1.1.0h/util/perl/TLSProxy/Record.pm | 339 +++++++ openssl-1.1.0h/util/perl/TLSProxy/ServerHello.pm | 210 ++++ .../util/perl/TLSProxy/ServerKeyExchange.pm | 134 +++ openssl-1.1.0h/util/perl/with_fallback.pm | 25 + 13 files changed, 3601 insertions(+) create mode 100644 openssl-1.1.0h/util/perl/OpenSSL/Glob.pm create mode 100644 openssl-1.1.0h/util/perl/OpenSSL/Test.pm create mode 100644 openssl-1.1.0h/util/perl/OpenSSL/Test/Simple.pm create mode 100644 openssl-1.1.0h/util/perl/OpenSSL/Test/Utils.pm create mode 100644 openssl-1.1.0h/util/perl/OpenSSL/Util/Pod.pm create mode 100644 openssl-1.1.0h/util/perl/TLSProxy/ClientHello.pm create mode 100644 openssl-1.1.0h/util/perl/TLSProxy/Message.pm create mode 100644 openssl-1.1.0h/util/perl/TLSProxy/NewSessionTicket.pm create mode 100644 openssl-1.1.0h/util/perl/TLSProxy/Proxy.pm create mode 100644 openssl-1.1.0h/util/perl/TLSProxy/Record.pm create mode 100644 openssl-1.1.0h/util/perl/TLSProxy/ServerHello.pm create mode 100644 openssl-1.1.0h/util/perl/TLSProxy/ServerKeyExchange.pm create mode 100644 openssl-1.1.0h/util/perl/with_fallback.pm (limited to 'openssl-1.1.0h/util/perl') diff --git a/openssl-1.1.0h/util/perl/OpenSSL/Glob.pm b/openssl-1.1.0h/util/perl/OpenSSL/Glob.pm new file mode 100644 index 0000000..ec87da4 --- /dev/null +++ b/openssl-1.1.0h/util/perl/OpenSSL/Glob.pm @@ -0,0 +1,21 @@ +package OpenSSL::Glob; + +use strict; +use warnings; + +use File::Glob; + +use Exporter; +use vars qw($VERSION @ISA @EXPORT); + +$VERSION = '0.1'; +@ISA = qw(Exporter); +@EXPORT = qw(glob); + +sub glob { + goto &File::Glob::bsd_glob if $^O ne "VMS"; + goto &CORE::glob; +} + +1; +__END__ diff --git a/openssl-1.1.0h/util/perl/OpenSSL/Test.pm b/openssl-1.1.0h/util/perl/OpenSSL/Test.pm new file mode 100644 index 0000000..5de7b58 --- /dev/null +++ b/openssl-1.1.0h/util/perl/OpenSSL/Test.pm @@ -0,0 +1,1051 @@ +# Copyright 2016-2018 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + +package OpenSSL::Test; + +use strict; +use warnings; + +use Test::More 0.96; + +use Exporter; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +$VERSION = "0.8"; +@ISA = qw(Exporter); +@EXPORT = (@Test::More::EXPORT, qw(setup indir app fuzz perlapp test perltest + run)); +@EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file + srctop_dir srctop_file + data_file + pipe with cmdstr quotify)); + +=head1 NAME + +OpenSSL::Test - a private extension of Test::More + +=head1 SYNOPSIS + + use OpenSSL::Test; + + setup("my_test_name"); + + ok(run(app(["openssl", "version"])), "check for openssl presence"); + + indir "subdir" => sub { + ok(run(test(["sometest", "arg1"], stdout => "foo.txt")), + "run sometest with output to foo.txt"); + }; + +=head1 DESCRIPTION + +This module is a private extension of L for testing OpenSSL. +In addition to the Test::More functions, it also provides functions that +easily find the diverse programs within a OpenSSL build tree, as well as +some other useful functions. + +This module I on the environment variables C<$TOP> or C<$SRCTOP> +and C<$BLDTOP>. Without one of the combinations it refuses to work. +See L below. + +With each test recipe, a parallel data directory with (almost) the same name +as the recipe is possible in the source directory tree. For example, for a +recipe C<$SRCTOP/test/recipes/99-foo.t>, there could be a directory +C<$SRCTOP/test/recipes/99-foo_data/>. + +=cut + +use File::Copy; +use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir + catdir catfile splitpath catpath devnull abs2rel + rel2abs/; +use File::Path 2.00 qw/rmtree mkpath/; +use File::Basename; + + +# The name of the test. This is set by setup() and is used in the other +# functions to verify that setup() has been used. +my $test_name = undef; + +# Directories we want to keep track of TOP, APPS, TEST and RESULTS are the +# ones we're interested in, corresponding to the environment variables TOP +# (mandatory), BIN_D, TEST_D, UTIL_D and RESULT_D. +my %directories = (); + +# The environment variables that gave us the contents in %directories. These +# get modified whenever we change directories, so that subprocesses can use +# the values of those environment variables as well +my @direnv = (); + +# A bool saying if we shall stop all testing if the current recipe has failing +# tests or not. This is set by setup() if the environment variable STOPTEST +# is defined with a non-empty value. +my $end_with_bailout = 0; + +# A set of hooks that is affected by with() and may be used in diverse places. +# All hooks are expected to be CODE references. +my %hooks = ( + + # exit_checker is used by run() directly after completion of a command. + # it receives the exit code from that command and is expected to return + # 1 (for success) or 0 (for failure). This is the value that will be + # returned by run(). + # NOTE: When run() gets the option 'capture => 1', this hook is ignored. + exit_checker => sub { return shift == 0 ? 1 : 0 }, + + ); + +# Debug flag, to be set manually when needed +my $debug = 0; + +# Declare some utility functions that are defined at the end +sub bldtop_file; +sub bldtop_dir; +sub srctop_file; +sub srctop_dir; +sub quotify; + +# Declare some private functions that are defined at the end +sub __env; +sub __cwd; +sub __apps_file; +sub __results_file; +sub __fixup_cmd; +sub __build_cmd; + +=head2 Main functions + +The following functions are exported by default when using C. + +=cut + +=over 4 + +=item B + +C is used for initial setup, and it is mandatory that it's used. +If it's not used in a OpenSSL test recipe, the rest of the recipe will +most likely refuse to run. + +C checks for environment variables (see L below), +checks that C<$TOP/Configure> or C<$SRCTOP/Configure> exists, C +into the results directory (defined by the C<$RESULT_D> environment +variable if defined, otherwise C<$BLDTOP/test> or C<$TOP/test>, whichever +is defined). + +=back + +=cut + +sub setup { + my $old_test_name = $test_name; + $test_name = shift; + + BAIL_OUT("setup() must receive a name") unless $test_name; + warn "setup() detected test name change. Innocuous, so we continue...\n" + if $old_test_name && $old_test_name ne $test_name; + + return if $old_test_name; + + BAIL_OUT("setup() needs \$TOP or \$SRCTOP and \$BLDTOP to be defined") + unless $ENV{TOP} || ($ENV{SRCTOP} && $ENV{BLDTOP}); + BAIL_OUT("setup() found both \$TOP and \$SRCTOP or \$BLDTOP...") + if $ENV{TOP} && ($ENV{SRCTOP} || $ENV{BLDTOP}); + + __env(); + + BAIL_OUT("setup() expects the file Configure in the source top directory") + unless -f srctop_file("Configure"); + + __cwd($directories{RESULTS}); +} + +=over 4 + +=item B sub BLOCK, OPTS> + +C is used to run a part of the recipe in a different directory than +the one C moved into, usually a subdirectory, given by SUBDIR. +The part of the recipe that's run there is given by the codeblock BLOCK. + +C takes some additional options OPTS that affect the subdirectory: + +=over 4 + +=item B 0|1> + +When set to 1 (or any value that perl preceives as true), the subdirectory +will be created if it doesn't already exist. This happens before BLOCK +is executed. + +=item B 0|1> + +When set to 1 (or any value that perl preceives as true), the subdirectory +will be cleaned out and removed. This happens both before and after BLOCK +is executed. + +=back + +An example: + + indir "foo" => sub { + ok(run(app(["openssl", "version"]), stdout => "foo.txt")); + if (ok(open(RESULT, "foo.txt"), "reading foo.txt")) { + my $line = ; + close RESULT; + is($line, qr/^OpenSSL 1\./, + "check that we're using OpenSSL 1.x.x"); + } + }, create => 1, cleanup => 1; + +=back + +=cut + +sub indir { + my $subdir = shift; + my $codeblock = shift; + my %opts = @_; + + my $reverse = __cwd($subdir,%opts); + BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into") + unless $reverse; + + $codeblock->(); + + __cwd($reverse); + + if ($opts{cleanup}) { + rmtree($subdir, { safe => 0 }); + } +} + +=over 4 + +=item B + +=item B + +Both of these functions take a reference to a list that is a command and +its arguments, and some additional options (described further on). + +C expects to find the given command (the first item in the given list +reference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps> +or C<$BLDTOP/apps>). + +C expects to find the given command (the first item in the given list +reference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test> +or C<$BLDTOP/test>). + +Both return a CODEREF to be used by C, C or C. + +The options that both C and C can take are in the form of hash +values: + +=over 4 + +=item B PATH> + +=item B PATH> + +=item B PATH> + +In all three cases, the corresponding standard input, output or error is +redirected from (for stdin) or to (for the others) a file given by the +string PATH, I, if the value is C, C or similar. + +=back + +=item B + +=item B + +Both these functions function the same way as B and B, except +that they expect the command to be a perl script. Also, they support one +more option: + +=over 4 + +=item B ARRAYref> + +The array reference is a set of arguments for perl rather than the script. +Take care so that none of them can be seen as a script! Flags and their +eventual arguments only! + +=back + +An example: + + ok(run(perlapp(["foo.pl", "arg1"], + interpreter_args => [ "-I", srctop_dir("test") ]))); + +=back + +=cut + +sub app { + my $cmd = shift; + my %opts = @_; + return sub { my $num = shift; + return __build_cmd($num, \&__apps_file, $cmd, %opts); } +} + +sub fuzz { + my $cmd = shift; + my %opts = @_; + return sub { my $num = shift; + return __build_cmd($num, \&__fuzz_file, $cmd, %opts); } +} + +sub test { + my $cmd = shift; + my %opts = @_; + return sub { my $num = shift; + return __build_cmd($num, \&__test_file, $cmd, %opts); } +} + +sub perlapp { + my $cmd = shift; + my %opts = @_; + return sub { my $num = shift; + return __build_cmd($num, \&__perlapps_file, $cmd, %opts); } +} + +sub perltest { + my $cmd = shift; + my %opts = @_; + return sub { my $num = shift; + return __build_cmd($num, \&__perltest_file, $cmd, %opts); } +} + +=over 4 + +=item B + +This CODEREF is expected to be the value return by C or C, +anything else will most likely cause an error unless you know what you're +doing. + +C executes the command returned by CODEREF and return either the +resulting output (if the option C is set true) or a boolean indicating +if the command succeeded or not. + +The options that C can take are in the form of hash values: + +=over 4 + +=item B 0|1> + +If true, the command will be executed with a perl backtick, and C will +return the resulting output as an array of lines. If false or not given, +the command will be executed with C, and C will return 1 if +the command was successful or 0 if it wasn't. + +=back + +For further discussion on what is considered a successful command or not, see +the function C further down. + +=back + +=cut + +sub run { + my ($cmd, $display_cmd) = shift->(0); + my %opts = @_; + + return () if !$cmd; + + my $prefix = ""; + if ( $^O eq "VMS" ) { # VMS + $prefix = "pipe "; + } + + my @r = (); + my $r = 0; + my $e = 0; + + # In non-verbose, we want to shut up the command interpreter, in case + # it has something to complain about. On VMS, it might complain both + # on stdout and stderr + my $save_STDOUT; + my $save_STDERR; + if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) { + open $save_STDOUT, '>&', \*STDOUT or die "Can't dup STDOUT: $!"; + open $save_STDERR, '>&', \*STDERR or die "Can't dup STDERR: $!"; + open STDOUT, ">", devnull(); + open STDERR, ">", devnull(); + } + + # The dance we do with $? is the same dance the Unix shells appear to + # do. For example, a program that gets aborted (and therefore signals + # SIGABRT = 6) will appear to exit with the code 134. We mimic this + # to make it easier to compare with a manual run of the command. + if ($opts{capture}) { + @r = `$prefix$cmd`; + $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8); + } else { + system("$prefix$cmd"); + $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8); + $r = $hooks{exit_checker}->($e); + } + + if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) { + close STDOUT; + close STDERR; + open STDOUT, '>&', $save_STDOUT or die "Can't restore STDOUT: $!"; + open STDERR, '>&', $save_STDERR or die "Can't restore STDERR: $!"; + } + + print STDERR "$prefix$display_cmd => $e\n" + if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE}; + + # At this point, $? stops being interesting, and unfortunately, + # there are Test::More versions that get picky if we leave it + # non-zero. + $? = 0; + + if ($opts{capture}) { + return @r; + } else { + return $r; + } +} + +END { + my $tb = Test::More->builder; + my $failure = scalar(grep { $_ == 0; } $tb->summary); + if ($failure && $end_with_bailout) { + BAIL_OUT("Stoptest!"); + } +} + +=head2 Utility functions + +The following functions are exported on request when using C. + + # To only get the bldtop_file and srctop_file functions. + use OpenSSL::Test qw/bldtop_file srctop_file/; + + # To only get the bldtop_file function in addition to the default ones. + use OpenSSL::Test qw/:DEFAULT bldtop_file/; + +=cut + +# Utility functions, exported on request + +=over 4 + +=item B + +LIST is a list of directories that make up a path from the top of the OpenSSL +build directory (as indicated by the environment variable C<$TOP> or +C<$BLDTOP>). +C returns the resulting directory as a string, adapted to the local +operating system. + +=back + +=cut + +sub bldtop_dir { + return __bldtop_dir(@_); # This caters for operating systems that have + # a very distinct syntax for directories. +} + +=over 4 + +=item B + +LIST is a list of directories that make up a path from the top of the OpenSSL +build directory (as indicated by the environment variable C<$TOP> or +C<$BLDTOP>) and FILENAME is the name of a file located in that directory path. +C returns the resulting file path as a string, adapted to the local +operating system. + +=back + +=cut + +sub bldtop_file { + return __bldtop_file(@_); +} + +=over 4 + +=item B + +LIST is a list of directories that make up a path from the top of the OpenSSL +source directory (as indicated by the environment variable C<$TOP> or +C<$SRCTOP>). +C returns the resulting directory as a string, adapted to the local +operating system. + +=back + +=cut + +sub srctop_dir { + return __srctop_dir(@_); # This caters for operating systems that have + # a very distinct syntax for directories. +} + +=over 4 + +=item B + +LIST is a list of directories that make up a path from the top of the OpenSSL +source directory (as indicated by the environment variable C<$TOP> or +C<$SRCTOP>) and FILENAME is the name of a file located in that directory path. +C returns the resulting file path as a string, adapted to the local +operating system. + +=back + +=cut + +sub srctop_file { + return __srctop_file(@_); +} + +=over 4 + +=item B + +LIST is a list of directories that make up a path from the data directory +associated with the test (see L above) and FILENAME is the name +of a file located in that directory path. C returns the resulting +file path as a string, adapted to the local operating system. + +=back + +=cut + +sub data_file { + return __data_file(@_); +} + +=over 4 + +=item B + +LIST is a list of CODEREFs returned by C or C, from which C +creates a new command composed of all the given commands put together in a +pipe. C returns a new CODEREF in the same manner as C or C, +to be passed to C for execution. + +=back + +=cut + +sub pipe { + my @cmds = @_; + return + sub { + my @cs = (); + my @dcs = (); + my @els = (); + my $counter = 0; + foreach (@cmds) { + my ($c, $dc, @el) = $_->(++$counter); + + return () if !$c; + + push @cs, $c; + push @dcs, $dc; + push @els, @el; + } + return ( + join(" | ", @cs), + join(" | ", @dcs), + @els + ); + }; +} + +=over 4 + +=item B + +C will temporarly install hooks given by the HASHREF and then execute +the given CODEREF. Hooks are usually expected to have a coderef as value. + +The currently available hoosk are: + +=over 4 + +=item B CODEREF> + +This hook is executed after C has performed its given command. The +CODEREF receives the exit code as only argument and is expected to return +1 (if the exit code indicated success) or 0 (if the exit code indicated +failure). + +=back + +=back + +=cut + +sub with { + my $opts = shift; + my %opts = %{$opts}; + my $codeblock = shift; + + my %saved_hooks = (); + + foreach (keys %opts) { + $saved_hooks{$_} = $hooks{$_} if exists($hooks{$_}); + $hooks{$_} = $opts{$_}; + } + + $codeblock->(); + + foreach (keys %saved_hooks) { + $hooks{$_} = $saved_hooks{$_}; + } +} + +=over 4 + +=item B + +C takes a CODEREF from C or C and simply returns the +command as a string. + +C takes some additiona options OPTS that affect the string returned: + +=over 4 + +=item B 0|1> + +When set to 0, the returned string will be with all decorations, such as a +possible redirect of stderr to the null device. This is suitable if the +string is to be used directly in a recipe. + +When set to 1, the returned string will be without extra decorations. This +is suitable for display if that is desired (doesn't confuse people with all +internal stuff), or if it's used to pass a command down to a subprocess. + +Default: 0 + +=back + +=back + +=cut + +sub cmdstr { + my ($cmd, $display_cmd) = shift->(0); + my %opts = @_; + + if ($opts{display}) { + return $display_cmd; + } else { + return $cmd; + } +} + +=over 4 + +=item B + +LIST is a list of strings that are going to be used as arguments for a +command, and makes sure to inject quotes and escapes as necessary depending +on the content of each string. + +This can also be used to put quotes around the executable of a command. +I + +=back + +=cut + +sub quotify { + # Unix setup (default if nothing else is mentioned) + my $arg_formatter = + sub { $_ = shift; + ($_ eq '' || /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/) ? "'$_'" : $_ }; + + if ( $^O eq "VMS") { # VMS setup + $arg_formatter = sub { + $_ = shift; + if ($_ eq '' || /\s|["[:upper:]]/) { + s/"/""/g; + '"'.$_.'"'; + } else { + $_; + } + }; + } elsif ( $^O eq "MSWin32") { # MSWin setup + $arg_formatter = sub { + $_ = shift; + if ($_ eq '' || /\s|["\|\&\*\;<>]/) { + s/(["\\])/\\$1/g; + '"'.$_.'"'; + } else { + $_; + } + }; + } + + return map { $arg_formatter->($_) } @_; +} + +###################################################################### +# private functions. These are never exported. + +=head1 ENVIRONMENT + +OpenSSL::Test depends on some environment variables. + +=over 4 + +=item B + +This environment variable is mandatory. C will check that it's +defined and that it's a directory that contains the file C. +If this isn't so, C will C. + +=item B + +If defined, its value should be the directory where the openssl application +is located. Defaults to C<$TOP/apps> (adapted to the operating system). + +=item B + +If defined, its value should be the directory where the test applications +are located. Defaults to C<$TOP/test> (adapted to the operating system). + +=item B + +If defined, it puts testing in a different mode, where a recipe with +failures will result in a C at the end of its run. + +=back + +=cut + +sub __env { + (my $recipe_datadir = basename($0)) =~ s/\.t$/_data/i; + + $directories{SRCTOP} = $ENV{SRCTOP} || $ENV{TOP}; + $directories{BLDTOP} = $ENV{BLDTOP} || $ENV{TOP}; + $directories{BLDAPPS} = $ENV{BIN_D} || __bldtop_dir("apps"); + $directories{SRCAPPS} = __srctop_dir("apps"); + $directories{BLDFUZZ} = __bldtop_dir("fuzz"); + $directories{SRCFUZZ} = __srctop_dir("fuzz"); + $directories{BLDTEST} = $ENV{TEST_D} || __bldtop_dir("test"); + $directories{SRCTEST} = __srctop_dir("test"); + $directories{SRCDATA} = __srctop_dir("test", "recipes", + $recipe_datadir); + $directories{RESULTS} = $ENV{RESULT_D} || $directories{BLDTEST}; + + push @direnv, "TOP" if $ENV{TOP}; + push @direnv, "SRCTOP" if $ENV{SRCTOP}; + push @direnv, "BLDTOP" if $ENV{BLDTOP}; + push @direnv, "BIN_D" if $ENV{BIN_D}; + push @direnv, "TEST_D" if $ENV{TEST_D}; + push @direnv, "RESULT_D" if $ENV{RESULT_D}; + + $end_with_bailout = $ENV{STOPTEST} ? 1 : 0; +}; + +sub __srctop_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + return catfile($directories{SRCTOP},@_,$f); +} + +sub __srctop_dir { + BAIL_OUT("Must run setup() first") if (! $test_name); + + return catdir($directories{SRCTOP},@_); +} + +sub __bldtop_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + return catfile($directories{BLDTOP},@_,$f); +} + +sub __bldtop_dir { + BAIL_OUT("Must run setup() first") if (! $test_name); + + return catdir($directories{BLDTOP},@_); +} + +sub __exeext { + my $ext = ""; + if ($^O eq "VMS" ) { # VMS + $ext = ".exe"; + } elsif ($^O eq "MSWin32") { # Windows + $ext = ".exe"; + } + return $ENV{"EXE_EXT"} || $ext; +} + +sub __test_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + my $out = catfile($directories{BLDTEST},@_,$f . __exeext()); + $out = catfile($directories{SRCTEST},@_,$f) unless -x $out; + return $out; +} + +sub __perltest_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + my $out = catfile($directories{BLDTEST},@_,$f); + $out = catfile($directories{SRCTEST},@_,$f) unless -f $out; + return ($^X, $out); +} + +sub __apps_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + my $out = catfile($directories{BLDAPPS},@_,$f . __exeext()); + $out = catfile($directories{SRCAPPS},@_,$f) unless -x $out; + return $out; +} + +sub __fuzz_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + my $out = catfile($directories{BLDFUZZ},@_,$f . __exeext()); + $out = catfile($directories{SRCFUZZ},@_,$f) unless -x $out; + return $out; +} + +sub __perlapps_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + my $out = catfile($directories{BLDAPPS},@_,$f); + $out = catfile($directories{SRCAPPS},@_,$f) unless -f $out; + return ($^X, $out); +} + +sub __data_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + return catfile($directories{SRCDATA},@_,$f); +} + +sub __results_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + return catfile($directories{RESULTS},@_,$f); +} + +sub __cwd { + my $dir = catdir(shift); + my %opts = @_; + my $abscurdir = rel2abs(curdir()); + my $absdir = rel2abs($dir); + my $reverse = abs2rel($abscurdir, $absdir); + + # PARANOIA: if we're not moving anywhere, we do nothing more + if ($abscurdir eq $absdir) { + return $reverse; + } + + # Do not support a move to a different volume for now. Maybe later. + BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported") + if $reverse eq $abscurdir; + + # If someone happened to give a directory that leads back to the current, + # it's extremely silly to do anything more, so just simulate that we did + # move. + # In this case, we won't even clean it out, for safety's sake. + return "." if $reverse eq ""; + + $dir = canonpath($dir); + if ($opts{create}) { + mkpath($dir); + } + + # We are recalculating the directories we keep track of, but need to save + # away the result for after having moved into the new directory. + my %tmp_directories = (); + my %tmp_ENV = (); + + # For each of these directory variables, figure out where they are relative + # to the directory we want to move to if they aren't absolute (if they are, + # they don't change!) + my @dirtags = sort keys %directories; + foreach (@dirtags) { + if (!file_name_is_absolute($directories{$_})) { + my $newpath = abs2rel(rel2abs($directories{$_}), rel2abs($dir)); + $tmp_directories{$_} = $newpath; + } + } + + # Treat each environment variable that was used to get us the values in + # %directories the same was as the paths in %directories, so any sub + # process can use their values properly as well + foreach (@direnv) { + if (!file_name_is_absolute($ENV{$_})) { + my $newpath = abs2rel(rel2abs($ENV{$_}), rel2abs($dir)); + $tmp_ENV{$_} = $newpath; + } + } + + # Should we just bail out here as well? I'm unsure. + return undef unless chdir($dir); + + if ($opts{cleanup}) { + rmtree(".", { safe => 0, keep_root => 1 }); + } + + # We put back new values carefully. Doing the obvious + # %directories = ( %tmp_irectories ) + # will clear out any value that happens to be an absolute path + foreach (keys %tmp_directories) { + $directories{$_} = $tmp_directories{$_}; + } + foreach (keys %tmp_ENV) { + $ENV{$_} = $tmp_ENV{$_}; + } + + if ($debug) { + print STDERR "DEBUG: __cwd(), directories and files:\n"; + print STDERR " \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n"; + print STDERR " \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n"; + print STDERR " \$directories{SRCDATA} = \"$directories{SRCDATA}\"\n"; + print STDERR " \$directories{RESULTS} = \"$directories{RESULTS}\"\n"; + print STDERR " \$directories{BLDAPPS} = \"$directories{BLDAPPS}\"\n"; + print STDERR " \$directories{SRCAPPS} = \"$directories{SRCAPPS}\"\n"; + print STDERR " \$directories{SRCTOP} = \"$directories{SRCTOP}\"\n"; + print STDERR " \$directories{BLDTOP} = \"$directories{BLDTOP}\"\n"; + print STDERR "\n"; + print STDERR " current directory is \"",curdir(),"\"\n"; + print STDERR " the way back is \"$reverse\"\n"; + } + + return $reverse; +} + +sub __fixup_cmd { + my $prog = shift; + my $exe_shell = shift; + + my $prefix = __bldtop_file("util", "shlib_wrap.sh")." "; + + if (defined($exe_shell)) { + $prefix = "$exe_shell "; + } elsif ($^O eq "VMS" ) { # VMS + $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []"); + } elsif ($^O eq "MSWin32") { # Windows + $prefix = ""; + } + + # We test both with and without extension. The reason + # is that we might be passed a complete file spec, with + # extension. + if ( ! -x $prog ) { + my $prog = "$prog"; + if ( ! -x $prog ) { + $prog = undef; + } + } + + if (defined($prog)) { + # Make sure to quotify the program file on platforms that may + # have spaces or similar in their path name. + # To our knowledge, VMS is the exception where quotifying should + # never happen. + ($prog) = quotify($prog) unless $^O eq "VMS"; + return $prefix.$prog; + } + + print STDERR "$prog not found\n"; + return undef; +} + +sub __build_cmd { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $num = shift; + my $path_builder = shift; + # Make a copy to not destroy the caller's array + my @cmdarray = ( @{$_[0]} ); shift; + my %opts = @_; + + # We do a little dance, as $path_builder might return a list of + # more than one. If so, only the first is to be considered a + # program to fix up, the rest is part of the arguments. This + # happens for perl scripts, where $path_builder will return + # a list of two, $^X and the script name. + # Also, if $path_builder returned more than one, we don't apply + # the EXE_SHELL environment variable. + my @prog = ($path_builder->(shift @cmdarray)); + my $first = shift @prog; + my $exe_shell = @prog ? undef : $ENV{EXE_SHELL}; + my $cmd = __fixup_cmd($first, $exe_shell); + if (@prog) { + if ( ! -f $prog[0] ) { + print STDERR "$prog[0] not found\n"; + $cmd = undef; + } + } + my @args = (@prog, @cmdarray); + if (defined($opts{interpreter_args})) { + unshift @args, @{$opts{interpreter_args}}; + } + + return () if !$cmd; + + my $arg_str = ""; + my $null = devnull(); + + + $arg_str = " ".join(" ", quotify @args) if @args; + + my $fileornull = sub { $_[0] ? $_[0] : $null; }; + my $stdin = ""; + my $stdout = ""; + my $stderr = ""; + my $saved_stderr = undef; + $stdin = " < ".$fileornull->($opts{stdin}) if exists($opts{stdin}); + $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout}); + $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr}); + + my $display_cmd = "$cmd$arg_str$stdin$stdout$stderr"; + + $stderr=" 2> ".$null + unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE}; + + $cmd .= "$arg_str$stdin$stdout$stderr"; + + if ($debug) { + print STDERR "DEBUG[__build_cmd]: \$cmd = \"$cmd\"\n"; + print STDERR "DEBUG[__build_cmd]: \$display_cmd = \"$display_cmd\"\n"; + } + + return ($cmd, $display_cmd); +} + +=head1 SEE ALSO + +L, L + +=head1 AUTHORS + +Richard Levitte Elevitte@openssl.orgE with assitance and +inspiration from Andy Polyakov Eappro@openssl.org. + +=cut + +1; diff --git a/openssl-1.1.0h/util/perl/OpenSSL/Test/Simple.pm b/openssl-1.1.0h/util/perl/OpenSSL/Test/Simple.pm new file mode 100644 index 0000000..c5a84d5 --- /dev/null +++ b/openssl-1.1.0h/util/perl/OpenSSL/Test/Simple.pm @@ -0,0 +1,91 @@ +# Copyright 2016 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + +package OpenSSL::Test::Simple; + +use strict; +use warnings; + +use Exporter; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +$VERSION = "0.2"; +@ISA = qw(Exporter); +@EXPORT = qw(simple_test); + +=head1 NAME + +OpenSSL::Test::Simple - a few very simple test functions + +=head1 SYNOPSIS + + use OpenSSL::Test::Simple; + + simple_test("my_test_name", "destest", "des"); + +=head1 DESCRIPTION + +Sometimes, the functions in L are quite tedious for some +repetitive tasks. This module provides functions to make life easier. +You could call them hacks if you wish. + +=cut + +use OpenSSL::Test; +use OpenSSL::Test::Utils; + +=over 4 + +=item B + +Runs a test named NAME, running the program PROGRAM with no arguments, +to test the algorithm ALGORITHM. + +A complete recipe looks like this: + + use OpenSSL::Test::Simple; + + simple_test("test_bf", "bftest", "bf"); + +=back + +=cut + +# args: +# name (used with setup()) +# algorithm (used to check if it's at all supported) +# name of binary (the program that does the actual test) +sub simple_test { + my ($name, $prgr, @algos) = @_; + + setup($name); + + if (scalar(disabled(@algos))) { + if (scalar(@algos) == 1) { + plan skip_all => $algos[0]." is not supported by this OpenSSL build"; + } else { + my $last = pop @algos; + plan skip_all => join(", ", @algos)." and $last are not supported by this OpenSSL build"; + } + } + + plan tests => 1; + + ok(run(test([$prgr])), "running $prgr"); +} + +=head1 SEE ALSO + +L + +=head1 AUTHORS + +Richard Levitte Elevitte@openssl.orgE with inspiration +from Rich Salz Ersalz@openssl.orgE. + +=cut + +1; diff --git a/openssl-1.1.0h/util/perl/OpenSSL/Test/Utils.pm b/openssl-1.1.0h/util/perl/OpenSSL/Test/Utils.pm new file mode 100644 index 0000000..7b0a705 --- /dev/null +++ b/openssl-1.1.0h/util/perl/OpenSSL/Test/Utils.pm @@ -0,0 +1,240 @@ +# Copyright 2016 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + +package OpenSSL::Test::Utils; + +use strict; +use warnings; + +use Exporter; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +$VERSION = "0.1"; +@ISA = qw(Exporter); +@EXPORT = qw(alldisabled anydisabled disabled config available_protocols + have_IPv4 have_IPv6); + +=head1 NAME + +OpenSSL::Test::Utils - test utility functions + +=head1 SYNOPSIS + + use OpenSSL::Test::Utils; + + my @tls = available_protocols("tls"); + my @dtls = available_protocols("dtls"); + alldisabled("dh", "dsa"); + anydisabled("dh", "dsa"); + + config("fips"); + + have_IPv4(); + have_IPv6(); + +=head1 DESCRIPTION + +This module provides utility functions for the testing framework. + +=cut + +use OpenSSL::Test qw/:DEFAULT bldtop_file/; + +=over 4 + +=item B + +Returns a list of strings for all the available SSL/TLS versions if +STRING is "tls", or for all the available DTLS versions if STRING is +"dtls". Otherwise, it returns the empty list. The strings in the +returned list can be used with B and B. + +=item B +=item B + +In an array context returns an array with each element set to 1 if the +corresponding feature is disabled and 0 otherwise. + +In a scalar context, alldisabled returns 1 if all of the features in +ARRAY are disabled, while anydisabled returns 1 if any of them are +disabled. + +=item B + +Returns an item from the %config hash in \$TOP/configdata.pm. + +=item B +=item B + +Return true if IPv4 / IPv6 is possible to use on the current system. + +=back + +=cut + +our %available_protocols; +our %disabled; +our %config; +my $configdata_loaded = 0; + +sub load_configdata { + # We eval it so it doesn't run at compile time of this file. + # The latter would have bldtop_file() complain that setup() hasn't + # been run yet. + my $configdata = bldtop_file("configdata.pm"); + eval { require $configdata; + %available_protocols = %configdata::available_protocols; + %disabled = %configdata::disabled; + %config = %configdata::config; + }; + $configdata_loaded = 1; +} + +# args +# list of 1s and 0s, coming from check_disabled() +sub anyof { + my $x = 0; + foreach (@_) { $x += $_ } + return $x > 0; +} + +# args +# list of 1s and 0s, coming from check_disabled() +sub allof { + my $x = 1; + foreach (@_) { $x *= $_ } + return $x > 0; +} + +# args +# list of strings, all of them should be names of features +# that can be disabled. +# returns a list of 1s (if the corresponding feature is disabled) +# and 0s (if it isn't) +sub check_disabled { + return map { exists $disabled{lc $_} ? 1 : 0 } @_; +} + +# Exported functions ################################################# + +# args: +# list of features to check +sub anydisabled { + load_configdata() unless $configdata_loaded; + my @ret = check_disabled(@_); + return @ret if wantarray; + return anyof(@ret); +} + +# args: +# list of features to check +sub alldisabled { + load_configdata() unless $configdata_loaded; + my @ret = check_disabled(@_); + return @ret if wantarray; + return allof(@ret); +} + +# !!! Kept for backward compatibility +# args: +# single string +sub disabled { + anydisabled(@_); +} + +sub available_protocols { + load_configdata() unless $configdata_loaded; + my $protocol_class = shift; + if (exists $available_protocols{lc $protocol_class}) { + return @{$available_protocols{lc $protocol_class}} + } + return (); +} + +sub config { + load_configdata() unless $configdata_loaded; + return $config{$_[0]}; +} + +# IPv4 / IPv6 checker +my $have_IPv4 = -1; +my $have_IPv6 = -1; +my $IP_factory; +sub check_IP { + my $listenaddress = shift; + + eval { + require IO::Socket::IP; + my $s = IO::Socket::IP->new( + LocalAddr => $listenaddress, + LocalPort => 0, + Listen=>1, + ); + $s or die "\n"; + $s->close(); + }; + if ($@ eq "") { + return 1; + } + + eval { + require IO::Socket::INET6; + my $s = IO::Socket::INET6->new( + LocalAddr => $listenaddress, + LocalPort => 0, + Listen=>1, + ); + $s or die "\n"; + $s->close(); + }; + if ($@ eq "") { + return 1; + } + + eval { + require IO::Socket::INET; + my $s = IO::Socket::INET->new( + LocalAddr => $listenaddress, + LocalPort => 0, + Listen=>1, + ); + $s or die "\n"; + $s->close(); + }; + if ($@ eq "") { + return 1; + } + + return 0; +} + +sub have_IPv4 { + if ($have_IPv4 < 0) { + $have_IPv4 = check_IP("127.0.0.1"); + } + return $have_IPv4; +} + +sub have_IPv6 { + if ($have_IPv6 < 0) { + $have_IPv6 = check_IP("::1"); + } + return $have_IPv6; +} + + +=head1 SEE ALSO + +L + +=head1 AUTHORS + +Stephen Henson Esteve@openssl.orgE and +Richard Levitte Elevitte@openssl.orgE + +=cut + +1; diff --git a/openssl-1.1.0h/util/perl/OpenSSL/Util/Pod.pm b/openssl-1.1.0h/util/perl/OpenSSL/Util/Pod.pm new file mode 100644 index 0000000..5c0af95 --- /dev/null +++ b/openssl-1.1.0h/util/perl/OpenSSL/Util/Pod.pm @@ -0,0 +1,158 @@ +# Copyright 2016 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + +package OpenSSL::Util::Pod; + +use strict; +use warnings; + +use Exporter; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +$VERSION = "0.1"; +@ISA = qw(Exporter); +@EXPORT = qw(extract_pod_info); +@EXPORT_OK = qw(); + +=head1 NAME + +OpenSSL::Util::Pod - utilities to manipulate .pod files + +=head1 SYNOPSIS + + use OpenSSL::Util::Pod; + + my %podinfo = extract_pod_info("foo.pod"); + + # or if the file is already opened... Note that this consumes the + # remainder of the file. + + my %podinfo = extract_pod_info(\*STDIN); + +=head1 DESCRIPTION + +=over + +=item B + +=item B + +=item B + +=item B + +Extracts information from a .pod file, given a STRING (file name) or a +GLOB (a file handle). The result is given back as a hash table. + +The additional hash is for extra parameters: + +=over + +=item B
N> + +The value MUST be a number, and will be the default man section number +to be used with the given .pod file. This number can be altered if +the .pod file has a line like this: + + =for comment openssl_manual_section: 4 + +=item B 0|1> + +If set to 1, extra debug text will be printed on STDERR + +=back + +=back + +=head1 RETURN VALUES + +=over + +=item B returns a hash table with the following +items: + +=over + +=item B
N> + +The man section number this .pod file belongs to. Often the same as +was given as input. + +=item B [ "name", ... ]> + +All the names extracted from the NAME section. + +=back + +=back + +=cut + +sub extract_pod_info { + my $input = shift; + my $defaults_ref = shift || {}; + my %defaults = ( debug => 0, section => 0, %$defaults_ref ); + my $fh = undef; + my $filename = undef; + + # If not a file handle, then it's assume to be a file path (a string) + unless (ref $input eq "GLOB") { + $filename = $input; + open $fh, $input or die "Trying to read $filename: $!\n"; + print STDERR "DEBUG: Reading $input\n" if $defaults{debug}; + $input = $fh; + } + + my %podinfo = ( section => $defaults{section}); + while(<$input>) { + s|\R$||; + if (m|^=for\s+comment\s+openssl_manual_section:\s*([0-9])\s*$|) { + print STDERR "DEBUG: Found man section number $1\n" + if $defaults{debug}; + $podinfo{section} = $1; + } + + # Stop reading when we have reached past the NAME section. + last if (m|^=head1| + && defined $podinfo{lastsect} + && $podinfo{lastsect} eq "NAME"); + + # Collect the section name + if (m|^=head1\s*(.*)|) { + $podinfo{lastsect} = $1; + $podinfo{lastsect} =~ s/\s+$//; + print STDERR "DEBUG: Found new pod section $1\n" + if $defaults{debug}; + print STDERR "DEBUG: Clearing pod section text\n" + if $defaults{debug}; + $podinfo{lastsecttext} = ""; + } + + next if (m|^=| || m|^\s*$|); + + # Collect the section text + print STDERR "DEBUG: accumulating pod section text \"$_\"\n" + if $defaults{debug}; + $podinfo{lastsecttext} .= " " if $podinfo{lastsecttext}; + $podinfo{lastsecttext} .= $_; + } + + + if (defined $fh) { + close $fh; + print STDERR "DEBUG: Done reading $filename\n" if $defaults{debug}; + } + + $podinfo{lastsecttext} =~ s| - .*$||; + + my @names = + map { s|\s+||g; $_ } + split(m|,|, $podinfo{lastsecttext}); + + return ( section => $podinfo{section}, names => [ @names ] ); +} + +1; diff --git a/openssl-1.1.0h/util/perl/TLSProxy/ClientHello.pm b/openssl-1.1.0h/util/perl/TLSProxy/ClientHello.pm new file mode 100644 index 0000000..ec739d2 --- /dev/null +++ b/openssl-1.1.0h/util/perl/TLSProxy/ClientHello.pm @@ -0,0 +1,242 @@ +# Copyright 2016 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + +use strict; + +package TLSProxy::ClientHello; + +use vars '@ISA'; +push @ISA, 'TLSProxy::Message'; + +sub new +{ + my $class = shift; + my ($server, + $data, + $records, + $startoffset, + $message_frag_lens) = @_; + + my $self = $class->SUPER::new( + $server, + 1, + $data, + $records, + $startoffset, + $message_frag_lens); + + $self->{client_version} = 0; + $self->{random} = []; + $self->{session_id_len} = 0; + $self->{session} = ""; + $self->{ciphersuite_len} = 0; + $self->{ciphersuites} = []; + $self->{comp_meth_len} = 0; + $self->{comp_meths} = []; + $self->{extensions_len} = 0; + $self->{extension_data} = ""; + + return $self; +} + +sub parse +{ + my $self = shift; + my $ptr = 2; + my ($client_version) = unpack('n', $self->data); + my $random = substr($self->data, $ptr, 32); + $ptr += 32; + my $session_id_len = unpack('C', substr($self->data, $ptr)); + $ptr++; + my $session = substr($self->data, $ptr, $session_id_len); + $ptr += $session_id_len; + my $ciphersuite_len = unpack('n', substr($self->data, $ptr)); + $ptr += 2; + my @ciphersuites = unpack('n*', substr($self->data, $ptr, + $ciphersuite_len)); + $ptr += $ciphersuite_len; + my $comp_meth_len = unpack('C', substr($self->data, $ptr)); + $ptr++; + my @comp_meths = unpack('C*', substr($self->data, $ptr, $comp_meth_len)); + $ptr += $comp_meth_len; + my $extensions_len = unpack('n', substr($self->data, $ptr)); + $ptr += 2; + #For now we just deal with this as a block of data. In the future we will + #want to parse this + my $extension_data = substr($self->data, $ptr); + + if (length($extension_data) != $extensions_len) { + die "Invalid extension length\n"; + } + my %extensions = (); + while (length($extension_data) >= 4) { + my ($type, $size) = unpack("nn", $extension_data); + my $extdata = substr($extension_data, 4, $size); + $extension_data = substr($extension_data, 4 + $size); + $extensions{$type} = $extdata; + } + + $self->client_version($client_version); + $self->random($random); + $self->session_id_len($session_id_len); + $self->session($session); + $self->ciphersuite_len($ciphersuite_len); + $self->ciphersuites(\@ciphersuites); + $self->comp_meth_len($comp_meth_len); + $self->comp_meths(\@comp_meths); + $self->extensions_len($extensions_len); + $self->extension_data(\%extensions); + + $self->process_extensions(); + + print " Client Version:".$client_version."\n"; + print " Session ID Len:".$session_id_len."\n"; + print " Ciphersuite len:".$ciphersuite_len."\n"; + print " Compression Method Len:".$comp_meth_len."\n"; + print " Extensions Len:".$extensions_len."\n"; +} + +#Perform any actions necessary based on the extensions we've seen +sub process_extensions +{ + my $self = shift; + my %extensions = %{$self->extension_data}; + + #Clear any state from a previous run + TLSProxy::Record->etm(0); + + if (exists $extensions{TLSProxy::Message::EXT_ENCRYPT_THEN_MAC}) { + TLSProxy::Record->etm(1); + } +} + +#Reconstruct the on-the-wire message data following changes +sub set_message_contents +{ + my $self = shift; + my $data; + my $extensions = ""; + + $data = pack('n', $self->client_version); + $data .= $self->random; + $data .= pack('C', $self->session_id_len); + $data .= $self->session; + $data .= pack('n', $self->ciphersuite_len); + $data .= pack("n*", @{$self->ciphersuites}); + $data .= pack('C', $self->comp_meth_len); + $data .= pack("C*", @{$self->comp_meths}); + + foreach my $key (keys %{$self->extension_data}) { + my $extdata = ${$self->extension_data}{$key}; + $extensions .= pack("n", $key); + $extensions .= pack("n", length($extdata)); + $extensions .= $extdata; + if ($key == TLSProxy::Message::EXT_DUPLICATE_EXTENSION) { + $extensions .= pack("n", $key); + $extensions .= pack("n", length($extdata)); + $extensions .= $extdata; + } + } + + $data .= pack('n', length($extensions)); + $data .= $extensions; + + $self->data($data); +} + +#Read/write accessors +sub client_version +{ + my $self = shift; + if (@_) { + $self->{client_version} = shift; + } + return $self->{client_version}; +} +sub random +{ + my $self = shift; + if (@_) { + $self->{random} = shift; + } + return $self->{random}; +} +sub session_id_len +{ + my $self = shift; + if (@_) { + $self->{session_id_len} = shift; + } + return $self->{session_id_len}; +} +sub session +{ + my $self = shift; + if (@_) { + $self->{session} = shift; + } + return $self->{session}; +} +sub ciphersuite_len +{ + my $self = shift; + if (@_) { + $self->{ciphersuite_len} = shift; + } + return $self->{ciphersuite_len}; +} +sub ciphersuites +{ + my $self = shift; + if (@_) { + $self->{ciphersuites} = shift; + } + return $self->{ciphersuites}; +} +sub comp_meth_len +{ + my $self = shift; + if (@_) { + $self->{comp_meth_len} = shift; + } + return $self->{comp_meth_len}; +} +sub comp_meths +{ + my $self = shift; + if (@_) { + $self->{comp_meths} = shift; + } + return $self->{comp_meths}; +} +sub extensions_len +{ + my $self = shift; + if (@_) { + $self->{extensions_len} = shift; + } + return $self->{extensions_len}; +} +sub extension_data +{ + my $self = shift; + if (@_) { + $self->{extension_data} = shift; + } + return $self->{extension_data}; +} +sub set_extension +{ + my ($self, $ext_type, $ext_data) = @_; + $self->{extension_data}{$ext_type} = $ext_data; +} +sub delete_extension +{ + my ($self, $ext_type) = @_; + delete $self->{extension_data}{$ext_type}; +} +1; diff --git a/openssl-1.1.0h/util/perl/TLSProxy/Message.pm b/openssl-1.1.0h/util/perl/TLSProxy/Message.pm new file mode 100644 index 0000000..0821bde --- /dev/null +++ b/openssl-1.1.0h/util/perl/TLSProxy/Message.pm @@ -0,0 +1,456 @@ +# Copyright 2016 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + +use strict; + +package TLSProxy::Message; + +use constant TLS_MESSAGE_HEADER_LENGTH => 4; + +#Message types +use constant { + MT_HELLO_REQUEST => 0, + MT_CLIENT_HELLO => 1, + MT_SERVER_HELLO => 2, + MT_NEW_SESSION_TICKET => 4, + MT_CERTIFICATE => 11, + MT_SERVER_KEY_EXCHANGE => 12, + MT_CERTIFICATE_REQUEST => 13, + MT_SERVER_HELLO_DONE => 14, + MT_CERTIFICATE_VERIFY => 15, + MT_CLIENT_KEY_EXCHANGE => 16, + MT_FINISHED => 20, + MT_CERTIFICATE_STATUS => 22, + MT_NEXT_PROTO => 67 +}; + +#Alert levels +use constant { + AL_LEVEL_WARN => 1, + AL_LEVEL_FATAL => 2 +}; + +#Alert descriptions +use constant { + AL_DESC_CLOSE_NOTIFY => 0, + AL_DESC_UNEXPECTED_MESSAGE => 10, + AL_DESC_NO_RENEGOTIATION => 100 +}; + +my %message_type = ( + MT_HELLO_REQUEST, "HelloRequest", + MT_CLIENT_HELLO, "ClientHello", + MT_SERVER_HELLO, "ServerHello", + MT_NEW_SESSION_TICKET, "NewSessionTicket", + MT_CERTIFICATE, "Certificate", + MT_SERVER_KEY_EXCHANGE, "ServerKeyExchange", + MT_CERTIFICATE_REQUEST, "CertificateRequest", + MT_SERVER_HELLO_DONE, "ServerHelloDone", + MT_CERTIFICATE_VERIFY, "CertificateVerify", + MT_CLIENT_KEY_EXCHANGE, "ClientKeyExchange", + MT_FINISHED, "Finished", + MT_CERTIFICATE_STATUS, "CertificateStatus", + MT_NEXT_PROTO, "NextProto" +); + +use constant { + EXT_STATUS_REQUEST => 5, + EXT_ENCRYPT_THEN_MAC => 22, + EXT_EXTENDED_MASTER_SECRET => 23, + EXT_SESSION_TICKET => 35, + # This extension does not exist and isn't recognised by OpenSSL. + # We use it to test handling of duplicate extensions. + EXT_DUPLICATE_EXTENSION => 1234 +}; + +my $payload = ""; +my $messlen = -1; +my $mt; +my $startoffset = -1; +my $server = 0; +my $success = 0; +my $end = 0; +my @message_rec_list = (); +my @message_frag_lens = (); +my $ciphersuite = 0; + +sub clear +{ + $payload = ""; + $messlen = -1; + $startoffset = -1; + $server = 0; + $success = 0; + $end = 0; + @message_rec_list = (); + @message_frag_lens = (); +} + +#Class method to extract messages from a record +sub get_messages +{ + my $class = shift; + my $serverin = shift; + my $record = shift; + my @messages = (); + my $message; + + @message_frag_lens = (); + + if ($serverin != $server && length($payload) != 0) { + die "Changed peer, but we still have fragment data\n"; + } + $server = $serverin; + + if ($record->content_type == TLSProxy::Record::RT_CCS) { + if ($payload ne "") { + #We can't handle this yet + die "CCS received before message data complete\n"; + } + if ($server) { + TLSProxy::Record->server_ccs_seen(1); + } else { + TLSProxy::Record->client_ccs_seen(1); + } + } elsif ($record->content_type == TLSProxy::Record::RT_HANDSHAKE) { + if ($record->len == 0 || $record->len_real == 0) { + print " Message truncated\n"; + } else { + my $recoffset = 0; + + if (length $payload > 0) { + #We are continuing processing a message started in a previous + #record. Add this record to the list associated with this + #message + push @message_rec_list, $record; + + if ($messlen <= length($payload)) { + #Shouldn't happen + die "Internal error: invalid messlen: ".$messlen + ." payload length:".length($payload)."\n"; + } + if (length($payload) + $record->decrypt_len >= $messlen) { + #We can complete the message with this record + $recoffset = $messlen - length($payload); + $payload .= substr($record->decrypt_data, 0, $recoffset); + push @message_frag_lens, $recoffset; + $message = create_message($server, $mt, $payload, + $startoffset); + push @messages, $message; + + $payload = ""; + } else { + #This is just part of the total message + $payload .= $record->decrypt_data; + $recoffset = $record->decrypt_len; + push @message_frag_lens, $record->decrypt_len; + } + print " Partial message data read: ".$recoffset." bytes\n"; + } + + while ($record->decrypt_len > $recoffset) { + #We are at the start of a new message + if ($record->decrypt_len - $recoffset < 4) { + #Whilst technically probably valid we can't cope with this + die "End of record in the middle of a message header\n"; + } + @message_rec_list = ($record); + my $lenhi; + my $lenlo; + ($mt, $lenhi, $lenlo) = unpack('CnC', + substr($record->decrypt_data, + $recoffset)); + $messlen = ($lenhi << 8) | $lenlo; + print " Message type: $message_type{$mt}\n"; + print " Message Length: $messlen\n"; + $startoffset = $recoffset; + $recoffset += 4; + $payload = ""; + + if ($recoffset <= $record->decrypt_len) { + #Some payload data is present in this record + if ($record->decrypt_len - $recoffset >= $messlen) { + #We can complete the message with this record + $payload .= substr($record->decrypt_data, $recoffset, + $messlen); + $recoffset += $messlen; + push @message_frag_lens, $messlen; + $message = create_message($server, $mt, $payload, + $startoffset); + push @messages, $message; + + $payload = ""; + } else { + #This is just part of the total message + $payload .= substr($record->decrypt_data, $recoffset, + $record->decrypt_len - $recoffset); + $recoffset = $record->decrypt_len; + push @message_frag_lens, $recoffset; + } + } + } + } + } elsif ($record->content_type == TLSProxy::Record::RT_APPLICATION_DATA) { + print " [ENCRYPTED APPLICATION DATA]\n"; + print " [".$record->decrypt_data."]\n"; + } elsif ($record->content_type == TLSProxy::Record::RT_ALERT) { + my ($alertlev, $alertdesc) = unpack('CC', $record->decrypt_data); + #A CloseNotify from the client indicates we have finished successfully + #(we assume) + if (!$end && !$server && $alertlev == AL_LEVEL_WARN + && $alertdesc == AL_DESC_CLOSE_NOTIFY) { + $success = 1; + } + #All alerts end the test + $end = 1; + } + + return @messages; +} + +#Function to work out which sub-class we need to create and then +#construct it +sub create_message +{ + my ($server, $mt, $data, $startoffset) = @_; + my $message; + + #We only support ClientHello in this version...needs to be extended for + #others + if ($mt == MT_CLIENT_HELLO) { + $message = TLSProxy::ClientHello->new( + $server, + $data, + [@message_rec_list], + $startoffset, + [@message_frag_lens] + ); + $message->parse(); + } elsif ($mt == MT_SERVER_HELLO) { + $message = TLSProxy::ServerHello->new( + $server, + $data, + [@message_rec_list], + $startoffset, + [@message_frag_lens] + ); + $message->parse(); + } elsif ($mt == MT_SERVER_KEY_EXCHANGE) { + $message = TLSProxy::ServerKeyExchange->new( + $server, + $data, + [@message_rec_list], + $startoffset, + [@message_frag_lens] + ); + $message->parse(); + } elsif ($mt == MT_NEW_SESSION_TICKET) { + $message = TLSProxy::NewSessionTicket->new( + $server, + $data, + [@message_rec_list], + $startoffset, + [@message_frag_lens] + ); + $message->parse(); + } else { + #Unknown message type + $message = TLSProxy::Message->new( + $server, + $mt, + $data, + [@message_rec_list], + $startoffset, + [@message_frag_lens] + ); + } + + return $message; +} + +sub end +{ + my $class = shift; + return $end; +} +sub success +{ + my $class = shift; + return $success; +} +sub fail +{ + my $class = shift; + return !$success && $end; +} +sub new +{ + my $class = shift; + my ($server, + $mt, + $data, + $records, + $startoffset, + $message_frag_lens) = @_; + + my $self = { + server => $server, + data => $data, + records => $records, + mt => $mt, + startoffset => $startoffset, + message_frag_lens => $message_frag_lens + }; + + return bless $self, $class; +} + +sub ciphersuite +{ + my $class = shift; + if (@_) { + $ciphersuite = shift; + } + return $ciphersuite; +} + +#Update all the underlying records with the modified data from this message +#Note: Does not currently support re-encrypting +sub repack +{ + my $self = shift; + my $msgdata; + + my $numrecs = $#{$self->records}; + + $self->set_message_contents(); + + my $lenhi; + my $lenlo; + + $lenlo = length($self->data) & 0xff; + $lenhi = length($self->data) >> 8; + $msgdata = pack('CnC', $self->mt, $lenhi, $lenlo).$self->data; + + if ($numrecs == 0) { + #The message is fully contained within one record + my ($rec) = @{$self->records}; + my $recdata = $rec->decrypt_data; + + my $old_length; + + # We use empty message_frag_lens to indicates that pre-repacking, + # the message wasn't present. The first fragment length doesn't include + # the TLS header, so we need to check and compute the right length. + if (@{$self->message_frag_lens}) { + $old_length = ${$self->message_frag_lens}[0] + + TLS_MESSAGE_HEADER_LENGTH; + } else { + $old_length = 0; + } + + my $prefix = substr($recdata, 0, $self->startoffset); + my $suffix = substr($recdata, $self->startoffset + $old_length); + + $rec->decrypt_data($prefix.($msgdata).($suffix)); + # TODO(openssl-team): don't keep explicit lengths. + # (If a length override is ever needed to construct invalid packets, + # use an explicit override field instead.) + $rec->decrypt_len(length($rec->decrypt_data)); + $rec->len($rec->len + length($msgdata) - $old_length); + # Don't support re-encryption. + $rec->data($rec->decrypt_data); + + #Update the fragment len in case we changed it above + ${$self->message_frag_lens}[0] = length($msgdata) + - TLS_MESSAGE_HEADER_LENGTH; + return; + } + + #Note we don't currently support changing a fragmented message length + my $recctr = 0; + my $datadone = 0; + foreach my $rec (@{$self->records}) { + my $recdata = $rec->decrypt_data; + if ($recctr == 0) { + #This is the first record + my $remainlen = length($recdata) - $self->startoffset; + $rec->data(substr($recdata, 0, $self->startoffset) + .substr(($msgdata), 0, $remainlen)); + $datadone += $remainlen; + } elsif ($recctr + 1 == $numrecs) { + #This is the last record + $rec->data(substr($msgdata, $datadone)); + } else { + #This is a middle record + $rec->data(substr($msgdata, $datadone, length($rec->data))); + $datadone += length($rec->data); + } + $recctr++; + } +} + +#To be overridden by sub-classes +sub set_message_contents +{ +} + +#Read only accessors +sub server +{ + my $self = shift; + return $self->{server}; +} + +#Read/write accessors +sub mt +{ + my $self = shift; + if (@_) { + $self->{mt} = shift; + } + return $self->{mt}; +} +sub data +{ + my $self = shift; + if (@_) { + $self->{data} = shift; + } + return $self->{data}; +} +sub records +{ + my $self = shift; + if (@_) { + $self->{records} = shift; + } + return $self->{records}; +} +sub startoffset +{ + my $self = shift; + if (@_) { + $self->{startoffset} = shift; + } + return $self->{startoffset}; +} +sub message_frag_lens +{ + my $self = shift; + if (@_) { + $self->{message_frag_lens} = shift; + } + return $self->{message_frag_lens}; +} +sub encoded_length +{ + my $self = shift; + return TLS_MESSAGE_HEADER_LENGTH + length($self->data); +} + +1; diff --git a/openssl-1.1.0h/util/perl/TLSProxy/NewSessionTicket.pm b/openssl-1.1.0h/util/perl/TLSProxy/NewSessionTicket.pm new file mode 100644 index 0000000..e509985 --- /dev/null +++ b/openssl-1.1.0h/util/perl/TLSProxy/NewSessionTicket.pm @@ -0,0 +1,81 @@ +# Copyright 2016 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + +use strict; + +package TLSProxy::NewSessionTicket; + +use vars '@ISA'; +push @ISA, 'TLSProxy::Message'; + +sub new +{ + my $class = shift; + my ($server, + $data, + $records, + $startoffset, + $message_frag_lens) = @_; + + my $self = $class->SUPER::new( + $server, + TLSProxy::Message::MT_NEW_SESSION_TICKET, + $data, + $records, + $startoffset, + $message_frag_lens); + + $self->{ticket_lifetime_hint} = 0; + $self->{ticket} = ""; + + return $self; +} + +sub parse +{ + my $self = shift; + + my $ticket_lifetime_hint = unpack('N', $self->data); + my $ticket_len = unpack('n', $self->data); + my $ticket = substr($self->data, 6, $ticket_len); + + $self->ticket_lifetime_hint($ticket_lifetime_hint); + $self->ticket($ticket); +} + + +#Reconstruct the on-the-wire message data following changes +sub set_message_contents +{ + my $self = shift; + my $data; + + $data = pack('N', $self->ticket_lifetime_hint); + $data .= pack('n', length($self->ticket)); + $data .= $self->ticket; + + $self->data($data); +} + +#Read/write accessors +sub ticket_lifetime_hint +{ + my $self = shift; + if (@_) { + $self->{ticket_lifetime_hint} = shift; + } + return $self->{ticket_lifetime_hint}; +} +sub ticket +{ + my $self = shift; + if (@_) { + $self->{ticket} = shift; + } + return $self->{ticket}; +} +1; diff --git a/openssl-1.1.0h/util/perl/TLSProxy/Proxy.pm b/openssl-1.1.0h/util/perl/TLSProxy/Proxy.pm new file mode 100644 index 0000000..de14362 --- /dev/null +++ b/openssl-1.1.0h/util/perl/TLSProxy/Proxy.pm @@ -0,0 +1,553 @@ +# Copyright 2016-2018 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + +use strict; +use POSIX ":sys_wait_h"; + +package TLSProxy::Proxy; + +use File::Spec; +use IO::Socket; +use IO::Select; +use TLSProxy::Record; +use TLSProxy::Message; +use TLSProxy::ClientHello; +use TLSProxy::ServerHello; +use TLSProxy::ServerKeyExchange; +use TLSProxy::NewSessionTicket; +use Time::HiRes qw/usleep/; + +my $have_IPv6 = 0; +my $IP_factory; + +sub new +{ + my $class = shift; + my ($filter, + $execute, + $cert, + $debug) = @_; + + my $self = { + #Public read/write + proxy_addr => "localhost", + proxy_port => 4453, + server_addr => "localhost", + server_port => 4443, + filter => $filter, + serverflags => "", + clientflags => "", + serverconnects => 1, + serverpid => 0, + clientpid => 0, + reneg => 0, + + #Public read + execute => $execute, + cert => $cert, + debug => $debug, + cipherc => "", + ciphers => "AES128-SHA", + flight => -1, + direction => -1, + partial => ["", ""], + record_list => [], + message_list => [], + }; + + # IO::Socket::IP is on the core module list, IO::Socket::INET6 isn't. + # However, IO::Socket::INET6 is older and is said to be more widely + # deployed for the moment, and may have less bugs, so we try the latter + # first, then fall back on the code modules. Worst case scenario, we + # fall back to IO::Socket::INET, only supports IPv4. + eval { + require IO::Socket::INET6; + my $s = IO::Socket::INET6->new( + LocalAddr => "::1", + LocalPort => 0, + Listen=>1, + ); + $s or die "\n"; + $s->close(); + }; + if ($@ eq "") { + $IP_factory = sub { IO::Socket::INET6->new(@_); }; + $have_IPv6 = 1; + } else { + eval { + require IO::Socket::IP; + my $s = IO::Socket::IP->new( + LocalAddr => "::1", + LocalPort => 0, + Listen=>1, + ); + $s or die "\n"; + $s->close(); + }; + if ($@ eq "") { + $IP_factory = sub { IO::Socket::IP->new(@_); }; + $have_IPv6 = 1; + } else { + $IP_factory = sub { IO::Socket::INET->new(@_); }; + } + } + + # Create the Proxy socket + my $proxaddr = $self->{proxy_addr}; + $proxaddr =~ s/[\[\]]//g; # Remove [ and ] + my @proxyargs = ( + LocalHost => $proxaddr, + LocalPort => $self->{proxy_port}, + Proto => "tcp", + Listen => SOMAXCONN, + ); + push @proxyargs, ReuseAddr => 1 + unless $^O eq "MSWin32"; + $self->{proxy_sock} = $IP_factory->(@proxyargs); + + if ($self->{proxy_sock}) { + print "Proxy started on port ".$self->{proxy_port}."\n"; + } else { + warn "Failed creating proxy socket (".$proxaddr.",".$self->{proxy_port}."): $!\n"; + } + + return bless $self, $class; +} + +sub DESTROY +{ + my $self = shift; + + $self->{proxy_sock}->close() if $self->{proxy_sock}; +} + +sub clearClient +{ + my $self = shift; + + $self->{cipherc} = ""; + $self->{flight} = -1; + $self->{direction} = -1; + $self->{partial} = ["", ""]; + $self->{record_list} = []; + $self->{message_list} = []; + $self->{clientflags} = ""; + $self->{clientpid} = 0; + + TLSProxy::Message->clear(); + TLSProxy::Record->clear(); +} + +sub clear +{ + my $self = shift; + + $self->clearClient; + $self->{ciphers} = "AES128-SHA"; + $self->{serverflags} = ""; + $self->{serverconnects} = 1; + $self->{serverpid} = 0; + $self->{reneg} = 0; +} + +sub restart +{ + my $self = shift; + + $self->clear; + $self->start; +} + +sub clientrestart +{ + my $self = shift; + + $self->clear; + $self->clientstart; +} + +sub start +{ + my ($self) = shift; + my $pid; + + if ($self->{proxy_sock} == 0) { + return 0; + } + + $pid = fork(); + if ($pid == 0) { + my $execcmd = $self->execute + ." s_server -max_protocol TLSv1.2 -no_comp -rev -engine ossltest -accept " + .($self->server_port) + ." -cert ".$self->cert." -naccept ".$self->serverconnects; + unless ($self->supports_IPv6) { + $execcmd .= " -4"; + } + if ($self->ciphers ne "") { + $execcmd .= " -cipher ".$self->ciphers; + } + if ($self->serverflags ne "") { + $execcmd .= " ".$self->serverflags; + } + if ($self->debug) { + print STDERR "Server command: $execcmd\n"; + } + exec($execcmd); + } + $self->serverpid($pid); + + return $self->clientstart; +} + +sub clientstart +{ + my ($self) = shift; + my $oldstdout; + + if ($self->execute) { + my $pid = fork(); + if ($pid == 0) { + my $echostr; + if ($self->reneg()) { + $echostr = "R"; + } else { + $echostr = "test"; + } + my $execcmd = "echo ".$echostr." | ".$self->execute + ." s_client -max_protocol TLSv1.2 -engine ossltest -connect " + .($self->proxy_addr).":".($self->proxy_port); + unless ($self->supports_IPv6) { + $execcmd .= " -4"; + } + if ($self->cipherc ne "") { + $execcmd .= " -cipher ".$self->cipherc; + } + if ($self->clientflags ne "") { + $execcmd .= " ".$self->clientflags; + } + if ($self->debug) { + print STDERR "Client command: $execcmd\n"; + } + exec($execcmd); + } + $self->clientpid($pid); + } + + # Wait for incoming connection from client + my $client_sock; + if(!($client_sock = $self->{proxy_sock}->accept())) { + warn "Failed accepting incoming connection: $!\n"; + return 0; + } + + print "Connection opened\n"; + + # Now connect to the server + my $retry = 50; + my $server_sock; + #We loop over this a few times because sometimes s_server can take a while + #to start up + do { + my $servaddr = $self->server_addr; + $servaddr =~ s/[\[\]]//g; # Remove [ and ] + eval { + $server_sock = $IP_factory->( + PeerAddr => $servaddr, + PeerPort => $self->server_port, + MultiHomed => 1, + Proto => 'tcp' + ); + }; + + $retry--; + #Some buggy IP factories can return a defined server_sock that hasn't + #actually connected, so we check peerport too + if ($@ || !defined($server_sock) || !defined($server_sock->peerport)) { + $server_sock->close() if defined($server_sock); + undef $server_sock; + if ($retry) { + #Sleep for a short while + select(undef, undef, undef, 0.1); + } else { + warn "Failed to start up server (".$servaddr.",".$self->server_port."): $!\n"; + return 0; + } + } + } while (!$server_sock); + + my $sel = IO::Select->new($server_sock, $client_sock); + my $indata; + my @handles = ($server_sock, $client_sock); + + #Wait for either the server socket or the client socket to become readable + my @ready; + local $SIG{PIPE} = "IGNORE"; + while(!(TLSProxy::Message->end) && (@ready = $sel->can_read)) { + foreach my $hand (@ready) { + if ($hand == $server_sock) { + $server_sock->sysread($indata, 16384) or goto END; + $indata = $self->process_packet(1, $indata); + $client_sock->syswrite($indata); + } elsif ($hand == $client_sock) { + $client_sock->sysread($indata, 16384) or goto END; + $indata = $self->process_packet(0, $indata); + $server_sock->syswrite($indata); + } else { + print "Err\n"; + goto END; + } + } + } + + END: + print "Connection closed\n"; + if($server_sock) { + $server_sock->close(); + } + if($client_sock) { + #Closing this also kills the child process + $client_sock->close(); + } + if(!$self->debug) { + select($oldstdout); + } + $self->serverconnects($self->serverconnects - 1); + if ($self->serverconnects == 0) { + die "serverpid is zero\n" if $self->serverpid == 0; + print "Waiting for server process to close: " + .$self->serverpid."\n"; + waitpid( $self->serverpid, 0); + die "exit code $? from server process\n" if $? != 0; + } else { + # Give s_server sufficient time to finish what it was doing + usleep(250000); + } + die "clientpid is zero\n" if $self->clientpid == 0; + print "Waiting for client process to close: ".$self->clientpid."\n"; + waitpid($self->clientpid, 0); + + return 1; +} + +sub process_packet +{ + my ($self, $server, $packet) = @_; + my $len_real; + my $decrypt_len; + my $data; + my $recnum; + + if ($server) { + print "Received server packet\n"; + } else { + print "Received client packet\n"; + } + + if ($self->{direction} != $server) { + $self->{flight} = $self->{flight} + 1; + $self->{direction} = $server; + } + + print "Packet length = ".length($packet)."\n"; + print "Processing flight ".$self->flight."\n"; + + #Return contains the list of record found in the packet followed by the + #list of messages in those records and any partial message + my @ret = TLSProxy::Record->get_records($server, $self->flight, $self->{partial}[$server].$packet); + $self->{partial}[$server] = $ret[2]; + push @{$self->record_list}, @{$ret[0]}; + push @{$self->{message_list}}, @{$ret[1]}; + + print "\n"; + + if (scalar(@{$ret[0]}) == 0 or length($ret[2]) != 0) { + return ""; + } + + #Finished parsing. Call user provided filter here + if (defined $self->filter) { + $self->filter->($self); + } + + #Reconstruct the packet + $packet = ""; + foreach my $record (@{$self->record_list}) { + $packet .= $record->reconstruct_record(); + } + + print "Forwarded packet length = ".length($packet)."\n\n"; + + return $packet; +} + +#Read accessors +sub execute +{ + my $self = shift; + return $self->{execute}; +} +sub cert +{ + my $self = shift; + return $self->{cert}; +} +sub debug +{ + my $self = shift; + return $self->{debug}; +} +sub flight +{ + my $self = shift; + return $self->{flight}; +} +sub record_list +{ + my $self = shift; + return $self->{record_list}; +} +sub success +{ + my $self = shift; + return $self->{success}; +} +sub end +{ + my $self = shift; + return $self->{end}; +} +sub supports_IPv6 +{ + my $self = shift; + return $have_IPv6; +} +sub proxy_addr +{ + my $self = shift; + return $self->{proxy_addr}; +} +sub proxy_port +{ + my $self = shift; + return $self->{proxy_port}; +} + +#Read/write accessors +sub server_addr +{ + my $self = shift; + if (@_) { + $self->{server_addr} = shift; + } + return $self->{server_addr}; +} +sub server_port +{ + my $self = shift; + if (@_) { + $self->{server_port} = shift; + } + return $self->{server_port}; +} +sub filter +{ + my $self = shift; + if (@_) { + $self->{filter} = shift; + } + return $self->{filter}; +} +sub cipherc +{ + my $self = shift; + if (@_) { + $self->{cipherc} = shift; + } + return $self->{cipherc}; +} +sub ciphers +{ + my $self = shift; + if (@_) { + $self->{ciphers} = shift; + } + return $self->{ciphers}; +} +sub serverflags +{ + my $self = shift; + if (@_) { + $self->{serverflags} = shift; + } + return $self->{serverflags}; +} +sub clientflags +{ + my $self = shift; + if (@_) { + $self->{clientflags} = shift; + } + return $self->{clientflags}; +} +sub serverconnects +{ + my $self = shift; + if (@_) { + $self->{serverconnects} = shift; + } + return $self->{serverconnects}; +} +# This is a bit ugly because the caller is responsible for keeping the records +# in sync with the updated message list; simply updating the message list isn't +# sufficient to get the proxy to forward the new message. +# But it does the trick for the one test (test_sslsessiontick) that needs it. +sub message_list +{ + my $self = shift; + if (@_) { + $self->{message_list} = shift; + } + return $self->{message_list}; +} +sub serverpid +{ + my $self = shift; + if (@_) { + $self->{serverpid} = shift; + } + return $self->{serverpid}; +} +sub clientpid +{ + my $self = shift; + if (@_) { + $self->{clientpid} = shift; + } + return $self->{clientpid}; +} + +sub fill_known_data +{ + my $length = shift; + my $ret = ""; + for (my $i = 0; $i < $length; $i++) { + $ret .= chr($i); + } + return $ret; +} + +sub reneg +{ + my $self = shift; + if (@_) { + $self->{reneg} = shift; + } + return $self->{reneg}; +} + +1; diff --git a/openssl-1.1.0h/util/perl/TLSProxy/Record.pm b/openssl-1.1.0h/util/perl/TLSProxy/Record.pm new file mode 100644 index 0000000..786ba0c --- /dev/null +++ b/openssl-1.1.0h/util/perl/TLSProxy/Record.pm @@ -0,0 +1,339 @@ +# Copyright 2016-2018 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + +use strict; + +use TLSProxy::Proxy; + +package TLSProxy::Record; + +my $server_ccs_seen = 0; +my $client_ccs_seen = 0; +my $etm = 0; + +use constant TLS_RECORD_HEADER_LENGTH => 5; + +#Record types +use constant { + RT_APPLICATION_DATA => 23, + RT_HANDSHAKE => 22, + RT_ALERT => 21, + RT_CCS => 20, + RT_UNKNOWN => 100 +}; + +my %record_type = ( + RT_APPLICATION_DATA, "APPLICATION DATA", + RT_HANDSHAKE, "HANDSHAKE", + RT_ALERT, "ALERT", + RT_CCS, "CCS", + RT_UNKNOWN, "UNKNOWN" +); + +use constant { + VERS_TLS_1_3 => 772, + VERS_TLS_1_2 => 771, + VERS_TLS_1_1 => 770, + VERS_TLS_1_0 => 769, + VERS_SSL_3_0 => 768, + VERS_SSL_LT_3_0 => 767 +}; + +my %tls_version = ( + VERS_TLS_1_3, "TLS1.3", + VERS_TLS_1_2, "TLS1.2", + VERS_TLS_1_1, "TLS1.1", + VERS_TLS_1_0, "TLS1.0", + VERS_SSL_3_0, "SSL3", + VERS_SSL_LT_3_0, "SSL<3" +); + +#Class method to extract records from a packet of data +sub get_records +{ + my $class = shift; + my $server = shift; + my $flight = shift; + my $packet = shift; + my $partial = ""; + my @record_list = (); + my @message_list = (); + my $data; + my $content_type; + my $version; + my $len; + my $len_real; + my $decrypt_len; + + my $recnum = 1; + while (length ($packet) > 0) { + print " Record $recnum"; + if ($server) { + print " (server -> client)\n"; + } else { + print " (client -> server)\n"; + } + #Get the record header + if (length($packet) < TLS_RECORD_HEADER_LENGTH + || length($packet) < 5 + unpack("n", substr($packet, 3, 2))) { + print "Partial data : ".length($packet)." bytes\n"; + $partial = $packet; + $packet = ""; + } else { + ($content_type, $version, $len) = unpack('CnnC*', $packet); + $data = substr($packet, 5, $len); + + print " Content type: ".$record_type{$content_type}."\n"; + print " Version: $tls_version{$version}\n"; + print " Length: $len"; + if ($len == length($data)) { + print "\n"; + $decrypt_len = $len_real = $len; + } else { + print " (expected), ".length($data)." (actual)\n"; + $decrypt_len = $len_real = length($data); + } + + my $record = TLSProxy::Record->new( + $flight, + $content_type, + $version, + $len, + 0, + $len_real, + $decrypt_len, + substr($packet, TLS_RECORD_HEADER_LENGTH, $len_real), + substr($packet, TLS_RECORD_HEADER_LENGTH, $len_real) + ); + + if (($server && $server_ccs_seen) + || (!$server && $client_ccs_seen)) { + if ($etm) { + $record->decryptETM(); + } else { + $record->decrypt(); + } + } + + push @record_list, $record; + + #Now figure out what messages are contained within this record + my @messages = TLSProxy::Message->get_messages($server, $record); + push @message_list, @messages; + + $packet = substr($packet, TLS_RECORD_HEADER_LENGTH + $len_real); + $recnum++; + } + } + + return (\@record_list, \@message_list, $partial); +} + +sub clear +{ + $server_ccs_seen = 0; + $client_ccs_seen = 0; +} + +#Class level accessors +sub server_ccs_seen +{ + my $class = shift; + if (@_) { + $server_ccs_seen = shift; + } + return $server_ccs_seen; +} +sub client_ccs_seen +{ + my $class = shift; + if (@_) { + $client_ccs_seen = shift; + } + return $client_ccs_seen; +} +#Enable/Disable Encrypt-then-MAC +sub etm +{ + my $class = shift; + if (@_) { + $etm = shift; + } + return $etm; +} + +sub new +{ + my $class = shift; + my ($flight, + $content_type, + $version, + $len, + $sslv2, + $len_real, + $decrypt_len, + $data, + $decrypt_data) = @_; + + my $self = { + flight => $flight, + content_type => $content_type, + version => $version, + len => $len, + sslv2 => $sslv2, + len_real => $len_real, + decrypt_len => $decrypt_len, + data => $data, + decrypt_data => $decrypt_data, + orig_decrypt_data => $decrypt_data, + sent => 0 + }; + + return bless $self, $class; +} + +#Decrypt using encrypt-then-MAC +sub decryptETM +{ + my ($self) = shift; + + my $data = $self->data; + + if($self->version >= VERS_TLS_1_1()) { + #TLS1.1+ has an explicit IV. Throw it away + $data = substr($data, 16); + } + + #Throw away the MAC (assumes MAC is 20 bytes for now. FIXME) + $data = substr($data, 0, length($data) - 20); + + #Find out what the padding byte is + my $padval = unpack("C", substr($data, length($data) - 1)); + + #Throw away the padding + $data = substr($data, 0, length($data) - ($padval + 1)); + + $self->decrypt_data($data); + $self->decrypt_len(length($data)); + + return $data; +} + +#Standard decrypt +sub decrypt() +{ + my ($self) = shift; + + my $data = $self->data; + + if($self->version >= VERS_TLS_1_1()) { + #TLS1.1+ has an explicit IV. Throw it away + $data = substr($data, 16); + } + + #Find out what the padding byte is + my $padval = unpack("C", substr($data, length($data) - 1)); + + #Throw away the padding + $data = substr($data, 0, length($data) - ($padval + 1)); + + #Throw away the MAC (assumes MAC is 20 bytes for now. FIXME) + $data = substr($data, 0, length($data) - 20); + + $self->decrypt_data($data); + $self->decrypt_len(length($data)); + + return $data; +} + +#Reconstruct the on-the-wire record representation +sub reconstruct_record +{ + my $self = shift; + my $data; + + if ($self->{sent}) { + return ""; + } + $self->{sent} = 1; + + if ($self->sslv2) { + $data = pack('n', $self->len | 0x8000); + } else { + $data = pack('Cnn', $self->content_type, $self->version, $self->len); + } + $data .= $self->data; + + return $data; +} + +#Read only accessors +sub flight +{ + my $self = shift; + return $self->{flight}; +} +sub content_type +{ + my $self = shift; + return $self->{content_type}; +} +sub version +{ + my $self = shift; + return $self->{version}; +} +sub sslv2 +{ + my $self = shift; + return $self->{sslv2}; +} +sub len_real +{ + my $self = shift; + return $self->{len_real}; +} +sub orig_decrypt_data +{ + my $self = shift; + return $self->{orig_decrypt_data}; +} + +#Read/write accessors +sub decrypt_len +{ + my $self = shift; + if (@_) { + $self->{decrypt_len} = shift; + } + return $self->{decrypt_len}; +} +sub data +{ + my $self = shift; + if (@_) { + $self->{data} = shift; + } + return $self->{data}; +} +sub decrypt_data +{ + my $self = shift; + if (@_) { + $self->{decrypt_data} = shift; + } + return $self->{decrypt_data}; +} +sub len +{ + my $self = shift; + if (@_) { + $self->{len} = shift; + } + return $self->{len}; +} +1; diff --git a/openssl-1.1.0h/util/perl/TLSProxy/ServerHello.pm b/openssl-1.1.0h/util/perl/TLSProxy/ServerHello.pm new file mode 100644 index 0000000..79a8be9 --- /dev/null +++ b/openssl-1.1.0h/util/perl/TLSProxy/ServerHello.pm @@ -0,0 +1,210 @@ +# Copyright 2016 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + +use strict; + +package TLSProxy::ServerHello; + +use vars '@ISA'; +push @ISA, 'TLSProxy::Message'; + +sub new +{ + my $class = shift; + my ($server, + $data, + $records, + $startoffset, + $message_frag_lens) = @_; + + my $self = $class->SUPER::new( + $server, + TLSProxy::Message::MT_SERVER_HELLO, + $data, + $records, + $startoffset, + $message_frag_lens); + + $self->{server_version} = 0; + $self->{random} = []; + $self->{session_id_len} = 0; + $self->{session} = ""; + $self->{ciphersuite} = 0; + $self->{comp_meth} = 0; + $self->{extension_data} = ""; + + return $self; +} + +sub parse +{ + my $self = shift; + my $ptr = 2; + my ($server_version) = unpack('n', $self->data); + my $random = substr($self->data, $ptr, 32); + $ptr += 32; + my $session_id_len = unpack('C', substr($self->data, $ptr)); + $ptr++; + my $session = substr($self->data, $ptr, $session_id_len); + $ptr += $session_id_len; + my $ciphersuite = unpack('n', substr($self->data, $ptr)); + $ptr += 2; + my $comp_meth = unpack('C', substr($self->data, $ptr)); + $ptr++; + my $extensions_len = unpack('n', substr($self->data, $ptr)); + if (!defined $extensions_len) { + $extensions_len = 0; + } else { + $ptr += 2; + } + #For now we just deal with this as a block of data. In the future we will + #want to parse this + my $extension_data; + if ($extensions_len != 0) { + $extension_data = substr($self->data, $ptr); + + if (length($extension_data) != $extensions_len) { + die "Invalid extension length\n"; + } + } else { + if (length($self->data) != $ptr) { + die "Invalid extension length\n"; + } + $extension_data = ""; + } + my %extensions = (); + while (length($extension_data) >= 4) { + my ($type, $size) = unpack("nn", $extension_data); + my $extdata = substr($extension_data, 4, $size); + $extension_data = substr($extension_data, 4 + $size); + $extensions{$type} = $extdata; + } + + $self->server_version($server_version); + $self->random($random); + $self->session_id_len($session_id_len); + $self->session($session); + $self->ciphersuite($ciphersuite); + $self->comp_meth($comp_meth); + $self->extension_data(\%extensions); + + $self->process_data(); + + print " Server Version:".$server_version."\n"; + print " Session ID Len:".$session_id_len."\n"; + print " Ciphersuite:".$ciphersuite."\n"; + print " Compression Method:".$comp_meth."\n"; + print " Extensions Len:".$extensions_len."\n"; +} + +#Perform any actions necessary based on the data we've seen +sub process_data +{ + my $self = shift; + + TLSProxy::Message->ciphersuite($self->ciphersuite); +} + +#Reconstruct the on-the-wire message data following changes +sub set_message_contents +{ + my $self = shift; + my $data; + my $extensions = ""; + + $data = pack('n', $self->server_version); + $data .= $self->random; + $data .= pack('C', $self->session_id_len); + $data .= $self->session; + $data .= pack('n', $self->ciphersuite); + $data .= pack('C', $self->comp_meth); + + foreach my $key (keys %{$self->extension_data}) { + my $extdata = ${$self->extension_data}{$key}; + $extensions .= pack("n", $key); + $extensions .= pack("n", length($extdata)); + $extensions .= $extdata; + if ($key == TLSProxy::Message::EXT_DUPLICATE_EXTENSION) { + $extensions .= pack("n", $key); + $extensions .= pack("n", length($extdata)); + $extensions .= $extdata; + } + } + + $data .= pack('n', length($extensions)); + $data .= $extensions; + $self->data($data); +} + +#Read/write accessors +sub server_version +{ + my $self = shift; + if (@_) { + $self->{client_version} = shift; + } + return $self->{client_version}; +} +sub random +{ + my $self = shift; + if (@_) { + $self->{random} = shift; + } + return $self->{random}; +} +sub session_id_len +{ + my $self = shift; + if (@_) { + $self->{session_id_len} = shift; + } + return $self->{session_id_len}; +} +sub session +{ + my $self = shift; + if (@_) { + $self->{session} = shift; + } + return $self->{session}; +} +sub ciphersuite +{ + my $self = shift; + if (@_) { + $self->{ciphersuite} = shift; + } + return $self->{ciphersuite}; +} +sub comp_meth +{ + my $self = shift; + if (@_) { + $self->{comp_meth} = shift; + } + return $self->{comp_meth}; +} +sub extension_data +{ + my $self = shift; + if (@_) { + $self->{extension_data} = shift; + } + return $self->{extension_data}; +} +sub set_extension +{ + my ($self, $ext_type, $ext_data) = @_; + $self->{extension_data}{$ext_type} = $ext_data; +} +sub delete_extension +{ + my ($self, $ext_type) = @_; + delete $self->{extension_data}{$ext_type}; +} +1; diff --git a/openssl-1.1.0h/util/perl/TLSProxy/ServerKeyExchange.pm b/openssl-1.1.0h/util/perl/TLSProxy/ServerKeyExchange.pm new file mode 100644 index 0000000..6e5b4cd --- /dev/null +++ b/openssl-1.1.0h/util/perl/TLSProxy/ServerKeyExchange.pm @@ -0,0 +1,134 @@ +# Copyright 2016 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + +use strict; + +package TLSProxy::ServerKeyExchange; + +use vars '@ISA'; +push @ISA, 'TLSProxy::Message'; + +sub new +{ + my $class = shift; + my ($server, + $data, + $records, + $startoffset, + $message_frag_lens) = @_; + + my $self = $class->SUPER::new( + $server, + TLSProxy::Message::MT_SERVER_KEY_EXCHANGE, + $data, + $records, + $startoffset, + $message_frag_lens); + + #DHE + $self->{p} = ""; + $self->{g} = ""; + $self->{pub_key} = ""; + $self->{sig} = ""; + + return $self; +} + +sub parse +{ + my $self = shift; + + #Minimal SKE parsing. Only supports DHE at the moment (if its not DHE + #the parsing data will be trash...which is ok as long as we don't try to + #use it) + + my $p_len = unpack('n', $self->data); + my $ptr = 2; + my $p = substr($self->data, $ptr, $p_len); + $ptr += $p_len; + + my $g_len = unpack('n', substr($self->data, $ptr)); + $ptr += 2; + my $g = substr($self->data, $ptr, $g_len); + $ptr += $g_len; + + my $pub_key_len = unpack('n', substr($self->data, $ptr)); + $ptr += 2; + my $pub_key = substr($self->data, $ptr, $pub_key_len); + $ptr += $pub_key_len; + + #We assume its signed + my $sig_len = unpack('n', substr($self->data, $ptr)); + my $sig = ""; + if (defined $sig_len) { + $ptr += 2; + $sig = substr($self->data, $ptr, $sig_len); + $ptr += $sig_len; + } + + $self->p($p); + $self->g($g); + $self->pub_key($pub_key); + $self->sig($sig); +} + + +#Reconstruct the on-the-wire message data following changes +sub set_message_contents +{ + my $self = shift; + my $data; + + $data = pack('n', length($self->p)); + $data .= $self->p; + $data .= pack('n', length($self->g)); + $data .= $self->g; + $data .= pack('n', length($self->pub_key)); + $data .= $self->pub_key; + if (length($self->sig) > 0) { + $data .= pack('n', length($self->sig)); + $data .= $self->sig; + } + + $self->data($data); +} + +#Read/write accessors +#DHE +sub p +{ + my $self = shift; + if (@_) { + $self->{p} = shift; + } + return $self->{p}; +} +sub g +{ + my $self = shift; + if (@_) { + $self->{g} = shift; + } + return $self->{g}; +} +sub pub_key +{ + my $self = shift; + if (@_) { + $self->{pub_key} = shift; + } + return $self->{pub_key}; +} +sub sig +{ + my $self = shift; + if (@_) { + $self->{sig} = shift; + } + return $self->{sig}; +} +1; diff --git a/openssl-1.1.0h/util/perl/with_fallback.pm b/openssl-1.1.0h/util/perl/with_fallback.pm new file mode 100644 index 0000000..2af1d5f --- /dev/null +++ b/openssl-1.1.0h/util/perl/with_fallback.pm @@ -0,0 +1,25 @@ +# Copyright 2016 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the OpenSSL license (the "License"). You may not use +# this file except in compliance with the License. You can obtain a copy +# in the file LICENSE in the source distribution or at +# https://www.openssl.org/source/license.html + +package with_fallback; + +sub import { + use File::Basename; + use File::Spec::Functions; + foreach (@_) { + eval "require $_"; + if ($@) { + unshift @INC, catdir(dirname(__FILE__), + "..", "..", "external", "perl"); + my $transfer = "transfer::$_"; + eval "require $transfer"; + shift @INC; + warn $@ if $@; + } + } +} +1; -- cgit v1.2.3