#!/usr/bin/perl -wT

#
# txt2dat 0.2.0 online interface
# 4 March 2007
# Jim DeVona
# http://anoved.net/txt2dat.html
#
# Just a web front end for Ross Crawford's txt2dat utility,
# which converts text strings to LDraw stickers:
# http://www.br-eng.info/about/lego/LDraw/txt2dat/index.htm
#
# The accompanying HTML form defines the default values, if any, for
# each txt2dat argument. Parameters that are not defined are omitted.
#
# Version history:
#
# - 0.2.0 (13 March 2007) - adopted txt2dat version number,
#                           added description field,
#                           match -f to assigned filename
#
# Issues:
#
# - Font uploading is the iffiest thing here, what with tmp files and all
# - Forking and fork error catching are new tricks, so I may be tricked
#
# License:
#
#   txt2dat is a separate work to which the following terms do not apply.
#   You can do whatever you to do with this script.
#   Improvements are encouraged.
#   No support is promised.
#

use strict;
use CGI;
use CGI::Carp qw/ fatalsToBrowser /;
use File::Temp qw/ tempfile tempdir /;

# Configuration
use constant MAX_KB_UPLOAD => 150;
use constant MAX_BASE_FILENAME => 25;
use constant TXT2DAT => '/home/anoved/bin/txt2dat';
#use constant TXT2DAT => '/usr/local/bin/txt2dat';
use constant TXT2DAT_HOME => '../txt2dat.html';
use constant FONT1 => '/home/anoved/fonts/verasans.ttf';
use constant FONT2 => '/home/anoved/fonts/veraserif.ttf';
use constant FONT3 => '/home/anoved/fonts/nasaliza.ttf';
#use constant FONT1 => '/Users/anoved/Sites/fonts/verasans.ttf';
#use constant FONT2 => '/Users/anoved/Sites/fonts/veraserif.ttf';
#use constant FONT3 => '/Users/anoved/Sites/fonts/nasaliza.ttf';

# Allow but restrict uploads
$CGI::DISABLE_UPLOADS = 0;
$CGI::POST_MAX = 1024 * MAX_KB_UPLOAD;

# parse CGI request
my $q = new CGI;
if ($q->cgi_error) {
	t2d_error($q, $q->cgi_error . ' (maximum upload size is ' . MAX_KB_UPLOAD . ' kilobytes)');
}

# tx2dat is clearly a prerequisite
if (not -e TXT2DAT or not -x TXT2DAT)  {
	t2d_error($q, 'Cannot find executable ' . TXT2DAT);
}

my @opts;

# sticker text is the only strictly required parameter
if (not defined $q->param('s')) {
	t2d_error($q, 'Missing sticker text (parameter <code>s</code> not defined)');
}
if ('' eq $q->param('s')) {
	t2d_error($q, 'No sticker text entered');
}
if ($q->param('s') =~ /^([\w .!?-]+)$/) {
	# untainted sticker text
	push @opts, '-s', $1;
} else {
	# crudely restrict input
	t2d_error($q, 'Sorry, text is currently restricted to upper or lower case letters <code>A</code> to <code>Z</code>, digits <code>0</code> to <code>9</code>, spaces, and the following punctuation: <code>.!?-</code> (download txt2dat to your computer to circumvent this online restriction)');
}

# font color
if (defined $q->param('c')) {
	
	# get raw color code
	my $c_taint;
	if ('other' eq $q->param('c')) {
		if (not defined $q->param('oc')) {
			t2d_error($q, 'Other font color requested but not defined (missing <code>oc</code> parameter)');
		} else {
			$c_taint = $q->param('oc');
		}
	} else {
		$c_taint = $q->param('c');
	}
	
	# validate and untaint color code
	if ('-' eq $c_taint) {
		push @opts, '-c', '-';
	} else {
		if ($c_taint =~ /^(\d+)$/) {
			if ($1 < 0 || $1 > 511) {
				# restrict range
				t2d_error($q, 'Font color must be an integer no less than <code>0</code> and no greater than <code>511</code>');
			} else {
				# untainted ldraw color code
				push @opts, '-c', $1;
			}
		} else {
			# not a number (txt2dat accepts negative color codes, but we don't)
			t2d_error($q, 'Invalid characters in font color (digits <code>0</code> to <code>9</code> only)');
		}
	}
}

# font size
if (defined $q->param('p')) {
	
	# get raw point size
	my $p_taint;
	if ('other' eq $q->param('p')) {
		if (not defined $q->param('op')) {
			t2d_error($q, 'Other font size requested but not defined (missing <code>op</code> parameter)');
		} else {
			$p_taint = $q->param('op');
		}
	} else {
		$p_taint = $q->param('p');
	}
	
	# validate and untaint point size
	# based on http://www.regular-expressions.info/floatingpoint.html
	if ($p_taint =~ /^([0-9]*\.?[0-9]+)$/) {
		if ($1 < 1) {
			t2d_error($q, 'Font size must be greater than or equal to <code>1</code>');
		} else {
			push @opts, '-p', $1;
		}
	} else {
		t2d_error($q, 'Invalid characters in font size (<code>.</code> with digits <code>0</code> to <code>9</code> only)');
	}
}

# spline resolution
if (defined $q->param('r')) {
	
	# get raw resolution
	my $r_taint;
	if ('other' eq $q->param('r')) {
		if (not defined $q->param('or')) {
			t2d_error($q, 'Other spline resolution requested but not defined (missing <code>or</code> parameter)');
		} else {
			$r_taint = $q->param('or');
		}
	} else {
		$r_taint = $q->param('r');
	}
	
	# validate and untaint resolution
	if ($r_taint =~ /^([0-9]*\.?[0-9]+)$/) {
		if ($1 < 0) {
			t2d_error($q, 'Spline resolution should be greeater than or equal to <code>0</code>');
		} else {
			push @opts, '-r', $1;
		}
	} else {
		t2d_error($q, 'Invalid characters in spline resolution (<code>.</code> with digits <code>0</code> to <code>9</code> only)');
	}
}

# custom description
if ((defined $q->param('dd')) && ('ON' eq $q->param('dd'))) {
	if (defined $q->param('d')) {
		if ($q->param('d') =~ /^([\w .!?-]+)$/) {
			push @opts, '-d', $1;
		} else {
			t2d_error($q, 'Sorry, descriptions are currently restricted to upper or lower case letters <code>A</code> to <code>Z</code>, digits <code>0</code> to <code>9</code>, spaces, and the following punctuation: <code>.!?-</code> (download txt2dat to your computer to circumvent this online restriction)');
		}
	}
}

# edges
if ((not defined $q->param('ll')) || ('ON' ne $q->param('ll'))) {
	# this is a reverse switch - we set the flag when the checkbox is NOT on
	push @opts, '-l';
}

# bounding box
if ((defined $q->param('xx')) && ('ON' eq $q->param('xx'))) {
	
	# look at parameters specific to the bounding box
	
	# width
	if ((defined $q->param('dw')) && ('ON' eq $q->param('dw'))) {
		if (defined $q->param('w')) {
			if ($q->param('w') =~ /^([0-9]*\.?[0-9]+)$/) {
				if ($1 < 1) {
					t2d_error($q, 'Width should be greater than or equal to <code>1</code>');
				} else {
					push @opts, '-w', $1;
				}
			} else {
				t2d_error($q, 'Invalid characters in width (<code>.</code> with digits <code>0</code> to <code>9</code> only)');
			}
		}
	}
	
	# height
	if ((defined $q->param('dh')) && ('ON' eq $q->param('dh'))) {
		if (defined $q->param('h')) {
			if ($q->param('h') =~ /^([0-9]*\.?[0-9]+)$/) {
				if ($1 < 1) {
					t2d_error($q, 'Height should be greater than or equal to <code>1</code>');
				} else {
					push @opts, '-h', $1;
				}
			} else {
				t2d_error($q, 'Invalid characters in height (<code>.</code> with digits <code>0</code> to <code>9</code> only)');
			}
		}
	}
	
	# background color
	if (defined $q->param('b')) {
		
		# get raw color code
		my $b_taint;
		if ('other' eq $q->param('b')) {
			if (not defined $q->param('ob')) {
				t2d_error($q, 'Other background color requested but not defined (missing <code>ob</code> parameter)');
			} else {
				$b_taint = $q->param('ob');
			}
		} else {
			$b_taint = $q->param('b');
		}
		
		# validate and untaint color code
		if ('-' eq $b_taint) {
			push @opts, '-b', '-';
		} else {
			if ($b_taint =~ /^(\d+)$/) {
				if ($1 < 0 || $1 > 511) {
					# restrict range
					t2d_error($q, 'Background coor must be an integer no less than <code>0</code> and no greater than <code>511</code>');
				} else {
					# untainted ldraw color code
					push @opts, '-b', $1;
				}
			} else {
				# not a number (txt2dat accepts negative color codes, but we don't)
				t2d_error($q, 'Invalid characters in background color (digits <code>0</code> to <code>9</code> only)');
			}
		}
	}
} else {
	# indicate no bounding box
	push @opts, '-x';
}

# internal or uploaded font
if (defined $q->param('font')) {
	if ('0' eq $q->param('font')) {
		# no argument to add for default font
	} elsif ('1' eq $q->param('font')) {
		push @opts, FONT1;
	} elsif ('2' eq $q->param('font')) {
		push @opts, FONT2;
	} elsif ('3' eq $q->param('font')) {
		push @opts, FONT3;
	} elsif ('other' eq $q->param('font')) {
		if (not defined $q->param('ofont')) {
			t2d_error($q, 'Other font requested but not defined (missing <code>ofont</code> parameter)');
		} else {
			
			# create temp file in tmp directory; *should* be auto-deleted
			my $tmp_dir = tempdir(CLEANUP=>1) or t2d_error($q, 'CGI cannot create temporary directory for uploaded font');
			my ($tmp_fh, $tmp_fontfile) = tempfile(DIR=>$tmp_dir) or t2d_error($q, 'CGI cannot create temporary file for uploaded font');
			
			# temporarily save uploaded font so txt2dat can have at it
			my $cgi_fh = $q->upload('ofont') or t2d_error($q, 'Cannot access uploaded font');
			binmode $cgi_fh;
			binmode $tmp_fh;
			my $tmp_buffer = ''; # arbitrary buffer size
			while (read($cgi_fh, $tmp_buffer, 1024)) {
				print $tmp_fh $tmp_buffer;
			}
			close $tmp_fh;
			
			# tell txt2dat where to get it
			push @opts, $tmp_fontfile;
		}
	} else {
		t2d_error($q, 'Inalid font parameter (should be <code>0</code>, <code>1</code>, <code>2</code>, <code>3</code>, or <code>other</code>)');
	}
}

# devise an output filename
my $filename = '';
my $taintname = $q->param('s');
$taintname =~ s/[^\w]//g;
if ($taintname =~ /^(\w+)$/) {
	$filename .= substr($1,0,MAX_BASE_FILENAME);
} else {
	$filename .= 'sticker';
}
$filename .= '.dat';

# tell txt2dat what we're naming the sticker
push @opts, '-f', $filename;

# fork open a pipe to a clone of ourselves
# this technique of forking to exec without risking a shell is
# derived from examples in O'Reilly's "CGI Programming with Perl" 2nd ed.
my $pipe;
my $pid = open $pipe, "-|";
if (not defined $pid) {
	t2d_error($q, "CGI cannot fork or open pipe to fork ($!)");
}

# the parent gets the child's pid while the child gets zero
# end of the line for the child fork as it assumes the identity of txt2dat
if ($pid == 0) {
	$ENV{'PATH'} = '';
	exec TXT2DAT, @opts or exit 1;
}

# if the pipe exits with nothing assume child fork failed
my $firstline = <$pipe>;
if (("" == $firstline) && (eof $pipe)) {
	t2d_error($q, 'CGI cannot execute ' . TXT2DAT . ' ' . join(' ',@opts));
}

# otherwise original process continues to channel txt2dat's output to user
print $q->header(-type => 'application/x-ldraw', -attachment => $filename);
print $firstline;
print while <$pipe>;
close $pipe;
exit;

# print minimal HTML formatted error message and exit
sub t2d_error {
	my ($q, $msg) = @_;
	print $q->header('text/html'),
	      $q->start_html('txt2dat Error'),
	      $q->h1('txt2dat Error:'),
	      $q->h2($msg),
	      $q->p('Please return to ' . $q->a({-href=>TXT2DAT_HOME},'txt2dat') . ' and verify your input.'),
	      $q->end_html;
	exit 1;
}