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