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