File Coverage

blib/lib/PITA/Guest/Server/HTTP.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package PITA::Guest::Server::HTTP;

# The HTTP server component of the support server

use 5.008;
use strict;
use File::Spec                      ();
use POE::Declare::HTTP::Server 0.05 ();

our $VERSION = '0.60';
our @ISA     = 'POE::Declare::HTTP::Server';

use POE::Declare {
	Mirrors     => 'Param',
	PingEvent   => 'Message',
	MirrorEvent => 'Message',
	UploadEvent => 'Message',
};





######################################################################
# Constructor and Accessors

sub new {
	my $self = shift->SUPER::new(
		Mirrors => { },
		@_,
		Handler => sub {
			# Convert to a more convention form
			$_[0]->handler( $_[1]->request, $_[1] );
		},
	);

	# Check and normalize
	unless ( Params::Util::_HASH0($self->Mirrors) ) {
		die "Missing or invalid Mirrors param";
	}
	foreach my $route ( sort keys %{$self->Mirrors} ) {
		my $dir = File::Spec->rel2abs( $self->Mirrors->{$route} );
		unless ( -d $dir ) {
			die "Directory '$dir' for mirror '$route' does not exist";
		}
		$self->Mirrors->{$route} = $dir;
	}

	return $self;
}





######################################################################
# Main Methods

# Sort of half-assed Process compatibility for testing purposes
sub run {
	$_[0]->start;
	POE::Kernel->run;
	return 1;
}

# Wrapper for doing cleansing of the response
sub handler {
	my $self     = shift;
	my $response = $_[1];

	# Call the main handler
	$self->_handler(@_);

	# Add content length for all responses
	if ( defined $response->content ) {
		unless ( $response->header('Content-Length') ) {
			my $bytes = length $response->content;
			$response->header( 'Content-Length' => $bytes );
		}
	}

	return;
}

sub _handler {
	my $self     = shift;
	my $request  = shift;
	my $response = shift;
	my $path     = $request->uri->path;

	if ( $request->method eq 'GET' ) {
		# Handle a ping
		if ( $path eq '/' ) {
			$response->code(200);
			$response->header( 'Content-Type' => 'text/plain' );
			$response->content('200 - PONG');
			$self->PingEvent;
			return;
		}

		# Handle a mirror file fetch
		my $Mirrors = $self->Mirrors;
		foreach my $route ( sort keys %$Mirrors ) {
			my $escaped = quotemeta $route;
			next unless $path =~ /^$escaped(.+)$/;
			my $file = $1;
			my $root = $Mirrors->{$route};
			my $full = File::Spec->catfile( $root, $file );
			if ( -f $full and -r _ ) {
				# Load the file
				local $/ = undef;
				my $io = IO::File->new($full, 'r') or die "open: $full";
				$io->binmode;
				my $blob = $io->getline;

				# Send the file
				$response->code(200);
				$response->header('Content-Type' => 'application/x-gzip');
				$response->content($blob);
			} else {
				$response->code(404);
				$response->header('Content-Type' => 'text/plain');
				$response->content('404 - File Not Found');
			}

			# Report the mirror event
			$self->MirrorEvent( $route, $file, $response->code );

			return;
		}
	}

	if ( $request->method eq 'PUT' ) {
		# Send the upload message
		$self->UploadEvent( $path => \( $request->content ) );

		# Send a content-less ok to the client
		$response->code(204);
		$response->message('Upload received');

		return;
	}

	return;
}

compile;