diff options
Diffstat (limited to 'gmi.pl')
| -rwxr-xr-x | gmi.pl | 132 |
1 files changed, 128 insertions, 4 deletions
@@ -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; +} |