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