App-CamelPKI
view release on metacpan or search on metacpan
lib/App/CamelPKI/CADB.pm view on Meta::CPAN
=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;
}
if (! -d $dir) {
mkpath($dir) or
throw App::CamelPKI::Error::IO("cannot create path",
-IOfile => $dir);
}
$class->_connect($dir)->deploy();
return;
}
=head2 load($dir)
Restricted constructor (see L<App::CamelPKI::RestrictedClassMethod>).
Loads the database from the $dir directory and returns a read-write
object.
=cut
sub load : Restricted {
my ($class, $dir) = @_;
$class->initdb($dir);
my $self = bless
{ dbix => $class->_connect($dir),
}, $class;
$self->{dbix}->txn_begin;
if (defined(our $debugsub)) { # See L</debug_statements>
$self->{dbix}->storage->debugobj
(App::CamelPKI::CADB::_Logger->new($debugsub));
$self->{dbix}->storage->debug(1);
}
return $self;
}
=head2 add($cert, %infos)
Add a certificate to the database. $cert is an instance of
L<App::CamelPKI::Certificate> which must not be already existing.
%infos is a table of nominative informations, dealt as an opaque chain,
where keys must been validaded by the regular expression qr/[a-z0-9_]+/,
and values are character chains or references to a character chains table.
Semantics on these informations is at the caller's choice; from the
I<App::CamelPKI::CADB> point of view, these informations can be used as
search expression in L</search>, and be consulted using L</infos> in
L</App::CamelPKI::CADB::Cursor>.
=cut
sub add {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
if (@_ % 2);
my ($self, $cert, %infos) = @_;
my $dercert = $cert->serialize(-format => "DER");
throw App::CamelPKI::Error::Database("Certificate already entered")
if $self->{dbix}->resultset("Certificate")
->search({der => $dercert})->count;
my $certid = $self->{dbix}->resultset("Certificate")->create
({der => $dercert, serial => $cert->get_serial,
not_before => $cert->get_notBefore,
not_after => $cert->get_notAfter,
})->id;
foreach my $key (keys %infos) {
foreach my $val (ref($infos{$key}) eq "ARRAY" ? @{$infos{$key}} :
($infos{$key})) {
$self->{dbix}->resultset("CertInfo")
->create({certid => $certid,
key => $key,
val => $val});
}
}
1;
}
=head2 search(%criteria)
Search certificates that were added (L</add>) precedently, using
%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
lib/App/CamelPKI/CADB.pm view on Meta::CPAN
# Fields that follow are de-normalisations on the "der" field,
# to allow searchs.
# The serial number, on a hexadecimal textual form, used by
# Crypt::OpenSSL::CA (ie "0x1234deadbeef").
serial => {data_type => "text",
is_nullable => 0,
},
# Dates of validity for the certificate, in "zulu" format with
# 4 digit for the year date.
not_before => { data_type => "text",
is_nullable => 0 },
not_after => { data_type => "text",
is_nullable => 0 },
);
__PACKAGE__->set_primary_key("certid");
__PACKAGE__->has_many("infos",
"App::CamelPKI::CADB::_Schema::CertInfo", "certid");
=head2 App::CamelPKI::CADB::_Schema::Sequence
This class represents the "sequences" table, which contains one line
for each sequence created with L</next_serial> or L</max_serial>.
=cut
package App::CamelPKI::CADB::_Schema::Sequence;
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw(Core));
__PACKAGE__->table("sequences");
__PACKAGE__->add_columns
# The name of the sequence, in minor case
(name => { data_type => "text",
is_nullable => 0,
},
# The current sequence number
val => { data_type => "integer",
is_nullable => 0,
});
__PACKAGE__->set_primary_key("name");
=head2 App::CamelPKI::CADB::_Schema
This class represents the whole database schema. Instances of this
class (created by L</_connect>) represent a connection to a concrete
database.
=cut
package App::CamelPKI::CADB::_Schema;
use base qw/DBIx::Class::Schema/;
__PACKAGE__->load_classes(qw(Certificate CertInfo Sequence));
=head3 throw_exception
Overload of the parent class to throw
L<App::CamelPKI::Error/App::CamelPKI::Error::Database>.
=cut
sub throw_exception {
my $self = shift;
throw App::CamelPKI::Error::Database(join(" ", @_));
}
=head2 App::CamelPKI::CADB::_Logger
Auxilliary class to observe SQL requests, as suggested in
L<DBIx::Class:Manual::Cookbook/Profiling>. Used by L</load>
to honor the setting done by L</debug_statements>.
=cut
package App::CamelPKI::CADB::_Logger;
sub new {
my ($class, $debugfunc) = @_;
bless { debugfunc => $debugfunc }, $class;
}
sub txn_begin {}
sub txn_commit {}
sub query_start {}
sub query_end {
my ($self, @params) = @_;
$self->{debugfunc}->(@params);
}
require My::Tests::Below unless caller;
1;
__END__
=head1 TEST SUITE
=cut
use Test::More qw(no_plan);
use Test::Group;
use File::Spec::Functions qw(catfile catdir);
use IO::File;
use Fatal qw(mkdir);
use File::Slurp qw(read_file);
use App::CamelPKI::Error;
use App::CamelPKI::Sys qw(fork_and_do);
use App::CamelPKI::Test qw(%test_self_signed_certs
%test_entity_certs);
use App::CamelPKI::Certificate;
use Crypt::OpenSSL::CA;
test "learning: storing with real pieces of NUL characters "
. "inside" => sub {
# Let's prepare a dummy schema...
{
package Bogus::Schema::Beware;
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw(Core));
__PACKAGE__->table("beware");
__PACKAGE__->add_columns("blob" => { data_type => "blob" });
package Bogus::Schema;
( run in 0.863 second using v1.01-cache-2.11-cpan-39bf76dae61 )