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