File Coverage

blib/lib/Apache/iNcom.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

#
#    iNcom.pm - Main module of the iNcom package.
#
#    This file is part of Apache::iNcom
#
#    Author: Francis J. Lacoste
#
#    Copyright (C) 1999 Francis J. Lacoste, iNsu Innovations
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License as published by
#    the Free Software Foundation; either version 2 of the License, or
#    (at your option) any later version.
#
#    This program is distributed in the hope that it will be useful,
#    but WITHOUT ANY WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#    GNU General Public License for more details.
#
#    You should have received a copy of the GNU General Public License
#    along with this program; if not, write to the Free Software
#    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
package Apache::iNcom;

use strict;

require 5.005;

use DBI;

use Apache;
use Apache::Log;
use Apache::Cookie;
use Apache::Request;
use Apache::File;
use Apache::Constants qw( :common :response HTTP_PRECONDITION_FAILED );

use HTML::Embperl;

use Apache::iNcom::Request;
use Apache::iNcom::Localizer;

use vars qw($VERSION);
BEGIN {
    ($VERSION) = '0.09';
}

my %VALID_PNOTES = map { $_ => 1 } qw (
    INCOM_SESSION INCOM_DBH INCOM_LOCALIZER INCOM_COOKIES
);

# Grabbed from CGI.pm by Lincoln Stein
sub offset_calc {
    my($time) = @_;
    my(%mult) = ('s'=>1,
                 'm'=>60,
                 'h'=>60*60,
                 'd'=>60*60*24,
                 'M'=>60*60*24*30,
                 'y'=>60*60*24*365);
    # format for time can be in any of the forms...
    # "now" -- expire immediately
    # "+180s" -- in 180 seconds
    # "+2m" -- in 2 minutes
    # "+12h" -- in 12 hours
    # "+1d"  -- in 1 day
    # "+3M"  -- in 3 months
    # "+2y"  -- in 2 years
    # "-3m"  -- 3 minutes ago(!)
    my($offset);
    if (!$time || (lc($time) eq 'now')) {
        $offset = 0;
    } elsif ($time=~/^([+-]?(?:\d+|\d*\.\d*))([mhdMy]?)/) {
        $offset = ($mult{$2} || 1)*$1;
    } else {
	die "invalid expiration offset: $time\n";
    }
    return ($offset);
}

sub db_init {
    my $r = shift;
    my $dsn	= $r->dir_config( "INCOM_DBI_DSN" );
    my $user	= $r->dir_config( "INCOM_DBI_USER" );
    my $passwd	= $r->dir_config( "INCOM_DBI_PASSWD" );

    unless ( $dsn ) {
	$r->log_error( "iNcom configuration error: INCOM_DBI_DSN is not defined" );
	return SERVER_ERROR;
    }

    my $dbh;
    eval {
	$dbh = DBI->connect( $dsn, $user, $passwd, { RaiseError => 1,
						     AutoCommit => 0,
						   } );
	my $trace_lvl  = $r->dir_config( "INCOM_DBI_TRACE" );
	my $trace_file = $r->dir_config( "INCOM_DBI_LOG"   );

	# Turn tracing on if requested
	if ( $trace_lvl ) {
	    $trace_file = $r->server_root_relative( $trace_file )
	      if defined $trace_file;
	    $dbh->trace( $trace_lvl, $trace_file );
	}

	# Saves it in the request record for access from
	# other handlers
	$r->pnotes( INCOM_DBH => $dbh );

    };
    if ($@ ) {
	$r->log_error( "error opening connection to database: $@" );
	return return_error( $r, SERVER_ERROR );
    }
    return OK;
}

sub i18n_init {
    my $r = shift;

    my $langs = $r->header_in( "Accept-Language" );
    my @languages;
    if ( $langs ) {
	my $q = 100;
	@languages = map {
	    $_->[0];
	} sort { $b->[1] <=> $a->[1] } map {
	    my $l;
	    if ( /([-\w]+)\s*;\s*q=([\d.]+)/ ) {
		$l = [$1, $2 ];
	    } else {
		$l = [$_, $q--];
	    }
	} split /\s*,\s*/, $langs;
    }

    # Add the language set in cookies
    my $cookies = $r->pnotes( "INCOM_COOKIES" );
    unshift @languages, $cookies->{INCOM_LANGUAGE}->value
      if $cookies->{INCOM_LANGUAGE};

    # Check each languages tags for validity
    my $localizer =
      new Apache::iNcom::Localizer( $r->dir_config( "INCOM_DEFAULT_LANGUAGE" ) || "en",
				    @languages
				  );

    # Set environment variables so that other parts of the system
    # does hopefully the Right Things(tm)
    $ENV{LANG} = $localizer->preferred_lang;

    # Long live GNU !
    $ENV{LANGUAGE} = join ":", $localizer->preferred_langs,
      $localizer->default_lang;

    # Cache it for further use.
    $r->pnotes( "INCOM_LOCALIZER", $localizer );

    return OK;
}

*Apache::iNcom::handler = \&request_init;

sub request_init {
    my $r = shift;

    # If we are in a subrequest, just copy
    # what was initialized to the new request
    if ( $r->is_main ) {
	my $prefix	    = $r->dir_config( "INCOM_URL_PREFIX" ) || "/";
	unless ( $prefix =~ m|/$| ) {
	    $r->log_error( "iNcom configuration error: INCOM_URL_PREFIX must ends with /" );
	    return SERVER_ERROR;
	}

	# Parse cookies
	my $c = $r->header_in( "Cookie" );
	my $cookies = Apache::Cookie->new( $r )->parse( $c );
	$r->pnotes( "INCOM_COOKIES", $cookies );

	# Parse languages
	my $rv = i18n_init( $r );
	return $rv if $rv != OK;

    } else {
	my $prev = $r->prev;
	foreach my $name ( keys %VALID_PNOTES ) {
	    $r->pnotes( $name, $prev->pnotes( $name ) );
	}
	return OK;
    }

    # Next handler is dispatch_handler
    $r->push_handlers( PerlTransHandler => \&dispatch_handler );

    return OK;
}

sub bake_session_cookie {
    my ($r, $session_id) = @_;

    my $prefix		= $r->dir_config( "INCOM_URL_PREFIX" ) || "/";
    my $session_secure  = $r->dir_config( "INCOM_SESSION_SECURE" );
    my $session_domain  = $r->dir_config( "INCOM_SESSION_DOMAIN" );
    my $session_expires = $r->dir_config( "INCOM_SESSION_EXPIRES" );
    my $session_path    = $r->dir_config( "INCOM_SESSION_PATH" )
      || $prefix;

    my $cookie = new Apache::Cookie( $r,
				     -name   => "INCOM_SESSION",
				     -value  => $session_id,
				     -path   => $session_path
				   );
    $cookie->domain( $session_domain )	    if $session_domain;
    $cookie->expires( $session_expires )    if $session_expires;
    $cookie->secure( 1 )		    if $session_secure;

    # Add cookie to outgoing headers
    $cookie->bake;
}

sub session_init {
    my $r = shift;

    my %session;

    # Check if there is a session id in the cookies
    my $cookies = $r->pnotes( "INCOM_COOKIES" );
    if ( $cookies->{INCOM_SESSION} ) {
	my $session_id = $cookies->{INCOM_SESSION}->value;

	# Load the user's session
	eval {
	    # Make sure it looks like a session id
	    die "Invalid session id: $session_id\n"
	      unless length $session_id == 32 &&
		$session_id =~ tr/a-fA-F0-9/a-fA-F0-9/ == 32;

	    tie %session, 'Apache::iNcom::Session', $session_id,
	      { dbh => $r->pnotes( "INCOM_DBH"),
		Serialize => $r->dir_config( "INCOM_SESSION_SERIALIZE_ACCESS" ),
	      };

	    # Save the session for future handlers
	    $r->pnotes( INCOM_SESSION => \%session );

	    if ( $r->dir_config( "INCOM_SESSION_EXPIRES" ) ) {
		# If session doesn't expire with the browser session
		# we must renew the cookie.
		bake_session_cookie( $r, $session_id );
	    }

	};
	if ( $@ ) {
	    # The session ID is probably invalid
	    chomp $@;
	    $r->warn( "error loading session: $@" );
	} else {
	    # Return ref to session to indicate success
	    return \%session;
	}
    }

    # No valid session could be loaded
    return undef;
}


# Return the requested error code but sets a custom response
# if the error condition is present in the error map.
sub return_error {
    my ( $r, $status ) = @_;

    my $prefix = $r->dir_config( "INCOM_URL_PREFIX" ) || "/";
    my $map = $r->dir_config( "INCOM_ERROR_PROFILE" );
    return $status unless $map;

    $map = $r->server_root_relative( $map );
    unless ( -e $map && -f _ && -r _ ) {
	$r->warn( "INCOM_ERROR_PROFILE is not valid" );
	return $status;
    }

    my $response = eval {
	my $profile = do $map;
	unless ( ref $profile eq "HASH" ) {
	    $r->warn( "INCOM_ERROR_PROFILE didn't return an hash ref" );
	    return $status;
	}

	my $error_cond = $r->pnotes( "INCOM_ERROR" );

	$profile->{$error_cond} || $profile->{$status};
    };
    if ( $@) {
	$r->warn( "error while evaluating error profile: $@" );
	return $status;
    }

    $r->custom_response( $status, $prefix . "/incom_error/" . $response ) if $response;

    return $status;
}

# This is a handler used to transform the request
# to an action. It is invoked during the URI
# translation phase of the request
#
# It is responsible for loading the user session. If
# there is no session it sets the content handler to
# the new_session_handler
sub dispatch_handler {
    my $r = shift;

    # Get configuration
    my $prefix	    = $r->dir_config( "INCOM_URL_PREFIX" ) || "/";
    my $index_file  = $r->dir_config( "INCOM_INDEX" )  || "index.html";
    my $incom_root  = $r->dir_config( "INCOM_ROOT" )
      || $r->document_root;
    $incom_root = $r->server_root_relative( $incom_root );

    my $uri = $r->uri;

    # Decline to handle this unless the request URI match our prefix
    return DECLINED unless $uri =~ s!^$prefix/*!!;

    # Only support GET or POST
    return NOT_IMPLEMENTED unless $r->method =~ /^(GET|POST)$/;

    if ( $r->is_main ) {
	# On the first request, we open the connection to the database
	# and loads the user session
	my $rc      = db_init( $r );
	session_init( $r );

	# To clean DB connection and Session
	$r->push_handlers( PerlCleanupHandler => \&request_cleanup );
    }

    # Determine the handler
    if ( $uri =~ s!^incom_cookie_check/!! ) {
	# Check if the session was loaded properly
	if ( ref $r->pnotes( "INCOM_SESSION") ) {
	    # Cookie test suceeded. Tell browser to refetch
	    # original file
	    $r->pnotes( "INCOM_REDIRECT_TO", $prefix . $uri );
	    $r->push_handlers( PerlHandler => \&redirect_handler );
	    $r->handler( "perl-script" );
	} else {
	    # Cookie test failed
	    $r->pnotes( "INCOM_ERROR", "no_cookies" );
	    return return_error( $r, HTTP_PRECONDITION_FAILED );
	}
    } elsif ( $uri =~ s!^incom_set_lang/([-\w]+)/!! ) {
	$r->pnotes( "INCOM_NEW_LANG", "$1" );
	$r->pnotes( "INCOM_REDIRECT_TO", $prefix . $uri );

	$r->push_handlers( PerlHandler => \&set_lang_handler );
	$r->handler( "perl-script" );

    # incom_error magic URL should only be called as a subrequest.
    } elsif ( (!$r->main) && $uri =~ s!^incom_error/!! ) {

	$incom_root = $r->dir_config( "INCOM_ERROR_ROOT" ) || $incom_root;
	$incom_root = $r->server_root_relative( $incom_root );

	$r->push_handlers( PerlHandler => \&error_handler );
	$r->handler( "perl-script" );

    } elsif ( not ref $r->pnotes( "INCOM_SESSION" ) ) {

	# The user doesn't belong to an existing session
	$r->push_handlers( PerlHandler => \&new_session_handler );
	$r->handler( "perl-script" );
    } else {

	# Default handler
	$r->push_handlers( PerlHandler => \&default_handler );
	$r->handler( "perl-script" );
    }

    # Set the filename
    $uri ||= $index_file;

    # Handle directory index
    $uri =~ s!/$!/$index_file!;

    # Find the properly localized file
    my $localizer = $r->pnotes( "INCOM_LOCALIZER" );
    my $file = $localizer->find_localized_file( $incom_root . "/" . $uri );

    # Set filename of the request
    $r->filename(  $file  );

    # Request should never be cached
    $r->header_out( 'Pragma',	     'no-cache' );
    $r->header_out( 'Cache-control', 'no-cache' );
    $r->no_cache(1);

    # Default content-type
    $r->content_type( "text/html" );

    return OK;
}

# Content handler invoked when the request is not
# part of a session.
#
# It creates a new session.  Sets a cookie to it
# and redirect the user to resubmit the request
# to a rewritten URL.
sub new_session_handler {
    my $r = shift;

    my %session;
    eval {
	tie %session, 'Apache::iNcom::Session', undef,
	  { dbh => $r->pnotes( "INCOM_DBH"),
	    Serialize => $r->dir_config( "INCOM_SESSION_SERIALIZE_ACCESS" ),
	  };

	bake_session_cookie( $r, $session{_session_id} );
    };
    if ($@) {
	$r->log_error( "error creating session: $@" );
	return return_error( $r, SERVER_ERROR );
    }

    # Tell the browser to repost its request. We will then be
    # able to check if he has cookie turn on
    my $prefix	= $r->dir_config( "INCOM_URL_PREFIX" ) || "/";
    my $uri	= $r->uri;
    $uri =~ s!^$prefix/*!${prefix}incom_cookie_check/!;

    $r->content_type( "text/html" );
    $r->header_out( Location => $uri );

    return REDIRECT;
}

sub redirect_handler {
    my $r = shift;

    $r->content_type( "text/html" );
    $r->header_out( Location => $r->pnotes( "INCOM_REDIRECT_TO" ) );

    return REDIRECT;
}

sub set_lang_handler {
    my $r = shift;

    my $prefix	    = $r->dir_config( "INCOM_URL_PREFIX" ) || "/";
    my $session_domain  = $r->dir_config( "INCOM_SESSION_DOMAIN" );
    my $session_path    = $r->dir_config( "INCOM_SESSION_PATH" )
      || $prefix;
    my $session_expires = $r->dir_config( "INCOM_SESSION_EXPIRES" );

    # Create a cookie which has the same lifespan than
    # the session cookie.
    my $cookie = new Apache::Cookie( $r,
				     -name  => "INCOM_LANGUAGE",
				     -value => $r->pnotes( "INCOM_NEW_LANG" ),
				     -path  => $session_path,
				   );
    $cookie->domain( $session_domain )	    if $session_domain;
    $cookie->expires( $session_expires )    if $session_expires;

    # Add cookie to outgoing headers
    $cookie->bake;

    # Tell the browser to repost its request. The next
    # request will favorise the new language.
    $r->content_type( "text/html" );
    $r->header_out( Location => $r->pnotes( "INCOM_REDIRECT_TO" ) );

    return REDIRECT;
}

sub package_name {
    my $r    = shift;
    my $file = shift;

    my $host = $r->server->server_hostname;
    my $root = $r->dir_config( "INCOM_ROOT" ) || $r->document_root;
    $root = $r->server_root_relative( $root );

    # Remove document root
    $file =~ s!^$root/!!;

    # Remove trailing suffixes of the last component
    # of the path name
    $file =~ s!\.[^/]*$!!;

    # Munge invalid character
    $file =~ tr/a-zA-Z0-9/_/cs;

    # Munge invalid character in hostname
    $host =~ tr/a-zA-Z0-9/_/cs;

    return  "Apache::iNcom::" . $host . "::" . $file;
}

sub error_handler {
    my $r = shift;

    my $filename    = $r->filename;

    unless ( -e $r->finfo ) {
	$r->log_reason( "nonexistent file", $filename );
	return NOT_FOUND;
    }

    unless ( -f _ ) {
	$r->log_reason( "not a regular file", $filename );
	return FORBIDDEN;
    }

    unless ( -r _ ) {
	$r->log_reason( "No permissions to read", $filename );
	return FORBIDDEN;
    }

    # Determine the package name of this error page
    # Package is Apache::iNcom::basename of the page
    my $package = package_name( $r, $filename );
    my $req	= new Apache::iNcom::Request( $r, $package );
    # Play magic
    $req->setup_aliases;

    # Send the response
    my $output;
    $r->content_type( "text/html" );

    my $debug = $r->dir_config( "EMBPERL_DEBUG" ) || $ENV{EMBPERL_DEBUG} || 0;
    my $options = $r->dir_config( "EMBPERL_OPTIONS" ) ||
      $ENV{EMBPERL_OPTIONS} || 16; # Default = optRawInput
    # optDisableFormData,optReturnError
    $options |= 256 | 262144;

    my $params = {
		  package   => $package,
		  output    => \$output,
		  inputfile => $filename,
		  req_rec   => $r,
		  debug	    => $debug,
		  options   => $options,
		  param	    => $r->prev->pnotes( "INCOM_HTML_EMBPERL_ERRORS" ),
		 };
    my $rc = HTML::Embperl::Execute( $params );

    $req->cleanup_aliases;

    my $dbh	= $r->pnotes( "INCOM_DBH" );
    if ($rc != OK && $rc != MOVED && $rc != REDIRECT ) {
	# If there was an error, rollback all changes
	# to the database
	eval { $dbh->rollback; };
	$r->log_error( "error reverting changes to database: $@" ) if $@;

	$r->log_reason( "error in embperl code", $filename );

	return $rc;
    } else {
	# Commit all changes to the database
	eval { $dbh->commit; };
	$r->log_error( "error commiting changes to database: $@" ) if $@;
	$r->header_out( "Content-Length", length $output );
	$r->send_http_header;

	$r->print( $output );
	return OK;
    }
}

sub default_handler {
    # Create an Apache::Request object for
    # parsing POST and GET request
    my $r = new Apache::Request( shift );

    my $filename    = $r->filename;

    unless ( -e $r->finfo ) {
	$r->log_reason( "nonexistent file", $filename );
	return return_error( $r, NOT_FOUND );
    }

    unless ( -f _ ) {
	$r->log_reason( "not a regular file", $filename );
	return return_error( $r, FORBIDDEN );
    }

    unless ( -r _ ) {
	$r->log_reason( "No permissions to read", $filename );
	return return_error( $r, FORBIDDEN );
    }

    # Read the POST data or the Query stringn
    my $status = $r->parse;
    unless ( $status == OK ) {
	$r->log_reason( "error reading request body: " .
 			$r->notes( "error-notes"), $filename);
	return return_error( $r, $status );
    }

    # Copy the elements into the fdat hash
    my %fdat = ();
    my @ffld = ();
    for my $key ( $r->param ) {
	# Discard empty fields
	my @values = grep { $_ ne "" } $r->param( $key );
	next unless @values;
	push @ffld, $key;

	# This is what is expected from HTML::Embperl
	$fdat{$key} = join "\t", @values;
    }

    # Determine the package name of this page
    # Package is Apache::iNcom::basename of the page
    my $package = package_name( $r, $filename );
    my $req	= new Apache::iNcom::Request( $r, $package );
    # Play magic
    $req->setup_aliases;

    # Send the response
    my $output;
    $r->content_type( "text/html" );

    my $debug = $r->dir_config( "EMBPERL_DEBUG" ) || $ENV{EMBPERL_DEBUG} || 0;
    my $options = $r->dir_config( "EMBPERL_OPTIONS" ) ||
      $ENV{EMBPERL_OPTIONS} || 16; # Default = optRawInput
    # optDisableFormData,optReturnError
    $options |= 256 | 262144;

    my $params = {
		  package   => $package,
		  output    => \$output,
		  inputfile => $filename,
		  req_rec   => $r,
		  errors    => [],
		  debug	    => $debug,
		  options   => $options,
		  fdat	    => \%fdat,
		  ffld	    => \@ffld,
		 };
    my $rc = HTML::Embperl::Execute( $params );

    $req->cleanup_aliases;

    my $dbh	= $r->pnotes( "INCOM_DBH" );
    if ($rc != OK && $rc != MOVED && $rc != REDIRECT ) {
	# If there was an error, rollback all changes
	# to the database
	eval { $dbh->rollback; };
	$r->log_error( "error reverting changes to database: $@" ) if $@;

	$r->log_reason( "error in embperl code", $filename );

	# Save HTML error messages for the error page
	$r->pnotes( "INCOM_HTML_EMBPERL_ERRORS", $params->{errors} );

	return return_error( $r, $rc );
    } else {
	# Commit all changes to the database
	eval { $dbh->commit; };
	$r->log_error( "error commiting changes to database: $@" ) if $@;
	$r->header_out( "Content-Length", length $output );
	$r->send_http_header;

	$r->print( $output );
	return OK;
    }
}

sub request_cleanup {
    my $r = shift;

    my $session = $r->pnotes( "INCOM_SESSION" );
    if ( $session ) {
	eval { untie %$session; };
	$r->log_error( "error untying session: $@" ) if $@;
    }

    my $dbh = $r->pnotes( "INCOM_DBH" );
    if ( $dbh ) {
	# Delete expired sessions on 5% of the requests
	if ( rand 100 < 5 ) {
	    eval {
		my $session_expires =
		  $r->dir_config( "INCOM_SESSION_EXPIRES" );
		my $offset;
		if ( $session_expires ) {
		    $offset = offset_calc( $session_expires );
		} else {
		    $offset = 3600 * 24; # One day
		}
		# XXX Is this really portable ????
		my $time = localtime ( time - $offset);
		$dbh->do( "DELETE FROM sessions WHERE last_update < '$time'" );
		$dbh->commit;
	    };
	    $r->log_error( "error removing old sessions: $@" ) if $@;
	}

	eval {
	    $dbh->disconnect unless $dbh;
	};
	$r->log_error( "error closing connection to database: $@" ) if $@;
    }

    return OK;
}

1;
__END__