Gruta/CGI.pm

   1 package Gruta::CGI;
   2
   3 use CGI;
   4 use Carp;
   5
   6 sub vars {
   7         return $_[0]->{cgi}->Vars();
   8 }
   9
  10 sub upload_dirs {
  11         return @{ $_[0]->{upload_dirs} };
  12 }
  13
  14 sub http_headers {
  15         my $self        = shift;
  16         my %headers     = @_;
  17
  18         foreach my $k (keys(%headers)) {
  19                 $self->{http_headers}->{$k} = $headers{$k};
  20         }
  21
  22         return $self->{http_headers};
  23 }
  24
  25 sub cookie {
  26         my $self        = shift;
  27
  28         if (@_) {
  29         my $cookie = shift;
  30
  31                 $self->http_headers('Set-Cookie', $cookie . '; HttpOnly');
  32         }
  33
  34         return $ENV{HTTP_COOKIE};
  35 }
  36
  37 sub status {
  38     $_[0]->http_headers( 'Status', $_[1] );
  39 }
  40
  41 sub redirect {
  42     my $self    = shift;
  43     my $t       = shift;
  44     my $status  = shift || 301;
  45
  46     $self->status($status);
  47     $self->http_headers('Location', $self->data->url($t));
  48
  49     return $self;
  50 }
  51
  52 sub filter_comment {
  53         my $self        = shift;
  54         my $content     = shift;
  55
  56         # do some filtering
  57     $content =~ s/([<>"'&])/sprintf("&#%d;",ord($1))/ge;
  58         $content =~ s/\n{2,}/<p>/g;
  59
  60         return $content;
  61 }
  62
  63 sub validate_comment {
  64     my $self    = shift;
  65     my $comment = shift; # Gruta::Data::Comment
  66
  67     # too short or too long? fail
  68     my $c = $comment->get('content');
  69
  70 #   length($c) > 8 or croak("Comment content too short");
  71     length($c) < 16384 or croak("Comment content too long");
  72
  73     my @l = split('http:', $c);
  74     scalar(@l) < 8 or croak("Too much URLs in comment");
  75
  76     # filter spam
  77     if ($c =~ /\[(url|link)=/) {
  78         croak("Invalid content");
  79     }
  80
  81     # special spam validators
  82
  83     # blogspam.net
  84     my $use_blogspam_net = $self->data->source->template('cfg_use_blogspam_net');
  85
  86     if ($use_blogspam_net && $use_blogspam_net->get('content')) {
  87         eval("use RPC::XML::Client;");
  88
  89         if (!$@) {
  90             my $blogspam = RPC::XML::Client->new(
  91                 'http://test.blogspam.net:8888/');
  92
  93             if ($blogspam) {
  94                 my $res = $blogspam->send_request('testComment', {
  95                     ip      => $ENV{REMOTE_ADDR},
  96                     comment => $comment->get('content'),
  97                     agent   => $ENV{HTTP_USER_AGENT},
  98                     name    => $comment->get('author')
  99                     }
 100                 );
 101
 102                 if (ref($res)) {
 103                     my $r = $res->value();
 104
 105 #                   print STDERR "blogspam.net " . $r . "\n";
 106
 107                     if ($r =~ /^SPAM:/) {
 108                         croak("Comment rejected as " . $r . ' (blogspam.net)');
 109                     }
 110                 }
 111             }
 112         }
 113         }
 114
 115     # Akismet
 116     eval("use Net::Akismet;");
 117
 118     if (!$@) {
 119         # validate with Akismet
 120
 121         # pick API key and hostname templates
 122         my $api_key_t   = $self->data->source->template('cfg_akismet_api_key');
 123         my $url_t       = $self->data->source->template('cfg_akismet_url');
 124
 125         if ($api_key_t && $url_t) {
 126             my $api_key = $api_key_t->get('content');
 127             my $url     = $url_t->get('content');
 128
 129             if ($api_key && $url) {
 130                 my $akismet = Net::Akismet->new(
 131                     KEY => $api_key,
 132                     URL => $url
 133                 );
 134
 135                 if ($akismet) {
 136                     my $ret = $akismet->check(
 137                         USER_IP             => $ENV{REMOTE_ADDR},
 138                         COMMENT_USER_AGENT  => $ENV{HTTP_USER_AGENT},
 139                         COMMENT_CONTENT     => $comment->get('content'),
 140                         COMMENT_AUTHOR      => $comment->get('author'),
 141                         REFERRER            => $ENV{HTTP_REFERER}
 142                     );
 143
 144 #                   print STDERR "Akismet said: ", $ret, "\n";
 145
 146                     if ($ret && $ret eq 'true') {
 147                         croak('Comment rejected as SPAM (Akismet)');
 148                     }
 149                 }
 150             }
 151         }
 152     }
 153
 154     return $self;
 155 }
 156
 157 sub data {
 158         my $self        = shift;
 159         my $data        = shift;
 160
 161         if (defined($data)) {
 162                 $self->{data} = $data;
 163         }
 164
 165         return $self->{data};
 166 }
 167
 168
 169 sub upload {
 170         my $self        = shift;
 171         my $dir         = shift;
 172         my $field       = shift;
 173
 174         my $file = $self->{cgi}->param($field);
 175         my ($basename) = ($file =~ /([^\/\\]+)$/);
 176
 177         if (! grep(/^$dir$/, $self->upload_dirs())) {
 178                 croak "Unauthorized upload directory $dir";
 179         }
 180
 181         # create the directory
 182         mkdir $dir;
 183
 184         my $filename = $dir . '/' . $basename;
 185
 186         open F, '>' . $filename or croak "Can't write $filename";
 187         while(<$file>) {
 188                 print F $_;
 189         }
 190
 191         close F;
 192 }
 193
 194
 195 sub search_image {
 196     my $self    = shift;
 197     my $str     = shift;
 198     my $dir;
 199     my @ret = ();
 200
 201     # find first the 'img' directory
 202     foreach my $d ($self->upload_dirs()) {
 203         if ($d =~ /\/img$/) {
 204             $dir = $d;
 205         }
 206     }
 207
 208     if ($dir) {
 209         @ret = map { /\/([^\/]+)$/; $_ = $1; }
 210                     glob($dir . '/*' . $str . '*');
 211     }
 212
 213     return @ret;
 214 }
 215
 216
 217 sub new {
 218         my $class       = shift;
 219
 220         my $obj = bless( { @_ }, $class );
 221
 222     $obj->{charset}                 ||= 'UTF-8';
 223     $obj->{min_size_for_gzip}       ||= 10000;
 224     $obj->{query_timeout}           ||= 20;
 225     $obj->{cache_control_max_age}   ||= 300;
 226
 227     $obj->{http_headers} = {
 228         'Content-Type'          => 'text/html; charset=' . $obj->{charset},
 229     };
 230
 231         $obj->{upload_dirs} ||= [];
 232
 233         $obj->{cgi} = CGI->new();
 234
 235         return $obj;
 236 }
 237
 238
 239 sub run {
 240         my $self        = shift;
 241
 242         my $data = $self->data();
 243         my $vars = $self->vars();
 244
 245         $data->template->cgi_vars($vars);
 246
 247         if ($ENV{REMOTE_USER} and my $u = $data->source->user($ENV{REMOTE_USER})) {
 248                 $data->auth( $u );
 249         }
 250         elsif (my $cookie = $self->cookie()) {
 251                 if (my ($sid) = ($cookie =~ /sid\s*=\s*(\d+)/)) {
 252                         $data->auth_from_sid( $sid );
 253                 }
 254         }
 255
 256         my $st = 'INDEX';
 257
 258         if ($vars->{t}) {
 259                 $st = uc($vars->{t});
 260         }
 261
 262         $st = 'INDEX' unless $st =~ /^[-\w0-9_]+$/;
 263
 264         # not identified nor users found?
 265         if (!$data->auth() && ! $data->source->users()) {
 266
 267                 # create the admin user
 268                 my $u = Gruta::Data::User->new(
 269                         id              => 'admin',
 270                         is_admin        => 1,
 271                         can_upload      => 1,
 272                         username        => 'Admin',
 273                         email           => 'webmaster@localhost'
 274                 );
 275
 276                 # set a random password (to be promptly changed)
 277                 $u->password(rand());
 278
 279                 # insert the user
 280                 $data->source->insert_user($u);
 281
 282                 # create a new session
 283                 my $session = Gruta::Data::Session->new(user_id => 'admin');
 284                 $u->source->insert_session($session);
 285
 286                 $self->cookie('sid=' . $session->get('id'));
 287
 288                 $data->auth($u);
 289                 $data->session($session);
 290
 291                 $st = 'ADMIN';
 292         }
 293
 294         my $body = undef;
 295
 296         eval {
 297                 # install a timeout handler
 298                 $SIG{ALRM} = sub { die "Timeout processing query"; };
 299                 alarm $self->{query_timeout};
 300
 301                 $body = $data->template->process( $st )
 302         };
 303
 304         alarm 0;
 305
 306         if ($@) {
 307                 $data->log($@);
 308 #               $self->redirect('INDEX');
 309
 310                 $self->status(500);
 311                 $body = "<h1>500 Internal Server Error</h1><pre>$@</pre>";
 312
 313                 # main processing failed
 314                 $self->{error} = 1;
 315         }
 316
 317         $self->http_headers('X-Powered-By'      => 'Gruta ' . $self->data->version());
 318
 319         if (!$data->auth()) {
 320                 use Digest::MD5;
 321                 use Encode qw(encode_utf8);
 322
 323                 my $md5 = Digest::MD5->new();
 324                 $md5->add(encode_utf8($body));
 325                 my $etag = '"' . $md5->hexdigest() . '"';
 326
 327                 my $inm = $ENV{HTTP_IF_NONE_MATCH} || '';
 328
 329                 if ($inm eq $etag) {
 330                         $self->status(304);
 331                         $body = '';
 332                 }
 333         else {
 334             $self->http_headers(
 335                 'ETag'          => $etag,
 336                 'Cache-Control' => 'max-age=' . $self->{cache_control_max_age}
 337             );
 338         }
 339         }
 340
 341         # does the client accept compression?
 342         if (length($body) > $self->{min_size_for_gzip} &&
 343                 $ENV{HTTP_ACCEPT_ENCODING} =~ /gzip/) {
 344                 # compress!!
 345                 use Compress::Zlib;
 346
 347                 if (my $cbody = Compress::Zlib::memGzip($body)) {
 348                         $self->http_headers('Content-encoding' => 'gzip');
 349                         $body = $cbody;
 350                 }
 351         }
 352
 353         my $h = $self->http_headers();
 354         foreach my $k (keys(%{ $h })) {
 355                 print $k, ': ', $h->{$k}, "\n";
 356         }
 357         print "\n";
 358
 359         print $body;
 360 }
 361
 362 1;