1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2013 Best Practical Solutions, LLC
6 # <sales@bestpractical.com>
8 # (Except where explicitly superseded by other copyright notices)
13 # This work is made available to you under the terms of Version 2 of
14 # the GNU General Public License. A copy of that license should have
15 # been provided with this software, but in any event can be snarfed
18 # This work is distributed in the hope that it will be useful, but
19 # WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 # General Public License for more details.
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 # 02110-1301 or visit their web page on the internet at
27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
30 # CONTRIBUTION SUBMISSION POLICY:
32 # (The following paragraph is not intended to limit the rights granted
33 # to you to modify and distribute this software under the terms of
34 # the GNU General Public License and is only of importance to you if
35 # you choose to contribute your changes and enhancements to the
36 # community by submitting them to Best Practical Solutions, LLC.)
38 # By intentionally submitting any modifications, corrections or
39 # derivatives to this work, or any other work intended for use with
40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
41 # you are the copyright holder for those contributions and you grant
42 # Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
43 # royalty-free, perpetual, license to use, copy, create derivative
44 # works based on those contributions, and sublicense and distribute
45 # those contributions and any derivatives thereof.
47 # END BPS TAGGED BLOCK }}}
49 ## Portions Copyright 2000 Tobias Brox <tobix@fsck.com>
51 ## This is a library of static subs to be used by the Mason web
64 package RT::Interface::Web;
66 use RT::SavedSearches;
68 use RT::Interface::Web::Session;
74 =head2 EscapeUTF8 SCALARREF
76 does a css-busting but minimalist escaping of whatever html you're passing in.
82 return unless defined $$ref;
87 $$ref =~ s/\(/(/g;
88 $$ref =~ s/\)/)/g;
97 =head2 EscapeURI SCALARREF
99 Escapes URI component according to RFC2396
105 return unless defined $$ref;
108 $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
113 sub _encode_surrogates {
114 my $uni = $_[0] - 0x10000;
115 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
120 return unless defined $$ref;
122 $$ref = "'" . join('',
124 chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
125 $_ <= 255 ? sprintf("\\x%02X", $_) :
126 $_ <= 65535 ? sprintf("\\u%04X", $_) :
127 sprintf("\\u%X\\u%X", _encode_surrogates($_))
128 } unpack('U*', $$ref))
132 # {{{ WebCanonicalizeInfo
134 =head2 WebCanonicalizeInfo();
136 Different web servers set different environmental varibles. This
137 function must return something suitable for REMOTE_USER. By default,
138 just downcase $ENV{'REMOTE_USER'}
142 sub WebCanonicalizeInfo {
143 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
148 # {{{ WebExternalAutoInfo
150 =head2 WebExternalAutoInfo($user);
152 Returns a hash of user attributes, used when WebExternalAuto is set.
156 sub WebExternalAutoInfo {
161 # default to making Privileged users, even if they specify
162 # some other default Attributes
163 if ( !$RT::AutoCreate
164 || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
166 $user_info{'Privileged'} = 1;
169 if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
171 # Populate fields with information from Unix /etc/passwd
173 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
174 $user_info{'Comments'} = $comments if defined $comments;
175 $user_info{'RealName'} = $realname if defined $realname;
176 } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
178 # Populate fields with information from NT domain controller
181 # and return the wad of stuff
190 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
192 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
194 # Roll back any dangling transactions from a previous failed connection
195 $RT::Handle->ForceRollback() if $RT::Handle->TransactionDepth;
197 MaybeEnableSQLStatementLog();
199 # avoid reentrancy, as suggested by masonbook
200 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
202 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
203 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
206 PreprocessTimeUpdates($ARGS);
208 MaybeShowInstallModePage();
210 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
212 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new() unless _UserLoggedIn();
214 # Process session-related callbacks before any auth attempts
215 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
217 MaybeRejectPrivateComponentRequest();
219 MaybeShowNoAuthPage($ARGS);
221 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
223 _ForceLogout() unless _UserLoggedIn();
225 # Process per-page authentication callbacks
226 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
228 unless ( _UserLoggedIn() ) {
231 # Authenticate if the user is trying to login via user/pass query args
232 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
235 my $m = $HTML::Mason::Commands::m;
237 # REST urls get a special 401 response
238 if ($m->request_comp->path =~ '^/REST/\d+\.\d+/') {
239 $HTML::Mason::Commands::r->content_type("text/plain");
240 $m->error_format("text");
241 $m->out("RT/$RT::VERSION 401 Credentials required\n");
242 $m->out("\n$msg\n") if $msg;
245 # Specially handle /index.html so that we get a nicer URL
246 elsif ( $m->request_comp->path eq '/index.html' ) {
247 my $next = SetNextPage($ARGS);
248 $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]);
252 TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
257 MaybeShowInterstitialCSRFPage($ARGS);
259 # now it applies not only to home page, but any dashboard that can be used as a workspace
260 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
261 if ( $ARGS->{'HomeRefreshInterval'} );
263 # Process per-page global callbacks
264 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
266 ShowRequestedPage($ARGS);
267 LogRecordedSQLStatements();
269 # Process per-page final cleanup callbacks
270 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
275 delete $HTML::Mason::Commands::session{'CurrentUser'};
279 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
287 =head2 LoginError ERROR
289 Pushes a login error into the Actions session store and returns the hash key.
295 my $key = Digest::MD5::md5_hex( rand(1024) );
296 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
297 $HTML::Mason::Commands::session{'i'}++;
301 =head2 SetNextPage ARGSRef [PATH]
303 Intuits and stashes the next page in the sesssion hash. If PATH is
304 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
311 my $next = $_[0] ? $_[0] : IntuitNextPage();
312 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
313 my $page = { url => $next };
315 # If an explicit URL was passed and we didn't IntuitNextPage, then
316 # IsPossibleCSRF below is almost certainly unrelated to the actual
317 # destination. Currently explicit next pages aren't used in RT, but the
319 if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
320 # This isn't really CSRF, but the CSRF heuristics are useful for catching
321 # requests which may have unintended side-effects.
322 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
325 "Marking original destination as having side-effects before redirecting for login.\n"
327 ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
329 $page->{'HasSideEffects'} = [$msg, @loc];
333 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
334 $HTML::Mason::Commands::session{'i'}++;
338 =head2 FetchNextPage HASHKEY
340 Returns the stashed next page hashref for the given hash.
345 my $hash = shift || "";
346 return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
349 =head2 RemoveNextPage HASHKEY
351 Removes the stashed next page for the given hash and returns it.
356 my $hash = shift || "";
357 return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
360 =head2 TangentForLogin ARGSRef [HASH]
362 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
363 the next page. Takes a hashref of request %ARGS as the first parameter.
364 Optionally takes all other parameters as a hash which is dumped into query
369 sub TangentForLogin {
371 my $hash = SetNextPage($ARGS);
372 my %query = (@_, next => $hash);
373 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
374 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
378 =head2 TangentForLoginWithError ERROR
380 Localizes the passed error message, stashes it with L<LoginError> and then
381 calls L<TangentForLogin> with the appropriate results key.
385 sub TangentForLoginWithError {
387 my $key = LoginError(HTML::Mason::Commands::loc(@_));
388 TangentForLogin( $ARGS, results => $key );
391 =head2 IntuitNextPage
393 Attempt to figure out the path to which we should return the user after a
394 tangent. The current request URL is used, or failing that, the C<WebURL>
395 configuration variable.
402 # This includes any query parameters. Redirect will take care of making
403 # it an absolute URL.
404 if ($ENV{'REQUEST_URI'}) {
405 $req_uri = $ENV{'REQUEST_URI'};
407 # collapse multiple leading slashes so the first part doesn't look like
408 # a hostname of a schema-less URI
409 $req_uri =~ s{^/+}{/};
412 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
415 my $uri = URI->new($next);
417 # You get undef scheme with a relative uri like "/Search/Build.html"
418 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
419 $next = RT->Config->Get('WebURL');
422 # Make sure we're logging in to the same domain
423 # You can get an undef authority with a relative uri like "index.html"
424 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
425 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
426 $next = RT->Config->Get('WebURL');
432 =head2 MaybeShowInstallModePage
434 This function, called exclusively by RT's autohandler, dispatches
435 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
437 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
441 sub MaybeShowInstallModePage {
442 return unless RT->InstallMode;
444 my $m = $HTML::Mason::Commands::m;
445 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
447 } elsif ( $m->request_comp->path !~ '^(/+)Install/' ) {
448 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
455 =head2 MaybeShowNoAuthPage \%ARGS
457 This function, called exclusively by RT's autohandler, dispatches
458 a request to the page a user requested (but only if it matches the "noauth" regex.
460 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
464 sub MaybeShowNoAuthPage {
467 my $m = $HTML::Mason::Commands::m;
469 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
471 # Don't show the login page to logged in users
472 Redirect(RT->Config->Get('WebURL'))
473 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
475 # If it's a noauth file, don't ask for auth.
476 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
480 =head2 MaybeRejectPrivateComponentRequest
482 This function will reject calls to private components, like those under
483 C</Elements>. If the requested path is a private component then we will
484 abort with a C<403> error.
488 sub MaybeRejectPrivateComponentRequest {
489 my $m = $HTML::Mason::Commands::m;
490 my $path = $m->request_comp->path;
492 # We do not check for dhandler here, because requesting our dhandlers
493 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
499 _elements | # mobile UI
502 autohandler | # requesting this directly is suspicious
503 l (_unsafe)? ) # loc component
504 ( $ | / ) # trailing slash or end of path
506 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
509 warn "rejecting private component $path\n";
516 =head2 ShowRequestedPage \%ARGS
518 This function, called exclusively by RT's autohandler, dispatches
519 a request to the page a user requested (making sure that unpriviled users
520 can only see self-service pages.
524 sub ShowRequestedPage {
527 my $m = $HTML::Mason::Commands::m;
529 # Ensure that the cookie that we send is up-to-date, in case the
530 # session-id has been modified in any way
533 # If the user isn't privileged, they can only see SelfService
534 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
536 # if the user is trying to access a ticket, redirect them
537 if ( $m->request_comp->path =~ '^(/+)Ticket/Display.html' && $ARGS->{'id'} ) {
538 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
541 # otherwise, drop the user at the SelfService default page
542 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
543 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
546 # if user is in SelfService dir let him do anything
548 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
551 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
556 sub AttemptExternalAuth {
559 return unless ( RT->Config->Get('WebExternalAuth') );
561 my $user = $ARGS->{user};
562 my $m = $HTML::Mason::Commands::m;
564 # If RT is configured for external auth, let's go through and get REMOTE_USER
566 # do we actually have a REMOTE_USER equivlent?
567 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
568 my $orig_user = $user;
570 $user = RT::Interface::Web::WebCanonicalizeInfo();
571 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
573 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
574 my $NodeName = Win32::NodeName();
575 $user =~ s/^\Q$NodeName\E\\//i;
578 my $next = RemoveNextPage($ARGS->{'next'});
579 $next = $next->{'url'} if ref $next;
580 InstantiateNewSession() unless _UserLoggedIn;
581 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
582 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
584 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
586 # Create users on-the-fly
587 my $UserObj = RT::User->new($RT::SystemUser);
588 my ( $val, $msg ) = $UserObj->Create(
589 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
596 # now get user specific information, to better create our user.
597 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
599 # set the attributes that have been defined.
600 foreach my $attribute ( $UserObj->WritableAttributes ) {
602 Attribute => $attribute,
604 UserInfo => $new_user_info,
605 CallbackName => 'NewUser',
606 CallbackPage => '/autohandler'
608 my $method = "Set$attribute";
609 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
611 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
614 # we failed to successfully create the user. abort abort abort.
615 delete $HTML::Mason::Commands::session{'CurrentUser'};
617 if (RT->Config->Get('WebFallbackToInternalAuth')) {
618 TangentForLoginWithError($ARGS, 'Cannot create user: [_1]', $msg);
625 if ( _UserLoggedIn() ) {
626 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
627 # It is possible that we did a redirect to the login page,
628 # if the external auth allows lack of auth through with no
629 # REMOTE_USER set, instead of forcing a "permission
630 # denied" message. Honor the $next.
631 Redirect($next) if $next;
632 # Unlike AttemptPasswordAuthentication below, we do not
633 # force a redirect to / if $next is not set -- otherwise,
634 # straight-up external auth would always redirect to /
635 # when you first hit it.
637 delete $HTML::Mason::Commands::session{'CurrentUser'};
640 unless ( RT->Config->Get('WebFallbackToInternalAuth') ) {
641 TangentForLoginWithError($ARGS, 'You are not an authorized user');
644 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
645 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
646 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
647 TangentForLoginWithError($ARGS, 'You are not an authorized user');
651 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
652 # XXX: we must return AUTH_REQUIRED status or we fallback to
653 # internal auth here too.
654 delete $HTML::Mason::Commands::session{'CurrentUser'}
655 if defined $HTML::Mason::Commands::session{'CurrentUser'};
659 sub AttemptPasswordAuthentication {
661 return unless defined $ARGS->{user} && defined $ARGS->{pass};
663 my $user_obj = RT::CurrentUser->new();
664 $user_obj->Load( $ARGS->{user} );
666 my $m = $HTML::Mason::Commands::m;
668 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
669 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
670 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
671 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
674 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
676 # It's important to nab the next page from the session before we blow
678 my $next = RemoveNextPage($ARGS->{'next'});
679 $next = $next->{'url'} if ref $next;
681 InstantiateNewSession();
682 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
684 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
686 # Really the only time we don't want to redirect here is if we were
687 # passed user and pass as query params in the URL.
691 elsif ($ARGS->{'next'}) {
692 # Invalid hash, but still wants to go somewhere, take them to /
693 Redirect(RT->Config->Get('WebURL'));
696 return (1, HTML::Mason::Commands::loc('Logged in'));
700 =head2 LoadSessionFromCookie
702 Load or setup a session cookie for the current user.
706 sub _SessionCookieName {
707 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
708 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
712 sub LoadSessionFromCookie {
714 my %cookies = CGI::Cookie->fetch;
715 my $cookiename = _SessionCookieName();
716 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
717 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
718 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
719 undef $cookies{$cookiename};
721 if ( int RT->Config->Get('AutoLogoff') ) {
722 my $now = int( time / 60 );
723 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
725 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
726 InstantiateNewSession();
729 # save session on each request when AutoLogoff is turned on
730 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
734 sub InstantiateNewSession {
735 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
736 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
740 sub SendSessionCookie {
741 my $cookie = CGI::Cookie->new(
742 -name => _SessionCookieName(),
743 -value => $HTML::Mason::Commands::session{_session_id},
744 -path => RT->Config->Get('WebPath'),
745 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
746 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
749 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
754 This routine ells the current user's browser to redirect to URL.
755 Additionally, it unties the user's currently active session, helping to avoid
756 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
757 a cached DBI statement handle twice at the same time.
762 my $redir_to = shift;
763 untie $HTML::Mason::Commands::session;
764 my $uri = URI->new($redir_to);
765 my $server_uri = URI->new( RT->Config->Get('WebURL') );
767 # Make relative URIs absolute from the server host and scheme
768 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
769 if (not defined $uri->host) {
770 $uri->host($server_uri->host);
771 $uri->port($server_uri->port);
774 # If the user is coming in via a non-canonical
775 # hostname, don't redirect them to the canonical host,
776 # it will just upset them (and invalidate their credentials)
777 # don't do this if $RT::CanoniaclRedirectURLs is true
778 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
779 && $uri->host eq $server_uri->host
780 && $uri->port eq $server_uri->port )
782 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
783 $uri->scheme('https');
785 $uri->scheme('http');
788 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
789 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} );
790 $uri->port( $ENV{'SERVER_PORT'} );
793 # not sure why, but on some systems without this call mason doesn't
794 # set status to 302, but 200 instead and people see blank pages
795 $HTML::Mason::Commands::r->status(302);
797 # Perlbal expects a status message, but Mason's default redirect status
798 # doesn't provide one. See also rt.cpan.org #36689.
799 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
801 $HTML::Mason::Commands::m->abort;
804 =head2 StaticFileHeaders
806 Send the browser a few headers to try to get it to (somewhat agressively)
807 cache RT's static Javascript and CSS files.
809 This routine could really use _accurate_ heuristics. (XXX TODO)
813 sub StaticFileHeaders {
814 my $date = RT::Date->new($RT::SystemUser);
817 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public';
819 # remove any cookie headers -- if it is cached publicly, it
820 # shouldn't include anyone's cookie!
821 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
823 # Expire things in a month.
824 $date->Set( Value => time + 30 * 24 * 60 * 60 );
825 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616;
827 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
828 # request, but we don't handle it and generate full reply again
829 # Last modified at server start time
830 # $date->Set( Value => $^T );
831 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
834 =head2 ComponentPathIsSafe PATH
836 Takes C<PATH> and returns a boolean indicating that the user-specified partial
837 component path is safe.
839 Currently "safe" means that the path does not start with a dot (C<.>), does
840 not contain a slash-dot C</.>, and does not contain any nulls.
844 sub ComponentPathIsSafe {
847 return $path !~ m{(?:^|/)\.} and $path !~ m{\0};
852 Takes a C<< Path => path >> and returns a boolean indicating that
853 the path is safely within RT's control or not. The path I<must> be
856 This function does not consult the filesystem at all; it is merely
857 a logical sanity checking of the path. This explicitly does not handle
858 symlinks; if you have symlinks in RT's webroot pointing outside of it,
859 then we assume you know what you are doing.
866 my $path = $args{Path};
868 # Get File::Spec to clean up extra /s, ./, etc
869 my $cleaned_up = File::Spec->canonpath($path);
871 if (!defined($cleaned_up)) {
872 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
876 # Forbid too many ..s. We can't just sum then check because
877 # "../foo/bar/baz" should be illegal even though it has more
878 # downdirs than updirs. So as soon as we get a negative score
879 # (which means "breaking out" of the top level) we reject the path.
881 my @components = split '/', $cleaned_up;
883 for my $component (@components) {
884 if ($component eq '..') {
887 $RT::Logger->info("Rejecting unsafe path: $path");
891 elsif ($component eq '.' || $component eq '') {
892 # these two have no effect on $score
902 =head2 SendStaticFile
904 Takes a File => path and a Type => Content-type
906 If Type isn't provided and File is an image, it will
907 figure out a sane Content-type, otherwise it will
908 send application/octet-stream
910 Will set caching headers using StaticFileHeaders
917 my $file = $args{File};
918 my $type = $args{Type};
919 my $relfile = $args{RelativeFile};
921 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
922 $HTML::Mason::Commands::r->status(400);
923 $HTML::Mason::Commands::m->abort;
926 $self->StaticFileHeaders();
929 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
931 $type =~ s/jpg/jpeg/gi;
933 $type ||= "application/octet-stream";
936 # CGI.pm version 3.51 and 3.52 bang charset=iso-8859-1 onto our JS
937 # since we don't specify a charset
938 if ( $type =~ m{application/javascript} &&
939 $type !~ m{charset=([\w-]+)$} ) {
940 $type .= "; charset=utf-8";
942 $HTML::Mason::Commands::r->content_type($type);
943 open( my $fh, '<', $file ) or die "couldn't open file: $!";
947 $HTML::Mason::Commands::m->out($_) while (<$fh>);
948 $HTML::Mason::Commands::m->flush_buffer;
955 my $content = $args{Content};
956 return '' unless $content;
958 # Make the content have no 'weird' newlines in it
959 $content =~ s/\r+\n/\n/g;
961 my $return_content = $content;
963 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
964 my $sigonly = $args{StripSignature};
966 # massage content to easily detect if there's any real content
967 $content =~ s/\s+//g; # yes! remove all the spaces
969 # remove html version of spaces and newlines
970 $content =~ s! !!g;
971 $content =~ s!<br/?>!!g;
974 # Filter empty content when type is text/html
975 return '' if $html && $content !~ /\S/;
977 # If we aren't supposed to strip the sig, just bail now.
978 return $return_content unless $sigonly;
981 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
984 # Check for plaintext sig
985 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
987 # Check for html-formatted sig; we don't use EscapeUTF8 here
988 # because we want to precisely match the escaping that FCKEditor
989 # uses. see also 311223f5, which fixed this for 4.0
996 and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
999 return $return_content;
1007 # if they've passed multiple values, they'll be an array. if they've
1008 # passed just one, a scalar whatever they are, mark them as utf8
1011 ? Encode::is_utf8($_)
1013 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
1014 : ( $type eq 'ARRAY' )
1015 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1017 : ( $type eq 'HASH' )
1018 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1024 sub PreprocessTimeUpdates {
1027 # Later in the code we use
1028 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1029 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
1030 # The call_next method pass through original arguments and if you have
1031 # an argument with unicode key then in a next component you'll get two
1032 # records in the args hash: one with key without UTF8 flag and another
1033 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
1034 # is copied from mason's source to get the same results as we get from
1035 # call_next method, this feature is not documented, so we just leave it
1036 # here to avoid possible side effects.
1038 # This code canonicalizes time inputs in hours into minutes
1039 foreach my $field ( keys %$ARGS ) {
1040 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1042 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1043 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1044 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1045 $ARGS->{$local} *= 60;
1047 delete $ARGS->{$field};
1052 sub MaybeEnableSQLStatementLog {
1054 my $log_sql_statements = RT->Config->Get('StatementLog');
1056 if ($log_sql_statements) {
1057 $RT::Handle->ClearSQLStatementLog;
1058 $RT::Handle->LogSQLStatements(1);
1063 sub LogRecordedSQLStatements {
1064 my $log_sql_statements = RT->Config->Get('StatementLog');
1066 return unless ($log_sql_statements);
1068 my @log = $RT::Handle->SQLStatementLog;
1069 $RT::Handle->ClearSQLStatementLog;
1070 for my $stmt (@log) {
1071 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1081 level => $log_sql_statements,
1083 . sprintf( "%.6f", $duration )
1085 . ( @bind ? " [ bound values: @{[map{qq|'$_'|} @bind]} ]" : "" )
1091 our %is_whitelisted_component = (
1092 # The RSS feed embeds an auth token in the path, but query
1093 # information for the search. Because it's a straight-up read, in
1094 # addition to embedding its own auth, it's fine.
1095 '/NoAuth/rss/dhandler' => 1,
1097 # IE doesn't send referer in window.open()
1098 # besides, as a harmless calendar select page, it's fine
1099 '/Helpers/CalPopup.html' => 1,
1101 # While both of these can be used for denial-of-service against RT
1102 # (construct a very inefficient query and trick lots of users into
1103 # running them against RT) it's incredibly useful to be able to link
1104 # to a search result or bookmark a result page.
1105 '/Search/Results.html' => 1,
1106 '/Search/Simple.html' => 1,
1109 # Components which are blacklisted from automatic, argument-based whitelisting.
1110 # These pages are not idempotent when called with just an id.
1111 our %is_blacklisted_component = (
1112 # Takes only id and toggles bookmark state
1113 '/Helpers/Toggle/TicketBookmark' => 1,
1116 sub IsCompCSRFWhitelisted {
1120 return 1 if $is_whitelisted_component{$comp};
1122 my %args = %{ $ARGS };
1124 # If the user specifies a *correct* user and pass then they are
1125 # golden. This acts on the presumption that external forms may
1126 # hardcode a username and password -- if a malicious attacker knew
1127 # both already, CSRF is the least of your problems.
1128 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1129 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1130 my $user_obj = RT::CurrentUser->new();
1131 $user_obj->Load($args{user});
1132 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1138 # Some pages aren't idempotent even with safe args like id; blacklist
1139 # them from the automatic whitelisting below.
1140 return 0 if $is_blacklisted_component{$comp};
1142 # Eliminate arguments that do not indicate an effectful request.
1143 # For example, "id" is acceptable because that is how RT retrieves a
1147 # If they have a valid results= from MaybeRedirectForResults, that's
1149 delete $args{results} if $args{results}
1150 and $HTML::Mason::Commands::session{"Actions"}->{$args{results}};
1152 # The homepage refresh, which uses the Refresh header, doesn't send
1153 # a referer in most browsers; whitelist the one parameter it reloads
1154 # with, HomeRefreshInterval, which is safe
1155 delete $args{HomeRefreshInterval};
1157 # If there are no arguments, then it's likely to be an idempotent
1158 # request, which are not susceptible to CSRF
1164 sub IsRefererCSRFWhitelisted {
1165 my $referer = _NormalizeHost(shift);
1166 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1167 $base_url = $base_url->host_port;
1170 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1171 push @$configs,$config;
1172 return 1 if $referer->host_port eq $config;
1175 return (0,$referer,$configs);
1178 =head3 _NormalizeHost
1180 Takes a URI and creates a URI object that's been normalized
1181 to handle common problems such as localhost vs 127.0.0.1
1185 sub _NormalizeHost {
1187 my $uri= URI->new(shift);
1188 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1194 sub IsPossibleCSRF {
1197 # If first request on this session is to a REST endpoint, then
1198 # whitelist the REST endpoints -- and explicitly deny non-REST
1199 # endpoints. We do this because using a REST cookie in a browser
1200 # would open the user to CSRF attacks to the REST endpoints.
1201 my $comp = $HTML::Mason::Commands::m->request_comp->path;
1202 $HTML::Mason::Commands::session{'REST'} = $comp =~ m{^/REST/\d+\.\d+/}
1203 unless defined $HTML::Mason::Commands::session{'REST'};
1205 if ($HTML::Mason::Commands::session{'REST'}) {
1206 return 0 if $comp =~ m{^/REST/\d+\.\d+/};
1208 This login session belongs to a REST client, and cannot be used to
1209 access non-REST interfaces of RT for security reasons.
1211 my $details = <<EOT;
1212 Please log out and back in to obtain a session for normal browsing. If
1213 you understand the security implications, disabling RT's CSRF protection
1214 will remove this restriction.
1217 HTML::Mason::Commands::Abort( $why, Details => $details );
1220 return 0 if IsCompCSRFWhitelisted( $comp, $ARGS );
1222 # if there is no Referer header then assume the worst
1224 "your browser did not supply a Referrer header", # loc
1225 ) if !$ENV{HTTP_REFERER};
1227 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1228 return 0 if $whitelisted;
1230 if ( @$configs > 1 ) {
1232 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1233 $browser->host_port,
1235 join(', ', @$configs) );
1239 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1240 $browser->host_port,
1244 sub ExpandCSRFToken {
1247 my $token = delete $ARGS->{CSRF_Token};
1248 return unless $token;
1250 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1251 return unless $data;
1252 return unless $data->{uri} eq $HTML::Mason::Commands::r->uri;
1254 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1255 return unless $user->ValidateAuthString( $data->{auth}, $token );
1257 %{$ARGS} = %{$data->{args}};
1259 # We explicitly stored file attachments with the request, but not in
1260 # the session yet, as that would itself be an attack. Put them into
1261 # the session now, so they'll be visible.
1262 if ($data->{attach}) {
1263 my $filename = $data->{attach}{filename};
1264 my $mime = $data->{attach}{mime};
1265 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1272 sub StoreRequestToken {
1275 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1276 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1278 auth => $user->GenerateAuthString( $token ),
1279 uri => $HTML::Mason::Commands::r->uri,
1282 if ($ARGS->{Attach}) {
1283 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1284 my $file_path = delete $ARGS->{'Attach'};
1286 filename => Encode::decode_utf8("$file_path"),
1287 mime => $attachment,
1291 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1292 $HTML::Mason::Commands::session{'i'}++;
1296 sub MaybeShowInterstitialCSRFPage {
1299 return unless RT->Config->Get('RestrictReferrer');
1301 # Deal with the form token provided by the interstitial, which lets
1302 # browsers which never set referer headers still use RT, if
1303 # painfully. This blows values into ARGS
1304 return if ExpandCSRFToken($ARGS);
1306 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1307 return if !$is_csrf;
1309 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1311 my $token = StoreRequestToken($ARGS);
1312 $HTML::Mason::Commands::m->comp(
1314 OriginalURL => $HTML::Mason::Commands::r->uri,
1315 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1318 # Calls abort, never gets here
1321 our @POTENTIAL_PAGE_ACTIONS = (
1322 qr'/Ticket/Create.html' => "create a ticket", # loc
1323 qr'/Ticket/' => "update a ticket", # loc
1324 qr'/Admin/' => "modify RT's configuration", # loc
1325 qr'/Approval/' => "update an approval", # loc
1326 qr'/Dashboards/' => "modify a dashboard", # loc
1327 qr'/m/ticket/' => "update a ticket", # loc
1328 qr'Prefs' => "modify your preferences", # loc
1329 qr'/Search/' => "modify or access a search", # loc
1330 qr'/SelfService/Create' => "create a ticket", # loc
1331 qr'/SelfService/' => "update a ticket", # loc
1334 sub PotentialPageAction {
1336 my @potentials = @POTENTIAL_PAGE_ACTIONS;
1337 while (my ($pattern, $result) = splice @potentials, 0, 2) {
1338 return HTML::Mason::Commands::loc($result)
1339 if $page =~ $pattern;
1344 package HTML::Mason::Commands;
1346 use vars qw/$r $m %session/;
1352 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1353 with whatever it's called with. If there is no $session{'CurrentUser'},
1354 it creates a temporary user, so we have something to get a localisation handle
1361 if ( $session{'CurrentUser'}
1362 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1364 return ( $session{'CurrentUser'}->loc(@_) );
1367 RT::CurrentUser->new();
1371 return ( $u->loc(@_) );
1374 # pathetic case -- SystemUser is gone.
1383 =head2 loc_fuzzy STRING
1385 loc_fuzzy is for handling localizations of messages that may already
1386 contain interpolated variables, typically returned from libraries
1387 outside RT's control. It takes the message string and extracts the
1388 variable array automatically by matching against the candidate entries
1389 inside the lexicon file.
1396 if ( $session{'CurrentUser'}
1397 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1399 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1401 my $u = RT::CurrentUser->new( $RT::SystemUser->Id );
1402 return ( $u->loc_fuzzy($msg) );
1409 # Error - calls Error and aborts
1414 if ( $session{'ErrorDocument'}
1415 && $session{'ErrorDocumentType'} )
1417 $r->content_type( $session{'ErrorDocumentType'} );
1418 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1421 $m->comp( "/Elements/Error", Why => $why, %args );
1428 # {{{ sub CreateTicket
1430 =head2 CreateTicket ARGS
1432 Create a new ticket, using Mason's %ARGS. returns @results.
1441 my $Ticket = new RT::Ticket( $session{'CurrentUser'} );
1443 my $Queue = new RT::Queue( $session{'CurrentUser'} );
1444 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1445 Abort('Queue not found');
1448 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1449 Abort('You have no permission to create tickets in that queue.');
1453 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1454 $due = new RT::Date( $session{'CurrentUser'} );
1455 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1458 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1459 $starts = new RT::Date( $session{'CurrentUser'} );
1460 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1463 my $sigless = RT::Interface::Web::StripContent(
1464 Content => $ARGS{Content},
1465 ContentType => $ARGS{ContentType},
1466 StripSignature => 1,
1467 CurrentUser => $session{'CurrentUser'},
1470 my $MIMEObj = MakeMIMEEntity(
1471 Subject => $ARGS{'Subject'},
1472 From => $ARGS{'From'},
1475 Type => $ARGS{'ContentType'},
1478 if ( $ARGS{'Attachments'} ) {
1479 my $rv = $MIMEObj->make_multipart;
1480 $RT::Logger->error("Couldn't make multipart message")
1481 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1483 foreach ( values %{ $ARGS{'Attachments'} } ) {
1485 $RT::Logger->error("Couldn't add empty attachemnt");
1488 $MIMEObj->add_part($_);
1492 for my $argument (qw(Encrypt Sign)) {
1493 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
1497 Type => $ARGS{'Type'} || 'ticket',
1498 Queue => $ARGS{'Queue'},
1499 Owner => $ARGS{'Owner'},
1502 Requestor => $ARGS{'Requestors'},
1504 AdminCc => $ARGS{'AdminCc'},
1505 InitialPriority => $ARGS{'InitialPriority'},
1506 FinalPriority => $ARGS{'FinalPriority'},
1507 TimeLeft => $ARGS{'TimeLeft'},
1508 TimeEstimated => $ARGS{'TimeEstimated'},
1509 TimeWorked => $ARGS{'TimeWorked'},
1510 Subject => $ARGS{'Subject'},
1511 Status => $ARGS{'Status'},
1512 Due => $due ? $due->ISO : undef,
1513 Starts => $starts ? $starts->ISO : undef,
1518 foreach my $type (qw(Requestor Cc AdminCc)) {
1519 push @temp_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1520 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1524 if (@temp_squelch) {
1525 require RT::Action::SendEmail;
1526 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1529 if ( $ARGS{'AttachTickets'} ) {
1530 require RT::Action::SendEmail;
1531 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1532 ref $ARGS{'AttachTickets'}
1533 ? @{ $ARGS{'AttachTickets'} }
1534 : ( $ARGS{'AttachTickets'} ) );
1537 foreach my $arg ( keys %ARGS ) {
1538 next if $arg =~ /-(?:Magic|Category)$/;
1540 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1541 $create_args{$arg} = $ARGS{$arg};
1544 # Object-RT::Ticket--CustomField-3-Values
1545 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1548 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1549 $cf->SetContextObject( $Queue );
1551 unless ( $cf->id ) {
1552 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1556 if ( $arg =~ /-Upload$/ ) {
1557 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1561 my $type = $cf->Type;
1564 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1565 @values = @{ $ARGS{$arg} };
1566 } elsif ( $type =~ /text/i ) {
1567 @values = ( $ARGS{$arg} );
1569 no warnings 'uninitialized';
1570 @values = split /\r*\n/, $ARGS{$arg};
1572 @values = grep length, map {
1578 grep defined, @values;
1580 $create_args{"CustomField-$cfid"} = \@values;
1584 # turn new link lists into arrays, and pass in the proper arguments
1586 'new-DependsOn' => 'DependsOn',
1587 'DependsOn-new' => 'DependedOnBy',
1588 'new-MemberOf' => 'Parents',
1589 'MemberOf-new' => 'Children',
1590 'new-RefersTo' => 'RefersTo',
1591 'RefersTo-new' => 'ReferredToBy',
1593 foreach my $key ( keys %map ) {
1594 next unless $ARGS{$key};
1595 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1599 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1604 push( @Actions, split( "\n", $ErrMsg ) );
1605 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1606 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1608 return ( $Ticket, @Actions );
1614 # {{{ sub LoadTicket - loads a ticket
1616 =head2 LoadTicket id
1618 Takes a ticket id as its only variable. if it's handed an array, it takes
1621 Returns an RT::Ticket object as the current user.
1628 if ( ref($id) eq "ARRAY" ) {
1633 Abort("No ticket specified");
1636 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1638 unless ( $Ticket->id ) {
1639 Abort("Could not load ticket $id");
1646 # {{{ sub ProcessUpdateMessage
1648 =head2 ProcessUpdateMessage
1650 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1652 Don't write message if it only contains current user's signature and
1653 SkipSignatureOnly argument is true. Function anyway adds attachments
1654 and updates time worked field even if skips message. The default value
1659 sub ProcessUpdateMessage {
1664 SkipSignatureOnly => 1,
1668 if ( $args{ARGSRef}->{'UpdateAttachments'}
1669 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1671 delete $args{ARGSRef}->{'UpdateAttachments'};
1674 # Strip the signature
1675 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1676 Content => $args{ARGSRef}->{UpdateContent},
1677 ContentType => $args{ARGSRef}->{UpdateContentType},
1678 StripSignature => $args{SkipSignatureOnly},
1679 CurrentUser => $args{'TicketObj'}->CurrentUser,
1682 # If, after stripping the signature, we have no message, move the
1683 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1684 # ProcessBasics can deal -- then bail out.
1685 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1686 and not length $args{ARGSRef}->{'UpdateContent'} )
1688 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1689 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1694 if ( $args{ARGSRef}->{'UpdateSubject'} eq $args{'TicketObj'}->Subject ) {
1695 $args{ARGSRef}->{'UpdateSubject'} = undef;
1698 my $Message = MakeMIMEEntity(
1699 Subject => $args{ARGSRef}->{'UpdateSubject'},
1700 Body => $args{ARGSRef}->{'UpdateContent'},
1701 Type => $args{ARGSRef}->{'UpdateContentType'},
1704 $Message->head->add( 'Message-ID' => Encode::encode_utf8(
1705 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1707 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1708 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1709 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1711 $old_txn = $args{TicketObj}->Transactions->First();
1714 if ( my $msg = $old_txn->Message->First ) {
1715 RT::Interface::Email::SetInReplyTo(
1716 Message => $Message,
1721 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1722 $Message->make_multipart;
1723 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
1726 if ( $args{ARGSRef}->{'AttachTickets'} ) {
1727 require RT::Action::SendEmail;
1728 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1729 ref $args{ARGSRef}->{'AttachTickets'}
1730 ? @{ $args{ARGSRef}->{'AttachTickets'} }
1731 : ( $args{ARGSRef}->{'AttachTickets'} ) );
1734 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
1735 my $cc = $args{ARGSRef}->{'UpdateCc'};
1737 my %txn_customfields;
1739 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1740 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1741 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1745 my %message_args = (
1747 BccMessageTo => $bcc,
1748 Sign => $args{ARGSRef}->{'Sign'},
1749 Encrypt => $args{ARGSRef}->{'Encrypt'},
1750 MIMEObj => $Message,
1751 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
1752 CustomFields => \%txn_customfields,
1756 foreach my $type (qw(Cc AdminCc)) {
1757 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1758 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{$type} );
1759 push @temp_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
1760 push @temp_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
1763 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
1764 push @temp_squelch, map $_->address, Email::Address->parse( $message_args{Requestor} );
1765 push @temp_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
1768 if (@temp_squelch) {
1769 require RT::Action::SendEmail;
1770 RT::Action::SendEmail->SquelchMailTo( RT::Action::SendEmail->SquelchMailTo, @temp_squelch );
1773 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
1774 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1775 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
1777 my $var = ucfirst($1) . 'MessageTo';
1779 if ( $message_args{$var} ) {
1780 $message_args{$var} .= ", $value";
1782 $message_args{$var} = $value;
1788 # Do the update via the appropriate Ticket method
1789 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
1790 my ( $Transaction, $Description, $Object ) =
1791 $args{TicketObj}->Comment(%message_args);
1792 push( @results, $Description );
1793 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1794 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
1795 my ( $Transaction, $Description, $Object ) =
1796 $args{TicketObj}->Correspond(%message_args);
1797 push( @results, $Description );
1798 #$Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
1801 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
1808 # {{{ sub MakeMIMEEntity
1810 =head2 MakeMIMEEntity PARAMHASH
1812 Takes a paramhash Subject, Body and AttachmentFieldName.
1814 Also takes Form, Cc and Type as optional paramhash keys.
1816 Returns a MIME::Entity.
1820 sub MakeMIMEEntity {
1822 #TODO document what else this takes.
1828 AttachmentFieldName => undef,
1832 my $Message = MIME::Entity->build(
1833 Type => 'multipart/mixed',
1834 map { $_ => Encode::encode_utf8( $args{ $_} ) }
1835 grep defined $args{$_}, qw(Subject From Cc)
1838 if ( defined $args{'Body'} && length $args{'Body'} ) {
1840 # Make the update content have no 'weird' newlines in it
1841 $args{'Body'} =~ s/\r\n/\n/gs;
1844 Type => $args{'Type'} || 'text/plain',
1846 Data => $args{'Body'},
1850 if ( $args{'AttachmentFieldName'} ) {
1852 my $cgi_object = $m->cgi_object;
1854 if ( my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ) ) {
1856 my ( @content, $buffer );
1857 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
1858 push @content, $buffer;
1861 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
1863 # Prefer the cached name first over CGI.pm stringification.
1864 my $filename = $RT::Mason::CGI::Filename;
1865 $filename = "$filehandle" unless defined $filename;
1866 $filename = Encode::encode_utf8( $filename );
1867 $filename =~ s{^.*[\\/]}{};
1870 Type => $uploadinfo->{'Content-Type'},
1871 Filename => $filename,
1874 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
1875 $Message->head->set( 'Subject' => $filename );
1880 $Message->make_singlepart;
1882 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
1890 # {{{ sub ParseDateToISO
1892 =head2 ParseDateToISO
1894 Takes a date in an arbitrary format.
1895 Returns an ISO date and time in GMT
1899 sub ParseDateToISO {
1902 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
1904 Format => 'unknown',
1907 return ( $date_obj->ISO );
1912 # {{{ sub ProcessACLChanges
1914 sub ProcessACLChanges {
1915 my $ARGSref = shift;
1919 foreach my $arg ( keys %$ARGSref ) {
1920 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
1922 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
1925 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
1926 @rights = @{ $ARGSref->{$arg} };
1928 @rights = $ARGSref->{$arg};
1930 @rights = grep $_, @rights;
1931 next unless @rights;
1933 my $principal = RT::Principal->new( $session{'CurrentUser'} );
1934 $principal->Load($principal_id);
1937 if ( $object_type eq 'RT::System' ) {
1939 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
1940 $obj = $object_type->new( $session{'CurrentUser'} );
1941 $obj->Load($object_id);
1942 unless ( $obj->id ) {
1943 $RT::Logger->error("couldn't load $object_type #$object_id");
1947 $RT::Logger->error("object type '$object_type' is incorrect");
1948 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
1952 foreach my $right (@rights) {
1953 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
1954 push( @results, $msg );
1963 # {{{ sub UpdateRecordObj
1965 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
1967 @attribs is a list of ticket fields to check and update if they differ from the B<Object>'s current values. ARGSRef is a ref to HTML::Mason's %ARGS.
1969 Returns an array of success/failure messages
1973 sub UpdateRecordObject {
1976 AttributesRef => undef,
1978 AttributePrefix => undef,
1982 my $Object = $args{'Object'};
1983 my @results = $Object->Update(
1984 AttributesRef => $args{'AttributesRef'},
1985 ARGSRef => $args{'ARGSRef'},
1986 AttributePrefix => $args{'AttributePrefix'},
1994 # {{{ Sub ProcessCustomFieldUpdates
1996 sub ProcessCustomFieldUpdates {
1998 CustomFieldObj => undef,
2003 my $Object = $args{'CustomFieldObj'};
2004 my $ARGSRef = $args{'ARGSRef'};
2006 my @attribs = qw(Name Type Description Queue SortOrder);
2007 my @results = UpdateRecordObject(
2008 AttributesRef => \@attribs,
2013 my $prefix = "CustomField-" . $Object->Id;
2014 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2015 my ( $addval, $addmsg ) = $Object->AddValue(
2016 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2017 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2018 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2020 push( @results, $addmsg );
2024 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2025 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2026 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2028 foreach my $id (@delete_values) {
2029 next unless defined $id;
2030 my ( $err, $msg ) = $Object->DeleteValue($id);
2031 push( @results, $msg );
2034 my $vals = $Object->Values();
2035 while ( my $cfv = $vals->Next() ) {
2036 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2037 if ( $cfv->SortOrder != $so ) {
2038 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2039 push( @results, $msg );
2049 # {{{ sub ProcessTicketBasics
2051 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2053 Returns an array of results messages.
2057 sub ProcessTicketBasics {
2065 my $TicketObj = $args{'TicketObj'};
2066 my $ARGSRef = $args{'ARGSRef'};
2068 # {{{ Set basic fields
2081 if ( $ARGSRef->{'Queue'} and ( $ARGSRef->{'Queue'} !~ /^(\d+)$/ ) ) {
2082 my $tempqueue = RT::Queue->new($RT::SystemUser);
2083 $tempqueue->Load( $ARGSRef->{'Queue'} );
2084 if ( $tempqueue->id ) {
2085 $ARGSRef->{'Queue'} = $tempqueue->id;
2089 # Status isn't a field that can be set to a null value.
2090 # RT core complains if you try
2091 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2093 my @results = UpdateRecordObject(
2094 AttributesRef => \@attribs,
2095 Object => $TicketObj,
2096 ARGSRef => $ARGSRef,
2099 # We special case owner changing, so we can use ForceOwnerChange
2100 if ( $ARGSRef->{'Owner'} && ( $TicketObj->Owner != $ARGSRef->{'Owner'} ) ) {
2102 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2103 $ChownType = "Force";
2105 $ChownType = "Give";
2108 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2109 push( @results, $msg );
2119 sub ProcessTicketCustomFieldUpdates {
2121 $args{'Object'} = delete $args{'TicketObj'};
2122 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2124 # Build up a list of objects that we want to work with
2125 my %custom_fields_to_mod;
2126 foreach my $arg ( keys %$ARGSRef ) {
2127 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2128 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2129 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2130 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2131 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2132 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2136 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2139 sub ProcessObjectCustomFieldUpdates {
2141 my $ARGSRef = $args{'ARGSRef'};
2144 # Build up a list of objects that we want to work with
2145 my %custom_fields_to_mod;
2146 foreach my $arg ( keys %$ARGSRef ) {
2148 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2149 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2151 # For each of those objects, find out what custom fields we want to work with.
2152 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2155 # For each of those objects
2156 foreach my $class ( keys %custom_fields_to_mod ) {
2157 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2158 my $Object = $args{'Object'};
2159 $Object = $class->new( $session{'CurrentUser'} )
2160 unless $Object && ref $Object eq $class;
2162 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2163 unless ( $Object->id ) {
2164 $RT::Logger->warning("Couldn't load object $class #$id");
2168 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2169 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2170 $CustomFieldObj->SetContextObject($Object);
2171 $CustomFieldObj->LoadById($cf);
2172 unless ( $CustomFieldObj->id ) {
2173 $RT::Logger->warning("Couldn't load custom field #$cf");
2177 _ProcessObjectCustomFieldUpdates(
2178 Prefix => "Object-$class-$id-CustomField-$cf-",
2180 CustomField => $CustomFieldObj,
2181 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2189 sub _ProcessObjectCustomFieldUpdates {
2191 my $cf = $args{'CustomField'};
2192 my $cf_type = $cf->Type;
2194 # Remove blank Values since the magic field will take care of this. Sometimes
2195 # the browser gives you a blank value which causes CFs to be processed twice
2196 if ( defined $args{'ARGS'}->{'Values'}
2197 && !length $args{'ARGS'}->{'Values'}
2198 && $args{'ARGS'}->{'Values-Magic'} )
2200 delete $args{'ARGS'}->{'Values'};
2204 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2206 # skip category argument
2207 next if $arg eq 'Category';
2210 next if $arg eq 'Value-TimeUnits';
2212 # since http won't pass in a form element with a null value, we need
2214 if ( $arg eq 'Values-Magic' ) {
2216 # We don't care about the magic, if there's really a values element;
2217 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2218 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2220 # "Empty" values does not mean anything for Image and Binary fields
2221 next if $cf_type =~ /^(?:Image|Binary)$/;
2224 $args{'ARGS'}->{'Values'} = undef;
2228 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2229 @values = @{ $args{'ARGS'}->{$arg} };
2230 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2231 @values = ( $args{'ARGS'}->{$arg} );
2233 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2234 if defined $args{'ARGS'}->{$arg};
2236 @values = grep length, map {
2242 grep defined, @values;
2244 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2245 foreach my $value (@values) {
2246 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2250 push( @results, $msg );
2252 } elsif ( $arg eq 'Upload' ) {
2253 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2254 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2255 push( @results, $msg );
2256 } elsif ( $arg eq 'DeleteValues' ) {
2257 foreach my $value (@values) {
2258 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2262 push( @results, $msg );
2264 } elsif ( $arg eq 'DeleteValueIds' ) {
2265 foreach my $value (@values) {
2266 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2270 push( @results, $msg );
2272 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2273 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2276 foreach my $value (@values) {
2277 if ( my $entry = $cf_values->HasEntry($value) ) {
2278 $values_hash{ $entry->id } = 1;
2282 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2286 push( @results, $msg );
2287 $values_hash{$val} = 1 if $val;
2290 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2291 return @results if ( $cf->Type eq 'Date' && ! @values );
2293 $cf_values->RedoSearch;
2294 while ( my $cf_value = $cf_values->Next ) {
2295 next if $values_hash{ $cf_value->id };
2297 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2299 ValueId => $cf_value->id
2301 push( @results, $msg );
2303 } elsif ( $arg eq 'Values' ) {
2304 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2306 # keep everything up to the point of difference, delete the rest
2308 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2309 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2318 # now add/replace extra things, if any
2319 foreach my $value (@values) {
2320 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2324 push( @results, $msg );
2329 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2330 $cf->Name, ref $args{'Object'},
2339 # {{{ sub ProcessTicketWatchers
2341 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2343 Returns an array of results messages.
2347 sub ProcessTicketWatchers {
2355 my $Ticket = $args{'TicketObj'};
2356 my $ARGSRef = $args{'ARGSRef'};
2360 foreach my $key ( keys %$ARGSRef ) {
2362 # Delete deletable watchers
2363 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2364 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2368 push @results, $msg;
2371 # Delete watchers in the simple style demanded by the bulk manipulator
2372 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2373 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2374 Email => $ARGSRef->{$key},
2377 push @results, $msg;
2380 # Add new wathchers by email address
2381 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2382 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2385 #They're in this order because otherwise $1 gets clobbered :/
2386 my ( $code, $msg ) = $Ticket->AddWatcher(
2387 Type => $ARGSRef->{$key},
2388 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2390 push @results, $msg;
2393 #Add requestors in the simple style demanded by the bulk manipulator
2394 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2395 my ( $code, $msg ) = $Ticket->AddWatcher(
2397 Email => $ARGSRef->{$key}
2399 push @results, $msg;
2402 # Add new watchers by owner
2403 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2404 my $principal_id = $1;
2405 my $form = $ARGSRef->{$key};
2406 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2407 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2409 my ( $code, $msg ) = $Ticket->AddWatcher(
2411 PrincipalId => $principal_id
2413 push @results, $msg;
2423 # {{{ sub ProcessTicketDates
2425 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2427 Returns an array of results messages.
2431 sub ProcessTicketDates {
2438 my $Ticket = $args{'TicketObj'};
2439 my $ARGSRef = $args{'ARGSRef'};
2443 # {{{ Set date fields
2444 my @date_fields = qw(
2452 #Run through each field in this list. update the value if apropriate
2453 foreach my $field (@date_fields) {
2454 next unless exists $ARGSRef->{ $field . '_Date' };
2455 next if $ARGSRef->{ $field . '_Date' } eq '';
2459 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2461 Format => 'unknown',
2462 Value => $ARGSRef->{ $field . '_Date' }
2465 my $obj = $field . "Obj";
2466 if ( ( defined $DateObj->Unix )
2467 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
2469 my $method = "Set$field";
2470 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
2471 push @results, "$msg";
2481 # {{{ sub ProcessTicketLinks
2483 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2485 Returns an array of results messages.
2489 sub ProcessTicketLinks {
2496 my $Ticket = $args{'TicketObj'};
2497 my $ARGSRef = $args{'ARGSRef'};
2499 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
2501 #Merge if we need to
2502 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
2503 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
2504 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
2505 push @results, $msg;
2513 sub ProcessRecordLinks {
2520 my $Record = $args{'RecordObj'};
2521 my $ARGSRef = $args{'ARGSRef'};
2525 # Delete links that are gone gone gone.
2526 foreach my $arg ( keys %$ARGSRef ) {
2527 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
2532 my ( $val, $msg ) = $Record->DeleteLink(
2538 push @results, $msg;
2544 my @linktypes = qw( DependsOn MemberOf RefersTo );
2546 foreach my $linktype (@linktypes) {
2547 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
2548 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
2549 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
2551 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
2553 $luri =~ s/\s+$//; # Strip trailing whitespace
2554 my ( $val, $msg ) = $Record->AddLink(
2558 push @results, $msg;
2561 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
2562 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
2563 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
2565 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
2567 my ( $val, $msg ) = $Record->AddLink(
2572 push @results, $msg;
2580 =head2 _UploadedFile ( $arg );
2582 Takes a CGI parameter name; if a file is uploaded under that name,
2583 return a hash reference suitable for AddCustomFieldValue's use:
2584 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
2586 Returns C<undef> if no files were uploaded in the C<$arg> field.
2592 my $cgi_object = $m->cgi_object;
2593 my $fh = $cgi_object->upload($arg) or return undef;
2594 my $upload_info = $cgi_object->uploadInfo($fh);
2596 my $filename = "$fh";
2597 $filename =~ s#^.*[\\/]##;
2602 LargeContent => do { local $/; scalar <$fh> },
2603 ContentType => $upload_info->{'Content-Type'},
2607 sub GetColumnMapEntry {
2608 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
2610 # deal with the simplest thing first
2611 if ( $args{'Map'}{ $args{'Name'} } ) {
2612 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
2616 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
2617 return undef unless $args{'Map'}->{$mainkey};
2618 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
2619 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
2621 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
2626 sub ProcessColumnMapValue {
2628 my %args = ( Arguments => [], Escape => 1, @_ );
2631 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
2632 my @tmp = $value->( @{ $args{'Arguments'} } );
2633 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
2634 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
2635 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
2636 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
2641 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
2645 =head2 _load_container_object ( $type, $id );
2647 Instantiate container object for saving searches.
2651 sub _load_container_object {
2652 my ( $obj_type, $obj_id ) = @_;
2653 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
2656 =head2 _parse_saved_search ( $arg );
2658 Given a serialization string for saved search, and returns the
2659 container object and the search id.
2663 sub _parse_saved_search {
2665 return unless $spec;
2666 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
2673 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
2676 =head2 ScrubHTML content
2678 Removes unsafe and undesired HTML from the passed content
2684 my $Content = shift;
2685 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
2687 $Content = '' if !defined($Content);
2688 return $SCRUBBER->scrub($Content);
2693 Returns a new L<HTML::Scrubber> object.
2695 If you need to be more lax about what HTML tags and attributes are allowed,
2696 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
2699 package HTML::Mason::Commands;
2700 # Let tables through
2701 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
2706 our @SCRUBBER_ALLOWED_TAGS = qw(
2707 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
2708 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE
2711 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
2712 # Match http, ftp and relative urls
2713 # XXX: we also scrub format strings with this module then allow simple config options
2714 href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i,
2720 (?:(?:background-)?color: \s*
2721 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
2722 \#[a-f0-9]{3,6} | # #fff or #ffffff
2723 [\w\-]+ # green, light-blue, etc.
2725 text-align: \s* \w+ |
2726 font-size: \s* [\w.\-]+ |
2727 font-family: \s* [\w\s"',.\-]+ |
2728 font-weight: \s* [\w\-]+ |
2730 # MS Office styles, which are probably fine. If we don't, then any
2731 # associated styles in the same attribute get stripped.
2732 mso-[\w\-]+?: \s* [\w\s"',.\-]+
2734 +$ # one or more of these allowed properties from here 'till sunset
2738 our %SCRUBBER_RULES = ();
2741 require HTML::Scrubber;
2742 my $scrubber = HTML::Scrubber->new();
2746 %SCRUBBER_ALLOWED_ATTRIBUTES,
2747 '*' => 0, # require attributes be explicitly allowed
2750 $scrubber->deny(qw[*]);
2751 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
2752 $scrubber->rules(%SCRUBBER_RULES);
2754 # Scrubbing comments is vital since IE conditional comments can contain
2755 # arbitrary HTML and we'd pass it right on through.
2756 $scrubber->comment(0);
2761 package RT::Interface::Web;
2762 RT::Base->_ImportOverlays();