|
1 #! /usr/bin/perl -T |
|
2 |
|
3 use 5.010; |
|
4 use strict; |
|
5 use warnings; |
|
6 |
|
7 use Data::Dumper; |
|
8 |
|
9 use CGI qw(:all); |
|
10 use CGI::Carp qw(fatalsToBrowser); |
|
11 use Crypt::Simple; |
|
12 use Digest::SHA1 qw(sha1_hex); |
|
13 use Mail::Sendmail; |
|
14 use DBI; |
|
15 use Template; |
|
16 use File::Basename; |
|
17 use Mail::RFC822::Address qw(valid); |
|
18 |
|
19 delete @ENV{grep /PATH$/ => keys %ENV}; |
|
20 $ENV{PATH} = "/usr/bin:/usr/sbin:/bin:/sbin"; |
|
21 |
|
22 my $DSN = "DBI:SQLite:db.sqlite3"; |
|
23 my $SECRET = "iexaephuwe"; # used for generating the hash |
|
24 my $EXPIRATION = 3600; # the link is valid for 1 hour only |
|
25 my $SUBJECT = "Retter packen"; # ASCII only! *used for mail subject* |
|
26 my %FIELDS = ( |
|
27 MAN => [qw[givenname surname mail]], |
|
28 OPT => [qw[tel]] |
|
29 ); |
|
30 |
|
31 my %ttconfig = ( |
|
32 INCLUDE_PATH => "templates", |
|
33 DEBUG => 1, |
|
34 VARIABLES => { |
|
35 MAILTO => "hs+retter\@schlittermann.de" |
|
36 }, |
|
37 ); |
|
38 |
|
39 my $DBH = DBI->connect($DSN, undef, undef, {RaiseError=>1}); |
|
40 END { $DBH and $DBH->disconnect } |
|
41 |
|
42 sub insert(\%); |
|
43 sub confirm($); |
|
44 |
|
45 MAIN: { |
|
46 |
|
47 # Redirect if called without the script name, this avoids |
|
48 # other problems later |
|
49 if (basename($ENV{SCRIPT_NAME}) ne basename(url(-path_info => 0, -relative => 1))) { |
|
50 print redirect(basename($ENV{SCRIPT_NAME})); |
|
51 } |
|
52 |
|
53 # OK, let's start |
|
54 print header(-charset => "UTF-8"); |
|
55 my $tt = Template->new(\%ttconfig); |
|
56 |
|
57 # ACCESS |
|
58 # Here we generate a link URL (sent via Mail) containing the |
|
59 # encrypted current timestamp. Accessing the form is only possible |
|
60 # using this link. Note: These links may not be unique! |
|
61 if (!path_info()) { |
|
62 my %warn; |
|
63 my $sent; |
|
64 |
|
65 if (param("mail")) { |
|
66 if (not valid param("mail")) { |
|
67 $warn{mail} = "INVALID"; |
|
68 } |
|
69 else { |
|
70 my $xxx = encrypt(time); |
|
71 $xxx =~ s/\+/-/g; |
|
72 $xxx =~ s/\//_/g; |
|
73 |
|
74 # send mail |
|
75 sendmail(To => scalar(param("mail")), |
|
76 From => "hs+retter\@schlittermann.de", |
|
77 Sender => "hs\@schlittermann.de", |
|
78 Subject => "[$SUBJECT] Link zur Online-Anmeldung", |
|
79 Message => "Bitte benutze den folgenden Link, um zum Anmeldeformular zu gelangen:\n" |
|
80 . url(-query => 0) . "/$xxx\n" |
|
81 . "\n-- \nHeiko Schlittermann\n"); |
|
82 |
|
83 $sent = param("mail"); |
|
84 } |
|
85 } |
|
86 $tt->process("access.tpl", { |
|
87 sent => $sent, |
|
88 warn => %warn ? \%warn : undef, |
|
89 value => { mail => scalar param("mail") }, |
|
90 }); |
|
91 exit 0; |
|
92 } |
|
93 |
|
94 # No access without correct path_info |
|
95 if (my $_ = basename(path_info())) { |
|
96 s/_/\//g; |
|
97 s/-/+/g; |
|
98 eval { |
|
99 my $time = decrypt($_) or die "DECRYPTION ERROR"; |
|
100 $time =~ /^\d+$/ or die "FORMAT ERROR"; |
|
101 time() - $time < $EXPIRATION or die "EXPIRED"; |
|
102 }; |
|
103 if ($@) { |
|
104 $tt->process("denied.tpl", { |
|
105 url => url(-path => 0), |
|
106 }) or die $tt->error(); |
|
107 exit 0; |
|
108 } |
|
109 } |
|
110 |
|
111 ### all went fine, we start processing |
|
112 ### the form |
|
113 |
|
114 my %warn; |
|
115 my %value; |
|
116 |
|
117 ## Input |
|
118 if (param("clear")) { |
|
119 Delete_all(); |
|
120 } |
|
121 |
|
122 # Submission |
|
123 if (param("submit")) { |
|
124 foreach my $param (@{$FIELDS{MAN}}, @{$FIELDS{OPT}}) { |
|
125 |
|
126 # strip away spaces to "untaint" the variables, additionally |
|
127 # limit the length |
|
128 my $_ = param($param); |
|
129 /^\s*(.*)\s*$/; |
|
130 |
|
131 if (!length $1 and $param ~~ @{$FIELDS{MAN}}) { |
|
132 push @{$warn{$param}}, "Leer!?"; |
|
133 } |
|
134 |
|
135 if (length $1 > 200) { |
|
136 push @{$warn{$param}}, "Zu lang (bitte weniger als 200 Zeichen)."; |
|
137 } |
|
138 |
|
139 param(-name => $param, value => $1); |
|
140 $value{$param} = $1; |
|
141 } |
|
142 |
|
143 # Mail needs extra check |
|
144 if ($value{mail} and not valid($value{mail})) { |
|
145 push @{$warn{mail}}, "Keine gültig erscheinende Mail-Adresse."; |
|
146 } |
|
147 |
|
148 foreach (keys %warn) { |
|
149 $warn{$_} = join " ", @{$warn{$_}}; |
|
150 } |
|
151 |
|
152 if (!%warn) { |
|
153 my %r = insert(%value); |
|
154 sendmail(To => $value{mail}, |
|
155 From => "hs\@schlittermann.de", |
|
156 "Content-Type" => "text/plain; charset=\"UTF-8\"", |
|
157 Subject => "Bitte die Anmeldung bestaetigen.", |
|
158 Message => "Bitte bestätige Deine Anmeldung, in dem Du folgende Webseite aufrufst:\n" |
|
159 . url(-path_info => 1, -query => 0) . "?confirm=$r{uuid}\n"); |
|
160 |
|
161 $tt->process("ack.tpl", { |
|
162 value => \%value, |
|
163 timestamp => $r{timestamp}, |
|
164 uuid => $r{uuid}, |
|
165 }) or die $tt->error(); |
|
166 exit 0; |
|
167 } |
|
168 } |
|
169 |
|
170 if (param("confirm") =~ /^\s*(.+)\s*/) { |
|
171 my %data = confirm($1); |
|
172 $tt->process("confirm.tpl", { |
|
173 value => \%data}) or die $tt->error(); |
|
174 exit 0; |
|
175 } |
|
176 |
|
177 ## Formular |
|
178 $tt->process("entry.tpl", { |
|
179 warn => %warn ? \%warn : undef, |
|
180 value => { |
|
181 givenname => scalar param("givenname"), |
|
182 surname => scalar param("surname"), |
|
183 mail => scalar param("mail"), |
|
184 }, |
|
185 } ) or die $tt->error(); |
|
186 exit 0; |
|
187 } |
|
188 |
|
189 sub insert(\%) { |
|
190 my %value = %{$_[0]}; |
|
191 my $uuid = sha1_hex($SECRET . values %value); |
|
192 |
|
193 $DBH->begin_work; |
|
194 my $sth; |
|
195 $sth = $DBH->prepare("SELECT timestamp FROM db WHERE uuid = ?"); |
|
196 $sth->execute($uuid); |
|
197 |
|
198 if (my $r = $sth->fetchrow_hashref) { |
|
199 my $timestamp = $r->{timestamp}; |
|
200 $DBH->rollback; |
|
201 return (uuid => $uuid, |
|
202 timestamp => $r->{timestamp}); |
|
203 } |
|
204 $sth = $DBH->prepare("INSERT INTO db |
|
205 (givenname, surname, mail, uuid, timestamp) |
|
206 VALUES(?, ?, ?, ?, ?)"); |
|
207 $sth->execute(@value{qw/givenname surname mail/}, $uuid, time); |
|
208 $DBH->commit; |
|
209 |
|
210 return (uuid => $uuid, |
|
211 timestamp => undef); |
|
212 |
|
213 } |
|
214 |
|
215 sub confirm($) { |
|
216 my $uuid = shift; |
|
217 my %data; |
|
218 $DBH->begin_work; |
|
219 my $sth = $DBH->prepare("SELECT givenname, surname, mail FROM db WHERE uuid = ?"); |
|
220 $sth->execute($uuid); |
|
221 my $r = $sth->fetchrow_hashref; |
|
222 if (!$r) { |
|
223 $DBH->rollback; |
|
224 return (error => "NOT FOUND"); |
|
225 } |
|
226 %data = ( |
|
227 givenname => $r->{givenname}, |
|
228 surname => $r->{surname}, |
|
229 mail => $r->{mail} |
|
230 ); |
|
231 |
|
232 $sth = $DBH->prepare("UPDATE db SET ack = ? WHERE uuid = ?"); |
|
233 $sth->execute(1, $uuid); |
|
234 $DBH->commit; |
|
235 |
|
236 return %data; |
|
237 } |