simplify access to object log activity
[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
95442846
TC
8our $VERSION = "1.016";
9
10=head1 NAME
11
12BSE::Request::Base - base class for request objects
13
14=head1 SYNOPSIS
15
16 use BSE::Request;
17 my $req = BSE::Request->new;
18
19=head1 DESCRIPTION
20
21The BSE::Request::Base class provides most of the functionality of
22BSE::Request.
23
24=head1 CONSTRUCTOR
25
26=over
27
28=item new()
29
30Create a new request. Paramaters:
31
32=over
33
34=item *
35
36C<cgi> - provide a custom CGI object. Default: create a CGI.pm object.
37
38=item *
39
40C<cfg> - provide a custom config object. Default: create a BSE::Cfg
41object.
42
43=item *
44
45C<fastcgi> - set to true and supply cgi if this is a FastCGI request.
46
47=item *
48
49C<nodatabase> - skip database initialization.
50
51=item *
52
53C<nosession> - don't allow a session object to be initialized.
54
55=back
56
57=cut
cb7fd78d 58
70789617
TC
59sub new {
60 my ($class, %opts) = @_;
61
d2473dc2
TC
62 $opts{cfg} ||= BSE::Cfg->new;
63
b3dbf74b 64 unless ($opts{nodatabase}) {
f811b4b8 65 require BSE::DB;
b3dbf74b
TC
66 BSE::DB->init($opts{cfg});
67 BSE::DB->startup();
68 }
5ac2ad24 69
a93c4cb8
TC
70 my $self = bless \%opts, $class;
71
72 $opts{cgi} ||= $self->_make_cgi;
8062fbd7 73 $opts{fastcgi} ||= 0;
7c74b5f6 74 $opts{vars} = {};
70789617 75
3f9c8a96 76 return $self;
70789617
TC
77}
78
a93c4cb8
TC
79sub _tracking_uploads {
80 my ($self) = @_;
81 unless (defined $self->{_tracking_uploads}) {
82 my $want_track = $self->cfg->entry("basic", "track_uploads", 0);
83 my $will_track = $self->_cache_available && $want_track;
84 if ($want_track && !$will_track) {
85 print STDERR "** Upload tracking requested but no cache found\n";
86 }
87 $self->{_tracking_uploads} = $will_track;
88 }
89
90 return $self->{_tracking_uploads};
91}
92
93sub _cache_available {
94 my ($self) = @_;
95
96 unless (defined $self->{_cache_available}) {
97 my $cache_class = $self->cfg->entry("cache", "class");
98 $self->{_cache_available} = defined $cache_class;
99 }
100
101 return $self->{_cache_available};
102}
103
104sub _cache_object {
105 my ($self) = @_;
106
107 $self->_cache_available or return;
108 $self->{_cache} and return $self->{_cache};
109
ebc63b18 110 require BSE::Cache;
a93c4cb8 111
ebc63b18 112 $self->{_cache} = BSE::Cache->load($self->cfg);
a93c4cb8
TC
113
114 return $self->{_cache};
115}
116
95442846
TC
117=back
118
119=head1 METHODS
120
121=over
122
123=item cache_set($key, $value)
124
125Set the cache entry $key to $value.
126
127Does nothing if the cache is not configured.
128
129=cut
130
a93c4cb8
TC
131sub cache_set {
132 my ($self, $key, $value) = @_;
133
134 my $cache = $self->_cache_object
135 or return;
136
46a55e1e 137 $cache->set($key, $value);
a93c4cb8
TC
138}
139
95442846
TC
140=item cache_get($key)
141
142Retrieve the cache entry identified by $key.
143
144=cut
145
a93c4cb8
TC
146sub cache_get {
147 my ($self, $key) = @_;
148
149 my $cache = $self->_cache_object
150 or return;
151
46a55e1e 152 return $cache->get($key);
a93c4cb8
TC
153}
154
70789617 155sub _make_cgi {
a93c4cb8
TC
156 my ($self) = @_;
157
46a55e1e 158 my $cache;
a93c4cb8
TC
159 if ($self->_tracking_uploads
160 && $ENV{REQUEST_METHOD} eq 'POST'
78d982ee 161 && $ENV{CONTENT_TYPE}
46a55e1e 162 && $ENV{CONTENT_TYPE} =~ m(^multipart/form-data)
15f30f31 163 && $ENV{CONTENT_LENGTH}
3f9c8a96
TC
164 && $ENV{QUERY_STRING}
165 && $ENV{QUERY_STRING} =~ /^_upload=([a-zA-Z0-9_]+)$/
46a55e1e 166 && defined ($cache = $self->_cache_object)) {
a93c4cb8 167 # very hacky
3f9c8a96
TC
168 my $upload_key = $1;
169 my $fullkey = "upload-$upload_key";
a93c4cb8 170 my $q;
15f30f31 171 my $done = 0;
ec269d0f 172 my $last_set = time();
15f30f31
TC
173 my $complete = 0;
174 eval {
175 $q = CGI->new
176 (
177 sub {
178 my ($filename, $data, $size_so_far) = @_;
3f9c8a96 179
15f30f31
TC
180 $done += length $data;
181 my $now = time;
182 if ($last_set + 1 <= $now) { # just in case we end up loading Time::HiRes
183 $cache->set($fullkey,
184 {
185 done => $done,
186 total => $ENV{CONTENT_LENGTH},
187 filename => $filename,
188 complete => 0
189 });
190 $last_set = $now;
191 }
192 },
193 0, # data for upload hook
194 1, # continue to use temp files
195 {} # start out empty and don't read STDIN
196 );
197
198 $q->init(); # initialize for real cgi
199 $complete = 1;
200 };
201
3f9c8a96
TC
202 if ($complete) {
203 $cache->set($fullkey,
204 {
205 done => $ENV{CONTENT_LENGTH},
206 total => $ENV{CONTENT_LENGTH},
207 complete => 1,
208 });
209 }
210 else {
211 $cache->set($fullkey,
212 {
213 failed => 1,
214 });
215 die;
216 }
217
218 if ($self->utf8) {
219 require BSE::CGI;
220 return BSE::CGI->new($q, $self->charset);
15f30f31 221 }
a93c4cb8
TC
222
223 return $q;
224 }
225
6361fafb
TC
226 my $q = CGI->new;
227 my $error = $q->cgi_error;
228 if ($error) {
229 print STDERR "CGI ERROR: $error\n";
230 }
231
3f9c8a96
TC
232 if ($self->utf8) {
233 require BSE::CGI;
234 return BSE::CGI->new($q, $self->charset);
235 }
236
6361fafb 237 return $q;
70789617
TC
238}
239
95442846
TC
240=item cgi
241
242Return the request's CGI object.
243
244=cut
245
70789617
TC
246sub cgi {
247 return $_[0]{cgi};
248}
249
95442846
TC
250=item cfg
251
252Return the request's cfg object.
253
254=cut
255
70789617
TC
256sub cfg {
257 return $_[0]{cfg};
258}
259
95442846
TC
260=item session
261
262Return the request's session object.
263
264=cut
265
70789617 266sub session {
d37dd861 267 my $self = shift;
70789617 268
d37dd861
TC
269 $self->{session}
270 or $self->_make_session;
271
272 return $self->{session};
70789617
TC
273}
274
95442846
TC
275=item is_fastcgi
276
277return true for a fast CGI request.
278
279=cut
280
8062fbd7
TC
281sub is_fastcgi {
282 $_[0]{fastcgi};
283}
284
95442846
TC
285=item end_request
286
287End the current request.
288
289Must only be called by BSE itself.
290
291=cut
292
70789617
TC
293sub end_request {
294 delete $_[0]{session};
295}
296
95442846
TC
297=item user
298
299Return the currently logged in admin user.
300
301Only valid in administrative templates.
302
303=cut
304
70789617
TC
305sub user {
306 return $_[0]{adminuser};
307}
308
309sub setuser {
310 $_[0]{adminuser} = $_[1];
311}
312
313sub getuser {
314 $_[0]{adminuser};
315}
316
95442846
TC
317=item url($action, $params, $name)
318
319Equivalent to $req->cfg->admin_url($action, $params, $name)
320
321=cut
322
70789617
TC
323sub url {
324 my ($self, $action, $params, $name) = @_;
325
a5093f33 326 return $self->cfg->admin_url($action, $params, $name);
70789617
TC
327}
328
95442846
TC
329=item check_admin_logon()
330
331Used internally to check an admin user is logged on.
332
333=cut
334
70789617
TC
335sub check_admin_logon {
336 my ($self) = @_;
337
338 require BSE::Permissions;
339 return BSE::Permissions->check_logon($self);
340}
341
70789617
TC
342my $site_article =
343 {
344 id => -1,
345 title => "unknown",
346 parentid => 0,
347 generator => 'Generate::Article',
348 level => 0,
349 };
350
95442846
TC
351=item user_can($perm, $object, $msg)
352
353Check if the current admin user can perform action $perm on $object.
354
355$object is an article or an article id.
356
357=cut
358
70789617
TC
359sub user_can {
360 my ($self, $perm, $object, $rmsg) = @_;
361
362 require BSE::Permissions;
363 $object ||= $site_article;
364 $self->{perms} ||= BSE::Permissions->new($self->cfg);
365 if ($self->cfg->entry('basic', 'access_control', 0)) {
366 unless (ref $object) {
367 require Articles;
368 my $art = $object == -1 ? $site_article : Articles->getByPkey($object);
369 if ($art) {
370 $object = $art;
371 }
372 else {
373 print STDERR "** Cannot find article id $object\n";
374 require Carp;
375 Carp::cluck "Cannot find article id $object";
376 return 0;
377 }
378 }
379 return $self->{perms}->user_has_perm($self->user, $object, $perm, $rmsg);
380 }
381 else {
382 # some checks need to happen even if we don't want logons
383 return $self->{perms}->user_has_perm({ id=>-1 }, $object, $perm, $rmsg);
384 }
385}
386
387# a stub for now
388sub get_object {
389 return;
390}
391
95442846
TC
392=item access_control
393
394Return true if access control is enabled.
395
396=cut
397
70789617
TC
398sub access_control {
399 $_[0]->{cfg}->entry('basic', 'access_control', 0);
400}
401
95442846 402=item flash($msg, ...)
d2473dc2 403
95442846 404Flash a notice (backward compat).
70789617 405
95442846 406=cut
70789617 407
7c74b5f6
TC
408sub flash {
409 my ($self, @msg) = @_;
410
411 return $self->flash_notice(@msg);
412}
413
95442846
TC
414=item flash_error($msg, ...)
415
416Flash an error message.
417
418=cut
419
13a986ee
TC
420sub flash_error {
421 my ($self, @msg) = @_;
422
7c74b5f6 423 return $self->flashext({ class => "error" }, @msg);
13a986ee
TC
424}
425
95442846
TC
426=item flash_notice($msg, ...)
427
428Flash a notice.
429
430=cut
431
7c74b5f6 432sub flash_notice {
e63c3728
TC
433 my ($self, @msg) = @_;
434
7c74b5f6
TC
435 return $self->flashext({ class => "notice" }, @msg);
436}
437
95442846
TC
438=item flashext(\%opts, $msg, ...)
439
440Flash a message, with options.
441
442Possible options are:
443
444=over
445
446=item *
447
448class - defaults to "notice".
449
450=item *
451
452type - defaults to "text", can also be "html".
453
454=back
455
456The $msg parameter can also be a message id.
457
458=cut
459
7c74b5f6
TC
460sub flashext {
461 my ($self, $opts, @msg) = @_;
462
463 my %entry =
464 (
465 class => $opts->{class} || "notice",
466 type => "text",
467 );
f83119bf 468 if ($msg[0] =~ /^msg:/) {
7c74b5f6
TC
469 $entry{text} = $self->catmsg(@msg);
470 $entry{html} = $self->htmlmsg(@msg);
f83119bf
TC
471 }
472 else {
7c74b5f6
TC
473 $entry{text} = "@msg";
474 $entry{html} = escape_html($entry{text});
f83119bf
TC
475 }
476
e63c3728
TC
477 my @flash;
478 @flash = @{$self->session->{flash}} if $self->session->{flash};
7c74b5f6
TC
479 push @flash, \%entry;
480
e63c3728
TC
481 $self->session->{flash} = \@flash;
482}
483
13a986ee
TC
484sub _str_msg {
485 my ($req, $msg) = @_;
486
487 if ($msg =~ /^(msg:[\w-]+(?:\/[\w-]+)+)(?::(.*))?$/) {
488 my $id = $1;
489 my $params = $2;
490 my @params = defined $params ? split(/:/, $params) : ();
491 $msg = $req->catmsg($id, \@params);
492 }
493
494 return $msg;
495}
496
7c74b5f6
TC
497sub _str_msg_html {
498 my ($req, $msg) = @_;
499
500 if ($msg =~ /^(msg:[\w-]+(?:\/[\w-]+)+)(?::(.*))?$/) {
501 my $id = $1;
502 my $params = $2;
503 my @params = defined $params ? split(/:/, $params) : ();
504 $msg = $req->htmlmsg($id, \@params);
505 }
98e998de
TC
506 else {
507 $msg = escape_html($msg);
508 }
7c74b5f6
TC
509
510 return $msg;
511}
512
95442846
TC
513=item messages($errors)
514
515Retrieve the current set of messages, optionally setting them.
516
517Returns a list of message entries, each with:
518
519=over
520
521=item *
522
523class - error or notice.
524
525=item *
526
527type - the original content type of the message, either "text" or
528"html".
529
530=item *
531
532text - the message as text.
533
534=item *
535
536html - the message as html.
537
538=back
539
540=cut
541
7c74b5f6
TC
542sub messages {
543 my ($self, $errors) = @_;
70789617 544
7c74b5f6
TC
545 my @messages;
546 push @messages, @{$self->{messages}} if $self->{messages};
18aa1655 547 if ($errors and ref $errors && keys %$errors) {
ebc63b18
TC
548 # do any translation needed
549 for my $key (keys %$errors) {
550 my @msgs = ref $errors->{$key} ? @{$errors->{$key}} : $errors->{$key};
551
552 for my $msg (@msgs) {
7c74b5f6 553 $msg = $self->_str_msg($msg);
ebc63b18
TC
554 }
555 $errors->{$key} = ref $errors->{$key} ? \@msgs : $msgs[0];
556 }
557
7c74b5f6 558 my @fields = $self->cgi->param;
70789617 559 my %work = %$errors;
70789617
TC
560 for my $field (@fields) {
561 if (my $entry = delete $work{$field}) {
7c74b5f6
TC
562 push @messages,
563 map +{
564 type => "text",
565 text => $_,
566 class => "error",
567 html => escape_html($_),
568 }, ref($entry) ? grep $_, @$entry : $entry;
70789617
TC
569 }
570 }
571 for my $entry (values %work) {
572 if (ref $entry) {
7c74b5f6
TC
573 push @messages, map
574 +{
575 type => "text",
576 text => $_,
577 class => "error",
578 html => escape_html($_)
579 }, grep $_, @$entry;
70789617
TC
580 }
581 else {
7c74b5f6
TC
582 push @messages,
583 {
584 type => "text",
585 text => $entry,
586 class => "error",
587 html => escape_html($entry),
588 };
70789617
TC
589 }
590 }
59fca225 591 $self->{field_errors} = $errors;
70789617 592 }
18aa1655
TC
593 elsif ($errors && !ref $errors) {
594 push @messages,
595 {
596 type => "text",
597 text => $errors,
598 class => "error",
599 html => escape_html($errors),
600 };
601 }
7c74b5f6
TC
602 if (!$self->{nosession} && $self->session->{flash}) {
603 push @messages, @{$self->session->{flash}};
604 delete $self->session->{flash};
e63c3728 605 }
7c74b5f6
TC
606 if (!@messages && $self->cgi->param('m')) {
607 push @messages, map
608 +{
609 type => "text",
610 text => $self->_str_msg($_),
611 class => "unknown",
612 html => $self->_str_msg_html($_),
613 }, $self->cgi->param("m");
70789617
TC
614 }
615
7c74b5f6
TC
616 my %seen;
617 @messages = grep !$seen{$_->{html}}++, @messages; # don't need duplicates
618
619 $self->{messages} = \@messages;
620
621 return \@messages;
622}
623
95442846
TC
624=item message($errors)
625
626Return the current set of messages as a single string in HTML, with
627C<< <br /> >> separators.
628
629=cut
630
7c74b5f6
TC
631sub message {
632 my ($self, $errors) = @_;
633
634 my $messages = $self->messages($errors);
635
636 return join "<br />",
637 map { $_->{type} eq 'html' ? $_->{text} : escape_html($_->{text}) } @$messages
638}
639
59fca225
TC
640=item field_errors
641
642Return a hash of field errors that have been supplied to
643message()/messages().
644
645=cut
646
647sub field_errors {
648 my ($self) = @_;
649
650 return $self->{field_errors} || {};
651}
652
7c74b5f6
TC
653sub _set_vars {
654 my ($self) = @_;
655
656 require Scalar::Util;
657 $self->{vars}{request} = $self;
658 Scalar::Util::weaken($self->{vars}{request});
659 $self->set_variable(cgi => $self->cgi);
660 $self->set_variable(cfg => $self->cfg);
661 $self->set_variable(assert_dynamic => 1);
2814fdf7
TC
662 unless ($self->{vars}{bse}) {
663 require BSE::Variables;
664 $self->set_variable(bse => BSE::Variables->dyn_variables(request => $self));
665 }
70789617
TC
666}
667
95442846 668=item siteuser
70789617 669
95442846 670Get the currently logged in siteuser.
7c74b5f6 671
95442846 672=cut
70789617
TC
673
674# get the current site user if one is logged on
675sub siteuser {
676 my ($req) = @_;
677
678 ++$req->{siteuser_calls};
679 if (exists $req->{_siteuser}) {
680 ++$req->{siteuser_cached};
681 return $req->{_siteuser};
682 }
683
684 my $cfg = $req->cfg;
685 my $session = $req->session;
686 require SiteUsers;
687 if ($cfg->entryBool('custom', 'user_auth')) {
688 require BSE::CfgInfo;
689 my $custom = BSE::CfgInfo::custom_class($cfg);
690
691 return $custom->siteuser_auth($session, $req->cgi, $cfg);
692 }
693 else {
694 $req->{_siteuser} = undef;
695
696 my $userid = $session->{userid}
697 or return;
3f9c8a96 698 my $user = SiteUsers->getByPkey($userid)
70789617
TC
699 or return;
700 $user->{disabled}
701 and return;
702
703 $req->{_siteuser} = $user;
704
705 return $user;
706 }
707}
708
95442846
TC
709=item validate()
710
711Perform data validation on the current CGI request. Parameters include:
712
713=over
714
715=item *
716
717errors
718
719=item *
720
721fields
722
723=item *
724
725rules
726
727=item *
728
729section
730
731=item *
732
733optional
734
735=back
736
737=cut
738
70789617
TC
739sub validate {
740 my ($req, %options) = @_;
741
742 $options{rules} ||= {};
743
744 require BSE::Validate;
9b3a5df0
TC
745 my %opts =
746 (
747 fields => $options{fields},
748 rules => $options{rules},
749 );
750 exists $options{optional} and $opts{optional} = $options{optional};
751 BSE::Validate::bse_validate
752 (
753 $req->cgi,
754 $options{errors},
755 \%opts,
756 $req->cfg,
757 $options{section}
758 );
70789617
TC
759}
760
95442846
TC
761=item validate_hash(%opts)
762
763Validate data stored in a hash.
764
765Takes an extra parameter over L</validate()>:
766
767=over
768
769=item *
770
771data - a hash reference with the data to validate.
772
773=back
774
775=cut
776
70789617
TC
777sub validate_hash {
778 my ($req, %options) = @_;
779
780 $options{rules} ||= {};
781
9b3a5df0
TC
782 my %opts =
783 (
784 fields => $options{fields},
785 rules => $options{rules},
786 );
787 exists $options{optional} and $opts{optional} = $options{optional};
70789617 788 require BSE::Validate;
9b3a5df0
TC
789 BSE::Validate::bse_validate_hash
790 (
791 $options{data},
792 $options{errors},
793 \%opts,
794 $req->cfg,
795 $options{section}
796 );
70789617
TC
797}
798
95442846
TC
799=item configure_fields(\%fields, $section)
800
801Configure a field hash.
802
803=cut
804
70789617
TC
805sub configure_fields {
806 my ($self, $fields, $section) = @_;
807
808 my $cfg = $self->cfg;
809 require BSE::Validate;
810 my $cfg_fields = BSE::Validate::bse_configure_fields($fields, $cfg, $section);
811
812 for my $name (keys %$fields) {
813 for my $cfg_name (qw/htmltype type width height size maxlength/) {
814 my $value = $cfg->entry($section, "${name}_${cfg_name}");
815 defined $value and $cfg_fields->{$name}{$cfg_name} = $value;
816 }
817 }
818
819 $cfg_fields;
820}
821
81aa5f57
TC
822sub _article_parent {
823 my ($self, $article) = @_;
824
825 my $id = $article->parentid;
826 $id > 0
827 or return;
828
829 $self->{_cached_article} ||= {};
830 my $cache = $self->{_cached_article};
831
832 $cache->{$id}
833 or $cache->{$id} = $article->parent;
834
835 return $cache->{$id};
836}
837
838sub _article_group_ids {
839 my ($self, $article) = @_;
840
841 my $id = $article->id;
842 $self->{_cached_groupids} ||= {};
843 my $cache = $self->{_cached_groupids};
844 $cache->{$id}
845 or $cache->{$id} = [ $article->group_ids ];
846
847 return @{$cache->{$id}};
848}
849
70789617
TC
850sub _have_group_access {
851 my ($req, $user, $group_ids, $membership) = @_;
852
853 if (grep $_ > 0, @$group_ids) {
854 $membership->{filled}
855 or %$membership = map { $_ => 1 } 'filled', $user->group_ids;
856 return 1
857 if grep $membership->{$_}, @$group_ids;
858 }
859 for my $query_id (grep $_ < 0, @$group_ids) {
860 require BSE::TB::SiteUserGroups;
861 my $group = BSE::TB::SiteUserGroups->getQueryGroup($req->cfg, $query_id)
862 or next;
863 my $rows = BSE::DB->single->dbh->selectall_arrayref($group->{sql}, { MaxRows=>1 }, $user->{id});
864 $rows && @$rows
865 and return 1;
866 }
867
868 return 0;
869}
870
871sub _siteuser_has_access {
872 my ($req, $article, $user, $default, $membership) = @_;
873
874 defined $default or $default = 1;
875 defined $membership or $membership = {};
876
1b73ea7e
TC
877 unless ($article) {
878 # this shouldn't happen
879 cluck("_siteuser_has_access() called without an article parameter!");
880 return 0;
881 }
882
81aa5f57 883 my @group_ids = $req->_article_group_ids($article);
70789617
TC
884 if ($article->{inherit_siteuser_rights}
885 && $article->{parentid} != -1) {
886 if (@group_ids) {
887 $user ||= $req->siteuser
888 or return 0;
889 if ($req->_have_group_access($user, \@group_ids, $membership)) {
890 return 1;
891 }
892 else {
81aa5f57 893 return $req->siteuser_has_access($req->_article_parent($article), $user, 0);
70789617
TC
894 }
895 }
896 else {
897 # ask parent
81aa5f57 898 return $req->siteuser_has_access($req->_article_parent($article), $user, $default);
70789617
TC
899 }
900 }
901 else {
902 if (@group_ids) {
903 $user ||= $req->siteuser
904 or return 0;
905 if ($req->_have_group_access($user, \@group_ids, $membership)) {
906 return 1;
907 }
908 else {
909 return 0;
910 }
911 }
912 else {
913 return $default;
914 }
915 }
916}
917
95442846
TC
918=item siteuser_has_access($article)
919
920=item siteuser_has_access($article, $user)
921
922Check if the current or supplied site user has access to the supplied article.
923
924=cut
925
70789617
TC
926sub siteuser_has_access {
927 my ($req, $article, $user, $default, $membership) = @_;
928
929 $user ||= $req->siteuser;
930
931 ++$req->{has_access_total};
932 if ($req->{_siteuser} && $user && $user->{id} == $req->{_siteuser}{id}
933 && exists $req->{_access_cache}{$article->{id}}) {
934 ++$req->{has_access_cached};
935 return $req->{_access_cache}{$article->{id}};
936 }
937
938 my $result = $req->_siteuser_has_access($article, $user, $default, $membership);
939
940 if ($user && $req->{_siteuser} && $user->{id} == $req->{_siteuser}{id}) {
941 $req->{_access_cache}{$article->{id}} = $result;
942 }
943
944 return $result;
945}
946
70789617
TC
947sub DESTROY {
948 my ($self) = @_;
949
950 if ($self->{cache_stats}) {
951 print STDERR "Siteuser cache: $self->{siteuser_calls} Total, $self->{siteuser_cached} Cached\n"
952 if $self->{siteuser_calls};
953 print STDERR "Access cache: $self->{has_access_total} Total, $self->{has_access_cached} Cached\n"
954 if $self->{has_access_total};
955 }
956
957 if ($self->{session}) {
958 undef $self->{session};
959 }
960}
961
962sub set_article {
963 my ($self, $name, $article) = @_;
964
7c74b5f6 965 $self->set_variable($name, $article);
70789617
TC
966 if ($article) {
967 $self->{articles}{$name} = $article;
968 }
969 else {
970 delete $self->{articles}{$name};
971 }
972}
973
974sub get_article {
975 my ($self, $name) = @_;
976
977 exists $self->{articles}{$name}
978 or return;
979
980 my $article = $self->{articles}{$name};
981 if (ref $article eq 'SCALAR') {
982 $article = $$article;
983 }
984 $article
985 or return;
986
987 $article;
988}
989
7c74b5f6
TC
990sub set_variable {
991 my ($self, $name, $value) = @_;
992
993 $self->{vars}{$name} = $value;
994}
995
70789617
TC
996sub text {
997 my ($self, $id, $default) = @_;
998
56f87a80 999 return $self->cfg->entry('messages', $id, $default);
70789617
TC
1000}
1001
1002sub _convert_utf8_cgi_to_charset {
1003 my ($self) = @_;
1004
1005 require Encode;
1006 my $cgi = $self->cgi;
1007 my $workset = $self->cfg->entry('html', 'charset', 'iso-8859-1');
1008 my $decoded = $self->cfg->entry('html', 'cgi_decoded', 1);
1009
1010 # avoids param decoding the data
1011 $cgi->charset($workset);
1012
1013 print STDERR "Converting parameters from UTF8 to $workset\n"
1014 if $self->cfg->entry('debug', 'convert_charset');
1015
1016 if ($decoded) {
1017 # CGI.pm has already converted it from utf8 to perl's internal encoding
1018 # so we just need to encode to the working encoding
1019 # I don't see a reliable way to detect this without configuring it
1020 for my $name ($cgi->param) {
1021 my @values = map Encode::encode($workset, $_), $cgi->param($name);
1022
1023 $cgi->param($name => @values);
1024 }
1025 }
1026 else {
1027 for my $name ($cgi->param) {
1028 my @values = $cgi->param($name);
1029 Encode::from_to($_, $workset, 'utf8') for @values;
1030 $cgi->param($name => @values);
1031 }
1032 }
1033}
1034
1035sub _encode_utf8 {
1036 my ($self) = @_;
1037
1038 my $cgi = $self->cgi;
1039
1040 require Encode;
1041 for my $name ($cgi->param) {
1042 my @values = map Encode::encode('utf8', $_), $cgi->param($name);
1043 $cgi->param($name => @values);
1044 }
1045}
1046
f5505b76
TC
1047sub user_url {
1048 my ($req, $script, $target, @options) = @_;
1049
13a986ee 1050 return $req->cfg->user_url($script, $target, @options);
f5505b76
TC
1051}
1052
95442846 1053=item is_ssl
61138170 1054
95442846 1055Return true if the current request is an SSL request.
61138170 1056
95442846 1057=cut
6bc5006a 1058
95442846
TC
1059sub is_ssl {
1060 exists $ENV{HTTPS} || exists $ENV{SSL_CIPHER};
1061}
6bc5006a 1062
95442846
TC
1063my %recaptcha_errors =
1064 (
1065 'incorrect-captcha-sol' => 'Incorrect CAPTCHA solution',
1066 'recaptcha-not-reachable' => "CAPTCHA server not reachable, please wait a moment and try again",
1067 );
6bc5006a 1068
95442846 1069=item test_recaptcha
6bc5006a 1070
95442846 1071Test if a valid reCAPTCHA response was received.
61138170 1072
95442846 1073=cut
c6fc339f
TC
1074
1075sub test_recaptcha {
1076 my ($self, %opts) = @_;
1077
1078 require Captcha::reCAPTCHA;
1079 my $apiprivkey = $self->cfg->entry('recaptcha', 'api_private_key');
1080 unless (defined $apiprivkey) {
1081 print STDERR "** No recaptcha api_private_key defined **\n";
1082 return;
1083 }
1084 my $msg;
1085 my $error = $opts{error} || \$msg;
1086 my $c = Captcha::reCAPTCHA->new;
1087 my $cgi = $self->cgi;
1088 my $challenge = $cgi->param('recaptcha_challenge_field');
1089 my $response = $cgi->param('recaptcha_response_field');
1090 delete $self->{recaptcha_error};
1091 if (!defined $challenge || $challenge !~ /\S/) {
1092 $$error = "No reCAPTCHA challenge found";
1093 return;
1094 }
1095 if (!defined $response || $response !~ /\S/) {
1096 $$error = "No reCAPTCHA response entered";
1097 return;
1098 }
1099
1100 my $result = $c->check_answer($apiprivkey, $ENV{REMOTE_ADDR},
1101 $challenge, $response);
1102 unless ($result->{is_valid}) {
1103 my $key = 'error_'.$result->{error};
1104 $key =~ tr/-/_/;
1105 $$error = $self->cfg->entry('recaptcha', $key)
1106 || $recaptcha_errors{$result->{error}}
1107 || $result->{error};
1108 }
1109 $self->{recaptcha_result} = $result;
1110
1111 return !!$result->{is_valid};
1112}
1113
1114sub recaptcha_result {
1115 $_[0]{recaptcha_result};
1116}
1117
58baa27b
TC
1118=item get_csrf_token($name)
1119
1120Generate a csrf token for the given name.
1121
1122=cut
1123
1124my $sequence = 0;
1125
1126sub get_csrf_token {
1127 my ($req, $name) = @_;
1128
1129 my $cache = $req->session->{csrfp};
1130 my $max_age = $req->cfg->entry('basic', 'csrfp_max_age', 3600);
1131 my $now = time;
1132
1133 my $entry = $cache->{$name};
1134 if (!$entry || $entry->{time} + $max_age < $now) {
1135 if ($entry) {
1136 $entry->{oldtoken} = $entry->{token};
1137 $entry->{oldtime} = $entry->{time};
1138 }
1139 else {
1140 $entry = {};
1141 }
1142
1143 # this doesn't need to be so perfectly secure that we drain the
1144 # entropy pool and it'll be called fairly often
1145 require Digest::MD5;
1146 $entry->{token} =
1147 Digest::MD5::md5_hex($now . $$ . rand() . $sequence++ . $name);
1148 $entry->{time} = $now;
1149 }
1150 $cache->{$name} = $entry;
1151 $req->session->{csrfp} = $cache;
1152
1153 return $entry->{token};
1154}
1155
1156=item check_csrf($name)
1157
1158Check if the CSRF token supplied by the form is valid.
1159
1160$name should be the name supplied to the csrfp token.
1161
1162=cut
1163
1164sub check_csrf {
1165 my ($self, $name) = @_;
1166
1167 defined $name
1168 or confess "No CSRF token name supplied";
1169
8f42c1c2
TC
1170 $self->is_ajax
1171 and return 1;
1172
58baa27b
TC
1173 my $debug = $self->cfg->entry('debug', 'csrf', 0);
1174
1175 # the form might have multiple submit buttons, each initiating a
1176 # different function, so the the form should supply tokens for every
1177 # function for the form
1178 my @tokens = $self->cgi->param('_csrfp');
1179 unless (@tokens) {
1180 $self->_csrf_error("No _csrfp token supplied");
1181 return;
1182 }
1183
1184 my $entry = $self->session->{csrfp}{$name};
1185 unless ($entry) {
1186 $self->_csrf_error("No token entry found for $name");
1187 return;
1188 }
1189
1190 my $max_age = $self->cfg->entry('basic', 'csrfp_max_age', 3600);
1191 my $now = time;
1192 for my $token (@tokens) {
1193 if ($entry->{token}
1194 && $entry->{token} eq $token
1195 && $entry->{time} + 2*$max_age >= $now) {
1196 $debug
1197 and print STDERR "CSRF: match current token\n";
1198 return 1;
1199 }
1200
1201 if ($entry->{oldtoken}
1202 && $entry->{oldtoken} eq $token
1203 && $entry->{oldtime} + 2*$max_age >= $now) {
1204 return 1;
1205 }
1206 }
1207
1208 $self->_csrf_error("No tokens matched the $name entry");
1209 return;
1210}
1211
1212sub _csrf_error {
1213 my ($self, $message) = @_;
1214
1215 $self->cfg->entry('debug', 'csrf', 0)
1216 and print STDERR "csrf error: $message\n";
1217 $self->{csrf_error} = $message;
1218
1219 return;
1220}
1221
1222sub csrf_error {
1223 $_[0]{csrf_error};
1224}
1225
a0edb02e
TC
1226=item audit(object => $object, action => $action)
1227
1228Simple audit logging.
1229
c925a6af 1230See BSE::TB::AuditLog.
a0edb02e 1231
c925a6af 1232object, component, msg are required.
a0edb02e
TC
1233
1234=cut
1235
1236sub audit {
1237 my ($self, %opts) = @_;
1238
c925a6af 1239 require BSE::TB::AuditLog;
a0edb02e 1240
080fc207 1241 $opts{actor} ||= $self->user || "U";
a0edb02e 1242
c925a6af 1243 return BSE::TB::AuditLog->log(%opts);
a0edb02e
TC
1244}
1245
3f9c8a96
TC
1246sub utf8 {
1247 my $self = shift;
1248 return $self->cfg->utf8;
1249}
1250
1251sub charset {
1252 my $self = shift;
1253 return $self->cfg->charset;
1254}
1255
ebc63b18
TC
1256=item message_catalog
1257
1258Retrieve the message catalog.
1259
1260=cut
1261
1262sub message_catalog {
1263 my ($self) = @_;
1264
1265 unless ($self->{message_catalog}) {
1266 require BSE::Message;
1267 my %opts;
1268 $self->_cache_available and $opts{cache} = $self->_cache_object;
1269 $self->{message_catalog} = BSE::Message->new(%opts);
1270 }
1271
1272 return $self->{message_catalog};
1273}
1274
1275=item catmsg($id)
1276
1277=item catmsg($id, \@params)
1278
1279=item catmsg($id, \@params, $default)
1280
1281=item catmsg($id, \@params, $default, $lang)
1282
1283Retrieve a message from the message catalog, performing substitution.
1284
1285This retrieves the text version of the message only.
1286
1287=cut
1288
1289sub catmsg {
1290 my ($self, $id, $params, $default, $lang) = @_;
1291
1292 defined $lang or $lang = $self->language;
1293 defined $params or $params = [];
1294
1295 $id =~ s/^msg://
1296 or return "* bad message id - missing leading msg: *";
1297
1298 my $result = $self->message_catalog->text($lang, $id, $params, $default);
1299 unless ($result) {
1300 $result = "Unknown message id $id";
1301 }
1302
1303 return $result;
1304}
1305
7c74b5f6
TC
1306=item htmlmsg($id)
1307
1308=item htmlmsg($id, \@params)
1309
1310=item htmlmsg($id, \@params, $default)
1311
1312=item htmlmsg($id, \@params, $default, $lang)
1313
1314Retrieve a message from the message catalog, performing substitution.
1315
1316This retrieves the html version of the message only.
1317
1318=cut
1319
1320sub htmlmsg {
1321 my ($self, $id, $params, $default, $lang) = @_;
1322
1323 defined $lang or $lang = $self->language;
1324 defined $params or $params = [];
1325
1326 $id =~ s/^msg://
1327 or return "* bad message id - missing leading msg: *";
1328
1329 my $result = $self->message_catalog->html($lang, $id, $params, $default);
1330 unless ($result) {
1331 $result = "Unknown message id $id";
1332 }
1333
1334 return $result;
1335}
1336
ebc63b18
TC
1337=item language
1338
1339Fetch the language for the current system/user.
1340
1341Warning: this currently fetches a system configured default, in the
1342future it will use a user default and/or a browser set default.
1343
1344=cut
1345
1346sub language {
1347 my ($self) = @_;
1348
1349 return $self->cfg->entry("basic", "language_code", "en");
1350}
1351
b4b37b81
TC
1352=item ip_address
1353
1354The IP address of the broswer.
1355
1356=cut
1357
a74330a2
TC
1358sub ip_address {
1359 return $ENV{REMOTE_ADDR};
1360}
1361
b4b37b81
TC
1362=item method
1363
1364The request method (post, get etc) in lower case
1365
1366=cut
1367
1368sub method {
1369 return lc $ENV{REQUEST_METHOD};
1370}
1371
1372=item cart
1373
1374The user's shopping cart as a L<BSE::Cart> object.
1375
1376=cut
1377
240fb6b6
TC
1378sub cart {
1379 my ($self, $stage) = @_;
1380
1381 require BSE::Cart;
1382 $self->{cart} ||= BSE::Cart->new($self, $stage);
1383
1384 return $self->{cart};
1385}
1386
95442846
TC
1387=back
1388
1389=head2 Page Generation
1390
1391These aren't suitable for use in a template.
1392
1393=over
1394
1395=item template_sets()
1396
1397Return a list of template sets for the current admin user.
1398
1399=cut
1400
1401sub template_sets {
1402 my ($self) = @_;
1403
1404 return () unless $self->access_control;
1405
1406 my $user = $self->user
1407 or return;
1408
1409 return grep $_ ne '', map $_->{template_set}, $user->groups;
1410}
1411
1412=item get_refresh($url)
1413
1414Fetch a refresh result for the given url.
1415
1416=cut
1417
1418sub get_refresh {
1419 my ($req, $url) = @_;
1420
1421 require BSE::Template;
1422 BSE::Template->get_refresh($url, $req->cfg);
1423}
1424
1425=item output_result($result)
1426
1427Output a page result.
1428
1429=cut
1430
1431sub output_result {
1432 my ($req, $result) = @_;
1433
1434 require BSE::Template;
1435 BSE::Template->output_result($req, $result);
1436}
1437
1438=item dyn_response($template, $acts, $modifier)
1439
1440=item dyn_response($template, $acts)
1441
1442Generate a page result from template with the given tags.
1443
1444Allows _t or t to specify an alternate template.
1445
1446=cut
1447
1448sub dyn_response {
1449 my ($req, $template, $acts, $modifier) = @_;
1450
1451 my @search = $template;
1452 my $base_template = $template;
1453 my $t = $req->cgi->param('t');
1454 $t or $t = $req->cgi->param('_t');
1455 $t or $t = $modifier;
1456 if ($t && $t =~ /^\w+$/) {
1457 $template .= "_$t";
1458 unshift @search, $template;
1459 }
1460
1461 $req->set_variable(template => $template);
1462 $req->_set_vars();
1463
1464 require BSE::Template;
1465 my @sets;
1466 if ($template =~ m!^admin/!) {
1467 @sets = $req->template_sets;
1468 }
1469
1470 return BSE::Template->get_response($template, $req->cfg, $acts,
1471 $base_template, \@sets, $req->{vars});
1472}
1473
1474=item response($template, $acts)
1475
1476Return a page response generated from $template and the tags in $acts.
1477
1478=cut
1479
1480sub response {
1481 my ($req, $template, $acts) = @_;
1482
1483 require BSE::Template;
1484 my @sets;
1485 if ($template =~ m!^admin/!) {
1486 @sets = $req->template_sets;
1487 }
1488
1489 $req->set_variable(template => $template);
1490 $req->_set_vars();
1491
1492 return BSE::Template->get_response($template, $req->cfg, $acts,
1493 $template, \@sets, $req->{vars});
1494}
1495
1496=item dyn_user_tags()
1497
1498Return the standard dynamic page tags.
1499
1500=cut
1501
1502sub dyn_user_tags {
1503 my ($self) = @_;
1504
1505 require BSE::Util::DynamicTags;
1506 return BSE::Util::DynamicTags->new($self)->tags;
1507}
1508
1509=item admin_tags()
1510
1511Return the standard admin page tags.
1512
1513=cut
1514
1515sub admin_tags {
1516 my ($req) = @_;
1517
1518 require BSE::Util::Tags;
1519 return
1520 (
1521 BSE::Util::Tags->common($req),
1522 BSE::Util::Tags->admin(undef, $req->cfg),
1523 BSE::Util::Tags->secure($req),
1524 $req->custom_admin_tags,
1525 );
1526}
1527
1528sub custom_admin_tags {
1529 my ($req) = @_;
1530
1531 $req->cfg->entry("custom", "admin_tags")
1532 or return;
1533
1534 require BSE::CfgInfo;
1535
1536 return BSE::CfgInfo::custom_class($req->cfg)->admin_tags($req);
1537}
1538
1539=item is_ajax
1540
1541Return true if the current request is an Ajax request.
1542
1543Warning: changing this code has security concerns, it should only
1544match where the request can only be an Ajax request - if the request
1545can be produced by a normal form/link POST or GET this method must NOT
1546return true.
1547
1548=cut
1549
1550sub is_ajax {
1551 my ($self) = @_;
1552
1553 defined $ENV{HTTP_X_REQUESTED_WITH}
1554 && $ENV{HTTP_X_REQUESTED_WITH} =~ /XMLHttpRequest/
1555 and return 1;
1556
1557 return;
1558}
1559
1560=item want_json_response
1561
1562Return true if the caller has indicated they want a JSON response.
1563
1564In practice, returns true if is_ajax() is true or a _ parameter was
1565supplied.
1566
1567=cut
1568
1569sub want_json_response {
1570 my ($self) = @_;
1571
1572 $self->is_ajax and return 1;
1573
1574 $self->cgi->param("_") and return 1;
1575
1576 return;
1577}
1578
1579=item send_email
1580
1581Send a simple email.
1582
1583=cut
1584
1585sub send_email {
1586 my ($self, %opts) = @_;
1587
1588 my $acts = $opts{acts} || {};
1589 my %acts =
1590 (
1591 $self->dyn_user_tags,
1592 %$acts,
1593 );
1594 if ($opts{extraacts}) {
1595 %acts = ( %acts, %{$opts{extraacts}} );
1596 }
1597 require BSE::ComposeMail;
1598 return BSE::ComposeMail->send_simple
1599 (
1600 %opts,
1601 acts => \%acts
1602 );
1603}
1604
1605=item json_content
1606
1607Generate a hash suitable for output_result() as JSON.
1608
1609=cut
1610
1611sub json_content {
1612 my ($self, @values) = @_;
1613
1614 require JSON;
1615
1616 my $json = JSON->new;
1617
1618 if ($self->utf8) {
1619 $json->utf8;
1620 }
1621
1622 my $value = @values > 1 ? +{ @values } : $values[0];
1623 my ($context) = $self->cgi->param("_context");
1624 if (defined $context) {
1625 $value->{context} = $context;
1626 }
1627
1628 my $json_result =
1629 +{
1630 type => "application/json",
1631 content => $json->encode($value),
1632 };
1633
1634 if (!exists $ENV{HTTP_X_REQUESTED_WITH}
1635 || $ENV{HTTP_X_REQUESTED_WITH} !~ /XMLHttpRequest/) {
1636 $json_result->{type} = "text/plain";
1637 }
1638
1639 return $json_result;
1640}
1641
1642sub field_error {
1643 my ($self, $errors) = @_;
1644
1645 my %errors = %$errors;
1646 for my $key (keys %errors) {
1647 if ($errors{$key} =~ /^msg:/) {
1648 $errors{$key} = $self->_str_msg($errors{$key});
1649 }
1650 }
1651
1652 return $self->json_content
1653 (
1654 success => 0,
1655 error_code => "FIELD",
1656 errors => \%errors,
1657 message => "Fields failed validation",
1658 );
1659}
1660
1661=item logon_error
1662
1663Standard structure of an "admin user not logged on" error returned as
1664JSON content.
1665
1666=cut
1667
1668sub logon_error {
1669 my ($self) = @_;
1670 return $self->json_content
1671 (
1672 success => 0,
1673 error_code => "LOGON",
1674 message => "Access forbidden: user not logged on",
1675 errors => {},
1676 );
1677}
1678
70789617 16791;
95442846
TC
1680
1681=back
1682
1683=head1 AUTHOR
1684
1685Tony Cook <tony@develop-help.com>
1686
1687=cut