view release on metacpan or  search on metacpan

lib/App/FonBot/Plugin/HTTPD.pm  view on Meta::CPAN

use warnings;

use Apache2::Authen::Passphrase qw/pwcheck/;
use HTTP::Status qw/HTTP_BAD_REQUEST HTTP_OK HTTP_NO_CONTENT HTTP_FORBIDDEN HTTP_UNAUTHORIZED/;
use JSON qw/encode_json/;
use Log::Log4perl;
use POE::Component::Server::HTTP qw/RC_OK RC_DENY RC_WAIT/;

use DB_File;
use MIME::Base64 qw/decode_base64/;
use Storable qw/freeze thaw/;
use Text::ParseWords qw/shellwords/;

use App::FonBot::Plugin::Config qw/$httpd_port/;
use App::FonBot::Plugin::Common;

##################################################

my $log=Log::Log4perl->get_logger(__PACKAGE__);

my $httpd;
my %waiting_userrequests;
my %responses;

sub init{
	$log->info('initializing '.__PACKAGE__);
	%waiting_requests = ();
	%waiting_userrequests = ();
	$httpd = POE::Component::Server::HTTP->new(
		Port => $httpd_port,
		PreHandler => { '/' => [\&pre_auth, \&pre_get, \&pre_userget], },
		ContentHandler =>{ '/send' => \&on_send, '/get' => \&on_get, '/ok' => \&on_ok, '/userget' => \&on_userget, '/usersend' => \&on_usersend },
		ErrorHandler => { '/' => sub { RC_OK }},
		Headers => { 'Cache-Control' => 'no-cache' },
	);
}

sub fini{
	$log->info('finishing '.__PACKAGE__);
	POE::Kernel->call($httpd, 'shutdown');
}

##################################################

sub httpdie (\$$;$){
	my ($response,$errstr,$errcode)=@_;

	$$response->code($errcode // HTTP_BAD_REQUEST);
	$$response->header(Content_Type => 'text/plain');
	$$response->message($errstr);

	die 'Bad Request';
}

sub pre_auth{
	my ($request, $response)=@_;

	eval {
		my $authorization=$request->header('Authorization') // die 'No Authorization header';
		$authorization =~ /^Basic (.+)$/ or die 'Invalid Authorization header';
		my ($user, $password) = decode_base64($1) =~ /^(.+):(.*)$/ or die 'Invalid Authorization header';
		eval { pwcheck $user, $password; 1 } or die 'Invalid user/password combination';
		$request->header(Username => $user);
		$log->debug("HTTP request from $user to url ".$request->url);
	};
	if (my $error = $@) {
		$response->code(HTTP_UNAUTHORIZED);
		$response->message('Bad username or password');
		$response->header(Content_Type => 'text/plain');
		$response->header(WWW_Authenticate => 'Basic realm="fonbotd"');
		$response->content('Unauthorized');
		$log->debug("Request denied: $error");
		return RC_DENY
	}

	$response->content('');
	RC_OK
}

sub pre_get{
	my ($request, $response)=@_;
	my $user=$request->header('Username');
	return RC_OK if $response->code;
	return RC_OK unless $user;
	return RC_OK unless $request->uri =~ m,/get,;

	unless (exists $commands{$user}) {
		$log->debug("No pending commands for $user, entering RC_WAIT");
		$waiting_requests{$user}->continue if exists $waiting_requests{$user};
		$waiting_requests{$user}=$response;
		return RC_WAIT
	}

	RC_OK
}

sub pre_userget{
	my ($request, $response)=@_;
	my $user=$request->header('Username');
	return RC_OK if $response->code;
	return RC_OK unless $user;
	return RC_OK unless $request->uri =~ m,/userget,;

	unless (exists $responses{$user}) {
		$log->debug("No pending responses for $user, entering RC_WAIT");
		$waiting_userrequests{$user}->continue if exists $waiting_userrequests{$user};
		$waiting_userrequests{$user}=$response;
		return RC_WAIT
	}

	RC_OK
}

sub on_ok{
	my ($request, $response)=@_;
	return RC_OK if $response->code;

	$response->code(HTTP_OK);
	RC_OK
}

sub on_get{
	my ($request, $response)=@_;
	return RC_OK if $response->code;

	eval {
		my $user=$request->header('Username');
		$log->debug("on_get from user $user");