summaryrefslogtreecommitdiff
path: root/gmi.pl
diff options
context:
space:
mode:
Diffstat (limited to 'gmi.pl')
-rwxr-xr-xgmi.pl132
1 files changed, 128 insertions, 4 deletions
diff --git a/gmi.pl b/gmi.pl
index 7fb9401..1cf1244 100755
--- a/gmi.pl
+++ b/gmi.pl
@@ -7,7 +7,7 @@ use warnings;
use 5.010;
#use diagnostics;
-our $VERSION = 'v0.16.2';
+our $VERSION = 'v0.17.0';
# Modules
use IO::Socket::SSL; # CPAN
@@ -59,6 +59,7 @@ const our %GEM_RES_CODES => (
'cert_req' => '60 Certificate Required',
'cert_unauth' => '61 Certificate Unauthorized',
'cert_invalid' => '62 Certificate Invalid',
+ 'custom' => '!s',
);
const our @VALID_DEFAULT_SETTINGS =>
@@ -67,7 +68,7 @@ const our @VALID_DEFAULT_SETTINGS =>
unix redirection redirect/;
const our @VALID_VHOST_SETTINGS =>
qw/auto_cert assume_index dir_listing root cert key default_mime bind ports
- unix redirection redirect/;
+ unix redirection redirect cert_req/;
my ($config, $err) = from_toml(_slurp('./config.toml'));
if ($err) {
@@ -103,6 +104,7 @@ check_config_keys($config);
my $ft = File::Type->new();
my $log;
+my $cl_cert;
my $sel = IO::Select->new();
select_add_listen($sel, @srv);
@@ -217,6 +219,7 @@ while (my @ready = $sel->can_read) {
say "$log [". localtime(). ']';
exit if ($fork_toggled);
+ undef $cl_cert;
}
#$srv->close();
@@ -224,6 +227,17 @@ while (my @ready = $sel->can_read) {
sub respond_to_client {
my ($cl, $vhost, $doc_loc, $path) = @_;
+ my ($cert_req, $cert_meta, $check_path) = cert_req($vhost, $path);
+ if ($cert_req) {
+ if ($cert_meta) {
+ speak($cl, 'custom', "60 $cert_meta");
+ }
+ else {
+ speak($cl, 'cert_req');
+ }
+ goto CLOSE;
+ }
+
my $redirection = redirection_parameter($vhost);
if ($redirection) {
my $redirect = check_for_config_redirection($vhost, $path, $redirection);
@@ -583,7 +597,11 @@ sub ssl_config {
my ($conf_ref) = @_;
my %ssl = (
SSL_version => '!SSLv2:!SSLv3:!TLSv1:!TLSv1_1',
+ SSL_server => 1,
Listen => 5,
+ # If peer sends us a cert, use the callback to accept it for future use.
+ SSL_verify_mode => SSL_VERIFY_PEER,
+ SSL_verify_callback => \&verify_cert_callback,
SSL_fast_shutdown => 1,
Timeout => 5, # !! Nothing to do with the config option !!
@@ -1043,9 +1061,9 @@ sub check_for_config_redirection {
if ($redirection >= 2) {
# regular expression compiling
for my $redirect (keys %{ $config->{$vhost}{redirect} }) {
- ### $redirect
+ # ## $redirect
my $redirect_replace = $config->{$vhost}{redirect}{$redirect};
- ### $redirect_replace
+ # ## $redirect_replace
my $regex_match;
#my $regex_replace;
@@ -1088,3 +1106,109 @@ sub redirection_parameter {
}
return;
}
+
+## no critic (unpack)
+sub verify_cert_callback {
+ ### @_;
+ ## perl arrays start at 0, not 1
+ #1. a true/false value that indicates what OpenSSL thinks of the certificate,
+ #2. a C-style memory address of the certificate store,
+ #3. a string containing the certificate's issuer attributes and owner attributes, and
+ #4. a string containing any errors encountered (0 if no errors).
+ #5. a C-style memory address of the peer's own certificate (convertible to PEM form with Net::SSLeay::PEM_get_string_X509()).
+ #6. The depth of the certificate in the chain. Depth 0 is the leaf certificate.
+ ## $pem
+ $cl_cert = CERT_asHash(PEM_string2cert(Net::SSLeay::PEM_get_string_X509($_[4])));
+ ### $cl_cert
+ return 1;
+}
+## use critic
+
+## no critic (deep, return, useless, complex)
+sub cert_req {
+ my ($vhost, $path) = @_;
+ $path ? ($path = "/$path") : ($path = '/');
+
+ if (exists $config->{$vhost}{cert_req}) {
+ my $cert_req = $config->{$vhost}{cert_req};
+ ### $cert_req
+ for my $key (keys %{ $cert_req }) {
+ ### $key
+ ### $path
+ my $regex = qr{$key};
+ if ($path =~ m/$regex/) {
+ ### yep, that path matched that key
+ my ($req, $meta);
+ if (ref $cert_req->{$key} eq 'ARRAY') {
+ $req = $cert_req->{$key}[0];
+ if ($req eq 'any' and defined $cl_cert) {
+ return 0;
+ }
+ elsif ($req eq 'pubkey' and defined $cl_cert) {
+ my $cl_cert_f = $cl_cert->{fingerprint_sha256};
+ $cl_cert_f =~ s/://g;
+ $cl_cert_f = lc $cl_cert_f;
+ for my $pubkey (@{ $cert_req->{$key} }) {
+ my $pk = $pubkey;
+ $pk =~ s/://g;
+ $pk = lc $pk;
+ ### $pk
+ ### $cl_cert_f
+ if ($pk eq $cl_cert_f) {
+ return 0;
+ }
+ }
+ }
+ elsif ($req eq 'file' and defined $cl_cert) {
+ my $cl_cert_f = $cl_cert->{fingerprint_sha256};
+ $cl_cert_f =~ s/://g;
+ $cl_cert_f = lc $cl_cert_f;
+
+ for my $file (@{ $cert_req->{$key} }) {
+ ### $file
+ ## no critic (RequireBriefOpen)
+ if (-e $file and -r $file) {
+ open my $fh, '<', $file
+ or serr("'$vhost': cert_req: '$file': $ERRNO");
+ while (<$fh>) {
+ my $pk = $_;
+ $pk =~ s/://g;
+ $pk = lc $pk;
+ chomp $pk;
+ ### $pk
+ ### $cl_cert_f
+ if ($pk eq $cl_cert_f) {
+ close $fh
+ or warn "$vhost: $file: $ERRNO";
+ return 0;
+ }
+ }
+ close $fh
+ or warn "$vhost: $file: $ERRNO";
+ }
+ }
+ }
+
+ ### $req
+ if ($cert_req->{$key}[1]) {
+ return 1, $cert_req->{$key}[1];
+ }
+ else {
+ return 1;
+ }
+ }
+ # must be string, hopefully 'any'
+ elsif ($cert_req->{$key} eq 'any' and defined $cl_cert) {
+ return 0;
+ }
+ else {
+ serr("'$vhost': certs: when not an array, it must be 'any'.");
+ return 1;
+ }
+ ### fall back to require certificate, the regex *DID* match.
+ return 1, 'System Error';
+ }
+ }
+ }
+ return;
+}