view release on metacpan or  search on metacpan

t/lib/App/CamelPKI/Test.pm  view on Meta::CPAN

    return HTTP::Request->new("GET", $url);
}

sub http_request_execute {
    my ($req, %args) = @_;
    die "Bad argument $req" unless eval { $req->isa("HTTP::Request") };
    # Trust me, snarfing this undocumented variable really is the
    # most elegant way of causing LWP to use a client certificate.
    # I've gone through these hoops many, many times.
    local @LWP::Protocol::http::EXTRA_SOCK_OPTS;
    if ($args{-key} && $args{-certificate}) {
        my $keysdir = catdir(tempdir(), "test_ssl_client_keys");
        if (! -d $keysdir) {
            mkdir($keysdir) or die "Cannot mkdir($keysdir): $!\n";
        }
        write_file(my $clientcertfile = catfile($keysdir, "cert.pem"),
                   (ref($args{-certificate}) ?
                    $args{-certificate}->serialize() :
                    $args{-certificate}));
        write_file(my $clientkeyfile = catfile($keysdir, "key.pem"),
                   (ref($args{-key}) ? $args{-key}->serialize() :
                    $args{-key}));
        @LWP::Protocol::http::EXTRA_SOCK_OPTS =
            (SSL_use_cert => 1,
             SSL_cert_file => $clientcertfile,
             SSL_key_file => $clientkeyfile,
            );
    }
    return LWP::UserAgent->new->request($req);
}

=item I<camel_pki_chain>

Returns the certification chain of the App-PKI application under test,
starting with the Operational CA certificate.

=cut

sub camel_pki_chain {
    require Catalyst::Test;
    Catalyst::Test->import("App::CamelPKI");

    my $req = Catalyst::Utils::request("/ca/certificate_chain_pem");
    my $resp = Catalyst::Test::local_request("App::CamelPKI", $req)
        ->content;
    return map {$_->serialize} (App::CamelPKI::Certificate->parse_bundle($resp));
}



=item I<openssl_path>

Returns the path to the C<openssl> command-line tool, if it is known,
or undef.  Useful for skipping tests that depend on
L</run_thru_openssl> being able to run.

=cut

sub openssl_path {
    my ($openssl_bin) =
        ( `which openssl 2>/dev/null` =~ m/^(.*)/ ); # Chopped, untainted
    return if ! ($openssl_bin && -x $openssl_bin);
    return $openssl_bin;
}

=item I<run_thru_openssl($stdin_text, $arg1, $arg2, ...)>

Runs the command C<openssl $arg1 $arg2 ...>, feeding it $stdin_text on
its standard input.  In list context, returns a ($stdout_text,
$stderr_text) pair.  In scalar context, returns the text of the
combined standard output and error streams.  Throws an exception if
the C<openssl> command is unavailable (that is, L</openssl_path>
returns undef).  Upon return $? will be set to the exit status of
C<openssl>.

=cut

use IPC::Run ();
use Carp ();
sub run_thru_openssl {
    my ($data, @cmdline) = @_;

    $data = "" if (! defined($data));
    Carp::croak "Bizarre first argument passed to run_thru_openssl()"
        if ref($data);

    defined(my $binary = openssl_path) or die "Cannot find openssl binary";
    unshift(@cmdline, $binary);

    if (wantarray) {
        my ($out, $err);
        IPC::Run::run(\@cmdline, \$data, \$out, \$err);
        return ($out, $err);
    } else {
        my $out;
        IPC::Run::run(\@cmdline, \$data, \$out, \$out);
        return $out;
    }
}

=item I<run_dumpasn1($der)>

Runs the I<dumpasn1> command (found in $ENV{PATH}) on $der and returns
its output.  Throws an exception if dumpasn1 fails for some reason.

=cut

sub run_dumpasn1 {
    my ($der) = @_;
    my $out;
    IPC::Run::run(["dumpasn1", "-"], \$der, \$out, \$out);
    die "dumpasn1 failed with code $?" if $?;
    return $out;
 }


=item I<run_perl($scripttext)>

Runs $scripttext in a sub-Perl interpreter, returning the text of its
combined stdout and stderr as a single string.  $? is set to the exit
value of same.

=item I<run_perl_ok($scripttext)>

=item I<run_perl_ok($scripttext, \$stdout)>

=item I<run_perl_ok($scripttext, \$stdout, $testname)>

Like L</run_perl> but simultaneously asserts (using L<Test::More>)
that the exit value is successful.  The return value of the sub is the
status of the assertion; the output of $scripttext (that is, the
return value of the underlying call to I<run_perl>) is transmitted to
the caller by modifying in-place the scalar reference passed as the
second argument, if any.  Additionally the aforementioned output is
passed to L<Test::More/diag> if the script does exit with nonzero
status.

=cut

sub run_perl {
    my ($scripttext, $outref, $testname) = @_;

    Carp::croak "Bizarre first argument passed to run_perl()"
        if (! defined($scripttext) || ref($scripttext));

    if ($ENV{DEBUG}) {
        my $scriptdir = catdir(tempdir(), "run_perl_ok");
        File::Path::mkpath($scriptdir);
        my $scriptfile = catfile
            ($scriptdir, sprintf("run_perl_ok_%d_%d", $$,
                                 _unique_number()));
        write_file($scriptfile, $scripttext);
        diag(<<"FOR_CONVENIENCE");
run_perl: a copy of the script to run was saved in $scriptfile
to ease debugging.
FOR_CONVENIENCE
    }

    my ($perl) = ($^X =~ m/^(.*)$/); # Untainted
    my @perlcmdline = ($perl, (map { -I => $_ }
                               (grep {! m|/usr|} @INC)),  # Shame, shame.
                      );

    diag(join(" ", @perlcmdline)) if $ENV{DEBUG};

    my $stdout;
    IPC::Run::run(\@perlcmdline, \$scripttext, \$stdout, \$stdout);
    return $stdout;
}

sub run_perl_ok {
    my ($code, $outref, $testname) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    $testname ||= "run_perl_ok";
    my $out = run_perl($code);
    $$outref = $out if ref($outref) eq "SCALAR";
    my $retval = is($?, 0, $testname);
    diag($out) if ! $retval;
    return $retval;
}

=item I<certificate_looks_ok($pem_certificate)>

=item I<certificate_looks_ok($pem_certificate, $test_name)>

Checks that a certificate passed as a PEM string looks OK to OpenSSL,
meaning that the signature validates OK and OpenSSL is able to parse
it.

=cut

sub certificate_looks_ok {
    my ($pem_certificate, $test_name) = @_;

    $test_name ||= "certificate_looks_ok";
    test $test_name => sub {
        my ($out, $err);
        ($out, $err) =
            run_thru_openssl($pem_certificate, qw(x509 -noout -text));
        unless (is($?, 0, "openssl execution failed with code $?")) {
            diag $err;
            return;
        }
        unlike($out, qr/error/,
             "openssl seemed to dislike the certificate");
        like($out, qr/Certificate:/,
             "openssl seemed not to be able to parse the certificate");
    };
}

=item I<certificate_chain_ok($pem_certificate, \@certchain )>

=item I<certificate_chain_ok($pem_certificate, \@certchain , $test_name)>

Checks that a certificate passed as a PEM string is validly signed by
the certificate chain @certchain, which is a list of PEM strings
passed as a reference.

=cut