1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2014 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 chart) or bookmark a result page.
1287 '/Search/Results.html' => 1,
1288 '/Search/Simple.html' => 1,
1289 '/m/tickets/search' => 1,
1290 '/Search/Chart.html' => 1,
1292 # This page takes Attachment and Transaction argument to figure
1293 # out what to show, but it's read only and will deny information if you
1294 # don't have ShowOutgoingEmail.
1295 '/Ticket/ShowEmailRecord.html' => 1,
1298 # Components which are blacklisted from automatic, argument-based whitelisting.
1299 # These pages are not idempotent when called with just an id.
1300 our %is_blacklisted_component = (
1301 # Takes only id and toggles bookmark state
1302 '/Helpers/Toggle/TicketBookmark' => 1,
1305 sub IsCompCSRFWhitelisted {
1309 return 1 if $is_whitelisted_component{$comp};
1311 my %args = %{ $ARGS };
1313 # If the user specifies a *correct* user and pass then they are
1314 # golden. This acts on the presumption that external forms may
1315 # hardcode a username and password -- if a malicious attacker knew
1316 # both already, CSRF is the least of your problems.
1317 my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin');
1318 if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) {
1319 my $user_obj = RT::CurrentUser->new();
1320 $user_obj->Load($args{user});
1321 return 1 if $user_obj->id && $user_obj->IsPassword($args{pass});
1327 # Some pages aren't idempotent even with safe args like id; blacklist
1328 # them from the automatic whitelisting below.
1329 return 0 if $is_blacklisted_component{$comp};
1331 # Eliminate arguments that do not indicate an effectful request.
1332 # For example, "id" is acceptable because that is how RT retrieves a
1336 # If they have a results= from MaybeRedirectForResults, that's also fine.
1337 delete $args{results};
1339 # The homepage refresh, which uses the Refresh header, doesn't send
1340 # a referer in most browsers; whitelist the one parameter it reloads
1341 # with, HomeRefreshInterval, which is safe
1342 delete $args{HomeRefreshInterval};
1344 # The NotMobile flag is fine for any page; it's only used to toggle a flag
1345 # in the session related to which interface you get.
1346 delete $args{NotMobile};
1348 # If there are no arguments, then it's likely to be an idempotent
1349 # request, which are not susceptible to CSRF
1355 sub IsRefererCSRFWhitelisted {
1356 my $referer = _NormalizeHost(shift);
1357 my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL'));
1358 $base_url = $base_url->host_port;
1361 for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) {
1362 push @$configs,$config;
1364 my $host_port = $referer->host_port;
1365 if ($config =~ /\*/) {
1366 # Turn a literal * into a domain component or partial component match.
1367 # Refer to http://tools.ietf.org/html/rfc2818#page-5
1368 my $regex = join "[a-zA-Z0-9\-]*",
1369 map { quotemeta($_) }
1370 split /\*/, $config;
1372 return 1 if $host_port =~ /^$regex$/i;
1374 return 1 if $host_port eq $config;
1378 return (0,$referer,$configs);
1381 =head3 _NormalizeHost
1383 Takes a URI and creates a URI object that's been normalized
1384 to handle common problems such as localhost vs 127.0.0.1
1388 sub _NormalizeHost {
1390 $s = "http://$s" unless $s =~ /^http/i;
1391 my $uri= URI->new($s);
1392 $uri->host('127.0.0.1') if $uri->host eq 'localhost';
1398 sub IsPossibleCSRF {
1401 # If first request on this session is to a REST endpoint, then
1402 # whitelist the REST endpoints -- and explicitly deny non-REST
1403 # endpoints. We do this because using a REST cookie in a browser
1404 # would open the user to CSRF attacks to the REST endpoints.
1405 my $path = $HTML::Mason::Commands::r->path_info;
1406 $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)}
1407 unless defined $HTML::Mason::Commands::session{'REST'};
1409 if ($HTML::Mason::Commands::session{'REST'}) {
1410 return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)};
1412 This login session belongs to a REST client, and cannot be used to
1413 access non-REST interfaces of RT for security reasons.
1415 my $details = <<EOT;
1416 Please log out and back in to obtain a session for normal browsing. If
1417 you understand the security implications, disabling RT's CSRF protection
1418 will remove this restriction.
1421 HTML::Mason::Commands::Abort( $why, Details => $details );
1424 return 0 if IsCompCSRFWhitelisted(
1425 $HTML::Mason::Commands::m->request_comp->path,
1429 # if there is no Referer header then assume the worst
1431 "your browser did not supply a Referrer header", # loc
1432 ) if !$ENV{HTTP_REFERER};
1434 my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER});
1435 return 0 if $whitelisted;
1437 if ( @$configs > 1 ) {
1439 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc
1440 $browser->host_port,
1442 join(', ', @$configs) );
1446 "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc
1447 $browser->host_port,
1451 sub ExpandCSRFToken {
1454 my $token = delete $ARGS->{CSRF_Token};
1455 return unless $token;
1457 my $data = $HTML::Mason::Commands::session{'CSRF'}{$token};
1458 return unless $data;
1459 return unless $data->{path} eq $HTML::Mason::Commands::r->path_info;
1461 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1462 return unless $user->ValidateAuthString( $data->{auth}, $token );
1464 %{$ARGS} = %{$data->{args}};
1465 $HTML::Mason::Commands::DECODED_ARGS = $ARGS;
1467 # We explicitly stored file attachments with the request, but not in
1468 # the session yet, as that would itself be an attack. Put them into
1469 # the session now, so they'll be visible.
1470 if ($data->{attach}) {
1471 my $filename = $data->{attach}{filename};
1472 my $mime = $data->{attach}{mime};
1473 $HTML::Mason::Commands::session{'Attachments'}{$filename}
1480 sub StoreRequestToken {
1483 my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024));
1484 my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj;
1486 auth => $user->GenerateAuthString( $token ),
1487 path => $HTML::Mason::Commands::r->path_info,
1490 if ($ARGS->{Attach}) {
1491 my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' );
1492 my $file_path = delete $ARGS->{'Attach'};
1494 filename => Encode::decode_utf8("$file_path"),
1495 mime => $attachment,
1499 $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data;
1500 $HTML::Mason::Commands::session{'i'}++;
1504 sub MaybeShowInterstitialCSRFPage {
1507 return unless RT->Config->Get('RestrictReferrer');
1509 # Deal with the form token provided by the interstitial, which lets
1510 # browsers which never set referer headers still use RT, if
1511 # painfully. This blows values into ARGS
1512 return if ExpandCSRFToken($ARGS);
1514 my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS);
1515 return if !$is_csrf;
1517 $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc));
1519 my $token = StoreRequestToken($ARGS);
1520 $HTML::Mason::Commands::m->comp(
1522 OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info,
1523 Reason => HTML::Mason::Commands::loc( $msg, @loc ),
1526 # Calls abort, never gets here
1529 our @POTENTIAL_PAGE_ACTIONS = (
1530 qr'/Ticket/Create.html' => "create a ticket", # loc
1531 qr'/Ticket/' => "update a ticket", # loc
1532 qr'/Admin/' => "modify RT's configuration", # loc
1533 qr'/Approval/' => "update an approval", # loc
1534 qr'/Articles/' => "update an article", # loc
1535 qr'/Dashboards/' => "modify a dashboard", # loc
1536 qr'/m/ticket/' => "update a ticket", # loc
1537 qr'Prefs' => "modify your preferences", # loc
1538 qr'/Search/' => "modify or access a search", # loc
1539 qr'/SelfService/Create' => "create a ticket", # loc
1540 qr'/SelfService/' => "update a ticket", # loc
1543 sub PotentialPageAction {
1545 my @potentials = @POTENTIAL_PAGE_ACTIONS;
1546 while (my ($pattern, $result) = splice @potentials, 0, 2) {
1547 return HTML::Mason::Commands::loc($result)
1548 if $page =~ $pattern;
1553 package HTML::Mason::Commands;
1555 use vars qw/$r $m %session/;
1558 return $HTML::Mason::Commands::m->notes('menu');
1562 return $HTML::Mason::Commands::m->notes('page-menu');
1566 return $HTML::Mason::Commands::m->notes('page-widgets');
1573 loc is a nice clean global routine which calls $session{'CurrentUser'}->loc()
1574 with whatever it's called with. If there is no $session{'CurrentUser'},
1575 it creates a temporary user, so we have something to get a localisation handle
1582 if ( $session{'CurrentUser'}
1583 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1585 return ( $session{'CurrentUser'}->loc(@_) );
1588 RT::CurrentUser->new();
1592 return ( $u->loc(@_) );
1595 # pathetic case -- SystemUser is gone.
1602 =head2 loc_fuzzy STRING
1604 loc_fuzzy is for handling localizations of messages that may already
1605 contain interpolated variables, typically returned from libraries
1606 outside RT's control. It takes the message string and extracts the
1607 variable array automatically by matching against the candidate entries
1608 inside the lexicon file.
1615 if ( $session{'CurrentUser'}
1616 && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) )
1618 return ( $session{'CurrentUser'}->loc_fuzzy($msg) );
1620 my $u = RT::CurrentUser->new( RT->SystemUser->Id );
1621 return ( $u->loc_fuzzy($msg) );
1626 # Error - calls Error and aborts
1631 if ( $session{'ErrorDocument'}
1632 && $session{'ErrorDocumentType'} )
1634 $r->content_type( $session{'ErrorDocumentType'} );
1635 $m->comp( $session{'ErrorDocument'}, Why => $why, %args );
1638 $m->comp( "/Elements/Error", Why => $why, %args );
1643 sub MaybeRedirectForResults {
1645 Path => $HTML::Mason::Commands::m->request_comp->path,
1652 my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } );
1653 return unless $has_actions || $args{'Force'};
1655 my %arguments = %{ $args{'Arguments'} };
1657 if ( $has_actions ) {
1658 my $key = Digest::MD5::md5_hex( rand(1024) );
1659 push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} };
1661 $arguments{'results'} = $key;
1664 $args{'Path'} =~ s!^/+!!;
1665 my $url = RT->Config->Get('WebURL') . $args{Path};
1667 if ( keys %arguments ) {
1668 $url .= '?'. $m->comp( '/Elements/QueryString', %arguments );
1670 if ( $args{'Anchor'} ) {
1671 $url .= "#". $args{'Anchor'};
1673 return RT::Interface::Web::Redirect($url);
1676 =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF
1678 If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket,
1679 redirect to the approvals display page, preserving any arguments.
1681 C<Path>s matching C<Whitelist> are let through.
1683 This is a no-op if the C<ForceApprovalsView> option isn't enabled.
1687 sub MaybeRedirectToApproval {
1689 Path => $HTML::Mason::Commands::m->request_comp->path,
1695 return unless $ENV{REQUEST_METHOD} eq 'GET';
1697 my $id = $args{ARGSRef}->{id};
1700 and RT->Config->Get('ForceApprovalsView')
1701 and not $args{Path} =~ /$args{Whitelist}/)
1703 my $ticket = RT::Ticket->new( $session{'CurrentUser'} );
1706 if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') {
1707 MaybeRedirectForResults(
1708 Path => "/Approvals/Display.html",
1710 Anchor => $args{ARGSRef}->{Anchor},
1711 Arguments => $args{ARGSRef},
1717 =head2 CreateTicket ARGS
1719 Create a new ticket, using Mason's %ARGS. returns @results.
1728 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1730 my $Queue = RT::Queue->new( $session{'CurrentUser'} );
1731 unless ( $Queue->Load( $ARGS{'Queue'} ) ) {
1732 Abort('Queue not found');
1735 unless ( $Queue->CurrentUserHasRight('CreateTicket') ) {
1736 Abort('You have no permission to create tickets in that queue.');
1740 if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) {
1741 $due = RT::Date->new( $session{'CurrentUser'} );
1742 $due->Set( Format => 'unknown', Value => $ARGS{'Due'} );
1745 if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) {
1746 $starts = RT::Date->new( $session{'CurrentUser'} );
1747 $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} );
1750 my $sigless = RT::Interface::Web::StripContent(
1751 Content => $ARGS{Content},
1752 ContentType => $ARGS{ContentType},
1753 StripSignature => 1,
1754 CurrentUser => $session{'CurrentUser'},
1757 my $MIMEObj = MakeMIMEEntity(
1758 Subject => $ARGS{'Subject'},
1759 From => $ARGS{'From'},
1762 Type => $ARGS{'ContentType'},
1763 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
1766 if ( $ARGS{'Attachments'} ) {
1767 my $rv = $MIMEObj->make_multipart;
1768 $RT::Logger->error("Couldn't make multipart message")
1769 if !$rv || $rv !~ /^(?:DONE|ALREADY)$/;
1771 foreach ( map $ARGS{Attachments}->{$_}, sort keys %{ $ARGS{'Attachments'} } ) {
1773 $RT::Logger->error("Couldn't add empty attachemnt");
1776 $MIMEObj->add_part($_);
1780 for my $argument (qw(Encrypt Sign)) {
1781 $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 );
1785 Type => $ARGS{'Type'} || 'ticket',
1786 Queue => $ARGS{'Queue'},
1787 Owner => $ARGS{'Owner'},
1790 Requestor => $ARGS{'Requestors'},
1792 AdminCc => $ARGS{'AdminCc'},
1793 InitialPriority => $ARGS{'InitialPriority'},
1794 FinalPriority => $ARGS{'FinalPriority'},
1795 TimeLeft => $ARGS{'TimeLeft'},
1796 TimeEstimated => $ARGS{'TimeEstimated'},
1797 TimeWorked => $ARGS{'TimeWorked'},
1798 Subject => $ARGS{'Subject'},
1799 Status => $ARGS{'Status'},
1800 Due => $due ? $due->ISO : undef,
1801 Starts => $starts ? $starts->ISO : undef,
1806 foreach my $type (qw(Requestor Cc AdminCc)) {
1807 push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} )
1808 if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] };
1810 $create_args{TransSquelchMailTo} = \@txn_squelch
1813 if ( $ARGS{'AttachTickets'} ) {
1814 require RT::Action::SendEmail;
1815 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
1816 ref $ARGS{'AttachTickets'}
1817 ? @{ $ARGS{'AttachTickets'} }
1818 : ( $ARGS{'AttachTickets'} ) );
1821 foreach my $arg ( keys %ARGS ) {
1822 next if $arg =~ /-(?:Magic|Category)$/;
1824 if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) {
1825 $create_args{$arg} = $ARGS{$arg};
1828 # Object-RT::Ticket--CustomField-3-Values
1829 elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) {
1832 my $cf = RT::CustomField->new( $session{'CurrentUser'} );
1833 $cf->SetContextObject( $Queue );
1835 unless ( $cf->id ) {
1836 $RT::Logger->error( "Couldn't load custom field #" . $cfid );
1840 if ( $arg =~ /-Upload$/ ) {
1841 $create_args{"CustomField-$cfid"} = _UploadedFile($arg);
1845 my $type = $cf->Type;
1848 if ( ref $ARGS{$arg} eq 'ARRAY' ) {
1849 @values = @{ $ARGS{$arg} };
1850 } elsif ( $type =~ /text/i ) {
1851 @values = ( $ARGS{$arg} );
1853 no warnings 'uninitialized';
1854 @values = split /\r*\n/, $ARGS{$arg};
1856 @values = grep length, map {
1862 grep defined, @values;
1864 $create_args{"CustomField-$cfid"} = \@values;
1868 # turn new link lists into arrays, and pass in the proper arguments
1870 'new-DependsOn' => 'DependsOn',
1871 'DependsOn-new' => 'DependedOnBy',
1872 'new-MemberOf' => 'Parents',
1873 'MemberOf-new' => 'Children',
1874 'new-RefersTo' => 'RefersTo',
1875 'RefersTo-new' => 'ReferredToBy',
1877 foreach my $key ( keys %map ) {
1878 next unless $ARGS{$key};
1879 $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ];
1883 my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args);
1888 push( @Actions, split( "\n", $ErrMsg ) );
1889 unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) {
1890 Abort( "No permission to view newly created ticket #" . $Ticket->id . "." );
1892 return ( $Ticket, @Actions );
1898 =head2 LoadTicket id
1900 Takes a ticket id as its only variable. if it's handed an array, it takes
1903 Returns an RT::Ticket object as the current user.
1910 if ( ref($id) eq "ARRAY" ) {
1915 Abort("No ticket specified");
1918 my $Ticket = RT::Ticket->new( $session{'CurrentUser'} );
1920 unless ( $Ticket->id ) {
1921 Abort("Could not load ticket $id");
1928 =head2 ProcessUpdateMessage
1930 Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly.
1932 Don't write message if it only contains current user's signature and
1933 SkipSignatureOnly argument is true. Function anyway adds attachments
1934 and updates time worked field even if skips message. The default value
1939 # change from stock: if txn custom fields are set but there's no content
1940 # or attachment, create a Touch txn instead of doing nothing
1942 sub ProcessUpdateMessage {
1947 SkipSignatureOnly => 1,
1951 if ( $args{ARGSRef}->{'UpdateAttachments'}
1952 && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } )
1954 delete $args{ARGSRef}->{'UpdateAttachments'};
1957 # Strip the signature
1958 $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent(
1959 Content => $args{ARGSRef}->{UpdateContent},
1960 ContentType => $args{ARGSRef}->{UpdateContentType},
1961 StripSignature => $args{SkipSignatureOnly},
1962 CurrentUser => $args{'TicketObj'}->CurrentUser,
1965 my %txn_customfields;
1967 foreach my $key ( keys %{ $args{ARGSRef} } ) {
1968 if ( $key =~ /^(?:Object-RT::Transaction--)?CustomField-(\d+)/ ) {
1969 next if $key =~ /(TimeUnits|Magic)$/;
1970 $txn_customfields{$key} = $args{ARGSRef}->{$key};
1974 # If, after stripping the signature, we have no message, create a
1975 # Touch transaction if necessary
1976 if ( not $args{ARGSRef}->{'UpdateAttachments'}
1977 and not length $args{ARGSRef}->{'UpdateContent'} )
1979 #if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) {
1980 # $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked +
1981 # delete $args{ARGSRef}->{'UpdateTimeWorked'};
1984 my $timetaken = $args{ARGSRef}->{'UpdateTimeWorked'};
1985 if ( $timetaken or grep {length $_} values %txn_customfields ) {
1986 my ( $Transaction, $Description, $Object ) =
1987 $args{TicketObj}->Touch(
1988 CustomFields => \%txn_customfields,
1989 TimeTaken => $timetaken
1991 return $Description;
1996 if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) {
1997 $args{ARGSRef}->{'UpdateSubject'} = undef;
2000 my $Message = MakeMIMEEntity(
2001 Subject => $args{ARGSRef}->{'UpdateSubject'},
2002 Body => $args{ARGSRef}->{'UpdateContent'},
2003 Type => $args{ARGSRef}->{'UpdateContentType'},
2004 Interface => RT::Interface::Web::MobileClient() ? 'Mobile' : 'Web',
2007 $Message->head->replace( 'Message-ID' => Encode::encode_utf8(
2008 RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} )
2010 my $old_txn = RT::Transaction->new( $session{'CurrentUser'} );
2011 if ( $args{ARGSRef}->{'QuoteTransaction'} ) {
2012 $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} );
2014 $old_txn = $args{TicketObj}->Transactions->First();
2017 if ( my $msg = $old_txn->Message->First ) {
2018 RT::Interface::Email::SetInReplyTo(
2019 Message => $Message,
2024 if ( $args{ARGSRef}->{'UpdateAttachments'} ) {
2025 $Message->make_multipart;
2026 $Message->add_part($_) foreach map $args{ARGSRef}->{UpdateAttachments}{$_},
2027 sort keys %{ $args{ARGSRef}->{'UpdateAttachments'} };
2030 if ( $args{ARGSRef}->{'AttachTickets'} ) {
2031 require RT::Action::SendEmail;
2032 RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets,
2033 ref $args{ARGSRef}->{'AttachTickets'}
2034 ? @{ $args{ARGSRef}->{'AttachTickets'} }
2035 : ( $args{ARGSRef}->{'AttachTickets'} ) );
2038 my %message_args = (
2039 Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ),
2040 Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ),
2041 MIMEObj => $Message,
2042 TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'},
2043 CustomFields => \%txn_customfields,
2046 _ProcessUpdateMessageRecipients(
2047 MessageArgs => \%message_args,
2052 if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) {
2053 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args);
2054 push( @results, $Description );
2055 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2056 } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) {
2057 my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args);
2058 push( @results, $Description );
2059 $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object;
2062 loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") );
2067 sub _ProcessUpdateMessageRecipients {
2071 MessageArgs => undef,
2075 my $bcc = $args{ARGSRef}->{'UpdateBcc'};
2076 my $cc = $args{ARGSRef}->{'UpdateCc'};
2078 my $message_args = $args{MessageArgs};
2080 $message_args->{CcMessageTo} = $cc;
2081 $message_args->{BccMessageTo} = $bcc;
2084 foreach my $type (qw(Cc AdminCc)) {
2085 if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2086 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} );
2087 push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses;
2088 push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses;
2091 if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) {
2092 push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} );
2093 push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses;
2096 push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo};
2097 $message_args->{SquelchMailTo} = \@txn_squelch
2100 unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) {
2101 foreach my $key ( keys %{ $args{ARGSRef} } ) {
2102 next unless $key =~ /^Update(Cc|Bcc)-(.*)$/;
2104 my $var = ucfirst($1) . 'MessageTo';
2106 if ( $message_args->{$var} ) {
2107 $message_args->{$var} .= ", $value";
2109 $message_args->{$var} = $value;
2115 sub ProcessAttachments {
2121 my $ARGSRef = $args{ARGSRef} || {};
2122 # deal with deleting uploaded attachments
2123 foreach my $key ( keys %$ARGSRef ) {
2124 if ( $key =~ m/^DeleteAttach-(.+)$/ ) {
2125 delete $session{'Attachments'}{$1};
2127 $session{'Attachments'} = { %{ $session{'Attachments'} || {} } };
2130 # store the uploaded attachment in session
2131 if ( defined $ARGSRef->{'Attach'} && length $ARGSRef->{'Attach'} )
2133 my $attachment = MakeMIMEEntity( AttachmentFieldName => 'Attach' );
2135 my $file_path = Encode::decode_utf8("$ARGSRef->{'Attach'}");
2136 $session{'Attachments'} =
2137 { %{ $session{'Attachments'} || {} }, $file_path => $attachment, };
2140 # delete temporary storage entry to make WebUI clean
2141 unless ( keys %{ $session{'Attachments'} } and $ARGSRef->{'UpdateAttach'} )
2143 delete $session{'Attachments'};
2148 =head2 MakeMIMEEntity PARAMHASH
2150 Takes a paramhash Subject, Body and AttachmentFieldName.
2152 Also takes Form, Cc and Type as optional paramhash keys.
2154 Returns a MIME::Entity.
2158 sub MakeMIMEEntity {
2160 #TODO document what else this takes.
2166 AttachmentFieldName => undef,
2171 my $Message = MIME::Entity->build(
2172 Type => 'multipart/mixed',
2173 "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ),
2174 "X-RT-Interface" => $args{Interface},
2175 map { $_ => Encode::encode_utf8( $args{ $_} ) }
2176 grep defined $args{$_}, qw(Subject From Cc)
2179 if ( defined $args{'Body'} && length $args{'Body'} ) {
2181 # Make the update content have no 'weird' newlines in it
2182 $args{'Body'} =~ s/\r\n/\n/gs;
2185 Type => $args{'Type'} || 'text/plain',
2187 Data => $args{'Body'},
2191 if ( $args{'AttachmentFieldName'} ) {
2193 my $cgi_object = $m->cgi_object;
2194 my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} );
2195 if ( defined $filehandle && length $filehandle ) {
2197 my ( @content, $buffer );
2198 while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) {
2199 push @content, $buffer;
2202 my $uploadinfo = $cgi_object->uploadInfo($filehandle);
2204 my $filename = "$filehandle";
2205 $filename =~ s{^.*[\\/]}{};
2208 Type => $uploadinfo->{'Content-Type'},
2209 Filename => $filename,
2212 if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) {
2213 $Message->head->set( 'Subject' => $filename );
2216 # Attachment parts really shouldn't get a Message-ID or "interface"
2217 $Message->head->delete('Message-ID');
2218 $Message->head->delete('X-RT-Interface');
2222 $Message->make_singlepart;
2224 RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8
2232 =head2 ParseDateToISO
2234 Takes a date in an arbitrary format.
2235 Returns an ISO date and time in GMT
2239 sub ParseDateToISO {
2242 my $date_obj = RT::Date->new( $session{'CurrentUser'} );
2244 Format => 'unknown',
2247 return ( $date_obj->ISO );
2252 sub ProcessACLChanges {
2253 my $ARGSref = shift;
2257 foreach my $arg ( keys %$ARGSref ) {
2258 next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ );
2260 my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 );
2263 if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) {
2264 @rights = @{ $ARGSref->{$arg} };
2266 @rights = $ARGSref->{$arg};
2268 @rights = grep $_, @rights;
2269 next unless @rights;
2271 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2272 $principal->Load($principal_id);
2275 if ( $object_type eq 'RT::System' ) {
2277 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2278 $obj = $object_type->new( $session{'CurrentUser'} );
2279 $obj->Load($object_id);
2280 unless ( $obj->id ) {
2281 $RT::Logger->error("couldn't load $object_type #$object_id");
2285 $RT::Logger->error("object type '$object_type' is incorrect");
2286 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2290 foreach my $right (@rights) {
2291 my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right );
2292 push( @results, $msg );
2302 ProcessACLs expects values from a series of checkboxes that describe the full
2303 set of rights a principal should have on an object.
2305 It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId
2306 instead of with the prefixes Grant/RevokeRight. Each input should be an array
2307 listing the rights the principal should have, and ProcessACLs will modify the
2308 current rights to match. Additionally, the previously unused CheckACL input
2309 listing PrincipalId-ObjType-ObjId is now used to catch cases when all the
2310 rights are removed from a principal and as such no SetRights input is
2316 my $ARGSref = shift;
2317 my (%state, @results);
2319 my $CheckACL = $ARGSref->{'CheckACL'};
2320 my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL);
2322 # Check if we want to grant rights to a previously rights-less user
2323 for my $type (qw(user group)) {
2324 my $principal = _ParseACLNewPrincipal($ARGSref, $type)
2327 unless ($principal->PrincipalId) {
2328 push @results, loc("Couldn't load the specified principal");
2332 my $principal_id = $principal->PrincipalId;
2334 # Turn our addprincipal rights spec into a real one
2335 for my $arg (keys %$ARGSref) {
2336 next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/;
2338 my $tuple = "$principal_id-$1";
2339 my $key = "SetRights-$tuple";
2341 # If we have it already, that's odd, but merge them
2342 if (grep { $_ eq $tuple } @check) {
2343 $ARGSref->{$key} = [
2344 (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}),
2345 (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}),
2348 $ARGSref->{$key} = $ARGSref->{$arg};
2349 push @check, $tuple;
2354 # Build our rights state for each Principal-Object tuple
2355 foreach my $arg ( keys %$ARGSref ) {
2356 next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/;
2359 my $value = $ARGSref->{$arg};
2360 my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value);
2361 next unless @rights;
2363 $state{$tuple} = { map { $_ => 1 } @rights };
2366 foreach my $tuple (List::MoreUtils::uniq @check) {
2367 next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/;
2369 my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 );
2371 my $principal = RT::Principal->new( $session{'CurrentUser'} );
2372 $principal->Load($principal_id);
2375 if ( $object_type eq 'RT::System' ) {
2377 } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) {
2378 $obj = $object_type->new( $session{'CurrentUser'} );
2379 $obj->Load($object_id);
2380 unless ( $obj->id ) {
2381 $RT::Logger->error("couldn't load $object_type #$object_id");
2385 $RT::Logger->error("object type '$object_type' is incorrect");
2386 push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) );
2390 my $acls = RT::ACL->new($session{'CurrentUser'});
2391 $acls->LimitToObject( $obj );
2392 $acls->LimitToPrincipal( Id => $principal_id );
2394 while ( my $ace = $acls->Next ) {
2395 my $right = $ace->RightName;
2397 # Has right and should have right
2398 next if delete $state{$tuple}->{$right};
2400 # Has right and shouldn't have right
2401 my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right );
2402 push @results, $msg;
2405 # For everything left, they don't have the right but they should
2406 for my $right (keys %{ $state{$tuple} || {} }) {
2407 delete $state{$tuple}->{$right};
2408 my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right );
2409 push @results, $msg;
2412 # Check our state for leftovers
2413 if ( keys %{ $state{$tuple} || {} } ) {
2414 my $missed = join '|', %{$state{$tuple} || {}};
2416 "Uh-oh, it looks like we somehow missed a right in "
2417 ."ProcessACLs. Here's what was leftover: $missed"
2425 =head2 _ParseACLNewPrincipal
2427 Takes a hashref of C<%ARGS> and a principal type (C<user> or C<group>). Looks
2428 for the presence of rights being added on a principal of the specified type,
2429 and returns undef if no new principal is being granted rights. Otherwise loads
2430 up an L<RT::User> or L<RT::Group> object and returns it. Note that the object
2431 may not be successfully loaded, and you should check C<->id> yourself.
2435 sub _ParseACLNewPrincipal {
2436 my $ARGSref = shift;
2437 my $type = lc shift;
2438 my $key = "AddPrincipalForRights-$type";
2440 return unless $ARGSref->{$key};
2443 if ( $type eq 'user' ) {
2444 $principal = RT::User->new( $session{'CurrentUser'} );
2445 $principal->LoadByCol( Name => $ARGSref->{$key} );
2447 elsif ( $type eq 'group' ) {
2448 $principal = RT::Group->new( $session{'CurrentUser'} );
2449 $principal->LoadUserDefinedGroup( $ARGSref->{$key} );
2455 =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs)
2457 @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.
2459 Returns an array of success/failure messages
2463 sub UpdateRecordObject {
2466 AttributesRef => undef,
2468 AttributePrefix => undef,
2472 my $Object = $args{'Object'};
2473 my @results = $Object->Update(
2474 AttributesRef => $args{'AttributesRef'},
2475 ARGSRef => $args{'ARGSRef'},
2476 AttributePrefix => $args{'AttributePrefix'},
2484 sub ProcessCustomFieldUpdates {
2486 CustomFieldObj => undef,
2491 my $Object = $args{'CustomFieldObj'};
2492 my $ARGSRef = $args{'ARGSRef'};
2494 my @attribs = qw(Name Type Description Queue SortOrder);
2495 my @results = UpdateRecordObject(
2496 AttributesRef => \@attribs,
2501 my $prefix = "CustomField-" . $Object->Id;
2502 if ( $ARGSRef->{"$prefix-AddValue-Name"} ) {
2503 my ( $addval, $addmsg ) = $Object->AddValue(
2504 Name => $ARGSRef->{"$prefix-AddValue-Name"},
2505 Description => $ARGSRef->{"$prefix-AddValue-Description"},
2506 SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"},
2508 push( @results, $addmsg );
2512 = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' )
2513 ? @{ $ARGSRef->{"$prefix-DeleteValue"} }
2514 : ( $ARGSRef->{"$prefix-DeleteValue"} );
2516 foreach my $id (@delete_values) {
2517 next unless defined $id;
2518 my ( $err, $msg ) = $Object->DeleteValue($id);
2519 push( @results, $msg );
2522 my $vals = $Object->Values();
2523 while ( my $cfv = $vals->Next() ) {
2524 if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) {
2525 if ( $cfv->SortOrder != $so ) {
2526 my ( $err, $msg ) = $cfv->SetSortOrder($so);
2527 push( @results, $msg );
2537 =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2539 Returns an array of results messages.
2543 sub ProcessTicketBasics {
2551 my $TicketObj = $args{'TicketObj'};
2552 my $ARGSRef = $args{'ARGSRef'};
2554 my $OrigOwner = $TicketObj->Owner;
2569 # Canonicalize Queue and Owner to their IDs if they aren't numeric
2570 for my $field (qw(Queue Owner)) {
2571 if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) {
2572 my $class = $field eq 'Owner' ? "RT::User" : "RT::$field";
2573 my $temp = $class->new(RT->SystemUser);
2574 $temp->Load( $ARGSRef->{$field} );
2576 $ARGSRef->{$field} = $temp->id;
2581 # Status isn't a field that can be set to a null value.
2582 # RT core complains if you try
2583 delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'};
2585 my @results = UpdateRecordObject(
2586 AttributesRef => \@attribs,
2587 Object => $TicketObj,
2588 ARGSRef => $ARGSRef,
2591 # We special case owner changing, so we can use ForceOwnerChange
2592 if ( $ARGSRef->{'Owner'}
2593 && $ARGSRef->{'Owner'} !~ /\D/
2594 && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) {
2596 if ( $ARGSRef->{'ForceOwnerChange'} ) {
2597 $ChownType = "Force";
2603 my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType );
2604 push( @results, $msg );
2612 sub ProcessTicketReminders {
2619 my $Ticket = $args{'TicketObj'};
2620 my $args = $args{'ARGSRef'};
2623 my $reminder_collection = $Ticket->Reminders->Collection;
2625 if ( $args->{'update-reminders'} ) {
2626 while ( my $reminder = $reminder_collection->Next ) {
2627 my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve;
2628 if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) {
2629 my ($status, $msg) = $Ticket->Reminders->Resolve($reminder);
2630 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2633 elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) {
2634 my ($status, $msg) = $Ticket->Reminders->Open($reminder);
2635 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2638 if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) {
2639 my ($status, $msg) = $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ;
2640 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2643 if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) {
2644 my ($status, $msg) = $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ;
2645 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2648 if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) {
2649 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
2651 Format => 'unknown',
2652 Value => $args->{ 'Reminder-Due-' . $reminder->id }
2654 if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) {
2655 my ($status, $msg) = $reminder->SetDue( $DateObj->ISO );
2656 push @results, loc("Reminder #[_1]: [_2]", $reminder->id, $msg);
2662 if ( $args->{'NewReminder-Subject'} ) {
2663 my $due_obj = RT::Date->new( $session{'CurrentUser'} );
2665 Format => 'unknown',
2666 Value => $args->{'NewReminder-Due'}
2668 my ( $add_id, $msg ) = $Ticket->Reminders->Add(
2669 Subject => $args->{'NewReminder-Subject'},
2670 Owner => $args->{'NewReminder-Owner'},
2671 Due => $due_obj->ISO
2674 push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'});
2677 push @results, $msg;
2683 sub ProcessTicketCustomFieldUpdates {
2685 $args{'Object'} = delete $args{'TicketObj'};
2686 my $ARGSRef = { %{ $args{'ARGSRef'} } };
2688 # Build up a list of objects that we want to work with
2689 my %custom_fields_to_mod;
2690 foreach my $arg ( keys %$ARGSRef ) {
2691 if ( $arg =~ /^Ticket-(\d+-.*)/ ) {
2692 $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg};
2693 } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) {
2694 $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg};
2695 } elsif ( $arg =~ /^Object-RT::Transaction-(\d*)-CustomField/ ) {
2696 delete $ARGSRef->{$arg}; # don't try to update transaction fields
2700 return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef );
2703 sub ProcessObjectCustomFieldUpdates {
2705 my $ARGSRef = $args{'ARGSRef'};
2708 # Build up a list of objects that we want to work with
2709 my %custom_fields_to_mod;
2710 foreach my $arg ( keys %$ARGSRef ) {
2712 # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands>
2713 next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/;
2715 # For each of those objects, find out what custom fields we want to work with.
2716 $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg};
2719 # For each of those objects
2720 foreach my $class ( keys %custom_fields_to_mod ) {
2721 foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) {
2722 my $Object = $args{'Object'};
2723 $Object = $class->new( $session{'CurrentUser'} )
2724 unless $Object && ref $Object eq $class;
2726 $Object->Load($id) unless ( $Object->id || 0 ) == $id;
2727 unless ( $Object->id ) {
2728 $RT::Logger->warning("Couldn't load object $class #$id");
2732 foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) {
2733 my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} );
2734 $CustomFieldObj->SetContextObject($Object);
2735 $CustomFieldObj->LoadById($cf);
2736 unless ( $CustomFieldObj->id ) {
2737 $RT::Logger->warning("Couldn't load custom field #$cf");
2741 _ProcessObjectCustomFieldUpdates(
2742 Prefix => "Object-$class-$id-CustomField-$cf-",
2744 CustomField => $CustomFieldObj,
2745 ARGS => $custom_fields_to_mod{$class}{$id}{$cf},
2753 sub _ProcessObjectCustomFieldUpdates {
2755 my $cf = $args{'CustomField'};
2756 my $cf_type = $cf->Type || '';
2758 # Remove blank Values since the magic field will take care of this. Sometimes
2759 # the browser gives you a blank value which causes CFs to be processed twice
2760 if ( defined $args{'ARGS'}->{'Values'}
2761 && !length $args{'ARGS'}->{'Values'}
2762 && $args{'ARGS'}->{'Values-Magic'} )
2764 delete $args{'ARGS'}->{'Values'};
2768 foreach my $arg ( keys %{ $args{'ARGS'} } ) {
2770 # skip category argument
2771 next if $arg eq 'Category';
2774 next if $arg eq 'Value-TimeUnits';
2776 # since http won't pass in a form element with a null value, we need
2778 if ( $arg eq 'Values-Magic' ) {
2780 # We don't care about the magic, if there's really a values element;
2781 next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'};
2782 next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'};
2784 # "Empty" values does not mean anything for Image and Binary fields
2785 next if $cf_type =~ /^(?:Image|Binary)$/;
2788 $args{'ARGS'}->{'Values'} = undef;
2792 if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) {
2793 @values = @{ $args{'ARGS'}->{$arg} };
2794 } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext
2795 @values = ( $args{'ARGS'}->{$arg} );
2797 @values = split /\r*\n/, $args{'ARGS'}->{$arg}
2798 if defined $args{'ARGS'}->{$arg};
2800 @values = grep length, map {
2806 grep defined, @values;
2808 if ( $arg eq 'AddValue' || $arg eq 'Value' ) {
2809 foreach my $value (@values) {
2810 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2814 push( @results, $msg );
2816 } elsif ( $arg eq 'Upload' ) {
2817 my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next;
2818 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, );
2819 push( @results, $msg );
2820 } elsif ( $arg eq 'DeleteValues' ) {
2821 foreach my $value (@values) {
2822 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2826 push( @results, $msg );
2828 } elsif ( $arg eq 'DeleteValueIds' ) {
2829 foreach my $value (@values) {
2830 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2834 push( @results, $msg );
2836 } elsif ( $arg eq 'Values' && !$cf->Repeated ) {
2837 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2840 foreach my $value (@values) {
2841 if ( my $entry = $cf_values->HasEntry($value) ) {
2842 $values_hash{ $entry->id } = 1;
2846 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2850 push( @results, $msg );
2851 $values_hash{$val} = 1 if $val;
2854 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2855 return @results if ( $cf->Type eq 'Date' && ! @values );
2857 # For Date Cfs, @values is empty when there is no changes (no datas in form input)
2858 return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values );
2860 $cf_values->RedoSearch;
2861 while ( my $cf_value = $cf_values->Next ) {
2862 next if $values_hash{ $cf_value->id };
2864 my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue(
2866 ValueId => $cf_value->id
2868 push( @results, $msg );
2870 } elsif ( $arg eq 'Values' ) {
2871 my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id );
2873 # keep everything up to the point of difference, delete the rest
2875 foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) {
2876 if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) {
2885 # now add/replace extra things, if any
2886 foreach my $value (@values) {
2887 my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue(
2891 push( @results, $msg );
2896 loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]",
2897 $cf->Name, ref $args{'Object'},
2907 =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2909 Returns an array of results messages.
2913 sub ProcessTicketWatchers {
2921 my $Ticket = $args{'TicketObj'};
2922 my $ARGSRef = $args{'ARGSRef'};
2926 foreach my $key ( keys %$ARGSRef ) {
2928 # Delete deletable watchers
2929 if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) {
2930 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2934 push @results, $msg;
2937 # Delete watchers in the simple style demanded by the bulk manipulator
2938 elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) {
2939 my ( $code, $msg ) = $Ticket->DeleteWatcher(
2940 Email => $ARGSRef->{$key},
2943 push @results, $msg;
2946 # Add new wathchers by email address
2947 elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/
2948 and $key =~ /^WatcherTypeEmail(\d*)$/ )
2951 #They're in this order because otherwise $1 gets clobbered :/
2952 my ( $code, $msg ) = $Ticket->AddWatcher(
2953 Type => $ARGSRef->{$key},
2954 Email => $ARGSRef->{ "WatcherAddressEmail" . $1 }
2956 push @results, $msg;
2959 #Add requestors in the simple style demanded by the bulk manipulator
2960 elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) {
2961 my ( $code, $msg ) = $Ticket->AddWatcher(
2963 Email => $ARGSRef->{$key}
2965 push @results, $msg;
2968 # Add new watchers by owner
2969 elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) {
2970 my $principal_id = $1;
2971 my $form = $ARGSRef->{$key};
2972 foreach my $value ( ref($form) ? @{$form} : ($form) ) {
2973 next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i;
2975 my ( $code, $msg ) = $Ticket->AddWatcher(
2977 PrincipalId => $principal_id
2979 push @results, $msg;
2989 =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS );
2991 Returns an array of results messages.
2995 sub ProcessTicketDates {
3002 my $Ticket = $args{'TicketObj'};
3003 my $ARGSRef = $args{'ARGSRef'};
3008 my @date_fields = qw(
3017 #Run through each field in this list. update the value if apropriate
3018 foreach my $field (@date_fields) {
3019 next unless exists $ARGSRef->{ $field . '_Date' };
3020 next if $ARGSRef->{ $field . '_Date' } eq '';
3024 my $DateObj = RT::Date->new( $session{'CurrentUser'} );
3026 Format => 'unknown',
3027 Value => $ARGSRef->{ $field . '_Date' }
3030 my $obj = $field . "Obj";
3031 if ( ( defined $DateObj->Unix )
3032 and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) )
3034 my $method = "Set$field";
3035 my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO );
3036 push @results, "$msg";
3046 =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS );
3048 Returns an array of results messages.
3052 sub ProcessTicketLinks {
3059 my $Ticket = $args{'TicketObj'};
3060 my $ARGSRef = $args{'ARGSRef'};
3062 my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef );
3064 #Merge if we need to
3065 if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) {
3066 $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g;
3067 my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } );
3068 push @results, $msg;
3075 sub ProcessRecordLinks {
3082 my $Record = $args{'RecordObj'};
3083 my $ARGSRef = $args{'ARGSRef'};
3087 # Delete links that are gone gone gone.
3088 foreach my $arg ( keys %$ARGSRef ) {
3089 if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) {
3094 my ( $val, $msg ) = $Record->DeleteLink(
3100 push @results, $msg;
3106 my @linktypes = qw( DependsOn MemberOf RefersTo );
3108 foreach my $linktype (@linktypes) {
3109 if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) {
3110 $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } )
3111 if ref( $ARGSRef->{ $Record->Id . "-$linktype" } );
3113 for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) {
3115 $luri =~ s/\s+$//; # Strip trailing whitespace
3116 my ( $val, $msg ) = $Record->AddLink(
3120 push @results, $msg;
3123 if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) {
3124 $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } )
3125 if ref( $ARGSRef->{ "$linktype-" . $Record->Id } );
3127 for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) {
3129 my ( $val, $msg ) = $Record->AddLink(
3134 push @results, $msg;
3142 =head2 ProcessTransactionSquelching
3144 Takes a hashref of the submitted form arguments, C<%ARGS>.
3146 Returns a hash of squelched addresses.
3150 sub ProcessTransactionSquelching {
3152 my %checked = map { $_ => 1 } grep { defined }
3153 ( ref $args->{'TxnSendMailTo'} eq "ARRAY" ? @{$args->{'TxnSendMailTo'}} :
3154 defined $args->{'TxnSendMailTo'} ? ($args->{'TxnSendMailTo'}) :
3156 my %squelched = map { $_ => 1 } grep { not $checked{$_} } split /,/, ($args->{'TxnRecipients'}||'');
3160 =head2 _UploadedFile ( $arg );
3162 Takes a CGI parameter name; if a file is uploaded under that name,
3163 return a hash reference suitable for AddCustomFieldValue's use:
3164 C<( Value => $filename, LargeContent => $content, ContentType => $type )>.
3166 Returns C<undef> if no files were uploaded in the C<$arg> field.
3172 my $cgi_object = $m->cgi_object;
3173 my $fh = $cgi_object->upload($arg) or return undef;
3174 my $upload_info = $cgi_object->uploadInfo($fh);
3176 my $filename = "$fh";
3177 $filename =~ s#^.*[\\/]##;
3182 LargeContent => do { local $/; scalar <$fh> },
3183 ContentType => $upload_info->{'Content-Type'},
3187 sub GetColumnMapEntry {
3188 my %args = ( Map => {}, Name => '', Attribute => undef, @_ );
3190 # deal with the simplest thing first
3191 if ( $args{'Map'}{ $args{'Name'} } ) {
3192 return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} };
3196 elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.(.+)$/ ) {
3197 $subkey =~ s/^\{(.*)\}$/$1/;
3198 return undef unless $args{'Map'}->{$mainkey};
3199 return $args{'Map'}{$mainkey}{ $args{'Attribute'} }
3200 unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE';
3202 return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) };
3207 sub ProcessColumnMapValue {
3209 my %args = ( Arguments => [], Escape => 1, @_ );
3212 if ( UNIVERSAL::isa( $value, 'CODE' ) ) {
3213 my @tmp = $value->( @{ $args{'Arguments'} } );
3214 return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args );
3215 } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) {
3216 return join '', map ProcessColumnMapValue( $_, %args ), @$value;
3217 } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) {
3222 return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'};
3226 =head2 GetPrincipalsMap OBJECT, CATEGORIES
3228 Returns an array suitable for passing to /Admin/Elements/EditRights with the
3229 principal collections mapped from the categories given.
3233 sub GetPrincipalsMap {
3238 my $system = RT::Groups->new($session{'CurrentUser'});
3239 $system->LimitToSystemInternalGroups();
3240 $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3242 'System' => $system, # loc_left_pair
3247 my $groups = RT::Groups->new($session{'CurrentUser'});
3248 $groups->LimitToUserDefinedGroups();
3249 $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3251 # Only show groups who have rights granted on this object
3252 $groups->WithGroupRight(
3255 IncludeSystemRights => 0,
3256 IncludeSubgroupMembers => 0,
3260 'User Groups' => $groups, # loc_left_pair
3265 my $roles = RT::Groups->new($session{'CurrentUser'});
3267 if ($object->isa('RT::System')) {
3268 $roles->LimitToRolesForSystem();
3270 elsif ($object->isa('RT::Queue')) {
3271 $roles->LimitToRolesForQueue($object->Id);
3274 $RT::Logger->warn("Skipping unknown object type ($object) for Role principals");
3277 $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' );
3279 'Roles' => $roles, # loc_left_pair
3284 my $Users = RT->PrivilegedUsers->UserMembersObj();
3285 $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' );
3287 # Only show users who have rights granted on this object
3288 my $group_members = $Users->WhoHaveGroupRight(
3291 IncludeSystemRights => 0,
3292 IncludeSubgroupMembers => 0,
3295 # Limit to UserEquiv groups
3296 my $groups = $Users->NewAlias('Groups');
3300 ALIAS2 => $group_members,
3303 $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' );
3304 $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' );
3308 $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1)
3311 'Users' => $Users, # loc_left_pair
3319 =head2 _load_container_object ( $type, $id );
3321 Instantiate container object for saving searches.
3325 sub _load_container_object {
3326 my ( $obj_type, $obj_id ) = @_;
3327 return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id );
3330 =head2 _parse_saved_search ( $arg );
3332 Given a serialization string for saved search, and returns the
3333 container object and the search id.
3337 sub _parse_saved_search {
3339 return unless $spec;
3340 if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) {
3347 return ( _load_container_object( $obj_type, $obj_id ), $search_id );
3350 =head2 ScrubHTML content
3352 Removes unsafe and undesired HTML from the passed content
3358 my $Content = shift;
3359 $SCRUBBER = _NewScrubber() unless $SCRUBBER;
3361 $Content = '' if !defined($Content);
3362 return $SCRUBBER->scrub($Content);
3367 Returns a new L<HTML::Scrubber> object.
3369 If you need to be more lax about what HTML tags and attributes are allowed,
3370 create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the
3373 package HTML::Mason::Commands;
3374 # Let tables through
3375 push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH);
3380 our @SCRUBBER_ALLOWED_TAGS = qw(
3381 A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5
3382 H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO
3385 our %SCRUBBER_ALLOWED_ATTRIBUTES = (
3386 # Match http, https, ftp, mailto and relative urls
3387 # XXX: we also scrub format strings with this module then allow simple config options
3388 href => qr{^(?:https?:|ftp:|mailto:|/|__Web(?:Path|BaseURL|URL)__)}i,
3394 (?:(?:background-)?color: \s*
3395 (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d)
3396 \#[a-f0-9]{3,6} | # #fff or #ffffff
3397 [\w\-]+ # green, light-blue, etc.
3399 text-align: \s* \w+ |
3400 font-size: \s* [\w.\-]+ |
3401 font-family: \s* [\w\s"',.\-]+ |
3402 font-weight: \s* [\w\-]+ |
3404 # MS Office styles, which are probably fine. If we don't, then any
3405 # associated styles in the same attribute get stripped.
3406 mso-[\w\-]+?: \s* [\w\s"',.\-]+
3408 +$ # one or more of these allowed properties from here 'till sunset
3410 dir => qr/^(rtl|ltr)$/i,
3411 lang => qr/^\w+(-\w+)?$/,
3414 our %SCRUBBER_RULES = ();
3417 require HTML::Scrubber;
3418 my $scrubber = HTML::Scrubber->new();
3422 %SCRUBBER_ALLOWED_ATTRIBUTES,
3423 '*' => 0, # require attributes be explicitly allowed
3426 $scrubber->deny(qw[*]);
3427 $scrubber->allow(@SCRUBBER_ALLOWED_TAGS);
3428 $scrubber->rules(%SCRUBBER_RULES);
3430 # Scrubbing comments is vital since IE conditional comments can contain
3431 # arbitrary HTML and we'd pass it right on through.
3432 $scrubber->comment(0);
3439 Redispatches to L<RT::Interface::Web/EncodeJSON>
3444 RT::Interface::Web::EncodeJSON(@_);
3447 package RT::Interface::Web;
3448 RT::Base->_ImportOverlays();