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