File Coverage

blib/lib/Apache/AppSamurai.pm

Criterion	Covered	Total	%
statement	15	38	39.4
branch	1	2	50.0
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	21	45	46.6

# Apache::AppSamurai - Protect your master, even if he is without honour.

# $Id: AppSamurai.pm,v 1.66 2008/05/03 06:43:25 pauldoom Exp $

##
# Copyright (c) 2008 Paul M. Hirsch ([e-mail]).
# All rights reserved.
#
# This program is free software; you can redistribute it and/or modify it under
# the same terms as Perl itself.
##

# AppSamurai is a set of scripts and a module that tie into Apache via
# mod_perl to provide an authenticating reverse proxy front end for
# web applications.  It allows the use of outside authentication not
# supported by the backend app, and also adds session tracking.

package Apache::AppSamurai;
use strict;
use warnings;

# Keep VERSION (set manually) and REVISION (set by CVS)
use vars qw($VERSION $REVISION $MP);
$VERSION = '1.01';
$REVISION = substr(q$Revision: 1.66 $, 10, -1);

use Carp;

# mod_perl Includes
BEGIN {
    if (eval{require mod_perl2;}) {
	mod_perl2->import(qw(1.9922 StackedHandlers MethodHandlers Authen
			     Authz));
        require Apache2::Connection;
	require Apache2::RequestRec;
	require Apache2::RequestUtil;
	require Apache2::Log;
	require Apache2::Access;
	require Apache2::Response;
	require Apache2::Util;
	require Apache2::URI;
	require APR::Table;
	require APR::Pool;
	require Apache2::Const;
	Apache2::Const->import(qw(OK DECLINED REDIRECT HTTP_FORBIDDEN
				  HTTP_INTERNAL_SERVER_ERROR
				  HTTP_MOVED_TEMPORARILY HTTP_UNAUTHORIZED
				  M_GET));
	require Apache2::Request;
	$MP = 2;
    } else {
	require mod_perl;
	mod_perl->import(qw(1.07 StackedHandlers MethodHandlers Authen Authz));
	require Apache;
	require Apache::Log;
	require Apache::Util;
	require Apache::Constants;
	Apache::Constants->import(qw(OK DECLINED REDIRECT HTTP_FORBIDDEN
				     HTTP_INTERNAL_SERVER_ERROR
				     HTTP_MOVED_TEMPORARILY HTTP_UNAUTHORIZED
				     M_GET));
	require Apache::Request;
	$MP = 1;
    }
}

# Non-mod_perl includes
use CGI::Cookie;
use URI;
use Time::HiRes qw(usleep);

use Apache::AppSamurai::Util qw(CreateSessionAuthKey CheckSidFormat
				HashPass HashAny ComputeSessionId
				CheckUrlFormat CheckHostName
				CheckHostIP XHalf);

# Apache::AppSamurai::Session is a replacement for Apache::Session::Flex
# It provides normal Apache::Session::Flex features, plus optional extras
# like alternate session key generators/sizes and record level encryption
use Apache::AppSamurai::Session;

# Apache::AppSamurai::Tracker is a special instance of Session meant to
# be shared between all processes serving an auth_name
use Apache::AppSamurai::Tracker;

### START Apache::AuthSession based methods

# The following lower case methods are directly based on Apache::AuthCookie, or
# are required AuthCookie methods (like authen_cred() and authen_ses_key())

# Note - ($$) syntax, used in mod_perl 1 to induce calling the handler as
# an object, has been eliminated in mod_perl 2.  Each handler method called
# directly from Apache must be wrapped to support mod_perl 1 and mod_perl 2
# calls.  (Just explaining the mess before you have to read it.)

# Identify the username for the session and set for the request
sub recognize_user_mp1 ($$) { &recognize_user_real }
sub recognize_user_mp2 : method { &recognize_user_real }
*recognize_user = ($MP eq 1) ? \&recognize_user_mp1 : \&recognize_user_mp2;

sub recognize_user_real {
    my ($self, $r) = @_;
    my ($auth_type, $auth_name) = ($r->auth_type, $r->auth_name);

    return DECLINED unless $auth_type and $auth_name;

    my $cookie_name = $self->cookie_name($r);

    my ($cookie) = $r->headers_in->{'Cookie'} =~ /$cookie_name=([^;]+)/;
    if (!$cookie && $r->dir_config("${auth_name}Keysource")) {
	# Try to get key text using alternate method then compute the key.
	# FetchKeysource returns '' if no custom source is configured, in
	# which case the cookie should have been previously set, so non-zero
	# output is required.
	$cookie = $self->FetchKeysource($r);
	if ($cookie) {
	    $cookie = CreateSessionAuthKey($cookie);
	}
    }

    return DECLINED unless $cookie;

    $self->Log($r, ('debug', "recognize_user(): cookie $cookie_name is " . XHalf($cookie)));

    my ($user,@args) = $auth_type->authen_ses_key($r, $cookie);
    if ($user and scalar @args == 0) {
	$self->Log($r, ('debug', "recognize_user(): user is $user"));
	($MP eq 1) ? ($r->connection->user($user)) : ($r->user($user));
    } elsif (scalar @args > 0 and $auth_type->can('custom_errors')) {
	return $auth_type->custom_errors($r, $user, @args);
    } else {
	# Shrug
	$self->Log($r, ('warn', "recognize_user(): Unexpected result"));
	return DECLINED;
    }

    return OK;
}

# Get the cookie name for this protected area
sub cookie_name {
    my ($self, $r) = @_;

    my $auth_type = $r->auth_type;
    my $auth_name = $r->auth_name;
    my $cookie_name = $r->dir_config("${auth_name}CookieName") ||
	"${auth_type}_${auth_name}";
    return $cookie_name;
}

# Set request cache options (no-cache unless specifically told to cache)
sub handle_cache {
    my ($self, $r) = @_;

    my $auth_name = $r->auth_name;
    return unless $auth_name;

    unless ($r->dir_config("${auth_name}Cache")) {
	$r->no_cache(1);
	if (!$r->headers_out->{'Pragma'}) {
	    $r->err_headers_out->{'Pragma'} = 'no-cache';
	}
    }
}

# Backdate cookie to attempt to clear from web browser cookie store
sub remove_cookie {
    my ($self, $r) = @_;

    my $cookie_name = $self->cookie_name($r);
    my $str = $self->cookie_string( request => $r,
				    key     => $cookie_name,
				    value   => '',
				    expires => 'Mon, 21-May-1971 00:00:00 GMT' );

    $r->err_headers_out->add("Set-Cookie" => "$str");

    $self->Log($r, ('debug', "remove_cookie(): removed_cookie \"$cookie_name\""));
}

# Convert current POST request to GET
# Note - The use of this is questionable now that Apache::Request is being
# used.  May go away in the future.
sub _convert_to_get {
    my ($self, $r) = @_;
    return unless $r->method eq 'POST';

    $self->Log($r, ('debug', "Converting POST -> GET"));

    # Use Apache::Request for immediate access to all arguments.
    my $ar = ($MP eq 1) ?
	Apache::Request->instance($r) :
	Apache2::Request->new($r);

    # Pull list if GET and POST args
    my @params = $ar->param;
    my ($name, @values, $value);
    my @pairs = ();

    foreach $name (@params) {
	# we don't want to copy login data, only extra data.
	$name =~ /^(destination|credential_\d+)$/ and next;

	# Pull list of values for this key
	@values = $ar->param($name);

	# Make sure there is at least one value, which can be empty
	(scalar(@values)) or ($values[0] = '');

	foreach $value (@values) {
	    if ($MP eq 1) {
		push(@pairs, Apache::Util::escape_uri($name) . '=' .
		     Apache::Util::escape_uri($value));
	    } else {
		# Assume mod_perl 2 behaviour
		push(@pairs, Apache2::Util::escape_path($name, $r->pool) .
		     '=' . Apache2::Util::escape_path($value, $r->pool));
	    }
	}
    }

    $r->args(join '&', @pairs) if scalar(@pairs) > 0;

    $r->method('GET');
    $r->method_number(M_GET);
    $r->headers_in->unset('Content-Length');
}


# Handle regular (form based) login
sub login_mp1 ($$) { &login_real }
sub login_mp2 : method { &login_real }
*login = ($MP eq 1) ? \&login_mp1 : \&login_mp2;
sub login_real {
    my ($self, $r) = @_;
    my ($auth_type, $auth_name) = ($r->auth_type, $r->auth_name);

    # Use the magic of Apache::Request to ditch POST handling code
    # and cut to the args.
    my $ar = ($MP eq 1) ?
	Apache::Request->instance($r) :
	Apache2::Request->new($r);

    my ($ses_key, $tc, $destination, $nonce, $sig, $serverkey);
    my @credentials = ();

    # Get the hard set destination, or setup to just reload
    if ($r->dir_config("${auth_name}LoginDestination")) {
	$destination = $r->dir_config("${auth_name}LoginDestination");
    } elsif ($ar->param("destination")) {
	$destination = $ar->param("destination");
    } else {
	# Someday something slick could hold the URL, then cut through
	# to it.  Someday.  Today we die.
        $self->Log($r, ('warn', "No key 'destination' found in form data"));
        $r->subprocess_env('AuthCookieReason', 'no_cookie');
        return $auth_type->login_form($r);
    }

    # Check form nonce and signature
    if (defined($ar->param("nonce")) and defined($ar->param("sig"))) {
	unless (($nonce = CheckSidFormat($ar->param("nonce"))) and
		($sig = CheckSidFormat($ar->param("sig")))) {

	    $self->Log($r, ('warn', "Missing/invalid form nonce or sig"));
	    $r->subprocess_env('AuthCookieReason', 'no_cookie');
	    $r->err_headers_out->{'Location'} = $self->URLErrorCode($destination, 'bad_credentials');
	    $r->status(REDIRECT);
	    return REDIRECT;
	}
	$serverkey = $self->GetServerKey($r) or die("FATAL: Could not fetch valid server key\n");

	# Now check!
	unless ($sig eq ComputeSessionId($nonce, $serverkey)) {
	    # Failed!
	    $self->Log($r, ('warn', "Bad signature on posted form (Possible scripted attack)"));
	    $r->subprocess_env('AuthCookieReason', 'no_cookie');
	    $r->err_headers_out->{'Location'} = $self->URLErrorCode($destination, 'bad_credentials');
	    $r->status(REDIRECT);
	    return REDIRECT;
	}
    } else {
	# Failed!
	$self->Log($r, ('warn', "Missing NONCE and/or SIG in posted form (Possible scripted attack)"));
	$r->subprocess_env('AuthCookieReason', 'no_cookie');
	$r->err_headers_out->{'Location'} = $self->URLErrorCode($destination, 'bad_credentials');
	$r->status(REDIRECT);
	return REDIRECT;
    }

    # Get the credentials from the data posted by the client
    while ($tc = $ar->param("credential_" . scalar(@credentials))) {
	push(@credentials, $tc);

	($tc) ? ($tc =~ s/^(.).*$/$1/s) : ($tc = ''); # Only pull first char
 	                                              # for logging
	$self->Log($r, ('debug', "login(); Received credential_" . (scalar(@credentials) - 1) . ": $tc (hint)"));
    }

    # Convert all args into a GET and clear the credential_X args
    $self->_convert_to_get($r) if $r->method eq 'POST';

    # Check against credential cache if UniqueCredentials is set
    if ($r->dir_config("${auth_name}AuthUnique")) {
	unless ($self->CheckTracker($r, 'AuthUnique', @credentials)) {
	    # Tried to send the same credentials twice (or tracker system
	    # failure. Delete the credentials to fall through
	    @credentials = ();
	    $self->Log($r, ('warn', "login(): AuthUnique check failed: Tracker failure, or same credentials have been sent before"));
	}
    }

    if (@credentials) {
	# Exchange the credentials for a session key.
	$ses_key = $self->authen_cred($r, @credentials);
	if ($ses_key) {
	    # Set session cookie with expiration included if SessionExpire
	    # is set. (Extended +8 hours so we see logout events and cleanup)
	    if ($r->dir_config("${auth_name}SessionExpire")) {
		$self->send_cookie($r, $ses_key, {expires => $r->dir_config("${auth_name}SessionExpire") + 28800});
	    } else {
		$self->send_cookie($r, $ses_key);
	    }
	    $self->handle_cache($r);

	    # Log 1/2 of session key to debug
	    $self->Log($r, ('debug', "login(): session key (browser cookie value): " . XHalf($ses_key)));

	    # Godspeed You Black Emperor!
	    $r->headers_out->{"Location"} = $destination;
	    return HTTP_MOVED_TEMPORARILY;
	}
    }

    # Add their IP to the failure tracker
    # Ignores return (refusing a login page to an attacker doesn't stop them
    # from blindly reposting... can add a fail here if an embedded form
    # verification key is added to the mix in the future)
    if ($r->dir_config("${auth_name}IPFailures")) {
        if ($MP eq 1) {
	    $self->CheckTracker($r, 'IPFailures', $r->dir_config("${auth_name}IPFailures"), $r->get_remote_host);
        } else {
            $self->CheckTracker($r, 'IPFailures', $r->dir_config("${auth_name}IPFailures"), $r->connection->get_remote_host);
        }
    }

    # Append special error message code and try to redirect to the entry
    # point. (Avoids having the LOGIN URL show up in the browser window)
    $r->err_headers_out->{'Location'} = $self->URLErrorCode($destination, 'bad_credentials');
    $r->status(REDIRECT);
    return REDIRECT;
    # Handle this ol' style - XXX remove?
    #$r->subprocess_env('AuthCookieReason', 'bad_credentials');
    #$r->uri($destination);
    #return $auth_type->login_form($r);
}

# Special version of login that handles Basic Auth login instead of form
# Can be called by authenticate() if there is no valid session but a
# Authorization: Basic header is detected.  Can also be called directly,
# just like login() for targeted triggering
sub loginBasic_mp1 ($$) { &loginBasic_real }
sub loginBasic_mp2 : method { &loginBasic_real }
*loginBasic = ($MP eq 1) ? \&loginBasic_mp1 : \&loginBasic_mp2;
sub loginBasic_real {
    my ($self, $r) = @_;
    my ($auth_type, $auth_name) = ($r->auth_type, $r->auth_name);

    my ($ses_key, $t, @at, $tc);
    my @credentials = ();

    return DECLINED unless $r->is_initial_req; # Authenticate first req only

    # Count input credentials to figure how to split input
    my @authmethods = $self->GetAuthMethods($r);
    (@authmethods) || (die("loginBasic(): Missing authentication methods\n"));
    my $amc = scalar(@authmethods);

    # Extract basic auth info and fill out @credentials array
    my ($stat, $pass) = $r->get_basic_auth_pw;

    if ($r->user && $pass) {
	# Strip "domain\" portion of user if present.
	# (Thanks Windows Mobile ActiveSync for forcing domain\username syntax)
	$t = $r->user;
	$t =~ s/^.*\\+//;
	$r->user($t);
	push(@credentials, $t);

	# Use custom map pattern if set; else just a generic split on semicolon
	if (defined($r->dir_config("${auth_name}BasicAuthMap"))) {
	    push(@credentials, $self->ApplyAuthMap($r,$pass,$amc));
	} else {
	    # Boring old in-order split
	    foreach (split(';', $pass, $amc)) {
		push(@credentials, $_);
	    }
	}

	# Log partial first char of each credential
	if ($r->dir_config("${auth_name}Debug")) {
	    for (my $i = 0; $i < scalar(@credentials); $i++) {
		$credentials[$i] =~ /^(.)/;
		$self->Log($r, ('debug', "loginBasic(): Received credential_$i: $1 (hint)"));
	    }
	}

	# Check against credential cache if AuthUnique is set
	if ($r->dir_config("${auth_name}AuthUnique")) {
	    unless ($self->CheckTracker($r, 'AuthUnique', @credentials)) {
		# Tried to send the same credentials twice (or tracker system
		# failure. Delete the credentials to fall through
		@credentials = ();
		$self->Log($r, ('warn', "loginBasic(): AuthUnique check failed: Same credentials have been sent before"));
	    }
	}

	if (@credentials) {
	    # Exchange the credentials for a session key.
	    $ses_key = $self->authen_cred($r, @credentials);
	    if ($ses_key) {
		# Set session cookie with expiration included if SessionExpire
		# is set. (Extended +8 hours for logouts/cleanup)
		if ($r->dir_config("${auth_name}SessionExpire")) {
		    $self->send_cookie($r, $ses_key, {expires => $r->dir_config("${auth_name}SessionExpire") + 28800});
		} else {
		    $self->send_cookie($r, $ses_key);
		}
		$self->handle_cache($r);

		# Log 1/2 of session key to debug
		$self->Log($r, ('debug', "loginBasic(): session key (browser cookie value): " . XHalf($ses_key)));

		# Godspeed You Black Emperor!
		$t = $r->uri;
		($r->args) && ($t .= '?' . $r->args);
		$self->Log($r, ('debug', "loginBasic(): REDIRECTING TO: $t"));
		$r->err_headers_out->{'Location'} = $t;
		return REDIRECT;
	    }
	}
    }

    # Unset the username if set
    $r->user() and $r->user(undef);

    # Add their IP to the failure tracker and just return HTTP_FORBIDDEN
    # if they exceed the limit
    if ($r->dir_config("${auth_name}IPFailures")) {
        if ($MP eq 1) {
	    unless ($self->CheckTracker($r, 'IPFailures', $r->dir_config("${auth_name}IPFailures"), $r->get_remote_host)) {
	        $self->Log($r, ('warn', "loginBasic(): Returning HTTP_FORBIDDEN to IPFailires banned IP"));
	        return HTTP_FORBIDDEN;
            }
        } else {
            unless ($self->CheckTracker($r, 'IPFailures', $r->dir_config("${auth_name}IPFailures"), $r->connection->get_remote_host)) {
                $self->Log($r, ('warn', "loginBasic(): Returning HTTP_FORBIDDEN to IPFailires banned IP"));
                return HTTP_FORBIDDEN;
            }
	}
    }

    # Set the basic auth header and send back to the client
    $r->note_basic_auth_failure;
    return HTTP_UNAUTHORIZED;
}


# Logout, kill session, kill, kill, kill
sub logout_mp1 ($$) { &logout_real }
sub logout_mp2 : method { &logout_real }
*logout = ($MP eq 1) ? \&logout_mp1 : \&logout_mp2;
sub logout_real {
    my $self = shift;
    my $r = shift;
    my $auth_name = $r->auth_name;
    my $redirect = shift || "";
    my ($sid, %sess, $sessconfig, $username, $alterlist);

    # Get the Cookie header. If there is a session key for this realm, strip
    # off everything but the value of the cookie.
    my $cookie_name = $self->cookie_name($r);
    my ($key) = $r->headers_in->{'Cookie'} =~ /$cookie_name=([^;]+)/;

    # Try custom keysource if no cookie is present and Keysource is configured
    if (!$key && $auth_name && $r->dir_config("${auth_name}Keysource")) {
	# Pull in key text
	$key = $self->FetchKeysource($r);
	# Non-empty, so use to generate the real session auth key
	if ($key) {
	    $key = CreateSessionAuthKey($key);
	}
    }

    # If set, check key format, else check for custom keysource
    if ($key) {
	($key = CheckSidFormat($key)) || (($self->Log($r, 'error', 'logout(): Invalid Session Key Format')) && (return undef));
    }

    # Get session config from Apache
    ($sessconfig = $self->GetSessionConfig($r)) || (die("logout: Unable to get session configuration while checking authentication\n"));

    if ($key) {
	# Enter the authentication key into the session config (NEVER STORE IT
	# IN THE ACTUAL SESSION DATA!)
	$sessconfig->{key} = $key;

        # Compute real session ID
	($sessconfig->{ServerKey}) ||
	    (($self->Log($r, ('error', 'logout(): ${auth_name}SessionServerPass or ${auth_name}SessionServerKey not set (required for HMAC sessions)'))) &&
	     (return undef));
	($sid = ComputeSessionId($key, $sessconfig->{ServerKey})) || (($self->Log($r, ('error', 'logout(): Error computing session ID'))) && (return undef));
    } else {
	$sid = '';
    }

    # Try to delete the session.  Note that session handling errors do not
    # return but fall through to return OK or REDIRECT depending
    # on how we were called.
    if ($sid) {
	# Check the SID
  	if ($sid = CheckSidFormat($sid)) {
	    # Open the session (this should die on a non-existant session)!!!
	    eval { tie(%sess, 'Apache::AppSamurai::Session', $sid, $sessconfig); };
	    if ($@) {
		$self->Log($r, ('debug', "logout(): Unable to open session \"$sid\": $@"));
	    } else {
		$username = $sess{'username'};

                # Load alterlist
		$alterlist = $self->AlterlistLoad(\%sess);
		# Re-apply passback cookies to which were cleared and backdated
		# after session creation.  (This clears the passback cookies)
		if (defined($alterlist->{cookie})) {
		    $self->AlterlistPassBackCookie($alterlist, $r);
		}

		$self->DestroySession($r, \%sess);
        	untie(%sess);
		$self->Log($r, ('notice', "LOGOUT: username=\"$username\", session=\"$sid\", reason=logout"));
	    }
	} else {
	    $self->Log($r, ('error', 'logout(): Invalid Session ID Format'));
	}
    } else {
	# No cookie set
	$self->Log($r, ('error', 'logout(): Missing session ID'));
    }

    # Clear cookie and set no-cache for client
    $self->remove_cookie($r);
    $self->handle_cache($r);

    # Check for hard-coded redirect for logout, or failing that, our
    # landing page
    if ($r->dir_config("${auth_name}LogoutDestination")) {
	$redirect = $r->dir_config("${auth_name}LogoutDestination");
    } elsif ($r->dir_config("${auth_name}LoginDestination")) {
	$redirect = $r->dir_config("${auth_name}LoginDestination");
    }

    if ($redirect ne '') {
    	$r->err_headers_out->{'Location'} = $redirect;
    	$r->status(REDIRECT);
    	return REDIRECT;
    } else {
	# Strip path and reload - THIS ONLY WORKS IF / IS REDIRECTED TO THE
	# LANDING PAGE
	$r->err_headers_out->{'Location'} = '/';
	$r->status(REDIRECT);
    	return REDIRECT;
    }

    # Returning the login form without redirecting on logout is probably not
    # right for any circumstance.  (Leaving this here for reference.)
    # else {
    #    return $self->login_form($r);
    # }
}


# Check for unauthenticated session and force login if not authenticated
sub authenticate_mp1 ($$) { &authenticate_real }
sub authenticate_mp2 : method { &authenticate_real }
*authenticate = ($MP eq 1) ? \&authenticate_mp1 : \&authenticate_mp2;
sub authenticate_real {
    my ($self, $r) = @_;
    my $auth_user;
    my ($t, $foundcookie);

    unless ($r->is_initial_req) {
	if (defined $r->prev) {
	    # we are in a sub-request.  Just copy user from previous request.
	    ($MP eq 1) ? ($r->connection->user($r->prev->connection->user)) :
		($r->user($r->prev->user));
	}
	return OK;
    }

    # Type must either be our own, or Basic
    unless (($r->auth_type eq $self) || ($r->auth_type =~ /^basic$/i)) {
	# Location requires authentication but we don't handle this AuthType.
	$self->Log($r, ('debug', "authenticate(): AuthType mismatch: $self =/= ".$r->auth_type));
	return DECLINED;
    }

    # AuthType is $auth_type which we handle, Check the authentication realm
    my $auth_name = $r->auth_name;
    $self->Log($r, ('debug', "authenticate(): auth_name " . $auth_name));
    unless ($auth_name) {
	$r->log_reason("AuthName not set, AuthType=$self", $r->uri);
	return HTTP_INTERNAL_SERVER_ERROR;
    }

    # Get the Cookie header. If there is a session key for this realm, strip
    # off everything but the value of the cookie.
    my $cookie_name = $self->cookie_name($r);
    my ($ses_key_cookie) = ($r->headers_in->{"Cookie"} || "") =~ /$cookie_name=([^;]+)/;

    $foundcookie = 0;
    if ($ses_key_cookie) {
	# If cookie found and not "", set $foundcookie to note auth key source
	$foundcookie = 1;
    } elsif ($r->dir_config("${auth_name}Keysource")) {
	# Try custom keysource if no cookie is present and Keysource is configured
	# Pull in key text
	$ses_key_cookie = $self->FetchKeysource($r);

	if ($ses_key_cookie) {
	    # Non-empty, so use to generate the real session auth key
	    $ses_key_cookie = CreateSessionAuthKey($ses_key_cookie);
	} else {
	    $ses_key_cookie = "";
	}
    } else {
	$ses_key_cookie = "";
    }

    # Report half of session key
    $self->Log($r, ('debug', "authenticate(): Current ses_key_cookie: \"" . XHalf($ses_key_cookie) . "\""));

    if ($ses_key_cookie) {
	my ($auth_user, @args) = $self->authen_ses_key($r, $ses_key_cookie);

	if ($auth_user and scalar @args == 0) {
	    # We have a valid session key, so we return with an OK value.
	    # Tell the rest of Apache what the authentication method and
	    # user is.
	    if ($MP eq 1) {
		$r->connection->auth_type($self);
		$r->connection->user($auth_user);
	    } else {
		# Assume MP2 behaviour
		$r->ap_auth_type($self);
		$r->user($auth_user);
	    }
	    $self->Log($r, ('debug', "authenticate(): user authenticated as $auth_user"));

	    return OK;

	} elsif (scalar @args > 0 and $self->can('custom_errors')) {
	    return $self->custom_errors($r, $auth_user, @args);
	} else {
	    # There was a session key set, but it's invalid.
	    if ($foundcookie) {
		# Remove cookie from the client now so it does not come back.
		$self->remove_cookie($r);
	    }
	    $self->handle_cache($r);
	    $r->subprocess_env('AppSamuraiReason', 'bad_cookie');

	    # Add to our the session tracker (so we can short cut if resent)
	    # Ignores return (we are already on the way out...)
	    if ($r->dir_config("${auth_name}SessionUnique")) {
		$self->CheckTracker($r, 'SessionUnique', $ses_key_cookie);
	    }
   	}
    } else {
	# They have no cookie or Keysource generated auth key
	$r->subprocess_env('AppSamuraiReason', 'no_cookie');
    }

    # If serving Basic, hand control over the the basic login handler
    if ($r->auth_type =~ /^basic$/i) {
	# (Returns an OK if the login was good or return a 401 if not.)
	$self->Log($r, ('debug',  "authenticate(): Basic auth protected area: Attempting loginBasic()"));
	return $self->loginBasic($r);
    } else {
	# They aren't authenticated, and they tried to get a protected
	# document.  Send them the authen form.
	return $self->login_form($r);
    }
}

# Generate login form
sub login_form {
    my ($self, $r) = @_;
    my $auth_name = $r->auth_name;

    # Pull POST args into the GET args and set type as GET
    $self->_convert_to_get($r) if $r->method eq 'POST';

    my $authen_script;
    unless ($authen_script = $r->dir_config($auth_name . "LoginScript")) {
	$self->Log($r, ('error', "login_form(): PerlSetVar '${auth_name}LoginScript' not set", $r->uri));
	return HTTP_INTERNAL_SERVER_ERROR;
    }
    $self->Log($r, ('debug', "login_form(): Displaying $authen_script"));
    $r->custom_response(HTTP_FORBIDDEN, $authen_script);

    return HTTP_FORBIDDEN;
}

# Check for sane "satisfy" setting
sub satisfy_is_valid {
    my ($self, $r, $satisfy) = @_;
    $satisfy = lc $satisfy;

    if ($satisfy eq 'any' or $satisfy eq 'all') {
	return 1;
    } else {
	my $auth_name = $r->auth_name;
	$self->Log($r, ('error', "satisfy_is_valid(): PerlSetVar ${auth_name}Satisfy $satisfy invalid",$r->uri));
	return 0;
    }
}

# Get satisfy setting
sub get_satisfy {
    my ($self, $r) = @_;
    my $auth_name = $r->auth_name;
    return lc $r->dir_config("${auth_name}Satisfy") || 'all';
}


# Check for proper authorization for the area
sub authorize_mp1 ($$) { &authorize_real }
sub authorize_mp2 : method { &authorize_real }
*authorize = ($MP eq 1) ? \&authorize_mp1 : \&authorize_mp2;
sub authorize_real {
    my ($self, $r) = @_;

    $self->Log($r, ('debug', 'authorize(): URI '.$r->uri()));
    return OK unless $r->is_initial_req; #only the first internal request

    unless (($r->auth_type eq $self) || ($r->auth_type =~ /^basic$/i)) {
	$self->Log($r, ('debug', $self . "authorize(): Wrong auth type: " . $r->auth_type));
	return DECLINED;
    }

    my $reqs_arr = $r->requires or return DECLINED;

    my $user = ($MP eq 1) ? ($r->connection->user) : ($r->user);
    unless ($user) {
	# user is either undef or =0 which means the authentication failed
	$r->log_reason("No user authenticated", $r->uri);
	return HTTP_FORBIDDEN;
    }

    my $satisfy = $self->get_satisfy($r);
    return HTTP_INTERNAL_SERVER_ERROR unless $self->satisfy_is_valid($r,$satisfy);
    my $satisfy_all = $satisfy eq 'all';

    my ($forbidden);
    foreach my $req (@$reqs_arr) {
	my ($requirement, $args) = split /\s+/, $req->{requirement}, 2;
	$args = '' unless defined $args;
	$self->Log($r, ('debug', "authorize(): requirement := $requirement, $args"));

	if ( lc($requirement) eq 'valid-user' ) {
	    if ($satisfy_all) {
		next;
	    } else {
		return OK;
	    }
	}

	if($requirement eq 'user') {
	    if ($args =~ m/\b$user\b/) {
		next if $satisfy_all;
		return OK; # satisfy any
	    }

	    $forbidden = 1;
	    next;
	}

	# Call a custom method
	my $ret_val = $self->$requirement($r, $args);
	$self->Log($r, ('debug', "authorize(): $self->$requirement returned $ret_val"));
	if ($ret_val == OK) {
	    next if $satisfy_all;
	    return OK; # satisfy any
	}

	# Nothing succeeded, deny access to this user.
	$forbidden = 1;
    }

    return $forbidden ? HTTP_FORBIDDEN : OK;
}

# Have a session cookie Mr. Browser
sub send_cookie {
    my ($self, $r, $ses_key, $cookie_args) = @_;

    $cookie_args = {} unless defined $cookie_args;

    my $cookie_name = $self->cookie_name($r);

    my $cookie = $self->cookie_string( request => $r,
				       key     => $cookie_name,
				       value   => $ses_key,
				       %$cookie_args );

    # add P3P header if user has configured it.
    my $auth_name = $r->auth_name;
    if (my $p3p = $r->dir_config("${auth_name}P3P")) {
	$r->err_headers_out->{'P3P'} = $p3p;
    }

    $r->err_headers_out->add("Set-Cookie" => $cookie);
}

# Convert cookie store to header ready string
sub cookie_string {
    my $self = shift;

    # if passed 3 args, we have old-style call.
    if (scalar(@_) == 3) {
	carp "cookie_string(): deprecated old style call to ".__PACKAGE__."::cookie_string()";
	my ($r, $key, $value) = @_;
	return $self->cookie_string(request=>$r, key=>$key, value=>$value);
    }
    # otherwise assume named parameters.
    my %p = @_;
    for (qw/request key/) {
	die("cookie_string(): missing required parameter $_\n") unless defined $p{$_};
    }
    # its okay if value is undef here.

    my $r = $p{request};

    $p{value} = '' unless defined $p{value};

    my $string = sprintf '%s=%s', @p{'key','value'};

    my $auth_name = $r->auth_name;

    if (my $expires = $p{expires} || $r->dir_config("${auth_name}Expires")) {
	$expires = Apache::AppSamurai::Util::expires($expires);
	$string .= "; expires=$expires";
    }

    $string .= '; path=' . ( $self->get_cookie_path($r) || '/' );

    if (my $domain = $r->dir_config("${auth_name}Domain")) {
	$string .= "; domain=$domain";
    }

    if (!$r->dir_config("${auth_name}Secure") || ($r->dir_config("${auth_name}Secure") == 1)) {
	$string .= '; secure';
    }

    # HttpOnly is an MS extension.  See
    # http://msdn.microsoft.com/workshop/author/dhtml/httponly_cookies.asp
    if ($r->dir_config("${auth_name}HttpOnly")) {
	$string .= '; HttpOnly';
    }

    return $string;
}

# Retrieve session cookie value
sub key {
    my ($self, $r) = @_;

    my $auth_name = $r->auth_name;
    my $key = "";

    my $allcook = ($r->headers_in->{"Cookie"} || "");
    my $cookie_name = $self->cookie_name($r);
    ($key) = $allcook =~ /(?:^|\s)$cookie_name=([^;]*)/;

    # Try custom keysource if no cookie is present and Keysource is configured
    if (!$key && $auth_name && $r->dir_config("${auth_name}Keysource")) {
	# Pull in key text
	$key = $self->FetchKeysource($r);
	# Non-empty, so use to generate the real session auth key
	if ($key) {
	    $key = CreateSessionAuthKey($key);
	}
    }

    return $key;
}

# Retrieve session cookie path
sub get_cookie_path {
    my ($self, $r) = @_;

    my $auth_name = $r->auth_name;

    return $r->dir_config("${auth_name}Path");
}

# Check authentication credentials and return a new session key
sub authen_cred {
    my $self = shift;
    my $r = shift;
    my $username = shift;
    my @creds = @_;
    my $alterlist = {};

    # Check for matching credentials and configured authentication methods
    unless (@creds) {
	$self->Log($r, ('error', "LOGIN FAILURE: Missing credentials"));
	return undef;
    }

    my @authmethods = $self->GetAuthMethods($r);
    unless (@authmethods) {
        $self->Log($r, ('error', "LOGIN FAILURE: No authentication methods defined"));
	return undef;
    }
    unless (scalar(@creds) == scalar(@authmethods)) {
        $self->Log($r, ('error', "LOGIN FAILURE: Wrong number of credentials supplied"));
        return undef;
    }

    my $authenticated = 0;

    my ($ret, $errors);

    # Require and get new instance of each authentication module
    my $authenticators = $self->InitAuthenticators($r, @authmethods);

    $self->Log($r, ('debug', "authen_cred(): About to cycle authenticators"));
    for (my $i = 0; $i < scalar(@authmethods); $i++) {
	$self->Log($r, ('debug', "authen_cred(): Checking $authmethods[$i]"));

        # Perform auth check
	$ret = $authenticators->{$authmethods[$i]}->Authenticate($username, $_[$i]);
	# Log any errors, warnings, etc.
	($errors = $authenticators->{$authmethods[$i]}->Errors) && ($self->Log($r, $errors));
	$self->Log($r, ('debug', "authen_cred(): Done checking $authmethods[$i]"));

	if ($ret) {
	    # Success!
	    $authenticated++;

	    # Modify header (add/delete/filter) and cookie
	    # (add/delete/filter/pass) rules
	    $self->AlterlistMod($alterlist, $authenticators->{$authmethods[$i]}->{alterlist});
	    $self->Log($r, ('debug', "authen_cred(): Added alterlist groups for" . join(",", keys %{$alterlist})));

	} else {
	    # Failure! Stop checking auth.
	    last;
	}
    }

    $self->Log($r, ('debug', "authen_cred(): Done cycling authenticators"));

    # If the number of successful authentications equals the number of
    # authentication methods, you may pass.
    if (($authenticated == scalar(@authmethods)) && ($ret = $self->CreateSession($r, $username, $alterlist))) {
	return $ret;
    } else {
	# Log username (Log handles cleanup of the username and all log lines)
	if ($username) {
	    $self->Log($r, ('error', "LOGIN FAILURE: Authentication failed for \"$username\""));
	} else {
	    $self->Log($r, ('error', "LOGIN FAILURE: Authentication failed for missing or malformed username"));
	}

	# Lame excuse for brute force protection! Sleep from 0.0 to 1.0 secs
	# on failure to ensure someone can DoS us. :)  IPFailures tracker needs
	# work to have a pre-check, or to have a call out to a script to
	# do something (like add the IP to a firewall block table)
	usleep(rand(1000000));
    }

    return undef;
}

# Check session key and return user ID
sub authen_ses_key {
    my ($self, $r, $key) = @_;
    my ($sid, %sess, $username, $sessconfig, $tk, $tv, $reason);
    my $alterlist = {};

    # Is it well formed?
    ($key = CheckSidFormat($key)) || (($self->Log($r,('error', 'Invalid Session Key Format'))) && (return undef));

    # Get session config from Apache
    ($sessconfig = $self->GetSessionConfig($r)) || (die("authen_ses_key(): Unable to get session configuration while checking authentication\n"));

    # Enter the authentication key into the session config
    # (NOTE: MUST NOT BE STORED INSIDE SESSION)
    $sessconfig->{key} = $key;

    # Compute real session ID
    ($sessconfig->{ServerKey}) || (($self->Log($r, ('error', 'authen_ses_key(): ServerPass or ServerKey not set (required for HMAC sessions)'))) && (return undef));

    ($sid = ComputeSessionId($sessconfig->{key}, $sessconfig->{ServerKey})) || (($self->Log($r, ('error', 'authen_ses_key(): Error computing session ID'))) && (return undef));

    # Open the session (Eval will die on a non-existent session)
    eval { tie(%sess, 'Apache::AppSamurai::Session', $sid, $sessconfig); };
    if ($@) {
	$self->Log($r, ('debug', "authen_ses_key(): Unable to open session \"$sid\": $@"));
	return undef;
    }

    # Dump session contents to log (with some attempted cleanup for security)
    if ($self->_debug($r)) {
	my @tsl = ();
	push(@tsl, "authen_ses_key(): Dump of session \"$sid\": ");
	foreach $tk (sort keys %sess) {
	    $tv = $sess{$tk};
	    if ($tk eq 'al-header') {
		# Sanitize headers (Leaving 8 chars of context for each)
		$tv =~ s/^(\w+:authorization:.{1,8})(.*)$/$1 . "X" x length($2)/gmie;
	    } elsif ($tk eq 'al-cookie') {
                # Sanitize cookies (Leaving 8 characters of context)
		$tv =~ s/^(\w+:[^\:\=]+:.{1,8})([^;]*)(;.*)$/$1 . ("X" x length($2)) . $3/gmie;
	    } elsif ($tk =~ /auth/i) {
		# Probably something we want hidden
		$tv =~ s/^(.{1,8})(.*)$/$1 . "X" x length($2)/gmie;
	    }
	    push(@tsl, "$tk=>\"$tv\"");
	}
	$self->Log($r, ('debug', join(",", @tsl)));
    }

    # Pull header and cookie mod lists
    $alterlist = $self->AlterlistLoad(\%sess);

    # No reason... yet
    $reason = '';

    # Give me a reason... anything... any little excuse to kill your session...
    $username = $sess{'username'};
    if (!$username) {
	# Session must have a username
	$reason = 'no_username';
	# Extra-bad!
	$self->Log($r, ('error', "authen_ses_key(): No username for session \"$sid\""));
    } elsif (!$self->CheckTime(\%sess)) {
        # Expiration check failed
	$reason = 'timeout';
    } elsif (($sess{"Authorization"}) && ($r->headers_in->{"Authorization"}) && ($r->headers_in->{"Authorization"} ne $sess{"Authorization"})) {
	# Client sent a Authorization header that does not match the one sent
	# when logging in.  This indicates one of two potential issues:
	# 1) For areas configured to use basic auth, the auth has changed on
	#    the browser side, so kill the session.
	# 2) For areas we front with a form, this indicates that the backend
	#    server sent a 401 to the client.  We need to kill the session to
	#    get things in line again.
	$reason = "basic_auth_change";
    }

    if ($reason) {
	# Oh no!  They gave us a reason... It's ON!  (well, off)

	# Remove passback and session cookies first
	if (defined($alterlist->{cookie})) {
	    $self->AlterlistPassBackCookie($alterlist, $r);
	}

	$self->remove_cookie($r);
	$self->handle_cache($r);

	# Wake up.  Time to die.
        $self->DestroySession($r, \%sess);
	untie(%sess);
	$self->Log($r, ('notice', "LOGOUT: username=\"$username\", session=\"$sid\", reason=$reason"));

	# If serving basic auth, return undef instead of triggering login form
	if ($r->auth_type =~ /^basic$/i) {
	    return undef;
	} else {
	    # Use Apache::AuthCookie based custom_errors feature, which will
	    # call back into our custom_errors() method. (expired_cookie
	    # applies as an acceptable error for all of these cases.)
	    return('login', 'expired_cookie');
	}
    }

    # Apply header and cookie alterations to request headed for backend server
    $self->AlterlistApply($alterlist, $r);
    $self->Log($r, ('debug', "authen_ses_key(): Loaded and applied alterlist groups " . join(",", keys %{$alterlist})));

    # Release session file
    untie(%sess);

    return $username;
}


# custom_errors are a nice way to get flexible actions based on certain events
# without having to rewrite authentication() and other methods. Takes
# the request, a "code", and a message.  The original intent of this was to
# allow for custom server return messages, but I muck it up to do things like
# redirecting on certain errors, too.
sub custom_errors {
    my ($self, $r, $code, $message) = @_;
    my $t;

    # Handle request based on the format of the $code argument
    if ($code =~ /^login$/) {
	# Append the passed error code using ASERRCODE and bring up the login
	# form.  (Adds error code query to the current URI, which the login
	# form will pull back in)
	$t = $r->uri;
	($r->args) && ($t .= "?" . $r->args);
	$r->uri($self->URLErrorCode($t, 'message'));
	return $self->login_form($r);
    } elsif ($code =~ /^([A-Z0-9_]+)$/) {
	# Codes in all caps with an underscore are assumed to be Apache
        # response codes
	($message) && ($r->custom_response($code, $message));
	return $code;
    } else {
	# What was that?  Die out.
	die "custom_errors(): Invalid code passed to custom_errors: \"$code\"";
    }
}

## END Apache::AuthCookie based methods

# Everything past this point is not an overridden/modified Apache::AuthCookie
# function.

# Taking a request, try to get the AuthMethods list for the resource
sub GetAuthMethods {
    my ($self, $r) = @_;
    my ($authname, $authmethlist);
    my @authmethods = ();

    # Get the auth name
    ($authname = $r->auth_name()) || (die("GetAuthMethods(): No auth name set for this request!\n"));
    ($authmethlist = $r->dir_config($authname . "AuthMethods")) || (die("GetAuthMethods(): No authentication methods found for $authname!\n"));

    # AuthMethods should be a comma deliminated list of methods.  Let
    # us see, shall we?
    foreach (split(',', $authmethlist)) {
	(/^\s*(Auth[\w\d]+)\s*$/) || (die("GetAuthMethods(): Invalid ${authname}AuthMethods definition!\n"));
	push(@authmethods, $1);
    }

    return @authmethods;
}

# This just loads the appropriate Apache::AppSamurai::AuthXXX modules
# so they are ready to authenticate against.  Note that this function
# needs only be called by authen_cred() most of the time.  Returns a ref
# to a hash with AuthName->AuthNameInstance mappings
sub InitAuthenticators {
    my $self = shift;
    my $r = shift;
    my @authmethods = @_;
    my ($am, $amn, $lkn, $skn, $ch, $authname, $dirconfig);

    (scalar(@authmethods)) || (die("InitAuthenticators(): You must specify at least one authentication method!\n"));

    # Clear authenticator handle hash
    my $authenticators = {};

    # Get directory authentication name and a hash of its config
    ($authname = $r->auth_name()) || (die("InitAuthenticators(): No auth name set for this request!\n"));
    $dirconfig = $r->dir_config();

    # Init each auth method
    foreach $am (@authmethods) {
	($am =~ /^Auth[A-Z0-9][a-zA-Z0-9:]+$/) || (die("InitAuthenticators(): Illegal authentication method name!  (Check case)\n"));

	# Extract any config variables set for the configure auth methods
	# and store in a temp hash before creating auth module instance
	$ch = {};
	$lkn = '';
	$skn = '';
	foreach $lkn (keys %{$dirconfig}) {
	    ($lkn =~ /^${authname}${am}([\w\d]+)\s*$/) || (next);
	    $skn = $1;
	    $ch->{$skn} = $dirconfig->{$lkn};

	    # If a "header:" is requested, replace with the named
	    # header's value from the client request, or an empty string
	    if ($ch->{$skn} =~ /^header:([\w\d\-]+)$/i) {
		$ch->{$skn} = $r->headers_in->{$1};
	    }
	}

	if ($am =~ /^(AuthSimple)(.+)$/) {
	    # Framework auth modules (like AuthSimple) - These need
	    # a master AppSamurai::Auth*** module that expects the name
	    # of a submodule and its arguments
	    # Set submodule name, assuming it is under the master's tree
	    $ch->{SubModule} = $2;
	    # Use the master auth module from AppSamurai itself
	    $amn = 'Apache::AppSamurai::' . $1;
	} else {
	    $amn = 'Apache::AppSamurai::' . $am;
	}

	(eval "require $amn;") ||
	    (die("InitAuthenticators(): Could not load $amn\n"));

	{
	    # Disable strict within block so we can call ::new
	    no strict 'refs';
	    ($authenticators->{$am} = $amn->new(%{$ch})) ||
		(die("InitAuthenticators(): Could not create new $amn instance: " . $! . "\n"));
	}

	# A little sanity check on the returned authenticator
	$authenticators->{$am}->can("Authenticate") or die("InitAuthenticators(): Newly created $amn instance (for $am) does not have Authenticate() method");
    }

    return $authenticators;
}

# Retrieve session configuration from Apache config and return as a hash ref
sub GetSessionConfig {
    my ($self, $r) = @_;
    my $auth_name = ($r->auth_name()) || (die("GetSessionConfig(): No auth name defined!\n"));
    my $dirconfig = $r->dir_config;
    # Set some defaults that shouldn't be too horrible
    my $sessconfig = {};

    # Pull in session configuration
    foreach (keys %{$dirconfig}) {
	(/^${auth_name}Session([\w\d]+)\s*$/) || (next);
	$sessconfig->{$1} = $dirconfig->{$_};
    }

    unless (scalar(keys %{$sessconfig})) {
	$self->Log($r, ('error', "GetSessionConfig(): No Session configuration found for $auth_name!"));
	return undef;
    }

    ## TODO    - This section of session autoconfig/defaults is pretty
    ##           inflexilbe and too tightly tied to HMAC_SHA and CryptBase64.
    ##           It should be abolished or moved out and into a generalized
    ##           pre-config module that can be called ONCE (at startup)

    # Use files for storage and locking by default
    (exists($sessconfig->{Store})) || ($sessconfig->{Store} = "File");
    (exists($sessconfig->{Lock})) || ($sessconfig->{Lock} = "File");

    # If files are being used, paths must be set
    if ($sessconfig->{Store} eq 'File' && !exists($sessconfig->{Directory})) {
	$self->Log($r, ('error', "GetSessionConfig(): ${auth_name}SessionDirectoy must be defined for the File session store"));
	return undef;
    }
    if ($sessconfig->{Lock} eq 'File' && !exists($sessconfig->{LockDirectory})) {
	$self->Log($r, ('error', "GetSessionConfig(): ${auth_name}SessionLockDirectoy must be defined for the File session lock"));
	return undef;
    }

    # Use HMAC_SHA and CryptBase64 for session creation and serialization
    # by default.
    (exists($sessconfig->{Generate})) || ($sessconfig->{Generate} = "AppSamurai/HMAC_SHA");
    (exists($sessconfig->{Serialize})) || ($sessconfig->{Serialize} = "AppSamurai/CryptBase64");

    # Check/clean ServerPass if present (else assume ServerKey set)
    if (exists($sessconfig->{ServerPass})) {
	# Set the key (note - GetServerKey logs the error, if any)
	($sessconfig->{ServerKey} = $self->GetServerKey($r)) || (return undef);
    }

    # We have to have a ServerKey at this point, in hex form.
    if (($sessconfig->{Generate} =~ /HMAC/i) || ($sessconfig->{Serialize} =~ /Crypt/i)) {
	unless (CheckSidFormat($sessconfig->{ServerKey})) {
	    # Bad server key format
	    $self->Log($r, ('error', "GetSessionConfig(): You must a valid ${auth_name}ServerPass or ${auth_name}ServerKey!"));
	    return undef;
	}

	# For speed, SerializeCipher should be set in the config
	if (!$sessconfig->{SerializeCipher}) {
	    # Attempt to load CryptBase64 module
	    unless (eval "require Apache::AppSamurai::Session::Serialize::CryptBase64") {
		$self->Log($r, ('error', "GetSessionConfig(): Could not load CryptBase64 while attempting to auto-select ${auth_name}SerializeCipher value: $!"));
		return undef;
	    }
	    # Use CryptBase64 cipher detection utility (Slower)
	    unless ($sessconfig->{SerializeCipher} = &Apache::AppSamurai::Session::Serialize::CryptBase64::find_cipher()) {
		# None found.  (Note - Check @allowedciphers in CryptBase64.pm
		# for supported ciphers)
		$self->Log($r, ('error', "GetSessionConfig(): Could not auto-detect a suitable ${auth_name}SerializeCipher value (Please configure manualy): $!"));
		return undef;
	    }
	}
    }

    # Set a 1hr Timeout if neither Timeout or Expire are set
    unless ($sessconfig->{Timeout} || $sessconfig->{Expire}) {
	$sessconfig->{Timeout} = 3600;
    }

    return $sessconfig;
}


# Compute/check server key from server pass, returning key.
sub GetServerKey {
    my ($self, $r) = @_;
    my $auth_name = ($r->auth_name()) || (die("GetServerKey(): No auth name defined!\n"));
    my $dirconfig = $r->dir_config;
    my $serverkey = '';

    if (exists($dirconfig->{$auth_name . "SessionServerPass"})) {
	my $serverpass = $dirconfig->{$auth_name . "SessionServerPass"};

	unless ($serverpass =~ s/^\s*([[:print:]]{8,}?)\s*$/$1/s) {
	    $self->Log($r, ('error', "GetServerKey(): Invalid ${auth_name}SessionServerPass (must be use at least 8 printable characters"));
	    return undef;
	}

	if ($serverpass =~ /^(password|serverkey|serverpass|12345678)$/i) {
	    $self->Log($r, ('error', "GetServerKey(): ${auth_name}SessionServerPass is $1...  That is too lousy"));
	    return undef;
	}

	unless ($serverkey = HashPass($serverpass)) {
	    $self->Log($r, ('error', "GetServerKey(): Problem computing server key hash for ${auth_name}SessionServerPass"));
	    return undef;
	}

    } elsif (exists($dirconfig->{$auth_name . "SessionServerKey"})) {
	$serverkey = $dirconfig->{$auth_name . "SessionServerKey"};

    } else {
	$self->Log($r, ('error', "GetServerKey(): You must define either ${auth_name}SessionServerPass or ${auth_name}SessionServerKey in your Apache configuration"));
	return undef;
    }

    # Check for valid key format
    unless (CheckSidFormat($serverkey)) {
	# Not good, dude.  This should not happen
	$self->Log($r, ('error', "GetServerKey(): Invalid server session key (CheckSidFormat() failure) for $auth_name"));
	return undef;
    }

    return $serverkey;
}


# Apply the configured BasicAuthMap to the passed in credentials
# BasicAuthMap allows for flexibly parsing a single line of authentication
# data into multiple credentials in any order.  (Keep those users happy...)
# Returns an array with the parsed credentials in order, or an empty set on
# failure.
sub ApplyAuthMap {
    my ($self, $r, $pass, $amc) = @_;
    my $auth_name = ($r->auth_name) || ('');
    my ($o, $m, $i, @ct);
    my @creds = ();

    # Check basic map format
    ($r->dir_config("${auth_name}BasicAuthMap") =~ /^\s*([\d\,]+)\s*\=\s*(.+?)\s*$/) || (die("ApplyAuthMap(): Bad format in ${auth_name}BasicAuthMap\n"));
    $o = $1;
    $m = $2;

    # Try to map values from pass string
    (@ct) = $pass =~ /^$m$/;
    unless (scalar(@ct) eq $amc) {
	$self->Log($r, ('warn', "ApplyAuthMap: Unable to match credentials with ${auth_name}BasicAuthMap"));
	return ();
    }

    # Check credential numbers for sanity and assign values
    foreach $i (split(',', $o)) {
	($i =~ s/^\s*(\d+)\s*$/$1/) || (die("ApplyAuthMap(): Bad mapping format in ${auth_name}BasicAuthMap\n"));
	push(@creds, $ct[$i - 1]);
    }

    return @creds;
}


# Gather header and argument items from request to build custom session
# authentication key.  Not nearly as secure as random generation, but
# for cookie losing clients (generally automated), it is the only choice.
#
# Synatax:
#
#    TYPE:NAME
#
# TYPE - Type of item (header or arg) to pull in
# NAME - Name of header or argument to pull in
#
# The name match is case insensitive, but strict:  Only the exact names
# will be used to ensure a consistent key text source.  MAKE SURE TO USE
# PER-CLIENT UNIQUE VALUES!  The less random the key text source is, the
# easier it can be guessed/hacked. (Once again: Do not use the custom
# key text source feature if you can avoid it!)
sub FetchKeysource {
    my ($self, $r) = @_;
    my $auth_name = ($r->auth_name()) || (die("FetchKeysource(): No auth name defined!\n"));
    my @srcs = $r->dir_config->get("${auth_name}Keysource");

    # Return empty, which session key creators MUST interpret as a request
    # for a fully randomized key
    return '' unless (scalar @srcs);

    # Use Apache::Request for immediate access to all arguments.
    my $ar = ($MP eq 1) ? Apache::Request->instance($r) : Apache2::Request->new($r);

    my ($s, $t);
    my $keytext = '';

    # Pull values in with very moderate checking
    foreach $s (@srcs) {
	if ($s =~ /^\s*header:([\w\d\-\_]+)\s*$/i) {
	    if ($r->headers_in->{$1} and
		($t) = $r->headers_in->{$1} =~ /^\s*([\x20-\x7e]+?)\s*$/s) {
		$keytext .= $t;
		$self->Log($r, ('debug', "FetchKeysource(): Collected $s: " . XHalf($t)));
	    } else {
		$self->Log($r, ('warn', "FetchKeysource(): Missing header field: \"$1\": Can not calculate session key"));
		return undef;
	    }
	} elsif ($s =~ /^\s*arg:([\w\d\.\-\_]+)\s*$/i) {
	    if (($t = $ar->param($1)) && ($t =~ s/^\s*([^\r\n]+?)\s*$/$1/)) {
		$keytext .= $t;
		$self->Log($r, ('debug', "FetchKeysource(): Collected $s: " . XHalf($t)));
	    } else {
		$self->Log($r, ('warn', "FetchKeysource(): Missing argument: \"$1\": Can not calculate session key"));
		return undef;
	    }
	} else {
	    $self->Log($r, ('error', "FetchKeysource(): Invalid Keysource definition for $auth_name"));
	    return undef;
	}
    }

    return $keytext;
}

# Initiate a new session and return a session key.  Takes the $r request (for
# record keeping), the username, and an optional "alter list" to be used
# to change cookies and/or headers sent from the proxy to the backend server.
sub CreateSession {
    my ($self, $r, $username, $alterlist) = @_;
    (defined($alterlist)) || ($alterlist = {});
    my (%sess, $sid, $sessconfig, $kt);

    # Extract the session config
    ($sessconfig = $self->GetSessionConfig($r)) || (die "CreateSession(): Unable to get session configuration while creating new session");

    # Create a session auth key to send back to send back as the cookie
    # value, and to use the HMAC-SHA and optional session file encryptor.
    # FetchKeysource returns "" by default, resulting in a fully randomized
    # key.
    $kt = $self->FetchKeysource($r);
    if (defined($kt)) {
	$sessconfig->{key} = CreateSessionAuthKey($kt);
    } else {
	$self->Log($r, ('warn', "CreateSession(): Failed to generate session authentication key: Session creation denied"));
	return undef;
    }

    # Check for valid looking key
    unless (CheckSidFormat($sessconfig->{key})) {
	$self->Log($r, ('warn', "CreateSession(): Bad session authentication key returned!  Session creation denied"));
	return undef;
    }

    # Run against the unique session tracker if configured.  (*Don't make
    # the same session twice)
    if ($sessconfig->{Unique}) {
	unless ($self->CheckTracker($r, 'SessionUnique', $sessconfig->{key})) {
	    $self->Log($r, ('warn', "CreateSession(): SessionUnique detected duplicate session authentication key!  Session creation denied"));
	    return undef;
	}
    }

    # Wrapped this in an eval, since Apache:Session dies on failures
    eval { tie(%sess, 'Apache::AppSamurai::Session', undef, $sessconfig); };
    if ($@) {
	$self->Log($r, ('error', "CreateSession(): Unable to create new session: $@"));
	return undef;
    }
    $sid = $sess{_session_id};

    # Make sure we received a good session ID.
    (CheckSidFormat($sid)) || (($self->Log($r, ('error', 'CreateSession(): Invalid Session ID Format on new Session'))) && (return undef));
    $self->Log($r, ('notice', "LOGIN: username=\"$username\", session=\"$sid\""));

    # Store some basics
    $sess{'username'} = $username;
    $sess{'ctime'} = time();

    # Track last access time if Timeout is set
    if ($sessconfig->{Timeout}) {
	$sess{'atime'} = $sess{'ctime'};
	$sess{'Timeout'} = $sessconfig->{Timeout};
    }

    # Set hard expiration time if Expire is set
    if ($sessconfig->{Expire}) {
	$sess{'etime'} = $sess{'ctime'} + $sessconfig->{Expire};
	$sess{'Expire'} = $sessconfig->{Expire};
    }

    # Apply passback cookies to response, and pull in updated alterlist
    if (defined($alterlist->{cookie})) {
	$alterlist = $self->AlterlistPassBackCookie($alterlist, $r);
    }

    # If present, save Authorization header to detect future changes,
    # then prepend an alterlist rule to delete the header to prevent
    # pass though to the backend server.  (If needed, a separate
    # alterlist rule to add an Authorization header should be set
    # by a auth module.)
    if ($r->headers_in->{"Authorization"}) {
	$sess{'Authorization'} = $r->headers_in->{"Authorization"};
	# Stick it in front in case we have an existing add
	# header from an auth module
	unshift(@{$alterlist->{header}}, 'delete:Authorization:');
    }

    # Save current alterlist to session
    $self->AlterlistSave($alterlist, \%sess);

    # Release session
    untie(%sess);

    # Return the session auth key
    return $sessconfig->{key};
}

# Destroy a session, rendering it forever useless.  Takes a request hash ref
# and a session hash ref as args.  (Session must be tied when DestroySession
# is called.)
sub DestroySession {
    my ($self, $r, $sess) = @_;

    # Call the delete method for the the tied hash.  Wrapped in eval goodness
    # since Apache::Session will die on error.
    eval { tied(%{$sess})->delete; };
    if ($@) {
        $self->Log($r, ('warn', "DestroySession(): Unable to destroy session: $@"));
        return undef;
    }

    return 1;
}


## TRACKER - A system to store persistant and shared data for various
## uses. This is yet more code that could be refactored and busted into
## external modules to allow for adding arbitrary stateful checks of
## all sorts of things, (like the authentication handlers).
## For now, only a small set of tracker types are provided,
## and all are defined in this module.

# Get Tracker config (Tracker being a special case Session type targetted
# at IPC tasks)  The tracker should never hold sensitive data since encryption
# support is not provided!  Make sure to hash sensitive info if you need to
# track old session authentication keys or other items.
sub GetTrackerConfig {
    my ($self, $r) = @_;
    my $auth_name = ($r->auth_name()) || (die("GetTrackerConfig(): No auth name defined!\n"));
    my $dirconfig = $r->dir_config;

    my $trakconfig = {};

    # Pull in the session configurations then write the tracker config
    # over top.
    foreach (keys %{$dirconfig}) {
	(/^${auth_name}Session([\w\d]+)\s*$/) || (next);
	$trakconfig->{$1} = $dirconfig->{$_};
    }

    foreach (keys %{$dirconfig}) {
	(/^${auth_name}Tracker([\w\d]+)\s*$/) || (next);
	$trakconfig->{$1} = $dirconfig->{$_};
    }

    # Use files for storage and locking by default
    (exists($trakconfig->{Store})) || ($trakconfig->{Store} = "File");
    (exists($trakconfig->{Lock})) || ($trakconfig->{Lock} = "File");

    # Always use the basic Base64 serializer: it is portable, and avoids
    # having to special case of override when Crypt is used on sessions
    $trakconfig->{Serialize} = "Base64";

    # If files are being used, use the Session paths (if set), else die
    if ($trakconfig->{Store} eq 'File' && !exists($trakconfig->{Directory})) {
	$self->Log($r, ('error', "GetTrackerConfig(): ${auth_name}TrackerDirectoy must be defined for the File store"));
	return undef;
    }
    if ($trakconfig->{Lock} eq 'File' && !exists($trakconfig->{LockDirectory})) {
	$self->Log($r, ('error', "GetTrackerConfig(): ${auth_name}TrackerLockDirectoy must be defined for the File lock"));
	return undef;
    }

    return $trakconfig;
}

# Initiate the tracker.  Takes the $r request, a name (usually just the name of
# the module using the tracker), and returns a tied tracker hash reference.
# Currently does not support different settings for various tracker modules.
# All use the same cleanup, etc.
sub InitTracker {
    my ($self, $r, $name) = @_;
    my (%trak, $trakconfig);

    # Extract the tracker config
    ($trakconfig = $self->GetTrackerConfig($r)) || (die("InitTracker(): Unable to get tracker configuration: Please properly configure the tracker system or dissable features that use it\n"));

    # Basic sanity check on name, then set value in tracker config so the
    # Tracker module can pick it up if needed
    (($name) && ($name =~ /^[\w\d:\.\_\-]+$/)) || (die("InitTracker(): No tracker name or bad name specified for tracker\n"));
    $trakconfig->{Name} = $name;

    # Wrapped this in an eval, since Apache:Session type modules die on failure
    eval { tie(%trak, 'Apache::AppSamurai::Tracker', $name, $trakconfig); };
    if ($@) {
	$self->Log($r, ('error', "InitTracker(): Unable to setup tracker for \"$name\", retrying..."));
	# Try making a new one
	eval { tie(%trak, 'Apache::AppSamurai::Tracker', undef, $trakconfig); };
	if ($@) {
	    $self->Log($r, ('error', "InitTracker(): Unable to create new tracker for \"$name\": $@"));
	    return undef;
	}
	# Save its name inside
	$trak{Name} = $name;
	$self->Log($r, ('error', "InitTracker(): Created new tracker instance for \"$name\""));
    }

    # If cleanup is set, check if we need to run it
    if ($trakconfig->{Cleanup}) {
	# Fake last cleanup time as now, if not already set
	unless($trak{LastClean}) {
	    $trak{LastClean} = time();
	    $self->Log($r, ('debug', "InitTracker(): Set last cleanup for \"$name\" to " . $trak{LastClean}));
	}

	if ((time() - $trak{LastClean}) >= $trakconfig->{Cleanup}) {
	    $self->CleanupTracker($r, \%trak, $trakconfig->{Cleanup});
	}
    }

    # Return the open tracker hash ref
    return \%trak;
}

# Cleanup stale tracker items older than the given cleanup interval.
# Each item to clean MUST have a timestamp record in the first slot
# prefixed by "ts".
sub CleanupTracker {
    my ($self,$r,$trak,$to) = @_;
    my ($tk, $tts);
    my $time = time();

    (tied(%{$trak})) || die("CleanupTracker(): Called without valid tracker handle\n");
    ($trak->{LastClean}) || die("CleanupTracker(): Called without LastClean set for " . $trak->{Name} . "\n");

    # Default to 24 hour cleanup
    ($to) || die("CleanupTracker(): Called without Cleanup time specified for " . $trak->{Name} . "\n");

    $self->Log($r, ('debug', "CleanupTracker(): Cleaning up items in \"" . $trak->{Name} . "\" older than $to seconds"));

    foreach $tk (keys %{$trak}) {
	# Skip items with no time stamp at start of value
	next unless ($trak->{$tk} =~ /^ts(\d+)/);
	$tts = $1;
	if (($tts + $to) < $time) {
	    # Older than timeout: kill!
	    $self->Log($r, ('debug', "CleanupTracker(): Deleting stale item in \"" . $trak->{Name} . "\": $tk," . $trak->{$tk}));
	    delete($trak->{$tk});
	}
    }

    # Update the LastClean time
    $trak->{LastClean} = $time;
}

# Get ready to use tracker handle, then pass the specified tracker module
# (second arg), and pass it the rest of the arguments.  Returns 1 on sucessful
# setup and a good return from the tracker module, else 0;
sub CheckTracker {
    my $self = shift;
    my $r = shift;
    my $tmod = shift;
    my @args = @_;
    my ($tconf,$trak);
    my $ret = 0;

    # This should all be extended to use external modules instead (like the
    # authentication modules.)  I am pressed for time, so only a small set
    # of local checks are currently supported.
    if ($tmod =~ /^(IPFailures|AuthUnique|SessionUnique)$/) {
	$tmod = "CheckTracker" . $tmod;

	$self->Log($r, ('debug', "CheckTracker(): Calling $tmod"));

	unless ($trak = $self->InitTracker($r,$tmod)) {
	    $self->Log($r, ('error', "CheckTracker(): Failed to get initialized tracker handle for $tmod"));
	    return 0;
	}

	# Tracker methods currently die on major failure.  (A move to
	# object based setup, like auth system, would allow removing this
	# while maintining proper logging.)
	eval { { no strict "refs"; $ret = &$tmod($trak, @args) } };

	if ($@) {
	    $self->Log($r, ('error', "CheckTracker(): Tracker processing error: $@"));
	    untie(%{$trak});
	    return undef;
	}

	# Uncomment to get a dump of the tracker to the log
	#foreach (sort keys %{$trak}) {
	#    $self->Log($r, ('debug', "$tmod: $_ = " . $trak->{$_}));
	#}

	untie(%{$trak});
    } else {
	$self->Log($r, ('error', "CheckTracker(): Unknown tracker type $tmod"));
	$ret = 0;
    }

    return $ret;
}

# TODO - GET ALL TRACKER CHECKS AND MANAGEMENT REFACTORED TO OUTSIDE MODULES
# Check given tracker hash ($_[0]) for IP ($_[1]) hitting more than max ($_[2])
# times with no less than in interval ($_[3]) seconds between.
# Updates tracker item.
sub CheckTrackerIPFailures {
    my ($trak, $setting, $ip) = @_;
    my ($max, $interval, $tc, $tts);
    my $time = time();

    ($max,$interval) = split(':', $setting);
    unless (($max) && ($max =~ /^\d+$/) && ($interval) && ($interval =~ /^\d+$/)) {
	die("CheckTrackerIPFailures(): FATAL: Bad arguments to IPFailures: \"$setting\"\n");
    }

    ($ip = CheckHostIP($ip)) || (die("CheckTrackerIPFailures(): FATAL: Bad IP address\n"));

    # Force defaults of 10 failures in 1 minute or less intervals.
    ($max) || ($max = 10);
    ($interval) || ($interval = 60);

    # If defined and not timed out: add. Else starts fresh
    if ($trak->{$ip}) {
	($tts, $tc) = split(':', $trak->{$ip}, 2);

	# Sanity check, and pull actual numbers
	(($tts =~ s/^ts(\d+)$/$1/) && ($tc =~ s/^cnt(\d+)$/$1/)) || (die("CheckTrackerIPFailures(): FATAL: Corrupt entry for $ip detected\n"));

	# Not yet timed out
	if (($tts + $interval) > $time) {
	    $tc++;
	    $tts = $time;

	    $trak->{$ip} = join(':', "ts$tts", "cnt$tc");

	    if ($tc >= $max) {
	        die("CheckTrackerIPFailures(): RULE VIOLATION: ip=$ip, count=$tc\n");
	    }

	    return 1;
	}
    }

    # Expired or New entry: Set timestamp to now and count to 1
    $trak->{$ip} = join(':', "ts$time", "cnt1");

    return 1;
}

# Check given tracker hash ($_[0]), make sure we have not seen the same
# set of credentials ($_[1] - $_[n-1]) before.  Stores a hash of credential
# string to minimize security risk.
sub CheckTrackerAuthUnique {
    my $trak = shift;
    my $ch = HashAny(@_);
    my $time = time();

    # If defined, the jig is up!
    if ($trak->{$ch}) {
	die("CheckTrackerAuthUnique(): RULE VIOLATION: credkey=$ch\n");
    } else {
	# Set value to
	$trak->{$ch} = 'ts' . $time . ":cnt1";
    }

    return 1;
}

# Check given tracker hash ($_[0]), make sure we have not seen the same
# session authentication key (cookie) before.  Stores a hash of session key
# string to minimize security risk.
sub CheckTrackerSessionUnique {
    my $trak = shift;
    my $ch = HashAny(@_);
    my $time = time();

    # If defined, the jig is up!
    if ($trak->{$ch}) {
	die("CheckTrackerSessionUnique(): RULE VIOLATION: sesskey=$ch\n");
    } else {
	# Set value to
	$trak->{$ch} = 'ts' . $time . ":cnt1";
    }

    return 1;
}

# Check the last access time stamp, and update if needed, for a given session.
# Does NOT update the time if a fixed timeout has been set.
# Returns undef if the atime is more than the session's timeout age
# or if etime is set and is over the session's expire age.
sub CheckTime {
    my ($self, $sess) = @_;
    my $time = time();
    my $tdiff;
    my $ret = undef;

    # All sessions require at least a floating or fixed timeout!
    ($sess->{atime} || $sess->{etime}) or return undef;

    # Check the hard timeout first, if it exists.
    # This short circuits further checking since the hard timeout is king!
    if ($sess->{etime}) {
	if ($time >= $sess->{etime}) {
	    return undef;
	} else {
	    $ret = $sess->{etime};
	}
    }

    if ($sess->{atime}) {
	$tdiff = $time - $sess->{atime};
	if ($tdiff < $sess->{Timeout}) {
	    # We are still valid.  Update the time if we are over 60 seconds
	    # stale.
	    if ($tdiff >= 60) {
		$sess->{atime} = $time;
	    }
	    $ret = $sess->{atime};
	} else {
	    return undef;
	}
    }

    return $ret;
}


# The Alterlist functions manipulate and apply a list of transforms to apply to
# the headers and cookies of the client request before sending the request
# through to the backend server.  $self->{alterlist} is a hash containing
# one or more of the following container arrays:
#
# header
# ------
# @{$self->{alterlist}->{header}} - One or more header transforms, with the
#  syntax:
#                  ACTION:NAME:VALUE
#  ACTION - add, replace, or delete
#  NAME - Header name (or regex match for delete)
#  VALUE - New value of header for add or replace, else optional regex filter
#          for delete  (Prefix pattern with ! for negation)
#
# cookie
# ------
# @{$self->{alterlist}->{cookie}} - One or more cookie transforms, with the
#  syntax:
#                  ACTION:NAME:VALUE
#  ACTION - add, replace, delete, or passback
#  NAME - Cookie name (or regex match for delete)
#  VALUE - New value of cookie, or regex filter for delete action (Prefix
#          pattern with ! for negation)
#
# Note - delete rules with optional value match pattern will delete only values
#        of a multi-value cookie that match the value pattern
#
# The special "passback" action passes cookies back to the web browser on
# login, This allows us to gather cookies from backend servers on login, but
# have the web browser maintain them.
#
# More containers can be added without modifying the generic functions.

# Load Alterlist rules from session and return a ref to the loaded alterlist
sub AlterlistLoad {
    my ($self, $sess) = @_;
    my ($sk,$rk);
    my $alterlist = {};

    # All alterlist save value start with al-
    foreach $sk (keys %{$sess}) {
	($sk =~ /^al\-([\w]+)$/) || (next);
	$rk = $1;
	@{$alterlist->{$rk}} = split("\n", $sess->{$sk});
    }

    return $alterlist;
}

# Update current alterlist with given alterlist hash ref
sub AlterlistMod {
    my ($self, $alterlist, $alm) = @_;
    my $rk;

    (defined($alterlist)) || ($alterlist = {});

    # Update alterlist from $alm hash ref
    foreach $rk (keys %{$alm}) {
	foreach (@{$alm->{$rk}}) {
	    push(@{$alterlist->{$rk}}, $_);
	}
    }

    # Modifications made directly, but return the ref in case
    return $alterlist;
}

# Save existing alterlist to given session
sub AlterlistSave {
    my ($self, $alterlist, $sess) = @_;
    my ($sk,$rk);

    # Save alterlist to session in \n deliminated form.
    if (defined($alterlist) && scalar(keys %{$alterlist})) {
	foreach $rk (keys %{$alterlist}) {
	    $sk = "al-" . $rk;
	    $sess->{$sk} = join("\n", @{$alterlist->{$rk}});
	}
    }

    return $alterlist;
}

# Apply current alterlist rules to request (just calls sub methods in order)
sub AlterlistApply {
    my ($self, $alterlist, $r) = @_;
    my $status = 1;
    (defined($alterlist)) || (return 0);

    if (defined($alterlist->{header})) {
	# Run through headers (saving off alter count)
	$self->AlterlistApplyHeader($alterlist, $r);
	$self->Log($r, ('debug', "AlterlistApply(): Applied alterlist for header"));
    }

    if (defined($alterlist->{cookie})) {
	# Run through cookies (saving off alter count)
	$self->AlterlistApplyCookie($alterlist, $r);
	$self->Log($r, ('debug', "AlterlistApply(): Applied alterlist for cookie"));
    }

    return $alterlist;
}

# Apply alterlist rules to request headers.
sub AlterlistApplyHeader {
    my ($self, $alterlist, $r) = @_;
    (defined($alterlist->{header})) || (return 0);
    my ($t, $h, $hl, $act, $key, $val, $tk, $tv);

    # Extract current header hash and build \n deliminated lookup string
    # to fast match against
    $h = $r->headers_in;
    $hl = "\n" . join("\n", keys(%{$h})) . "\n";

    # Cycle through all header transforms
    foreach $t (@{$alterlist->{header}}) {
	($t =~ /^(add|replace|rep|delete|del):([\w\d\-]+):(.*?)$/i) || (($self->Log($r, ('debug', "AlterlistApplyHeader(): Skipping illegal header transform \"$t\""))) && (next));
	$act = $1;
	$key = $2;
	$val = $3;

	if ($act =~ /^add$/) {
	    # Blindly clear then add the header
	    $r->headers_in->unset($key);
	    $r->headers_in->add($key => $val);

            # Log obscured value
	    $self->Log($r, ('debug', "HEADER ADD: $key: " . XHalf($val)));
	} else {
	    # Replace and delete allow for regex header name matches
	    while ($hl =~ /($key)/igm) {
		# Update
		$tk = $1;
		# Make sure header was not deleted
		($r->headers_in->{$tk}) || (next);
		if ($act =~ /^replace|rep$/) {
		    # Blindly delete then add the header
		    # Save old value for log
		    $tv =  $r->headers_in->{$tk};
		    $r->headers_in->unset($tk);
		    $r->headers_in->add($tk => $val);

		    # Log obscured values
		    $self->Log($r, 'debug', ("AlterlistApplyHeader(): HEADER REPLACE: $tk: " . XHalf($tv) . " -> " . XHalf($val)));

		} elsif ($act =~ /^delete|del$/) {
		    # Check for extra content match
		    if ($val) {
			$tv = $r->headers_in->{$tk};
			# Handle negation
			if ($val =~ s/^\!//) {
			    ($tv =~ /($val)/is) && (next);
			} else {
			    ($tv =~ /($val)/is) || (next);
			}
		    }

		    # Kill!
		    $r->headers_in->unset($tk);

		    # Log obscured value
		    $self->Log($r, ('debug', "AlterlistApplyHeader(): HEADER DELETE: $tk: " . XHalf($tv)));
		}
	    }
	}
    }

    return $alterlist;
}


# Apply alterlist rules to request cookies.
# Note - Does not handle "passback" cookie.  Use AlterlistPassBackCookie() to
# retrieve and clear passback cookies)
sub AlterlistApplyCookie {
    my ($self, $alterlist, $r) = @_;

    (defined($alterlist->{cookie})) || (return 0);
    my ($t, %c, $cl, $act, $key, $val, $tk, $tv, @ta, @td);
    my $alterred = 0;

    # Grab any cookies any put into a hash of CGI::Cookies, or just make an
    # empty cookie hash for now.
    %c = CGI::Cookie->fetch($r);
    (%c) || (%c = ());
    # Build \n deliminated lookup string to fast match against
    $cl = "\n" . join("\n", keys(%c)) . "\n";

    foreach $t (@{$alterlist->{cookie}}) {
	# Note - : or = allowed between NAME and VALUE to make life easier
	($t =~ /^(add|replace|rep|delete|del|passback|set):([\w\d\-]+)(?:\:|\=)(.*?)$/i) || (($self->Log($r, ('debug', "AlterlistApplyCookie(): Skipping illegal cookie transform \"$t\""))) && (next));
	$act = $1;
	$key = $2;
	$val = $3;

	if ($act =~ /^passback|set$/) {
	    # passback not handled in this method
	    next;
	} elsif ($act =~ /^add$/) {
	    # Blindly add the cookie
	    @ta = split('&', $val);
	    # Add a new CGI::Cookie to the hash
	    $c{$key} = new CGI::Cookie(-name => $key, -value => \@ta);

	    # Log obscured value
	    $self->Log($r, ('debug', "AlterlistApplyCookie(): COOKIE ADD: $key=" . XHalf($val)));
	    $alterred++;
	} else {
	    # Replace and delete allow for regex cookie name matches
	    while ($cl =~ /($key)/igm) {
		# Update
		$tk = $1;
		if ($act =~ /^replace|rep$/) {
		    # Blindly delete then add the cookie back with new value
		    # Save old value for log
		    $tv = join('&', $c{$tk}->value);;
		    delete($c{$tk});
		    @ta = split('&', $val);
		    $c{$tk} = new CGI::Cookie(-name => $tk, -value => \@ta);

		    # Log obscured values
		    $self->Log($r, ('debug', "AlterlistApplyCookie(): COOKIE REPLACE: $tk: " . XHalf($tv) . " -> " . XHalf($val)));
		    $alterred++;
		} elsif ($act =~ /^delete|del$/) {
		    # Check for extra content match
		    if ($val) {
			@ta = ();
			@td = ();
			# Cycle through multi-values
			foreach $tv ($c{$tk}->value) {
			    # Handle negation
			    if ($val =~ s/^\!//) {
				# Save value and continue
				if ($tv =~ /($val)/is) {
				    push(@ta, $tv);
				    next;
				}
			    } else {
				# Save value and continue
				unless ($tv =~ /($val)/is) {
				    push(@ta, $tv);
				    next;
				}
			    }
			    # Fell through, so this value is history/unsaved
			    push(@td, $tv);
			    $alterred++;
			}
			# Kill!
			if (scalar @ta) {
			    # Some values left not deleted, so set those back
			    $c{$tk}->value(\@ta);
			    $tv = join('&', @td);

			    # Log obscured value
			    $self->Log($r, ('debug', "AlterlistApplyCookie(): COOKIE DELETE PARTIAL: $tk=" . XHalf($tv)));
			} else {
			    # Nothing left inside. KILL!
			    delete($c{$tk});
			    $tv = join('&', @td);

			    # Obscure values for logging
			    $tv =~ s/([^X])[\w\d]/${1}X/gs;
			    $self->Log($r, ('debug', "AlterlistApplyCookie(): COOKIE DELETE FULL: $tk=$tv"));
			}
		    } else {
			# Kill Em All
			$tv = $c{$key}->value;
			delete($c{$key});

                        # Obscure values for logging
			$tv =~ s/([^X])[\w\d]/${1}X/gs;
			$self->Log($r, ('debug', "AlterlistApplyCookie(): COOKIE DELETE FULL: $key=$tv"));

			$alterred++;
		    }
		}
	    }
	}
    }

    # Unset, then add cookies to header if changes were made
    if ($alterred) {
	$r->headers_in->unset('Cookie');
	$t = '';
	foreach $tk (keys %c) {
	    # Cookie to list in string form.
	    $t .= $c{$tk}->name . "=" . join('&', $c{$tk}->value) . "; ";
	}
	# Kill trailing '; '
	$t =~ s/\; $//s;
	# Ship it
	$r->headers_in->add('Cookie' => $t);
    }

    return $alterlist;
}

# Add a Set-cookie: header to r for all alterlist "passback" cookies and return
# a modified alterlist with the passback cookie values cleared and expired.
#
# Unlike normal alterlist rules, passback cookies are sent BACK to the client.
# The only time this can occur is upon login/redirect. The purpose of passback
# cookies is to set the same cookies in the browser as they would have set
# if they were connecting directly to the backend server(s).
#
# The return should be used to update the alterlist.  When
# AlterlistPassBackCookie is applied again, it will UNSET the passback cookies.
# This should be done on logout.
sub AlterlistPassBackCookie() {
    my ($self, $alterlist, $r) = @_;

    (defined($alterlist->{cookie})) || (return 0);
    my ($t, $key, $val, $opt, $tdomain, $tpath, $texpire);
    my @ct = ();
    my %c = ();

    foreach $t (@{$alterlist->{cookie}}) {
	# Note - : or = allowed between NAME and VALUE to make life easier
	($t =~ /^(passback|set):([\w\d\-]+)(?:\:|\=)([^;]*)(;.*)?$/i) || ((push(@ct, $t)) && (next));
	$key = $2;
	$val = $3;
	$opt = $4;
	$tdomain = $tpath = $texpire = '';

	# Unlike AlterlistApplyCookie which just needs to parse name and
	# value, the PassBack cookies are Set-Cookie items which may
	# have options.  Also, only process the last cookie value if
	# a multi-value cookie is passed

	# Add a new CGI::Cookie to the hash
	$c{$key} = new CGI::Cookie(-name => $key,
				   -value => $val,
				   );
	# Set further options (only Expires and Path currently passed through)
	foreach $t (split(';', $opt)) {
	    if ($t =~ /^\s*expires=([\w\d \:\;\-,]+)\s*$/) {
		$c{$key}->expires($1);
	    } elsif ($t =~ /^\s*path=(\/.*?)\s*$/) {
                $c{$key}->path($1);
            }
	}

	# Set other options to match session cookie values (could be made a
	# configurable, and allow for maintaining the original options from the
	# cookie.  I don't see a need.)
	my $auth_name = $r->auth_name;

	if ($r->dir_config("${auth_name}Domain")) {
	    $c{$key}->domain($r->dir_config("${auth_name}Domain"));
	}
	if (!$r->dir_config("${auth_name}Secure") || ($r->dir_config("${auth_name}Secure") == 1)) {
	    $c{$key}->secure(1);
	}

	$r->err_headers_out->add('Set-Cookie' => $c{$key});

	# Clean up and log
	$t = $c{$key};
	$t =~ /($key\s*\=\s*)(.*?)(;|$)/;
	$self->Log($r, ('debug', "AlterlistPassBackCookie(): COOKIE PASSBACK: " . $1 . XHalf($2) . $3));

	# Save an empty/expired cookie so next call to AlterlistPassBackCookie
	# with this alterlist will unset the cookie
	$c{$key}->value('');
	$c{$key}->expires('Thu, 1-Jan-1970 00:00:00 GMT');
	push(@ct, "passback:" . $c{$key});
    }

    # Save updated cookie array
    @{$alterlist->{cookie}} = @ct;

    return $alterlist;
}


# Append an error code to the list of query args in a given URL.  (Used to
# pass friendly error messages to users in external redirects.  (Note that
# AuthCookie used subprocess_env() to pass that info, but since that will only
# work in the same main request, it won't pass into an external redirect.)
sub URLErrorCode {
    my $self = shift;
    my $uri = (shift) || (return undef);
    my $ecode = (shift) || ('');

    ($uri = new URI($uri)) || (return undef);

    # Error codes must contain only letters, numbers, and/or _ chars.
    # Your login.pl script should read them in CAREFULLY and make sure
    # they follow this format.
    ($ecode =~ /^([\w\d_]+)$/) || (return undef);

    # Add the error code and return the URI in string form
    $uri->query_form($uri->query_form, 'ASERRCODE' => $ecode);
    return $uri->as_string;
}

# Log to configured log.  Always takes the request as the 1st arg.  Can
# take either a loglevel and a message as args 2 and 3, or an array
# of loglevel and message arrays as the 2nd arg.
sub Log {
    my $self = shift;
    my $r = shift;
    my $la = [];
    my $debug = $self->_debug($r);

    # Check if being called with a level and message, or with a log array
    if (ref($_[0]) eq "ARRAY") {
	$la = $_[0];
	(defined(@{$la}) && (scalar @{$la})) || (return 0);
    } else {
	(defined($_[0]) && defined($_[1])) || (return 0);
	# Set to a single child array of arrays
	$la = [[$_[0], $_[1]]];
    }

    # Collect a few tidbits (package name, client IP and URI?args)
    my $auth_name = ($r->auth_name || "");
    $auth_name .= ': ';
    my $info = '
    if ($MP eq 1) {
        $info .= ($r->get_remote_host || "");
    } else {
        $info .= ($r->connection->get_remote_host || "");
    }
    $info .= ', uri="';
    $info .= ($r->uri() || "");
    (defined($r->args())) && ($info .= '?' . $r->args());
    $info .= '">';

    # Get the log handle for the server
    my $log = $r->server->log;
    my $defaultlevel = 'error';
    my ($li, $level, $line);

    # Cycle through the log entries
    foreach $li (@{$la}) {
	if (scalar(@{$li}) == 2) { # 2 argument form with level and line
	    $level = $li->[0];
	    ($level) || ($level = $defaultlevel);
	    ($level =~ s/^(emerg|alert|crit|error|warn|notice|info|debug)$/$1/i) || (return 0);
	    $level = lc($level);
	    # Skip debug unless debug is enabled
	    next if (!$debug && ($level eq 'debug'));
	    $line = $auth_name . $li->[1] . $info;
	} elsif (scalar(@{$li}) == 1) { # 1 argument form: must add a level
	    $level = $defaultlevel;
	    $line = $auth_name . $li->[0] . $info;
	} else { # Who knows form: must hit someone's fingers with a hammer
	    return 0;
	}

	# Check log line, then ship it.
	$line = $self->FilterLogLine($line);
	$log->$level($line);
    }

    return 1;
}

# Check debug setting
sub _debug {
    my $self = shift;
    my $r = shift;
    my $debug = 0;
    if ($r->auth_name) {
	my $auth_name = $r->auth_name;
	if ($r->dir_config("${auth_name}Debug")) {
	    ($r->dir_config("${auth_name}Debug") =~ /^(\d+)$/) && ($debug = $1);
	}
    }

    return $debug;
}

# Filter the output line before logging.  Restricts to no more than CharMax
# characters and converts everything matching BlankChars to a space to
# try and protect logging systems and log monitors from attack.
sub FilterLogLine {
    my $self = shift;
    my $line = (shift || return undef);
    my $LogCharMax = 1024;

    # Strip surrounding whitespace
    $line =~ s/^\s*(.+?)\s*$/$1/s;
    # Convert newlines to ', '
    $line =~ s/\r?\n/, /sg;
    # Check length and truncate if needed
    $line = substr($line, 0, $LogCharMax);
    # Convert BlankChars matches to blanks
    $line =~ s/[\x00-\x08\x0b\x0c\x0e-\x1f\x7f\'\\]+/ /g;

    return $line;
}

1; # End of Apache::AppSamurai

__END__