Add user client certificate option

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;
+}