App-CamelPKI
view release on metacpan or search on metacpan
inc/My/Module/Build.pm view on Meta::CPAN
my ($self, $message) = @_;
$message = "\n$message" until ($message =~ m/^\n\n/);
$message .= "\n" until ($message =~ m/\n\n$/);
warn $message;
$self->prompt("Press RETURN to continue");
1;
}
=item I<show_fatal_error($message)>
Like L</show_warning>, but throws an exception after displaying
$message.
=cut
sub show_fatal_error {
my ($self, $message) = @_;
$self->show_warning($message);
die "Fatal error, bailing out.\n";
}
lib/App/CamelPKI.pm view on Meta::CPAN
# fully movable and persisted next to the users that have them,
# and this code will morph into a database.
if ($shortclass eq "CA") {
if (! defined $client_dn) {
return $full_model->facet_crl_only;
} elsif ($client_dn eq $admin_dn) {
return $full_model->facet_operational;
} else {
warn "User $client_dn unknown";
throw App::CamelPKI::Error::Privilege
("User unknown",
-dn => $client_dn);
}
} else {
throw App::CamelPKI::Error::Privilege
("Only CA privileges are available to the controller for now.");
}
}
=head2 setup_components
Overloaded from the parent class in order to lock down restricted
class methods in the Camel-PKI model after the respective classes are
loaded (see L<App::CamelPKI::RestrictedClassMethod>). This only occurs in
production (that is, when running under Apache, as determined by
lib/App/CamelPKI/CA.pm view on Meta::CPAN
=head2 load($directory, $cadb)
Restricted constructor (See L<App::CamelPKI::RestrictedClassMethod>).
Load the cryptographic material (private keys and certificates)
from $directory, creating it if needed, and use $cadb, an read-write
instance of L<App::CamelPKI::CADB>, as storage backend.
=cut
sub load : Restricted {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS") if (@_ != 3);
my ($class, $directory, $cadb) = @_;
if (! -d $directory) {
mkpath($directory) or
throw App::CamelPKI::Error::IO("cannot create directory",
-IOfile => $directory);
}
return bless {
db => $cadb,
cryptdir => $directory,
}, $class;
}
=head1 METHODS
lib/App/CamelPKI/CA.pm view on Meta::CPAN
Install the certificate and private key passed in argument in the
CA permanent storage space. The CA is unable to issue certificates
and CRLs until this step is not completed.
$cert is an L<App::CamelPKI::Certificate> object, and $key is an
L<App::CamelPKI::PrivateKey> object.
=cut
sub set_keys {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
unless (@_ % 2);
my ($self, @args) = @_;
while(my ($k, $v) = splice(@args, 0, 2)) {
if ($k eq "-certificate") {
write_file($self->_certificate_path,
$v->serialize(-format => "PEM"));
} elsif ($k eq "-key") {
write_file($self->_key_path,
$v->serialize(-format => "PEM"));
} else {
throw App::CamelPKI::Error::Internal
("INCORRECT_ARGS",
-details => "Unknown cryptographic material",
-type => $k);
}
}
}
=head2 is_operational()
Returns true only if a key and a certificate has been added to this CA
lib/App/CamelPKI/CA.pm view on Meta::CPAN
is detected, triggers an exception. In the same way, the template
may cause additional revocations following the revocation of
$certificate (see L<App::CamelPKI::CertTemplate/test_cascaded_revocation>).
This method is delegated to L<App::CamelPKI::CADB/revoke>, and recognized named
options are documented at this section.
=cut
sub revoke {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
unless (@_ % 2);
my ($self, $template, $cert, %options) = @_;
throw App::CamelPKI::Error::Internal("INCORRECT_ARGS")
if (! defined $cert);
throw App::CamelPKI::Error::Privilege
("Attempt to revoke a certificate foreign to this template",
-certificate => $cert,
-template => $template)
unless $self->database_facet($template)
->search(-certificate => $cert,
-revoked => undef)->count;
$self->{db}->revoke($cert, %options);
}
=head2 commit()
lib/App/CamelPKI/CA.pm view on Meta::CPAN
signing, on the form of a name (for example "sha256").
The default value is "sha256", as "md5" and "sha1" are not recommanded
due to progress done in their cryptanalysis
(L<http://www.win.tue.nl/~bdeweger/CollidingCertificates/>).
=back
=cut
sub issue_crl {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
unless (@_ % 2);
my ($self, %opts) = @_;
$opts{-validity} ||= 7;
$opts{-signature_hash} ||= "sha256";
my $crl = new Crypt::OpenSSL::CA::X509_CRL;
$crl->set_issuer_DN($self->certificate->as_crypt_openssl_ca_x509
->get_subject_DN);
my $now = App::CamelPKI::Time->now;
$crl->set_lastUpdate($now);
lib/App/CamelPKI/CA.pm view on Meta::CPAN
BEGIN { our @ISA = qw(App::CamelPKI::CA::FacetReadonly) };
use Class::Facet delegate => [qw(issue_crl commit)];
# Still meta-programming a bit, but I don't think Class::Facet could
# help me much here and remain generic.
BEGIN { foreach my $methname (qw(issue revoke)) {
my $method = sub {
my ($facetself, $trueself) = Class::Facet->selves(\@_);
throw App::CamelPKI::Error::Privilege
("Unauthorized certificate template $_[0]")
if ($_[0] && $_[0] ne $facetself->{certtemplate});
unshift @_, $trueself;
goto $trueself->can($methname);
};
{ no strict "refs"; *{"$methname"} = $method; }
} }
sub database {
my $self = shift;
lib/App/CamelPKI/CA.pm view on Meta::CPAN
}
}
=head2 facet_operational()
Returns a copy of this object with restricted privileges: the L</set_keys>
cannot be revoked anymore. This facet is suitable to pass to a "regular"
controller which has no rights to modify the CA keys.
Instead of returning an object which could do nothing, I<facet_operational>
throw an exception if L</is_operational> is not true.
=cut
sub facet_operational {
my ($self) = @_;
throw App::CamelPKI::Error::State
("cannot make operational facet "
. "of non-operational CA") unless $self->is_operational;
return bless { delegate => $self }, "App::CamelPKI::CA::FacetOperational";
package App::CamelPKI::CA::FacetOperational;
BEGIN { our @ISA = qw(App::CamelPKI::CA::FacetReadonly); }
use Class::Facet delegate => [qw(issue revoke commit issue_crl get_certificates_issued get_certificates_revoked get_certificate_by_serial)];
}
lib/App/CamelPKI/CADB.pm view on Meta::CPAN
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>).
lib/App/CamelPKI/CADB.pm view on Meta::CPAN
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})) {
lib/App/CamelPKI/CADB.pm view on Meta::CPAN
=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
lib/App/CamelPKI/CADB.pm view on Meta::CPAN
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
lib/App/CamelPKI/CADB.pm view on Meta::CPAN
{ 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);
lib/App/CamelPKI/CADB.pm view on Meta::CPAN
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})
lib/App/CamelPKI/CADB.pm view on Meta::CPAN
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
lib/App/CamelPKI/CertTemplate.pm view on Meta::CPAN
=item *
or must return a certificates list (in the form of L<App::CamelPKI::Certificates>
instances) if I<certificate_test_conflict> thinks to be conflict with
the new putative certificate. The calling CA then decides its have to
cancel the transaction, revoke certificates, or bypass the restriction
(see L<App::CamelPKI::CA/Coherence>);
=item *
or must throw an exception if there is no means to consider such a
certificate compliant in terms of the certificate policy.
=back
FIXME-TR: creuv�...
Noter que le principe de moindre privilège s'applique Ã
I<test_certificate_conflict>, et que la version de $db qu'il récupère
est en réalité une facette de la véritable base de données de CA, en
lecture seule et dont le contenu est de surcroît filtré sur la base
d'un I<need-to-know>: typiquement, I<test_certificate_conflict> ne
lib/App/CamelPKI/CertTemplate.pm view on Meta::CPAN
my %opts = $template->App::CamelPKI::CertTemplate::normalize_opts(@opts);
=for My::Tests::Below "explicit class idiom" end
sans quoi le gabarit de certificat aurait le droit de modifier
l'implémentation de cette méthode à sa guise.
=cut
sub normalize_opts {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
unless (@_ % 2);
my ($self, %opts) = @_;
return map {
throw App::CamelPKI::Error::Internal("INCORRECT_ARGS",
-details => "Wrong key $_")
unless m/^([a-z0-9_]+)$/i;
my $k = $1; # Déteinté
if (! defined $opts{$k}) {
throw App::CamelPKI::Error::Internal
("INCORRECT_ARGS",
-details => "Undef value for $k not allowed");
} elsif (ref($opts{$k}) eq "ARRAY") {
( $k => [ map {
defined or throw App::CamelPKI::Error::Internal
("INCORRECT_ARGS",
-details => "Undef value found in value list for $k");
"$_";
} @{$opts{$k}} ] );
} else {
( $k => "$opts{$k}" );
}
} ($self->list_keys);
}
lib/App/CamelPKI/CertTemplate.pm view on Meta::CPAN
} elsif (ref($v1) eq "ARRAY") {
my @v1 = sort @$v1; my @v2 = sort @$v2;
next LOOKALIKE if (@v1 != @v2);
foreach my $i (0..$#v1) {
next LOOKALIKE if $v1[$i] ne $v2[$i];
}
} else {
next LOOKALIKE if ($v1 ne $v2);
}
}
throw App::CamelPKI::Error::User
("Duplicate certificate in transaction",
-nominative_data1 => $hash,
-nominative_data2 => $lookalike);
}
push @{$approx_collisions->{$approxkey}}, $hash;
}
}
1;
lib/App/CamelPKI/Certificate.pm view on Meta::CPAN
Load $texte, which is a certificate I<bundle>, ie a concatenation of
one or more certificates in PEM format. Returns a list of
I<App::CamelPKI::Certificate> objects.
=cut
sub parse_bundle {
my ($class, $text) = @_;
throw App::CamelPKI::Error::Internal("MUST_CALL_IN_LIST_CONTEXT")
if (! wantarray);
my @allcerts = $text =~
m/(-+BEGIN.*?-+$
.*?
^-+END.*?-+$)/gmsx;
return map { scalar $class->parse($_) }
@allcerts;
}
lib/App/CamelPKI/Controller/CA/Template/Base.pm view on Meta::CPAN
],
}
$reqdetails->{requests} is a reference to list with one entry per
certificate to issue.
According to the coherency requirements set forth in certificate
template code, requesting a new certificate that collides with a
pre-existing one results in the latter being revoked implicitly;
requesting two colliding certificates within the same call to
I<certify> throws an exception.
The response is transmitted as an C<application/json> HTTP document,
with the following structure (again in Perl syntax):
{
keys => [
[ $cert1, $key1 ],
[ $cert2, $key2 ],
[ $cert3, $key3 ],
[ $cert4, $key4 ],
lib/App/CamelPKI/Controller/CA/Template/Base.pm view on Meta::CPAN
my $ca = $c->model("CA")->instance;
my $type = $c->request->params->{type};
my $data = $c->request->params->{data};
foreach my $shorttemplate ($self->_list_template_shortnames()) {
my $template = "App::CamelPKI::CertTemplate::$shorttemplate";
my @revocation_criteria =
map { ($type =~ m/$_/) ?
($_ => $data) :
() } ($self->_revocation_keys);
throw App::CamelPKI::Error::User
("Attempt revoke whole template group")
if ! @revocation_criteria;
warn @revocation_criteria;
$ca->revoke($template, $_)
for $ca->database->search
(template => $template, @revocation_criteria);
}
$ca->commit;
$c->stash->{type}=$type;
$c->stash->{data}=$data;
lib/App/CamelPKI/Controller/CA/Template/Base.pm view on Meta::CPAN
print "\n\n\n 1-- ".Data::Dumper::Dumper($self->_revocation_keys."\n\n\n");
my $ca = $c->model("CA")->instance;
foreach my $shorttemplate ($self->_list_template_shortnames()) {
my $template = "App::CamelPKI::CertTemplate::$shorttemplate";
my @revocation_criteria =
map { exists($revocdetails->{$_}) ?
($_ => $revocdetails->{$_}) :
() } ($self->_revocation_keys);
throw App::CamelPKI::Error::User
("Attempt revoke whole template group")
if ! @revocation_criteria;
$ca->revoke($template, $_)
for $ca->database->search
(template => $template, @revocation_criteria);
}
$ca->commit;
}
=head2 view_operations
lib/App/CamelPKI/Controller/Test.pm view on Meta::CPAN
(sprintf(<<'TEMPLATE',
ref($c->model("CA")) = "%s"
$c->engine->apache->subprocess_env =
%s
TEMPLATE
ref($c->model("CA")),
Data::Dumper::Dumper([$c->engine->apache
->subprocess_env])));
}
=head2 throw_exception
As the name implies, throws a structured exception.
=cut
use App::CamelPKI::Error;
sub throw_exception : Local {
throw App::CamelPKI::Error::User("cockpit error");
}
1;
lib/App/CamelPKI/Error.pm view on Meta::CPAN
App::CamelPKI::Error - Camel-PKI Error management
=head1 SYNOPSIS
=for My::Tests::Below "synopsis basic" begin
use App::CamelPKI::Error;
try {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS");
} catch App::CamelPKI::Error with {
warn "Oops, I made a boo-boo!";
};
=for My::Tests::Below "synopsis basic" end
=for My::Tests::Below "synopsis Class::Facet" begin
package My::Facet;
use Class::Facet from => "My::Object",
lib/App/CamelPKI/Error.pm view on Meta::CPAN
package App::CamelPKI::Error::Internal;
use vars qw(@ISA); @ISA=qw(App::CamelPKI::Error);
=head2 App::CamelPKI::Error::IO
Thrown when a file issue occurs. The incriminated file name must be passed
as the parameter C<-IOfile>, for example.
=for My::Tests::Below "App::CamelPKI::Error::IO" begin
throw App::CamelPKI::Error::IO("cannot open file",
-IOfile => $file);
=for My::Tests::Below "App::CamelPKI::Error::IO" end
The ->{-errorcode} field will be automatically set with the numerical
value of $! (see L</perlvar>) when the error is thrown. The
->{-error} field will be automatically set whith the textual value of
this same variable; note that this value depends on the active locale
and therefore should not be tested by error catching code.
=cut
package App::CamelPKI::Error::IO;
use vars qw(@ISA); @ISA=qw(App::CamelPKI::Error);
sub new {
lib/App/CamelPKI/Error.pm view on Meta::CPAN
B<on_facet_error> function that can be installed as a L<Class::Facet>
error handler, as shown in L</SYNOPSIS>.
=cut
package App::CamelPKI::Error::Privilege;
use vars qw(@ISA); @ISA=qw(App::CamelPKI::Error);
sub on_facet_error {
shift; # Off with the class name
throw App::CamelPKI::Error::Privilege(-text => "Facet error", @_);
}
=head2 App::CamelPKI::Error::Database
Thrown when an Camel-PKI database (typically L<App::CamelPKI::CADB>) detects
an error at the SQL level, as an invariant violation tentative or
an insert of two values for an unique index.
=cut
lib/App/CamelPKI/Error.pm view on Meta::CPAN
local $Carp::MaxEvalLen = 80; # ... but not too long anyway
local $Error::Depth = $Error::Depth + 1;
$Error::Depth += $opts{-depth} if (exists $opts{-depth});
return $self->Error::new(%opts);
}
=head2 stringify()
Overloaded to throw a complete error trace. If this does not match
your need, feel free to trap the exception in your own code.
=cut
sub stringify {
my ($self) = @_;
my $retval = sprintf("%s=%s\n",
ref($self), $self->SUPER::stringify);
foreach my $k (keys %$self) {
lib/App/CamelPKI/Error.pm view on Meta::CPAN
sub new { bless {}, shift }
sub facet { Class::Facet->make("My::Facet", shift) }
sub nothing { 1 }
}
ok(My::Object->new->nothing);
my $code = My::Tests::Below->pod_code_snippet("synopsis Class::Facet");
eval $code; die $@ if $@;
try {
My::Object->new->facet->nothing;
fail("should have thrown - Bug in Class::Facet?");
} catch App::CamelPKI::Error::Privilege with {
my $E = shift;
is($E->{-text}, "Facet error");
is($E->{-method}, "nothing");
};
};
use Errno qw(ENOENT);
test "App::CamelPKI::Error::IO and automatic decoration" => sub {
my $file = "/no/such_/file";
lib/App/CamelPKI/Model/CA.pm view on Meta::CPAN
sub set_brands : Restricted {
(undef, $cabrand, $cadbbrand) = @_;
}
sub _invoke_on_CA { $cabrand->invoke(@_) }
sub _invoke_on_CADB { $cadbbrand->invoke(@_) }
}
=head2 instance
Verify this CA has already undergone its Key Ceremony, or else throw an
exception; then create and returns an App::CamelPKI::CA instance which has
all privileges and represents the (unique) Operational CA installed on
this host.
Note that I<instance> is B<not> idempotent, and returns different
instances at each invocation. Were it not the case, constructors could
construct a covert channel using the shared instance, which is
mutable, and so a malicious controller could hide some information for
constructors that will later run in the same UNIX process.
=cut
sub instance {
my ($self) = @_;
my $ca = $self->_make_ca;
unless ($ca->is_operational) {
throw App::CamelPKI::Error::State(<<"MESSAGE");
The AC is not operational, please run
script/camel_pki_keyceremony.pl
MESSAGE
}
return $ca;
}
=head2 db_dir()
Returns the directory where are stored the App-PKI Certificate
lib/App/CamelPKI/Model/CA.pm view on Meta::CPAN
sub do_ceremony {
use File::Slurp;
use File::Spec::Functions qw(catfile);
use App::CamelPKI::CertTemplate::CA;
use App::CamelPKI::CertTemplate::PKI;
use Sys::Hostname ();
my ($self, $privdir, $webserver) = @_;
throw App::CamelPKI::Error::Internal("INCORRECT_ARGS")
unless (-d $privdir);
# REFACTORME: use a complete App::CamelPKI::CA instance for the
# Root CA
my $privKeyCA0 = App::CamelPKI::PrivateKey->genrsa($self->{keysize});
write_file(catfile($privdir, "ca0.key"),
$privKeyCA0->serialize(-format => "PEM"));
$privKeyCA0 = $privKeyCA0->as_crypt_openssl_ca_privatekey;
my $certCA0 = Crypt::OpenSSL::CA::X509->new
($privKeyCA0->get_public_key);
lib/App/CamelPKI/PEM.pm view on Meta::CPAN
=item I< -format => "DER" >
The format of $text. By default, an automatic detection is performed.
=back
=cut
sub parse {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
if (@_ % 2);
my ($class, $text, %args) = @_;
throw App::CamelPKI::Error::Internal("ABSTRACT_METHOD")
if ($class eq __PACKAGE__);
# Some JSON objects stringify to undef! In this case, Perl
# converts them into the null string, with a warning.
{ no warnings; $text = "$text" if defined $text; }
throw App::CamelPKI::Error::Internal("INCORRECT_ARGS")
if (! $text);
if (! exists $args{-format}) {
$args{-format} = ($text =~ m/^-+BEGIN/) ?
"PEM" : "DER";
}
# The canonical format is DER because it is smaller, plus it's The
# Right Thing for structural equality tests.
if ($args{-format} eq "DER") {
return bless { der => $text }, $class;
} elsif ($args{-format} eq "PEM") {
my $marker = $class->_marker;
unless ($text =~ m/-+BEGIN\ \Q$marker\E-+$
(.*?)
^-+END\ \Q$marker\E-+$/gmsx) {
throw App::CamelPKI::Error::Internal("INCORRECT_ARGS");
}
return bless { der => decode_base64($1) }, $class;
} else {
throw App::CamelPKI::Error::Internal
("INCORRECT_ARGS",
-details => "Unknown $class format $args{-format}");
}
}
=head2 load($fileName, %args)
Loads an object from a file on the file system. Named arguments are
the same as for L</parse>.
lib/App/CamelPKI/PEM.pm view on Meta::CPAN
=item I< -format => "DER" >
The format to use for serialization. Default value is "PEM".
=back
=cut
sub serialize {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
unless (@_ % 2);
my ($self, %args) = @_;
$args{-format} ||= "PEM";
if ($args{-format} eq "DER") {
return $self->{der};
} elsif ($args{-format} eq "PEM") {
my $foldedpem = encode_base64($self->{der});
$foldedpem =~ s/\n//g;
$foldedpem =~ s/(.{64})/$1\n/g;
$foldedpem =~ s/\n$//g;
my $marker = $self->_marker;
return <<"CERT";
-----BEGIN $marker-----
$foldedpem
-----END $marker-----
CERT
} else {
my $class = ref($self);
throw App::CamelPKI::Error::Internal
("INCORRECT_ARGS",
-details => "unknown $class format $args{-format}");
}
}
=head2 _marker
This abstract method returns the character chain to use as delimiter
(for example C<RSA PRIVATE KEY> for L<App::CamelPKI::PrivateKey>).
lib/App/CamelPKI/RestrictedClassMethod.pm view on Meta::CPAN
I<App::CamelPKI::RestrictedClassMethod> class which represents the right to
invoke methods marked as C<Restricted> in $classname.
=cut
sub grab {
my ($class, $wantclass) = @_;
# Can also be invoked as an instance method from inside this
# package:
my $self = ref($class) ? $class : $class->_get($wantclass);
throw App::CamelPKI::Error::Privilege("$wantclass is not loaded yet")
if (! defined $self);
throw App::CamelPKI::Error::Privilege("$wantclass is already taken")
if ($self->{grabbed});
$self->lockdown();
$self->{grabbed}++;
return $self;
}
=head2 fake_grab($classname)
Returns an object of class
L</App::CamelPKI::RestrictedClassMethod::FakeBrand>. Unlike the real
lib/App/CamelPKI/RestrictedClassMethod.pm view on Meta::CPAN
# Also an instance method (for internal calls from L</grab>)
my $self = ref($_[0]) ? shift : shift->_create(shift);
while(my $coderef = shift @{$self->{constructor_refs}}) {
no strict "refs";
my $codename;
foreach (@{Class::Inspector->functions($self->{class})}) {
$codename = $_, last if
(*{$self->{class} . "::$_"}{CODE} == $coderef);
}
throw App::CamelPKI::Error::Internal("ASSERTION_FAILED")
if (! $codename);
$self->{constructors}->{$codename} = $coderef;
no warnings "redefine";
*{$self->{class} . "::$codename"} = sub {
throw App::CamelPKI::Error::Privilege
("This constructor is restricted");
};
}
return;
}
=head1 METHODS
=head2 is_fake()
lib/App/CamelPKI/Sys.pm view on Meta::CPAN
test "fork_and_do" => sub {
my $pid = fork_and_do {
1;
};
waitpid($pid, 0); is($?, 0, "sub terminating normally");
$pid = fork_and_do {
die "don't worry, this message is normal\n";
};
waitpid($pid, 0); is($?, 1 << 8, "sub throwing an exception");
$pid = fork_and_do {
exit(42);
};
waitpid($pid, 0); is($?, 42 << 8, "sub exits with custom code");
$pid = fork_and_do {
sleep 10;
};
kill 9 => $pid;
lib/App/CamelPKI/SysV/Apache.pm view on Meta::CPAN
be instances of L<App::CamelPKI::Certificate> and L<App::CamelPKI::PrivateKey>
respectively), and also to verify the identity of HTTP/S clients that
themselves use a certificate (@chain, which is a list of instances of
L<App::CamelPKI::Certificate>; see also L</update_crl>). If $cert is a
self-signed certificate, C<-certification_chain> and its parameter
\@chain may be omitted.
=cut
sub set_keys {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
unless (@_ % 2);
my ($self, %keys) = @_;
while(my ($k, $v) = each %keys) {
if ($k eq "-certificate") {
write_file($self->_certificate_filename, $v->serialize());
} elsif ($k eq "-key") {
write_file($self->_key_filename, $v->serialize());
} elsif ($k eq "-certification_chain") {
write_file($self->_ca_bundle_filename,
join("", map { $_->serialize } @$v));
} else {
throw App::CamelPKI::Error::Internal
("INCORRECT_ARGS",
-details => "Unknown named option $k");
}
}
}
=head2 is_operational()
Returns true if and only if the ad-hoc cryptographic material has been
added to this Web server using L</set_keys>.
lib/App/CamelPKI/SysV/Apache.pm view on Meta::CPAN
sub update_crl { "UNIMPLEMENTED" }
=head2 start(%opts)
Starts the daemon synchronously, meaning that I<start> will only
return control to its caller after ensuring that the Apache process
wrote its PID file and bound to its TCP port. I<start()> is
idempotent, and terminates immediately if the serveur is already up.
An L<App::CamelPKI::Error/App::CamelPKI::Error::OtherProcess> exception will be
thrown if the server doesn't answer within L</async_timeout> seconds.
An L<App::CamelPKI::Error/App::CamelPKI::Error::User> exception will be thrown
if one attempts to I<start()> the server before providing it with its
certificate and key with L</set_keys>.
Available named options are:
=over
=item I<< -strace => $strace_logfile >>
Starts Apache under the C<strace> debug command, storing all results
lib/App/CamelPKI/SysV/Apache.pm view on Meta::CPAN
L<perlfunc/exec>) to run Apache directly (or more usefully, some
combination of Apache and a debugger, according to the above named
options). The current UNIX process will turn into Apache, and the
I<start> method will therefore never return.
=back
=cut
sub start {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
unless (@_ % 2);
my ($self, %opts) = @_;
throw App::CamelPKI::Error::OtherProcess("Apache is wedged")
if ($self->is_wedged);
return if $self->is_started;
$self->_write_config_file();
my (@debugprecmd, @dashX);
my $timeout = 1;
if (defined(my $stracefile = delete $opts{-strace})) {
@debugprecmd = ("strace", -o => $stracefile,
qw(-f -s 2000));
} elsif (my $tty = delete $opts{-gdb}) {
lib/App/CamelPKI/SysV/Apache.pm view on Meta::CPAN
"--args");
$timeout = 0;
}
if (delete $opts{-X}) { @dashX = qw(-X); }
my @fullcmdline =
(@debugprecmd,
$self->_apache_bin, @dashX, -f => $self->_config_filename);
if ($opts{-exec}) {
exec(@fullcmdline) or
throw App::CamelPKI::Error::OtherProcess("cannot exec() Apache",
-cmdline => \@fullcmdline);
} else {
# Double fork(), so we don't have to bother with zombies :
fork_and_do { fork_and_do {
exec @fullcmdline;
} };
}
if ($timeout) {
$self->_wait_for(sub { $self->is_started })
or throw App::CamelPKI::Error::OtherProcess("Cannot start Apache");
} else {
while(! $self->is_started) { sleep(1); }
};
return;
}
=head2 stop()
Stops the daemon synchronously, meaning that I<stop> will only return
control to its caller after ensuring that the Apache process whose PID
is in the PID file is terminated, and the TCP port is closed. Like
L</start>, this method is idempotent and returns immediately if the
server was already down.
An exception of class L<App::CamelPKI::Error/App::CamelPKI::Error::OtherProcess>
will be thrown if the server still hasn't stopped after
L</async_timeout> seconds.
Note that the "started" or "stopped" state is persisted to the
filesystem using the usual UNIX PID file mechanism; therefore it is
not necessary to use the same Perl object (or even the same process)
to L</start> and I<stop()> a given server.
=cut
sub stop {
my ($self) = @_;
throw App::CamelPKI::Error::OtherProcess("Apache is wedged")
if ($self->is_wedged);
return # Not wedged and not started means stopped
if ! defined(my $pid = $self->_process_ready);
kill TERM => $pid;
$self->_wait_for(sub { $self->is_stopped })
or throw App::CamelPKI::Error::OtherProcess("Cannot stop Apache");
return;
}
=head2 is_started()
Returns true iff the PID file currently contains the PID of a live
Apache process, B<and> one can connect to the TCP port.
=cut
lib/App/CamelPKI/SysV/Apache.pm view on Meta::CPAN
my ($self) = @_;
(! $self->_process_ready) && (! $self->_port_ready);
}
=head2 is_wedged()
Returns true iff neither L</is_stopped>, nor L</is_started> are true
(e.g. if the TCP port is taken, but not by us). One cannot call
L</start> or L</stop> against an instance of I<App::CamelPKI::SysV::Apache>
that I<is_wedged()> (L<App::CamelPKI::Error/App::CamelPKI::Error::OtherProcess>
exceptions would be thrown). More generally, neither can one call any
method that act upon other processes such as L</update_crl>. The
systems administrator therefore needs to take manual corrective action
to get out of this state.
=cut
sub is_wedged {
my ($self) = @_;
$self->_process_ready xor $self->_port_ready;
}
lib/App/CamelPKI/SysV/Apache.pm view on Meta::CPAN
=cut
sub tail_error_logfile {
my ($self) = @_;
my $log = new IO::File($self->_error_log_filename);
$self->{offset} = 0, return if (! defined $log);
my $retval;
if (defined wantarray) {
$log->seek($self->{offset}, SEEK_CUR)
or throw App::CamelPKI::Error::IO
("cannot seek", -IOfile => $self->_error_log_filename);
$retval = join('', $log->getlines);
} else { # Notamment à la construction
$log->seek(0, SEEK_END)
or throw App::CamelPKI::Error::IO
("cannot seek to end of file",
-IOfile => $self->_error_log_filename);
}
$self->{offset} = $log->tell();
return $retval;
}
=head1 TODO
lib/App/CamelPKI/SysV/Apache.pm view on Meta::CPAN
Returns false if there was no configuration file to parse. Throws an
exception in any other case.
=cut
sub _try_and_parse_config_file {
my ($self) = @_;
return if ! -f $self->_config_filename();
my $configtext = read_file($self->_config_filename());
(($self->{https_port}) = $configtext =~ m/Listen (\d+)/ )
or throw App::CamelPKI::Error::State
("Configuration file was tampered with",
-config_file => $self->_config_filename());
($self->{test_php_directory}) =
$configtext =~ m|Alias /t/php "(.*)"|; # Optional
$self->{has_camel_pki} =
($configtext =~ m/PerlModule App::CamelPKI/) ? 1 : 0;
return 1;
}
require My::Tests::Below unless caller;
lib/App/CamelPKI/Time.pm view on Meta::CPAN
=item B<An object of class App::CamelPKI::Time>
A deep copy of this object is returned.
=back
=cut
sub parse {
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
if (@_ % 2);
my ($class, $time, %opts) = @_;
if (! exists $opts{-format}) {
return bless { %$time }, $class if eval { $time->isa($class) };
return $class->now if ($time eq "now");
$opts{-format} = "Zulu";
}
throw App::CamelPKI::Error::Internal
("UNIMPLEMENTED",
-details => "unsupported format $opts{-format}")
unless ($opts{-format} eq "Zulu");
throw App::CamelPKI::Error::Internal("INCORRECT_ARGS",
-details => "cannot parse time")
unless my ($Y, $M, $D, $h, $m, $s) =
($time =~ m/^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})Z$/);
return bless
{ dt => DateTime->new(year => $Y, month => $M, day => $D,
hour => $h, minute => $m, second => $s),
}, $class;
}
=head2 now()
lib/App/CamelPKI/Time.pm view on Meta::CPAN
=head2 advance_days($days)
Returns a copy of this I<App::CamelPKI::Time> object advanced by the
specified number of days (which may be negative).
=cut
sub advance_days {
my ($self, $days) = @_;
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
if (! defined $days);
my $dt = $self->{dt}->clone;
my $duration = DateTime::Duration->new(days => abs($days));
$days >= 0 ? $dt->add_duration($duration) :
$dt->subtract_duration($duration);
return bless { dt => $dt }, ref($self);
}
=head2 advance_years($years)
Returns a copy of this I<App::CamelPKI::Time> object advanced by the
specified number of years, which may be negative.
=cut
sub advance_years {
my ($self, $days) = @_;
throw App::CamelPKI::Error::Internal("WRONG_NUMBER_ARGS")
if (! defined $days);
my $dt = $self->{dt}->clone;
my $duration = DateTime::Duration->new(years => abs($days));
$days >= 0 ? $dt->add_duration($duration) :
$dt->subtract_duration($duration);
return bless { dt => $dt }, ref($self);
}
=head2 make_your()
lib/App/CamelPKI/View/JSON.pm view on Meta::CPAN
package App::CamelPKI::View::JSON;
use strict;
use base 'Catalyst::View::JSON';
=head1 NAME
App::CamelPKI::View::JSON - the view used to throw data to an AJAX client
or any other RPC client.
=head1 SYNOPSIS
=head1 DESCRIPTION
This package is a (trivial for now) subclass of L<Catalyst::View>.
It allow to send a Perl data structure to an HTTP client, using
L<JSON> encoding format.
lib/Class/Facet.pm view on Meta::CPAN
unshift(@_, $origself);
goto $origself->can($methodname);
};
}
}
=head2 on_error($facetclass, $sub)
Installs $sub as the error management callback method for $facetclass.
$sub will always be called as a class method in void context, and
should throw an exception with L<perlfunc/die>, L<Exception::Class> or
some such, and not return. As shown in L</SYNOPSIS>, $sub should
accept the following named parameters:
=over
=item B<-file>
=item B<-line>
The filename and line number of the place in the code that invoked the
faulty operation.
=item B<-facetclass>
The facet class against which the error sub is being invoked. This
will be $facetclass, unless $sub is the error management routine for
several facets at once.
=item B<-reason>
The reason why the error is thrown, as the name of the method in
B<Class::Facet> that triggered the error, or one of the special values
C<facet_error> (meaning that L</facet_error> was invoked manually) or
C<forbidden_method> (if one tries to invoke a forbidden method through
the facet object).
=item B<-details> (optional)
A message in english explaining the reason of the error.
=item B<-method> (optional)
Set when trying to invoke a method through a facet object, but this
method is neither delegated (using L</delegate>) nor defined in the
facet package.
=back
The default implementation (if C<on_error()> is not called) is to
throw a text message in english using L<perlfunc/die> that contains a
subset of the aforementioned information.
=cut
# See the default implementation of the error handler in L</_carp>.
sub on_error {
my ($class, $facetclass, $sub) = @_;
unless (ref($sub) eq "CODE") {
$sub = "an undefined value" if ! defined $sub;
croak("Class::Facet: cannot use $sub as an error handler");
lib/Class/Facet.pm view on Meta::CPAN
=cut
sub make {
my ($class, $facetclass, $origobject) = @_;
# use Class::ISA;
# use UNIVERSAL::can;
#Making a facet from a facet is forbidden !!!!
# for my $int (Class::ISA::super_path($facetclass)) {
# eval {($int->can("from") && $int->can("delegate"))};
# throw App::CamelPKI::Error::User
# ("Subclassing a facet is forbidden")
# if ($int->can("from") && $int->can("delegate"))';
# }
return bless { delegate => $origobject }, $facetclass;
}
=head2 selves($argslistref)
Interprets $argslistref as a reference to the argument list (@_) of a
lib/Class/Facet.pm view on Meta::CPAN
test "synopsis, BEGIN style" => sub {
eval My::Tests::Below->pod_code_snippet("synopsis facet class");
die $@ if $@;
@Foo::TheRealOne::calls = ();
my $facet = Foo::TheRealOne->new->facet_readonly;
$facet->get_this();
is_deeply(\@Foo::TheRealOne::calls, ["get_this"]);
eval {
$facet->set_that;
fail("method should have thrown");
};
isnt($@, undef);
is_deeply(\@Foo::TheRealOne::calls, ["get_this"]);
};
test 'synopsis, "use Class::Facet" style' => sub {
eval "package Foo::ReadOnlyFacetToo;" .
My::Tests::Below->pod_code_snippet("synopsis without BEGIN");
die $@ if $@;
@Foo::TheRealOne::calls = ();
my $facet = Class::Facet->make
("Foo::ReadOnlyFacetToo", Foo::TheRealOne->new);
$facet->get_this();
is_deeply(\@Foo::TheRealOne::calls, ["get_this"]);
eval {
$facet->set_that;
fail("method should have thrown");
};
isnt($@, undef);
is_deeply(\@Foo::TheRealOne::calls, ["get_this"]);
};
test "facet structure" => sub {
my $origobject = Foo::TheRealOne->new;
my $facet = $origobject->facet_readonly;
my $facetclass = "Foo::ReadOnlyFacet";
my $facettoo = eval My::Tests::Below->pod_code_snippet
t/lib/App/CamelPKI/Test.pm view on Meta::CPAN
$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) };
t/lib/App/CamelPKI/Test.pm view on Meta::CPAN
$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;
t/lib/App/CamelPKI/Test.pm view on Meta::CPAN
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");
};
t/maintainer/dependencies.t view on Meta::CPAN
}
return $retval;
}
=head2 skip_pod($filename, $fd, $pm)
=head2 skip_here_document($filename, $fd, $line)
Both functions advance $fd, an instance of L<IO::Handle>, to skip past
non-Perl source code constructs, and return true if they indeed did
skip something (or throw an exception if they tried and failed). $pm
is a token returned by L<Module::ScanDeps/scan_line>; $line is a line
of the Perl source file. $filename is only used to construct the text
of error messages.
=cut
sub skip_pod {
my ($file, $fd, $pm) = @_;
return unless $pm eq '__POD__';
my $podline = $fd->input_line_number;
( run in 0.344 second using v1.01-cache-2.11-cpan-496ff517765 )