Add user client certificate option

3 files changed, 158 insertions, 8 deletions

diff --git a/TO_FIX.md b/TO_FIX.md
index 8ebd90d..af0e0c1 100644
--- a/TO_FIX.md
+++ b/TO_FIX.md
@@ -8,8 +8,6 @@ remove magic numbers
 
 make log output user adjustable
 
-add client certificate stuff
-
 add gmiaccess stuff
 
 add cgi stuff
@@ -21,3 +19,7 @@ check if loaded cert/keys are actually valid
 check values for keys in config file
 
 handle signals like interrupt better
+
+recently-accepted-cert-cache for specific cert-req keys, doing a look up EACH and EVERY TIME can be expensive when it it likely that a single person will be looking around.
+
+reduce complexity in cert_req()
diff --git a/config.toml.sample b/config.toml.sample
index 3f22149..a75fc25 100644
--- a/config.toml.sample
+++ b/config.toml.sample
@@ -73,7 +73,7 @@ redirection = 'simple'
 # Generate certificate and key automatically? Uses cert_key_dir
 auto_cert = true
 # Overrides default setting
-assume_index = true 
+assume_index = true
 
 # A more realistic example
 #['example.com']
@@ -111,4 +111,28 @@ assume_index = true
 #    '/blog/2022/dec/(.+)' = '/blog/2022/jul/$1',
 #    #      $1     $2   $3 
 #    '/blog/(20..)/(.+)/(.+)' = '/newsgroup/$1-$2/$3',
-#  }
+#}
+#
+#cert_req = {
+#  # will accept ANY certificate
+#  '/cert_required(.*) = 'any',
+#  # Same as above but you can set the text that will accopany the header.
+#  '/blog/secret(.*) = [
+#      'any', 'This is my secret place.'
+#  ],
+#  # Lock an area off with specific fingerprints (sha256)!
+#  '/payment_club(.*)' = [
+#      'pubkey, 'Accepted members only',
+#       # fingerprints (sha256) can have colons and be upper or lower case: program will normalize them.
+#       '0b435dd2efc7c7569d97559c22d4a35abbd19cfd6d15d23989773a69df5556c2',
+#       '...',
+#  ],
+#  # Suppose you have a LOT of pubkeys? This example will solve it.
+#  '/secret_blog(.*)' = [
+#      # file option allows you to specify files that should have a listing of accepted pubkeys
+#      # the second option '0' just tells the server to serve default meta text
+#      'file', 0,
+#      '../pubkeys1.txt',
+#      '../pubkeys2.txt',
+#   ],
+#}
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;
+}