415 lines
9.9 KiB
Perl
415 lines
9.9 KiB
Perl
package WebGUI::Session::Http;
|
|
|
|
=head1 LEGAL
|
|
|
|
-------------------------------------------------------------------
|
|
WebGUI is Copyright 2001-2009 Plain Black Corporation.
|
|
-------------------------------------------------------------------
|
|
Please read the legal notices (docs/legal.txt) and the license
|
|
(docs/license.txt) that came with this distribution before using
|
|
this software.
|
|
-------------------------------------------------------------------
|
|
http://www.plainblack.com info@plainblack.com
|
|
-------------------------------------------------------------------
|
|
|
|
=cut
|
|
|
|
|
|
use strict;
|
|
use Scalar::Util qw( weaken blessed );
|
|
use HTTP::Date ();
|
|
|
|
sub _deprecated {
|
|
my $alt = shift;
|
|
my $method = (caller(1))[3];
|
|
Carp::carp("$method is deprecated. Use 'WebGUI::$alt' instead.");
|
|
}
|
|
|
|
=head1 NAME
|
|
|
|
Package WebGUI::Session::Http
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This package allows the manipulation of HTTP protocol information.
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use WebGUI::Session::Http;
|
|
|
|
my $http = WebGUI::Session::Http->new($session);
|
|
|
|
$http->sendHeader();
|
|
|
|
$boolean = $http->isRedirect();
|
|
|
|
$http->setCookie($name,$value);
|
|
$http->setNoHeader($bool);
|
|
$http->setRedirect($url);
|
|
|
|
=head1 METHODS
|
|
|
|
These methods are available from this package:
|
|
|
|
=cut
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getCacheControl ( )
|
|
|
|
Returns the cache control setting from this object.
|
|
|
|
=cut
|
|
|
|
sub getCacheControl {
|
|
my $self = shift;
|
|
return $self->{_http}{cacheControl} || 1;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getCookies ( )
|
|
|
|
Retrieves the cookies from the HTTP header and returns a hash reference containing them.
|
|
|
|
=cut
|
|
|
|
sub getCookies {
|
|
my $self = shift;
|
|
_deprecated('Request::cookies');
|
|
return $self->session->request->cookies;
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getLastModified ( )
|
|
|
|
Returns the stored epoch date when the page as last modified.
|
|
|
|
=cut
|
|
|
|
sub getLastModified {
|
|
my $self = shift;
|
|
return $self->{_http}{lastModified};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getNoHeader ( )
|
|
|
|
Returns whether or not a HTTP header will be printed.
|
|
|
|
=cut
|
|
|
|
sub getNoHeader {
|
|
my $self = shift;
|
|
return $self->{_http}{noHeader};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 getStreamedFile ( ) {
|
|
|
|
Returns the location of a file to be streamed thru mod_perl, if one has been set.
|
|
|
|
=cut
|
|
|
|
sub getStreamedFile {
|
|
my $self = shift;
|
|
return $self->{_http}{streamlocation} || undef;
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 ifModifiedSince ( epoch [, maxCacheTimeout] )
|
|
|
|
Returns 1 if the epoch is greater than the modified date check.
|
|
|
|
=head3 epoch
|
|
|
|
The date that the requested content was last modified in epoch format.
|
|
|
|
=head3 maxCacheTimeout
|
|
|
|
A modifier to the epoch, that allows us to set a maximum timeout where content will appear to
|
|
have changed and a new page request will be allowed to be processed.
|
|
|
|
=cut
|
|
|
|
sub ifModifiedSince {
|
|
my $self = shift;
|
|
my $epoch = shift;
|
|
my $maxCacheTimeout = shift;
|
|
my $modified = $self->session->request->header('If-Modified-Since');
|
|
return 1 if ($modified eq "");
|
|
$modified = HTTP::Date::str2time($modified);
|
|
##Implement a step function that increments the epoch time in integer multiples of
|
|
##the maximum cache time. Used to handle the case where layouts containing macros
|
|
##(like assetproxied Navigations) can be periodically updated.
|
|
if ($maxCacheTimeout) {
|
|
my $delta = time() - $epoch;
|
|
$epoch += $delta - ($delta % $maxCacheTimeout);
|
|
}
|
|
return ($epoch > $modified);
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 isRedirect ( )
|
|
|
|
Returns a boolean value indicating whether the current page will redirect to some other location.
|
|
|
|
=cut
|
|
|
|
sub isRedirect {
|
|
my $self = shift;
|
|
my $status = $self->session->response->status;
|
|
return $status == 302 || $status == 301;
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 new ( session )
|
|
|
|
Constructor.
|
|
|
|
=head3 session
|
|
|
|
A reference to the current session.
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $session = shift;
|
|
my $self = bless { _session => $session }, $class;
|
|
weaken $self->{_session};
|
|
return $self;
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 sendHeader ( )
|
|
|
|
Generates and sends HTTP headers for a response.
|
|
|
|
=cut
|
|
|
|
sub sendHeader {
|
|
my $self = shift;
|
|
return undef if ($self->{_http}{noHeader});
|
|
return $self->_sendMinimalHeader unless defined $self->session->db(1);
|
|
|
|
my $session = $self->session;
|
|
my ($request, $response, $config) = $session->quick(qw(request response config ));
|
|
return undef unless $request;
|
|
my $userId = $session->get("userId");
|
|
|
|
# send webgui session cookie
|
|
my $cookieName = $config->getCookieName;
|
|
$self->setCookie($cookieName, $session->getId, $config->getCookieTTL, $config->get("cookieDomain")) unless $session->getId eq $request->cookies->{$cookieName};
|
|
|
|
$self->setNoHeader(1);
|
|
my %params;
|
|
if (!$self->isRedirect()) {
|
|
my $cacheControl = $self->getCacheControl;
|
|
my $date = ($userId eq "1") ? HTTP::Date::time2str($self->getLastModified) : HTTP::Date::time2str();
|
|
# under these circumstances, don't allow caching
|
|
if ($userId ne "1" || $cacheControl eq "none" || $self->session->setting->get("preventProxyCache")) {
|
|
$response->header(
|
|
"Cache-Control" => "private, max-age=1",
|
|
"Pragma" => "no-cache",
|
|
"Cache-Control" => "no-cache",
|
|
);
|
|
}
|
|
# in all other cases, set cache, but tell it to ask us every time so we don't mess with recently logged in users
|
|
else {
|
|
if ( $cacheControl eq "none" ) {
|
|
$response->header("Cache-Control" => "private, max-age=1");
|
|
}
|
|
else {
|
|
$response->header(
|
|
'Last-Modified' => $date,
|
|
'Cache-Control' => "must-revalidate, max-age=" . $cacheControl,
|
|
);
|
|
}
|
|
# do an extra incantation if the HTTP protocol is really old
|
|
if ($request->protocol =~ /(\d\.\d)/ && $1 < 1.1) {
|
|
my $date = HTTP::Date::time2str(time() + $cacheControl);
|
|
$response->header( 'Expires' => $date );
|
|
}
|
|
}
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
sub _sendMinimalHeader {
|
|
my $self = shift;
|
|
my $response = $self->session->response;
|
|
$response->content_type('text/html; charset=UTF-8');
|
|
$response->header(
|
|
'Cache-Control' => 'private',
|
|
"Pragma" => "no-cache",
|
|
"Cache-Control" => "no-cache",
|
|
);
|
|
return undef;
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 session ( )
|
|
|
|
Returns the reference to the current session.
|
|
|
|
=cut
|
|
|
|
sub session {
|
|
my $self = shift;
|
|
return $self->{_session};
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setCacheControl ( timeout )
|
|
|
|
Sets the cache control headers.
|
|
|
|
=head3 timeout
|
|
|
|
Either the number of seconds until the cache expires, or the word "none" to disable cache completely for this request.
|
|
|
|
=cut
|
|
|
|
sub setCacheControl {
|
|
my $self = shift;
|
|
my $timeout = shift;
|
|
$self->{_http}{cacheControl} = $timeout;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setCookie ( name, value [ , timeToLive, domain ] )
|
|
|
|
Sends a cookie to the browser.
|
|
|
|
=head3 name
|
|
|
|
The name of the cookie to set. Must be unique from all other cookies from this domain or it will overwrite that cookie.
|
|
|
|
=head3 value
|
|
|
|
The value to set.
|
|
|
|
=head3 timeToLive
|
|
|
|
The time that the cookie should remain in the browser. Defaults to "+10y" (10 years from now).
|
|
This may be "session" to indicate that the cookie is for the current browser session only.
|
|
|
|
=head3 domain
|
|
|
|
Explicitly set the domain for this cookie.
|
|
|
|
=cut
|
|
|
|
sub setCookie {
|
|
my $self = shift;
|
|
my $name = shift;
|
|
my $value = shift;
|
|
my $ttl = shift;
|
|
my $domain = shift;
|
|
$ttl = (defined $ttl ? $ttl : '+10y');
|
|
|
|
$self->session->response->cookies->{$name} = {
|
|
value => $value,
|
|
path => '/',
|
|
expires => $ttl ne 'session' ? $ttl : undef,
|
|
domain => $domain,
|
|
};
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setLastModified ( epoch )
|
|
|
|
=head3 epoch
|
|
|
|
The epoch date when the page was last modified.
|
|
|
|
=cut
|
|
|
|
sub setLastModified {
|
|
my $self = shift;
|
|
my $epoch = shift;
|
|
$self->{_http}{lastModified} = $epoch;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setNoHeader ( boolean )
|
|
|
|
Disables the printing of a HTTP header. Useful in situations when content is not
|
|
returned to a browser (export to disk for example).
|
|
|
|
=head3 boolean
|
|
|
|
Any value other than 0 will disable header printing.
|
|
|
|
=cut
|
|
|
|
sub setNoHeader {
|
|
my $self = shift;
|
|
$self->{_http}{noHeader} = shift;
|
|
}
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setRedirect ( url, [ type ] )
|
|
|
|
Sets the necessary information in the HTTP header to redirect to another URL.
|
|
|
|
=head3 url
|
|
|
|
The URL to redirect to. To prevent infinite loops, no redirect will be set if
|
|
url is the same as the current page, as found through $session->url->page.
|
|
|
|
=head3 type
|
|
|
|
Defaults to 302 (temporary redirect), but you can optionally set 301 (permanent redirect).
|
|
|
|
=cut
|
|
|
|
sub setRedirect {
|
|
my $self = shift;
|
|
my $url = shift;
|
|
my $type = shift || 302;
|
|
my @params = $self->session->form->param;
|
|
return undef if ($url eq $self->session->url->page() && scalar(@params) < 1); # prevent redirecting to self
|
|
$self->session->log->info("Redirecting to $url");
|
|
$self->session->response->location($url);
|
|
$self->session->response->status($type);
|
|
$self->session->style->setMeta({"http-equiv"=>"refresh",content=>"0; URL=".$url});
|
|
}
|
|
|
|
|
|
#-------------------------------------------------------------------
|
|
|
|
=head2 setStreamedFile ( ) {
|
|
|
|
Set a file to be streamed thru mod_perl.
|
|
|
|
=cut
|
|
|
|
sub setStreamedFile {
|
|
my $self = shift;
|
|
$self->{_http}{streamlocation} = shift;
|
|
}
|
|
|
|
|
|
1;
|
|
|