#!/usr/bin/perl
# Make Perl language on server interpret the rest of this file.

# plxp.cgi
# Perform these functions:
#	Acquire the values of the fields from the request.
#	Obtain the data required for a response to the request, using the applicable specialty routine.
#	Reply with an XML page.

# Session management: Sessions are not recognized. Each request is entirely self-contained.

# Encoding: Perl encodes output data (to the Web server and to database tables) into UTF-8 from
# character values. Thus, UTF-8 in a string, when output, would be incorrect. If UTF-8 data in a
# database table are to be retrieved and then output, they are first converted to character values.

# XML terms:
#	“Request” = an XML message from a client to the server.
#	“Response” = an XML message to the client replying to a request.
#	“Data” = the collection of elements constituting the content of the “data” element.
#	“Core” = the part of the data after the “vr” and “op” elements. In a request, the core contains
#		the argument structure of the operation.

# Request format: The data of a request must have these elements in this order:
#	0. “vr” (API version).
#	1. “op” (requested operation).
# Any argument structure required by the operation must follow the “op” element.

use warnings 'FATAL', 'all';
# Make every warning fatal.

use strict;
# Require strict checking of variable references, symbolic references, and barewords.

use vars ('%as', '$dbh', '$i', '%in');
# Declare global variables.

use Encode 'decode_utf8', 'encode_utf8';
# Import a function to decode from UTF-8 to character values and thereby test form-data UTF-8
# validity.

use Unicode::Normalize;
# Import functions to normalize Unicode strings.

use DBI;
# Import the general database-interface module. It imports DBD::Pg for PostgreSQL automatically.

use encoding 'utf8';
# Make Perl interpret the script and standard files as UTF-8 rather than bytes. Do not replace this
# with “use utf8”; that causes UTF-8 text in database tables to be treated as if character values.

my @eff = ((0) x 5);
# Initialize the efficiency facts for any desired testing.

&Init;
# Store initial values in %in.

&In;
# Parse the submitted request and store the API version, operation, and core in %in.

if ($in{ok}) {
# If the status is still good:

	&OpImp ($in{vr}, $in{op}, 'plx');
	# Connect to database “plx” and import the applicable operation routine.

	if ($in{ok}) {
	# If the status is still good:

		print +(&Resp ("<vr>$in{vr}</vr><op>$in{op}</op>" . &Op));
		# Run the operation routine and serve an XML response with the core that it generates,
		# prefixed with the API version and the operation.

		my $dbdis = ($dbh->disconnect);
		# Disconnect from the database.

		(warn $dbdis) unless $dbdis;
		# If the disconnection failed, record the failure message.

	}

}

############################ Subroutine definitions ############################

#### Abort
# Serve the specified error message and set the status to bad.
# Arguments:
#	0: message to be served.
#	1?: if list of environment variables to be appended.

sub Abort {

	my $msg = $_[0];
	# Initialize the response core.

	if (@_ > 1) {
	# If a list of environment variables is to be appended to the response core:

		my $i;

		foreach $i (keys %ENV) {
		# For each environment variable:

			$msg .= "; $i = $ENV{$i}";
			# Append its key and value to the response core.

		}

	}

	print (&Resp (&Err ($msg)));
	# Serve a response whose core is an “err” element containing the specified error message.

	$in{ok} = 0;
	# Record the status as bad.

}

#### DoArgs
# Check whether the count of the arguments in the core is correct and whether, for each required
# parameter, there is exactly 1 argument in the core with it. If so, compile an argument table.
# Arguments:
#	0: argument count.
#	1*: required arguments’ parameter names, if any.

sub DoArgs {

	$in{as} =~ s#[\n\r]##g;
	# Delete any line breaks from the core, because this operation ignores them.

	my $args = 0;
	# Initialize the argument count as 0.

	while (length $in{as}) {
	# Until the core is exhausted:

		unless ($in{as} =~ s#^<([a-z\d]+)>([^<>]+)</\1>##) {
		# Delete its first argument. If the deletion failed:

			return (&Err ("$in{op}-DoArgs 0: Invalid arg after " . (keys %as) . ' valid'));
			# Return a response core containing an error message.

		}

		if (exists $as{$1}) {
		# If an earlier argument provided a value for the same parameter:

			return (&Err ("$in{op}-DoArgs 1: Duplicate arg $1"));
			# Return a response core containing an error message.

		}

		$args++;
		# Increment the argument count.

		$as{$1} = $2;
		# Add the argument to the argument table.

	}

	(return (&Err ("$in{op}-DoArgs 2: Arg count not $_[0]"))) unless ($args == $_[0]);
	# If the argument count is wrong, return a response core containing an error message.

	foreach $i (@_[1 .. $#_]) {
	# For each required argument:

		unless (exists $as{$i}) {
		# If it is missing from the argument table:

			return (&Err ("$in{op}-DoArgs 3: No arg $i"));
			# Return a response core containing an error message.

		}

	}

	return '';
	# Return a success result.

}

#### DXml
# Return the specified text, converted from PCDATA to plain text.
# Arguments:
#	0: text as PCDATA.

sub DXml {

	my $ret = $_[0];
	# Identify the text as PCDATA.

	$ret =~ s#&lt;#<#g;
	# Convert any “&lt;” to “<”.

	$ret =~ s#&amp;#&#g;
	# Convert any “&amp;” to “&”.

	return $ret;
	# Return the converted text.

}

#### Err
# Return the specified error message as the core of a response.
# Arguments:
#	0: element content.
# Precondition: The element content is formatted as PCDATA.

sub Err {

	return "<err>$_[0]</err>";
	# Return an “err” element with the specified content.

}

#### Hex
# Return a hexadecimal encoding of the codepoint of the specified character.
# Arguments:
#	0: character.

sub Hex {

	return (sprintf '%5.5lx', (ord $_[0]));
	# Return a hexadecimal encoding of the codepoint of the specified character.

}

#### HexB
# Return a pseudo-list of the hexadecimal encodings of the values of the bytes in the specified
# string.
# Arguments:
#	0: string.

sub HexB {

	my @char = (unpack 'C*', $_[0]);
	# Identify a list of the values of the bytes in the specified string.

	my @chex;

	foreach $i (@char) {
	# For each of them:

		push @chex, (sprintf '%5.5lx', $i);
		# Append its hexadecimal encoding to a list.

	}

	return (join ':', @chex);
	# Return a pseudo-list of the hexadecimal encodings.

}

#### In
# Read and parse a request.

sub In {

	if (! (exists $ENV{REQUEST_METHOD})) {
	# If there is no request method:

		&Abort ('In 3: No request method', 1);
		# Report this and quit.

	}

	elsif (! (exists $ENV{CONTENT_TYPE})) {
	# Otherwise, if there is no content type:

		&Abort ('In 3: No content type', 1);
		# Report this and quit.

	}

	elsif (! (exists $ENV{CONTENT_LENGTH})) {
	# Otherwise, if there is no content length:

		&Abort ('In 3: No content length', 1);
		# Report this and quit.

	}

	elsif ($ENV{REQUEST_METHOD} ne 'POST') {
	# Otherwise, if the request method is not POST:

		&Abort ('In 3: Request method not POST', 1);
		# Report this and quit.

	}

	elsif ($ENV{CONTENT_TYPE} ne 'application/xml; charset=utf-8') {
	# Otherwise, if the content type is not XML/UTF-8:

		&Abort ('In 3: Content type wrong', 1);
		# Report this and quit.

	}

	elsif ($ENV{CONTENT_LENGTH} < 1) {
	# Otherwise, if the content length is not positive:

		&Abort ('In 3: Content length not positive', 1);
		# Report this and quit.

	}

	else {
	# Otherwise:

		binmode STDIN;
		# Make Perl treat the parameter string as raw bytes instead of UTF-8.

		my ($in, $inb);

		read STDIN, $inb, $ENV{CONTENT_LENGTH};
		# Identify the content as bytes.

		$in{op} = '';
		# Initialize the specialty routine as undefined.

		if (defined (eval {$in = (decode_utf8 ($inb, 1))})) {
		# Identify the content decoded from UTF-8 into Unicode character values. If the decoding
		# succeeds:

			my @in = (
				$in =~
				m#^<\?xml version="1\.0" encoding="utf-8"\?>[\n\r ]*<data>(.+)</data>[\n\r ]*$#
			);
			# Identify the data as a 1-element list.

			if (@in) {
			# If the request content is validly formatted and its data are non-blank:

				$in = $in[0];
				# Identify the core as a string, leaving it PCDATA, i.e. with any non-tag
				# “<” or any “&” replaced with “&lt;” or “&amp;”, respectively.

				@in = (
					$in =~
					m#^<vr>(\d+)</vr>[\n\r ]*<op>([a-z]+-\d+)</op>[\n\r ]*((?:<.+>)?)[\n\r ]*$#
				);
				# Identify the API version, the operation, and the core.

				if (@in) {
				# If they are validly formatted:

					($in{vr}, $in{op}, $in{as}) = @in;
					# Store them.

				}

				else {
				# Otherwise, i.e. if the API version, operation, and core are not validly
				# formatted:

					&Abort ('In 0: Invalid request data: ' . (&Xml ($in)));
					# Quit with an error message.

				}

			}

			else {
			# Otherwise, i.e. if the content is invalidly formatted or its data are blank:

				&Abort ('In 1: Invalid request content: ' . (&Xml ($inb)));
				# Quit with an error message.

			}

		}

		else {
		# Otherwise, i.e. if the decoding fails:

			&Abort ('In 2: Request content not UTF-8: ' . (&HexB ($inb)));
			# Quit with an error message.

		}

		$in{ENV_REMOTE_ADDR} = $ENV{REMOTE_ADDR};
		# Store the remote host's IP address.

		$in{ENV_ACCEPT_LANGUAGE} = $ENV{HTTP_ACCEPT_LANGUAGE};
		# Store the remote host's language-preference message.

	}

}

#### Init
# Initialize the global variables.

sub Init {

	$in{mgr} = 'pool@panlex.org';
	# Store the PanLex manager’s SMTP address.

	$in{pllv} = 1127;
	# Store the ID of the PanLex variety.

	$in{dir} = "/opt/data/p";
	# Store the master specialty-routine directory.

	$in{ok} = 1;
	# Initialize the status as OK.

}

#### OpImp
# Connect to the specified database and import the specified specialty routine.
# Arguments:
#	0: API version.
#	1: operation.
#	2: database.

sub OpImp {

	my $opf = "$in{dir}/$_[0]/$_[1].pl";
	# Identify the file containing the operation routine.

	if (-r $opf) {
	# If the file is readable:

		$dbh = DBI->connect(
			"dbi:Pg:dbname=$_[2];host=db3.panlex.org;port=5432", 'apache', undef,
			{ AutoCommit => 0 }
		);
		# Specify & connect to the PostgreSQL “plx” database as “apache”, with password
		# obtained from the .pgpass file in the “apache” user’s home directory.

		if ($dbh) {
		# If the connection succeeded:

			$in{util} = "$in{dir}/$in{vr}/util";
			# Store the utility directory.

			require $opf;
			# Include the operation routine, which is always a file containing a
			# subroutine named “Op”.

		}

		else {
		# Otherwise, i.e. if the database connection failed:

			&Abort ('OpImp 0: Unable to connect to database');
			# Quit with an error message.

		}

	}

	else {
	# Otherwise, i.e. if the file is not readable:

		&Abort ('OpImp 1: Operation not found');
		# Quit with an error message.

	}

}

#### QEIP
# Return whether any record in the specified table contains the specified positive integer in the
# specified column.
# Arguments:
#   0: table.
#	1: column.
#	2: integer.
# Precondition: The table and column exist.

sub QEIP {

	return (
		($_[2] =~ m#^[1-9]\d*$#)
		&& ($dbh->selectrow_array ("select $_[1] from $_[0] where $_[1] = $_[2]"))
	);
	# Return whether the integer is validly formatted and positive and a record has it as a value
	# in the specified column of the specified table.

}

#### Resp
# Return an XML response to the client with the specified data.
# Arguments:
#	0: data.
# Precondition: The data are PCDATA.

sub Resp {

	return (
		"Content-type: application/xml; charset=utf-8\n\n"
		. '<?xml version="1.0" encoding="utf-8"?><data>' . "$_[0]</data>"
	);
	# Return a header-prefixed XML message with the specified content in a “data” element.

}

#### Xml
# Convert the specified string to PCDATA.
# Arguments:
#	0: string.

sub Xml {

	my $ret = $_[0];
	# Identify the string.

	$ret =~ s/&/&amp;/g;
	# Replace any "&" with an "&amp;".

	$ret =~ s/</&lt;/g;
	# Replace any "<" with "&lt;".

	return $ret;
	# Return the modified string.

}
