cgi: remove special amount handling
[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 qw/:standard -debug/;
17 use CGI;
18 use Cwd qw(realpath);
19 use IO::Socket::UNIX;
20
21 realpath($0) =~ /^(.*)\/.*$/;
22 my %config = do $1 . '/config.rc';
23
24 my $baseurl = $config{baseurl};
25 my $htdocs =  $config{htdocs};
26 my $stripepubkey =  $config{stripepubkey};
27 my $socket_name = $config{payprocd_socket};
28 my $error_marker = '<span style="color: red;">* error</span>';
29
30 # The form variables are accessed via Q.
31 my $q  = new CGI;
32
33 # This is a multi-purpose CGI.  The mode decides what to do.
34 my $mode = $q->param("mode");
35 my $sessid = $q->param("sessid");
36 my $lang = $q->param("lang");
37
38 # Variables used in the template pages.
39 my $amount = "";
40 my $paytype = "";
41 my $stripeamount = "";
42 my $euroamount = "";
43 my $currency = "";
44 my $recur = "";
45 my $name = "";
46 my $mail = "";
47 my $message = "";
48 my $separef = "";
49 my $errorstr = "";
50
51 # We use a dictionary to track error.  Those errors will then be
52 # inserted into the output by write_template.
53 my %errdict = ();
54
55 # Prototypes
56 sub fail ($);
57 sub get_paypal_approval ();
58 sub complete_sepa ();
59
60
61 # Write a template file.  A template is a proper HTML file with
62 # variables enclosed in HTML comments.  To allow inserting data into
63 # a value attribute of an input field, such a tag needs to be written as
64 #   <input value=""/><!--FOO-->
65 # the result after processing will be
66 #   <input value="foo"/>
67 # assuming that the value of FOO is foo. Note that this substitution
68 # rules work for all tags and thus you better take care to add an
69 # extra space if you do not want this to happen.
70 sub write_template ($) {
71     my $fname = shift;
72
73     my $tname;
74     my $errorpanel = $errorstr;
75     my $err_amount = '';
76     my $err_name = '';
77     my $err_mail = '';
78     my $err_paytype = '';
79     my $check_checked = ' checked="checked"';
80     my $sel_eur = '';
81     my $sel_usd = '';
82     my $sel_gbp = '';
83     my $sel_jpy = '';
84     my $chk_amt500 = '';
85     my $chk_amt200 = '';
86     my $chk_amt100 = '';
87     my $chk_amt50 = '';
88     my $chk_amt20 = '';
89     my $chk_amt10 = '';
90     my $chk_amt5 = '';
91     my $chk_amtx = '';
92     my $amt_other = '';
93     my $recur_none = '';
94     my $recur_month = '';
95     my $recur_quarter = '';
96     my $recur_year = '';
97     my $recur_text = '';
98     my $message_fmt;
99     my $publishname;
100     my $check_paytype = 'none';
101     my $stripe_data_email = '';
102     my $stripe_data_label_value;
103     my $xamount;
104     my $stripelocale;
105
106     # Avoid broken HTML attributes.
107     $amount =~ s/\x22/\x27/g;
108     $stripeamount =~ s/\x22/\x27/g;
109     $currency =~ s/\x22/\x27/g;
110     $recur =~ s/\x22/\x27/g;
111     $name =~ s/\x22/\x27/g;
112     $mail =~ s/\x22/\x27/g;
113     $message =~ s/\x22/\x27/g;
114     $separef =~ s/\x22/\x27/g;
115     $lang =~ s/\x22/\x27/g;
116
117     # Clean possible user provided data
118     $sessid =~ s/</\x26lt;/g;
119     $lang =~ s/</\x26lt;/g;
120     $amount =~ s/</\x26lt;/g;
121     $stripeamount =~ s/</\x26lt;/g;
122     $currency =~ s/</\x26lt;/g;
123     $recur =~ s/</\x26lt;/g;
124     $name =~ s/</\x26lt;/g;
125     $mail =~ s/</\x26lt;/g;
126     $message =~ s/</\x26lt;/g;
127     $separef =~ s/</\x26lt;/g;
128
129     # No need to clean $euroamount.
130
131     # Check whether a translated template is available.
132     $tname = $htdocs . $fname;
133     $tname =~ s/\.html$/.$lang.html/;
134     if ( not -f $tname ) { $tname = $htdocs . $fname; }
135
136     # Create a formatted message.
137     $message_fmt = $message;
138     $message_fmt =~ s/\n/<br\x2f>/g;
139
140     # Check the currency and predefined amount.
141     if ( $currency =~ /EUR/i ) {
142         $sel_eur = ' selected="selected"';
143         $chk_amtx = $check_checked;
144         $amt_other = $amount;
145     } elsif ( $currency =~ /USD/i ) {
146         $sel_usd = ' selected="selected"';
147         $chk_amtx = $check_checked;
148         $amt_other = $amount;
149     } elsif ( $currency =~ /GBP/i ) {
150         $sel_gbp = ' selected="selected"';
151         $chk_amtx = $check_checked;
152         $amt_other = $amount;
153     } elsif ( $currency =~ /JPY/i ) {
154         $sel_jpy = ' selected="selected"';
155         $chk_amtx = $check_checked;
156         $amt_other = $amount;
157     } else {
158         $chk_amtx = $check_checked;
159         $amt_other = $amount;
160     }
161
162     # For non-recurring Stripe donations we do not want to send a
163     #     data-email="$mail"
164     # line to Stripe so to enable the user to use a a different mail
165     # address for use with them.  This is implemented using a
166     # STRIPE_DATA_EMAIL template variable.
167     $stripe_data_email = 'data-email="' . $mail . '"';
168     if ( $recur =~ /0/ ) {
169         $stripe_data_email = '';
170         $recur_none    = ' selected="selected"';
171         $recur_text    = '';
172
173         if ($lang eq 'de') {
174             $stripe_data_label_value = 'Einmalig spenden';
175         } elsif ($lang eq 'ja') {
176             $stripe_data_label_value = '一回の寄付する';
177         } else {
178             $stripe_data_label_value = 'Make one-time donation';
179         }
180
181     } elsif ( $recur =~ /12/ ) {
182         $recur_month   = ' selected="selected"';
183
184         if ($lang eq 'de') {
185             $recur_text    = 'monatlich';
186             $stripe_data_label_value = 'Monatlich spenden';
187         } elsif ($lang eq 'ja') {
188             $recur_text    = '毎月';
189             $stripe_data_label_value = '毎月寄付する';
190         } else {
191             $recur_text    = 'monthly';
192             $stripe_data_label_value = 'Donate monthly';
193         }
194
195     } elsif ( $recur =~ /4/ ) {
196         $recur_quarter = ' selected="selected"';
197
198         if ($lang eq 'de') {
199             $recur_text    = 'vierteljährlich';
200             $stripe_data_label_value = 'Vierteljährlich spenden';
201         } elsif ($lang eq 'ja') {
202             $recur_text    = '3ヶ月毎';
203             $stripe_data_label_value = '3ヶ月毎に寄付する';
204         } else {
205             $recur_text    = 'quarterly';
206             $stripe_data_label_value = 'Donate quarterly';
207         }
208
209     } elsif ( $recur =~ /1/ ) {
210         $recur_year    = ' selected="selected"';
211
212         if ($lang eq 'de') {
213             $recur_text    = 'jährlich';
214             $stripe_data_label_value = 'Jährlich spenden';
215         } elsif ($lang eq 'ja') {
216             $recur_text    = '毎年';
217             $stripe_data_label_value = '毎年寄付する';
218         } else {
219             $recur_text    = 'yearly';
220             $stripe_data_label_value = 'Donate yearly';
221         }
222
223     } else { # invalid
224         $stripe_data_label_value = '';
225     }
226
227     if ( $paytype eq "cc" ) {
228         $check_paytype = "CC";
229     } elsif ( $paytype eq "pp" ) {
230         $check_paytype = "PP";
231     } elsif ( $paytype eq "se" ) {
232         $check_paytype = "SE";
233     } elsif ( $paytype eq "bc" ) {
234         $check_paytype = "BC";
235     }
236
237     # Set var for the paypal button
238     if ( $name eq 'Anonymous' or $name eq '') {
239         $publishname = 'No';
240     } else {
241         $publishname = 'Yes';
242     }
243
244
245
246     # Set a specific locale.
247     if ($lang eq 'de')    { $stripelocale = "de"; }
248     elsif ($lang eq 'ja') { $stripelocale = "ja"; }
249     elsif ($lang eq 'en') { $stripelocale = "en"; }
250     else                  { $stripelocale = "auto"; }
251
252
253     # Build error strings.
254     foreach (keys %errdict)
255     {
256         my $fieldname;
257
258         if ($lang eq 'de')    { $fieldname = "Feld $_: ";  }
259         elsif ($lang eq 'ja') { $fieldname = "欄 $_: "; }
260         else                  { $fieldname = "Field $_: "; }
261
262         if    (/amount/) { $err_amount = $error_marker; }
263         elsif (/name/)   { $err_name   = $error_marker; }
264         elsif (/mail/)   { $err_mail   = $error_marker; }
265         elsif (/paytype/){ $err_paytype = $error_marker; }
266
267         $errorpanel = $errorpanel . $fieldname . $errdict{$_} . "<br/>\n"
268     }
269     if ( $errorpanel ne '' )
270     {
271         $errorpanel =
272             "<div style='color: red;'><p>\n" . $errorpanel . "</p></div>\n";
273     }
274
275
276     open TEMPLATE, $tname;
277     while (<TEMPLATE>) {
278         if ( /<!--/ )
279         {
280         # Only one replacement per line allowed to avoid recursive
281         # replacements. Note that MESSAGE uses a special treatment
282         # for the textarea tag.
283         s/<!--SESSID-->/$sessid/
284         || s/(\x22\x2f>)?<!--AMOUNT-->/$amount\1/
285         || s/(\x22\x2f>)?<!--AMT_OTHER-->/$amt_other\1/
286         || s/(\x22\x2f>)?<!--EUROAMOUNT-->/$euroamount\1/
287         || s/(\x22\x2f>)?<!--STRIPEPUBKEY-->/$stripepubkey\1/
288         || s/(\x22\x2f>)?<!--STRIPELOCALE-->/$stripelocale\1/
289         || s/(\x22\x2f>)?<!--STRIPEAMOUNT-->/$stripeamount\1/
290         || s/(\x22\x2f>)?<!--CURRENCY-->/$currency\1/
291         || s/(\x22\x2f>)?<!--NAME-->/$name\1/
292         || s/(\x22\x2f>)?<!--MAIL-->/$mail\1/
293         || s/\x2f><!--CHECK_$check_paytype-->/$check_checked\x2f>/
294         || s/(<\x2ftextarea>)?<!--MESSAGE-->/$message\1/
295         || s/<!--MESSAGE_FMT-->/$message_fmt/
296         || s/(<selected=\x22selected\x22)?><!--SEL_EUR-->/$sel_eur>/
297         || s/(<selected=\x22selected\x22)?><!--SEL_USD-->/$sel_usd>/
298         || s/(<selected=\x22selected\x22)?><!--SEL_GBP-->/$sel_gbp>/
299         || s/(<selected=\x22selected\x22)?><!--SEL_JPY-->/$sel_jpy>/
300         || s/(<selected=\x22selected\x22)?><!--RECUR_NONE-->/$recur_none>/
301         || s/(<selected=\x22selected\x22)?><!--RECUR_MONTH-->/$recur_month>/
302         || s/(<selected=\x22selected\x22)?><!--RECUR_QUARTER-->/$recur_quarter>/
303         || s/(<selected=\x22selected\x22)?><!--RECUR_YEAR-->/$recur_year>/
304         || s/(<check=\x22checked\x22)?\x2f><!--CHK_AMT500-->/$chk_amt500\x2f>/
305         || s/(<check=\x22checked\x22)?\x2f><!--CHK_AMT200-->/$chk_amt200\x2f>/
306         || s/(<check=\x22checked\x22)?\x2f><!--CHK_AMT100-->/$chk_amt100\x2f>/
307         || s/(<check=\x22checked\x22)?\x2f><!--CHK_AMT50-->/$chk_amt50\x2f>/
308         || s/(<check=\x22checked\x22)?\x2f><!--CHK_AMT20-->/$chk_amt20\x2f>/
309         || s/(<check=\x22checked\x22)?\x2f><!--CHK_AMT10-->/$chk_amt10\x2f>/
310         || s/(<check=\x22checked\x22)?\x2f><!--CHK_AMT5-->/$chk_amt5\x2f>/
311         || s/(<check=\x22checked\x22)?\x2f><!--CHK_AMTX-->/$chk_amtx\x2f>/
312         || s/<!--RECUR_TEXT-->/$recur_text/
313         || s/<!--STRIPE_DATA_EMAIL-->/$stripe_data_email/
314         || s/<!--STRIPE_DATA_LABEL_VALUE-->/$stripe_data_label_value/
315         || s/<!--PUBLISH_NAME-->/$publishname/
316         || s/<!--LANG-->/$lang/
317         || s/<!--SEPA_REF-->/$separef/
318         || s/<!--ERRORSTR-->/$errorstr/
319         || s/<!--ERR_AMOUNT-->/$err_amount/
320         || s/<!--ERR_NAME-->/$err_name/
321         || s/<!--ERR_MAIL-->/$err_mail/
322         || s/<!--ERR_PAYTYPE-->/$err_paytype/
323         || s/<!--ERRORPANEL-->/$errorpanel/;
324         }
325         print;
326     }
327     close TEMPLATE;
328     $errorstr = "";
329 }
330
331
332 # Call the payment processor daemon.  Takes the command and a
333 # reference to a dictionary with the data as input.  On return that
334 # disctionary is replaced by the response data.
335 sub payproc ($$)
336 {
337     my $cmd = shift;
338     my $data = shift;
339     my $sock;
340     my $key;
341     my $value;
342     my $status;
343     my $rest;
344
345     # print STDERR "calling payproc: ", $cmd, "<-\n";
346
347     $sock = IO::Socket::UNIX->new($socket_name)
348         or fail "Error connecting to payprocd: $!";
349     $sock->print ($cmd, "\n");
350
351     while (($key,$value) = each %$data) {
352         next if $key =~ /^_/;
353         $value =~ s/\n/\n /g;
354         $sock->print ("$key: $value\n");
355         # print STDERR "  $key: $value\n";
356     }
357     $sock->print ("\n");
358     $sock->flush or fail "write socket: $!";
359
360     %$data = ();
361     while (defined (my $line = <$sock>))
362     {
363         next if $line =~ /^\#/;
364         chomp $line;
365         last if $line eq '';
366         if (not defined $status)
367         {
368             ($status, $rest) = split(' ', $line, 2);
369             if ( $status eq 'ERR' )
370             {
371                 $rest =~ /\d+\s+\((.*)\).*/;
372                 $$data{"ERR_Description"} = $1;
373             }
374         }
375         elsif ( $line =~ /^\s+/ )
376         {
377             fail "bad dict line received" if not defined $key;
378             $$data{$key} .= "\n" . substr($line, 1);
379         }
380         else
381         {
382             ($key, $value) = split(':', $line, 2);
383             $value =~ s/^\s+//;
384             $$data{$key} = $value;
385         }
386     }
387
388     #print STDERR "payproc status: $status (", $$data{"ERR_Description"}, ")\n";
389     #while (($key,$value) = each %$data) {
390     #     print STDERR "  ", $key, ": ", $value, "\n";
391     #}
392
393     $sock->close;
394     return 1 if $status eq 'OK';
395     return 0 if $status eq 'ERR';
396     fail 'payproc did not return a proper status code';
397 }
398
399
400 # Write a dummy page
401 sub write_overload_page ()
402 {
403     print $q->header(-type=>'text/html', -charset=>'utf-8');
404     print "\n";
405     $errorstr =
406         '<p>The system is currently processing too many requests.</p>'
407         . '<p>Please retry later.</p>';
408
409     &write_template("donate/error.html");
410 }
411
412 sub write_cancel_page ()
413 {
414     print $q->header(-type=>'text/html', -charset=>'utf-8');
415     print "\n";
416     &write_template("donate/paypal-can.html");
417 }
418
419
420 # Write an internal error page
421 sub fail ($)
422 {
423     my $desc = shift;
424
425 # FIXME: write the detailed error only to the log.
426     print $q->header(-type=>'text/html', -charset=>'utf-8');
427     print "\n";
428     $errorstr =
429         '<p>An internal error occured:</p>'
430         . "<p>$desc</p>";
431
432     write_template("donate/error.html");
433     exit 0;
434 }
435
436
437 # Write a the initial donation page.  This is usallay done to show
438 # errors.  The page is intially shown as static page.
439 sub write_main_page ()
440 {
441     print $q->header(-type=>'text/html', -charset=>'utf-8');
442     print "\n";
443     write_template("donate/donate.html");
444 }
445
446
447 # Write a page with all the data inserted.
448 sub write_checkout_page ()
449 {
450     print $q->header(-type=>'text/html', -charset=>'utf-8');
451     print "\n";
452     if ( $paytype eq "cc" ) {
453         write_template("donate/checkout-cc.html");
454     }
455     elsif ( $paytype eq "pp" ) {
456         write_template("donate/checkout-pp.html");
457     }
458     elsif ( $paytype eq "bc" ) {
459         # For Bitcoins this is the final page
460         write_template("donate/checkout-bc.html");
461     }
462     else {
463         # For SEPA this is the final page
464         write_template("donate/checkout-se.html");
465     }
466 }
467
468
469 # Write the final thank you page.
470 sub write_thanks_page ()
471 {
472     print $q->header(-type=>'text/html', -charset=>'utf-8');
473     print "\n";
474     write_template("donate/donate-thanks.html");
475 }
476
477
478 # Check the values entered at the donation page.  Return true if
479 # everything is alright.  On error the donation page is send again.
480 sub check_donation ()
481 {
482     my %data;
483     my %sepa;
484     my $anyerr = 0;
485     my $msg;
486
487     $amount = $q->param("amount");
488     if ($amount eq 'other') {
489       $amount = $q->param("amountother");
490       $currency = $q->param("currency");
491     } else {
492       $currency = 'EUR';
493     }
494
495     $recur = $q->param("recur");
496     $name = $q->param("name");
497     $name = 'Anonymous' if $name eq '';
498     $mail = $q->param("mail");
499     $message = $q->param("message");
500     $stripeamount = "0";
501
502     # Check the amount and the recurring value
503     $data{"Amount"} = $amount;
504     $data{"Currency"} = $currency;
505     $data{"Recur"} = $recur;
506     if (not payproc ('CHECKAMOUNT', \%data )) {
507         $errdict{"amount"} = $data{"ERR_Description"};
508         $anyerr = 1;
509     }
510     $stripeamount = $data{"_amount"};
511     $amount = $data{"Amount"};
512     $recur = $data{"Recur"};
513     $currency = $data{"Currency"};
514     $euroamount = $data{"Euro"};
515
516     # Check that at least some Euros are given.  Due to Stripe
517     # processing fees and our own costs for bookkeeping we need to ask
518     # for a minimum amount.
519     if ( (not $anyerr) and ($euroamount < 4.00) ) {
520
521         if ($lang eq 'de') {
522             $msg= 'Um unsere Verwaltungskosten niedrig zu halten,'
523                 . 'können wir leider keine Spenden unter 4 Euro annehmen.';
524         } elsif ($lang eq 'ja') {
525             $msg = '申し訳ありません。間接経費のため、4ユーロ未満の寄付'
526                 . 'は受け付けることができません。';
527         }
528         else {
529             $msg = 'Sorry, due to overhead costs we do'
530                 . ' not accept donations of less than 4 Euro.';
531         }
532
533         $errdict{"amount"} = $msg;
534         $anyerr = 1;
535     }
536
537     # Check the payment type
538     $paytype = $q->param("paytype");
539     if ( $paytype eq "bc" ) {
540         # No further checks - this is kind of a hack.
541     }
542     elsif ( $paytype ne "cc" and $paytype ne "pp" and $paytype ne "se" ) {
543
544         if ($lang eq 'de') {
545             $msg= 'Keine Zahlungsart angegeben.'
546                 . ' Bitte "Kreditkarte", "PayPal" oder "SEPA" auswählen.';
547         } elsif ($lang eq 'ja') {
548             $msg= '支払い方式が選択されていません。'
549                 . '"クレジットカード", "PayPal", または "SEPA" が選択できます。';
550         }
551         else {
552             $msg= 'No payment type selected.'
553                 . ' Use "Credit Card", "PayPal", or "SEPA".';
554         }
555
556         $errdict{"paytype"} = $msg;
557         $anyerr = 1;
558     }
559
560     # SEPA credit transfers are only possible in Euro.
561     # (yes, this may overwrite an earlier error message).
562     if ( $paytype eq "se" and $currency ne "EUR" ) {
563         $errdict{"amount"} = 'SEPA transfers are only possible in EUR.';
564         $anyerr = 1;
565     }
566
567     # Check the mail address
568     if ($mail ne '' and $mail !~ /\S+@\S+\.\S+/ ) {
569         $errdict{"mail"} = 'invalid mail address';
570         $anyerr = 1;
571     }
572
573     # If needed present errors and ask again.  */
574     if ($anyerr) {
575         write_main_page();
576         return;
577     }
578
579     # Now create a session.
580     $data{"lang"} = $lang;
581     $data{"Stripeamount"} = $stripeamount;
582     $data{"Euroamount"} = $euroamount;
583     $data{"Recur"} = $recur;
584     $data{"Name"} = $name;
585     $data{"Mail"} = $mail;
586     $data{"Message"} = $message;
587     $data{"Paytype"} = $paytype;
588     payproc ('SESSION create', \%data ) or fail $data{"ERR_Description"};
589     $sessid = $data{"_SESSID"};
590
591     # Send the checkout page or redirect to paypal
592     if ( $paytype eq "pp" ) {
593         get_paypal_approval ();
594     }
595     elsif ( $paytype eq "se" ) {
596         complete_sepa ();
597     }
598     else {
599         write_checkout_page();
600     }
601 }
602
603 # This simply resends the main page again.
604 sub resend_main_page ()
605 {
606     my %data;
607
608     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
609     # If the session has a lang value use that.
610     if ($data{"lang"} ne '') {
611         $lang = $data{"lang"};
612     }
613     $amount = $data{"Amount"};
614     $currency = $data{"Currency"};
615     $recur = $data{"Recur"};
616     $paytype = $data{"Paytype"};
617     $stripeamount = $data{"Stripeamount"};
618     $euroamount = $data{"Euroamount"};
619     $name = $data{"Name"};
620     $mail = $data{"Mail"};
621     $message = $data{"Message"};
622
623     write_main_page();
624 }
625
626
627 # This is called by FIXME
628 sub complete_stripe_checkout ()
629 {
630     my %data;
631     my %stripe;
632     my $recur;
633     my $recur_text = '';
634
635     # fixme: Change the error message to note that the card has not
636     # been charged.  Somehow delete the token
637     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
638
639     # If the session has a lang value use that.
640     if ($data{"lang"} ne '') {
641         $lang = $data{"lang"};
642     }
643
644     # Do the checkout.
645     $stripe{"Card-Token"} = $q->param("stripeToken");
646     $stripe{"Currency"} = $data{"Currency"};
647     $stripe{"Amount"} = $data{"Amount"};
648     $stripe{"Desc"} =
649         "GnuPG donation by " . $data{"Name"} . " <" . $data{"Mail"} . ">";
650     $stripe{"Stmt-Desc"} = "GnuPG donation";
651     $stripe{"Email"} = $q->param("stripeEmail");
652     $stripe{"Recur"} = $data{"Recur"};
653     $stripe{"Meta[name]"} = $data{"Name"} unless $data{"Name"} eq 'Anonymous';
654     if ($data{"Mail"} ne $q->param("stripeEmail")) {
655         $stripe{"Meta[mail]"} = $data{"Mail"};
656     }
657     if ($data{"Message"} ne '') {
658         $stripe{"Meta[message]"} = $data{"Message"};
659     }
660     if (not payproc ('CHARGECARD', \%stripe)) {
661         $errorstr =
662             '<p>Error: ' . $stripe{"failure"} . '</p><p>'
663             . $stripe{"failure-mesg"} . '</p>';
664         # Again.
665         write_checkout_page ();
666         return;
667     }
668
669     # Print thanks
670     $recur = $stripe{"Recur"};
671     if ( $recur =~ /12/ ) {
672         if ($lang eq 'de')    { $recur_text = 'monatlich'; }
673         elsif ($lang eq 'ja') { $recur_text = '毎月'; }
674         else                  { $recur_text = 'Monthly'; }
675     } elsif ( $recur =~ /4/ ) {
676         if ($lang eq 'de')    { $recur_text = 'vierteljährlich'; }
677         elsif ($lang eq 'ja') { $recur_text = '3ヶ月毎'; }
678         else                  { $recur_text = 'Quarterly'; }
679     } elsif ( $recur =~ /1/ ) {
680         if ($lang eq 'de')    { $recur_text = 'jährlich'; }
681         elsif ($lang eq 'ja') { $recur_text = '毎年'; }
682         else                  { $recur_text = 'Yearly'; }
683     } else {
684         if ($lang eq 'de')    { $recur_text = 'nein'; }
685         elsif ($lang eq 'ja') { $recur_text = '一回だけ'; }
686         else                  { $recur_text = 'Just once'; }
687     }
688
689     if ($lang eq 'de') {
690         $message = <<EOF;
691 Betrag ......: $stripe{"Amount"} $stripe{"Currency"}
692 Dauerauftrag : $recur_text
693 Beschreibung : $stripe{"Desc"}
694 Kartennr. ...: *$stripe{"Last4"}
695 Dienstleister: Stripe
696 Charge-Id ...: $stripe{"Charge-Id"}
697 Zeitstempel .: $stripe{"_timestamp"}
698 Email .......: $stripe{"Email"}
699 EOF
700         if ($stripe{"account-id"} ne '') {
701             $message = $message . "Spender-ID ..: " . $stripe{"account-id"};
702         }
703     } elsif ($lang eq 'ja') {
704         $message = <<EOF;
705 金額 ......: $stripe{"Amount"} $stripe{"Currency"}
706 毎回?一回? : $recur_text
707 説明 ......: $stripe{"Desc"}
708 カード番号 : *$stripe{"Last4"}
709 決済業者 ..: Stripe
710 Charge-Id .: $stripe{"Charge-Id"}
711 時刻 ......: $stripe{"_timestamp"}
712 メール ....: $stripe{"Email"}
713 EOF
714         if ($stripe{"account-id"} ne '') {
715             $message = $message . "Account-Id : " . $stripe{"account-id"};
716         }
717     } else {
718          $message = <<EOF;
719 Amount ....: $stripe{"Amount"} $stripe{"Currency"}
720 Recurring .: $recur_text
721 Desc ......: $stripe{"Desc"}
722 Cardno.....: *$stripe{"Last4"}
723 Processor .: Stripe
724 Charge-Id .: $stripe{"Charge-Id"}
725 Timestamp .: $stripe{"_timestamp"}
726 Email .....: $stripe{"Email"}
727 EOF
728         if ($stripe{"account-id"} ne '') {
729             $message = $message . "Account-Id : " . $stripe{"account-id"};
730         }
731     }
732
733     if ($stripe{"Live"} eq 'f') {
734         $message = $message . "\n!!! TEST TRANSACTION !!!";
735     }
736
737     write_thanks_page ();
738     payproc ('SESSION destroy ' . $sessid, ());
739 }
740
741
742 # Initiate a payment with paypal and redirect to the Paypal site.
743 sub get_paypal_approval ()
744 {
745     my %data;
746     my %request;
747     my $redirurl;
748
749     payproc ('SESSION get ' . $sessid, \%data)
750         or fail $data{"ERR_Description"};
751
752     # If the session has a lang value use that.
753     if ($data{"lang"} ne '') {
754         $lang = $data{"lang"};
755     }
756
757     $request{"Currency"} = $data{"Currency"};
758     $request{"Amount"} = $data{"Amount"};
759     $request{"Desc"} =
760         "Donation of " . $data{"Amount"} . " " . $data{"Currency"} .
761         " to the GnuPG project";
762     $request{"Meta[name]"} = $data{"Name"} unless
763         $data{"Name"} eq 'Anonymous';
764     $request{"Meta[mail]"} = $data{"Mail"};
765     if ($data{"Message"} ne '') {
766         $request{"Meta[message]"} = $data{"Message"};
767     }
768     $request{"Return-Url"} =
769         $baseurl . "/cgi-bin/procdonate.cgi?mode=confirm-paypal";
770     $request{"Cancel-Url"} =
771         $baseurl . "/cgi-bin/procdonate.cgi?mode=cancel-paypal";
772     $request{"Session-Id"} = $sessid;
773
774     if (payproc ('GETINFO live', ())) {
775       $request{"Paypal-Xp"} = "XP-HD8G-XZRE-W7MH-EYNF";
776     } else {
777       $request{"Paypal-Xp"} = "XP-NBWZ-QR6Z-8CXV-Q8XS";
778     }
779
780     if (not payproc ('PPCHECKOUT prepare', \%request)) {
781         $errorstr = $request{"ERR_Description"};
782         # Back to the main page.
783         write_main_page();
784         return;
785     }
786
787     $redirurl = $request{"Redirect-Url"};
788
789     #print STDERR "Redirecting to: $redirurl\n";
790     print $q->redirect($redirurl) unless $redirurl eq "";
791 }
792
793
794 # The is called by paypal after approval.  We need to extract the alias
795 # and the payerid and store it in the session.  Then we ask to confirm
796 # the payment.
797 sub confirm_paypal_checkout ()
798 {
799     my $aliasid;
800     my $payerid;
801     my %data;
802
803     $aliasid = $q->param("aliasid");
804     $payerid = $q->param("PayerID");
805
806     # Get the session from the alias and store the aliasid and the
807     # payerid in the session.
808     payproc ('SESSION sessid ' . $aliasid, \%data)
809         or fail $data{"ERR_Description"};
810     $sessid = $data{"_SESSID"};
811     payproc ('SESSION get ' . $sessid, \%data)
812         or fail $data{"ERR_Description"};
813
814     # If the session has a lang value use that.
815     if ($data{"lang"} ne '') {
816         $lang = $data{"lang"};
817     }
818
819     if ( $data{"Paytype"} ne "pp" ) {
820         fail "Invalid paytype for Paypal transaction";
821     }
822
823     # Put a description for the thanks page into the session data.
824     # We do this only now because we send a reduced Desc field to paypal.
825     $data{"Desc"} =
826         "GnuPG donation by " . $data{"Name"} . " <" . $data{"Mail"} . ">";
827
828     # Note that the capitalization of session data names must match
829     # the rules of payprocd.
830     $data{"Paypal_aliasid"} = $aliasid;
831     $data{"Paypal_payerid"} = $payerid;
832
833     # Set vars for the checkout page.
834     $amount = $data{"Amount"};
835     $currency = $data{"Currency"};
836     $paytype = $data{"Paytype"};
837     $stripeamount = $data{"Stripeamount"};
838     $euroamount = $data{"Euroamount"};
839     $recur = $data{"Recur"};
840     $name = $data{"Name"};
841     $mail = $data{"Mail"};
842     $message = $data{"Message"};
843
844     # Store the session after setting the above vars because that call
845     # clears DATA.
846     payproc ('SESSION put ' . $sessid, \%data)
847         or fail $data{"ERR_Description"};
848
849     # Write the checkout (i.e. confirm payment) page
850     write_checkout_page ();
851 }
852
853
854 # The approved Paypal payment has been approved.  Now execute the
855 # payment.
856 sub complete_paypal_checkout ()
857 {
858     my %data;
859     my %request;
860
861     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
862
863     $request{"Alias-Id"}     = $data{"Paypal_aliasid"};
864     $request{"Paypal-Payer"} = $data{"Paypal_payerid"};
865
866     if (not payproc ('PPCHECKOUT execute', \%request)) {
867         $errorstr =
868             '<p>Error: ' . $request{"failure"} . '</p><p>'
869             . $request{"failure-mesg"} . '</p>';
870
871         print $q->header(-type=>'text/html', -charset=>'utf-8');
872         print "\n";
873         write_template("donate/error.html");
874         return;
875     }
876
877     # Print thanks
878
879     $message = <<EOF;
880 Amount ..: $request{"Amount"} $request{"Currency"}
881 Desc ....: $data{"Desc"}
882 Cardno...: n/a
883 Processor: PayPal
884 Email ...: $request{"Email"}
885 Charge-Id: $request{"Charge-Id"}
886 Timestamp: $request{"_timestamp"}
887 EOF
888     if ($request{"Live"} eq 'f') {
889         $message = $message . "\n!!! TEST TRANSACTION !!!";
890     }
891
892     write_thanks_page ();
893     payproc ('SESSION destroy ' . $sessid, ());
894 }
895
896
897 # Complete the SEPA payment: Check values and show final page.
898 sub complete_sepa ()
899 {
900     my %data;
901     my %request;
902
903     payproc ('SESSION get ' . $sessid, \%data)
904         or fail $data{"ERR_Description"};
905
906     # If the session has a lang value use that.
907     if ($data{"lang"} ne '') {
908         $lang = $data{"lang"};
909     }
910
911     $request{"Currency"} = $data{"Currency"};
912     $request{"Amount"} = $data{"Amount"};
913     $request{"Desc"} = "GnuPG SEPA donation";
914     $request{"Email"} = $data{"Mail"} unless $data{"Mail"} eq '';
915     $request{"Meta[name]"} = $data{"Name"} unless $data{"Name"} eq 'Anonymous';
916     if ($data{"Message"} ne '') {
917         $request{"Meta[message]"} = $data{"Message"};
918     }
919     if (not payproc ('SEPAPREORDER', \%request )) {
920         $errorstr = "Error: " . $request{"ERR_Description"};
921         # Back to the main page.
922         write_main_page ();
923         return;
924     }
925     $separef = $request{"Sepa-Ref"};
926     $amount = $request{"Amount"};
927
928     # Set remaining vars for the checkout page.
929     $currency = $data{"Currency"};
930     $paytype = $data{"Paytype"};
931     $stripeamount = $data{"Stripeamount"};
932     $euroamount = $data{"Euroamount"};
933     $recur = $data{"Recur"};
934     $name = $data{"Name"};
935     $mail = $data{"Mail"};
936     $message = $data{"Message"};
937
938     write_checkout_page ();
939 }
940
941
942 # Send a PING command to see whether payprocd is alive.
943 sub ping_pong ()
944 {
945     my %data = ();
946
947     if (payproc ('PING', \%data )) {
948        print $q->header(-type=>'text/HTML', -charset=>'utf-8');
949        print "\n";
950        print "<p>OK</p>\n";
951     }
952 }
953
954
955 #
956 # Main
957 #
958
959 #print STDERR "CGI called with mode=$mode\n";
960 #print STDERR "CGI called with sessid=$sessid\n";
961 if ($q->param('url') ne '') {
962     # If the URL field has been filled out, the client did not follow
963     # the instructions and thus failed the Turing test.  Provide an
964     # innocent error page.
965     write_overload_page ()
966 }
967 elsif ($mode eq '') {
968     # No mode: Show empty template.
969     write_main_page();
970 }
971 elsif ($mode eq 'preset') {
972     # Show a a template with certain preset values.
973     $currency = 'EUR';
974     $recur = '12';
975     $paytype = 'cc';
976     if ($q->param('plan') eq '12-5-eur' ) {
977         $amount = '5';
978     }
979     elsif ($q->param('plan') eq '12-10-eur' ) {
980         $amount = '10';
981     }
982     elsif ($q->param('plan') eq '12-20-eur' ) {
983         $amount = '20';
984     }
985
986     write_main_page();
987 }
988 elsif ($mode eq 'ping') {
989     # Check aliveness
990     ping_pong();
991 }
992 elsif ($mode eq 'main') {
993     # Returning from the donation start page
994     check_donation();
995 }
996 elsif ($mode eq 're-main') {
997     # Returning from the donation start page
998     resend_main_page();
999 }
1000 elsif ($mode eq 'checkout-stripe') {
1001     # we have the stripe token - charge the card.
1002     complete_stripe_checkout();
1003 }
1004 elsif ($mode eq 'cancel-paypal') {
1005     # Fixme: Destroy the alias of the session.
1006     write_cancel_page();
1007 }
1008 elsif ($mode eq 'confirm-paypal') {
1009     # We have approval from Paypal - show the confirm checkout page.
1010     confirm_paypal_checkout();
1011 }
1012 elsif ($mode eq 'checkout-paypal') {
1013     # The approved Paypal payment has been approved - charge.
1014     complete_paypal_checkout();
1015 }
1016 elsif ($mode eq 'pong') {
1017     # Helper to test a script checking PING.
1018     fail "Error connecting to payprocd: Forced to fail";
1019 }
1020 else {
1021     fail('Internal error: Unknown mode');
1022 }