HTTP::Daemon::Threaded::WebClient

Contained in the HTTP-Daemon-Threaded distribution.

Index

Code Index:

package HTTP::Daemon::Threaded::WebClient
EOF

Contained in the HTTP-Daemon-Threaded distribution.

use strict;
use warnings;

package HTTP::Daemon::Threaded::WebClient;
use Socket;
use threads;
use threads::shared;
use Time::Local;
use Time::HiRes qw(sleep);
use HTTP::Response;
use LWP::MediaTypes qw(add_type);
use HTTP::Daemon::Threaded::Socket;
use HTTP::Daemon::Threaded::Logable;
use HTTP::Daemon::Threaded::CGIAdapter;
use Thread::Apartment::MuxServer;
use URI::Escape;
use CGI;
use base qw(HTTP::Daemon::Threaded::Logable Thread::Apartment::MuxServer);

our $VERSION = '0.91';

sub new {
	my ($class, %args) = @_;
#
#	install all web client modules
#
	my $media = delete $args{MediaTypes};
	my $self = { %args };
	bless $self, $class;
	$self->set_client(delete $self->{AptTAC})
		if $self->{AptTAC};
	$self->logInfo("WebClient $args{ID} created\n");
#
#	create any content handlers
#
	my %handlers = ();
	my $i = 0;
	while ($i <= $#{$args{Handlers}}) {
#
#	compile the regexp string
#
		$args{Handlers}[$i++] = qr/$args{Handlers}[$i]/;

		my $module = $args{Handlers}[$i];
		unless ($module eq '*') {
			if (exists $handlers{$module}) {
				$args{Handlers}[$i] = $handlers{$module};
			}
			else {
				eval "require $module;";
				$self->logError("Can't load content handler $module: $@"),
				$@ = "Can't load content handler $module: $@",
				return undef
					if $@;
				$args{Handlers}[$i] = $handlers{$module} =
					${module}->new(
						SessionCache => $args{SessionCache},
						ContentParams => $args{ContentParams},
						LogLevel => $args{LogLevel},
						EventLogger => $args{EventLogger},
						);
				$@ = "Can't create instance of content handler $module",
				return undef
					unless defined $handlers{$module};
			}
		}
		$i++;
	}
#	print "WebClient has ", join("\n", @{$args{Handlers}}), "\n";
#
#	create a selector
#
	$self->{_sktsel} = HTTP::Daemon::Threaded::IOSelector->new($args{SelectInterval});
#
#	use current time for display
#
	my @ts = split(/\s+/, scalar localtime());
	$self->{_started} = join(' ', $ts[3], $ts[0], $ts[1], $ts[2], $ts[4]);
#
#	add add'l media types
#
	if ($media) {
		my ($ct, $fq);
		add_type($ct => (ref $fq ? @$fq : $fq))
			while (($ct, $fq) = each %$media);
	}
#
#	crate local'ized %ENV
#
	local *ENV = { %ENV };
	return $self;
}

sub get_simplex_methods {
	return {
		setLogLevel => 1,
	};
}

sub acceptConnection {
	my ($self, $fn) = @_;
#
#	create empty socket
#
	my $fd = HTTP::Daemon::Threaded::Socket->new();
	$self->logWarning("WebClient: fdopen($fn) failed: $!."),
	return undef
		unless $fd->fdopen($fn, '+>>');

	binmode $fd;
#
#	collect peer info
#
	my $sockaddr = getpeername($fd);
	my ($port, $addr) = sockaddr_in($sockaddr);
	my $clientaddr = inet_ntoa($addr) . ":$port";
	my $prefix = "Web client $clientaddr";
#	print "LINGER is ", join(', ', @res), "\n";
#
#	make sure to set options
#
#	$fd->sockopt(SO_KEEPALIVE, pack('l', 1));
#	$fd->setsockopt(SOL_SOCKET, SO_LINGER, pack('ll', 1,1));
#	my @res = $fd->getsockopt(SOL_SOCKET, SO_LINGER);
#	print "LINGER is ", join(', ', @res), "\n";
	$self->{LogPrefix}{$fn} = $prefix;
	$fd->setContext($self, 1);
#
#	add to selector
#
	$self->{_sktsel}->addNoWrite($fd);
	$fd->setSelector($self->{_sktsel});

	$self->{_curr_skt} = $fd;
	$self->{_idle_timer} = time();
	return $self->{ID};
}

sub run {
	my $self = shift;

	while (1) {
#
#	HTTP::Daemon::Threaded::IOSelector does the heavy lifting
#
		if (exists $self->{_curr_skt}) {
			my $elapsed = $self->{_sktsel}->select();
#
#	check idle time
#
			if ($self->{_curr_sess}) {
				$self->_shutdown()
					if $self->{_curr_sess}->isInactive($self->{_idle_timer});
			}
			elsif ($self->{InactivityTimer} < (time() - $self->{_idle_timer})) {
				$self->_shutdown();
			}
		}
		else {
#
#	if no connection installed, just kill time
#
			select(undef, undef, undef, 0.1);
		}
		return undef
			unless $self->handle_method_requests();
	}

	return 1;
}

sub _shutdown {
	my $self = shift;
	$self->logInfo("Shutting down connection...\n");
	my $fd = delete $self->{_curr_skt};
	delete $self->{LogPrefix}{fileno($fd)};
	$fd->close();
	$self->{_curr_sess}->close(),
	delete $self->{_curr_sess}
		if $self->{_curr_sess};
	$self->freeClient();
	return 1;
}

sub handleSocketEvent {
	my ($self, $fd) = @_;

	my ($page, $method, $buffer, $request, $cgi, $params, $handler, $session);
	my $close_on_resp;
	$fd = $self->{_curr_skt};
	my $handlers = $self->{Handlers};
#
#	read the request in (up to some max size) and validate
#	the header
#
	$request = $fd->get_request();
	return $self->_shutdown()
		unless $request;

#	$self->logInfo("Got a request as a " . (ref $request) . "\n");
#
#	get HTTP protocol level; if < 1.1, we close the connection on exit
#
#	$self->logInfo("Got pre 1.1 client\n"),
	$close_on_resp = 1,
	$fd->force_last_request()
		unless $fd->proto_ge("1.1");

	$session = $self->{SessionCache}->getSession($request)
		if $self->{SessionCache};
	$self->logInfo("Got a session\n") if $session;
	$page = $request->uri;
	$method = $request->method;
	$self->logInfo("Got web request for $method $page\n");
	$self->{_idle_timer} = time();
#
#	should use other error...should also support HEAD and eventually
#	PUT and UPLOAD
#
	$fd->send_error(404),
	return $self->_shutdown()
		unless (($method eq 'GET') ||
			($method eq 'POST') ||
			($method eq 'HEAD') ||
			($method eq 'PUT'));

	if ($page=~/^([^\?]+?)\?(.*)$/) {
#
#	extract params and normalize uri
#
		($page, $cgi, $params) = ($1, 1, $2);
		$self->logInfo("Its a CGI with params $params\n");
	}
	else {
#
#	disable params and normalize uri
#
		($cgi, $params) = (undef, undef);
		$page .= 'index.html'
			if (substr($page, -1, 1) eq '/');
	}
#
#	if uri is just 'stop', shut everything down
#
	if (($page eq '/stop') && ($method eq 'GET')) {
		$self->_shutdown();
		my $httpd = $self->{HTTPD};
		$httpd->close();
		return 1;
	}

	my $i = 0;

	$i += 2
		while ($i <= $#$handlers) &&
			$self->logInfo("Trying $$handlers[$i] on $page\n") &&
			($page!~/$$handlers[$i]/);

	unless ($i <= $#$handlers) {
#		$self->logInfo("$prefix: Unknown request URL $page\n"),
		$self->logInfo("Unknown request URL $page\n");
		$fd->send_error(404);
		$self->_shutdown()
			if $close_on_resp;
		return 1;
	}

	$handler = $handlers->[$i+1];
#
#	read the rest of it (if anymore)
#	see HTTP::Daemon::ClientConn
#
	my $ct = (($method eq 'GET') || ($method eq 'HEAD')) ?
		'application/x-www-form-urlencoded' :
		$request->content_type();

	if ($ct && ($ct eq 'application/x-www-form-urlencoded')) {
		$params = $request->content(),
		$cgi = 1
			if ($method eq 'POST');
#
#	convert request to (param => value) hash
#
		my %reqparams = ();
		if ($cgi) {
			my @request = split(/\&/, $params);
			$self->logInfo("Orig Params are " . join(', ', @request) . "\n");
			my ($key, $val);

			foreach (@request) {
				($key, $val) = split /=/;
#
#	fixed per D. Hastings' bug report
#	NOTE: the unescape might be faster by running the regex locally
#
				$key=~tr/+/ /;
				$val=~tr/+/ /;
				($key, $val) = uri_unescape($key, $val);
#
#	support duplicate params
#
				if (exists $reqparams{$key}) {
					$reqparams{$key} = [ $reqparams{$key} ]
						unless ref $reqparams{$key};
					push @{$reqparams{$key}}, $val;
				}
				else {
					$reqparams{$key} = $val;
				}
			}
			$params = \%reqparams;
			$self->logInfo("Params are " . join(', ', %reqparams) . "\n");
		}
	}
	elsif ($ct && (length($ct) > 10) && (substr($ct, 0, 10) eq 'multipart/')) {
#
#	multipart request (e.g., file upload); collect the parts
#
		my @parts = $request->parts();
		$params = \@parts;
	}
	elsif ($method eq 'POST') {
#
#	could be anything, just grab it as the parameter and treat as a cgi
#
		$params = $request->content();
		$cgi = 1;
	}
	elsif ($method eq 'PUT') {
		$params = $request->content();
	}
#
#	if handler is docroot, just return the file (or its metadata as header)
#
#	$self->logInfo("Using handler " . (ref $handler) . "\n");
	unless (ref $handler) {
#
#	trim possible leading slash
#
		$page = substr($page, 1)
			if (substr($page, 0, 1) eq '/');
		$self->logInfo("Fetching $self->{DocRoot}$page\n");
		($method eq 'GET') ?
			$fd->send_file_response($self->{DocRoot} . $page) :
			$fd->send_file_header($self->{DocRoot} . $page);
		$self->_shutdown()
			if $close_on_resp;
		return 1;
	}
#
#	if handler is a CGI, build a CGI object for it
#
	if ($handler->isa('HTTP::Daemon::Threaded::CGIHandler')) {
		$self->logInfo("Routing to request for $page to handler " . (ref $handler) . "\n");
#		print STDERR "*** routing CGI request\n";
		my $cgireq = HTTP::Daemon::Threaded::CGIAdapter->new($request, $fd, $ct);
#		print STDERR "*** got CGI request, create CGI object\n";
		my $cgiobj = CGI->new();
#		print STDERR "*** got CGI object, call handleCGI\n";
		$handler->handleCGI($cgiobj, $session);
#		print STDERR "*** got CGI response, send response\n";
		my $rsp = $cgireq->restore->response;
#		print STDERR "*** Response is \n", $rsp->as_string(), "\n";
		$fd->send_response($rsp);
#		print STDERR "*** sent response\n";
		#
		#	!!!BE CAREFUL WHEN MERGING W/ 1.01: async will eave stdin/stoud/ENV
		#	in bogus states; we'll need to restore as needed
	}
	else {
	
	$self->logInfo("Routing to request for $page to handler " . (ref $handler) . "\n");
	my $result =
		($method eq 'HEAD') ?
			$handler->getHeader($fd, $request, $page, $params, $session) :
		($method eq 'PUT') ?
			$handler->putContent($fd, $request, $page, $params, $session) :
			$handler->getContent($fd, $request, $page, $params, $session);
	}
	$self->_shutdown()
		if $close_on_resp;
	return 1;
}
#
#	borrowed from HTTP::Daemon::ClientConn to emulate HTTP::Daemon
#
sub url
{
    return $_[0]->{URL};
}

sub product_tokens
{
    return $_[0]->{ProductTokens};
}

sub freeClient {
	my $self = shift;
	{
		lock(@{$self->{FreeList}});
		unshift @{$self->{FreeList}}, $self->{ID};
	}
}

1;