view release on metacpan or  search on metacpan

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

        $req->method("POST");
        ## FIXME: presumably passing the POST payload was supposed to
        ## be done like this,
        # $req->add_content(scalar(JSON::to_json($struct)));
        ## but that doesn't work... so we use a global variable instead!
        ## (see L<App::CamelPKI::Action::JSON>):
        $App::CamelPKI::Action::JSON::request_body_for_tests =
            JSON::to_json($struct);
    }
    my $response = Catalyst::Test::local_request("App::CamelPKI", $req);
    die sprintf("plain request at $url failed with code %d\n%s\n",
                $response->code, $response->content)
        unless $response->is_success;
    my $retval = eval { JSON::from_json($response->content) };
    return $retval if defined $retval;
    die $response;
}

=item I<jsonreq_remote ($url, $struct, %args)>

Sends $struct to a real Apache server at $url, which must be
fully-qualified.  Returns the response as an L<HTTP::Response> object.

Available named options are:

=over

=item I<< -certificate => $certobj >>

=item I<< -certificate => $certpem >>

The certificate to identify oneself as, as an L<App::CamelPKI::Certificate>
instance or PEM string.

=item I<< -key => $keyobj >>

=item I<< -key => $keypem >>

The private key to use along with the certificate, as an
L<App::CamelPKI::PrivateKey> instance or PEM string.

=back

=cut

sub jsonreq_remote {
    my ($url, $structure, @args) = @_;

    my $req = http_request_prepare($url, @args);
    $req->method("POST");
    $req->header("Content-Type" => "application/json");
    $req->content(scalar(JSON::to_json($structure)));
    $req->header("Accept" => "application/json");
    return http_request_execute($req, @args);
}

=item I<jsoncall_remote($url, $struct, %args)>

Like L</jsonreq_remote> but instead of returning an L<HTTP::Response>
object, returns the decoded JSON data structure by reference and
throws an exception if the HTTP request isn't a success or doesn't
decode properly.

=cut

sub jsoncall_remote {
    my $response = jsonreq_remote(@_);
    my $content = $response->content;
    die sprintf("jsoncall_remote: failed with code %d\n%s\n",
                $response->code, $content) if ! $response->is_success;
    my $retval = eval { JSON::from_json($content) };
    return $retval if defined $retval;
    die $content;
}

=item I<call_remote($url)>

Gets $url and return the result.

=cut

sub call_remote {
	my ($url, @args) = @_;
	my $ua = LWP::UserAgent->new;
	my $req = http_request_prepare($url, @args);
    my $res = http_request_execute($req, @args);
 	
 	my $content = $res->content;
 	die sprintf("call_remote: failed with code %d\n%s\n",
                $res->code, $content) if ! $res->is_success;
    return $content if defined $content;
    die $content;
 	
}

=item I<formreq_remote($url $struct, $button, @args)>

Call a form and fill it based on $struct, then push on $button

=cut
sub formreq_remote {
    my ($url, $structure, $button, @args) = @_;
    
	my $ua = LWP::UserAgent->new;
	my $req = http_request_prepare($url, @args);
    my $res = http_request_execute($req, @args);
    
    my $tree = HTML::TreeBuilder->new;
    $tree->parse($res->content);
    $tree->eof();
    
    my @Forms = $tree->find_by_tag_name('FORM');
    die "No forms in page" unless @Forms;
    my $f = HTTP::Request::Form->new($Forms[0], $url);
    foreach my $part (keys(%$structure)){
    	$f->field($part, $structure->{$part});
    }
    my $response = http_request_execute($f->press($button), @args);
    return $response;
}

=item I<formcall_remote($url, $struct, %args)>

Like L</jsonreq_remote> but instead of returning an L<HTTP::Response>
object, returns the page and
throws an exception if the HTTP request isn't a success .

=cut

sub formcall_remote {
    my $response = formreq_remote(@_);
    my $content = $response->content;
    die sprintf("formcall_remote: failed with code %d\n%s\n",
                $response->code, $content) if ! $response->is_success;
    return $content if defined $content;
    die $content;
}

=item I<http_request_prepare($url, %args)>

=item I<http_request_execute($request, %args)>

These functions factor code between L</jsonreq_remote>,
L</plaintextcall_remote> and such, although they may also be called
directly.  I<http_request_prepare> creates and returns and returns a GET
L<HTTP::Request> object that the caller may further tweak, prior to
passing it along to I<http_request_execute>, which in turn does the HTTP/S
request and returns an L<HTTP::Response> object.  Named arguments are
the same as in L</jsonreq_remote>, L</plaintextcall_remote> or
L</jsoncall_remote>.

=cut

sub http_request_prepare {
    my ($url) = @_;
    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);
}

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

    unlike($out, qr/Crypt.*CA/,
           "errors are reported at the proper stack depth");
    # Errors must be propagated:
    like($out, qr/argl/m);
    # But not successes:
    unlike($out, qr/yipee/m);

};

test "certificate_looks_ok" => sub {
    my $ok_cert = <<'OK_CERT';
-----BEGIN CERTIFICATE-----
MIICsDCCAhmgAwIBAgIJAPV18QziY9UvMA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV
BAYTAkFVMRMwEQYDVQQIEwpTb21lLVN0YXRlMSEwHwYDVQQKExhJbnRlcm5ldCBX
aWRnaXRzIFB0eSBMdGQwHhcNMDcwMTI5MDgyODI0WhcNMDcwMjI4MDgyODI0WjBF
MQswCQYDVQQGEwJBVTETMBEGA1UECBMKU29tZS1TdGF0ZTEhMB8GA1UEChMYSW50
ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB
gQDfGYmlOYbpGkBD/agTUnixLcdh6H1XM13w17RbzaoA7byZD6L+Dn8MZd69PuXc
ZAQEUG4Oe6QyAcafsvDb7SHjyJHLoPTOsAZ0ex/0zIJVpw+XyppA8fZx6bnuHKUa
bqfj83OLk/ACfQSBX7bcL7Y8hwYcZJcqyjMzt9BT7oCldwIDAQABo4GnMIGkMB0G
A1UdDgQWBBTu+qGX79xcvFE8pG5zx2FcqAuV5TB1BgNVHSMEbjBsgBTu+qGX79xc
vFE8pG5zx2FcqAuV5aFJpEcwRTELMAkGA1UEBhMCQVUxEzARBgNVBAgTClNvbWUt
U3RhdGUxITAfBgNVBAoTGEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZIIJAPV18Qzi
Y9UvMAwGA1UdEwQFMAMBAf8wDQYJKoZIhvcNAQEFBQADgYEAFRkTlHJwSgOFQtxG
h0HHr4UES2xR+wD9xZOeFGZk066ZEdiOuUvNLYMFEe+Vo9OxAL/SdPt4oOcWremD
lTRumdcVP9vA8K4asPpXKqhpE/2EwDRmYE9g73n50yy2yazifourQmRVqSixs/ew
RSQ7/6JIpIihvyCUDUzM2bvexk8=
-----END CERTIFICATE-----
OK_CERT

    certificate_looks_ok($ok_cert);
    certificate_looks_ok($ok_cert . "\n"); # Robustness

    my $out = run_perl(<<"SCRIPT");
use strict;
use warnings;
use Test::More qw(no_plan);
use App::CamelPKI::Test qw(certificate_looks_ok);

my \$certificate = <<'OK_CERT';
$ok_cert
OK_CERT

certificate_looks_ok(\$certificate, "OK certificate"); # expecting OK
\$certificate =~ s/CQYDVQQGE/CQYDVQQGF/;
certificate_looks_ok(\$certificate, "botched certificate"); # expecting not OK

\$certificate = <<'DUD_CERT'; # Generated with an early version of
# Crypt::OpenSSL::CA; a public key is missing
-----BEGIN CERTIFICATE-----
MIHaMEWgAwIBAgIBATANBgkqhkiG9w0BAQUFADAAMB4XDTcwMDEwMTAwMDAwMFoX
DTcwMDEwMTAwMDAwMFowADAIMAMGAQADAQAwDQYJKoZIhvcNAQEFBQADgYEAsURd
sgu7sYyODuo5bCzkYBLrYb8653jjVt8hecoQj1Ete0X6uHk6t+nJ8qCwURc4FayF
kzapy9zWAGMy+6A/9CQz5862Phf3MkFM4OwkjJARBF7I73WfVEVX4e1PIgl4qjjJ
lgiG5TCUNWQrbRGa6LVDx7DErReEJE5vRwNxvjo=
-----END CERTIFICATE-----
DUD_CERT
certificate_looks_ok(\$certificate, "REGRESSION: dud cert");
         # expecting not OK, lest REGRESSION

certificate_looks_ok({}, "Should have thrown (bad input)"); # Should throw
SCRIPT

    like($out, qr/^ok 1/m);
    like($out, qr/^not ok 2/m);
    like($out, qr/^not ok 3/m);
    unlike($out, qr/^ok 4/m); # Should have died in run_thru_openssl()
    unlike($out, qr/source for input redirection/,
           "REGRESSION: passing undef to certificate_looks_ok() caused a strange error");
};

use App::CamelPKI::Test qw(test_CRL %test_rootca_certs);
use File::Spec::Functions qw(catfile);
test "test_CRL" => sub {
    my $cafile = catfile(App::CamelPKI::Test->tempdir, "cafile");
    write_file($cafile, $test_rootca_certs{"rsa1024"});
    my $crl = test_CRL("rsa1024");
    my $crldump = run_thru_openssl($crl, "crl", "-text",
                                   -CAfile => $cafile);
    is($?, 0);
    like($crldump, qr/no revoked certificates/i);
    write_file($cafile, $test_rootca_certs{"rsa2048"});
    $crl = test_CRL("rsa2048", -members => [ "0x42" ]);
    $crldump = run_thru_openssl($crl, "crl", "-text",
                                   -CAfile => $cafile);
    like($crldump, qr/42/);
};

my $cert_pem = $App::CamelPKI::Test::test_self_signed_certs{"rsa1024"};

# REFACTORME into App::CamelPKI::Test::pem2der or something
my $cert_der = do {
    use MIME::Base64 ();
    local $_ = $cert_pem;
    is(scalar(s/^-+(BEGIN|END) CERTIFICATE-+$//gm), 2,
       "test PEM certificate looks good") or warn $cert_pem;
    MIME::Base64::decode_base64($_);
};

test "x509_decoder" => sub {
    use MIME::Base64;
    my $decoder = App::CamelPKI::Test::x509_decoder('Certificate');
    ok($decoder->can("decode"));
    my $tree = $decoder->decode($cert_der);
    is($tree->{tbsCertificate}->{subjectPublicKeyInfo}
       ->{algorithm}->{algorithm},
       "1.2.840.113549.1.1.1", "rsaEncryption");
};


=head2 Synopsis tests

=cut

test "synopsis" => sub {
    # Thank you Test::Group for being fully reflexive!
    eval My::Tests::Below->pod_code_snippet("synopsis");
    die $@ if $@;
};