### Local Variables: ***
### mode:perl ***
### comment-column:0 ***
### comment-start: "### " ***
### comment-end: "***" ***
### End: ***
#
# ****************DO NOT MOVE OR CHANGE LINES ABOVE THIS*********************
#
# The first set of lines runs perl from any shell. The second set of lines 
# identifies the rest of the file as PERL for EMACS autoformatting. 
# See end of copyright for more information.
#
# 
# -------------------------------------------------------------------
#                                   X-BONE
#
#                          http://www.isi.edu/xbone
#                USC Information Sciences Institute (USC/ISI)
#                   Marina del Rey, California 90292, USA
#                          Copyright (c) 1998-2005
# 
# -------------------------------------------------------------------
#
# Copyright (c) 1998-2005 by the University of Southern California.
# All rights reserved.
#
# Permission to use, copy, modify, and distribute this software and
# its documentation in source and binary forms for non-commercial
# purposes and without fee is hereby granted, provided that the above
# copyright notice appear in all copies and that both the copyright
# notice and this permission notice appear in supporting
# documentation, and that any documentation, advertising materials,
# and other materials related to such distribution and use acknowledge
# that the software was developed by the University of Southern
# California, Information Sciences Institute.  The name of the
# University may not be used to endorse or promote products derived
# from this software without specific prior written permission.
# 
# THE UNIVERSITY OF SOUTHERN CALIFORNIA MAKES NO REPRESENTATIONS ABOUT
# THE SUITABILITY OF THIS SOFTWARE FOR ANY PURPOSE.  THIS SOFTWARE IS
# PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES,
# INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
# Other copyrights might apply to parts of this software and are so
# noted when applicable.
#
# -------------------------------------------------------------------
#
# Effort partly sponsored by the Defense Advanced Research Projects
# Agency (DARPA) and Air Force Research Laboratory, Air Force Materiel
# Command, USAF, under agreement numbers F30602-98-1-0200 (X-Bone) and
# F30602-01-2-0529 (DynaBone). The views and conclusions contained
# herein are those of the authors and should not be interpreted as
# necessarily representing the official policies or endorsements,
# either expressed or implied, of the Defense Advanced Research
# Projects Agency (DARPA), the Air Force Research Laboratory, or the
# U.S. Government.
#
# This work was partly supported by the NSF STI-XTEND (ANI-0230789)
# and NETFS (ANI-0129689) projects. Any opinions, findings, and
# conclusions or recommendations expressed in this material are those
# of the authors and do not necessarily reflect the views of the
# National Science Foundation.
#
# -------------------------------------------------------------------
#  $RCSfile: XB_Common.pm,v $
#
# $Revision: 1.28 $
#   $Author: pingali $
#     $Date: 2005/03/31 07:04:02 $
#    $State: Exp $
# ----------------------------------------------------------------------------
#
# Primary Author: Lars Eggert

package XB_Common;

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(fail_page my_th process_req user_info);
@EXPORT_OK = qw ();

use strict;
use sigtrap;

use CGI qw(:standard :html3);
use CGI::Carp qw(fatalsToBrowser);

sub fail_page ($$;@) {
  my ($header, $msg, @cookies) = @_;
  if($#cookies == -1) { print header; }
  else { print header("-cookie" => \@cookies); }
  print start_html(-title => $header, 
	           -background => "/xml/images/background_med_tan.gif",
		   -style => { -src =>"/xml/xbone.css" }), 
    h1( {-class => "secheader"}, $header), p($msg), 
    p("Back to the ", a({-href => "/"}, "main X-Bone page") . "."), end_html;
  exit(0);
}


sub my_th ($$) {
  my ($tag, $name) = @_;
  if(not defined param($tag) or param($tag) eq "") { 
    return th({-class => "redbg"}, $name); 
  } 
  return th($name);
}


sub process_req () {
  # process the request
  unless($ENV{'DOCUMENT_ROOT'}) { 
    fail_page "DOCUMENT_ROOT not defined.",
    p("This should not happen when being called from apache.") . 
      p("Something is seriously broken."); }
  
  my $base_dir = $ENV{'DOCUMENT_ROOT'};
  # untaint
  if ($base_dir =~ /^((\/([[:alnum:]]|[-_\.])*)*)$/) { $base_dir = $1; }
  else { die "tainted: $base_dir"; }
  $base_dir =~ s/\/(s-)?htdocs//;
  my $certs_dir = "$base_dir/unsigned-cert-requests"; 
  if(not -d $certs_dir) {
    mkdir $certs_dir, 0600 or die "cannot mkdir $certs_dir: $!";
  }
  my $counter = new File::CounterFile("$certs_dir/.counter", 1);
  unless($counter) { 
    fail_page "Request Counter Failure", 
    p("Could not create request counter file: $!"); 
  }
  my $count = $counter->inc();
  # untaint
  if ($count =~ /^(\d+)$/) { $count = $1; }
  else { die "tainted: $count"; } 
  my $req_file = "$certs_dir/cert$count.req"; # certificate request filename
  my ($message, $mail_message) = ("") x 2;
  
  my $key = param('SPKAC'); # this will fail if not Netscape browser
  unless($key) { 
    fail_page "Netscape Required",
    p("No private key included in request. Maybe you are not " .
      "running Netscape Navigator as I thought?"); 
  }
  
  # Explicitly list form fields we must have for certificate creation to work
  my @req_names = ('commonName', 'emailAddress', 'organizationName',
		   'organizationalUnitName', 'localityName', 
		   'stateOrProvinceName', 'countryName', 'SPKAC');
  
  foreach my $name (@req_names) {
    my $value = param("$name");
    $value =~ tr/\n//d;
    # this goes into the request file that will be signed by the CA	
    my $line = "$name = $value\n";
    $message .= $line;
    # this goes into the mail message sent to the CA (omit SPKAC) 
    unless($name eq "SPKAC") { $mail_message .= "$name: $value\n"; }
  }  
  
  # build the request file
  open(REQ, ">$req_file") or 
    fail_page "Request Creation Failed", 
    p("Could not create request file ($!): $req_file");
  print REQ $message;
  close(REQ);
  chmod 0444, $req_file;
  
  # make sure we actually created a request file
  unless(-f $req_file) { 
    fail_page "Request Creation Failed",
    p("Request file missing: $req_file"); 
  }
  
  # send email to the CA guys
  my $email = param('emailAddress');
  my $sender = param('commonName');
  my %letter = ( To => $XB_Params::CA_EMAIL,
		 From => "$sender <$email>",
		 Subject => "X-Bone Certificate Request",
		 Message => 
		 "This file needs to be passed through the signing script:\n".
		 $req_file . "\n\nSubmitted from overlay ".
                 "manager $XB_Params::XBONE_OVERLAY_MANAGER.\n\n".
		 "$mail_message\n"
	       );
  
  unless (Mail::Sendmail::sendmail(%letter)) { 
    fail_page "Error Sending Mail", 
    p("Could not send email: $Mail::Sendmail::error");
  }
}


sub user_info () {
  my %user = ( User         => "$ENV{SSL_CLIENT_S_DN_CN} &lt;" .
	                       a({-href => "mailto:$ENV{SSL_CLIENT_S_DN_Email}"},
				 $ENV{SSL_CLIENT_S_DN_Email}) . "&gt;",
	       Organization => $ENV{SSL_CLIENT_S_DN_O} .
  	                       ($ENV{SSL_CLIENT_S_DN_OU} ? 
				", $ENV{SSL_CLIENT_S_DN_OU}" : ""),
	       Location     => $ENV{SSL_CLIENT_S_DN_L} .
  	                       ($ENV{SSL_CLIENT_S_DN_ST} ? 
				", $ENV{SSL_CLIENT_S_DN_ST}" : "") .
	                       ($ENV{SSL_CLIENT_S_DN_C} ? 
				", $ENV{SSL_CLIENT_S_DN_C}" : ""));
  my $user_rows = "";
  while(my ($key, $val) = each %user) { $user_rows .= Tr(th($key), td($val)); }
  return  p("You are logged in with these credentials ",
	    "(taken from your X.509 certificate):") . table($user_rows);
}

1;