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 # If, after stripping the signature, we have no message, move the
1957 # UpdateTimeWorked into adjusted TimeWorked, so that a later
1958 # ProcessBasics can deal -- then bail out.
1959 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1960 and not length $args{ARGSRef}->{'UpdateContent'} )
1962 if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1963 $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'};
1968 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1969 $args{ARGSRef}->{'UpdateSubject'} = undef;
1972 my $Message = MakeMIMEEntity(
1973 Subject => $args{ARGSRef}->{'UpdateSubject'},
1974 Body => $args{ARGSRef}->{'UpdateContent'},
1975 Type => $args{ARGSRef}->{'UpdateContentType'},
1976 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
1979 $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
1980 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
1982 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
1983 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
1984 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
1986 $old_txn = $args{TicketObj}->Transactions->First();
1989 if ( my $msg = $old_txn->Message->First ) {
1990 RT::Interface::Email::SetInReplyTo(
1991 Message => $Message,
1996 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
1997 $Message->make_multipart;
1998 $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} };
2001 if ( $args{ARGSRef}->{'AttachTickets'} ) {
2002 require RT::Action::SendEmail;
2003 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2004 ref $args{ARGSRef}->{'AttachTickets'}
2005 ? @{ $args{ARGSRef}->{'AttachTickets'} }
2006 : ( $args{ARGSRef}->{'AttachTickets'} ) );
2009 my %txn_customfields;
2011 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2012 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
2013 $txn_customfields{$key} = $args{ARGSRef}->{$key};
2017 my %message_args = (
2018 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
2019 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
2020 MIMEObj => $Message,
2021 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
2022 CustomFields => \%txn_customfields,
2025 _ProcessUpdateMessageRecipients(
2026 MessageArgs => \%message_args,
2031 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2032 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2033 push( @results, $Description );
2034 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2035 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2036 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2037 push( @results, $Description );
2038 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2041 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2046 sub _ProcessUpdateMessageRecipients {
2050 MessageArgs => undef,
2054 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2055 my $cc = $args{ARGSRef}->{'UpdateCc'};
2057 my $message_args = $args{MessageArgs};
2059 $message_args->{CcMessageTo} = $cc;
2060 $message_args->{BccMessageTo} = $bcc;
2063 foreach my $type (qw(Cc AdminCc)) {
2064 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2065 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2066 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2067 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2070 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2071 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2072 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2076 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2077 $message_args->{SquelchMailTo} = \@txn_squelch
2080 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2081 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2082 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2084 my $var = ucfirst($1) . 'MessageTo';
2086 if ( $message_args->{$var} ) {
2087 $message_args->{$var} .= ", $value";
2089 $message_args->{$var} = $value;
2095 =head2 MakeMIMEEntity PARAMHASH
2097 Takes a paramhash Subject, Body and AttachmentFieldName.
2099 Also takes Form, Cc and Type as optional paramhash keys.
2101 Returns a MIME::Entity.
2105 sub MakeMIMEEntity {
2107 #TODO document what else this takes.
2113 AttachmentFieldName => undef,
2118 my $Message = MIME::Entity->build(
2119 Type => 'multipart/mixed',
2120 "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
2121 "X-RT-Interface" => $args{Interface},
2122 map { $_ => Encode::encode_utf8( $args{ $_} ) }
2123 grep defined $args{$_}, qw(Subject From Cc)
2126 if ( defined $args{'Body'} && length $args{'Body'} ) {
2128 # Make the update content have no 'weird' newlines in it
2129 $args{'Body'} =~ s/\r\n/\n/gs;
2132 Type => $args{'Type'} || 'text/plain',
2134 Data => $args{'Body'},
2138 if ( $args{'AttachmentFieldName'} ) {
2140 my $cgi_object = $m->cgi_object;
2141 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2142 if ( defined $filehandle && length $filehandle ) {
2144 my ( @content, $buffer );
2145 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2146 push @content, $buffer;
2149 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2151 my $filename = "$filehandle";
2152 $filename =~ s{^.*[\\/]}{};
2155 Type => $uploadinfo->{'Content-Type'},
2156 Filename => $filename,
2159 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2160 $Message->head->set( 'Subject' => $filename );
2163 # Attachment parts really shouldn't get a Message-ID or "interface"
2164 $Message->head->delete('Message-ID');
2165 $Message->head->delete('X-RT-Interface');
2169 $Message->make_singlepart;
2171 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2177 sub ProcessAttachments {
2183 my $ARGSRef = $args{ARGSRef} || {};
2184 # deal with deleting uploaded attachments
2185 foreach my $key ( keys %$ARGSRef ) {
2186 if ( $key =~ m/^DeleteAttach-(.+)$/ ) {
2187 delete $session{'Attachments'}{$1};
2189 $session{'Attachments'} = { %{ $session{'Attachments'} || {} } };
2192 # store the uploaded attachment in session
2193 if ( defined $ARGSRef->{'Attach'} && length $ARGSRef->{'Attach'} )
2195 my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' );
2197 my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}");
2198 $session{'Attachments'} =
2199 { %{ $session{'Attachments'} || {} }, $file_path => $attachment, };
2202 # delete temporary storage entry to make WebUI clean
2203 unless ( keys %{ $session{'Attachments'} } and $ARGSRef->{'UpdateAttach'} )
2205 delete $session{'Attachments'};
2210 =head2 ParseDateToISO
2212 Takes a date in an arbitrary format.
2213 Returns an ISO date and time in GMT
2217 sub ParseDateToISO {
2220 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2222 Format => 'unknown',
2225 return ( $date_obj->ISO );
2230 sub ProcessACLChanges {
2231 my $ARGSref = shift;
2235 foreach my $arg ( keys %$ARGSref ) {
2236 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2238 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2241 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2242 @rights = @{ $ARGSref->{$arg} };
2244 @rights = $ARGSref->{$arg};
2246 @rights = grep $_, @rights;
2247 next unless @rights;
2249 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2250 $principal->Load($principal_id);
2253 if ( $object_type eq 'RT::System' ) {
2255 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2256 $obj = $object_type->new( $session{'CurrentUser'} );
2257 $obj->Load($object_id);
2258 unless ( $obj->id ) {
2259 $RT::Logger->error("couldn't load $object_type #$object_id");
2263 $RT::Logger->error("object type '$object_type' is incorrect");
2264 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2268 foreach my $right (@rights) {
2269 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2270 push( @results, $msg );
2280 ProcessACLs expects values from a series of checkboxes that describe the full
2281 set of rights a principal should have on an object.
2283 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2284 instead of with the prefixes Grant/RevokeRight. Each input should be an array
2285 listing the rights the principal should have, and ProcessACLs will modify the
2286 current rights to match. Additionally, the previously unused CheckACL input
2287 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2288 rights are removed from a principal and as such no SetRights input is
2294 my $ARGSref = shift;
2295 my (%state, @results);
2297 my $CheckACL = $ARGSref->{'CheckACL'};
2298 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2300 # Check if we want to grant rights to a previously rights-less user
2301 for my $type (qw(user group)) {
2302 my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2305 unless ($principal->PrincipalId) {
2306 push @results, loc("Couldn't load the specified principal");
2310 my $principal_id = $principal->PrincipalId;
2312 # Turn our addprincipal rights spec into a real one
2313 for my $arg (keys %$ARGSref) {
2314 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2316 my $tuple = "$principal_id-$1";
2317 my $key = "SetRights-$tuple";
2319 # If we have it already, that's odd, but merge them
2320 if (grep { $_ eq $tuple } @check) {
2321 $ARGSref->{$key} = [
2322 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2323 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2326 $ARGSref->{$key} = $ARGSref->{$arg};
2327 push @check, $tuple;
2332 # Build our rights state for each Principal-Object tuple
2333 foreach my $arg ( keys %$ARGSref ) {
2334 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2337 my $value = $ARGSref->{$arg};
2338 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2339 next unless @rights;
2341 $state{$tuple} = { map { $_ => 1 } @rights };
2344 foreach my $tuple (List::MoreUtils::uniq @check) {
2345 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2347 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2349 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2350 $principal->Load($principal_id);
2353 if ( $object_type eq 'RT::System' ) {
2355 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2356 $obj = $object_type->new( $session{'CurrentUser'} );
2357 $obj->Load($object_id);
2358 unless ( $obj->id ) {
2359 $RT::Logger->error("couldn't load $object_type #$object_id");
2363 $RT::Logger->error("object type '$object_type' is incorrect");
2364 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2368 my $acls = RT::ACL->new($session{'CurrentUser'});
2369 $acls->LimitToObject( $obj );
2370 $acls->LimitToPrincipal( Id => $principal_id );
2372 while ( my $ace = $acls->Next ) {
2373 my $right = $ace->RightName;
2375 # Has right and should have right
2376 next if delete $state{$tuple}->{$right};
2378 # Has right and shouldn't have right
2379 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2380 push @results, $msg;
2383 # For everything left, they don't have the right but they should
2384 for my $right (keys %{ $state{$tuple} || {} }) {
2385 delete $state{$tuple}->{$right};
2386 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2387 push @results, $msg;
2390 # Check our state for leftovers
2391 if ( keys %{ $state{$tuple} || {} } ) {
2392 my $missed = join '|', %{$state{$tuple} || {}};
2394 "Uh-oh, it looks like we somehow missed a right in "
2395 ."ProcessACLs. Here's what was leftover: $missed"
2403 =head2 _ParseACLNewPrincipal
2405 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>). Looks
2406 for the presence of rights being added on a principal of the specified type,
2407 and returns undef if no new principal is being granted rights. Otherwise loads
2408 up an L<RT::User> or L<RT::Group> object and returns it. Note that the object
2409 may not be successfully loaded, and you should check C<->id> yourself.
2413 sub _ParseACLNewPrincipal {
2414 my $ARGSref = shift;
2415 my $type = lc shift;
2416 my $key = "AddPrincipalForRights-$type";
2418 return unless $ARGSref->{$key};
2421 if ( $type eq 'user' ) {
2422 $principal = RT::User->new( $session{'CurrentUser'} );
2423 $principal->LoadByCol( Name => $ARGSref->{$key} );
2425 elsif ( $type eq 'group' ) {
2426 $principal = RT::Group->new( $session{'CurrentUser'} );
2427 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2433 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2435 @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.
2437 Returns an array of success/failure messages
2441 sub UpdateRecordObject {
2444 AttributesRef => undef,
2446 AttributePrefix => undef,
2450 my $Object = $args{'Object'};
2451 my @results = $Object->Update(
2452 AttributesRef => $args{'AttributesRef'},
2453 ARGSRef => $args{'ARGSRef'},
2454 AttributePrefix => $args{'AttributePrefix'},
2462 sub ProcessCustomFieldUpdates {
2464 CustomFieldObj => undef,
2469 my $Object = $args{'CustomFieldObj'};
2470 my $ARGSRef = $args{'ARGSRef'};
2472 my @attribs = qw(Name Type Description Queue SortOrder);
2473 my @results = UpdateRecordObject(
2474 AttributesRef => \@attribs,
2479 my $prefix = "CustomField-" . $Object->Id;
2480 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2481 my ( $addval, $addmsg ) = $Object->AddValue(
2482 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2483 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2484 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2486 push( @results, $addmsg );
2490 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2491 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2492 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2494 foreach my $id (@delete_values) {
2495 next unless defined $id;
2496 my ( $err, $msg ) = $Object->DeleteValue($id);
2497 push( @results, $msg );
2500 my $vals = $Object->Values();
2501 while ( my $cfv = $vals->Next() ) {
2502 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2503 if ( $cfv->SortOrder != $so ) {
2504 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2505 push( @results, $msg );
2515 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2517 Returns an array of results messages.
2521 sub ProcessTicketBasics {
2529 my $TicketObj = $args{'TicketObj'};
2530 my $ARGSRef = $args{'ARGSRef'};
2532 my $OrigOwner = $TicketObj->Owner;
2547 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2548 for my $field (qw(Queue Owner)) {
2549 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2550 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2551 my $temp = $class->new(RT->SystemUser);
2552 $temp->Load( $ARGSRef->{$field} );
2554 $ARGSRef->{$field} = $temp->id;
2559 # Status isn't a field that can be set to a null value.
2560 # RT core complains if you try
2561 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2563 my @results = UpdateRecordObject(
2564 AttributesRef => \@attribs,
2565 Object => $TicketObj,
2566 ARGSRef => $ARGSRef,
2569 # We special case owner changing, so we can use ForceOwnerChange
2570 if ( $ARGSRef->{'Owner'}
2571 && $ARGSRef->{'Owner'} !~ /\D/
2572 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2574 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2575 $ChownType = "Force";
2581 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2582 push( @results, $msg );
2590 sub ProcessTicketReminders {
2597 my $Ticket = $args{'TicketObj'};
2598 my $args = $args{'ARGSRef'};
2601 my $reminder_collection = $Ticket->Reminders->Collection;
2603 if ( $args->{'update-reminders'} ) {
2604 while ( my $reminder = $reminder_collection->Next ) {
2605 my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2606 if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2607 $Ticket->Reminders->Resolve($reminder);
2609 elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2610 $Ticket->Reminders->Open($reminder);
2613 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2614 $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2617 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2618 $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2621 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2622 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2624 Format => 'unknown',
2625 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2627 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2628 $reminder->SetDue( $DateObj->ISO );
2634 if ( $args->{'NewReminder-Subject'} ) {
2635 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2637 Format => 'unknown',
2638 Value => $args->{'NewReminder-Due'}
2640 my ( $add_id, $msg ) = $Ticket->Reminders->Add(
2641 Subject => $args->{'NewReminder-Subject'},
2642 Owner => $args->{'NewReminder-Owner'},
2643 Due => $due_obj->ISO
2646 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2649 push @results, $msg;
2655 sub ProcessTicketCustomFieldUpdates {
2657 $args{'Object'} = delete $args{'TicketObj'};
2658 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2660 # Build up a list of objects that we want to work with
2661 my %custom_fields_to_mod;
2662 foreach my $arg ( keys %$ARGSRef ) {
2663 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2664 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2665 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2666 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2667 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2668 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2672 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2675 sub ProcessObjectCustomFieldUpdates {
2677 my $ARGSRef = $args{'ARGSRef'};
2680 # Build up a list of objects that we want to work with
2681 my %custom_fields_to_mod;
2682 foreach my $arg ( keys %$ARGSRef ) {
2684 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2685 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2687 # For each of those objects, find out what custom fields we want to work with.
2688 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2691 # For each of those objects
2692 foreach my $class ( keys %custom_fields_to_mod ) {
2693 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2694 my $Object = $args{'Object'};
2695 $Object = $class->new( $session{'CurrentUser'} )
2696 unless $Object && ref $Object eq $class;
2698 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2699 unless ( $Object->id ) {
2700 $RT::Logger->warning("Couldn't load object $class #$id");
2704 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2705 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2706 $CustomFieldObj->SetContextObject($Object);
2707 $CustomFieldObj->LoadById($cf);
2708 unless ( $CustomFieldObj->id ) {
2709 $RT::Logger->warning("Couldn't load custom field #$cf");
2713 _ProcessObjectCustomFieldUpdates(
2714 Prefix => "Object-$class-$id-CustomField-$cf-",
2716 CustomField => $CustomFieldObj,
2717 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2725 sub _ProcessObjectCustomFieldUpdates {
2727 my $cf = $args{'CustomField'};
2728 my $cf_type = $cf->Type || '';
2730 # Remove blank Values since the magic field will take care of this. Sometimes
2731 # the browser gives you a blank value which causes CFs to be processed twice
2732 if ( defined $args{'ARGS'}->{'Values'}
2733 && !length $args{'ARGS'}->{'Values'}
2734 && $args{'ARGS'}->{'Values-Magic'} )
2736 delete $args{'ARGS'}->{'Values'};
2740 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2742 # skip category argument
2743 next if $arg eq 'Category';
2746 next if $arg eq 'Value-TimeUnits';
2748 # since http won't pass in a form element with a null value, we need
2750 if ( $arg eq 'Values-Magic' ) {
2752 # We don't care about the magic, if there's really a values element;
2753 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2754 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2756 # "Empty" values does not mean anything for Image and Binary fields
2757 next if $cf_type =~ /^(?:Image|Binary)$/;
2760 $args{'ARGS'}->{'Values'} = undef;
2764 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2765 @values = @{ $args{'ARGS'}->{$arg} };
2766 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2767 @values = ( $args{'ARGS'}->{$arg} );
2769 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2770 if defined $args{'ARGS'}->{$arg};
2772 @values = grep length, map {
2778 grep defined, @values;
2780 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2781 foreach my $value (@values) {
2782 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2786 push( @results, $msg );
2788 } elsif ( $arg eq 'Upload' ) {
2789 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2790 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2791 push( @results, $msg );
2792 } elsif ( $arg eq 'DeleteValues' ) {
2793 foreach my $value (@values) {
2794 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2798 push( @results, $msg );
2800 } elsif ( $arg eq 'DeleteValueIds' ) {
2801 foreach my $value (@values) {
2802 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2806 push( @results, $msg );
2808 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2809 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2812 foreach my $value (@values) {
2813 if ( my $entry = $cf_values->HasEntry($value) ) {
2814 $values_hash{ $entry->id } = 1;
2818 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2822 push( @results, $msg );
2823 $values_hash{$val} = 1 if $val;
2826 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2827 return @results if ( $cf->Type eq 'Date' && ! @values );
2829 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2830 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2832 $cf_values->RedoSearch;
2833 while ( my $cf_value = $cf_values->Next ) {
2834 next if $values_hash{ $cf_value->id };
2836 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2838 ValueId => $cf_value->id
2840 push( @results, $msg );
2842 } elsif ( $arg eq 'Values' ) {
2843 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2845 # keep everything up to the point of difference, delete the rest
2847 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2848 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2857 # now add/replace extra things, if any
2858 foreach my $value (@values) {
2859 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2863 push( @results, $msg );
2868 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2869 $cf->Name, ref $args{'Object'},
2879 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2881 Returns an array of results messages.
2885 sub ProcessTicketWatchers {
2893 my $Ticket = $args{'TicketObj'};
2894 my $ARGSRef = $args{'ARGSRef'};
2898 foreach my $key ( keys %$ARGSRef ) {
2900 # Delete deletable watchers
2901 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2902 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2906 push @results, $msg;
2909 # Delete watchers in the simple style demanded by the bulk manipulator
2910 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2911 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2912 Email => $ARGSRef->{$key},
2915 push @results, $msg;
2918 # Add new wathchers by email address
2919 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2920 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2923 #They're in this order because otherwise $1 gets clobbered :/
2924 my ( $code, $msg ) = $Ticket->AddWatcher(
2925 Type => $ARGSRef->{$key},
2926 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2928 push @results, $msg;
2931 #Add requestors in the simple style demanded by the bulk manipulator
2932 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2933 my ( $code, $msg ) = $Ticket->AddWatcher(
2935 Email => $ARGSRef->{$key}
2937 push @results, $msg;
2940 # Add new watchers by owner
2941 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2942 my $principal_id = $1;
2943 my $form = $ARGSRef->{$key};
2944 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2945 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2947 my ( $code, $msg ) = $Ticket->AddWatcher(
2949 PrincipalId => $principal_id
2951 push @results, $msg;
2961 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2963 Returns an array of results messages.
2967 sub ProcessTicketDates {
2974 my $Ticket = $args{'TicketObj'};
2975 my $ARGSRef = $args{'ARGSRef'};
2980 my @date_fields = qw(
2989 #Run through each field in this list. update the value if apropriate
2990 foreach my $field (@date_fields) {
2991 next unless exists $ARGSRef->{ $field . '_Date' };
2992 next if $ARGSRef->{ $field . '_Date' } eq '';
2996 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2998 Format => 'unknown',
2999 Value => $ARGSRef->{ $field . '_Date' }
3002 my $obj = $field . "Obj";
3003 if ( ( defined $DateObj->Unix )
3004 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
3006 my $method = "Set$field";
3007 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3008 push @results, "$msg";
3018 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3020 Returns an array of results messages.
3024 sub ProcessTicketLinks {
3031 my $Ticket = $args{'TicketObj'};
3032 my $ARGSRef = $args{'ARGSRef'};
3034 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
3036 #Merge if we need to
3037 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
3038 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
3039 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
3040 push @results, $msg;
3047 sub ProcessRecordLinks {
3054 my $Record = $args{'RecordObj'};
3055 my $ARGSRef = $args{'ARGSRef'};
3059 # Delete links that are gone gone gone.
3060 foreach my $arg ( keys %$ARGSRef ) {
3061 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3066 my ( $val, $msg ) = $Record->DeleteLink(
3072 push @results, $msg;
3078 my @linktypes = qw( DependsOn MemberOf RefersTo );
3080 foreach my $linktype (@linktypes) {
3081 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
3082 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
3083 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
3085 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
3087 $luri =~ s/\s+$//; # Strip trailing whitespace
3088 my ( $val, $msg ) = $Record->AddLink(
3092 push @results, $msg;
3095 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
3096 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
3097 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
3099 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
3101 my ( $val, $msg ) = $Record->AddLink(
3106 push @results, $msg;
3114 =head2 ProcessTransactionSquelching
3116 Takes a hashref of the submitted form arguments, C<%ARGS>.
3118 Returns a hash of squelched addresses.
3122 sub ProcessTransactionSquelching {
3124 my %checked = map { $_ => 1 } grep { defined }
3125 ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} :
3126 defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) :
3128 my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3132 =head2 _UploadedFile ( $arg );
3134 Takes a CGI parameter name; if a file is uploaded under that name,
3135 return a hash reference suitable for AddCustomFieldValue's use:
3136 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3138 Returns C<undef> if no files were uploaded in the C<$arg> field.
3144 my $cgi_object = $m->cgi_object;
3145 my $fh = $cgi_object->upload($arg) or return undef;
3146 my $upload_info = $cgi_object->uploadInfo($fh);
3148 my $filename = "$fh";
3149 $filename =~ s#^.*[\\/]##;
3154 LargeContent => do { local $/; scalar <$fh> },
3155 ContentType => $upload_info->{'Content-Type'},
3159 sub GetColumnMapEntry {
3160 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3162 # deal with the simplest thing first
3163 if ( $args{'Map'}{ $args{'Name'} } ) {
3164 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3168 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) {
3169 return undef unless $args{'Map'}->{$mainkey};
3170 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3171 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3173 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3178 sub ProcessColumnMapValue {
3180 my %args = ( Arguments => [], Escape => 1, @_ );
3183 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3184 my @tmp = $value->( @{ $args{'Arguments'} } );
3185 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3186 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3187 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3188 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3193 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
3197 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3199 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3200 principal collections mapped from the categories given.
3204 sub GetPrincipalsMap {
3209 my $system = RT::Groups->new($session{'CurrentUser'});
3210 $system->LimitToSystemInternalGroups();
3211 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3213 'System' => $system, # loc_left_pair
3218 my $groups = RT::Groups->new($session{'CurrentUser'});
3219 $groups->LimitToUserDefinedGroups();
3220 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3222 # Only show groups who have rights granted on this object
3223 $groups->WithGroupRight(
3226 IncludeSystemRights => 0,
3227 IncludeSubgroupMembers => 0,
3231 'User Groups' => $groups, # loc_left_pair
3236 my $roles = RT::Groups->new($session{'CurrentUser'});
3238 if ($object->isa('RT::System')) {
3239 $roles->LimitToRolesForSystem();
3241 elsif ($object->isa('RT::Queue')) {
3242 $roles->LimitToRolesForQueue($object->Id);
3245 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3248 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3250 'Roles' => $roles, # loc_left_pair
3255 my $Users = RT->PrivilegedUsers->UserMembersObj();
3256 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3258 # Only show users who have rights granted on this object
3259 my $group_members = $Users->WhoHaveGroupRight(
3262 IncludeSystemRights => 0,
3263 IncludeSubgroupMembers => 0,
3266 # Limit to UserEquiv groups
3267 my $groups = $Users->NewAlias('Groups');
3271 ALIAS2 => $group_members,
3274 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3275 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3279 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3282 'Users' => $Users, # loc_left_pair
3290 =head2 _load_container_object ( $type, $id );
3292 Instantiate container object for saving searches.
3296 sub _load_container_object {
3297 my ( $obj_type, $obj_id ) = @_;
3298 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3301 =head2 _parse_saved_search ( $arg );
3303 Given a serialization string for saved search, and returns the
3304 container object and the search id.
3308 sub _parse_saved_search {
3310 return unless $spec;
3311 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3318 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3321 =head2 ScrubHTML content
3323 Removes unsafe and undesired HTML from the passed content
3329 my $Content = shift;
3330 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3332 $Content = '' if !defined($Content);
3333 return $SCRUBBER->scrub($Content);
3338 Returns a new L<HTML::Scrubber> object.
3340 If you need to be more lax about what HTML tags and attributes are allowed,
3341 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3344 package HTML::Mason::Commands;
3345 # Let tables through
3346 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3351 our @SCRUBBER_ALLOWED_TAGS = qw(
3352 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3353 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3356 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3357 # Match http, https, ftp, mailto and relative urls
3358 # XXX: we also scrub format strings with this module then allow simple config options
3359 href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|BaseURL|URL)__)}i,
3365 (?:(?:background-)?color: \s*
3366 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3367 \#[a-f0-9]{3,6} | # #fff or #ffffff
3368 [\w\-]+ # green, light-blue, etc.
3370 text-align: \s* \w+ |
3371 font-size: \s* [\w.\-]+ |
3372 font-family: \s* [\w\s"',.\-]+ |
3373 font-weight: \s* [\w\-]+ |
3375 # MS Office styles, which are probably fine. If we don't, then any
3376 # associated styles in the same attribute get stripped.
3377 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3379 +$ # one or more of these allowed properties from here 'till sunset
3381 dir => qr/^(rtl|ltr)$/i,
3382 lang => qr/^\w+(-\w+)?$/,
3385 our %SCRUBBER_RULES = ();
3388 require HTML::Scrubber;
3389 my $scrubber = HTML::Scrubber->new();
3393 %SCRUBBER_ALLOWED_ATTRIBUTES,
3394 '*' => 0, # require attributes be explicitly allowed
3397 $scrubber->deny(qw[*]);
3398 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3399 $scrubber->rules(%SCRUBBER_RULES);
3401 # Scrubbing comments is vital since IE conditional comments can contain
3402 # arbitrary HTML and we'd pass it right on through.
3403 $scrubber->comment(0);
3410 Redispatches to L<RT::Interface::Web/EncodeJSON>
3415 RT::Interface::Web::EncodeJSON(@_);
3418 package RT::Interface::Web;
3419 RT::Base->_ImportOverlays();