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                 $self->http_headers( 'Set-Cookie', shift );
  30         }
  31
  32         return $ENV{HTTP_COOKIE};
  33 }
  34
  35 sub status {
  36         $_[0]->http_headers( 'Status', $_[1] );
  37 }
  38
  39 sub redirect {
  40         my $self        = shift;
  41
  42         $self->http_headers('Location', $self->data->url(@_));
  43
  44         return $self;
  45 }
  46
  47 sub data {
  48         my $self        = shift;
  49         my $data        = shift;
  50
  51         if (defined($data)) {
  52                 $self->{data} = $data;
  53         }
  54
  55         return $self->{data};
  56 }
  57
  58
  59 sub upload {
  60         my $self        = shift;
  61         my $dir         = shift;
  62         my $field       = shift;
  63
  64         my $file = $self->{cgi}->param($field);
  65         my ($basename) = ($file =~ /([^\/\\]+)$/);
  66
  67         if (! grep(/^$dir$/, $self->upload_dirs())) {
  68                 croak "Unauthorized upload directory $dir";
  69         }
  70
  71         # create the directory
  72         mkdir $dir;
  73
  74         my $filename = $dir . '/' . $basename;
  75
  76         open F, '>' . $filename or croak "Can't write $filename";
  77         while(<$file>) {
  78                 print F $_;
  79         }
  80
  81         close F;
  82 }
  83
  84
  85 sub new {
  86         my $class       = shift;
  87
  88         my $obj = bless( { @_ }, $class );
  89
  90         $obj->{charset}                 ||= 'UTF-8';
  91         $obj->{min_size_for_gzip}       ||= 10000;
  92
  93         $obj->{http_headers} = {
  94                 'Content-Type'          => 'text/html; charset=' . $obj->{charset},
  95                 'X-Gateway-Interface'   => $ENV{'GATEWAY_INTERFACE'},
  96                 'X-Server-Name'         => $ENV{'SERVER_NAME'}
  97         };
  98
  99         $obj->{upload_dirs} ||= [];
 100
 101         $obj->{cgi} = CGI->new();
 102
 103         return $obj;
 104 }
 105
 106
 107 sub run {
 108         my $self        = shift;
 109
 110         my $data = $self->data();
 111         my $vars = $self->vars();
 112
 113         $data->template->cgi_vars($vars);
 114
 115         if ($ENV{REMOTE_USER} and my $u = $data->source->user($ENV{REMOTE_USER})) {
 116                 $data->auth( $u );
 117         }
 118         elsif (my $cookie = $self->cookie()) {
 119                 if (my ($sid) = ($cookie =~ /sid\s*=\s*(\d+)/)) {
 120                         $data->auth_from_sid( $sid );
 121                 }
 122         }
 123
 124         my $st = 'INDEX';
 125
 126         if ($vars->{t}) {
 127                 $st = uc($vars->{t});
 128         }
 129
 130         $st = 'INDEX' unless $st =~ /^[-\w0-9_]+$/;
 131
 132         # not identified nor users found?
 133         if (!$data->auth() && ! $data->source->users()) {
 134
 135                 # create the admin user
 136                 my $u = Gruta::Data::User->new(
 137                         id              => 'admin',
 138                         is_admin        => 1,
 139                         can_upload      => 1,
 140                         username        => 'Admin',
 141                         email           => 'webmaster@localhost'
 142                 );
 143
 144                 # set a random password (to be promptly changed)
 145                 $u->password(rand());
 146
 147                 # insert the user
 148                 $data->source->insert_user($u);
 149
 150                 # create a new session
 151                 my $session = Gruta::Data::Session->new(user_id => 'admin');
 152                 $u->source->insert_session($session);
 153
 154                 $self->cookie('sid=' . $session->get('id'));
 155
 156                 $data->auth($u);
 157                 $data->session($session);
 158
 159                 $st = 'ADMIN';
 160         }
 161
 162         my $body = undef;
 163
 164         eval { $body = $data->template->process( $st ) };
 165
 166         if ($@) {
 167                 $data->log($@);
 168 #               $self->redirect('INDEX');
 169
 170                 $self->status(500);
 171                 $body = "<h1>500 Internal Server Error</h1><pre>$@</pre>";
 172
 173                 # main processing failed
 174                 $self->{error} = 1;
 175         }
 176
 177         $self->http_headers('X-BaseURL'         => $self->data->base_url());
 178         $self->http_headers('X-Powered-By'      => 'Gruta ' . $self->data->version());
 179
 180         if (!$data->auth()) {
 181                 use Digest::MD5;
 182                 use Encode qw(encode_utf8);
 183
 184                 my $md5 = Digest::MD5->new();
 185                 $md5->add(encode_utf8($body));
 186                 my $etag = $md5->hexdigest();
 187
 188                 my $inm = $ENV{HTTP_IF_NONE_MATCH} || '';
 189
 190                 if ($inm eq $etag) {
 191                         $self->status(304);
 192                         $body = '';
 193                 }
 194                 else {
 195                         $self->http_headers('ETag' => $etag);
 196                 }
 197         }
 198
 199         # does the client accept compression?
 200         if (length($body) > $self->{min_size_for_gzip} &&
 201                 $ENV{HTTP_ACCEPT_ENCODING} =~ /gzip/) {
 202                 # compress!!
 203                 use Compress::Zlib;
 204
 205                 if (my $cbody = Compress::Zlib::memGzip($body)) {
 206                         $self->http_headers('Content-encoding' => 'gzip');
 207                         $body = $cbody;
 208                 }
 209         }
 210
 211         my $h = $self->http_headers();
 212         foreach my $k (keys(%{ $h })) {
 213                 print $k, ': ', $h->{$k}, "\n";
 214         }
 215         print "\n";
 216
 217         print $body;
 218 }
 219
 220 1;