Gruta/CGI.pm

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