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::Menu;
69 use RT::Interface::Web::Session;
72 use List::MoreUtils qw();
75 =head2 SquishedCSS $style
81 my $style = shift or die "need name";
82 return $SQUISHED_CSS{$style} if $SQUISHED_CSS{$style};
83 require RT::Squish::CSS;
84 my $css = RT::Squish::CSS->new( Style => $style );
85 $SQUISHED_CSS{ $css->Style } = $css;
95 return $SQUISHED_JS if $SQUISHED_JS;
97 require RT::Squish::JS;
98 my $js = RT::Squish::JS->new();
105 Removes the cached CSS and JS entries, forcing them to be regenerated
115 =head2 EscapeUTF8 SCALARREF
117 does a css-busting but minimalist escaping of whatever html you're passing in.
123 return unless defined $$ref;
125 $$ref =~ s/&/&/g;
128 $$ref =~ s/\(/(/g;
129 $$ref =~ s/\)/)/g;
130 $$ref =~ s/"/"/g;
131 $$ref =~ s/'/'/g;
136 =head2 EscapeURI SCALARREF
138 Escapes URI component according to RFC2396
144 return unless defined $$ref;
147 $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg;
150 =head2 EncodeJSON SCALAR
152 Encodes the SCALAR to JSON and returns a JSON string. SCALAR may be a simple
153 value or a reference.
158 JSON::to_json(shift, { utf8 => 1, allow_nonref => 1 });
161 sub _encode_surrogates {
162 my $uni = $_[0] - 0x10000;
163 return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
168 return unless defined $$ref;
170 $$ref = "'" . join('',
172 chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) :
173 $_ <= 255 ? sprintf("\\x%02X", $_) :
174 $_ <= 65535 ? sprintf("\\u%04X", $_) :
175 sprintf("\\u%X\\u%X", _encode_surrogates($_))
176 } unpack('U*', $$ref))
180 =head2 WebCanonicalizeInfo();
182 Different web servers set different environmental varibles. This
183 function must return something suitable for REMOTE_USER. By default,
184 just downcase $ENV{'REMOTE_USER'}
188 sub WebCanonicalizeInfo {
189 return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'};
194 =head2 WebExternalAutoInfo($user);
196 Returns a hash of user attributes, used when WebExternalAuto is set.
200 sub WebExternalAutoInfo {
205 # default to making Privileged users, even if they specify
206 # some other default Attributes
207 if ( !$RT::AutoCreate
208 || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) )
210 $user_info{'Privileged'} = 1;
213 if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) {
215 # Populate fields with information from Unix /etc/passwd
217 my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ];
218 $user_info{'Comments'} = $comments if defined $comments;
219 $user_info{'RealName'} = $realname if defined $realname;
220 } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) {
222 # Populate fields with information from NT domain controller
225 # and return the wad of stuff
233 if (RT->Config->Get('DevelMode')) {
234 require Module::Refresh;
235 Module::Refresh->refresh;
238 $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8");
240 $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ];
242 # Roll back any dangling transactions from a previous failed connection
243 $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth;
245 MaybeEnableSQLStatementLog();
247 # avoid reentrancy, as suggested by masonbook
248 local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest;
250 $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') )
251 if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') );
256 local $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
257 PreprocessTimeUpdates($ARGS);
260 MaybeShowInstallModePage();
262 $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS );
265 if ( _UserLoggedIn() ) {
266 # make user info up to date
267 $HTML::Mason::Commands::session{'CurrentUser'}
268 ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id );
269 undef $HTML::Mason::Commands::session{'CurrentUser'}->{'LangHandle'};
272 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
275 # Process session-related callbacks before any auth attempts
276 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' );
278 MaybeRejectPrivateComponentRequest();
280 MaybeShowNoAuthPage($ARGS);
282 AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn();
284 _ForceLogout() unless _UserLoggedIn();
286 # Process per-page authentication callbacks
287 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' );
289 if ( $ARGS->{'NotMobile'} ) {
290 $HTML::Mason::Commands::session{'NotMobile'} = 1;
293 unless ( _UserLoggedIn() ) {
296 # Authenticate if the user is trying to login via user/pass query args
297 my ($authed, $msg) = AttemptPasswordAuthentication($ARGS);
300 my $m = $HTML::Mason::Commands::m;
302 # REST urls get a special 401 response
303 if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) {
304 $HTML::Mason::Commands::r->content_type("text/plain");
305 $m->error_format("text");
306 $m->out("RT/$RT::VERSION 401 Credentials required\n");
307 $m->out("\n$msg\n") if $msg;
310 # Specially handle /index.html and /m/index.html so that we get a nicer URL
311 elsif ( $m->request_comp->path =~ m{^(/m)?/index\.html$} ) {
312 my $mobile = $1 ? 1 : 0;
313 my $next = SetNextPage($ARGS);
314 $m->comp('/NoAuth/Login.html',
321 TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef));
326 MaybeShowInterstitialCSRFPage($ARGS);
328 # now it applies not only to home page, but any dashboard that can be used as a workspace
329 $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'}
330 if ( $ARGS->{'HomeRefreshInterval'} );
332 # Process per-page global callbacks
333 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' );
335 ShowRequestedPage($ARGS);
336 LogRecordedSQLStatements(RequestData => {
337 Path => $HTML::Mason::Commands::m->request_path,
340 # Process per-page final cleanup callbacks
341 $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' );
343 $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS )
344 unless $HTML::Mason::Commands::r->content_type
345 =~ qr<^(text|application)/(x-)?(css|javascript)>;
350 delete $HTML::Mason::Commands::session{'CurrentUser'};
354 if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) {
362 =head2 LoginError ERROR
364 Pushes a login error into the Actions session store and returns the hash key.
370 my $key = Digest::MD5::md5_hex( rand(1024) );
371 push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new;
372 $HTML::Mason::Commands::session{'i'}++;
376 =head2 SetNextPage ARGSRef [PATH]
378 Intuits and stashes the next page in the sesssion hash. If PATH is
379 specified, uses that instead of the value of L<IntuitNextPage()>. Returns
386 my $next = $_[0] ? $_[0] : IntuitNextPage();
387 my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024));
388 my $page = { url => $next };
390 # If an explicit URL was passed and we didn't IntuitNextPage, then
391 # IsPossibleCSRF below is almost certainly unrelated to the actual
392 # destination. Currently explicit next pages aren't used in RT, but the
394 if (not $_[0] and RT->Config->Get("RestrictReferrer")) {
395 # This isn't really CSRF, but the CSRF heuristics are useful for catching
396 # requests which may have unintended side-effects.
397 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
400 "Marking original destination as having side-effects before redirecting for login.\n"
402 ."Reason: " . HTML::Mason::Commands::loc($msg, @loc)
404 $page->{'HasSideEffects'} = [$msg, @loc];
408 $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page;
409 $HTML::Mason::Commands::session{'i'}++;
413 =head2 FetchNextPage HASHKEY
415 Returns the stashed next page hashref for the given hash.
420 my $hash = shift || "";
421 return $HTML::Mason::Commands::session{'NextPage'}->{$hash};
424 =head2 RemoveNextPage HASHKEY
426 Removes the stashed next page for the given hash and returns it.
431 my $hash = shift || "";
432 return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash};
435 =head2 TangentForLogin ARGSRef [HASH]
437 Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as
438 the next page. Takes a hashref of request %ARGS as the first parameter.
439 Optionally takes all other parameters as a hash which is dumped into query
444 sub TangentForLogin {
446 my $hash = SetNextPage($ARGS);
447 my %query = (@_, next => $hash);
450 if $HTML::Mason::Commands::m->request_comp->path =~ m{^/m(/|$)};
452 my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?';
453 $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query);
457 =head2 TangentForLoginWithError ERROR
459 Localizes the passed error message, stashes it with L<LoginError> and then
460 calls L<TangentForLogin> with the appropriate results key.
464 sub TangentForLoginWithError {
466 my $key = LoginError(HTML::Mason::Commands::loc(@_));
467 TangentForLogin( $ARGS, results => $key );
470 =head2 IntuitNextPage
472 Attempt to figure out the path to which we should return the user after a
473 tangent. The current request URL is used, or failing that, the C<WebURL>
474 configuration variable.
481 # This includes any query parameters. Redirect will take care of making
482 # it an absolute URL.
483 if ($ENV{'REQUEST_URI'}) {
484 $req_uri = $ENV{'REQUEST_URI'};
486 # collapse multiple leading slashes so the first part doesn't look like
487 # a hostname of a schema-less URI
488 $req_uri =~ s{^/+}{/};
491 my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL');
494 my $uri = URI->new($next);
496 # You get undef scheme with a relative uri like "/Search/Build.html"
497 unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') {
498 $next = RT->Config->Get('WebURL');
501 # Make sure we're logging in to the same domain
502 # You can get an undef authority with a relative uri like "index.html"
503 my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL'));
504 unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) {
505 $next = RT->Config->Get('WebURL');
511 =head2 MaybeShowInstallModePage
513 This function, called exclusively by RT's autohandler, dispatches
514 a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file.
516 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
520 sub MaybeShowInstallModePage {
521 return unless RT->InstallMode;
523 my $m = $HTML::Mason::Commands::m;
524 if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) {
526 } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) {
527 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" );
534 =head2 MaybeShowNoAuthPage \%ARGS
536 This function, called exclusively by RT's autohandler, dispatches
537 a request to the page a user requested (but only if it matches the "noauth" regex.
539 If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler
543 sub MaybeShowNoAuthPage {
546 my $m = $HTML::Mason::Commands::m;
548 return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex');
550 # Don't show the login page to logged in users
551 Redirect(RT->Config->Get('WebURL'))
552 if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn();
554 # If it's a noauth file, don't ask for auth.
555 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
559 =head2 MaybeRejectPrivateComponentRequest
561 This function will reject calls to private components, like those under
562 C</Elements>. If the requested path is a private component then we will
563 abort with a C<403> error.
567 sub MaybeRejectPrivateComponentRequest {
568 my $m = $HTML::Mason::Commands::m;
569 my $path = $m->request_comp->path;
571 # We do not check for dhandler here, because requesting our dhandlers
572 # directly is okay. Mason will invoke the dhandler with a dhandler_arg of
578 _elements | # mobile UI
581 autohandler | # requesting this directly is suspicious
582 l (_unsafe)? ) # loc component
583 ( $ | / ) # trailing slash or end of path
585 && $path !~ m{ /RTx/Statistics/\w+/Elements/Chart }xi
588 warn "rejecting private component $path\n";
596 $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new());
597 $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new());
598 $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new());
603 =head2 ShowRequestedPage \%ARGS
605 This function, called exclusively by RT's autohandler, dispatches
606 a request to the page a user requested (making sure that unpriviled users
607 can only see self-service pages.
611 sub ShowRequestedPage {
614 my $m = $HTML::Mason::Commands::m;
616 # Ensure that the cookie that we send is up-to-date, in case the
617 # session-id has been modified in any way
620 # precache all system level rights for the current user
621 $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System );
623 # If the user isn't privileged, they can only see SelfService
624 unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) {
626 # if the user is trying to access a ticket, redirect them
627 if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) {
628 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} );
631 # otherwise, drop the user at the SelfService default page
632 elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) {
633 RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" );
636 # if user is in SelfService dir let him do anything
638 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
641 $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS );
646 sub AttemptExternalAuth {
649 return unless ( RT->Config->Get('WebExternalAuth') );
651 my $user = $ARGS->{user};
652 my $m = $HTML::Mason::Commands::m;
654 # If RT is configured for external auth, let's go through and get REMOTE_USER
656 # do we actually have a REMOTE_USER equivlent?
657 if ( RT::Interface::Web::WebCanonicalizeInfo() ) {
658 my $orig_user = $user;
660 $user = RT::Interface::Web::WebCanonicalizeInfo();
661 my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load';
663 if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) {
664 my $NodeName = Win32::NodeName();
665 $user =~ s/^\Q$NodeName\E\\//i;
668 my $next = RemoveNextPage($ARGS->{'next'});
669 $next = $next->{'url'} if ref $next;
670 InstantiateNewSession() unless _UserLoggedIn;
671 $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new();
672 $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user);
674 if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) {
676 # Create users on-the-fly
677 my $UserObj = RT::User->new(RT->SystemUser);
678 my ( $val, $msg ) = $UserObj->Create(
679 %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} },
686 # now get user specific information, to better create our user.
687 my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user);
689 # set the attributes that have been defined.
690 foreach my $attribute ( $UserObj->WritableAttributes ) {
692 Attribute => $attribute,
694 UserInfo => $new_user_info,
695 CallbackName => 'NewUser',
696 CallbackPage => '/autohandler'
698 my $method = "Set$attribute";
699 $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute};
701 $HTML::Mason::Commands::session{'CurrentUser'}->Load($user);
704 # we failed to successfully create the user. abort abort abort.
705 delete $HTML::Mason::Commands::session{'CurrentUser'};
707 if (RT->Config->Get('WebFallbackToInternalAuth')) {
708 TangentForLoginWithError($ARGS, 'Cannot create user: [_1]', $msg);
715 if ( _UserLoggedIn() ) {
716 $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' );
717 # It is possible that we did a redirect to the login page,
718 # if the external auth allows lack of auth through with no
719 # REMOTE_USER set, instead of forcing a "permission
720 # denied" message. Honor the $next.
721 Redirect($next) if $next;
722 # Unlike AttemptPasswordAuthentication below, we do not
723 # force a redirect to / if $next is not set -- otherwise,
724 # straight-up external auth would always redirect to /
725 # when you first hit it.
727 delete $HTML::Mason::Commands::session{'CurrentUser'};
730 unless ( RT->Config->Get('WebFallbackToInternalAuth') ) {
731 TangentForLoginWithError($ARGS, 'You are not an authorized user');
734 } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) {
735 unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) {
736 # XXX unreachable due to prior defaulting in HandleRequest (check c34d108)
737 TangentForLoginWithError($ARGS, 'You are not an authorized user');
741 # WebExternalAuth is set, but we don't have a REMOTE_USER. abort
742 # XXX: we must return AUTH_REQUIRED status or we fallback to
743 # internal auth here too.
744 delete $HTML::Mason::Commands::session{'CurrentUser'}
745 if defined $HTML::Mason::Commands::session{'CurrentUser'};
749 sub AttemptPasswordAuthentication {
751 return unless defined $ARGS->{user} && defined $ARGS->{pass};
753 my $user_obj = RT::CurrentUser->new();
754 $user_obj->Load( $ARGS->{user} );
756 my $m = $HTML::Mason::Commands::m;
758 unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) {
759 $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
760 $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' );
761 return (0, HTML::Mason::Commands::loc('Your username or password is incorrect'));
764 $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}");
766 # It's important to nab the next page from the session before we blow
768 my $next = RemoveNextPage($ARGS->{'next'});
769 $next = $next->{'url'} if ref $next;
771 InstantiateNewSession();
772 $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj;
774 $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' );
776 # Really the only time we don't want to redirect here is if we were
777 # passed user and pass as query params in the URL.
781 elsif ($ARGS->{'next'}) {
782 # Invalid hash, but still wants to go somewhere, take them to /
783 Redirect(RT->Config->Get('WebURL'));
786 return (1, HTML::Mason::Commands::loc('Logged in'));
790 =head2 LoadSessionFromCookie
792 Load or setup a session cookie for the current user.
796 sub _SessionCookieName {
797 my $cookiename = "RT_SID_" . RT->Config->Get('rtname');
798 $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'};
802 sub LoadSessionFromCookie {
804 my %cookies = CGI::Cookie->fetch;
805 my $cookiename = _SessionCookieName();
806 my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef );
807 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie;
808 unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) {
809 InstantiateNewSession();
811 if ( int RT->Config->Get('AutoLogoff') ) {
812 my $now = int( time / 60 );
813 my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0;
815 if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) {
816 InstantiateNewSession();
819 # save session on each request when AutoLogoff is turned on
820 $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update;
824 sub InstantiateNewSession {
825 tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session);
826 tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef;
830 sub SendSessionCookie {
831 my $cookie = CGI::Cookie->new(
832 -name => _SessionCookieName(),
833 -value => $HTML::Mason::Commands::session{_session_id},
834 -path => RT->Config->Get('WebPath'),
835 -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ),
836 -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ),
839 $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string;
844 This routine ells the current user's browser to redirect to URL.
845 Additionally, it unties the user's currently active session, helping to avoid
846 A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use
847 a cached DBI statement handle twice at the same time.
852 my $redir_to = shift;
853 untie $HTML::Mason::Commands::session;
854 my $uri = URI->new($redir_to);
855 my $server_uri = URI->new( _NormalizeHost(RT->Config->Get('WebURL')) );
857 # Make relative URIs absolute from the server host and scheme
858 $uri->scheme($server_uri->scheme) if not defined $uri->scheme;
859 if (not defined $uri->host) {
860 $uri->host($server_uri->host);
861 $uri->port($server_uri->port);
864 # If the user is coming in via a non-canonical
865 # hostname, don't redirect them to the canonical host,
866 # it will just upset them (and invalidate their credentials)
867 # don't do this if $RT::CanonicalizeRedirectURLs is true
868 if ( !RT->Config->Get('CanonicalizeRedirectURLs')
869 && $uri->host eq $server_uri->host
870 && $uri->port eq $server_uri->port )
872 if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) {
873 $uri->scheme('https');
875 $uri->scheme('http');
878 # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST
879 $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'});
880 $uri->port( $ENV{'SERVER_PORT'} );
883 # not sure why, but on some systems without this call mason doesn't
884 # set status to 302, but 200 instead and people see blank pages
885 $HTML::Mason::Commands::r->status(302);
887 # Perlbal expects a status message, but Mason's default redirect status
888 # doesn't provide one. See also rt.cpan.org #36689.
889 $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" );
891 $HTML::Mason::Commands::m->abort;
894 =head2 CacheControlExpiresHeaders
896 set both Cache-Control and Expires http headers
900 sub CacheControlExpiresHeaders {
903 my $Visibility = 'private';
904 if ( ! defined $args{Time} ) {
906 } elsif ( $args{Time} eq 'no-cache' ) {
908 } elsif ( $args{Time} eq 'forever' ) {
909 $args{Time} = 30 * 24 * 60 * 60;
910 $Visibility = 'public';
913 my $CacheControl = $args{Time}
914 ? sprintf "max-age=%d, %s", $args{Time}, $Visibility
917 $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = $CacheControl;
919 my $expires = RT::Date->new(RT->SystemUser);
921 $expires->AddSeconds( $args{Time} ) if $args{Time};
923 $HTML::Mason::Commands::r->headers_out->{'Expires'} = $expires->RFC2616;
926 =head2 StaticFileHeaders
928 Send the browser a few headers to try to get it to (somewhat agressively)
929 cache RT's static Javascript and CSS files.
931 This routine could really use _accurate_ heuristics. (XXX TODO)
935 sub StaticFileHeaders {
936 my $date = RT::Date->new(RT->SystemUser);
938 # remove any cookie headers -- if it is cached publicly, it
939 # shouldn't include anyone's cookie!
940 delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'};
942 # Expire things in a month.
943 CacheControlExpiresHeaders( Time => 'forever' );
945 # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since'
946 # request, but we don't handle it and generate full reply again
947 # Last modified at server start time
948 # $date->Set( Value => $^T );
949 # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616;
952 =head2 ComponentPathIsSafe PATH
954 Takes C<PATH> and returns a boolean indicating that the user-specified partial
955 component path is safe.
957 Currently "safe" means that the path does not start with a dot (C<.>), does
958 not contain a slash-dot C</.>, and does not contain any nulls.
962 sub ComponentPathIsSafe {
965 return $path !~ m{(?:^|/)\.} and $path !~ m{\0};
970 Takes a C<< Path => path >> and returns a boolean indicating that
971 the path is safely within RT's control or not. The path I<must> be
974 This function does not consult the filesystem at all; it is merely
975 a logical sanity checking of the path. This explicitly does not handle
976 symlinks; if you have symlinks in RT's webroot pointing outside of it,
977 then we assume you know what you are doing.
984 my $path = $args{Path};
986 # Get File::Spec to clean up extra /s, ./, etc
987 my $cleaned_up = File::Spec->canonpath($path);
989 if (!defined($cleaned_up)) {
990 $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path");
994 # Forbid too many ..s. We can't just sum then check because
995 # "../foo/bar/baz" should be illegal even though it has more
996 # downdirs than updirs. So as soon as we get a negative score
997 # (which means "breaking out" of the top level) we reject the path.
999 my @components = split '/', $cleaned_up;
1001 for my $component (@components) {
1002 if ($component eq '..') {
1005 $RT::Logger->info("Rejecting unsafe path: $path");
1009 elsif ($component eq '.' || $component eq '') {
1010 # these two have no effect on $score
1020 =head2 SendStaticFile
1022 Takes a File => path and a Type => Content-type
1024 If Type isn't provided and File is an image, it will
1025 figure out a sane Content-type, otherwise it will
1026 send application/octet-stream
1028 Will set caching headers using StaticFileHeaders
1032 sub SendStaticFile {
1035 my $file = $args{File};
1036 my $type = $args{Type};
1037 my $relfile = $args{RelativeFile};
1039 if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) {
1040 $HTML::Mason::Commands::r->status(400);
1041 $HTML::Mason::Commands::m->abort;
1044 $self->StaticFileHeaders();
1047 if ( $file =~ /\.(gif|png|jpe?g)$/i ) {
1049 $type =~ s/jpg/jpeg/gi;
1051 $type ||= "application/octet-stream";
1053 $HTML::Mason::Commands::r->content_type($type);
1054 open( my $fh, '<', $file ) or die "couldn't open file: $!";
1058 $HTML::Mason::Commands::m->out($_) while (<$fh>);
1059 $HTML::Mason::Commands::m->flush_buffer;
1070 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'}) {
1081 my $content = $args{Content};
1082 return '' unless $content;
1084 # Make the content have no 'weird' newlines in it
1085 $content =~ s/\r+\n/\n/g;
1087 my $return_content = $content;
1089 my $html = $args{ContentType} && $args{ContentType} eq "text/html";
1090 my $sigonly = $args{StripSignature};
1092 # massage content to easily detect if there's any real content
1093 $content =~ s/\s+//g; # yes! remove all the spaces
1095 # remove html version of spaces and newlines
1096 $content =~ s! !!g;
1097 $content =~ s!<br/?>!!g;
1100 # Filter empty content when type is text/html
1101 return '' if $html && $content !~ /\S/;
1103 # If we aren't supposed to strip the sig, just bail now.
1104 return $return_content unless $sigonly;
1106 # Find the signature
1107 my $sig = $args{'CurrentUser'}->UserObj->Signature || '';
1110 # Check for plaintext sig
1111 return '' if not $html and $content =~ /^(--)?\Q$sig\E$/;
1113 # Check for html-formatted sig; we don't use EscapeUTF8 here
1114 # because we want to precisely match the escapting that FCKEditor
1116 $sig =~ s/&/&/g;
1119 $sig =~ s/"/"/g;
1120 $sig =~ s/'/'/g;
1121 return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s;
1124 return $return_content;
1132 # if they've passed multiple values, they'll be an array. if they've
1133 # passed just one, a scalar whatever they are, mark them as utf8
1136 ? Encode::is_utf8($_)
1138 : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ )
1139 : ( $type eq 'ARRAY' )
1140 ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1142 : ( $type eq 'HASH' )
1143 ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) }
1149 sub PreprocessTimeUpdates {
1152 # Later in the code we use
1153 # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS );
1154 # instead of $m->call_next to avoid problems with UTF8 keys in arguments.
1155 # The call_next method pass through original arguments and if you have
1156 # an argument with unicode key then in a next component you'll get two
1157 # records in the args hash: one with key without UTF8 flag and another
1158 # with the flag, which may result into errors. "{ base_comp => $m->request_comp }"
1159 # is copied from mason's source to get the same results as we get from
1160 # call_next method, this feature is not documented, so we just leave it
1161 # here to avoid possible side effects.
1163 # This code canonicalizes time inputs in hours into minutes
1164 foreach my $field ( keys %$ARGS ) {
1165 next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1};
1167 $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b}
1168 {($1 || 0) + $3 ? $2 / $3 : 0}xe;
1169 if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) {
1170 $ARGS->{$local} *= 60;
1172 delete $ARGS->{$field};
1177 sub MaybeEnableSQLStatementLog {
1179 my $log_sql_statements = RT->Config->Get('StatementLog');
1181 if ($log_sql_statements) {
1182 $RT::Handle->ClearSQLStatementLog;
1183 $RT::Handle->LogSQLStatements(1);
1188 sub LogRecordedSQLStatements {
1191 my $log_sql_statements = RT->Config->Get('StatementLog');
1193 return unless ($log_sql_statements);
1195 my @log = $RT::Handle->SQLStatementLog;
1196 $RT::Handle->ClearSQLStatementLog;
1198 $RT::Handle->AddRequestToHistory({
1199 %{ $args{RequestData} },
1203 for my $stmt (@log) {
1204 my ( $time, $sql, $bind, $duration ) = @{$stmt};
1214 level => $log_sql_statements,
1216 . sprintf( "%.6f", $duration )
1218 . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" )
1224 my $_has_validated_web_config = 0;
1225 sub ValidateWebConfig {
1228 # do this once per server instance, not once per request
1229 return if $_has_validated_web_config;
1230 $_has_validated_web_config = 1;
1232 my $port = $ENV{SERVER_PORT};
1233 my $host = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER}
1234 || $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
1235 ($host, $port) = ($1, $2) if $host =~ /^(.*?):(\d+)$/;
1237 if ( $port != RT->Config->Get('WebPort') and not $ENV{'rt.explicit_port'}) {
1238 $RT::Logger->warn("The requested port ($port) does NOT match the configured WebPort ($RT::WebPort). "
1239 ."Perhaps you should Set(\$WebPort, $port); in RT_SiteConfig.pm, "
1240 ."otherwise your internal links may be broken.");
1243 if ( $host ne RT->Config->Get('WebDomain') ) {
1244 $RT::Logger->warn("The requested host ($host) does NOT match the configured WebDomain ($RT::WebDomain). "
1245 ."Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, "
1246 ."otherwise your internal links may be broken.");
1249 # Unfortunately, there is no reliable way to get the _path_ that was
1250 # requested at the proxy level; simply disable this warning if we're
1251 # proxied and there's a mismatch.
1252 my $proxied = $ENV{HTTP_X_FORWARDED_HOST} || $ENV{HTTP_X_FORWARDED_SERVER};
1253 if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath') and not $proxied) {
1254 $RT::Logger->warn("The requested path ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). "
1255 ."Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, "
1256 ."otherwise your internal links may be broken.");
1260 sub ComponentRoots {
1262 my %args = ( Names => 0, @_ );
1264 if (defined $HTML::Mason::Commands::m) {
1265 @roots = $HTML::Mason::Commands::m->interp->comp_root_array;
1268 [ local => $RT::MasonLocalComponentRoot ],
1269 (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}),
1270 [ standard => $RT::MasonComponentRoot ]
1273 @roots = map { $_->[1] } @roots unless $args{Names};
1277 our %is_whitelisted_component = (
1278 # The RSS feed embeds an auth token in the path, but query
1279 # information for the search. Because it's a straight-up read, in
1280 # addition to embedding its own auth, it's fine.
1281 '/NoAuth/rss/dhandler' => 1,
1283 # While these can be used for denial-of-service against RT
1284 # (construct a very inefficient query and trick lots of users into
1285 # running them against RT) it's incredibly useful to be able to link
1286 # to a search result or bookmark a result page.
1287 '/Search/Results.html' => 1,
1288 '/Search/Simple.html' => 1,
1289 '/m/tickets/search' => 1,
1292 # Components which are blacklisted from automatic, argument-based whitelisting.
1293 # These pages are not idempotent when called with just an id.
1294 our %is_blacklisted_component = (
1295 # Takes only id and toggles bookmark state
1296 '/Helpers/Toggle/TicketBookmark' => 1,
1299 sub IsCompCSRFWhitelisted {
1303 return 1 if $is_whitelisted_component{$comp};
1305 my %args = %{ $ARGS };
1307 # If the user specifies a *correct* user and pass then they are
1308 # golden. This acts on the presumption that external forms may
1309 # hardcode a username and password -- if a malicious attacker knew
1310 # both already, CSRF is the least of your problems.
1311 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1312 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1313 my $user_obj = RT::CurrentUser->new();
1314 $user_obj->Load($args{user});
1315 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1321 # Some pages aren't idempotent even with safe args like id; blacklist
1322 # them from the automatic whitelisting below.
1323 return 0 if $is_blacklisted_component{$comp};
1325 # Eliminate arguments that do not indicate an effectful request.
1326 # For example, "id" is acceptable because that is how RT retrieves a
1330 # If they have a results= from MaybeRedirectForResults, that's also fine.
1331 delete $args{results};
1333 # The homepage refresh, which uses the Refresh header, doesn't send
1334 # a referer in most browsers; whitelist the one parameter it reloads
1335 # with, HomeRefreshInterval, which is safe
1336 delete $args{HomeRefreshInterval};
1338 # The NotMobile flag is fine for any page; it's only used to toggle a flag
1339 # in the session related to which interface you get.
1340 delete $args{NotMobile};
1342 # If there are no arguments, then it's likely to be an idempotent
1343 # request, which are not susceptible to CSRF
1349 sub IsRefererCSRFWhitelisted {
1350 my $referer = _NormalizeHost(shift);
1351 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1352 $base_url = $base_url->host_port;
1355 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1356 push @$configs,$config;
1358 my $host_port = $referer->host_port;
1359 if ($config =~ /\*/) {
1360 # Turn a literal * into a domain component or partial component match.
1361 # Refer to http://tools.ietf.org/html/rfc2818#page-5
1362 my $regex = join "[a-zA-Z0-9\-]*",
1363 map { quotemeta($_) }
1364 split /\*/, $config;
1366 return 1 if $host_port =~ /^$regex$/i;
1368 return 1 if $host_port eq $config;
1372 return (0,$referer,$configs);
1375 =head3 _NormalizeHost
1377 Takes a URI and creates a URI object that's been normalized
1378 to handle common problems such as localhost vs 127.0.0.1
1382 sub _NormalizeHost {
1384 $s = "http://$s" unless $s =~ /^http/i;
1385 my $uri= URI->new($s);
1386 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1392 sub IsPossibleCSRF {
1395 # If first request on this session is to a REST endpoint, then
1396 # whitelist the REST endpoints -- and explicitly deny non-REST
1397 # endpoints. We do this because using a REST cookie in a browser
1398 # would open the user to CSRF attacks to the REST endpoints.
1399 my $path = $HTML::Mason::Commands::r->path_info;
1400 $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1401 unless defined $HTML::Mason::Commands::session{'REST'};
1403 if ($HTML::Mason::Commands::session{'REST'}) {
1404 return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1406 This login session belongs to a REST client, and cannot be used to
1407 access non-REST interfaces of RT for security reasons.
1409 my $details = <<EOT;
1410 Please log out and back in to obtain a session for normal browsing. If
1411 you understand the security implications, disabling RT's CSRF protection
1412 will remove this restriction.
1415 HTML::Mason::Commands::Abort( $why, Details => $details );
1418 return 0 if IsCompCSRFWhitelisted(
1419 $HTML::Mason::Commands::m->request_comp->path,
1423 # if there is no Referer header then assume the worst
1425 "your browser did not supply a Referrer header", # loc
1426 ) if !$ENV{HTTP_REFERER};
1428 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1429 return 0 if $whitelisted;
1431 if ( @$configs > 1 ) {
1433 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1434 $browser->host_port,
1436 join(', ', @$configs) );
1440 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1441 $browser->host_port,
1445 sub ExpandCSRFToken {
1448 my $token = delete $ARGS->{CSRF_Token};
1449 return unless $token;
1451 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1452 return unless $data;
1453 return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1455 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1456 return unless $user->ValidateAuthString( $data->{auth}, $token );
1458 %{$ARGS} = %{$data->{args}};
1459 $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1461 # We explicitly stored file attachments with the request, but not in
1462 # the session yet, as that would itself be an attack. Put them into
1463 # the session now, so they'll be visible.
1464 if ($data->{attach}) {
1465 my $filename = $data->{attach}{filename};
1466 my $mime = $data->{attach}{mime};
1467 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1474 sub StoreRequestToken {
1477 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1478 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1480 auth => $user->GenerateAuthString( $token ),
1481 path => $HTML::Mason::Commands::r->path_info,
1484 if ($ARGS->{Attach}) {
1485 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1486 my $file_path = delete $ARGS->{'Attach'};
1488 filename => Encode::decode_utf8("$file_path"),
1489 mime => $attachment,
1493 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1494 $HTML::Mason::Commands::session{'i'}++;
1498 sub MaybeShowInterstitialCSRFPage {
1501 return unless RT->Config->Get('RestrictReferrer');
1503 # Deal with the form token provided by the interstitial, which lets
1504 # browsers which never set referer headers still use RT, if
1505 # painfully. This blows values into ARGS
1506 return if ExpandCSRFToken($ARGS);
1508 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1509 return if !$is_csrf;
1511 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1513 my $token = StoreRequestToken($ARGS);
1514 $HTML::Mason::Commands::m->comp(
1516 OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1517 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1520 # Calls abort, never gets here
1523 our @POTENTIAL_PAGE_ACTIONS = (
1524 qr'/Ticket/Create.html' => "create a ticket", # loc
1525 qr'/Ticket/' => "update a ticket", # loc
1526 qr'/Admin/' => "modify RT's configuration", # loc
1527 qr'/Approval/' => "update an approval", # loc
1528 qr'/Articles/' => "update an article", # loc
1529 qr'/Dashboards/' => "modify a dashboard", # loc
1530 qr'/m/ticket/' => "update a ticket", # loc
1531 qr'Prefs' => "modify your preferences", # loc
1532 qr'/Search/' => "modify or access a search", # loc
1533 qr'/SelfService/Create' => "create a ticket", # loc
1534 qr'/SelfService/' => "update a ticket", # loc
1537 sub PotentialPageAction {
1539 my @potentials = @POTENTIAL_PAGE_ACTIONS;
1540 while (my ($pattern, $result) = splice @potentials, 0, 2) {
1541 return HTML::Mason::Commands::loc($result)
1542 if $page =~ $pattern;
1547 package HTML::Mason::Commands;
1549 use vars qw/$r $m %session/;
1552 return $HTML::Mason::Commands::m->notes('menu');
1556 return $HTML::Mason::Commands::m->notes('page-menu');
1560 return $HTML::Mason::Commands::m->notes('page-widgets');
1567 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1568 with whatever it's called with. If there is no $session{'CurrentUser'},
1569 it creates a temporary user, so we have something to get a localisation handle
1576 if ( $session{'CurrentUser'}
1577 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1579 return ( $session{'CurrentUser'}->loc(@_) );
1582 RT::CurrentUser->new();
1586 return ( $u->loc(@_) );
1589 # pathetic case -- SystemUser is gone.
1596 =head2 loc_fuzzy STRING
1598 loc_fuzzy is for handling localizations of messages that may already
1599 contain interpolated variables, typically returned from libraries
1600 outside RT's control. It takes the message string and extracts the
1601 variable array automatically by matching against the candidate entries
1602 inside the lexicon file.
1609 if ( $session{'CurrentUser'}
1610 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1612 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1614 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1615 return ( $u->loc_fuzzy($msg) );
1620 # Error - calls Error and aborts
1625 if ( $session{'ErrorDocument'}
1626 && $session{'ErrorDocumentType'} )
1628 $r->content_type( $session{'ErrorDocumentType'} );
1629 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1632 $m->comp( "/Elements/Error", Why => $why, %args );
1637 sub MaybeRedirectForResults {
1639 Path => $HTML::Mason::Commands::m->request_comp->path,
1646 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1647 return unless $has_actions || $args{'Force'};
1649 my %arguments = %{ $args{'Arguments'} };
1651 if ( $has_actions ) {
1652 my $key = Digest::MD5::md5_hex( rand(1024) );
1653 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1655 $arguments{'results'} = $key;
1658 $args{'Path'} =~ s!^/+!!;
1659 my $url = RT->Config->Get('WebURL') . $args{Path};
1661 if ( keys %arguments ) {
1662 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1664 if ( $args{'Anchor'} ) {
1665 $url .= "#". $args{'Anchor'};
1667 return RT::Interface::Web::Redirect($url);
1670 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1672 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1673 redirect to the approvals display page, preserving any arguments.
1675 C<Path>s matching C<Whitelist> are let through.
1677 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1681 sub MaybeRedirectToApproval {
1683 Path => $HTML::Mason::Commands::m->request_comp->path,
1689 return unless $ENV{REQUEST_METHOD} eq 'GET';
1691 my $id = $args{ARGSRef}->{id};
1694 and RT->Config->Get('ForceApprovalsView')
1695 and not $args{Path} =~ /$args{Whitelist}/)
1697 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1700 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1701 MaybeRedirectForResults(
1702 Path => "/Approvals/Display.html",
1704 Anchor => $args{ARGSRef}->{Anchor},
1705 Arguments => $args{ARGSRef},
1711 =head2 CreateTicket ARGS
1713 Create a new ticket, using Mason's %ARGS. returns @results.
1722 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1724 my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1725 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1726 Abort('Queue not found');
1729 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1730 Abort('You have no permission to create tickets in that queue.');
1734 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1735 $due = RT::Date->new( $session{'CurrentUser'} );
1736 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1739 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1740 $starts = RT::Date->new( $session{'CurrentUser'} );
1741 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1744 my $sigless = RT::Interface::Web::StripContent(
1745 Content => $ARGS{Content},
1746 ContentType => $ARGS{ContentType},
1747 StripSignature => 1,
1748 CurrentUser => $session{'CurrentUser'},
1751 my $MIMEObj = MakeMIMEEntity(
1752 Subject => $ARGS{'Subject'},
1753 From => $ARGS{'From'},
1756 Type => $ARGS{'ContentType'},
1757 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
1760 if ( $ARGS{'Attachments'} ) {
1761 my $rv = $MIMEObj->make_multipart;
1762 $RT::Logger->error("Couldn't make multipart message")
1763 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1765 foreach ( values %{ $ARGS{'Attachments'} } ) {
1767 $RT::Logger->error("Couldn't add empty attachemnt");
1770 $MIMEObj->add_part($_);
1774 for my $argument (qw(Encrypt Sign)) {
1775 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
1779 Type => $ARGS{'Type'} || 'ticket',
1780 Queue => $ARGS{'Queue'},
1781 Owner => $ARGS{'Owner'},
1784 Requestor => $ARGS{'Requestors'},
1786 AdminCc => $ARGS{'AdminCc'},
1787 InitialPriority => $ARGS{'InitialPriority'},
1788 FinalPriority => $ARGS{'FinalPriority'},
1789 TimeLeft => $ARGS{'TimeLeft'},
1790 TimeEstimated => $ARGS{'TimeEstimated'},
1791 TimeWorked => $ARGS{'TimeWorked'},
1792 Subject => $ARGS{'Subject'},
1793 Status => $ARGS{'Status'},
1794 Due => $due ? $due->ISO : undef,
1795 Starts => $starts ? $starts->ISO : undef,
1800 foreach my $type (qw(Requestor Cc AdminCc)) {
1801 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1802 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1804 $create_args{TransSquelchMailTo} = \@txn_squelch
1807 if ( $ARGS{'AttachTickets'} ) {
1808 require RT::Action::SendEmail;
1809 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1810 ref $ARGS{'AttachTickets'}
1811 ? @{ $ARGS{'AttachTickets'} }
1812 : ( $ARGS{'AttachTickets'} ) );
1815 foreach my $arg ( keys %ARGS ) {
1816 next if $arg =~ /-(?:Magic|Category)$/;
1818 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1819 $create_args{$arg} = $ARGS{$arg};
1822 # Object-RT::Ticket--CustomField-3-Values
1823 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1826 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1827 $cf->SetContextObject( $Queue );
1829 unless ( $cf->id ) {
1830 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1834 if ( $arg =~ /-Upload$/ ) {
1835 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1839 my $type = $cf->Type;
1842 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1843 @values = @{ $ARGS{$arg} };
1844 } elsif ( $type =~ /text/i ) {
1845 @values = ( $ARGS{$arg} );
1847 no warnings 'uninitialized';
1848 @values = split /\r*\n/, $ARGS{$arg};
1850 @values = grep length, map {
1856 grep defined, @values;
1858 $create_args{"CustomField-$cfid"} = \@values;
1862 # turn new link lists into arrays, and pass in the proper arguments
1864 'new-DependsOn' => 'DependsOn',
1865 'DependsOn-new' => 'DependedOnBy',
1866 'new-MemberOf' => 'Parents',
1867 'MemberOf-new' => 'Children',
1868 'new-RefersTo' => 'RefersTo',
1869 'RefersTo-new' => 'ReferredToBy',
1871 foreach my $key ( keys %map ) {
1872 next unless $ARGS{$key};
1873 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1877 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1882 push( @Actions, split( "\n", $ErrMsg ) );
1883 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1884 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1886 return ( $Ticket, @Actions );
1892 =head2 LoadTicket id
1894 Takes a ticket id as its only variable. if it's handed an array, it takes
1897 Returns an RT::Ticket object as the current user.
1904 if ( ref($id) eq "ARRAY" ) {
1909 Abort("No ticket specified");
1912 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1914 unless ( $Ticket->id ) {
1915 Abort("Could not load ticket $id");
1922 =head2 ProcessUpdateMessage
1924 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1926 Don't write message if it only contains current user's signature and
1927 SkipSignatureOnly argument is true. Function anyway adds attachments
1928 and updates time worked field even if skips message. The default value
1933 sub ProcessUpdateMessage {
1938 SkipSignatureOnly => 1,
1942 if ( $args{ARGSRef}->{'UpdateAttachments'}
1943 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1945 delete $args{ARGSRef}->{'UpdateAttachments'};
1948 # Strip the signature
1949 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1950 Content => $args{ARGSRef}->{UpdateContent},
1951 ContentType => $args{ARGSRef}->{UpdateContentType},
1952 StripSignature => $args{SkipSignatureOnly},
1953 CurrentUser => $args{'TicketObj'}->CurrentUser,
1956 my %txn_customfields;
1958 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1959 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1960 next if $key =~ /(TimeUnits|Magic)$/;
1961 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1965 # If, after stripping the signature, we have no message, create a
1966 # Touch transaction if necessary
1967 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1968 and not length $args{ARGSRef}->{'UpdateContent'} )
1970 #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1971 # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
1972 # delete $args{ARGSRef}->{'UpdateTimeWorked'};
1975 my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
1976 if ( $timetaken or grep {length $_} values %txn_customfields ) {
1977 my ( $Transaction, $Description, $Object ) =
1978 $args{TicketObj}->Touch(
1979 CustomFields => \%txn_customfields,
1980 TimeTaken => $timetaken
1982 return $Description;
1987 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1988 $args{ARGSRef}->{'UpdateSubject'} = undef;
1991 my $Message = MakeMIMEEntity(
1992 Subject => $args{ARGSRef}->{'UpdateSubject'},
1993 Body => $args{ARGSRef}->{'UpdateContent'},
1994 Type => $args{ARGSRef}->{'UpdateContentType'},
1995 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
1998 $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
1999 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
2001 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
2002 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
2003 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
2005 $old_txn = $args{TicketObj}->Transactions->First();
2008 if ( my $msg = $old_txn->Message->First ) {
2009 RT::Interface::Email::SetInReplyTo(
2010 Message => $Message,
2015 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
2016 $Message->make_multipart;
2017 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
2020 if ( $args{ARGSRef}->{'AttachTickets'} ) {
2021 require RT::Action::SendEmail;
2022 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2023 ref $args{ARGSRef}->{'AttachTickets'}
2024 ? @{ $args{ARGSRef}->{'AttachTickets'} }
2025 : ( $args{ARGSRef}->{'AttachTickets'} ) );
2028 my %message_args = (
2029 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
2030 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
2031 MIMEObj => $Message,
2032 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
2033 CustomFields => \%txn_customfields,
2036 _ProcessUpdateMessageRecipients(
2037 MessageArgs => \%message_args,
2042 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2043 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2044 push( @results, $Description );
2045 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2046 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2047 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2048 push( @results, $Description );
2049 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2052 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2057 sub _ProcessUpdateMessageRecipients {
2061 MessageArgs => undef,
2065 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2066 my $cc = $args{ARGSRef}->{'UpdateCc'};
2068 my $message_args = $args{MessageArgs};
2070 $message_args->{CcMessageTo} = $cc;
2071 $message_args->{BccMessageTo} = $bcc;
2074 foreach my $type (qw(Cc AdminCc)) {
2075 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2076 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2077 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2078 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2081 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2082 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2083 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2086 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2087 $message_args->{SquelchMailTo} = \@txn_squelch
2090 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2091 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2092 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2094 my $var = ucfirst($1) . 'MessageTo';
2096 if ( $message_args->{$var} ) {
2097 $message_args->{$var} .= ", $value";
2099 $message_args->{$var} = $value;
2105 sub ProcessAttachments {
2111 my $ARGSRef = $args{ARGSRef} || {};
2112 # deal with deleting uploaded attachments
2113 foreach my $key ( keys %$ARGSRef ) {
2114 if ( $key =~ m/^DeleteAttach-(.+)$/ ) {
2115 delete $session{'Attachments'}{$1};
2117 $session{'Attachments'} = { %{ $session{'Attachments'} || {} } };
2120 # store the uploaded attachment in session
2121 if ( defined $ARGSRef->{'Attach'} && length $ARGSRef->{'Attach'} )
2123 my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' );
2125 my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}");
2126 $session{'Attachments'} =
2127 { %{ $session{'Attachments'} || {} }, $file_path => $attachment, };
2130 # delete temporary storage entry to make WebUI clean
2131 unless ( keys %{ $session{'Attachments'} } and $ARGSRef->{'UpdateAttach'} )
2133 delete $session{'Attachments'};
2138 =head2 MakeMIMEEntity PARAMHASH
2140 Takes a paramhash Subject, Body and AttachmentFieldName.
2142 Also takes Form, Cc and Type as optional paramhash keys.
2144 Returns a MIME::Entity.
2148 sub MakeMIMEEntity {
2150 #TODO document what else this takes.
2156 AttachmentFieldName => undef,
2161 my $Message = MIME::Entity->build(
2162 Type => 'multipart/mixed',
2163 "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
2164 "X-RT-Interface" => $args{Interface},
2165 map { $_ => Encode::encode_utf8( $args{ $_} ) }
2166 grep defined $args{$_}, qw(Subject From Cc)
2169 if ( defined $args{'Body'} && length $args{'Body'} ) {
2171 # Make the update content have no 'weird' newlines in it
2172 $args{'Body'} =~ s/\r\n/\n/gs;
2175 Type => $args{'Type'} || 'text/plain',
2177 Data => $args{'Body'},
2181 if ( $args{'AttachmentFieldName'} ) {
2183 my $cgi_object = $m->cgi_object;
2184 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2185 if ( defined $filehandle && length $filehandle ) {
2187 my ( @content, $buffer );
2188 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2189 push @content, $buffer;
2192 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2194 my $filename = "$filehandle";
2195 $filename =~ s{^.*[\\/]}{};
2198 Type => $uploadinfo->{'Content-Type'},
2199 Filename => $filename,
2202 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2203 $Message->head->set( 'Subject' => $filename );
2206 # Attachment parts really shouldn't get a Message-ID or "interface"
2207 $Message->head->delete('Message-ID');
2208 $Message->head->delete('X-RT-Interface');
2212 $Message->make_singlepart;
2214 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2222 =head2 ParseDateToISO
2224 Takes a date in an arbitrary format.
2225 Returns an ISO date and time in GMT
2229 sub ParseDateToISO {
2232 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2234 Format => 'unknown',
2237 return ( $date_obj->ISO );
2242 sub ProcessACLChanges {
2243 my $ARGSref = shift;
2247 foreach my $arg ( keys %$ARGSref ) {
2248 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2250 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2253 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2254 @rights = @{ $ARGSref->{$arg} };
2256 @rights = $ARGSref->{$arg};
2258 @rights = grep $_, @rights;
2259 next unless @rights;
2261 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2262 $principal->Load($principal_id);
2265 if ( $object_type eq 'RT::System' ) {
2267 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2268 $obj = $object_type->new( $session{'CurrentUser'} );
2269 $obj->Load($object_id);
2270 unless ( $obj->id ) {
2271 $RT::Logger->error("couldn't load $object_type #$object_id");
2275 $RT::Logger->error("object type '$object_type' is incorrect");
2276 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2280 foreach my $right (@rights) {
2281 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2282 push( @results, $msg );
2292 ProcessACLs expects values from a series of checkboxes that describe the full
2293 set of rights a principal should have on an object.
2295 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2296 instead of with the prefixes Grant/RevokeRight. Each input should be an array
2297 listing the rights the principal should have, and ProcessACLs will modify the
2298 current rights to match. Additionally, the previously unused CheckACL input
2299 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2300 rights are removed from a principal and as such no SetRights input is
2306 my $ARGSref = shift;
2307 my (%state, @results);
2309 my $CheckACL = $ARGSref->{'CheckACL'};
2310 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2312 # Check if we want to grant rights to a previously rights-less user
2313 for my $type (qw(user group)) {
2314 my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2317 unless ($principal->PrincipalId) {
2318 push @results, loc("Couldn't load the specified principal");
2322 my $principal_id = $principal->PrincipalId;
2324 # Turn our addprincipal rights spec into a real one
2325 for my $arg (keys %$ARGSref) {
2326 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2328 my $tuple = "$principal_id-$1";
2329 my $key = "SetRights-$tuple";
2331 # If we have it already, that's odd, but merge them
2332 if (grep { $_ eq $tuple } @check) {
2333 $ARGSref->{$key} = [
2334 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2335 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2338 $ARGSref->{$key} = $ARGSref->{$arg};
2339 push @check, $tuple;
2344 # Build our rights state for each Principal-Object tuple
2345 foreach my $arg ( keys %$ARGSref ) {
2346 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2349 my $value = $ARGSref->{$arg};
2350 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2351 next unless @rights;
2353 $state{$tuple} = { map { $_ => 1 } @rights };
2356 foreach my $tuple (List::MoreUtils::uniq @check) {
2357 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2359 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2361 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2362 $principal->Load($principal_id);
2365 if ( $object_type eq 'RT::System' ) {
2367 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2368 $obj = $object_type->new( $session{'CurrentUser'} );
2369 $obj->Load($object_id);
2370 unless ( $obj->id ) {
2371 $RT::Logger->error("couldn't load $object_type #$object_id");
2375 $RT::Logger->error("object type '$object_type' is incorrect");
2376 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2380 my $acls = RT::ACL->new($session{'CurrentUser'});
2381 $acls->LimitToObject( $obj );
2382 $acls->LimitToPrincipal( Id => $principal_id );
2384 while ( my $ace = $acls->Next ) {
2385 my $right = $ace->RightName;
2387 # Has right and should have right
2388 next if delete $state{$tuple}->{$right};
2390 # Has right and shouldn't have right
2391 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2392 push @results, $msg;
2395 # For everything left, they don't have the right but they should
2396 for my $right (keys %{ $state{$tuple} || {} }) {
2397 delete $state{$tuple}->{$right};
2398 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2399 push @results, $msg;
2402 # Check our state for leftovers
2403 if ( keys %{ $state{$tuple} || {} } ) {
2404 my $missed = join '|', %{$state{$tuple} || {}};
2406 "Uh-oh, it looks like we somehow missed a right in "
2407 ."ProcessACLs. Here's what was leftover: $missed"
2415 =head2 _ParseACLNewPrincipal
2417 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>). Looks
2418 for the presence of rights being added on a principal of the specified type,
2419 and returns undef if no new principal is being granted rights. Otherwise loads
2420 up an L<RT::User> or L<RT::Group> object and returns it. Note that the object
2421 may not be successfully loaded, and you should check C<->id> yourself.
2425 sub _ParseACLNewPrincipal {
2426 my $ARGSref = shift;
2427 my $type = lc shift;
2428 my $key = "AddPrincipalForRights-$type";
2430 return unless $ARGSref->{$key};
2433 if ( $type eq 'user' ) {
2434 $principal = RT::User->new( $session{'CurrentUser'} );
2435 $principal->LoadByCol( Name => $ARGSref->{$key} );
2437 elsif ( $type eq 'group' ) {
2438 $principal = RT::Group->new( $session{'CurrentUser'} );
2439 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2445 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2447 @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.
2449 Returns an array of success/failure messages
2453 sub UpdateRecordObject {
2456 AttributesRef => undef,
2458 AttributePrefix => undef,
2462 my $Object = $args{'Object'};
2463 my @results = $Object->Update(
2464 AttributesRef => $args{'AttributesRef'},
2465 ARGSRef => $args{'ARGSRef'},
2466 AttributePrefix => $args{'AttributePrefix'},
2474 sub ProcessCustomFieldUpdates {
2476 CustomFieldObj => undef,
2481 my $Object = $args{'CustomFieldObj'};
2482 my $ARGSRef = $args{'ARGSRef'};
2484 my @attribs = qw(Name Type Description Queue SortOrder);
2485 my @results = UpdateRecordObject(
2486 AttributesRef => \@attribs,
2491 my $prefix = "CustomField-" . $Object->Id;
2492 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2493 my ( $addval, $addmsg ) = $Object->AddValue(
2494 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2495 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2496 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2498 push( @results, $addmsg );
2502 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2503 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2504 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2506 foreach my $id (@delete_values) {
2507 next unless defined $id;
2508 my ( $err, $msg ) = $Object->DeleteValue($id);
2509 push( @results, $msg );
2512 my $vals = $Object->Values();
2513 while ( my $cfv = $vals->Next() ) {
2514 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2515 if ( $cfv->SortOrder != $so ) {
2516 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2517 push( @results, $msg );
2527 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2529 Returns an array of results messages.
2533 sub ProcessTicketBasics {
2541 my $TicketObj = $args{'TicketObj'};
2542 my $ARGSRef = $args{'ARGSRef'};
2544 my $OrigOwner = $TicketObj->Owner;
2559 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2560 for my $field (qw(Queue Owner)) {
2561 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2562 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2563 my $temp = $class->new(RT->SystemUser);
2564 $temp->Load( $ARGSRef->{$field} );
2566 $ARGSRef->{$field} = $temp->id;
2571 # Status isn't a field that can be set to a null value.
2572 # RT core complains if you try
2573 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2575 my @results = UpdateRecordObject(
2576 AttributesRef => \@attribs,
2577 Object => $TicketObj,
2578 ARGSRef => $ARGSRef,
2581 # We special case owner changing, so we can use ForceOwnerChange
2582 if ( $ARGSRef->{'Owner'}
2583 && $ARGSRef->{'Owner'} !~ /\D/
2584 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2586 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2587 $ChownType = "Force";
2593 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2594 push( @results, $msg );
2602 sub ProcessTicketReminders {
2609 my $Ticket = $args{'TicketObj'};
2610 my $args = $args{'ARGSRef'};
2613 my $reminder_collection = $Ticket->Reminders->Collection;
2615 if ( $args->{'update-reminders'} ) {
2616 while ( my $reminder = $reminder_collection->Next ) {
2617 my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2618 if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2619 $Ticket->Reminders->Resolve($reminder);
2621 elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2622 $Ticket->Reminders->Open($reminder);
2625 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2626 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2629 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2630 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2633 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2634 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2636 Format => 'unknown',
2637 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2639 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2640 $reminder->SetDue( $DateObj->ISO );
2646 if ( $args->{'NewReminder-Subject'} ) {
2647 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2649 Format => 'unknown',
2650 Value => $args->{'NewReminder-Due'}
2652 my ( $add_id, $msg ) = $Ticket->Reminders->Add(
2653 Subject => $args->{'NewReminder-Subject'},
2654 Owner => $args->{'NewReminder-Owner'},
2655 Due => $due_obj->ISO
2658 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2661 push @results, $msg;
2667 sub ProcessTicketCustomFieldUpdates {
2669 $args{'Object'} = delete $args{'TicketObj'};
2670 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2672 # Build up a list of objects that we want to work with
2673 my %custom_fields_to_mod;
2674 foreach my $arg ( keys %$ARGSRef ) {
2675 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2676 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2677 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2678 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2679 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2680 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2684 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2687 sub ProcessObjectCustomFieldUpdates {
2689 my $ARGSRef = $args{'ARGSRef'};
2692 # Build up a list of objects that we want to work with
2693 my %custom_fields_to_mod;
2694 foreach my $arg ( keys %$ARGSRef ) {
2696 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2697 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2699 # For each of those objects, find out what custom fields we want to work with.
2700 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2703 # For each of those objects
2704 foreach my $class ( keys %custom_fields_to_mod ) {
2705 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2706 my $Object = $args{'Object'};
2707 $Object = $class->new( $session{'CurrentUser'} )
2708 unless $Object && ref $Object eq $class;
2710 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2711 unless ( $Object->id ) {
2712 $RT::Logger->warning("Couldn't load object $class #$id");
2716 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2717 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2718 $CustomFieldObj->SetContextObject($Object);
2719 $CustomFieldObj->LoadById($cf);
2720 unless ( $CustomFieldObj->id ) {
2721 $RT::Logger->warning("Couldn't load custom field #$cf");
2725 _ProcessObjectCustomFieldUpdates(
2726 Prefix => "Object-$class-$id-CustomField-$cf-",
2728 CustomField => $CustomFieldObj,
2729 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2737 sub _ProcessObjectCustomFieldUpdates {
2739 my $cf = $args{'CustomField'};
2740 my $cf_type = $cf->Type || '';
2742 # Remove blank Values since the magic field will take care of this. Sometimes
2743 # the browser gives you a blank value which causes CFs to be processed twice
2744 if ( defined $args{'ARGS'}->{'Values'}
2745 && !length $args{'ARGS'}->{'Values'}
2746 && $args{'ARGS'}->{'Values-Magic'} )
2748 delete $args{'ARGS'}->{'Values'};
2752 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2754 # skip category argument
2755 next if $arg eq 'Category';
2758 next if $arg eq 'Value-TimeUnits';
2760 # since http won't pass in a form element with a null value, we need
2762 if ( $arg eq 'Values-Magic' ) {
2764 # We don't care about the magic, if there's really a values element;
2765 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2766 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2768 # "Empty" values does not mean anything for Image and Binary fields
2769 next if $cf_type =~ /^(?:Image|Binary)$/;
2772 $args{'ARGS'}->{'Values'} = undef;
2776 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2777 @values = @{ $args{'ARGS'}->{$arg} };
2778 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2779 @values = ( $args{'ARGS'}->{$arg} );
2781 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2782 if defined $args{'ARGS'}->{$arg};
2784 @values = grep length, map {
2790 grep defined, @values;
2792 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2793 foreach my $value (@values) {
2794 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2798 push( @results, $msg );
2800 } elsif ( $arg eq 'Upload' ) {
2801 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2802 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2803 push( @results, $msg );
2804 } elsif ( $arg eq 'DeleteValues' ) {
2805 foreach my $value (@values) {
2806 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2810 push( @results, $msg );
2812 } elsif ( $arg eq 'DeleteValueIds' ) {
2813 foreach my $value (@values) {
2814 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2818 push( @results, $msg );
2820 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2821 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2824 foreach my $value (@values) {
2825 if ( my $entry = $cf_values->HasEntry($value) ) {
2826 $values_hash{ $entry->id } = 1;
2830 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2834 push( @results, $msg );
2835 $values_hash{$val} = 1 if $val;
2838 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2839 return @results if ( $cf->Type eq 'Date' && ! @values );
2841 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2842 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2844 $cf_values->RedoSearch;
2845 while ( my $cf_value = $cf_values->Next ) {
2846 next if $values_hash{ $cf_value->id };
2848 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2850 ValueId => $cf_value->id
2852 push( @results, $msg );
2854 } elsif ( $arg eq 'Values' ) {
2855 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2857 # keep everything up to the point of difference, delete the rest
2859 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2860 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2869 # now add/replace extra things, if any
2870 foreach my $value (@values) {
2871 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2875 push( @results, $msg );
2880 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2881 $cf->Name, ref $args{'Object'},
2891 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2893 Returns an array of results messages.
2897 sub ProcessTicketWatchers {
2905 my $Ticket = $args{'TicketObj'};
2906 my $ARGSRef = $args{'ARGSRef'};
2910 foreach my $key ( keys %$ARGSRef ) {
2912 # Delete deletable watchers
2913 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2914 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2918 push @results, $msg;
2921 # Delete watchers in the simple style demanded by the bulk manipulator
2922 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2923 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2924 Email => $ARGSRef->{$key},
2927 push @results, $msg;
2930 # Add new wathchers by email address
2931 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2932 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2935 #They're in this order because otherwise $1 gets clobbered :/
2936 my ( $code, $msg ) = $Ticket->AddWatcher(
2937 Type => $ARGSRef->{$key},
2938 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2940 push @results, $msg;
2943 #Add requestors in the simple style demanded by the bulk manipulator
2944 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2945 my ( $code, $msg ) = $Ticket->AddWatcher(
2947 Email => $ARGSRef->{$key}
2949 push @results, $msg;
2952 # Add new watchers by owner
2953 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2954 my $principal_id = $1;
2955 my $form = $ARGSRef->{$key};
2956 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2957 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2959 my ( $code, $msg ) = $Ticket->AddWatcher(
2961 PrincipalId => $principal_id
2963 push @results, $msg;
2973 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2975 Returns an array of results messages.
2979 sub ProcessTicketDates {
2986 my $Ticket = $args{'TicketObj'};
2987 my $ARGSRef = $args{'ARGSRef'};
2992 my @date_fields = qw(
3001 #Run through each field in this list. update the value if apropriate
3002 foreach my $field (@date_fields) {
3003 next unless exists $ARGSRef->{ $field . '_Date' };
3004 next if $ARGSRef->{ $field . '_Date' } eq '';
3008 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3010 Format => 'unknown',
3011 Value => $ARGSRef->{ $field . '_Date' }
3014 my $obj = $field . "Obj";
3015 if ( ( defined $DateObj->Unix )
3016 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
3018 my $method = "Set$field";
3019 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3020 push @results, "$msg";
3030 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3032 Returns an array of results messages.
3036 sub ProcessTicketLinks {
3043 my $Ticket = $args{'TicketObj'};
3044 my $ARGSRef = $args{'ARGSRef'};
3046 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
3048 #Merge if we need to
3049 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
3050 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
3051 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
3052 push @results, $msg;
3059 sub ProcessRecordLinks {
3066 my $Record = $args{'RecordObj'};
3067 my $ARGSRef = $args{'ARGSRef'};
3071 # Delete links that are gone gone gone.
3072 foreach my $arg ( keys %$ARGSRef ) {
3073 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3078 my ( $val, $msg ) = $Record->DeleteLink(
3084 push @results, $msg;
3090 my @linktypes = qw( DependsOn MemberOf RefersTo );
3092 foreach my $linktype (@linktypes) {
3093 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
3094 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
3095 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
3097 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
3099 $luri =~ s/\s+$//; # Strip trailing whitespace
3100 my ( $val, $msg ) = $Record->AddLink(
3104 push @results, $msg;
3107 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
3108 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
3109 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
3111 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
3113 my ( $val, $msg ) = $Record->AddLink(
3118 push @results, $msg;
3126 =head2 ProcessTransactionSquelching
3128 Takes a hashref of the submitted form arguments, C<%ARGS>.
3130 Returns a hash of squelched addresses.
3134 sub ProcessTransactionSquelching {
3136 my %checked = map { $_ => 1 } grep { defined }
3137 ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} :
3138 defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) :
3140 my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3144 =head2 _UploadedFile ( $arg );
3146 Takes a CGI parameter name; if a file is uploaded under that name,
3147 return a hash reference suitable for AddCustomFieldValue's use:
3148 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3150 Returns C<undef> if no files were uploaded in the C<$arg> field.
3156 my $cgi_object = $m->cgi_object;
3157 my $fh = $cgi_object->upload($arg) or return undef;
3158 my $upload_info = $cgi_object->uploadInfo($fh);
3160 my $filename = "$fh";
3161 $filename =~ s#^.*[\\/]##;
3166 LargeContent => do { local $/; scalar <$fh> },
3167 ContentType => $upload_info->{'Content-Type'},
3171 sub GetColumnMapEntry {
3172 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3174 # deal with the simplest thing first
3175 if ( $args{'Map'}{ $args{'Name'} } ) {
3176 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3180 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
3181 return undef unless $args{'Map'}->{$mainkey};
3182 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3183 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3185 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3190 sub ProcessColumnMapValue {
3192 my %args = ( Arguments => [], Escape => 1, @_ );
3195 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3196 my @tmp = $value->( @{ $args{'Arguments'} } );
3197 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3198 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3199 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3200 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3205 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
3209 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3211 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3212 principal collections mapped from the categories given.
3216 sub GetPrincipalsMap {
3221 my $system = RT::Groups->new($session{'CurrentUser'});
3222 $system->LimitToSystemInternalGroups();
3223 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3225 'System' => $system, # loc_left_pair
3230 my $groups = RT::Groups->new($session{'CurrentUser'});
3231 $groups->LimitToUserDefinedGroups();
3232 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3234 # Only show groups who have rights granted on this object
3235 $groups->WithGroupRight(
3238 IncludeSystemRights => 0,
3239 IncludeSubgroupMembers => 0,
3243 'User Groups' => $groups, # loc_left_pair
3248 my $roles = RT::Groups->new($session{'CurrentUser'});
3250 if ($object->isa('RT::System')) {
3251 $roles->LimitToRolesForSystem();
3253 elsif ($object->isa('RT::Queue')) {
3254 $roles->LimitToRolesForQueue($object->Id);
3257 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3260 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3262 'Roles' => $roles, # loc_left_pair
3267 my $Users = RT->PrivilegedUsers->UserMembersObj();
3268 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3270 # Only show users who have rights granted on this object
3271 my $group_members = $Users->WhoHaveGroupRight(
3274 IncludeSystemRights => 0,
3275 IncludeSubgroupMembers => 0,
3278 # Limit to UserEquiv groups
3279 my $groups = $Users->NewAlias('Groups');
3283 ALIAS2 => $group_members,
3286 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3287 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3291 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3294 'Users' => $Users, # loc_left_pair
3302 =head2 _load_container_object ( $type, $id );
3304 Instantiate container object for saving searches.
3308 sub _load_container_object {
3309 my ( $obj_type, $obj_id ) = @_;
3310 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3313 =head2 _parse_saved_search ( $arg );
3315 Given a serialization string for saved search, and returns the
3316 container object and the search id.
3320 sub _parse_saved_search {
3322 return unless $spec;
3323 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3330 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3333 =head2 ScrubHTML content
3335 Removes unsafe and undesired HTML from the passed content
3341 my $Content = shift;
3342 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3344 $Content = '' if !defined($Content);
3345 return $SCRUBBER->scrub($Content);
3350 Returns a new L<HTML::Scrubber> object.
3352 If you need to be more lax about what HTML tags and attributes are allowed,
3353 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3356 package HTML::Mason::Commands;
3357 # Let tables through
3358 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3363 our @SCRUBBER_ALLOWED_TAGS = qw(
3364 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3365 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3368 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3369 # Match http, https, ftp, mailto and relative urls
3370 # XXX: we also scrub format strings with this module then allow simple config options
3371 href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|BaseURL|URL)__)}i,
3377 (?:(?:background-)?color: \s*
3378 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3379 \#[a-f0-9]{3,6} | # #fff or #ffffff
3380 [\w\-]+ # green, light-blue, etc.
3382 text-align: \s* \w+ |
3383 font-size: \s* [\w.\-]+ |
3384 font-family: \s* [\w\s"',.\-]+ |
3385 font-weight: \s* [\w\-]+ |
3387 # MS Office styles, which are probably fine. If we don't, then any
3388 # associated styles in the same attribute get stripped.
3389 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3391 +$ # one or more of these allowed properties from here 'till sunset
3393 dir => qr/^(rtl|ltr)$/i,
3394 lang => qr/^\w+(-\w+)?$/,
3397 our %SCRUBBER_RULES = ();
3400 require HTML::Scrubber;
3401 my $scrubber = HTML::Scrubber->new();
3405 %SCRUBBER_ALLOWED_ATTRIBUTES,
3406 '*' => 0, # require attributes be explicitly allowed
3409 $scrubber->deny(qw[*]);
3410 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3411 $scrubber->rules(%SCRUBBER_RULES);
3413 # Scrubbing comments is vital since IE conditional comments can contain
3414 # arbitrary HTML and we'd pass it right on through.
3415 $scrubber->comment(0);
3422 Redispatches to L<RT::Interface::Web/EncodeJSON>
3427 RT::Interface::Web::EncodeJSON(@_);
3430 package RT::Interface::Web;
3431 RT::Base->_ImportOverlays();