diff -r 000000000000 -r 00dbdef7621f index.cgi
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/index.cgi	Fri Jul 01 16:20:17 2011 +0200
@@ -0,0 +1,237 @@
+#! /usr/bin/perl -T
+
+use 5.010;
+use strict;
+use warnings;
+
+use Data::Dumper;
+
+use CGI qw(:all);
+use CGI::Carp qw(fatalsToBrowser);
+use Crypt::Simple;
+use Digest::SHA1 qw(sha1_hex);
+use Mail::Sendmail;
+use DBI;
+use Template;
+use File::Basename;
+use Mail::RFC822::Address qw(valid);
+
+delete @ENV{grep /PATH$/ => keys %ENV};
+$ENV{PATH} = "/usr/bin:/usr/sbin:/bin:/sbin";
+
+my $DSN = "DBI:SQLite:db.sqlite3";
+my $SECRET = "iexaephuwe";	    # used for generating the hash
+my $EXPIRATION = 3600;		    # the link is valid for 1 hour only
+my $SUBJECT = "Retter packen";	    # ASCII only! *used for mail subject*
+my %FIELDS = (
+    MAN => [qw[givenname surname mail]],
+    OPT => [qw[tel]]
+);
+
+my %ttconfig = (
+    INCLUDE_PATH => "templates",
+    DEBUG => 1,
+    VARIABLES => {
+	MAILTO => "hs+retter\@schlittermann.de"
+    },
+);
+
+my $DBH = DBI->connect($DSN, undef, undef, {RaiseError=>1});
+END { $DBH and $DBH->disconnect }
+
+sub insert(\%);
+sub confirm($);
+
+MAIN: {
+
+    # Redirect if called without the script name, this avoids
+    # other problems later
+    if (basename($ENV{SCRIPT_NAME}) ne basename(url(-path_info => 0, -relative => 1))) {
+	print redirect(basename($ENV{SCRIPT_NAME}));
+    }
+
+    # OK, let's start
+    print header(-charset => "UTF-8");
+    my $tt = Template->new(\%ttconfig);
+
+    # ACCESS
+    # Here we generate a link URL (sent via Mail) containing the
+    # encrypted current timestamp. Accessing the form is only possible
+    # using this link. Note: These links may not be unique!
+    if (!path_info()) {
+	my %warn;
+	my $sent;
+
+	if (param("mail")) {
+	    if (not valid param("mail")) {
+		$warn{mail} = "INVALID";
+	    }
+	    else {
+		my $xxx = encrypt(time);
+		$xxx =~ s/\+/-/g;
+		$xxx =~ s/\//_/g;
+
+		# send mail
+		sendmail(To => scalar(param("mail")),
+		         From => "hs+retter\@schlittermann.de",
+			 Sender => "hs\@schlittermann.de",
+			 Subject => "[$SUBJECT] Link zur Online-Anmeldung",
+			 Message => "Bitte benutze den folgenden Link, um zum Anmeldeformular zu gelangen:\n"
+			    . url(-query => 0) . "/$xxx\n"
+			    . "\n-- \nHeiko Schlittermann\n");
+		    
+		$sent = param("mail");
+	    }
+	}
+	$tt->process("access.tpl", {
+	    sent => $sent,
+	    warn => %warn ? \%warn : undef,
+	    value => { mail => scalar param("mail") },
+	});
+	exit 0;
+    }
+
+    # No access without correct path_info
+    if (my $_ = basename(path_info())) {
+	s/_/\//g;
+	s/-/+/g;
+	eval {
+	    my $time = decrypt($_) or die "DECRYPTION ERROR";
+	    $time =~ /^\d+$/ or die "FORMAT ERROR";
+	    time() - $time < $EXPIRATION or die "EXPIRED";
+	};
+	if ($@) {
+	    $tt->process("denied.tpl", {
+		url => url(-path => 0),
+	    }) or die $tt->error();
+	    exit 0;
+	}
+    }
+
+    ### all went fine, we start processing
+    ### the form
+
+    my %warn;
+    my %value;
+
+    ## Input
+    if (param("clear")) {
+	Delete_all();
+    }
+
+    # Submission
+    if (param("submit")) {
+	foreach my $param (@{$FIELDS{MAN}}, @{$FIELDS{OPT}}) {
+
+	    # strip away spaces to "untaint" the variables, additionally
+	    # limit the length
+	    my $_ = param($param);
+	    /^\s*(.*)\s*$/;
+
+	    if (!length $1 and $param ~~ @{$FIELDS{MAN}}) {
+		push @{$warn{$param}}, "Leer!?";
+	    }
+
+	    if (length $1 > 200) {
+		push @{$warn{$param}}, "Zu lang (bitte weniger als 200 Zeichen).";
+	    }
+
+	    param(-name => $param, value => $1);
+	    $value{$param} = $1;
+	}
+
+	# Mail needs extra check
+	if ($value{mail} and not valid($value{mail})) {
+	    push @{$warn{mail}}, "Keine gültig erscheinende Mail-Adresse.";
+	}
+
+	foreach (keys %warn) {
+	    $warn{$_} = join " ", @{$warn{$_}};
+	}
+
+	if (!%warn) {
+	    my %r = insert(%value);
+	    sendmail(To => $value{mail},
+		     From => "hs\@schlittermann.de",
+		     "Content-Type" => "text/plain; charset=\"UTF-8\"",
+		     Subject => "Bitte die Anmeldung bestaetigen.",
+		     Message => "Bitte bestätige Deine Anmeldung, in dem Du folgende Webseite aufrufst:\n"
+		               . url(-path_info => 1, -query => 0) .  "?confirm=$r{uuid}\n");
+
+	    $tt->process("ack.tpl", {
+		value => \%value,
+		timestamp => $r{timestamp},
+		uuid => $r{uuid},
+	    }) or die $tt->error();
+	    exit 0;
+	}
+    }
+
+    if (param("confirm") =~ /^\s*(.+)\s*/) {
+	my %data = confirm($1);
+	$tt->process("confirm.tpl", {
+	    value => \%data}) or die $tt->error();
+	exit 0;
+    }
+
+    ## Formular
+    $tt->process("entry.tpl", {
+	warn => %warn ? \%warn : undef,
+	value => {
+	    givenname => scalar param("givenname"),
+	    surname => scalar param("surname"),
+	    mail => scalar param("mail"),
+	},
+    } ) or die $tt->error();
+    exit 0;
+}
+
+sub insert(\%) {
+    my %value = %{$_[0]};
+    my $uuid = sha1_hex($SECRET . values %value);
+
+    $DBH->begin_work;
+	my $sth;
+	$sth = $DBH->prepare("SELECT timestamp FROM db WHERE uuid = ?");
+	$sth->execute($uuid);
+
+	if (my $r = $sth->fetchrow_hashref) {
+	    my $timestamp = $r->{timestamp};
+	    $DBH->rollback;
+	    return (uuid => $uuid,
+	            timestamp => $r->{timestamp});
+	}
+	$sth = $DBH->prepare("INSERT INTO db 
+		(givenname, surname, mail, uuid, timestamp) 
+		VALUES(?, ?, ?, ?, ?)");
+	$sth->execute(@value{qw/givenname surname mail/}, $uuid, time);
+    $DBH->commit;
+
+    return (uuid => $uuid,
+	    timestamp => undef);
+
+}
+
+sub confirm($) {
+    my $uuid = shift;
+    my %data;
+    $DBH->begin_work;
+	my $sth = $DBH->prepare("SELECT givenname, surname, mail FROM db WHERE uuid = ?");
+	$sth->execute($uuid);
+	my $r = $sth->fetchrow_hashref;
+	if (!$r) {
+	    $DBH->rollback;
+	    return (error => "NOT FOUND");
+	}
+	%data = (
+	    givenname => $r->{givenname},
+	    surname => $r->{surname},
+	    mail => $r->{mail}
+	);
+
+	$sth = $DBH->prepare("UPDATE db SET ack = ? WHERE uuid = ?");
+	$sth->execute(1, $uuid);
+    $DBH->commit;
+
+    return %data;
+}