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