view release on metacpan or  search on metacpan

lib/Apache/AppSamurai.pm  view on Meta::CPAN

    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;

lib/Apache/AppSamurai.pm  view on Meta::CPAN

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 = ' <client=';
    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 .= '">';