Add tools and files to create a list of donors.
[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 $htdocs =  $config{htdocs};
24 my $socket_name = $config{payprocd_socket};
25 my $error_marker = '<span style="color: red;">* error</span>';
26
27 # The form variabales are accessed via Q.
28 my $q  = new CGI;
29
30 # This is a multi-purpose CGI.  The mode decides what to do.
31 my $mode = $q->param("mode");
32 my $sessid = $q->param("sessid");
33
34 # Variables used in the template pages.
35 my $amount = "";
36 my $stripeamount = "";
37 my $currency = "";
38 my $name = "";
39 my $mail = "";
40 my $message = "";
41 my $errorstr = "";
42
43 # We use a dictionary to track error.  Those errors will then be
44 # inserted into the output by write_template.
45 my %errdict = ();
46
47 # Prototypes
48 sub fail ($);
49
50
51 # Write a template file.  A template is a proper HTML file with
52 # variables enclosed in HTML comments.  To allow inserting data into
53 # a value attribute of an input field, such a tag needs to be written as
54 #   <input value=""/><!--FOO-->
55 # the result after processing will be
56 #   <input value="foo"/>
57 # assuming that the value of FOO is foo. Note that this substitution
58 # rules work for all tags and thus you better take care to add an
59 # extra space if if do not want this to happen.
60 sub write_template ($) {
61     my $fname = shift;
62
63     my $errorpanel = '';
64     my $err_amount = '';
65     my $err_name = '';
66     my $err_mail = '';
67     my $checkother = ' checked="checked"';
68     my $sel_eur = '';
69     my $sel_usd = '';
70     my $sel_gbp = '';
71     my $sel_jpy = '';
72     my $message_fmt;
73
74     # Avoid broken HTML attributes.
75     $amount =~ s/\x22/\x27/g;
76     $stripeamount =~ s/\x22/\x27/g;
77     $currency =~ s/\x22/\x27/g;
78     $name =~ s/\x22/\x27/g;
79     $mail =~ s/\x22/\x27/g;
80     $message =~ s/\x22/\x27/g;
81
82     # Clean possible user provided data
83     $sessid =~ s/</\x26lt;/g;
84     $amount =~ s/</\x26lt;/g;
85     $stripeamount =~ s/</\x26lt;/g;
86     $currency =~ s/</\x26lt;/g;
87     $name =~ s/</\x26lt;/g;
88     $mail =~ s/</\x26lt;/g;
89     $message =~ s/</\x26lt;/g;
90
91     # Create a formatted message.
92     $message_fmt = $message;
93     $message_fmt =~ s/\n/<br\x2f>/g;
94
95     if ( $currency =~ /EUR/i ) {
96         $sel_eur = ' selected="selected"';
97     } elsif ( $currency =~ /USD/i ) {
98         $sel_usd = ' selected="selected"';
99     } elsif ( $currency =~ /GBP/i ) {
100         $sel_gbp = ' selected="selected"';
101     } elsif ( $currency =~ /JPY/i ) {
102         $sel_jpy = ' selected="selected"';
103     }
104
105     # Build error strings.
106     foreach (keys %errdict)
107     {
108         if    (/amount/) { $err_amount = $error_marker; }
109         elsif (/name/)   { $err_name   = $error_marker; }
110         elsif (/mail/)   { $err_mail   = $error_marker; }
111
112         $errorpanel = $errorpanel . "Field $_: " . $errdict{$_} . "<br/>\n"
113     }
114     if ( $errorpanel ne '' )
115     {
116         $errorpanel =
117             "<div style='color: red;'><p>\n" . $errorpanel . "</p></div>\n";
118     }
119
120     open TEMPLATE, $htdocs . $fname;
121     while (<TEMPLATE>) {
122         if ( /<!--/ )
123         {
124             # Only one replacement per line allowed to avoid recursive
125             # replacements. Note that MESSAGE uses a special treatment
126             # for the textarea tag.
127             s/<!--SESSID-->/$sessid/
128             || s/(\x22\x2f>)?<!--AMOUNT-->/$amount\1/
129             || s/(\x22\x2f>)?<!--STRIPEAMOUNT-->/$stripeamount\1/
130             || s/(\x22\x2f>)?<!--CURRENCY-->/$currency\1/
131             || s/(\x22\x2f>)?<!--NAME-->/$name\1/
132             || s/(\x22\x2f>)?<!--MAIL-->/$mail\1/
133             || s/\x2f><!--CHECKOTHER-->/$checkother\x2f>/
134             || s/(<\x2ftextarea>)?<!--MESSAGE-->/$message\1/
135             || s/<!--MESSAGE_FMT-->/$message_fmt/
136             || s/(<selected=\x22selected\x22)?><!--SEL_EUR-->/$sel_eur>/
137             || s/(<selected=\x22selected\x22)?><!--SEL_USD-->/$sel_usd>/
138             || s/(<selected=\x22selected\x22)?><!--SEL_GBP-->/$sel_gbp>/
139             || s/(<selected=\x22selected\x22)?><!--SEL_JPY-->/$sel_jpy>/
140             || s/<!--ERRORSTR-->/$errorstr/
141             || s/<!--ERR_AMOUNT-->/$err_amount/
142             || s/<!--ERR_NAME-->/$err_name/
143             || s/<!--ERR_MAIL-->/$err_mail/
144             || s/<!--ERRORPANEL-->/$errorpanel/;
145         }
146         print;
147     }
148     close TEMPLATE;
149     $errorstr = "";
150 }
151
152
153 # Call the payment processor daemon.  Takes the command and a
154 # reference to a dictionary with the data as input.  On return that
155 # disctionary is replaced by the response data.
156 sub payproc ($$)
157 {
158     my $cmd = shift;
159     my $data = shift;
160     my $sock;
161     my $key;
162     my $value;
163     my $status;
164     my $rest;
165
166     # print STDERR "calling payproc: ", $cmd, "<-\n";
167
168     $sock = IO::Socket::UNIX->new($socket_name)
169         or fail "socket: $!";
170     $sock->print ($cmd, "\n");
171
172     while (($key,$value) = each %$data) {
173         next if $key =~ /^_/;
174         $value =~ s/\n/\n /g;
175         $sock->print ("$key: $value\n");
176         # print STDERR "  $key: $value\n";
177     }
178     $sock->print ("\n");
179     $sock->flush or fail "write socket: $!";
180
181     %$data = ();
182     while (defined (my $line = <$sock>))
183     {
184         next if $line =~ /^\#/;
185         chomp $line;
186         last if $line eq '';
187         if (not defined $status)
188         {
189             ($status, $rest) = split(' ', $line, 2);
190             if ( $status eq 'ERR' )
191             {
192                 $rest =~ /\d+\s+\((.*)\).*/;
193                 $$data{"ERR_Description"} = $1;
194             }
195         }
196         elsif ( $line =~ /^\s+/ )
197         {
198             fail "bad dict line received" if not defined $key;
199             $$data{$key} .= "\n" . substr($line, 1);
200         }
201         else
202         {
203             ($key, $value) = split(':', $line, 2);
204             $value =~ s/^\s+//;
205             $$data{$key} = $value;
206         }
207     }
208
209     #print STDERR "payproc status: $status (", $$data{"ERR_Description"}, ")\n";
210     #while (($key,$value) = each %$data) {
211     #     print STDERR "  ", $key, ": ", $value, "\n";
212     #}
213
214     $sock->close;
215     return 1 if $status eq 'OK';
216     return 0 if $status eq 'ERR';
217     fail 'payproc did not return a proper status code';
218 }
219
220
221 # Write a page with all the data inserted.
222 sub write_overload_page ()
223 {
224     print $q->header(-type=>'text/html', -charset=>'utf-8');
225     print "\n";
226     $errorstr =
227         '<p>The system is currently processing too many requests.</p>'
228         . '<p>Please retry later.</p>';
229
230     &write_template("donate/error.html");
231 }
232
233
234 # Write an internal error page
235 sub fail ($)
236 {
237     my $desc = shift;
238
239 # FIXME: write the detailed error only to the log.
240     print $q->header(-type=>'text/html', -charset=>'utf-8');
241     print "\n";
242     $errorstr =
243         '<p>An internal error occured:</p>'
244         . "<p>$desc</p>";
245
246     write_template("donate/error.html");
247     exit 0;
248 }
249
250
251 # Write a the initial donation page.  This is usallay done to show
252 # errors.  The page is intially shown as static page.
253 sub write_main_page ()
254 {
255     print $q->header(-type=>'text/html', -charset=>'utf-8');
256     print "\n";
257     write_template("donate/index.html");
258 }
259
260
261 # Write a page with all the data inserted.
262 sub write_checkout_page ()
263 {
264     print $q->header(-type=>'text/html', -charset=>'utf-8');
265     print "\n";
266     write_template("donate/checkout.html");
267 }
268
269 # Write a page with all the data inserted specific for cards.
270 sub write_checkout_cc_page ()
271 {
272     print $q->header(-type=>'text/html', -charset=>'utf-8');
273     print "\n";
274     write_template("donate/checkout-cc.html");
275 }
276
277
278 # Write the final thank you page.
279 sub write_thanks_page ()
280 {
281     print $q->header(-type=>'text/html', -charset=>'utf-8');
282     print "\n";
283     write_template("donate/donate-thanks.html");
284 }
285
286
287 # Check the values entered at the donation page.  Return true if
288 # everything is alright.  On error the donation page is send again.
289 sub check_donation ()
290 {
291     my %data;
292     my $anyerr = 0;
293
294     # Note: When re-displaying the page we always use amount other
295     # because that is easier to implement than figuring out which
296     # amount and currency was used and check the appropriate radio
297     # button.
298     $amount = $q->param("amount");
299     if ($amount eq 'other') {
300       $amount = $q->param("amountother");
301       $currency = $q->param("currency");
302     } else {
303       $currency = 'EUR';
304     }
305     $name = $q->param("name");
306     $name = 'Anonymous' if $name eq '';
307     $mail = $q->param("mail");
308     $message = $q->param("message");
309     $stripeamount = "0";
310
311     # Check the amount.
312     $data{"Amount"} = $amount;
313     $data{"Currency"} = $currency;
314     if (not payproc ('CHECKAMOUNT', \%data )) {
315         $errdict{"amount"} = $data{"ERR_Description"};
316         $anyerr = 1;
317     }
318     $stripeamount = $data{"_amount"};
319     $amount = $data{"Amount"};
320     $currency = $data{"Currency"};
321
322     # Check the mail address
323     if ($mail ne '' and $mail !~ /\S+@\S+\.\S+/ ) {
324         $errdict{"mail"} = 'invalid mail address';
325         $anyerr = 1;
326     }
327
328     # If needed present errors and ask again.  */
329     if ($anyerr) {
330         write_main_page();
331         return;
332     }
333
334
335     # Now create a session.
336     $data{"Stripeamount"} = $stripeamount;
337     $data{"Name"} = $name;
338     $data{"Mail"} = $mail;
339     $data{"Message"} = $message;
340     payproc ('SESSION create', \%data ) or fail $data{"ERR_Description"};
341     $sessid = $data{"_SESSID"};
342
343     # Send the checkout page.
344     write_checkout_page();
345 }
346
347 # This simply resends the main page again.
348 sub resend_main_page ()
349 {
350     my %data;
351
352     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
353     $amount = $data{"Amount"};
354     $currency = $data{"Currency"};
355     $stripeamount = $data{"Stripeamount"};
356     $name = $data{"Name"};
357     $mail = $data{"Mail"};
358     $message = $data{"Message"};
359
360     write_main_page();
361 }
362
363
364 # This simply resends the checkout options page.
365 sub resend_card_checkout ()
366 {
367     my %data;
368
369     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
370     $amount = $data{"Amount"};
371     $currency = $data{"Currency"};
372     $stripeamount = $data{"Stripeamount"};
373     $name = $data{"Name"};
374     $mail = $data{"Mail"};
375     $message = $data{"Message"};
376
377     write_checkout_page();
378 }
379
380
381
382 # This simply sends the card specific checkout page.
383 sub prepare_card_checkout ()
384 {
385     my %data;
386
387     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
388     $amount = $data{"Amount"};
389     $currency = $data{"Currency"};
390     $stripeamount = $data{"Stripeamount"};
391     $mail = $data{"Mail"};
392
393     write_checkout_cc_page();
394 }
395
396
397 # This is called by FIXME
398 sub complete_stripe_checkout ()
399 {
400     my %data;
401     my %stripe;
402
403     # fixme: Change the error message to note that the card has not
404     # been charged.  Somehow delete the token
405     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
406
407     # Do the checkout.
408     $stripe{"Card-Token"} = $q->param("stripeToken");
409     $stripe{"Currency"} = $data{"Currency"};
410     $stripe{"Amount"} = $data{"Amount"};
411     $stripe{"Desc"} =
412         "GnuPG donation by " . $data{"Name"} . " <" . $data{"Mail"} . ">";
413     $stripe{"Stmt-Desc"} = "GnuPG donation";
414     $stripe{"Email"} = $q->param("stripeEmail");
415     $stripe{"Meta[name]"} = $data{"Name"} unless $data{"Name"} eq 'Anonymous';
416     if ($data{"Mail"} ne $q->param("stripeEmail")) {
417         $stripe{"Meta[mail]"} = $data{"Mail"};
418     }
419     if ($data{"Message"} ne '') {
420         $stripe{"Meta[message]"} = $data{"Message"};
421     }
422     if (not payproc ('CHARGECARD', \%stripe)) {
423         $errorstr =
424             '<p>Error: ' . $stripe{"failure"} . '</p><p>'
425             . $stripe{"failure-mesg"} . '</p>';
426         # Again.
427         prepare_card_checkout ();
428         return;
429     }
430
431     # Print thanks
432
433     $message = <<EOF;
434 Amount ..: $stripe{"Amount"} $stripe{"Currency"}
435 Desc ....: $stripe{"Desc"}
436 Cardno...: *$stripe{"Last4"}
437 Processor: Stripe
438 Email ...: $stripe{"Email"}
439 Charge-Id: $stripe{"Charge-Id"}
440 Timestamp: $stripe{"_timestamp"}
441 EOF
442     if ($stripe{"Live"} eq 'f') {
443         $message = $message . "\n!!! TEST TRANSACTION !!!";
444     }
445
446     write_thanks_page ();
447     payproc ('SESSION destroy ' . $sessid, ());
448 }
449
450
451
452
453
454 #
455 # Main
456 #
457 #print STDERR "CGI called with mode=$mode\n";
458 #print STDERR "CGI called with sessid=$sessid\n";
459 if ($q->param('url') ne '') {
460     # If the URL field has been filled out, the client did not follow
461     # the instructions and thus failed the Turing test.  Provide an
462     # innocent error page.
463     write_overload_page ()
464 }
465 elsif ($mode eq 'main') {
466     # Returning from the donation start page
467     check_donation();
468 }
469 elsif ($mode eq 're-main') {
470     # Returning from the donation start page
471     resend_main_page();
472 }
473 elsif ($mode eq 're-checkout') {
474     # Redisplay the checkout option page
475     resend_card_checkout();
476 }
477 elsif ($mode eq 'checkout-cc') {
478     # The checkout page requested a card checkout.
479     prepare_card_checkout();
480 }
481 elsif ($mode eq 'checkout-stripe') {
482     # we have the stripe token - charge the card.
483     complete_stripe_checkout();
484 }
485 else {
486     fail('Internal error: Unknown mode');
487 }