properly escape the <:id:> tag
[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
b3dbf74b 13 unless ($opts{nodatabase}) {
f811b4b8 14 require BSE::DB;
b3dbf74b
TC
15 BSE::DB->init($opts{cfg});
16 BSE::DB->startup();
17 }
5ac2ad24 18
a93c4cb8
TC
19 my $self = bless \%opts, $class;
20
21 $opts{cgi} ||= $self->_make_cgi;
8062fbd7 22 $opts{fastcgi} ||= 0;
70789617 23
70789617
TC
24 if ($self->cfg->entry('html', 'utf8decodeall')) {
25 $self->_encode_utf8();
26 }
27 elsif ($self->cfg->entry('html', 'ajaxcharset', 0)
61138170 28 && $self->is_ajax) {
70789617
TC
29 # convert the values of each parameter from UTF8 to iso-8859-1
30 $self->_convert_utf8_cgi_to_charset();
31 }
32
33 $self;
34}
35
a93c4cb8
TC
36sub _tracking_uploads {
37 my ($self) = @_;
38 unless (defined $self->{_tracking_uploads}) {
39 my $want_track = $self->cfg->entry("basic", "track_uploads", 0);
40 my $will_track = $self->_cache_available && $want_track;
41 if ($want_track && !$will_track) {
42 print STDERR "** Upload tracking requested but no cache found\n";
43 }
44 $self->{_tracking_uploads} = $will_track;
45 }
46
47 return $self->{_tracking_uploads};
48}
49
50sub _cache_available {
51 my ($self) = @_;
52
53 unless (defined $self->{_cache_available}) {
54 my $cache_class = $self->cfg->entry("cache", "class");
55 $self->{_cache_available} = defined $cache_class;
56 }
57
58 return $self->{_cache_available};
59}
60
61sub _cache_object {
62 my ($self) = @_;
63
64 $self->_cache_available or return;
65 $self->{_cache} and return $self->{_cache};
66
67 my $cache_class = $self->cfg->entry("cache", "class");
68 ( my $cache_mod_file = $cache_class . ".pm" ) =~ s(::)(/)g;
a93c4cb8
TC
69 require $cache_mod_file;
70
46a55e1e 71 $self->{_cache} = $cache_class->new($self->cfg);
a93c4cb8
TC
72
73 return $self->{_cache};
74}
75
76sub cache_set {
77 my ($self, $key, $value) = @_;
78
79 my $cache = $self->_cache_object
80 or return;
81
46a55e1e 82 $cache->set($key, $value);
a93c4cb8
TC
83}
84
85sub cache_get {
86 my ($self, $key) = @_;
87
88 my $cache = $self->_cache_object
89 or return;
90
46a55e1e 91 return $cache->get($key);
a93c4cb8
TC
92}
93
70789617 94sub _make_cgi {
a93c4cb8
TC
95 my ($self) = @_;
96
46a55e1e 97 my $cache;
a93c4cb8
TC
98 if ($self->_tracking_uploads
99 && $ENV{REQUEST_METHOD} eq 'POST'
78d982ee 100 && $ENV{CONTENT_TYPE}
46a55e1e 101 && $ENV{CONTENT_TYPE} =~ m(^multipart/form-data)
15f30f31 102 && $ENV{CONTENT_LENGTH}
46a55e1e 103 && defined ($cache = $self->_cache_object)) {
a93c4cb8
TC
104 # very hacky
105 my $q;
15f30f31 106 my $done = 0;
ec269d0f 107 my $last_set = time();
15f30f31
TC
108 my $upload_key;
109 if ($ENV{QUERY_STRING}
110 && $ENV{QUERY_STRING} =~ /^_upload=([a-zA-Z0-9_]+)$/) {
111 $upload_key = $1;
112 }
113 my $complete = 0;
114 eval {
115 $q = CGI->new
116 (
117 sub {
118 my ($filename, $data, $size_so_far) = @_;
119
120 $upload_key ||= $q->param("_upload");
121 $upload_key or return;
122 my $fullkey = "upload-$upload_key";
123 $done += length $data;
124 my $now = time;
125 if ($last_set + 1 <= $now) { # just in case we end up loading Time::HiRes
126 $cache->set($fullkey,
127 {
128 done => $done,
129 total => $ENV{CONTENT_LENGTH},
130 filename => $filename,
131 complete => 0
132 });
133 $last_set = $now;
134 }
135 },
136 0, # data for upload hook
137 1, # continue to use temp files
138 {} # start out empty and don't read STDIN
139 );
140
141 $q->init(); # initialize for real cgi
142 $complete = 1;
143 };
144
145 if ($upload_key) {
146 my $fullkey = "upload-$upload_key";
147
148 if ($complete) {
149 $cache->set($fullkey,
150 {
151 done => $ENV{CONTENT_LENGTH},
152 total => $ENV{CONTENT_LENGTH},
153 complete => 1,
154 });
155 }
156 else {
157 $cache->set($fullkey,
158 {
159 failed => 1,
160 });
161 die;
162 }
163 }
164
a93c4cb8
TC
165
166 return $q;
167 }
168
6361fafb
TC
169 my $q = CGI->new;
170 my $error = $q->cgi_error;
171 if ($error) {
172 print STDERR "CGI ERROR: $error\n";
173 }
174
175 return $q;
70789617
TC
176}
177
178sub cgi {
179 return $_[0]{cgi};
180}
181
182sub cfg {
183 return $_[0]{cfg};
184}
185
186sub session {
187 $_[0]{session} or die "Session has been deleted already\n";
188
189 return $_[0]{session};
190}
191
8062fbd7
TC
192sub is_fastcgi {
193 $_[0]{fastcgi};
194}
195
70789617
TC
196sub end_request {
197 delete $_[0]{session};
198}
199
70789617
TC
200sub user {
201 return $_[0]{adminuser};
202}
203
204sub setuser {
205 $_[0]{adminuser} = $_[1];
206}
207
208sub getuser {
209 $_[0]{adminuser};
210}
211
212# this needs to become non-admin specific
213sub url {
214 my ($self, $action, $params, $name) = @_;
215
216 require BSE::CfgInfo;
217 my $url = BSE::CfgInfo::admin_base_url($self->{cfg});
218 $url .= "/cgi-bin/admin/$action.pl";
219 if ($params && keys %$params) {
220 $url .= "?" . join("&", map { "$_=".escape_uri($params->{$_}) } keys %$params);
221 }
222 $url .= "#$name" if $name;
223
224 $url;
225}
226
227sub check_admin_logon {
228 my ($self) = @_;
229
230 require BSE::Permissions;
231 return BSE::Permissions->check_logon($self);
232}
233
234sub template_sets {
235 my ($self) = @_;
236
237 return () unless $self->access_control;
238
239 my $user = $self->user
240 or return;
241
242 return grep $_ ne '', map $_->{template_set}, $user->groups;
243}
244
245my $site_article =
246 {
247 id => -1,
248 title => "unknown",
249 parentid => 0,
250 generator => 'Generate::Article',
251 level => 0,
252 };
253
254sub user_can {
255 my ($self, $perm, $object, $rmsg) = @_;
256
257 require BSE::Permissions;
258 $object ||= $site_article;
259 $self->{perms} ||= BSE::Permissions->new($self->cfg);
260 if ($self->cfg->entry('basic', 'access_control', 0)) {
261 unless (ref $object) {
262 require Articles;
263 my $art = $object == -1 ? $site_article : Articles->getByPkey($object);
264 if ($art) {
265 $object = $art;
266 }
267 else {
268 print STDERR "** Cannot find article id $object\n";
269 require Carp;
270 Carp::cluck "Cannot find article id $object";
271 return 0;
272 }
273 }
274 return $self->{perms}->user_has_perm($self->user, $object, $perm, $rmsg);
275 }
276 else {
277 # some checks need to happen even if we don't want logons
278 return $self->{perms}->user_has_perm({ id=>-1 }, $object, $perm, $rmsg);
279 }
280}
281
282# a stub for now
283sub get_object {
284 return;
285}
286
287sub access_control {
288 $_[0]->{cfg}->entry('basic', 'access_control', 0);
289}
290
d2473dc2
TC
291sub get_refresh {
292 my ($req, $url) = @_;
293
294 require BSE::Template;
295 BSE::Template->get_refresh($url, $req->cfg);
296}
297
70789617
TC
298sub output_result {
299 my ($req, $result) = @_;
300
301 require BSE::Template;
302 BSE::Template->output_result($req, $result);
303}
304
e63c3728
TC
305sub flash {
306 my ($self, @msg) = @_;
307
308 my $msg = "@msg";
309 my @flash;
310 @flash = @{$self->session->{flash}} if $self->session->{flash};
311 push @flash, $msg;
312 $self->session->{flash} = \@flash;
313}
314
70789617
TC
315sub message {
316 my ($req, $errors) = @_;
317
318 my $msg = '';
e63c3728 319 my @lines;
70789617
TC
320 if ($errors and keys %$errors) {
321 my @fields = $req->cgi->param;
322 my %work = %$errors;
70789617
TC
323 for my $field (@fields) {
324 if (my $entry = delete $work{$field}) {
325 push @lines, ref($entry) ? grep $_, @$entry : $entry;
326 }
327 }
328 for my $entry (values %work) {
329 if (ref $entry) {
330 push @lines, grep $_, @$entry;
331 }
332 else {
333 push @lines, $entry;
334 }
335 }
336 my %seen;
337 @lines = grep !$seen{$_}++, @lines; # don't need duplicates
70789617 338 }
b0090c10 339 if (!$req->{nosession} && $req->session->{flash}) {
e63c3728
TC
340 push @lines, @{$req->session->{flash}};
341 delete $req->session->{flash};
342 }
343 $msg = join "<br />", map escape_html($_), @lines;
70789617
TC
344 if (!$msg && $req->cgi->param('m')) {
345 $msg = join(' ', $req->cgi->param('m'));
346 $msg = escape_html($msg);
347 }
348
349 return $msg;
350}
351
352sub dyn_response {
4c4d3c3f 353 my ($req, $template, $acts, $modifier) = @_;
70789617
TC
354
355 my @search = $template;
356 my $base_template = $template;
357 my $t = $req->cgi->param('t');
358 $t or $t = $req->cgi->param('_t');
4c4d3c3f 359 $t or $t = $modifier;
70789617
TC
360 if ($t && $t =~ /^\w+$/) {
361 $template .= "_$t";
362 unshift @search, $template;
363 }
364
365 require BSE::Template;
366 my @sets;
367 if ($template =~ m!^admin/!) {
368 @sets = $req->template_sets;
369 }
370
371 return BSE::Template->get_response($template, $req->cfg, $acts,
372 $base_template, \@sets);
373}
374
375sub response {
376 my ($req, $template, $acts) = @_;
377
378 require BSE::Template;
379 my @sets;
380 if ($template =~ m!^admin/!) {
381 @sets = $req->template_sets;
382 }
383
384 return BSE::Template->get_response($template, $req->cfg, $acts,
385 $template, \@sets);
386}
387
388# get the current site user if one is logged on
389sub siteuser {
390 my ($req) = @_;
391
392 ++$req->{siteuser_calls};
393 if (exists $req->{_siteuser}) {
394 ++$req->{siteuser_cached};
395 return $req->{_siteuser};
396 }
397
398 my $cfg = $req->cfg;
399 my $session = $req->session;
400 require SiteUsers;
401 if ($cfg->entryBool('custom', 'user_auth')) {
402 require BSE::CfgInfo;
403 my $custom = BSE::CfgInfo::custom_class($cfg);
404
405 return $custom->siteuser_auth($session, $req->cgi, $cfg);
406 }
407 else {
408 $req->{_siteuser} = undef;
409
410 my $userid = $session->{userid}
411 or return;
412 my $user = SiteUsers->getBy(userId=>$userid)
413 or return;
414 $user->{disabled}
415 and return;
416
417 $req->{_siteuser} = $user;
418
419 return $user;
420 }
421}
422
423sub validate {
424 my ($req, %options) = @_;
425
426 $options{rules} ||= {};
427
428 require BSE::Validate;
9b3a5df0
TC
429 my %opts =
430 (
431 fields => $options{fields},
432 rules => $options{rules},
433 );
434 exists $options{optional} and $opts{optional} = $options{optional};
435 BSE::Validate::bse_validate
436 (
437 $req->cgi,
438 $options{errors},
439 \%opts,
440 $req->cfg,
441 $options{section}
442 );
70789617
TC
443}
444
445sub validate_hash {
446 my ($req, %options) = @_;
447
448 $options{rules} ||= {};
449
9b3a5df0
TC
450 my %opts =
451 (
452 fields => $options{fields},
453 rules => $options{rules},
454 );
455 exists $options{optional} and $opts{optional} = $options{optional};
70789617 456 require BSE::Validate;
9b3a5df0
TC
457 BSE::Validate::bse_validate_hash
458 (
459 $options{data},
460 $options{errors},
461 \%opts,
462 $req->cfg,
463 $options{section}
464 );
70789617
TC
465}
466
467sub configure_fields {
468 my ($self, $fields, $section) = @_;
469
470 my $cfg = $self->cfg;
471 require BSE::Validate;
472 my $cfg_fields = BSE::Validate::bse_configure_fields($fields, $cfg, $section);
473
474 for my $name (keys %$fields) {
475 for my $cfg_name (qw/htmltype type width height size maxlength/) {
476 my $value = $cfg->entry($section, "${name}_${cfg_name}");
477 defined $value and $cfg_fields->{$name}{$cfg_name} = $value;
478 }
479 }
480
481 $cfg_fields;
482}
483
484sub _have_group_access {
485 my ($req, $user, $group_ids, $membership) = @_;
486
487 if (grep $_ > 0, @$group_ids) {
488 $membership->{filled}
489 or %$membership = map { $_ => 1 } 'filled', $user->group_ids;
490 return 1
491 if grep $membership->{$_}, @$group_ids;
492 }
493 for my $query_id (grep $_ < 0, @$group_ids) {
494 require BSE::TB::SiteUserGroups;
495 my $group = BSE::TB::SiteUserGroups->getQueryGroup($req->cfg, $query_id)
496 or next;
497 my $rows = BSE::DB->single->dbh->selectall_arrayref($group->{sql}, { MaxRows=>1 }, $user->{id});
498 $rows && @$rows
499 and return 1;
500 }
501
502 return 0;
503}
504
505sub _siteuser_has_access {
506 my ($req, $article, $user, $default, $membership) = @_;
507
508 defined $default or $default = 1;
509 defined $membership or $membership = {};
510
1b73ea7e
TC
511 unless ($article) {
512 # this shouldn't happen
513 cluck("_siteuser_has_access() called without an article parameter!");
514 return 0;
515 }
516
70789617
TC
517 my @group_ids = $article->group_ids;
518 if ($article->{inherit_siteuser_rights}
519 && $article->{parentid} != -1) {
520 if (@group_ids) {
521 $user ||= $req->siteuser
522 or return 0;
523 if ($req->_have_group_access($user, \@group_ids, $membership)) {
524 return 1;
525 }
526 else {
527 return $req->siteuser_has_access($article->parent, $user, 0);
528 }
529 }
530 else {
531 # ask parent
532 return $req->siteuser_has_access($article->parent, $user, $default);
533 }
534 }
535 else {
536 if (@group_ids) {
537 $user ||= $req->siteuser
538 or return 0;
539 if ($req->_have_group_access($user, \@group_ids, $membership)) {
540 return 1;
541 }
542 else {
543 return 0;
544 }
545 }
546 else {
547 return $default;
548 }
549 }
550}
551
552sub siteuser_has_access {
553 my ($req, $article, $user, $default, $membership) = @_;
554
555 $user ||= $req->siteuser;
556
557 ++$req->{has_access_total};
558 if ($req->{_siteuser} && $user && $user->{id} == $req->{_siteuser}{id}
559 && exists $req->{_access_cache}{$article->{id}}) {
560 ++$req->{has_access_cached};
561 return $req->{_access_cache}{$article->{id}};
562 }
563
564 my $result = $req->_siteuser_has_access($article, $user, $default, $membership);
565
566 if ($user && $req->{_siteuser} && $user->{id} == $req->{_siteuser}{id}) {
567 $req->{_access_cache}{$article->{id}} = $result;
568 }
569
570 return $result;
571}
572
573sub dyn_user_tags {
574 my ($self) = @_;
575
576 require BSE::Util::DynamicTags;
577 return BSE::Util::DynamicTags->new($self)->tags;
578}
579
580sub DESTROY {
581 my ($self) = @_;
582
583 if ($self->{cache_stats}) {
584 print STDERR "Siteuser cache: $self->{siteuser_calls} Total, $self->{siteuser_cached} Cached\n"
585 if $self->{siteuser_calls};
586 print STDERR "Access cache: $self->{has_access_total} Total, $self->{has_access_cached} Cached\n"
587 if $self->{has_access_total};
588 }
589
590 if ($self->{session}) {
591 undef $self->{session};
592 }
593}
594
595sub set_article {
596 my ($self, $name, $article) = @_;
597
598 if ($article) {
599 $self->{articles}{$name} = $article;
600 }
601 else {
602 delete $self->{articles}{$name};
603 }
604}
605
606sub get_article {
607 my ($self, $name) = @_;
608
609 exists $self->{articles}{$name}
610 or return;
611
612 my $article = $self->{articles}{$name};
613 if (ref $article eq 'SCALAR') {
614 $article = $$article;
615 }
616 $article
617 or return;
618
619 $article;
620}
621
622sub text {
623 my ($self, $id, $default) = @_;
624
56f87a80 625 return $self->cfg->entry('messages', $id, $default);
70789617
TC
626}
627
628sub _convert_utf8_cgi_to_charset {
629 my ($self) = @_;
630
631 require Encode;
632 my $cgi = $self->cgi;
633 my $workset = $self->cfg->entry('html', 'charset', 'iso-8859-1');
634 my $decoded = $self->cfg->entry('html', 'cgi_decoded', 1);
635
636 # avoids param decoding the data
637 $cgi->charset($workset);
638
639 print STDERR "Converting parameters from UTF8 to $workset\n"
640 if $self->cfg->entry('debug', 'convert_charset');
641
642 if ($decoded) {
643 # CGI.pm has already converted it from utf8 to perl's internal encoding
644 # so we just need to encode to the working encoding
645 # I don't see a reliable way to detect this without configuring it
646 for my $name ($cgi->param) {
647 my @values = map Encode::encode($workset, $_), $cgi->param($name);
648
649 $cgi->param($name => @values);
650 }
651 }
652 else {
653 for my $name ($cgi->param) {
654 my @values = $cgi->param($name);
655 Encode::from_to($_, $workset, 'utf8') for @values;
656 $cgi->param($name => @values);
657 }
658 }
659}
660
661sub _encode_utf8 {
662 my ($self) = @_;
663
664 my $cgi = $self->cgi;
665
666 require Encode;
667 for my $name ($cgi->param) {
668 my @values = map Encode::encode('utf8', $_), $cgi->param($name);
669 $cgi->param($name => @values);
670 }
671}
672
f5505b76
TC
673sub user_url {
674 my ($req, $script, $target, @options) = @_;
675
676 my $cfg = $req->cfg;
677 my $base = $script eq 'shop' ? $cfg->entryVar('site', 'secureurl') : '';
678 my $template;
796809d1
TC
679 if ($target) {
680 if ($script eq 'nuser') {
681 $template = "/cgi-bin/nuser.pl/user/TARGET";
682 }
683 else {
684 $template = "$base/cgi-bin/$script.pl?a_TARGET=1";
685 }
686 $template = $cfg->entry('targets', $script, $template);
687 $template =~ s/TARGET/$target/;
f5505b76
TC
688 }
689 else {
796809d1
TC
690 if ($script eq 'nuser') {
691 $template = "/cgi-bin/nuser.pl/user";
692 }
693 else {
694 $template = "$base/cgi-bin/$script.pl";
695 }
696 $template = $cfg->entry('targets', $script.'_n', $template);
f5505b76 697 }
f5505b76
TC
698 if (@options) {
699 $template .= $template =~ /\?/ ? '&' : '?';
700 my @entries;
701 while (my ($key, $value) = splice(@options, 0, 2)) {
702 push @entries, "$key=" . escape_uri($value);
703 }
704 $template .= join '&', @entries;
705 }
706
707 return $template;
708}
709
61138170
TC
710sub admin_tags {
711 my ($req) = @_;
712
713 require BSE::Util::Tags;
714 return
715 (
716 BSE::Util::Tags->common($req),
717 BSE::Util::Tags->admin(undef, $req->cfg),
718 BSE::Util::Tags->secure($req),
719 );
720}
721
722=item is_ajax
723
8f42c1c2
TC
724Return true if the current request is an Ajax request.
725
726Warning: changing this code has security concerns, it should only
727match where the request can only be an Ajax request - if the request
728can be produced by a normal form/link POST or GET this method must NOT
729return true.
61138170
TC
730
731=cut
732
733sub is_ajax {
734 my ($self) = @_;
735
736 defined $ENV{HTTP_X_REQUESTED_WITH}
737 && $ENV{HTTP_X_REQUESTED_WITH} =~ /XMLHttpRequest/
738 and return 1;
739
61138170
TC
740 return;
741}
742
5273694f
TC
743=item want_json_response
744
745Return true if the caller has indicated they want a JSON response.
746
747In practice, returns true if is_ajax() is true or a _ parameter was
748supplied.
749
750=cut
751
752sub want_json_response {
753 my ($self) = @_;
754
755 $self->is_ajax and return 1;
756
757 $self->cgi->param("_") and return 1;
758
759 return;
760}
761
61138170
TC
762=item send_email
763
764Send a simple email.
765
766=cut
767
768sub send_email {
769 my ($self, %opts) = @_;
770
771 require BSE::ComposeMail;
772 my $mailer = BSE::ComposeMail->new(cfg => $self->cfg);
773
774 my $id = $opts{id}
775 or confess "No mail id provided";
776
777 my $section = "email $id";
778
779 for my $key (qw/subject template html_template allow_html from from_name/) {
780 my $value = $self->{cfg}->entry($section, $key);
781 defined $value and $opts{$key} = $value;
782 }
783 unless (defined $opts{acts}) {
784 require BSE::Util::Tags;
785 BSE::Util::Tags->import(qw/tag_hash_plain/);
786 my %acts =
787 (
788 $self->dyn_user_tags
789 );
6c83a514
TC
790 if ($opts{extraacts}) {
791 %acts = ( %acts, %{$opts{extraacts}} );
792 }
793 $opts{acts} = \%acts;
61138170
TC
794 }
795
796 $mailer->send(%opts)
797 or print STDERR "Error sending mail $id: ", $mailer->errstr, "\n";
798
799 return 1;
800}
801
c6fc339f
TC
802=item is_ssl
803
804Return true if the current request is an SSL request.
805
806=cut
807
808sub is_ssl {
809 exists $ENV{HTTPS} || exists $ENV{SSL_CIPHER};
810}
811
812my %recaptcha_errors =
813 (
814 'incorrect-captcha-sol' => 'Incorrect CAPTCHA solution',
815 'recaptcha-not-reachable' => "CAPTCHA server not reachable, please wait a moment and try again",
816 );
817
818=item test_recaptcha
819
820Test if a valid reCAPTCHA response was received.
821
822=cut
823
824sub test_recaptcha {
825 my ($self, %opts) = @_;
826
827 require Captcha::reCAPTCHA;
828 my $apiprivkey = $self->cfg->entry('recaptcha', 'api_private_key');
829 unless (defined $apiprivkey) {
830 print STDERR "** No recaptcha api_private_key defined **\n";
831 return;
832 }
833 my $msg;
834 my $error = $opts{error} || \$msg;
835 my $c = Captcha::reCAPTCHA->new;
836 my $cgi = $self->cgi;
837 my $challenge = $cgi->param('recaptcha_challenge_field');
838 my $response = $cgi->param('recaptcha_response_field');
839 delete $self->{recaptcha_error};
840 if (!defined $challenge || $challenge !~ /\S/) {
841 $$error = "No reCAPTCHA challenge found";
842 return;
843 }
844 if (!defined $response || $response !~ /\S/) {
845 $$error = "No reCAPTCHA response entered";
846 return;
847 }
848
849 my $result = $c->check_answer($apiprivkey, $ENV{REMOTE_ADDR},
850 $challenge, $response);
851 unless ($result->{is_valid}) {
852 my $key = 'error_'.$result->{error};
853 $key =~ tr/-/_/;
854 $$error = $self->cfg->entry('recaptcha', $key)
855 || $recaptcha_errors{$result->{error}}
856 || $result->{error};
857 }
858 $self->{recaptcha_result} = $result;
859
860 return !!$result->{is_valid};
861}
862
863sub recaptcha_result {
864 $_[0]{recaptcha_result};
865}
866
58baa27b
TC
867=item json_content
868
869Generate a hash suitable for output_result() as JSON.
870
871=cut
872
873sub json_content {
874 my ($self, @values) = @_;
875
876 require JSON;
877
878 my $json = JSON->new;
879
880 my $value = @values > 1 ? +{ @values } : $values[0];
7350b200
TC
881 my ($context) = $self->cgi->param("_context");
882 if (defined $context) {
883 $value->{context} = $context;
884 }
58baa27b 885
f6c1d890 886 my $json_result =
58baa27b
TC
887 +{
888 type => "application/json",
889 content => $json->encode($value),
890 };
f6c1d890
TC
891
892 if (!exists $ENV{HTTP_X_REQUESTED_WITH}
893 || $ENV{HTTP_X_REQUESTED_WITH} !~ /XMLHttpRequest/) {
894 $json_result->{type} = "text/plain";
895 }
896
897 return $json_result;
58baa27b
TC
898}
899
900=item get_csrf_token($name)
901
902Generate a csrf token for the given name.
903
904=cut
905
906my $sequence = 0;
907
908sub get_csrf_token {
909 my ($req, $name) = @_;
910
911 my $cache = $req->session->{csrfp};
912 my $max_age = $req->cfg->entry('basic', 'csrfp_max_age', 3600);
913 my $now = time;
914
915 my $entry = $cache->{$name};
916 if (!$entry || $entry->{time} + $max_age < $now) {
917 if ($entry) {
918 $entry->{oldtoken} = $entry->{token};
919 $entry->{oldtime} = $entry->{time};
920 }
921 else {
922 $entry = {};
923 }
924
925 # this doesn't need to be so perfectly secure that we drain the
926 # entropy pool and it'll be called fairly often
927 require Digest::MD5;
928 $entry->{token} =
929 Digest::MD5::md5_hex($now . $$ . rand() . $sequence++ . $name);
930 $entry->{time} = $now;
931 }
932 $cache->{$name} = $entry;
933 $req->session->{csrfp} = $cache;
934
935 return $entry->{token};
936}
937
938=item check_csrf($name)
939
940Check if the CSRF token supplied by the form is valid.
941
942$name should be the name supplied to the csrfp token.
943
944=cut
945
946sub check_csrf {
947 my ($self, $name) = @_;
948
949 defined $name
950 or confess "No CSRF token name supplied";
951
8f42c1c2
TC
952 $self->is_ajax
953 and return 1;
954
58baa27b
TC
955 my $debug = $self->cfg->entry('debug', 'csrf', 0);
956
957 # the form might have multiple submit buttons, each initiating a
958 # different function, so the the form should supply tokens for every
959 # function for the form
960 my @tokens = $self->cgi->param('_csrfp');
961 unless (@tokens) {
962 $self->_csrf_error("No _csrfp token supplied");
963 return;
964 }
965
966 my $entry = $self->session->{csrfp}{$name};
967 unless ($entry) {
968 $self->_csrf_error("No token entry found for $name");
969 return;
970 }
971
972 my $max_age = $self->cfg->entry('basic', 'csrfp_max_age', 3600);
973 my $now = time;
974 for my $token (@tokens) {
975 if ($entry->{token}
976 && $entry->{token} eq $token
977 && $entry->{time} + 2*$max_age >= $now) {
978 $debug
979 and print STDERR "CSRF: match current token\n";
980 return 1;
981 }
982
983 if ($entry->{oldtoken}
984 && $entry->{oldtoken} eq $token
985 && $entry->{oldtime} + 2*$max_age >= $now) {
986 return 1;
987 }
988 }
989
990 $self->_csrf_error("No tokens matched the $name entry");
991 return;
992}
993
994sub _csrf_error {
995 my ($self, $message) = @_;
996
997 $self->cfg->entry('debug', 'csrf', 0)
998 and print STDERR "csrf error: $message\n";
999 $self->{csrf_error} = $message;
1000
1001 return;
1002}
1003
1004sub csrf_error {
1005 $_[0]{csrf_error};
1006}
1007
a0edb02e
TC
1008=item audit(object => $object, action => $action)
1009
1010Simple audit logging.
1011
1012We record:
1013
1014 object id, object describe result, action, siteuserid, ip address, date/time
1015
1016object and action are required.
1017
1018=cut
1019
1020sub audit {
1021 my ($self, %opts) = @_;
1022
1023 my $object = delete $opts{object}
1024 or confess "Missing object parameter";
1025
1026 my $action = delete $opts{action}
1027 or confess "Missing action parameter";
1028
1029 # check all of these are callable
1030 my $id = $object->id;
1031 my $desc = $object->describe;
1032
1033 $self->cfg->entry("basic", "auditlog", 0)
1034 or return; # no audit logging
1035
1036 # assumed that check_admin_logon() has been done
1037 my $admin = $self->user;
1038
1039 require BSE::Util::SQL;
1040 require BSE::TB::AuditLog;
1041 my %entry =
1042 (
1043 object_id => $id,
1044 object_desc => $desc,
1045 action => $action,
1046 admin_id => $admin ? $admin->id : undef,
1047 ip_address => $ENV{REMOTE_ADDR},
1048 when_at => BSE::Util::SQL::now_datetime(),
1049 );
1050 BSE::TB::AuditLog->make(%entry);
1051}
1052
a74330a2
TC
1053sub ip_address {
1054 return $ENV{REMOTE_ADDR};
1055}
1056
70789617 10571;