web: Enforce a minimum donation of 4 Euro.
[gnupg-doc.git] / cgi / procdonate.cgi
1 #!/usr/bin/perl -T
2
3 # procdonate.cgi - Donation payment processor for gnupg.org
4 # Copyright (C) 2014 g10 Code GmbH
5 #
6 # This file is free software; as a special exception the author gives
7 # unlimited permission to copy and/or distribute it, with or without
8 # modifications, as long as this notice is preserved.
9 #
10 # This program is distributed in the hope that it will be useful, but
11 # WITHOUT ANY WARRANTY, to the extent permitted by law; without even the
12 # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14
15 use strict;
16 use CGI;
17 use Cwd qw(realpath);
18 use IO::Socket::UNIX;
19
20 realpath($0) =~ /^(.*)\/.*$/;
21 my %config = do $1 . '/config.rc';
22
23 my $htdocs =  $config{htdocs};
24 my $socket_name = $config{payprocd_socket};
25 my $error_marker = '<span style="color: red;">* error</span>';
26
27 # The form variabales are accessed via Q.
28 my $q  = new CGI;
29
30 # This is a multi-purpose CGI.  The mode decides what to do.
31 my $mode = $q->param("mode");
32 my $sessid = $q->param("sessid");
33
34 # Variables used in the template pages.
35 my $amount = "";
36 my $stripeamount = "";
37 my $euroamount = "";
38 my $currency = "";
39 my $name = "";
40 my $mail = "";
41 my $message = "";
42 my $errorstr = "";
43
44 # We use a dictionary to track error.  Those errors will then be
45 # inserted into the output by write_template.
46 my %errdict = ();
47
48 # Prototypes
49 sub fail ($);
50
51
52 # Write a template file.  A template is a proper HTML file with
53 # variables enclosed in HTML comments.  To allow inserting data into
54 # a value attribute of an input field, such a tag needs to be written as
55 #   <input value=""/><!--FOO-->
56 # the result after processing will be
57 #   <input value="foo"/>
58 # assuming that the value of FOO is foo. Note that this substitution
59 # rules work for all tags and thus you better take care to add an
60 # extra space if if do not want this to happen.
61 sub write_template ($) {
62     my $fname = shift;
63
64     my $errorpanel = '';
65     my $err_amount = '';
66     my $err_name = '';
67     my $err_mail = '';
68     my $checkother = ' checked="checked"';
69     my $sel_eur = '';
70     my $sel_usd = '';
71     my $sel_gbp = '';
72     my $sel_jpy = '';
73     my $message_fmt;
74     my $publishname;
75
76     # Avoid broken HTML attributes.
77     $amount =~ s/\x22/\x27/g;
78     $stripeamount =~ s/\x22/\x27/g;
79     $currency =~ s/\x22/\x27/g;
80     $name =~ s/\x22/\x27/g;
81     $mail =~ s/\x22/\x27/g;
82     $message =~ s/\x22/\x27/g;
83
84     # Clean possible user provided data
85     $sessid =~ s/</\x26lt;/g;
86     $amount =~ s/</\x26lt;/g;
87     $stripeamount =~ s/</\x26lt;/g;
88     $currency =~ s/</\x26lt;/g;
89     $name =~ s/</\x26lt;/g;
90     $mail =~ s/</\x26lt;/g;
91     $message =~ s/</\x26lt;/g;
92
93     # No need to clean $euroamount.
94
95     # Create a formatted message.
96     $message_fmt = $message;
97     $message_fmt =~ s/\n/<br\x2f>/g;
98
99     if ( $currency =~ /EUR/i ) {
100         $sel_eur = ' selected="selected"';
101     } elsif ( $currency =~ /USD/i ) {
102         $sel_usd = ' selected="selected"';
103     } elsif ( $currency =~ /GBP/i ) {
104         $sel_gbp = ' selected="selected"';
105     } elsif ( $currency =~ /JPY/i ) {
106         $sel_jpy = ' selected="selected"';
107     }
108
109     # Set var for the paypal button
110     if ( $name eq 'Anonymous' or $name eq '') {
111         $publishname = 'No';
112     } else {
113         $publishname = 'Yes';
114     }
115
116     # Build error strings.
117     foreach (keys %errdict)
118     {
119         if    (/amount/) { $err_amount = $error_marker; }
120         elsif (/name/)   { $err_name   = $error_marker; }
121         elsif (/mail/)   { $err_mail   = $error_marker; }
122
123         $errorpanel = $errorpanel . "Field $_: " . $errdict{$_} . "<br/>\n"
124     }
125     if ( $errorpanel ne '' )
126     {
127         $errorpanel =
128             "<div style='color: red;'><p>\n" . $errorpanel . "</p></div>\n";
129     }
130
131     open TEMPLATE, $htdocs . $fname;
132     while (<TEMPLATE>) {
133         if ( /<!--/ )
134         {
135             # Only one replacement per line allowed to avoid recursive
136             # replacements. Note that MESSAGE uses a special treatment
137             # for the textarea tag.
138             s/<!--SESSID-->/$sessid/
139             || s/(\x22\x2f>)?<!--AMOUNT-->/$amount\1/
140             || s/(\x22\x2f>)?<!--EUROAMOUNT-->/$euroamount\1/
141             || s/(\x22\x2f>)?<!--STRIPEAMOUNT-->/$stripeamount\1/
142             || s/(\x22\x2f>)?<!--CURRENCY-->/$currency\1/
143             || s/(\x22\x2f>)?<!--NAME-->/$name\1/
144             || s/(\x22\x2f>)?<!--MAIL-->/$mail\1/
145             || s/\x2f><!--CHECKOTHER-->/$checkother\x2f>/
146             || s/(<\x2ftextarea>)?<!--MESSAGE-->/$message\1/
147             || s/<!--MESSAGE_FMT-->/$message_fmt/
148             || s/(<selected=\x22selected\x22)?><!--SEL_EUR-->/$sel_eur>/
149             || s/(<selected=\x22selected\x22)?><!--SEL_USD-->/$sel_usd>/
150             || s/(<selected=\x22selected\x22)?><!--SEL_GBP-->/$sel_gbp>/
151             || s/(<selected=\x22selected\x22)?><!--SEL_JPY-->/$sel_jpy>/
152             || s/<!--PUBLISH_NAME-->/$publishname/
153             || s/<!--ERRORSTR-->/$errorstr/
154             || s/<!--ERR_AMOUNT-->/$err_amount/
155             || s/<!--ERR_NAME-->/$err_name/
156             || s/<!--ERR_MAIL-->/$err_mail/
157             || s/<!--ERRORPANEL-->/$errorpanel/;
158         }
159         print;
160     }
161     close TEMPLATE;
162     $errorstr = "";
163 }
164
165
166 # Call the payment processor daemon.  Takes the command and a
167 # reference to a dictionary with the data as input.  On return that
168 # disctionary is replaced by the response data.
169 sub payproc ($$)
170 {
171     my $cmd = shift;
172     my $data = shift;
173     my $sock;
174     my $key;
175     my $value;
176     my $status;
177     my $rest;
178
179     # print STDERR "calling payproc: ", $cmd, "<-\n";
180
181     $sock = IO::Socket::UNIX->new($socket_name)
182         or fail "socket: $!";
183     $sock->print ($cmd, "\n");
184
185     while (($key,$value) = each %$data) {
186         next if $key =~ /^_/;
187         $value =~ s/\n/\n /g;
188         $sock->print ("$key: $value\n");
189         # print STDERR "  $key: $value\n";
190     }
191     $sock->print ("\n");
192     $sock->flush or fail "write socket: $!";
193
194     %$data = ();
195     while (defined (my $line = <$sock>))
196     {
197         next if $line =~ /^\#/;
198         chomp $line;
199         last if $line eq '';
200         if (not defined $status)
201         {
202             ($status, $rest) = split(' ', $line, 2);
203             if ( $status eq 'ERR' )
204             {
205                 $rest =~ /\d+\s+\((.*)\).*/;
206                 $$data{"ERR_Description"} = $1;
207             }
208         }
209         elsif ( $line =~ /^\s+/ )
210         {
211             fail "bad dict line received" if not defined $key;
212             $$data{$key} .= "\n" . substr($line, 1);
213         }
214         else
215         {
216             ($key, $value) = split(':', $line, 2);
217             $value =~ s/^\s+//;
218             $$data{$key} = $value;
219         }
220     }
221
222     #print STDERR "payproc status: $status (", $$data{"ERR_Description"}, ")\n";
223     #while (($key,$value) = each %$data) {
224     #     print STDERR "  ", $key, ": ", $value, "\n";
225     #}
226
227     $sock->close;
228     return 1 if $status eq 'OK';
229     return 0 if $status eq 'ERR';
230     fail 'payproc did not return a proper status code';
231 }
232
233
234 # Write a page with all the data inserted.
235 sub write_overload_page ()
236 {
237     print $q->header(-type=>'text/html', -charset=>'utf-8');
238     print "\n";
239     $errorstr =
240         '<p>The system is currently processing too many requests.</p>'
241         . '<p>Please retry later.</p>';
242
243     &write_template("donate/error.html");
244 }
245
246
247 # Write an internal error page
248 sub fail ($)
249 {
250     my $desc = shift;
251
252 # FIXME: write the detailed error only to the log.
253     print $q->header(-type=>'text/html', -charset=>'utf-8');
254     print "\n";
255     $errorstr =
256         '<p>An internal error occured:</p>'
257         . "<p>$desc</p>";
258
259     write_template("donate/error.html");
260     exit 0;
261 }
262
263
264 # Write a the initial donation page.  This is usallay done to show
265 # errors.  The page is intially shown as static page.
266 sub write_main_page ()
267 {
268     print $q->header(-type=>'text/html', -charset=>'utf-8');
269     print "\n";
270     write_template("donate/index.html");
271 }
272
273
274 # Write a page with all the data inserted.
275 sub write_checkout_page ()
276 {
277     print $q->header(-type=>'text/html', -charset=>'utf-8');
278     print "\n";
279     write_template("donate/checkout.html");
280 }
281
282 # Write a page with all the data inserted specific for cards.
283 sub write_checkout_cc_page ()
284 {
285     print $q->header(-type=>'text/html', -charset=>'utf-8');
286     print "\n";
287     write_template("donate/checkout-cc.html");
288 }
289
290
291 # Write the final thank you page.
292 sub write_thanks_page ()
293 {
294     print $q->header(-type=>'text/html', -charset=>'utf-8');
295     print "\n";
296     write_template("donate/donate-thanks.html");
297 }
298
299
300 # Check the values entered at the donation page.  Return true if
301 # everything is alright.  On error the donation page is send again.
302 sub check_donation ()
303 {
304     my %data;
305     my $anyerr = 0;
306
307     # Note: When re-displaying the page we always use amount other
308     # because that is easier to implement than figuring out which
309     # amount and currency was used and check the appropriate radio
310     # button.
311     $amount = $q->param("amount");
312     if ($amount eq 'other') {
313       $amount = $q->param("amountother");
314       $currency = $q->param("currency");
315     } else {
316       $currency = 'EUR';
317     }
318     $name = $q->param("name");
319     $name = 'Anonymous' if $name eq '';
320     $mail = $q->param("mail");
321     $message = $q->param("message");
322     $stripeamount = "0";
323
324     # Check the amount.
325     $data{"Amount"} = $amount;
326     $data{"Currency"} = $currency;
327     if (not payproc ('CHECKAMOUNT', \%data )) {
328         $errdict{"amount"} = $data{"ERR_Description"};
329         $anyerr = 1;
330     }
331     $stripeamount = $data{"_amount"};
332     $amount = $data{"Amount"};
333     $currency = $data{"Currency"};
334     $euroamount = $data{"Euro"};
335
336     # Check that at least some Euros are given.  Due to Stripe
337     # processing fees and our own costs for bookkeeping we need to ask
338     # for a minimum amount.
339     if ( (not $anyerr) and ($euroamount < 4.00) ) {
340         $errdict{"amount"} = 'Sorry, due to overhead costs we do' .
341                              ' not accept donations of less than 4 Euro.';
342         $anyerr = 1;
343     }
344
345
346     # Check the mail address
347     if ($mail ne '' and $mail !~ /\S+@\S+\.\S+/ ) {
348         $errdict{"mail"} = 'invalid mail address';
349         $anyerr = 1;
350     }
351
352     # If needed present errors and ask again.  */
353     if ($anyerr) {
354         write_main_page();
355         return;
356     }
357
358
359     # Now create a session.
360     $data{"Stripeamount"} = $stripeamount;
361     $data{"Euroamount"} = $euroamount;
362     $data{"Name"} = $name;
363     $data{"Mail"} = $mail;
364     $data{"Message"} = $message;
365     payproc ('SESSION create', \%data ) or fail $data{"ERR_Description"};
366     $sessid = $data{"_SESSID"};
367
368     # Send the checkout page.
369     write_checkout_page();
370 }
371
372 # This simply resends the main page again.
373 sub resend_main_page ()
374 {
375     my %data;
376
377     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
378     $amount = $data{"Amount"};
379     $currency = $data{"Currency"};
380     $stripeamount = $data{"Stripeamount"};
381     $euroamount = $data{"Euroamount"};
382     $name = $data{"Name"};
383     $mail = $data{"Mail"};
384     $message = $data{"Message"};
385
386     write_main_page();
387 }
388
389
390 # This simply resends the checkout options page.
391 sub resend_card_checkout ()
392 {
393     my %data;
394
395     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
396     $amount = $data{"Amount"};
397     $currency = $data{"Currency"};
398     $stripeamount = $data{"Stripeamount"};
399     $euroamount = $data{"Euroamount"};
400     $name = $data{"Name"};
401     $mail = $data{"Mail"};
402     $message = $data{"Message"};
403
404     write_checkout_page();
405 }
406
407
408
409 # This simply sends the card specific checkout page.
410 sub prepare_card_checkout ()
411 {
412     my %data;
413
414     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
415     $amount = $data{"Amount"};
416     $currency = $data{"Currency"};
417     $stripeamount = $data{"Stripeamount"};
418     $euroamount = $data{"Euroamount"};
419     $mail = $data{"Mail"};
420
421     write_checkout_cc_page();
422 }
423
424
425 # This is called by FIXME
426 sub complete_stripe_checkout ()
427 {
428     my %data;
429     my %stripe;
430
431     # fixme: Change the error message to note that the card has not
432     # been charged.  Somehow delete the token
433     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
434
435     # Do the checkout.
436     $stripe{"Card-Token"} = $q->param("stripeToken");
437     $stripe{"Currency"} = $data{"Currency"};
438     $stripe{"Amount"} = $data{"Amount"};
439     $stripe{"Desc"} =
440         "GnuPG donation by " . $data{"Name"} . " <" . $data{"Mail"} . ">";
441     $stripe{"Stmt-Desc"} = "GnuPG donation";
442     $stripe{"Email"} = $q->param("stripeEmail");
443     $stripe{"Meta[name]"} = $data{"Name"} unless $data{"Name"} eq 'Anonymous';
444     if ($data{"Mail"} ne $q->param("stripeEmail")) {
445         $stripe{"Meta[mail]"} = $data{"Mail"};
446     }
447     if ($data{"Message"} ne '') {
448         $stripe{"Meta[message]"} = $data{"Message"};
449     }
450     if (not payproc ('CHARGECARD', \%stripe)) {
451         $errorstr =
452             '<p>Error: ' . $stripe{"failure"} . '</p><p>'
453             . $stripe{"failure-mesg"} . '</p>';
454         # Again.
455         prepare_card_checkout ();
456         return;
457     }
458
459     # Print thanks
460
461     $message = <<EOF;
462 Amount ..: $stripe{"Amount"} $stripe{"Currency"}
463 Desc ....: $stripe{"Desc"}
464 Cardno...: *$stripe{"Last4"}
465 Processor: Stripe
466 Email ...: $stripe{"Email"}
467 Charge-Id: $stripe{"Charge-Id"}
468 Timestamp: $stripe{"_timestamp"}
469 EOF
470     if ($stripe{"Live"} eq 'f') {
471         $message = $message . "\n!!! TEST TRANSACTION !!!";
472     }
473
474     write_thanks_page ();
475     payproc ('SESSION destroy ' . $sessid, ());
476 }
477
478
479
480
481
482 #
483 # Main
484 #
485 #print STDERR "CGI called with mode=$mode\n";
486 #print STDERR "CGI called with sessid=$sessid\n";
487 if ($q->param('url') ne '') {
488     # If the URL field has been filled out, the client did not follow
489     # the instructions and thus failed the Turing test.  Provide an
490     # innocent error page.
491     write_overload_page ()
492 }
493 elsif ($mode eq 'main') {
494     # Returning from the donation start page
495     check_donation();
496 }
497 elsif ($mode eq 're-main') {
498     # Returning from the donation start page
499     resend_main_page();
500 }
501 elsif ($mode eq 're-checkout') {
502     # Redisplay the checkout option page
503     resend_card_checkout();
504 }
505 elsif ($mode eq 'checkout-cc') {
506     # The checkout page requested a card checkout.
507     prepare_card_checkout();
508 }
509 elsif ($mode eq 'checkout-stripe') {
510     # we have the stripe token - charge the card.
511     complete_stripe_checkout();
512 }
513 else {
514     fail('Internal error: Unknown mode');
515 }