view release on metacpan or  search on metacpan

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

package Apache::SdnFw;

use strict;
use Carp;
use Apache;
use Apache::Constants qw(:common :response :http);
use Compress::Zlib 1.0;
use Time::HiRes qw(time);
use Date::Format;
use Apache::SdnFw::lib::Core;

our $VERSION = '0.92';

sub handler {
	my $r = shift;

	# our goal here is to facilitate handing off to the main
	# system processor with some basic information
	# which will then return a very structured data object
	# back, which we will then dump back out to the client

	my %options;
	$options{uri} = $r->uri();
	$options{args} = $r->args();
	$options{remote_addr} = $r->get_remote_host();

	my %headers = $r->headers_in();
	if ($headers{Cookie}) {
		foreach my $kv (split '; ', $headers{Cookie}) {
			my ($k,$v) = split '=', $kv;
			$options{cookies}{$k} = $v;
		}
	}
	$options{server_name} = $headers{Host};
	$options{server_name} =~ s/^www\.//;

	# pull in some other information
	foreach my $key (qw(
		HTTPS HTTPD_ROOT HTTP_COOKIE HTTP_REFERER HTTP_USER_AGENT DB_STRING
		DB_USER BASE_URL DOCUMENT_ROOT REQUEST_METHOD QUERY_STRING HIDE_PERMISSION
		GOOGLE_MAPS_KEY DEV FORCE_HTTPS GAUTH GUSER IP_LOGIN TITLE IPHONE DBDEBUG
		OBJECT_BASE CONTENT_LENGTH CONTENT_TYPE APACHE_SERVER_NAME IP_ADDR ETERNAL_COOKIE
		CRYPT_KEY)) {

		$options{env}{$key} = ($r->dir_config($key) or $r->subprocess_env->{$key});
	}

	# get incoming parameters (black box function)
	get_params($r,\%options);

	# kill some shit
	foreach my $k (qw(__EVENTARGUMENT __EVENTVALIDATION __VIEWSTATE __EVENTTARGET)) {
		delete $options{in}{$k};
	}

	# what content type do we want back? (default to text/html)
	$options{content_type} = $options{in}{c} || 'text/html';

	# try and get a Core object and pass this information to it
	# setup our database debug output file
	if ($options{env}{DBDEBUG}) {
		_start_dbdebug(\%options);
	}

	my $s;
	eval {
		$s = Apache::SdnFw::lib::Core->new(%options);
		$s->process();
		#croak "test".Data::Dumper->Dump([$s]);
	};

	if ($options{env}{DBDEBUG}) {
		_end_dbdebug($s);
	}

	# so from all that happens below here is what $s->{r} should have
	# error => ,
	# redirect => ,
	# return_code => ,
	# set_cookie => [ array ],
	# filename => ,
	# file_path => ,
	# content => ,

	if ($@) {
		$s->{dbh}->rollback if (defined($s->{dbh}));;
		return error($r,"Eval Error: $@");
	}

	unless(ref $s->{r} eq "HASH") {
		return error($r,"r hash not returned by core");
	}

	if ($s->{r}{error}) {
		return error($r,"Process Error: $s->{r}{error}");
	}

	if ($s->{r}{redirect}) {
		$r->header_out('Location' => $s->{r}{redirect});
		return MOVED;
	}

	#if ($s->{r}{remote_user}) {
	#	$r->subprocess_env(REMOTE_USER => $s->{r}{remote_user});
		$r->subprocess_env(USER_ID => $s->{r}{log_user});
		$r->subprocess_env(LOCATION_ID => $s->{r}{log_location});
	#}

	if ($s->{r}{return_code}) {
		return NOT_FOUND if ($s->{r}{return_code} eq "NOT_FOUND");
		return FORBIDDEN if ($s->{r}{return_code} eq "FORBIDDEN");

		# unknown return code
		return error($r,"Unknown return_code: $s->{r}{return_code}");
	}

	# add cookies
	foreach my $cookie (@{$s->{r}{set_cookie}}) {
		$r->err_headers_out->add('Set-Cookie' => $cookie);
	}

	#return error($r,"Missing content_type") unless($s->{r}{content_type});

	# compress the data?
	my $gzip = $r->header_in('Accept-Encoding') =~ /gzip/;
	if ($gzip && !$s->{r}{file_path}) {
		if ($r->protocol =~ /1\.1/) {
			my %vary = map {$_,1} qw(Accept-Encoding User-Agent);
			if (my @vary = $r->header_out('Vary')) {
				@vary{@vary} = ();
			}
			$r->header_out('Vary' => join ',', keys %vary);
		}
		$r->content_encoding('gzip');
	}

	$r->content_type($s->{r}{content_type});
	$r->headers_out->add('Content-Disposition' => "filename=$s->{r}{filename}")
		if ($s->{r}{filename});

	if (defined($s->{r}{headers})) {
		foreach my $k (keys %{$s->{r}{headers}}) {
			$r->headers_out->add($k => $s->{r}{headers}{$k});
		}
	}

	$r->send_http_header;

	if ($s->{r}{file_path}) {
		# send a raw file
		open(FILE, $s->{r}{file_path});
		$r->send_fd( \*FILE );
		close(FILE);
	} else {
		# or just send back content

		wrap_template($s) if ($s->{r}{content_type} eq 'text/html' && !$s->{raw_html});

		if ($s->{save_static}) {
			my $fname = "$s->{object}_$s->{function}.html";
			open F, ">/data/$s->{obase}/content/$fname";
			print F $s->{r}{content};
			close F;
		}

		if ($gzip) {
			$r->print(Compress::Zlib::memGzip($s->{r}{content}));
		} else {
			$r->print($s->{r}{content});
		
		}
	}

	return HTTP_OK;
}

sub wrap_template {
	my $s = shift;