#!/usr/bin/perl
use strict ;
use warnings ;
use vars ;

use CGI ;
use Carp ;
use Stanford::Orange::Util qw/tempfile spew trim/ ;

# The result is returned as a text/plain document with this format:
#
# <the subject>;<san1>,<san2>,...
#
# Example: A subject but no SANs:
#    example.com;
#
# Example: No subject but some SANs:
#    ;san1,san2
#
# Example: No subject or SANs:
#    ;


my $q = CGI->new ;

# Get the POSTed value
# Note that we get CSR from the parameters and trim in two steps to avoid
# the dreaded "CGI::param called in list context" error.
my $csr = $q->param('csr') ;
$csr = trim($csr) ;

my $subject               = get_subject_from_csr($csr) ;
my ($pk_type, $SANS_href) = get_sans_from_csr($csr) ;
my @SANS = @$SANS_href ;

print($q->header('text/plain')) ;
print("$subject;$pk_type;" . join(q{,}, @SANS)) ;

sub get_subject_from_csr {
    my ($subj) = @_ ;

    my $tempfile = tempfile() ;
    spew($subj, $tempfile) ;

    my $csrfile = '/dev/null' ;

    my @openssl_cmd = (
        '/usr/bin/openssl',
        'req',
        '-noout',
        '-subject',
        '-in', $tempfile,
    ) ;
    my ($stdout, $stderr, $rv) = run_command(@openssl_cmd) ;
    unlink $tempfile or carp "failed to unlink '$tempfile': $!" ;

    if ($stderr) {
        carp "could not extract subject name from CSR: $stderr @openssl_cmd" ;
        return q{} ;
    }

    #<<<  We like the comment formatted like it.
    # Look for a string like this: 'CN=hostname' followed either by
    #'/something' or the end of the string.
    #
    # Some possibilities:
    # subject=/CN=ehsctweb1.stanford.edu/O=Stanford University/OU=EH&S/emailAddress=dchask@stanford.edu/L=Stanford/ST=CA/C=US
    # subject=/C=US/ST=California/L=Stanford/O=Stanford University/OU=IT Services/CN=mdm-dev2.stanford.edu
    # subject=/C=US/ST=California/L=Stanford/O=Stanford University/OU=IT Services/CN=*.law.stanford.edu
    # subject=C = US, ST = California, L = Palo Alto, O = Stanford Law School, OU = IT, CN = law.stanford.edu, emailAddress = webmaster@law.stanford.edu
    #
    # Note that according to RFC2253 we must allow for white space between the attribute type (e.g.,
    # "CN" and the equals sign "=", and between the equals sign "=" and the attribute value (e.g.,
    # "*.law.stanford.edu".
    #>>>
    if ($stdout =~ m{CN \s*=\s* ([\*[:alpha:]\d\.][[:alpha:]\d\-\.]*) ([\/\,]|$)}xsm) {
        return $1 ;
    } else {
        carp "could not extract subject name from CSR: $stdout" ;
        return q{} ;
    }
}

sub get_sans_from_csr {
    my ($csr) = @_ ;

    my @sans = () ;

    my $tempfile = tempfile() ;
    spew($csr, $tempfile) ;

    my @openssl_cmd = (
	'/usr/bin/openssl',
	'req',
	'-noout',
	'-text',
	'-in', $tempfile,
	) ;

    my ($stdout, $stderr, $rv) = run_command(@openssl_cmd) ;
    unlink $tempfile or carp "failed to unlink '$tempfile': $!" ;

    if ($stderr) {
	carp "could not extract subject alternative names from CSR: $stderr @openssl_cmd" ;
	return q{} ;
    }

    # Get any SANs from stderr
    my @lines = split(/\n/, $stdout) ;

    my $in_san_section = 0 ;
    my $done_parsing   = 0 ;
    foreach my $line (@lines) {
	if ($done_parsing) {
	    # Do nothing
	} elsif ($in_san_section) {
	    # Get the SANs.
	    # the line should look like:
            #  DNS:law-dev.stanford.edu, DNS:law-stage.stanford.edu, ...
	    my @clauses = split(q{,}, trim($line)) ;
	    foreach my $clause (@clauses) {
		if (trim($clause) =~ m{DNS:(\S+)$}xsm) {
		    # Found one.
		    my $san = $1 ;
		    push(@sans, $san) ;
		}
	    }
	    # We are done.
	    $done_parsing = 1 ;
	} elsif ($line =~ m{X509v3.Subject.Alternative.Name}xsm) {
	    # The next line will have what we want.
	    $in_san_section = 1 ;
	} else {
	    # Do nothing
	}
    }

    # Get the PK type
    my $pk_type = 'unknown' ;
    if ($stdout =~ m{Public\ Key\ Algorithm:\s+(\S+)}xsm) {
	$pk_type = $1 ;
    }

    return ($pk_type, \@sans) ;
}

sub run_command {
    my (@command) = @_ ;

    # (From Russ)
    use IPC::Run qw(run) ;
    my ($out, $err) ;
    run \@command, q{>}, \$out, q{2>}, \$err ;
    return ($out, $err, $? >> 8) ;
}
