+ InstantiateNewSession();
+ $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
+
+ $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
+
+ # Really the only time we don't want to redirect here is if we were
+ # passed user and pass as query params in the URL.
+ if ($next) {
+ Redirect($next);
+ }
+ elsif ($ARGS->{'next'}) {
+ # Invalid hash, but still wants to go somewhere, take them to /
+ Redirect(RT->Config->Get('WebURL'));
+ }
+
+ return (1, HTML::Mason::Commands::loc('Logged in'));
+ }
+}
+
+=head2 LoadSessionFromCookie
+
+Load or setup a session cookie for the current user.
+
+=cut
+
+sub _SessionCookieName {
+ my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
+ $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
+ return $cookiename;
+}
+
+sub LoadSessionFromCookie {
+
+ my %cookies = CGI::Cookie->fetch;
+ my $cookiename = _SessionCookieName();
+ my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
+ tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
+ unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
+ InstantiateNewSession();
+ }
+ if ( int RT->Config->Get('AutoLogoff') ) {
+ my $now = int( time / 60 );
+ my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
+
+ if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
+ InstantiateNewSession();
+ }
+
+ # save session on each request when AutoLogoff is turned on
+ $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
+ }
+}
+
+sub InstantiateNewSession {
+ tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
+ tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
+ SendSessionCookie();
+}
+
+sub SendSessionCookie {
+ my $cookie = CGI::Cookie->new(
+ -name => _SessionCookieName(),
+ -value => $HTML::Mason::Commands::session{_session_id},
+ -path => RT->Config->Get('WebPath'),
+ -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
+ -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
+ );
+
+ $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
+}
+
+=head2 Redirect URL
+
+This routine ells the current user's browser to redirect to URL.
+Additionally, it unties the user's currently active session, helping to avoid
+A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
+a cached DBI statement handle twice at the same time.
+
+=cut
+
+sub Redirect {
+ my $redir_to = shift;
+ untie $HTML::Mason::Commands::session;
+ my $uri = URI->new($redir_to);
+ my $server_uri = URI->new( _NormalizeHost(RT->Config->Get('WebURL')) );
+
+ # Make relative URIs absolute from the server host and scheme
+ $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
+ if (not defined $uri->host) {
+ $uri->host($server_uri->host);
+ $uri->port($server_uri->port);
+ }
+
+ # If the user is coming in via a non-canonical
+ # hostname, don't redirect them to the canonical host,
+ # it will just upset them (and invalidate their credentials)
+ # don't do this if $RT::CanonicalizeRedirectURLs is true
+ if ( !RT->Config->Get('CanonicalizeRedirectURLs')
+ && $uri->host eq $server_uri->host
+ && $uri->port eq $server_uri->port )
+ {
+ if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
+ $uri->scheme('https');
+ } else {
+ $uri->scheme('http');
+ }
+
+ # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
+ $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'});
+ $uri->port( $ENV{'SERVER_PORT'} );
+ }
+
+ # not sure why, but on some systems without this call mason doesn't
+ # set status to 302, but 200 instead and people see blank pages
+ $HTML::Mason::Commands::r->status(302);
+
+ # Perlbal expects a status message, but Mason's default redirect status
+ # doesn't provide one. See also rt.cpan.org #36689.
+ $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
+
+ $HTML::Mason::Commands::m->abort;
+}
+
+=head2 CacheControlExpiresHeaders
+
+set both Cache-Control and Expires http headers
+
+=cut
+
+sub CacheControlExpiresHeaders {
+ my %args = @_;
+
+ my $Visibility = 'private';
+ if ( ! defined $args{Time} ) {
+ $args{Time} = 0;
+ } elsif ( $args{Time} eq 'no-cache' ) {
+ $args{Time} = 0;
+ } elsif ( $args{Time} eq 'forever' ) {
+ $args{Time} = 30 * 24 * 60 * 60;
+ $Visibility = 'public';
+ }
+
+ my $CacheControl = $args{Time}
+ ? sprintf "max-age=%d, %s", $args{Time}, $Visibility
+ : 'no-cache'
+ ;
+ $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = $CacheControl;
+
+ my $expires = RT::Date->new(RT->SystemUser);
+ $expires->SetToNow;
+ $expires->AddSeconds( $args{Time} ) if $args{Time};
+
+ $HTML::Mason::Commands::r->headers_out->{'Expires'} = $expires->RFC2616;
+}
+
+=head2 StaticFileHeaders
+
+Send the browser a few headers to try to get it to (somewhat agressively)
+cache RT's static Javascript and CSS files.
+
+This routine could really use _accurate_ heuristics. (XXX TODO)
+
+=cut
+
+sub StaticFileHeaders {
+ my $date = RT::Date->new(RT->SystemUser);
+
+ # remove any cookie headers -- if it is cached publicly, it
+ # shouldn't include anyone's cookie!
+ delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
+
+ # Expire things in a month.
+ CacheControlExpiresHeaders( Time => 'forever' );
+
+ # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
+ # request, but we don't handle it and generate full reply again
+ # Last modified at server start time
+ # $date->Set( Value => $^T );
+ # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
+}
+
+=head2 ComponentPathIsSafe PATH
+
+Takes C<PATH> and returns a boolean indicating that the user-specified partial
+component path is safe.
+
+Currently "safe" means that the path does not start with a dot (C<.>), does
+not contain a slash-dot C</.>, and does not contain any nulls.
+
+=cut
+
+sub ComponentPathIsSafe {
+ my $self = shift;
+ my $path = shift;
+ return $path !~ m{(?:^|/)\.} and $path !~ m{\0};
+}
+
+=head2 PathIsSafe
+
+Takes a C<< Path => path >> and returns a boolean indicating that
+the path is safely within RT's control or not. The path I<must> be
+relative.
+
+This function does not consult the filesystem at all; it is merely
+a logical sanity checking of the path. This explicitly does not handle
+symlinks; if you have symlinks in RT's webroot pointing outside of it,
+then we assume you know what you are doing.
+
+=cut
+
+sub PathIsSafe {
+ my $self = shift;
+ my %args = @_;
+ my $path = $args{Path};
+
+ # Get File::Spec to clean up extra /s, ./, etc
+ my $cleaned_up = File::Spec->canonpath($path);
+
+ if (!defined($cleaned_up)) {
+ $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
+ return 0;
+ }
+
+ # Forbid too many ..s. We can't just sum then check because
+ # "../foo/bar/baz" should be illegal even though it has more
+ # downdirs than updirs. So as soon as we get a negative score
+ # (which means "breaking out" of the top level) we reject the path.
+
+ my @components = split '/', $cleaned_up;
+ my $score = 0;
+ for my $component (@components) {
+ if ($component eq '..') {
+ $score--;
+ if ($score < 0) {
+ $RT::Logger->info("Rejecting unsafe path: $path");
+ return 0;
+ }
+ }
+ elsif ($component eq '.' || $component eq '') {
+ # these two have no effect on $score
+ }
+ else {
+ $score++;
+ }
+ }
+
+ return 1;
+}
+
+=head2 SendStaticFile
+
+Takes a File => path and a Type => Content-type
+
+If Type isn't provided and File is an image, it will
+figure out a sane Content-type, otherwise it will
+send application/octet-stream
+
+Will set caching headers using StaticFileHeaders
+
+=cut
+
+sub SendStaticFile {
+ my $self = shift;
+ my %args = @_;
+ my $file = $args{File};
+ my $type = $args{Type};
+ my $relfile = $args{RelativeFile};
+
+ if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
+ $HTML::Mason::Commands::r->status(400);
+ $HTML::Mason::Commands::m->abort;
+ }
+
+ $self->StaticFileHeaders();
+
+ unless ($type) {
+ if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
+ $type = "image/$1";
+ $type =~ s/jpg/jpeg/gi;
+ }
+ $type ||= "application/octet-stream";
+ }
+ $HTML::Mason::Commands::r->content_type($type);
+ open( my $fh, '<', $file ) or die "couldn't open file: $!";
+ binmode($fh);
+ {
+ local $/ = \16384;
+ $HTML::Mason::Commands::m->out($_) while (<$fh>);
+ $HTML::Mason::Commands::m->flush_buffer;
+ }
+ close $fh;
+}
+
+
+
+sub MobileClient {
+ my $self = shift;
+
+
+if (($ENV{'HTTP_USER_AGENT'} || '') =~ /(?:hiptop|Blazer|Novarra|Vagabond|SonyEricsson|Symbian|NetFront|UP.Browser|UP.Link|Windows CE|MIDP|J2ME|DoCoMo|J-PHONE|PalmOS|PalmSource|iPhone|iPod|AvantGo|Nokia|Android|WebOS|S60|Mobile)/io && !$HTML::Mason::Commands::session{'NotMobile'}) {
+ return 1;
+} else {
+ return undef;
+}
+
+}
+
+
+sub StripContent {
+ my %args = @_;
+ my $content = $args{Content};
+ return '' unless $content;
+
+ # Make the content have no 'weird' newlines in it
+ $content =~ s/\r+\n/\n/g;
+
+ my $return_content = $content;
+
+ my $html = $args{ContentType} && $args{ContentType} eq "text/html";
+ my $sigonly = $args{StripSignature};
+
+ # massage content to easily detect if there's any real content
+ $content =~ s/\s+//g; # yes! remove all the spaces
+ if ( $html ) {
+ # remove html version of spaces and newlines
+ $content =~ s! !!g;
+ $content =~ s!<br/?>!!g;
+ }
+
+ # Filter empty content when type is text/html
+ return '' if $html && $content !~ /\S/;
+
+ # If we aren't supposed to strip the sig, just bail now.
+ return $return_content unless $sigonly;
+
+ # Find the signature
+ my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
+ $sig =~ s/\s+//g;
+
+ # Check for plaintext sig
+ return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
+
+ # Check for html-formatted sig; we don't use EscapeUTF8 here
+ # because we want to precisely match the escapting that FCKEditor
+ # uses.
+ $sig =~ s/&/&/g;
+ $sig =~ s/</</g;
+ $sig =~ s/>/>/g;
+ $sig =~ s/"/"/g;
+ $sig =~ s/'/'/g;
+ return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
+
+ # Pass it through
+ return $return_content;
+}
+
+sub DecodeARGS {
+ my $ARGS = shift;
+
+ %{$ARGS} = map {
+
+ # if they've passed multiple values, they'll be an array. if they've
+ # passed just one, a scalar whatever they are, mark them as utf8
+ my $type = ref($_);
+ ( !$type )
+ ? Encode::is_utf8($_)
+ ? $_
+ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
+ : ( $type eq 'ARRAY' )
+ ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
+ @$_ ]
+ : ( $type eq 'HASH' )
+ ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
+ %$_ }
+ : $_
+ } %$ARGS;
+}
+
+sub PreprocessTimeUpdates {
+ my $ARGS = shift;
+
+ # Later in the code we use
+ # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
+ # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
+ # The call_next method pass through original arguments and if you have
+ # an argument with unicode key then in a next component you'll get two
+ # records in the args hash: one with key without UTF8 flag and another
+ # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
+ # is copied from mason's source to get the same results as we get from
+ # call_next method, this feature is not documented, so we just leave it
+ # here to avoid possible side effects.
+
+ # This code canonicalizes time inputs in hours into minutes
+ foreach my $field ( keys %$ARGS ) {
+ next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
+ my $local = $1;
+ $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
+ {($1 || 0) + $3 ? $2 / $3 : 0}xe;
+ if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
+ $ARGS->{$local} *= 60;
+ }
+ delete $ARGS->{$field};
+ }
+
+}
+
+sub MaybeEnableSQLStatementLog {
+
+ my $log_sql_statements = RT->Config->Get('StatementLog');
+
+ if ($log_sql_statements) {
+ $RT::Handle->ClearSQLStatementLog;
+ $RT::Handle->LogSQLStatements(1);
+ }
+
+}
+
+sub LogRecordedSQLStatements {
+ my %args = @_;
+
+ my $log_sql_statements = RT->Config->Get('StatementLog');
+
+ return unless ($log_sql_statements);
+
+ my @log = $RT::Handle->SQLStatementLog;
+ $RT::Handle->ClearSQLStatementLog;
+
+ $RT::Handle->AddRequestToHistory({
+ %{ $args{RequestData} },
+ Queries => \@log,
+ });
+
+ for my $stmt (@log) {
+ my ( $time, $sql, $bind, $duration ) = @{$stmt};
+ my @bind;
+ if ( ref $bind ) {
+ @bind = @{$bind};
+ } else {
+
+ # Older DBIx-SB
+ $duration = $bind;
+ }
+ $RT::Logger->log(
+ level => $log_sql_statements,
+ message => "SQL("
+ . sprintf( "%.6f", $duration )
+ . "s): $sql;"
+ . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
+ );
+ }
+
+}
+
+my $_has_validated_web_config = 0;
+sub ValidateWebConfig {
+ my $self = shift;
+
+ # do this once per server instance, not once per request
+ return if $_has_validated_web_config;
+ $_has_validated_web_config = 1;
+
+ my $port = $ENV{SERVER_PORT};
+ my $host = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER}
+ || $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
+ ($host, $port) = ($1, $2) if $host =~ /^(.*?):(\d+)$/;
+
+ if ( $port != RT->Config->Get('WebPort') and not $ENV{'rt.explicit_port'}) {
+ $RT::Logger->warn("The requested port ($port) does NOT match the configured WebPort ($RT::WebPort). "
+ ."Perhaps you should Set(\$WebPort, $port); in RT_SiteConfig.pm, "
+ ."otherwise your internal links may be broken.");
+ }
+
+ if ( $host ne RT->Config->Get('WebDomain') ) {
+ $RT::Logger->warn("The requested host ($host) does NOT match the configured WebDomain ($RT::WebDomain). "
+ ."Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, "
+ ."otherwise your internal links may be broken.");
+ }
+
+ # Unfortunately, there is no reliable way to get the _path_ that was
+ # requested at the proxy level; simply disable this warning if we're
+ # proxied and there's a mismatch.
+ my $proxied = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER};
+ if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath') and not $proxied) {
+ $RT::Logger->warn("The requested path ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). "
+ ."Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, "
+ ."otherwise your internal links may be broken.");
+ }
+}
+
+sub ComponentRoots {
+ my $self = shift;
+ my %args = ( Names => 0, @_ );
+ my @roots;
+ if (defined $HTML::Mason::Commands::m) {
+ @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
+ } else {
+ @roots = (
+ [ local => $RT::MasonLocalComponentRoot ],
+ (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
+ [ standard => $RT::MasonComponentRoot ]
+ );
+ }
+ @roots = map { $_->[1] } @roots unless $args{Names};
+ return @roots;
+}
+
+our %is_whitelisted_component = (
+ # The RSS feed embeds an auth token in the path, but query
+ # information for the search. Because it's a straight-up read, in
+ # addition to embedding its own auth, it's fine.
+ '/NoAuth/rss/dhandler' => 1,
+
+ # While these can be used for denial-of-service against RT
+ # (construct a very inefficient query and trick lots of users into
+ # running them against RT) it's incredibly useful to be able to link
+ # to a search result or bookmark a result page.
+ '/Search/Results.html' => 1,
+ '/Search/Simple.html' => 1,
+ '/m/tickets/search' => 1,
+);
+
+# Components which are blacklisted from automatic, argument-based whitelisting.
+# These pages are not idempotent when called with just an id.
+our %is_blacklisted_component = (
+ # Takes only id and toggles bookmark state
+ '/Helpers/Toggle/TicketBookmark' => 1,
+);
+
+sub IsCompCSRFWhitelisted {
+ my $comp = shift;
+ my $ARGS = shift;
+
+ return 1 if $is_whitelisted_component{$comp};
+
+ my %args = %{ $ARGS };
+
+ # If the user specifies a *correct* user and pass then they are
+ # golden. This acts on the presumption that external forms may
+ # hardcode a username and password -- if a malicious attacker knew
+ # both already, CSRF is the least of your problems.
+ my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
+ if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
+ my $user_obj = RT::CurrentUser->new();
+ $user_obj->Load($args{user});
+ return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
+
+ delete $args{user};
+ delete $args{pass};
+ }
+
+ # Some pages aren't idempotent even with safe args like id; blacklist
+ # them from the automatic whitelisting below.
+ return 0 if $is_blacklisted_component{$comp};
+
+ # Eliminate arguments that do not indicate an effectful request.
+ # For example, "id" is acceptable because that is how RT retrieves a
+ # record.
+ delete $args{id};
+
+ # If they have a results= from MaybeRedirectForResults, that's also fine.
+ delete $args{results};
+
+ # The homepage refresh, which uses the Refresh header, doesn't send
+ # a referer in most browsers; whitelist the one parameter it reloads
+ # with, HomeRefreshInterval, which is safe
+ delete $args{HomeRefreshInterval};
+
+ # The NotMobile flag is fine for any page; it's only used to toggle a flag
+ # in the session related to which interface you get.
+ delete $args{NotMobile};
+
+ # If there are no arguments, then it's likely to be an idempotent
+ # request, which are not susceptible to CSRF
+ return 1 if !%args;
+
+ return 0;
+}
+
+sub IsRefererCSRFWhitelisted {
+ my $referer = _NormalizeHost(shift);
+ my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
+ $base_url = $base_url->host_port;
+
+ my $configs;
+ for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
+ push @$configs,$config;
+
+ my $host_port = $referer->host_port;
+ if ($config =~ /\*/) {
+ # Turn a literal * into a domain component or partial component match.
+ # Refer to http://tools.ietf.org/html/rfc2818#page-5
+ my $regex = join "[a-zA-Z0-9\-]*",
+ map { quotemeta($_) }
+ split /\*/, $config;
+
+ return 1 if $host_port =~ /^$regex$/i;
+ } else {
+ return 1 if $host_port eq $config;
+ }
+ }
+
+ return (0,$referer,$configs);
+}
+
+=head3 _NormalizeHost
+
+Takes a URI and creates a URI object that's been normalized
+to handle common problems such as localhost vs 127.0.0.1
+
+=cut
+
+sub _NormalizeHost {
+ my $s = shift;
+ $s = "http://$s" unless $s =~ /^http/i;
+ my $uri= URI->new($s);
+ $uri->host('127.0.0.1') if $uri->host eq 'localhost';
+
+ return $uri;
+
+}
+
+sub IsPossibleCSRF {
+ my $ARGS = shift;
+
+ # If first request on this session is to a REST endpoint, then
+ # whitelist the REST endpoints -- and explicitly deny non-REST
+ # endpoints. We do this because using a REST cookie in a browser
+ # would open the user to CSRF attacks to the REST endpoints.
+ my $path = $HTML::Mason::Commands::r->path_info;
+ $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
+ unless defined $HTML::Mason::Commands::session{'REST'};
+
+ if ($HTML::Mason::Commands::session{'REST'}) {
+ return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
+ my $why = <<EOT;
+This login session belongs to a REST client, and cannot be used to
+access non-REST interfaces of RT for security reasons.
+EOT
+ my $details = <<EOT;
+Please log out and back in to obtain a session for normal browsing. If
+you understand the security implications, disabling RT's CSRF protection
+will remove this restriction.
+EOT
+ chomp $details;
+ HTML::Mason::Commands::Abort( $why, Details => $details );
+ }
+
+ return 0 if IsCompCSRFWhitelisted(
+ $HTML::Mason::Commands::m->request_comp->path,
+ $ARGS
+ );
+
+ # if there is no Referer header then assume the worst
+ return (1,
+ "your browser did not supply a Referrer header", # loc
+ ) if !$ENV{HTTP_REFERER};
+
+ my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
+ return 0 if $whitelisted;
+
+ if ( @$configs > 1 ) {
+ return (1,
+ "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
+ $browser->host_port,
+ shift @$configs,
+ join(', ', @$configs) );
+ }
+
+ return (1,
+ "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
+ $browser->host_port,
+ $configs->[0]);
+}
+
+sub ExpandCSRFToken {
+ my $ARGS = shift;
+
+ my $token = delete $ARGS->{CSRF_Token};
+ return unless $token;
+
+ my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
+ return unless $data;
+ return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
+
+ my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
+ return unless $user->ValidateAuthString( $data->{auth}, $token );
+
+ %{$ARGS} = %{$data->{args}};
+ $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
+
+ # We explicitly stored file attachments with the request, but not in
+ # the session yet, as that would itself be an attack. Put them into
+ # the session now, so they'll be visible.
+ if ($data->{attach}) {
+ my $filename = $data->{attach}{filename};
+ my $mime = $data->{attach}{mime};
+ $HTML::Mason::Commands::session{'Attachments'}{$filename}
+ = $mime;
+ }
+
+ return 1;
+}
+
+sub StoreRequestToken {
+ my $ARGS = shift;
+
+ my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
+ my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
+ my $data = {
+ auth => $user->GenerateAuthString( $token ),
+ path => $HTML::Mason::Commands::r->path_info,
+ args => $ARGS,
+ };
+ if ($ARGS->{Attach}) {
+ my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
+ my $file_path = delete $ARGS->{'Attach'};
+ $data->{attach} = {
+ filename => Encode::decode_utf8("$file_path"),
+ mime => $attachment,
+ };
+ }
+
+ $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
+ $HTML::Mason::Commands::session{'i'}++;
+ return $token;
+}
+
+sub MaybeShowInterstitialCSRFPage {
+ my $ARGS = shift;
+
+ return unless RT->Config->Get('RestrictReferrer');
+
+ # Deal with the form token provided by the interstitial, which lets
+ # browsers which never set referer headers still use RT, if
+ # painfully. This blows values into ARGS
+ return if ExpandCSRFToken($ARGS);
+
+ my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
+ return if !$is_csrf;
+
+ $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
+
+ my $token = StoreRequestToken($ARGS);
+ $HTML::Mason::Commands::m->comp(
+ '/Elements/CSRF',
+ OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
+ Reason => HTML::Mason::Commands::loc( $msg, @loc ),
+ Token => $token,
+ );
+ # Calls abort, never gets here
+}
+
+our @POTENTIAL_PAGE_ACTIONS = (
+ qr'/Ticket/Create.html' => "create a ticket", # loc
+ qr'/Ticket/' => "update a ticket", # loc
+ qr'/Admin/' => "modify RT's configuration", # loc
+ qr'/Approval/' => "update an approval", # loc
+ qr'/Articles/' => "update an article", # loc
+ qr'/Dashboards/' => "modify a dashboard", # loc
+ qr'/m/ticket/' => "update a ticket", # loc
+ qr'Prefs' => "modify your preferences", # loc
+ qr'/Search/' => "modify or access a search", # loc
+ qr'/SelfService/Create' => "create a ticket", # loc
+ qr'/SelfService/' => "update a ticket", # loc
+);
+
+sub PotentialPageAction {
+ my $page = shift;
+ my @potentials = @POTENTIAL_PAGE_ACTIONS;
+ while (my ($pattern, $result) = splice @potentials, 0, 2) {
+ return HTML::Mason::Commands::loc($result)
+ if $page =~ $pattern;
+ }
+ return "";
+}
+
+package HTML::Mason::Commands;
+
+use vars qw/$r $m %session/;
+
+sub Menu {
+ return $HTML::Mason::Commands::m->notes('menu');
+}
+
+sub PageMenu {
+ return $HTML::Mason::Commands::m->notes('page-menu');
+}
+
+sub PageWidgets {
+ return $HTML::Mason::Commands::m->notes('page-widgets');
+}
+
+
+
+=head2 loc ARRAY
+
+loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
+with whatever it's called with. If there is no $session{'CurrentUser'},
+it creates a temporary user, so we have something to get a localisation handle
+through
+
+=cut
+
+sub loc {
+
+ if ( $session{'CurrentUser'}
+ && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
+ {
+ return ( $session{'CurrentUser'}->loc(@_) );
+ } elsif (
+ my $u = eval {
+ RT::CurrentUser->new();
+ }
+ )
+ {
+ return ( $u->loc(@_) );
+ } else {
+
+ # pathetic case -- SystemUser is gone.
+ return $_[0];
+ }
+}
+
+
+
+=head2 loc_fuzzy STRING
+
+loc_fuzzy is for handling localizations of messages that may already
+contain interpolated variables, typically returned from libraries
+outside RT's control. It takes the message string and extracts the
+variable array automatically by matching against the candidate entries
+inside the lexicon file.
+
+=cut
+
+sub loc_fuzzy {
+ my $msg = shift;
+
+ if ( $session{'CurrentUser'}
+ && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
+ {
+ return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
+ } else {
+ my $u = RT::CurrentUser->new( RT->SystemUser->Id );
+ return ( $u->loc_fuzzy($msg) );
+ }
+}
+
+
+# Error - calls Error and aborts
+sub Abort {
+ my $why = shift;
+ my %args = @_;
+
+ if ( $session{'ErrorDocument'}
+ && $session{'ErrorDocumentType'} )
+ {
+ $r->content_type( $session{'ErrorDocumentType'} );
+ $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
+ $m->abort;
+ } else {
+ $m->comp( "/Elements/Error", Why => $why, %args );
+ $m->abort;
+ }
+}
+
+sub MaybeRedirectForResults {
+ my %args = (
+ Path => $HTML::Mason::Commands::m->request_comp->path,
+ Arguments => {},
+ Anchor => undef,
+ Actions => undef,
+ Force => 0,
+ @_
+ );
+ my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
+ return unless $has_actions || $args{'Force'};
+
+ my %arguments = %{ $args{'Arguments'} };
+
+ if ( $has_actions ) {
+ my $key = Digest::MD5::md5_hex( rand(1024) );
+ push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
+ $session{'i'}++;
+ $arguments{'results'} = $key;
+ }
+
+ $args{'Path'} =~ s!^/+!!;
+ my $url = RT->Config->Get('WebURL') . $args{Path};
+
+ if ( keys %arguments ) {
+ $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
+ }
+ if ( $args{'Anchor'} ) {
+ $url .= "#". $args{'Anchor'};
+ }
+ return RT::Interface::Web::Redirect($url);
+}
+
+=head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
+
+If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
+redirect to the approvals display page, preserving any arguments.
+
+C<Path>s matching C<Whitelist> are let through.
+
+This is a no-op if the C<ForceApprovalsView> option isn't enabled.
+
+=cut
+
+sub MaybeRedirectToApproval {
+ my %args = (
+ Path => $HTML::Mason::Commands::m->request_comp->path,
+ ARGSRef => {},
+ Whitelist => undef,
+ @_
+ );
+
+ return unless $ENV{REQUEST_METHOD} eq 'GET';
+
+ my $id = $args{ARGSRef}->{id};
+
+ if ( $id
+ and RT->Config->Get('ForceApprovalsView')
+ and not $args{Path} =~ /$args{Whitelist}/)
+ {
+ my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
+ $ticket->Load($id);
+
+ if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
+ MaybeRedirectForResults(
+ Path => "/Approvals/Display.html",
+ Force => 1,
+ Anchor => $args{ARGSRef}->{Anchor},
+ Arguments => $args{ARGSRef},