iterator filters - also fixed up lots of tests
[bse.git] / site / cgi-bin / modules / BSE / Request / Base.pm
CommitLineData
70789617
TC
1package BSE::Request::Base;
2use strict;
3use CGI ();
4use BSE::Cfg;
5use DevHelp::HTML;
6
7sub new {
8 my ($class, %opts) = @_;
9
10 $opts{cfg} ||= BSE::Cfg->new;
11 $opts{cgi} ||= $class->_make_cgi;
12
13 my $self = bless \%opts, $class;
14 if ($self->cfg->entry('html', 'utf8decodeall')) {
15 $self->_encode_utf8();
16 }
17 elsif ($self->cfg->entry('html', 'ajaxcharset', 0)
18 && (() = $self->cgi->param('_'))) {
19 # convert the values of each parameter from UTF8 to iso-8859-1
20 $self->_convert_utf8_cgi_to_charset();
21 }
22
23 $self;
24}
25
26sub _make_cgi {
27 CGI->new;
28}
29
30sub cgi {
31 return $_[0]{cgi};
32}
33
34sub cfg {
35 return $_[0]{cfg};
36}
37
38sub session {
39 $_[0]{session} or die "Session has been deleted already\n";
40
41 return $_[0]{session};
42}
43
44sub end_request {
45 delete $_[0]{session};
46}
47
48sub extra_headers { return }
49
50sub user {
51 return $_[0]{adminuser};
52}
53
54sub setuser {
55 $_[0]{adminuser} = $_[1];
56}
57
58sub getuser {
59 $_[0]{adminuser};
60}
61
62# this needs to become non-admin specific
63sub url {
64 my ($self, $action, $params, $name) = @_;
65
66 require BSE::CfgInfo;
67 my $url = BSE::CfgInfo::admin_base_url($self->{cfg});
68 $url .= "/cgi-bin/admin/$action.pl";
69 if ($params && keys %$params) {
70 $url .= "?" . join("&", map { "$_=".escape_uri($params->{$_}) } keys %$params);
71 }
72 $url .= "#$name" if $name;
73
74 $url;
75}
76
77sub check_admin_logon {
78 my ($self) = @_;
79
80 require BSE::Permissions;
81 return BSE::Permissions->check_logon($self);
82}
83
84sub template_sets {
85 my ($self) = @_;
86
87 return () unless $self->access_control;
88
89 my $user = $self->user
90 or return;
91
92 return grep $_ ne '', map $_->{template_set}, $user->groups;
93}
94
95my $site_article =
96 {
97 id => -1,
98 title => "unknown",
99 parentid => 0,
100 generator => 'Generate::Article',
101 level => 0,
102 };
103
104sub user_can {
105 my ($self, $perm, $object, $rmsg) = @_;
106
107 require BSE::Permissions;
108 $object ||= $site_article;
109 $self->{perms} ||= BSE::Permissions->new($self->cfg);
110 if ($self->cfg->entry('basic', 'access_control', 0)) {
111 unless (ref $object) {
112 require Articles;
113 my $art = $object == -1 ? $site_article : Articles->getByPkey($object);
114 if ($art) {
115 $object = $art;
116 }
117 else {
118 print STDERR "** Cannot find article id $object\n";
119 require Carp;
120 Carp::cluck "Cannot find article id $object";
121 return 0;
122 }
123 }
124 return $self->{perms}->user_has_perm($self->user, $object, $perm, $rmsg);
125 }
126 else {
127 # some checks need to happen even if we don't want logons
128 return $self->{perms}->user_has_perm({ id=>-1 }, $object, $perm, $rmsg);
129 }
130}
131
132# a stub for now
133sub get_object {
134 return;
135}
136
137sub access_control {
138 $_[0]->{cfg}->entry('basic', 'access_control', 0);
139}
140
141sub output_result {
142 my ($req, $result) = @_;
143
144 require BSE::Template;
145 BSE::Template->output_result($req, $result);
146}
147
148sub message {
149 my ($req, $errors) = @_;
150
151 my $msg = '';
152 if ($errors and keys %$errors) {
153 my @fields = $req->cgi->param;
154 my %work = %$errors;
155 my @lines;
156 for my $field (@fields) {
157 if (my $entry = delete $work{$field}) {
158 push @lines, ref($entry) ? grep $_, @$entry : $entry;
159 }
160 }
161 for my $entry (values %work) {
162 if (ref $entry) {
163 push @lines, grep $_, @$entry;
164 }
165 else {
166 push @lines, $entry;
167 }
168 }
169 my %seen;
170 @lines = grep !$seen{$_}++, @lines; # don't need duplicates
171 $msg = join "<br />", map escape_html($_), @lines;
172 }
173 if (!$msg && $req->cgi->param('m')) {
174 $msg = join(' ', $req->cgi->param('m'));
175 $msg = escape_html($msg);
176 }
177
178 return $msg;
179}
180
181sub dyn_response {
182 my ($req, $template, $acts) = @_;
183
184 my @search = $template;
185 my $base_template = $template;
186 my $t = $req->cgi->param('t');
187 $t or $t = $req->cgi->param('_t');
188 if ($t && $t =~ /^\w+$/) {
189 $template .= "_$t";
190 unshift @search, $template;
191 }
192
193 require BSE::Template;
194 my @sets;
195 if ($template =~ m!^admin/!) {
196 @sets = $req->template_sets;
197 }
198
199 return BSE::Template->get_response($template, $req->cfg, $acts,
200 $base_template, \@sets);
201}
202
203sub response {
204 my ($req, $template, $acts) = @_;
205
206 require BSE::Template;
207 my @sets;
208 if ($template =~ m!^admin/!) {
209 @sets = $req->template_sets;
210 }
211
212 return BSE::Template->get_response($template, $req->cfg, $acts,
213 $template, \@sets);
214}
215
216# get the current site user if one is logged on
217sub siteuser {
218 my ($req) = @_;
219
220 ++$req->{siteuser_calls};
221 if (exists $req->{_siteuser}) {
222 ++$req->{siteuser_cached};
223 return $req->{_siteuser};
224 }
225
226 my $cfg = $req->cfg;
227 my $session = $req->session;
228 require SiteUsers;
229 if ($cfg->entryBool('custom', 'user_auth')) {
230 require BSE::CfgInfo;
231 my $custom = BSE::CfgInfo::custom_class($cfg);
232
233 return $custom->siteuser_auth($session, $req->cgi, $cfg);
234 }
235 else {
236 $req->{_siteuser} = undef;
237
238 my $userid = $session->{userid}
239 or return;
240 my $user = SiteUsers->getBy(userId=>$userid)
241 or return;
242 $user->{disabled}
243 and return;
244
245 $req->{_siteuser} = $user;
246
247 return $user;
248 }
249}
250
251sub validate {
252 my ($req, %options) = @_;
253
254 $options{rules} ||= {};
255
256 require BSE::Validate;
257 BSE::Validate::bse_validate($req->cgi, $options{errors},
258 {
259 fields => $options{fields},
260 rules => $options{rules},
261 },
262 $req->cfg, $options{section});
263}
264
265sub validate_hash {
266 my ($req, %options) = @_;
267
268 $options{rules} ||= {};
269
270 require BSE::Validate;
271 BSE::Validate::bse_validate_hash($options{data}, $options{errors},
272 {
273 fields=>$options{fields},
274 rules => $options{rules},
275 },
276 $req->cfg, $options{section});
277}
278
279sub configure_fields {
280 my ($self, $fields, $section) = @_;
281
282 my $cfg = $self->cfg;
283 require BSE::Validate;
284 my $cfg_fields = BSE::Validate::bse_configure_fields($fields, $cfg, $section);
285
286 for my $name (keys %$fields) {
287 for my $cfg_name (qw/htmltype type width height size maxlength/) {
288 my $value = $cfg->entry($section, "${name}_${cfg_name}");
289 defined $value and $cfg_fields->{$name}{$cfg_name} = $value;
290 }
291 }
292
293 $cfg_fields;
294}
295
296sub _have_group_access {
297 my ($req, $user, $group_ids, $membership) = @_;
298
299 if (grep $_ > 0, @$group_ids) {
300 $membership->{filled}
301 or %$membership = map { $_ => 1 } 'filled', $user->group_ids;
302 return 1
303 if grep $membership->{$_}, @$group_ids;
304 }
305 for my $query_id (grep $_ < 0, @$group_ids) {
306 require BSE::TB::SiteUserGroups;
307 my $group = BSE::TB::SiteUserGroups->getQueryGroup($req->cfg, $query_id)
308 or next;
309 my $rows = BSE::DB->single->dbh->selectall_arrayref($group->{sql}, { MaxRows=>1 }, $user->{id});
310 $rows && @$rows
311 and return 1;
312 }
313
314 return 0;
315}
316
317sub _siteuser_has_access {
318 my ($req, $article, $user, $default, $membership) = @_;
319
320 defined $default or $default = 1;
321 defined $membership or $membership = {};
322
323 my @group_ids = $article->group_ids;
324 if ($article->{inherit_siteuser_rights}
325 && $article->{parentid} != -1) {
326 if (@group_ids) {
327 $user ||= $req->siteuser
328 or return 0;
329 if ($req->_have_group_access($user, \@group_ids, $membership)) {
330 return 1;
331 }
332 else {
333 return $req->siteuser_has_access($article->parent, $user, 0);
334 }
335 }
336 else {
337 # ask parent
338 return $req->siteuser_has_access($article->parent, $user, $default);
339 }
340 }
341 else {
342 if (@group_ids) {
343 $user ||= $req->siteuser
344 or return 0;
345 if ($req->_have_group_access($user, \@group_ids, $membership)) {
346 return 1;
347 }
348 else {
349 return 0;
350 }
351 }
352 else {
353 return $default;
354 }
355 }
356}
357
358sub siteuser_has_access {
359 my ($req, $article, $user, $default, $membership) = @_;
360
361 $user ||= $req->siteuser;
362
363 ++$req->{has_access_total};
364 if ($req->{_siteuser} && $user && $user->{id} == $req->{_siteuser}{id}
365 && exists $req->{_access_cache}{$article->{id}}) {
366 ++$req->{has_access_cached};
367 return $req->{_access_cache}{$article->{id}};
368 }
369
370 my $result = $req->_siteuser_has_access($article, $user, $default, $membership);
371
372 if ($user && $req->{_siteuser} && $user->{id} == $req->{_siteuser}{id}) {
373 $req->{_access_cache}{$article->{id}} = $result;
374 }
375
376 return $result;
377}
378
379sub dyn_user_tags {
380 my ($self) = @_;
381
382 require BSE::Util::DynamicTags;
383 return BSE::Util::DynamicTags->new($self)->tags;
384}
385
386sub DESTROY {
387 my ($self) = @_;
388
389 if ($self->{cache_stats}) {
390 print STDERR "Siteuser cache: $self->{siteuser_calls} Total, $self->{siteuser_cached} Cached\n"
391 if $self->{siteuser_calls};
392 print STDERR "Access cache: $self->{has_access_total} Total, $self->{has_access_cached} Cached\n"
393 if $self->{has_access_total};
394 }
395
396 if ($self->{session}) {
397 undef $self->{session};
398 }
399}
400
401sub set_article {
402 my ($self, $name, $article) = @_;
403
404 if ($article) {
405 $self->{articles}{$name} = $article;
406 }
407 else {
408 delete $self->{articles}{$name};
409 }
410}
411
412sub get_article {
413 my ($self, $name) = @_;
414
415 exists $self->{articles}{$name}
416 or return;
417
418 my $article = $self->{articles}{$name};
419 if (ref $article eq 'SCALAR') {
420 $article = $$article;
421 }
422 $article
423 or return;
424
425 $article;
426}
427
428sub text {
429 my ($self, $id, $default) = @_;
430
431 $default;
432}
433
434sub _convert_utf8_cgi_to_charset {
435 my ($self) = @_;
436
437 require Encode;
438 my $cgi = $self->cgi;
439 my $workset = $self->cfg->entry('html', 'charset', 'iso-8859-1');
440 my $decoded = $self->cfg->entry('html', 'cgi_decoded', 1);
441
442 # avoids param decoding the data
443 $cgi->charset($workset);
444
445 print STDERR "Converting parameters from UTF8 to $workset\n"
446 if $self->cfg->entry('debug', 'convert_charset');
447
448 if ($decoded) {
449 # CGI.pm has already converted it from utf8 to perl's internal encoding
450 # so we just need to encode to the working encoding
451 # I don't see a reliable way to detect this without configuring it
452 for my $name ($cgi->param) {
453 my @values = map Encode::encode($workset, $_), $cgi->param($name);
454
455 $cgi->param($name => @values);
456 }
457 }
458 else {
459 for my $name ($cgi->param) {
460 my @values = $cgi->param($name);
461 Encode::from_to($_, $workset, 'utf8') for @values;
462 $cgi->param($name => @values);
463 }
464 }
465}
466
467sub _encode_utf8 {
468 my ($self) = @_;
469
470 my $cgi = $self->cgi;
471
472 require Encode;
473 for my $name ($cgi->param) {
474 my @values = map Encode::encode('utf8', $_), $cgi->param($name);
475 $cgi->param($name => @values);
476 }
477}
478
4791;