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