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