App-CamelPKI
view release on metacpan or search on metacpan
lib/App/CamelPKI/CADB.pm view on Meta::CPAN
#!perl -w
package App::CamelPKI::CADB;
use warnings;
use strict;
=head1 NAME
B<App::CamelPKI::CADB> - Store L<App::CamelPKI::CA> datas in a SQLite database
=head1 SYNOPSIS
=for My::Tests::Below "synopsis"
use App::CamelPKI::CADB;
my $cadb = load App::CamelPKI::CADB($dir);
my $serial = $cadb->next_serial("certificate");
# ... making a $certificate with $serial ...
$cadb->add($cert, foo => "bar", baz => [ "quux", "bloggs" ]);
$cadb->revoke($certificate, -revocation_reason => "keyCompromise",
-compromise_time => "20070313104800Z");
$cadb->commit();
for(my $cursor = $cadb->search(-initially_valid_at => "now",
-revoked => 1);
$cursor->has_more; $cursor->next) {
my $cert = $cursor->certificate;
my %infos = $cursor->infos;
my $revocation_time = $cursor->revocation_time;
my $revocation_reason = $cursor->revocation_reason;
my $compromise_time = $cursor->compromise_time;
# ... making the CRL ...
}
=for My::Tests::Below "synopsis" end
=head1 DESCRIPTION
This class modelizes a CA database; this database store issued
certificates, nominative datas used for their creation, revocation
status of these certificates, and some incremental series for CRL
and certificates serial numbers.
For now, Camel-PKI only knows howto store certificates in an SQLite
database.
=head1 CAPABILITY DISCIPLINE
Possessing an I<App::CamelPKI::CADB> instance equates privilege to perform
all non-destructive write operations on this database; however, no
deletion of certificates is possible.
The L</facet_readonly> method returns a read-only version on this
database.
The L</debug_statements> method is restricted (see
L<App::CamelPKI::RestrictedClassMethod>), despite it not being a class
method; the result is that it cannot be called at all when
I<App::CamelPKI::RestrictedClassMethod> is active, which is what we want
(C<debug_statements()> is not meant to be called at all in
production).
=cut
use File::Path qw(mkpath);
use File::Spec::Functions qw(catfile catdir);
use SQL::Translator 0.07; # On behalf of ->deploy()
use App::CamelPKI::Error;
use App::CamelPKI::RestrictedClassMethod ':Restricted';
use App::CamelPKI::Time;
use App::CamelPKI::Certificate;
=head1 METHODS
=head2 initdb($dir)
Populates $dir, a string containing the name of a directory, with an
empty database. Returns immediately if $dir already exists.
=cut
sub initdb {
my ($class, $dir) = @_;
my $db_file = $class->_db_file($dir);
my $dsn = $class->_dsn($dir);
if (-f $db_file) {
$class->_connect($dir); # Acts as a functional test
return;
}
lib/App/CamelPKI/CADB.pm view on Meta::CPAN
%criteria criteria in a conjonctive way (ie, dealt with the "AND"
operator).
If %criteria does not contain any key C<< -initially_valid_at >>
and C<< -revoked >>, then %criteria is supposed to implicitly contain
-initially_valid_at => "now", -revoked => 0
to make I<search()> returns only valid certificates (in the RFC3280
way), if not stated otherwise.
In a more general way, keys and values for %criteria are:
=over
=item I<< -certificate => $cert >>
Renvoie uniquement le certificat identique à $cert, une instance de
L<App::CamelPKI::Certificate>.
=item I<< -initially_valid_at => $time >>
Returns only certificates that were initially scheduled to be valid at
$time date, regardless of whether they have been revoked (but see also
C<< -revoked >>). In other words, returns certificates that match
notBefore <= $time && $time <= notAfter
$time is either an object of class L<App::CamelPKI::Time>, a date in the
"zulu" format (yyyymmddhhmmssZ), or the special string "now".
=item I<< -revoked => 1 >>
Returns only revoked certificates, ie those for which the most recent
call to L</revoke> did not specify C<< -reason => "removeFromCRL" >>.
=item I<< -revoked => 0 >>
Returns only valid certificates, or those that were un-revoked by
passing C<< -reason => "removeFromCRL" >> to L</revoke>.
=item I<< -revoked => undef >>
Search certificates without consideration for their revocation status.
Used to cancel the effect of the implicit value mentioned above.
=item I<< -serial => serial >>
Search certificates for the certifiate serial.
=item I<< $infokey => $infoval >>
where $infokey doesn't start by a hyphen (-): returns only
certificate(s) that had $infokey and $infoval among their %infos at
the time they where added using L</add>. $infoval may be undef,
indicating that any value for $infokey in %infos is acceptable.
=back
The return value in list context is a list of L<App::CamelPKI::Certificate>
object class. In scalar context, a B<cursor object> of the
L</App::CamelPKI::CADB::Cursor> class is returned.
=cut
sub search {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
unless (@_ % 2);
my ($self, %searchkeys) = @_;
if (! exists $searchkeys{-initially_valid_at} &&
! exists $searchkeys{-revoked}) {
$searchkeys{-initially_valid_at} = "now";
$searchkeys{-revoked} = 0;
}
# Using DBIx::Class release 0.07003, the join list to execute don't
# support iterative enumeration, unlike the WHERE clauses. We must
# use this dirty kludge, that violates DBIx::Class encapsulation in
# two points:
my @joins;
my $cursor = $self->{dbix}->resultset("Certificate")
->search({ }, { join => \@joins }); # Encaps violation
# number 1: we will be modifying \@joins later
while(my ($k, $v) = each %searchkeys) {
if ($k !~ m/^-/) {
push(@joins, "infos");
my $qualifier = (@joins == 1) ? "" : "_" . scalar(@joins);
# encapsulation violation number 2: we try to guess the
# way DBIx::Class disambiguates the join column names.
$cursor = $cursor->search
({ "infos${qualifier}.key" => $k,
( defined($v) ? ("infos${qualifier}.val" => $v) : () ),
});
} elsif ($k eq "-certificate") {
throw App::CamelPKI::Error::Internal("INCORRECT_ARGS")
unless eval { $v->isa("App::CamelPKI::Certificate") };
$cursor = $cursor->search
( { der => $v->serialize(-format => "DER") } );
} elsif ($k eq "-initially_valid_at") {
$v = App::CamelPKI::Time->parse($v);
$cursor = $cursor->search
( { not_before => { "<=", $v->zulu },
not_after => { " >=", $v->zulu }} );
} elsif ($k eq "-serial") {
$cursor = $cursor->search
( { serial => { "=", $v } } );
} elsif ($k eq "-revoked") {
if (! defined($v)) {
# no-op
} elsif ($v) {
# Only revoked certificates
$cursor = $cursor->search
# Yes, { "!=", undef } correctly translates to "IS
# NOT NULL". Props to SQL::Abstract!
( [ -and => { revocation_time => { "!=", undef } },
{ revocation_reason => { "!=", "removeFromCRL" } }
] );
} else {
# Only *not* revoked certificates
$cursor = $cursor->search
( [ -or => { revocation_time => { "==", undef } },
{ revocation_reason => "removeFromCRL" }
] );
}
} else {
throw App::CamelPKI::Error::Internal
("INCORRECT_ARGS", -details => "Unknown search key $k");
}
}
$cursor = (ref($self) . "::Cursor")->_new
($cursor, $self->{dbix}->resultset("CertInfo"));
return $cursor if ! wantarray;
my @retval;
for(; $cursor->has_more; $cursor->next) {
push(@retval, $cursor->certificate);
}
return @retval;
}
=head2 revoke($cert, %options)
Mark a certificate as revoked, for the CA to know it must been
included in the next CRLs. $cert is an instance of
L<App::CamelPKI::Certificate>. Known Named options are:
=over
=item I<< -revocation_time => $time >>
The revocation date, in "zulu" format (yyyymmddhhmmssZ). By default,
the current date is used.
=item I<< -revocation_reason => $reason >>
=item I<< -hold_instruction => $oid >> (B<NOT IMPLEMENTED YET>)
=item I<< -hold_instruction => $string >> (B<NOT IMPLEMENTED YET>)
=item I<< -compromise_time => $time >>
Values of the extensions of the same name in the CRL, as documented in
L<Crypt::OpenSSL::CA/add_entry>. By default, these extensions are
omitted. Using C<removeFromCRL> as C<$reason> cancels the revocation
of this certificate. Please note that values for keys
C<-hold_instruction> and C<-revocation_reason> undergo
canonicalization, so that they may read out differently from the
L</App::CamelPKI::CADB::Cursor> when fetched again.
=back
=cut
sub revoke {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
if (@_ % 2);
my ($self, $cert, %options) = @_;
throw App::CamelPKI::Error::Internal("UNIMPLEMENTED")
if ($options{-hold_instruction});
# ... And thus, I can just skip field canonicalization issues for
# now!
my $cursor = $self->{dbix}->resultset("Certificate")
->search({ der => $cert->serialize(-format => "DER") });
throw App::CamelPKI::Error::Database
("Unknown certificate", -certificate => $cert)
unless defined(my $row = $cursor->next);
throw App::CamelPKI::Error::Database
("Duplicate certificate", -certificate => $cert)
if $cursor->next;
$row->revocation_time
(App::CamelPKI::Time->parse($options{-revocation_time} || "now")
->zulu);
$row->compromise_time
(App::CamelPKI::Time->parse($options{-compromise_time})->zulu)
if (exists $options{-compromise_time});
$row->revocation_reason($options{-revocation_reason})
if (exists $options{-revocation_reason});
$row->update;
1;
}
=head2 next_serial($seqname)
Increments the sequence named $seqname and returns its new value.
$seqname may be any string matching m/^[a-z]+$/i, at the caller's
choice. Sequences start at 2.
=cut
sub next_serial {
my ($self, $seqname) = @_;
my $row = $self->{dbix}->resultset("Sequence")->find_or_new
({name => $seqname});
if (! $row->in_storage) {
$row->val(2);
$row->insert();
return 2;
} else {
my $retval = $row->val + 1;
$row->val($retval);
$row->update();
return $retval;
}
}
=head2 commit()
Commits all modifications made with L</add>, L</revoke> and
L</next_serial> since the construction of this object, or the previous
call to I<commit()>, whichever is latest. B<If commit() is not
called, no write will be made to the file system, and all
modifications will be lost!>.
=cut
sub commit {
my ($self) = @_;
$self->{dbix}->txn_commit();
$self->{dbix}->txn_begin();
}
=head2 max_serial($seqname)
Returns (an approximation of) the current status of the sequence named
$seqname, ie an integer which is guaranteed to be superior or equal to
all previous values previously returned by L</next_serial>, and
strictly inferior to all values that will be returned in the future.
=cut
sub max_serial {
my ($self, $seqname) = @_;
my $row = $self->{dbix}->resultset("Sequence")->find_or_new
({name => $seqname});
return ($row->in_storage ? $row->val : 0);
}
=head2 facet_readonly()
Returns a read-only copy of the database object: only L</search> and
L</max_serial> methods are available.
=cut
sub facet_readonly {
my ($self) = @_;
return bless { delegate => $self },
"App::CamelPKI::CADB::FacetReadOnly";
package App::CamelPKI::CADB::FacetReadOnly;
use Class::Facet from => "App::CamelPKI::CADB",
on_error => \&App::CamelPKI::Error::Privilege::on_facet_error,
delegate => [qw(search max_serial)];
}
=head2 debug_statements($debugsub)
This restricted method (see L<App::CamelPKI::RestrictedClassMethod>)
installs $debugsub as the SQL request observer on all
I<App::CamelPKI::CADB> objects constructed later. This method will be
called thusly for each SQL request:
$debugsub->($sql, @bind_values);
This mecanism is only destined for testing purposes; it should not
be used in production.
=cut
sub debug_statements : Restricted {
my ($class, $debugsub) = @_;
our $debugsub = $debugsub;
}
=head1 App::CamelPKI::CADB::Cursor
This class models a read only SQL cursor equivalent; instancies may be
constructed using L</search>.
An attentive reader will probably understand that's a fairly trivial
derivation of the L<DBIx::Class> API; However there is no reason to
return directly an instance of I<DBIx::Class> in L</search> because
it will violate the encapsulation of I<App::CamelPKI::CADB>. Consequence
could be a induced coupling (it should be impossible to refactor the
scheme without breaking the whole calling code), and worse, a
privilege escape leading to a security breach (because it's also
possible to write with a I<DBIx::Class> cursor).
=cut
package App::CamelPKI::CADB::Cursor;
=begin internals
=head2 _new($realcursor, $infos_resultset)
Constructor. $realcursor is an instance of
L<DBIx::Class::ResultSet> coming from
L</App::CamelPKI::CADB::_Schema::Certificate> which represents all certificates
to be enumerated; $infos_resultset is an instance of
L<DBIx::Class::ResultSet> coming from L</App::CamelPKI::CADB::_Schema::CertInfos>
which represents the B<totality> of B<CertInfos> in database, and it's the
job of I<App::CamelPKI::CADB::Cursor> to restrict this search to what it is
interresting.
=cut
sub _new {
my ($class, $cursor, $infos_resultset) = @_;
return bless {
index => 0,
cursor => $cursor,
infos_set => $infos_resultset,
}, $class;
}
=head2 _fetch_certificates()
Execute the SQL request that rocks, grab in one shot all certificates
and their revocation informations, and cache them in $self->{certs}
which become a list of objects form the
L</App::CamelPKI::CADB::_Schema::Certificate>.
Rationale for this 'slurpy' behavior: SQLite does not appreciate to have
a statement in progress when you close the connection (symptom:
C<cannot commit transaction - SQL statements in progress(1)>). That's
why we cannot use the "streaming" mode of DBIx::Class without a complex
system of statement caching in one time, I'm just too lazy to implement
right now...
=cut
sub _fetch_certificates {
my ($self) = @_;
return if $self->{certs};
$self->{certs} = [];
$self->{cursor}->reset;
while(my $row = $self->{cursor}->next) {
push (@{$self->{certs}}, $row);
}
return;
}
=head2 _fetch_infos()
Functions as L</_fetch_certificates> (which is called before each operation
of this method), grab in one shot all nominative informations about
certificates, and cache them in $self->{infos} in the form of a reference
to a list of same length as @{$self->{certs}} and ordored the same way,
which contains as many multi-valued hash tables to store informations
as passed by L</add> at the time of the respective certificates insertion.
=cut
sub _fetch_infos {
my ($self) = @_;
return if $self->{infos};
$self->_fetch_certificates;
my %infos;
# FIXME: we could repeat the $self->{cursor} SQL instead.
# This could helps to play too much DBI placeholders...
my $infocursor = $self->{infos_set}->search
({ certid => { in => [ map { $_->certid } @{$self->{certs}} ] }});
$infocursor->reset;
while(my $info = $infocursor->next) {
push(@{$infos{$info->certid}->{$info->key}},
$info->val);
}
$self->{infos} = [ map { ($infos{$_->certid} || {}) }
@{$self->{certs}} ];
return;
}
=head2 _current()
Returns the tuple object currently under the cursor.
=cut
sub _current {
my ($self) = @_;
$self->_fetch_certificates;
return $self->{certs}->[$self->{index}];
}
=end internals
=head2 count
Returns the total number of entries in this cursor, independently of the number
of times L</next> has already been called.
=cut
sub count {
my ($self) = @_;
return @{$self->{certs}} if $self->{certs};
# No-camel optimization, isn't it? No! learning test of
# DBIx::Class! Syntagm found in
# L<DBIx::Class::Manual::Cookbook>.
my $count = $self->{cursor}->search
({}, {
select => [ { count => { distinct => 'me.certid' } } ],
as => [ 'count' ]
});
my $retval = $count->next->get_column("count");
$count->next; # Reach the end of records, close the statment
# subjacent handle, and so remove an useless warning.
return $retval;
}
=head2 has_more
Returns true if, and only if, the cursor has still some results to propose.
All methods hereafter have an undef behavior when I<has_more> returns false.
=cut
sub has_more { defined(shift->_current) }
=head2 next
Makes the cursor advance one position.
=cut
sub next {
my ($self) = @_;
$self->{index}++;
return;
}
=head2 certificate
Returns the certificate currently under the cursor, in a
L<App::CamelPKI::Certificate> object.
=cut
sub certificate { App::CamelPKI::Certificate->parse(shift->_current->der) }
=head2 infos
Returns a table of structures and contents simliar to the table
%infos passed to L</add> at the time of the certiticate insertion
in database. In a scalar context, returns a reference on a hash
which contains references on lists; In a list context, returns this
same hash "flat" (a list alternating scalar keys and values which
are references on lists).
The order of the %info keys, and the order of values contained in when
more than on key provided, is B<not> preserved.
=cut
sub infos {
my ($self) = @_;
$self->_fetch_infos;
return wantarray ? %{$self->{infos}->[$self->{index}]} :
$self->{infos}->[$self->{index}];
}
=head2 revocation_time
=head2 revocation_reason
=head2 compromise_time
=head2 hold_instruction
Returns the canonical form of the revocation informations corresponding
to the certificate present under the cursor at that time: time stamps
are in "zulu" format; I<revocation_reason()> returns a symbolic character
chains among the one listed in RFC3280 section 5.3.1; I<hold_instruction()>
returns an OID in decimal notation separated by dots (for example
C<1.2.840.10040.2.1>).
=cut
sub revocation_time { shift->_current->revocation_time }
sub revocation_reason { shift->_current->revocation_reason }
sub compromise_time { shift->_current->compromise_time }
sub hold_instruction { shift->_current->hold_instruction }
=begin internals
=head1 INTERNAL METHODS
=cut
package App::CamelPKI::CADB;
=head2 DESTROY
Called when the object is to be destroyed; disconnect the underlying
database to get rid off stupid warnings (see discussions on
L<http://lists.rawmode.org/pipermail/dbix-class/2006-October/002567.html>).
=cut
sub DESTROY {
local $@;
my ($self) = @_;
return if ! defined $self->{dbix};
my $storage = $self->{dbix}->storage; return if ! defined $storage;
$storage->disconnect;
}
=head1 INTERNAL CLASS METHODS
=head2 _schema_class
Returns the name of the object class containing the schema declaration,
L</App::CamelPKI::CADB::_Schema>.
=cut
sub _schema_class {
my ($self) = @_;
$self = ref($self) if ref($self);
return "${self}::_Schema";
}
=head2 _db_file($homedir)
Returns the name of the file which contains the SQLite database.
=cut
sub _db_file {
my ($class, $dir) = @_;
return catfile($dir, "ca.db");
lib/App/CamelPKI/CADB.pm view on Meta::CPAN
=head2 open_db()
Open a connection to the database for testing purposes. SQL requests
are recorded in the @queries global variable, so that tests are able
to inspect the requests they caused to be made. If the $debug_queries
variable is set to a true value, SQL requests will also be printed to
STDERR.
=cut
our @queries;
our $debug_queries;
App::CamelPKI::CADB->debug_statements(sub {
my ($sql, @bind_values) = @_;
push(@queries, $sql);
map { $_ = "<der>" if m/[\000-\010]/ } @bind_values;
diag join(" / ", $sql, @bind_values) . "\n" if $debug_queries;
});
sub open_db {
my $cadb = load App::CamelPKI::CADB($testdir);
return $cadb;
}
test "->add()" => sub {
my $cadb = open_db;
$cadb->add($cert, template => "foobar");
try {
$cadb->add($cert, zoinx => ["deux", "mille" ]);
fail("inserting doubled bloom prohibited");
} catch App::CamelPKI::Error::Database with {
pass;
};
$cadb = open_db;
$cadb->add($cert, template => "foobar"); # Works because the
# transaction has been rollbacked
$cadb->add(App::CamelPKI::Certificate->parse
($test_entity_certs{"rsa1024"}),
foo => "bar",
zoinx => ["is", "tan" ],
);
$cadb->commit;
is($cadb->search()->count(), 2, "certificates in base");
};
test "->search() in list context" => sub {
my $cadb = open_db;
my @certs = $cadb->search(-initially_valid_at => "20010101020400Z");
is(scalar(@certs), 0);
@certs = $cadb->search(-initially_valid_at => "now");
is(scalar(@certs), 2, "all certificates");
grep { ok($_->isa("App::CamelPKI::Certificate")) } @certs;
@certs = $cadb->search(-certificate => $cert);
is(scalar(@certs), 1);
ok($certs[0]->equals($cert));
};
test "->search() with a cursor" => sub {
my $cadb = open_db;
my $cursor = $cadb->search(-revoked => undef);
is($cursor->count, 2);
ok($cursor->has_more);
ok($cursor->certificate->isa("App::CamelPKI::Certificate"));
$cursor->next;
ok($cursor->has_more);
ok($cursor->certificate->isa("App::CamelPKI::Certificate"));
$cursor->next;
ok(! $cursor->has_more);
$cursor = $cadb->search(-revoked => undef);
isnt($cursor->infos, undef,
"consulting ->infos available "
. "even if we don't look for them");
$cursor = $cadb->search(template => "foobar", -revoked => 0);
ok($cursor->has_more);
is($cursor->infos->{template}->[0], "foobar");
ok($cursor->has_more, "the cursor did not move");
$cursor->next; ok(! $cursor->has_more);
$cursor = $cadb->search(template => "foobar", -revoked => 1);
ok(! $cursor->has_more);
is($cursor->count, 0, 'Filter "and" which exclude all');
# This one is tricky: the search matches for two reasons (zoinx =>
# "is" and zoinx => "tan"), but we want only one response back.
$cursor = $cadb->search(zoinx => undef);
is($cursor->count, 1);
is_deeply([ sort @{$cursor->infos->{zoinx}}], [qw(is tan)])
or warn Data::Dumper::Dumper(scalar $cursor->infos);
};
test "REGRESSION: searching with multiple nominatives keys" => sub {
my $cadb = open_db;
my @certs = $cadb->search(foo => "bar", zoinx => "is");
is(scalar(@certs), 1);
@certs = $cadb->search(foo => "bar", zoinx => "is", zoinx => "tan");
is(scalar(@certs), 1);
};
test "->revoke()" => sub {
my $cadb = open_db;
$cadb->revoke($cert, -revocation_reason => "keyCompromise",
-compromise_time => "now");
$cadb->commit();
is($cadb->search()->count(), 1, "only valid certificates by default");
is($cadb->search(-revoked => undef)->count(), 2,
"all certificates");
is($cadb->search(-revoked => 1)->revocation_reason, "keyCompromise");
like($cadb->search(-revoked => 1)->compromise_time,
qr/^\d{4}\d{2}\d{2}\d{2}\d{2}\d{2}Z$/,
"the compromise time has been canonicalized");
$cadb->revoke($cert, -revocation_reason => "removeFromCRL");
$cadb->commit();
is($cadb->search()->count(), 2, "certificate redemption");
};
test "->next_serial() et ->max_serial()" => sub {
my $cadb = open_db;
my @serialz = map { $cadb->next_serial("corn") } (1..10);
grep { cmp_ok($serialz[$_], ">=", 2) } (0..$#serialz);
grep { cmp_ok($serialz[$_ - 1], "<", $serialz[$_]) } (1..$#serialz);
my $maxserial = $cadb->max_serial("corn");
is($cadb->max_serial("corn"), $maxserial,
"->max_serial is idempotent");
grep { cmp_ok($serialz[$_], "<=", $maxserial) } (0..$#serialz);
cmp_ok($cadb->next_serial("corn"), ">", $maxserial);
};
test "real unicity for ->next_serial() and ->max_serial()" => sub {
my $numprocs = 5; my $numincs = 10; my $numcommits = 10;
my $resultsfile = catfile($testdir, "serialz.txt");
my $fd = new IO::File($resultsfile, ">");
$fd->autoflush(1);
my @pids = map { fork_and_do {
my $base = open_db;
COMMIT: for my $i (1..$numcommits) {
my $done = try {
for my $j (1..$numincs) {
$fd->print($base->next_serial("zoinx") . "\n");
}
$base->commit;
1;
} catch Error with {
my $E = shift;
die($E) unless ($E =~ m/database is locked/i);
select(undef, undef, undef, rand);
$base = open_db;
0;
};
# If we got a serial with ->next_serial, the test as now
# written makes it mandatory that we succeed to commit
# later. It's not strictly needed if the caller knows how to
# do a two-phase commit, but we err on the safe side.
redo COMMIT if ! $done;
}
} } (1..$numprocs);
while(@pids) { waitpid(shift(@pids), 0); }
my @lines = read_file($resultsfile);
is(scalar(@lines), $numprocs * $numincs * $numcommits,
"right number of lines in $resultsfile");
my %serialz = map { $_ => 1 } (@lines);
is(scalar(keys %serialz), scalar(@lines),
"no collision in $resultsfile");
};
change_db_dir();
use App::CamelPKI::Test qw(%test_public_keys %test_keys_plaintext);
test "->search() and left-join request optimization"
=> sub {
my $cadb = open_db;
my $pubkey = Crypt::OpenSSL::CA::PublicKey
->parse_RSA($test_public_keys{rsa1024});
my $privkey = Crypt::OpenSSL::CA::PrivateKey
->parse($test_keys_plaintext{rsa1024});
foreach my $i (1..100) {
my $cert_to_be = Crypt::OpenSSL::CA::X509->new($pubkey);
$cert_to_be->set_notBefore("20070101000000Z");
$cert_to_be->set_notAfter("20570101000000Z");
$cert_to_be->set_serial(sprintf("0x%x", $i));
my $cert = App::CamelPKI::Certificate->parse
($cert_to_be->sign($privkey, "sha256"));
$cadb->add($cert, foo => "bar", baz => "quux");
}
$cadb->commit();
@queries = ();
my $cursor = $cadb->search(-revoked => undef);
foreach my $i (1..100) {
ok($cursor->has_more);
is($cursor->infos->{foo}->[0], "bar");
is($cursor->infos->{baz}->[0], "quux");
$cursor->next;
}
ok(! $cursor->has_more);
cmp_ok(scalar(@queries), "<", 10,
"the number of requests is sub-linear "
. "wrt the number of fetched certificates");
};
change_db_dir();
test "REGRESSION: searching by infos must not mask some of them"
=> sub {
my $cadb = open_db;
my $cert = App::CamelPKI::Certificate->parse
($test_self_signed_certs{"rsa2048"});
$cadb->add($cert, foo => "bar", baz => [ "quux", "bloggs" ]);
# Witness Experiency:
my $cursor = $cadb->search();
is($cursor->count, 1);
my $infos = $cursor->infos;
is($infos->{foo}->[0], "bar")
or warn Data::Dumper::Dumper($infos);
is_deeply([sort @{$infos->{baz}}], [qw(bloggs quux)]);
# Experiency test:
$cursor = $cadb->search(foo => "bar");
is($cursor->count, 1);
is_deeply(scalar($cursor->infos), $infos)
or warn Data::Dumper::Dumper(scalar($cursor->infos));
};
change_db_dir();
test "synopsis" => sub {
my $code = My::Tests::Below->pod_code_snippet("synopsis");
$code =~ s/\bmy /our /g;
my $dir = $testdir;
my $certificate = $cert;
eval "package Synopsis; $code"; fail($@) if $@;
cmp_ok($Synopsis::serial, ">=", 2);
ok($Synopsis::cadb->isa("App::CamelPKI::CADB"));
ok($Synopsis::cursor->isa("App::CamelPKI::CADB::Cursor"));
is($Synopsis::cert->serialize(), $certificate->serialize());
is($Synopsis::infos{foo}->[0], "bar");
is_deeply([sort @{$Synopsis::infos{baz}}], [qw(bloggs quux)]);
like($Synopsis::revocation_time, qr/^\d{4}\d{2}\d{2}\d{2}\d{2}\d{2}Z$/,
"revocation time looks ok");
is($Synopsis::revocation_reason, "keyCompromise");
is($Synopsis::compromise_time, "20070313104800Z");
};
=end internals
=cut
( run in 0.674 second using v1.01-cache-2.11-cpan-39bf76dae61 )