diff options
Diffstat (limited to 'roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl')
19 files changed, 5021 insertions, 0 deletions
diff --git a/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/OpenSSL/Glob.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/OpenSSL/Glob.pm new file mode 100644 index 000000000..ec87da4ae --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/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/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/OpenSSL/Test.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/OpenSSL/Test.pm new file mode 100644 index 000000000..0df6ad0a5 --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/OpenSSL/Test.pm @@ -0,0 +1,1217 @@ +# Copyright 2016-2020 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 run indir cmd app fuzz test + perlapp perltest subtest)); +@EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file + srctop_dir srctop_file + data_file data_dir + pipe with cmdstr quotify + openssl_versions)); + +=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<Test::More> 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<depends> on the environment variables C<$TOP> or C<$SRCTOP> +and C<$BLDTOP>. Without one of the combinations it refuses to work. +See L</ENVIRONMENT> 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; +use Cwd qw/getcwd abs_path/; + +my $level = 0; + +# 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 status value that run() + # will give back (through the |statusvar| reference and as returned value + # when capture => 1 doesn't apply). + exit_checker => sub { return shift == 0 ? 1 : 0 }, + + ); + +# Debug flag, to be set manually when needed +my $debug = 0; + +=head2 Main functions + +The following functions are exported by default when using C<OpenSSL::Test>. + +=cut + +=over 4 + +=item B<setup "NAME"> + +C<setup> 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<setup> checks for environment variables (see L</ENVIRONMENT> below), +checks that C<$TOP/Configure> or C<$SRCTOP/Configure> exists, C<chdir> +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<indir "SUBDIR" =E<gt> sub BLOCK, OPTS> + +C<indir> is used to run a part of the recipe in a different directory than +the one C<setup> moved into, usually a subdirectory, given by SUBDIR. +The part of the recipe that's run there is given by the codeblock BLOCK. + +C<indir> takes some additional options OPTS that affect the subdirectory: + +=over 4 + +=item B<create =E<gt> 0|1> + +When set to 1 (or any value that perl perceives as true), the subdirectory +will be created if it doesn't already exist. This happens before BLOCK +is executed. + +=item B<cleanup =E<gt> 0|1> + +When set to 1 (or any value that perl perceives 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 = <RESULT>; + 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<cmd ARRAYREF, OPTS> + +This functions build up a platform dependent command based on the +input. It takes a reference to a list that is the executable or +script and its arguments, and some additional options (described +further on). Where necessary, the command will be wrapped in a +suitable environment to make sure the correct shared libraries are +used (currently only on Unix). + +It returns a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>. + +The options that C<cmd> can take are in the form of hash values: + +=over 4 + +=item B<stdin =E<gt> PATH> + +=item B<stdout =E<gt> PATH> + +=item B<stderr =E<gt> 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<or>, if the value is C<undef>, C</dev/null> or similar. + +=back + +=item B<app ARRAYREF, OPTS> + +=item B<test ARRAYREF, OPTS> + +Both of these are specific applications of C<cmd>, with just a couple +of small difference: + +C<app> 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<test> 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>). + +Also, for both C<app> and C<test>, the command may be prefixed with +the content of the environment variable C<$EXE_SHELL>, which is useful +in case OpenSSL has been cross compiled. + +=item B<perlapp ARRAYREF, OPTS> + +=item B<perltest ARRAYREF, OPTS> + +These are also specific applications of C<cmd>, where the interpreter +is predefined to be C<perl>, and they expect the script to be +interpreted to reside in the same location as C<app> and C<test>. + +C<perlapp> and C<perltest> will also take the following option: + +=over 4 + +=item B<interpreter_args =E<gt> ARRAYref> + +The array reference is a set of arguments for the interpreter 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 + +=begin comment + +One might wonder over the complexity of C<apps>, C<fuzz>, C<test>, ... +with all the lazy evaluations and all that. The reason for this is that +we want to make sure the directory in which those programs are found are +correct at the time these commands are used. Consider the following code +snippet: + + my $cmd = app(["openssl", ...]); + + indir "foo", sub { + ok(run($cmd), "Testing foo") + }; + +If there wasn't this lazy evaluation, the directory where C<openssl> is +found would be incorrect at the time C<run> is called, because it was +calculated before we moved into the directory "foo". + +=end comment + +=cut + +sub cmd { + my $cmd = shift; + my %opts = @_; + return sub { + my $num = shift; + # Make a copy to not destroy the caller's array + my @cmdargs = ( @$cmd ); + my @prog = __wrap_cmd(shift @cmdargs, $opts{exe_shell} // ()); + + return __decorate_cmd($num, [ @prog, quotify(@cmdargs) ], + %opts); + } +} + +sub app { + my $cmd = shift; + my %opts = @_; + return sub { + my @cmdargs = ( @{$cmd} ); + my @prog = __fixup_prg(__apps_file(shift @cmdargs, __exeext())); + return cmd([ @prog, @cmdargs ], + exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift); + } +} + +sub fuzz { + my $cmd = shift; + my %opts = @_; + return sub { + my @cmdargs = ( @{$cmd} ); + my @prog = __fixup_prg(__fuzz_file(shift @cmdargs, __exeext())); + return cmd([ @prog, @cmdargs ], + exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift); + } +} + +sub test { + my $cmd = shift; + my %opts = @_; + return sub { + my @cmdargs = ( @{$cmd} ); + my @prog = __fixup_prg(__test_file(shift @cmdargs, __exeext())); + return cmd([ @prog, @cmdargs ], + exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift); + } +} + +sub perlapp { + my $cmd = shift; + my %opts = @_; + return sub { + my @interpreter_args = defined $opts{interpreter_args} ? + @{$opts{interpreter_args}} : (); + my @interpreter = __fixup_prg($^X); + my @cmdargs = ( @{$cmd} ); + my @prog = __apps_file(shift @cmdargs, undef); + return cmd([ @interpreter, @interpreter_args, + @prog, @cmdargs ], %opts) -> (shift); + } +} + +sub perltest { + my $cmd = shift; + my %opts = @_; + return sub { + my @interpreter_args = defined $opts{interpreter_args} ? + @{$opts{interpreter_args}} : (); + my @interpreter = __fixup_prg($^X); + my @cmdargs = ( @{$cmd} ); + my @prog = __test_file(shift @cmdargs, undef); + return cmd([ @interpreter, @interpreter_args, + @prog, @cmdargs ], %opts) -> (shift); + } +} + +=over 4 + +=item B<run CODEREF, OPTS> + +CODEREF is expected to be the value return by C<cmd> or any of its +derivatives, anything else will most likely cause an error unless you +know what you're doing. + +C<run> executes the command returned by CODEREF and return either the +resulting output (if the option C<capture> is set true) or a boolean +indicating if the command succeeded or not. + +The options that C<run> can take are in the form of hash values: + +=over 4 + +=item B<capture =E<gt> 0|1> + +If true, the command will be executed with a perl backtick, and C<run> will +return the resulting output as an array of lines. If false or not given, +the command will be executed with C<system()>, and C<run> will return 1 if +the command was successful or 0 if it wasn't. + +=item B<prefix =E<gt> EXPR> + +If specified, EXPR will be used as a string to prefix the output from the +command. This is useful if the output contains lines starting with C<ok > +or C<not ok > that can disturb Test::Harness. + +=item B<statusvar =E<gt> VARREF> + +If used, B<VARREF> must be a reference to a scalar variable. It will be +assigned a boolean indicating if the command succeeded or not. This is +particularly useful together with B<capture>. + +=back + +For further discussion on what is considered a successful command or not, see +the function C<with> 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; + + die "OpenSSL::Test::run(): statusvar value not a scalar reference" + if $opts{statusvar} && ref($opts{statusvar}) ne "SCALAR"; + + # 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(); + } + + $ENV{HARNESS_OSSL_LEVEL} = $level + 1; + + # 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} || defined($opts{prefix})) { + my $pipe; + local $_; + + open($pipe, '-|', "$prefix$cmd") or die "Can't start command: $!"; + while(<$pipe>) { + my $l = ($opts{prefix} // "") . $_; + if ($opts{capture}) { + push @r, $l; + } else { + print STDOUT $l; + } + } + close $pipe; + } else { + $ENV{HARNESS_OSSL_PREFIX} = "# "; + system("$prefix$cmd"); + delete $ENV{HARNESS_OSSL_PREFIX}; + } + $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8); + $r = $hooks{exit_checker}->($e); + if ($opts{statusvar}) { + ${$opts{statusvar}} = $r; + } + + 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<OpenSSL::Test>. + + # 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<bldtop_dir LIST> + +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<bldtop_dir> 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<bldtop_file LIST, FILENAME> + +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<bldtop_file> 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<srctop_dir LIST> + +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<srctop_dir> 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<srctop_file LIST, FILENAME> + +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<srctop_file> 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<data_dir LIST> + +LIST is a list of directories that make up a path from the data directory +associated with the test (see L</DESCRIPTION> above). +C<data_dir> returns the resulting directory as a string, adapted to the local +operating system. + +=back + +=cut + +sub data_dir { + return __data_dir(@_); +} + +=over 4 + +=item B<data_file LIST, FILENAME> + +LIST is a list of directories that make up a path from the data directory +associated with the test (see L</DESCRIPTION> above) and FILENAME is the name +of a file located in that directory path. C<data_file> 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<pipe LIST> + +LIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe> +creates a new command composed of all the given commands put together in a +pipe. C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>, +to be passed to C<run> 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<with HASHREF, CODEREF> + +C<with> will temporarily 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<exit_checker =E<gt> CODEREF> + +This hook is executed after C<run> 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<cmdstr CODEREF, OPTS> + +C<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the +command as a string. + +C<cmdstr> takes some additional options OPTS that affect the string returned: + +=over 4 + +=item B<display =E<gt> 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<quotify LIST> + +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<This must never ever be done on VMS.> + +=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->($_) } @_; +} + +=over 4 + +=item B<openssl_versions> + +Returns a list of two numbers, the first representing the build version, +the second representing the library version. See opensslv.h for more +information on those numbers. + +=back + +=cut + +my @versions = (); +sub openssl_versions { + unless (@versions) { + my %lines = + map { s/\R$//; + /^(.*): (0x[[:xdigit:]]{8})$/; + die "Weird line: $_" unless defined $1; + $1 => hex($2) } + run(test(['versions']), capture => 1); + @versions = ( $lines{'Build version'}, $lines{'Library version'} ); + } + return @versions; +} + +###################################################################### +# private functions. These are never exported. + +=head1 ENVIRONMENT + +OpenSSL::Test depends on some environment variables. + +=over 4 + +=item B<TOP> + +This environment variable is mandatory. C<setup> will check that it's +defined and that it's a directory that contains the file C<Configure>. +If this isn't so, C<setup> will C<BAIL_OUT>. + +=item B<BIN_D> + +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<TEST_D> + +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<STOPTEST> + +If defined, it puts testing in a different mode, where a recipe with +failures will result in a C<BAIL_OUT> at the end of its run. + +=back + +=cut + +sub __env { + (my $recipe_datadir = basename($0)) =~ s/\.t$/_data/i; + + $directories{SRCTOP} = abs_path($ENV{SRCTOP} || $ENV{TOP}); + $directories{BLDTOP} = abs_path($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; +}; + +# __srctop_file and __srctop_dir are helpers to build file and directory +# names on top of the source directory. They depend on $SRCTOP, and +# therefore on the proper use of setup() and when needed, indir(). +# __bldtop_file and __bldtop_dir do the same thing but relative to $BLDTOP. +# __srctop_file and __bldtop_file take the same kind of argument as +# File::Spec::Functions::catfile. +# Similarly, __srctop_dir and __bldtop_dir take the same kind of argument +# as File::Spec::Functions::catdir +sub __srctop_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + return abs2rel(catfile($directories{SRCTOP},@_,$f),getcwd); +} + +sub __srctop_dir { + BAIL_OUT("Must run setup() first") if (! $test_name); + + return abs2rel(catdir($directories{SRCTOP},@_), getcwd); +} + +sub __bldtop_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + return abs2rel(catfile($directories{BLDTOP},@_,$f), getcwd); +} + +sub __bldtop_dir { + BAIL_OUT("Must run setup() first") if (! $test_name); + + return abs2rel(catdir($directories{BLDTOP},@_), getcwd); +} + +# __exeext is a function that returns the platform dependent file extension +# for executable binaries, or the value of the environment variable $EXE_EXT +# if that one is defined. +sub __exeext { + my $ext = ""; + if ($^O eq "VMS" ) { # VMS + $ext = ".exe"; + } elsif ($^O eq "MSWin32") { # Windows + $ext = ".exe"; + } + return $ENV{"EXE_EXT"} || $ext; +} + +# __test_file, __apps_file and __fuzz_file return the full path to a file +# relative to the test/, apps/ or fuzz/ directory in the build tree or the +# source tree, depending on where the file is found. Note that when looking +# in the build tree, the file name with an added extension is looked for, if +# an extension is given. The intent is to look for executable binaries (in +# the build tree) or possibly scripts (in the source tree). +# These functions all take the same arguments as File::Spec::Functions::catfile, +# *plus* a mandatory extension argument. This extension argument can be undef, +# and is ignored in such a case. +sub __test_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $e = pop || ""; + my $f = pop; + my $out = catfile($directories{BLDTEST},@_,$f . $e); + $out = catfile($directories{SRCTEST},@_,$f) unless -f $out; + return $out; +} + +sub __apps_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $e = pop || ""; + my $f = pop; + my $out = catfile($directories{BLDAPPS},@_,$f . $e); + $out = catfile($directories{SRCAPPS},@_,$f) unless -f $out; + return $out; +} + +sub __fuzz_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $e = pop || ""; + my $f = pop; + my $out = catfile($directories{BLDFUZZ},@_,$f . $e); + $out = catfile($directories{SRCFUZZ},@_,$f) unless -f $out; + return $out; +} + +sub __data_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + return catfile($directories{SRCDATA},@_,$f); +} + +sub __data_dir { + BAIL_OUT("Must run setup() first") if (! $test_name); + + return catdir($directories{SRCDATA},@_); +} + +sub __results_file { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $f = pop; + return catfile($directories{RESULTS},@_,$f); +} + +# __cwd DIR +# __cwd DIR, OPTS +# +# __cwd changes directory to DIR (string) and changes all the relative +# entries in %directories accordingly. OPTS is an optional series of +# hash style arguments to alter __cwd's behavior: +# +# create = 0|1 The directory we move to is created if 1, not if 0. +# cleanup = 0|1 The directory we move from is removed if 1, not if 0. + +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_directories ) + # 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; +} + +# __wrap_cmd CMD +# __wrap_cmd CMD, EXE_SHELL +# +# __wrap_cmd "wraps" CMD (string) with a beginning command that makes sure +# the command gets executed with an appropriate environment. If EXE_SHELL +# is given, it is used as the beginning command. +# +# __wrap_cmd returns a list that should be used to build up a larger list +# of command tokens, or be joined together like this: +# +# join(" ", __wrap_cmd($cmd)) +sub __wrap_cmd { + my $cmd = shift; + my $exe_shell = shift; + + my @prefix = ( __bldtop_file("util", "shlib_wrap.sh") ); + + if(defined($exe_shell)) { + @prefix = ( $exe_shell ); + } elsif ($^O eq "VMS" || $^O eq "MSWin32") { + # VMS and Windows don't use any wrapper script for the moment + @prefix = (); + } + + return (@prefix, $cmd); +} + +# __fixup_prg PROG +# +# __fixup_prg does whatever fixup is needed to execute an executable binary +# given by PROG (string). +# +# __fixup_prg returns a string with the possibly prefixed program path spec. +sub __fixup_prg { + my $prog = shift; + + my $prefix = ""; + + if ($^O eq "VMS" ) { + $prefix = ($prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i ? "mcr " : "mcr []"); + } + + 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; +} + +# __decorate_cmd NUM, CMDARRAYREF +# +# __decorate_cmd takes a command number NUM and a command token array +# CMDARRAYREF, builds up a command string from them and decorates it +# with necessary redirections. +# __decorate_cmd returns a list of two strings, one with the command +# string to actually be used, the other to be displayed for the user. +# The reason these strings might differ is that we redirect stderr to +# the null device unless we're verbose and unless the user has +# explicitly specified a stderr redirection. +sub __decorate_cmd { + BAIL_OUT("Must run setup() first") if (! $test_name); + + my $num = shift; + my $cmd = shift; + my %opts = @_; + + my $cmdstr = join(" ", @$cmd); + my $null = devnull(); + 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 = "$cmdstr$stdin$stdout$stderr"; + + $stderr=" 2> ".$null + unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE}; + + $cmdstr .= "$stdin$stdout$stderr"; + + if ($debug) { + print STDERR "DEBUG[__decorate_cmd]: \$cmdstr = \"$cmdstr\"\n"; + print STDERR "DEBUG[__decorate_cmd]: \$display_cmd = \"$display_cmd\"\n"; + } + + return ($cmdstr, $display_cmd); +} + +=head1 SEE ALSO + +L<Test::More>, L<Test::Harness> + +=head1 AUTHORS + +Richard Levitte E<lt>levitte@openssl.orgE<gt> with assistance and +inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>. + +=cut + +no warnings 'redefine'; +sub subtest { + $level++; + + Test::More::subtest @_; + + $level--; +}; + +1; diff --git a/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/OpenSSL/Test/Simple.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/OpenSSL/Test/Simple.pm new file mode 100644 index 000000000..c5a84d5ca --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/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<OpenSSL::Test> 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<simple_test NAME, PROGRAM, ALGORITHM> + +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<OpenSSL::Test> + +=head1 AUTHORS + +Richard Levitte E<lt>levitte@openssl.orgE<gt> with inspiration +from Rich Salz E<lt>rsalz@openssl.orgE<gt>. + +=cut + +1; diff --git a/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/OpenSSL/Test/Utils.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/OpenSSL/Test/Utils.pm new file mode 100644 index 000000000..7b0a70563 --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/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<available_protocols STRING> + +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<alldisabled> and B<anydisabled>. + +=item B<alldisabled ARRAY> +=item B<anydisabled ARRAY> + +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<config STRING> + +Returns an item from the %config hash in \$TOP/configdata.pm. + +=item B<have_IPv4> +=item B<have_IPv6> + +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<OpenSSL::Test> + +=head1 AUTHORS + +Stephen Henson E<lt>steve@openssl.orgE<gt> and +Richard Levitte E<lt>levitte@openssl.orgE<gt> + +=cut + +1; diff --git a/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/OpenSSL/Util/Pod.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/OpenSSL/Util/Pod.pm new file mode 100644 index 000000000..9f76fbf1a --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/OpenSSL/Util/Pod.pm @@ -0,0 +1,149 @@ +# 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<extract_pod_info "FILENAME", HASHREF> + +=item B<extract_pod_info "FILENAME"> + +=item B<extract_pod_info GLOB, HASHREF> + +=item B<extract_pod_info GLOB> + +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<section =E<gt> N> + +The value MUST be a number, and will be the man section number +to be used with the given .pod file. + +=item B<debug =E<gt> 0|1> + +If set to 1, extra debug text will be printed on STDERR + +=back + +=back + +=head1 RETURN VALUES + +=over + +=item B<extract_pod_info> returns a hash table with the following +items: + +=over + +=item B<section =E<gt> N> + +The man section number this .pod file belongs to. Often the same as +was given as input. + +=item B<names =E<gt> [ "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$||; + # 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/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Alert.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Alert.pm new file mode 100644 index 000000000..e27497dbd --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Alert.pm @@ -0,0 +1,51 @@ +# Copyright 2018-2019 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::Alert; + +sub new +{ + my $class = shift; + my ($server, + $encrypted, + $level, + $description) = @_; + + my $self = { + server => $server, + encrypted => $encrypted, + level => $level, + description => $description + }; + + return bless $self, $class; +} + +#Read only accessors +sub server +{ + my $self = shift; + return $self->{server}; +} +sub encrypted +{ + my $self = shift; + return $self->{encrypted}; +} +sub level +{ + my $self = shift; + return $self->{level}; +} +sub description +{ + my $self = shift; + return $self->{description}; +} +1; diff --git a/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Certificate.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Certificate.pm new file mode 100644 index 000000000..73737137b --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Certificate.pm @@ -0,0 +1,214 @@ +# Copyright 2016-2019 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::Certificate; + +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_CERTIFICATE, + $data, + $records, + $startoffset, + $message_frag_lens); + + $self->{first_certificate} = ""; + $self->{extension_data} = ""; + $self->{remaining_certdata} = ""; + + return $self; +} + +sub parse +{ + my $self = shift; + + if (TLSProxy::Proxy->is_tls13()) { + my $context_len = unpack('C', $self->data); + my $context = substr($self->data, 1, $context_len); + + my $remdata = substr($self->data, 1 + $context_len); + + my ($hicertlistlen, $certlistlen) = unpack('Cn', $remdata); + $certlistlen += ($hicertlistlen << 16); + + $remdata = substr($remdata, 3); + + die "Invalid Certificate List length" + if length($remdata) != $certlistlen; + + my ($hicertlen, $certlen) = unpack('Cn', $remdata); + $certlen += ($hicertlen << 16); + + die "Certificate too long" if ($certlen + 3) > $certlistlen; + + $remdata = substr($remdata, 3); + + my $certdata = substr($remdata, 0, $certlen); + + $remdata = substr($remdata, $certlen); + + my $extensions_len = unpack('n', $remdata); + $remdata = substr($remdata, 2); + + die "Extensions too long" + if ($certlen + 3 + $extensions_len + 2) > $certlistlen; + + my $extension_data = ""; + if ($extensions_len != 0) { + $extension_data = substr($remdata, 0, $extensions_len); + + 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; + } + $remdata = substr($remdata, $extensions_len); + + $self->context($context); + $self->first_certificate($certdata); + $self->extension_data(\%extensions); + $self->remaining_certdata($remdata); + + print " Context:".$context."\n"; + print " Certificate List Len:".$certlistlen."\n"; + print " Certificate Len:".$certlen."\n"; + print " Extensions Len:".$extensions_len."\n"; + } else { + my ($hicertlistlen, $certlistlen) = unpack('Cn', $self->data); + $certlistlen += ($hicertlistlen << 16); + + my $remdata = substr($self->data, 3); + + die "Invalid Certificate List length" + if length($remdata) != $certlistlen; + + my ($hicertlen, $certlen) = unpack('Cn', $remdata); + $certlen += ($hicertlen << 16); + + die "Certificate too long" if ($certlen + 3) > $certlistlen; + + $remdata = substr($remdata, 3); + + my $certdata = substr($remdata, 0, $certlen); + + $remdata = substr($remdata, $certlen); + + $self->first_certificate($certdata); + $self->remaining_certdata($remdata); + + print " Certificate List Len:".$certlistlen."\n"; + print " Certificate Len:".$certlen."\n"; + } +} + +#Reconstruct the on-the-wire message data following changes +sub set_message_contents +{ + my $self = shift; + my $data; + my $extensions = ""; + + if (TLSProxy::Proxy->is_tls13()) { + foreach my $key (keys %{$self->extension_data}) { + my $extdata = ${$self->extension_data}{$key}; + $extensions .= pack("n", $key); + $extensions .= pack("n", length($extdata)); + $extensions .= $extdata; + } + $data = pack('C', length($self->context())); + $data .= $self->context; + my $certlen = length($self->first_certificate); + my $certlistlen = $certlen + length($extensions) + + length($self->remaining_certdata); + my $hi = $certlistlen >> 16; + $certlistlen = $certlistlen & 0xffff; + $data .= pack('Cn', $hi, $certlistlen); + $hi = $certlen >> 16; + $certlen = $certlen & 0xffff; + $data .= pack('Cn', $hi, $certlen); + $data .= pack('n', length($extensions)); + $data .= $extensions; + $data .= $self->remaining_certdata(); + $self->data($data); + } else { + my $certlen = length($self->first_certificate); + my $certlistlen = $certlen + length($self->remaining_certdata); + my $hi = $certlistlen >> 16; + $certlistlen = $certlistlen & 0xffff; + $data .= pack('Cn', $hi, $certlistlen); + $hi = $certlen >> 16; + $certlen = $certlen & 0xffff; + $data .= pack('Cn', $hi, $certlen); + $data .= $self->remaining_certdata(); + $self->data($data); + } +} + +#Read/write accessors +sub context +{ + my $self = shift; + if (@_) { + $self->{context} = shift; + } + return $self->{context}; +} +sub first_certificate +{ + my $self = shift; + if (@_) { + $self->{first_certificate} = shift; + } + return $self->{first_certificate}; +} +sub remaining_certdata +{ + my $self = shift; + if (@_) { + $self->{remaining_certdata} = shift; + } + return $self->{remaining_certdata}; +} +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/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/CertificateRequest.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/CertificateRequest.pm new file mode 100644 index 000000000..bc4105335 --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/CertificateRequest.pm @@ -0,0 +1,105 @@ +# Copyright 2016-2019 The OpenSSL Project Authors. All Rights Reserved. +# +# Licensed under the Apache License 2.0 (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::CertificateRequest; + +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_CERTIFICATE_REQUEST, + $data, + $records, + $startoffset, + $message_frag_lens); + + $self->{extension_data} = ""; + + return $self; +} + +sub parse +{ + my $self = shift; + my $ptr = 1; + + if (TLSProxy::Proxy->is_tls13()) { + my $request_ctx_len = unpack('C', $self->data); + my $request_ctx = substr($self->data, $ptr, $request_ctx_len); + $ptr += $request_ctx_len; + + my $extensions_len = unpack('n', substr($self->data, $ptr)); + $ptr += 2; + 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->extension_data(\%extensions); + + print " Extensions Len:".$extensions_len."\n"; + } + # else parse TLSv1.2 version - we don't support that at the moment +} + +#Reconstruct the on-the-wire message data following changes +sub set_message_contents +{ + my $self = shift; + my $data; + my $extensions = ""; + + foreach my $key (keys %{$self->extension_data}) { + my $extdata = ${$self->extension_data}{$key}; + $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 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/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/CertificateVerify.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/CertificateVerify.pm new file mode 100644 index 000000000..8bf969fba --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/CertificateVerify.pm @@ -0,0 +1,96 @@ +# 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::CertificateVerify; + +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_CERTIFICATE_VERIFY, + $data, + $records, + $startoffset, + $message_frag_lens); + + $self->{sigalg} = -1; + $self->{signature} = ""; + + return $self; +} + +sub parse +{ + my $self = shift; + + my $sigalg = -1; + my $remdata = $self->data; + my $record = ${$self->records}[0]; + + if (TLSProxy::Proxy->is_tls13() + || $record->version() == TLSProxy::Record::VERS_TLS_1_2) { + $sigalg = unpack('n', $remdata); + $remdata = substr($remdata, 2); + } + + my $siglen = unpack('n', substr($remdata, 0, 2)); + my $sig = substr($remdata, 2); + + die "Invalid CertificateVerify signature length" if length($sig) != $siglen; + + print " SigAlg:".$sigalg."\n"; + print " Signature Len:".$siglen."\n"; + + $self->sigalg($sigalg); + $self->signature($sig); +} + +#Reconstruct the on-the-wire message data following changes +sub set_message_contents +{ + my $self = shift; + my $data = ""; + my $sig = $self->signature(); + my $olddata = $self->data(); + + $data .= pack("n", $self->sigalg()) if ($self->sigalg() != -1); + $data .= pack("n", length($sig)); + $data .= $sig; + + $self->data($data); +} + +#Read/write accessors +sub sigalg +{ + my $self = shift; + if (@_) { + $self->{sigalg} = shift; + } + return $self->{sigalg}; +} +sub signature +{ + my $self = shift; + if (@_) { + $self->{signature} = shift; + } + return $self->{signature}; +} +1; diff --git a/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/ClientHello.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/ClientHello.pm new file mode 100644 index 000000000..76dce740a --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/ClientHello.pm @@ -0,0 +1,258 @@ +# Copyright 2016-2019 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); + } +} + +sub extension_contents +{ + my $self = shift; + my $key = shift; + my $extension = ""; + + my $extdata = ${$self->extension_data}{$key}; + $extension .= pack("n", $key); + $extension .= pack("n", length($extdata)); + $extension .= $extdata; + return $extension; +} + +#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}) { + next if ($key == TLSProxy::Message::EXT_PSK); + $extensions .= $self->extension_contents($key); + #Add extension twice if we are duplicating that extension + $extensions .= $self->extension_contents($key) if ($key == $self->dupext); + } + #PSK extension always goes last... + if (defined ${$self->extension_data}{TLSProxy::Message::EXT_PSK}) { + $extensions .= $self->extension_contents(TLSProxy::Message::EXT_PSK); + } + #unless we have EXT_FORCE_LAST + if (defined ${$self->extension_data}{TLSProxy::Message::EXT_FORCE_LAST}) { + $extensions .= $self->extension_contents(TLSProxy::Message::EXT_FORCE_LAST); + } + + $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/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/EncryptedExtensions.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/EncryptedExtensions.pm new file mode 100644 index 000000000..262b720cf --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/EncryptedExtensions.pm @@ -0,0 +1,110 @@ +# Copyright 2016-2019 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::EncryptedExtensions; + +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_ENCRYPTED_EXTENSIONS, + $data, + $records, + $startoffset, + $message_frag_lens); + + $self->{extension_data} = ""; + + return $self; +} + +sub parse +{ + my $self = shift; + + my $extensions_len = unpack('n', $self->data); + if (!defined $extensions_len) { + $extensions_len = 0; + } + + my $extension_data; + if ($extensions_len != 0) { + $extension_data = substr($self->data, 2); + + if (length($extension_data) != $extensions_len) { + die "Invalid extension length\n"; + } + } else { + if (length($self->data) != 2) { + 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->extension_data(\%extensions); + + print " Extensions Len:".$extensions_len."\n"; +} + +#Reconstruct the on-the-wire message data following changes +sub set_message_contents +{ + my $self = shift; + my $data; + my $extensions = ""; + + foreach my $key (keys %{$self->extension_data}) { + my $extdata = ${$self->extension_data}{$key}; + $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 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/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Message.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Message.pm new file mode 100644 index 000000000..10b615607 --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Message.pm @@ -0,0 +1,606 @@ +# Copyright 2016-2019 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 TLSProxy::Alert; + +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_ENCRYPTED_EXTENSIONS => 8, + 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_ILLEGAL_PARAMETER => 47, + 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_ENCRYPTED_EXTENSIONS, "EncryptedExtensions", + 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_SERVER_NAME => 0, + EXT_MAX_FRAGMENT_LENGTH => 1, + EXT_STATUS_REQUEST => 5, + EXT_SUPPORTED_GROUPS => 10, + EXT_EC_POINT_FORMATS => 11, + EXT_SRP => 12, + EXT_SIG_ALGS => 13, + EXT_USE_SRTP => 14, + EXT_ALPN => 16, + EXT_SCT => 18, + EXT_PADDING => 21, + EXT_ENCRYPT_THEN_MAC => 22, + EXT_EXTENDED_MASTER_SECRET => 23, + EXT_SESSION_TICKET => 35, + EXT_KEY_SHARE => 51, + EXT_PSK => 41, + EXT_SUPPORTED_VERSIONS => 43, + EXT_COOKIE => 44, + EXT_PSK_KEX_MODES => 45, + EXT_POST_HANDSHAKE_AUTH => 49, + EXT_SIG_ALGS_CERT => 50, + EXT_RENEGOTIATE => 65281, + EXT_NPN => 13172, + EXT_CRYPTOPRO_BUG_EXTENSION => 0xfde8, + EXT_UNKNOWN => 0xfffe, + #Unknown extension that should appear last + EXT_FORCE_LAST => 0xffff +}; + +# SignatureScheme of TLS 1.3 from: +# https://www.iana.org/assignments/tls-parameters/tls-parameters.xhtml#tls-signaturescheme +# We have to manually grab the SHA224 equivalents from the old registry +use constant { + SIG_ALG_RSA_PKCS1_SHA256 => 0x0401, + SIG_ALG_RSA_PKCS1_SHA384 => 0x0501, + SIG_ALG_RSA_PKCS1_SHA512 => 0x0601, + SIG_ALG_ECDSA_SECP256R1_SHA256 => 0x0403, + SIG_ALG_ECDSA_SECP384R1_SHA384 => 0x0503, + SIG_ALG_ECDSA_SECP521R1_SHA512 => 0x0603, + SIG_ALG_RSA_PSS_RSAE_SHA256 => 0x0804, + SIG_ALG_RSA_PSS_RSAE_SHA384 => 0x0805, + SIG_ALG_RSA_PSS_RSAE_SHA512 => 0x0806, + SIG_ALG_ED25519 => 0x0807, + SIG_ALG_ED448 => 0x0808, + SIG_ALG_RSA_PSS_PSS_SHA256 => 0x0809, + SIG_ALG_RSA_PSS_PSS_SHA384 => 0x080a, + SIG_ALG_RSA_PSS_PSS_SHA512 => 0x080b, + SIG_ALG_RSA_PKCS1_SHA1 => 0x0201, + SIG_ALG_ECDSA_SHA1 => 0x0203, + SIG_ALG_DSA_SHA1 => 0x0202, + SIG_ALG_DSA_SHA256 => 0x0402, + SIG_ALG_DSA_SHA384 => 0x0502, + SIG_ALG_DSA_SHA512 => 0x0602, + OSSL_SIG_ALG_RSA_PKCS1_SHA224 => 0x0301, + OSSL_SIG_ALG_DSA_SHA224 => 0x0302, + OSSL_SIG_ALG_ECDSA_SHA224 => 0x0303 +}; + +use constant { + CIPHER_RSA_WITH_AES_128_CBC_SHA => 0x002f, + CIPHER_DHE_RSA_AES_128_SHA => 0x0033, + CIPHER_ADH_AES_128_SHA => 0x0034, + CIPHER_TLS13_AES_128_GCM_SHA256 => 0x1301, + CIPHER_TLS13_AES_256_GCM_SHA384 => 0x1302 +}; + +use constant { + CLIENT => 0, + SERVER => 1 +}; + +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; +my $successondata = 0; +my $alert; + +sub clear +{ + $payload = ""; + $messlen = -1; + $startoffset = -1; + $server = 0; + $success = 0; + $end = 0; + $successondata = 0; + @message_rec_list = (); + @message_frag_lens = (); + $alert = undef; +} + +#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 (!TLSProxy::Proxy->is_tls13()) { + if ($server) { + TLSProxy::Record->server_encrypting(1); + } else { + TLSProxy::Record->client_encrypting(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"; + + if ($successondata) { + $success = 1; + $end = 1; + } + } elsif ($record->content_type == TLSProxy::Record::RT_ALERT) { + my ($alertlev, $alertdesc) = unpack('CC', $record->decrypt_data); + print " [$alertlev, $alertdesc]\n"; + #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; + } + #Fatal or close notify alerts end the test + if ($alertlev == AL_LEVEL_FATAL || $alertdesc == AL_DESC_CLOSE_NOTIFY) { + $end = 1; + } + $alert = TLSProxy::Alert->new( + $server, + $record->encrypted, + $alertlev, + $alertdesc); + } + + 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_ENCRYPTED_EXTENSIONS) { + $message = TLSProxy::EncryptedExtensions->new( + $server, + $data, + [@message_rec_list], + $startoffset, + [@message_frag_lens] + ); + $message->parse(); + } elsif ($mt == MT_CERTIFICATE) { + $message = TLSProxy::Certificate->new( + $server, + $data, + [@message_rec_list], + $startoffset, + [@message_frag_lens] + ); + $message->parse(); + } elsif ($mt == MT_CERTIFICATE_REQUEST) { + $message = TLSProxy::CertificateRequest->new( + $server, + $data, + [@message_rec_list], + $startoffset, + [@message_frag_lens] + ); + $message->parse(); + } elsif ($mt == MT_CERTIFICATE_VERIFY) { + $message = TLSProxy::CertificateVerify->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 alert +{ + return $alert; +} + +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, + dupext => -1 + }; + + 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: Only supports re-encrypting for TLSv1.3 +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); + # Only support re-encryption for TLSv1.3. + if (TLSProxy::Proxy->is_tls13() && $rec->encrypted()) { + #Add content type (1 byte) and 16 tag bytes + $rec->data($rec->decrypt_data + .pack("C", TLSProxy::Record::RT_HANDSHAKE).("\0"x16)); + } else { + $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); +} +sub dupext +{ + my $self = shift; + if (@_) { + $self->{dupext} = shift; + } + return $self->{dupext}; +} +sub successondata +{ + my $class = shift; + if (@_) { + $successondata = shift; + } + return $successondata; +} +1; diff --git a/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/NewSessionTicket.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/NewSessionTicket.pm new file mode 100644 index 000000000..e5099851d --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/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/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Proxy.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Proxy.pm new file mode 100644 index 000000000..6f983b328 --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Proxy.pm @@ -0,0 +1,729 @@ +# Copyright 2016-2019 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::EncryptedExtensions; +use TLSProxy::Certificate; +use TLSProxy::CertificateRequest; +use TLSProxy::CertificateVerify; +use TLSProxy::ServerKeyExchange; +use TLSProxy::NewSessionTicket; + +my $have_IPv6; +my $IP_factory; + +BEGIN +{ + # 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 core 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(Domain => AF_INET6, @_); }; + $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(@_); }; + $have_IPv6 = 0; + } + } +} + +my $is_tls13 = 0; +my $ciphersuite = undef; + +sub new +{ + my $class = shift; + my ($filter, + $execute, + $cert, + $debug) = @_; + + my $self = { + #Public read/write + proxy_addr => $have_IPv6 ? "[::1]" : "127.0.0.1", + filter => $filter, + serverflags => "", + clientflags => "", + serverconnects => 1, + reneg => 0, + sessionfile => undef, + + #Public read + proxy_port => 0, + server_port => 0, + serverpid => 0, + clientpid => 0, + execute => $execute, + cert => $cert, + debug => $debug, + cipherc => "", + ciphersuitesc => "", + ciphers => "AES128-SHA", + ciphersuitess => "TLS_AES_128_GCM_SHA256", + flight => -1, + direction => -1, + partial => ["", ""], + record_list => [], + message_list => [], + }; + + # Create the Proxy socket + my $proxaddr = $self->{proxy_addr}; + $proxaddr =~ s/[\[\]]//g; # Remove [ and ] + my @proxyargs = ( + LocalHost => $proxaddr, + LocalPort => 0, + Proto => "tcp", + Listen => SOMAXCONN, + ); + + if (my $sock = $IP_factory->(@proxyargs)) { + $self->{proxy_sock} = $sock; + $self->{proxy_port} = $sock->sockport(); + $self->{proxy_addr} = $sock->sockhost(); + $self->{proxy_addr} =~ s/(.*:.*)/[$1]/; + print "Proxy started on port ", + "$self->{proxy_addr}:$self->{proxy_port}\n"; + # use same address for s_server + $self->{server_addr} = $self->{proxy_addr}; + } else { + warn "Failed creating proxy socket (".$proxaddr.",0): $!\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->{ciphersuitec} = ""; + $self->{flight} = -1; + $self->{direction} = -1; + $self->{partial} = ["", ""]; + $self->{record_list} = []; + $self->{message_list} = []; + $self->{clientflags} = ""; + $self->{sessionfile} = undef; + $self->{clientpid} = 0; + $is_tls13 = 0; + $ciphersuite = undef; + + TLSProxy::Message->clear(); + TLSProxy::Record->clear(); +} + +sub clear +{ + my $self = shift; + + $self->clearClient; + $self->{ciphers} = "AES128-SHA"; + $self->{ciphersuitess} = "TLS_AES_128_GCM_SHA256"; + $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 connect_to_server +{ + my $self = shift; + my $servaddr = $self->{server_addr}; + + $servaddr =~ s/[\[\]]//g; # Remove [ and ] + + my $sock = $IP_factory->(PeerAddr => $servaddr, + PeerPort => $self->{server_port}, + Proto => 'tcp'); + if (!defined($sock)) { + my $err = $!; + kill(3, $self->{real_serverpid}); + die "unable to connect: $err\n"; + } + + $self->{server_sock} = $sock; +} + +sub start +{ + my ($self) = shift; + my $pid; + + if ($self->{proxy_sock} == 0) { + return 0; + } + + my $execcmd = $self->execute + ." s_server -max_protocol TLSv1.3 -no_comp -rev -engine ossltest" + #In TLSv1.3 we issue two session tickets. The default session id + #callback gets confused because the ossltest engine causes the same + #session id to be created twice due to the changed random number + #generation. Using "-ext_cache" replaces the default callback with a + #different one that doesn't get confused. + ." -ext_cache" + ." -accept $self->{server_addr}:0" + ." -cert ".$self->cert." -cert2 ".$self->cert + ." -naccept ".$self->serverconnects; + if ($self->ciphers ne "") { + $execcmd .= " -cipher ".$self->ciphers; + } + if ($self->ciphersuitess ne "") { + $execcmd .= " -ciphersuites ".$self->ciphersuitess; + } + if ($self->serverflags ne "") { + $execcmd .= " ".$self->serverflags; + } + if ($self->debug) { + print STDERR "Server command: $execcmd\n"; + } + + open(my $savedin, "<&STDIN"); + + # Temporarily replace STDIN so that sink process can inherit it... + $pid = open(STDIN, "$execcmd 2>&1 |") or die "Failed to $execcmd: $!\n"; + $self->{real_serverpid} = $pid; + + # Process the output from s_server until we find the ACCEPT line, which + # tells us what the accepting address and port are. + while (<>) { + print; + s/\R$//; # Better chomp + next unless (/^ACCEPT\s.*:(\d+)$/); + $self->{server_port} = $1; + last; + } + + if ($self->{server_port} == 0) { + # This actually means that s_server exited, because otherwise + # we would still searching for ACCEPT... + waitpid($pid, 0); + die "no ACCEPT detected in '$execcmd' output: $?\n"; + } + + # Just make sure everything else is simply printed [as separate lines]. + # The sub process simply inherits our STD* and will keep consuming + # server's output and printing it as long as there is anything there, + # out of our way. + my $error; + $pid = undef; + if (eval { require Win32::Process; 1; }) { + if (Win32::Process::Create(my $h, $^X, "perl -ne print", 0, 0, ".")) { + $pid = $h->GetProcessID(); + $self->{proc_handle} = $h; # hold handle till next round [or exit] + } else { + $error = Win32::FormatMessage(Win32::GetLastError()); + } + } else { + if (defined($pid = fork)) { + $pid or exec("$^X -ne print") or exit($!); + } else { + $error = $!; + } + } + + # Change back to original stdin + open(STDIN, "<&", $savedin); + close($savedin); + + if (!defined($pid)) { + kill(3, $self->{real_serverpid}); + die "Failed to capture s_server's output: $error\n"; + } + + $self->{serverpid} = $pid; + + print STDERR "Server responds on ", + "$self->{server_addr}:$self->{server_port}\n"; + + # Connect right away... + $self->connect_to_server(); + + return $self->clientstart; +} + +sub clientstart +{ + my ($self) = shift; + + if ($self->execute) { + my $pid; + my $execcmd = $self->execute + ." s_client -max_protocol TLSv1.3 -engine ossltest" + ." -connect $self->{proxy_addr}:$self->{proxy_port}"; + if ($self->cipherc ne "") { + $execcmd .= " -cipher ".$self->cipherc; + } + if ($self->ciphersuitesc ne "") { + $execcmd .= " -ciphersuites ".$self->ciphersuitesc; + } + if ($self->clientflags ne "") { + $execcmd .= " ".$self->clientflags; + } + if ($self->clientflags !~ m/-(no)?servername/) { + $execcmd .= " -servername localhost"; + } + if (defined $self->sessionfile) { + $execcmd .= " -ign_eof"; + } + if ($self->debug) { + print STDERR "Client command: $execcmd\n"; + } + + open(my $savedout, ">&STDOUT"); + # If we open pipe with new descriptor, attempt to close it, + # explicitly or implicitly, would incur waitpid and effectively + # dead-lock... + if (!($pid = open(STDOUT, "| $execcmd"))) { + my $err = $!; + kill(3, $self->{real_serverpid}); + die "Failed to $execcmd: $err\n"; + } + $self->{clientpid} = $pid; + + # queue [magic] input + print $self->reneg ? "R" : "test"; + + # this closes client's stdin without waiting for its pid + open(STDOUT, ">&", $savedout); + close($savedout); + } + + # Wait for incoming connection from client + my $fdset = IO::Select->new($self->{proxy_sock}); + if (!$fdset->can_read(60)) { + kill(3, $self->{real_serverpid}); + die "s_client didn't try to connect\n"; + } + + my $client_sock; + if(!($client_sock = $self->{proxy_sock}->accept())) { + warn "Failed accepting incoming connection: $!\n"; + return 0; + } + + print "Connection opened\n"; + + my $server_sock = $self->{server_sock}; + my $indata; + + #Wait for either the server socket or the client socket to become readable + $fdset = IO::Select->new($server_sock, $client_sock); + my @ready; + my $ctr = 0; + local $SIG{PIPE} = "IGNORE"; + $self->{saw_session_ticket} = undef; + while($fdset->count && $ctr < 10) { + if (defined($self->{sessionfile})) { + # s_client got -ign_eof and won't be exiting voluntarily, so we + # look for data *and* session ticket... + last if TLSProxy::Message->success() + && $self->{saw_session_ticket}; + } + if (!(@ready = $fdset->can_read(1))) { + $ctr++; + next; + } + foreach my $hand (@ready) { + if ($hand == $server_sock) { + if ($server_sock->sysread($indata, 16384)) { + if ($indata = $self->process_packet(1, $indata)) { + $client_sock->syswrite($indata) or goto END; + } + $ctr = 0; + } else { + $fdset->remove($server_sock); + $client_sock->shutdown(SHUT_WR); + } + } elsif ($hand == $client_sock) { + if ($client_sock->sysread($indata, 16384)) { + if ($indata = $self->process_packet(0, $indata)) { + $server_sock->syswrite($indata) or goto END; + } + $ctr = 0; + } else { + $fdset->remove($client_sock); + $server_sock->shutdown(SHUT_WR); + } + } else { + kill(3, $self->{real_serverpid}); + die "Unexpected handle"; + } + } + } + + if ($ctr >= 10) { + kill(3, $self->{real_serverpid}); + die "No progress made"; + } + + END: + print "Connection closed\n"; + if($server_sock) { + $server_sock->close(); + $self->{server_sock} = undef; + } + if($client_sock) { + #Closing this also kills the child process + $client_sock->close(); + } + + my $pid; + if (--$self->{serverconnects} == 0) { + $pid = $self->{serverpid}; + print "Waiting for 'perl -ne print' process to close: $pid...\n"; + $pid = waitpid($pid, 0); + if ($pid > 0) { + die "exit code $? from 'perl -ne print' process\n" if $? != 0; + } elsif ($pid == 0) { + kill(3, $self->{real_serverpid}); + die "lost control over $self->{serverpid}?"; + } + $pid = $self->{real_serverpid}; + print "Waiting for s_server process to close: $pid...\n"; + # it's done already, just collect the exit code [and reap]... + waitpid($pid, 0); + die "exit code $? from s_server process\n" if $? != 0; + } else { + # It's a bit counter-intuitive spot to make next connection to + # the s_server. Rationale is that established connection works + # as synchronization point, in sense that this way we know that + # s_server is actually done with current session... + $self->connect_to_server(); + } + $pid = $self->{clientpid}; + print "Waiting for s_client process to close: $pid...\n"; + waitpid($pid, 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); + } + + #Take a note on NewSessionTicket + foreach my $message (reverse @{$self->{message_list}}) { + if ($message->{mt} == TLSProxy::Message::MT_NEW_SESSION_TICKET) { + $self->{saw_session_ticket} = 1; + last; + } + } + + #Reconstruct the packet + $packet = ""; + foreach my $record (@{$self->record_list}) { + $packet .= $record->reconstruct_record($server); + } + + 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}; +} +sub server_addr +{ + my $self = shift; + return $self->{server_addr}; +} +sub server_port +{ + my $self = shift; + return $self->{server_port}; +} +sub serverpid +{ + my $self = shift; + return $self->{serverpid}; +} +sub clientpid +{ + my $self = shift; + return $self->{clientpid}; +} + +#Read/write accessors +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 ciphersuitesc +{ + my $self = shift; + if (@_) { + $self->{ciphersuitesc} = shift; + } + return $self->{ciphersuitesc}; +} +sub ciphers +{ + my $self = shift; + if (@_) { + $self->{ciphers} = shift; + } + return $self->{ciphers}; +} +sub ciphersuitess +{ + my $self = shift; + if (@_) { + $self->{ciphersuitess} = shift; + } + return $self->{ciphersuitess}; +} +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 fill_known_data +{ + my $length = shift; + my $ret = ""; + for (my $i = 0; $i < $length; $i++) { + $ret .= chr($i); + } + return $ret; +} + +sub is_tls13 +{ + my $class = shift; + if (@_) { + $is_tls13 = shift; + } + return $is_tls13; +} + +sub reneg +{ + my $self = shift; + if (@_) { + $self->{reneg} = shift; + } + return $self->{reneg}; +} + +#Setting a sessionfile means that the client will not close until the given +#file exists. This is useful in TLSv1.3 where otherwise s_client will close +#immediately at the end of the handshake, but before the session has been +#received from the server. A side effect of this is that s_client never sends +#a close_notify, so instead we consider success to be when it sends application +#data over the connection. +sub sessionfile +{ + my $self = shift; + if (@_) { + $self->{sessionfile} = shift; + TLSProxy::Message->successondata(1); + } + return $self->{sessionfile}; +} + +sub ciphersuite +{ + my $class = shift; + if (@_) { + $ciphersuite = shift; + } + return $ciphersuite; +} + +1; diff --git a/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Record.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Record.pm new file mode 100644 index 000000000..841467b8e --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/Record.pm @@ -0,0 +1,401 @@ +# Copyright 2016-2019 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_encrypting = 0; +my $client_encrypting = 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_4 => 0x0305, + VERS_TLS_1_3 => 0x0304, + VERS_TLS_1_2 => 0x0303, + VERS_TLS_1_1 => 0x0302, + VERS_TLS_1_0 => 0x0301, + VERS_SSL_3_0 => 0x0300, + VERS_SSL_LT_3_0 => 0x02ff +}; + +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 $recnum = 1; + while (length ($packet) > 0) { + print " Record $recnum ", $server ? "(server -> client)\n" + : "(client -> server)\n"; + + #Get the record header (unpack can't fail if $packet is too short) + my ($content_type, $version, $len) = unpack('Cnn', $packet); + + if (length($packet) < TLS_RECORD_HEADER_LENGTH + ($len // 0)) { + print "Partial data : ".length($packet)." bytes\n"; + $partial = $packet; + last; + } + + my $data = substr($packet, TLS_RECORD_HEADER_LENGTH, $len); + + print " Content type: ".$record_type{$content_type}."\n"; + print " Version: $tls_version{$version}\n"; + print " Length: $len\n"; + + my $record = TLSProxy::Record->new( + $flight, + $content_type, + $version, + $len, + 0, + $len, # len_real + $len, # decrypt_len + $data, # data + $data # decrypt_data + ); + + if ($content_type != RT_CCS + && (!TLSProxy::Proxy->is_tls13() + || $content_type != RT_ALERT)) { + if (($server && $server_encrypting) + || (!$server && $client_encrypting)) { + if (!TLSProxy::Proxy->is_tls13() && $etm) { + $record->decryptETM(); + } else { + $record->decrypt(); + } + $record->encrypted(1); + + if (TLSProxy::Proxy->is_tls13()) { + print " Inner content type: " + .$record_type{$record->content_type()}."\n"; + } + } + } + + 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); + $recnum++; + } + + return (\@record_list, \@message_list, $partial); +} + +sub clear +{ + $server_encrypting = 0; + $client_encrypting = 0; +} + +#Class level accessors +sub server_encrypting +{ + my $class = shift; + if (@_) { + $server_encrypting = shift; + } + return $server_encrypting; +} +sub client_encrypting +{ + my $class = shift; + if (@_) { + $client_encrypting= shift; + } + return $client_encrypting; +} +#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, + encrypted => 0, + outer_content_type => RT_APPLICATION_DATA + }; + + 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 $mactaglen = 20; + my $data = $self->data; + + #Throw away any IVs + if (TLSProxy::Proxy->is_tls13()) { + #A TLS1.3 client, when processing the server's initial flight, could + #respond with either an encrypted or an unencrypted alert. + if ($self->content_type() == RT_ALERT) { + #TODO(TLS1.3): Eventually it is sufficient just to check the record + #content type. If an alert is encrypted it will have a record + #content type of application data. However we haven't done the + #record layer changes yet, so it's a bit more complicated. For now + #we will additionally check if the data length is 2 (1 byte for + #alert level, 1 byte for alert description). If it is, then this is + #an unencrypted alert, so don't try to decrypt + return $data if (length($data) == 2); + } + $mactaglen = 16; + } elsif ($self->version >= VERS_TLS_1_1()) { + #16 bytes for a standard IV + $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 or TAG + $data = substr($data, 0, length($data) - $mactaglen); + + if (TLSProxy::Proxy->is_tls13()) { + #Get the content type + my $content_type = unpack("C", substr($data, length($data) - 1)); + $self->content_type($content_type); + $data = substr($data, 0, length($data) - 1); + } + + $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 $server = shift; + my $data; + + #We only replay the records in the same direction + if ($self->{sent} || ($self->flight & 1) != $server) { + return ""; + } + $self->{sent} = 1; + + if ($self->sslv2) { + $data = pack('n', $self->len | 0x8000); + } else { + if (TLSProxy::Proxy->is_tls13() && $self->encrypted) { + $data = pack('Cnn', $self->outer_content_type, $self->version, + $self->len); + } 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 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}; +} +sub version +{ + my $self = shift; + if (@_) { + $self->{version} = shift; + } + return $self->{version}; +} +sub content_type +{ + my $self = shift; + if (@_) { + $self->{content_type} = shift; + } + return $self->{content_type}; +} +sub encrypted +{ + my $self = shift; + if (@_) { + $self->{encrypted} = shift; + } + return $self->{encrypted}; +} +sub outer_content_type +{ + my $self = shift; + if (@_) { + $self->{outer_content_type} = shift; + } + return $self->{outer_content_type}; +} +sub is_fatal_alert +{ + my $self = shift; + my $server = shift; + + if (($self->{flight} & 1) == $server + && $self->{content_type} == TLSProxy::Record::RT_ALERT) { + my ($level, $alert) = unpack('CC', $self->decrypt_data); + return $alert if ($level == 2); + } + return 0; +} +1; diff --git a/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/ServerHello.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/ServerHello.pm new file mode 100644 index 000000000..e9f1eca19 --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/ServerHello.pm @@ -0,0 +1,236 @@ +# Copyright 2016-2019 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'; + +my $hrrrandom = pack("C*", 0xCF, 0x21, 0xAD, 0x74, 0xE5, 0x9A, 0x61, 0x11, 0xBE, + 0x1D, 0x8C, 0x02, 0x1E, 0x65, 0xB8, 0x91, 0xC2, 0xA2, + 0x11, 0x16, 0x7A, 0xBB, 0x8C, 0x5E, 0x07, 0x9E, 0x09, + 0xE2, 0xC8, 0xA8, 0x33, 0x9C); + +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 $neg_version = $server_version; + + my $random = substr($self->data, $ptr, 32); + $ptr += 32; + my $session_id_len = 0; + my $session = ""; + $session_id_len = unpack('C', substr($self->data, $ptr)); + $ptr++; + $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 = 0; + $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; + if ($type == TLSProxy::Message::EXT_SUPPORTED_VERSIONS) { + $neg_version = unpack('n', $extdata); + } + } + + if ($random eq $hrrrandom) { + TLSProxy::Proxy->is_tls13(1); + } elsif ($neg_version == TLSProxy::Record::VERS_TLS_1_3) { + TLSProxy::Proxy->is_tls13(1); + + TLSProxy::Record->server_encrypting(1); + TLSProxy::Record->client_encrypting(1); + } + + $self->server_version($server_version); + $self->random($random); + $self->session_id_len($session_id_len); + $self->session($session); + $self->ciphersuite($ciphersuite); + TLSProxy::Proxy->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 == $self->dupext) { + $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->{server_version} = shift; + } + return $self->{server_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/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/ServerKeyExchange.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/ServerKeyExchange.pm new file mode 100644 index 000000000..e0086e2be --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/TLSProxy/ServerKeyExchange.pm @@ -0,0 +1,157 @@ +# Copyright 2016-2019 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->{sigalg} = -1; + $self->{sig} = ""; + + return $self; +} + +sub parse +{ + my $self = shift; + my $sigalg = -1; + + #Minimal SKE parsing. Only supports one known DHE ciphersuite at the moment + return if TLSProxy::Proxy->ciphersuite() + != TLSProxy::Message::CIPHER_ADH_AES_128_SHA + && TLSProxy::Proxy->ciphersuite() + != TLSProxy::Message::CIPHER_DHE_RSA_AES_128_SHA; + + 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 $record = ${$self->records}[0]; + + if (TLSProxy::Proxy->is_tls13() + || $record->version() == TLSProxy::Record::VERS_TLS_1_2) { + $sigalg = unpack('n', substr($self->data, $ptr)); + $ptr += 2; + } + my $sig = ""; + if (defined $sigalg) { + my $sig_len = unpack('n', substr($self->data, $ptr)); + 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->sigalg($sigalg) if defined $sigalg; + $self->signature($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; + $data .= pack('n', $self->sigalg) if ($self->sigalg != -1); + if (length($self->signature) > 0) { + $data .= pack('n', length($self->signature)); + $data .= $self->signature; + } + + $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 sigalg +{ + my $self = shift; + if (@_) { + $self->{sigalg} = shift; + } + return $self->{sigalg}; +} +sub signature +{ + my $self = shift; + if (@_) { + $self->{sig} = shift; + } + return $self->{sig}; +} +1; diff --git a/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/checkhandshake.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/checkhandshake.pm new file mode 100644 index 000000000..04441b561 --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/checkhandshake.pm @@ -0,0 +1,232 @@ +#! /usr/bin/env perl +# Copyright 2015-2019 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 checkhandshake; + +use OpenSSL::Test qw/:DEFAULT cmdstr srctop_file srctop_dir bldtop_dir/; +use OpenSSL::Test::Utils; +use TLSProxy::Proxy; + +use Exporter; +our @ISA = 'Exporter'; +our @EXPORT = qw(@handmessages @extensions checkhandshake); + +use constant { + DEFAULT_HANDSHAKE => 1, + OCSP_HANDSHAKE => 2, + RESUME_HANDSHAKE => 4, + CLIENT_AUTH_HANDSHAKE => 8, + RENEG_HANDSHAKE => 16, + NPN_HANDSHAKE => 32, + EC_HANDSHAKE => 64, + HRR_HANDSHAKE => 128, + HRR_RESUME_HANDSHAKE => 256, + + ALL_HANDSHAKES => 511 +}; + +use constant { + #DEFAULT also includes SESSION_TICKET_SRV_EXTENSION and SERVER_NAME_CLI + DEFAULT_EXTENSIONS => 0x00000007, + SESSION_TICKET_SRV_EXTENSION => 0x00000002, + SERVER_NAME_CLI_EXTENSION => 0x00000004, + SERVER_NAME_SRV_EXTENSION => 0x00000008, + STATUS_REQUEST_CLI_EXTENSION => 0x00000010, + STATUS_REQUEST_SRV_EXTENSION => 0x00000020, + ALPN_CLI_EXTENSION => 0x00000040, + ALPN_SRV_EXTENSION => 0x00000080, + SCT_CLI_EXTENSION => 0x00000100, + SCT_SRV_EXTENSION => 0x00000200, + RENEGOTIATE_CLI_EXTENSION => 0x00000400, + NPN_CLI_EXTENSION => 0x00000800, + NPN_SRV_EXTENSION => 0x00001000, + SRP_CLI_EXTENSION => 0x00002000, + #Client side for ec point formats is a default extension + EC_POINT_FORMAT_SRV_EXTENSION => 0x00004000, + PSK_CLI_EXTENSION => 0x00008000, + PSK_SRV_EXTENSION => 0x00010000, + KEY_SHARE_SRV_EXTENSION => 0x00020000, + PSK_KEX_MODES_EXTENSION => 0x00040000, + KEY_SHARE_HRR_EXTENSION => 0x00080000, + SUPPORTED_GROUPS_SRV_EXTENSION => 0x00100000, + POST_HANDSHAKE_AUTH_CLI_EXTENSION => 0x00200000 +}; + +our @handmessages = (); +our @extensions = (); + +sub checkhandshake($$$$) +{ + my ($proxy, $handtype, $exttype, $testname) = @_; + + subtest $testname => sub { + my $loop = 0; + my $numtests; + my $extcount; + my $clienthelloseen = 0; + + my $lastmt = 0; + my $numsh = 0; + if (TLSProxy::Proxy::is_tls13()) { + #How many ServerHellos are we expecting? + for ($numtests = 0; $handmessages[$loop][1] != 0; $loop++) { + next if (($handmessages[$loop][1] & $handtype) == 0); + $numsh++ if ($lastmt != TLSProxy::Message::MT_SERVER_HELLO + && $handmessages[$loop][0] == TLSProxy::Message::MT_SERVER_HELLO); + $lastmt = $handmessages[$loop][0]; + } + } + + #First count the number of tests + my $nextmess = 0; + my $message = undef; + my $chnum = 0; + my $shnum = 0; + if (!TLSProxy::Proxy::is_tls13()) { + # In non-TLSv1.3 we always treat reneg CH and SH like the first CH + # and SH + $chnum = 1; + $shnum = 1; + } + #If we're only expecting one ServerHello out of two then we skip the + #first ServerHello in the list completely + $shnum++ if ($numsh == 1 && TLSProxy::Proxy::is_tls13()); + $loop = 0; + for ($numtests = 0; $handmessages[$loop][1] != 0; $loop++) { + next if (($handmessages[$loop][1] & $handtype) == 0); + if (scalar @{$proxy->message_list} > $nextmess) { + $message = ${$proxy->message_list}[$nextmess]; + $nextmess++; + } else { + $message = undef; + } + $numtests++; + + next if (!defined $message); + if (TLSProxy::Proxy::is_tls13()) { + $chnum++ if $message->mt() == TLSProxy::Message::MT_CLIENT_HELLO; + $shnum++ if $message->mt() == TLSProxy::Message::MT_SERVER_HELLO; + } + next if ($message->mt() != TLSProxy::Message::MT_CLIENT_HELLO + && $message->mt() != TLSProxy::Message::MT_SERVER_HELLO + && $message->mt() != + TLSProxy::Message::MT_ENCRYPTED_EXTENSIONS + && $message->mt() != TLSProxy::Message::MT_CERTIFICATE + && $message->mt() != TLSProxy::Message::MT_CERTIFICATE_REQUEST); + + next if $message->mt() == TLSProxy::Message::MT_CERTIFICATE + && !TLSProxy::Proxy::is_tls13(); + + my $extchnum = 1; + my $extshnum = 1; + for (my $extloop = 0; + $extensions[$extloop][3] != 0; + $extloop++) { + $extchnum = 2 if $extensions[$extloop][0] != TLSProxy::Message::MT_CLIENT_HELLO + && TLSProxy::Proxy::is_tls13(); + $extshnum = 2 if $extensions[$extloop][0] != TLSProxy::Message::MT_SERVER_HELLO + && $extchnum == 2; + next if $extensions[$extloop][0] == TLSProxy::Message::MT_CLIENT_HELLO + && $extchnum != $chnum; + next if $extensions[$extloop][0] == TLSProxy::Message::MT_SERVER_HELLO + && $extshnum != $shnum; + next if ($message->mt() != $extensions[$extloop][0]); + next if ($message->server() != $extensions[$extloop][2]); + $numtests++; + } + $numtests++; + } + + plan tests => $numtests; + + $nextmess = 0; + $message = undef; + if (TLSProxy::Proxy::is_tls13()) { + $chnum = 0; + $shnum = 0; + } else { + # In non-TLSv1.3 we always treat reneg CH and SH like the first CH + # and SH + $chnum = 1; + $shnum = 1; + } + #If we're only expecting one ServerHello out of two then we skip the + #first ServerHello in the list completely + $shnum++ if ($numsh == 1 && TLSProxy::Proxy::is_tls13()); + for ($loop = 0; $handmessages[$loop][1] != 0; $loop++) { + next if (($handmessages[$loop][1] & $handtype) == 0); + if (scalar @{$proxy->message_list} > $nextmess) { + $message = ${$proxy->message_list}[$nextmess]; + $nextmess++; + } else { + $message = undef; + } + if (!defined $message) { + fail("Message type check. Got nothing, expected " + .$handmessages[$loop][0]); + next; + } else { + ok($message->mt == $handmessages[$loop][0], + "Message type check. Got ".$message->mt + .", expected ".$handmessages[$loop][0]); + } + if (TLSProxy::Proxy::is_tls13()) { + $chnum++ if $message->mt() == TLSProxy::Message::MT_CLIENT_HELLO; + $shnum++ if $message->mt() == TLSProxy::Message::MT_SERVER_HELLO; + } + + next if ($message->mt() != TLSProxy::Message::MT_CLIENT_HELLO + && $message->mt() != TLSProxy::Message::MT_SERVER_HELLO + && $message->mt() != + TLSProxy::Message::MT_ENCRYPTED_EXTENSIONS + && $message->mt() != TLSProxy::Message::MT_CERTIFICATE + && $message->mt() != TLSProxy::Message::MT_CERTIFICATE_REQUEST); + + next if $message->mt() == TLSProxy::Message::MT_CERTIFICATE + && !TLSProxy::Proxy::is_tls13(); + + if ($message->mt() == TLSProxy::Message::MT_CLIENT_HELLO) { + #Add renegotiate extension we will expect if renegotiating + $exttype |= RENEGOTIATE_CLI_EXTENSION + if ($clienthelloseen && !TLSProxy::Proxy::is_tls13()); + $clienthelloseen = 1; + } + #Now check that we saw the extensions we expected + my $msgexts = $message->extension_data(); + my $extchnum = 1; + my $extshnum = 1; + for (my $extloop = 0, $extcount = 0; $extensions[$extloop][3] != 0; + $extloop++) { + #In TLSv1.3 we can have two ClientHellos if there has been a + #HelloRetryRequest, and they may have different extensions. Skip + #if these are extensions for a different ClientHello + $extchnum = 2 if $extensions[$extloop][0] != TLSProxy::Message::MT_CLIENT_HELLO + && TLSProxy::Proxy::is_tls13(); + $extshnum = 2 if $extensions[$extloop][0] != TLSProxy::Message::MT_SERVER_HELLO + && $extchnum == 2; + next if $extensions[$extloop][0] == TLSProxy::Message::MT_CLIENT_HELLO + && $extchnum != $chnum; + next if $extensions[$extloop][0] == TLSProxy::Message::MT_SERVER_HELLO + && $extshnum != $shnum; + next if ($message->mt() != $extensions[$extloop][0]); + next if ($message->server() != $extensions[$extloop][2]); + ok (($extensions[$extloop][3] & $exttype) == 0 + || defined ($msgexts->{$extensions[$extloop][1]}), + "Extension presence check (Message: ".$message->mt() + ." Extension: ".($extensions[$extloop][3] & $exttype).", " + .$extloop.")"); + $extcount++ if (($extensions[$extloop][3] & $exttype) != 0); + } + ok($extcount == keys %$msgexts, "Extensions count mismatch (" + .$extcount.", ".(keys %$msgexts) + .")"); + } + } +} + +1; diff --git a/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/with_fallback.pm b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/with_fallback.pm new file mode 100644 index 000000000..242365033 --- /dev/null +++ b/roms/edk2/CryptoPkg/Library/OpensslLib/openssl/util/perl/with_fallback.pm @@ -0,0 +1,27 @@ +# 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 with_fallback; + +sub import { + shift; + + use File::Basename; + use File::Spec::Functions; + foreach (@_) { + eval "use $_"; + if ($@) { + unshift @INC, catdir(dirname(__FILE__), + "..", "..", "external", "perl"); + my $transfer = "transfer::$_"; + eval "use $transfer"; + shift @INC; + warn $@ if $@; + } + } +} +1; |