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