web: Add new donation system
[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     print STDERR "selected currecny->$currency<-\n";
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     print STDERR "selected currecny->$sel_gbp<-\n";
105
106     # Build error strings.
107     foreach (keys %errdict)
108     {
109         if    (/amount/) { $err_amount = $error_marker; }
110         elsif (/name/)   { $err_name   = $error_marker; }
111         elsif (/mail/)   { $err_mail   = $error_marker; }
112
113         $errorpanel = $errorpanel . "Field $_: " . $errdict{$_} . "<br/>\n"
114     }
115     if ( $errorpanel ne '' )
116     {
117         $errorpanel =
118             "<div style='color: red;'><p>\n" . $errorpanel . "</p></div>\n";
119     }
120
121     open TEMPLATE, $htdocs . $fname;
122     while (<TEMPLATE>) {
123         if ( /<!--/ )
124         {
125             # Only one replacement per line allowed to avoid recursive
126             # replacements. Note that MESSAGE uses a special treatment
127             # for the textarea tag.
128             s/<!--SESSID-->/$sessid/
129             || s/(\x22\x2f>)?<!--AMOUNT-->/$amount\1/
130             || s/(\x22\x2f>)?<!--STRIPEAMOUNT-->/$stripeamount\1/
131             || s/(\x22\x2f>)?<!--CURRENCY-->/$currency\1/
132             || s/(\x22\x2f>)?<!--NAME-->/$name\1/
133             || s/(\x22\x2f>)?<!--MAIL-->/$mail\1/
134             || s/\x2f><!--CHECKOTHER-->/$checkother\x2f>/
135             || s/(<\x2ftextarea>)?<!--MESSAGE-->/$message\1/
136             || s/<!--MESSAGE_FMT-->/$message_fmt/
137             || s/(<selected=\x22selected\x22)?><!--SEL_EUR-->/$sel_eur>/
138             || s/(<selected=\x22selected\x22)?><!--SEL_USD-->/$sel_usd>/
139             || s/(<selected=\x22selected\x22)?><!--SEL_GBP-->/$sel_gbp>/
140             || s/(<selected=\x22selected\x22)?><!--SEL_JPY-->/$sel_jpy>/
141             || s/<!--ERRORSTR-->/$errorstr/
142             || s/<!--ERR_AMOUNT-->/$err_amount/
143             || s/<!--ERR_NAME-->/$err_name/
144             || s/<!--ERR_MAIL-->/$err_mail/
145             || s/<!--ERRORPANEL-->/$errorpanel/;
146         }
147         print;
148     }
149     close TEMPLATE;
150     $errorstr = "";
151 }
152
153
154 # Call the payment processor daemon.  Takes the command and a
155 # reference to a dictionary with the data as input.  On return that
156 # disctionary is replaced by the response data.
157 sub payproc ($$)
158 {
159     my $cmd = shift;
160     my $data = shift;
161     my $sock;
162     my $key;
163     my $value;
164     my $status;
165     my $rest;
166
167     # print STDERR "calling payproc: ", $cmd, "<-\n";
168
169     $sock = IO::Socket::UNIX->new($socket_name)
170         or fail "socket: $!";
171     $sock->print ($cmd, "\n");
172
173     while (($key,$value) = each %$data) {
174         next if $key =~ /^_/;
175         $value =~ s/\n/\n /g;
176         $sock->print ("$key: $value\n");
177         # print STDERR "  $key: $value\n";
178     }
179     $sock->print ("\n");
180     $sock->flush or fail "write socket: $!";
181
182     %$data = ();
183     while (defined (my $line = <$sock>))
184     {
185         next if $line =~ /^\#/;
186         chomp $line;
187         last if $line eq '';
188         if (not defined $status)
189         {
190             ($status, $rest) = split(' ', $line, 2);
191             if ( $status eq 'ERR' )
192             {
193                 $rest =~ /\d+\s+\((.*)\).*/;
194                 $$data{"ERR_Description"} = $1;
195             }
196         }
197         elsif ( $line =~ /^\s+/ )
198         {
199             fail "bad dict line received" if not defined $key;
200             $$data{$key} .= "\n" . substr($line, 1);
201         }
202         else
203         {
204             ($key, $value) = split(':', $line, 2);
205             $value =~ s/^\s+//;
206             $$data{$key} = $value;
207         }
208     }
209
210     #print STDERR "payproc status: $status (", $$data{"ERR_Description"}, ")\n";
211     #while (($key,$value) = each %$data) {
212     #     print STDERR "  ", $key, ": ", $value, "\n";
213     #}
214
215     $sock->close;
216     return 1 if $status eq 'OK';
217     return 0 if $status eq 'ERR';
218     fail 'payproc did not return a proper status code';
219 }
220
221
222 # Write a page with all the data inserted.
223 sub write_overload_page ()
224 {
225     print $q->header(-type=>'text/html', -charset=>'utf-8');
226     print "\n";
227     $errorstr =
228         '<p>The system is currently processing too many requests.</p>'
229         . '<p>Please retry later.</p>';
230
231     &write_template("donate/error.html");
232 }
233
234
235 # Write an internal error page
236 sub fail ($)
237 {
238     my $desc = shift;
239
240 # FIXME: write the detailed error only to the log.
241     print $q->header(-type=>'text/html', -charset=>'utf-8');
242     print "\n";
243     $errorstr =
244         '<p>An internal error occured:</p>'
245         . "<p>$desc</p>";
246
247     write_template("donate/error.html");
248     exit 0;
249 }
250
251
252 # Write a the initial donation page.  This is usallay done to show
253 # errors.  The page is intially shown as static page.
254 sub write_main_page ()
255 {
256     print $q->header(-type=>'text/html', -charset=>'utf-8');
257     print "\n";
258     write_template("donate/index.html");
259 }
260
261
262 # Write a page with all the data inserted.
263 sub write_checkout_page ()
264 {
265     print $q->header(-type=>'text/html', -charset=>'utf-8');
266     print "\n";
267     write_template("donate/checkout.html");
268 }
269
270 # Write a page with all the data inserted specific for cards.
271 sub write_checkout_cc_page ()
272 {
273     print $q->header(-type=>'text/html', -charset=>'utf-8');
274     print "\n";
275     write_template("donate/checkout-cc.html");
276 }
277
278
279 # Write the final thank you page.
280 sub write_thanks_page ()
281 {
282     print $q->header(-type=>'text/html', -charset=>'utf-8');
283     print "\n";
284     write_template("donate/donate-thanks.html");
285 }
286
287
288 # Check the values entered at the donation page.  Return true if
289 # everything is alright.  On error the donation page is send again.
290 sub check_donation ()
291 {
292     my %data;
293     my $anyerr = 0;
294
295     # Note: When re-displaying the page we always use amount other
296     # because that is easier to implement than figuring out which
297     # amount and currency was used and check the appropriate radio
298     # button.
299     $amount = $q->param("amount");
300     if ($amount eq 'other') {
301       $amount = $q->param("amountother");
302       $currency = $q->param("currency");
303     } else {
304       $currency = 'EUR';
305     }
306     $name = $q->param("name");
307     $name = 'Anonymous' if $name eq '';
308     $mail = $q->param("mail");
309     $message = $q->param("message");
310     $stripeamount = "0";
311
312     # Check the amount.
313     $data{"Amount"} = $amount;
314     $data{"Currency"} = $currency;
315     if (not payproc ('CHECKAMOUNT', \%data )) {
316         $errdict{"amount"} = $data{"ERR_Description"};
317         $anyerr = 1;
318     }
319     $stripeamount = $data{"_amount"};
320     $amount = $data{"Amount"};
321     $currency = $data{"Currency"};
322
323     # Check the mail address
324     if ($mail ne '' and $mail !~ /\S+@\S+\.\S+/ ) {
325         $errdict{"mail"} = 'invalid mail address';
326         $anyerr = 1;
327     }
328
329     # If needed present errors and ask again.  */
330     if ($anyerr) {
331         write_main_page();
332         return;
333     }
334
335
336     # Now create a session.
337     $data{"Stripeamount"} = $stripeamount;
338     $data{"Name"} = $name;
339     $data{"Mail"} = $mail;
340     $data{"Message"} = $message;
341     payproc ('SESSION create', \%data ) or fail $data{"ERR_Description"};
342     $sessid = $data{"_SESSID"};
343
344     # Send the checkout page.
345     write_checkout_page();
346 }
347
348 # This simply resends the main page again.
349 sub resend_main_page ()
350 {
351     my %data;
352
353     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
354     $amount = $data{"Amount"};
355     $currency = $data{"Currency"};
356     $stripeamount = $data{"Stripeamount"};
357     $name = $data{"Name"};
358     $mail = $data{"Mail"};
359     $message = $data{"Message"};
360
361     write_main_page();
362 }
363
364
365 # This simply resends the checkout options page.
366 sub resend_card_checkout ()
367 {
368     my %data;
369
370     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
371     $amount = $data{"Amount"};
372     $currency = $data{"Currency"};
373     $stripeamount = $data{"Stripeamount"};
374     $name = $data{"Name"};
375     $mail = $data{"Mail"};
376     $message = $data{"Message"};
377
378     write_checkout_page();
379 }
380
381
382
383 # This simply sends the card specific checkout page.
384 sub prepare_card_checkout ()
385 {
386     my %data;
387
388     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
389     $amount = $data{"Amount"};
390     $currency = $data{"Currency"};
391     $stripeamount = $data{"Stripeamount"};
392     $mail = $data{"Mail"};
393
394     write_checkout_cc_page();
395 }
396
397
398 # This is called by FIXME
399 sub complete_stripe_checkout ()
400 {
401     my %data;
402     my %stripe;
403
404     # fixme: Change the error message to note that the card has not
405     # been charged.  Somehow delete the token
406     payproc ('SESSION get ' . $sessid, \%data) or fail $data{"ERR_Description"};
407
408     # Do the checkout.
409     $stripe{"Card-Token"} = $q->param("stripeToken");
410     $stripe{"Currency"} = $data{"Currency"};
411     $stripe{"Amount"} = $data{"Amount"};
412     $stripe{"Desc"} =
413         "GnuPG donation by " . $data{"Name"} . " <" . $data{"Mail"} . ">";
414     $stripe{"Stmt-Desc"} = "GnuPG donation";
415     $stripe{"Email"} = $q->param("stripeEmail");
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 }