#  This is version 0.3 of absent
#
#               Copyright (c) 1999 by AT&T.
#  Permission to use, copy, and modify this software without fee is
#  hereby granted, provided that this entire notice is included in all
#  copies of any software which is or includes a copy or modification
#  of this software and in all copies of the supporting documentation
#  for such software.
#
#  SOME PARTS OF ABSENT MAY BE RESTRICTED UNDER UNITED STATES EXPORT
#  REGULATIONS.
#
#  THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR
#  IMPLIED WARRANTY.  IN PARTICULAR, NEITHER THE AUTHORS NOR AT&T MAKE
#  ANY REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE
#  MERCHANTABILITY OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR
#  PURPOSE.
#       
# Author          : Christian Gilmore
# Created On      : Thu May 28 12:24:35 EDT 1998
# Status          : Functional
# 
# NAME
#    AbsentProxyRewrite.pm
#
# PURPOSE
#    Portion of absent to process incoming URIs, fetch remote pages, and
#    rewrite URLs for the absent client. Next generation of rewrite_urls.pl 
#    code.
#
###############################################################################

# Name of the package
package AbsentProxyRewrite;


# XXX EDIT ME XXX
# ABSENT_URL is used in constructing rewritten URLs; it's the base url
# for all rewrites and should point to the OUTSIDE absent server.
# IMPORTANT: this url is handed to outside clients, which see pushweb as
# though it were absent; so if, for example, your outside host is named
# absent and your inside host pushweb, you MUST make this URL something
# of the form
#  https://absent...
# _NOT_
#  https://pushweb...
# do not put a trailing slash on this URL.
my $ABSENT_HOST = "absent.yoyodyne.com";
my $ABSENT_URL = "https://$ABSENT_HOST";
#
# ABSENT_EMAIL is the mail address of someone responsible at your site
# for the absent system.  It's used to indicate where users should send
# mail if they have a problem.
#
my $ABSENT_EMAIL = "absent\@yoyodyne.com";
#
# INTERNAL_SITES is a regex matching domains which are inside the firewall; any
# URL with a string matching this regex in its host part will be rewritten
# by absent.
# for example, given the value of INTERNAL_SITES below, URLs like
#  http://www.yoyodyne.net/boing
# would be rewritten to something like
#   https://absent.yoyodyne.com/geturl=http%3a%2f%2fwww.yoyodyne.com%2fboing...
# while
#   http://www.zorch.com/yoyodyne.com/
# would not be rewritten (because the string "yoyodyne.com" doesn't appear in
# the host portion of the URL).  note that relative URLs will have been
# expanded before this test is applied, so there's no need to worry about
# them directly.
#
my $INTERNAL_SITES ="yoyodyne.com";
#
# TIMEOUT is the maximum length of a login session with absent before the
# user must reauthenticate.  This number is directly proportional to the
# length of the "window of opportunity" for an attacker who sits down at
# a terminal which has not been properly logged out and inversely
# proportional to user frustration level; the next request after TIMEOUT
# seconds of use will abort, forcing the user to reauthenticate.
#
my $TIMEOUT = 3000; # 50 minutes
#
# DEBUG produces voluminous spam useful mostly to the absent developers.
#
my $DEBUG = 0;
#
# PUSHWEB_DIR is the location of the pushweb installation tree.  it is ONLY
# used in constructing the paths below.
#
my $PUSHWEB_DIR="/usr/local/pushweb";
#
# You'll only need to modify these if you depart from the directory structure
# described in the INSTALL file.  If you do, change these to reflect where
# you'd like pushweb to store files.
# PUSHWEB_LIB is the location where library files, like the Otp module, live
# USER_DIR is the directory containing the opiekeys file
# COOKIE_DIR is where pushweb will store a map of the cookies served to users
# LOG_DIR is where pushweb dumps random logs
# DEBUG_FILE is the file pushweb will write debug logs to (surprise!)
#
my $PUSHWEB_LIB="$PUSHWEB_DIR/lib";
my $USER_DIR = "$PUSHWEB_DIR/etc/users";
my $COOKIE_DIR = "$PUSHWEB_DIR/etc/cookies";
my $LOG_DIR = "$PUSHWEB_DIR/logs";
my $DEBUG_FILE = "$LOG_DIR/debug_log";
#
# Fill in the installation directories for pushweb here.  if you
# installed the Otp library as described in the INSTALL file, you should
# just have to change the '/usr/local/pushweb' part to something appropriate.
use lib "/usr/local/pushweb/lib";
use lib "/usr/local/pushweb/lib/Otp";
use lib "/usr/local/pushweb/lib/Otp/blib/arch";
#
# HTML_EXT is a list of file extensions which contain things absent should
# try to rewrite.  in otherwords, it's anything that probably contains HTML
#
my $HTML_EXT = "(\.html|\.htm|\.asp|\.php3|\\\/)\$";
#
# you shouldn't need to edit anything below here.
#
use strict;
use Apache::Constants ':common';
use Apache::Log;
use Fcntl;
use Digest::HMAC_MD5 qw(hmac_md5 hmac_md5_hex);
use HTTP::Cookies;
use LWP::UserAgent ();
use NDBM_File;
use Otp;
use Response_Pages;
use URI::URL;
# Turn on for debugging purposes
# use LWP::Debug qw(+);


# Environment variables

my $NOSUCHSITE='_nosuchsite_';
my $PRODUCT = "Absent/0.3";
my %TOP_ELEMENTS =
(
 '/title'  => 1,
 '/head'   => 1,
 'body'    => 1,
);
my %LINK_ELEMENTS =
( # These represent all the possible valid tags that have links in them
 'a'       => 'href',
 'applet'  => {
	       'archive'    => 1,
	       'code'       => 1,
	       'codebase'   => 1,
	      },
 'area'    => 'href',
 'body'    => 'background',
 'embed'   => 'src',
 'form'    => 'action',
 'frame'   => 'src',
 'img'     => {
               'src'        => 1,
               'lowsrc'     => 1,
               'usemap'     => 1,
              },
 'input'   => 'src',
 'isindex' => 'action',
 'link'    => {
               'href'       => 1,
               'src'        => 1,
              },
 'meta'    => {
	       'content'    => 1,
	       'http-equiv' => 1,
	      },
 'object'  => {
               'classid'    => 1,
               'codebase'   => 1,
               'data'       => 1,
               'name'       => 1,
               'usemap'     => 1,
              },
 'script'  => 'src',
 'td'      => 'background',
 'th'      => 'background',
 'tr'      => 'background',
);


###############################################################################
###############################################################################
# handler: main routine for handling the proxy's response
###############################################################################
###############################################################################
sub handler {
  my($r) = @_;
  $r->handler("perl-script");
  $r->push_handlers(PerlHandler => \&absent_handler);
  return OK;
}

###############################################################################
###############################################################################
# absent_handler: subroutine called from handler
###############################################################################
###############################################################################
sub absent_handler {
  my($r) = @_;
  my($key, $val, $debug_info, $response);

  my $req = $r->uri;
  my $args = $r->args;
  if ($args ne "") {
    $req .= "?" . $args;
  }
  # Seems we're just going to deal with relative URIs
  $req =~ m!^/\??([^=]+)=([^/?]+)/?\??(.*)!;
  my $command = $1;
  my $username = $2;
  my $remainder = $3;

  # Un-Webify plus signs and %-encoding
  # $remainder =~ tr/+/ /;
  # $remainder =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
  # We're just dealing with: / :
  # $remainder =~ s/%(2f|3a)/pack("C", hex($1))/egi;
  
  if ($DEBUG) {
    open(LOGFILE, ">>$DEBUG_FILE");
    print LOGFILE "REQUEST: $req\n";
    close(LOGFILE);
  }

  if ($DEBUG) {
    $debug_info = "Time started: " . time . "\n";
    $debug_info .= "URI: $req\n";
    $debug_info .= "ARGS: $args\n";
    $debug_info .= "Command: $command\n";
    $debug_info .= "User: $username\n";
    $debug_info .= "Remainder: $remainder\n";
  }

 SWITCH: {


    if ($command eq "login") {
      my $challenge = &Otp::make_challenge($username);
      # Test for a valid user/challenge
      unless ($challenge) {
	if ($DEBUG) {
	  $debug_info .= "Time challenge issuance failed: " . time . "\n";
	  $debug_info .= "Challenge: $challenge\n";
	}
	$response = &generate_page($username, "failed_login");
	$r->content_type('text/html');
	&respond($r, $response);
	last SWITCH;
      }
      $challenge =~ /(\S+)\s(\S+)\s(\S+)\s(\S+)/;
      my $hash = $1;
      my $otp_number = $2;
      my $seed = $3;
      if ($DEBUG) {
	$debug_info .= "Time challenge issued: " . time . "\n";
	$debug_info .= "Hash: $hash\n";
	$debug_info .= "OTP Number: $otp_number\n";
	$debug_info .= "Seed: $seed\n";
      }
      $response = &generate_page($username, $command, $hash, 
				 $otp_number, $seed);
      $r->content_type('text/html');
      &respond($r, $response);
      last SWITCH;
    }
    


    if ($command eq "OTP_response") {
      $remainder =~ /response=([^&]*)/;
      my $OTP_response = $1;
      $OTP_response =~ tr/+/ /;
      $remainder =~ /&startpage=([^&]*)/;
      my $startpage = $1;
      $remainder =~ /&staticstartpage=([^&]*)/;
      if ($1) {
	$startpage = $1;
	# Temporary until we've figured out how to deal in general with :
	$startpage =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
      }
      # Need to de-entitize them...
      my $result = &Otp::check_response($username, $OTP_response);
      if ($DEBUG) {
	$debug_info .= "Time response verified: " . time . "\n";
	$debug_info .= "OTP Response: $OTP_response\n";
	$debug_info .= "Result: $result\n";
	$debug_info .= "Start Page: $startpage\n";
      }
      if ($result == 1) {
	&Otp::login_user($username);
	my $key = &get_key($username);
	# Cookie file setup
	my $textkey = unpack("H*", $key);
	my $cookie_jar = new HTTP::Cookies(File => 
					   "$COOKIE_DIR/$username.$textkey");
	$cookie_jar->save();
	$r->header_out('Set-Cookie', 
		       "absent-cookie; path=/; domain=$ABSENT_HOST; secure");
	if ($DEBUG) {
	  $debug_info .= "Key: $key". "\n";
	  $debug_info .= "TextKey: $textkey". "\n";
	}
	if ($key) {
	  # Must return a http-equiv refresh to the client because
	  # a refresh of the otp_response will fail (as will a back,
	  # since we're not allowing cached docs.
	  my $url_len = sprintf "%lx", length($startpage);
	  my $mac = &get_mac($startpage, $key);
	  $startpage = "$ABSENT_URL/geturl=$username/$url_len$mac/$startpage";
	  $response = &generate_page($username, "start", $startpage);
	  $r->header_out('Refresh', "0; $startpage");
	} else {
	  $response = &generate_page($username, "no_key");
	}
      } else {
	$response = &generate_page($username, "failed_challenge");
      }
      $r->content_type('text/html');
      &respond($r, $response);
      last SWITCH;
    }



    if ($command eq "logout") {
      # 4 byte timestamp after the 8 bytes of name
      # Must check MAC first
      $remainder =~ m!(\w{2})([^/]+)/(.*)!;
      my $url_len = $1;
      my $mac = $2;
      my $check_url = $3;
      my $check_len = sprintf "%lx", length($check_url);
      if ($DEBUG) {
	$debug_info .= "Mac: $mac\n";
	$debug_info .= "My URI: $check_url\n";
	$debug_info .= "Check Length: $check_len\n";
	$debug_info .= "URL Length: $url_len\n";
      }
      if ($check_len == $url_len) {
	my $key = &get_key($username);
	my $check_mac = &get_mac($check_url, $key);
	if ($DEBUG) {
	  $debug_info .= "Time user logged out: " . time . "\n";
	  $debug_info .= "Key: $key\n";
	  $debug_info .= "CheckMAC: $check_mac\n";
	}
	if ($check_mac eq $mac) {
	  &logout_user($username, $key);
	  $response = &generate_page($username, $command);
	} else {
	  $response = &generate_page($username, "failed_challenge");
	}
      } else {
	$response = &generate_page($username, "failed_challenge");
      }
      $r->content_type('text/html');
      &respond($r, $response);
      last SWITCH;
    }



    if ($command eq "geturl") {
      # Must still break the remainder and check MAC
      $remainder =~ m!(\w{2})([^/]+)/(.*)!;
      my $url_len = $1;
      my $mac = $2;
      my $my_uri = $3;
      $my_uri =~ /(^[^?\#]*)/;
      my $check_len = sprintf "%lx", length($1);
      if ($DEBUG) {
	$debug_info .= "Time URL get started: " . time . "\n";
	$debug_info .= "Mac: $mac\n";
	$debug_info .= "My URI: $1\n";
	$debug_info .= "Check Length: $check_len\n";
	$debug_info .= "URL Length: $url_len\n";
      }
      if ($check_len == $url_len) {
	my ($key, $timestamp) = &get_user_info($username);
	my $check_mac = &get_mac($1, $key);
	my $currtime = time;
	my $diff = $currtime - $timestamp;
	if ($DEBUG) {
	  $debug_info .= "Time user key gathered: " . time . "\n";
	  $debug_info .= "Timestamp: $timestamp\n";
	  $debug_info .= "Difference: $diff\n";
	  $debug_info .= "Key: $key\n";
	  $debug_info .= "CheckMAC: $check_mac\n";
	}
	if ($check_mac eq $mac) {
	  if ($diff > $TIMEOUT) {
	    &logout_user($username);
	    $response = &generate_page($username, "timed_out");
	    $r->content_type('text/html');
	    &respond($r, $response);
	  } else {
	    my ($buf, $temp);
	    # Un-Webify plus signs and %-encoding
	    # $my_uri =~ tr/+/ /;
	    # $my_uri =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	    ($r, $buf, $temp) = &fetch_url($r, $my_uri, $username, $key);
	    $debug_info .= $temp;
	    &respond($r, $buf);
	  }
	} else {
	  $response = &generate_page($username, "bad_mac");
	  $r->content_type('text/html');
	  &respond($r, $response);
	}
      } else {
	$response = &generate_page($username, "bad_length");
	$r->content_type('text/html');
	&respond($r, $response);
      }
      last SWITCH;
    }
    


    if ($command eq "jumpurl") {
      # Must still break the remainder and check MAC
      $remainder =~ m!(\w{2})([^/]+)/(.*)!;
      my $url_len = $1;
      my $mac = $2;
      my $my_uri = $3;
      $my_uri =~ /(^[^?\#]*)/;
      my $check_len = sprintf "%lx", length($1);
      if ($DEBUG) {
	$debug_info .= "Time URL jump started: " . time . "\n";
	$debug_info .= "Mac: $mac\n";
	$debug_info .= "My URI: $1\n";
	$debug_info .= "Check Length: $check_len\n";
	$debug_info .= "URL Length: $url_len\n";
      }
      if ($check_len == $url_len) {
	my ($key, $timestamp) = &get_user_info($username);
	my $check_mac = &get_mac($1, $key);
	my $currtime = time;
	my $diff = $currtime - $timestamp;
	if ($DEBUG) {
	  $debug_info .= "Time user key gathered: " . time . "\n";
	  $debug_info .= "Timestamp: $timestamp\n";
	  $debug_info .= "Difference: $diff\n";
	  $debug_info .= "Key: $key\n";
	  $debug_info .= "CheckMAC: $check_mac\n";
	}
	if ($check_mac eq $mac) {
	  if ($diff > $TIMEOUT) {
	    &logout_user($username);
	    $response = &generate_page($username, "timed_out");
	    $r->content_type('text/html');
	    &respond($r, $response);
	  } else {
	    $my_uri =~ s/.*jumpto=(.*)/$1/;
	    # Temporary until we've figured out how to deal in general with :
	    $my_uri =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	    $my_uri =~ m!://([^/]*)/!;
	    my $my_host = $1;
	    if ($DEBUG) {
	      $debug_info .= "New URI: $my_uri\n";
	      $debug_info .= "New Host: $my_host\n";
	    }
	    my ($buf, $temp);
	    if ($my_host =~ /$INTERNAL_SITES/ || !($my_host =~ /\./)) {
	      ($r, $buf, $temp) = &fetch_url($r, $my_uri, $username, $key);
	      $debug_info .= $temp;
	    } else {
	      $buf = &generate_page($username, "start", $my_uri);
	      $r->content_type('text/html');
	    }
	    &respond($r, $buf);
	  }
	} else {
	  $response = &generate_page($username, "bad_mac");
	  $r->content_type('text/html');
	  &respond($r, $response);
	}
      } else {
	$response = &generate_page($username, "bad_length");
	$r->content_type('text/html');
	&respond($r, $response);
      }
      last SWITCH;
    }
    
    # No valid command was given
    $response = &generate_page($username, "unknown", $command);
    $r->content_type('text/html');
    &respond($r, $response);
  }

  if ($DEBUG) {
    my (%headers_out) = $r->headers_out;
    while(($key,$val) = each %headers_out) {
      $debug_info .= "OUT $key: $val\n";
    }
    open(LOGFILE, ">>$DEBUG_FILE");
    print LOGFILE "**************\n$debug_info\n";
    close(LOGFILE);
    $debug_info = '';
  }

  return OK;
}

###############################################################################
###############################################################################
# respond: send the response back to the client
###############################################################################
###############################################################################
sub respond {
  my $r = shift;
  my $response = shift;

  $r->no_cache(1);
  # Apache's no-caching (as of 1.3.0) is broken. It just modifies stamp
  $r->header_out('Pragma', 'no-cache');
  $r->header_out('Cache-control', 'no-cache');
  $r->header_out('Content-Length', length($response));
  $r->send_http_header();
  $r->print($response);
}

###############################################################################
###############################################################################
# fetch_url: an attempt to put the URL fetching into its own function
###############################################################################
###############################################################################
sub fetch_url {
  my ($r, $my_uri, $username, $key) = @_;
  my $buf = '';
  my $debug_info = '';
  my $client_agent = '';
  my $toppos = -1;
  my $cookies = 0;
  my $unavailable = 0;
  my ($tmp, $firsthalf, $lasthalf, $k, $v, $base);
  
  $my_uri =~ m!://([^/]*)/!;
  my $remote_host = $1;

  my $request = new HTTP::Request $r->method, $my_uri;
  my $textkey = unpack("H*", $key);
  my $cookie_jar = new HTTP::Cookies(File => "$COOKIE_DIR/$username.$textkey",
				     Ignore_Discard => 1,);
  
  if ($DEBUG) {
    $debug_info .= "Time proxy request method created: " . time . "\n";
    $debug_info .= "Cookie file: $COOKIE_DIR/$username.$textkey\n";
  }

  my(%headers_in) = $r->headers_in;
  while(($k,$v) = each %headers_in) {
    # HACK to force no Keep-Alives on the connection between proxy
    # and remote server
    if ($DEBUG) {
      $debug_info .= "IN $k: $v\n";
    }
    if ($k =~ /Connection/) {
      $v = "Close";
    } elsif ($k =~ /Host/) {
      $v = "$remote_host";
    } elsif ($k =~ /Referer/) {
      $v =~ s/.*(http:\/\/.*)/$1/;
    } elsif ($k =~ /Cookie/) {
      $cookies = 1;
      $cookie_jar->load();
      $cookie_jar->add_cookie_header($request);
      if ($DEBUG) {
	$tmp = $cookie_jar->as_string();
	$debug_info .= "To server cookies:\n$tmp";
      }
    }
    if ($k =~ /User-Agent/) {
      $client_agent = $v;
    }
    unless ($k =~ /Cookie/) {
      $request->header($k,$v);	      
    }
  }

  if ($DEBUG) {
    $tmp = $request->headers_as_string;
    $debug_info .= "TR $tmp\n";
  }


  if ($r->method eq "POST") {
    my $content;
    if ($r->header_in('Content-type') eq 'application/x-www-form-urlencoded') {
      $content = $r->content;
    } else {
      $r->read($content, $r->header_in('Content-length'));
    }
    $request->content($content);
    if ($DEBUG) {
      $debug_info .= "Request type: " . $r->method . "\n";
      $debug_info .= "Request content type: " .
	$r->header_in('Content-type') . "\n";
      $debug_info .= "Request content: $content\n";
    }
  }
  
  my $ua = new LWP::UserAgent;
  if ($client_agent ne '') {
    $ua->agent("$client_agent; $PRODUCT");
  } else {
    $ua->agent("$PRODUCT");
  }
  my $res = $ua->simple_request($request);
  $r->content_type($res->header('Content-type'));
  if ($DEBUG) {
    $debug_info .= "Time proxy got page: " . time . "\n";
    $tmp = length($res->content);
    $debug_info .= "Original size of page: $tmp\n";
  }
  #feed reponse back into our request_rec*
  $r->status($res->code);
  $r->status_line(join " ", $res->code, $res->message);

  if ($r->status == 500) {
    $unavailable = 1;
    $r->status('200');
    $r->content_type('text/html');
  }

  if ($cookies) {
    $cookie_jar->extract_cookies($res);
    $cookie_jar->save();
    if ($DEBUG) {
      $tmp = $cookie_jar->as_string();
      $debug_info .= "From server cookies:\n$tmp";
    }
  }
  $res->scan(sub {
	       my ($header, $value) = @_;
	       unless ($header =~ /Cookie/) {
		 $r->header_out($header, $value);
	       }
	     });
  
  if ($DEBUG) {
    my(%headers_out) = $r->headers_out;
    while(($k,$v) = each %headers_out) {
      $debug_info .= "OUT $k: $v\n";
    }
    $debug_info .= "Status: " . $r->status . "\n";
    $debug_info .= "Status Line: " . $r->status_line . "\n";
  }

  if ($r->status =~ /(301|302)/) {
    my $location = $res->header('Location');
    $location =~ m!://([^/]*)/!;
    if ($1 =~ /$INTERNAL_SITES/) {
      $location =~ /^([^?]*)/;
      my $location_len = sprintf "%lx", length($1);
      my $key = &get_key($username);
      my $mac = &get_mac($1, $key);
      $location = "$ABSENT_URL/geturl=$username/$location_len$mac/$location";
      $r->header_out('Location', $location);
      if ($DEBUG) {
	$debug_info .= "Internal: $INTERNAL_SITES\n";
      }
    }
    if ($DEBUG) {
      $debug_info .= "Location: $location\n";
    }
  } elsif ($r->content_type =~ m!^text/html! 
	   || &is_html($my_uri, "$res->content")) {
    # Below inserted because apache doesn't allow no entry
    $r->content_type('text/html');
    $base = $my_uri;
    if ($unavailable) {
      $buf = &generate_page($username, "unavailable", $my_uri);
    } else {
      $buf = $res->content;
    }

    # Deal with in-document base tags beforehand
    if ($buf =~ /<base\s+href="?([^>]*)"?[^>]*?>/si) {
      $base = $1;
    }
    
    if ($DEBUG) {
      $debug_info .= "Base URL: $base\n";
      $debug_info .= "Time URL rewriting started: " . time . "\n";
    }

    ($r, $buf, $toppos) = &parse($r, $username, $buf, $base, $toppos);

    if ($DEBUG) {
      $debug_info .= "Time URL rewriting completed: " . time . "\n";
    }
    
    # Add in absent header message
    my $message = $Response_Pages::AbsentMessage;
    my $personal_page = &get_personal_page($username);
    $message =~ s/NOSUCHSITE/$NOSUCHSITE/g;
    $message =~ s/USERID/$username/g;
    if (defined($personal_page)) {
      $message =~ s/PERSONAL_PAGE/$personal_page/g;
      $message =~ s/<\/?PP>//g;
    } else {
      $message =~ s/<PP>.*<\/PP>//g;
    }
    ($r, $message, $tmp) = &parse($r, $username, $message, '', 0);
    # Specifically alter geturl to a logout message
    $message =~ s/geturl=([^>]*$NOSUCHSITE\/logout=$username)/logout=$1/;
    # Specifically alter geturl to a jumpurl message	      
    $message =~ s/geturl=([^>]*$NOSUCHSITE\/jumpurl=$username)/jumpurl=$1/;
    $firsthalf = substr($buf, 0, $toppos);
    $lasthalf = substr($buf, $toppos + 1);
    $buf = $firsthalf . $message . $lasthalf;
    
    if ($DEBUG) {
      $debug_info .= "Top Position: $toppos\n";
      $debug_info .= "Time absentizing completed: " . time . "\n";
      $tmp = length($buf);
      $debug_info .= "Final size of page: $tmp\n";
      #	$debug_info .= "$buf\n\n\n";
    }
  } else {
    $buf = $res->content;
  }

  return($r, $buf, $debug_info);
}


###############################################################################
###############################################################################
# parse: make URLs absolute and absentized in document
###############################################################################
###############################################################################
sub parse {
  my($r, $username, $buf, $base, $toppos) = @_;
  my ($lessthanpos, $greaterthanpos, $prediff, $diff, 
      $preblock, $tagblock, $lastblock);
  my $pos = 0;
  my $movepos = 0;
  my $newbuf = '';
  my $buflen = length($buf);

  while (($lessthanpos = index($buf, "<", $pos)) > -1) {
    $greaterthanpos = index($buf, ">", $lessthanpos);
    $prediff = $lessthanpos - $pos;
    $diff = $greaterthanpos - $lessthanpos - 1;
    $preblock = substr($buf, $pos, $prediff + 1);
    $tagblock = substr($buf, $lessthanpos + 1, $diff);
    ($r, $tagblock, $movepos) = &dealwithtag($r, $username, $base, $tagblock);
    $newbuf .= "$preblock$tagblock";
    if ($movepos) {
      $toppos = length($newbuf) + 1;
    }
    $pos = $greaterthanpos;
  }
  $lastblock = substr($buf, $pos, $buflen);
  $newbuf .= "$lastblock";

  return($r, $newbuf, $toppos);
}

###############################################################################
###############################################################################
# dealwithtag: decides if there a URL in a tag and absentizes it if there is
###############################################################################
###############################################################################
sub dealwithtag {
  my ($r, $username, $base, $tagblock) = @_;
  my @blocks;
  my ($tag, $lctag, $key, $lckey, $value, $lcvalue, $delay, $tmp, $i);
  my $movepos = 0;
  my $done = 0;
  my $refresh = 0;

  # Remove spaces around equal signs, eg 'src = bar' becomes 'src=bar'
  $tagblock =~ s/\s*=\s*/=/g;
  # Remove leading spaces in block, eg < img ...> becomes <img ...>
  $tagblock =~ s/^\s+//;
  @blocks = split(/\s+/, $tagblock);
  $tag = shift(@blocks);
  $lctag = lc($tag);
  if (exists($LINK_ELEMENTS{$lctag})) {
    $tagblock = $tag;
    for ($i = 0; $i < @blocks; $i++) {
      if ($blocks[$i] =~ /=/) {
        ($key, $value) = split(/=/, $blocks[$i], 2);
        $lckey = lc($key);
        if ($lctag =~ /(applet|img|link|meta|object)/) {
          if (exists($LINK_ELEMENTS{$lctag}{$lckey})) {
            $value =~ s/\"//g;
	    if ($lctag eq 'meta') {
	      $lcvalue = lc($value);
	      if ($lckey eq 'http-equiv') {
		if ($lcvalue eq 'refresh') {
		  $refresh = 1;
		} 
		$tagblock .= " $key=\"$value\"";
		next;
	      } else {
		# Must be a content key
		while (!$done && $i < @blocks) {
		  $value .= " $blocks[++$i]";
		  if (1 == ($value =~ s/\"//g)) {
		    $done = 1;
		  }
		}
		$done = 0;
		if ($refresh) {
		  $tmp = $value;
		  $value =~ /(\d)+\;\s*url=([^;\s]+)/i;
		  $delay = $1;
		  $value = $2;
		} else {
		  $tagblock .= " $key=\"$value\"";
		  next;
		}
	      }
	    }
	    # deal with potential codebase issues
	    if ($lctag eq 'applet' || $lctag eq 'object') {
	      # Must deal with later
	    }
            $value = &absentize($username, $base, $value);
	    if ($lctag eq 'meta' && $refresh) {
	      $refresh = 0;
	      $r->header_out('Refresh', "$delay; $value");
	      $tmp =~ s/(url=)[^;\s]+/$1$value/i;
	      $value = $tmp;
	    }
	    $tagblock .= " $key=\"$value\"";
          } else {
	    $tagblock .= " $blocks[$i]";
	  }
        } elsif ($lckey eq $LINK_ELEMENTS{$lctag}) {
	  $value =~ s/\"//g;
	  $value = &absentize($username, $base, $value);
	  $tagblock .= " $key=\"$value\"";
	} else {
	  $tagblock .= " $blocks[$i]";
	}
      } else {
        $tagblock .= " $blocks[$i]";
      }
    }
  }
  if (exists($TOP_ELEMENTS{$lctag})) {
    $movepos = 1;
  }

  return ($r, $tagblock, $movepos);
}

###############################################################################
###############################################################################
# absentize: actually make the URL absent-compliant
###############################################################################
###############################################################################
sub absentize {
  my ($username, $base, $uri) = @_;
  my ($url_len, $key, $mac, $session_url);
  my $url = new URI::URL $uri, $base;
  local $URI::URL::ABS_REMOTE_LEADING_DOTS = 1;

  $url = $url->abs;
  # Absentize only http requests
  if ($url->scheme eq 'http') {
    if ($url->host =~ /$INTERNAL_SITES/ || !($url->host =~ /\./)) {
      # Below commented out because if we encode colons, the handler
      # will errantly not be called. Must eventually investigate
      # further.
      #
      # Reserved chars defined in RFC1630: = ; / $ ? : whitespace
      # See http://www.w3.org/Addressing/URL/5_URI_BNF.html
      # We're just dealing with: / :
      # if ($url =~ /foobar/) {
      #   $url =~ s/[:\/]/sprintf("%s","%").unpack("H8",$&)/eg;
      # }
      $url =~ /^([^?\#]*)/;
      $url_len = sprintf "%lx", length($1);
      $key = &get_key($username);
      $mac = &get_mac($1, $key);
      $session_url = "$ABSENT_URL/geturl=$username/$url_len$mac/";
      $uri = $session_url . $url;
    }
  }

  return $uri;
}

###############################################################################
###############################################################################
# get_mac: generate a mac based upon the user's key and the URL
###############################################################################
###############################################################################
sub get_mac {
  my ($text, $key) = @_;

  my $mac = hmac_md5_hex($text, $key);
  # Want only first 40 bits, ie 5 bytes
  $mac = substr($mac, 0, 5);
  $mac = unpack("H*", $mac);

  return $mac;
}

###############################################################################
###############################################################################
# get_key: get the user's key from the user table on disk
###############################################################################
###############################################################################
sub get_key {
  my ($user) = @_;
  my $key = '';

  my $userfile = "$USER_DIR/$user";
  open(TABLE, "$userfile") or return 0;
  # Need exact position in user table for key, just happens to currently
  # be at the front
  seek(TABLE, 0, 0);
  read(TABLE, $key, 8, 0);
  close(TABLE);

  return $key;
}

###############################################################################
###############################################################################
# get_user_info: get the user key and creation timestamp from the user
#   table on disk. Partial duplicate of get_key. Done this way to open
#   the user file only once per operation.
###############################################################################
###############################################################################
sub get_user_info {
  my ($user) = @_;
  my $key = '';
  my $timestamp = '';

  my $userfile = "$USER_DIR/$user";
  open(TABLE, "$userfile") or return 0;
  # Need exact position in user table for key, just happens to currently
  # be at the front
  # Need exact position in user table for timestamp
  # 4 byte timestamp after the 8 bytes of name
  seek(TABLE, 0, 0);
  read(TABLE, $key, 8, 0);
  seek(TABLE, 8, 0);
  read(TABLE, $timestamp, 4, 0);
  close(TABLE);
  $timestamp = unpack("i*", $timestamp);

  return ($key, $timestamp);
}

###############################################################################
###############################################################################
# logout_user: clear the user table
###############################################################################
###############################################################################
sub logout_user {
  my ($user, $key) = @_;

  my $userfile = "$USER_DIR/$user";
  unlink($userfile);
  my $textkey = unpack("H*", $key);
  my $cookie_jar = new HTTP::Cookies(File => "$COOKIE_DIR/$user.$textkey");
  $cookie_jar->clear();
  $cookie_jar->save();
}

###############################################################################
###############################################################################
# get_personal_page: get the personal page from the user DBM file
###############################################################################
###############################################################################
sub get_personal_page {
  my $username = shift;
  my $personalpagefile = $USER_DIR . "/personal_pages";
  my %personalpagehash = ();
  my $personalpage;
  undef($personalpage);

  tie(%personalpagehash, "NDBM_File", $personalpagefile, O_RDWR, 0664);
  unless ($personalpagehash{$username} eq '') {
    $personalpage = $personalpagehash{$username};
  }
  untie(%personalpagehash);

  return($personalpage);
}

###############################################################################
###############################################################################
# is_html: return 1 if the page is html when content-type is unavailable,
#   else return 0;
###############################################################################
###############################################################################
sub is_html {
  my ($uri, $buf) = @_;

  if ($uri =~ $HTML_EXT) {
    return 1;
  }

  # We could in the future examine the content also to determine if it is
  # HTML, but we don't now.

  return 0;
}

###############################################################################
###############################################################################
# generate_page: generate and return the proper response page
###############################################################################
###############################################################################
sub generate_page {
  my $username = shift;
  my $page = shift;
  my (@remainder) = @_;
  my $response = '';

 SWITCH: {
    if ($page eq 'bad_length') {
      $response = $Response_Pages::BadLengthPage;
      last SWITCH;
    }
    if ($page eq 'bad_mac') {
      $response = $Response_Pages::BadMACPage;
      last SWITCH;
    }
    if ($page eq 'failed_login') {
      $response = $Response_Pages::FailedLoginPage;
      last SWITCH;
    }
    if ($page eq 'failed_challenge') {
      $response = $Response_Pages::FailedChallengePage;
      last SWITCH;
    }
    if ($page eq 'login') {
      my ($hash, $otp_number, $seed) = @remainder;
      my $personal_page = &get_personal_page($username);
      $response = $Response_Pages::ChallengePage;
      $response =~ s/HASH/$hash/g;
      $response =~ s/OTP_NUMBER_STUB/$otp_number/g;
      $response =~ s/CHALLENGE_STUB/$seed/g;
      if (defined($personal_page)) {
	$response =~ s/PERSONAL_PAGE/$personal_page/g;
	$response =~ s/<\/?PP>//g;
      } else {
	$response =~ s/<PP>.*<\/PP>//gs;
      }
      last SWITCH;
    }
    if ($page eq 'logout') {
      $response = $Response_Pages::LogoutPage;
      last SWITCH;
    }
    if ($page eq 'no_key') {
      $response = $Response_Pages::NoKeyPage;
      last SWITCH;
    }
    if ($page eq 'start') {
      my ($startpage) = @remainder;
      $response = $Response_Pages::StartPage;
      $response =~ s/STARTPAGE/$startpage/g;
      last SWITCH;
    }
    if ($page eq 'timed_out') {
      $response = $Response_Pages::TimedOutPage;
      last SWITCH;
    }
    if ($page eq 'unavailable') {
      my ($unavailablepage) = @remainder;
      $response = $Response_Pages::UnavailablePage;
      $response =~ s/UNAVAILABLEPAGE/$unavailablepage/g;
      last SWITCH;
    }
    if ($page eq 'unknown') {
      my ($command) = @remainder;
      $response =  $Response_Pages::InvalidCommandPage;
      $response =~ s/COMMAND/$command/g;
      last SWITCH;
    }

    $response = "Error type not found\n";
  }  

  $response =~ s/USERID/$username/g;
  return($response);
}

1;

__END__


# $Id: AbsentProxyRewrite.pm,v 1.22 1999/12/16 23:10:22 cgilmore Exp $
# $Log: AbsentProxyRewrite.pm,v $
# Revision 1.22  1999/12/16 23:10:22  cgilmore
# corrected 301 section host matching
#
# Revision 1.21  1999/12/15 16:29:37  cgilmore
# upped version number
#
# Revision 1.20  1999/12/15 16:19:51  cgilmore
# corrected jumpurl matching problem
#
# Revision 1.19  1999/12/13 20:08:19  cgilmore
# Removed reliance upon hacks to mod_perl. Module now properly deals
# on its own for multipart form data.
#
# Revision 1.18  1999/10/26 19:17:23  cgilmore
# corrected volatile cookie problem. HTTP::Cookie slightly changed its
# syntax. also made minor cosmetic code changes.
#
# Revision 1.17  1999/10/21 17:29:57  cgilmore
# added content-type string before all error responses
#
# Revision 1.16  1999/10/20 22:59:44  cgilmore
# cleaned up a bunch of things including INTERNAL_SITE(S), ABSENTHOST,
# and respond function headers. Also added is_html test for content
# returned without Content-Type. Put in a bug report to apache about
# their not allowing no content-type to be returned.
#
# Revision 1.15  1999/10/20 18:10:37  cgilmore
# forgot a comma in the applet tag of the LINK_ELEMENTS
#
# Revision 1.14  1999/10/20 18:06:33  cgilmore
# added new fields to applet tag. still need to deal with applet/object
# codebase issues.
#
# Revision 1.13  1999/06/21 14:53:51  cgilmore
# initialize toppos to -1 to properly handle html without standard top elements
#
# Revision 1.12  1999/06/16 20:03:37  cgilmore
# enabled strict, minor cleanup of global declarations,
# repointed debug log
#
# Revision 1.11  1999/02/11 21:06:28  cgilmore
# Fixed meta tag related bugs. Added ability to handle an invalid
# URL or dead site with aplomb. Added personal start/home page
# ability.
#
# Revision 1.10  1999/01/19 20:32:52  cgilmore
# added cookie support
#
# Revision 1.9  1999/01/18 21:35:26  cgilmore
# Added input "src" and meta "content"/"http-equiv" tags
# Corrected redirection problem
#
# Revision 1.8  1998/12/17 23:41:48  cgilmore
# fixed, among other things, handling of invalid users and non-fully
# qualified hostnames
#
# Revision 1.7  1998/09/22 21:54:24  cgilmore
# added no-cache lines as no_cache(1) doesn't do the best thing
#
# Revision 1.6  1998/09/02 21:40:50  cgilmore
# removed references to prepend as it was STUPID! Sigh.
#
# Revision 1.5  1998/08/26 15:24:01  cgilmore
# added major functionality, including jumpurl. cleaned up a number of
# bugs. altered Apache.pm to handle multipart forms (will be outmoded
# when Apache::Request is released).
#
# Revision 1.4  1998/08/03 14:03:08  cgilmore
# works properly, although there are still clunky parts such as the
# fetching of the start page (and all random URLs).
#
# Revision 1.3  1998/07/15 17:33:19  cgilmore
# successfully integrated the request handling portion of the code.
# still remaining is cleanup of geturl and logout handling.
#
# Revision 1.2  1998/06/25 18:38:24  cgilmore
# response portion works!!!
#
# Revision 1.1  1998/06/23 19:22:31  cgilmore
# Initial revision

