really check the success value correctly
[bse.git] / site / cgi-bin / modules / BSE / Request / Base.pm
CommitLineData
70789617
TC
1package BSE::Request::Base;
2use strict;
3use CGI ();
4use BSE::Cfg;
5use DevHelp::HTML;
61138170 6use Carp qw(cluck confess);
70789617
TC
7
8sub new {
9 my ($class, %opts) = @_;
10
d2473dc2
TC
11 $opts{cfg} ||= BSE::Cfg->new;
12
13 BSE::DB->init($opts{cfg});
5ac2ad24
TC
14 BSE::DB->startup();
15
70789617 16 $opts{cgi} ||= $class->_make_cgi;
8062fbd7 17 $opts{fastcgi} ||= 0;
70789617
TC
18
19 my $self = bless \%opts, $class;
20 if ($self->cfg->entry('html', 'utf8decodeall')) {
21 $self->_encode_utf8();
22 }
23 elsif ($self->cfg->entry('html', 'ajaxcharset', 0)
61138170 24 && $self->is_ajax) {
70789617
TC
25 # convert the values of each parameter from UTF8 to iso-8859-1
26 $self->_convert_utf8_cgi_to_charset();
27 }
28
29 $self;
30}
31
32sub _make_cgi {
6361fafb
TC
33 my $q = CGI->new;
34 my $error = $q->cgi_error;
35 if ($error) {
36 print STDERR "CGI ERROR: $error\n";
37 }
38
39 return $q;
70789617
TC
40}
41
42sub cgi {
43 return $_[0]{cgi};
44}
45
46sub cfg {
47 return $_[0]{cfg};
48}
49
50sub session {
51 $_[0]{session} or die "Session has been deleted already\n";
52
53 return $_[0]{session};
54}
55
8062fbd7
TC
56sub is_fastcgi {
57 $_[0]{fastcgi};
58}
59
70789617
TC
60sub end_request {
61 delete $_[0]{session};
62}
63
70789617
TC
64sub user {
65 return $_[0]{adminuser};
66}
67
68sub setuser {
69 $_[0]{adminuser} = $_[1];
70}
71
72sub getuser {
73 $_[0]{adminuser};
74}
75
76# this needs to become non-admin specific
77sub url {
78 my ($self, $action, $params, $name) = @_;
79
80 require BSE::CfgInfo;
81 my $url = BSE::CfgInfo::admin_base_url($self->{cfg});
82 $url .= "/cgi-bin/admin/$action.pl";
83 if ($params && keys %$params) {
84 $url .= "?" . join("&", map { "$_=".escape_uri($params->{$_}) } keys %$params);
85 }
86 $url .= "#$name" if $name;
87
88 $url;
89}
90
91sub check_admin_logon {
92 my ($self) = @_;
93
94 require BSE::Permissions;
95 return BSE::Permissions->check_logon($self);
96}
97
98sub template_sets {
99 my ($self) = @_;
100
101 return () unless $self->access_control;
102
103 my $user = $self->user
104 or return;
105
106 return grep $_ ne '', map $_->{template_set}, $user->groups;
107}
108
109my $site_article =
110 {
111 id => -1,
112 title => "unknown",
113 parentid => 0,
114 generator => 'Generate::Article',
115 level => 0,
116 };
117
118sub user_can {
119 my ($self, $perm, $object, $rmsg) = @_;
120
121 require BSE::Permissions;
122 $object ||= $site_article;
123 $self->{perms} ||= BSE::Permissions->new($self->cfg);
124 if ($self->cfg->entry('basic', 'access_control', 0)) {
125 unless (ref $object) {
126 require Articles;
127 my $art = $object == -1 ? $site_article : Articles->getByPkey($object);
128 if ($art) {
129 $object = $art;
130 }
131 else {
132 print STDERR "** Cannot find article id $object\n";
133 require Carp;
134 Carp::cluck "Cannot find article id $object";
135 return 0;
136 }
137 }
138 return $self->{perms}->user_has_perm($self->user, $object, $perm, $rmsg);
139 }
140 else {
141 # some checks need to happen even if we don't want logons
142 return $self->{perms}->user_has_perm({ id=>-1 }, $object, $perm, $rmsg);
143 }
144}
145
146# a stub for now
147sub get_object {
148 return;
149}
150
151sub access_control {
152 $_[0]->{cfg}->entry('basic', 'access_control', 0);
153}
154
d2473dc2
TC
155sub get_refresh {
156 my ($req, $url) = @_;
157
158 require BSE::Template;
159 BSE::Template->get_refresh($url, $req->cfg);
160}
161
70789617
TC
162sub output_result {
163 my ($req, $result) = @_;
164
165 require BSE::Template;
166 BSE::Template->output_result($req, $result);
167}
168
e63c3728
TC
169sub flash {
170 my ($self, @msg) = @_;
171
172 my $msg = "@msg";
173 my @flash;
174 @flash = @{$self->session->{flash}} if $self->session->{flash};
175 push @flash, $msg;
176 $self->session->{flash} = \@flash;
177}
178
70789617
TC
179sub message {
180 my ($req, $errors) = @_;
181
182 my $msg = '';
e63c3728 183 my @lines;
70789617
TC
184 if ($errors and keys %$errors) {
185 my @fields = $req->cgi->param;
186 my %work = %$errors;
70789617
TC
187 for my $field (@fields) {
188 if (my $entry = delete $work{$field}) {
189 push @lines, ref($entry) ? grep $_, @$entry : $entry;
190 }
191 }
192 for my $entry (values %work) {
193 if (ref $entry) {
194 push @lines, grep $_, @$entry;
195 }
196 else {
197 push @lines, $entry;
198 }
199 }
200 my %seen;
201 @lines = grep !$seen{$_}++, @lines; # don't need duplicates
70789617 202 }
e63c3728
TC
203 if ($req->session->{flash}) {
204 push @lines, @{$req->session->{flash}};
205 delete $req->session->{flash};
206 }
207 $msg = join "<br />", map escape_html($_), @lines;
70789617
TC
208 if (!$msg && $req->cgi->param('m')) {
209 $msg = join(' ', $req->cgi->param('m'));
210 $msg = escape_html($msg);
211 }
212
213 return $msg;
214}
215
216sub dyn_response {
4c4d3c3f 217 my ($req, $template, $acts, $modifier) = @_;
70789617
TC
218
219 my @search = $template;
220 my $base_template = $template;
221 my $t = $req->cgi->param('t');
222 $t or $t = $req->cgi->param('_t');
4c4d3c3f 223 $t or $t = $modifier;
70789617
TC
224 if ($t && $t =~ /^\w+$/) {
225 $template .= "_$t";
226 unshift @search, $template;
227 }
228
229 require BSE::Template;
230 my @sets;
231 if ($template =~ m!^admin/!) {
232 @sets = $req->template_sets;
233 }
234
235 return BSE::Template->get_response($template, $req->cfg, $acts,
236 $base_template, \@sets);
237}
238
239sub response {
240 my ($req, $template, $acts) = @_;
241
242 require BSE::Template;
243 my @sets;
244 if ($template =~ m!^admin/!) {
245 @sets = $req->template_sets;
246 }
247
248 return BSE::Template->get_response($template, $req->cfg, $acts,
249 $template, \@sets);
250}
251
252# get the current site user if one is logged on
253sub siteuser {
254 my ($req) = @_;
255
256 ++$req->{siteuser_calls};
257 if (exists $req->{_siteuser}) {
258 ++$req->{siteuser_cached};
259 return $req->{_siteuser};
260 }
261
262 my $cfg = $req->cfg;
263 my $session = $req->session;
264 require SiteUsers;
265 if ($cfg->entryBool('custom', 'user_auth')) {
266 require BSE::CfgInfo;
267 my $custom = BSE::CfgInfo::custom_class($cfg);
268
269 return $custom->siteuser_auth($session, $req->cgi, $cfg);
270 }
271 else {
272 $req->{_siteuser} = undef;
273
274 my $userid = $session->{userid}
275 or return;
276 my $user = SiteUsers->getBy(userId=>$userid)
277 or return;
278 $user->{disabled}
279 and return;
280
281 $req->{_siteuser} = $user;
282
283 return $user;
284 }
285}
286
287sub validate {
288 my ($req, %options) = @_;
289
290 $options{rules} ||= {};
291
292 require BSE::Validate;
9b3a5df0
TC
293 my %opts =
294 (
295 fields => $options{fields},
296 rules => $options{rules},
297 );
298 exists $options{optional} and $opts{optional} = $options{optional};
299 BSE::Validate::bse_validate
300 (
301 $req->cgi,
302 $options{errors},
303 \%opts,
304 $req->cfg,
305 $options{section}
306 );
70789617
TC
307}
308
309sub validate_hash {
310 my ($req, %options) = @_;
311
312 $options{rules} ||= {};
313
9b3a5df0
TC
314 my %opts =
315 (
316 fields => $options{fields},
317 rules => $options{rules},
318 );
319 exists $options{optional} and $opts{optional} = $options{optional};
70789617 320 require BSE::Validate;
9b3a5df0
TC
321 BSE::Validate::bse_validate_hash
322 (
323 $options{data},
324 $options{errors},
325 \%opts,
326 $req->cfg,
327 $options{section}
328 );
70789617
TC
329}
330
331sub configure_fields {
332 my ($self, $fields, $section) = @_;
333
334 my $cfg = $self->cfg;
335 require BSE::Validate;
336 my $cfg_fields = BSE::Validate::bse_configure_fields($fields, $cfg, $section);
337
338 for my $name (keys %$fields) {
339 for my $cfg_name (qw/htmltype type width height size maxlength/) {
340 my $value = $cfg->entry($section, "${name}_${cfg_name}");
341 defined $value and $cfg_fields->{$name}{$cfg_name} = $value;
342 }
343 }
344
345 $cfg_fields;
346}
347
348sub _have_group_access {
349 my ($req, $user, $group_ids, $membership) = @_;
350
351 if (grep $_ > 0, @$group_ids) {
352 $membership->{filled}
353 or %$membership = map { $_ => 1 } 'filled', $user->group_ids;
354 return 1
355 if grep $membership->{$_}, @$group_ids;
356 }
357 for my $query_id (grep $_ < 0, @$group_ids) {
358 require BSE::TB::SiteUserGroups;
359 my $group = BSE::TB::SiteUserGroups->getQueryGroup($req->cfg, $query_id)
360 or next;
361 my $rows = BSE::DB->single->dbh->selectall_arrayref($group->{sql}, { MaxRows=>1 }, $user->{id});
362 $rows && @$rows
363 and return 1;
364 }
365
366 return 0;
367}
368
369sub _siteuser_has_access {
370 my ($req, $article, $user, $default, $membership) = @_;
371
372 defined $default or $default = 1;
373 defined $membership or $membership = {};
374
1b73ea7e
TC
375 unless ($article) {
376 # this shouldn't happen
377 cluck("_siteuser_has_access() called without an article parameter!");
378 return 0;
379 }
380
70789617
TC
381 my @group_ids = $article->group_ids;
382 if ($article->{inherit_siteuser_rights}
383 && $article->{parentid} != -1) {
384 if (@group_ids) {
385 $user ||= $req->siteuser
386 or return 0;
387 if ($req->_have_group_access($user, \@group_ids, $membership)) {
388 return 1;
389 }
390 else {
391 return $req->siteuser_has_access($article->parent, $user, 0);
392 }
393 }
394 else {
395 # ask parent
396 return $req->siteuser_has_access($article->parent, $user, $default);
397 }
398 }
399 else {
400 if (@group_ids) {
401 $user ||= $req->siteuser
402 or return 0;
403 if ($req->_have_group_access($user, \@group_ids, $membership)) {
404 return 1;
405 }
406 else {
407 return 0;
408 }
409 }
410 else {
411 return $default;
412 }
413 }
414}
415
416sub siteuser_has_access {
417 my ($req, $article, $user, $default, $membership) = @_;
418
419 $user ||= $req->siteuser;
420
421 ++$req->{has_access_total};
422 if ($req->{_siteuser} && $user && $user->{id} == $req->{_siteuser}{id}
423 && exists $req->{_access_cache}{$article->{id}}) {
424 ++$req->{has_access_cached};
425 return $req->{_access_cache}{$article->{id}};
426 }
427
428 my $result = $req->_siteuser_has_access($article, $user, $default, $membership);
429
430 if ($user && $req->{_siteuser} && $user->{id} == $req->{_siteuser}{id}) {
431 $req->{_access_cache}{$article->{id}} = $result;
432 }
433
434 return $result;
435}
436
437sub dyn_user_tags {
438 my ($self) = @_;
439
440 require BSE::Util::DynamicTags;
441 return BSE::Util::DynamicTags->new($self)->tags;
442}
443
444sub DESTROY {
445 my ($self) = @_;
446
447 if ($self->{cache_stats}) {
448 print STDERR "Siteuser cache: $self->{siteuser_calls} Total, $self->{siteuser_cached} Cached\n"
449 if $self->{siteuser_calls};
450 print STDERR "Access cache: $self->{has_access_total} Total, $self->{has_access_cached} Cached\n"
451 if $self->{has_access_total};
452 }
453
454 if ($self->{session}) {
455 undef $self->{session};
456 }
457}
458
459sub set_article {
460 my ($self, $name, $article) = @_;
461
462 if ($article) {
463 $self->{articles}{$name} = $article;
464 }
465 else {
466 delete $self->{articles}{$name};
467 }
468}
469
470sub get_article {
471 my ($self, $name) = @_;
472
473 exists $self->{articles}{$name}
474 or return;
475
476 my $article = $self->{articles}{$name};
477 if (ref $article eq 'SCALAR') {
478 $article = $$article;
479 }
480 $article
481 or return;
482
483 $article;
484}
485
486sub text {
487 my ($self, $id, $default) = @_;
488
56f87a80 489 return $self->cfg->entry('messages', $id, $default);
70789617
TC
490}
491
492sub _convert_utf8_cgi_to_charset {
493 my ($self) = @_;
494
495 require Encode;
496 my $cgi = $self->cgi;
497 my $workset = $self->cfg->entry('html', 'charset', 'iso-8859-1');
498 my $decoded = $self->cfg->entry('html', 'cgi_decoded', 1);
499
500 # avoids param decoding the data
501 $cgi->charset($workset);
502
503 print STDERR "Converting parameters from UTF8 to $workset\n"
504 if $self->cfg->entry('debug', 'convert_charset');
505
506 if ($decoded) {
507 # CGI.pm has already converted it from utf8 to perl's internal encoding
508 # so we just need to encode to the working encoding
509 # I don't see a reliable way to detect this without configuring it
510 for my $name ($cgi->param) {
511 my @values = map Encode::encode($workset, $_), $cgi->param($name);
512
513 $cgi->param($name => @values);
514 }
515 }
516 else {
517 for my $name ($cgi->param) {
518 my @values = $cgi->param($name);
519 Encode::from_to($_, $workset, 'utf8') for @values;
520 $cgi->param($name => @values);
521 }
522 }
523}
524
525sub _encode_utf8 {
526 my ($self) = @_;
527
528 my $cgi = $self->cgi;
529
530 require Encode;
531 for my $name ($cgi->param) {
532 my @values = map Encode::encode('utf8', $_), $cgi->param($name);
533 $cgi->param($name => @values);
534 }
535}
536
f5505b76
TC
537sub user_url {
538 my ($req, $script, $target, @options) = @_;
539
540 my $cfg = $req->cfg;
541 my $base = $script eq 'shop' ? $cfg->entryVar('site', 'secureurl') : '';
542 my $template;
796809d1
TC
543 if ($target) {
544 if ($script eq 'nuser') {
545 $template = "/cgi-bin/nuser.pl/user/TARGET";
546 }
547 else {
548 $template = "$base/cgi-bin/$script.pl?a_TARGET=1";
549 }
550 $template = $cfg->entry('targets', $script, $template);
551 $template =~ s/TARGET/$target/;
f5505b76
TC
552 }
553 else {
796809d1
TC
554 if ($script eq 'nuser') {
555 $template = "/cgi-bin/nuser.pl/user";
556 }
557 else {
558 $template = "$base/cgi-bin/$script.pl";
559 }
560 $template = $cfg->entry('targets', $script.'_n', $template);
f5505b76 561 }
f5505b76
TC
562 if (@options) {
563 $template .= $template =~ /\?/ ? '&' : '?';
564 my @entries;
565 while (my ($key, $value) = splice(@options, 0, 2)) {
566 push @entries, "$key=" . escape_uri($value);
567 }
568 $template .= join '&', @entries;
569 }
570
571 return $template;
572}
573
61138170
TC
574sub admin_tags {
575 my ($req) = @_;
576
577 require BSE::Util::Tags;
578 return
579 (
580 BSE::Util::Tags->common($req),
581 BSE::Util::Tags->admin(undef, $req->cfg),
582 BSE::Util::Tags->secure($req),
583 );
584}
585
586=item is_ajax
587
8f42c1c2
TC
588Return true if the current request is an Ajax request.
589
590Warning: changing this code has security concerns, it should only
591match where the request can only be an Ajax request - if the request
592can be produced by a normal form/link POST or GET this method must NOT
593return true.
61138170
TC
594
595=cut
596
597sub is_ajax {
598 my ($self) = @_;
599
600 defined $ENV{HTTP_X_REQUESTED_WITH}
601 && $ENV{HTTP_X_REQUESTED_WITH} =~ /XMLHttpRequest/
602 and return 1;
603
61138170
TC
604 return;
605}
606
607=item send_email
608
609Send a simple email.
610
611=cut
612
613sub send_email {
614 my ($self, %opts) = @_;
615
616 require BSE::ComposeMail;
617 my $mailer = BSE::ComposeMail->new(cfg => $self->cfg);
618
619 my $id = $opts{id}
620 or confess "No mail id provided";
621
622 my $section = "email $id";
623
624 for my $key (qw/subject template html_template allow_html from from_name/) {
625 my $value = $self->{cfg}->entry($section, $key);
626 defined $value and $opts{$key} = $value;
627 }
628 unless (defined $opts{acts}) {
629 require BSE::Util::Tags;
630 BSE::Util::Tags->import(qw/tag_hash_plain/);
631 my %acts =
632 (
633 $self->dyn_user_tags
634 );
6c83a514
TC
635 if ($opts{extraacts}) {
636 %acts = ( %acts, %{$opts{extraacts}} );
637 }
638 $opts{acts} = \%acts;
61138170
TC
639 }
640
641 $mailer->send(%opts)
642 or print STDERR "Error sending mail $id: ", $mailer->errstr, "\n";
643
644 return 1;
645}
646
c6fc339f
TC
647=item is_ssl
648
649Return true if the current request is an SSL request.
650
651=cut
652
653sub is_ssl {
654 exists $ENV{HTTPS} || exists $ENV{SSL_CIPHER};
655}
656
657my %recaptcha_errors =
658 (
659 'incorrect-captcha-sol' => 'Incorrect CAPTCHA solution',
660 'recaptcha-not-reachable' => "CAPTCHA server not reachable, please wait a moment and try again",
661 );
662
663=item test_recaptcha
664
665Test if a valid reCAPTCHA response was received.
666
667=cut
668
669sub test_recaptcha {
670 my ($self, %opts) = @_;
671
672 require Captcha::reCAPTCHA;
673 my $apiprivkey = $self->cfg->entry('recaptcha', 'api_private_key');
674 unless (defined $apiprivkey) {
675 print STDERR "** No recaptcha api_private_key defined **\n";
676 return;
677 }
678 my $msg;
679 my $error = $opts{error} || \$msg;
680 my $c = Captcha::reCAPTCHA->new;
681 my $cgi = $self->cgi;
682 my $challenge = $cgi->param('recaptcha_challenge_field');
683 my $response = $cgi->param('recaptcha_response_field');
684 delete $self->{recaptcha_error};
685 if (!defined $challenge || $challenge !~ /\S/) {
686 $$error = "No reCAPTCHA challenge found";
687 return;
688 }
689 if (!defined $response || $response !~ /\S/) {
690 $$error = "No reCAPTCHA response entered";
691 return;
692 }
693
694 my $result = $c->check_answer($apiprivkey, $ENV{REMOTE_ADDR},
695 $challenge, $response);
696 unless ($result->{is_valid}) {
697 my $key = 'error_'.$result->{error};
698 $key =~ tr/-/_/;
699 $$error = $self->cfg->entry('recaptcha', $key)
700 || $recaptcha_errors{$result->{error}}
701 || $result->{error};
702 }
703 $self->{recaptcha_result} = $result;
704
705 return !!$result->{is_valid};
706}
707
708sub recaptcha_result {
709 $_[0]{recaptcha_result};
710}
711
58baa27b
TC
712=item json_content
713
714Generate a hash suitable for output_result() as JSON.
715
716=cut
717
718sub json_content {
719 my ($self, @values) = @_;
720
721 require JSON;
722
723 my $json = JSON->new;
724
725 my $value = @values > 1 ? +{ @values } : $values[0];
726
727 return
728 +{
729 type => "application/json",
730 content => $json->encode($value),
731 };
732}
733
734=item get_csrf_token($name)
735
736Generate a csrf token for the given name.
737
738=cut
739
740my $sequence = 0;
741
742sub get_csrf_token {
743 my ($req, $name) = @_;
744
745 my $cache = $req->session->{csrfp};
746 my $max_age = $req->cfg->entry('basic', 'csrfp_max_age', 3600);
747 my $now = time;
748
749 my $entry = $cache->{$name};
750 if (!$entry || $entry->{time} + $max_age < $now) {
751 if ($entry) {
752 $entry->{oldtoken} = $entry->{token};
753 $entry->{oldtime} = $entry->{time};
754 }
755 else {
756 $entry = {};
757 }
758
759 # this doesn't need to be so perfectly secure that we drain the
760 # entropy pool and it'll be called fairly often
761 require Digest::MD5;
762 $entry->{token} =
763 Digest::MD5::md5_hex($now . $$ . rand() . $sequence++ . $name);
764 $entry->{time} = $now;
765 }
766 $cache->{$name} = $entry;
767 $req->session->{csrfp} = $cache;
768
769 return $entry->{token};
770}
771
772=item check_csrf($name)
773
774Check if the CSRF token supplied by the form is valid.
775
776$name should be the name supplied to the csrfp token.
777
778=cut
779
780sub check_csrf {
781 my ($self, $name) = @_;
782
783 defined $name
784 or confess "No CSRF token name supplied";
785
8f42c1c2
TC
786 $self->is_ajax
787 and return 1;
788
58baa27b
TC
789 my $debug = $self->cfg->entry('debug', 'csrf', 0);
790
791 # the form might have multiple submit buttons, each initiating a
792 # different function, so the the form should supply tokens for every
793 # function for the form
794 my @tokens = $self->cgi->param('_csrfp');
795 unless (@tokens) {
796 $self->_csrf_error("No _csrfp token supplied");
797 return;
798 }
799
800 my $entry = $self->session->{csrfp}{$name};
801 unless ($entry) {
802 $self->_csrf_error("No token entry found for $name");
803 return;
804 }
805
806 my $max_age = $self->cfg->entry('basic', 'csrfp_max_age', 3600);
807 my $now = time;
808 for my $token (@tokens) {
809 if ($entry->{token}
810 && $entry->{token} eq $token
811 && $entry->{time} + 2*$max_age >= $now) {
812 $debug
813 and print STDERR "CSRF: match current token\n";
814 return 1;
815 }
816
817 if ($entry->{oldtoken}
818 && $entry->{oldtoken} eq $token
819 && $entry->{oldtime} + 2*$max_age >= $now) {
820 return 1;
821 }
822 }
823
824 $self->_csrf_error("No tokens matched the $name entry");
825 return;
826}
827
828sub _csrf_error {
829 my ($self, $message) = @_;
830
831 $self->cfg->entry('debug', 'csrf', 0)
832 and print STDERR "csrf error: $message\n";
833 $self->{csrf_error} = $message;
834
835 return;
836}
837
838sub csrf_error {
839 $_[0]{csrf_error};
840}
841
70789617 8421;