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 # change from stock: if txn custom fields are set but there's no content
1934 # or attachment, create a Touch txn instead of doing nothing
1936 sub ProcessUpdateMessage {
1941 SkipSignatureOnly => 1,
1945 if ( $args{ARGSRef}->{'UpdateAttachments'}
1946 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1948 delete $args{ARGSRef}->{'UpdateAttachments'};
1951 # Strip the signature
1952 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1953 Content => $args{ARGSRef}->{UpdateContent},
1954 ContentType => $args{ARGSRef}->{UpdateContentType},
1955 StripSignature => $args{SkipSignatureOnly},
1956 CurrentUser => $args{'TicketObj'}->CurrentUser,
1959 my %txn_customfields;
1961 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1962 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1963 next if $key =~ /(TimeUnits|Magic)$/;
1964 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1968 # If, after stripping the signature, we have no message, create a
1969 # Touch transaction if necessary
1970 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1971 and not length $args{ARGSRef}->{'UpdateContent'} )
1973 #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1974 # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
1975 # delete $args{ARGSRef}->{'UpdateTimeWorked'};
1978 my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
1979 if ( $timetaken or grep {length $_} values %txn_customfields ) {
1980 my ( $Transaction, $Description, $Object ) =
1981 $args{TicketObj}->Touch(
1982 CustomFields => \%txn_customfields,
1983 TimeTaken => $timetaken
1985 return $Description;
1990 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1991 $args{ARGSRef}->{'UpdateSubject'} = undef;
1994 my $Message = MakeMIMEEntity(
1995 Subject => $args{ARGSRef}->{'UpdateSubject'},
1996 Body => $args{ARGSRef}->{'UpdateContent'},
1997 Type => $args{ARGSRef}->{'UpdateContentType'},
1998 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2001 $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
2002 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
2004 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
2005 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
2006 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
2008 $old_txn = $args{TicketObj}->Transactions->First();
2011 if ( my $msg = $old_txn->Message->First ) {
2012 RT::Interface::Email::SetInReplyTo(
2013 Message => $Message,
2018 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
2019 $Message->make_multipart;
2020 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
2023 if ( $args{ARGSRef}->{'AttachTickets'} ) {
2024 require RT::Action::SendEmail;
2025 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2026 ref $args{ARGSRef}->{'AttachTickets'}
2027 ? @{ $args{ARGSRef}->{'AttachTickets'} }
2028 : ( $args{ARGSRef}->{'AttachTickets'} ) );
2031 my %message_args = (
2032 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
2033 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
2034 MIMEObj => $Message,
2035 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
2036 CustomFields => \%txn_customfields,
2039 _ProcessUpdateMessageRecipients(
2040 MessageArgs => \%message_args,
2045 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2046 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2047 push( @results, $Description );
2048 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2049 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2050 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2051 push( @results, $Description );
2052 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2055 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2060 sub _ProcessUpdateMessageRecipients {
2064 MessageArgs => undef,
2068 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2069 my $cc = $args{ARGSRef}->{'UpdateCc'};
2071 my $message_args = $args{MessageArgs};
2073 $message_args->{CcMessageTo} = $cc;
2074 $message_args->{BccMessageTo} = $bcc;
2077 foreach my $type (qw(Cc AdminCc)) {
2078 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2079 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2080 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2081 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2084 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2085 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2086 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2089 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2090 $message_args->{SquelchMailTo} = \@txn_squelch
2093 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2094 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2095 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2097 my $var = ucfirst($1) . 'MessageTo';
2099 if ( $message_args->{$var} ) {
2100 $message_args->{$var} .= ", $value";
2102 $message_args->{$var} = $value;
2108 sub ProcessAttachments {
2114 my $ARGSRef = $args{ARGSRef} || {};
2115 # deal with deleting uploaded attachments
2116 foreach my $key ( keys %$ARGSRef ) {
2117 if ( $key =~ m/^DeleteAttach-(.+)$/ ) {
2118 delete $session{'Attachments'}{$1};
2120 $session{'Attachments'} = { %{ $session{'Attachments'} || {} } };
2123 # store the uploaded attachment in session
2124 if ( defined $ARGSRef->{'Attach'} && length $ARGSRef->{'Attach'} )
2126 my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' );
2128 my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}");
2129 $session{'Attachments'} =
2130 { %{ $session{'Attachments'} || {} }, $file_path => $attachment, };
2133 # delete temporary storage entry to make WebUI clean
2134 unless ( keys %{ $session{'Attachments'} } and $ARGSRef->{'UpdateAttach'} )
2136 delete $session{'Attachments'};
2141 =head2 MakeMIMEEntity PARAMHASH
2143 Takes a paramhash Subject, Body and AttachmentFieldName.
2145 Also takes Form, Cc and Type as optional paramhash keys.
2147 Returns a MIME::Entity.
2151 sub MakeMIMEEntity {
2153 #TODO document what else this takes.
2159 AttachmentFieldName => undef,
2164 my $Message = MIME::Entity->build(
2165 Type => 'multipart/mixed',
2166 "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
2167 "X-RT-Interface" => $args{Interface},
2168 map { $_ => Encode::encode_utf8( $args{ $_} ) }
2169 grep defined $args{$_}, qw(Subject From Cc)
2172 if ( defined $args{'Body'} && length $args{'Body'} ) {
2174 # Make the update content have no 'weird' newlines in it
2175 $args{'Body'} =~ s/\r\n/\n/gs;
2178 Type => $args{'Type'} || 'text/plain',
2180 Data => $args{'Body'},
2184 if ( $args{'AttachmentFieldName'} ) {
2186 my $cgi_object = $m->cgi_object;
2187 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2188 if ( defined $filehandle && length $filehandle ) {
2190 my ( @content, $buffer );
2191 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2192 push @content, $buffer;
2195 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2197 my $filename = "$filehandle";
2198 $filename =~ s{^.*[\\/]}{};
2201 Type => $uploadinfo->{'Content-Type'},
2202 Filename => $filename,
2205 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2206 $Message->head->set( 'Subject' => $filename );
2209 # Attachment parts really shouldn't get a Message-ID or "interface"
2210 $Message->head->delete('Message-ID');
2211 $Message->head->delete('X-RT-Interface');
2215 $Message->make_singlepart;
2217 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2225 =head2 ParseDateToISO
2227 Takes a date in an arbitrary format.
2228 Returns an ISO date and time in GMT
2232 sub ParseDateToISO {
2235 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2237 Format => 'unknown',
2240 return ( $date_obj->ISO );
2245 sub ProcessACLChanges {
2246 my $ARGSref = shift;
2250 foreach my $arg ( keys %$ARGSref ) {
2251 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2253 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2256 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2257 @rights = @{ $ARGSref->{$arg} };
2259 @rights = $ARGSref->{$arg};
2261 @rights = grep $_, @rights;
2262 next unless @rights;
2264 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2265 $principal->Load($principal_id);
2268 if ( $object_type eq 'RT::System' ) {
2270 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2271 $obj = $object_type->new( $session{'CurrentUser'} );
2272 $obj->Load($object_id);
2273 unless ( $obj->id ) {
2274 $RT::Logger->error("couldn't load $object_type #$object_id");
2278 $RT::Logger->error("object type '$object_type' is incorrect");
2279 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2283 foreach my $right (@rights) {
2284 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2285 push( @results, $msg );
2295 ProcessACLs expects values from a series of checkboxes that describe the full
2296 set of rights a principal should have on an object.
2298 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2299 instead of with the prefixes Grant/RevokeRight. Each input should be an array
2300 listing the rights the principal should have, and ProcessACLs will modify the
2301 current rights to match. Additionally, the previously unused CheckACL input
2302 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2303 rights are removed from a principal and as such no SetRights input is
2309 my $ARGSref = shift;
2310 my (%state, @results);
2312 my $CheckACL = $ARGSref->{'CheckACL'};
2313 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2315 # Check if we want to grant rights to a previously rights-less user
2316 for my $type (qw(user group)) {
2317 my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2320 unless ($principal->PrincipalId) {
2321 push @results, loc("Couldn't load the specified principal");
2325 my $principal_id = $principal->PrincipalId;
2327 # Turn our addprincipal rights spec into a real one
2328 for my $arg (keys %$ARGSref) {
2329 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2331 my $tuple = "$principal_id-$1";
2332 my $key = "SetRights-$tuple";
2334 # If we have it already, that's odd, but merge them
2335 if (grep { $_ eq $tuple } @check) {
2336 $ARGSref->{$key} = [
2337 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2338 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2341 $ARGSref->{$key} = $ARGSref->{$arg};
2342 push @check, $tuple;
2347 # Build our rights state for each Principal-Object tuple
2348 foreach my $arg ( keys %$ARGSref ) {
2349 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2352 my $value = $ARGSref->{$arg};
2353 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2354 next unless @rights;
2356 $state{$tuple} = { map { $_ => 1 } @rights };
2359 foreach my $tuple (List::MoreUtils::uniq @check) {
2360 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2362 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2364 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2365 $principal->Load($principal_id);
2368 if ( $object_type eq 'RT::System' ) {
2370 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2371 $obj = $object_type->new( $session{'CurrentUser'} );
2372 $obj->Load($object_id);
2373 unless ( $obj->id ) {
2374 $RT::Logger->error("couldn't load $object_type #$object_id");
2378 $RT::Logger->error("object type '$object_type' is incorrect");
2379 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2383 my $acls = RT::ACL->new($session{'CurrentUser'});
2384 $acls->LimitToObject( $obj );
2385 $acls->LimitToPrincipal( Id => $principal_id );
2387 while ( my $ace = $acls->Next ) {
2388 my $right = $ace->RightName;
2390 # Has right and should have right
2391 next if delete $state{$tuple}->{$right};
2393 # Has right and shouldn't have right
2394 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2395 push @results, $msg;
2398 # For everything left, they don't have the right but they should
2399 for my $right (keys %{ $state{$tuple} || {} }) {
2400 delete $state{$tuple}->{$right};
2401 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2402 push @results, $msg;
2405 # Check our state for leftovers
2406 if ( keys %{ $state{$tuple} || {} } ) {
2407 my $missed = join '|', %{$state{$tuple} || {}};
2409 "Uh-oh, it looks like we somehow missed a right in "
2410 ."ProcessACLs. Here's what was leftover: $missed"
2418 =head2 _ParseACLNewPrincipal
2420 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>). Looks
2421 for the presence of rights being added on a principal of the specified type,
2422 and returns undef if no new principal is being granted rights. Otherwise loads
2423 up an L<RT::User> or L<RT::Group> object and returns it. Note that the object
2424 may not be successfully loaded, and you should check C<->id> yourself.
2428 sub _ParseACLNewPrincipal {
2429 my $ARGSref = shift;
2430 my $type = lc shift;
2431 my $key = "AddPrincipalForRights-$type";
2433 return unless $ARGSref->{$key};
2436 if ( $type eq 'user' ) {
2437 $principal = RT::User->new( $session{'CurrentUser'} );
2438 $principal->LoadByCol( Name => $ARGSref->{$key} );
2440 elsif ( $type eq 'group' ) {
2441 $principal = RT::Group->new( $session{'CurrentUser'} );
2442 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2448 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2450 @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.
2452 Returns an array of success/failure messages
2456 sub UpdateRecordObject {
2459 AttributesRef => undef,
2461 AttributePrefix => undef,
2465 my $Object = $args{'Object'};
2466 my @results = $Object->Update(
2467 AttributesRef => $args{'AttributesRef'},
2468 ARGSRef => $args{'ARGSRef'},
2469 AttributePrefix => $args{'AttributePrefix'},
2477 sub ProcessCustomFieldUpdates {
2479 CustomFieldObj => undef,
2484 my $Object = $args{'CustomFieldObj'};
2485 my $ARGSRef = $args{'ARGSRef'};
2487 my @attribs = qw(Name Type Description Queue SortOrder);
2488 my @results = UpdateRecordObject(
2489 AttributesRef => \@attribs,
2494 my $prefix = "CustomField-" . $Object->Id;
2495 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2496 my ( $addval, $addmsg ) = $Object->AddValue(
2497 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2498 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2499 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2501 push( @results, $addmsg );
2505 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2506 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2507 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2509 foreach my $id (@delete_values) {
2510 next unless defined $id;
2511 my ( $err, $msg ) = $Object->DeleteValue($id);
2512 push( @results, $msg );
2515 my $vals = $Object->Values();
2516 while ( my $cfv = $vals->Next() ) {
2517 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2518 if ( $cfv->SortOrder != $so ) {
2519 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2520 push( @results, $msg );
2530 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2532 Returns an array of results messages.
2536 sub ProcessTicketBasics {
2544 my $TicketObj = $args{'TicketObj'};
2545 my $ARGSRef = $args{'ARGSRef'};
2547 my $OrigOwner = $TicketObj->Owner;
2562 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2563 for my $field (qw(Queue Owner)) {
2564 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2565 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2566 my $temp = $class->new(RT->SystemUser);
2567 $temp->Load( $ARGSRef->{$field} );
2569 $ARGSRef->{$field} = $temp->id;
2574 # Status isn't a field that can be set to a null value.
2575 # RT core complains if you try
2576 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2578 my @results = UpdateRecordObject(
2579 AttributesRef => \@attribs,
2580 Object => $TicketObj,
2581 ARGSRef => $ARGSRef,
2584 # We special case owner changing, so we can use ForceOwnerChange
2585 if ( $ARGSRef->{'Owner'}
2586 && $ARGSRef->{'Owner'} !~ /\D/
2587 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2589 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2590 $ChownType = "Force";
2596 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2597 push( @results, $msg );
2605 sub ProcessTicketReminders {
2612 my $Ticket = $args{'TicketObj'};
2613 my $args = $args{'ARGSRef'};
2616 my $reminder_collection = $Ticket->Reminders->Collection;
2618 if ( $args->{'update-reminders'} ) {
2619 while ( my $reminder = $reminder_collection->Next ) {
2620 my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2621 if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2622 $Ticket->Reminders->Resolve($reminder);
2624 elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2625 $Ticket->Reminders->Open($reminder);
2628 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2629 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2632 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2633 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2636 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2637 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2639 Format => 'unknown',
2640 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2642 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2643 $reminder->SetDue( $DateObj->ISO );
2649 if ( $args->{'NewReminder-Subject'} ) {
2650 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2652 Format => 'unknown',
2653 Value => $args->{'NewReminder-Due'}
2655 my ( $add_id, $msg ) = $Ticket->Reminders->Add(
2656 Subject => $args->{'NewReminder-Subject'},
2657 Owner => $args->{'NewReminder-Owner'},
2658 Due => $due_obj->ISO
2661 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2664 push @results, $msg;
2670 sub ProcessTicketCustomFieldUpdates {
2672 $args{'Object'} = delete $args{'TicketObj'};
2673 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2675 # Build up a list of objects that we want to work with
2676 my %custom_fields_to_mod;
2677 foreach my $arg ( keys %$ARGSRef ) {
2678 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2679 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2680 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2681 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2682 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2683 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2687 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2690 sub ProcessObjectCustomFieldUpdates {
2692 my $ARGSRef = $args{'ARGSRef'};
2695 # Build up a list of objects that we want to work with
2696 my %custom_fields_to_mod;
2697 foreach my $arg ( keys %$ARGSRef ) {
2699 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2700 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2702 # For each of those objects, find out what custom fields we want to work with.
2703 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2706 # For each of those objects
2707 foreach my $class ( keys %custom_fields_to_mod ) {
2708 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2709 my $Object = $args{'Object'};
2710 $Object = $class->new( $session{'CurrentUser'} )
2711 unless $Object && ref $Object eq $class;
2713 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2714 unless ( $Object->id ) {
2715 $RT::Logger->warning("Couldn't load object $class #$id");
2719 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2720 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2721 $CustomFieldObj->SetContextObject($Object);
2722 $CustomFieldObj->LoadById($cf);
2723 unless ( $CustomFieldObj->id ) {
2724 $RT::Logger->warning("Couldn't load custom field #$cf");
2728 _ProcessObjectCustomFieldUpdates(
2729 Prefix => "Object-$class-$id-CustomField-$cf-",
2731 CustomField => $CustomFieldObj,
2732 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2740 sub _ProcessObjectCustomFieldUpdates {
2742 my $cf = $args{'CustomField'};
2743 my $cf_type = $cf->Type || '';
2745 # Remove blank Values since the magic field will take care of this. Sometimes
2746 # the browser gives you a blank value which causes CFs to be processed twice
2747 if ( defined $args{'ARGS'}->{'Values'}
2748 && !length $args{'ARGS'}->{'Values'}
2749 && $args{'ARGS'}->{'Values-Magic'} )
2751 delete $args{'ARGS'}->{'Values'};
2755 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2757 # skip category argument
2758 next if $arg eq 'Category';
2761 next if $arg eq 'Value-TimeUnits';
2763 # since http won't pass in a form element with a null value, we need
2765 if ( $arg eq 'Values-Magic' ) {
2767 # We don't care about the magic, if there's really a values element;
2768 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2769 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2771 # "Empty" values does not mean anything for Image and Binary fields
2772 next if $cf_type =~ /^(?:Image|Binary)$/;
2775 $args{'ARGS'}->{'Values'} = undef;
2779 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2780 @values = @{ $args{'ARGS'}->{$arg} };
2781 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2782 @values = ( $args{'ARGS'}->{$arg} );
2784 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2785 if defined $args{'ARGS'}->{$arg};
2787 @values = grep length, map {
2793 grep defined, @values;
2795 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2796 foreach my $value (@values) {
2797 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2801 push( @results, $msg );
2803 } elsif ( $arg eq 'Upload' ) {
2804 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2805 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2806 push( @results, $msg );
2807 } elsif ( $arg eq 'DeleteValues' ) {
2808 foreach my $value (@values) {
2809 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2813 push( @results, $msg );
2815 } elsif ( $arg eq 'DeleteValueIds' ) {
2816 foreach my $value (@values) {
2817 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2821 push( @results, $msg );
2823 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2824 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2827 foreach my $value (@values) {
2828 if ( my $entry = $cf_values->HasEntry($value) ) {
2829 $values_hash{ $entry->id } = 1;
2833 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2837 push( @results, $msg );
2838 $values_hash{$val} = 1 if $val;
2841 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2842 return @results if ( $cf->Type eq 'Date' && ! @values );
2844 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2845 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2847 $cf_values->RedoSearch;
2848 while ( my $cf_value = $cf_values->Next ) {
2849 next if $values_hash{ $cf_value->id };
2851 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2853 ValueId => $cf_value->id
2855 push( @results, $msg );
2857 } elsif ( $arg eq 'Values' ) {
2858 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2860 # keep everything up to the point of difference, delete the rest
2862 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2863 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2872 # now add/replace extra things, if any
2873 foreach my $value (@values) {
2874 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2878 push( @results, $msg );
2883 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2884 $cf->Name, ref $args{'Object'},
2894 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2896 Returns an array of results messages.
2900 sub ProcessTicketWatchers {
2908 my $Ticket = $args{'TicketObj'};
2909 my $ARGSRef = $args{'ARGSRef'};
2913 foreach my $key ( keys %$ARGSRef ) {
2915 # Delete deletable watchers
2916 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2917 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2921 push @results, $msg;
2924 # Delete watchers in the simple style demanded by the bulk manipulator
2925 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2926 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2927 Email => $ARGSRef->{$key},
2930 push @results, $msg;
2933 # Add new wathchers by email address
2934 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2935 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2938 #They're in this order because otherwise $1 gets clobbered :/
2939 my ( $code, $msg ) = $Ticket->AddWatcher(
2940 Type => $ARGSRef->{$key},
2941 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2943 push @results, $msg;
2946 #Add requestors in the simple style demanded by the bulk manipulator
2947 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2948 my ( $code, $msg ) = $Ticket->AddWatcher(
2950 Email => $ARGSRef->{$key}
2952 push @results, $msg;
2955 # Add new watchers by owner
2956 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2957 my $principal_id = $1;
2958 my $form = $ARGSRef->{$key};
2959 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2960 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2962 my ( $code, $msg ) = $Ticket->AddWatcher(
2964 PrincipalId => $principal_id
2966 push @results, $msg;
2976 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2978 Returns an array of results messages.
2982 sub ProcessTicketDates {
2989 my $Ticket = $args{'TicketObj'};
2990 my $ARGSRef = $args{'ARGSRef'};
2995 my @date_fields = qw(
3004 #Run through each field in this list. update the value if apropriate
3005 foreach my $field (@date_fields) {
3006 next unless exists $ARGSRef->{ $field . '_Date' };
3007 next if $ARGSRef->{ $field . '_Date' } eq '';
3011 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3013 Format => 'unknown',
3014 Value => $ARGSRef->{ $field . '_Date' }
3017 my $obj = $field . "Obj";
3018 if ( ( defined $DateObj->Unix )
3019 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
3021 my $method = "Set$field";
3022 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3023 push @results, "$msg";
3033 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3035 Returns an array of results messages.
3039 sub ProcessTicketLinks {
3046 my $Ticket = $args{'TicketObj'};
3047 my $ARGSRef = $args{'ARGSRef'};
3049 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
3051 #Merge if we need to
3052 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
3053 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
3054 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
3055 push @results, $msg;
3062 sub ProcessRecordLinks {
3069 my $Record = $args{'RecordObj'};
3070 my $ARGSRef = $args{'ARGSRef'};
3074 # Delete links that are gone gone gone.
3075 foreach my $arg ( keys %$ARGSRef ) {
3076 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3081 my ( $val, $msg ) = $Record->DeleteLink(
3087 push @results, $msg;
3093 my @linktypes = qw( DependsOn MemberOf RefersTo );
3095 foreach my $linktype (@linktypes) {
3096 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
3097 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
3098 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
3100 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
3102 $luri =~ s/\s+$//; # Strip trailing whitespace
3103 my ( $val, $msg ) = $Record->AddLink(
3107 push @results, $msg;
3110 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
3111 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
3112 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
3114 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
3116 my ( $val, $msg ) = $Record->AddLink(
3121 push @results, $msg;
3129 =head2 ProcessTransactionSquelching
3131 Takes a hashref of the submitted form arguments, C<%ARGS>.
3133 Returns a hash of squelched addresses.
3137 sub ProcessTransactionSquelching {
3139 my %checked = map { $_ => 1 } grep { defined }
3140 ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} :
3141 defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) :
3143 my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3147 =head2 _UploadedFile ( $arg );
3149 Takes a CGI parameter name; if a file is uploaded under that name,
3150 return a hash reference suitable for AddCustomFieldValue's use:
3151 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3153 Returns C<undef> if no files were uploaded in the C<$arg> field.
3159 my $cgi_object = $m->cgi_object;
3160 my $fh = $cgi_object->upload($arg) or return undef;
3161 my $upload_info = $cgi_object->uploadInfo($fh);
3163 my $filename = "$fh";
3164 $filename =~ s#^.*[\\/]##;
3169 LargeContent => do { local $/; scalar <$fh> },
3170 ContentType => $upload_info->{'Content-Type'},
3174 sub GetColumnMapEntry {
3175 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3177 # deal with the simplest thing first
3178 if ( $args{'Map'}{ $args{'Name'} } ) {
3179 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3183 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
3184 return undef unless $args{'Map'}->{$mainkey};
3185 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3186 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3188 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3193 sub ProcessColumnMapValue {
3195 my %args = ( Arguments => [], Escape => 1, @_ );
3198 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3199 my @tmp = $value->( @{ $args{'Arguments'} } );
3200 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3201 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3202 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3203 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3208 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
3212 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3214 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3215 principal collections mapped from the categories given.
3219 sub GetPrincipalsMap {
3224 my $system = RT::Groups->new($session{'CurrentUser'});
3225 $system->LimitToSystemInternalGroups();
3226 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3228 'System' => $system, # loc_left_pair
3233 my $groups = RT::Groups->new($session{'CurrentUser'});
3234 $groups->LimitToUserDefinedGroups();
3235 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3237 # Only show groups who have rights granted on this object
3238 $groups->WithGroupRight(
3241 IncludeSystemRights => 0,
3242 IncludeSubgroupMembers => 0,
3246 'User Groups' => $groups, # loc_left_pair
3251 my $roles = RT::Groups->new($session{'CurrentUser'});
3253 if ($object->isa('RT::System')) {
3254 $roles->LimitToRolesForSystem();
3256 elsif ($object->isa('RT::Queue')) {
3257 $roles->LimitToRolesForQueue($object->Id);
3260 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3263 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3265 'Roles' => $roles, # loc_left_pair
3270 my $Users = RT->PrivilegedUsers->UserMembersObj();
3271 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3273 # Only show users who have rights granted on this object
3274 my $group_members = $Users->WhoHaveGroupRight(
3277 IncludeSystemRights => 0,
3278 IncludeSubgroupMembers => 0,
3281 # Limit to UserEquiv groups
3282 my $groups = $Users->NewAlias('Groups');
3286 ALIAS2 => $group_members,
3289 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3290 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3294 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3297 'Users' => $Users, # loc_left_pair
3305 =head2 _load_container_object ( $type, $id );
3307 Instantiate container object for saving searches.
3311 sub _load_container_object {
3312 my ( $obj_type, $obj_id ) = @_;
3313 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3316 =head2 _parse_saved_search ( $arg );
3318 Given a serialization string for saved search, and returns the
3319 container object and the search id.
3323 sub _parse_saved_search {
3325 return unless $spec;
3326 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3333 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3336 =head2 ScrubHTML content
3338 Removes unsafe and undesired HTML from the passed content
3344 my $Content = shift;
3345 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3347 $Content = '' if !defined($Content);
3348 return $SCRUBBER->scrub($Content);
3353 Returns a new L<HTML::Scrubber> object.
3355 If you need to be more lax about what HTML tags and attributes are allowed,
3356 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3359 package HTML::Mason::Commands;
3360 # Let tables through
3361 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3366 our @SCRUBBER_ALLOWED_TAGS = qw(
3367 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3368 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3371 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3372 # Match http, https, ftp, mailto and relative urls
3373 # XXX: we also scrub format strings with this module then allow simple config options
3374 href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|BaseURL|URL)__)}i,
3380 (?:(?:background-)?color: \s*
3381 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3382 \#[a-f0-9]{3,6} | # #fff or #ffffff
3383 [\w\-]+ # green, light-blue, etc.
3385 text-align: \s* \w+ |
3386 font-size: \s* [\w.\-]+ |
3387 font-family: \s* [\w\s"',.\-]+ |
3388 font-weight: \s* [\w\-]+ |
3390 # MS Office styles, which are probably fine. If we don't, then any
3391 # associated styles in the same attribute get stripped.
3392 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3394 +$ # one or more of these allowed properties from here 'till sunset
3396 dir => qr/^(rtl|ltr)$/i,
3397 lang => qr/^\w+(-\w+)?$/,
3400 our %SCRUBBER_RULES = ();
3403 require HTML::Scrubber;
3404 my $scrubber = HTML::Scrubber->new();
3408 %SCRUBBER_ALLOWED_ATTRIBUTES,
3409 '*' => 0, # require attributes be explicitly allowed
3412 $scrubber->deny(qw[*]);
3413 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3414 $scrubber->rules(%SCRUBBER_RULES);
3416 # Scrubbing comments is vital since IE conditional comments can contain
3417 # arbitrary HTML and we'd pass it right on through.
3418 $scrubber->comment(0);
3425 Redispatches to L<RT::Interface::Web/EncodeJSON>
3430 RT::Interface::Web::EncodeJSON(@_);
3433 package RT::Interface::Web;
3434 RT::Base->_ImportOverlays();