allow metadata to be defined for new products
[bse.git] / site / cgi-bin / modules / BSE / Request / Base.pm
1 package BSE::Request::Base;
2 use strict;
3 use CGI ();
4 use BSE::Cfg;
5 use BSE::Util::HTML;
6 use Carp qw(cluck confess);
7
8 our $VERSION = "1.032";
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
58
59 sub new {
60   my ($class, %opts) = @_;
61
62   $opts{cfg} ||= BSE::Cfg->new;
63
64   unless ($opts{nodatabase}) {
65     require BSE::DB;
66     BSE::DB->init($opts{cfg});
67     BSE::DB->startup();
68     require Squirrel::Table;
69     Squirrel::Table->caching(0);
70   }
71
72   my $self = bless \%opts, $class;
73
74   $opts{cgi} ||= $self->_make_cgi;
75   $opts{fastcgi} ||= 0;
76   $opts{vars} = {};
77
78   return $self;
79 }
80
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
112   require BSE::Cache;
113
114   $self->{_cache} = BSE::Cache->load($self->cfg);
115
116   return $self->{_cache};
117 }
118
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
133 sub cache_set {
134   my ($self, $key, $value) = @_;
135
136   my $cache = $self->_cache_object
137     or return;
138
139   $cache->set($key, $value);
140 }
141
142 =item cache_get($key)
143
144 Retrieve the cache entry identified by $key.
145
146 =cut
147
148 sub cache_get {
149   my ($self, $key) = @_;
150
151   my $cache = $self->_cache_object
152     or return;
153
154   return $cache->get($key);
155 }
156
157 sub _make_cgi {
158   my ($self) = @_;
159
160   my $cache;
161   if ($self->_tracking_uploads
162       && $ENV{REQUEST_METHOD} eq 'POST'
163       && $ENV{CONTENT_TYPE}
164       && $ENV{CONTENT_TYPE} =~ m(^multipart/form-data)
165       && $ENV{CONTENT_LENGTH}
166       && $ENV{QUERY_STRING}
167       && $ENV{QUERY_STRING} =~ /^_upload=([a-zA-Z0-9_]+)$/
168       && defined ($cache = $self->_cache_object)) {
169     # very hacky
170     my $upload_key = $1;
171     my $fullkey = "upload-$upload_key";
172     my $q;
173     my $done = 0;
174     my $last_set = time();
175     my $complete = 0;
176     eval {
177       $q = CGI->new
178         (
179          sub {
180            my ($filename, $data, $size_so_far) = @_;
181
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
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);
223     }
224
225     return $q;
226   }
227
228   my $q = CGI->new;
229   my $error = $q->cgi_error;
230   if ($error) {
231     print STDERR "CGI ERROR: $error\n";
232   }
233
234   if ($self->utf8) {
235     require BSE::CGI;
236     return BSE::CGI->new($q, $self->charset);
237   }
238
239   return $q;
240 }
241
242 =item cgi
243
244 Return the request's CGI object.
245
246 =cut
247
248 sub cgi {
249   return $_[0]{cgi};
250 }
251
252 =item cfg
253
254 Return the request's cfg object.
255
256 =cut
257
258 sub cfg {
259   return $_[0]{cfg};
260 }
261
262 =item session
263
264 Return the request's session object.
265
266 =cut
267
268 sub session {
269   my $self = shift;
270
271   $self->{session}
272     or $self->_make_session;
273
274   return $self->{session};
275 }
276
277 =item is_fastcgi
278
279 return true for a fast CGI request.
280
281 =cut
282
283 sub is_fastcgi {
284   $_[0]{fastcgi};
285 }
286
287 =item end_request
288
289 End the current request.
290
291 Must only be called by BSE itself.
292
293 =cut
294
295 sub end_request {
296   delete $_[0]{session};
297 }
298
299 =item user
300
301 Return the currently logged in admin user.
302
303 Only valid in administrative templates.
304
305 =cut
306
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
319 =item url($action, $params, $name)
320
321 Equivalent to $req->cfg->admin_url($action, $params, $name)
322
323 =cut
324
325 sub url {
326   my ($self, $action, $params, $name) = @_;
327
328   return $self->cfg->admin_url($action, $params, $name);
329 }
330
331 =item check_admin_logon()
332
333 Used internally to check an admin user is logged on.
334
335 =cut
336
337 sub check_admin_logon {
338   my ($self) = @_;
339
340   require BSE::Permissions;
341   return BSE::Permissions->check_logon($self);
342 }
343
344 my $site_article = 
345   { 
346    id        => -1, 
347    title     => "unknown", 
348    parentid  => 0, 
349    generator => 'BSE::Generate::Article',
350    level     => 0,
351   };
352
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
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 BSE::TB::Articles;
370       my $art = $object == -1 ? $site_article : BSE::TB::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
394 =item access_control
395
396 Return true if access control is enabled.
397
398 =cut
399
400 sub access_control {
401   $_[0]->{cfg}->entry('basic', 'access_control', 0);
402 }
403
404 =item flash($msg, ...)
405
406 Flash a notice (backward compat).
407
408 =cut
409
410 sub flash {
411   my ($self, @msg) = @_;
412
413   return $self->flash_notice(@msg);
414 }
415
416 =item flash_error($msg, ...)
417
418 Flash an error message.
419
420 =cut
421
422 sub flash_error {
423   my ($self, @msg) = @_;
424
425   return $self->flashext({ class => "error" }, @msg);
426 }
427
428 =item flash_notice($msg, ...)
429
430 Flash a notice.
431
432 =cut
433
434 sub flash_notice {
435   my ($self, @msg) = @_;
436
437   return $self->flashext({ class => "notice" }, @msg);
438 }
439
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
462 sub flashext {
463   my ($self, $opts, @msg) = @_;
464
465   my %entry =
466     (
467      class => $opts->{class} || "notice",
468      type => "text",
469     );
470   if ($msg[0] =~ /^msg:/) {
471     $entry{text} = $self->catmsg(@msg);
472     $entry{html} = $self->htmlmsg(@msg);
473   }
474   else {
475     $entry{text} = "@msg";
476     $entry{html} = escape_html($entry{text});
477   }
478
479   my @flash;
480   @flash = @{$self->session->{flash}} if $self->session->{flash};
481   push @flash, \%entry;
482
483   $self->session->{flash} = \@flash;
484 }
485
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
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   }
508   else {
509     $msg = escape_html($msg);
510   }
511
512   return $msg;
513 }
514
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
544 sub messages {
545   my ($self, $errors) = @_;
546
547   my @messages;
548   push @messages, @{$self->{messages}} if $self->{messages};
549   if ($errors and ref $errors && keys %$errors) {
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) {
555         $msg = $self->_str_msg($msg);
556       }
557       $errors->{$key} = ref $errors->{$key} ? \@msgs : $msgs[0];
558     }
559
560     my @fields = $self->cgi->param;
561     my %work = %$errors;
562     for my $field (@fields) {
563       if (my $entry = delete $work{$field}) {
564         push @messages,
565           map +{
566                 type => "text",
567                 text => $_,
568                 class => "error",
569                 html => escape_html($_),
570                }, ref($entry) ? grep $_, @$entry : $entry;
571       }
572     }
573     for my $entry (values %work) {
574       if (ref $entry) {
575         push @messages, map
576           +{
577             type => "text",
578             text => $_,
579             class => "error",
580             html => escape_html($_)
581            }, grep $_, @$entry;
582       }
583       else {
584         push @messages,
585           {
586            type => "text",
587            text => $entry,
588            class => "error",
589            html => escape_html($entry),
590           };
591       }
592     }
593     $self->{field_errors} = $errors;
594   }
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   }
604   if (!$self->{nosession} && $self->session->{flash}) {
605     push @messages, @{$self->session->{flash}};
606     delete $self->session->{flash};
607   }
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");
616   }
617
618   my %seen;
619   @messages = grep !$seen{$_->{html}}++, @messages; # don't need duplicates
620
621   $self->{messages} = \@messages;
622
623   return \@messages;
624 }
625
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
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
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
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);
664   unless ($self->{vars}{bse}) {
665     require BSE::Variables;
666     $self->set_variable(bse => BSE::Variables->dyn_variables(request => $self));
667   }
668 }
669
670 =item siteuser
671
672 Get the currently logged in siteuser.
673
674 =cut
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 BSE::TB::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;
700     my $user = BSE::TB::SiteUsers->getByPkey($userid)
701       or return;
702     $user->{disabled}
703       and return;
704
705     $req->{_siteuser} = $user;
706
707     return $user;
708   }
709 }
710
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
741 sub validate {
742   my ($req, %options) = @_;
743
744   $options{rules} ||= {};
745
746   require BSE::Validate;
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       );
761 }
762
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
779 sub validate_hash {
780   my ($req, %options) = @_;
781
782   $options{rules} ||= {};
783
784   my %opts =
785     (
786      fields => $options{fields},
787      rules => $options{rules},
788     );
789   exists $options{optional} and $opts{optional} = $options{optional};
790   require BSE::Validate;
791   BSE::Validate::bse_validate_hash
792       (
793        $options{data},
794        $options{errors},
795        \%opts,
796        $req->cfg,
797        $options{section}
798       );
799 }
800
801 =item configure_fields(\%fields, $section)
802
803 Configure a field hash.
804
805 =cut
806
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
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
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
879   unless ($article) {
880     # this shouldn't happen
881     cluck("_siteuser_has_access() called without an article parameter!");
882     return 0;
883   }
884
885   my @group_ids = $req->_article_group_ids($article);
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 {
895         return $req->siteuser_has_access($req->_article_parent($article), $user, 0);
896       }
897     }
898     else {
899       # ask parent
900       return $req->siteuser_has_access($req->_article_parent($article), $user, $default);
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
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
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
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
967   $self->set_variable($name, $article);
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
992 sub set_variable {
993   my ($self, $name, $value) = @_;
994
995   $self->{vars}{$name} = $value;
996 }
997
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
1005 sub text {
1006   my ($self, $id, $default) = @_;
1007
1008   return $self->cfg->entry('messages', $id, $default);
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
1056 sub user_url {
1057   my ($req, $script, $target, @options) = @_;
1058
1059   return $req->cfg->user_url($script, $target, @options);
1060 }
1061
1062 =item is_ssl
1063
1064 Return true if the current request is an SSL request.
1065
1066 =cut
1067
1068 sub is_ssl {
1069   exists $ENV{HTTPS} || exists $ENV{SSL_CIPHER};
1070 }
1071
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   );
1077
1078 =item test_recaptcha
1079
1080 Test if a valid reCAPTCHA response was received.
1081
1082 =cut
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
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
1179   $self->is_ajax
1180     and return 1;
1181
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
1235 =item audit(object => $object, action => $action)
1236
1237 Simple audit logging.
1238
1239 See BSE::TB::AuditLog.
1240
1241 object, component, msg are required.
1242
1243 =cut
1244
1245 sub audit {
1246   my ($self, %opts) = @_;
1247
1248   require BSE::TB::AuditLog;
1249
1250   $opts{actor} ||= $self->user || "U";
1251
1252   return BSE::TB::AuditLog->log(%opts);
1253 }
1254
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
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
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
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
1361 =item ip_address
1362
1363 The IP address of the broswer.
1364
1365 =cut
1366
1367 sub ip_address {
1368   return $ENV{REMOTE_ADDR};
1369 }
1370
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
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
1391 =item referer
1392
1393 The referer if any.
1394
1395 =cut
1396
1397 sub referer {
1398   return $ENV{HTTP_REFERER} || "";
1399 }
1400
1401 =item cart
1402
1403 The user's shopping cart as a L<BSE::Cart> object.
1404
1405 =cut
1406
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
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
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
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                                      dynamic => 1);
1518 }
1519
1520 =item response($template, $acts)
1521
1522 Return a page response generated from $template and the tags in $acts.
1523
1524 =cut
1525
1526 sub response {
1527   my ($req, $template, $acts) = @_;
1528
1529   require BSE::Template;
1530   my @sets;
1531   if ($template =~ m!^admin/!) {
1532     @sets = $req->template_sets;
1533   }
1534
1535   $req->set_variable(template => $template);
1536   $req->_set_vars();
1537
1538   return BSE::Template->get_response($template, $req->cfg, $acts, 
1539                                      $template, \@sets, $req->{vars},
1540                                      dynamic => 1);
1541 }
1542
1543 =item dyn_user_tags()
1544
1545 Return the standard dynamic page tags.
1546
1547 =cut
1548
1549 sub dyn_user_tags {
1550   my ($self) = @_;
1551
1552   require BSE::Util::DynamicTags;
1553   return BSE::Util::DynamicTags->new($self)->tags;
1554 }
1555
1556 =item admin_tags()
1557
1558 Return the standard admin page tags.
1559
1560 =cut
1561
1562 sub admin_tags {
1563   my ($req) = @_;
1564
1565   $req->set_variable
1566     (
1567      auditlog =>
1568      sub {
1569        require BSE::TB::AuditLog;
1570        Squirrel::Template::Expr::WrapClass->new("BSE::TB::AuditLog")
1571      });
1572
1573   require BSE::Util::Tags;
1574   return
1575     (
1576      BSE::Util::Tags->common($req),
1577      BSE::Util::Tags->admin(undef, $req->cfg),
1578      BSE::Util::Tags->secure($req),
1579      $req->custom_admin_tags,
1580     );
1581 }
1582
1583 sub custom_admin_tags {
1584   my ($req) = @_;
1585
1586   $req->cfg->entry("custom", "admin_tags")
1587     or return;
1588
1589   require BSE::CfgInfo;
1590
1591   return BSE::CfgInfo::custom_class($req->cfg)->admin_tags($req);
1592 }
1593
1594 =item is_ajax
1595
1596 Return true if the current request is an Ajax request.
1597
1598 Warning: changing this code has security concerns, it should only
1599 match where the request can only be an Ajax request - if the request
1600 can be produced by a normal form/link POST or GET this method must NOT
1601 return true.
1602
1603 =cut
1604
1605 sub is_ajax {
1606   my ($self) = @_;
1607
1608   defined $ENV{HTTP_X_REQUESTED_WITH}
1609     && $ENV{HTTP_X_REQUESTED_WITH} =~ /XMLHttpRequest/
1610       and return 1;
1611
1612   return;
1613 }
1614
1615 =item want_json_response
1616
1617 Return true if the caller has indicated they want a JSON response.
1618
1619 In practice, returns true if is_ajax() is true or a _ parameter was
1620 supplied.
1621
1622 =cut
1623
1624 sub want_json_response {
1625   my ($self) = @_;
1626
1627   $self->is_ajax and return 1;
1628
1629   $self->cgi->param("_") and return 1;
1630
1631   return;
1632 }
1633
1634 =item send_email
1635
1636 Send a simple email.
1637
1638 =cut
1639
1640 sub send_email {
1641   my ($self, %opts) = @_;
1642
1643   my $acts = $opts{acts} || {};
1644   my %acts =
1645     (
1646      $self->dyn_user_tags,
1647      %$acts,
1648     );
1649   if ($opts{extraacts}) {
1650     %acts = ( %acts, %{$opts{extraacts}} );
1651   }
1652   require BSE::ComposeMail;
1653   return BSE::ComposeMail->send_simple
1654     (
1655      %opts,
1656      acts => \%acts
1657     );
1658 }
1659
1660 =item json_content
1661
1662 Generate a hash suitable for output_result() as JSON.
1663
1664 =cut
1665
1666 sub json_content {
1667   my ($self, @values) = @_;
1668
1669   require JSON;
1670
1671   my $json = JSON->new;
1672
1673   if ($self->utf8) {
1674     $json->utf8;
1675   }
1676
1677   my $value = @values > 1 ? +{ @values } : $values[0];
1678   my ($context) = $self->cgi->param("_context");
1679   if (defined $context) {
1680     $value->{context} = $context;
1681   }
1682
1683   my $json_result =
1684     +{
1685       type => "application/json",
1686       content => $json->encode($value),
1687      };
1688
1689   if (!exists $ENV{HTTP_X_REQUESTED_WITH}
1690       || $ENV{HTTP_X_REQUESTED_WITH} !~ /XMLHttpRequest/) {
1691     $json_result->{type} = "text/plain";
1692   }
1693
1694   return $json_result;
1695 }
1696
1697 sub field_error {
1698   my ($self, $errors) = @_;
1699
1700   my %errors = %$errors;
1701   for my $key (keys %errors) {
1702     if ($errors{$key} =~ /^msg:/) {
1703       $errors{$key} = $self->_str_msg($errors{$key});
1704     }
1705   }
1706
1707   return $self->json_content
1708     (
1709      success => 0,
1710      error_code => "FIELD",
1711      errors => \%errors,
1712      message => "Fields failed validation",
1713     );
1714 }
1715
1716 =item logon_error
1717
1718 Standard structure of an "admin user not logged on" error returned as
1719 JSON content.
1720
1721 =cut
1722
1723 sub logon_error {
1724   my ($self) = @_;
1725   return $self->json_content
1726     (
1727      success => 0,
1728      error_code => "LOGON",
1729      message => "Access forbidden: user not logged on",
1730      errors => {},
1731     );
1732 }
1733
1734 =item cgi_fields
1735
1736 Extract values for the fields specified by the fields parameter.
1737
1738 Field information expected or supported:
1739
1740 =over
1741
1742 =item *
1743
1744 C<htmltype> - if this is checkbox, C<type> is consulted, if C<"int">
1745 then set the value based on whether the field is present, otherwise
1746 return a concatenation of the values of the checkboxes of that name.
1747
1748 =item *
1749
1750 C<type> - if C<date> then parse the content as a date.
1751
1752 =item *
1753
1754 C<api> - if true, don't convert dates from d/m/y to y-m-d, since they
1755 should already be that format.
1756
1757 =item *
1758
1759 C<trim> - for plain text fields, trim leading and trailing whitespace.
1760
1761 =item *
1762
1763 C<readonly> - no values are stored.
1764
1765 =back
1766
1767 =cut
1768
1769 sub cgi_fields {
1770   my ($self, %opts) = @_;
1771
1772   my %values;
1773   my $fields = $opts{fields}
1774     or confess "Missing fields parameter";
1775
1776   my $cgi = $self->cgi;
1777  FIELD:
1778   for my $name (keys %$fields) {
1779     my $field = $fields->{$name};
1780     $field->{readonly}
1781       and next FIELD;
1782     my $value;
1783     if ($field->{htmltype} eq "file") {
1784       my $fh = $cgi->upload($name);
1785       my $filename = $cgi->param($name);
1786       if ($fh) {
1787         $value = { fh => $fh, filename => "".$filename };
1788       }
1789     }
1790     elsif ($field->{htmltype} eq "checkbox") {
1791       if ($field->{type} eq "int") {
1792         $value = $cgi->param($name) ? 1 : 0;
1793       }
1794       else {
1795         $value = join("", $cgi->param($name));
1796       }
1797     }
1798     elsif ($field->{htmltype} eq "multicheck") {
1799       $value = [ $cgi->param($name) ];
1800     }
1801     elsif ($field->{type} && $field->{type} eq "date" && !$opts{api}) {
1802       ($value) = $cgi->param($name);
1803       require DevHelp::Date;
1804       my $msg;
1805       if (my ($year, $month, $day) = DevHelp::Date::dh_parse_date($value, \$msg)) {
1806         $value = sprintf("%04d-%02d-%02d", $year, $month, $day);
1807       }
1808     }
1809     elsif ($field->{type} && $field->{type} eq "time" && !$opts{api}) {
1810       ($value) = $cgi->param($name);
1811       require DevHelp::Date;
1812       my $msg;
1813       my ($hour, $minute, $sec) = DevHelp::Date::dh_parse_time($value, \$msg);
1814       $value = sprintf("%02d:%02d:%02d", $hour, $minute, $sec);
1815     }
1816     else {
1817       ($value) = $cgi->param($name);
1818       defined $name or $value = "";
1819       if ($field->{trim}) {
1820         $value =~ s/^\s+//;
1821         $value =~ s/\s+\z//;
1822       }
1823     }
1824     $values{$name} = $value;
1825   }
1826
1827   return \%values;
1828 }
1829
1830 =item ip_locked_out
1831
1832 Return true if there's an active IP address lockout of the current IP
1833 address.
1834
1835 =cut
1836
1837 sub ip_locked_out {
1838   my ($self, $type) = @_;
1839
1840   require BSE::TB::IPLockouts;
1841   return BSE::TB::IPLockouts->active($self->ip_address, $type);
1842 }
1843
1844 1;
1845
1846 =back
1847
1848 =head1 AUTHOR
1849
1850 Tony Cook <tony@develop-help.com>
1851
1852 =cut