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