#!/usr/bin/perl
#
# cert-request -- CGI script to request an SSL certificate.
#
# Written by Kevin Hall <hallk@stanford.edu>
# Updated by Adam Lewenberg <adamhl@stanford.edu>
# Maintained by Adam Lewenberg <adamhl@stanford.edu>
# (Previously maintained by Huaqing Zheng <morpheus@stanford.edu>)
# Copyright 2003, 2004, 2012, 2013, 2014, 2016, 2019 Board of Trustees, Leland Stanford Jr. University

## no critic (ProhibitParensWithBuiltins) ;
## no critic (RequireCheckingReturnValueOfEval) ;
## no critic (RequireNoMatchVarsWithUseEnglish) ;

##############################################################################
# Site configuration
##############################################################################

use strict ;
use warnings ;
use autodie ;

use AppConfig ;
use Carp ;
use DateTime ;
use DateTime::Format::Strptime ;
use English;
use HTML::Template ;
use CGI qw(:standard) ;
use CGI::FormBuilder ;
use CGI::Cookie ;
use POSIX qw(strftime) ;
use YAML::Tiny ;
use Mail::RFC822::Address ;
use IPC::Run ;
use Readonly ;

use Stanford::PKObj ;
use Stanford::Orange::Util qw /slurp/ ;

Readonly my $MAX_SUBJECT_ALT_NAME => 100 ;
Readonly my $MIN_RSA_KEY_SIZE     => 2048 ;
Readonly my $MIN_ECC_KEY_SIZE     => 160 ;

my $VERSION = '52 [2020-08-20]';

my $FORM ;
my $WARNING_STR ;
my $TMPL ;
my @SERVERTYPES ;
my %PARAMS ;

# Load configuration parameters.
my $config_yaml_file = '/etc/certreq/cert-request' ;
my %CR_CONF          = get_config($config_yaml_file) ;

# Redirect to the outage page?
my $redirect_to_outage = $CR_CONF{'redirect_to_outage'} ;
if ($redirect_to_outage) {
    my $q = CGI->new ;
    print $q->redirect('/outage');
    exit 0 ;
}

$FORM = '/usr/share/certreq/template/cert-request-form.tmpl' ;

my $REMCTL = '/usr/bin/remctl' ;

@SERVERTYPES = (
    'Apache',
    'Java Web Server (Javasoft/Sun)',
    'Microsoft IIS',
    'RedHat Linux',
    'Tomcat',
    'OTHER',
    ) ;

my $SERVERTYPE_DEFAULT = 'Apache' ;

# How do we refer to cetificates with multiple domain names: UCC,
# Multi-domain, ...?
my $multi_domain_label = 'Multi-hostname' ;

my %NETDB_RESULTS = (
    'USER_CONTROLS_NODE'           => 100,
    'NO_NODE_IN_NETDB'             => 101,
    'USER_DOES_NOT_CONTROL_NODE'   => 102,
    'USER_CONTROLS_DOMAIN'         => 200,
    'NO_DOMAIN_IN_NETDB'           => 201,
    'USER_DOES_NOT_CONTROL_DOMAIN' => 202,
) ;

##############################################################################
# Form generation routines
##############################################################################

sub generate_form {

    my $form = CGI::FormBuilder->new(
        template => '/usr/share/certreq/template/form.tmpl' ,
        method   => 'post',
        enctype  => 'multipart/form-data',
        reset    => 1,
        class    => 'form-group',
        table    => 0,
    );

    ## current user is an admin?
    $form->field(name => 'isadmin',
                 label => 'sunetid',
                 value => is_admin(),
        );

    $form->field(name    => 'skip_netdb',
                 options => ['Yes',],
                 class   => 'form-control-sm',
        );

    ## sunetid
    $form->field(
        name => 'sunetid',
        label => 'sunetid',
        value => $ENV{'REMOTE_USER'},
        );

    ## display name
    $form->field(name => 'display_name',
                 label => 'Full name',
                 value => get_displayName());

    ## email address
    $form->field(name  => 'email',
                 label => 'Email',
                 value => get_requester_email(),
        );

    ## server name
    $form->field(name  => 'server_name',
                 label => 'Server name',
                 size  => 50,
        );

    ## server types. We set "selectname" to 0 so that
    ## the pull-down select does NOT have one of those
    ## '-select-' no-value choices.
    $form->field(name       => 'server_type',
                 label      => 'Server type',
                 options    => \@SERVERTYPES,
                 selectname => 0,
                 value      => $SERVERTYPE_DEFAULT,
                 class      => 'form-control-sm',
        );

    ## contact_address
    $form->field(name  => 'contact_address',
                 label => 'Contact group',
                 type  => 'email',
                 size  => 50,
                 class => 'form-control-sm',
        );

    ## duration
    $form->field(name  => 'duration',
                 label => 'Duration of certificate',
                 value =>  '1 year',
                 options => ['1 year'],
        );

    ## public key_algorithm (auto-filled by Javascript)
    $form->field(name  => 'public_key_algorithm',
                 label => 'Public key algorithm (derived from CSR)',
                 readonly => 1,
                 value =>  q{},
                 class => 'form-control-sm',
        );

    ## CSR
    $form->field(name  => 'csr',
                 label => 'csr',
                 type  => 'textarea',
                 rows  => '15',
                 cols  => '50',
                 class => 'form-control',
        );

    ## Alternative SANs
    $form->field(name  => 'alternatives',
                 label => 'alternatives',
                 type  => 'textarea',
                 rows  => '2',
                 cols  => '70',
                 class => 'form-control',
        );

    ## Comments
    $form->field(name  => 'comments',
                 label => 'comments',
                 type  => 'textarea',
                 rows  => '2',
                 cols  => '70',
                 class => 'form-control',
        );

    $form->field(name => 'required',
                 label => '<span class="required" title="Required">*</span>',
                 value => q{});


    return $form ;
}

##############################################################################
# Validation routines
##############################################################################

# Validate the submitted form by checking all the parameters.  Generate a
# warning with all the errors if the parameters are bad.
#
# Returns 0 if submit IS NOT valid.
# Returns 1 if submit IS valid.
#
# Sets the global variable $WARNING_STRING
#
# Validation logic. Failure of any of the following means invalid
# submission.
#
# 0.  If skip_netdb has the value "on" then the logged-in user had
#     better be an admin.

# 1.  The server name field must have a value (this is normally
#     accomplished via Javsacript that extracts the Subject from the CSR.
#
# 2.  The contact address field must contain an e-mail address.
#
# 3.  The CSR field must not be empty.
#
# 4.  The alternatives list must either be empty or, if non-empty, must be
#     comma-delimited list of hostnames or wildcard hostnames.
#
# 5.  There cannot be more than 100 alternative names.
#
# 6.  The CSR string must be well-formed and its subject matching the
#     server name.
#
# 7.  [ADMIN excepted] Subject must not be "stanford.edu" (reqires a
#     special request).
#
# 8.  Subject must NOT contain a wildcard certificate (SAN only).
#
# 9.  [ADMIN excepted] Alternative name cannot contain "*.stanford.edu"
#     (requires a special request).
#
# 10. If the fqdn_required parameter is set to "YES" then all hostname names must
#     be fully-qualified.
#
# 11. Submitter must have access to all names (subject and alternative
#     names) in NetDB: nodes and domains.

sub validate_submit {
    ## no critic (ProhibitExcessComplexity) ;
    ## no critic (NamingConventions::Capitalization) ;
    my @errors ;

    ## ## ##    # ## ##    # ## ##    # ## ##    # ## ##    # ## ##
    my $return_with_WARNING_fref = sub {
        $WARNING_STR = format_warning_string(\@errors) ;
        return 0 ;
    } ;
    ## ## ##    # ## ##    # ## ##    # ## ##    # ## ##    # ## ##

    # Some convenience variables.
    my $server_name     = trim($PARAMS{'server_name'}) ;
    my $alternatives    = trim($PARAMS{'alternatives'}) ;
    my $csr             = trim($PARAMS{'csr'}) ;
    my $contact_address = trim($PARAMS{'contact_address'}) ;
    my $skip_netdb      = trim($PARAMS{'skip_netdb'}) ;

    my $skip_netdb_check = 0 ;
    if ((defined($skip_netdb) && ($skip_netdb =~ m{yes}ixsm)) ||
        ($CR_CONF{'validate_hostname_access_via_netdb'} =~ m{NO}ixsm)) {
        $skip_netdb_check = 1 ;
    }

    # If skip_netdb is checked the user needs to be an admin.
    if ($skip_netdb_check && (!is_admin())) {
        push(@errors, q/Only an admin can skip the NetDB check./) ;
    }

    ## Stage 1: Missing or malformed.
    if ($server_name !~ m{\w}xsm) {
        push(@errors, q/Server name: you must indicate the name of the /
              . q/server that will be using the SSL certificate./) ;
    } else {
        $server_name = lc($server_name) ;
    }

    #<<<  we use special spacing here for clarity
    if (!$contact_address) {
        push(@errors, q/Contact address: please include a contact email / .
                      q/address where the certificate and expiration / .
                      q/notification can be sent./) ;
    } else {
        # Make sure there is only ONE contact e-mail address.
        if (!Mail::RFC822::Address::valid($PARAMS{contact_address})) {
            push(@errors, q/Contact address: please include a single valid / .
                          q/contact email address where the certificate and/ .
                          q/expiration notification can be sent./ );
        }
    }
    #>>>

    if ($csr !~ m{\w}xsm) {
        my $err_string = 'You must include a '
          . 'valid Certificate Signing Request in your form submission.' ;
        push(@errors, $err_string) ;
        return $return_with_WARNING_fref->() ;
    }

    #<<<  we use special spacing here for clarity
    if (($csr !~ m{BEGIN.*[ ]CERTIFICATE}xsm) ||
        ($csr !~ m{END.*[ ]CERTIFICATE}xsm)) {
        push @errors, q/CSR: The CSR should start with / .
            q/"-----BEGIN CERTIFICATE REQUEST-----" and end with / .
            q/"-----END CERTIFICATE REQUEST-----". Please make sure you are / .
            q/pasting the entire contents of your CSR into the appropriate / .
            q/box./ ;
    }

    # Subject restriction. We allow admins to submit CSR's with
    # "stanford.edu" in the subject.
    if (!is_admin() && $server_name eq 'stanford.edu') {
        push(@errors, q{Certificate requests for the domain 'stanford.edu' }
                    . q{must be placed through HelpSU}) ;
    } elsif (is_wildcard($server_name)) {
        push(@errors, 'Wildcard certificate names cannot be in the Subject; '
                    . 'put them in the alternatives section instead.') ;
    }
    #>>>

    # If there are alternatives, create an array of them.
    my @alts = () ;

    # If $alternatives is not empty, it needs to contain no whitespace, and
    # only alphanumnerics, dots, dashes, stars, and commas.
    if (defined($alternatives) && ($alternatives ne q{})) {

        # If requester DOES include spaces, strip them out.
        $alternatives =~ s{\s}{}xsmg ;

        # An alternatives string must consist of these characters only:
        #  - letter
        #  - digit
        #  - period (".")
        #  - comma (",")
        #  - hyphen ("-")
        #  - asterisk ("*")
        if ($alternatives !~ m{^[-.,*[:lower:]\d]+$}ixsm) {
            push(
                @errors,
                "If you include Q[$alternatives]server name alternatives, enter them "
                  . 'as a comma-delimited list of valid host names '
                  . 'with no spaces (the only characters allowed in '
                  . 'a hostname are letters, numbers, hyphens, asterisks, and periods).'
            ) ;
        } else {
            @alts = split(/[\s+|,]/xsm, $alternatives) ;

          ALT_LOOP:
            foreach my $alt (@alts) {
                # Allow *.something or something. We allow the first
                # character to be a number.
                if ($alt !~ m{^(?:[*][.])?[-.[:lower:]\d]+$}ixsm) {
                    push(
                        @errors,
                        'One of your alternative server names is not well-formed.'
                    ) ;
                    last ALT_LOOP;
                } elsif ($alt eq '*.stanford.edu') {
                    push(
                        @errors,
                        q{Certificate requests for the wildcard '*.stanford.edu' }
                          . q{must be placed through HelpSU}
                    ) ;
                }
            }
            if (scalar(@alts) > $MAX_SUBJECT_ALT_NAME) {
                push(
                    @errors,
                    "You cannot have more than $MAX_SUBJECT_ALT_NAME alternative names."
                ) ;
            }
        }
    } else {
        ## No alternatives.
    }

    # If fqdn_required is true make sure all the names (subject and alts) are
    # fully-qualifed.
    if ($CR_CONF{'fqdn_required'} !~ m{no}ixsm) {
        my @all_names = ($server_name, @alts) ;
        foreach my $name (@all_names) {
            if (!is_fully_qualified($name)) {
                push(
                    @errors,
                    "The name '$name' is not fully-qualified."
                ) ;
            }
        }
    }

    if (@errors) {
        return $return_with_WARNING_fref->() ;
    }

    # Make sure csr is in valid format and contains fully qualified
    # domain name that matches name entered in form.
    my $validate_csr_error = validate_csr() ;
    if ($validate_csr_error) {
        push(@errors, $validate_csr_error) ;
        return $return_with_WARNING_fref->() ;
    }

    # Since checking NetDB access is the last thing we do, if NetDB access
    # checking is turned off, we can return now.
    if ($skip_netdb_check) {
        return 1 ;
    }

    # For the subject name and all alternatives, make sure requester has
    # necessary NetDB access on node. Put the server_name and alts into a
    # single array.
    my @names_to_check = ($server_name, @alts) ;

    # Do NOT allow submission of *.stanford.edu (unless submitted is an admin).
    # This is a SPECIAL request.
    if (!is_admin()) {
        foreach my $name (@names_to_check) {
            if ($name =~ m{[*][.]stanford[.]edu}xsm) {
                push(@errors, 'Requests for *.stanford.edu must be submitted '
                      . 'via a HelpSU ticket.') ;
                return $return_with_WARNING_fref->() ;
            }
        }
    }

    my $netdbinfo = get_netdb_info($ENV{'REMOTE_USER'}, \@names_to_check) ;

    # We loop through names to check finding any that are problematic.
    foreach my $name (@names_to_check) {
        ## See if there was an error with this name
        my $err_string = validate_hostname($name, $netdbinfo) ;

        if ($err_string) {
            ## There was a problem.
            push(@errors, $err_string) ;
        }
    }

    if (scalar(@errors) == 0) {
        # No errors.
        return 1 ;
    } else {
        # At least one error.
        return $return_with_WARNING_fref->() ;
    }
}

sub format_warning_string {
    my ($errors_aref) = @_ ;

    my @errors = @{$errors_aref} ;

    my $warning_str = 'Submission errors:' . ul(li([@errors])) ;

    return $warning_str ;
}

# Returns 1 if $name is fully-qualified, 0 otherwise.
sub is_fully_qualified {
    my ($name) = @_ ;

    return ($name =~ m{[.](com|edu|net|org|us)$}ixsm) ;
}

# Takes as input ($hostname, $netdbinfo).
#
# Returns the empty string if there are no access problems. Otherwise, the
# string returned describes the access problem.
sub validate_hostname {
    my ($hostname, $netdbinfo) = @_ ;

    my $header = "<strong>$hostname</strong>" ;

    if (is_wildcard($hostname)) {
        ### WILDCARD REQUEST
        my $domain = $hostname ;
        $domain =~ s{^[*][.]}{}xsm ;

        ### DOMAIN
        my $generic_domain_help = <<"EOR";
To request a wildcard certificate for '$domain' there
must exist in NetDB a DOMAIN object for '$domain'
and you must be an Admin for that
DOMAIN object. Please contact Networking for help setting this up.
EOR

        # DOMAIN does not exist.
        if (!$netdbinfo->domain_exists($domain)) {
            my $err_string = <<"EOW";
$header: The name '$domain' does not exist in NetDB as a
DOMAIN object.
$generic_domain_help
EOW
            return $err_string ;
        } elsif ($netdbinfo->controls_domain($domain)) {
            ## DOMAIN exists and user controls it.
            return q{} ;
        } else {
            ## DOMAIN exists and user does NOT control it.
            my $err_string = <<"EOW";
$header: You do not have 'Use as name' access to the
DOMAIN object '$domain' in NetDB.
$generic_domain_help
EOW
            return $err_string ;
        }
    } else {
        ### NON-WILDCARD REQUEST

        ### NODE
        my $generic_node_help = <<"EOR";
To request a certificate for '$hostname' there must exist in NetDB a
NODE object for '$hostname' and you must be in either the User or Admin
field for that node.
EOR

        # NODE or DOMAIN does not exist.
        if ((!$netdbinfo->node_exists($hostname)) && (!$netdbinfo->domain_exists($hostname))) {
            my $err_string = <<"EOW";
$header: The name '$hostname' does not exist in NetDB as a NODE or DOMAIN object.
$generic_node_help
EOW
            return $err_string ;
        } elsif ($netdbinfo->controls_node($hostname)) {
            ## NODE exists and user controls it.
            return q{} ;
        } elsif ($netdbinfo->controls_domain($hostname)) {
            ## DOMAIN exists and user controls it.
            return q{} ;
        } else {
            ## NODE or DOMAIN exists but user does NOT control it.
            my $object_string ;
            if ($netdbinfo->node_exists($hostname)) {
                if ($netdbinfo->domain_exists($hostname)) {
                    $object_string = 'NODE or DOMAIN';
                } else {
                    $object_string = 'NODE';
                }
            } else {
                $object_string = 'DOMAIN';
            }
                    my $err_string = <<"EOW";
$header: You do not have User or Admin access to the $object_string object '$hostname' in NetDB.
$generic_node_help
EOW
            return $err_string ;
        }
    }

    # If we get here, some sort of unknown error.
    my $unknown_error = 'An unknown error occured. Please contact the SSL '
      . 'Certificate provisioing administrators.' ;

    return $unknown_error ;
}

# Parse the PARAMS object and $ENV and populate a hash mapping request object
# fields to values. The fields are:
#
#   certificate_type_name  => normal|ucc|wildcard
#   server_typename       => a server type recognized by InCommon
#   requester_sunetid      => requester's sunetid
#   requester_fullname     => requester's full name
#   requester_email        => requester's e-mail address
#   requester_affiliation  => requester's affiliation
#   requester_department   => requester's department
#   cn                     => the certificate cn (common name)
#   contact_email          => the contact e-mail address
#   duration               => 1|2
#   csr                    => the csr (certificate signing request)
#   approval_contacts      => the list of IDG approvers (??)
#   requester_comments     => requester comments
#   requester_alternatives => requester alternative names
#   use_test_site          => 0|1
#
sub construct_request_values {
    my %field_to_value = () ;

    ## server_type_name
    # Convert the server-type into one that Stanford::Certificate
    # understands.
    my $lcl_stype = $PARAMS{'server_type'} ;
    #<<<  we use special spacing here for clarity
    my $server_type_name =
        ($lcl_stype =~ m{apache}ixsm)              ? 'Apache/ModSSL'
      : ($lcl_stype =~ m{Java\s*Web\s*Server}ixsm) ? 'Java Web Server (Javasoft / Sun)'
      : ($lcl_stype =~ m{Microsoft\s*IIS}ixsm)     ? 'Microsoft IIS 5.x and later'
      : ($lcl_stype =~ m{RedHat}ixsm)              ? 'RedHat Linux'
      : ($lcl_stype =~ m{Tomcat}ixsm)              ? 'Tomcat'
      : ($lcl_stype =~ m{OTHER}ixsm)               ? 'OTHER'
      : undef
    ;
    #>>>
    if (!defined($server_type_name)) {
        croak "could not find a server type matching '$lcl_stype'" ;
    }
    $field_to_value{'server_type_name'} = $server_type_name ;

    ## requester_sunetid,
    ## requester_fullname,
    ## requester_email,
    ## requester_affiliation,
    ## requester_department
    $field_to_value{'requester_sunetid'}    = $ENV{'REMOTE_USER'} ;
    $field_to_value{'requester_fullname'}   = get_displayName() ;
    $field_to_value{'requester_email'}      = get_requester_email() ;
    $field_to_value{'requester_department'} = get_ou() ;

    ## cn
    $field_to_value{'cn'} = $PARAMS{'server_name'} ;

    ## contact_email
    $field_to_value{'contact_email'} = $PARAMS{'contact_address'} ;

    ## duration
    # As of August 2020 duration can only have one value: 1 (i.e., 1 year).
    $field_to_value{'duration'} = 1 ;

    ## csr
    $field_to_value{'csr'} = trim($PARAMS{'csr'}) ;

    ## approval_contacts
    # Get the list of InCommon approvers from the cert-request
    # config. If, for some reason, this list is empty, send to a
    # reasonable default.
    my $incommon_approvers = $CR_CONF{'incommon_approvers'} ;
    if (!$incommon_approvers) {
        $incommon_approvers = 'its-ssl-service-test@lists.stanford.edu' ;
    }
    $field_to_value{'approval_contacts'} = $incommon_approvers ;

    ## requester_comments
    my $requester_comments ;
    $requester_comments = $PARAMS{'comments'} ;
    $field_to_value{'requester_comments'} = $requester_comments ;

    ## requester_alternatives
    # Normalize the subject alternative names string
    my $alternatives_raw = $PARAMS{alternatives} ;
    my $requester_alternatives ;
    my @sans = () ;
    if (defined($alternatives_raw)) {
        ## Remove all spaces.
        $alternatives_raw =~ s{\s}{}gxsm ;

        # Split on the commas
        my @alts = split(/,/xsm, $alternatives_raw) ;

        foreach my $alt (@alts) {
            ## If $alt is non-empty, push it.
            if ($alt) {
                push(@sans, $alt) ;
            }
        }
    }
    $requester_alternatives = join(q{,}, @sans) ;
    $field_to_value{'requester_alternatives'} = $requester_alternatives ;

    ## Set the certificate type.
    my $certificate_type_name ;
    if (scalar(@sans) > 0) {
        $certificate_type_name = 'ucc' ;
    } else {
        $certificate_type_name = 'normal' ;
    }
    $field_to_value{'certificate_type_name'} = $certificate_type_name ;

    ## use_test_site (or not)
    $field_to_value{'use_test_site'} = use_test_certmanager() ;

    return %field_to_value ;
}

# Returns 1 if the configuration directs us to use the production
# certificate manager, 0 otherwise.
sub use_prod_certmanager {
    # For safety's sake we default to using the TEST site.
    my $use_prod_site        = $CR_CONF{'use_prod_site'} ;
    my $use_prod_certmanager = $CR_CONF{'use_prod_certmanager'} ;

    if ($use_prod_site) {
        deprecation_warning(q['use_prod_site' is deprecated; use instead 'use_prod_certmanager']);
    }

    if ($use_prod_site && ($use_prod_site !~ m{yes}ixsm)) {
        return 0 ;
    }

    if ($use_prod_certmanager && ($use_prod_certmanager !~ m{yes}ixsm)) {
        return 0 ;
    }

    # If we get here neither 'use_prod_site' nor 'use_prod_certmanager'
    # configuration directives were used.
    return 1;
}

# Return the "opposite" of use_prod_certmanager.
sub use_test_certmanager {
    return (use_prod_certmanager() + 1) % 2 ;
}

# Returns 1 if the configuration directs us to use the NetDB production
# instance, 0 otherwise.
sub use_prod_netdb {
    # For safety's sake we default to using the PRODUCTION NetDB
    # site.
    #
    # Why? If we mistakenly used the non-production NetDB site but
    # were sending certificate requests to the production certificate
    # manager this might allow someone to get a production certificate
    # when they shouldn't.
    my $netdb_instance = $CR_CONF{'netdb_instance'} ;
    my $use_prod_netdb = $CR_CONF{'use_prod_netdb'} ;

    if ($netdb_instance) {
        deprecation_warning(q['netdb_instance' is deprecated; use instead 'use_prod_netdb']);
    }

    if ($netdb_instance && ($netdb_instance =~ m{dev}ixsm)) {
        return 0;
    }

    if ($use_prod_netdb && ($use_prod_netdb =~ m{no}ixsm)) {
        return 0;
    }

    return 1;
}

sub deprecation_warning {
    my ($d_warning) = @_ ;
    warn "DEPRECATION WARNING: $d_warning" ;
    return 1 ;
}


# Take the form submission:
#   1. Create a Stanford::Certificate request
#   2. Save request object in the Stanford Certificate database
#   3. Send the request to the InCommon/Comodo Certificate Manager
#   4. Send a notification to the certificate approvers to approve this
#      request.
sub create_and_send_cert_request {
    ## Step 1. Construct the hash mapping needed request parameters.
    my %request_field_to_value = construct_request_values() ;

    # Step 2. Make sure the InCommon Certificate Manager credentials file
    # exists. If it does not, abort (as there is no point in continuing).
    my $incommon_cm_credentials_file =
      $CR_CONF{'incommon_cm_credentials_yaml_file'} ;
    if (!$incommon_cm_credentials_file) {
        croak 'no Incommon Certificate Manager credential files defined' ;
    } elsif (!(-e $incommon_cm_credentials_file)) {
        croak 'could not find Incommon Certificate Manager credential '
          . "file '$incommon_cm_credentials_file'" ;
    }

    # Step 3. Make a Stanford::Certificate::Result::Request object.
    eval 'use Stanford::Certificate' ;  ## no critic (ProhibitStringyEval) ;
    if ($EVAL_ERROR) {
        croak "problem loading Stanford::Certificate: $EVAL_ERROR" ;
    }

    my $connect_yml_file = '/etc/certreq/cert-request-db.yml' ;
    my $schema           = Stanford::Certificate::attach($connect_yml_file) ;
    my $request          = $schema->resultset('Request')->new({}) ;

    # Step 4. Make the request object based on the form values.
    my $new_request = $request->create_from_web_page(%request_field_to_value) ;

    # Step 5. Save the request object in the request database.
    $new_request->saveme() ;

    # Step 6. Check to see if this certificate type needs special
    # handling. If the certificate is not a single-domain cert OR
    # there are SANs OR this is a re-issue, mark it special handling.
    my $special_handling = undef ;
    #<<<  we use special spacing here for clarity
    if (    ($new_request->certificate_type()->name() eq 'normal')
         && (!$request_field_to_value{'requester_alternatives'})
       ) {
        $special_handling = 0 ;
    } else {
        $special_handling = 1 ;
    }
    #>>>

    # Step 6. Send the request to InCommon.
    $new_request->send($incommon_cm_credentials_file) ;

    # Step 7. Notify the approver(s) that an approval is needed. (The
    # approvers were set in the 'approval_contacts' property in the call
    # to the create_from_web_page function above.)
    $new_request->notify_approvers('special_handling' => $special_handling) ;

    # Step 8. Notify the interested parties that the request has been
    # submitted to InCommon. The interested parties are the requester and
    # the contact address.
    $new_request->notify_sent() ;

    return 1 ;
}

# Takes as input the requester sunetid and a (reference to an) array of
# hostnames.
#
# Returns the hash mapping
#
#   $hostname => [$node_control_results, $domain_control_results]
#
# where $node_control_results and $domain_control_results are values in
# the hash %NETDB_RESULTS.
#
# Raises an exception if the external script used to gather this
# information fails.
sub get_netdb_info {
    my ($requester, $hostnames_aref) = @_ ;

    my @hostnames = @{$hostnames_aref} ;

    # We remove any leading '*.' prefixes.
    my @hostnames_stripped = () ;
    foreach my $hostname (@hostnames) {
        $hostname =~ s{^[*][.]}{}xsm ;
        push(@hostnames_stripped, $hostname) ;
    }

    # Remove any duplicates.
    my %names_indicator = () ;
    foreach my $hostname (@hostnames_stripped) {
        $names_indicator{$hostname} = 1 ;
    }

    my @hostnames_unique = keys %names_indicator ;

    # Construct the string that netdb-access-info-for-ssl wants:
    # Example: adamhl,mdm1.stanford.edu;adamhl,mdm2.stanford.edu
    my @tuples = map { $requester . q{,} . $_ } @hostnames_unique ;

    # $fs is the field separator
    my $fs = q{:} ;

    my $query_string = join($fs, @tuples) ;

    # Construct the command: either
    #
    #  "netdb-access-info-for-ssl $query_string"
    #
    # or
    #
    #  "netdb-access-info-for-ssl -t $query_string"
    my @cmd = qw( netdb-access-info-for-ssl ) ;

    if (!use_prod_netdb()) {
        # The configuration says to not use the non-production version of
        # NetDB, so add the '-t' option.
        push(@cmd, '-t') ;
    }

    # Add the query string and we are done constructing the command:
    push(@cmd, $query_string) ;

    my $keytab_file = '/etc/certreq/netdb-access.keytab' ;
    my ($stdout, $stderr, $rc) = run_under_keytab(\@cmd, $keytab_file) ;

    if ($stderr) {
        croak "problem running netdb-access-info-for-ssl: $stderr" ;
    } else {
        ## Parse the results. The results come back in this format:
        ## user1,hostname1,RESULT ;user2,hostname2,RESULT
        return NetDBInfo->new('results' => $stdout) ;
    }
}

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

    # (From Russ)
    my ($out, $err) ;
    ## no critic (ValuesAndExpressions::ProhibitMagicNumbers) ;
    IPC::Run::run(\@command, q{>}, \$out, q{2>}, \$err) ;
    return ($out, $err, $CHILD_ERROR >> 8) ;
}

# Given a command array and kerberos keytab file, run the command under
# the context of that keytab.
#
# Returns the triple ($stdout, $stderr, $exit_code) from running the
# k5start command.  Note that we include the -t option to get an AFS
# token.
sub run_under_keytab {
    my ($command_aref, $keytab_file) = @_ ;

    my @command_to_run = @{$command_aref} ;

    my @k5start_cmd = (
        'k5start',
        '-U',
        '-f', $keytab_file,
        '-t',  # get AFS token
        '-q',  # be quiet
    ) ;

    my $cmd = join(q{ }, @command_to_run) ;

    #<<< tell perltidy to skip this small section
    my @command = (@k5start_cmd,
                   q{--},
                   'sh',
                   '-c',
                   $cmd,
        ) ;
    #>>>
    return run_command_improved(@command) ;
}

sub validate_csr {
    my $err_string ;

    my $CSR = trim($PARAMS{'csr'}) ;

    my @objects = Stanford::PKObj::get_objects_from_string($CSR) ;
    my $csr     = $objects[0] ;

    my ($key_size, $pk_algorithm) ;
    eval {
        ($key_size, $pk_algorithm) = $csr->get_keyinfo() ;
    } ;
    if ($EVAL_ERROR) {
        $err_string = 'Could not parse your CSR string.' ;
        return $err_string ;
    }

    my %csr_fields ;
    eval {
        %csr_fields = Stanford::PKObj::parse_req($csr->get_contents()) ;
    } ;
    if (! %csr_fields) {
        $err_string = 'Could not parse your CSR string.' ;
        return $err_string ;
    }

    my $subject = $csr_fields{'subject'} ;

    # We wrap dn_to_cn in an eval in case it raises an exception.
    my $csr_server_name ;
    #<<< tell perltidy to skip this small section
    eval {
        $csr_server_name = Stanford::Orange::Util::dn_to_cn($subject) ;
    } ;
    #>>>

    my $server_name = $PARAMS{'server_name'} ;

    if (!defined($csr_server_name)) {
        my $openssl_cmd = '/usr/bin/openssl req -noout -text -in' ;
        $err_string =
            'Cannot find the CN '
          . 'within the contents of your CSR (Certificate Signing '
          . 'Request). Please make sure the contents of your CSR can be viewed '
          . "and the CN exists with this command:<br><br> $openssl_cmd [csr "
          . 'file]' ;
        return $err_string ;
    } elsif (lc($csr_server_name) ne lc($server_name)) {
        $err_string =
            'The server name '
          . "you indicated in the form ($server_name) doesn't match "
          . "the one in the CSR ($csr_server_name). Please double-check your "
          . 'request and make sure these match.' ;
        return $err_string ;
    }

    # RSA CSRs must be signed with a key of at least $MIN_RSA_KEY_SIZE
    # bits; ECC CSRs must use a key of at least $MIN_ECC_KEY_SIZE bits.
    if (!$key_size) {
        $err_string =
            'Your CSR is signed with a '
          . 'public key whose size we could not determine. Please contact '
          . 'the SSL Certificate service team for assistance.' ;
        return $err_string ;
    } elsif (($pk_algorithm =~ m{rsa|dsa}isxm) && ($key_size < $MIN_RSA_KEY_SIZE)) {
        $err_string =
            'Your CSR is signed with a '
          . "$key_size-bit key which is no longer supported. Please create a new $MIN_RSA_KEY_SIZE-bit "
          . 'key and generate a new CSR for your order.' ;
        return $err_string ;
    } elsif (($pk_algorithm =~ m{id.ecPublicKey}isxm) && ($key_size < $MIN_ECC_KEY_SIZE)) {
        $err_string =
            "CSRs using ECC public-keys must have a minimum key size of $MIN_ECC_KEY_SIZE "
          . "bits. Your CSR has a $key_size-bit key which is too small." ;
        return $err_string ;
    } else {
        # Everything is OK, so nothing to do.
    }

    # If we get here, there are no CSR-related validation errors, so
    # return the empty string to indicate this.
    return q{} ;
}

# Return $ENV{'displayName'} if $ENV{'displayName'} is defined,
# otherwise return a string based on REMOTE_USER.
sub get_displayName {  ## no critic (NamingConventions::Capitalization) ;
    if ($ENV{'displayName'}) {
        return $ENV{'displayName'} ;
    } else {
        return '(No displayName)' ;
    }
}

# Return $ENV{'ou'} if $ENV{'ou'} is defined, otherwise return some other string.
sub get_ou {
    if ($ENV{'ou'}) {
        return $ENV{'ou'} ;
    } else {
        return 'No department defined' ;
    }
}

##############################################################################
# NetDB Info class
##############################################################################
package NetDBInfo {  ## no critic (Subroutines::RequireArgUnpacking) ;

    use Readonly ;

    Readonly my $RESULT_NO_NODE         =>  4 ;
    Readonly my $RESULT_NO_DOMAIN       =>  8 ;
    Readonly my $RESULT_CONTROLS_NODE   => 16 ;
    Readonly my $RESULT_CONTROLS_DOMAIN => 32 ;

    sub new {
        my ($proto, %args) = @_ ;
        my $self = {} ;
        my $class = ref($proto) || $proto ;

        $self->{'results'} = $args{'results'} || undef ;

        $self->{'controls_node'}   = {} ;
        $self->{'controls_domain'} = {} ;

        bless($self, $class) ;

        $self->initialize() ;

        return $self ;
    }

    # Returns 1 if a NODE object with the name $node_name exists in NetDB,
    # 0 otherwise.
    sub node_exists {
        my $self = shift ;
        my ($node_name) = @_ ;

        if (exists($self->{'controls_node'}->{$node_name})) {
            return 1 ;
        } else {
            return 0 ;
        }
    }

    # Returns 1 if a DOMAIN object with the name $node_name exists in NetDB,
    # 0 otherwise.
    sub domain_exists {
        my $self = shift ;
        my ($domain_name) = @_ ;

        if (exists($self->{'controls_domain'}->{$domain_name})) {
            return 1 ;
        } else {
            return 0 ;
        }
    }

    # $control should be 0 for does NOT control, 1 for DOES control
    sub controls_node {
        my $self = shift ;
        my ($node_name, $control) = @_ ;

        if (defined($control)) {
            $self->{'controls_node'}->{$node_name} = $control ;
        }

        return $self->{'controls_node'}->{$node_name} ;
    }

    # $control should be 0 for does NOT control, 1 for DOES control
    sub controls_domain {
        my $self = shift ;
        my ($domain_name, $control) = @_ ;

        if (defined($control)) {
            $self->{'controls_domain'}->{$domain_name} = $control ;
        }

        return $self->{'controls_domain'}->{$domain_name} ;
    }

    # Take results in $self->{'results'} and parse.
    sub initialize {
        my $self = shift ;

        my $results = $self->{'results'} ;

        my $fs = q{:} ;

        my @results = split(/$fs/xsm, $results) ;

        foreach my $result (@results) {
            my ($user, $host, $result_code) = split(/,/xsm, $result) ;

            if ($result_code & $RESULT_NO_NODE) {
                ## NO_NODE_IN_NETDB
                ## We do nothing.
            } elsif ($result_code & $RESULT_CONTROLS_NODE) {
                ## USER_CONTROLS_NODE
                $self->controls_node($host, 1) ;
            } else {
                ## USER_DOES_NOT_CONTROL_NODE
                $self->controls_node($host, 0) ;
            }

            if ($result_code & $RESULT_NO_DOMAIN) {
                ## NO_DOMAIN_IN_NETDB
            } elsif ($result_code & $RESULT_CONTROLS_DOMAIN) {
                ## USER_CONTROLS_DOMAIN
                $self->controls_domain($host, 1) ;
            } else {
                ## USER_DOES_NOT_CONTROL_NODE
                $self->controls_domain($host, 0) ;
            }

        }

        return $self ;
    }
}

##############################################################################
# Helper routines
##############################################################################

# Send a note back to the user confirming the ssl certificate request.
sub send_email {
    my ($to, $subject, $body) = @_;

    my $smtp_host = $ENV{'SMTP_HOSTNAME'} or die "SMTP_HOSTNAME not set";
    my $smtp_port = $ENV{'SMTP_PORT'} or die "SMTP_PORT not set";
    my $smtp_user = $ENV{'SMTP_USERNAME'} or die "SMTP_USERNAME not set";
    my $smtp_pass = $ENV{'SMTP_PASSWORD'} or die "SMTP_PASSWORD not set";
    my $from      = $CR_CONF{'from_email_address'} ;

    my $smtp = Net::SMTP->new(
        $smtp_host,
        Port    => $smtp_port,
        Timeout => 30,
        Debug   => 1
    ) or die "Could not connect to SMTP server: $!";

    $smtp->starttls() or die "Failed to start TLS: $!";
    $smtp->auth($smtp_user, $smtp_pass) or die "SMTP authentication failed: $!";

    $smtp->mail($from);
    $smtp->to($to);
    $smtp->data();
    $smtp->datasend("From: ITS SSL Request Service <$from>\n");
    $smtp->datasend("To: $to\n");
    $smtp->datasend("Subject: $subject\n");
    $smtp->datasend("\n");
    $smtp->datasend($body);
    $smtp->dataend();
    $smtp->quit();
}

sub auto_reply {
    my $mail = <<'EOM';
**** This is an automated response, please do not reply to this message. ****

Your request has been successfully submitted to the SSL certificate
administrators. Once created your cert will be sent as an e-mail
attachment to the contact address listed in your request. The e-mail will
also contain instructions on how to install the cert.

Further documentation for this service can be found at
    https://www.stanford.edu/services/ssl/

If you have any questions, please fill out a HelpSU form at
    https://helpsu.stanford.edu

Thank you very much.

**** This is an automated response, please do not reply to this message. ****
EOM

    my $to      = $PARAMS{contact_address};
    my $subject = "SSL certificate request for $PARAMS{server_name} has been submitted";

    send_email($to, $subject, $mail);
    return;
}

# Returns a hash with these keys:
#
# - use_prod_site (deprecated synonym of use_prod_certmanager)
# - use_prod_certmanager
# - use_prod_netdb
# - from_email_address
# - to_email_override
# - incommon_cm_credentials_yaml_file
# - db_connect_yaml_file
# - incommon_approvers
# - validate_hostname_access_via_netdb
# - redirect_to_outage
# - admin_sunetids
# - netdb_instance (deprecated)

sub get_config {
    my ($cfg_yaml_file) = @_ ;

    if (!$cfg_yaml_file) {
        croak 'missing config file' ;
    }

    if (!(-f $cfg_yaml_file)) {
        croak "missing or unreadable config file '$cfg_yaml_file'" ;
    }

    my %config_key_to_value = () ;

    my $yaml = YAML::Tiny->new ;
    $yaml = YAML::Tiny->read($cfg_yaml_file) ;
    if (!defined($yaml)) {
        croak "failed to parse '$config_yaml_file' as a YAML file: "
          . YAML::Tiny->errstr() ;
    }

    # Which keys are MANDATORY, that is, if they are missing from the
    # configuration file we abort.
    my %keys_to_mandatory = (
        'use_prod_site'                      => 1,
        'use_prod_certmanager'               => 0,
        'use_prod_netdb'                     => 0,
        'from_email_address'                 => 0,
        'to_email_override'                  => 0,
        'incommon_cm_credentials_yaml_file'  => 1,
        'db_connect_yaml_file'               => 1,
        'incommon_approvers'                 => 1,
        'validate_hostname_access_via_netdb' => 1,
        'redirect_to_outage'                 => 0,
        'admin_sunetids'                     => 0,
        'netdb_instance'                     => 0,
        'fqdn_required'                      => 0,
    ) ;

    foreach my $key (keys %keys_to_mandatory) {
        if (exists($yaml->[0]->{$key})) {
            $config_key_to_value{$key} = $yaml->[0]->{$key} ;
        } elsif ($keys_to_mandatory{$key}) {
            carp "config file missing parameter '$key'" ;
        } else {
            ## key is not in config but not mandatory, so do nothing.
        }
    }

    # Parse admin_sunetids into an array
    my @admin_sunetids = () ;
    my @admin_sunetids_filtered = () ;
    if ($config_key_to_value{'admin_sunetids'}) {
        @admin_sunetids = split(/,/xsm,
                              $config_key_to_value{'admin_sunetids'}) ;
        # Remove any blanks
        foreach my $admin_sunetid (@admin_sunetids) {
            $admin_sunetid = trim($admin_sunetid) ;
            if ($admin_sunetid) {
                push(@admin_sunetids_filtered, $admin_sunetid) ;
            }
        }
    }
    $config_key_to_value{'admin_sunetids'} = \@admin_sunetids_filtered ;

    # Die if missing important ones
    if (!$config_key_to_value{'from_email_address'}) {
        croak q{missing 'from_email_address' configuration directive} ;
    }

    # Set default value of fqdn_required if not defined.
    if (!exists($config_key_to_value{'fqdn_required'})) {
        $config_key_to_value{'fqdn_required'} = 'YES' ;
    }

    return %config_key_to_value ;
}

sub get_requester_email {
    ## no critic (RequireInterpolationOfMetachars) ;
    if ($ENV{WEBAUTH_LDAP_MAIL}) {
        return $ENV{WEBAUTH_LDAP_MAIL} ;
    } else {
        return $ENV{REMOTE_USER} . q{@stanford.edu} ;
    }
}

sub trim {
    my ($s) = @_ ;

    if (!defined($s)) { return $s }

    $s =~ s{^\s*}{}xs ;  ## no critic (RequireLineBoundaryMatching) ;
    $s =~ s{\s*$}{}xs ;  ## no critic (RequireLineBoundaryMatching) ;

    return $s ;
}

# Return 1 id $name starts with "*." 0 otherwise.
sub is_wildcard {
    my ($name) = @_ ;
    return ($name =~ m{^[*][.]}xsm) ;
}

sub set_cookie {

}

sub is_admin {
    my @admin_sunetids = @{ $CR_CONF{'admin_sunetids'} } ;

    foreach my $admin_sunetid (@admin_sunetids) {
        if ($ENV{'REMOTE_USER'} eq $admin_sunetid) {
            return 1 ;
        }
    }

    return 0 ;
}

sub set_motd {
    # Read in the motd file (if there is one).
    my $motd_html ;
    if (-f '/etc/certreq/motd.html') {
        $motd_html = slurp('/etc/certreq/motd.html');
    }

    # Read in the expiration of the motd. This file should contain a single line
    # of the form "YYYY-MM-DD HH:MM:SS". This date/time means that the motd will be shown
    # UNLESS the current LOCAL date/time is greater than the time in the file. If not file
    # the motd is shown forever.
    my $motd_expired = 0;
    if (-f '/etc/certreq/motd-expiration') {
        my $motd_expiration = slurp('/etc/certreq/motd-expiration');
        if ($motd_expiration =~ m{^(\d{4}-\d{2}-\d{2}\s+\d{2}:\d{2}:\d{2})}xsm) {
            my $date_string = $1 ;
            my $parser = DateTime::Format::Strptime->new(
                pattern => '%Y-%m-%d %H:%M:%S',
                on_error => 'croak',
                );
            my $dt_expired = $parser->parse_datetime($date_string);
            my $dt_now     = DateTime->now;
            if (DateTime->compare($dt_now, $dt_expired) > 0) {
                # This means current time is past the expired time set in
                # /etc/certreq/motd-expiration, so we don't show the MOTD.
                $motd_expired = 1 ;
            } else {
                # Not expired
                $motd_expired = 0 ;
            }
        } else {
            # Could not parse date as let's assume not expired.
            $motd_expired = 0 ;
        }
    } else {
        # No expiraiton file, so not expired.
        $motd_expired = 0 ;
    }

    if ($motd_html && !$motd_expired) {
        $TMPL->param('SHOW_MOTD' => 1) ;
        $TMPL->param('MOTD'      => $motd_html) ;
    } else {
        $TMPL->param('SHOW_MOTD' => 0) ;
    }

    # Also set the application version.
    $TMPL->param(APP_VERSION => $VERSION);

    return ;
}

##############################################################################
# Main routine
##############################################################################
# Get output and errors in the right order.
local $OUTPUT_AUTOFLUSH = 1 ;

if (-f '/etc/certreq/maintenance') {
    my $maint_form = '/usr/share/certreq/template/cert-reqest-maintenance.tmpl' ;
    $TMPL = HTML::Template->new(filename => $maint_form) ;
    print header, $TMPL->output ;
    exit 0 ;
}

my $form = generate_form() ;
if ($form->submitted) {
    %PARAMS = CGI::Vars() ;
    if (validate_submit()) {
        ## START: create and send the certificate request
        eval { create_and_send_cert_request() ; } ;
        if ($EVAL_ERROR) {
            carp 'there was a problem creating or sending the certificate '
              . "request to InCommon: $EVAL_ERROR" ;
        }
        ## END: create and send the certificate request. ##

        # Set a cookie with the confirmation and redirect.
        my $server_name = $PARAMS{'server_name'} ;
        my $cookie_value = <<"EOC";
Your request for <strong>$server_name</strong> has been submitted to the
SSL certificate administrators.
When the request is approved, an e-mail will be sent to the contact
address listed in your request. This e-mail will contain links where the certificate
can be downloaded in a variety of formats.
EOC
        my $q = CGI->new;
        my $cookie = CGI::Cookie->new(-name  => 'success',
                                      -value => $cookie_value) ;
        print $q->redirect(-uri    => '/cert-request',
                           -cookie =>[$cookie],
                          );
    } else {
        $TMPL = HTML::Template->new(filename => $FORM) ;
        set_motd();
        $TMPL->param(WARNING => $WARNING_STR) ;
        $TMPL->param(REQFORM => $form->render(
                         table => 0,
                     ));
        print header, $TMPL->output ;
    }
} else {
    # MAIN FORM

    # Was there a success cookie set?
    my %cookies = CGI::Cookie->fetch ;
    my $success = undef ;
    my $cookie ;
    if (exists($cookies{'success'})) {
        $success = $cookies{'success'}->value ;
        $cookie = CGI::Cookie->new(-name  => 'success',
                                   -value => q{}) ;

    }

    $TMPL = HTML::Template->new(filename => $FORM) ;
    set_motd();

    $TMPL->param(REQFORM => $form->render(
                     table => 0,
                 ));
    if ($success) {
        $TMPL->param(SUCCESS => $success) ;
    }
    print header(-cookie=>$cookie), $TMPL->output ;
}
