The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package App::FonBot::Plugin::HTTPD;

our $VERSION = '0.000_5';

use v5.14;
use strict;
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 => 8888,
		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");

		if (exists $commands{$user}) {
			my $json=encode_json thaw $commands{$user};
			$log->debug("Sending JSON: $json to $user");
			$response->content($json);
			$response->code(HTTP_OK);
			$response->message('Commands sent');
		} else {
			$log->debug("Sending back 204 No Content");
			$response->code(HTTP_NO_CONTENT);
			$response->message('No pending commands');
		}

		delete $commands{$user}
	};

	$log->error("ERROR: $@") if $@ && $@ !~ /^Bad Request /;

	RC_OK
}

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

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

		if (exists $responses{$user}) {
			my $json=encode_json $responses{$user};
			$log->debug("Sending JSON: $json to $user");
			$response->content($json);
			$response->code(HTTP_OK);
			$response->message('Responses sent');
		} else {
			$log->debug("Sending back 204 No Content");
			$response->code(HTTP_NO_CONTENT);
			$response->message('No pending responses');
		}

		delete $responses{$user}
	};

	$log->error("ERROR: $@") if $@ && $@ !~ /^Bad Request /;

	RC_OK
}

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

	eval {
		httpdie $response, 'All requests must use the POST http method' unless $request->method eq 'POST';
		my $user=$request->header('Username');

		my $destination=$request->header('X-Destination') // httpdie $response, 'Missing destination address';
		my ($driver, $address)=shellwords $destination;

		my $content=$request->content // httpdie $response, 'Content is undef';

		if ($driver eq 'HTTP') {
			$responses{$user}//=[];
			push $responses{$user}, $content;
			if (exists $waiting_userrequests{$user}) {
				$waiting_userrequests{$user}->continue;
				delete $waiting_userrequests{$user}
			}
		} else {
			unless ($ok_user_addresses{"$user $driver $address"}) {
				$response->code(HTTP_FORBIDDEN);
				$response->message("$user is not allowed to send messages to $address");
				return
			}

			POE::Kernel->post($driver, 'send_message', $address, $content) or $log->error("Driver not found: $driver");
		}

		$response->code(HTTP_NO_CONTENT);
		$response->message('Message sent');
	};

	$log->error("ERROR: $@") if $@ && $@ !~ /^Bad Request /;
	$log->debug('Responding to send from $user with '.$response->code.' '.$response->message);
	RC_OK
}

sub on_usersend{
	my ($request, $response)=@_;
	$log->debug("asdasd asd");
	return RC_OK if $response->code;

	eval{
		httpdie $response, 'All requests must use the POST http method' unless $request->method eq 'POST';
		my $user=$request->header('Username');

		my $content=$request->content // httpdie $response, 'Content is undef';

		sendmsg $user, $request->header('X-Requestid'), HTTP => shellwords $_ for split '\n', $content;

		$response->code(HTTP_NO_CONTENT);
		$response->message('Command sent');
	};

	$log->error("ERROR: $@") if $@ && $@ !~ /^Bad Request /;
	$log->debug('Responding to usersend from $user with '.$response->code.' '.$response->message);
	RC_OK
}

1;
__END__

=encoding utf-8

=head1 NAME

App::FonBot::Plugin::HTTPD - FonBot webserver plugin, used for communication with phones

=head1 SYNOPSIS

	use App::FonBot::Plugin::HTTPD;
	App::FonBot::Plugin::HTTPD->init;
	...
	App::FonBot::Plugin::HTTPD->fini;

=head1 DESCRIPTION

This FonBot plugin provides a webserver for interacting with fonbotd. All requests use Basic access authentication.

The available calls are:

=over

=item GET C</get>

Returns a JSON array of pending commands for the current user. Uses long polling — the server does not respond immediately if there are no pending commands.

=item GET C</ok>

Returns a 200 OK.

=item POST C</send>

Sends a message to an address. The address is given in the C<X-Destination> header. The message is in the POST data.

=item GET C</userget>

Returns a JSON array of pending messages for the current user. Uses long polling — the server does not respond immediately if there are no pending commands.

=item POST C</usersend>

Sends a command to the sender's phone. The optional C<X-Requestid> header sets the request ID. The command is in the POST data

=back

=head1 CONFIGURATION VARIABLES

=over

=item C<$httpd_port>

The HTTPD listens on this port.

=back

=head1 AUTHOR

Marius Gavrilescu C<< marius@ieval.ro >>

=head1 COPYRIGHT AND LICENSE

Copyright 2013 Marius Gavrilescu

This file is part of fonbotd.

fonbotd is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

fonbotd 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 Affero General Public License for more details.

You should have received a copy of the GNU Affero General Public License
along with fonbotd.  If not, see <http://www.gnu.org/licenses/>


=cut